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(offset) & SVpad_OUR) {
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(offset) & SVpad_OUR) {
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)) {
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);
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;
4592 cv = newCONSTSUB(NULL, name, const_sv);
4595 SvREFCNT_dec(PL_compcv);
4597 PL_sub_generation++;
4604 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4605 * before we clobber PL_compcv.
4609 /* Might have had built-in attributes applied -- propagate them. */
4610 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4611 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4612 stash = GvSTASH(CvGV(cv));
4613 else if (CvSTASH(cv))
4614 stash = CvSTASH(cv);
4616 stash = PL_curstash;
4619 /* possibly about to re-define existing subr -- ignore old cv */
4620 rcv = (SV*)PL_compcv;
4621 if (name && GvSTASH(gv))
4622 stash = GvSTASH(gv);
4624 stash = PL_curstash;
4626 apply_attrs(stash, rcv, attrs, FALSE);
4628 if (cv) { /* must reuse cv if autoloaded */
4630 /* got here with just attrs -- work done, so bug out */
4631 SAVEFREESV(PL_compcv);
4634 /* transfer PL_compcv to cv */
4636 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4637 if (!CvWEAKOUTSIDE(cv))
4638 SvREFCNT_dec(CvOUTSIDE(cv));
4639 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4640 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
4641 CvOUTSIDE(PL_compcv) = 0;
4642 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4643 CvPADLIST(PL_compcv) = 0;
4644 /* inner references to PL_compcv must be fixed up ... */
4645 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
4646 /* ... before we throw it away */
4647 SvREFCNT_dec(PL_compcv);
4649 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4650 ++PL_sub_generation;
4657 PL_sub_generation++;
4661 CvFILE_set_from_cop(cv, PL_curcop);
4662 CvSTASH(cv) = PL_curstash;
4665 sv_setpvn((SV*)cv, ps, ps_len);
4667 if (PL_error_count) {
4671 const char *s = strrchr(name, ':');
4673 if (strEQ(s, "BEGIN")) {
4674 const char not_safe[] =
4675 "BEGIN not safe after errors--compilation aborted";
4676 if (PL_in_eval & EVAL_KEEPERR)
4677 Perl_croak(aTHX_ not_safe);
4679 /* force display of errors found but not reported */
4680 sv_catpv(ERRSV, not_safe);
4681 Perl_croak(aTHX_ "%"SVf, ERRSV);
4690 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4691 mod(scalarseq(block), OP_LEAVESUBLV));
4694 /* This makes sub {}; work as expected. */
4695 if (block->op_type == OP_STUB) {
4697 block = newSTATEOP(0, NULL, 0);
4699 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4701 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4702 OpREFCNT_set(CvROOT(cv), 1);
4703 CvSTART(cv) = LINKLIST(CvROOT(cv));
4704 CvROOT(cv)->op_next = 0;
4705 CALL_PEEP(CvSTART(cv));
4707 /* now that optimizer has done its work, adjust pad values */
4709 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4712 assert(!CvCONST(cv));
4713 if (ps && !*ps && op_const_sv(block, cv))
4717 if (name || aname) {
4719 const char * const tname = (name ? name : aname);
4721 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4722 SV * const sv = newSV(0);
4723 SV * const tmpstr = sv_newmortal();
4724 GV * const db_postponed = gv_fetchpvs("DB::postponed",
4725 GV_ADDMULTI, SVt_PVHV);
4728 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4730 (long)PL_subline, (long)CopLINE(PL_curcop));
4731 gv_efullname3(tmpstr, gv, NULL);
4732 hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0);
4733 hv = GvHVn(db_postponed);
4734 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
4735 CV * const pcv = GvCV(db_postponed);
4741 call_sv((SV*)pcv, G_DISCARD);
4746 if ((s = strrchr(tname,':')))
4751 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4754 if (strEQ(s, "BEGIN") && !PL_error_count) {
4755 const I32 oldscope = PL_scopestack_ix;
4757 SAVECOPFILE(&PL_compiling);
4758 SAVECOPLINE(&PL_compiling);
4761 PL_beginav = newAV();
4762 DEBUG_x( dump_sub(gv) );
4763 av_push(PL_beginav, (SV*)cv);
4764 GvCV(gv) = 0; /* cv has been hijacked */
4765 call_list(oldscope, PL_beginav);
4767 PL_curcop = &PL_compiling;
4768 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4771 else if (strEQ(s, "END") && !PL_error_count) {
4774 DEBUG_x( dump_sub(gv) );
4775 av_unshift(PL_endav, 1);
4776 av_store(PL_endav, 0, (SV*)cv);
4777 GvCV(gv) = 0; /* cv has been hijacked */
4779 else if (strEQ(s, "CHECK") && !PL_error_count) {
4781 PL_checkav = newAV();
4782 DEBUG_x( dump_sub(gv) );
4783 if (PL_main_start && ckWARN(WARN_VOID))
4784 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4785 av_unshift(PL_checkav, 1);
4786 av_store(PL_checkav, 0, (SV*)cv);
4787 GvCV(gv) = 0; /* cv has been hijacked */
4789 else if (strEQ(s, "INIT") && !PL_error_count) {
4791 PL_initav = newAV();
4792 DEBUG_x( dump_sub(gv) );
4793 if (PL_main_start && ckWARN(WARN_VOID))
4794 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4795 av_push(PL_initav, (SV*)cv);
4796 GvCV(gv) = 0; /* cv has been hijacked */
4801 PL_copline = NOLINE;
4806 /* XXX unsafe for threads if eval_owner isn't held */
4808 =for apidoc newCONSTSUB
4810 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4811 eligible for inlining at compile-time.
4817 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
4824 SAVECOPLINE(PL_curcop);
4825 CopLINE_set(PL_curcop, PL_copline);
4828 PL_hints &= ~HINT_BLOCK_SCOPE;
4831 SAVESPTR(PL_curstash);
4832 SAVECOPSTASH(PL_curcop);
4833 PL_curstash = stash;
4834 CopSTASH_set(PL_curcop,stash);
4837 cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
4838 CvXSUBANY(cv).any_ptr = sv;
4840 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
4844 CopSTASH_free(PL_curcop);
4852 =for apidoc U||newXS
4854 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4860 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
4863 GV * const gv = gv_fetchpv(name ? name :
4864 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4865 GV_ADDMULTI, SVt_PVCV);
4869 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4871 if ((cv = (name ? GvCV(gv) : NULL))) {
4873 /* just a cached method */
4877 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4878 /* already defined (or promised) */
4879 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
4880 if (ckWARN(WARN_REDEFINE)) {
4881 GV * const gvcv = CvGV(cv);
4883 HV * const stash = GvSTASH(gvcv);
4885 const char *redefined_name = HvNAME_get(stash);
4886 if ( strEQ(redefined_name,"autouse") ) {
4887 const line_t oldline = CopLINE(PL_curcop);
4888 if (PL_copline != NOLINE)
4889 CopLINE_set(PL_curcop, PL_copline);
4890 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4891 CvCONST(cv) ? "Constant subroutine %s redefined"
4892 : "Subroutine %s redefined"
4894 CopLINE_set(PL_curcop, oldline);
4904 if (cv) /* must reuse cv if autoloaded */
4908 sv_upgrade((SV *)cv, SVt_PVCV);
4912 PL_sub_generation++;
4916 (void)gv_fetchfile(filename);
4917 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
4918 an external constant string */
4919 CvXSUB(cv) = subaddr;
4922 const char *s = strrchr(name,':');
4928 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4931 if (strEQ(s, "BEGIN")) {
4933 PL_beginav = newAV();
4934 av_push(PL_beginav, (SV*)cv);
4935 GvCV(gv) = 0; /* cv has been hijacked */
4937 else if (strEQ(s, "END")) {
4940 av_unshift(PL_endav, 1);
4941 av_store(PL_endav, 0, (SV*)cv);
4942 GvCV(gv) = 0; /* cv has been hijacked */
4944 else if (strEQ(s, "CHECK")) {
4946 PL_checkav = newAV();
4947 if (PL_main_start && ckWARN(WARN_VOID))
4948 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4949 av_unshift(PL_checkav, 1);
4950 av_store(PL_checkav, 0, (SV*)cv);
4951 GvCV(gv) = 0; /* cv has been hijacked */
4953 else if (strEQ(s, "INIT")) {
4955 PL_initav = newAV();
4956 if (PL_main_start && ckWARN(WARN_VOID))
4957 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4958 av_push(PL_initav, (SV*)cv);
4959 GvCV(gv) = 0; /* cv has been hijacked */
4970 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4976 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
4977 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
4979 #ifdef GV_UNIQUE_CHECK
4981 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
4985 if ((cv = GvFORM(gv))) {
4986 if (ckWARN(WARN_REDEFINE)) {
4987 const line_t oldline = CopLINE(PL_curcop);
4988 if (PL_copline != NOLINE)
4989 CopLINE_set(PL_curcop, PL_copline);
4990 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4991 o ? "Format %"SVf" redefined"
4992 : "Format STDOUT redefined" ,cSVOPo->op_sv);
4993 CopLINE_set(PL_curcop, oldline);
5000 CvFILE_set_from_cop(cv, PL_curcop);
5003 pad_tidy(padtidy_FORMAT);
5004 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5005 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5006 OpREFCNT_set(CvROOT(cv), 1);
5007 CvSTART(cv) = LINKLIST(CvROOT(cv));
5008 CvROOT(cv)->op_next = 0;
5009 CALL_PEEP(CvSTART(cv));
5011 PL_copline = NOLINE;
5016 Perl_newANONLIST(pTHX_ OP *o)
5018 return newUNOP(OP_REFGEN, 0,
5019 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5023 Perl_newANONHASH(pTHX_ OP *o)
5025 return newUNOP(OP_REFGEN, 0,
5026 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5030 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5032 return newANONATTRSUB(floor, proto, NULL, block);
5036 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5038 return newUNOP(OP_REFGEN, 0,
5039 newSVOP(OP_ANONCODE, 0,
5040 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5044 Perl_oopsAV(pTHX_ OP *o)
5047 switch (o->op_type) {
5049 o->op_type = OP_PADAV;
5050 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5051 return ref(o, OP_RV2AV);
5054 o->op_type = OP_RV2AV;
5055 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5060 if (ckWARN_d(WARN_INTERNAL))
5061 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
5068 Perl_oopsHV(pTHX_ OP *o)
5071 switch (o->op_type) {
5074 o->op_type = OP_PADHV;
5075 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5076 return ref(o, OP_RV2HV);
5080 o->op_type = OP_RV2HV;
5081 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5086 if (ckWARN_d(WARN_INTERNAL))
5087 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
5094 Perl_newAVREF(pTHX_ OP *o)
5097 if (o->op_type == OP_PADANY) {
5098 o->op_type = OP_PADAV;
5099 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5102 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5103 && ckWARN(WARN_DEPRECATED)) {
5104 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5105 "Using an array as a reference is deprecated");
5107 return newUNOP(OP_RV2AV, 0, scalar(o));
5111 Perl_newGVREF(pTHX_ I32 type, OP *o)
5113 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5114 return newUNOP(OP_NULL, 0, o);
5115 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5119 Perl_newHVREF(pTHX_ OP *o)
5122 if (o->op_type == OP_PADANY) {
5123 o->op_type = OP_PADHV;
5124 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5127 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5128 && ckWARN(WARN_DEPRECATED)) {
5129 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5130 "Using a hash as a reference is deprecated");
5132 return newUNOP(OP_RV2HV, 0, scalar(o));
5136 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5138 return newUNOP(OP_RV2CV, flags, scalar(o));
5142 Perl_newSVREF(pTHX_ OP *o)
5145 if (o->op_type == OP_PADANY) {
5146 o->op_type = OP_PADSV;
5147 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5150 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5151 o->op_flags |= OPpDONE_SVREF;
5154 return newUNOP(OP_RV2SV, 0, scalar(o));
5157 /* Check routines. See the comments at the top of this file for details
5158 * on when these are called */
5161 Perl_ck_anoncode(pTHX_ OP *o)
5163 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
5164 cSVOPo->op_sv = NULL;
5169 Perl_ck_bitop(pTHX_ OP *o)
5172 #define OP_IS_NUMCOMPARE(op) \
5173 ((op) == OP_LT || (op) == OP_I_LT || \
5174 (op) == OP_GT || (op) == OP_I_GT || \
5175 (op) == OP_LE || (op) == OP_I_LE || \
5176 (op) == OP_GE || (op) == OP_I_GE || \
5177 (op) == OP_EQ || (op) == OP_I_EQ || \
5178 (op) == OP_NE || (op) == OP_I_NE || \
5179 (op) == OP_NCMP || (op) == OP_I_NCMP)
5180 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
5181 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
5182 && (o->op_type == OP_BIT_OR
5183 || o->op_type == OP_BIT_AND
5184 || o->op_type == OP_BIT_XOR))
5186 const OP * const left = cBINOPo->op_first;
5187 const OP * const right = left->op_sibling;
5188 if ((OP_IS_NUMCOMPARE(left->op_type) &&
5189 (left->op_flags & OPf_PARENS) == 0) ||
5190 (OP_IS_NUMCOMPARE(right->op_type) &&
5191 (right->op_flags & OPf_PARENS) == 0))
5192 if (ckWARN(WARN_PRECEDENCE))
5193 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
5194 "Possible precedence problem on bitwise %c operator",
5195 o->op_type == OP_BIT_OR ? '|'
5196 : o->op_type == OP_BIT_AND ? '&' : '^'
5203 Perl_ck_concat(pTHX_ OP *o)
5205 const OP * const kid = cUNOPo->op_first;
5206 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
5207 !(kUNOP->op_first->op_flags & OPf_MOD))
5208 o->op_flags |= OPf_STACKED;
5213 Perl_ck_spair(pTHX_ OP *o)
5216 if (o->op_flags & OPf_KIDS) {
5219 const OPCODE type = o->op_type;
5220 o = modkids(ck_fun(o), type);
5221 kid = cUNOPo->op_first;
5222 newop = kUNOP->op_first->op_sibling;
5224 (newop->op_sibling ||
5225 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5226 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5227 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5231 op_free(kUNOP->op_first);
5232 kUNOP->op_first = newop;
5234 o->op_ppaddr = PL_ppaddr[++o->op_type];
5239 Perl_ck_delete(pTHX_ OP *o)
5243 if (o->op_flags & OPf_KIDS) {
5244 OP * const kid = cUNOPo->op_first;
5245 switch (kid->op_type) {
5247 o->op_flags |= OPf_SPECIAL;
5250 o->op_private |= OPpSLICE;
5253 o->op_flags |= OPf_SPECIAL;
5258 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5267 Perl_ck_die(pTHX_ OP *o)
5270 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5276 Perl_ck_eof(pTHX_ OP *o)
5279 const I32 type = o->op_type;
5281 if (o->op_flags & OPf_KIDS) {
5282 if (cLISTOPo->op_first->op_type == OP_STUB) {
5284 o = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
5292 Perl_ck_eval(pTHX_ OP *o)
5295 PL_hints |= HINT_BLOCK_SCOPE;
5296 if (o->op_flags & OPf_KIDS) {
5297 SVOP * const kid = (SVOP*)cUNOPo->op_first;
5300 o->op_flags &= ~OPf_KIDS;
5303 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
5306 cUNOPo->op_first = 0;
5309 NewOp(1101, enter, 1, LOGOP);
5310 enter->op_type = OP_ENTERTRY;
5311 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5312 enter->op_private = 0;
5314 /* establish postfix order */
5315 enter->op_next = (OP*)enter;
5317 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5318 o->op_type = OP_LEAVETRY;
5319 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5320 enter->op_other = o;
5330 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5332 o->op_targ = (PADOFFSET)PL_hints;
5333 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
5334 /* Store a copy of %^H that pp_entereval can pick up */
5335 OP *hhop = newSVOP(OP_CONST, 0, (SV*)newHVhv(GvHV(PL_hintgv)));
5336 cUNOPo->op_first->op_sibling = hhop;
5337 o->op_private |= OPpEVAL_HAS_HH;
5343 Perl_ck_exit(pTHX_ OP *o)
5346 HV * const table = GvHV(PL_hintgv);
5348 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
5349 if (svp && *svp && SvTRUE(*svp))
5350 o->op_private |= OPpEXIT_VMSISH;
5352 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5358 Perl_ck_exec(pTHX_ OP *o)
5360 if (o->op_flags & OPf_STACKED) {
5363 kid = cUNOPo->op_first->op_sibling;
5364 if (kid->op_type == OP_RV2GV)
5373 Perl_ck_exists(pTHX_ OP *o)
5377 if (o->op_flags & OPf_KIDS) {
5378 OP * const kid = cUNOPo->op_first;
5379 if (kid->op_type == OP_ENTERSUB) {
5380 (void) ref(kid, o->op_type);
5381 if (kid->op_type != OP_RV2CV && !PL_error_count)
5382 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5384 o->op_private |= OPpEXISTS_SUB;
5386 else if (kid->op_type == OP_AELEM)
5387 o->op_flags |= OPf_SPECIAL;
5388 else if (kid->op_type != OP_HELEM)
5389 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5397 Perl_ck_rvconst(pTHX_ register OP *o)
5400 SVOP * const kid = (SVOP*)cUNOPo->op_first;
5402 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5403 if (o->op_type == OP_RV2CV)
5404 o->op_private &= ~1;
5406 if (kid->op_type == OP_CONST) {
5409 SV * const kidsv = kid->op_sv;
5411 /* Is it a constant from cv_const_sv()? */
5412 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5413 SV * const rsv = SvRV(kidsv);
5414 const int svtype = SvTYPE(rsv);
5415 const char *badtype = NULL;
5417 switch (o->op_type) {
5419 if (svtype > SVt_PVMG)
5420 badtype = "a SCALAR";
5423 if (svtype != SVt_PVAV)
5424 badtype = "an ARRAY";
5427 if (svtype != SVt_PVHV)
5431 if (svtype != SVt_PVCV)
5436 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5439 else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
5440 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
5441 /* If this is an access to a stash, disable "strict refs", because
5442 * stashes aren't auto-vivified at compile-time (unless we store
5443 * symbols in them), and we don't want to produce a run-time
5444 * stricture error when auto-vivifying the stash. */
5445 const char *s = SvPV_nolen(kidsv);
5446 const STRLEN l = SvCUR(kidsv);
5447 if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
5448 o->op_private &= ~HINT_STRICT_REFS;
5450 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5451 const char *badthing;
5452 switch (o->op_type) {
5454 badthing = "a SCALAR";
5457 badthing = "an ARRAY";
5460 badthing = "a HASH";
5468 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
5472 * This is a little tricky. We only want to add the symbol if we
5473 * didn't add it in the lexer. Otherwise we get duplicate strict
5474 * warnings. But if we didn't add it in the lexer, we must at
5475 * least pretend like we wanted to add it even if it existed before,
5476 * or we get possible typo warnings. OPpCONST_ENTERED says
5477 * whether the lexer already added THIS instance of this symbol.
5479 iscv = (o->op_type == OP_RV2CV) * 2;
5481 gv = gv_fetchsv(kidsv,
5482 iscv | !(kid->op_private & OPpCONST_ENTERED),
5485 : o->op_type == OP_RV2SV
5487 : o->op_type == OP_RV2AV
5489 : o->op_type == OP_RV2HV
5492 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5494 kid->op_type = OP_GV;
5495 SvREFCNT_dec(kid->op_sv);
5497 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5498 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5499 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
5501 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv));
5503 kid->op_sv = SvREFCNT_inc(gv);
5505 kid->op_private = 0;
5506 kid->op_ppaddr = PL_ppaddr[OP_GV];
5513 Perl_ck_ftst(pTHX_ OP *o)
5516 const I32 type = o->op_type;
5518 if (o->op_flags & OPf_REF) {
5521 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5522 SVOP * const kid = (SVOP*)cUNOPo->op_first;
5524 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5525 OP * const newop = newGVOP(type, OPf_REF,
5526 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
5532 if ((PL_hints & HINT_FILETEST_ACCESS) &&
5533 OP_IS_FILETEST_ACCESS(o))
5534 o->op_private |= OPpFT_ACCESS;
5536 if (PL_check[kid->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst)
5537 && kid->op_type != OP_STAT && kid->op_type != OP_LSTAT)
5538 o->op_private |= OPpFT_STACKED;
5542 if (type == OP_FTTTY)
5543 o = newGVOP(type, OPf_REF, PL_stdingv);
5545 o = newUNOP(type, 0, newDEFSVOP());
5551 Perl_ck_fun(pTHX_ OP *o)
5554 const int type = o->op_type;
5555 register I32 oa = PL_opargs[type] >> OASHIFT;
5557 if (o->op_flags & OPf_STACKED) {
5558 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5561 return no_fh_allowed(o);
5564 if (o->op_flags & OPf_KIDS) {
5565 OP **tokid = &cLISTOPo->op_first;
5566 register OP *kid = cLISTOPo->op_first;
5570 if (kid->op_type == OP_PUSHMARK ||
5571 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5573 tokid = &kid->op_sibling;
5574 kid = kid->op_sibling;
5576 if (!kid && PL_opargs[type] & OA_DEFGV)
5577 *tokid = kid = newDEFSVOP();
5581 sibl = kid->op_sibling;
5584 /* list seen where single (scalar) arg expected? */
5585 if (numargs == 1 && !(oa >> 4)
5586 && kid->op_type == OP_LIST && type != OP_SCALAR)
5588 return too_many_arguments(o,PL_op_desc[type]);
5601 if ((type == OP_PUSH || type == OP_UNSHIFT)
5602 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5603 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5604 "Useless use of %s with no values",
5607 if (kid->op_type == OP_CONST &&
5608 (kid->op_private & OPpCONST_BARE))
5610 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
5611 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
5612 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5613 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5614 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
5615 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
5618 kid->op_sibling = sibl;
5621 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5622 bad_type(numargs, "array", PL_op_desc[type], kid);
5626 if (kid->op_type == OP_CONST &&
5627 (kid->op_private & OPpCONST_BARE))
5629 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
5630 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
5631 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5632 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5633 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
5634 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
5637 kid->op_sibling = sibl;
5640 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5641 bad_type(numargs, "hash", PL_op_desc[type], kid);
5646 OP * const newop = newUNOP(OP_NULL, 0, kid);
5647 kid->op_sibling = 0;
5649 newop->op_next = newop;
5651 kid->op_sibling = sibl;
5656 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5657 if (kid->op_type == OP_CONST &&
5658 (kid->op_private & OPpCONST_BARE))
5660 OP * const newop = newGVOP(OP_GV, 0,
5661 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
5662 if (!(o->op_private & 1) && /* if not unop */
5663 kid == cLISTOPo->op_last)
5664 cLISTOPo->op_last = newop;
5668 else if (kid->op_type == OP_READLINE) {
5669 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5670 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5673 I32 flags = OPf_SPECIAL;
5677 /* is this op a FH constructor? */
5678 if (is_handle_constructor(o,numargs)) {
5679 const char *name = NULL;
5683 /* Set a flag to tell rv2gv to vivify
5684 * need to "prove" flag does not mean something
5685 * else already - NI-S 1999/05/07
5688 if (kid->op_type == OP_PADSV) {
5689 name = PAD_COMPNAME_PV(kid->op_targ);
5690 /* SvCUR of a pad namesv can't be trusted
5691 * (see PL_generation), so calc its length
5697 else if (kid->op_type == OP_RV2SV
5698 && kUNOP->op_first->op_type == OP_GV)
5700 GV * const gv = cGVOPx_gv(kUNOP->op_first);
5702 len = GvNAMELEN(gv);
5704 else if (kid->op_type == OP_AELEM
5705 || kid->op_type == OP_HELEM)
5707 OP *op = ((BINOP*)kid)->op_first;
5711 const char * const a =
5712 kid->op_type == OP_AELEM ?
5714 if (((op->op_type == OP_RV2AV) ||
5715 (op->op_type == OP_RV2HV)) &&
5716 (op = ((UNOP*)op)->op_first) &&
5717 (op->op_type == OP_GV)) {
5718 /* packagevar $a[] or $h{} */
5719 GV * const gv = cGVOPx_gv(op);
5727 else if (op->op_type == OP_PADAV
5728 || op->op_type == OP_PADHV) {
5729 /* lexicalvar $a[] or $h{} */
5730 const char * const padname =
5731 PAD_COMPNAME_PV(op->op_targ);
5740 name = SvPV_const(tmpstr, len);
5745 name = "__ANONIO__";
5752 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5753 namesv = PAD_SVl(targ);
5754 SvUPGRADE(namesv, SVt_PV);
5756 sv_setpvn(namesv, "$", 1);
5757 sv_catpvn(namesv, name, len);
5760 kid->op_sibling = 0;
5761 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5762 kid->op_targ = targ;
5763 kid->op_private |= priv;
5765 kid->op_sibling = sibl;
5771 mod(scalar(kid), type);
5775 tokid = &kid->op_sibling;
5776 kid = kid->op_sibling;
5778 o->op_private |= numargs;
5780 return too_many_arguments(o,OP_DESC(o));
5783 else if (PL_opargs[type] & OA_DEFGV) {
5785 return newUNOP(type, 0, newDEFSVOP());
5789 while (oa & OA_OPTIONAL)
5791 if (oa && oa != OA_LIST)
5792 return too_few_arguments(o,OP_DESC(o));
5798 Perl_ck_glob(pTHX_ OP *o)
5804 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5805 append_elem(OP_GLOB, o, newDEFSVOP());
5807 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
5808 && GvCVu(gv) && GvIMPORTED_CV(gv)))
5810 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
5813 #if !defined(PERL_EXTERNAL_GLOB)
5814 /* XXX this can be tightened up and made more failsafe. */
5815 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
5818 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5819 newSVpvs("File::Glob"), NULL, NULL, NULL);
5820 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
5821 glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
5822 GvCV(gv) = GvCV(glob_gv);
5823 (void)SvREFCNT_inc((SV*)GvCV(gv));
5824 GvIMPORTED_CV_on(gv);
5827 #endif /* PERL_EXTERNAL_GLOB */
5829 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5830 append_elem(OP_GLOB, o,
5831 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5832 o->op_type = OP_LIST;
5833 o->op_ppaddr = PL_ppaddr[OP_LIST];
5834 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5835 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5836 cLISTOPo->op_first->op_targ = 0;
5837 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5838 append_elem(OP_LIST, o,
5839 scalar(newUNOP(OP_RV2CV, 0,
5840 newGVOP(OP_GV, 0, gv)))));
5841 o = newUNOP(OP_NULL, 0, ck_subr(o));
5842 o->op_targ = OP_GLOB; /* hint at what it used to be */
5845 gv = newGVgen("main");
5847 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5853 Perl_ck_grep(pTHX_ OP *o)
5858 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5861 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5862 NewOp(1101, gwop, 1, LOGOP);
5864 if (o->op_flags & OPf_STACKED) {
5867 kid = cLISTOPo->op_first->op_sibling;
5868 if (!cUNOPx(kid)->op_next)
5869 Perl_croak(aTHX_ "panic: ck_grep");
5870 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
5873 kid->op_next = (OP*)gwop;
5874 o->op_flags &= ~OPf_STACKED;
5876 kid = cLISTOPo->op_first->op_sibling;
5877 if (type == OP_MAPWHILE)
5884 kid = cLISTOPo->op_first->op_sibling;
5885 if (kid->op_type != OP_NULL)
5886 Perl_croak(aTHX_ "panic: ck_grep");
5887 kid = kUNOP->op_first;
5889 gwop->op_type = type;
5890 gwop->op_ppaddr = PL_ppaddr[type];
5891 gwop->op_first = listkids(o);
5892 gwop->op_flags |= OPf_KIDS;
5893 gwop->op_other = LINKLIST(kid);
5894 kid->op_next = (OP*)gwop;
5895 offset = pad_findmy("$_");
5896 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
5897 o->op_private = gwop->op_private = 0;
5898 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5901 o->op_private = gwop->op_private = OPpGREP_LEX;
5902 gwop->op_targ = o->op_targ = offset;
5905 kid = cLISTOPo->op_first->op_sibling;
5906 if (!kid || !kid->op_sibling)
5907 return too_few_arguments(o,OP_DESC(o));
5908 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5909 mod(kid, OP_GREPSTART);
5915 Perl_ck_index(pTHX_ OP *o)
5917 if (o->op_flags & OPf_KIDS) {
5918 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5920 kid = kid->op_sibling; /* get past "big" */
5921 if (kid && kid->op_type == OP_CONST)
5922 fbm_compile(((SVOP*)kid)->op_sv, 0);
5928 Perl_ck_lengthconst(pTHX_ OP *o)
5930 /* XXX length optimization goes here */
5935 Perl_ck_lfun(pTHX_ OP *o)
5937 const OPCODE type = o->op_type;
5938 return modkids(ck_fun(o), type);
5942 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5944 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
5945 switch (cUNOPo->op_first->op_type) {
5947 /* This is needed for
5948 if (defined %stash::)
5949 to work. Do not break Tk.
5951 break; /* Globals via GV can be undef */
5953 case OP_AASSIGN: /* Is this a good idea? */
5954 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5955 "defined(@array) is deprecated");
5956 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5957 "\t(Maybe you should just omit the defined()?)\n");
5960 /* This is needed for
5961 if (defined %stash::)
5962 to work. Do not break Tk.
5964 break; /* Globals via GV can be undef */
5966 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5967 "defined(%%hash) is deprecated");
5968 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5969 "\t(Maybe you should just omit the defined()?)\n");
5980 Perl_ck_rfun(pTHX_ OP *o)
5982 const OPCODE type = o->op_type;
5983 return refkids(ck_fun(o), type);
5987 Perl_ck_listiob(pTHX_ OP *o)
5991 kid = cLISTOPo->op_first;
5994 kid = cLISTOPo->op_first;
5996 if (kid->op_type == OP_PUSHMARK)
5997 kid = kid->op_sibling;
5998 if (kid && o->op_flags & OPf_STACKED)
5999 kid = kid->op_sibling;
6000 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6001 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6002 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6003 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6004 cLISTOPo->op_first->op_sibling = kid;
6005 cLISTOPo->op_last = kid;
6006 kid = kid->op_sibling;
6011 append_elem(o->op_type, o, newDEFSVOP());
6017 Perl_ck_say(pTHX_ OP *o)
6020 o->op_type = OP_PRINT;
6021 cLISTOPo->op_last = cLISTOPo->op_last->op_sibling
6022 = newSVOP(OP_CONST, 0, newSVpvs("\n"));
6027 Perl_ck_smartmatch(pTHX_ OP *o)
6030 if (0 == (o->op_flags & OPf_SPECIAL)) {
6031 OP *first = cBINOPo->op_first;
6032 OP *second = first->op_sibling;
6034 /* Implicitly take a reference to an array or hash */
6035 first->op_sibling = NULL;
6036 first = cBINOPo->op_first = ref_array_or_hash(first);
6037 second = first->op_sibling = ref_array_or_hash(second);
6039 /* Implicitly take a reference to a regular expression */
6040 if (first->op_type == OP_MATCH) {
6041 first->op_type = OP_QR;
6042 first->op_ppaddr = PL_ppaddr[OP_QR];
6044 if (second->op_type == OP_MATCH) {
6045 second->op_type = OP_QR;
6046 second->op_ppaddr = PL_ppaddr[OP_QR];
6055 Perl_ck_sassign(pTHX_ OP *o)
6057 OP *kid = cLISTOPo->op_first;
6058 /* has a disposable target? */
6059 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6060 && !(kid->op_flags & OPf_STACKED)
6061 /* Cannot steal the second time! */
6062 && !(kid->op_private & OPpTARGET_MY))
6064 OP * const kkid = kid->op_sibling;
6066 /* Can just relocate the target. */
6067 if (kkid && kkid->op_type == OP_PADSV
6068 && !(kkid->op_private & OPpLVAL_INTRO))
6070 kid->op_targ = kkid->op_targ;
6072 /* Now we do not need PADSV and SASSIGN. */
6073 kid->op_sibling = o->op_sibling; /* NULL */
6074 cLISTOPo->op_first = NULL;
6077 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6085 Perl_ck_match(pTHX_ OP *o)
6088 if (o->op_type != OP_QR && PL_compcv) {
6089 const I32 offset = pad_findmy("$_");
6090 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS(offset) & SVpad_OUR)) {
6091 o->op_targ = offset;
6092 o->op_private |= OPpTARGET_MY;
6095 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
6096 o->op_private |= OPpRUNTIME;
6101 Perl_ck_method(pTHX_ OP *o)
6103 OP * const kid = cUNOPo->op_first;
6104 if (kid->op_type == OP_CONST) {
6105 SV* sv = kSVOP->op_sv;
6106 const char * const method = SvPVX_const(sv);
6107 if (!(strchr(method, ':') || strchr(method, '\''))) {
6109 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6110 sv = newSVpvn_share(method, SvCUR(sv), 0);
6113 kSVOP->op_sv = NULL;
6115 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6124 Perl_ck_null(pTHX_ OP *o)
6130 Perl_ck_open(pTHX_ OP *o)
6133 HV * const table = GvHV(PL_hintgv);
6135 SV **svp = hv_fetchs(table, "open_IN", FALSE);
6137 const I32 mode = mode_from_discipline(*svp);
6138 if (mode & O_BINARY)
6139 o->op_private |= OPpOPEN_IN_RAW;
6140 else if (mode & O_TEXT)
6141 o->op_private |= OPpOPEN_IN_CRLF;
6144 svp = hv_fetchs(table, "open_OUT", FALSE);
6146 const I32 mode = mode_from_discipline(*svp);
6147 if (mode & O_BINARY)
6148 o->op_private |= OPpOPEN_OUT_RAW;
6149 else if (mode & O_TEXT)
6150 o->op_private |= OPpOPEN_OUT_CRLF;
6153 if (o->op_type == OP_BACKTICK)
6156 /* In case of three-arg dup open remove strictness
6157 * from the last arg if it is a bareword. */
6158 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
6159 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
6163 if ((last->op_type == OP_CONST) && /* The bareword. */
6164 (last->op_private & OPpCONST_BARE) &&
6165 (last->op_private & OPpCONST_STRICT) &&
6166 (oa = first->op_sibling) && /* The fh. */
6167 (oa = oa->op_sibling) && /* The mode. */
6168 (oa->op_type == OP_CONST) &&
6169 SvPOK(((SVOP*)oa)->op_sv) &&
6170 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
6171 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
6172 (last == oa->op_sibling)) /* The bareword. */
6173 last->op_private &= ~OPpCONST_STRICT;
6179 Perl_ck_repeat(pTHX_ OP *o)
6181 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6182 o->op_private |= OPpREPEAT_DOLIST;
6183 cBINOPo->op_first = force_list(cBINOPo->op_first);
6191 Perl_ck_require(pTHX_ OP *o)
6196 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6197 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6199 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6200 SV * const sv = kid->op_sv;
6201 U32 was_readonly = SvREADONLY(sv);
6206 sv_force_normal_flags(sv, 0);
6207 assert(!SvREADONLY(sv));
6214 for (s = SvPVX(sv); *s; s++) {
6215 if (*s == ':' && s[1] == ':') {
6216 const STRLEN len = strlen(s+2)+1;
6218 Move(s+2, s+1, len, char);
6219 SvCUR_set(sv, SvCUR(sv) - 1);
6222 sv_catpvs(sv, ".pm");
6223 SvFLAGS(sv) |= was_readonly;
6227 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
6228 /* handle override, if any */
6229 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
6230 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
6231 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
6232 gv = gvp ? *gvp : NULL;
6236 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6237 OP * const kid = cUNOPo->op_first;
6238 cUNOPo->op_first = 0;
6240 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
6241 append_elem(OP_LIST, kid,
6242 scalar(newUNOP(OP_RV2CV, 0,
6251 Perl_ck_return(pTHX_ OP *o)
6254 if (CvLVALUE(PL_compcv)) {
6256 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6257 mod(kid, OP_LEAVESUBLV);
6263 Perl_ck_select(pTHX_ OP *o)
6267 if (o->op_flags & OPf_KIDS) {
6268 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6269 if (kid && kid->op_sibling) {
6270 o->op_type = OP_SSELECT;
6271 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6273 return fold_constants(o);
6277 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6278 if (kid && kid->op_type == OP_RV2GV)
6279 kid->op_private &= ~HINT_STRICT_REFS;
6284 Perl_ck_shift(pTHX_ OP *o)
6287 const I32 type = o->op_type;
6289 if (!(o->op_flags & OPf_KIDS)) {
6293 argop = newUNOP(OP_RV2AV, 0,
6294 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
6295 return newUNOP(type, 0, scalar(argop));
6297 return scalar(modkids(ck_fun(o), type));
6301 Perl_ck_sort(pTHX_ OP *o)
6306 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0)
6308 HV * const hinthv = GvHV(PL_hintgv);
6310 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
6312 const I32 sorthints = (I32)SvIV(*svp);
6313 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
6314 o->op_private |= OPpSORT_QSORT;
6315 if ((sorthints & HINT_SORT_STABLE) != 0)
6316 o->op_private |= OPpSORT_STABLE;
6321 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6323 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6324 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6326 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6328 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6330 if (kid->op_type == OP_SCOPE) {
6334 else if (kid->op_type == OP_LEAVE) {
6335 if (o->op_type == OP_SORT) {
6336 op_null(kid); /* wipe out leave */
6339 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6340 if (k->op_next == kid)
6342 /* don't descend into loops */
6343 else if (k->op_type == OP_ENTERLOOP
6344 || k->op_type == OP_ENTERITER)
6346 k = cLOOPx(k)->op_lastop;
6351 kid->op_next = 0; /* just disconnect the leave */
6352 k = kLISTOP->op_first;
6357 if (o->op_type == OP_SORT) {
6358 /* provide scalar context for comparison function/block */
6364 o->op_flags |= OPf_SPECIAL;
6366 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6369 firstkid = firstkid->op_sibling;
6372 /* provide list context for arguments */
6373 if (o->op_type == OP_SORT)
6380 S_simplify_sort(pTHX_ OP *o)
6383 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6388 if (!(o->op_flags & OPf_STACKED))
6390 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
6391 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
6392 kid = kUNOP->op_first; /* get past null */
6393 if (kid->op_type != OP_SCOPE)
6395 kid = kLISTOP->op_last; /* get past scope */
6396 switch(kid->op_type) {
6404 k = kid; /* remember this node*/
6405 if (kBINOP->op_first->op_type != OP_RV2SV)
6407 kid = kBINOP->op_first; /* get past cmp */
6408 if (kUNOP->op_first->op_type != OP_GV)
6410 kid = kUNOP->op_first; /* get past rv2sv */
6412 if (GvSTASH(gv) != PL_curstash)
6414 gvname = GvNAME(gv);
6415 if (*gvname == 'a' && gvname[1] == '\0')
6417 else if (*gvname == 'b' && gvname[1] == '\0')
6422 kid = k; /* back to cmp */
6423 if (kBINOP->op_last->op_type != OP_RV2SV)
6425 kid = kBINOP->op_last; /* down to 2nd arg */
6426 if (kUNOP->op_first->op_type != OP_GV)
6428 kid = kUNOP->op_first; /* get past rv2sv */
6430 if (GvSTASH(gv) != PL_curstash)
6432 gvname = GvNAME(gv);
6434 ? !(*gvname == 'a' && gvname[1] == '\0')
6435 : !(*gvname == 'b' && gvname[1] == '\0'))
6437 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6439 o->op_private |= OPpSORT_DESCEND;
6440 if (k->op_type == OP_NCMP)
6441 o->op_private |= OPpSORT_NUMERIC;
6442 if (k->op_type == OP_I_NCMP)
6443 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6444 kid = cLISTOPo->op_first->op_sibling;
6445 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6446 op_free(kid); /* then delete it */
6450 Perl_ck_split(pTHX_ OP *o)
6455 if (o->op_flags & OPf_STACKED)
6456 return no_fh_allowed(o);
6458 kid = cLISTOPo->op_first;
6459 if (kid->op_type != OP_NULL)
6460 Perl_croak(aTHX_ "panic: ck_split");
6461 kid = kid->op_sibling;
6462 op_free(cLISTOPo->op_first);
6463 cLISTOPo->op_first = kid;
6465 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
6466 cLISTOPo->op_last = kid; /* There was only one element previously */
6469 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6470 OP * const sibl = kid->op_sibling;
6471 kid->op_sibling = 0;
6472 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
6473 if (cLISTOPo->op_first == cLISTOPo->op_last)
6474 cLISTOPo->op_last = kid;
6475 cLISTOPo->op_first = kid;
6476 kid->op_sibling = sibl;
6479 kid->op_type = OP_PUSHRE;
6480 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6482 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
6483 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
6484 "Use of /g modifier is meaningless in split");
6487 if (!kid->op_sibling)
6488 append_elem(OP_SPLIT, o, newDEFSVOP());
6490 kid = kid->op_sibling;
6493 if (!kid->op_sibling)
6494 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6496 kid = kid->op_sibling;
6499 if (kid->op_sibling)
6500 return too_many_arguments(o,OP_DESC(o));
6506 Perl_ck_join(pTHX_ OP *o)
6508 const OP * const kid = cLISTOPo->op_first->op_sibling;
6509 if (kid && kid->op_type == OP_MATCH) {
6510 if (ckWARN(WARN_SYNTAX)) {
6511 const REGEXP *re = PM_GETRE(kPMOP);
6512 const char *pmstr = re ? re->precomp : "STRING";
6513 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6514 "/%s/ should probably be written as \"%s\"",
6522 Perl_ck_subr(pTHX_ OP *o)
6525 OP *prev = ((cUNOPo->op_first->op_sibling)
6526 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6527 OP *o2 = prev->op_sibling;
6534 I32 contextclass = 0;
6538 o->op_private |= OPpENTERSUB_HASTARG;
6539 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6540 if (cvop->op_type == OP_RV2CV) {
6542 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6543 op_null(cvop); /* disable rv2cv */
6544 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6545 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6546 GV *gv = cGVOPx_gv(tmpop);
6549 tmpop->op_private |= OPpEARLY_CV;
6552 namegv = CvANON(cv) ? gv : CvGV(cv);
6553 proto = SvPV_nolen((SV*)cv);
6555 if (CvASSERTION(cv)) {
6556 if (PL_hints & HINT_ASSERTING) {
6557 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
6558 o->op_private |= OPpENTERSUB_DB;
6562 if (!(PL_hints & HINT_ASSERTIONSSEEN) && ckWARN(WARN_ASSERTIONS)) {
6563 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
6564 "Impossible to activate assertion call");
6571 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6572 if (o2->op_type == OP_CONST)
6573 o2->op_private &= ~OPpCONST_STRICT;
6574 else if (o2->op_type == OP_LIST) {
6575 OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
6576 if (sib && sib->op_type == OP_CONST)
6577 sib->op_private &= ~OPpCONST_STRICT;
6580 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6581 if (PERLDB_SUB && PL_curstash != PL_debstash)
6582 o->op_private |= OPpENTERSUB_DB;
6583 while (o2 != cvop) {
6587 return too_many_arguments(o, gv_ename(namegv));
6605 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6607 arg == 1 ? "block or sub {}" : "sub {}",
6608 gv_ename(namegv), o2);
6611 /* '*' allows any scalar type, including bareword */
6614 if (o2->op_type == OP_RV2GV)
6615 goto wrapref; /* autoconvert GLOB -> GLOBref */
6616 else if (o2->op_type == OP_CONST)
6617 o2->op_private &= ~OPpCONST_STRICT;
6618 else if (o2->op_type == OP_ENTERSUB) {
6619 /* accidental subroutine, revert to bareword */
6620 OP *gvop = ((UNOP*)o2)->op_first;
6621 if (gvop && gvop->op_type == OP_NULL) {
6622 gvop = ((UNOP*)gvop)->op_first;
6624 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6627 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6628 (gvop = ((UNOP*)gvop)->op_first) &&
6629 gvop->op_type == OP_GV)
6631 GV * const gv = cGVOPx_gv(gvop);
6632 OP * const sibling = o2->op_sibling;
6633 SV * const n = newSVpvs("");
6635 gv_fullname4(n, gv, "", FALSE);
6636 o2 = newSVOP(OP_CONST, 0, n);
6637 prev->op_sibling = o2;
6638 o2->op_sibling = sibling;
6654 if (contextclass++ == 0) {
6655 e = strchr(proto, ']');
6656 if (!e || e == proto)
6665 /* XXX We shouldn't be modifying proto, so we can const proto */
6670 while (*--p != '[');
6671 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
6672 gv_ename(namegv), o2);
6678 if (o2->op_type == OP_RV2GV)
6681 bad_type(arg, "symbol", gv_ename(namegv), o2);
6684 if (o2->op_type == OP_ENTERSUB)
6687 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6690 if (o2->op_type == OP_RV2SV ||
6691 o2->op_type == OP_PADSV ||
6692 o2->op_type == OP_HELEM ||
6693 o2->op_type == OP_AELEM ||
6694 o2->op_type == OP_THREADSV)
6697 bad_type(arg, "scalar", gv_ename(namegv), o2);
6700 if (o2->op_type == OP_RV2AV ||
6701 o2->op_type == OP_PADAV)
6704 bad_type(arg, "array", gv_ename(namegv), o2);
6707 if (o2->op_type == OP_RV2HV ||
6708 o2->op_type == OP_PADHV)
6711 bad_type(arg, "hash", gv_ename(namegv), o2);
6716 OP* const sib = kid->op_sibling;
6717 kid->op_sibling = 0;
6718 o2 = newUNOP(OP_REFGEN, 0, kid);
6719 o2->op_sibling = sib;
6720 prev->op_sibling = o2;
6722 if (contextclass && e) {
6737 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
6738 gv_ename(namegv), cv);
6743 mod(o2, OP_ENTERSUB);
6745 o2 = o2->op_sibling;
6747 if (proto && !optional &&
6748 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6749 return too_few_arguments(o, gv_ename(namegv));
6752 o=newSVOP(OP_CONST, 0, newSViv(0));
6758 Perl_ck_svconst(pTHX_ OP *o)
6760 SvREADONLY_on(cSVOPo->op_sv);
6765 Perl_ck_chdir(pTHX_ OP *o)
6767 if (o->op_flags & OPf_KIDS) {
6768 SVOP *kid = (SVOP*)cUNOPo->op_first;
6770 if (kid && kid->op_type == OP_CONST &&
6771 (kid->op_private & OPpCONST_BARE))
6773 o->op_flags |= OPf_SPECIAL;
6774 kid->op_private &= ~OPpCONST_STRICT;
6781 Perl_ck_trunc(pTHX_ OP *o)
6783 if (o->op_flags & OPf_KIDS) {
6784 SVOP *kid = (SVOP*)cUNOPo->op_first;
6786 if (kid->op_type == OP_NULL)
6787 kid = (SVOP*)kid->op_sibling;
6788 if (kid && kid->op_type == OP_CONST &&
6789 (kid->op_private & OPpCONST_BARE))
6791 o->op_flags |= OPf_SPECIAL;
6792 kid->op_private &= ~OPpCONST_STRICT;
6799 Perl_ck_unpack(pTHX_ OP *o)
6801 OP *kid = cLISTOPo->op_first;
6802 if (kid->op_sibling) {
6803 kid = kid->op_sibling;
6804 if (!kid->op_sibling)
6805 kid->op_sibling = newDEFSVOP();
6811 Perl_ck_substr(pTHX_ OP *o)
6814 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6815 OP *kid = cLISTOPo->op_first;
6817 if (kid->op_type == OP_NULL)
6818 kid = kid->op_sibling;
6820 kid->op_flags |= OPf_MOD;
6826 /* A peephole optimizer. We visit the ops in the order they're to execute.
6827 * See the comments at the top of this file for more details about when
6828 * peep() is called */
6831 Perl_peep(pTHX_ register OP *o)
6834 register OP* oldop = NULL;
6836 if (!o || o->op_opt)
6840 SAVEVPTR(PL_curcop);
6841 for (; o; o = o->op_next) {
6845 switch (o->op_type) {
6849 PL_curcop = ((COP*)o); /* for warnings */
6854 if (cSVOPo->op_private & OPpCONST_STRICT)
6855 no_bareword_allowed(o);
6857 case OP_METHOD_NAMED:
6858 /* Relocate sv to the pad for thread safety.
6859 * Despite being a "constant", the SV is written to,
6860 * for reference counts, sv_upgrade() etc. */
6862 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6863 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6864 /* If op_sv is already a PADTMP then it is being used by
6865 * some pad, so make a copy. */
6866 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6867 SvREADONLY_on(PAD_SVl(ix));
6868 SvREFCNT_dec(cSVOPo->op_sv);
6870 else if (o->op_type == OP_CONST
6871 && cSVOPo->op_sv == &PL_sv_undef) {
6872 /* PL_sv_undef is hack - it's unsafe to store it in the
6873 AV that is the pad, because av_fetch treats values of
6874 PL_sv_undef as a "free" AV entry and will merrily
6875 replace them with a new SV, causing pad_alloc to think
6876 that this pad slot is free. (When, clearly, it is not)
6878 SvOK_off(PAD_SVl(ix));
6879 SvPADTMP_on(PAD_SVl(ix));
6880 SvREADONLY_on(PAD_SVl(ix));
6883 SvREFCNT_dec(PAD_SVl(ix));
6884 SvPADTMP_on(cSVOPo->op_sv);
6885 PAD_SETSV(ix, cSVOPo->op_sv);
6886 /* XXX I don't know how this isn't readonly already. */
6887 SvREADONLY_on(PAD_SVl(ix));
6889 cSVOPo->op_sv = NULL;
6897 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6898 if (o->op_next->op_private & OPpTARGET_MY) {
6899 if (o->op_flags & OPf_STACKED) /* chained concats */
6900 goto ignore_optimization;
6902 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6903 o->op_targ = o->op_next->op_targ;
6904 o->op_next->op_targ = 0;
6905 o->op_private |= OPpTARGET_MY;
6908 op_null(o->op_next);
6910 ignore_optimization:
6914 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6916 break; /* Scalar stub must produce undef. List stub is noop */
6920 if (o->op_targ == OP_NEXTSTATE
6921 || o->op_targ == OP_DBSTATE
6922 || o->op_targ == OP_SETSTATE)
6924 PL_curcop = ((COP*)o);
6926 /* XXX: We avoid setting op_seq here to prevent later calls
6927 to peep() from mistakenly concluding that optimisation
6928 has already occurred. This doesn't fix the real problem,
6929 though (See 20010220.007). AMS 20010719 */
6930 /* op_seq functionality is now replaced by op_opt */
6931 if (oldop && o->op_next) {
6932 oldop->op_next = o->op_next;
6940 if (oldop && o->op_next) {
6941 oldop->op_next = o->op_next;
6949 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
6950 OP* const pop = (o->op_type == OP_PADAV) ?
6951 o->op_next : o->op_next->op_next;
6953 if (pop && pop->op_type == OP_CONST &&
6954 ((PL_op = pop->op_next)) &&
6955 pop->op_next->op_type == OP_AELEM &&
6956 !(pop->op_next->op_private &
6957 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6958 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6963 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
6964 no_bareword_allowed(pop);
6965 if (o->op_type == OP_GV)
6966 op_null(o->op_next);
6967 op_null(pop->op_next);
6969 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6970 o->op_next = pop->op_next->op_next;
6971 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6972 o->op_private = (U8)i;
6973 if (o->op_type == OP_GV) {
6978 o->op_flags |= OPf_SPECIAL;
6979 o->op_type = OP_AELEMFAST;
6985 if (o->op_next->op_type == OP_RV2SV) {
6986 if (!(o->op_next->op_private & OPpDEREF)) {
6987 op_null(o->op_next);
6988 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6990 o->op_next = o->op_next->op_next;
6991 o->op_type = OP_GVSV;
6992 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6995 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6996 GV * const gv = cGVOPo_gv;
6997 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
6998 /* XXX could check prototype here instead of just carping */
6999 SV * const sv = sv_newmortal();
7000 gv_efullname3(sv, gv, NULL);
7001 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
7002 "%"SVf"() called too early to check prototype",
7006 else if (o->op_next->op_type == OP_READLINE
7007 && o->op_next->op_next->op_type == OP_CONCAT
7008 && (o->op_next->op_next->op_flags & OPf_STACKED))
7010 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
7011 o->op_type = OP_RCATLINE;
7012 o->op_flags |= OPf_STACKED;
7013 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
7014 op_null(o->op_next->op_next);
7015 op_null(o->op_next);
7032 while (cLOGOP->op_other->op_type == OP_NULL)
7033 cLOGOP->op_other = cLOGOP->op_other->op_next;
7034 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
7040 while (cLOOP->op_redoop->op_type == OP_NULL)
7041 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
7042 peep(cLOOP->op_redoop);
7043 while (cLOOP->op_nextop->op_type == OP_NULL)
7044 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
7045 peep(cLOOP->op_nextop);
7046 while (cLOOP->op_lastop->op_type == OP_NULL)
7047 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
7048 peep(cLOOP->op_lastop);
7055 while (cPMOP->op_pmreplstart &&
7056 cPMOP->op_pmreplstart->op_type == OP_NULL)
7057 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
7058 peep(cPMOP->op_pmreplstart);
7063 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
7064 && ckWARN(WARN_SYNTAX))
7066 if (o->op_next->op_sibling &&
7067 o->op_next->op_sibling->op_type != OP_EXIT &&
7068 o->op_next->op_sibling->op_type != OP_WARN &&
7069 o->op_next->op_sibling->op_type != OP_DIE) {
7070 const line_t oldline = CopLINE(PL_curcop);
7072 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
7073 Perl_warner(aTHX_ packWARN(WARN_EXEC),
7074 "Statement unlikely to be reached");
7075 Perl_warner(aTHX_ packWARN(WARN_EXEC),
7076 "\t(Maybe you meant system() when you said exec()?)\n");
7077 CopLINE_set(PL_curcop, oldline);
7087 const char *key = NULL;
7092 if (((BINOP*)o)->op_last->op_type != OP_CONST)
7095 /* Make the CONST have a shared SV */
7096 svp = cSVOPx_svp(((BINOP*)o)->op_last);
7097 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
7098 key = SvPV_const(sv, keylen);
7099 lexname = newSVpvn_share(key,
7100 SvUTF8(sv) ? -(I32)keylen : keylen,
7106 if ((o->op_private & (OPpLVAL_INTRO)))
7109 rop = (UNOP*)((BINOP*)o)->op_first;
7110 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7112 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7113 if (!(SvFLAGS(lexname) & SVpad_TYPED))
7115 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
7116 if (!fields || !GvHV(*fields))
7118 key = SvPV_const(*svp, keylen);
7119 if (!hv_fetch(GvHV(*fields), key,
7120 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
7122 Perl_croak(aTHX_ "No such class field \"%s\" "
7123 "in variable %s of type %s",
7124 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
7137 SVOP *first_key_op, *key_op;
7139 if ((o->op_private & (OPpLVAL_INTRO))
7140 /* I bet there's always a pushmark... */
7141 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
7142 /* hmmm, no optimization if list contains only one key. */
7144 rop = (UNOP*)((LISTOP*)o)->op_last;
7145 if (rop->op_type != OP_RV2HV)
7147 if (rop->op_first->op_type == OP_PADSV)
7148 /* @$hash{qw(keys here)} */
7149 rop = (UNOP*)rop->op_first;
7151 /* @{$hash}{qw(keys here)} */
7152 if (rop->op_first->op_type == OP_SCOPE
7153 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
7155 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
7161 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
7162 if (!(SvFLAGS(lexname) & SVpad_TYPED))
7164 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
7165 if (!fields || !GvHV(*fields))
7167 /* Again guessing that the pushmark can be jumped over.... */
7168 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
7169 ->op_first->op_sibling;
7170 for (key_op = first_key_op; key_op;
7171 key_op = (SVOP*)key_op->op_sibling) {
7172 if (key_op->op_type != OP_CONST)
7174 svp = cSVOPx_svp(key_op);
7175 key = SvPV_const(*svp, keylen);
7176 if (!hv_fetch(GvHV(*fields), key,
7177 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
7179 Perl_croak(aTHX_ "No such class field \"%s\" "
7180 "in variable %s of type %s",
7181 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
7188 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
7192 /* check that RHS of sort is a single plain array */
7193 OP *oright = cUNOPo->op_first;
7194 if (!oright || oright->op_type != OP_PUSHMARK)
7197 /* reverse sort ... can be optimised. */
7198 if (!cUNOPo->op_sibling) {
7199 /* Nothing follows us on the list. */
7200 OP * const reverse = o->op_next;
7202 if (reverse->op_type == OP_REVERSE &&
7203 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
7204 OP * const pushmark = cUNOPx(reverse)->op_first;
7205 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
7206 && (cUNOPx(pushmark)->op_sibling == o)) {
7207 /* reverse -> pushmark -> sort */
7208 o->op_private |= OPpSORT_REVERSE;
7210 pushmark->op_next = oright->op_next;
7216 /* make @a = sort @a act in-place */
7220 oright = cUNOPx(oright)->op_sibling;
7223 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
7224 oright = cUNOPx(oright)->op_sibling;
7228 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
7229 || oright->op_next != o
7230 || (oright->op_private & OPpLVAL_INTRO)
7234 /* o2 follows the chain of op_nexts through the LHS of the
7235 * assign (if any) to the aassign op itself */
7237 if (!o2 || o2->op_type != OP_NULL)
7240 if (!o2 || o2->op_type != OP_PUSHMARK)
7243 if (o2 && o2->op_type == OP_GV)
7246 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
7247 || (o2->op_private & OPpLVAL_INTRO)
7252 if (!o2 || o2->op_type != OP_NULL)
7255 if (!o2 || o2->op_type != OP_AASSIGN
7256 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
7259 /* check that the sort is the first arg on RHS of assign */
7261 o2 = cUNOPx(o2)->op_first;
7262 if (!o2 || o2->op_type != OP_NULL)
7264 o2 = cUNOPx(o2)->op_first;
7265 if (!o2 || o2->op_type != OP_PUSHMARK)
7267 if (o2->op_sibling != o)
7270 /* check the array is the same on both sides */
7271 if (oleft->op_type == OP_RV2AV) {
7272 if (oright->op_type != OP_RV2AV
7273 || !cUNOPx(oright)->op_first
7274 || cUNOPx(oright)->op_first->op_type != OP_GV
7275 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
7276 cGVOPx_gv(cUNOPx(oright)->op_first)
7280 else if (oright->op_type != OP_PADAV
7281 || oright->op_targ != oleft->op_targ
7285 /* transfer MODishness etc from LHS arg to RHS arg */
7286 oright->op_flags = oleft->op_flags;
7287 o->op_private |= OPpSORT_INPLACE;
7289 /* excise push->gv->rv2av->null->aassign */
7290 o2 = o->op_next->op_next;
7291 op_null(o2); /* PUSHMARK */
7293 if (o2->op_type == OP_GV) {
7294 op_null(o2); /* GV */
7297 op_null(o2); /* RV2AV or PADAV */
7298 o2 = o2->op_next->op_next;
7299 op_null(o2); /* AASSIGN */
7301 o->op_next = o2->op_next;
7307 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
7309 LISTOP *enter, *exlist;
7312 enter = (LISTOP *) o->op_next;
7315 if (enter->op_type == OP_NULL) {
7316 enter = (LISTOP *) enter->op_next;
7320 /* for $a (...) will have OP_GV then OP_RV2GV here.
7321 for (...) just has an OP_GV. */
7322 if (enter->op_type == OP_GV) {
7323 gvop = (OP *) enter;
7324 enter = (LISTOP *) enter->op_next;
7327 if (enter->op_type == OP_RV2GV) {
7328 enter = (LISTOP *) enter->op_next;
7334 if (enter->op_type != OP_ENTERITER)
7337 iter = enter->op_next;
7338 if (!iter || iter->op_type != OP_ITER)
7341 expushmark = enter->op_first;
7342 if (!expushmark || expushmark->op_type != OP_NULL
7343 || expushmark->op_targ != OP_PUSHMARK)
7346 exlist = (LISTOP *) expushmark->op_sibling;
7347 if (!exlist || exlist->op_type != OP_NULL
7348 || exlist->op_targ != OP_LIST)
7351 if (exlist->op_last != o) {
7352 /* Mmm. Was expecting to point back to this op. */
7355 theirmark = exlist->op_first;
7356 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
7359 if (theirmark->op_sibling != o) {
7360 /* There's something between the mark and the reverse, eg
7361 for (1, reverse (...))
7366 ourmark = ((LISTOP *)o)->op_first;
7367 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
7370 ourlast = ((LISTOP *)o)->op_last;
7371 if (!ourlast || ourlast->op_next != o)
7374 rv2av = ourmark->op_sibling;
7375 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
7376 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
7377 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
7378 /* We're just reversing a single array. */
7379 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
7380 enter->op_flags |= OPf_STACKED;
7383 /* We don't have control over who points to theirmark, so sacrifice
7385 theirmark->op_next = ourmark->op_next;
7386 theirmark->op_flags = ourmark->op_flags;
7387 ourlast->op_next = gvop ? gvop : (OP *) enter;
7390 enter->op_private |= OPpITER_REVERSED;
7391 iter->op_private |= OPpITER_REVERSED;
7398 UNOP *refgen, *rv2cv;
7401 /* I do not understand this, but if o->op_opt isn't set to 1,
7402 various tests in ext/B/t/bytecode.t fail with no readily
7408 if ((o->op_flags && OPf_WANT) != OPf_WANT_VOID)
7411 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
7414 rv2gv = ((BINOP *)o)->op_last;
7415 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
7418 refgen = (UNOP *)((BINOP *)o)->op_first;
7420 if (!refgen || refgen->op_type != OP_REFGEN)
7423 exlist = (LISTOP *)refgen->op_first;
7424 if (!exlist || exlist->op_type != OP_NULL
7425 || exlist->op_targ != OP_LIST)
7428 if (exlist->op_first->op_type != OP_PUSHMARK)
7431 rv2cv = (UNOP*)exlist->op_last;
7433 if (rv2cv->op_type != OP_RV2CV)
7436 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
7437 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
7438 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
7440 o->op_private |= OPpASSIGN_CV_TO_GV;
7441 rv2gv->op_private |= OPpDONT_INIT_GV;
7442 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
7458 Perl_custom_op_name(pTHX_ const OP* o)
7461 const IV index = PTR2IV(o->op_ppaddr);
7465 if (!PL_custom_op_names) /* This probably shouldn't happen */
7466 return (char *)PL_op_name[OP_CUSTOM];
7468 keysv = sv_2mortal(newSViv(index));
7470 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
7472 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
7474 return SvPV_nolen(HeVAL(he));
7478 Perl_custom_op_desc(pTHX_ const OP* o)
7481 const IV index = PTR2IV(o->op_ppaddr);
7485 if (!PL_custom_op_descs)
7486 return (char *)PL_op_desc[OP_CUSTOM];
7488 keysv = sv_2mortal(newSViv(index));
7490 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
7492 return (char *)PL_op_desc[OP_CUSTOM];
7494 return SvPV_nolen(HeVAL(he));
7499 /* Efficient sub that returns a constant scalar value. */
7501 const_sv_xsub(pTHX_ CV* cv)
7508 Perl_croak(aTHX_ "usage: %s::%s()",
7509 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7513 ST(0) = (SV*)XSANY.any_ptr;
7519 * c-indentation-style: bsd
7521 * indent-tabs-mode: t
7524 * ex: set ts=8 sts=4 sw=4 noet: