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)
492 Perl_op_refcnt_unlock(pTHX)
498 /* Contextualizers */
500 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
503 Perl_linklist(pTHX_ OP *o)
510 /* establish postfix order */
511 first = cUNOPo->op_first;
514 o->op_next = LINKLIST(first);
517 if (kid->op_sibling) {
518 kid->op_next = LINKLIST(kid->op_sibling);
519 kid = kid->op_sibling;
533 Perl_scalarkids(pTHX_ OP *o)
535 if (o && o->op_flags & OPf_KIDS) {
537 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
544 S_scalarboolean(pTHX_ OP *o)
547 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
548 if (ckWARN(WARN_SYNTAX)) {
549 const line_t oldline = CopLINE(PL_curcop);
551 if (PL_copline != NOLINE)
552 CopLINE_set(PL_curcop, PL_copline);
553 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
554 CopLINE_set(PL_curcop, oldline);
561 Perl_scalar(pTHX_ OP *o)
566 /* assumes no premature commitment */
567 if (!o || PL_error_count || (o->op_flags & OPf_WANT)
568 || o->op_type == OP_RETURN)
573 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
575 switch (o->op_type) {
577 scalar(cBINOPo->op_first);
582 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
586 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
587 if (!kPMOP->op_pmreplroot)
588 deprecate_old("implicit split to @_");
596 if (o->op_flags & OPf_KIDS) {
597 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
603 kid = cLISTOPo->op_first;
605 while ((kid = kid->op_sibling)) {
611 WITH_THR(PL_curcop = &PL_compiling);
616 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
622 WITH_THR(PL_curcop = &PL_compiling);
625 if (ckWARN(WARN_VOID))
626 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
632 Perl_scalarvoid(pTHX_ OP *o)
636 const char* useless = NULL;
640 if (o->op_type == OP_NEXTSTATE
641 || o->op_type == OP_SETSTATE
642 || o->op_type == OP_DBSTATE
643 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
644 || o->op_targ == OP_SETSTATE
645 || o->op_targ == OP_DBSTATE)))
646 PL_curcop = (COP*)o; /* for warning below */
648 /* assumes no premature commitment */
649 want = o->op_flags & OPf_WANT;
650 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
651 || o->op_type == OP_RETURN)
656 if ((o->op_private & OPpTARGET_MY)
657 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
659 return scalar(o); /* As if inside SASSIGN */
662 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
664 switch (o->op_type) {
666 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
670 if (o->op_flags & OPf_STACKED)
674 if (o->op_private == 4)
746 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
747 useless = OP_DESC(o);
751 kid = cUNOPo->op_first;
752 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
753 kid->op_type != OP_TRANS) {
756 useless = "negative pattern binding (!~)";
763 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
764 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
765 useless = "a variable";
770 if (cSVOPo->op_private & OPpCONST_STRICT)
771 no_bareword_allowed(o);
773 if (ckWARN(WARN_VOID)) {
774 useless = "a constant";
775 /* don't warn on optimised away booleans, eg
776 * use constant Foo, 5; Foo || print; */
777 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
779 /* the constants 0 and 1 are permitted as they are
780 conventionally used as dummies in constructs like
781 1 while some_condition_with_side_effects; */
782 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
784 else if (SvPOK(sv)) {
785 /* perl4's way of mixing documentation and code
786 (before the invention of POD) was based on a
787 trick to mix nroff and perl code. The trick was
788 built upon these three nroff macros being used in
789 void context. The pink camel has the details in
790 the script wrapman near page 319. */
791 const char * const maybe_macro = SvPVX_const(sv);
792 if (strnEQ(maybe_macro, "di", 2) ||
793 strnEQ(maybe_macro, "ds", 2) ||
794 strnEQ(maybe_macro, "ig", 2))
799 op_null(o); /* don't execute or even remember it */
803 o->op_type = OP_PREINC; /* pre-increment is faster */
804 o->op_ppaddr = PL_ppaddr[OP_PREINC];
808 o->op_type = OP_PREDEC; /* pre-decrement is faster */
809 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
813 o->op_type = OP_I_PREINC; /* pre-increment is faster */
814 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
818 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
819 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
828 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
833 if (o->op_flags & OPf_STACKED)
840 if (!(o->op_flags & OPf_KIDS))
851 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
858 /* all requires must return a boolean value */
859 o->op_flags &= ~OPf_WANT;
864 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
865 if (!kPMOP->op_pmreplroot)
866 deprecate_old("implicit split to @_");
870 if (useless && ckWARN(WARN_VOID))
871 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
876 Perl_listkids(pTHX_ OP *o)
878 if (o && o->op_flags & OPf_KIDS) {
880 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
887 Perl_list(pTHX_ OP *o)
892 /* assumes no premature commitment */
893 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
894 || o->op_type == OP_RETURN)
899 if ((o->op_private & OPpTARGET_MY)
900 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
902 return o; /* As if inside SASSIGN */
905 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
907 switch (o->op_type) {
910 list(cBINOPo->op_first);
915 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
923 if (!(o->op_flags & OPf_KIDS))
925 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
926 list(cBINOPo->op_first);
927 return gen_constant_list(o);
934 kid = cLISTOPo->op_first;
936 while ((kid = kid->op_sibling)) {
942 WITH_THR(PL_curcop = &PL_compiling);
946 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
952 WITH_THR(PL_curcop = &PL_compiling);
955 /* all requires must return a boolean value */
956 o->op_flags &= ~OPf_WANT;
963 Perl_scalarseq(pTHX_ OP *o)
967 if (o->op_type == OP_LINESEQ ||
968 o->op_type == OP_SCOPE ||
969 o->op_type == OP_LEAVE ||
970 o->op_type == OP_LEAVETRY)
973 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
974 if (kid->op_sibling) {
978 PL_curcop = &PL_compiling;
980 o->op_flags &= ~OPf_PARENS;
981 if (PL_hints & HINT_BLOCK_SCOPE)
982 o->op_flags |= OPf_PARENS;
985 o = newOP(OP_STUB, 0);
990 S_modkids(pTHX_ OP *o, I32 type)
992 if (o && o->op_flags & OPf_KIDS) {
994 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1000 /* Propagate lvalue ("modifiable") context to an op and its children.
1001 * 'type' represents the context type, roughly based on the type of op that
1002 * would do the modifying, although local() is represented by OP_NULL.
1003 * It's responsible for detecting things that can't be modified, flag
1004 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
1005 * might have to vivify a reference in $x), and so on.
1007 * For example, "$a+1 = 2" would cause mod() to be called with o being
1008 * OP_ADD and type being OP_SASSIGN, and would output an error.
1012 Perl_mod(pTHX_ OP *o, I32 type)
1016 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1019 if (!o || PL_error_count)
1022 if ((o->op_private & OPpTARGET_MY)
1023 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1028 switch (o->op_type) {
1034 if (!(o->op_private & (OPpCONST_ARYBASE)))
1037 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1038 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
1042 SAVEI32(PL_compiling.cop_arybase);
1043 PL_compiling.cop_arybase = 0;
1045 else if (type == OP_REFGEN)
1048 Perl_croak(aTHX_ "That use of $[ is unsupported");
1051 if (o->op_flags & OPf_PARENS)
1055 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1056 !(o->op_flags & OPf_STACKED)) {
1057 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1058 /* The default is to set op_private to the number of children,
1059 which for a UNOP such as RV2CV is always 1. And w're using
1060 the bit for a flag in RV2CV, so we need it clear. */
1061 o->op_private &= ~1;
1062 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1063 assert(cUNOPo->op_first->op_type == OP_NULL);
1064 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1067 else if (o->op_private & OPpENTERSUB_NOMOD)
1069 else { /* lvalue subroutine call */
1070 o->op_private |= OPpLVAL_INTRO;
1071 PL_modcount = RETURN_UNLIMITED_NUMBER;
1072 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1073 /* Backward compatibility mode: */
1074 o->op_private |= OPpENTERSUB_INARGS;
1077 else { /* Compile-time error message: */
1078 OP *kid = cUNOPo->op_first;
1082 if (kid->op_type == OP_PUSHMARK)
1084 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1086 "panic: unexpected lvalue entersub "
1087 "args: type/targ %ld:%"UVuf,
1088 (long)kid->op_type, (UV)kid->op_targ);
1089 kid = kLISTOP->op_first;
1091 while (kid->op_sibling)
1092 kid = kid->op_sibling;
1093 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1095 if (kid->op_type == OP_METHOD_NAMED
1096 || kid->op_type == OP_METHOD)
1100 NewOp(1101, newop, 1, UNOP);
1101 newop->op_type = OP_RV2CV;
1102 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1103 newop->op_first = NULL;
1104 newop->op_next = (OP*)newop;
1105 kid->op_sibling = (OP*)newop;
1106 newop->op_private |= OPpLVAL_INTRO;
1107 newop->op_private &= ~1;
1111 if (kid->op_type != OP_RV2CV)
1113 "panic: unexpected lvalue entersub "
1114 "entry via type/targ %ld:%"UVuf,
1115 (long)kid->op_type, (UV)kid->op_targ);
1116 kid->op_private |= OPpLVAL_INTRO;
1117 break; /* Postpone until runtime */
1121 kid = kUNOP->op_first;
1122 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1123 kid = kUNOP->op_first;
1124 if (kid->op_type == OP_NULL)
1126 "Unexpected constant lvalue entersub "
1127 "entry via type/targ %ld:%"UVuf,
1128 (long)kid->op_type, (UV)kid->op_targ);
1129 if (kid->op_type != OP_GV) {
1130 /* Restore RV2CV to check lvalueness */
1132 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1133 okid->op_next = kid->op_next;
1134 kid->op_next = okid;
1137 okid->op_next = NULL;
1138 okid->op_type = OP_RV2CV;
1140 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1141 okid->op_private |= OPpLVAL_INTRO;
1142 okid->op_private &= ~1;
1146 cv = GvCV(kGVOP_gv);
1156 /* grep, foreach, subcalls, refgen */
1157 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1159 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1160 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1162 : (o->op_type == OP_ENTERSUB
1163 ? "non-lvalue subroutine call"
1165 type ? PL_op_desc[type] : "local"));
1179 case OP_RIGHT_SHIFT:
1188 if (!(o->op_flags & OPf_STACKED))
1195 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1201 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1202 PL_modcount = RETURN_UNLIMITED_NUMBER;
1203 return o; /* Treat \(@foo) like ordinary list. */
1207 if (scalar_mod_type(o, type))
1209 ref(cUNOPo->op_first, o->op_type);
1213 if (type == OP_LEAVESUBLV)
1214 o->op_private |= OPpMAYBE_LVSUB;
1220 PL_modcount = RETURN_UNLIMITED_NUMBER;
1223 ref(cUNOPo->op_first, o->op_type);
1228 PL_hints |= HINT_BLOCK_SCOPE;
1243 PL_modcount = RETURN_UNLIMITED_NUMBER;
1244 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1245 return o; /* Treat \(@foo) like ordinary list. */
1246 if (scalar_mod_type(o, type))
1248 if (type == OP_LEAVESUBLV)
1249 o->op_private |= OPpMAYBE_LVSUB;
1253 if (!type) /* local() */
1254 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1255 PAD_COMPNAME_PV(o->op_targ));
1263 if (type != OP_SASSIGN)
1267 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1272 if (type == OP_LEAVESUBLV)
1273 o->op_private |= OPpMAYBE_LVSUB;
1275 pad_free(o->op_targ);
1276 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1277 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1278 if (o->op_flags & OPf_KIDS)
1279 mod(cBINOPo->op_first->op_sibling, type);
1284 ref(cBINOPo->op_first, o->op_type);
1285 if (type == OP_ENTERSUB &&
1286 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1287 o->op_private |= OPpLVAL_DEFER;
1288 if (type == OP_LEAVESUBLV)
1289 o->op_private |= OPpMAYBE_LVSUB;
1299 if (o->op_flags & OPf_KIDS)
1300 mod(cLISTOPo->op_last, type);
1305 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1307 else if (!(o->op_flags & OPf_KIDS))
1309 if (o->op_targ != OP_LIST) {
1310 mod(cBINOPo->op_first, type);
1316 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1321 if (type != OP_LEAVESUBLV)
1323 break; /* mod()ing was handled by ck_return() */
1326 /* [20011101.069] File test operators interpret OPf_REF to mean that
1327 their argument is a filehandle; thus \stat(".") should not set
1329 if (type == OP_REFGEN &&
1330 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1333 if (type != OP_LEAVESUBLV)
1334 o->op_flags |= OPf_MOD;
1336 if (type == OP_AASSIGN || type == OP_SASSIGN)
1337 o->op_flags |= OPf_SPECIAL|OPf_REF;
1338 else if (!type) { /* local() */
1341 o->op_private |= OPpLVAL_INTRO;
1342 o->op_flags &= ~OPf_SPECIAL;
1343 PL_hints |= HINT_BLOCK_SCOPE;
1348 if (ckWARN(WARN_SYNTAX)) {
1349 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1350 "Useless localization of %s", OP_DESC(o));
1354 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1355 && type != OP_LEAVESUBLV)
1356 o->op_flags |= OPf_REF;
1361 S_scalar_mod_type(const OP *o, I32 type)
1365 if (o->op_type == OP_RV2GV)
1389 case OP_RIGHT_SHIFT:
1408 S_is_handle_constructor(const OP *o, I32 numargs)
1410 switch (o->op_type) {
1418 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1431 Perl_refkids(pTHX_ OP *o, I32 type)
1433 if (o && o->op_flags & OPf_KIDS) {
1435 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1442 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
1447 if (!o || PL_error_count)
1450 switch (o->op_type) {
1452 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1453 !(o->op_flags & OPf_STACKED)) {
1454 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1455 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1456 assert(cUNOPo->op_first->op_type == OP_NULL);
1457 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1458 o->op_flags |= OPf_SPECIAL;
1459 o->op_private &= ~1;
1464 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1465 doref(kid, type, set_op_ref);
1468 if (type == OP_DEFINED)
1469 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1470 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1473 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1474 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1475 : type == OP_RV2HV ? OPpDEREF_HV
1477 o->op_flags |= OPf_MOD;
1482 o->op_flags |= OPf_MOD; /* XXX ??? */
1488 o->op_flags |= OPf_REF;
1491 if (type == OP_DEFINED)
1492 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1493 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1499 o->op_flags |= OPf_REF;
1504 if (!(o->op_flags & OPf_KIDS))
1506 doref(cBINOPo->op_first, type, set_op_ref);
1510 doref(cBINOPo->op_first, o->op_type, set_op_ref);
1511 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1512 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1513 : type == OP_RV2HV ? OPpDEREF_HV
1515 o->op_flags |= OPf_MOD;
1525 if (!(o->op_flags & OPf_KIDS))
1527 doref(cLISTOPo->op_last, type, set_op_ref);
1537 S_dup_attrlist(pTHX_ OP *o)
1542 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1543 * where the first kid is OP_PUSHMARK and the remaining ones
1544 * are OP_CONST. We need to push the OP_CONST values.
1546 if (o->op_type == OP_CONST)
1547 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1549 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1551 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1552 if (o->op_type == OP_CONST)
1553 rop = append_elem(OP_LIST, rop,
1554 newSVOP(OP_CONST, o->op_flags,
1555 SvREFCNT_inc(cSVOPo->op_sv)));
1562 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1567 /* fake up C<use attributes $pkg,$rv,@attrs> */
1568 ENTER; /* need to protect against side-effects of 'use' */
1570 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1572 #define ATTRSMODULE "attributes"
1573 #define ATTRSMODULE_PM "attributes.pm"
1576 /* Don't force the C<use> if we don't need it. */
1577 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
1578 if (svp && *svp != &PL_sv_undef)
1579 /*EMPTY*/; /* already in %INC */
1581 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1582 newSVpvs(ATTRSMODULE), NULL);
1585 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1586 newSVpvs(ATTRSMODULE),
1588 prepend_elem(OP_LIST,
1589 newSVOP(OP_CONST, 0, stashsv),
1590 prepend_elem(OP_LIST,
1591 newSVOP(OP_CONST, 0,
1593 dup_attrlist(attrs))));
1599 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1602 OP *pack, *imop, *arg;
1608 assert(target->op_type == OP_PADSV ||
1609 target->op_type == OP_PADHV ||
1610 target->op_type == OP_PADAV);
1612 /* Ensure that attributes.pm is loaded. */
1613 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1615 /* Need package name for method call. */
1616 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
1618 /* Build up the real arg-list. */
1619 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1621 arg = newOP(OP_PADSV, 0);
1622 arg->op_targ = target->op_targ;
1623 arg = prepend_elem(OP_LIST,
1624 newSVOP(OP_CONST, 0, stashsv),
1625 prepend_elem(OP_LIST,
1626 newUNOP(OP_REFGEN, 0,
1627 mod(arg, OP_REFGEN)),
1628 dup_attrlist(attrs)));
1630 /* Fake up a method call to import */
1631 meth = newSVpvs_share("import");
1632 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1633 append_elem(OP_LIST,
1634 prepend_elem(OP_LIST, pack, list(arg)),
1635 newSVOP(OP_METHOD_NAMED, 0, meth)));
1636 imop->op_private |= OPpENTERSUB_NOMOD;
1638 /* Combine the ops. */
1639 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1643 =notfor apidoc apply_attrs_string
1645 Attempts to apply a list of attributes specified by the C<attrstr> and
1646 C<len> arguments to the subroutine identified by the C<cv> argument which
1647 is expected to be associated with the package identified by the C<stashpv>
1648 argument (see L<attributes>). It gets this wrong, though, in that it
1649 does not correctly identify the boundaries of the individual attribute
1650 specifications within C<attrstr>. This is not really intended for the
1651 public API, but has to be listed here for systems such as AIX which
1652 need an explicit export list for symbols. (It's called from XS code
1653 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1654 to respect attribute syntax properly would be welcome.
1660 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
1661 const char *attrstr, STRLEN len)
1666 len = strlen(attrstr);
1670 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1672 const char * const sstr = attrstr;
1673 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1674 attrs = append_elem(OP_LIST, attrs,
1675 newSVOP(OP_CONST, 0,
1676 newSVpvn(sstr, attrstr-sstr)));
1680 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1681 newSVpvs(ATTRSMODULE),
1682 NULL, prepend_elem(OP_LIST,
1683 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1684 prepend_elem(OP_LIST,
1685 newSVOP(OP_CONST, 0,
1691 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
1696 if (!o || PL_error_count)
1700 if (type == OP_LIST) {
1702 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1703 my_kid(kid, attrs, imopsp);
1704 } else if (type == OP_UNDEF) {
1706 } else if (type == OP_RV2SV || /* "our" declaration */
1708 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1709 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1710 yyerror(Perl_form(aTHX_ "Can't declare %s in %s",
1711 OP_DESC(o), PL_in_my == KEY_our ? "our" : "my"));
1713 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
1715 PL_in_my_stash = NULL;
1716 apply_attrs(GvSTASH(gv),
1717 (type == OP_RV2SV ? GvSV(gv) :
1718 type == OP_RV2AV ? (SV*)GvAV(gv) :
1719 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1722 o->op_private |= OPpOUR_INTRO;
1725 else if (type != OP_PADSV &&
1728 type != OP_PUSHMARK)
1730 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1732 PL_in_my == KEY_our ? "our" : "my"));
1735 else if (attrs && type != OP_PUSHMARK) {
1739 PL_in_my_stash = NULL;
1741 /* check for C<my Dog $spot> when deciding package */
1742 stash = PAD_COMPNAME_TYPE(o->op_targ);
1744 stash = PL_curstash;
1745 apply_attrs_my(stash, o, attrs, imopsp);
1747 o->op_flags |= OPf_MOD;
1748 o->op_private |= OPpLVAL_INTRO;
1753 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1757 int maybe_scalar = 0;
1759 /* [perl #17376]: this appears to be premature, and results in code such as
1760 C< our(%x); > executing in list mode rather than void mode */
1762 if (o->op_flags & OPf_PARENS)
1772 o = my_kid(o, attrs, &rops);
1774 if (maybe_scalar && o->op_type == OP_PADSV) {
1775 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
1776 o->op_private |= OPpLVAL_INTRO;
1779 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
1782 PL_in_my_stash = NULL;
1787 Perl_my(pTHX_ OP *o)
1789 return my_attrs(o, NULL);
1793 Perl_sawparens(pTHX_ OP *o)
1796 o->op_flags |= OPf_PARENS;
1801 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
1806 if ( (left->op_type == OP_RV2AV ||
1807 left->op_type == OP_RV2HV ||
1808 left->op_type == OP_PADAV ||
1809 left->op_type == OP_PADHV)
1810 && ckWARN(WARN_MISC))
1812 const char * const desc = PL_op_desc[(right->op_type == OP_SUBST ||
1813 right->op_type == OP_TRANS)
1814 ? right->op_type : OP_MATCH];
1815 const char * const sample = ((left->op_type == OP_RV2AV ||
1816 left->op_type == OP_PADAV)
1817 ? "@array" : "%hash");
1818 Perl_warner(aTHX_ packWARN(WARN_MISC),
1819 "Applying %s to %s will act on scalar(%s)",
1820 desc, sample, sample);
1823 if (right->op_type == OP_CONST &&
1824 cSVOPx(right)->op_private & OPpCONST_BARE &&
1825 cSVOPx(right)->op_private & OPpCONST_STRICT)
1827 no_bareword_allowed(right);
1830 ismatchop = right->op_type == OP_MATCH ||
1831 right->op_type == OP_SUBST ||
1832 right->op_type == OP_TRANS;
1833 if (ismatchop && right->op_private & OPpTARGET_MY) {
1835 right->op_private &= ~OPpTARGET_MY;
1837 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
1838 right->op_flags |= OPf_STACKED;
1839 if (right->op_type != OP_MATCH &&
1840 ! (right->op_type == OP_TRANS &&
1841 right->op_private & OPpTRANS_IDENTICAL))
1842 left = mod(left, right->op_type);
1843 if (right->op_type == OP_TRANS)
1844 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
1846 o = prepend_elem(right->op_type, scalar(left), right);
1848 return newUNOP(OP_NOT, 0, scalar(o));
1852 return bind_match(type, left,
1853 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
1857 Perl_invert(pTHX_ OP *o)
1861 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
1862 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
1866 Perl_scope(pTHX_ OP *o)
1870 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
1871 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
1872 o->op_type = OP_LEAVE;
1873 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
1875 else if (o->op_type == OP_LINESEQ) {
1877 o->op_type = OP_SCOPE;
1878 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
1879 kid = ((LISTOP*)o)->op_first;
1880 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
1883 /* The following deals with things like 'do {1 for 1}' */
1884 kid = kid->op_sibling;
1886 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
1891 o = newLISTOP(OP_SCOPE, 0, o, NULL);
1897 Perl_block_start(pTHX_ int full)
1900 const int retval = PL_savestack_ix;
1901 pad_block_start(full);
1903 PL_hints &= ~HINT_BLOCK_SCOPE;
1904 SAVESPTR(PL_compiling.cop_warnings);
1905 if (! specialWARN(PL_compiling.cop_warnings)) {
1906 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
1907 SAVEFREESV(PL_compiling.cop_warnings) ;
1909 SAVESPTR(PL_compiling.cop_io);
1910 if (! specialCopIO(PL_compiling.cop_io)) {
1911 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
1912 SAVEFREESV(PL_compiling.cop_io) ;
1918 Perl_block_end(pTHX_ I32 floor, OP *seq)
1921 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
1922 OP* const retval = scalarseq(seq);
1924 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
1926 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
1935 const I32 offset = pad_findmy("$_");
1936 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
1937 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
1940 OP * const o = newOP(OP_PADSV, 0);
1941 o->op_targ = offset;
1947 Perl_newPROG(pTHX_ OP *o)
1953 PL_eval_root = newUNOP(OP_LEAVEEVAL,
1954 ((PL_in_eval & EVAL_KEEPERR)
1955 ? OPf_SPECIAL : 0), o);
1956 PL_eval_start = linklist(PL_eval_root);
1957 PL_eval_root->op_private |= OPpREFCOUNTED;
1958 OpREFCNT_set(PL_eval_root, 1);
1959 PL_eval_root->op_next = 0;
1960 CALL_PEEP(PL_eval_start);
1963 if (o->op_type == OP_STUB) {
1964 PL_comppad_name = 0;
1969 PL_main_root = scope(sawparens(scalarvoid(o)));
1970 PL_curcop = &PL_compiling;
1971 PL_main_start = LINKLIST(PL_main_root);
1972 PL_main_root->op_private |= OPpREFCOUNTED;
1973 OpREFCNT_set(PL_main_root, 1);
1974 PL_main_root->op_next = 0;
1975 CALL_PEEP(PL_main_start);
1978 /* Register with debugger */
1980 CV * const cv = get_cv("DB::postponed", FALSE);
1984 XPUSHs((SV*)CopFILEGV(&PL_compiling));
1986 call_sv((SV*)cv, G_DISCARD);
1993 Perl_localize(pTHX_ OP *o, I32 lex)
1996 if (o->op_flags & OPf_PARENS)
1997 /* [perl #17376]: this appears to be premature, and results in code such as
1998 C< our(%x); > executing in list mode rather than void mode */
2005 if ( PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ','
2006 && ckWARN(WARN_PARENTHESIS))
2008 char *s = PL_bufptr;
2011 /* some heuristics to detect a potential error */
2012 while (*s && (strchr(", \t\n", *s)))
2016 if (*s && strchr("@$%*", *s) && *++s
2017 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2020 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2022 while (*s && (strchr(", \t\n", *s)))
2028 if (sigil && (*s == ';' || *s == '=')) {
2029 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2030 "Parentheses missing around \"%s\" list",
2031 lex ? (PL_in_my == KEY_our ? "our" : "my")
2039 o = mod(o, OP_NULL); /* a bit kludgey */
2041 PL_in_my_stash = NULL;
2046 Perl_jmaybe(pTHX_ OP *o)
2048 if (o->op_type == OP_LIST) {
2050 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL,
2052 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2058 Perl_fold_constants(pTHX_ register OP *o)
2062 I32 type = o->op_type;
2065 if (PL_opargs[type] & OA_RETSCALAR)
2067 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2068 o->op_targ = pad_alloc(type, SVs_PADTMP);
2070 /* integerize op, unless it happens to be C<-foo>.
2071 * XXX should pp_i_negate() do magic string negation instead? */
2072 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2073 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2074 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2076 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2079 if (!(PL_opargs[type] & OA_FOLDCONST))
2084 /* XXX might want a ck_negate() for this */
2085 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2096 /* XXX what about the numeric ops? */
2097 if (PL_hints & HINT_LOCALE)
2102 goto nope; /* Don't try to run w/ errors */
2104 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2105 if ((curop->op_type != OP_CONST ||
2106 (curop->op_private & OPpCONST_BARE)) &&
2107 curop->op_type != OP_LIST &&
2108 curop->op_type != OP_SCALAR &&
2109 curop->op_type != OP_NULL &&
2110 curop->op_type != OP_PUSHMARK)
2116 curop = LINKLIST(o);
2120 sv = *(PL_stack_sp--);
2121 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2122 pad_swipe(o->op_targ, FALSE);
2123 else if (SvTEMP(sv)) { /* grab mortal temp? */
2124 (void)SvREFCNT_inc(sv);
2128 if (type == OP_RV2GV)
2129 return newGVOP(OP_GV, 0, (GV*)sv);
2130 return newSVOP(OP_CONST, 0, sv);
2137 Perl_gen_constant_list(pTHX_ register OP *o)
2141 const I32 oldtmps_floor = PL_tmps_floor;
2145 return o; /* Don't attempt to run with errors */
2147 PL_op = curop = LINKLIST(o);
2154 PL_tmps_floor = oldtmps_floor;
2156 o->op_type = OP_RV2AV;
2157 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2158 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2159 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2160 o->op_opt = 0; /* needs to be revisited in peep() */
2161 curop = ((UNOP*)o)->op_first;
2162 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2169 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2172 if (!o || o->op_type != OP_LIST)
2173 o = newLISTOP(OP_LIST, 0, o, NULL);
2175 o->op_flags &= ~OPf_WANT;
2177 if (!(PL_opargs[type] & OA_MARK))
2178 op_null(cLISTOPo->op_first);
2180 o->op_type = (OPCODE)type;
2181 o->op_ppaddr = PL_ppaddr[type];
2182 o->op_flags |= flags;
2184 o = CHECKOP(type, o);
2185 if (o->op_type != (unsigned)type)
2188 return fold_constants(o);
2191 /* List constructors */
2194 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2202 if (first->op_type != (unsigned)type
2203 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2205 return newLISTOP(type, 0, first, last);
2208 if (first->op_flags & OPf_KIDS)
2209 ((LISTOP*)first)->op_last->op_sibling = last;
2211 first->op_flags |= OPf_KIDS;
2212 ((LISTOP*)first)->op_first = last;
2214 ((LISTOP*)first)->op_last = last;
2219 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2227 if (first->op_type != (unsigned)type)
2228 return prepend_elem(type, (OP*)first, (OP*)last);
2230 if (last->op_type != (unsigned)type)
2231 return append_elem(type, (OP*)first, (OP*)last);
2233 first->op_last->op_sibling = last->op_first;
2234 first->op_last = last->op_last;
2235 first->op_flags |= (last->op_flags & OPf_KIDS);
2243 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2251 if (last->op_type == (unsigned)type) {
2252 if (type == OP_LIST) { /* already a PUSHMARK there */
2253 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2254 ((LISTOP*)last)->op_first->op_sibling = first;
2255 if (!(first->op_flags & OPf_PARENS))
2256 last->op_flags &= ~OPf_PARENS;
2259 if (!(last->op_flags & OPf_KIDS)) {
2260 ((LISTOP*)last)->op_last = first;
2261 last->op_flags |= OPf_KIDS;
2263 first->op_sibling = ((LISTOP*)last)->op_first;
2264 ((LISTOP*)last)->op_first = first;
2266 last->op_flags |= OPf_KIDS;
2270 return newLISTOP(type, 0, first, last);
2276 Perl_newNULLLIST(pTHX)
2278 return newOP(OP_STUB, 0);
2282 Perl_force_list(pTHX_ OP *o)
2284 if (!o || o->op_type != OP_LIST)
2285 o = newLISTOP(OP_LIST, 0, o, NULL);
2291 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2296 NewOp(1101, listop, 1, LISTOP);
2298 listop->op_type = (OPCODE)type;
2299 listop->op_ppaddr = PL_ppaddr[type];
2302 listop->op_flags = (U8)flags;
2306 else if (!first && last)
2309 first->op_sibling = last;
2310 listop->op_first = first;
2311 listop->op_last = last;
2312 if (type == OP_LIST) {
2313 OP* const pushop = newOP(OP_PUSHMARK, 0);
2314 pushop->op_sibling = first;
2315 listop->op_first = pushop;
2316 listop->op_flags |= OPf_KIDS;
2318 listop->op_last = pushop;
2321 return CHECKOP(type, listop);
2325 Perl_newOP(pTHX_ I32 type, I32 flags)
2329 NewOp(1101, o, 1, OP);
2330 o->op_type = (OPCODE)type;
2331 o->op_ppaddr = PL_ppaddr[type];
2332 o->op_flags = (U8)flags;
2335 o->op_private = (U8)(0 | (flags >> 8));
2336 if (PL_opargs[type] & OA_RETSCALAR)
2338 if (PL_opargs[type] & OA_TARGET)
2339 o->op_targ = pad_alloc(type, SVs_PADTMP);
2340 return CHECKOP(type, o);
2344 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2350 first = newOP(OP_STUB, 0);
2351 if (PL_opargs[type] & OA_MARK)
2352 first = force_list(first);
2354 NewOp(1101, unop, 1, UNOP);
2355 unop->op_type = (OPCODE)type;
2356 unop->op_ppaddr = PL_ppaddr[type];
2357 unop->op_first = first;
2358 unop->op_flags = (U8)(flags | OPf_KIDS);
2359 unop->op_private = (U8)(1 | (flags >> 8));
2360 unop = (UNOP*) CHECKOP(type, unop);
2364 return fold_constants((OP *) unop);
2368 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2372 NewOp(1101, binop, 1, BINOP);
2375 first = newOP(OP_NULL, 0);
2377 binop->op_type = (OPCODE)type;
2378 binop->op_ppaddr = PL_ppaddr[type];
2379 binop->op_first = first;
2380 binop->op_flags = (U8)(flags | OPf_KIDS);
2383 binop->op_private = (U8)(1 | (flags >> 8));
2386 binop->op_private = (U8)(2 | (flags >> 8));
2387 first->op_sibling = last;
2390 binop = (BINOP*)CHECKOP(type, binop);
2391 if (binop->op_next || binop->op_type != (OPCODE)type)
2394 binop->op_last = binop->op_first->op_sibling;
2396 return fold_constants((OP *)binop);
2399 static int uvcompare(const void *a, const void *b)
2400 __attribute__nonnull__(1)
2401 __attribute__nonnull__(2)
2402 __attribute__pure__;
2403 static int uvcompare(const void *a, const void *b)
2405 if (*((const UV *)a) < (*(const UV *)b))
2407 if (*((const UV *)a) > (*(const UV *)b))
2409 if (*((const UV *)a+1) < (*(const UV *)b+1))
2411 if (*((const UV *)a+1) > (*(const UV *)b+1))
2417 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2420 SV * const tstr = ((SVOP*)expr)->op_sv;
2421 SV * const rstr = ((SVOP*)repl)->op_sv;
2424 const U8 *t = (U8*)SvPV_const(tstr, tlen);
2425 const U8 *r = (U8*)SvPV_const(rstr, rlen);
2429 register short *tbl;
2431 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
2432 const I32 squash = o->op_private & OPpTRANS_SQUASH;
2433 I32 del = o->op_private & OPpTRANS_DELETE;
2434 PL_hints |= HINT_BLOCK_SCOPE;
2437 o->op_private |= OPpTRANS_FROM_UTF;
2440 o->op_private |= OPpTRANS_TO_UTF;
2442 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2443 SV* const listsv = newSVpvs("# comment\n");
2445 const U8* tend = t + tlen;
2446 const U8* rend = r + rlen;
2460 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2461 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2467 t = tsave = bytes_to_utf8(t, &len);
2470 if (!to_utf && rlen) {
2472 r = rsave = bytes_to_utf8(r, &len);
2476 /* There are several snags with this code on EBCDIC:
2477 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2478 2. scan_const() in toke.c has encoded chars in native encoding which makes
2479 ranges at least in EBCDIC 0..255 range the bottom odd.
2483 U8 tmpbuf[UTF8_MAXBYTES+1];
2486 Newx(cp, 2*tlen, UV);
2488 transv = newSVpvs("");
2490 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2492 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2494 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2498 cp[2*i+1] = cp[2*i];
2502 qsort(cp, i, 2*sizeof(UV), uvcompare);
2503 for (j = 0; j < i; j++) {
2505 diff = val - nextmin;
2507 t = uvuni_to_utf8(tmpbuf,nextmin);
2508 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2510 U8 range_mark = UTF_TO_NATIVE(0xff);
2511 t = uvuni_to_utf8(tmpbuf, val - 1);
2512 sv_catpvn(transv, (char *)&range_mark, 1);
2513 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2520 t = uvuni_to_utf8(tmpbuf,nextmin);
2521 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2523 U8 range_mark = UTF_TO_NATIVE(0xff);
2524 sv_catpvn(transv, (char *)&range_mark, 1);
2526 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2527 UNICODE_ALLOW_SUPER);
2528 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2529 t = (const U8*)SvPVX_const(transv);
2530 tlen = SvCUR(transv);
2534 else if (!rlen && !del) {
2535 r = t; rlen = tlen; rend = tend;
2538 if ((!rlen && !del) || t == r ||
2539 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2541 o->op_private |= OPpTRANS_IDENTICAL;
2545 while (t < tend || tfirst <= tlast) {
2546 /* see if we need more "t" chars */
2547 if (tfirst > tlast) {
2548 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2550 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2552 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2559 /* now see if we need more "r" chars */
2560 if (rfirst > rlast) {
2562 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2564 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2566 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2575 rfirst = rlast = 0xffffffff;
2579 /* now see which range will peter our first, if either. */
2580 tdiff = tlast - tfirst;
2581 rdiff = rlast - rfirst;
2588 if (rfirst == 0xffffffff) {
2589 diff = tdiff; /* oops, pretend rdiff is infinite */
2591 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2592 (long)tfirst, (long)tlast);
2594 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2598 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2599 (long)tfirst, (long)(tfirst + diff),
2602 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2603 (long)tfirst, (long)rfirst);
2605 if (rfirst + diff > max)
2606 max = rfirst + diff;
2608 grows = (tfirst < rfirst &&
2609 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2621 else if (max > 0xff)
2626 Safefree(cPVOPo->op_pv);
2627 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2628 SvREFCNT_dec(listsv);
2630 SvREFCNT_dec(transv);
2632 if (!del && havefinal && rlen)
2633 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2634 newSVuv((UV)final), 0);
2637 o->op_private |= OPpTRANS_GROWS;
2649 tbl = (short*)cPVOPo->op_pv;
2651 Zero(tbl, 256, short);
2652 for (i = 0; i < (I32)tlen; i++)
2654 for (i = 0, j = 0; i < 256; i++) {
2656 if (j >= (I32)rlen) {
2665 if (i < 128 && r[j] >= 128)
2675 o->op_private |= OPpTRANS_IDENTICAL;
2677 else if (j >= (I32)rlen)
2680 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2681 tbl[0x100] = (short)(rlen - j);
2682 for (i=0; i < (I32)rlen - j; i++)
2683 tbl[0x101+i] = r[j+i];
2687 if (!rlen && !del) {
2690 o->op_private |= OPpTRANS_IDENTICAL;
2692 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
2693 o->op_private |= OPpTRANS_IDENTICAL;
2695 for (i = 0; i < 256; i++)
2697 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
2698 if (j >= (I32)rlen) {
2700 if (tbl[t[i]] == -1)
2706 if (tbl[t[i]] == -1) {
2707 if (t[i] < 128 && r[j] >= 128)
2714 o->op_private |= OPpTRANS_GROWS;
2722 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2727 NewOp(1101, pmop, 1, PMOP);
2728 pmop->op_type = (OPCODE)type;
2729 pmop->op_ppaddr = PL_ppaddr[type];
2730 pmop->op_flags = (U8)flags;
2731 pmop->op_private = (U8)(0 | (flags >> 8));
2733 if (PL_hints & HINT_RE_TAINT)
2734 pmop->op_pmpermflags |= PMf_RETAINT;
2735 if (PL_hints & HINT_LOCALE)
2736 pmop->op_pmpermflags |= PMf_LOCALE;
2737 pmop->op_pmflags = pmop->op_pmpermflags;
2740 if (av_len((AV*) PL_regex_pad[0]) > -1) {
2741 SV * const repointer = av_pop((AV*)PL_regex_pad[0]);
2742 pmop->op_pmoffset = SvIV(repointer);
2743 SvREPADTMP_off(repointer);
2744 sv_setiv(repointer,0);
2746 SV * const repointer = newSViv(0);
2747 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
2748 pmop->op_pmoffset = av_len(PL_regex_padav);
2749 PL_regex_pad = AvARRAY(PL_regex_padav);
2753 /* link into pm list */
2754 if (type != OP_TRANS && PL_curstash) {
2755 MAGIC *mg = mg_find((SV*)PL_curstash, PERL_MAGIC_symtab);
2758 mg = sv_magicext((SV*)PL_curstash, 0, PERL_MAGIC_symtab, 0, 0, 0);
2760 pmop->op_pmnext = (PMOP*)mg->mg_obj;
2761 mg->mg_obj = (SV*)pmop;
2762 PmopSTASH_set(pmop,PL_curstash);
2765 return CHECKOP(type, pmop);
2768 /* Given some sort of match op o, and an expression expr containing a
2769 * pattern, either compile expr into a regex and attach it to o (if it's
2770 * constant), or convert expr into a runtime regcomp op sequence (if it's
2773 * isreg indicates that the pattern is part of a regex construct, eg
2774 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
2775 * split "pattern", which aren't. In the former case, expr will be a list
2776 * if the pattern contains more than one term (eg /a$b/) or if it contains
2777 * a replacement, ie s/// or tr///.
2781 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
2786 I32 repl_has_vars = 0;
2790 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
2791 /* last element in list is the replacement; pop it */
2793 repl = cLISTOPx(expr)->op_last;
2794 kid = cLISTOPx(expr)->op_first;
2795 while (kid->op_sibling != repl)
2796 kid = kid->op_sibling;
2797 kid->op_sibling = NULL;
2798 cLISTOPx(expr)->op_last = kid;
2801 if (isreg && expr->op_type == OP_LIST &&
2802 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
2804 /* convert single element list to element */
2805 OP* const oe = expr;
2806 expr = cLISTOPx(oe)->op_first->op_sibling;
2807 cLISTOPx(oe)->op_first->op_sibling = NULL;
2808 cLISTOPx(oe)->op_last = NULL;
2812 if (o->op_type == OP_TRANS) {
2813 return pmtrans(o, expr, repl);
2816 reglist = isreg && expr->op_type == OP_LIST;
2820 PL_hints |= HINT_BLOCK_SCOPE;
2823 if (expr->op_type == OP_CONST) {
2825 SV * const pat = ((SVOP*)expr)->op_sv;
2826 const char *p = SvPV_const(pat, plen);
2827 if ((o->op_flags & OPf_SPECIAL) && (*p == ' ' && p[1] == '\0')) {
2828 U32 was_readonly = SvREADONLY(pat);
2832 sv_force_normal_flags(pat, 0);
2833 assert(!SvREADONLY(pat));
2836 SvREADONLY_off(pat);
2840 sv_setpvn(pat, "\\s+", 3);
2842 SvFLAGS(pat) |= was_readonly;
2844 p = SvPV_const(pat, plen);
2845 pm->op_pmflags |= PMf_SKIPWHITE;
2848 pm->op_pmdynflags |= PMdf_UTF8;
2849 /* FIXME - can we make this function take const char * args? */
2850 PM_SETRE(pm, CALLREGCOMP(aTHX_ (char*)p, (char*)p + plen, pm));
2851 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
2852 pm->op_pmflags |= PMf_WHITE;
2856 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
2857 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2859 : OP_REGCMAYBE),0,expr);
2861 NewOp(1101, rcop, 1, LOGOP);
2862 rcop->op_type = OP_REGCOMP;
2863 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
2864 rcop->op_first = scalar(expr);
2865 rcop->op_flags |= OPf_KIDS
2866 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
2867 | (reglist ? OPf_STACKED : 0);
2868 rcop->op_private = 1;
2871 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
2873 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
2876 /* establish postfix order */
2877 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
2879 rcop->op_next = expr;
2880 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
2883 rcop->op_next = LINKLIST(expr);
2884 expr->op_next = (OP*)rcop;
2887 prepend_elem(o->op_type, scalar((OP*)rcop), o);
2892 if (pm->op_pmflags & PMf_EVAL) {
2894 if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
2895 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
2897 else if (repl->op_type == OP_CONST)
2901 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
2902 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
2903 if (curop->op_type == OP_GV) {
2904 GV * const gv = cGVOPx_gv(curop);
2906 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
2909 else if (curop->op_type == OP_RV2CV)
2911 else if (curop->op_type == OP_RV2SV ||
2912 curop->op_type == OP_RV2AV ||
2913 curop->op_type == OP_RV2HV ||
2914 curop->op_type == OP_RV2GV) {
2915 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
2918 else if (curop->op_type == OP_PADSV ||
2919 curop->op_type == OP_PADAV ||
2920 curop->op_type == OP_PADHV ||
2921 curop->op_type == OP_PADANY) {
2924 else if (curop->op_type == OP_PUSHRE)
2925 /*EMPTY*/; /* Okay here, dangerous in newASSIGNOP */
2935 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
2936 pm->op_pmflags |= PMf_CONST; /* const for long enough */
2937 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
2938 prepend_elem(o->op_type, scalar(repl), o);
2941 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
2942 pm->op_pmflags |= PMf_MAYBE_CONST;
2943 pm->op_pmpermflags |= PMf_MAYBE_CONST;
2945 NewOp(1101, rcop, 1, LOGOP);
2946 rcop->op_type = OP_SUBSTCONT;
2947 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
2948 rcop->op_first = scalar(repl);
2949 rcop->op_flags |= OPf_KIDS;
2950 rcop->op_private = 1;
2953 /* establish postfix order */
2954 rcop->op_next = LINKLIST(repl);
2955 repl->op_next = (OP*)rcop;
2957 pm->op_pmreplroot = scalar((OP*)rcop);
2958 pm->op_pmreplstart = LINKLIST(rcop);
2967 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
2971 NewOp(1101, svop, 1, SVOP);
2972 svop->op_type = (OPCODE)type;
2973 svop->op_ppaddr = PL_ppaddr[type];
2975 svop->op_next = (OP*)svop;
2976 svop->op_flags = (U8)flags;
2977 if (PL_opargs[type] & OA_RETSCALAR)
2979 if (PL_opargs[type] & OA_TARGET)
2980 svop->op_targ = pad_alloc(type, SVs_PADTMP);
2981 return CHECKOP(type, svop);
2985 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
2989 NewOp(1101, padop, 1, PADOP);
2990 padop->op_type = (OPCODE)type;
2991 padop->op_ppaddr = PL_ppaddr[type];
2992 padop->op_padix = pad_alloc(type, SVs_PADTMP);
2993 SvREFCNT_dec(PAD_SVl(padop->op_padix));
2994 PAD_SETSV(padop->op_padix, sv);
2997 padop->op_next = (OP*)padop;
2998 padop->op_flags = (U8)flags;
2999 if (PL_opargs[type] & OA_RETSCALAR)
3001 if (PL_opargs[type] & OA_TARGET)
3002 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3003 return CHECKOP(type, padop);
3007 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3013 return newPADOP(type, flags, SvREFCNT_inc(gv));
3015 return newSVOP(type, flags, SvREFCNT_inc(gv));
3020 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3024 NewOp(1101, pvop, 1, PVOP);
3025 pvop->op_type = (OPCODE)type;
3026 pvop->op_ppaddr = PL_ppaddr[type];
3028 pvop->op_next = (OP*)pvop;
3029 pvop->op_flags = (U8)flags;
3030 if (PL_opargs[type] & OA_RETSCALAR)
3032 if (PL_opargs[type] & OA_TARGET)
3033 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3034 return CHECKOP(type, pvop);
3038 Perl_package(pTHX_ OP *o)
3044 save_hptr(&PL_curstash);
3045 save_item(PL_curstname);
3047 name = SvPV_const(cSVOPo->op_sv, len);
3048 PL_curstash = gv_stashpvn(name, len, TRUE);
3049 sv_setpvn(PL_curstname, name, len);
3052 PL_hints |= HINT_BLOCK_SCOPE;
3053 PL_copline = NOLINE;
3058 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3065 if (idop->op_type != OP_CONST)
3066 Perl_croak(aTHX_ "Module name must be constant");
3071 SV * const vesv = ((SVOP*)version)->op_sv;
3073 if (!arg && !SvNIOKp(vesv)) {
3080 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3081 Perl_croak(aTHX_ "Version number must be constant number");
3083 /* Make copy of idop so we don't free it twice */
3084 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3086 /* Fake up a method call to VERSION */
3087 meth = newSVpvs_share("VERSION");
3088 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3089 append_elem(OP_LIST,
3090 prepend_elem(OP_LIST, pack, list(version)),
3091 newSVOP(OP_METHOD_NAMED, 0, meth)));
3095 /* Fake up an import/unimport */
3096 if (arg && arg->op_type == OP_STUB)
3097 imop = arg; /* no import on explicit () */
3098 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3099 imop = NULL; /* use 5.0; */
3101 idop->op_private |= OPpCONST_NOVER;
3106 /* Make copy of idop so we don't free it twice */
3107 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3109 /* Fake up a method call to import/unimport */
3111 ? newSVpvs_share("import") : newSVpvs_share("unimport");
3112 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3113 append_elem(OP_LIST,
3114 prepend_elem(OP_LIST, pack, list(arg)),
3115 newSVOP(OP_METHOD_NAMED, 0, meth)));
3118 /* Fake up the BEGIN {}, which does its thing immediately. */
3120 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
3123 append_elem(OP_LINESEQ,
3124 append_elem(OP_LINESEQ,
3125 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
3126 newSTATEOP(0, NULL, veop)),
3127 newSTATEOP(0, NULL, imop) ));
3129 /* The "did you use incorrect case?" warning used to be here.
3130 * The problem is that on case-insensitive filesystems one
3131 * might get false positives for "use" (and "require"):
3132 * "use Strict" or "require CARP" will work. This causes
3133 * portability problems for the script: in case-strict
3134 * filesystems the script will stop working.
3136 * The "incorrect case" warning checked whether "use Foo"
3137 * imported "Foo" to your namespace, but that is wrong, too:
3138 * there is no requirement nor promise in the language that
3139 * a Foo.pm should or would contain anything in package "Foo".
3141 * There is very little Configure-wise that can be done, either:
3142 * the case-sensitivity of the build filesystem of Perl does not
3143 * help in guessing the case-sensitivity of the runtime environment.
3146 PL_hints |= HINT_BLOCK_SCOPE;
3147 PL_copline = NOLINE;
3149 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3153 =head1 Embedding Functions
3155 =for apidoc load_module
3157 Loads the module whose name is pointed to by the string part of name.
3158 Note that the actual module name, not its filename, should be given.
3159 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3160 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3161 (or 0 for no flags). ver, if specified, provides version semantics
3162 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3163 arguments can be used to specify arguments to the module's import()
3164 method, similar to C<use Foo::Bar VERSION LIST>.
3169 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3172 va_start(args, ver);
3173 vload_module(flags, name, ver, &args);
3177 #ifdef PERL_IMPLICIT_CONTEXT
3179 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3183 va_start(args, ver);
3184 vload_module(flags, name, ver, &args);
3190 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3195 OP * const modname = newSVOP(OP_CONST, 0, name);
3196 modname->op_private |= OPpCONST_BARE;
3198 veop = newSVOP(OP_CONST, 0, ver);
3202 if (flags & PERL_LOADMOD_NOIMPORT) {
3203 imop = sawparens(newNULLLIST());
3205 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3206 imop = va_arg(*args, OP*);
3211 sv = va_arg(*args, SV*);
3213 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3214 sv = va_arg(*args, SV*);
3218 const line_t ocopline = PL_copline;
3219 COP * const ocurcop = PL_curcop;
3220 const int oexpect = PL_expect;
3222 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3223 veop, modname, imop);
3224 PL_expect = oexpect;
3225 PL_copline = ocopline;
3226 PL_curcop = ocurcop;
3231 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
3237 if (!force_builtin) {
3238 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
3239 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
3240 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
3241 gv = gvp ? *gvp : NULL;
3245 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3246 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3247 append_elem(OP_LIST, term,
3248 scalar(newUNOP(OP_RV2CV, 0,
3253 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3259 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3261 return newBINOP(OP_LSLICE, flags,
3262 list(force_list(subscript)),
3263 list(force_list(listval)) );
3267 S_is_list_assignment(pTHX_ register const OP *o)
3272 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3273 o = cUNOPo->op_first;
3275 if (o->op_type == OP_COND_EXPR) {
3276 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
3277 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3282 yyerror("Assignment to both a list and a scalar");
3286 if (o->op_type == OP_LIST &&
3287 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3288 o->op_private & OPpLVAL_INTRO)
3291 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3292 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3293 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3296 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3299 if (o->op_type == OP_RV2SV)
3306 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3312 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3313 return newLOGOP(optype, 0,
3314 mod(scalar(left), optype),
3315 newUNOP(OP_SASSIGN, 0, scalar(right)));
3318 return newBINOP(optype, OPf_STACKED,
3319 mod(scalar(left), optype), scalar(right));
3323 if (is_list_assignment(left)) {
3327 /* Grandfathering $[ assignment here. Bletch.*/
3328 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
3329 PL_eval_start = (left->op_type == OP_CONST) ? right : 0;
3330 left = mod(left, OP_AASSIGN);
3333 else if (left->op_type == OP_CONST) {
3334 /* Result of assignment is always 1 (or we'd be dead already) */
3335 return newSVOP(OP_CONST, 0, newSViv(1));
3337 curop = list(force_list(left));
3338 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3339 o->op_private = (U8)(0 | (flags >> 8));
3341 /* PL_generation sorcery:
3342 * an assignment like ($a,$b) = ($c,$d) is easier than
3343 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3344 * To detect whether there are common vars, the global var
3345 * PL_generation is incremented for each assign op we compile.
3346 * Then, while compiling the assign op, we run through all the
3347 * variables on both sides of the assignment, setting a spare slot
3348 * in each of them to PL_generation. If any of them already have
3349 * that value, we know we've got commonality. We could use a
3350 * single bit marker, but then we'd have to make 2 passes, first
3351 * to clear the flag, then to test and set it. To find somewhere
3352 * to store these values, evil chicanery is done with SvCUR().
3355 if (!(left->op_private & OPpLVAL_INTRO)) {
3358 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3359 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3360 if (curop->op_type == OP_GV) {
3361 GV *gv = cGVOPx_gv(curop);
3362 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3364 SvCUR_set(gv, PL_generation);
3366 else if (curop->op_type == OP_PADSV ||
3367 curop->op_type == OP_PADAV ||
3368 curop->op_type == OP_PADHV ||
3369 curop->op_type == OP_PADANY)
3371 if (PAD_COMPNAME_GEN(curop->op_targ)
3372 == (STRLEN)PL_generation)
3374 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
3377 else if (curop->op_type == OP_RV2CV)
3379 else if (curop->op_type == OP_RV2SV ||
3380 curop->op_type == OP_RV2AV ||
3381 curop->op_type == OP_RV2HV ||
3382 curop->op_type == OP_RV2GV) {
3383 if (lastop->op_type != OP_GV) /* funny deref? */
3386 else if (curop->op_type == OP_PUSHRE) {
3387 if (((PMOP*)curop)->op_pmreplroot) {
3389 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3390 ((PMOP*)curop)->op_pmreplroot));
3392 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3394 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3396 SvCUR_set(gv, PL_generation);
3405 o->op_private |= OPpASSIGN_COMMON;
3407 if (right && right->op_type == OP_SPLIT) {
3409 if ((tmpop = ((LISTOP*)right)->op_first) &&
3410 tmpop->op_type == OP_PUSHRE)
3412 PMOP * const pm = (PMOP*)tmpop;
3413 if (left->op_type == OP_RV2AV &&
3414 !(left->op_private & OPpLVAL_INTRO) &&
3415 !(o->op_private & OPpASSIGN_COMMON) )
3417 tmpop = ((UNOP*)left)->op_first;
3418 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3420 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3421 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3423 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3424 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
3426 pm->op_pmflags |= PMf_ONCE;
3427 tmpop = cUNOPo->op_first; /* to list (nulled) */
3428 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3429 tmpop->op_sibling = NULL; /* don't free split */
3430 right->op_next = tmpop->op_next; /* fix starting loc */
3431 op_free(o); /* blow off assign */
3432 right->op_flags &= ~OPf_WANT;
3433 /* "I don't know and I don't care." */
3438 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3439 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3441 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3443 sv_setiv(sv, PL_modcount+1);
3451 right = newOP(OP_UNDEF, 0);
3452 if (right->op_type == OP_READLINE) {
3453 right->op_flags |= OPf_STACKED;
3454 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3457 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3458 o = newBINOP(OP_SASSIGN, flags,
3459 scalar(right), mod(scalar(left), OP_SASSIGN) );
3463 o = newSVOP(OP_CONST, 0, newSViv(PL_compiling.cop_arybase));
3470 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3473 const U32 seq = intro_my();
3476 NewOp(1101, cop, 1, COP);
3477 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3478 cop->op_type = OP_DBSTATE;
3479 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3482 cop->op_type = OP_NEXTSTATE;
3483 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3485 cop->op_flags = (U8)flags;
3486 cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
3488 cop->op_private |= NATIVE_HINTS;
3490 PL_compiling.op_private = cop->op_private;
3491 cop->op_next = (OP*)cop;
3494 cop->cop_label = label;
3495 PL_hints |= HINT_BLOCK_SCOPE;
3498 cop->cop_arybase = PL_curcop->cop_arybase;
3499 if (specialWARN(PL_curcop->cop_warnings))
3500 cop->cop_warnings = PL_curcop->cop_warnings ;
3502 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3503 if (specialCopIO(PL_curcop->cop_io))
3504 cop->cop_io = PL_curcop->cop_io;
3506 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3509 if (PL_copline == NOLINE)
3510 CopLINE_set(cop, CopLINE(PL_curcop));
3512 CopLINE_set(cop, PL_copline);
3513 PL_copline = NOLINE;
3516 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3518 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3520 CopSTASH_set(cop, PL_curstash);
3522 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3523 SV * const * const svp = av_fetch(CopFILEAVx(PL_curcop), (I32)CopLINE(cop), FALSE);
3524 if (svp && *svp != &PL_sv_undef ) {
3525 (void)SvIOK_on(*svp);
3526 SvIV_set(*svp, PTR2IV(cop));
3530 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3535 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3538 return new_logop(type, flags, &first, &other);
3542 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3547 OP *first = *firstp;
3548 OP * const other = *otherp;
3550 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3551 return newBINOP(type, flags, scalar(first), scalar(other));
3553 scalarboolean(first);
3554 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3555 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3556 if (type == OP_AND || type == OP_OR) {
3562 first = *firstp = cUNOPo->op_first;
3564 first->op_next = o->op_next;
3565 cUNOPo->op_first = NULL;
3569 if (first->op_type == OP_CONST) {
3570 if (first->op_private & OPpCONST_STRICT)
3571 no_bareword_allowed(first);
3572 else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
3573 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
3574 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
3575 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
3576 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
3579 if (other->op_type == OP_CONST)
3580 other->op_private |= OPpCONST_SHORTCIRCUIT;
3584 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
3585 const OP *o2 = other;
3586 if ( ! (o2->op_type == OP_LIST
3587 && (( o2 = cUNOPx(o2)->op_first))
3588 && o2->op_type == OP_PUSHMARK
3589 && (( o2 = o2->op_sibling)) )
3592 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
3593 || o2->op_type == OP_PADHV)
3594 && o2->op_private & OPpLVAL_INTRO
3595 && ckWARN(WARN_DEPRECATED))
3597 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
3598 "Deprecated use of my() in false conditional");
3603 if (first->op_type == OP_CONST)
3604 first->op_private |= OPpCONST_SHORTCIRCUIT;
3608 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
3609 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
3611 const OP * const k1 = ((UNOP*)first)->op_first;
3612 const OP * const k2 = k1->op_sibling;
3614 switch (first->op_type)
3617 if (k2 && k2->op_type == OP_READLINE
3618 && (k2->op_flags & OPf_STACKED)
3619 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3621 warnop = k2->op_type;
3626 if (k1->op_type == OP_READDIR
3627 || k1->op_type == OP_GLOB
3628 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3629 || k1->op_type == OP_EACH)
3631 warnop = ((k1->op_type == OP_NULL)
3632 ? (OPCODE)k1->op_targ : k1->op_type);
3637 const line_t oldline = CopLINE(PL_curcop);
3638 CopLINE_set(PL_curcop, PL_copline);
3639 Perl_warner(aTHX_ packWARN(WARN_MISC),
3640 "Value of %s%s can be \"0\"; test with defined()",
3642 ((warnop == OP_READLINE || warnop == OP_GLOB)
3643 ? " construct" : "() operator"));
3644 CopLINE_set(PL_curcop, oldline);
3651 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
3652 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3654 NewOp(1101, logop, 1, LOGOP);
3656 logop->op_type = (OPCODE)type;
3657 logop->op_ppaddr = PL_ppaddr[type];
3658 logop->op_first = first;
3659 logop->op_flags = (U8)(flags | OPf_KIDS);
3660 logop->op_other = LINKLIST(other);
3661 logop->op_private = (U8)(1 | (flags >> 8));
3663 /* establish postfix order */
3664 logop->op_next = LINKLIST(first);
3665 first->op_next = (OP*)logop;
3666 first->op_sibling = other;
3668 CHECKOP(type,logop);
3670 o = newUNOP(OP_NULL, 0, (OP*)logop);
3677 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3685 return newLOGOP(OP_AND, 0, first, trueop);
3687 return newLOGOP(OP_OR, 0, first, falseop);
3689 scalarboolean(first);
3690 if (first->op_type == OP_CONST) {
3691 if (first->op_private & OPpCONST_BARE &&
3692 first->op_private & OPpCONST_STRICT) {
3693 no_bareword_allowed(first);
3695 if (SvTRUE(((SVOP*)first)->op_sv)) {
3706 NewOp(1101, logop, 1, LOGOP);
3707 logop->op_type = OP_COND_EXPR;
3708 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3709 logop->op_first = first;
3710 logop->op_flags = (U8)(flags | OPf_KIDS);
3711 logop->op_private = (U8)(1 | (flags >> 8));
3712 logop->op_other = LINKLIST(trueop);
3713 logop->op_next = LINKLIST(falseop);
3715 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
3718 /* establish postfix order */
3719 start = LINKLIST(first);
3720 first->op_next = (OP*)logop;
3722 first->op_sibling = trueop;
3723 trueop->op_sibling = falseop;
3724 o = newUNOP(OP_NULL, 0, (OP*)logop);
3726 trueop->op_next = falseop->op_next = o;
3733 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3742 NewOp(1101, range, 1, LOGOP);
3744 range->op_type = OP_RANGE;
3745 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3746 range->op_first = left;
3747 range->op_flags = OPf_KIDS;
3748 leftstart = LINKLIST(left);
3749 range->op_other = LINKLIST(right);
3750 range->op_private = (U8)(1 | (flags >> 8));
3752 left->op_sibling = right;
3754 range->op_next = (OP*)range;
3755 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3756 flop = newUNOP(OP_FLOP, 0, flip);
3757 o = newUNOP(OP_NULL, 0, flop);
3759 range->op_next = leftstart;
3761 left->op_next = flip;
3762 right->op_next = flop;
3764 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3765 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3766 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3767 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3769 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3770 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3773 if (!flip->op_private || !flop->op_private)
3774 linklist(o); /* blow off optimizer unless constant */
3780 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3785 const bool once = block && block->op_flags & OPf_SPECIAL &&
3786 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3788 PERL_UNUSED_ARG(debuggable);
3791 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3792 return block; /* do {} while 0 does once */
3793 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3794 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3795 expr = newUNOP(OP_DEFINED, 0,
3796 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3797 } else if (expr->op_flags & OPf_KIDS) {
3798 const OP * const k1 = ((UNOP*)expr)->op_first;
3799 const OP * const k2 = k1 ? k1->op_sibling : NULL;
3800 switch (expr->op_type) {
3802 if (k2 && k2->op_type == OP_READLINE
3803 && (k2->op_flags & OPf_STACKED)
3804 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3805 expr = newUNOP(OP_DEFINED, 0, expr);
3809 if (k1->op_type == OP_READDIR
3810 || k1->op_type == OP_GLOB
3811 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3812 || k1->op_type == OP_EACH)
3813 expr = newUNOP(OP_DEFINED, 0, expr);
3819 /* if block is null, the next append_elem() would put UNSTACK, a scalar
3820 * op, in listop. This is wrong. [perl #27024] */
3822 block = newOP(OP_NULL, 0);
3823 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3824 o = new_logop(OP_AND, 0, &expr, &listop);
3827 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3829 if (once && o != listop)
3830 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3833 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3835 o->op_flags |= flags;
3837 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3842 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
3843 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
3852 PERL_UNUSED_ARG(debuggable);
3855 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3856 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3857 expr = newUNOP(OP_DEFINED, 0,
3858 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3859 } else if (expr->op_flags & OPf_KIDS) {
3860 const OP * const k1 = ((UNOP*)expr)->op_first;
3861 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
3862 switch (expr->op_type) {
3864 if (k2 && k2->op_type == OP_READLINE
3865 && (k2->op_flags & OPf_STACKED)
3866 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3867 expr = newUNOP(OP_DEFINED, 0, expr);
3871 if (k1->op_type == OP_READDIR
3872 || k1->op_type == OP_GLOB
3873 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3874 || k1->op_type == OP_EACH)
3875 expr = newUNOP(OP_DEFINED, 0, expr);
3882 block = newOP(OP_NULL, 0);
3883 else if (cont || has_my) {
3884 block = scope(block);
3888 next = LINKLIST(cont);
3891 OP * const unstack = newOP(OP_UNSTACK, 0);
3894 cont = append_elem(OP_LINESEQ, cont, unstack);
3897 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3898 redo = LINKLIST(listop);
3901 PL_copline = (line_t)whileline;
3903 o = new_logop(OP_AND, 0, &expr, &listop);
3904 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3905 op_free(expr); /* oops, it's a while (0) */
3907 return NULL; /* listop already freed by new_logop */
3910 ((LISTOP*)listop)->op_last->op_next =
3911 (o == listop ? redo : LINKLIST(o));
3917 NewOp(1101,loop,1,LOOP);
3918 loop->op_type = OP_ENTERLOOP;
3919 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3920 loop->op_private = 0;
3921 loop->op_next = (OP*)loop;
3924 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
3926 loop->op_redoop = redo;
3927 loop->op_lastop = o;
3928 o->op_private |= loopflags;
3931 loop->op_nextop = next;
3933 loop->op_nextop = o;
3935 o->op_flags |= flags;
3936 o->op_private |= (flags >> 8);
3941 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
3946 PADOFFSET padoff = 0;
3951 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
3952 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
3953 sv->op_type = OP_RV2GV;
3954 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
3955 if (cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
3956 iterpflags |= OPpITER_DEF;
3958 else if (sv->op_type == OP_PADSV) { /* private variable */
3959 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
3960 padoff = sv->op_targ;
3965 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
3966 padoff = sv->op_targ;
3968 iterflags |= OPf_SPECIAL;
3973 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
3974 if (padoff && strEQ(PAD_COMPNAME_PV(padoff), "$_"))
3975 iterpflags |= OPpITER_DEF;
3978 const I32 offset = pad_findmy("$_");
3979 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
3980 sv = newGVOP(OP_GV, 0, PL_defgv);
3985 iterpflags |= OPpITER_DEF;
3987 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
3988 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
3989 iterflags |= OPf_STACKED;
3991 else if (expr->op_type == OP_NULL &&
3992 (expr->op_flags & OPf_KIDS) &&
3993 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
3995 /* Basically turn for($x..$y) into the same as for($x,$y), but we
3996 * set the STACKED flag to indicate that these values are to be
3997 * treated as min/max values by 'pp_iterinit'.
3999 UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4000 LOGOP* const range = (LOGOP*) flip->op_first;
4001 OP* const left = range->op_first;
4002 OP* const right = left->op_sibling;
4005 range->op_flags &= ~OPf_KIDS;
4006 range->op_first = NULL;
4008 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4009 listop->op_first->op_next = range->op_next;
4010 left->op_next = range->op_other;
4011 right->op_next = (OP*)listop;
4012 listop->op_next = listop->op_first;
4015 expr = (OP*)(listop);
4017 iterflags |= OPf_STACKED;
4020 expr = mod(force_list(expr), OP_GREPSTART);
4023 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4024 append_elem(OP_LIST, expr, scalar(sv))));
4025 assert(!loop->op_next);
4026 /* for my $x () sets OPpLVAL_INTRO;
4027 * for our $x () sets OPpOUR_INTRO */
4028 loop->op_private = (U8)iterpflags;
4029 #ifdef PL_OP_SLAB_ALLOC
4032 NewOp(1234,tmp,1,LOOP);
4033 Copy(loop,tmp,1,LISTOP);
4038 Renew(loop, 1, LOOP);
4040 loop->op_targ = padoff;
4041 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
4042 PL_copline = forline;
4043 return newSTATEOP(0, label, wop);
4047 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4052 if (type != OP_GOTO || label->op_type == OP_CONST) {
4053 /* "last()" means "last" */
4054 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4055 o = newOP(type, OPf_SPECIAL);
4057 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4058 ? SvPVx_nolen_const(((SVOP*)label)->op_sv)
4064 /* Check whether it's going to be a goto &function */
4065 if (label->op_type == OP_ENTERSUB
4066 && !(label->op_flags & OPf_STACKED))
4067 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4068 o = newUNOP(type, OPf_STACKED, label);
4070 PL_hints |= HINT_BLOCK_SCOPE;
4074 /* if the condition is a literal array or hash
4075 (or @{ ... } etc), make a reference to it.
4078 S_ref_array_or_hash(pTHX_ OP *cond)
4081 && (cond->op_type == OP_RV2AV
4082 || cond->op_type == OP_PADAV
4083 || cond->op_type == OP_RV2HV
4084 || cond->op_type == OP_PADHV))
4086 return newUNOP(OP_REFGEN,
4087 0, mod(cond, OP_REFGEN));
4093 /* These construct the optree fragments representing given()
4096 entergiven and enterwhen are LOGOPs; the op_other pointer
4097 points up to the associated leave op. We need this so we
4098 can put it in the context and make break/continue work.
4099 (Also, of course, pp_enterwhen will jump straight to
4100 op_other if the match fails.)
4105 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
4106 I32 enter_opcode, I32 leave_opcode,
4107 PADOFFSET entertarg)
4113 NewOp(1101, enterop, 1, LOGOP);
4114 enterop->op_type = enter_opcode;
4115 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
4116 enterop->op_flags = (U8) OPf_KIDS;
4117 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
4118 enterop->op_private = 0;
4120 o = newUNOP(leave_opcode, 0, (OP *) enterop);
4123 enterop->op_first = scalar(cond);
4124 cond->op_sibling = block;
4126 o->op_next = LINKLIST(cond);
4127 cond->op_next = (OP *) enterop;
4130 /* This is a default {} block */
4131 enterop->op_first = block;
4132 enterop->op_flags |= OPf_SPECIAL;
4134 o->op_next = (OP *) enterop;
4137 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
4138 entergiven and enterwhen both
4141 enterop->op_next = LINKLIST(block);
4142 block->op_next = enterop->op_other = o;
4147 /* Does this look like a boolean operation? For these purposes
4148 a boolean operation is:
4149 - a subroutine call [*]
4150 - a logical connective
4151 - a comparison operator
4152 - a filetest operator, with the exception of -s -M -A -C
4153 - defined(), exists() or eof()
4154 - /$re/ or $foo =~ /$re/
4156 [*] possibly surprising
4160 S_looks_like_bool(pTHX_ OP *o)
4163 switch(o->op_type) {
4165 return looks_like_bool(cLOGOPo->op_first);
4169 looks_like_bool(cLOGOPo->op_first)
4170 && looks_like_bool(cLOGOPo->op_first->op_sibling));
4174 case OP_NOT: case OP_XOR:
4175 /* Note that OP_DOR is not here */
4177 case OP_EQ: case OP_NE: case OP_LT:
4178 case OP_GT: case OP_LE: case OP_GE:
4180 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
4181 case OP_I_GT: case OP_I_LE: case OP_I_GE:
4183 case OP_SEQ: case OP_SNE: case OP_SLT:
4184 case OP_SGT: case OP_SLE: case OP_SGE:
4188 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
4189 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
4190 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
4191 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
4192 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
4193 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
4194 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
4195 case OP_FTTEXT: case OP_FTBINARY:
4197 case OP_DEFINED: case OP_EXISTS:
4198 case OP_MATCH: case OP_EOF:
4203 /* Detect comparisons that have been optimized away */
4204 if (cSVOPo->op_sv == &PL_sv_yes
4205 || cSVOPo->op_sv == &PL_sv_no)
4216 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
4220 return newGIVWHENOP(
4221 ref_array_or_hash(cond),
4223 OP_ENTERGIVEN, OP_LEAVEGIVEN,
4227 /* If cond is null, this is a default {} block */
4229 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
4231 bool cond_llb = (!cond || looks_like_bool(cond));
4237 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
4239 scalar(ref_array_or_hash(cond)));
4242 return newGIVWHENOP(
4244 append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
4245 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
4249 =for apidoc cv_undef
4251 Clear out all the active components of a CV. This can happen either
4252 by an explicit C<undef &foo>, or by the reference count going to zero.
4253 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
4254 children can still follow the full lexical scope chain.
4260 Perl_cv_undef(pTHX_ CV *cv)
4264 if (CvFILE(cv) && !CvISXSUB(cv)) {
4265 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4266 Safefree(CvFILE(cv));
4271 if (!CvISXSUB(cv) && CvROOT(cv)) {
4272 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
4273 Perl_croak(aTHX_ "Can't undef active subroutine");
4276 PAD_SAVE_SETNULLPAD();
4278 op_free(CvROOT(cv));
4283 SvPOK_off((SV*)cv); /* forget prototype */
4288 /* remove CvOUTSIDE unless this is an undef rather than a free */
4289 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
4290 if (!CvWEAKOUTSIDE(cv))
4291 SvREFCNT_dec(CvOUTSIDE(cv));
4292 CvOUTSIDE(cv) = NULL;
4295 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4298 if (CvISXSUB(cv) && CvXSUB(cv)) {
4301 /* delete all flags except WEAKOUTSIDE */
4302 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
4306 Perl_cv_ckproto(pTHX_ const CV *cv, const GV *gv, const char *p)
4308 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX_const(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4309 SV* const msg = sv_newmortal();
4313 gv_efullname3(name = sv_newmortal(), gv, NULL);
4314 sv_setpv(msg, "Prototype mismatch:");
4316 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4318 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (const SV *)cv);
4320 sv_catpvs(msg, ": none");
4321 sv_catpvs(msg, " vs ");
4323 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4325 sv_catpvs(msg, "none");
4326 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
4330 static void const_sv_xsub(pTHX_ CV* cv);
4334 =head1 Optree Manipulation Functions
4336 =for apidoc cv_const_sv
4338 If C<cv> is a constant sub eligible for inlining. returns the constant
4339 value returned by the sub. Otherwise, returns NULL.
4341 Constant subs can be created with C<newCONSTSUB> or as described in
4342 L<perlsub/"Constant Functions">.
4347 Perl_cv_const_sv(pTHX_ CV *cv)
4351 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
4353 return CvCONST(cv) ? (SV*)CvXSUBANY(cv).any_ptr : NULL;
4356 /* op_const_sv: examine an optree to determine whether it's in-lineable.
4357 * Can be called in 3 ways:
4360 * look for a single OP_CONST with attached value: return the value
4362 * cv && CvCLONE(cv) && !CvCONST(cv)
4364 * examine the clone prototype, and if contains only a single
4365 * OP_CONST referencing a pad const, or a single PADSV referencing
4366 * an outer lexical, return a non-zero value to indicate the CV is
4367 * a candidate for "constizing" at clone time
4371 * We have just cloned an anon prototype that was marked as a const
4372 * candidiate. Try to grab the current value, and in the case of
4373 * PADSV, ignore it if it has multiple references. Return the value.
4377 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
4385 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4386 o = cLISTOPo->op_first->op_sibling;
4388 for (; o; o = o->op_next) {
4389 const OPCODE type = o->op_type;
4391 if (sv && o->op_next == o)
4393 if (o->op_next != o) {
4394 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4396 if (type == OP_DBSTATE)
4399 if (type == OP_LEAVESUB || type == OP_RETURN)
4403 if (type == OP_CONST && cSVOPo->op_sv)
4405 else if (cv && type == OP_CONST) {
4406 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4410 else if (cv && type == OP_PADSV) {
4411 if (CvCONST(cv)) { /* newly cloned anon */
4412 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4413 /* the candidate should have 1 ref from this pad and 1 ref
4414 * from the parent */
4415 if (!sv || SvREFCNT(sv) != 2)
4422 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
4423 sv = &PL_sv_undef; /* an arbitrary non-null value */
4434 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4436 PERL_UNUSED_ARG(floor);
4446 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4450 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4452 return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
4456 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4463 register CV *cv = NULL;
4465 /* If the subroutine has no body, no attributes, and no builtin attributes
4466 then it's just a sub declaration, and we may be able to get away with
4467 storing with a placeholder scalar in the symbol table, rather than a
4468 full GV and CV. If anything is present then it will take a full CV to
4470 const I32 gv_fetch_flags
4471 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
4472 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
4473 const char * const name = o ? SvPVx_nolen_const(cSVOPo->op_sv) : NULL;
4476 assert(proto->op_type == OP_CONST);
4477 ps = SvPVx_const(((SVOP*)proto)->op_sv, ps_len);
4482 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4483 SV * const sv = sv_newmortal();
4484 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4485 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
4486 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4487 aname = SvPVX_const(sv);
4492 gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
4493 : gv_fetchpv(aname ? aname
4494 : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4495 gv_fetch_flags, SVt_PVCV);
4504 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4505 maximum a prototype before. */
4506 if (SvTYPE(gv) > SVt_NULL) {
4507 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4508 && ckWARN_d(WARN_PROTOTYPE))
4510 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
4512 cv_ckproto((CV*)gv, NULL, ps);
4515 sv_setpvn((SV*)gv, ps, ps_len);
4517 sv_setiv((SV*)gv, -1);
4518 SvREFCNT_dec(PL_compcv);
4519 cv = PL_compcv = NULL;
4520 PL_sub_generation++;
4524 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
4526 #ifdef GV_UNIQUE_CHECK
4527 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4528 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4532 if (!block || !ps || *ps || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
4535 const_sv = op_const_sv(block, NULL);
4538 const bool exists = CvROOT(cv) || CvXSUB(cv);
4540 #ifdef GV_UNIQUE_CHECK
4541 if (exists && GvUNIQUE(gv)) {
4542 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4546 /* if the subroutine doesn't exist and wasn't pre-declared
4547 * with a prototype, assume it will be AUTOLOADed,
4548 * skipping the prototype check
4550 if (exists || SvPOK(cv))
4551 cv_ckproto(cv, gv, ps);
4552 /* already defined (or promised)? */
4553 if (exists || GvASSUMECV(gv)) {
4554 if (!block && !attrs) {
4555 if (CvFLAGS(PL_compcv)) {
4556 /* might have had built-in attrs applied */
4557 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4559 /* just a "sub foo;" when &foo is already defined */
4560 SAVEFREESV(PL_compcv);
4564 if (ckWARN(WARN_REDEFINE)
4566 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4568 const line_t oldline = CopLINE(PL_curcop);
4569 if (PL_copline != NOLINE)
4570 CopLINE_set(PL_curcop, PL_copline);
4571 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4572 CvCONST(cv) ? "Constant subroutine %s redefined"
4573 : "Subroutine %s redefined", name);
4574 CopLINE_set(PL_curcop, oldline);
4582 (void)SvREFCNT_inc(const_sv);
4584 assert(!CvROOT(cv) && !CvCONST(cv));
4585 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
4586 CvXSUBANY(cv).any_ptr = const_sv;
4587 CvXSUB(cv) = const_sv_xsub;
4593 cv = newCONSTSUB(NULL, name, const_sv);
4596 SvREFCNT_dec(PL_compcv);
4598 PL_sub_generation++;
4605 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4606 * before we clobber PL_compcv.
4610 /* Might have had built-in attributes applied -- propagate them. */
4611 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4612 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4613 stash = GvSTASH(CvGV(cv));
4614 else if (CvSTASH(cv))
4615 stash = CvSTASH(cv);
4617 stash = PL_curstash;
4620 /* possibly about to re-define existing subr -- ignore old cv */
4621 rcv = (SV*)PL_compcv;
4622 if (name && GvSTASH(gv))
4623 stash = GvSTASH(gv);
4625 stash = PL_curstash;
4627 apply_attrs(stash, rcv, attrs, FALSE);
4629 if (cv) { /* must reuse cv if autoloaded */
4631 /* got here with just attrs -- work done, so bug out */
4632 SAVEFREESV(PL_compcv);
4635 /* transfer PL_compcv to cv */
4637 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4638 if (!CvWEAKOUTSIDE(cv))
4639 SvREFCNT_dec(CvOUTSIDE(cv));
4640 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4641 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
4642 CvOUTSIDE(PL_compcv) = 0;
4643 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4644 CvPADLIST(PL_compcv) = 0;
4645 /* inner references to PL_compcv must be fixed up ... */
4646 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
4647 /* ... before we throw it away */
4648 SvREFCNT_dec(PL_compcv);
4650 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4651 ++PL_sub_generation;
4658 PL_sub_generation++;
4662 CvFILE_set_from_cop(cv, PL_curcop);
4663 CvSTASH(cv) = PL_curstash;
4666 sv_setpvn((SV*)cv, ps, ps_len);
4668 if (PL_error_count) {
4672 const char *s = strrchr(name, ':');
4674 if (strEQ(s, "BEGIN")) {
4675 const char not_safe[] =
4676 "BEGIN not safe after errors--compilation aborted";
4677 if (PL_in_eval & EVAL_KEEPERR)
4678 Perl_croak(aTHX_ not_safe);
4680 /* force display of errors found but not reported */
4681 sv_catpv(ERRSV, not_safe);
4682 Perl_croak(aTHX_ "%"SVf, ERRSV);
4691 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4692 mod(scalarseq(block), OP_LEAVESUBLV));
4695 /* This makes sub {}; work as expected. */
4696 if (block->op_type == OP_STUB) {
4698 block = newSTATEOP(0, NULL, 0);
4700 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4702 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4703 OpREFCNT_set(CvROOT(cv), 1);
4704 CvSTART(cv) = LINKLIST(CvROOT(cv));
4705 CvROOT(cv)->op_next = 0;
4706 CALL_PEEP(CvSTART(cv));
4708 /* now that optimizer has done its work, adjust pad values */
4710 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4713 assert(!CvCONST(cv));
4714 if (ps && !*ps && op_const_sv(block, cv))
4718 if (name || aname) {
4720 const char * const tname = (name ? name : aname);
4722 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4723 SV * const sv = newSV(0);
4724 SV * const tmpstr = sv_newmortal();
4725 GV * const db_postponed = gv_fetchpvs("DB::postponed",
4726 GV_ADDMULTI, SVt_PVHV);
4729 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4731 (long)PL_subline, (long)CopLINE(PL_curcop));
4732 gv_efullname3(tmpstr, gv, NULL);
4733 hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0);
4734 hv = GvHVn(db_postponed);
4735 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
4736 CV * const pcv = GvCV(db_postponed);
4742 call_sv((SV*)pcv, G_DISCARD);
4747 if ((s = strrchr(tname,':')))
4752 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4755 if (strEQ(s, "BEGIN") && !PL_error_count) {
4756 const I32 oldscope = PL_scopestack_ix;
4758 SAVECOPFILE(&PL_compiling);
4759 SAVECOPLINE(&PL_compiling);
4762 PL_beginav = newAV();
4763 DEBUG_x( dump_sub(gv) );
4764 av_push(PL_beginav, (SV*)cv);
4765 GvCV(gv) = 0; /* cv has been hijacked */
4766 call_list(oldscope, PL_beginav);
4768 PL_curcop = &PL_compiling;
4769 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4772 else if (strEQ(s, "END") && !PL_error_count) {
4775 DEBUG_x( dump_sub(gv) );
4776 av_unshift(PL_endav, 1);
4777 av_store(PL_endav, 0, (SV*)cv);
4778 GvCV(gv) = 0; /* cv has been hijacked */
4780 else if (strEQ(s, "CHECK") && !PL_error_count) {
4782 PL_checkav = newAV();
4783 DEBUG_x( dump_sub(gv) );
4784 if (PL_main_start && ckWARN(WARN_VOID))
4785 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4786 av_unshift(PL_checkav, 1);
4787 av_store(PL_checkav, 0, (SV*)cv);
4788 GvCV(gv) = 0; /* cv has been hijacked */
4790 else if (strEQ(s, "INIT") && !PL_error_count) {
4792 PL_initav = newAV();
4793 DEBUG_x( dump_sub(gv) );
4794 if (PL_main_start && ckWARN(WARN_VOID))
4795 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4796 av_push(PL_initav, (SV*)cv);
4797 GvCV(gv) = 0; /* cv has been hijacked */
4802 PL_copline = NOLINE;
4807 /* XXX unsafe for threads if eval_owner isn't held */
4809 =for apidoc newCONSTSUB
4811 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4812 eligible for inlining at compile-time.
4818 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
4825 SAVECOPLINE(PL_curcop);
4826 CopLINE_set(PL_curcop, PL_copline);
4829 PL_hints &= ~HINT_BLOCK_SCOPE;
4832 SAVESPTR(PL_curstash);
4833 SAVECOPSTASH(PL_curcop);
4834 PL_curstash = stash;
4835 CopSTASH_set(PL_curcop,stash);
4838 cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
4839 CvXSUBANY(cv).any_ptr = sv;
4841 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
4845 CopSTASH_free(PL_curcop);
4853 =for apidoc U||newXS
4855 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4861 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
4864 GV * const gv = gv_fetchpv(name ? name :
4865 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4866 GV_ADDMULTI, SVt_PVCV);
4870 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4872 if ((cv = (name ? GvCV(gv) : NULL))) {
4874 /* just a cached method */
4878 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4879 /* already defined (or promised) */
4880 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
4881 if (ckWARN(WARN_REDEFINE)) {
4882 GV * const gvcv = CvGV(cv);
4884 HV * const stash = GvSTASH(gvcv);
4886 const char *redefined_name = HvNAME_get(stash);
4887 if ( strEQ(redefined_name,"autouse") ) {
4888 const line_t oldline = CopLINE(PL_curcop);
4889 if (PL_copline != NOLINE)
4890 CopLINE_set(PL_curcop, PL_copline);
4891 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4892 CvCONST(cv) ? "Constant subroutine %s redefined"
4893 : "Subroutine %s redefined"
4895 CopLINE_set(PL_curcop, oldline);
4905 if (cv) /* must reuse cv if autoloaded */
4909 sv_upgrade((SV *)cv, SVt_PVCV);
4913 PL_sub_generation++;
4917 (void)gv_fetchfile(filename);
4918 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
4919 an external constant string */
4921 CvXSUB(cv) = subaddr;
4924 const char *s = strrchr(name,':');
4930 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4933 if (strEQ(s, "BEGIN")) {
4935 PL_beginav = newAV();
4936 av_push(PL_beginav, (SV*)cv);
4937 GvCV(gv) = 0; /* cv has been hijacked */
4939 else if (strEQ(s, "END")) {
4942 av_unshift(PL_endav, 1);
4943 av_store(PL_endav, 0, (SV*)cv);
4944 GvCV(gv) = 0; /* cv has been hijacked */
4946 else if (strEQ(s, "CHECK")) {
4948 PL_checkav = newAV();
4949 if (PL_main_start && ckWARN(WARN_VOID))
4950 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4951 av_unshift(PL_checkav, 1);
4952 av_store(PL_checkav, 0, (SV*)cv);
4953 GvCV(gv) = 0; /* cv has been hijacked */
4955 else if (strEQ(s, "INIT")) {
4957 PL_initav = newAV();
4958 if (PL_main_start && ckWARN(WARN_VOID))
4959 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4960 av_push(PL_initav, (SV*)cv);
4961 GvCV(gv) = 0; /* cv has been hijacked */
4972 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4978 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
4979 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
4981 #ifdef GV_UNIQUE_CHECK
4983 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
4987 if ((cv = GvFORM(gv))) {
4988 if (ckWARN(WARN_REDEFINE)) {
4989 const line_t oldline = CopLINE(PL_curcop);
4990 if (PL_copline != NOLINE)
4991 CopLINE_set(PL_curcop, PL_copline);
4992 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4993 o ? "Format %"SVf" redefined"
4994 : "Format STDOUT redefined" ,cSVOPo->op_sv);
4995 CopLINE_set(PL_curcop, oldline);
5002 CvFILE_set_from_cop(cv, PL_curcop);
5005 pad_tidy(padtidy_FORMAT);
5006 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5007 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5008 OpREFCNT_set(CvROOT(cv), 1);
5009 CvSTART(cv) = LINKLIST(CvROOT(cv));
5010 CvROOT(cv)->op_next = 0;
5011 CALL_PEEP(CvSTART(cv));
5013 PL_copline = NOLINE;
5018 Perl_newANONLIST(pTHX_ OP *o)
5020 return newUNOP(OP_REFGEN, 0,
5021 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5025 Perl_newANONHASH(pTHX_ OP *o)
5027 return newUNOP(OP_REFGEN, 0,
5028 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5032 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5034 return newANONATTRSUB(floor, proto, NULL, block);
5038 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5040 return newUNOP(OP_REFGEN, 0,
5041 newSVOP(OP_ANONCODE, 0,
5042 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5046 Perl_oopsAV(pTHX_ OP *o)
5049 switch (o->op_type) {
5051 o->op_type = OP_PADAV;
5052 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5053 return ref(o, OP_RV2AV);
5056 o->op_type = OP_RV2AV;
5057 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5062 if (ckWARN_d(WARN_INTERNAL))
5063 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
5070 Perl_oopsHV(pTHX_ OP *o)
5073 switch (o->op_type) {
5076 o->op_type = OP_PADHV;
5077 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5078 return ref(o, OP_RV2HV);
5082 o->op_type = OP_RV2HV;
5083 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5088 if (ckWARN_d(WARN_INTERNAL))
5089 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
5096 Perl_newAVREF(pTHX_ OP *o)
5099 if (o->op_type == OP_PADANY) {
5100 o->op_type = OP_PADAV;
5101 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5104 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5105 && ckWARN(WARN_DEPRECATED)) {
5106 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5107 "Using an array as a reference is deprecated");
5109 return newUNOP(OP_RV2AV, 0, scalar(o));
5113 Perl_newGVREF(pTHX_ I32 type, OP *o)
5115 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5116 return newUNOP(OP_NULL, 0, o);
5117 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5121 Perl_newHVREF(pTHX_ OP *o)
5124 if (o->op_type == OP_PADANY) {
5125 o->op_type = OP_PADHV;
5126 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5129 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5130 && ckWARN(WARN_DEPRECATED)) {
5131 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5132 "Using a hash as a reference is deprecated");
5134 return newUNOP(OP_RV2HV, 0, scalar(o));
5138 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5140 return newUNOP(OP_RV2CV, flags, scalar(o));
5144 Perl_newSVREF(pTHX_ OP *o)
5147 if (o->op_type == OP_PADANY) {
5148 o->op_type = OP_PADSV;
5149 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5152 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5153 o->op_flags |= OPpDONE_SVREF;
5156 return newUNOP(OP_RV2SV, 0, scalar(o));
5159 /* Check routines. See the comments at the top of this file for details
5160 * on when these are called */
5163 Perl_ck_anoncode(pTHX_ OP *o)
5165 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
5166 cSVOPo->op_sv = NULL;
5171 Perl_ck_bitop(pTHX_ OP *o)
5174 #define OP_IS_NUMCOMPARE(op) \
5175 ((op) == OP_LT || (op) == OP_I_LT || \
5176 (op) == OP_GT || (op) == OP_I_GT || \
5177 (op) == OP_LE || (op) == OP_I_LE || \
5178 (op) == OP_GE || (op) == OP_I_GE || \
5179 (op) == OP_EQ || (op) == OP_I_EQ || \
5180 (op) == OP_NE || (op) == OP_I_NE || \
5181 (op) == OP_NCMP || (op) == OP_I_NCMP)
5182 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
5183 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
5184 && (o->op_type == OP_BIT_OR
5185 || o->op_type == OP_BIT_AND
5186 || o->op_type == OP_BIT_XOR))
5188 const OP * const left = cBINOPo->op_first;
5189 const OP * const right = left->op_sibling;
5190 if ((OP_IS_NUMCOMPARE(left->op_type) &&
5191 (left->op_flags & OPf_PARENS) == 0) ||
5192 (OP_IS_NUMCOMPARE(right->op_type) &&
5193 (right->op_flags & OPf_PARENS) == 0))
5194 if (ckWARN(WARN_PRECEDENCE))
5195 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
5196 "Possible precedence problem on bitwise %c operator",
5197 o->op_type == OP_BIT_OR ? '|'
5198 : o->op_type == OP_BIT_AND ? '&' : '^'
5205 Perl_ck_concat(pTHX_ OP *o)
5207 const OP * const kid = cUNOPo->op_first;
5208 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
5209 !(kUNOP->op_first->op_flags & OPf_MOD))
5210 o->op_flags |= OPf_STACKED;
5215 Perl_ck_spair(pTHX_ OP *o)
5218 if (o->op_flags & OPf_KIDS) {
5221 const OPCODE type = o->op_type;
5222 o = modkids(ck_fun(o), type);
5223 kid = cUNOPo->op_first;
5224 newop = kUNOP->op_first->op_sibling;
5226 (newop->op_sibling ||
5227 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5228 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5229 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5233 op_free(kUNOP->op_first);
5234 kUNOP->op_first = newop;
5236 o->op_ppaddr = PL_ppaddr[++o->op_type];
5241 Perl_ck_delete(pTHX_ OP *o)
5245 if (o->op_flags & OPf_KIDS) {
5246 OP * const kid = cUNOPo->op_first;
5247 switch (kid->op_type) {
5249 o->op_flags |= OPf_SPECIAL;
5252 o->op_private |= OPpSLICE;
5255 o->op_flags |= OPf_SPECIAL;
5260 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5269 Perl_ck_die(pTHX_ OP *o)
5272 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5278 Perl_ck_eof(pTHX_ OP *o)
5281 const I32 type = o->op_type;
5283 if (o->op_flags & OPf_KIDS) {
5284 if (cLISTOPo->op_first->op_type == OP_STUB) {
5286 o = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
5294 Perl_ck_eval(pTHX_ OP *o)
5297 PL_hints |= HINT_BLOCK_SCOPE;
5298 if (o->op_flags & OPf_KIDS) {
5299 SVOP * const kid = (SVOP*)cUNOPo->op_first;
5302 o->op_flags &= ~OPf_KIDS;
5305 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
5308 cUNOPo->op_first = 0;
5311 NewOp(1101, enter, 1, LOGOP);
5312 enter->op_type = OP_ENTERTRY;
5313 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5314 enter->op_private = 0;
5316 /* establish postfix order */
5317 enter->op_next = (OP*)enter;
5319 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5320 o->op_type = OP_LEAVETRY;
5321 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5322 enter->op_other = o;
5332 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5334 o->op_targ = (PADOFFSET)PL_hints;
5335 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
5336 /* Store a copy of %^H that pp_entereval can pick up */
5337 OP *hhop = newSVOP(OP_CONST, 0, (SV*)newHVhv(GvHV(PL_hintgv)));
5338 cUNOPo->op_first->op_sibling = hhop;
5339 o->op_private |= OPpEVAL_HAS_HH;
5345 Perl_ck_exit(pTHX_ OP *o)
5348 HV * const table = GvHV(PL_hintgv);
5350 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
5351 if (svp && *svp && SvTRUE(*svp))
5352 o->op_private |= OPpEXIT_VMSISH;
5354 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5360 Perl_ck_exec(pTHX_ OP *o)
5362 if (o->op_flags & OPf_STACKED) {
5365 kid = cUNOPo->op_first->op_sibling;
5366 if (kid->op_type == OP_RV2GV)
5375 Perl_ck_exists(pTHX_ OP *o)
5379 if (o->op_flags & OPf_KIDS) {
5380 OP * const kid = cUNOPo->op_first;
5381 if (kid->op_type == OP_ENTERSUB) {
5382 (void) ref(kid, o->op_type);
5383 if (kid->op_type != OP_RV2CV && !PL_error_count)
5384 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5386 o->op_private |= OPpEXISTS_SUB;
5388 else if (kid->op_type == OP_AELEM)
5389 o->op_flags |= OPf_SPECIAL;
5390 else if (kid->op_type != OP_HELEM)
5391 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5399 Perl_ck_rvconst(pTHX_ register OP *o)
5402 SVOP * const kid = (SVOP*)cUNOPo->op_first;
5404 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5405 if (o->op_type == OP_RV2CV)
5406 o->op_private &= ~1;
5408 if (kid->op_type == OP_CONST) {
5411 SV * const kidsv = kid->op_sv;
5413 /* Is it a constant from cv_const_sv()? */
5414 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5415 SV * const rsv = SvRV(kidsv);
5416 const int svtype = SvTYPE(rsv);
5417 const char *badtype = NULL;
5419 switch (o->op_type) {
5421 if (svtype > SVt_PVMG)
5422 badtype = "a SCALAR";
5425 if (svtype != SVt_PVAV)
5426 badtype = "an ARRAY";
5429 if (svtype != SVt_PVHV)
5433 if (svtype != SVt_PVCV)
5438 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5441 else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
5442 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
5443 /* If this is an access to a stash, disable "strict refs", because
5444 * stashes aren't auto-vivified at compile-time (unless we store
5445 * symbols in them), and we don't want to produce a run-time
5446 * stricture error when auto-vivifying the stash. */
5447 const char *s = SvPV_nolen(kidsv);
5448 const STRLEN l = SvCUR(kidsv);
5449 if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
5450 o->op_private &= ~HINT_STRICT_REFS;
5452 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5453 const char *badthing;
5454 switch (o->op_type) {
5456 badthing = "a SCALAR";
5459 badthing = "an ARRAY";
5462 badthing = "a HASH";
5470 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
5474 * This is a little tricky. We only want to add the symbol if we
5475 * didn't add it in the lexer. Otherwise we get duplicate strict
5476 * warnings. But if we didn't add it in the lexer, we must at
5477 * least pretend like we wanted to add it even if it existed before,
5478 * or we get possible typo warnings. OPpCONST_ENTERED says
5479 * whether the lexer already added THIS instance of this symbol.
5481 iscv = (o->op_type == OP_RV2CV) * 2;
5483 gv = gv_fetchsv(kidsv,
5484 iscv | !(kid->op_private & OPpCONST_ENTERED),
5487 : o->op_type == OP_RV2SV
5489 : o->op_type == OP_RV2AV
5491 : o->op_type == OP_RV2HV
5494 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5496 kid->op_type = OP_GV;
5497 SvREFCNT_dec(kid->op_sv);
5499 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5500 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5501 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
5503 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv));
5505 kid->op_sv = SvREFCNT_inc(gv);
5507 kid->op_private = 0;
5508 kid->op_ppaddr = PL_ppaddr[OP_GV];
5515 Perl_ck_ftst(pTHX_ OP *o)
5518 const I32 type = o->op_type;
5520 if (o->op_flags & OPf_REF) {
5523 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5524 SVOP * const kid = (SVOP*)cUNOPo->op_first;
5526 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5527 OP * const newop = newGVOP(type, OPf_REF,
5528 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
5534 if ((PL_hints & HINT_FILETEST_ACCESS) &&
5535 OP_IS_FILETEST_ACCESS(o))
5536 o->op_private |= OPpFT_ACCESS;
5538 if (PL_check[kid->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst)
5539 && kid->op_type != OP_STAT && kid->op_type != OP_LSTAT)
5540 o->op_private |= OPpFT_STACKED;
5544 if (type == OP_FTTTY)
5545 o = newGVOP(type, OPf_REF, PL_stdingv);
5547 o = newUNOP(type, 0, newDEFSVOP());
5553 Perl_ck_fun(pTHX_ OP *o)
5556 const int type = o->op_type;
5557 register I32 oa = PL_opargs[type] >> OASHIFT;
5559 if (o->op_flags & OPf_STACKED) {
5560 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5563 return no_fh_allowed(o);
5566 if (o->op_flags & OPf_KIDS) {
5567 OP **tokid = &cLISTOPo->op_first;
5568 register OP *kid = cLISTOPo->op_first;
5572 if (kid->op_type == OP_PUSHMARK ||
5573 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5575 tokid = &kid->op_sibling;
5576 kid = kid->op_sibling;
5578 if (!kid && PL_opargs[type] & OA_DEFGV)
5579 *tokid = kid = newDEFSVOP();
5583 sibl = kid->op_sibling;
5586 /* list seen where single (scalar) arg expected? */
5587 if (numargs == 1 && !(oa >> 4)
5588 && kid->op_type == OP_LIST && type != OP_SCALAR)
5590 return too_many_arguments(o,PL_op_desc[type]);
5603 if ((type == OP_PUSH || type == OP_UNSHIFT)
5604 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5605 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5606 "Useless use of %s with no values",
5609 if (kid->op_type == OP_CONST &&
5610 (kid->op_private & OPpCONST_BARE))
5612 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
5613 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
5614 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5615 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5616 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
5617 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
5620 kid->op_sibling = sibl;
5623 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5624 bad_type(numargs, "array", PL_op_desc[type], kid);
5628 if (kid->op_type == OP_CONST &&
5629 (kid->op_private & OPpCONST_BARE))
5631 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
5632 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
5633 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5634 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5635 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
5636 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
5639 kid->op_sibling = sibl;
5642 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5643 bad_type(numargs, "hash", PL_op_desc[type], kid);
5648 OP * const newop = newUNOP(OP_NULL, 0, kid);
5649 kid->op_sibling = 0;
5651 newop->op_next = newop;
5653 kid->op_sibling = sibl;
5658 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5659 if (kid->op_type == OP_CONST &&
5660 (kid->op_private & OPpCONST_BARE))
5662 OP * const newop = newGVOP(OP_GV, 0,
5663 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
5664 if (!(o->op_private & 1) && /* if not unop */
5665 kid == cLISTOPo->op_last)
5666 cLISTOPo->op_last = newop;
5670 else if (kid->op_type == OP_READLINE) {
5671 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5672 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5675 I32 flags = OPf_SPECIAL;
5679 /* is this op a FH constructor? */
5680 if (is_handle_constructor(o,numargs)) {
5681 const char *name = NULL;
5685 /* Set a flag to tell rv2gv to vivify
5686 * need to "prove" flag does not mean something
5687 * else already - NI-S 1999/05/07
5690 if (kid->op_type == OP_PADSV) {
5691 name = PAD_COMPNAME_PV(kid->op_targ);
5692 /* SvCUR of a pad namesv can't be trusted
5693 * (see PL_generation), so calc its length
5699 else if (kid->op_type == OP_RV2SV
5700 && kUNOP->op_first->op_type == OP_GV)
5702 GV * const gv = cGVOPx_gv(kUNOP->op_first);
5704 len = GvNAMELEN(gv);
5706 else if (kid->op_type == OP_AELEM
5707 || kid->op_type == OP_HELEM)
5709 OP *op = ((BINOP*)kid)->op_first;
5713 const char * const a =
5714 kid->op_type == OP_AELEM ?
5716 if (((op->op_type == OP_RV2AV) ||
5717 (op->op_type == OP_RV2HV)) &&
5718 (op = ((UNOP*)op)->op_first) &&
5719 (op->op_type == OP_GV)) {
5720 /* packagevar $a[] or $h{} */
5721 GV * const gv = cGVOPx_gv(op);
5729 else if (op->op_type == OP_PADAV
5730 || op->op_type == OP_PADHV) {
5731 /* lexicalvar $a[] or $h{} */
5732 const char * const padname =
5733 PAD_COMPNAME_PV(op->op_targ);
5742 name = SvPV_const(tmpstr, len);
5747 name = "__ANONIO__";
5754 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5755 namesv = PAD_SVl(targ);
5756 SvUPGRADE(namesv, SVt_PV);
5758 sv_setpvn(namesv, "$", 1);
5759 sv_catpvn(namesv, name, len);
5762 kid->op_sibling = 0;
5763 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5764 kid->op_targ = targ;
5765 kid->op_private |= priv;
5767 kid->op_sibling = sibl;
5773 mod(scalar(kid), type);
5777 tokid = &kid->op_sibling;
5778 kid = kid->op_sibling;
5780 o->op_private |= numargs;
5782 return too_many_arguments(o,OP_DESC(o));
5785 else if (PL_opargs[type] & OA_DEFGV) {
5787 return newUNOP(type, 0, newDEFSVOP());
5791 while (oa & OA_OPTIONAL)
5793 if (oa && oa != OA_LIST)
5794 return too_few_arguments(o,OP_DESC(o));
5800 Perl_ck_glob(pTHX_ OP *o)
5806 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5807 append_elem(OP_GLOB, o, newDEFSVOP());
5809 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
5810 && GvCVu(gv) && GvIMPORTED_CV(gv)))
5812 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
5815 #if !defined(PERL_EXTERNAL_GLOB)
5816 /* XXX this can be tightened up and made more failsafe. */
5817 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
5820 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5821 newSVpvs("File::Glob"), NULL, NULL, NULL);
5822 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
5823 glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
5824 GvCV(gv) = GvCV(glob_gv);
5825 (void)SvREFCNT_inc((SV*)GvCV(gv));
5826 GvIMPORTED_CV_on(gv);
5829 #endif /* PERL_EXTERNAL_GLOB */
5831 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5832 append_elem(OP_GLOB, o,
5833 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5834 o->op_type = OP_LIST;
5835 o->op_ppaddr = PL_ppaddr[OP_LIST];
5836 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5837 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5838 cLISTOPo->op_first->op_targ = 0;
5839 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5840 append_elem(OP_LIST, o,
5841 scalar(newUNOP(OP_RV2CV, 0,
5842 newGVOP(OP_GV, 0, gv)))));
5843 o = newUNOP(OP_NULL, 0, ck_subr(o));
5844 o->op_targ = OP_GLOB; /* hint at what it used to be */
5847 gv = newGVgen("main");
5849 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5855 Perl_ck_grep(pTHX_ OP *o)
5860 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5863 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5864 NewOp(1101, gwop, 1, LOGOP);
5866 if (o->op_flags & OPf_STACKED) {
5869 kid = cLISTOPo->op_first->op_sibling;
5870 if (!cUNOPx(kid)->op_next)
5871 Perl_croak(aTHX_ "panic: ck_grep");
5872 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
5875 kid->op_next = (OP*)gwop;
5876 o->op_flags &= ~OPf_STACKED;
5878 kid = cLISTOPo->op_first->op_sibling;
5879 if (type == OP_MAPWHILE)
5886 kid = cLISTOPo->op_first->op_sibling;
5887 if (kid->op_type != OP_NULL)
5888 Perl_croak(aTHX_ "panic: ck_grep");
5889 kid = kUNOP->op_first;
5891 gwop->op_type = type;
5892 gwop->op_ppaddr = PL_ppaddr[type];
5893 gwop->op_first = listkids(o);
5894 gwop->op_flags |= OPf_KIDS;
5895 gwop->op_other = LINKLIST(kid);
5896 kid->op_next = (OP*)gwop;
5897 offset = pad_findmy("$_");
5898 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
5899 o->op_private = gwop->op_private = 0;
5900 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5903 o->op_private = gwop->op_private = OPpGREP_LEX;
5904 gwop->op_targ = o->op_targ = offset;
5907 kid = cLISTOPo->op_first->op_sibling;
5908 if (!kid || !kid->op_sibling)
5909 return too_few_arguments(o,OP_DESC(o));
5910 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5911 mod(kid, OP_GREPSTART);
5917 Perl_ck_index(pTHX_ OP *o)
5919 if (o->op_flags & OPf_KIDS) {
5920 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5922 kid = kid->op_sibling; /* get past "big" */
5923 if (kid && kid->op_type == OP_CONST)
5924 fbm_compile(((SVOP*)kid)->op_sv, 0);
5930 Perl_ck_lengthconst(pTHX_ OP *o)
5932 /* XXX length optimization goes here */
5937 Perl_ck_lfun(pTHX_ OP *o)
5939 const OPCODE type = o->op_type;
5940 return modkids(ck_fun(o), type);
5944 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5946 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
5947 switch (cUNOPo->op_first->op_type) {
5949 /* This is needed for
5950 if (defined %stash::)
5951 to work. Do not break Tk.
5953 break; /* Globals via GV can be undef */
5955 case OP_AASSIGN: /* Is this a good idea? */
5956 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5957 "defined(@array) is deprecated");
5958 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5959 "\t(Maybe you should just omit the defined()?)\n");
5962 /* This is needed for
5963 if (defined %stash::)
5964 to work. Do not break Tk.
5966 break; /* Globals via GV can be undef */
5968 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5969 "defined(%%hash) is deprecated");
5970 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5971 "\t(Maybe you should just omit the defined()?)\n");
5982 Perl_ck_rfun(pTHX_ OP *o)
5984 const OPCODE type = o->op_type;
5985 return refkids(ck_fun(o), type);
5989 Perl_ck_listiob(pTHX_ OP *o)
5993 kid = cLISTOPo->op_first;
5996 kid = cLISTOPo->op_first;
5998 if (kid->op_type == OP_PUSHMARK)
5999 kid = kid->op_sibling;
6000 if (kid && o->op_flags & OPf_STACKED)
6001 kid = kid->op_sibling;
6002 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6003 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6004 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6005 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6006 cLISTOPo->op_first->op_sibling = kid;
6007 cLISTOPo->op_last = kid;
6008 kid = kid->op_sibling;
6013 append_elem(o->op_type, o, newDEFSVOP());
6019 Perl_ck_say(pTHX_ OP *o)
6022 o->op_type = OP_PRINT;
6023 cLISTOPo->op_last = cLISTOPo->op_last->op_sibling
6024 = newSVOP(OP_CONST, 0, newSVpvs("\n"));
6029 Perl_ck_smartmatch(pTHX_ OP *o)
6032 if (0 == (o->op_flags & OPf_SPECIAL)) {
6033 OP *first = cBINOPo->op_first;
6034 OP *second = first->op_sibling;
6036 /* Implicitly take a reference to an array or hash */
6037 first->op_sibling = NULL;
6038 first = cBINOPo->op_first = ref_array_or_hash(first);
6039 second = first->op_sibling = ref_array_or_hash(second);
6041 /* Implicitly take a reference to a regular expression */
6042 if (first->op_type == OP_MATCH) {
6043 first->op_type = OP_QR;
6044 first->op_ppaddr = PL_ppaddr[OP_QR];
6046 if (second->op_type == OP_MATCH) {
6047 second->op_type = OP_QR;
6048 second->op_ppaddr = PL_ppaddr[OP_QR];
6057 Perl_ck_sassign(pTHX_ OP *o)
6059 OP *kid = cLISTOPo->op_first;
6060 /* has a disposable target? */
6061 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6062 && !(kid->op_flags & OPf_STACKED)
6063 /* Cannot steal the second time! */
6064 && !(kid->op_private & OPpTARGET_MY))
6066 OP * const kkid = kid->op_sibling;
6068 /* Can just relocate the target. */
6069 if (kkid && kkid->op_type == OP_PADSV
6070 && !(kkid->op_private & OPpLVAL_INTRO))
6072 kid->op_targ = kkid->op_targ;
6074 /* Now we do not need PADSV and SASSIGN. */
6075 kid->op_sibling = o->op_sibling; /* NULL */
6076 cLISTOPo->op_first = NULL;
6079 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6087 Perl_ck_match(pTHX_ OP *o)
6090 if (o->op_type != OP_QR && PL_compcv) {
6091 const I32 offset = pad_findmy("$_");
6092 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
6093 o->op_targ = offset;
6094 o->op_private |= OPpTARGET_MY;
6097 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
6098 o->op_private |= OPpRUNTIME;
6103 Perl_ck_method(pTHX_ OP *o)
6105 OP * const kid = cUNOPo->op_first;
6106 if (kid->op_type == OP_CONST) {
6107 SV* sv = kSVOP->op_sv;
6108 const char * const method = SvPVX_const(sv);
6109 if (!(strchr(method, ':') || strchr(method, '\''))) {
6111 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6112 sv = newSVpvn_share(method, SvCUR(sv), 0);
6115 kSVOP->op_sv = NULL;
6117 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6126 Perl_ck_null(pTHX_ OP *o)
6132 Perl_ck_open(pTHX_ OP *o)
6135 HV * const table = GvHV(PL_hintgv);
6137 SV **svp = hv_fetchs(table, "open_IN", FALSE);
6139 const I32 mode = mode_from_discipline(*svp);
6140 if (mode & O_BINARY)
6141 o->op_private |= OPpOPEN_IN_RAW;
6142 else if (mode & O_TEXT)
6143 o->op_private |= OPpOPEN_IN_CRLF;
6146 svp = hv_fetchs(table, "open_OUT", FALSE);
6148 const I32 mode = mode_from_discipline(*svp);
6149 if (mode & O_BINARY)
6150 o->op_private |= OPpOPEN_OUT_RAW;
6151 else if (mode & O_TEXT)
6152 o->op_private |= OPpOPEN_OUT_CRLF;
6155 if (o->op_type == OP_BACKTICK)
6158 /* In case of three-arg dup open remove strictness
6159 * from the last arg if it is a bareword. */
6160 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
6161 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
6165 if ((last->op_type == OP_CONST) && /* The bareword. */
6166 (last->op_private & OPpCONST_BARE) &&
6167 (last->op_private & OPpCONST_STRICT) &&
6168 (oa = first->op_sibling) && /* The fh. */
6169 (oa = oa->op_sibling) && /* The mode. */
6170 (oa->op_type == OP_CONST) &&
6171 SvPOK(((SVOP*)oa)->op_sv) &&
6172 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
6173 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
6174 (last == oa->op_sibling)) /* The bareword. */
6175 last->op_private &= ~OPpCONST_STRICT;
6181 Perl_ck_repeat(pTHX_ OP *o)
6183 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6184 o->op_private |= OPpREPEAT_DOLIST;
6185 cBINOPo->op_first = force_list(cBINOPo->op_first);
6193 Perl_ck_require(pTHX_ OP *o)
6198 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6199 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6201 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6202 SV * const sv = kid->op_sv;
6203 U32 was_readonly = SvREADONLY(sv);
6208 sv_force_normal_flags(sv, 0);
6209 assert(!SvREADONLY(sv));
6216 for (s = SvPVX(sv); *s; s++) {
6217 if (*s == ':' && s[1] == ':') {
6218 const STRLEN len = strlen(s+2)+1;
6220 Move(s+2, s+1, len, char);
6221 SvCUR_set(sv, SvCUR(sv) - 1);
6224 sv_catpvs(sv, ".pm");
6225 SvFLAGS(sv) |= was_readonly;
6229 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
6230 /* handle override, if any */
6231 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
6232 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
6233 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
6234 gv = gvp ? *gvp : NULL;
6238 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6239 OP * const kid = cUNOPo->op_first;
6240 cUNOPo->op_first = 0;
6242 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
6243 append_elem(OP_LIST, kid,
6244 scalar(newUNOP(OP_RV2CV, 0,
6253 Perl_ck_return(pTHX_ OP *o)
6256 if (CvLVALUE(PL_compcv)) {
6258 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6259 mod(kid, OP_LEAVESUBLV);
6265 Perl_ck_select(pTHX_ OP *o)
6269 if (o->op_flags & OPf_KIDS) {
6270 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6271 if (kid && kid->op_sibling) {
6272 o->op_type = OP_SSELECT;
6273 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6275 return fold_constants(o);
6279 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6280 if (kid && kid->op_type == OP_RV2GV)
6281 kid->op_private &= ~HINT_STRICT_REFS;
6286 Perl_ck_shift(pTHX_ OP *o)
6289 const I32 type = o->op_type;
6291 if (!(o->op_flags & OPf_KIDS)) {
6295 argop = newUNOP(OP_RV2AV, 0,
6296 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
6297 return newUNOP(type, 0, scalar(argop));
6299 return scalar(modkids(ck_fun(o), type));
6303 Perl_ck_sort(pTHX_ OP *o)
6308 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0)
6310 HV * const hinthv = GvHV(PL_hintgv);
6312 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
6314 const I32 sorthints = (I32)SvIV(*svp);
6315 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
6316 o->op_private |= OPpSORT_QSORT;
6317 if ((sorthints & HINT_SORT_STABLE) != 0)
6318 o->op_private |= OPpSORT_STABLE;
6323 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6325 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6326 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6328 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6330 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6332 if (kid->op_type == OP_SCOPE) {
6336 else if (kid->op_type == OP_LEAVE) {
6337 if (o->op_type == OP_SORT) {
6338 op_null(kid); /* wipe out leave */
6341 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6342 if (k->op_next == kid)
6344 /* don't descend into loops */
6345 else if (k->op_type == OP_ENTERLOOP
6346 || k->op_type == OP_ENTERITER)
6348 k = cLOOPx(k)->op_lastop;
6353 kid->op_next = 0; /* just disconnect the leave */
6354 k = kLISTOP->op_first;
6359 if (o->op_type == OP_SORT) {
6360 /* provide scalar context for comparison function/block */
6366 o->op_flags |= OPf_SPECIAL;
6368 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6371 firstkid = firstkid->op_sibling;
6374 /* provide list context for arguments */
6375 if (o->op_type == OP_SORT)
6382 S_simplify_sort(pTHX_ OP *o)
6385 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6390 if (!(o->op_flags & OPf_STACKED))
6392 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
6393 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
6394 kid = kUNOP->op_first; /* get past null */
6395 if (kid->op_type != OP_SCOPE)
6397 kid = kLISTOP->op_last; /* get past scope */
6398 switch(kid->op_type) {
6406 k = kid; /* remember this node*/
6407 if (kBINOP->op_first->op_type != OP_RV2SV)
6409 kid = kBINOP->op_first; /* get past cmp */
6410 if (kUNOP->op_first->op_type != OP_GV)
6412 kid = kUNOP->op_first; /* get past rv2sv */
6414 if (GvSTASH(gv) != PL_curstash)
6416 gvname = GvNAME(gv);
6417 if (*gvname == 'a' && gvname[1] == '\0')
6419 else if (*gvname == 'b' && gvname[1] == '\0')
6424 kid = k; /* back to cmp */
6425 if (kBINOP->op_last->op_type != OP_RV2SV)
6427 kid = kBINOP->op_last; /* down to 2nd arg */
6428 if (kUNOP->op_first->op_type != OP_GV)
6430 kid = kUNOP->op_first; /* get past rv2sv */
6432 if (GvSTASH(gv) != PL_curstash)
6434 gvname = GvNAME(gv);
6436 ? !(*gvname == 'a' && gvname[1] == '\0')
6437 : !(*gvname == 'b' && gvname[1] == '\0'))
6439 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6441 o->op_private |= OPpSORT_DESCEND;
6442 if (k->op_type == OP_NCMP)
6443 o->op_private |= OPpSORT_NUMERIC;
6444 if (k->op_type == OP_I_NCMP)
6445 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6446 kid = cLISTOPo->op_first->op_sibling;
6447 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6448 op_free(kid); /* then delete it */
6452 Perl_ck_split(pTHX_ OP *o)
6457 if (o->op_flags & OPf_STACKED)
6458 return no_fh_allowed(o);
6460 kid = cLISTOPo->op_first;
6461 if (kid->op_type != OP_NULL)
6462 Perl_croak(aTHX_ "panic: ck_split");
6463 kid = kid->op_sibling;
6464 op_free(cLISTOPo->op_first);
6465 cLISTOPo->op_first = kid;
6467 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
6468 cLISTOPo->op_last = kid; /* There was only one element previously */
6471 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6472 OP * const sibl = kid->op_sibling;
6473 kid->op_sibling = 0;
6474 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
6475 if (cLISTOPo->op_first == cLISTOPo->op_last)
6476 cLISTOPo->op_last = kid;
6477 cLISTOPo->op_first = kid;
6478 kid->op_sibling = sibl;
6481 kid->op_type = OP_PUSHRE;
6482 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6484 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
6485 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
6486 "Use of /g modifier is meaningless in split");
6489 if (!kid->op_sibling)
6490 append_elem(OP_SPLIT, o, newDEFSVOP());
6492 kid = kid->op_sibling;
6495 if (!kid->op_sibling)
6496 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6498 kid = kid->op_sibling;
6501 if (kid->op_sibling)
6502 return too_many_arguments(o,OP_DESC(o));
6508 Perl_ck_join(pTHX_ OP *o)
6510 const OP * const kid = cLISTOPo->op_first->op_sibling;
6511 if (kid && kid->op_type == OP_MATCH) {
6512 if (ckWARN(WARN_SYNTAX)) {
6513 const REGEXP *re = PM_GETRE(kPMOP);
6514 const char *pmstr = re ? re->precomp : "STRING";
6515 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6516 "/%s/ should probably be written as \"%s\"",
6524 Perl_ck_subr(pTHX_ OP *o)
6527 OP *prev = ((cUNOPo->op_first->op_sibling)
6528 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6529 OP *o2 = prev->op_sibling;
6536 I32 contextclass = 0;
6540 o->op_private |= OPpENTERSUB_HASTARG;
6541 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6542 if (cvop->op_type == OP_RV2CV) {
6544 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6545 op_null(cvop); /* disable rv2cv */
6546 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6547 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6548 GV *gv = cGVOPx_gv(tmpop);
6551 tmpop->op_private |= OPpEARLY_CV;
6554 namegv = CvANON(cv) ? gv : CvGV(cv);
6555 proto = SvPV_nolen((SV*)cv);
6557 if (CvASSERTION(cv)) {
6558 if (PL_hints & HINT_ASSERTING) {
6559 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
6560 o->op_private |= OPpENTERSUB_DB;
6564 if (!(PL_hints & HINT_ASSERTIONSSEEN) && ckWARN(WARN_ASSERTIONS)) {
6565 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
6566 "Impossible to activate assertion call");
6573 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6574 if (o2->op_type == OP_CONST)
6575 o2->op_private &= ~OPpCONST_STRICT;
6576 else if (o2->op_type == OP_LIST) {
6577 OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
6578 if (sib && sib->op_type == OP_CONST)
6579 sib->op_private &= ~OPpCONST_STRICT;
6582 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6583 if (PERLDB_SUB && PL_curstash != PL_debstash)
6584 o->op_private |= OPpENTERSUB_DB;
6585 while (o2 != cvop) {
6589 return too_many_arguments(o, gv_ename(namegv));
6607 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6609 arg == 1 ? "block or sub {}" : "sub {}",
6610 gv_ename(namegv), o2);
6613 /* '*' allows any scalar type, including bareword */
6616 if (o2->op_type == OP_RV2GV)
6617 goto wrapref; /* autoconvert GLOB -> GLOBref */
6618 else if (o2->op_type == OP_CONST)
6619 o2->op_private &= ~OPpCONST_STRICT;
6620 else if (o2->op_type == OP_ENTERSUB) {
6621 /* accidental subroutine, revert to bareword */
6622 OP *gvop = ((UNOP*)o2)->op_first;
6623 if (gvop && gvop->op_type == OP_NULL) {
6624 gvop = ((UNOP*)gvop)->op_first;
6626 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6629 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6630 (gvop = ((UNOP*)gvop)->op_first) &&
6631 gvop->op_type == OP_GV)
6633 GV * const gv = cGVOPx_gv(gvop);
6634 OP * const sibling = o2->op_sibling;
6635 SV * const n = newSVpvs("");
6637 gv_fullname4(n, gv, "", FALSE);
6638 o2 = newSVOP(OP_CONST, 0, n);
6639 prev->op_sibling = o2;
6640 o2->op_sibling = sibling;
6656 if (contextclass++ == 0) {
6657 e = strchr(proto, ']');
6658 if (!e || e == proto)
6667 /* XXX We shouldn't be modifying proto, so we can const proto */
6672 while (*--p != '[');
6673 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
6674 gv_ename(namegv), o2);
6680 if (o2->op_type == OP_RV2GV)
6683 bad_type(arg, "symbol", gv_ename(namegv), o2);
6686 if (o2->op_type == OP_ENTERSUB)
6689 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6692 if (o2->op_type == OP_RV2SV ||
6693 o2->op_type == OP_PADSV ||
6694 o2->op_type == OP_HELEM ||
6695 o2->op_type == OP_AELEM ||
6696 o2->op_type == OP_THREADSV)
6699 bad_type(arg, "scalar", gv_ename(namegv), o2);
6702 if (o2->op_type == OP_RV2AV ||
6703 o2->op_type == OP_PADAV)
6706 bad_type(arg, "array", gv_ename(namegv), o2);
6709 if (o2->op_type == OP_RV2HV ||
6710 o2->op_type == OP_PADHV)
6713 bad_type(arg, "hash", gv_ename(namegv), o2);
6718 OP* const sib = kid->op_sibling;
6719 kid->op_sibling = 0;
6720 o2 = newUNOP(OP_REFGEN, 0, kid);
6721 o2->op_sibling = sib;
6722 prev->op_sibling = o2;
6724 if (contextclass && e) {
6739 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
6740 gv_ename(namegv), cv);
6745 mod(o2, OP_ENTERSUB);
6747 o2 = o2->op_sibling;
6749 if (proto && !optional &&
6750 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6751 return too_few_arguments(o, gv_ename(namegv));
6754 o=newSVOP(OP_CONST, 0, newSViv(0));
6760 Perl_ck_svconst(pTHX_ OP *o)
6762 SvREADONLY_on(cSVOPo->op_sv);
6767 Perl_ck_chdir(pTHX_ OP *o)
6769 if (o->op_flags & OPf_KIDS) {
6770 SVOP *kid = (SVOP*)cUNOPo->op_first;
6772 if (kid && kid->op_type == OP_CONST &&
6773 (kid->op_private & OPpCONST_BARE))
6775 o->op_flags |= OPf_SPECIAL;
6776 kid->op_private &= ~OPpCONST_STRICT;
6783 Perl_ck_trunc(pTHX_ OP *o)
6785 if (o->op_flags & OPf_KIDS) {
6786 SVOP *kid = (SVOP*)cUNOPo->op_first;
6788 if (kid->op_type == OP_NULL)
6789 kid = (SVOP*)kid->op_sibling;
6790 if (kid && kid->op_type == OP_CONST &&
6791 (kid->op_private & OPpCONST_BARE))
6793 o->op_flags |= OPf_SPECIAL;
6794 kid->op_private &= ~OPpCONST_STRICT;
6801 Perl_ck_unpack(pTHX_ OP *o)
6803 OP *kid = cLISTOPo->op_first;
6804 if (kid->op_sibling) {
6805 kid = kid->op_sibling;
6806 if (!kid->op_sibling)
6807 kid->op_sibling = newDEFSVOP();
6813 Perl_ck_substr(pTHX_ OP *o)
6816 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6817 OP *kid = cLISTOPo->op_first;
6819 if (kid->op_type == OP_NULL)
6820 kid = kid->op_sibling;
6822 kid->op_flags |= OPf_MOD;
6828 /* A peephole optimizer. We visit the ops in the order they're to execute.
6829 * See the comments at the top of this file for more details about when
6830 * peep() is called */
6833 Perl_peep(pTHX_ register OP *o)
6836 register OP* oldop = NULL;
6838 if (!o || o->op_opt)
6842 SAVEVPTR(PL_curcop);
6843 for (; o; o = o->op_next) {
6847 switch (o->op_type) {
6851 PL_curcop = ((COP*)o); /* for warnings */
6856 if (cSVOPo->op_private & OPpCONST_STRICT)
6857 no_bareword_allowed(o);
6859 case OP_METHOD_NAMED:
6860 /* Relocate sv to the pad for thread safety.
6861 * Despite being a "constant", the SV is written to,
6862 * for reference counts, sv_upgrade() etc. */
6864 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6865 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6866 /* If op_sv is already a PADTMP then it is being used by
6867 * some pad, so make a copy. */
6868 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6869 SvREADONLY_on(PAD_SVl(ix));
6870 SvREFCNT_dec(cSVOPo->op_sv);
6872 else if (o->op_type == OP_CONST
6873 && cSVOPo->op_sv == &PL_sv_undef) {
6874 /* PL_sv_undef is hack - it's unsafe to store it in the
6875 AV that is the pad, because av_fetch treats values of
6876 PL_sv_undef as a "free" AV entry and will merrily
6877 replace them with a new SV, causing pad_alloc to think
6878 that this pad slot is free. (When, clearly, it is not)
6880 SvOK_off(PAD_SVl(ix));
6881 SvPADTMP_on(PAD_SVl(ix));
6882 SvREADONLY_on(PAD_SVl(ix));
6885 SvREFCNT_dec(PAD_SVl(ix));
6886 SvPADTMP_on(cSVOPo->op_sv);
6887 PAD_SETSV(ix, cSVOPo->op_sv);
6888 /* XXX I don't know how this isn't readonly already. */
6889 SvREADONLY_on(PAD_SVl(ix));
6891 cSVOPo->op_sv = NULL;
6899 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6900 if (o->op_next->op_private & OPpTARGET_MY) {
6901 if (o->op_flags & OPf_STACKED) /* chained concats */
6902 goto ignore_optimization;
6904 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6905 o->op_targ = o->op_next->op_targ;
6906 o->op_next->op_targ = 0;
6907 o->op_private |= OPpTARGET_MY;
6910 op_null(o->op_next);
6912 ignore_optimization:
6916 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6918 break; /* Scalar stub must produce undef. List stub is noop */
6922 if (o->op_targ == OP_NEXTSTATE
6923 || o->op_targ == OP_DBSTATE
6924 || o->op_targ == OP_SETSTATE)
6926 PL_curcop = ((COP*)o);
6928 /* XXX: We avoid setting op_seq here to prevent later calls
6929 to peep() from mistakenly concluding that optimisation
6930 has already occurred. This doesn't fix the real problem,
6931 though (See 20010220.007). AMS 20010719 */
6932 /* op_seq functionality is now replaced by op_opt */
6933 if (oldop && o->op_next) {
6934 oldop->op_next = o->op_next;
6942 if (oldop && o->op_next) {
6943 oldop->op_next = o->op_next;
6951 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
6952 OP* const pop = (o->op_type == OP_PADAV) ?
6953 o->op_next : o->op_next->op_next;
6955 if (pop && pop->op_type == OP_CONST &&
6956 ((PL_op = pop->op_next)) &&
6957 pop->op_next->op_type == OP_AELEM &&
6958 !(pop->op_next->op_private &
6959 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6960 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6965 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
6966 no_bareword_allowed(pop);
6967 if (o->op_type == OP_GV)
6968 op_null(o->op_next);
6969 op_null(pop->op_next);
6971 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6972 o->op_next = pop->op_next->op_next;
6973 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6974 o->op_private = (U8)i;
6975 if (o->op_type == OP_GV) {
6980 o->op_flags |= OPf_SPECIAL;
6981 o->op_type = OP_AELEMFAST;
6987 if (o->op_next->op_type == OP_RV2SV) {
6988 if (!(o->op_next->op_private & OPpDEREF)) {
6989 op_null(o->op_next);
6990 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6992 o->op_next = o->op_next->op_next;
6993 o->op_type = OP_GVSV;
6994 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6997 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6998 GV * const gv = cGVOPo_gv;
6999 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
7000 /* XXX could check prototype here instead of just carping */
7001 SV * const sv = sv_newmortal();
7002 gv_efullname3(sv, gv, NULL);
7003 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
7004 "%"SVf"() called too early to check prototype",
7008 else if (o->op_next->op_type == OP_READLINE
7009 && o->op_next->op_next->op_type == OP_CONCAT
7010 && (o->op_next->op_next->op_flags & OPf_STACKED))
7012 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
7013 o->op_type = OP_RCATLINE;
7014 o->op_flags |= OPf_STACKED;
7015 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
7016 op_null(o->op_next->op_next);
7017 op_null(o->op_next);
7034 while (cLOGOP->op_other->op_type == OP_NULL)
7035 cLOGOP->op_other = cLOGOP->op_other->op_next;
7036 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
7042 while (cLOOP->op_redoop->op_type == OP_NULL)
7043 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
7044 peep(cLOOP->op_redoop);
7045 while (cLOOP->op_nextop->op_type == OP_NULL)
7046 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
7047 peep(cLOOP->op_nextop);
7048 while (cLOOP->op_lastop->op_type == OP_NULL)
7049 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
7050 peep(cLOOP->op_lastop);
7057 while (cPMOP->op_pmreplstart &&
7058 cPMOP->op_pmreplstart->op_type == OP_NULL)
7059 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
7060 peep(cPMOP->op_pmreplstart);
7065 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
7066 && ckWARN(WARN_SYNTAX))
7068 if (o->op_next->op_sibling &&
7069 o->op_next->op_sibling->op_type != OP_EXIT &&
7070 o->op_next->op_sibling->op_type != OP_WARN &&
7071 o->op_next->op_sibling->op_type != OP_DIE) {
7072 const line_t oldline = CopLINE(PL_curcop);
7074 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
7075 Perl_warner(aTHX_ packWARN(WARN_EXEC),
7076 "Statement unlikely to be reached");
7077 Perl_warner(aTHX_ packWARN(WARN_EXEC),
7078 "\t(Maybe you meant system() when you said exec()?)\n");
7079 CopLINE_set(PL_curcop, oldline);
7089 const char *key = NULL;
7094 if (((BINOP*)o)->op_last->op_type != OP_CONST)
7097 /* Make the CONST have a shared SV */
7098 svp = cSVOPx_svp(((BINOP*)o)->op_last);
7099 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
7100 key = SvPV_const(sv, keylen);
7101 lexname = newSVpvn_share(key,
7102 SvUTF8(sv) ? -(I32)keylen : keylen,
7108 if ((o->op_private & (OPpLVAL_INTRO)))
7111 rop = (UNOP*)((BINOP*)o)->op_first;
7112 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7114 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7115 if (!SvPAD_TYPED(lexname))
7117 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
7118 if (!fields || !GvHV(*fields))
7120 key = SvPV_const(*svp, keylen);
7121 if (!hv_fetch(GvHV(*fields), key,
7122 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
7124 Perl_croak(aTHX_ "No such class field \"%s\" "
7125 "in variable %s of type %s",
7126 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
7139 SVOP *first_key_op, *key_op;
7141 if ((o->op_private & (OPpLVAL_INTRO))
7142 /* I bet there's always a pushmark... */
7143 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
7144 /* hmmm, no optimization if list contains only one key. */
7146 rop = (UNOP*)((LISTOP*)o)->op_last;
7147 if (rop->op_type != OP_RV2HV)
7149 if (rop->op_first->op_type == OP_PADSV)
7150 /* @$hash{qw(keys here)} */
7151 rop = (UNOP*)rop->op_first;
7153 /* @{$hash}{qw(keys here)} */
7154 if (rop->op_first->op_type == OP_SCOPE
7155 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
7157 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
7163 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
7164 if (!SvPAD_TYPED(lexname))
7166 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
7167 if (!fields || !GvHV(*fields))
7169 /* Again guessing that the pushmark can be jumped over.... */
7170 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
7171 ->op_first->op_sibling;
7172 for (key_op = first_key_op; key_op;
7173 key_op = (SVOP*)key_op->op_sibling) {
7174 if (key_op->op_type != OP_CONST)
7176 svp = cSVOPx_svp(key_op);
7177 key = SvPV_const(*svp, keylen);
7178 if (!hv_fetch(GvHV(*fields), key,
7179 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
7181 Perl_croak(aTHX_ "No such class field \"%s\" "
7182 "in variable %s of type %s",
7183 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
7190 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
7194 /* check that RHS of sort is a single plain array */
7195 OP *oright = cUNOPo->op_first;
7196 if (!oright || oright->op_type != OP_PUSHMARK)
7199 /* reverse sort ... can be optimised. */
7200 if (!cUNOPo->op_sibling) {
7201 /* Nothing follows us on the list. */
7202 OP * const reverse = o->op_next;
7204 if (reverse->op_type == OP_REVERSE &&
7205 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
7206 OP * const pushmark = cUNOPx(reverse)->op_first;
7207 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
7208 && (cUNOPx(pushmark)->op_sibling == o)) {
7209 /* reverse -> pushmark -> sort */
7210 o->op_private |= OPpSORT_REVERSE;
7212 pushmark->op_next = oright->op_next;
7218 /* make @a = sort @a act in-place */
7222 oright = cUNOPx(oright)->op_sibling;
7225 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
7226 oright = cUNOPx(oright)->op_sibling;
7230 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
7231 || oright->op_next != o
7232 || (oright->op_private & OPpLVAL_INTRO)
7236 /* o2 follows the chain of op_nexts through the LHS of the
7237 * assign (if any) to the aassign op itself */
7239 if (!o2 || o2->op_type != OP_NULL)
7242 if (!o2 || o2->op_type != OP_PUSHMARK)
7245 if (o2 && o2->op_type == OP_GV)
7248 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
7249 || (o2->op_private & OPpLVAL_INTRO)
7254 if (!o2 || o2->op_type != OP_NULL)
7257 if (!o2 || o2->op_type != OP_AASSIGN
7258 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
7261 /* check that the sort is the first arg on RHS of assign */
7263 o2 = cUNOPx(o2)->op_first;
7264 if (!o2 || o2->op_type != OP_NULL)
7266 o2 = cUNOPx(o2)->op_first;
7267 if (!o2 || o2->op_type != OP_PUSHMARK)
7269 if (o2->op_sibling != o)
7272 /* check the array is the same on both sides */
7273 if (oleft->op_type == OP_RV2AV) {
7274 if (oright->op_type != OP_RV2AV
7275 || !cUNOPx(oright)->op_first
7276 || cUNOPx(oright)->op_first->op_type != OP_GV
7277 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
7278 cGVOPx_gv(cUNOPx(oright)->op_first)
7282 else if (oright->op_type != OP_PADAV
7283 || oright->op_targ != oleft->op_targ
7287 /* transfer MODishness etc from LHS arg to RHS arg */
7288 oright->op_flags = oleft->op_flags;
7289 o->op_private |= OPpSORT_INPLACE;
7291 /* excise push->gv->rv2av->null->aassign */
7292 o2 = o->op_next->op_next;
7293 op_null(o2); /* PUSHMARK */
7295 if (o2->op_type == OP_GV) {
7296 op_null(o2); /* GV */
7299 op_null(o2); /* RV2AV or PADAV */
7300 o2 = o2->op_next->op_next;
7301 op_null(o2); /* AASSIGN */
7303 o->op_next = o2->op_next;
7309 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
7311 LISTOP *enter, *exlist;
7314 enter = (LISTOP *) o->op_next;
7317 if (enter->op_type == OP_NULL) {
7318 enter = (LISTOP *) enter->op_next;
7322 /* for $a (...) will have OP_GV then OP_RV2GV here.
7323 for (...) just has an OP_GV. */
7324 if (enter->op_type == OP_GV) {
7325 gvop = (OP *) enter;
7326 enter = (LISTOP *) enter->op_next;
7329 if (enter->op_type == OP_RV2GV) {
7330 enter = (LISTOP *) enter->op_next;
7336 if (enter->op_type != OP_ENTERITER)
7339 iter = enter->op_next;
7340 if (!iter || iter->op_type != OP_ITER)
7343 expushmark = enter->op_first;
7344 if (!expushmark || expushmark->op_type != OP_NULL
7345 || expushmark->op_targ != OP_PUSHMARK)
7348 exlist = (LISTOP *) expushmark->op_sibling;
7349 if (!exlist || exlist->op_type != OP_NULL
7350 || exlist->op_targ != OP_LIST)
7353 if (exlist->op_last != o) {
7354 /* Mmm. Was expecting to point back to this op. */
7357 theirmark = exlist->op_first;
7358 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
7361 if (theirmark->op_sibling != o) {
7362 /* There's something between the mark and the reverse, eg
7363 for (1, reverse (...))
7368 ourmark = ((LISTOP *)o)->op_first;
7369 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
7372 ourlast = ((LISTOP *)o)->op_last;
7373 if (!ourlast || ourlast->op_next != o)
7376 rv2av = ourmark->op_sibling;
7377 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
7378 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
7379 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
7380 /* We're just reversing a single array. */
7381 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
7382 enter->op_flags |= OPf_STACKED;
7385 /* We don't have control over who points to theirmark, so sacrifice
7387 theirmark->op_next = ourmark->op_next;
7388 theirmark->op_flags = ourmark->op_flags;
7389 ourlast->op_next = gvop ? gvop : (OP *) enter;
7392 enter->op_private |= OPpITER_REVERSED;
7393 iter->op_private |= OPpITER_REVERSED;
7400 UNOP *refgen, *rv2cv;
7403 /* I do not understand this, but if o->op_opt isn't set to 1,
7404 various tests in ext/B/t/bytecode.t fail with no readily
7410 if ((o->op_flags && OPf_WANT) != OPf_WANT_VOID)
7413 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
7416 rv2gv = ((BINOP *)o)->op_last;
7417 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
7420 refgen = (UNOP *)((BINOP *)o)->op_first;
7422 if (!refgen || refgen->op_type != OP_REFGEN)
7425 exlist = (LISTOP *)refgen->op_first;
7426 if (!exlist || exlist->op_type != OP_NULL
7427 || exlist->op_targ != OP_LIST)
7430 if (exlist->op_first->op_type != OP_PUSHMARK)
7433 rv2cv = (UNOP*)exlist->op_last;
7435 if (rv2cv->op_type != OP_RV2CV)
7438 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
7439 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
7440 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
7442 o->op_private |= OPpASSIGN_CV_TO_GV;
7443 rv2gv->op_private |= OPpDONT_INIT_GV;
7444 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
7460 Perl_custom_op_name(pTHX_ const OP* o)
7463 const IV index = PTR2IV(o->op_ppaddr);
7467 if (!PL_custom_op_names) /* This probably shouldn't happen */
7468 return (char *)PL_op_name[OP_CUSTOM];
7470 keysv = sv_2mortal(newSViv(index));
7472 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
7474 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
7476 return SvPV_nolen(HeVAL(he));
7480 Perl_custom_op_desc(pTHX_ const OP* o)
7483 const IV index = PTR2IV(o->op_ppaddr);
7487 if (!PL_custom_op_descs)
7488 return (char *)PL_op_desc[OP_CUSTOM];
7490 keysv = sv_2mortal(newSViv(index));
7492 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
7494 return (char *)PL_op_desc[OP_CUSTOM];
7496 return SvPV_nolen(HeVAL(he));
7501 /* Efficient sub that returns a constant scalar value. */
7503 const_sv_xsub(pTHX_ CV* cv)
7510 Perl_croak(aTHX_ "usage: %s::%s()",
7511 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7515 ST(0) = (SV*)XSANY.any_ptr;
7521 * c-indentation-style: bsd
7523 * indent-tabs-mode: t
7526 * ex: set ts=8 sts=4 sw=4 noet: