3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * "You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
13 * our Mr. Bilbo's first cousin on the mother's side (her mother being the
14 * youngest of the Old Took's daughters); and Mr. Drogo was his second
15 * cousin. So Mr. Frodo is his first *and* second cousin, once removed
16 * either way, as the saying is, if you follow me." --the Gaffer
19 /* This file contains the functions that create, manipulate and optimize
20 * the OP structures that hold a compiled perl program.
22 * A Perl program is compiled into a tree of OPs. Each op contains
23 * structural pointers (eg to its siblings and the next op in the
24 * execution sequence), a pointer to the function that would execute the
25 * op, plus any data specific to that op. For example, an OP_CONST op
26 * points to the pp_const() function and to an SV containing the constant
27 * value. When pp_const() is executed, its job is to push that SV onto the
30 * OPs are mainly created by the newFOO() functions, which are mainly
31 * called from the parser (in perly.y) as the code is parsed. For example
32 * the Perl code $a + $b * $c would cause the equivalent of the following
33 * to be called (oversimplifying a bit):
35 * newBINOP(OP_ADD, flags,
37 * newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
40 * Note that during the build of miniperl, a temporary copy of this file
41 * is made, called opmini.c.
45 Perl's compiler is essentially a 3-pass compiler with interleaved phases:
49 An execution-order pass
51 The bottom-up pass is represented by all the "newOP" routines and
52 the ck_ routines. The bottom-upness is actually driven by yacc.
53 So at the point that a ck_ routine fires, we have no idea what the
54 context is, either upward in the syntax tree, or either forward or
55 backward in the execution order. (The bottom-up parser builds that
56 part of the execution order it knows about, but if you follow the "next"
57 links around, you'll find it's actually a closed loop through the
60 Whenever the bottom-up parser gets to a node that supplies context to
61 its components, it invokes that portion of the top-down pass that applies
62 to that part of the subtree (and marks the top node as processed, so
63 if a node further up supplies context, it doesn't have to take the
64 plunge again). As a particular subcase of this, as the new node is
65 built, it takes all the closed execution loops of its subcomponents
66 and links them into a new closed loop for the higher level node. But
67 it's still not the real execution order.
69 The actual execution order is not known till we get a grammar reduction
70 to a top-level unit like a subroutine or file that will be called by
71 "name" rather than via a "next" pointer. At that point, we can call
72 into peep() to do that code's portion of the 3rd pass. It has to be
73 recursive, but it's recursive on basic blocks, not on tree nodes.
81 #define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
83 #if defined(PL_OP_SLAB_ALLOC)
85 #ifndef PERL_SLAB_SIZE
86 #define PERL_SLAB_SIZE 2048
90 Perl_Slab_Alloc(pTHX_ int m, size_t sz)
93 * To make incrementing use count easy PL_OpSlab is an I32 *
94 * To make inserting the link to slab PL_OpPtr is I32 **
95 * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
96 * Add an overhead for pointer to slab and round up as a number of pointers
98 sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
99 if ((PL_OpSpace -= sz) < 0) {
100 PL_OpPtr = (I32 **) PerlMemShared_malloc(PERL_SLAB_SIZE*sizeof(I32*));
104 Zero(PL_OpPtr,PERL_SLAB_SIZE,I32 **);
105 /* We reserve the 0'th I32 sized chunk as a use count */
106 PL_OpSlab = (I32 *) PL_OpPtr;
107 /* Reduce size by the use count word, and by the size we need.
108 * Latter is to mimic the '-=' in the if() above
110 PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
111 /* Allocation pointer starts at the top.
112 Theory: because we build leaves before trunk allocating at end
113 means that at run time access is cache friendly upward
115 PL_OpPtr += PERL_SLAB_SIZE;
117 assert( PL_OpSpace >= 0 );
118 /* Move the allocation pointer down */
120 assert( PL_OpPtr > (I32 **) PL_OpSlab );
121 *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */
122 (*PL_OpSlab)++; /* Increment use count of slab */
123 assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
124 assert( *PL_OpSlab > 0 );
125 return (void *)(PL_OpPtr + 1);
129 Perl_Slab_Free(pTHX_ void *op)
131 I32 * const * const ptr = (I32 **) op;
132 I32 * const slab = ptr[-1];
133 assert( ptr-1 > (I32 **) slab );
134 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
136 if (--(*slab) == 0) {
138 # define PerlMemShared PerlMem
141 PerlMemShared_free(slab);
142 if (slab == PL_OpSlab) {
149 * In the following definition, the ", (OP*)0" is just to make the compiler
150 * think the expression is of the right type: croak actually does a Siglongjmp.
152 #define CHECKOP(type,o) \
153 ((PL_op_mask && PL_op_mask[type]) \
154 ? ( op_free((OP*)o), \
155 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
157 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
159 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
162 S_gv_ename(pTHX_ GV *gv)
164 SV* const tmpsv = sv_newmortal();
165 gv_efullname3(tmpsv, gv, NULL);
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 const bool is_our = (PL_in_my == KEY_our);
215 /* complain about "my $<special_var>" etc etc */
219 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
220 (name[1] == '_' && (*name == '$' || name[2]))))
222 /* name[2] is true if strlen(name) > 2 */
223 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
224 /* 1999-02-27 mjd@plover.com */
226 p = strchr(name, '\0');
227 /* The next block assumes the buffer is at least 205 chars
228 long. At present, it's always at least 256 chars. */
230 strcpy(name+200, "...");
236 /* Move everything else down one character */
237 for (; p-name > 2; p--)
239 name[2] = toCTRL(name[1]);
242 yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
245 /* check for duplicate declaration */
246 pad_check_dup(name, is_our, (PL_curstash ? PL_curstash : PL_defstash));
248 if (PL_in_my_stash && *name != '$') {
249 yyerror(Perl_form(aTHX_
250 "Can't declare class for non-scalar %s in \"%s\"",
251 name, is_our ? "our" : "my"));
254 /* allocate a spare slot and store the name in that slot */
256 off = pad_add_name(name,
259 /* $_ is always in main::, even with our */
260 ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
271 Perl_op_free(pTHX_ OP *o)
277 if (!o || o->op_static)
280 if (o->op_private & OPpREFCOUNTED) {
281 switch (o->op_type) {
289 refcnt = OpREFCNT_dec(o);
299 if (o->op_flags & OPf_KIDS) {
300 register OP *kid, *nextkid;
301 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
302 nextkid = kid->op_sibling; /* Get before next freeing kid */
308 type = (OPCODE)o->op_targ;
310 /* COP* is not cleared by op_clear() so that we may track line
311 * numbers etc even after null() */
312 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
317 #ifdef DEBUG_LEAKING_SCALARS
324 Perl_op_clear(pTHX_ OP *o)
328 switch (o->op_type) {
329 case OP_NULL: /* Was holding old type, if any. */
330 case OP_ENTEREVAL: /* Was holding hints. */
334 if (!(o->op_flags & OPf_REF)
335 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
341 if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
342 /* not an OP_PADAV replacement */
344 if (cPADOPo->op_padix > 0) {
345 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
346 * may still exist on the pad */
347 pad_swipe(cPADOPo->op_padix, TRUE);
348 cPADOPo->op_padix = 0;
351 SvREFCNT_dec(cSVOPo->op_sv);
352 cSVOPo->op_sv = NULL;
356 case OP_METHOD_NAMED:
358 SvREFCNT_dec(cSVOPo->op_sv);
359 cSVOPo->op_sv = NULL;
362 Even if op_clear does a pad_free for the target of the op,
363 pad_free doesn't actually remove the sv that exists in the pad;
364 instead it lives on. This results in that it could be reused as
365 a target later on when the pad was reallocated.
368 pad_swipe(o->op_targ,1);
377 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
381 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
382 SvREFCNT_dec(cSVOPo->op_sv);
383 cSVOPo->op_sv = NULL;
386 Safefree(cPVOPo->op_pv);
387 cPVOPo->op_pv = NULL;
391 op_free(cPMOPo->op_pmreplroot);
395 if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) {
396 /* No GvIN_PAD_off here, because other references may still
397 * exist on the pad */
398 pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot), TRUE);
401 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
408 HV * const pmstash = PmopSTASH(cPMOPo);
409 if (pmstash && !SvIS_FREED(pmstash)) {
410 MAGIC * const mg = mg_find((SV*)pmstash, PERL_MAGIC_symtab);
412 PMOP *pmop = (PMOP*) mg->mg_obj;
413 PMOP *lastpmop = NULL;
415 if (cPMOPo == pmop) {
417 lastpmop->op_pmnext = pmop->op_pmnext;
419 mg->mg_obj = (SV*) pmop->op_pmnext;
423 pmop = pmop->op_pmnext;
427 PmopSTASH_free(cPMOPo);
429 cPMOPo->op_pmreplroot = NULL;
430 /* we use the "SAFE" version of the PM_ macros here
431 * since sv_clean_all might release some PMOPs
432 * after PL_regex_padav has been cleared
433 * and the clearing of PL_regex_padav needs to
434 * happen before sv_clean_all
436 ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
437 PM_SETRE_SAFE(cPMOPo, NULL);
439 if(PL_regex_pad) { /* We could be in destruction */
440 av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
441 SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
442 PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
449 if (o->op_targ > 0) {
450 pad_free(o->op_targ);
456 S_cop_free(pTHX_ COP* cop)
458 Safefree(cop->cop_label); /* FIXME: treaddead ??? */
461 if (! specialWARN(cop->cop_warnings))
462 SvREFCNT_dec(cop->cop_warnings);
463 if (! specialCopIO(cop->cop_io)) {
467 SvREFCNT_dec(cop->cop_io);
473 Perl_op_null(pTHX_ OP *o)
476 if (o->op_type == OP_NULL)
479 o->op_targ = o->op_type;
480 o->op_type = OP_NULL;
481 o->op_ppaddr = PL_ppaddr[OP_NULL];
485 Perl_op_refcnt_lock(pTHX)
493 Perl_op_refcnt_unlock(pTHX)
500 /* Contextualizers */
502 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
505 Perl_linklist(pTHX_ OP *o)
512 /* establish postfix order */
513 first = cUNOPo->op_first;
516 o->op_next = LINKLIST(first);
519 if (kid->op_sibling) {
520 kid->op_next = LINKLIST(kid->op_sibling);
521 kid = kid->op_sibling;
535 Perl_scalarkids(pTHX_ OP *o)
537 if (o && o->op_flags & OPf_KIDS) {
539 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
546 S_scalarboolean(pTHX_ OP *o)
549 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
550 if (ckWARN(WARN_SYNTAX)) {
551 const line_t oldline = CopLINE(PL_curcop);
553 if (PL_copline != NOLINE)
554 CopLINE_set(PL_curcop, PL_copline);
555 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
556 CopLINE_set(PL_curcop, oldline);
563 Perl_scalar(pTHX_ OP *o)
568 /* assumes no premature commitment */
569 if (!o || PL_error_count || (o->op_flags & OPf_WANT)
570 || o->op_type == OP_RETURN)
575 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
577 switch (o->op_type) {
579 scalar(cBINOPo->op_first);
584 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
588 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
589 if (!kPMOP->op_pmreplroot)
590 deprecate_old("implicit split to @_");
598 if (o->op_flags & OPf_KIDS) {
599 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
605 kid = cLISTOPo->op_first;
607 while ((kid = kid->op_sibling)) {
613 WITH_THR(PL_curcop = &PL_compiling);
618 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
624 WITH_THR(PL_curcop = &PL_compiling);
627 if (ckWARN(WARN_VOID))
628 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
634 Perl_scalarvoid(pTHX_ OP *o)
638 const char* useless = NULL;
642 if (o->op_type == OP_NEXTSTATE
643 || o->op_type == OP_SETSTATE
644 || o->op_type == OP_DBSTATE
645 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
646 || o->op_targ == OP_SETSTATE
647 || o->op_targ == OP_DBSTATE)))
648 PL_curcop = (COP*)o; /* for warning below */
650 /* assumes no premature commitment */
651 want = o->op_flags & OPf_WANT;
652 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
653 || o->op_type == OP_RETURN)
658 if ((o->op_private & OPpTARGET_MY)
659 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
661 return scalar(o); /* As if inside SASSIGN */
664 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
666 switch (o->op_type) {
668 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
672 if (o->op_flags & OPf_STACKED)
676 if (o->op_private == 4)
748 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
749 useless = OP_DESC(o);
753 kid = cUNOPo->op_first;
754 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
755 kid->op_type != OP_TRANS) {
758 useless = "negative pattern binding (!~)";
765 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
766 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
767 useless = "a variable";
772 if (cSVOPo->op_private & OPpCONST_STRICT)
773 no_bareword_allowed(o);
775 if (ckWARN(WARN_VOID)) {
776 useless = "a constant";
777 /* don't warn on optimised away booleans, eg
778 * use constant Foo, 5; Foo || print; */
779 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
781 /* the constants 0 and 1 are permitted as they are
782 conventionally used as dummies in constructs like
783 1 while some_condition_with_side_effects; */
784 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
786 else if (SvPOK(sv)) {
787 /* perl4's way of mixing documentation and code
788 (before the invention of POD) was based on a
789 trick to mix nroff and perl code. The trick was
790 built upon these three nroff macros being used in
791 void context. The pink camel has the details in
792 the script wrapman near page 319. */
793 const char * const maybe_macro = SvPVX_const(sv);
794 if (strnEQ(maybe_macro, "di", 2) ||
795 strnEQ(maybe_macro, "ds", 2) ||
796 strnEQ(maybe_macro, "ig", 2))
801 op_null(o); /* don't execute or even remember it */
805 o->op_type = OP_PREINC; /* pre-increment is faster */
806 o->op_ppaddr = PL_ppaddr[OP_PREINC];
810 o->op_type = OP_PREDEC; /* pre-decrement is faster */
811 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
815 o->op_type = OP_I_PREINC; /* pre-increment is faster */
816 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
820 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
821 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
830 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
835 if (o->op_flags & OPf_STACKED)
842 if (!(o->op_flags & OPf_KIDS))
853 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
860 /* all requires must return a boolean value */
861 o->op_flags &= ~OPf_WANT;
866 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
867 if (!kPMOP->op_pmreplroot)
868 deprecate_old("implicit split to @_");
872 if (useless && ckWARN(WARN_VOID))
873 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
878 Perl_listkids(pTHX_ OP *o)
880 if (o && o->op_flags & OPf_KIDS) {
882 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
889 Perl_list(pTHX_ OP *o)
894 /* assumes no premature commitment */
895 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
896 || o->op_type == OP_RETURN)
901 if ((o->op_private & OPpTARGET_MY)
902 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
904 return o; /* As if inside SASSIGN */
907 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
909 switch (o->op_type) {
912 list(cBINOPo->op_first);
917 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
925 if (!(o->op_flags & OPf_KIDS))
927 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
928 list(cBINOPo->op_first);
929 return gen_constant_list(o);
936 kid = cLISTOPo->op_first;
938 while ((kid = kid->op_sibling)) {
944 WITH_THR(PL_curcop = &PL_compiling);
948 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
954 WITH_THR(PL_curcop = &PL_compiling);
957 /* all requires must return a boolean value */
958 o->op_flags &= ~OPf_WANT;
965 Perl_scalarseq(pTHX_ OP *o)
969 if (o->op_type == OP_LINESEQ ||
970 o->op_type == OP_SCOPE ||
971 o->op_type == OP_LEAVE ||
972 o->op_type == OP_LEAVETRY)
975 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
976 if (kid->op_sibling) {
980 PL_curcop = &PL_compiling;
982 o->op_flags &= ~OPf_PARENS;
983 if (PL_hints & HINT_BLOCK_SCOPE)
984 o->op_flags |= OPf_PARENS;
987 o = newOP(OP_STUB, 0);
992 S_modkids(pTHX_ OP *o, I32 type)
994 if (o && o->op_flags & OPf_KIDS) {
996 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1002 /* Propagate lvalue ("modifiable") context to an op and its children.
1003 * 'type' represents the context type, roughly based on the type of op that
1004 * would do the modifying, although local() is represented by OP_NULL.
1005 * It's responsible for detecting things that can't be modified, flag
1006 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
1007 * might have to vivify a reference in $x), and so on.
1009 * For example, "$a+1 = 2" would cause mod() to be called with o being
1010 * OP_ADD and type being OP_SASSIGN, and would output an error.
1014 Perl_mod(pTHX_ OP *o, I32 type)
1018 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1021 if (!o || PL_error_count)
1024 if ((o->op_private & OPpTARGET_MY)
1025 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1030 switch (o->op_type) {
1036 if (!(o->op_private & (OPpCONST_ARYBASE)))
1039 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1040 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
1044 SAVEI32(PL_compiling.cop_arybase);
1045 PL_compiling.cop_arybase = 0;
1047 else if (type == OP_REFGEN)
1050 Perl_croak(aTHX_ "That use of $[ is unsupported");
1053 if (o->op_flags & OPf_PARENS)
1057 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1058 !(o->op_flags & OPf_STACKED)) {
1059 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1060 /* The default is to set op_private to the number of children,
1061 which for a UNOP such as RV2CV is always 1. And w're using
1062 the bit for a flag in RV2CV, so we need it clear. */
1063 o->op_private &= ~1;
1064 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1065 assert(cUNOPo->op_first->op_type == OP_NULL);
1066 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1069 else if (o->op_private & OPpENTERSUB_NOMOD)
1071 else { /* lvalue subroutine call */
1072 o->op_private |= OPpLVAL_INTRO;
1073 PL_modcount = RETURN_UNLIMITED_NUMBER;
1074 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1075 /* Backward compatibility mode: */
1076 o->op_private |= OPpENTERSUB_INARGS;
1079 else { /* Compile-time error message: */
1080 OP *kid = cUNOPo->op_first;
1084 if (kid->op_type == OP_PUSHMARK)
1086 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1088 "panic: unexpected lvalue entersub "
1089 "args: type/targ %ld:%"UVuf,
1090 (long)kid->op_type, (UV)kid->op_targ);
1091 kid = kLISTOP->op_first;
1093 while (kid->op_sibling)
1094 kid = kid->op_sibling;
1095 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1097 if (kid->op_type == OP_METHOD_NAMED
1098 || kid->op_type == OP_METHOD)
1102 NewOp(1101, newop, 1, UNOP);
1103 newop->op_type = OP_RV2CV;
1104 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1105 newop->op_first = NULL;
1106 newop->op_next = (OP*)newop;
1107 kid->op_sibling = (OP*)newop;
1108 newop->op_private |= OPpLVAL_INTRO;
1109 newop->op_private &= ~1;
1113 if (kid->op_type != OP_RV2CV)
1115 "panic: unexpected lvalue entersub "
1116 "entry via type/targ %ld:%"UVuf,
1117 (long)kid->op_type, (UV)kid->op_targ);
1118 kid->op_private |= OPpLVAL_INTRO;
1119 break; /* Postpone until runtime */
1123 kid = kUNOP->op_first;
1124 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1125 kid = kUNOP->op_first;
1126 if (kid->op_type == OP_NULL)
1128 "Unexpected constant lvalue entersub "
1129 "entry via type/targ %ld:%"UVuf,
1130 (long)kid->op_type, (UV)kid->op_targ);
1131 if (kid->op_type != OP_GV) {
1132 /* Restore RV2CV to check lvalueness */
1134 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1135 okid->op_next = kid->op_next;
1136 kid->op_next = okid;
1139 okid->op_next = NULL;
1140 okid->op_type = OP_RV2CV;
1142 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1143 okid->op_private |= OPpLVAL_INTRO;
1144 okid->op_private &= ~1;
1148 cv = GvCV(kGVOP_gv);
1158 /* grep, foreach, subcalls, refgen */
1159 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1161 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1162 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1164 : (o->op_type == OP_ENTERSUB
1165 ? "non-lvalue subroutine call"
1167 type ? PL_op_desc[type] : "local"));
1181 case OP_RIGHT_SHIFT:
1190 if (!(o->op_flags & OPf_STACKED))
1197 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1203 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1204 PL_modcount = RETURN_UNLIMITED_NUMBER;
1205 return o; /* Treat \(@foo) like ordinary list. */
1209 if (scalar_mod_type(o, type))
1211 ref(cUNOPo->op_first, o->op_type);
1215 if (type == OP_LEAVESUBLV)
1216 o->op_private |= OPpMAYBE_LVSUB;
1222 PL_modcount = RETURN_UNLIMITED_NUMBER;
1225 ref(cUNOPo->op_first, o->op_type);
1230 PL_hints |= HINT_BLOCK_SCOPE;
1245 PL_modcount = RETURN_UNLIMITED_NUMBER;
1246 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1247 return o; /* Treat \(@foo) like ordinary list. */
1248 if (scalar_mod_type(o, type))
1250 if (type == OP_LEAVESUBLV)
1251 o->op_private |= OPpMAYBE_LVSUB;
1255 if (!type) /* local() */
1256 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1257 PAD_COMPNAME_PV(o->op_targ));
1265 if (type != OP_SASSIGN)
1269 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1274 if (type == OP_LEAVESUBLV)
1275 o->op_private |= OPpMAYBE_LVSUB;
1277 pad_free(o->op_targ);
1278 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1279 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1280 if (o->op_flags & OPf_KIDS)
1281 mod(cBINOPo->op_first->op_sibling, type);
1286 ref(cBINOPo->op_first, o->op_type);
1287 if (type == OP_ENTERSUB &&
1288 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1289 o->op_private |= OPpLVAL_DEFER;
1290 if (type == OP_LEAVESUBLV)
1291 o->op_private |= OPpMAYBE_LVSUB;
1301 if (o->op_flags & OPf_KIDS)
1302 mod(cLISTOPo->op_last, type);
1307 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1309 else if (!(o->op_flags & OPf_KIDS))
1311 if (o->op_targ != OP_LIST) {
1312 mod(cBINOPo->op_first, type);
1318 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1323 if (type != OP_LEAVESUBLV)
1325 break; /* mod()ing was handled by ck_return() */
1328 /* [20011101.069] File test operators interpret OPf_REF to mean that
1329 their argument is a filehandle; thus \stat(".") should not set
1331 if (type == OP_REFGEN &&
1332 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1335 if (type != OP_LEAVESUBLV)
1336 o->op_flags |= OPf_MOD;
1338 if (type == OP_AASSIGN || type == OP_SASSIGN)
1339 o->op_flags |= OPf_SPECIAL|OPf_REF;
1340 else if (!type) { /* local() */
1343 o->op_private |= OPpLVAL_INTRO;
1344 o->op_flags &= ~OPf_SPECIAL;
1345 PL_hints |= HINT_BLOCK_SCOPE;
1350 if (ckWARN(WARN_SYNTAX)) {
1351 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1352 "Useless localization of %s", OP_DESC(o));
1356 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1357 && type != OP_LEAVESUBLV)
1358 o->op_flags |= OPf_REF;
1363 S_scalar_mod_type(const OP *o, I32 type)
1367 if (o->op_type == OP_RV2GV)
1391 case OP_RIGHT_SHIFT:
1410 S_is_handle_constructor(const OP *o, I32 numargs)
1412 switch (o->op_type) {
1420 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1433 Perl_refkids(pTHX_ OP *o, I32 type)
1435 if (o && o->op_flags & OPf_KIDS) {
1437 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1444 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
1449 if (!o || PL_error_count)
1452 switch (o->op_type) {
1454 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1455 !(o->op_flags & OPf_STACKED)) {
1456 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1457 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1458 assert(cUNOPo->op_first->op_type == OP_NULL);
1459 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1460 o->op_flags |= OPf_SPECIAL;
1461 o->op_private &= ~1;
1466 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1467 doref(kid, type, set_op_ref);
1470 if (type == OP_DEFINED)
1471 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1472 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1475 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1476 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1477 : type == OP_RV2HV ? OPpDEREF_HV
1479 o->op_flags |= OPf_MOD;
1484 o->op_flags |= OPf_MOD; /* XXX ??? */
1490 o->op_flags |= OPf_REF;
1493 if (type == OP_DEFINED)
1494 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1495 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1501 o->op_flags |= OPf_REF;
1506 if (!(o->op_flags & OPf_KIDS))
1508 doref(cBINOPo->op_first, type, set_op_ref);
1512 doref(cBINOPo->op_first, o->op_type, set_op_ref);
1513 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1514 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1515 : type == OP_RV2HV ? OPpDEREF_HV
1517 o->op_flags |= OPf_MOD;
1527 if (!(o->op_flags & OPf_KIDS))
1529 doref(cLISTOPo->op_last, type, set_op_ref);
1539 S_dup_attrlist(pTHX_ OP *o)
1544 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1545 * where the first kid is OP_PUSHMARK and the remaining ones
1546 * are OP_CONST. We need to push the OP_CONST values.
1548 if (o->op_type == OP_CONST)
1549 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1551 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1553 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1554 if (o->op_type == OP_CONST)
1555 rop = append_elem(OP_LIST, rop,
1556 newSVOP(OP_CONST, o->op_flags,
1557 SvREFCNT_inc(cSVOPo->op_sv)));
1564 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1569 /* fake up C<use attributes $pkg,$rv,@attrs> */
1570 ENTER; /* need to protect against side-effects of 'use' */
1572 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1574 #define ATTRSMODULE "attributes"
1575 #define ATTRSMODULE_PM "attributes.pm"
1578 /* Don't force the C<use> if we don't need it. */
1579 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
1580 if (svp && *svp != &PL_sv_undef)
1581 /*EMPTY*/; /* already in %INC */
1583 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1584 newSVpvs(ATTRSMODULE), NULL);
1587 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1588 newSVpvs(ATTRSMODULE),
1590 prepend_elem(OP_LIST,
1591 newSVOP(OP_CONST, 0, stashsv),
1592 prepend_elem(OP_LIST,
1593 newSVOP(OP_CONST, 0,
1595 dup_attrlist(attrs))));
1601 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1604 OP *pack, *imop, *arg;
1610 assert(target->op_type == OP_PADSV ||
1611 target->op_type == OP_PADHV ||
1612 target->op_type == OP_PADAV);
1614 /* Ensure that attributes.pm is loaded. */
1615 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1617 /* Need package name for method call. */
1618 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
1620 /* Build up the real arg-list. */
1621 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1623 arg = newOP(OP_PADSV, 0);
1624 arg->op_targ = target->op_targ;
1625 arg = prepend_elem(OP_LIST,
1626 newSVOP(OP_CONST, 0, stashsv),
1627 prepend_elem(OP_LIST,
1628 newUNOP(OP_REFGEN, 0,
1629 mod(arg, OP_REFGEN)),
1630 dup_attrlist(attrs)));
1632 /* Fake up a method call to import */
1633 meth = newSVpvs_share("import");
1634 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1635 append_elem(OP_LIST,
1636 prepend_elem(OP_LIST, pack, list(arg)),
1637 newSVOP(OP_METHOD_NAMED, 0, meth)));
1638 imop->op_private |= OPpENTERSUB_NOMOD;
1640 /* Combine the ops. */
1641 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1645 =notfor apidoc apply_attrs_string
1647 Attempts to apply a list of attributes specified by the C<attrstr> and
1648 C<len> arguments to the subroutine identified by the C<cv> argument which
1649 is expected to be associated with the package identified by the C<stashpv>
1650 argument (see L<attributes>). It gets this wrong, though, in that it
1651 does not correctly identify the boundaries of the individual attribute
1652 specifications within C<attrstr>. This is not really intended for the
1653 public API, but has to be listed here for systems such as AIX which
1654 need an explicit export list for symbols. (It's called from XS code
1655 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1656 to respect attribute syntax properly would be welcome.
1662 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
1663 const char *attrstr, STRLEN len)
1668 len = strlen(attrstr);
1672 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1674 const char * const sstr = attrstr;
1675 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1676 attrs = append_elem(OP_LIST, attrs,
1677 newSVOP(OP_CONST, 0,
1678 newSVpvn(sstr, attrstr-sstr)));
1682 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1683 newSVpvs(ATTRSMODULE),
1684 NULL, prepend_elem(OP_LIST,
1685 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1686 prepend_elem(OP_LIST,
1687 newSVOP(OP_CONST, 0,
1693 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
1698 if (!o || PL_error_count)
1702 if (type == OP_LIST) {
1704 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1705 my_kid(kid, attrs, imopsp);
1706 } else if (type == OP_UNDEF) {
1708 } else if (type == OP_RV2SV || /* "our" declaration */
1710 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1711 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1712 yyerror(Perl_form(aTHX_ "Can't declare %s in %s",
1713 OP_DESC(o), PL_in_my == KEY_our ? "our" : "my"));
1715 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
1717 PL_in_my_stash = NULL;
1718 apply_attrs(GvSTASH(gv),
1719 (type == OP_RV2SV ? GvSV(gv) :
1720 type == OP_RV2AV ? (SV*)GvAV(gv) :
1721 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1724 o->op_private |= OPpOUR_INTRO;
1727 else if (type != OP_PADSV &&
1730 type != OP_PUSHMARK)
1732 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1734 PL_in_my == KEY_our ? "our" : "my"));
1737 else if (attrs && type != OP_PUSHMARK) {
1741 PL_in_my_stash = NULL;
1743 /* check for C<my Dog $spot> when deciding package */
1744 stash = PAD_COMPNAME_TYPE(o->op_targ);
1746 stash = PL_curstash;
1747 apply_attrs_my(stash, o, attrs, imopsp);
1749 o->op_flags |= OPf_MOD;
1750 o->op_private |= OPpLVAL_INTRO;
1755 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1759 int maybe_scalar = 0;
1761 /* [perl #17376]: this appears to be premature, and results in code such as
1762 C< our(%x); > executing in list mode rather than void mode */
1764 if (o->op_flags & OPf_PARENS)
1774 o = my_kid(o, attrs, &rops);
1776 if (maybe_scalar && o->op_type == OP_PADSV) {
1777 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
1778 o->op_private |= OPpLVAL_INTRO;
1781 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
1784 PL_in_my_stash = NULL;
1789 Perl_my(pTHX_ OP *o)
1791 return my_attrs(o, NULL);
1795 Perl_sawparens(pTHX_ OP *o)
1797 PERL_UNUSED_CONTEXT;
1799 o->op_flags |= OPf_PARENS;
1804 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
1809 if ( (left->op_type == OP_RV2AV ||
1810 left->op_type == OP_RV2HV ||
1811 left->op_type == OP_PADAV ||
1812 left->op_type == OP_PADHV)
1813 && ckWARN(WARN_MISC))
1815 const char * const desc = PL_op_desc[(right->op_type == OP_SUBST ||
1816 right->op_type == OP_TRANS)
1817 ? right->op_type : OP_MATCH];
1818 const char * const sample = ((left->op_type == OP_RV2AV ||
1819 left->op_type == OP_PADAV)
1820 ? "@array" : "%hash");
1821 Perl_warner(aTHX_ packWARN(WARN_MISC),
1822 "Applying %s to %s will act on scalar(%s)",
1823 desc, sample, sample);
1826 if (right->op_type == OP_CONST &&
1827 cSVOPx(right)->op_private & OPpCONST_BARE &&
1828 cSVOPx(right)->op_private & OPpCONST_STRICT)
1830 no_bareword_allowed(right);
1833 ismatchop = right->op_type == OP_MATCH ||
1834 right->op_type == OP_SUBST ||
1835 right->op_type == OP_TRANS;
1836 if (ismatchop && right->op_private & OPpTARGET_MY) {
1838 right->op_private &= ~OPpTARGET_MY;
1840 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
1841 right->op_flags |= OPf_STACKED;
1842 if (right->op_type != OP_MATCH &&
1843 ! (right->op_type == OP_TRANS &&
1844 right->op_private & OPpTRANS_IDENTICAL))
1845 left = mod(left, right->op_type);
1846 if (right->op_type == OP_TRANS)
1847 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
1849 o = prepend_elem(right->op_type, scalar(left), right);
1851 return newUNOP(OP_NOT, 0, scalar(o));
1855 return bind_match(type, left,
1856 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
1860 Perl_invert(pTHX_ OP *o)
1864 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
1865 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
1869 Perl_scope(pTHX_ OP *o)
1873 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
1874 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
1875 o->op_type = OP_LEAVE;
1876 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
1878 else if (o->op_type == OP_LINESEQ) {
1880 o->op_type = OP_SCOPE;
1881 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
1882 kid = ((LISTOP*)o)->op_first;
1883 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
1886 /* The following deals with things like 'do {1 for 1}' */
1887 kid = kid->op_sibling;
1889 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
1894 o = newLISTOP(OP_SCOPE, 0, o, NULL);
1900 Perl_block_start(pTHX_ int full)
1903 const int retval = PL_savestack_ix;
1904 pad_block_start(full);
1906 PL_hints &= ~HINT_BLOCK_SCOPE;
1907 SAVESPTR(PL_compiling.cop_warnings);
1908 if (! specialWARN(PL_compiling.cop_warnings)) {
1909 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
1910 SAVEFREESV(PL_compiling.cop_warnings) ;
1912 SAVESPTR(PL_compiling.cop_io);
1913 if (! specialCopIO(PL_compiling.cop_io)) {
1914 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
1915 SAVEFREESV(PL_compiling.cop_io) ;
1921 Perl_block_end(pTHX_ I32 floor, OP *seq)
1924 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
1925 OP* const retval = scalarseq(seq);
1927 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
1929 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
1938 const I32 offset = pad_findmy("$_");
1939 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
1940 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
1943 OP * const o = newOP(OP_PADSV, 0);
1944 o->op_targ = offset;
1950 Perl_newPROG(pTHX_ OP *o)
1956 PL_eval_root = newUNOP(OP_LEAVEEVAL,
1957 ((PL_in_eval & EVAL_KEEPERR)
1958 ? OPf_SPECIAL : 0), o);
1959 PL_eval_start = linklist(PL_eval_root);
1960 PL_eval_root->op_private |= OPpREFCOUNTED;
1961 OpREFCNT_set(PL_eval_root, 1);
1962 PL_eval_root->op_next = 0;
1963 CALL_PEEP(PL_eval_start);
1966 if (o->op_type == OP_STUB) {
1967 PL_comppad_name = 0;
1972 PL_main_root = scope(sawparens(scalarvoid(o)));
1973 PL_curcop = &PL_compiling;
1974 PL_main_start = LINKLIST(PL_main_root);
1975 PL_main_root->op_private |= OPpREFCOUNTED;
1976 OpREFCNT_set(PL_main_root, 1);
1977 PL_main_root->op_next = 0;
1978 CALL_PEEP(PL_main_start);
1981 /* Register with debugger */
1983 CV * const cv = get_cv("DB::postponed", FALSE);
1987 XPUSHs((SV*)CopFILEGV(&PL_compiling));
1989 call_sv((SV*)cv, G_DISCARD);
1996 Perl_localize(pTHX_ OP *o, I32 lex)
1999 if (o->op_flags & OPf_PARENS)
2000 /* [perl #17376]: this appears to be premature, and results in code such as
2001 C< our(%x); > executing in list mode rather than void mode */
2008 if ( PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ','
2009 && ckWARN(WARN_PARENTHESIS))
2011 char *s = PL_bufptr;
2014 /* some heuristics to detect a potential error */
2015 while (*s && (strchr(", \t\n", *s)))
2019 if (*s && strchr("@$%*", *s) && *++s
2020 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2023 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2025 while (*s && (strchr(", \t\n", *s)))
2031 if (sigil && (*s == ';' || *s == '=')) {
2032 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2033 "Parentheses missing around \"%s\" list",
2034 lex ? (PL_in_my == KEY_our ? "our" : "my")
2042 o = mod(o, OP_NULL); /* a bit kludgey */
2044 PL_in_my_stash = NULL;
2049 Perl_jmaybe(pTHX_ OP *o)
2051 if (o->op_type == OP_LIST) {
2053 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL,
2055 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2061 Perl_fold_constants(pTHX_ register OP *o)
2065 I32 type = o->op_type;
2068 if (PL_opargs[type] & OA_RETSCALAR)
2070 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2071 o->op_targ = pad_alloc(type, SVs_PADTMP);
2073 /* integerize op, unless it happens to be C<-foo>.
2074 * XXX should pp_i_negate() do magic string negation instead? */
2075 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2076 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2077 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2079 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2082 if (!(PL_opargs[type] & OA_FOLDCONST))
2087 /* XXX might want a ck_negate() for this */
2088 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2099 /* XXX what about the numeric ops? */
2100 if (PL_hints & HINT_LOCALE)
2105 goto nope; /* Don't try to run w/ errors */
2107 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2108 if ((curop->op_type != OP_CONST ||
2109 (curop->op_private & OPpCONST_BARE)) &&
2110 curop->op_type != OP_LIST &&
2111 curop->op_type != OP_SCALAR &&
2112 curop->op_type != OP_NULL &&
2113 curop->op_type != OP_PUSHMARK)
2119 curop = LINKLIST(o);
2123 sv = *(PL_stack_sp--);
2124 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2125 pad_swipe(o->op_targ, FALSE);
2126 else if (SvTEMP(sv)) { /* grab mortal temp? */
2127 (void)SvREFCNT_inc(sv);
2131 if (type == OP_RV2GV)
2132 return newGVOP(OP_GV, 0, (GV*)sv);
2133 return newSVOP(OP_CONST, 0, sv);
2140 Perl_gen_constant_list(pTHX_ register OP *o)
2144 const I32 oldtmps_floor = PL_tmps_floor;
2148 return o; /* Don't attempt to run with errors */
2150 PL_op = curop = LINKLIST(o);
2157 PL_tmps_floor = oldtmps_floor;
2159 o->op_type = OP_RV2AV;
2160 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2161 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2162 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2163 o->op_opt = 0; /* needs to be revisited in peep() */
2164 curop = ((UNOP*)o)->op_first;
2165 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2172 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2175 if (!o || o->op_type != OP_LIST)
2176 o = newLISTOP(OP_LIST, 0, o, NULL);
2178 o->op_flags &= ~OPf_WANT;
2180 if (!(PL_opargs[type] & OA_MARK))
2181 op_null(cLISTOPo->op_first);
2183 o->op_type = (OPCODE)type;
2184 o->op_ppaddr = PL_ppaddr[type];
2185 o->op_flags |= flags;
2187 o = CHECKOP(type, o);
2188 if (o->op_type != (unsigned)type)
2191 return fold_constants(o);
2194 /* List constructors */
2197 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2205 if (first->op_type != (unsigned)type
2206 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2208 return newLISTOP(type, 0, first, last);
2211 if (first->op_flags & OPf_KIDS)
2212 ((LISTOP*)first)->op_last->op_sibling = last;
2214 first->op_flags |= OPf_KIDS;
2215 ((LISTOP*)first)->op_first = last;
2217 ((LISTOP*)first)->op_last = last;
2222 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2230 if (first->op_type != (unsigned)type)
2231 return prepend_elem(type, (OP*)first, (OP*)last);
2233 if (last->op_type != (unsigned)type)
2234 return append_elem(type, (OP*)first, (OP*)last);
2236 first->op_last->op_sibling = last->op_first;
2237 first->op_last = last->op_last;
2238 first->op_flags |= (last->op_flags & OPf_KIDS);
2246 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2254 if (last->op_type == (unsigned)type) {
2255 if (type == OP_LIST) { /* already a PUSHMARK there */
2256 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2257 ((LISTOP*)last)->op_first->op_sibling = first;
2258 if (!(first->op_flags & OPf_PARENS))
2259 last->op_flags &= ~OPf_PARENS;
2262 if (!(last->op_flags & OPf_KIDS)) {
2263 ((LISTOP*)last)->op_last = first;
2264 last->op_flags |= OPf_KIDS;
2266 first->op_sibling = ((LISTOP*)last)->op_first;
2267 ((LISTOP*)last)->op_first = first;
2269 last->op_flags |= OPf_KIDS;
2273 return newLISTOP(type, 0, first, last);
2279 Perl_newNULLLIST(pTHX)
2281 return newOP(OP_STUB, 0);
2285 Perl_force_list(pTHX_ OP *o)
2287 if (!o || o->op_type != OP_LIST)
2288 o = newLISTOP(OP_LIST, 0, o, NULL);
2294 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2299 NewOp(1101, listop, 1, LISTOP);
2301 listop->op_type = (OPCODE)type;
2302 listop->op_ppaddr = PL_ppaddr[type];
2305 listop->op_flags = (U8)flags;
2309 else if (!first && last)
2312 first->op_sibling = last;
2313 listop->op_first = first;
2314 listop->op_last = last;
2315 if (type == OP_LIST) {
2316 OP* const pushop = newOP(OP_PUSHMARK, 0);
2317 pushop->op_sibling = first;
2318 listop->op_first = pushop;
2319 listop->op_flags |= OPf_KIDS;
2321 listop->op_last = pushop;
2324 return CHECKOP(type, listop);
2328 Perl_newOP(pTHX_ I32 type, I32 flags)
2332 NewOp(1101, o, 1, OP);
2333 o->op_type = (OPCODE)type;
2334 o->op_ppaddr = PL_ppaddr[type];
2335 o->op_flags = (U8)flags;
2338 o->op_private = (U8)(0 | (flags >> 8));
2339 if (PL_opargs[type] & OA_RETSCALAR)
2341 if (PL_opargs[type] & OA_TARGET)
2342 o->op_targ = pad_alloc(type, SVs_PADTMP);
2343 return CHECKOP(type, o);
2347 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2353 first = newOP(OP_STUB, 0);
2354 if (PL_opargs[type] & OA_MARK)
2355 first = force_list(first);
2357 NewOp(1101, unop, 1, UNOP);
2358 unop->op_type = (OPCODE)type;
2359 unop->op_ppaddr = PL_ppaddr[type];
2360 unop->op_first = first;
2361 unop->op_flags = (U8)(flags | OPf_KIDS);
2362 unop->op_private = (U8)(1 | (flags >> 8));
2363 unop = (UNOP*) CHECKOP(type, unop);
2367 return fold_constants((OP *) unop);
2371 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2375 NewOp(1101, binop, 1, BINOP);
2378 first = newOP(OP_NULL, 0);
2380 binop->op_type = (OPCODE)type;
2381 binop->op_ppaddr = PL_ppaddr[type];
2382 binop->op_first = first;
2383 binop->op_flags = (U8)(flags | OPf_KIDS);
2386 binop->op_private = (U8)(1 | (flags >> 8));
2389 binop->op_private = (U8)(2 | (flags >> 8));
2390 first->op_sibling = last;
2393 binop = (BINOP*)CHECKOP(type, binop);
2394 if (binop->op_next || binop->op_type != (OPCODE)type)
2397 binop->op_last = binop->op_first->op_sibling;
2399 return fold_constants((OP *)binop);
2402 static int uvcompare(const void *a, const void *b)
2403 __attribute__nonnull__(1)
2404 __attribute__nonnull__(2)
2405 __attribute__pure__;
2406 static int uvcompare(const void *a, const void *b)
2408 if (*((const UV *)a) < (*(const UV *)b))
2410 if (*((const UV *)a) > (*(const UV *)b))
2412 if (*((const UV *)a+1) < (*(const UV *)b+1))
2414 if (*((const UV *)a+1) > (*(const UV *)b+1))
2420 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2423 SV * const tstr = ((SVOP*)expr)->op_sv;
2424 SV * const rstr = ((SVOP*)repl)->op_sv;
2427 const U8 *t = (U8*)SvPV_const(tstr, tlen);
2428 const U8 *r = (U8*)SvPV_const(rstr, rlen);
2432 register short *tbl;
2434 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
2435 const I32 squash = o->op_private & OPpTRANS_SQUASH;
2436 I32 del = o->op_private & OPpTRANS_DELETE;
2437 PL_hints |= HINT_BLOCK_SCOPE;
2440 o->op_private |= OPpTRANS_FROM_UTF;
2443 o->op_private |= OPpTRANS_TO_UTF;
2445 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2446 SV* const listsv = newSVpvs("# comment\n");
2448 const U8* tend = t + tlen;
2449 const U8* rend = r + rlen;
2463 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2464 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2470 t = tsave = bytes_to_utf8(t, &len);
2473 if (!to_utf && rlen) {
2475 r = rsave = bytes_to_utf8(r, &len);
2479 /* There are several snags with this code on EBCDIC:
2480 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2481 2. scan_const() in toke.c has encoded chars in native encoding which makes
2482 ranges at least in EBCDIC 0..255 range the bottom odd.
2486 U8 tmpbuf[UTF8_MAXBYTES+1];
2489 Newx(cp, 2*tlen, UV);
2491 transv = newSVpvs("");
2493 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2495 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2497 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2501 cp[2*i+1] = cp[2*i];
2505 qsort(cp, i, 2*sizeof(UV), uvcompare);
2506 for (j = 0; j < i; j++) {
2508 diff = val - nextmin;
2510 t = uvuni_to_utf8(tmpbuf,nextmin);
2511 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2513 U8 range_mark = UTF_TO_NATIVE(0xff);
2514 t = uvuni_to_utf8(tmpbuf, val - 1);
2515 sv_catpvn(transv, (char *)&range_mark, 1);
2516 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2523 t = uvuni_to_utf8(tmpbuf,nextmin);
2524 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2526 U8 range_mark = UTF_TO_NATIVE(0xff);
2527 sv_catpvn(transv, (char *)&range_mark, 1);
2529 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2530 UNICODE_ALLOW_SUPER);
2531 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2532 t = (const U8*)SvPVX_const(transv);
2533 tlen = SvCUR(transv);
2537 else if (!rlen && !del) {
2538 r = t; rlen = tlen; rend = tend;
2541 if ((!rlen && !del) || t == r ||
2542 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2544 o->op_private |= OPpTRANS_IDENTICAL;
2548 while (t < tend || tfirst <= tlast) {
2549 /* see if we need more "t" chars */
2550 if (tfirst > tlast) {
2551 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2553 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2555 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2562 /* now see if we need more "r" chars */
2563 if (rfirst > rlast) {
2565 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2567 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2569 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2578 rfirst = rlast = 0xffffffff;
2582 /* now see which range will peter our first, if either. */
2583 tdiff = tlast - tfirst;
2584 rdiff = rlast - rfirst;
2591 if (rfirst == 0xffffffff) {
2592 diff = tdiff; /* oops, pretend rdiff is infinite */
2594 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2595 (long)tfirst, (long)tlast);
2597 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2601 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2602 (long)tfirst, (long)(tfirst + diff),
2605 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2606 (long)tfirst, (long)rfirst);
2608 if (rfirst + diff > max)
2609 max = rfirst + diff;
2611 grows = (tfirst < rfirst &&
2612 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2624 else if (max > 0xff)
2629 Safefree(cPVOPo->op_pv);
2630 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2631 SvREFCNT_dec(listsv);
2633 SvREFCNT_dec(transv);
2635 if (!del && havefinal && rlen)
2636 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2637 newSVuv((UV)final), 0);
2640 o->op_private |= OPpTRANS_GROWS;
2652 tbl = (short*)cPVOPo->op_pv;
2654 Zero(tbl, 256, short);
2655 for (i = 0; i < (I32)tlen; i++)
2657 for (i = 0, j = 0; i < 256; i++) {
2659 if (j >= (I32)rlen) {
2668 if (i < 128 && r[j] >= 128)
2678 o->op_private |= OPpTRANS_IDENTICAL;
2680 else if (j >= (I32)rlen)
2683 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2684 tbl[0x100] = (short)(rlen - j);
2685 for (i=0; i < (I32)rlen - j; i++)
2686 tbl[0x101+i] = r[j+i];
2690 if (!rlen && !del) {
2693 o->op_private |= OPpTRANS_IDENTICAL;
2695 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
2696 o->op_private |= OPpTRANS_IDENTICAL;
2698 for (i = 0; i < 256; i++)
2700 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
2701 if (j >= (I32)rlen) {
2703 if (tbl[t[i]] == -1)
2709 if (tbl[t[i]] == -1) {
2710 if (t[i] < 128 && r[j] >= 128)
2717 o->op_private |= OPpTRANS_GROWS;
2725 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2730 NewOp(1101, pmop, 1, PMOP);
2731 pmop->op_type = (OPCODE)type;
2732 pmop->op_ppaddr = PL_ppaddr[type];
2733 pmop->op_flags = (U8)flags;
2734 pmop->op_private = (U8)(0 | (flags >> 8));
2736 if (PL_hints & HINT_RE_TAINT)
2737 pmop->op_pmpermflags |= PMf_RETAINT;
2738 if (PL_hints & HINT_LOCALE)
2739 pmop->op_pmpermflags |= PMf_LOCALE;
2740 pmop->op_pmflags = pmop->op_pmpermflags;
2743 if (av_len((AV*) PL_regex_pad[0]) > -1) {
2744 SV * const repointer = av_pop((AV*)PL_regex_pad[0]);
2745 pmop->op_pmoffset = SvIV(repointer);
2746 SvREPADTMP_off(repointer);
2747 sv_setiv(repointer,0);
2749 SV * const repointer = newSViv(0);
2750 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
2751 pmop->op_pmoffset = av_len(PL_regex_padav);
2752 PL_regex_pad = AvARRAY(PL_regex_padav);
2756 /* link into pm list */
2757 if (type != OP_TRANS && PL_curstash) {
2758 MAGIC *mg = mg_find((SV*)PL_curstash, PERL_MAGIC_symtab);
2761 mg = sv_magicext((SV*)PL_curstash, 0, PERL_MAGIC_symtab, 0, 0, 0);
2763 pmop->op_pmnext = (PMOP*)mg->mg_obj;
2764 mg->mg_obj = (SV*)pmop;
2765 PmopSTASH_set(pmop,PL_curstash);
2768 return CHECKOP(type, pmop);
2771 /* Given some sort of match op o, and an expression expr containing a
2772 * pattern, either compile expr into a regex and attach it to o (if it's
2773 * constant), or convert expr into a runtime regcomp op sequence (if it's
2776 * isreg indicates that the pattern is part of a regex construct, eg
2777 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
2778 * split "pattern", which aren't. In the former case, expr will be a list
2779 * if the pattern contains more than one term (eg /a$b/) or if it contains
2780 * a replacement, ie s/// or tr///.
2784 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
2789 I32 repl_has_vars = 0;
2793 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
2794 /* last element in list is the replacement; pop it */
2796 repl = cLISTOPx(expr)->op_last;
2797 kid = cLISTOPx(expr)->op_first;
2798 while (kid->op_sibling != repl)
2799 kid = kid->op_sibling;
2800 kid->op_sibling = NULL;
2801 cLISTOPx(expr)->op_last = kid;
2804 if (isreg && expr->op_type == OP_LIST &&
2805 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
2807 /* convert single element list to element */
2808 OP* const oe = expr;
2809 expr = cLISTOPx(oe)->op_first->op_sibling;
2810 cLISTOPx(oe)->op_first->op_sibling = NULL;
2811 cLISTOPx(oe)->op_last = NULL;
2815 if (o->op_type == OP_TRANS) {
2816 return pmtrans(o, expr, repl);
2819 reglist = isreg && expr->op_type == OP_LIST;
2823 PL_hints |= HINT_BLOCK_SCOPE;
2826 if (expr->op_type == OP_CONST) {
2828 SV * const pat = ((SVOP*)expr)->op_sv;
2829 const char *p = SvPV_const(pat, plen);
2830 if ((o->op_flags & OPf_SPECIAL) && (*p == ' ' && p[1] == '\0')) {
2831 U32 was_readonly = SvREADONLY(pat);
2835 sv_force_normal_flags(pat, 0);
2836 assert(!SvREADONLY(pat));
2839 SvREADONLY_off(pat);
2843 sv_setpvn(pat, "\\s+", 3);
2845 SvFLAGS(pat) |= was_readonly;
2847 p = SvPV_const(pat, plen);
2848 pm->op_pmflags |= PMf_SKIPWHITE;
2851 pm->op_pmdynflags |= PMdf_UTF8;
2852 /* FIXME - can we make this function take const char * args? */
2853 PM_SETRE(pm, CALLREGCOMP(aTHX_ (char*)p, (char*)p + plen, pm));
2854 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
2855 pm->op_pmflags |= PMf_WHITE;
2859 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
2860 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2862 : OP_REGCMAYBE),0,expr);
2864 NewOp(1101, rcop, 1, LOGOP);
2865 rcop->op_type = OP_REGCOMP;
2866 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
2867 rcop->op_first = scalar(expr);
2868 rcop->op_flags |= OPf_KIDS
2869 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
2870 | (reglist ? OPf_STACKED : 0);
2871 rcop->op_private = 1;
2874 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
2876 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
2879 /* establish postfix order */
2880 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
2882 rcop->op_next = expr;
2883 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
2886 rcop->op_next = LINKLIST(expr);
2887 expr->op_next = (OP*)rcop;
2890 prepend_elem(o->op_type, scalar((OP*)rcop), o);
2895 if (pm->op_pmflags & PMf_EVAL) {
2897 if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
2898 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
2900 else if (repl->op_type == OP_CONST)
2904 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
2905 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
2906 if (curop->op_type == OP_GV) {
2907 GV * const gv = cGVOPx_gv(curop);
2909 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
2912 else if (curop->op_type == OP_RV2CV)
2914 else if (curop->op_type == OP_RV2SV ||
2915 curop->op_type == OP_RV2AV ||
2916 curop->op_type == OP_RV2HV ||
2917 curop->op_type == OP_RV2GV) {
2918 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
2921 else if (curop->op_type == OP_PADSV ||
2922 curop->op_type == OP_PADAV ||
2923 curop->op_type == OP_PADHV ||
2924 curop->op_type == OP_PADANY) {
2927 else if (curop->op_type == OP_PUSHRE)
2928 /*EMPTY*/; /* Okay here, dangerous in newASSIGNOP */
2938 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
2939 pm->op_pmflags |= PMf_CONST; /* const for long enough */
2940 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
2941 prepend_elem(o->op_type, scalar(repl), o);
2944 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
2945 pm->op_pmflags |= PMf_MAYBE_CONST;
2946 pm->op_pmpermflags |= PMf_MAYBE_CONST;
2948 NewOp(1101, rcop, 1, LOGOP);
2949 rcop->op_type = OP_SUBSTCONT;
2950 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
2951 rcop->op_first = scalar(repl);
2952 rcop->op_flags |= OPf_KIDS;
2953 rcop->op_private = 1;
2956 /* establish postfix order */
2957 rcop->op_next = LINKLIST(repl);
2958 repl->op_next = (OP*)rcop;
2960 pm->op_pmreplroot = scalar((OP*)rcop);
2961 pm->op_pmreplstart = LINKLIST(rcop);
2970 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
2974 NewOp(1101, svop, 1, SVOP);
2975 svop->op_type = (OPCODE)type;
2976 svop->op_ppaddr = PL_ppaddr[type];
2978 svop->op_next = (OP*)svop;
2979 svop->op_flags = (U8)flags;
2980 if (PL_opargs[type] & OA_RETSCALAR)
2982 if (PL_opargs[type] & OA_TARGET)
2983 svop->op_targ = pad_alloc(type, SVs_PADTMP);
2984 return CHECKOP(type, svop);
2988 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
2992 NewOp(1101, padop, 1, PADOP);
2993 padop->op_type = (OPCODE)type;
2994 padop->op_ppaddr = PL_ppaddr[type];
2995 padop->op_padix = pad_alloc(type, SVs_PADTMP);
2996 SvREFCNT_dec(PAD_SVl(padop->op_padix));
2997 PAD_SETSV(padop->op_padix, sv);
3000 padop->op_next = (OP*)padop;
3001 padop->op_flags = (U8)flags;
3002 if (PL_opargs[type] & OA_RETSCALAR)
3004 if (PL_opargs[type] & OA_TARGET)
3005 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3006 return CHECKOP(type, padop);
3010 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3016 return newPADOP(type, flags, SvREFCNT_inc(gv));
3018 return newSVOP(type, flags, SvREFCNT_inc(gv));
3023 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3027 NewOp(1101, pvop, 1, PVOP);
3028 pvop->op_type = (OPCODE)type;
3029 pvop->op_ppaddr = PL_ppaddr[type];
3031 pvop->op_next = (OP*)pvop;
3032 pvop->op_flags = (U8)flags;
3033 if (PL_opargs[type] & OA_RETSCALAR)
3035 if (PL_opargs[type] & OA_TARGET)
3036 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3037 return CHECKOP(type, pvop);
3041 Perl_package(pTHX_ OP *o)
3047 save_hptr(&PL_curstash);
3048 save_item(PL_curstname);
3050 name = SvPV_const(cSVOPo->op_sv, len);
3051 PL_curstash = gv_stashpvn(name, len, TRUE);
3052 sv_setpvn(PL_curstname, name, len);
3055 PL_hints |= HINT_BLOCK_SCOPE;
3056 PL_copline = NOLINE;
3061 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3068 if (idop->op_type != OP_CONST)
3069 Perl_croak(aTHX_ "Module name must be constant");
3074 SV * const vesv = ((SVOP*)version)->op_sv;
3076 if (!arg && !SvNIOKp(vesv)) {
3083 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3084 Perl_croak(aTHX_ "Version number must be constant number");
3086 /* Make copy of idop so we don't free it twice */
3087 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3089 /* Fake up a method call to VERSION */
3090 meth = newSVpvs_share("VERSION");
3091 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3092 append_elem(OP_LIST,
3093 prepend_elem(OP_LIST, pack, list(version)),
3094 newSVOP(OP_METHOD_NAMED, 0, meth)));
3098 /* Fake up an import/unimport */
3099 if (arg && arg->op_type == OP_STUB)
3100 imop = arg; /* no import on explicit () */
3101 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3102 imop = NULL; /* use 5.0; */
3104 idop->op_private |= OPpCONST_NOVER;
3109 /* Make copy of idop so we don't free it twice */
3110 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3112 /* Fake up a method call to import/unimport */
3114 ? newSVpvs_share("import") : newSVpvs_share("unimport");
3115 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3116 append_elem(OP_LIST,
3117 prepend_elem(OP_LIST, pack, list(arg)),
3118 newSVOP(OP_METHOD_NAMED, 0, meth)));
3121 /* Fake up the BEGIN {}, which does its thing immediately. */
3123 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
3126 append_elem(OP_LINESEQ,
3127 append_elem(OP_LINESEQ,
3128 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
3129 newSTATEOP(0, NULL, veop)),
3130 newSTATEOP(0, NULL, imop) ));
3132 /* The "did you use incorrect case?" warning used to be here.
3133 * The problem is that on case-insensitive filesystems one
3134 * might get false positives for "use" (and "require"):
3135 * "use Strict" or "require CARP" will work. This causes
3136 * portability problems for the script: in case-strict
3137 * filesystems the script will stop working.
3139 * The "incorrect case" warning checked whether "use Foo"
3140 * imported "Foo" to your namespace, but that is wrong, too:
3141 * there is no requirement nor promise in the language that
3142 * a Foo.pm should or would contain anything in package "Foo".
3144 * There is very little Configure-wise that can be done, either:
3145 * the case-sensitivity of the build filesystem of Perl does not
3146 * help in guessing the case-sensitivity of the runtime environment.
3149 PL_hints |= HINT_BLOCK_SCOPE;
3150 PL_copline = NOLINE;
3152 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3156 =head1 Embedding Functions
3158 =for apidoc load_module
3160 Loads the module whose name is pointed to by the string part of name.
3161 Note that the actual module name, not its filename, should be given.
3162 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3163 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3164 (or 0 for no flags). ver, if specified, provides version semantics
3165 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3166 arguments can be used to specify arguments to the module's import()
3167 method, similar to C<use Foo::Bar VERSION LIST>.
3172 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3175 va_start(args, ver);
3176 vload_module(flags, name, ver, &args);
3180 #ifdef PERL_IMPLICIT_CONTEXT
3182 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3186 va_start(args, ver);
3187 vload_module(flags, name, ver, &args);
3193 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3198 OP * const modname = newSVOP(OP_CONST, 0, name);
3199 modname->op_private |= OPpCONST_BARE;
3201 veop = newSVOP(OP_CONST, 0, ver);
3205 if (flags & PERL_LOADMOD_NOIMPORT) {
3206 imop = sawparens(newNULLLIST());
3208 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3209 imop = va_arg(*args, OP*);
3214 sv = va_arg(*args, SV*);
3216 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3217 sv = va_arg(*args, SV*);
3221 const line_t ocopline = PL_copline;
3222 COP * const ocurcop = PL_curcop;
3223 const int oexpect = PL_expect;
3225 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3226 veop, modname, imop);
3227 PL_expect = oexpect;
3228 PL_copline = ocopline;
3229 PL_curcop = ocurcop;
3234 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
3240 if (!force_builtin) {
3241 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
3242 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
3243 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
3244 gv = gvp ? *gvp : NULL;
3248 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3249 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3250 append_elem(OP_LIST, term,
3251 scalar(newUNOP(OP_RV2CV, 0,
3256 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3262 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3264 return newBINOP(OP_LSLICE, flags,
3265 list(force_list(subscript)),
3266 list(force_list(listval)) );
3270 S_is_list_assignment(pTHX_ register const OP *o)
3275 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3276 o = cUNOPo->op_first;
3278 if (o->op_type == OP_COND_EXPR) {
3279 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
3280 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3285 yyerror("Assignment to both a list and a scalar");
3289 if (o->op_type == OP_LIST &&
3290 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3291 o->op_private & OPpLVAL_INTRO)
3294 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3295 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3296 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3299 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3302 if (o->op_type == OP_RV2SV)
3309 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3315 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3316 return newLOGOP(optype, 0,
3317 mod(scalar(left), optype),
3318 newUNOP(OP_SASSIGN, 0, scalar(right)));
3321 return newBINOP(optype, OPf_STACKED,
3322 mod(scalar(left), optype), scalar(right));
3326 if (is_list_assignment(left)) {
3330 /* Grandfathering $[ assignment here. Bletch.*/
3331 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
3332 PL_eval_start = (left->op_type == OP_CONST) ? right : 0;
3333 left = mod(left, OP_AASSIGN);
3336 else if (left->op_type == OP_CONST) {
3337 /* Result of assignment is always 1 (or we'd be dead already) */
3338 return newSVOP(OP_CONST, 0, newSViv(1));
3340 curop = list(force_list(left));
3341 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3342 o->op_private = (U8)(0 | (flags >> 8));
3344 /* PL_generation sorcery:
3345 * an assignment like ($a,$b) = ($c,$d) is easier than
3346 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3347 * To detect whether there are common vars, the global var
3348 * PL_generation is incremented for each assign op we compile.
3349 * Then, while compiling the assign op, we run through all the
3350 * variables on both sides of the assignment, setting a spare slot
3351 * in each of them to PL_generation. If any of them already have
3352 * that value, we know we've got commonality. We could use a
3353 * single bit marker, but then we'd have to make 2 passes, first
3354 * to clear the flag, then to test and set it. To find somewhere
3355 * to store these values, evil chicanery is done with SvCUR().
3358 if (!(left->op_private & OPpLVAL_INTRO)) {
3361 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3362 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3363 if (curop->op_type == OP_GV) {
3364 GV *gv = cGVOPx_gv(curop);
3365 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3367 SvCUR_set(gv, PL_generation);
3369 else if (curop->op_type == OP_PADSV ||
3370 curop->op_type == OP_PADAV ||
3371 curop->op_type == OP_PADHV ||
3372 curop->op_type == OP_PADANY)
3374 if (PAD_COMPNAME_GEN(curop->op_targ)
3375 == (STRLEN)PL_generation)
3377 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
3380 else if (curop->op_type == OP_RV2CV)
3382 else if (curop->op_type == OP_RV2SV ||
3383 curop->op_type == OP_RV2AV ||
3384 curop->op_type == OP_RV2HV ||
3385 curop->op_type == OP_RV2GV) {
3386 if (lastop->op_type != OP_GV) /* funny deref? */
3389 else if (curop->op_type == OP_PUSHRE) {
3390 if (((PMOP*)curop)->op_pmreplroot) {
3392 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3393 ((PMOP*)curop)->op_pmreplroot));
3395 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3397 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3399 SvCUR_set(gv, PL_generation);
3408 o->op_private |= OPpASSIGN_COMMON;
3410 if (right && right->op_type == OP_SPLIT) {
3412 if ((tmpop = ((LISTOP*)right)->op_first) &&
3413 tmpop->op_type == OP_PUSHRE)
3415 PMOP * const pm = (PMOP*)tmpop;
3416 if (left->op_type == OP_RV2AV &&
3417 !(left->op_private & OPpLVAL_INTRO) &&
3418 !(o->op_private & OPpASSIGN_COMMON) )
3420 tmpop = ((UNOP*)left)->op_first;
3421 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3423 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3424 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3426 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3427 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
3429 pm->op_pmflags |= PMf_ONCE;
3430 tmpop = cUNOPo->op_first; /* to list (nulled) */
3431 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3432 tmpop->op_sibling = NULL; /* don't free split */
3433 right->op_next = tmpop->op_next; /* fix starting loc */
3434 op_free(o); /* blow off assign */
3435 right->op_flags &= ~OPf_WANT;
3436 /* "I don't know and I don't care." */
3441 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3442 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3444 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3446 sv_setiv(sv, PL_modcount+1);
3454 right = newOP(OP_UNDEF, 0);
3455 if (right->op_type == OP_READLINE) {
3456 right->op_flags |= OPf_STACKED;
3457 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3460 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3461 o = newBINOP(OP_SASSIGN, flags,
3462 scalar(right), mod(scalar(left), OP_SASSIGN) );
3466 o = newSVOP(OP_CONST, 0, newSViv(PL_compiling.cop_arybase));
3473 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3476 const U32 seq = intro_my();
3479 NewOp(1101, cop, 1, COP);
3480 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3481 cop->op_type = OP_DBSTATE;
3482 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3485 cop->op_type = OP_NEXTSTATE;
3486 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3488 cop->op_flags = (U8)flags;
3489 cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
3491 cop->op_private |= NATIVE_HINTS;
3493 PL_compiling.op_private = cop->op_private;
3494 cop->op_next = (OP*)cop;
3497 cop->cop_label = label;
3498 PL_hints |= HINT_BLOCK_SCOPE;
3501 cop->cop_arybase = PL_curcop->cop_arybase;
3502 if (specialWARN(PL_curcop->cop_warnings))
3503 cop->cop_warnings = PL_curcop->cop_warnings ;
3505 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3506 if (specialCopIO(PL_curcop->cop_io))
3507 cop->cop_io = PL_curcop->cop_io;
3509 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3512 if (PL_copline == NOLINE)
3513 CopLINE_set(cop, CopLINE(PL_curcop));
3515 CopLINE_set(cop, PL_copline);
3516 PL_copline = NOLINE;
3519 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3521 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3523 CopSTASH_set(cop, PL_curstash);
3525 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3526 SV * const * const svp = av_fetch(CopFILEAVx(PL_curcop), (I32)CopLINE(cop), FALSE);
3527 if (svp && *svp != &PL_sv_undef ) {
3528 (void)SvIOK_on(*svp);
3529 SvIV_set(*svp, PTR2IV(cop));
3533 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3538 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3541 return new_logop(type, flags, &first, &other);
3545 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3550 OP *first = *firstp;
3551 OP * const other = *otherp;
3553 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3554 return newBINOP(type, flags, scalar(first), scalar(other));
3556 scalarboolean(first);
3557 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3558 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3559 if (type == OP_AND || type == OP_OR) {
3565 first = *firstp = cUNOPo->op_first;
3567 first->op_next = o->op_next;
3568 cUNOPo->op_first = NULL;
3572 if (first->op_type == OP_CONST) {
3573 if (first->op_private & OPpCONST_STRICT)
3574 no_bareword_allowed(first);
3575 else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
3576 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
3577 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
3578 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
3579 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
3582 if (other->op_type == OP_CONST)
3583 other->op_private |= OPpCONST_SHORTCIRCUIT;
3587 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
3588 const OP *o2 = other;
3589 if ( ! (o2->op_type == OP_LIST
3590 && (( o2 = cUNOPx(o2)->op_first))
3591 && o2->op_type == OP_PUSHMARK
3592 && (( o2 = o2->op_sibling)) )
3595 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
3596 || o2->op_type == OP_PADHV)
3597 && o2->op_private & OPpLVAL_INTRO
3598 && ckWARN(WARN_DEPRECATED))
3600 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
3601 "Deprecated use of my() in false conditional");
3606 if (first->op_type == OP_CONST)
3607 first->op_private |= OPpCONST_SHORTCIRCUIT;
3611 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
3612 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
3614 const OP * const k1 = ((UNOP*)first)->op_first;
3615 const OP * const k2 = k1->op_sibling;
3617 switch (first->op_type)
3620 if (k2 && k2->op_type == OP_READLINE
3621 && (k2->op_flags & OPf_STACKED)
3622 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3624 warnop = k2->op_type;
3629 if (k1->op_type == OP_READDIR
3630 || k1->op_type == OP_GLOB
3631 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3632 || k1->op_type == OP_EACH)
3634 warnop = ((k1->op_type == OP_NULL)
3635 ? (OPCODE)k1->op_targ : k1->op_type);
3640 const line_t oldline = CopLINE(PL_curcop);
3641 CopLINE_set(PL_curcop, PL_copline);
3642 Perl_warner(aTHX_ packWARN(WARN_MISC),
3643 "Value of %s%s can be \"0\"; test with defined()",
3645 ((warnop == OP_READLINE || warnop == OP_GLOB)
3646 ? " construct" : "() operator"));
3647 CopLINE_set(PL_curcop, oldline);
3654 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
3655 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3657 NewOp(1101, logop, 1, LOGOP);
3659 logop->op_type = (OPCODE)type;
3660 logop->op_ppaddr = PL_ppaddr[type];
3661 logop->op_first = first;
3662 logop->op_flags = (U8)(flags | OPf_KIDS);
3663 logop->op_other = LINKLIST(other);
3664 logop->op_private = (U8)(1 | (flags >> 8));
3666 /* establish postfix order */
3667 logop->op_next = LINKLIST(first);
3668 first->op_next = (OP*)logop;
3669 first->op_sibling = other;
3671 CHECKOP(type,logop);
3673 o = newUNOP(OP_NULL, 0, (OP*)logop);
3680 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3688 return newLOGOP(OP_AND, 0, first, trueop);
3690 return newLOGOP(OP_OR, 0, first, falseop);
3692 scalarboolean(first);
3693 if (first->op_type == OP_CONST) {
3694 if (first->op_private & OPpCONST_BARE &&
3695 first->op_private & OPpCONST_STRICT) {
3696 no_bareword_allowed(first);
3698 if (SvTRUE(((SVOP*)first)->op_sv)) {
3709 NewOp(1101, logop, 1, LOGOP);
3710 logop->op_type = OP_COND_EXPR;
3711 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3712 logop->op_first = first;
3713 logop->op_flags = (U8)(flags | OPf_KIDS);
3714 logop->op_private = (U8)(1 | (flags >> 8));
3715 logop->op_other = LINKLIST(trueop);
3716 logop->op_next = LINKLIST(falseop);
3718 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
3721 /* establish postfix order */
3722 start = LINKLIST(first);
3723 first->op_next = (OP*)logop;
3725 first->op_sibling = trueop;
3726 trueop->op_sibling = falseop;
3727 o = newUNOP(OP_NULL, 0, (OP*)logop);
3729 trueop->op_next = falseop->op_next = o;
3736 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3745 NewOp(1101, range, 1, LOGOP);
3747 range->op_type = OP_RANGE;
3748 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3749 range->op_first = left;
3750 range->op_flags = OPf_KIDS;
3751 leftstart = LINKLIST(left);
3752 range->op_other = LINKLIST(right);
3753 range->op_private = (U8)(1 | (flags >> 8));
3755 left->op_sibling = right;
3757 range->op_next = (OP*)range;
3758 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3759 flop = newUNOP(OP_FLOP, 0, flip);
3760 o = newUNOP(OP_NULL, 0, flop);
3762 range->op_next = leftstart;
3764 left->op_next = flip;
3765 right->op_next = flop;
3767 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3768 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3769 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3770 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3772 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3773 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3776 if (!flip->op_private || !flop->op_private)
3777 linklist(o); /* blow off optimizer unless constant */
3783 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3788 const bool once = block && block->op_flags & OPf_SPECIAL &&
3789 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3791 PERL_UNUSED_ARG(debuggable);
3794 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3795 return block; /* do {} while 0 does once */
3796 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3797 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3798 expr = newUNOP(OP_DEFINED, 0,
3799 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3800 } else if (expr->op_flags & OPf_KIDS) {
3801 const OP * const k1 = ((UNOP*)expr)->op_first;
3802 const OP * const k2 = k1 ? k1->op_sibling : NULL;
3803 switch (expr->op_type) {
3805 if (k2 && k2->op_type == OP_READLINE
3806 && (k2->op_flags & OPf_STACKED)
3807 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3808 expr = newUNOP(OP_DEFINED, 0, expr);
3812 if (k1->op_type == OP_READDIR
3813 || k1->op_type == OP_GLOB
3814 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3815 || k1->op_type == OP_EACH)
3816 expr = newUNOP(OP_DEFINED, 0, expr);
3822 /* if block is null, the next append_elem() would put UNSTACK, a scalar
3823 * op, in listop. This is wrong. [perl #27024] */
3825 block = newOP(OP_NULL, 0);
3826 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3827 o = new_logop(OP_AND, 0, &expr, &listop);
3830 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3832 if (once && o != listop)
3833 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3836 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3838 o->op_flags |= flags;
3840 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3845 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
3846 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
3855 PERL_UNUSED_ARG(debuggable);
3858 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3859 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3860 expr = newUNOP(OP_DEFINED, 0,
3861 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3862 } else if (expr->op_flags & OPf_KIDS) {
3863 const OP * const k1 = ((UNOP*)expr)->op_first;
3864 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
3865 switch (expr->op_type) {
3867 if (k2 && k2->op_type == OP_READLINE
3868 && (k2->op_flags & OPf_STACKED)
3869 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3870 expr = newUNOP(OP_DEFINED, 0, expr);
3874 if (k1->op_type == OP_READDIR
3875 || k1->op_type == OP_GLOB
3876 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3877 || k1->op_type == OP_EACH)
3878 expr = newUNOP(OP_DEFINED, 0, expr);
3885 block = newOP(OP_NULL, 0);
3886 else if (cont || has_my) {
3887 block = scope(block);
3891 next = LINKLIST(cont);
3894 OP * const unstack = newOP(OP_UNSTACK, 0);
3897 cont = append_elem(OP_LINESEQ, cont, unstack);
3900 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3901 redo = LINKLIST(listop);
3904 PL_copline = (line_t)whileline;
3906 o = new_logop(OP_AND, 0, &expr, &listop);
3907 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3908 op_free(expr); /* oops, it's a while (0) */
3910 return NULL; /* listop already freed by new_logop */
3913 ((LISTOP*)listop)->op_last->op_next =
3914 (o == listop ? redo : LINKLIST(o));
3920 NewOp(1101,loop,1,LOOP);
3921 loop->op_type = OP_ENTERLOOP;
3922 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3923 loop->op_private = 0;
3924 loop->op_next = (OP*)loop;
3927 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
3929 loop->op_redoop = redo;
3930 loop->op_lastop = o;
3931 o->op_private |= loopflags;
3934 loop->op_nextop = next;
3936 loop->op_nextop = o;
3938 o->op_flags |= flags;
3939 o->op_private |= (flags >> 8);
3944 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
3949 PADOFFSET padoff = 0;
3954 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
3955 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
3956 sv->op_type = OP_RV2GV;
3957 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
3958 if (cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
3959 iterpflags |= OPpITER_DEF;
3961 else if (sv->op_type == OP_PADSV) { /* private variable */
3962 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
3963 padoff = sv->op_targ;
3968 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
3969 padoff = sv->op_targ;
3971 iterflags |= OPf_SPECIAL;
3976 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
3977 if (padoff && strEQ(PAD_COMPNAME_PV(padoff), "$_"))
3978 iterpflags |= OPpITER_DEF;
3981 const I32 offset = pad_findmy("$_");
3982 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
3983 sv = newGVOP(OP_GV, 0, PL_defgv);
3988 iterpflags |= OPpITER_DEF;
3990 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
3991 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
3992 iterflags |= OPf_STACKED;
3994 else if (expr->op_type == OP_NULL &&
3995 (expr->op_flags & OPf_KIDS) &&
3996 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
3998 /* Basically turn for($x..$y) into the same as for($x,$y), but we
3999 * set the STACKED flag to indicate that these values are to be
4000 * treated as min/max values by 'pp_iterinit'.
4002 UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4003 LOGOP* const range = (LOGOP*) flip->op_first;
4004 OP* const left = range->op_first;
4005 OP* const right = left->op_sibling;
4008 range->op_flags &= ~OPf_KIDS;
4009 range->op_first = NULL;
4011 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4012 listop->op_first->op_next = range->op_next;
4013 left->op_next = range->op_other;
4014 right->op_next = (OP*)listop;
4015 listop->op_next = listop->op_first;
4018 expr = (OP*)(listop);
4020 iterflags |= OPf_STACKED;
4023 expr = mod(force_list(expr), OP_GREPSTART);
4026 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4027 append_elem(OP_LIST, expr, scalar(sv))));
4028 assert(!loop->op_next);
4029 /* for my $x () sets OPpLVAL_INTRO;
4030 * for our $x () sets OPpOUR_INTRO */
4031 loop->op_private = (U8)iterpflags;
4032 #ifdef PL_OP_SLAB_ALLOC
4035 NewOp(1234,tmp,1,LOOP);
4036 Copy(loop,tmp,1,LISTOP);
4041 Renew(loop, 1, LOOP);
4043 loop->op_targ = padoff;
4044 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
4045 PL_copline = forline;
4046 return newSTATEOP(0, label, wop);
4050 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4055 if (type != OP_GOTO || label->op_type == OP_CONST) {
4056 /* "last()" means "last" */
4057 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4058 o = newOP(type, OPf_SPECIAL);
4060 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4061 ? SvPVx_nolen_const(((SVOP*)label)->op_sv)
4067 /* Check whether it's going to be a goto &function */
4068 if (label->op_type == OP_ENTERSUB
4069 && !(label->op_flags & OPf_STACKED))
4070 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4071 o = newUNOP(type, OPf_STACKED, label);
4073 PL_hints |= HINT_BLOCK_SCOPE;
4077 /* if the condition is a literal array or hash
4078 (or @{ ... } etc), make a reference to it.
4081 S_ref_array_or_hash(pTHX_ OP *cond)
4084 && (cond->op_type == OP_RV2AV
4085 || cond->op_type == OP_PADAV
4086 || cond->op_type == OP_RV2HV
4087 || cond->op_type == OP_PADHV))
4089 return newUNOP(OP_REFGEN,
4090 0, mod(cond, OP_REFGEN));
4096 /* These construct the optree fragments representing given()
4099 entergiven and enterwhen are LOGOPs; the op_other pointer
4100 points up to the associated leave op. We need this so we
4101 can put it in the context and make break/continue work.
4102 (Also, of course, pp_enterwhen will jump straight to
4103 op_other if the match fails.)
4108 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
4109 I32 enter_opcode, I32 leave_opcode,
4110 PADOFFSET entertarg)
4116 NewOp(1101, enterop, 1, LOGOP);
4117 enterop->op_type = enter_opcode;
4118 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
4119 enterop->op_flags = (U8) OPf_KIDS;
4120 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
4121 enterop->op_private = 0;
4123 o = newUNOP(leave_opcode, 0, (OP *) enterop);
4126 enterop->op_first = scalar(cond);
4127 cond->op_sibling = block;
4129 o->op_next = LINKLIST(cond);
4130 cond->op_next = (OP *) enterop;
4133 /* This is a default {} block */
4134 enterop->op_first = block;
4135 enterop->op_flags |= OPf_SPECIAL;
4137 o->op_next = (OP *) enterop;
4140 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
4141 entergiven and enterwhen both
4144 enterop->op_next = LINKLIST(block);
4145 block->op_next = enterop->op_other = o;
4150 /* Does this look like a boolean operation? For these purposes
4151 a boolean operation is:
4152 - a subroutine call [*]
4153 - a logical connective
4154 - a comparison operator
4155 - a filetest operator, with the exception of -s -M -A -C
4156 - defined(), exists() or eof()
4157 - /$re/ or $foo =~ /$re/
4159 [*] possibly surprising
4163 S_looks_like_bool(pTHX_ OP *o)
4166 switch(o->op_type) {
4168 return looks_like_bool(cLOGOPo->op_first);
4172 looks_like_bool(cLOGOPo->op_first)
4173 && looks_like_bool(cLOGOPo->op_first->op_sibling));
4177 case OP_NOT: case OP_XOR:
4178 /* Note that OP_DOR is not here */
4180 case OP_EQ: case OP_NE: case OP_LT:
4181 case OP_GT: case OP_LE: case OP_GE:
4183 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
4184 case OP_I_GT: case OP_I_LE: case OP_I_GE:
4186 case OP_SEQ: case OP_SNE: case OP_SLT:
4187 case OP_SGT: case OP_SLE: case OP_SGE:
4191 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
4192 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
4193 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
4194 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
4195 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
4196 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
4197 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
4198 case OP_FTTEXT: case OP_FTBINARY:
4200 case OP_DEFINED: case OP_EXISTS:
4201 case OP_MATCH: case OP_EOF:
4206 /* Detect comparisons that have been optimized away */
4207 if (cSVOPo->op_sv == &PL_sv_yes
4208 || cSVOPo->op_sv == &PL_sv_no)
4219 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
4223 return newGIVWHENOP(
4224 ref_array_or_hash(cond),
4226 OP_ENTERGIVEN, OP_LEAVEGIVEN,
4230 /* If cond is null, this is a default {} block */
4232 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
4234 bool cond_llb = (!cond || looks_like_bool(cond));
4240 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
4242 scalar(ref_array_or_hash(cond)));
4245 return newGIVWHENOP(
4247 append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
4248 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
4252 =for apidoc cv_undef
4254 Clear out all the active components of a CV. This can happen either
4255 by an explicit C<undef &foo>, or by the reference count going to zero.
4256 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
4257 children can still follow the full lexical scope chain.
4263 Perl_cv_undef(pTHX_ CV *cv)
4267 if (CvFILE(cv) && !CvISXSUB(cv)) {
4268 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4269 Safefree(CvFILE(cv));
4274 if (!CvISXSUB(cv) && CvROOT(cv)) {
4275 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
4276 Perl_croak(aTHX_ "Can't undef active subroutine");
4279 PAD_SAVE_SETNULLPAD();
4281 op_free(CvROOT(cv));
4286 SvPOK_off((SV*)cv); /* forget prototype */
4291 /* remove CvOUTSIDE unless this is an undef rather than a free */
4292 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
4293 if (!CvWEAKOUTSIDE(cv))
4294 SvREFCNT_dec(CvOUTSIDE(cv));
4295 CvOUTSIDE(cv) = NULL;
4298 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4301 if (CvISXSUB(cv) && CvXSUB(cv)) {
4304 /* delete all flags except WEAKOUTSIDE */
4305 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
4309 Perl_cv_ckproto(pTHX_ const CV *cv, const GV *gv, const char *p)
4311 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX_const(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4312 SV* const msg = sv_newmortal();
4316 gv_efullname3(name = sv_newmortal(), gv, NULL);
4317 sv_setpv(msg, "Prototype mismatch:");
4319 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4321 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (const SV *)cv);
4323 sv_catpvs(msg, ": none");
4324 sv_catpvs(msg, " vs ");
4326 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4328 sv_catpvs(msg, "none");
4329 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
4333 static void const_sv_xsub(pTHX_ CV* cv);
4337 =head1 Optree Manipulation Functions
4339 =for apidoc cv_const_sv
4341 If C<cv> is a constant sub eligible for inlining. returns the constant
4342 value returned by the sub. Otherwise, returns NULL.
4344 Constant subs can be created with C<newCONSTSUB> or as described in
4345 L<perlsub/"Constant Functions">.
4350 Perl_cv_const_sv(pTHX_ CV *cv)
4352 PERL_UNUSED_CONTEXT;
4355 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
4357 return CvCONST(cv) ? (SV*)CvXSUBANY(cv).any_ptr : NULL;
4360 /* op_const_sv: examine an optree to determine whether it's in-lineable.
4361 * Can be called in 3 ways:
4364 * look for a single OP_CONST with attached value: return the value
4366 * cv && CvCLONE(cv) && !CvCONST(cv)
4368 * examine the clone prototype, and if contains only a single
4369 * OP_CONST referencing a pad const, or a single PADSV referencing
4370 * an outer lexical, return a non-zero value to indicate the CV is
4371 * a candidate for "constizing" at clone time
4375 * We have just cloned an anon prototype that was marked as a const
4376 * candidiate. Try to grab the current value, and in the case of
4377 * PADSV, ignore it if it has multiple references. Return the value.
4381 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
4389 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4390 o = cLISTOPo->op_first->op_sibling;
4392 for (; o; o = o->op_next) {
4393 const OPCODE type = o->op_type;
4395 if (sv && o->op_next == o)
4397 if (o->op_next != o) {
4398 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4400 if (type == OP_DBSTATE)
4403 if (type == OP_LEAVESUB || type == OP_RETURN)
4407 if (type == OP_CONST && cSVOPo->op_sv)
4409 else if (cv && type == OP_CONST) {
4410 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4414 else if (cv && type == OP_PADSV) {
4415 if (CvCONST(cv)) { /* newly cloned anon */
4416 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4417 /* the candidate should have 1 ref from this pad and 1 ref
4418 * from the parent */
4419 if (!sv || SvREFCNT(sv) != 2)
4426 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
4427 sv = &PL_sv_undef; /* an arbitrary non-null value */
4438 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4440 PERL_UNUSED_ARG(floor);
4450 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4454 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4456 return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
4460 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4467 register CV *cv = NULL;
4469 /* If the subroutine has no body, no attributes, and no builtin attributes
4470 then it's just a sub declaration, and we may be able to get away with
4471 storing with a placeholder scalar in the symbol table, rather than a
4472 full GV and CV. If anything is present then it will take a full CV to
4474 const I32 gv_fetch_flags
4475 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
4476 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
4477 const char * const name = o ? SvPVx_nolen_const(cSVOPo->op_sv) : NULL;
4480 assert(proto->op_type == OP_CONST);
4481 ps = SvPVx_const(((SVOP*)proto)->op_sv, ps_len);
4486 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4487 SV * const sv = sv_newmortal();
4488 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4489 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
4490 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4491 aname = SvPVX_const(sv);
4496 gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
4497 : gv_fetchpv(aname ? aname
4498 : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4499 gv_fetch_flags, SVt_PVCV);
4508 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4509 maximum a prototype before. */
4510 if (SvTYPE(gv) > SVt_NULL) {
4511 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4512 && ckWARN_d(WARN_PROTOTYPE))
4514 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
4516 cv_ckproto((CV*)gv, NULL, ps);
4519 sv_setpvn((SV*)gv, ps, ps_len);
4521 sv_setiv((SV*)gv, -1);
4522 SvREFCNT_dec(PL_compcv);
4523 cv = PL_compcv = NULL;
4524 PL_sub_generation++;
4528 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
4530 #ifdef GV_UNIQUE_CHECK
4531 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4532 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4536 if (!block || !ps || *ps || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
4539 const_sv = op_const_sv(block, NULL);
4542 const bool exists = CvROOT(cv) || CvXSUB(cv);
4544 #ifdef GV_UNIQUE_CHECK
4545 if (exists && GvUNIQUE(gv)) {
4546 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4550 /* if the subroutine doesn't exist and wasn't pre-declared
4551 * with a prototype, assume it will be AUTOLOADed,
4552 * skipping the prototype check
4554 if (exists || SvPOK(cv))
4555 cv_ckproto(cv, gv, ps);
4556 /* already defined (or promised)? */
4557 if (exists || GvASSUMECV(gv)) {
4558 if (!block && !attrs) {
4559 if (CvFLAGS(PL_compcv)) {
4560 /* might have had built-in attrs applied */
4561 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4563 /* just a "sub foo;" when &foo is already defined */
4564 SAVEFREESV(PL_compcv);
4568 if (ckWARN(WARN_REDEFINE)
4570 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4572 const line_t oldline = CopLINE(PL_curcop);
4573 if (PL_copline != NOLINE)
4574 CopLINE_set(PL_curcop, PL_copline);
4575 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4576 CvCONST(cv) ? "Constant subroutine %s redefined"
4577 : "Subroutine %s redefined", name);
4578 CopLINE_set(PL_curcop, oldline);
4586 (void)SvREFCNT_inc(const_sv);
4588 assert(!CvROOT(cv) && !CvCONST(cv));
4589 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
4590 CvXSUBANY(cv).any_ptr = const_sv;
4591 CvXSUB(cv) = const_sv_xsub;
4597 cv = newCONSTSUB(NULL, name, const_sv);
4600 SvREFCNT_dec(PL_compcv);
4602 PL_sub_generation++;
4609 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4610 * before we clobber PL_compcv.
4614 /* Might have had built-in attributes applied -- propagate them. */
4615 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4616 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4617 stash = GvSTASH(CvGV(cv));
4618 else if (CvSTASH(cv))
4619 stash = CvSTASH(cv);
4621 stash = PL_curstash;
4624 /* possibly about to re-define existing subr -- ignore old cv */
4625 rcv = (SV*)PL_compcv;
4626 if (name && GvSTASH(gv))
4627 stash = GvSTASH(gv);
4629 stash = PL_curstash;
4631 apply_attrs(stash, rcv, attrs, FALSE);
4633 if (cv) { /* must reuse cv if autoloaded */
4635 /* got here with just attrs -- work done, so bug out */
4636 SAVEFREESV(PL_compcv);
4639 /* transfer PL_compcv to cv */
4641 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4642 if (!CvWEAKOUTSIDE(cv))
4643 SvREFCNT_dec(CvOUTSIDE(cv));
4644 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4645 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
4646 CvOUTSIDE(PL_compcv) = 0;
4647 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4648 CvPADLIST(PL_compcv) = 0;
4649 /* inner references to PL_compcv must be fixed up ... */
4650 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
4651 /* ... before we throw it away */
4652 SvREFCNT_dec(PL_compcv);
4654 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4655 ++PL_sub_generation;
4662 PL_sub_generation++;
4666 CvFILE_set_from_cop(cv, PL_curcop);
4667 CvSTASH(cv) = PL_curstash;
4670 sv_setpvn((SV*)cv, ps, ps_len);
4672 if (PL_error_count) {
4676 const char *s = strrchr(name, ':');
4678 if (strEQ(s, "BEGIN")) {
4679 const char not_safe[] =
4680 "BEGIN not safe after errors--compilation aborted";
4681 if (PL_in_eval & EVAL_KEEPERR)
4682 Perl_croak(aTHX_ not_safe);
4684 /* force display of errors found but not reported */
4685 sv_catpv(ERRSV, not_safe);
4686 Perl_croak(aTHX_ "%"SVf, ERRSV);
4695 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4696 mod(scalarseq(block), OP_LEAVESUBLV));
4699 /* This makes sub {}; work as expected. */
4700 if (block->op_type == OP_STUB) {
4702 block = newSTATEOP(0, NULL, 0);
4704 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4706 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4707 OpREFCNT_set(CvROOT(cv), 1);
4708 CvSTART(cv) = LINKLIST(CvROOT(cv));
4709 CvROOT(cv)->op_next = 0;
4710 CALL_PEEP(CvSTART(cv));
4712 /* now that optimizer has done its work, adjust pad values */
4714 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4717 assert(!CvCONST(cv));
4718 if (ps && !*ps && op_const_sv(block, cv))
4722 if (name || aname) {
4724 const char * const tname = (name ? name : aname);
4726 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4727 SV * const sv = newSV(0);
4728 SV * const tmpstr = sv_newmortal();
4729 GV * const db_postponed = gv_fetchpvs("DB::postponed",
4730 GV_ADDMULTI, SVt_PVHV);
4733 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4735 (long)PL_subline, (long)CopLINE(PL_curcop));
4736 gv_efullname3(tmpstr, gv, NULL);
4737 hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0);
4738 hv = GvHVn(db_postponed);
4739 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
4740 CV * const pcv = GvCV(db_postponed);
4746 call_sv((SV*)pcv, G_DISCARD);
4751 if ((s = strrchr(tname,':')))
4756 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4759 if (strEQ(s, "BEGIN") && !PL_error_count) {
4760 const I32 oldscope = PL_scopestack_ix;
4762 SAVECOPFILE(&PL_compiling);
4763 SAVECOPLINE(&PL_compiling);
4766 PL_beginav = newAV();
4767 DEBUG_x( dump_sub(gv) );
4768 av_push(PL_beginav, (SV*)cv);
4769 GvCV(gv) = 0; /* cv has been hijacked */
4770 call_list(oldscope, PL_beginav);
4772 PL_curcop = &PL_compiling;
4773 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4776 else if (strEQ(s, "END") && !PL_error_count) {
4779 DEBUG_x( dump_sub(gv) );
4780 av_unshift(PL_endav, 1);
4781 av_store(PL_endav, 0, (SV*)cv);
4782 GvCV(gv) = 0; /* cv has been hijacked */
4784 else if (strEQ(s, "CHECK") && !PL_error_count) {
4786 PL_checkav = newAV();
4787 DEBUG_x( dump_sub(gv) );
4788 if (PL_main_start && ckWARN(WARN_VOID))
4789 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4790 av_unshift(PL_checkav, 1);
4791 av_store(PL_checkav, 0, (SV*)cv);
4792 GvCV(gv) = 0; /* cv has been hijacked */
4794 else if (strEQ(s, "INIT") && !PL_error_count) {
4796 PL_initav = newAV();
4797 DEBUG_x( dump_sub(gv) );
4798 if (PL_main_start && ckWARN(WARN_VOID))
4799 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4800 av_push(PL_initav, (SV*)cv);
4801 GvCV(gv) = 0; /* cv has been hijacked */
4806 PL_copline = NOLINE;
4811 /* XXX unsafe for threads if eval_owner isn't held */
4813 =for apidoc newCONSTSUB
4815 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4816 eligible for inlining at compile-time.
4822 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
4829 SAVECOPLINE(PL_curcop);
4830 CopLINE_set(PL_curcop, PL_copline);
4833 PL_hints &= ~HINT_BLOCK_SCOPE;
4836 SAVESPTR(PL_curstash);
4837 SAVECOPSTASH(PL_curcop);
4838 PL_curstash = stash;
4839 CopSTASH_set(PL_curcop,stash);
4842 cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
4843 CvXSUBANY(cv).any_ptr = sv;
4845 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
4849 CopSTASH_free(PL_curcop);
4857 =for apidoc U||newXS
4859 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4865 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
4868 GV * const gv = gv_fetchpv(name ? name :
4869 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4870 GV_ADDMULTI, SVt_PVCV);
4874 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4876 if ((cv = (name ? GvCV(gv) : NULL))) {
4878 /* just a cached method */
4882 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4883 /* already defined (or promised) */
4884 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
4885 if (ckWARN(WARN_REDEFINE)) {
4886 GV * const gvcv = CvGV(cv);
4888 HV * const stash = GvSTASH(gvcv);
4890 const char *redefined_name = HvNAME_get(stash);
4891 if ( strEQ(redefined_name,"autouse") ) {
4892 const line_t oldline = CopLINE(PL_curcop);
4893 if (PL_copline != NOLINE)
4894 CopLINE_set(PL_curcop, PL_copline);
4895 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4896 CvCONST(cv) ? "Constant subroutine %s redefined"
4897 : "Subroutine %s redefined"
4899 CopLINE_set(PL_curcop, oldline);
4909 if (cv) /* must reuse cv if autoloaded */
4913 sv_upgrade((SV *)cv, SVt_PVCV);
4917 PL_sub_generation++;
4921 (void)gv_fetchfile(filename);
4922 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
4923 an external constant string */
4925 CvXSUB(cv) = subaddr;
4928 const char *s = strrchr(name,':');
4934 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4937 if (strEQ(s, "BEGIN")) {
4939 PL_beginav = newAV();
4940 av_push(PL_beginav, (SV*)cv);
4941 GvCV(gv) = 0; /* cv has been hijacked */
4943 else if (strEQ(s, "END")) {
4946 av_unshift(PL_endav, 1);
4947 av_store(PL_endav, 0, (SV*)cv);
4948 GvCV(gv) = 0; /* cv has been hijacked */
4950 else if (strEQ(s, "CHECK")) {
4952 PL_checkav = newAV();
4953 if (PL_main_start && ckWARN(WARN_VOID))
4954 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4955 av_unshift(PL_checkav, 1);
4956 av_store(PL_checkav, 0, (SV*)cv);
4957 GvCV(gv) = 0; /* cv has been hijacked */
4959 else if (strEQ(s, "INIT")) {
4961 PL_initav = newAV();
4962 if (PL_main_start && ckWARN(WARN_VOID))
4963 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4964 av_push(PL_initav, (SV*)cv);
4965 GvCV(gv) = 0; /* cv has been hijacked */
4976 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4982 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
4983 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
4985 #ifdef GV_UNIQUE_CHECK
4987 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
4991 if ((cv = GvFORM(gv))) {
4992 if (ckWARN(WARN_REDEFINE)) {
4993 const line_t oldline = CopLINE(PL_curcop);
4994 if (PL_copline != NOLINE)
4995 CopLINE_set(PL_curcop, PL_copline);
4996 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4997 o ? "Format %"SVf" redefined"
4998 : "Format STDOUT redefined" ,cSVOPo->op_sv);
4999 CopLINE_set(PL_curcop, oldline);
5006 CvFILE_set_from_cop(cv, PL_curcop);
5009 pad_tidy(padtidy_FORMAT);
5010 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5011 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5012 OpREFCNT_set(CvROOT(cv), 1);
5013 CvSTART(cv) = LINKLIST(CvROOT(cv));
5014 CvROOT(cv)->op_next = 0;
5015 CALL_PEEP(CvSTART(cv));
5017 PL_copline = NOLINE;
5022 Perl_newANONLIST(pTHX_ OP *o)
5024 return newUNOP(OP_REFGEN, 0,
5025 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5029 Perl_newANONHASH(pTHX_ OP *o)
5031 return newUNOP(OP_REFGEN, 0,
5032 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5036 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5038 return newANONATTRSUB(floor, proto, NULL, block);
5042 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5044 return newUNOP(OP_REFGEN, 0,
5045 newSVOP(OP_ANONCODE, 0,
5046 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5050 Perl_oopsAV(pTHX_ OP *o)
5053 switch (o->op_type) {
5055 o->op_type = OP_PADAV;
5056 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5057 return ref(o, OP_RV2AV);
5060 o->op_type = OP_RV2AV;
5061 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5066 if (ckWARN_d(WARN_INTERNAL))
5067 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
5074 Perl_oopsHV(pTHX_ OP *o)
5077 switch (o->op_type) {
5080 o->op_type = OP_PADHV;
5081 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5082 return ref(o, OP_RV2HV);
5086 o->op_type = OP_RV2HV;
5087 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5092 if (ckWARN_d(WARN_INTERNAL))
5093 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
5100 Perl_newAVREF(pTHX_ OP *o)
5103 if (o->op_type == OP_PADANY) {
5104 o->op_type = OP_PADAV;
5105 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5108 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5109 && ckWARN(WARN_DEPRECATED)) {
5110 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5111 "Using an array as a reference is deprecated");
5113 return newUNOP(OP_RV2AV, 0, scalar(o));
5117 Perl_newGVREF(pTHX_ I32 type, OP *o)
5119 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5120 return newUNOP(OP_NULL, 0, o);
5121 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5125 Perl_newHVREF(pTHX_ OP *o)
5128 if (o->op_type == OP_PADANY) {
5129 o->op_type = OP_PADHV;
5130 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5133 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5134 && ckWARN(WARN_DEPRECATED)) {
5135 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5136 "Using a hash as a reference is deprecated");
5138 return newUNOP(OP_RV2HV, 0, scalar(o));
5142 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5144 return newUNOP(OP_RV2CV, flags, scalar(o));
5148 Perl_newSVREF(pTHX_ OP *o)
5151 if (o->op_type == OP_PADANY) {
5152 o->op_type = OP_PADSV;
5153 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5156 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5157 o->op_flags |= OPpDONE_SVREF;
5160 return newUNOP(OP_RV2SV, 0, scalar(o));
5163 /* Check routines. See the comments at the top of this file for details
5164 * on when these are called */
5167 Perl_ck_anoncode(pTHX_ OP *o)
5169 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
5170 cSVOPo->op_sv = NULL;
5175 Perl_ck_bitop(pTHX_ OP *o)
5178 #define OP_IS_NUMCOMPARE(op) \
5179 ((op) == OP_LT || (op) == OP_I_LT || \
5180 (op) == OP_GT || (op) == OP_I_GT || \
5181 (op) == OP_LE || (op) == OP_I_LE || \
5182 (op) == OP_GE || (op) == OP_I_GE || \
5183 (op) == OP_EQ || (op) == OP_I_EQ || \
5184 (op) == OP_NE || (op) == OP_I_NE || \
5185 (op) == OP_NCMP || (op) == OP_I_NCMP)
5186 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
5187 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
5188 && (o->op_type == OP_BIT_OR
5189 || o->op_type == OP_BIT_AND
5190 || o->op_type == OP_BIT_XOR))
5192 const OP * const left = cBINOPo->op_first;
5193 const OP * const right = left->op_sibling;
5194 if ((OP_IS_NUMCOMPARE(left->op_type) &&
5195 (left->op_flags & OPf_PARENS) == 0) ||
5196 (OP_IS_NUMCOMPARE(right->op_type) &&
5197 (right->op_flags & OPf_PARENS) == 0))
5198 if (ckWARN(WARN_PRECEDENCE))
5199 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
5200 "Possible precedence problem on bitwise %c operator",
5201 o->op_type == OP_BIT_OR ? '|'
5202 : o->op_type == OP_BIT_AND ? '&' : '^'
5209 Perl_ck_concat(pTHX_ OP *o)
5211 const OP * const kid = cUNOPo->op_first;
5212 PERL_UNUSED_CONTEXT;
5213 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
5214 !(kUNOP->op_first->op_flags & OPf_MOD))
5215 o->op_flags |= OPf_STACKED;
5220 Perl_ck_spair(pTHX_ OP *o)
5223 if (o->op_flags & OPf_KIDS) {
5226 const OPCODE type = o->op_type;
5227 o = modkids(ck_fun(o), type);
5228 kid = cUNOPo->op_first;
5229 newop = kUNOP->op_first->op_sibling;
5231 (newop->op_sibling ||
5232 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5233 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5234 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5238 op_free(kUNOP->op_first);
5239 kUNOP->op_first = newop;
5241 o->op_ppaddr = PL_ppaddr[++o->op_type];
5246 Perl_ck_delete(pTHX_ OP *o)
5250 if (o->op_flags & OPf_KIDS) {
5251 OP * const kid = cUNOPo->op_first;
5252 switch (kid->op_type) {
5254 o->op_flags |= OPf_SPECIAL;
5257 o->op_private |= OPpSLICE;
5260 o->op_flags |= OPf_SPECIAL;
5265 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5274 Perl_ck_die(pTHX_ OP *o)
5277 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5283 Perl_ck_eof(pTHX_ OP *o)
5286 const I32 type = o->op_type;
5288 if (o->op_flags & OPf_KIDS) {
5289 if (cLISTOPo->op_first->op_type == OP_STUB) {
5291 o = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
5299 Perl_ck_eval(pTHX_ OP *o)
5302 PL_hints |= HINT_BLOCK_SCOPE;
5303 if (o->op_flags & OPf_KIDS) {
5304 SVOP * const kid = (SVOP*)cUNOPo->op_first;
5307 o->op_flags &= ~OPf_KIDS;
5310 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
5313 cUNOPo->op_first = 0;
5316 NewOp(1101, enter, 1, LOGOP);
5317 enter->op_type = OP_ENTERTRY;
5318 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5319 enter->op_private = 0;
5321 /* establish postfix order */
5322 enter->op_next = (OP*)enter;
5324 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5325 o->op_type = OP_LEAVETRY;
5326 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5327 enter->op_other = o;
5337 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5339 o->op_targ = (PADOFFSET)PL_hints;
5340 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
5341 /* Store a copy of %^H that pp_entereval can pick up */
5342 OP *hhop = newSVOP(OP_CONST, 0, (SV*)newHVhv(GvHV(PL_hintgv)));
5343 cUNOPo->op_first->op_sibling = hhop;
5344 o->op_private |= OPpEVAL_HAS_HH;
5350 Perl_ck_exit(pTHX_ OP *o)
5353 HV * const table = GvHV(PL_hintgv);
5355 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
5356 if (svp && *svp && SvTRUE(*svp))
5357 o->op_private |= OPpEXIT_VMSISH;
5359 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5365 Perl_ck_exec(pTHX_ OP *o)
5367 if (o->op_flags & OPf_STACKED) {
5370 kid = cUNOPo->op_first->op_sibling;
5371 if (kid->op_type == OP_RV2GV)
5380 Perl_ck_exists(pTHX_ OP *o)
5384 if (o->op_flags & OPf_KIDS) {
5385 OP * const kid = cUNOPo->op_first;
5386 if (kid->op_type == OP_ENTERSUB) {
5387 (void) ref(kid, o->op_type);
5388 if (kid->op_type != OP_RV2CV && !PL_error_count)
5389 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5391 o->op_private |= OPpEXISTS_SUB;
5393 else if (kid->op_type == OP_AELEM)
5394 o->op_flags |= OPf_SPECIAL;
5395 else if (kid->op_type != OP_HELEM)
5396 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5404 Perl_ck_rvconst(pTHX_ register OP *o)
5407 SVOP * const kid = (SVOP*)cUNOPo->op_first;
5409 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5410 if (o->op_type == OP_RV2CV)
5411 o->op_private &= ~1;
5413 if (kid->op_type == OP_CONST) {
5416 SV * const kidsv = kid->op_sv;
5418 /* Is it a constant from cv_const_sv()? */
5419 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5420 SV * const rsv = SvRV(kidsv);
5421 const int svtype = SvTYPE(rsv);
5422 const char *badtype = NULL;
5424 switch (o->op_type) {
5426 if (svtype > SVt_PVMG)
5427 badtype = "a SCALAR";
5430 if (svtype != SVt_PVAV)
5431 badtype = "an ARRAY";
5434 if (svtype != SVt_PVHV)
5438 if (svtype != SVt_PVCV)
5443 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5446 else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
5447 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
5448 /* If this is an access to a stash, disable "strict refs", because
5449 * stashes aren't auto-vivified at compile-time (unless we store
5450 * symbols in them), and we don't want to produce a run-time
5451 * stricture error when auto-vivifying the stash. */
5452 const char *s = SvPV_nolen(kidsv);
5453 const STRLEN l = SvCUR(kidsv);
5454 if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
5455 o->op_private &= ~HINT_STRICT_REFS;
5457 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5458 const char *badthing;
5459 switch (o->op_type) {
5461 badthing = "a SCALAR";
5464 badthing = "an ARRAY";
5467 badthing = "a HASH";
5475 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
5479 * This is a little tricky. We only want to add the symbol if we
5480 * didn't add it in the lexer. Otherwise we get duplicate strict
5481 * warnings. But if we didn't add it in the lexer, we must at
5482 * least pretend like we wanted to add it even if it existed before,
5483 * or we get possible typo warnings. OPpCONST_ENTERED says
5484 * whether the lexer already added THIS instance of this symbol.
5486 iscv = (o->op_type == OP_RV2CV) * 2;
5488 gv = gv_fetchsv(kidsv,
5489 iscv | !(kid->op_private & OPpCONST_ENTERED),
5492 : o->op_type == OP_RV2SV
5494 : o->op_type == OP_RV2AV
5496 : o->op_type == OP_RV2HV
5499 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5501 kid->op_type = OP_GV;
5502 SvREFCNT_dec(kid->op_sv);
5504 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5505 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5506 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
5508 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv));
5510 kid->op_sv = SvREFCNT_inc(gv);
5512 kid->op_private = 0;
5513 kid->op_ppaddr = PL_ppaddr[OP_GV];
5520 Perl_ck_ftst(pTHX_ OP *o)
5523 const I32 type = o->op_type;
5525 if (o->op_flags & OPf_REF) {
5528 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5529 SVOP * const kid = (SVOP*)cUNOPo->op_first;
5531 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5532 OP * const newop = newGVOP(type, OPf_REF,
5533 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
5539 if ((PL_hints & HINT_FILETEST_ACCESS) &&
5540 OP_IS_FILETEST_ACCESS(o))
5541 o->op_private |= OPpFT_ACCESS;
5543 if (PL_check[kid->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst)
5544 && kid->op_type != OP_STAT && kid->op_type != OP_LSTAT)
5545 o->op_private |= OPpFT_STACKED;
5549 if (type == OP_FTTTY)
5550 o = newGVOP(type, OPf_REF, PL_stdingv);
5552 o = newUNOP(type, 0, newDEFSVOP());
5558 Perl_ck_fun(pTHX_ OP *o)
5561 const int type = o->op_type;
5562 register I32 oa = PL_opargs[type] >> OASHIFT;
5564 if (o->op_flags & OPf_STACKED) {
5565 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5568 return no_fh_allowed(o);
5571 if (o->op_flags & OPf_KIDS) {
5572 OP **tokid = &cLISTOPo->op_first;
5573 register OP *kid = cLISTOPo->op_first;
5577 if (kid->op_type == OP_PUSHMARK ||
5578 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5580 tokid = &kid->op_sibling;
5581 kid = kid->op_sibling;
5583 if (!kid && PL_opargs[type] & OA_DEFGV)
5584 *tokid = kid = newDEFSVOP();
5588 sibl = kid->op_sibling;
5591 /* list seen where single (scalar) arg expected? */
5592 if (numargs == 1 && !(oa >> 4)
5593 && kid->op_type == OP_LIST && type != OP_SCALAR)
5595 return too_many_arguments(o,PL_op_desc[type]);
5608 if ((type == OP_PUSH || type == OP_UNSHIFT)
5609 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5610 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5611 "Useless use of %s with no values",
5614 if (kid->op_type == OP_CONST &&
5615 (kid->op_private & OPpCONST_BARE))
5617 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
5618 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
5619 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5620 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5621 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
5622 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
5625 kid->op_sibling = sibl;
5628 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5629 bad_type(numargs, "array", PL_op_desc[type], kid);
5633 if (kid->op_type == OP_CONST &&
5634 (kid->op_private & OPpCONST_BARE))
5636 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
5637 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
5638 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5639 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5640 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
5641 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
5644 kid->op_sibling = sibl;
5647 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5648 bad_type(numargs, "hash", PL_op_desc[type], kid);
5653 OP * const newop = newUNOP(OP_NULL, 0, kid);
5654 kid->op_sibling = 0;
5656 newop->op_next = newop;
5658 kid->op_sibling = sibl;
5663 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5664 if (kid->op_type == OP_CONST &&
5665 (kid->op_private & OPpCONST_BARE))
5667 OP * const newop = newGVOP(OP_GV, 0,
5668 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
5669 if (!(o->op_private & 1) && /* if not unop */
5670 kid == cLISTOPo->op_last)
5671 cLISTOPo->op_last = newop;
5675 else if (kid->op_type == OP_READLINE) {
5676 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5677 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5680 I32 flags = OPf_SPECIAL;
5684 /* is this op a FH constructor? */
5685 if (is_handle_constructor(o,numargs)) {
5686 const char *name = NULL;
5690 /* Set a flag to tell rv2gv to vivify
5691 * need to "prove" flag does not mean something
5692 * else already - NI-S 1999/05/07
5695 if (kid->op_type == OP_PADSV) {
5696 name = PAD_COMPNAME_PV(kid->op_targ);
5697 /* SvCUR of a pad namesv can't be trusted
5698 * (see PL_generation), so calc its length
5704 else if (kid->op_type == OP_RV2SV
5705 && kUNOP->op_first->op_type == OP_GV)
5707 GV * const gv = cGVOPx_gv(kUNOP->op_first);
5709 len = GvNAMELEN(gv);
5711 else if (kid->op_type == OP_AELEM
5712 || kid->op_type == OP_HELEM)
5714 OP *op = ((BINOP*)kid)->op_first;
5718 const char * const a =
5719 kid->op_type == OP_AELEM ?
5721 if (((op->op_type == OP_RV2AV) ||
5722 (op->op_type == OP_RV2HV)) &&
5723 (op = ((UNOP*)op)->op_first) &&
5724 (op->op_type == OP_GV)) {
5725 /* packagevar $a[] or $h{} */
5726 GV * const gv = cGVOPx_gv(op);
5734 else if (op->op_type == OP_PADAV
5735 || op->op_type == OP_PADHV) {
5736 /* lexicalvar $a[] or $h{} */
5737 const char * const padname =
5738 PAD_COMPNAME_PV(op->op_targ);
5747 name = SvPV_const(tmpstr, len);
5752 name = "__ANONIO__";
5759 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5760 namesv = PAD_SVl(targ);
5761 SvUPGRADE(namesv, SVt_PV);
5763 sv_setpvn(namesv, "$", 1);
5764 sv_catpvn(namesv, name, len);
5767 kid->op_sibling = 0;
5768 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5769 kid->op_targ = targ;
5770 kid->op_private |= priv;
5772 kid->op_sibling = sibl;
5778 mod(scalar(kid), type);
5782 tokid = &kid->op_sibling;
5783 kid = kid->op_sibling;
5785 o->op_private |= numargs;
5787 return too_many_arguments(o,OP_DESC(o));
5790 else if (PL_opargs[type] & OA_DEFGV) {
5792 return newUNOP(type, 0, newDEFSVOP());
5796 while (oa & OA_OPTIONAL)
5798 if (oa && oa != OA_LIST)
5799 return too_few_arguments(o,OP_DESC(o));
5805 Perl_ck_glob(pTHX_ OP *o)
5811 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5812 append_elem(OP_GLOB, o, newDEFSVOP());
5814 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
5815 && GvCVu(gv) && GvIMPORTED_CV(gv)))
5817 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
5820 #if !defined(PERL_EXTERNAL_GLOB)
5821 /* XXX this can be tightened up and made more failsafe. */
5822 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
5825 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5826 newSVpvs("File::Glob"), NULL, NULL, NULL);
5827 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
5828 glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
5829 GvCV(gv) = GvCV(glob_gv);
5830 (void)SvREFCNT_inc((SV*)GvCV(gv));
5831 GvIMPORTED_CV_on(gv);
5834 #endif /* PERL_EXTERNAL_GLOB */
5836 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5837 append_elem(OP_GLOB, o,
5838 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5839 o->op_type = OP_LIST;
5840 o->op_ppaddr = PL_ppaddr[OP_LIST];
5841 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5842 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5843 cLISTOPo->op_first->op_targ = 0;
5844 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5845 append_elem(OP_LIST, o,
5846 scalar(newUNOP(OP_RV2CV, 0,
5847 newGVOP(OP_GV, 0, gv)))));
5848 o = newUNOP(OP_NULL, 0, ck_subr(o));
5849 o->op_targ = OP_GLOB; /* hint at what it used to be */
5852 gv = newGVgen("main");
5854 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5860 Perl_ck_grep(pTHX_ OP *o)
5865 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5868 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5869 NewOp(1101, gwop, 1, LOGOP);
5871 if (o->op_flags & OPf_STACKED) {
5874 kid = cLISTOPo->op_first->op_sibling;
5875 if (!cUNOPx(kid)->op_next)
5876 Perl_croak(aTHX_ "panic: ck_grep");
5877 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
5880 kid->op_next = (OP*)gwop;
5881 o->op_flags &= ~OPf_STACKED;
5883 kid = cLISTOPo->op_first->op_sibling;
5884 if (type == OP_MAPWHILE)
5891 kid = cLISTOPo->op_first->op_sibling;
5892 if (kid->op_type != OP_NULL)
5893 Perl_croak(aTHX_ "panic: ck_grep");
5894 kid = kUNOP->op_first;
5896 gwop->op_type = type;
5897 gwop->op_ppaddr = PL_ppaddr[type];
5898 gwop->op_first = listkids(o);
5899 gwop->op_flags |= OPf_KIDS;
5900 gwop->op_other = LINKLIST(kid);
5901 kid->op_next = (OP*)gwop;
5902 offset = pad_findmy("$_");
5903 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
5904 o->op_private = gwop->op_private = 0;
5905 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5908 o->op_private = gwop->op_private = OPpGREP_LEX;
5909 gwop->op_targ = o->op_targ = offset;
5912 kid = cLISTOPo->op_first->op_sibling;
5913 if (!kid || !kid->op_sibling)
5914 return too_few_arguments(o,OP_DESC(o));
5915 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5916 mod(kid, OP_GREPSTART);
5922 Perl_ck_index(pTHX_ OP *o)
5924 if (o->op_flags & OPf_KIDS) {
5925 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5927 kid = kid->op_sibling; /* get past "big" */
5928 if (kid && kid->op_type == OP_CONST)
5929 fbm_compile(((SVOP*)kid)->op_sv, 0);
5935 Perl_ck_lengthconst(pTHX_ OP *o)
5937 /* XXX length optimization goes here */
5942 Perl_ck_lfun(pTHX_ OP *o)
5944 const OPCODE type = o->op_type;
5945 return modkids(ck_fun(o), type);
5949 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5951 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
5952 switch (cUNOPo->op_first->op_type) {
5954 /* This is needed for
5955 if (defined %stash::)
5956 to work. Do not break Tk.
5958 break; /* Globals via GV can be undef */
5960 case OP_AASSIGN: /* Is this a good idea? */
5961 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5962 "defined(@array) is deprecated");
5963 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5964 "\t(Maybe you should just omit the defined()?)\n");
5967 /* This is needed for
5968 if (defined %stash::)
5969 to work. Do not break Tk.
5971 break; /* Globals via GV can be undef */
5973 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5974 "defined(%%hash) is deprecated");
5975 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5976 "\t(Maybe you should just omit the defined()?)\n");
5987 Perl_ck_rfun(pTHX_ OP *o)
5989 const OPCODE type = o->op_type;
5990 return refkids(ck_fun(o), type);
5994 Perl_ck_listiob(pTHX_ OP *o)
5998 kid = cLISTOPo->op_first;
6001 kid = cLISTOPo->op_first;
6003 if (kid->op_type == OP_PUSHMARK)
6004 kid = kid->op_sibling;
6005 if (kid && o->op_flags & OPf_STACKED)
6006 kid = kid->op_sibling;
6007 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6008 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6009 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6010 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6011 cLISTOPo->op_first->op_sibling = kid;
6012 cLISTOPo->op_last = kid;
6013 kid = kid->op_sibling;
6018 append_elem(o->op_type, o, newDEFSVOP());
6024 Perl_ck_say(pTHX_ OP *o)
6027 o->op_type = OP_PRINT;
6028 cLISTOPo->op_last = cLISTOPo->op_last->op_sibling
6029 = newSVOP(OP_CONST, 0, newSVpvs("\n"));
6034 Perl_ck_smartmatch(pTHX_ OP *o)
6037 if (0 == (o->op_flags & OPf_SPECIAL)) {
6038 OP *first = cBINOPo->op_first;
6039 OP *second = first->op_sibling;
6041 /* Implicitly take a reference to an array or hash */
6042 first->op_sibling = NULL;
6043 first = cBINOPo->op_first = ref_array_or_hash(first);
6044 second = first->op_sibling = ref_array_or_hash(second);
6046 /* Implicitly take a reference to a regular expression */
6047 if (first->op_type == OP_MATCH) {
6048 first->op_type = OP_QR;
6049 first->op_ppaddr = PL_ppaddr[OP_QR];
6051 if (second->op_type == OP_MATCH) {
6052 second->op_type = OP_QR;
6053 second->op_ppaddr = PL_ppaddr[OP_QR];
6062 Perl_ck_sassign(pTHX_ OP *o)
6064 OP *kid = cLISTOPo->op_first;
6065 /* has a disposable target? */
6066 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6067 && !(kid->op_flags & OPf_STACKED)
6068 /* Cannot steal the second time! */
6069 && !(kid->op_private & OPpTARGET_MY))
6071 OP * const kkid = kid->op_sibling;
6073 /* Can just relocate the target. */
6074 if (kkid && kkid->op_type == OP_PADSV
6075 && !(kkid->op_private & OPpLVAL_INTRO))
6077 kid->op_targ = kkid->op_targ;
6079 /* Now we do not need PADSV and SASSIGN. */
6080 kid->op_sibling = o->op_sibling; /* NULL */
6081 cLISTOPo->op_first = NULL;
6084 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6092 Perl_ck_match(pTHX_ OP *o)
6095 if (o->op_type != OP_QR && PL_compcv) {
6096 const I32 offset = pad_findmy("$_");
6097 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
6098 o->op_targ = offset;
6099 o->op_private |= OPpTARGET_MY;
6102 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
6103 o->op_private |= OPpRUNTIME;
6108 Perl_ck_method(pTHX_ OP *o)
6110 OP * const kid = cUNOPo->op_first;
6111 if (kid->op_type == OP_CONST) {
6112 SV* sv = kSVOP->op_sv;
6113 const char * const method = SvPVX_const(sv);
6114 if (!(strchr(method, ':') || strchr(method, '\''))) {
6116 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6117 sv = newSVpvn_share(method, SvCUR(sv), 0);
6120 kSVOP->op_sv = NULL;
6122 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6131 Perl_ck_null(pTHX_ OP *o)
6133 PERL_UNUSED_CONTEXT;
6138 Perl_ck_open(pTHX_ OP *o)
6141 HV * const table = GvHV(PL_hintgv);
6143 SV **svp = hv_fetchs(table, "open_IN", FALSE);
6145 const I32 mode = mode_from_discipline(*svp);
6146 if (mode & O_BINARY)
6147 o->op_private |= OPpOPEN_IN_RAW;
6148 else if (mode & O_TEXT)
6149 o->op_private |= OPpOPEN_IN_CRLF;
6152 svp = hv_fetchs(table, "open_OUT", FALSE);
6154 const I32 mode = mode_from_discipline(*svp);
6155 if (mode & O_BINARY)
6156 o->op_private |= OPpOPEN_OUT_RAW;
6157 else if (mode & O_TEXT)
6158 o->op_private |= OPpOPEN_OUT_CRLF;
6161 if (o->op_type == OP_BACKTICK)
6164 /* In case of three-arg dup open remove strictness
6165 * from the last arg if it is a bareword. */
6166 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
6167 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
6171 if ((last->op_type == OP_CONST) && /* The bareword. */
6172 (last->op_private & OPpCONST_BARE) &&
6173 (last->op_private & OPpCONST_STRICT) &&
6174 (oa = first->op_sibling) && /* The fh. */
6175 (oa = oa->op_sibling) && /* The mode. */
6176 (oa->op_type == OP_CONST) &&
6177 SvPOK(((SVOP*)oa)->op_sv) &&
6178 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
6179 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
6180 (last == oa->op_sibling)) /* The bareword. */
6181 last->op_private &= ~OPpCONST_STRICT;
6187 Perl_ck_repeat(pTHX_ OP *o)
6189 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6190 o->op_private |= OPpREPEAT_DOLIST;
6191 cBINOPo->op_first = force_list(cBINOPo->op_first);
6199 Perl_ck_require(pTHX_ OP *o)
6204 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6205 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6207 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6208 SV * const sv = kid->op_sv;
6209 U32 was_readonly = SvREADONLY(sv);
6214 sv_force_normal_flags(sv, 0);
6215 assert(!SvREADONLY(sv));
6222 for (s = SvPVX(sv); *s; s++) {
6223 if (*s == ':' && s[1] == ':') {
6224 const STRLEN len = strlen(s+2)+1;
6226 Move(s+2, s+1, len, char);
6227 SvCUR_set(sv, SvCUR(sv) - 1);
6230 sv_catpvs(sv, ".pm");
6231 SvFLAGS(sv) |= was_readonly;
6235 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
6236 /* handle override, if any */
6237 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
6238 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
6239 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
6240 gv = gvp ? *gvp : NULL;
6244 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6245 OP * const kid = cUNOPo->op_first;
6246 cUNOPo->op_first = 0;
6248 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
6249 append_elem(OP_LIST, kid,
6250 scalar(newUNOP(OP_RV2CV, 0,
6259 Perl_ck_return(pTHX_ OP *o)
6262 if (CvLVALUE(PL_compcv)) {
6264 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6265 mod(kid, OP_LEAVESUBLV);
6271 Perl_ck_select(pTHX_ OP *o)
6275 if (o->op_flags & OPf_KIDS) {
6276 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6277 if (kid && kid->op_sibling) {
6278 o->op_type = OP_SSELECT;
6279 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6281 return fold_constants(o);
6285 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6286 if (kid && kid->op_type == OP_RV2GV)
6287 kid->op_private &= ~HINT_STRICT_REFS;
6292 Perl_ck_shift(pTHX_ OP *o)
6295 const I32 type = o->op_type;
6297 if (!(o->op_flags & OPf_KIDS)) {
6301 argop = newUNOP(OP_RV2AV, 0,
6302 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
6303 return newUNOP(type, 0, scalar(argop));
6305 return scalar(modkids(ck_fun(o), type));
6309 Perl_ck_sort(pTHX_ OP *o)
6314 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0)
6316 HV * const hinthv = GvHV(PL_hintgv);
6318 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
6320 const I32 sorthints = (I32)SvIV(*svp);
6321 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
6322 o->op_private |= OPpSORT_QSORT;
6323 if ((sorthints & HINT_SORT_STABLE) != 0)
6324 o->op_private |= OPpSORT_STABLE;
6329 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6331 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6332 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6334 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6336 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6338 if (kid->op_type == OP_SCOPE) {
6342 else if (kid->op_type == OP_LEAVE) {
6343 if (o->op_type == OP_SORT) {
6344 op_null(kid); /* wipe out leave */
6347 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6348 if (k->op_next == kid)
6350 /* don't descend into loops */
6351 else if (k->op_type == OP_ENTERLOOP
6352 || k->op_type == OP_ENTERITER)
6354 k = cLOOPx(k)->op_lastop;
6359 kid->op_next = 0; /* just disconnect the leave */
6360 k = kLISTOP->op_first;
6365 if (o->op_type == OP_SORT) {
6366 /* provide scalar context for comparison function/block */
6372 o->op_flags |= OPf_SPECIAL;
6374 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6377 firstkid = firstkid->op_sibling;
6380 /* provide list context for arguments */
6381 if (o->op_type == OP_SORT)
6388 S_simplify_sort(pTHX_ OP *o)
6391 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6396 if (!(o->op_flags & OPf_STACKED))
6398 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
6399 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
6400 kid = kUNOP->op_first; /* get past null */
6401 if (kid->op_type != OP_SCOPE)
6403 kid = kLISTOP->op_last; /* get past scope */
6404 switch(kid->op_type) {
6412 k = kid; /* remember this node*/
6413 if (kBINOP->op_first->op_type != OP_RV2SV)
6415 kid = kBINOP->op_first; /* get past cmp */
6416 if (kUNOP->op_first->op_type != OP_GV)
6418 kid = kUNOP->op_first; /* get past rv2sv */
6420 if (GvSTASH(gv) != PL_curstash)
6422 gvname = GvNAME(gv);
6423 if (*gvname == 'a' && gvname[1] == '\0')
6425 else if (*gvname == 'b' && gvname[1] == '\0')
6430 kid = k; /* back to cmp */
6431 if (kBINOP->op_last->op_type != OP_RV2SV)
6433 kid = kBINOP->op_last; /* down to 2nd arg */
6434 if (kUNOP->op_first->op_type != OP_GV)
6436 kid = kUNOP->op_first; /* get past rv2sv */
6438 if (GvSTASH(gv) != PL_curstash)
6440 gvname = GvNAME(gv);
6442 ? !(*gvname == 'a' && gvname[1] == '\0')
6443 : !(*gvname == 'b' && gvname[1] == '\0'))
6445 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6447 o->op_private |= OPpSORT_DESCEND;
6448 if (k->op_type == OP_NCMP)
6449 o->op_private |= OPpSORT_NUMERIC;
6450 if (k->op_type == OP_I_NCMP)
6451 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6452 kid = cLISTOPo->op_first->op_sibling;
6453 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6454 op_free(kid); /* then delete it */
6458 Perl_ck_split(pTHX_ OP *o)
6463 if (o->op_flags & OPf_STACKED)
6464 return no_fh_allowed(o);
6466 kid = cLISTOPo->op_first;
6467 if (kid->op_type != OP_NULL)
6468 Perl_croak(aTHX_ "panic: ck_split");
6469 kid = kid->op_sibling;
6470 op_free(cLISTOPo->op_first);
6471 cLISTOPo->op_first = kid;
6473 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
6474 cLISTOPo->op_last = kid; /* There was only one element previously */
6477 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6478 OP * const sibl = kid->op_sibling;
6479 kid->op_sibling = 0;
6480 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
6481 if (cLISTOPo->op_first == cLISTOPo->op_last)
6482 cLISTOPo->op_last = kid;
6483 cLISTOPo->op_first = kid;
6484 kid->op_sibling = sibl;
6487 kid->op_type = OP_PUSHRE;
6488 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6490 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
6491 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
6492 "Use of /g modifier is meaningless in split");
6495 if (!kid->op_sibling)
6496 append_elem(OP_SPLIT, o, newDEFSVOP());
6498 kid = kid->op_sibling;
6501 if (!kid->op_sibling)
6502 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6504 kid = kid->op_sibling;
6507 if (kid->op_sibling)
6508 return too_many_arguments(o,OP_DESC(o));
6514 Perl_ck_join(pTHX_ OP *o)
6516 const OP * const kid = cLISTOPo->op_first->op_sibling;
6517 if (kid && kid->op_type == OP_MATCH) {
6518 if (ckWARN(WARN_SYNTAX)) {
6519 const REGEXP *re = PM_GETRE(kPMOP);
6520 const char *pmstr = re ? re->precomp : "STRING";
6521 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6522 "/%s/ should probably be written as \"%s\"",
6530 Perl_ck_subr(pTHX_ OP *o)
6533 OP *prev = ((cUNOPo->op_first->op_sibling)
6534 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6535 OP *o2 = prev->op_sibling;
6542 I32 contextclass = 0;
6546 o->op_private |= OPpENTERSUB_HASTARG;
6547 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6548 if (cvop->op_type == OP_RV2CV) {
6550 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6551 op_null(cvop); /* disable rv2cv */
6552 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6553 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6554 GV *gv = cGVOPx_gv(tmpop);
6557 tmpop->op_private |= OPpEARLY_CV;
6560 namegv = CvANON(cv) ? gv : CvGV(cv);
6561 proto = SvPV_nolen((SV*)cv);
6563 if (CvASSERTION(cv)) {
6564 if (PL_hints & HINT_ASSERTING) {
6565 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
6566 o->op_private |= OPpENTERSUB_DB;
6570 if (!(PL_hints & HINT_ASSERTIONSSEEN) && ckWARN(WARN_ASSERTIONS)) {
6571 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
6572 "Impossible to activate assertion call");
6579 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6580 if (o2->op_type == OP_CONST)
6581 o2->op_private &= ~OPpCONST_STRICT;
6582 else if (o2->op_type == OP_LIST) {
6583 OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
6584 if (sib && sib->op_type == OP_CONST)
6585 sib->op_private &= ~OPpCONST_STRICT;
6588 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6589 if (PERLDB_SUB && PL_curstash != PL_debstash)
6590 o->op_private |= OPpENTERSUB_DB;
6591 while (o2 != cvop) {
6595 return too_many_arguments(o, gv_ename(namegv));
6613 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6615 arg == 1 ? "block or sub {}" : "sub {}",
6616 gv_ename(namegv), o2);
6619 /* '*' allows any scalar type, including bareword */
6622 if (o2->op_type == OP_RV2GV)
6623 goto wrapref; /* autoconvert GLOB -> GLOBref */
6624 else if (o2->op_type == OP_CONST)
6625 o2->op_private &= ~OPpCONST_STRICT;
6626 else if (o2->op_type == OP_ENTERSUB) {
6627 /* accidental subroutine, revert to bareword */
6628 OP *gvop = ((UNOP*)o2)->op_first;
6629 if (gvop && gvop->op_type == OP_NULL) {
6630 gvop = ((UNOP*)gvop)->op_first;
6632 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6635 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6636 (gvop = ((UNOP*)gvop)->op_first) &&
6637 gvop->op_type == OP_GV)
6639 GV * const gv = cGVOPx_gv(gvop);
6640 OP * const sibling = o2->op_sibling;
6641 SV * const n = newSVpvs("");
6643 gv_fullname4(n, gv, "", FALSE);
6644 o2 = newSVOP(OP_CONST, 0, n);
6645 prev->op_sibling = o2;
6646 o2->op_sibling = sibling;
6662 if (contextclass++ == 0) {
6663 e = strchr(proto, ']');
6664 if (!e || e == proto)
6673 /* XXX We shouldn't be modifying proto, so we can const proto */
6678 while (*--p != '[');
6679 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
6680 gv_ename(namegv), o2);
6686 if (o2->op_type == OP_RV2GV)
6689 bad_type(arg, "symbol", gv_ename(namegv), o2);
6692 if (o2->op_type == OP_ENTERSUB)
6695 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6698 if (o2->op_type == OP_RV2SV ||
6699 o2->op_type == OP_PADSV ||
6700 o2->op_type == OP_HELEM ||
6701 o2->op_type == OP_AELEM ||
6702 o2->op_type == OP_THREADSV)
6705 bad_type(arg, "scalar", gv_ename(namegv), o2);
6708 if (o2->op_type == OP_RV2AV ||
6709 o2->op_type == OP_PADAV)
6712 bad_type(arg, "array", gv_ename(namegv), o2);
6715 if (o2->op_type == OP_RV2HV ||
6716 o2->op_type == OP_PADHV)
6719 bad_type(arg, "hash", gv_ename(namegv), o2);
6724 OP* const sib = kid->op_sibling;
6725 kid->op_sibling = 0;
6726 o2 = newUNOP(OP_REFGEN, 0, kid);
6727 o2->op_sibling = sib;
6728 prev->op_sibling = o2;
6730 if (contextclass && e) {
6745 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
6746 gv_ename(namegv), cv);
6751 mod(o2, OP_ENTERSUB);
6753 o2 = o2->op_sibling;
6755 if (proto && !optional &&
6756 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6757 return too_few_arguments(o, gv_ename(namegv));
6760 o=newSVOP(OP_CONST, 0, newSViv(0));
6766 Perl_ck_svconst(pTHX_ OP *o)
6768 PERL_UNUSED_CONTEXT;
6769 SvREADONLY_on(cSVOPo->op_sv);
6774 Perl_ck_chdir(pTHX_ OP *o)
6776 if (o->op_flags & OPf_KIDS) {
6777 SVOP *kid = (SVOP*)cUNOPo->op_first;
6779 if (kid && kid->op_type == OP_CONST &&
6780 (kid->op_private & OPpCONST_BARE))
6782 o->op_flags |= OPf_SPECIAL;
6783 kid->op_private &= ~OPpCONST_STRICT;
6790 Perl_ck_trunc(pTHX_ OP *o)
6792 if (o->op_flags & OPf_KIDS) {
6793 SVOP *kid = (SVOP*)cUNOPo->op_first;
6795 if (kid->op_type == OP_NULL)
6796 kid = (SVOP*)kid->op_sibling;
6797 if (kid && kid->op_type == OP_CONST &&
6798 (kid->op_private & OPpCONST_BARE))
6800 o->op_flags |= OPf_SPECIAL;
6801 kid->op_private &= ~OPpCONST_STRICT;
6808 Perl_ck_unpack(pTHX_ OP *o)
6810 OP *kid = cLISTOPo->op_first;
6811 if (kid->op_sibling) {
6812 kid = kid->op_sibling;
6813 if (!kid->op_sibling)
6814 kid->op_sibling = newDEFSVOP();
6820 Perl_ck_substr(pTHX_ OP *o)
6823 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6824 OP *kid = cLISTOPo->op_first;
6826 if (kid->op_type == OP_NULL)
6827 kid = kid->op_sibling;
6829 kid->op_flags |= OPf_MOD;
6835 /* A peephole optimizer. We visit the ops in the order they're to execute.
6836 * See the comments at the top of this file for more details about when
6837 * peep() is called */
6840 Perl_peep(pTHX_ register OP *o)
6843 register OP* oldop = NULL;
6845 if (!o || o->op_opt)
6849 SAVEVPTR(PL_curcop);
6850 for (; o; o = o->op_next) {
6854 switch (o->op_type) {
6858 PL_curcop = ((COP*)o); /* for warnings */
6863 if (cSVOPo->op_private & OPpCONST_STRICT)
6864 no_bareword_allowed(o);
6866 case OP_METHOD_NAMED:
6867 /* Relocate sv to the pad for thread safety.
6868 * Despite being a "constant", the SV is written to,
6869 * for reference counts, sv_upgrade() etc. */
6871 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6872 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6873 /* If op_sv is already a PADTMP then it is being used by
6874 * some pad, so make a copy. */
6875 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6876 SvREADONLY_on(PAD_SVl(ix));
6877 SvREFCNT_dec(cSVOPo->op_sv);
6879 else if (o->op_type == OP_CONST
6880 && cSVOPo->op_sv == &PL_sv_undef) {
6881 /* PL_sv_undef is hack - it's unsafe to store it in the
6882 AV that is the pad, because av_fetch treats values of
6883 PL_sv_undef as a "free" AV entry and will merrily
6884 replace them with a new SV, causing pad_alloc to think
6885 that this pad slot is free. (When, clearly, it is not)
6887 SvOK_off(PAD_SVl(ix));
6888 SvPADTMP_on(PAD_SVl(ix));
6889 SvREADONLY_on(PAD_SVl(ix));
6892 SvREFCNT_dec(PAD_SVl(ix));
6893 SvPADTMP_on(cSVOPo->op_sv);
6894 PAD_SETSV(ix, cSVOPo->op_sv);
6895 /* XXX I don't know how this isn't readonly already. */
6896 SvREADONLY_on(PAD_SVl(ix));
6898 cSVOPo->op_sv = NULL;
6906 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6907 if (o->op_next->op_private & OPpTARGET_MY) {
6908 if (o->op_flags & OPf_STACKED) /* chained concats */
6909 goto ignore_optimization;
6911 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6912 o->op_targ = o->op_next->op_targ;
6913 o->op_next->op_targ = 0;
6914 o->op_private |= OPpTARGET_MY;
6917 op_null(o->op_next);
6919 ignore_optimization:
6923 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6925 break; /* Scalar stub must produce undef. List stub is noop */
6929 if (o->op_targ == OP_NEXTSTATE
6930 || o->op_targ == OP_DBSTATE
6931 || o->op_targ == OP_SETSTATE)
6933 PL_curcop = ((COP*)o);
6935 /* XXX: We avoid setting op_seq here to prevent later calls
6936 to peep() from mistakenly concluding that optimisation
6937 has already occurred. This doesn't fix the real problem,
6938 though (See 20010220.007). AMS 20010719 */
6939 /* op_seq functionality is now replaced by op_opt */
6940 if (oldop && o->op_next) {
6941 oldop->op_next = o->op_next;
6949 if (oldop && o->op_next) {
6950 oldop->op_next = o->op_next;
6958 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
6959 OP* const pop = (o->op_type == OP_PADAV) ?
6960 o->op_next : o->op_next->op_next;
6962 if (pop && pop->op_type == OP_CONST &&
6963 ((PL_op = pop->op_next)) &&
6964 pop->op_next->op_type == OP_AELEM &&
6965 !(pop->op_next->op_private &
6966 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6967 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6972 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
6973 no_bareword_allowed(pop);
6974 if (o->op_type == OP_GV)
6975 op_null(o->op_next);
6976 op_null(pop->op_next);
6978 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6979 o->op_next = pop->op_next->op_next;
6980 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6981 o->op_private = (U8)i;
6982 if (o->op_type == OP_GV) {
6987 o->op_flags |= OPf_SPECIAL;
6988 o->op_type = OP_AELEMFAST;
6994 if (o->op_next->op_type == OP_RV2SV) {
6995 if (!(o->op_next->op_private & OPpDEREF)) {
6996 op_null(o->op_next);
6997 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6999 o->op_next = o->op_next->op_next;
7000 o->op_type = OP_GVSV;
7001 o->op_ppaddr = PL_ppaddr[OP_GVSV];
7004 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
7005 GV * const gv = cGVOPo_gv;
7006 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
7007 /* XXX could check prototype here instead of just carping */
7008 SV * const sv = sv_newmortal();
7009 gv_efullname3(sv, gv, NULL);
7010 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
7011 "%"SVf"() called too early to check prototype",
7015 else if (o->op_next->op_type == OP_READLINE
7016 && o->op_next->op_next->op_type == OP_CONCAT
7017 && (o->op_next->op_next->op_flags & OPf_STACKED))
7019 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
7020 o->op_type = OP_RCATLINE;
7021 o->op_flags |= OPf_STACKED;
7022 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
7023 op_null(o->op_next->op_next);
7024 op_null(o->op_next);
7041 while (cLOGOP->op_other->op_type == OP_NULL)
7042 cLOGOP->op_other = cLOGOP->op_other->op_next;
7043 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
7049 while (cLOOP->op_redoop->op_type == OP_NULL)
7050 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
7051 peep(cLOOP->op_redoop);
7052 while (cLOOP->op_nextop->op_type == OP_NULL)
7053 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
7054 peep(cLOOP->op_nextop);
7055 while (cLOOP->op_lastop->op_type == OP_NULL)
7056 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
7057 peep(cLOOP->op_lastop);
7064 while (cPMOP->op_pmreplstart &&
7065 cPMOP->op_pmreplstart->op_type == OP_NULL)
7066 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
7067 peep(cPMOP->op_pmreplstart);
7072 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
7073 && ckWARN(WARN_SYNTAX))
7075 if (o->op_next->op_sibling &&
7076 o->op_next->op_sibling->op_type != OP_EXIT &&
7077 o->op_next->op_sibling->op_type != OP_WARN &&
7078 o->op_next->op_sibling->op_type != OP_DIE) {
7079 const line_t oldline = CopLINE(PL_curcop);
7081 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
7082 Perl_warner(aTHX_ packWARN(WARN_EXEC),
7083 "Statement unlikely to be reached");
7084 Perl_warner(aTHX_ packWARN(WARN_EXEC),
7085 "\t(Maybe you meant system() when you said exec()?)\n");
7086 CopLINE_set(PL_curcop, oldline);
7096 const char *key = NULL;
7101 if (((BINOP*)o)->op_last->op_type != OP_CONST)
7104 /* Make the CONST have a shared SV */
7105 svp = cSVOPx_svp(((BINOP*)o)->op_last);
7106 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
7107 key = SvPV_const(sv, keylen);
7108 lexname = newSVpvn_share(key,
7109 SvUTF8(sv) ? -(I32)keylen : keylen,
7115 if ((o->op_private & (OPpLVAL_INTRO)))
7118 rop = (UNOP*)((BINOP*)o)->op_first;
7119 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7121 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7122 if (!SvPAD_TYPED(lexname))
7124 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
7125 if (!fields || !GvHV(*fields))
7127 key = SvPV_const(*svp, keylen);
7128 if (!hv_fetch(GvHV(*fields), key,
7129 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
7131 Perl_croak(aTHX_ "No such class field \"%s\" "
7132 "in variable %s of type %s",
7133 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
7146 SVOP *first_key_op, *key_op;
7148 if ((o->op_private & (OPpLVAL_INTRO))
7149 /* I bet there's always a pushmark... */
7150 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
7151 /* hmmm, no optimization if list contains only one key. */
7153 rop = (UNOP*)((LISTOP*)o)->op_last;
7154 if (rop->op_type != OP_RV2HV)
7156 if (rop->op_first->op_type == OP_PADSV)
7157 /* @$hash{qw(keys here)} */
7158 rop = (UNOP*)rop->op_first;
7160 /* @{$hash}{qw(keys here)} */
7161 if (rop->op_first->op_type == OP_SCOPE
7162 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
7164 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
7170 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
7171 if (!SvPAD_TYPED(lexname))
7173 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
7174 if (!fields || !GvHV(*fields))
7176 /* Again guessing that the pushmark can be jumped over.... */
7177 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
7178 ->op_first->op_sibling;
7179 for (key_op = first_key_op; key_op;
7180 key_op = (SVOP*)key_op->op_sibling) {
7181 if (key_op->op_type != OP_CONST)
7183 svp = cSVOPx_svp(key_op);
7184 key = SvPV_const(*svp, keylen);
7185 if (!hv_fetch(GvHV(*fields), key,
7186 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
7188 Perl_croak(aTHX_ "No such class field \"%s\" "
7189 "in variable %s of type %s",
7190 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
7197 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
7201 /* check that RHS of sort is a single plain array */
7202 OP *oright = cUNOPo->op_first;
7203 if (!oright || oright->op_type != OP_PUSHMARK)
7206 /* reverse sort ... can be optimised. */
7207 if (!cUNOPo->op_sibling) {
7208 /* Nothing follows us on the list. */
7209 OP * const reverse = o->op_next;
7211 if (reverse->op_type == OP_REVERSE &&
7212 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
7213 OP * const pushmark = cUNOPx(reverse)->op_first;
7214 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
7215 && (cUNOPx(pushmark)->op_sibling == o)) {
7216 /* reverse -> pushmark -> sort */
7217 o->op_private |= OPpSORT_REVERSE;
7219 pushmark->op_next = oright->op_next;
7225 /* make @a = sort @a act in-place */
7229 oright = cUNOPx(oright)->op_sibling;
7232 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
7233 oright = cUNOPx(oright)->op_sibling;
7237 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
7238 || oright->op_next != o
7239 || (oright->op_private & OPpLVAL_INTRO)
7243 /* o2 follows the chain of op_nexts through the LHS of the
7244 * assign (if any) to the aassign op itself */
7246 if (!o2 || o2->op_type != OP_NULL)
7249 if (!o2 || o2->op_type != OP_PUSHMARK)
7252 if (o2 && o2->op_type == OP_GV)
7255 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
7256 || (o2->op_private & OPpLVAL_INTRO)
7261 if (!o2 || o2->op_type != OP_NULL)
7264 if (!o2 || o2->op_type != OP_AASSIGN
7265 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
7268 /* check that the sort is the first arg on RHS of assign */
7270 o2 = cUNOPx(o2)->op_first;
7271 if (!o2 || o2->op_type != OP_NULL)
7273 o2 = cUNOPx(o2)->op_first;
7274 if (!o2 || o2->op_type != OP_PUSHMARK)
7276 if (o2->op_sibling != o)
7279 /* check the array is the same on both sides */
7280 if (oleft->op_type == OP_RV2AV) {
7281 if (oright->op_type != OP_RV2AV
7282 || !cUNOPx(oright)->op_first
7283 || cUNOPx(oright)->op_first->op_type != OP_GV
7284 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
7285 cGVOPx_gv(cUNOPx(oright)->op_first)
7289 else if (oright->op_type != OP_PADAV
7290 || oright->op_targ != oleft->op_targ
7294 /* transfer MODishness etc from LHS arg to RHS arg */
7295 oright->op_flags = oleft->op_flags;
7296 o->op_private |= OPpSORT_INPLACE;
7298 /* excise push->gv->rv2av->null->aassign */
7299 o2 = o->op_next->op_next;
7300 op_null(o2); /* PUSHMARK */
7302 if (o2->op_type == OP_GV) {
7303 op_null(o2); /* GV */
7306 op_null(o2); /* RV2AV or PADAV */
7307 o2 = o2->op_next->op_next;
7308 op_null(o2); /* AASSIGN */
7310 o->op_next = o2->op_next;
7316 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
7318 LISTOP *enter, *exlist;
7321 enter = (LISTOP *) o->op_next;
7324 if (enter->op_type == OP_NULL) {
7325 enter = (LISTOP *) enter->op_next;
7329 /* for $a (...) will have OP_GV then OP_RV2GV here.
7330 for (...) just has an OP_GV. */
7331 if (enter->op_type == OP_GV) {
7332 gvop = (OP *) enter;
7333 enter = (LISTOP *) enter->op_next;
7336 if (enter->op_type == OP_RV2GV) {
7337 enter = (LISTOP *) enter->op_next;
7343 if (enter->op_type != OP_ENTERITER)
7346 iter = enter->op_next;
7347 if (!iter || iter->op_type != OP_ITER)
7350 expushmark = enter->op_first;
7351 if (!expushmark || expushmark->op_type != OP_NULL
7352 || expushmark->op_targ != OP_PUSHMARK)
7355 exlist = (LISTOP *) expushmark->op_sibling;
7356 if (!exlist || exlist->op_type != OP_NULL
7357 || exlist->op_targ != OP_LIST)
7360 if (exlist->op_last != o) {
7361 /* Mmm. Was expecting to point back to this op. */
7364 theirmark = exlist->op_first;
7365 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
7368 if (theirmark->op_sibling != o) {
7369 /* There's something between the mark and the reverse, eg
7370 for (1, reverse (...))
7375 ourmark = ((LISTOP *)o)->op_first;
7376 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
7379 ourlast = ((LISTOP *)o)->op_last;
7380 if (!ourlast || ourlast->op_next != o)
7383 rv2av = ourmark->op_sibling;
7384 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
7385 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
7386 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
7387 /* We're just reversing a single array. */
7388 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
7389 enter->op_flags |= OPf_STACKED;
7392 /* We don't have control over who points to theirmark, so sacrifice
7394 theirmark->op_next = ourmark->op_next;
7395 theirmark->op_flags = ourmark->op_flags;
7396 ourlast->op_next = gvop ? gvop : (OP *) enter;
7399 enter->op_private |= OPpITER_REVERSED;
7400 iter->op_private |= OPpITER_REVERSED;
7407 UNOP *refgen, *rv2cv;
7410 /* I do not understand this, but if o->op_opt isn't set to 1,
7411 various tests in ext/B/t/bytecode.t fail with no readily
7417 if ((o->op_flags && OPf_WANT) != OPf_WANT_VOID)
7420 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
7423 rv2gv = ((BINOP *)o)->op_last;
7424 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
7427 refgen = (UNOP *)((BINOP *)o)->op_first;
7429 if (!refgen || refgen->op_type != OP_REFGEN)
7432 exlist = (LISTOP *)refgen->op_first;
7433 if (!exlist || exlist->op_type != OP_NULL
7434 || exlist->op_targ != OP_LIST)
7437 if (exlist->op_first->op_type != OP_PUSHMARK)
7440 rv2cv = (UNOP*)exlist->op_last;
7442 if (rv2cv->op_type != OP_RV2CV)
7445 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
7446 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
7447 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
7449 o->op_private |= OPpASSIGN_CV_TO_GV;
7450 rv2gv->op_private |= OPpDONT_INIT_GV;
7451 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
7467 Perl_custom_op_name(pTHX_ const OP* o)
7470 const IV index = PTR2IV(o->op_ppaddr);
7474 if (!PL_custom_op_names) /* This probably shouldn't happen */
7475 return (char *)PL_op_name[OP_CUSTOM];
7477 keysv = sv_2mortal(newSViv(index));
7479 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
7481 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
7483 return SvPV_nolen(HeVAL(he));
7487 Perl_custom_op_desc(pTHX_ const OP* o)
7490 const IV index = PTR2IV(o->op_ppaddr);
7494 if (!PL_custom_op_descs)
7495 return (char *)PL_op_desc[OP_CUSTOM];
7497 keysv = sv_2mortal(newSViv(index));
7499 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
7501 return (char *)PL_op_desc[OP_CUSTOM];
7503 return SvPV_nolen(HeVAL(he));
7508 /* Efficient sub that returns a constant scalar value. */
7510 const_sv_xsub(pTHX_ CV* cv)
7517 Perl_croak(aTHX_ "usage: %s::%s()",
7518 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7522 ST(0) = (SV*)XSANY.any_ptr;
7528 * c-indentation-style: bsd
7530 * indent-tabs-mode: t
7533 * ex: set ts=8 sts=4 sw=4 noet: