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 ", Nullop" is just to make the compiler
150 * think the expression is of the right type: croak actually does a Siglongjmp.
152 #define CHECKOP(type,o) \
153 ((PL_op_mask && PL_op_mask[type]) \
154 ? ( op_free((OP*)o), \
155 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
157 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
159 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
162 S_gv_ename(pTHX_ GV *gv)
164 SV* const tmpsv = sv_newmortal();
165 gv_efullname3(tmpsv, gv, Nullch);
166 return SvPV_nolen_const(tmpsv);
170 S_no_fh_allowed(pTHX_ OP *o)
172 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
178 S_too_few_arguments(pTHX_ OP *o, const char *name)
180 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
185 S_too_many_arguments(pTHX_ OP *o, const char *name)
187 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
192 S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid)
194 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
195 (int)n, name, t, OP_DESC(kid)));
199 S_no_bareword_allowed(pTHX_ const OP *o)
201 qerror(Perl_mess(aTHX_
202 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
206 /* "register" allocation */
209 Perl_allocmy(pTHX_ char *name)
213 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 = Nullsv;
356 case OP_METHOD_NAMED:
358 SvREFCNT_dec(cSVOPo->op_sv);
359 cSVOPo->op_sv = Nullsv;
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 = Nullsv;
386 Safefree(cPVOPo->op_pv);
387 cPVOPo->op_pv = Nullch;
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 = Nullop;
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, (REGEXP*)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 char *s = SvPV(cop->cop_io,len);
468 Perl_warn(aTHX_ "io='%.*s'",(int) len,s); /* ??? --jhi */
471 SvREFCNT_dec(cop->cop_io);
477 Perl_op_null(pTHX_ OP *o)
480 if (o->op_type == OP_NULL)
483 o->op_targ = o->op_type;
484 o->op_type = OP_NULL;
485 o->op_ppaddr = PL_ppaddr[OP_NULL];
489 Perl_op_refcnt_lock(pTHX)
496 Perl_op_refcnt_unlock(pTHX)
502 /* Contextualizers */
504 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
507 Perl_linklist(pTHX_ OP *o)
514 /* establish postfix order */
515 first = cUNOPo->op_first;
518 o->op_next = LINKLIST(first);
521 if (kid->op_sibling) {
522 kid->op_next = LINKLIST(kid->op_sibling);
523 kid = kid->op_sibling;
537 Perl_scalarkids(pTHX_ OP *o)
539 if (o && o->op_flags & OPf_KIDS) {
541 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
548 S_scalarboolean(pTHX_ OP *o)
551 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
552 if (ckWARN(WARN_SYNTAX)) {
553 const line_t oldline = CopLINE(PL_curcop);
555 if (PL_copline != NOLINE)
556 CopLINE_set(PL_curcop, PL_copline);
557 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
558 CopLINE_set(PL_curcop, oldline);
565 Perl_scalar(pTHX_ OP *o)
570 /* assumes no premature commitment */
571 if (!o || PL_error_count || (o->op_flags & OPf_WANT)
572 || o->op_type == OP_RETURN)
577 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
579 switch (o->op_type) {
581 scalar(cBINOPo->op_first);
586 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
590 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
591 if (!kPMOP->op_pmreplroot)
592 deprecate_old("implicit split to @_");
600 if (o->op_flags & OPf_KIDS) {
601 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
607 kid = cLISTOPo->op_first;
609 while ((kid = kid->op_sibling)) {
615 WITH_THR(PL_curcop = &PL_compiling);
620 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
626 WITH_THR(PL_curcop = &PL_compiling);
629 if (ckWARN(WARN_VOID))
630 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
636 Perl_scalarvoid(pTHX_ OP *o)
640 const char* useless = NULL;
644 if (o->op_type == OP_NEXTSTATE
645 || o->op_type == OP_SETSTATE
646 || o->op_type == OP_DBSTATE
647 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
648 || o->op_targ == OP_SETSTATE
649 || o->op_targ == OP_DBSTATE)))
650 PL_curcop = (COP*)o; /* for warning below */
652 /* assumes no premature commitment */
653 want = o->op_flags & OPf_WANT;
654 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
655 || o->op_type == OP_RETURN)
660 if ((o->op_private & OPpTARGET_MY)
661 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
663 return scalar(o); /* As if inside SASSIGN */
666 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
668 switch (o->op_type) {
670 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
674 if (o->op_flags & OPf_STACKED)
678 if (o->op_private == 4)
750 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
751 useless = OP_DESC(o);
755 kid = cUNOPo->op_first;
756 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
757 kid->op_type != OP_TRANS) {
760 useless = "negative pattern binding (!~)";
767 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
768 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
769 useless = "a variable";
774 if (cSVOPo->op_private & OPpCONST_STRICT)
775 no_bareword_allowed(o);
777 if (ckWARN(WARN_VOID)) {
778 useless = "a constant";
779 /* don't warn on optimised away booleans, eg
780 * use constant Foo, 5; Foo || print; */
781 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
783 /* the constants 0 and 1 are permitted as they are
784 conventionally used as dummies in constructs like
785 1 while some_condition_with_side_effects; */
786 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
788 else if (SvPOK(sv)) {
789 /* perl4's way of mixing documentation and code
790 (before the invention of POD) was based on a
791 trick to mix nroff and perl code. The trick was
792 built upon these three nroff macros being used in
793 void context. The pink camel has the details in
794 the script wrapman near page 319. */
795 const char * const maybe_macro = SvPVX_const(sv);
796 if (strnEQ(maybe_macro, "di", 2) ||
797 strnEQ(maybe_macro, "ds", 2) ||
798 strnEQ(maybe_macro, "ig", 2))
803 op_null(o); /* don't execute or even remember it */
807 o->op_type = OP_PREINC; /* pre-increment is faster */
808 o->op_ppaddr = PL_ppaddr[OP_PREINC];
812 o->op_type = OP_PREDEC; /* pre-decrement is faster */
813 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
817 o->op_type = OP_I_PREINC; /* pre-increment is faster */
818 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
822 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
823 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
832 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
837 if (o->op_flags & OPf_STACKED)
844 if (!(o->op_flags & OPf_KIDS))
855 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
862 /* all requires must return a boolean value */
863 o->op_flags &= ~OPf_WANT;
868 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
869 if (!kPMOP->op_pmreplroot)
870 deprecate_old("implicit split to @_");
874 if (useless && ckWARN(WARN_VOID))
875 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
880 Perl_listkids(pTHX_ OP *o)
882 if (o && o->op_flags & OPf_KIDS) {
884 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
891 Perl_list(pTHX_ OP *o)
896 /* assumes no premature commitment */
897 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
898 || o->op_type == OP_RETURN)
903 if ((o->op_private & OPpTARGET_MY)
904 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
906 return o; /* As if inside SASSIGN */
909 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
911 switch (o->op_type) {
914 list(cBINOPo->op_first);
919 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
927 if (!(o->op_flags & OPf_KIDS))
929 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
930 list(cBINOPo->op_first);
931 return gen_constant_list(o);
938 kid = cLISTOPo->op_first;
940 while ((kid = kid->op_sibling)) {
946 WITH_THR(PL_curcop = &PL_compiling);
950 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
956 WITH_THR(PL_curcop = &PL_compiling);
959 /* all requires must return a boolean value */
960 o->op_flags &= ~OPf_WANT;
967 Perl_scalarseq(pTHX_ OP *o)
971 if (o->op_type == OP_LINESEQ ||
972 o->op_type == OP_SCOPE ||
973 o->op_type == OP_LEAVE ||
974 o->op_type == OP_LEAVETRY)
977 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
978 if (kid->op_sibling) {
982 PL_curcop = &PL_compiling;
984 o->op_flags &= ~OPf_PARENS;
985 if (PL_hints & HINT_BLOCK_SCOPE)
986 o->op_flags |= OPf_PARENS;
989 o = newOP(OP_STUB, 0);
994 S_modkids(pTHX_ OP *o, I32 type)
996 if (o && o->op_flags & OPf_KIDS) {
998 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1004 /* Propagate lvalue ("modifiable") context to an op and its children.
1005 * 'type' represents the context type, roughly based on the type of op that
1006 * would do the modifying, although local() is represented by OP_NULL.
1007 * It's responsible for detecting things that can't be modified, flag
1008 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
1009 * might have to vivify a reference in $x), and so on.
1011 * For example, "$a+1 = 2" would cause mod() to be called with o being
1012 * OP_ADD and type being OP_SASSIGN, and would output an error.
1016 Perl_mod(pTHX_ OP *o, I32 type)
1020 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1023 if (!o || PL_error_count)
1026 if ((o->op_private & OPpTARGET_MY)
1027 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1032 switch (o->op_type) {
1038 if (!(o->op_private & (OPpCONST_ARYBASE)))
1041 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1042 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
1046 SAVEI32(PL_compiling.cop_arybase);
1047 PL_compiling.cop_arybase = 0;
1049 else if (type == OP_REFGEN)
1052 Perl_croak(aTHX_ "That use of $[ is unsupported");
1055 if (o->op_flags & OPf_PARENS)
1059 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1060 !(o->op_flags & OPf_STACKED)) {
1061 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1062 /* The default is to set op_private to the number of children,
1063 which for a UNOP such as RV2CV is always 1. And w're using
1064 the bit for a flag in RV2CV, so we need it clear. */
1065 o->op_private &= ~1;
1066 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1067 assert(cUNOPo->op_first->op_type == OP_NULL);
1068 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1071 else if (o->op_private & OPpENTERSUB_NOMOD)
1073 else { /* lvalue subroutine call */
1074 o->op_private |= OPpLVAL_INTRO;
1075 PL_modcount = RETURN_UNLIMITED_NUMBER;
1076 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1077 /* Backward compatibility mode: */
1078 o->op_private |= OPpENTERSUB_INARGS;
1081 else { /* Compile-time error message: */
1082 OP *kid = cUNOPo->op_first;
1086 if (kid->op_type == OP_PUSHMARK)
1088 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1090 "panic: unexpected lvalue entersub "
1091 "args: type/targ %ld:%"UVuf,
1092 (long)kid->op_type, (UV)kid->op_targ);
1093 kid = kLISTOP->op_first;
1095 while (kid->op_sibling)
1096 kid = kid->op_sibling;
1097 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1099 if (kid->op_type == OP_METHOD_NAMED
1100 || kid->op_type == OP_METHOD)
1104 NewOp(1101, newop, 1, UNOP);
1105 newop->op_type = OP_RV2CV;
1106 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1107 newop->op_first = Nullop;
1108 newop->op_next = (OP*)newop;
1109 kid->op_sibling = (OP*)newop;
1110 newop->op_private |= OPpLVAL_INTRO;
1111 newop->op_private &= ~1;
1115 if (kid->op_type != OP_RV2CV)
1117 "panic: unexpected lvalue entersub "
1118 "entry via type/targ %ld:%"UVuf,
1119 (long)kid->op_type, (UV)kid->op_targ);
1120 kid->op_private |= OPpLVAL_INTRO;
1121 break; /* Postpone until runtime */
1125 kid = kUNOP->op_first;
1126 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1127 kid = kUNOP->op_first;
1128 if (kid->op_type == OP_NULL)
1130 "Unexpected constant lvalue entersub "
1131 "entry via type/targ %ld:%"UVuf,
1132 (long)kid->op_type, (UV)kid->op_targ);
1133 if (kid->op_type != OP_GV) {
1134 /* Restore RV2CV to check lvalueness */
1136 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1137 okid->op_next = kid->op_next;
1138 kid->op_next = okid;
1141 okid->op_next = Nullop;
1142 okid->op_type = OP_RV2CV;
1144 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1145 okid->op_private |= OPpLVAL_INTRO;
1146 okid->op_private &= ~1;
1150 cv = GvCV(kGVOP_gv);
1160 /* grep, foreach, subcalls, refgen */
1161 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1163 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1164 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1166 : (o->op_type == OP_ENTERSUB
1167 ? "non-lvalue subroutine call"
1169 type ? PL_op_desc[type] : "local"));
1183 case OP_RIGHT_SHIFT:
1192 if (!(o->op_flags & OPf_STACKED))
1199 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1205 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1206 PL_modcount = RETURN_UNLIMITED_NUMBER;
1207 return o; /* Treat \(@foo) like ordinary list. */
1211 if (scalar_mod_type(o, type))
1213 ref(cUNOPo->op_first, o->op_type);
1217 if (type == OP_LEAVESUBLV)
1218 o->op_private |= OPpMAYBE_LVSUB;
1224 PL_modcount = RETURN_UNLIMITED_NUMBER;
1227 ref(cUNOPo->op_first, o->op_type);
1232 PL_hints |= HINT_BLOCK_SCOPE;
1247 PL_modcount = RETURN_UNLIMITED_NUMBER;
1248 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1249 return o; /* Treat \(@foo) like ordinary list. */
1250 if (scalar_mod_type(o, type))
1252 if (type == OP_LEAVESUBLV)
1253 o->op_private |= OPpMAYBE_LVSUB;
1257 if (!type) /* local() */
1258 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1259 PAD_COMPNAME_PV(o->op_targ));
1267 if (type != OP_SASSIGN)
1271 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1276 if (type == OP_LEAVESUBLV)
1277 o->op_private |= OPpMAYBE_LVSUB;
1279 pad_free(o->op_targ);
1280 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1281 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1282 if (o->op_flags & OPf_KIDS)
1283 mod(cBINOPo->op_first->op_sibling, type);
1288 ref(cBINOPo->op_first, o->op_type);
1289 if (type == OP_ENTERSUB &&
1290 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1291 o->op_private |= OPpLVAL_DEFER;
1292 if (type == OP_LEAVESUBLV)
1293 o->op_private |= OPpMAYBE_LVSUB;
1303 if (o->op_flags & OPf_KIDS)
1304 mod(cLISTOPo->op_last, type);
1309 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1311 else if (!(o->op_flags & OPf_KIDS))
1313 if (o->op_targ != OP_LIST) {
1314 mod(cBINOPo->op_first, type);
1320 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1325 if (type != OP_LEAVESUBLV)
1327 break; /* mod()ing was handled by ck_return() */
1330 /* [20011101.069] File test operators interpret OPf_REF to mean that
1331 their argument is a filehandle; thus \stat(".") should not set
1333 if (type == OP_REFGEN &&
1334 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1337 if (type != OP_LEAVESUBLV)
1338 o->op_flags |= OPf_MOD;
1340 if (type == OP_AASSIGN || type == OP_SASSIGN)
1341 o->op_flags |= OPf_SPECIAL|OPf_REF;
1342 else if (!type) { /* local() */
1345 o->op_private |= OPpLVAL_INTRO;
1346 o->op_flags &= ~OPf_SPECIAL;
1347 PL_hints |= HINT_BLOCK_SCOPE;
1352 if (ckWARN(WARN_SYNTAX)) {
1353 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1354 "Useless localization of %s", OP_DESC(o));
1358 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1359 && type != OP_LEAVESUBLV)
1360 o->op_flags |= OPf_REF;
1365 S_scalar_mod_type(pTHX_ const OP *o, I32 type)
1369 if (o->op_type == OP_RV2GV)
1393 case OP_RIGHT_SHIFT:
1412 S_is_handle_constructor(pTHX_ const OP *o, I32 numargs)
1414 switch (o->op_type) {
1422 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1435 Perl_refkids(pTHX_ OP *o, I32 type)
1437 if (o && o->op_flags & OPf_KIDS) {
1439 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1446 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
1451 if (!o || PL_error_count)
1454 switch (o->op_type) {
1456 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1457 !(o->op_flags & OPf_STACKED)) {
1458 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1459 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1460 assert(cUNOPo->op_first->op_type == OP_NULL);
1461 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1462 o->op_flags |= OPf_SPECIAL;
1463 o->op_private &= ~1;
1468 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1469 doref(kid, type, set_op_ref);
1472 if (type == OP_DEFINED)
1473 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1474 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1477 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1478 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1479 : type == OP_RV2HV ? OPpDEREF_HV
1481 o->op_flags |= OPf_MOD;
1486 o->op_flags |= OPf_MOD; /* XXX ??? */
1492 o->op_flags |= OPf_REF;
1495 if (type == OP_DEFINED)
1496 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1497 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1503 o->op_flags |= OPf_REF;
1508 if (!(o->op_flags & OPf_KIDS))
1510 doref(cBINOPo->op_first, type, set_op_ref);
1514 doref(cBINOPo->op_first, o->op_type, set_op_ref);
1515 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1516 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1517 : type == OP_RV2HV ? OPpDEREF_HV
1519 o->op_flags |= OPf_MOD;
1529 if (!(o->op_flags & OPf_KIDS))
1531 doref(cLISTOPo->op_last, type, set_op_ref);
1541 S_dup_attrlist(pTHX_ OP *o)
1546 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1547 * where the first kid is OP_PUSHMARK and the remaining ones
1548 * are OP_CONST. We need to push the OP_CONST values.
1550 if (o->op_type == OP_CONST)
1551 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1553 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1555 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1556 if (o->op_type == OP_CONST)
1557 rop = append_elem(OP_LIST, rop,
1558 newSVOP(OP_CONST, o->op_flags,
1559 SvREFCNT_inc(cSVOPo->op_sv)));
1566 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1571 /* fake up C<use attributes $pkg,$rv,@attrs> */
1572 ENTER; /* need to protect against side-effects of 'use' */
1574 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1576 #define ATTRSMODULE "attributes"
1577 #define ATTRSMODULE_PM "attributes.pm"
1580 /* Don't force the C<use> if we don't need it. */
1581 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
1582 if (svp && *svp != &PL_sv_undef)
1583 ; /* already in %INC */
1585 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1586 newSVpvs(ATTRSMODULE), NULL);
1589 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1590 newSVpvs(ATTRSMODULE),
1592 prepend_elem(OP_LIST,
1593 newSVOP(OP_CONST, 0, stashsv),
1594 prepend_elem(OP_LIST,
1595 newSVOP(OP_CONST, 0,
1597 dup_attrlist(attrs))));
1603 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1606 OP *pack, *imop, *arg;
1612 assert(target->op_type == OP_PADSV ||
1613 target->op_type == OP_PADHV ||
1614 target->op_type == OP_PADAV);
1616 /* Ensure that attributes.pm is loaded. */
1617 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1619 /* Need package name for method call. */
1620 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
1622 /* Build up the real arg-list. */
1623 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1625 arg = newOP(OP_PADSV, 0);
1626 arg->op_targ = target->op_targ;
1627 arg = prepend_elem(OP_LIST,
1628 newSVOP(OP_CONST, 0, stashsv),
1629 prepend_elem(OP_LIST,
1630 newUNOP(OP_REFGEN, 0,
1631 mod(arg, OP_REFGEN)),
1632 dup_attrlist(attrs)));
1634 /* Fake up a method call to import */
1635 meth = newSVpvs_share("import");
1636 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1637 append_elem(OP_LIST,
1638 prepend_elem(OP_LIST, pack, list(arg)),
1639 newSVOP(OP_METHOD_NAMED, 0, meth)));
1640 imop->op_private |= OPpENTERSUB_NOMOD;
1642 /* Combine the ops. */
1643 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1647 =notfor apidoc apply_attrs_string
1649 Attempts to apply a list of attributes specified by the C<attrstr> and
1650 C<len> arguments to the subroutine identified by the C<cv> argument which
1651 is expected to be associated with the package identified by the C<stashpv>
1652 argument (see L<attributes>). It gets this wrong, though, in that it
1653 does not correctly identify the boundaries of the individual attribute
1654 specifications within C<attrstr>. This is not really intended for the
1655 public API, but has to be listed here for systems such as AIX which
1656 need an explicit export list for symbols. (It's called from XS code
1657 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1658 to respect attribute syntax properly would be welcome.
1664 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
1665 const char *attrstr, STRLEN len)
1670 len = strlen(attrstr);
1674 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1676 const char * const sstr = attrstr;
1677 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1678 attrs = append_elem(OP_LIST, attrs,
1679 newSVOP(OP_CONST, 0,
1680 newSVpvn(sstr, attrstr-sstr)));
1684 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1685 newSVpvs(ATTRSMODULE),
1686 Nullsv, prepend_elem(OP_LIST,
1687 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1688 prepend_elem(OP_LIST,
1689 newSVOP(OP_CONST, 0,
1695 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
1700 if (!o || PL_error_count)
1704 if (type == OP_LIST) {
1706 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1707 my_kid(kid, attrs, imopsp);
1708 } else if (type == OP_UNDEF) {
1710 } else if (type == OP_RV2SV || /* "our" declaration */
1712 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1713 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1714 yyerror(Perl_form(aTHX_ "Can't declare %s in %s",
1715 OP_DESC(o), PL_in_my == KEY_our ? "our" : "my"));
1717 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
1719 PL_in_my_stash = NULL;
1720 apply_attrs(GvSTASH(gv),
1721 (type == OP_RV2SV ? GvSV(gv) :
1722 type == OP_RV2AV ? (SV*)GvAV(gv) :
1723 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1726 o->op_private |= OPpOUR_INTRO;
1729 else if (type != OP_PADSV &&
1732 type != OP_PUSHMARK)
1734 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1736 PL_in_my == KEY_our ? "our" : "my"));
1739 else if (attrs && type != OP_PUSHMARK) {
1743 PL_in_my_stash = NULL;
1745 /* check for C<my Dog $spot> when deciding package */
1746 stash = PAD_COMPNAME_TYPE(o->op_targ);
1748 stash = PL_curstash;
1749 apply_attrs_my(stash, o, attrs, imopsp);
1751 o->op_flags |= OPf_MOD;
1752 o->op_private |= OPpLVAL_INTRO;
1757 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1761 int maybe_scalar = 0;
1763 /* [perl #17376]: this appears to be premature, and results in code such as
1764 C< our(%x); > executing in list mode rather than void mode */
1766 if (o->op_flags & OPf_PARENS)
1776 o = my_kid(o, attrs, &rops);
1778 if (maybe_scalar && o->op_type == OP_PADSV) {
1779 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
1780 o->op_private |= OPpLVAL_INTRO;
1783 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
1786 PL_in_my_stash = NULL;
1791 Perl_my(pTHX_ OP *o)
1793 return my_attrs(o, Nullop);
1797 Perl_sawparens(pTHX_ OP *o)
1800 o->op_flags |= OPf_PARENS;
1805 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
1810 if ( (left->op_type == OP_RV2AV ||
1811 left->op_type == OP_RV2HV ||
1812 left->op_type == OP_PADAV ||
1813 left->op_type == OP_PADHV)
1814 && ckWARN(WARN_MISC))
1816 const char * const desc = PL_op_desc[(right->op_type == OP_SUBST ||
1817 right->op_type == OP_TRANS)
1818 ? right->op_type : OP_MATCH];
1819 const char * const sample = ((left->op_type == OP_RV2AV ||
1820 left->op_type == OP_PADAV)
1821 ? "@array" : "%hash");
1822 Perl_warner(aTHX_ packWARN(WARN_MISC),
1823 "Applying %s to %s will act on scalar(%s)",
1824 desc, sample, sample);
1827 if (right->op_type == OP_CONST &&
1828 cSVOPx(right)->op_private & OPpCONST_BARE &&
1829 cSVOPx(right)->op_private & OPpCONST_STRICT)
1831 no_bareword_allowed(right);
1834 ismatchop = right->op_type == OP_MATCH ||
1835 right->op_type == OP_SUBST ||
1836 right->op_type == OP_TRANS;
1837 if (ismatchop && right->op_private & OPpTARGET_MY) {
1839 right->op_private &= ~OPpTARGET_MY;
1841 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
1842 right->op_flags |= OPf_STACKED;
1843 if (right->op_type != OP_MATCH &&
1844 ! (right->op_type == OP_TRANS &&
1845 right->op_private & OPpTRANS_IDENTICAL))
1846 left = mod(left, right->op_type);
1847 if (right->op_type == OP_TRANS)
1848 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
1850 o = prepend_elem(right->op_type, scalar(left), right);
1852 return newUNOP(OP_NOT, 0, scalar(o));
1856 return bind_match(type, left,
1857 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
1861 Perl_invert(pTHX_ OP *o)
1865 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
1866 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
1870 Perl_scope(pTHX_ OP *o)
1874 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
1875 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
1876 o->op_type = OP_LEAVE;
1877 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
1879 else if (o->op_type == OP_LINESEQ) {
1881 o->op_type = OP_SCOPE;
1882 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
1883 kid = ((LISTOP*)o)->op_first;
1884 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
1887 /* The following deals with things like 'do {1 for 1}' */
1888 kid = kid->op_sibling;
1890 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
1895 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
1901 Perl_block_start(pTHX_ int full)
1904 const int retval = PL_savestack_ix;
1905 pad_block_start(full);
1907 PL_hints &= ~HINT_BLOCK_SCOPE;
1908 SAVESPTR(PL_compiling.cop_warnings);
1909 if (! specialWARN(PL_compiling.cop_warnings)) {
1910 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
1911 SAVEFREESV(PL_compiling.cop_warnings) ;
1913 SAVESPTR(PL_compiling.cop_io);
1914 if (! specialCopIO(PL_compiling.cop_io)) {
1915 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
1916 SAVEFREESV(PL_compiling.cop_io) ;
1922 Perl_block_end(pTHX_ I32 floor, OP *seq)
1925 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
1926 OP* const retval = scalarseq(seq);
1928 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
1930 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
1939 const I32 offset = pad_findmy("$_");
1940 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
1941 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
1944 OP * const o = newOP(OP_PADSV, 0);
1945 o->op_targ = offset;
1951 Perl_newPROG(pTHX_ OP *o)
1957 PL_eval_root = newUNOP(OP_LEAVEEVAL,
1958 ((PL_in_eval & EVAL_KEEPERR)
1959 ? OPf_SPECIAL : 0), o);
1960 PL_eval_start = linklist(PL_eval_root);
1961 PL_eval_root->op_private |= OPpREFCOUNTED;
1962 OpREFCNT_set(PL_eval_root, 1);
1963 PL_eval_root->op_next = 0;
1964 CALL_PEEP(PL_eval_start);
1967 if (o->op_type == OP_STUB) {
1968 PL_comppad_name = 0;
1973 PL_main_root = scope(sawparens(scalarvoid(o)));
1974 PL_curcop = &PL_compiling;
1975 PL_main_start = LINKLIST(PL_main_root);
1976 PL_main_root->op_private |= OPpREFCOUNTED;
1977 OpREFCNT_set(PL_main_root, 1);
1978 PL_main_root->op_next = 0;
1979 CALL_PEEP(PL_main_start);
1982 /* Register with debugger */
1984 CV * const cv = get_cv("DB::postponed", FALSE);
1988 XPUSHs((SV*)CopFILEGV(&PL_compiling));
1990 call_sv((SV*)cv, G_DISCARD);
1997 Perl_localize(pTHX_ OP *o, I32 lex)
2000 if (o->op_flags & OPf_PARENS)
2001 /* [perl #17376]: this appears to be premature, and results in code such as
2002 C< our(%x); > executing in list mode rather than void mode */
2009 if ( PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ','
2010 && ckWARN(WARN_PARENTHESIS))
2012 char *s = PL_bufptr;
2015 /* some heuristics to detect a potential error */
2016 while (*s && (strchr(", \t\n", *s)))
2020 if (*s && strchr("@$%*", *s) && *++s
2021 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2024 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2026 while (*s && (strchr(", \t\n", *s)))
2032 if (sigil && (*s == ';' || *s == '=')) {
2033 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2034 "Parentheses missing around \"%s\" list",
2035 lex ? (PL_in_my == KEY_our ? "our" : "my")
2043 o = mod(o, OP_NULL); /* a bit kludgey */
2045 PL_in_my_stash = NULL;
2050 Perl_jmaybe(pTHX_ OP *o)
2052 if (o->op_type == OP_LIST) {
2053 OP * const o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", GV_ADD, SVt_PV)));
2054 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2060 Perl_fold_constants(pTHX_ register OP *o)
2064 I32 type = o->op_type;
2067 if (PL_opargs[type] & OA_RETSCALAR)
2069 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2070 o->op_targ = pad_alloc(type, SVs_PADTMP);
2072 /* integerize op, unless it happens to be C<-foo>.
2073 * XXX should pp_i_negate() do magic string negation instead? */
2074 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2075 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2076 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2078 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2081 if (!(PL_opargs[type] & OA_FOLDCONST))
2086 /* XXX might want a ck_negate() for this */
2087 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2098 /* XXX what about the numeric ops? */
2099 if (PL_hints & HINT_LOCALE)
2104 goto nope; /* Don't try to run w/ errors */
2106 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2107 if ((curop->op_type != OP_CONST ||
2108 (curop->op_private & OPpCONST_BARE)) &&
2109 curop->op_type != OP_LIST &&
2110 curop->op_type != OP_SCALAR &&
2111 curop->op_type != OP_NULL &&
2112 curop->op_type != OP_PUSHMARK)
2118 curop = LINKLIST(o);
2122 sv = *(PL_stack_sp--);
2123 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2124 pad_swipe(o->op_targ, FALSE);
2125 else if (SvTEMP(sv)) { /* grab mortal temp? */
2126 (void)SvREFCNT_inc(sv);
2130 if (type == OP_RV2GV)
2131 return newGVOP(OP_GV, 0, (GV*)sv);
2132 return newSVOP(OP_CONST, 0, sv);
2139 Perl_gen_constant_list(pTHX_ register OP *o)
2143 const I32 oldtmps_floor = PL_tmps_floor;
2147 return o; /* Don't attempt to run with errors */
2149 PL_op = curop = LINKLIST(o);
2156 PL_tmps_floor = oldtmps_floor;
2158 o->op_type = OP_RV2AV;
2159 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2160 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2161 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2162 o->op_opt = 0; /* needs to be revisited in peep() */
2163 curop = ((UNOP*)o)->op_first;
2164 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2171 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2174 if (!o || o->op_type != OP_LIST)
2175 o = newLISTOP(OP_LIST, 0, o, Nullop);
2177 o->op_flags &= ~OPf_WANT;
2179 if (!(PL_opargs[type] & OA_MARK))
2180 op_null(cLISTOPo->op_first);
2182 o->op_type = (OPCODE)type;
2183 o->op_ppaddr = PL_ppaddr[type];
2184 o->op_flags |= flags;
2186 o = CHECKOP(type, o);
2187 if (o->op_type != (unsigned)type)
2190 return fold_constants(o);
2193 /* List constructors */
2196 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2204 if (first->op_type != (unsigned)type
2205 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2207 return newLISTOP(type, 0, first, last);
2210 if (first->op_flags & OPf_KIDS)
2211 ((LISTOP*)first)->op_last->op_sibling = last;
2213 first->op_flags |= OPf_KIDS;
2214 ((LISTOP*)first)->op_first = last;
2216 ((LISTOP*)first)->op_last = last;
2221 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2229 if (first->op_type != (unsigned)type)
2230 return prepend_elem(type, (OP*)first, (OP*)last);
2232 if (last->op_type != (unsigned)type)
2233 return append_elem(type, (OP*)first, (OP*)last);
2235 first->op_last->op_sibling = last->op_first;
2236 first->op_last = last->op_last;
2237 first->op_flags |= (last->op_flags & OPf_KIDS);
2245 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2253 if (last->op_type == (unsigned)type) {
2254 if (type == OP_LIST) { /* already a PUSHMARK there */
2255 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2256 ((LISTOP*)last)->op_first->op_sibling = first;
2257 if (!(first->op_flags & OPf_PARENS))
2258 last->op_flags &= ~OPf_PARENS;
2261 if (!(last->op_flags & OPf_KIDS)) {
2262 ((LISTOP*)last)->op_last = first;
2263 last->op_flags |= OPf_KIDS;
2265 first->op_sibling = ((LISTOP*)last)->op_first;
2266 ((LISTOP*)last)->op_first = first;
2268 last->op_flags |= OPf_KIDS;
2272 return newLISTOP(type, 0, first, last);
2278 Perl_newNULLLIST(pTHX)
2280 return newOP(OP_STUB, 0);
2284 Perl_force_list(pTHX_ OP *o)
2286 if (!o || o->op_type != OP_LIST)
2287 o = newLISTOP(OP_LIST, 0, o, Nullop);
2293 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2298 NewOp(1101, listop, 1, LISTOP);
2300 listop->op_type = (OPCODE)type;
2301 listop->op_ppaddr = PL_ppaddr[type];
2304 listop->op_flags = (U8)flags;
2308 else if (!first && last)
2311 first->op_sibling = last;
2312 listop->op_first = first;
2313 listop->op_last = last;
2314 if (type == OP_LIST) {
2315 OP* const pushop = newOP(OP_PUSHMARK, 0);
2316 pushop->op_sibling = first;
2317 listop->op_first = pushop;
2318 listop->op_flags |= OPf_KIDS;
2320 listop->op_last = pushop;
2323 return CHECKOP(type, listop);
2327 Perl_newOP(pTHX_ I32 type, I32 flags)
2331 NewOp(1101, o, 1, OP);
2332 o->op_type = (OPCODE)type;
2333 o->op_ppaddr = PL_ppaddr[type];
2334 o->op_flags = (U8)flags;
2337 o->op_private = (U8)(0 | (flags >> 8));
2338 if (PL_opargs[type] & OA_RETSCALAR)
2340 if (PL_opargs[type] & OA_TARGET)
2341 o->op_targ = pad_alloc(type, SVs_PADTMP);
2342 return CHECKOP(type, o);
2346 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2352 first = newOP(OP_STUB, 0);
2353 if (PL_opargs[type] & OA_MARK)
2354 first = force_list(first);
2356 NewOp(1101, unop, 1, UNOP);
2357 unop->op_type = (OPCODE)type;
2358 unop->op_ppaddr = PL_ppaddr[type];
2359 unop->op_first = first;
2360 unop->op_flags = (U8)(flags | OPf_KIDS);
2361 unop->op_private = (U8)(1 | (flags >> 8));
2362 unop = (UNOP*) CHECKOP(type, unop);
2366 return fold_constants((OP *) unop);
2370 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2374 NewOp(1101, binop, 1, BINOP);
2377 first = newOP(OP_NULL, 0);
2379 binop->op_type = (OPCODE)type;
2380 binop->op_ppaddr = PL_ppaddr[type];
2381 binop->op_first = first;
2382 binop->op_flags = (U8)(flags | OPf_KIDS);
2385 binop->op_private = (U8)(1 | (flags >> 8));
2388 binop->op_private = (U8)(2 | (flags >> 8));
2389 first->op_sibling = last;
2392 binop = (BINOP*)CHECKOP(type, binop);
2393 if (binop->op_next || binop->op_type != (OPCODE)type)
2396 binop->op_last = binop->op_first->op_sibling;
2398 return fold_constants((OP *)binop);
2401 static int uvcompare(const void *a, const void *b) __attribute__nonnull__(1) __attribute__nonnull__(2) __attribute__pure__;
2402 static int uvcompare(const void *a, const void *b)
2404 if (*((const UV *)a) < (*(const UV *)b))
2406 if (*((const UV *)a) > (*(const UV *)b))
2408 if (*((const UV *)a+1) < (*(const UV *)b+1))
2410 if (*((const UV *)a+1) > (*(const UV *)b+1))
2416 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2419 SV * const tstr = ((SVOP*)expr)->op_sv;
2420 SV * const rstr = ((SVOP*)repl)->op_sv;
2423 const U8 *t = (U8*)SvPV_const(tstr, tlen);
2424 const U8 *r = (U8*)SvPV_const(rstr, rlen);
2428 register short *tbl;
2430 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
2431 const I32 squash = o->op_private & OPpTRANS_SQUASH;
2432 I32 del = o->op_private & OPpTRANS_DELETE;
2433 PL_hints |= HINT_BLOCK_SCOPE;
2436 o->op_private |= OPpTRANS_FROM_UTF;
2439 o->op_private |= OPpTRANS_TO_UTF;
2441 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2442 SV* const listsv = newSVpvs("# comment\n");
2444 const U8* tend = t + tlen;
2445 const U8* rend = r + rlen;
2459 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2460 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2466 t = tsave = bytes_to_utf8(t, &len);
2469 if (!to_utf && rlen) {
2471 r = rsave = bytes_to_utf8(r, &len);
2475 /* There are several snags with this code on EBCDIC:
2476 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2477 2. scan_const() in toke.c has encoded chars in native encoding which makes
2478 ranges at least in EBCDIC 0..255 range the bottom odd.
2482 U8 tmpbuf[UTF8_MAXBYTES+1];
2485 Newx(cp, 2*tlen, UV);
2487 transv = newSVpvs("");
2489 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2491 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2493 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2497 cp[2*i+1] = cp[2*i];
2501 qsort(cp, i, 2*sizeof(UV), uvcompare);
2502 for (j = 0; j < i; j++) {
2504 diff = val - nextmin;
2506 t = uvuni_to_utf8(tmpbuf,nextmin);
2507 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2509 U8 range_mark = UTF_TO_NATIVE(0xff);
2510 t = uvuni_to_utf8(tmpbuf, val - 1);
2511 sv_catpvn(transv, (char *)&range_mark, 1);
2512 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2519 t = uvuni_to_utf8(tmpbuf,nextmin);
2520 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2522 U8 range_mark = UTF_TO_NATIVE(0xff);
2523 sv_catpvn(transv, (char *)&range_mark, 1);
2525 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2526 UNICODE_ALLOW_SUPER);
2527 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2528 t = (const U8*)SvPVX_const(transv);
2529 tlen = SvCUR(transv);
2533 else if (!rlen && !del) {
2534 r = t; rlen = tlen; rend = tend;
2537 if ((!rlen && !del) || t == r ||
2538 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2540 o->op_private |= OPpTRANS_IDENTICAL;
2544 while (t < tend || tfirst <= tlast) {
2545 /* see if we need more "t" chars */
2546 if (tfirst > tlast) {
2547 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2549 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2551 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2558 /* now see if we need more "r" chars */
2559 if (rfirst > rlast) {
2561 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2563 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2565 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2574 rfirst = rlast = 0xffffffff;
2578 /* now see which range will peter our first, if either. */
2579 tdiff = tlast - tfirst;
2580 rdiff = rlast - rfirst;
2587 if (rfirst == 0xffffffff) {
2588 diff = tdiff; /* oops, pretend rdiff is infinite */
2590 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2591 (long)tfirst, (long)tlast);
2593 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2597 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2598 (long)tfirst, (long)(tfirst + diff),
2601 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2602 (long)tfirst, (long)rfirst);
2604 if (rfirst + diff > max)
2605 max = rfirst + diff;
2607 grows = (tfirst < rfirst &&
2608 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2620 else if (max > 0xff)
2625 Safefree(cPVOPo->op_pv);
2626 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2627 SvREFCNT_dec(listsv);
2629 SvREFCNT_dec(transv);
2631 if (!del && havefinal && rlen)
2632 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2633 newSVuv((UV)final), 0);
2636 o->op_private |= OPpTRANS_GROWS;
2648 tbl = (short*)cPVOPo->op_pv;
2650 Zero(tbl, 256, short);
2651 for (i = 0; i < (I32)tlen; i++)
2653 for (i = 0, j = 0; i < 256; i++) {
2655 if (j >= (I32)rlen) {
2664 if (i < 128 && r[j] >= 128)
2674 o->op_private |= OPpTRANS_IDENTICAL;
2676 else if (j >= (I32)rlen)
2679 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2680 tbl[0x100] = (short)(rlen - j);
2681 for (i=0; i < (I32)rlen - j; i++)
2682 tbl[0x101+i] = r[j+i];
2686 if (!rlen && !del) {
2689 o->op_private |= OPpTRANS_IDENTICAL;
2691 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
2692 o->op_private |= OPpTRANS_IDENTICAL;
2694 for (i = 0; i < 256; i++)
2696 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
2697 if (j >= (I32)rlen) {
2699 if (tbl[t[i]] == -1)
2705 if (tbl[t[i]] == -1) {
2706 if (t[i] < 128 && r[j] >= 128)
2713 o->op_private |= OPpTRANS_GROWS;
2721 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2726 NewOp(1101, pmop, 1, PMOP);
2727 pmop->op_type = (OPCODE)type;
2728 pmop->op_ppaddr = PL_ppaddr[type];
2729 pmop->op_flags = (U8)flags;
2730 pmop->op_private = (U8)(0 | (flags >> 8));
2732 if (PL_hints & HINT_RE_TAINT)
2733 pmop->op_pmpermflags |= PMf_RETAINT;
2734 if (PL_hints & HINT_LOCALE)
2735 pmop->op_pmpermflags |= PMf_LOCALE;
2736 pmop->op_pmflags = pmop->op_pmpermflags;
2739 if (av_len((AV*) PL_regex_pad[0]) > -1) {
2740 SV * const repointer = av_pop((AV*)PL_regex_pad[0]);
2741 pmop->op_pmoffset = SvIV(repointer);
2742 SvREPADTMP_off(repointer);
2743 sv_setiv(repointer,0);
2745 SV * const repointer = newSViv(0);
2746 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
2747 pmop->op_pmoffset = av_len(PL_regex_padav);
2748 PL_regex_pad = AvARRAY(PL_regex_padav);
2752 /* link into pm list */
2753 if (type != OP_TRANS && PL_curstash) {
2754 MAGIC *mg = mg_find((SV*)PL_curstash, PERL_MAGIC_symtab);
2757 mg = sv_magicext((SV*)PL_curstash, 0, PERL_MAGIC_symtab, 0, 0, 0);
2759 pmop->op_pmnext = (PMOP*)mg->mg_obj;
2760 mg->mg_obj = (SV*)pmop;
2761 PmopSTASH_set(pmop,PL_curstash);
2764 return CHECKOP(type, pmop);
2767 /* Given some sort of match op o, and an expression expr containing a
2768 * pattern, either compile expr into a regex and attach it to o (if it's
2769 * constant), or convert expr into a runtime regcomp op sequence (if it's
2772 * isreg indicates that the pattern is part of a regex construct, eg
2773 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
2774 * split "pattern", which aren't. In the former case, expr will be a list
2775 * if the pattern contains more than one term (eg /a$b/) or if it contains
2776 * a replacement, ie s/// or tr///.
2780 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
2785 I32 repl_has_vars = 0;
2789 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
2790 /* last element in list is the replacement; pop it */
2792 repl = cLISTOPx(expr)->op_last;
2793 kid = cLISTOPx(expr)->op_first;
2794 while (kid->op_sibling != repl)
2795 kid = kid->op_sibling;
2796 kid->op_sibling = Nullop;
2797 cLISTOPx(expr)->op_last = kid;
2800 if (isreg && expr->op_type == OP_LIST &&
2801 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
2803 /* convert single element list to element */
2804 OP* const oe = expr;
2805 expr = cLISTOPx(oe)->op_first->op_sibling;
2806 cLISTOPx(oe)->op_first->op_sibling = Nullop;
2807 cLISTOPx(oe)->op_last = Nullop;
2811 if (o->op_type == OP_TRANS) {
2812 return pmtrans(o, expr, repl);
2815 reglist = isreg && expr->op_type == OP_LIST;
2819 PL_hints |= HINT_BLOCK_SCOPE;
2822 if (expr->op_type == OP_CONST) {
2824 SV * const pat = ((SVOP*)expr)->op_sv;
2825 const char *p = SvPV_const(pat, plen);
2826 if ((o->op_flags & OPf_SPECIAL) && (*p == ' ' && p[1] == '\0')) {
2827 U32 was_readonly = SvREADONLY(pat);
2831 sv_force_normal_flags(pat, 0);
2832 assert(!SvREADONLY(pat));
2835 SvREADONLY_off(pat);
2839 sv_setpvn(pat, "\\s+", 3);
2841 SvFLAGS(pat) |= was_readonly;
2843 p = SvPV_const(pat, plen);
2844 pm->op_pmflags |= PMf_SKIPWHITE;
2847 pm->op_pmdynflags |= PMdf_UTF8;
2848 /* FIXME - can we make this function take const char * args? */
2849 PM_SETRE(pm, CALLREGCOMP(aTHX_ (char*)p, (char*)p + plen, pm));
2850 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
2851 pm->op_pmflags |= PMf_WHITE;
2855 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
2856 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2858 : OP_REGCMAYBE),0,expr);
2860 NewOp(1101, rcop, 1, LOGOP);
2861 rcop->op_type = OP_REGCOMP;
2862 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
2863 rcop->op_first = scalar(expr);
2864 rcop->op_flags |= OPf_KIDS
2865 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
2866 | (reglist ? OPf_STACKED : 0);
2867 rcop->op_private = 1;
2870 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
2872 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
2875 /* establish postfix order */
2876 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
2878 rcop->op_next = expr;
2879 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
2882 rcop->op_next = LINKLIST(expr);
2883 expr->op_next = (OP*)rcop;
2886 prepend_elem(o->op_type, scalar((OP*)rcop), o);
2891 if (pm->op_pmflags & PMf_EVAL) {
2893 if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
2894 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
2896 else if (repl->op_type == OP_CONST)
2900 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
2901 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
2902 if (curop->op_type == OP_GV) {
2903 GV * const gv = cGVOPx_gv(curop);
2905 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
2908 else if (curop->op_type == OP_RV2CV)
2910 else if (curop->op_type == OP_RV2SV ||
2911 curop->op_type == OP_RV2AV ||
2912 curop->op_type == OP_RV2HV ||
2913 curop->op_type == OP_RV2GV) {
2914 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
2917 else if (curop->op_type == OP_PADSV ||
2918 curop->op_type == OP_PADAV ||
2919 curop->op_type == OP_PADHV ||
2920 curop->op_type == OP_PADANY) {
2923 else if (curop->op_type == OP_PUSHRE)
2924 ; /* Okay here, dangerous in newASSIGNOP */
2934 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
2935 pm->op_pmflags |= PMf_CONST; /* const for long enough */
2936 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
2937 prepend_elem(o->op_type, scalar(repl), o);
2940 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
2941 pm->op_pmflags |= PMf_MAYBE_CONST;
2942 pm->op_pmpermflags |= PMf_MAYBE_CONST;
2944 NewOp(1101, rcop, 1, LOGOP);
2945 rcop->op_type = OP_SUBSTCONT;
2946 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
2947 rcop->op_first = scalar(repl);
2948 rcop->op_flags |= OPf_KIDS;
2949 rcop->op_private = 1;
2952 /* establish postfix order */
2953 rcop->op_next = LINKLIST(repl);
2954 repl->op_next = (OP*)rcop;
2956 pm->op_pmreplroot = scalar((OP*)rcop);
2957 pm->op_pmreplstart = LINKLIST(rcop);
2966 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
2970 NewOp(1101, svop, 1, SVOP);
2971 svop->op_type = (OPCODE)type;
2972 svop->op_ppaddr = PL_ppaddr[type];
2974 svop->op_next = (OP*)svop;
2975 svop->op_flags = (U8)flags;
2976 if (PL_opargs[type] & OA_RETSCALAR)
2978 if (PL_opargs[type] & OA_TARGET)
2979 svop->op_targ = pad_alloc(type, SVs_PADTMP);
2980 return CHECKOP(type, svop);
2984 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
2988 NewOp(1101, padop, 1, PADOP);
2989 padop->op_type = (OPCODE)type;
2990 padop->op_ppaddr = PL_ppaddr[type];
2991 padop->op_padix = pad_alloc(type, SVs_PADTMP);
2992 SvREFCNT_dec(PAD_SVl(padop->op_padix));
2993 PAD_SETSV(padop->op_padix, sv);
2996 padop->op_next = (OP*)padop;
2997 padop->op_flags = (U8)flags;
2998 if (PL_opargs[type] & OA_RETSCALAR)
3000 if (PL_opargs[type] & OA_TARGET)
3001 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3002 return CHECKOP(type, padop);
3006 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3012 return newPADOP(type, flags, SvREFCNT_inc(gv));
3014 return newSVOP(type, flags, SvREFCNT_inc(gv));
3019 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3023 NewOp(1101, pvop, 1, PVOP);
3024 pvop->op_type = (OPCODE)type;
3025 pvop->op_ppaddr = PL_ppaddr[type];
3027 pvop->op_next = (OP*)pvop;
3028 pvop->op_flags = (U8)flags;
3029 if (PL_opargs[type] & OA_RETSCALAR)
3031 if (PL_opargs[type] & OA_TARGET)
3032 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3033 return CHECKOP(type, pvop);
3037 Perl_package(pTHX_ OP *o)
3043 save_hptr(&PL_curstash);
3044 save_item(PL_curstname);
3046 name = SvPV_const(cSVOPo->op_sv, len);
3047 PL_curstash = gv_stashpvn(name, len, TRUE);
3048 sv_setpvn(PL_curstname, name, len);
3051 PL_hints |= HINT_BLOCK_SCOPE;
3052 PL_copline = NOLINE;
3057 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3064 if (idop->op_type != OP_CONST)
3065 Perl_croak(aTHX_ "Module name must be constant");
3070 SV * const vesv = ((SVOP*)version)->op_sv;
3072 if (!arg && !SvNIOKp(vesv)) {
3079 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3080 Perl_croak(aTHX_ "Version number must be constant number");
3082 /* Make copy of idop so we don't free it twice */
3083 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3085 /* Fake up a method call to VERSION */
3086 meth = newSVpvs_share("VERSION");
3087 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3088 append_elem(OP_LIST,
3089 prepend_elem(OP_LIST, pack, list(version)),
3090 newSVOP(OP_METHOD_NAMED, 0, meth)));
3094 /* Fake up an import/unimport */
3095 if (arg && arg->op_type == OP_STUB)
3096 imop = arg; /* no import on explicit () */
3097 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3098 imop = Nullop; /* use 5.0; */
3100 idop->op_private |= OPpCONST_NOVER;
3105 /* Make copy of idop so we don't free it twice */
3106 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3108 /* Fake up a method call to import/unimport */
3110 ? newSVpvs_share("import") : newSVpvs_share("unimport");
3111 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3112 append_elem(OP_LIST,
3113 prepend_elem(OP_LIST, pack, list(arg)),
3114 newSVOP(OP_METHOD_NAMED, 0, meth)));
3117 /* Fake up the BEGIN {}, which does its thing immediately. */
3119 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
3122 append_elem(OP_LINESEQ,
3123 append_elem(OP_LINESEQ,
3124 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, idop)),
3125 newSTATEOP(0, Nullch, veop)),
3126 newSTATEOP(0, Nullch, imop) ));
3128 /* The "did you use incorrect case?" warning used to be here.
3129 * The problem is that on case-insensitive filesystems one
3130 * might get false positives for "use" (and "require"):
3131 * "use Strict" or "require CARP" will work. This causes
3132 * portability problems for the script: in case-strict
3133 * filesystems the script will stop working.
3135 * The "incorrect case" warning checked whether "use Foo"
3136 * imported "Foo" to your namespace, but that is wrong, too:
3137 * there is no requirement nor promise in the language that
3138 * a Foo.pm should or would contain anything in package "Foo".
3140 * There is very little Configure-wise that can be done, either:
3141 * the case-sensitivity of the build filesystem of Perl does not
3142 * help in guessing the case-sensitivity of the runtime environment.
3145 PL_hints |= HINT_BLOCK_SCOPE;
3146 PL_copline = NOLINE;
3148 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3152 =head1 Embedding Functions
3154 =for apidoc load_module
3156 Loads the module whose name is pointed to by the string part of name.
3157 Note that the actual module name, not its filename, should be given.
3158 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3159 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3160 (or 0 for no flags). ver, if specified, provides version semantics
3161 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3162 arguments can be used to specify arguments to the module's import()
3163 method, similar to C<use Foo::Bar VERSION LIST>.
3168 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3171 va_start(args, ver);
3172 vload_module(flags, name, ver, &args);
3176 #ifdef PERL_IMPLICIT_CONTEXT
3178 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3182 va_start(args, ver);
3183 vload_module(flags, name, ver, &args);
3189 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3194 OP * const modname = newSVOP(OP_CONST, 0, name);
3195 modname->op_private |= OPpCONST_BARE;
3197 veop = newSVOP(OP_CONST, 0, ver);
3201 if (flags & PERL_LOADMOD_NOIMPORT) {
3202 imop = sawparens(newNULLLIST());
3204 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3205 imop = va_arg(*args, OP*);
3210 sv = va_arg(*args, SV*);
3212 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3213 sv = va_arg(*args, SV*);
3217 const line_t ocopline = PL_copline;
3218 COP * const ocurcop = PL_curcop;
3219 const int oexpect = PL_expect;
3221 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3222 veop, modname, imop);
3223 PL_expect = oexpect;
3224 PL_copline = ocopline;
3225 PL_curcop = ocurcop;
3230 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
3236 if (!force_builtin) {
3237 gv = gv_fetchpv("do", 0, SVt_PVCV);
3238 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
3239 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
3240 gv = gvp ? *gvp : Nullgv;
3244 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3245 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3246 append_elem(OP_LIST, term,
3247 scalar(newUNOP(OP_RV2CV, 0,
3252 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3258 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3260 return newBINOP(OP_LSLICE, flags,
3261 list(force_list(subscript)),
3262 list(force_list(listval)) );
3266 S_is_list_assignment(pTHX_ register const OP *o)
3271 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3272 o = cUNOPo->op_first;
3274 if (o->op_type == OP_COND_EXPR) {
3275 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
3276 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3281 yyerror("Assignment to both a list and a scalar");
3285 if (o->op_type == OP_LIST &&
3286 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3287 o->op_private & OPpLVAL_INTRO)
3290 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3291 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3292 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3295 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3298 if (o->op_type == OP_RV2SV)
3305 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3311 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3312 return newLOGOP(optype, 0,
3313 mod(scalar(left), optype),
3314 newUNOP(OP_SASSIGN, 0, scalar(right)));
3317 return newBINOP(optype, OPf_STACKED,
3318 mod(scalar(left), optype), scalar(right));
3322 if (is_list_assignment(left)) {
3326 /* Grandfathering $[ assignment here. Bletch.*/
3327 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
3328 PL_eval_start = (left->op_type == OP_CONST) ? right : 0;
3329 left = mod(left, OP_AASSIGN);
3332 else if (left->op_type == OP_CONST) {
3333 /* Result of assignment is always 1 (or we'd be dead already) */
3334 return newSVOP(OP_CONST, 0, newSViv(1));
3336 curop = list(force_list(left));
3337 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3338 o->op_private = (U8)(0 | (flags >> 8));
3340 /* PL_generation sorcery:
3341 * an assignment like ($a,$b) = ($c,$d) is easier than
3342 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3343 * To detect whether there are common vars, the global var
3344 * PL_generation is incremented for each assign op we compile.
3345 * Then, while compiling the assign op, we run through all the
3346 * variables on both sides of the assignment, setting a spare slot
3347 * in each of them to PL_generation. If any of them already have
3348 * that value, we know we've got commonality. We could use a
3349 * single bit marker, but then we'd have to make 2 passes, first
3350 * to clear the flag, then to test and set it. To find somewhere
3351 * to store these values, evil chicanery is done with SvCUR().
3354 if (!(left->op_private & OPpLVAL_INTRO)) {
3357 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3358 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3359 if (curop->op_type == OP_GV) {
3360 GV *gv = cGVOPx_gv(curop);
3361 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3363 SvCUR_set(gv, PL_generation);
3365 else if (curop->op_type == OP_PADSV ||
3366 curop->op_type == OP_PADAV ||
3367 curop->op_type == OP_PADHV ||
3368 curop->op_type == OP_PADANY)
3370 if (PAD_COMPNAME_GEN(curop->op_targ)
3371 == (STRLEN)PL_generation)
3373 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
3376 else if (curop->op_type == OP_RV2CV)
3378 else if (curop->op_type == OP_RV2SV ||
3379 curop->op_type == OP_RV2AV ||
3380 curop->op_type == OP_RV2HV ||
3381 curop->op_type == OP_RV2GV) {
3382 if (lastop->op_type != OP_GV) /* funny deref? */
3385 else if (curop->op_type == OP_PUSHRE) {
3386 if (((PMOP*)curop)->op_pmreplroot) {
3388 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3389 ((PMOP*)curop)->op_pmreplroot));
3391 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3393 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3395 SvCUR_set(gv, PL_generation);
3404 o->op_private |= OPpASSIGN_COMMON;
3406 if (right && right->op_type == OP_SPLIT) {
3408 if ((tmpop = ((LISTOP*)right)->op_first) &&
3409 tmpop->op_type == OP_PUSHRE)
3411 PMOP * const pm = (PMOP*)tmpop;
3412 if (left->op_type == OP_RV2AV &&
3413 !(left->op_private & OPpLVAL_INTRO) &&
3414 !(o->op_private & OPpASSIGN_COMMON) )
3416 tmpop = ((UNOP*)left)->op_first;
3417 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3419 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3420 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3422 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3423 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3425 pm->op_pmflags |= PMf_ONCE;
3426 tmpop = cUNOPo->op_first; /* to list (nulled) */
3427 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3428 tmpop->op_sibling = Nullop; /* don't free split */
3429 right->op_next = tmpop->op_next; /* fix starting loc */
3430 op_free(o); /* blow off assign */
3431 right->op_flags &= ~OPf_WANT;
3432 /* "I don't know and I don't care." */
3437 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3438 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3440 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3442 sv_setiv(sv, PL_modcount+1);
3450 right = newOP(OP_UNDEF, 0);
3451 if (right->op_type == OP_READLINE) {
3452 right->op_flags |= OPf_STACKED;
3453 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3456 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3457 o = newBINOP(OP_SASSIGN, flags,
3458 scalar(right), mod(scalar(left), OP_SASSIGN) );
3462 o = newSVOP(OP_CONST, 0, newSViv(PL_compiling.cop_arybase));
3469 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3472 const U32 seq = intro_my();
3475 NewOp(1101, cop, 1, COP);
3476 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3477 cop->op_type = OP_DBSTATE;
3478 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3481 cop->op_type = OP_NEXTSTATE;
3482 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3484 cop->op_flags = (U8)flags;
3485 cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
3487 cop->op_private |= NATIVE_HINTS;
3489 PL_compiling.op_private = cop->op_private;
3490 cop->op_next = (OP*)cop;
3493 cop->cop_label = label;
3494 PL_hints |= HINT_BLOCK_SCOPE;
3497 cop->cop_arybase = PL_curcop->cop_arybase;
3498 if (specialWARN(PL_curcop->cop_warnings))
3499 cop->cop_warnings = PL_curcop->cop_warnings ;
3501 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3502 if (specialCopIO(PL_curcop->cop_io))
3503 cop->cop_io = PL_curcop->cop_io;
3505 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3508 if (PL_copline == NOLINE)
3509 CopLINE_set(cop, CopLINE(PL_curcop));
3511 CopLINE_set(cop, PL_copline);
3512 PL_copline = NOLINE;
3515 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3517 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3519 CopSTASH_set(cop, PL_curstash);
3521 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3522 SV * const * const svp = av_fetch(CopFILEAVx(PL_curcop), (I32)CopLINE(cop), FALSE);
3523 if (svp && *svp != &PL_sv_undef ) {
3524 (void)SvIOK_on(*svp);
3525 SvIV_set(*svp, PTR2IV(cop));
3529 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3534 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3537 return new_logop(type, flags, &first, &other);
3541 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3546 OP *first = *firstp;
3547 OP * const other = *otherp;
3549 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3550 return newBINOP(type, flags, scalar(first), scalar(other));
3552 scalarboolean(first);
3553 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3554 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3555 if (type == OP_AND || type == OP_OR) {
3561 first = *firstp = cUNOPo->op_first;
3563 first->op_next = o->op_next;
3564 cUNOPo->op_first = Nullop;
3568 if (first->op_type == OP_CONST) {
3569 if (first->op_private & OPpCONST_STRICT)
3570 no_bareword_allowed(first);
3571 else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
3572 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
3573 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
3574 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
3575 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
3578 if (other->op_type == OP_CONST)
3579 other->op_private |= OPpCONST_SHORTCIRCUIT;
3583 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
3584 const OP *o2 = other;
3585 if ( ! (o2->op_type == OP_LIST
3586 && (( o2 = cUNOPx(o2)->op_first))
3587 && o2->op_type == OP_PUSHMARK
3588 && (( o2 = o2->op_sibling)) )
3591 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
3592 || o2->op_type == OP_PADHV)
3593 && o2->op_private & OPpLVAL_INTRO
3594 && ckWARN(WARN_DEPRECATED))
3596 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
3597 "Deprecated use of my() in false conditional");
3602 if (first->op_type == OP_CONST)
3603 first->op_private |= OPpCONST_SHORTCIRCUIT;
3607 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
3608 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
3610 const OP * const k1 = ((UNOP*)first)->op_first;
3611 const OP * const k2 = k1->op_sibling;
3613 switch (first->op_type)
3616 if (k2 && k2->op_type == OP_READLINE
3617 && (k2->op_flags & OPf_STACKED)
3618 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3620 warnop = k2->op_type;
3625 if (k1->op_type == OP_READDIR
3626 || k1->op_type == OP_GLOB
3627 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3628 || k1->op_type == OP_EACH)
3630 warnop = ((k1->op_type == OP_NULL)
3631 ? (OPCODE)k1->op_targ : k1->op_type);
3636 const line_t oldline = CopLINE(PL_curcop);
3637 CopLINE_set(PL_curcop, PL_copline);
3638 Perl_warner(aTHX_ packWARN(WARN_MISC),
3639 "Value of %s%s can be \"0\"; test with defined()",
3641 ((warnop == OP_READLINE || warnop == OP_GLOB)
3642 ? " construct" : "() operator"));
3643 CopLINE_set(PL_curcop, oldline);
3650 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
3651 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3653 NewOp(1101, logop, 1, LOGOP);
3655 logop->op_type = (OPCODE)type;
3656 logop->op_ppaddr = PL_ppaddr[type];
3657 logop->op_first = first;
3658 logop->op_flags = (U8)(flags | OPf_KIDS);
3659 logop->op_other = LINKLIST(other);
3660 logop->op_private = (U8)(1 | (flags >> 8));
3662 /* establish postfix order */
3663 logop->op_next = LINKLIST(first);
3664 first->op_next = (OP*)logop;
3665 first->op_sibling = other;
3667 CHECKOP(type,logop);
3669 o = newUNOP(OP_NULL, 0, (OP*)logop);
3676 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3684 return newLOGOP(OP_AND, 0, first, trueop);
3686 return newLOGOP(OP_OR, 0, first, falseop);
3688 scalarboolean(first);
3689 if (first->op_type == OP_CONST) {
3690 if (first->op_private & OPpCONST_BARE &&
3691 first->op_private & OPpCONST_STRICT) {
3692 no_bareword_allowed(first);
3694 if (SvTRUE(((SVOP*)first)->op_sv)) {
3705 NewOp(1101, logop, 1, LOGOP);
3706 logop->op_type = OP_COND_EXPR;
3707 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3708 logop->op_first = first;
3709 logop->op_flags = (U8)(flags | OPf_KIDS);
3710 logop->op_private = (U8)(1 | (flags >> 8));
3711 logop->op_other = LINKLIST(trueop);
3712 logop->op_next = LINKLIST(falseop);
3714 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
3717 /* establish postfix order */
3718 start = LINKLIST(first);
3719 first->op_next = (OP*)logop;
3721 first->op_sibling = trueop;
3722 trueop->op_sibling = falseop;
3723 o = newUNOP(OP_NULL, 0, (OP*)logop);
3725 trueop->op_next = falseop->op_next = o;
3732 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3741 NewOp(1101, range, 1, LOGOP);
3743 range->op_type = OP_RANGE;
3744 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3745 range->op_first = left;
3746 range->op_flags = OPf_KIDS;
3747 leftstart = LINKLIST(left);
3748 range->op_other = LINKLIST(right);
3749 range->op_private = (U8)(1 | (flags >> 8));
3751 left->op_sibling = right;
3753 range->op_next = (OP*)range;
3754 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3755 flop = newUNOP(OP_FLOP, 0, flip);
3756 o = newUNOP(OP_NULL, 0, flop);
3758 range->op_next = leftstart;
3760 left->op_next = flip;
3761 right->op_next = flop;
3763 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3764 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3765 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3766 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3768 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3769 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3772 if (!flip->op_private || !flop->op_private)
3773 linklist(o); /* blow off optimizer unless constant */
3779 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3784 const bool once = block && block->op_flags & OPf_SPECIAL &&
3785 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3787 PERL_UNUSED_ARG(debuggable);
3790 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3791 return block; /* do {} while 0 does once */
3792 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3793 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3794 expr = newUNOP(OP_DEFINED, 0,
3795 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3796 } else if (expr->op_flags & OPf_KIDS) {
3797 const OP * const k1 = ((UNOP*)expr)->op_first;
3798 const OP * const k2 = k1 ? k1->op_sibling : NULL;
3799 switch (expr->op_type) {
3801 if (k2 && k2->op_type == OP_READLINE
3802 && (k2->op_flags & OPf_STACKED)
3803 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3804 expr = newUNOP(OP_DEFINED, 0, expr);
3808 if (k1->op_type == OP_READDIR
3809 || k1->op_type == OP_GLOB
3810 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3811 || k1->op_type == OP_EACH)
3812 expr = newUNOP(OP_DEFINED, 0, expr);
3818 /* if block is null, the next append_elem() would put UNSTACK, a scalar
3819 * op, in listop. This is wrong. [perl #27024] */
3821 block = newOP(OP_NULL, 0);
3822 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3823 o = new_logop(OP_AND, 0, &expr, &listop);
3826 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3828 if (once && o != listop)
3829 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3832 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3834 o->op_flags |= flags;
3836 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3841 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
3842 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
3851 PERL_UNUSED_ARG(debuggable);
3854 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3855 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3856 expr = newUNOP(OP_DEFINED, 0,
3857 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3858 } else if (expr->op_flags & OPf_KIDS) {
3859 const OP * const k1 = ((UNOP*)expr)->op_first;
3860 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
3861 switch (expr->op_type) {
3863 if (k2 && k2->op_type == OP_READLINE
3864 && (k2->op_flags & OPf_STACKED)
3865 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3866 expr = newUNOP(OP_DEFINED, 0, expr);
3870 if (k1->op_type == OP_READDIR
3871 || k1->op_type == OP_GLOB
3872 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3873 || k1->op_type == OP_EACH)
3874 expr = newUNOP(OP_DEFINED, 0, expr);
3881 block = newOP(OP_NULL, 0);
3882 else if (cont || has_my) {
3883 block = scope(block);
3887 next = LINKLIST(cont);
3890 OP * const unstack = newOP(OP_UNSTACK, 0);
3893 cont = append_elem(OP_LINESEQ, cont, unstack);
3896 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3897 redo = LINKLIST(listop);
3900 PL_copline = (line_t)whileline;
3902 o = new_logop(OP_AND, 0, &expr, &listop);
3903 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3904 op_free(expr); /* oops, it's a while (0) */
3906 return Nullop; /* listop already freed by new_logop */
3909 ((LISTOP*)listop)->op_last->op_next =
3910 (o == listop ? redo : LINKLIST(o));
3916 NewOp(1101,loop,1,LOOP);
3917 loop->op_type = OP_ENTERLOOP;
3918 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3919 loop->op_private = 0;
3920 loop->op_next = (OP*)loop;
3923 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
3925 loop->op_redoop = redo;
3926 loop->op_lastop = o;
3927 o->op_private |= loopflags;
3930 loop->op_nextop = next;
3932 loop->op_nextop = o;
3934 o->op_flags |= flags;
3935 o->op_private |= (flags >> 8);
3940 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
3945 PADOFFSET padoff = 0;
3950 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
3951 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
3952 sv->op_type = OP_RV2GV;
3953 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
3954 if (cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
3955 iterpflags |= OPpITER_DEF;
3957 else if (sv->op_type == OP_PADSV) { /* private variable */
3958 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
3959 padoff = sv->op_targ;
3964 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
3965 padoff = sv->op_targ;
3967 iterflags |= OPf_SPECIAL;
3972 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
3973 if (padoff && strEQ(PAD_COMPNAME_PV(padoff), "$_"))
3974 iterpflags |= OPpITER_DEF;
3977 const I32 offset = pad_findmy("$_");
3978 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
3979 sv = newGVOP(OP_GV, 0, PL_defgv);
3984 iterpflags |= OPpITER_DEF;
3986 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
3987 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
3988 iterflags |= OPf_STACKED;
3990 else if (expr->op_type == OP_NULL &&
3991 (expr->op_flags & OPf_KIDS) &&
3992 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
3994 /* Basically turn for($x..$y) into the same as for($x,$y), but we
3995 * set the STACKED flag to indicate that these values are to be
3996 * treated as min/max values by 'pp_iterinit'.
3998 UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
3999 LOGOP* const range = (LOGOP*) flip->op_first;
4000 OP* const left = range->op_first;
4001 OP* const right = left->op_sibling;
4004 range->op_flags &= ~OPf_KIDS;
4005 range->op_first = Nullop;
4007 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4008 listop->op_first->op_next = range->op_next;
4009 left->op_next = range->op_other;
4010 right->op_next = (OP*)listop;
4011 listop->op_next = listop->op_first;
4014 expr = (OP*)(listop);
4016 iterflags |= OPf_STACKED;
4019 expr = mod(force_list(expr), OP_GREPSTART);
4022 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4023 append_elem(OP_LIST, expr, scalar(sv))));
4024 assert(!loop->op_next);
4025 /* for my $x () sets OPpLVAL_INTRO;
4026 * for our $x () sets OPpOUR_INTRO */
4027 loop->op_private = (U8)iterpflags;
4028 #ifdef PL_OP_SLAB_ALLOC
4031 NewOp(1234,tmp,1,LOOP);
4032 Copy(loop,tmp,1,LISTOP);
4037 Renew(loop, 1, LOOP);
4039 loop->op_targ = padoff;
4040 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
4041 PL_copline = forline;
4042 return newSTATEOP(0, label, wop);
4046 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4051 if (type != OP_GOTO || label->op_type == OP_CONST) {
4052 /* "last()" means "last" */
4053 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4054 o = newOP(type, OPf_SPECIAL);
4056 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4057 ? SvPVx_nolen_const(((SVOP*)label)->op_sv)
4063 /* Check whether it's going to be a goto &function */
4064 if (label->op_type == OP_ENTERSUB
4065 && !(label->op_flags & OPf_STACKED))
4066 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4067 o = newUNOP(type, OPf_STACKED, label);
4069 PL_hints |= HINT_BLOCK_SCOPE;
4073 /* if the condition is a literal array or hash
4074 (or @{ ... } etc), make a reference to it.
4077 S_ref_array_or_hash(pTHX_ OP *cond)
4080 && (cond->op_type == OP_RV2AV
4081 || cond->op_type == OP_PADAV
4082 || cond->op_type == OP_RV2HV
4083 || cond->op_type == OP_PADHV))
4085 return newUNOP(OP_REFGEN,
4086 0, mod(cond, OP_REFGEN));
4092 /* These construct the optree fragments representing given()
4095 entergiven and enterwhen are LOGOPs; the op_other pointer
4096 points up to the associated leave op. We need this so we
4097 can put it in the context and make break/continue work.
4098 (Also, of course, pp_enterwhen will jump straight to
4099 op_other if the match fails.)
4104 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
4105 I32 enter_opcode, I32 leave_opcode,
4106 PADOFFSET entertarg)
4112 NewOp(1101, enterop, 1, LOGOP);
4113 enterop->op_type = enter_opcode;
4114 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
4115 enterop->op_flags = (U8) OPf_KIDS;
4116 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
4117 enterop->op_private = 0;
4119 o = newUNOP(leave_opcode, 0, (OP *) enterop);
4122 enterop->op_first = scalar(cond);
4123 cond->op_sibling = block;
4125 o->op_next = LINKLIST(cond);
4126 cond->op_next = (OP *) enterop;
4129 /* This is a default {} block */
4130 enterop->op_first = block;
4131 enterop->op_flags |= OPf_SPECIAL;
4133 o->op_next = (OP *) enterop;
4136 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
4137 entergiven and enterwhen both
4140 enterop->op_next = LINKLIST(block);
4141 block->op_next = enterop->op_other = o;
4146 /* Does this look like a boolean operation? For these purposes
4147 a boolean operation is:
4148 - a subroutine call [*]
4149 - a logical connective
4150 - a comparison operator
4151 - a filetest operator, with the exception of -s -M -A -C
4152 - defined(), exists() or eof()
4153 - /$re/ or $foo =~ /$re/
4155 [*] possibly surprising
4159 S_looks_like_bool(pTHX_ OP *o)
4162 switch(o->op_type) {
4164 return looks_like_bool(cLOGOPo->op_first);
4168 looks_like_bool(cLOGOPo->op_first)
4169 && looks_like_bool(cLOGOPo->op_first->op_sibling));
4173 case OP_NOT: case OP_XOR:
4174 /* Note that OP_DOR is not here */
4176 case OP_EQ: case OP_NE: case OP_LT:
4177 case OP_GT: case OP_LE: case OP_GE:
4179 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
4180 case OP_I_GT: case OP_I_LE: case OP_I_GE:
4182 case OP_SEQ: case OP_SNE: case OP_SLT:
4183 case OP_SGT: case OP_SLE: case OP_SGE:
4187 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
4188 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
4189 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
4190 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
4191 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
4192 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
4193 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
4194 case OP_FTTEXT: case OP_FTBINARY:
4196 case OP_DEFINED: case OP_EXISTS:
4197 case OP_MATCH: case OP_EOF:
4202 /* Detect comparisons that have been optimized away */
4203 if (cSVOPo->op_sv == &PL_sv_yes
4204 || cSVOPo->op_sv == &PL_sv_no)
4215 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
4219 return newGIVWHENOP(
4220 ref_array_or_hash(cond),
4222 OP_ENTERGIVEN, OP_LEAVEGIVEN,
4226 /* If cond is null, this is a default {} block */
4228 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
4230 bool cond_llb = (!cond || looks_like_bool(cond));
4236 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
4238 scalar(ref_array_or_hash(cond)));
4241 return newGIVWHENOP(
4243 append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
4244 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
4248 =for apidoc cv_undef
4250 Clear out all the active components of a CV. This can happen either
4251 by an explicit C<undef &foo>, or by the reference count going to zero.
4252 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
4253 children can still follow the full lexical scope chain.
4259 Perl_cv_undef(pTHX_ CV *cv)
4263 if (CvFILE(cv) && !CvXSUB(cv)) {
4264 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4265 Safefree(CvFILE(cv));
4270 if (!CvXSUB(cv) && CvROOT(cv)) {
4272 Perl_croak(aTHX_ "Can't undef active subroutine");
4275 PAD_SAVE_SETNULLPAD();
4277 op_free(CvROOT(cv));
4278 CvROOT(cv) = Nullop;
4279 CvSTART(cv) = Nullop;
4282 SvPOK_off((SV*)cv); /* forget prototype */
4287 /* remove CvOUTSIDE unless this is an undef rather than a free */
4288 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
4289 if (!CvWEAKOUTSIDE(cv))
4290 SvREFCNT_dec(CvOUTSIDE(cv));
4291 CvOUTSIDE(cv) = Nullcv;
4294 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4300 /* delete all flags except WEAKOUTSIDE */
4301 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
4305 Perl_cv_ckproto(pTHX_ const CV *cv, const GV *gv, const char *p)
4307 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX_const(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4308 SV* const msg = sv_newmortal();
4312 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4313 sv_setpv(msg, "Prototype mismatch:");
4315 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4317 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (const SV *)cv);
4319 sv_catpvs(msg, ": none");
4320 sv_catpvs(msg, " vs ");
4322 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4324 sv_catpvs(msg, "none");
4325 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
4329 static void const_sv_xsub(pTHX_ CV* cv);
4333 =head1 Optree Manipulation Functions
4335 =for apidoc cv_const_sv
4337 If C<cv> is a constant sub eligible for inlining. returns the constant
4338 value returned by the sub. Otherwise, returns NULL.
4340 Constant subs can be created with C<newCONSTSUB> or as described in
4341 L<perlsub/"Constant Functions">.
4346 Perl_cv_const_sv(pTHX_ CV *cv)
4350 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
4352 return CvCONST(cv) ? (SV*)CvXSUBANY(cv).any_ptr : NULL;
4355 /* op_const_sv: examine an optree to determine whether it's in-lineable.
4356 * Can be called in 3 ways:
4359 * look for a single OP_CONST with attached value: return the value
4361 * cv && CvCLONE(cv) && !CvCONST(cv)
4363 * examine the clone prototype, and if contains only a single
4364 * OP_CONST referencing a pad const, or a single PADSV referencing
4365 * an outer lexical, return a non-zero value to indicate the CV is
4366 * a candidate for "constizing" at clone time
4370 * We have just cloned an anon prototype that was marked as a const
4371 * candidiate. Try to grab the current value, and in the case of
4372 * PADSV, ignore it if it has multiple references. Return the value.
4376 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
4384 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4385 o = cLISTOPo->op_first->op_sibling;
4387 for (; o; o = o->op_next) {
4388 const OPCODE type = o->op_type;
4390 if (sv && o->op_next == o)
4392 if (o->op_next != o) {
4393 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4395 if (type == OP_DBSTATE)
4398 if (type == OP_LEAVESUB || type == OP_RETURN)
4402 if (type == OP_CONST && cSVOPo->op_sv)
4404 else if (cv && type == OP_CONST) {
4405 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4409 else if (cv && type == OP_PADSV) {
4410 if (CvCONST(cv)) { /* newly cloned anon */
4411 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4412 /* the candidate should have 1 ref from this pad and 1 ref
4413 * from the parent */
4414 if (!sv || SvREFCNT(sv) != 2)
4421 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
4422 sv = &PL_sv_undef; /* an arbitrary non-null value */
4433 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4435 PERL_UNUSED_ARG(floor);
4445 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4449 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4451 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4455 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4462 register CV *cv = NULL;
4464 /* If the subroutine has no body, no attributes, and no builtin attributes
4465 then it's just a sub declaration, and we may be able to get away with
4466 storing with a placeholder scalar in the symbol table, rather than a
4467 full GV and CV. If anything is present then it will take a full CV to
4469 const I32 gv_fetch_flags
4470 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
4471 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
4472 const char * const name = o ? SvPVx_nolen_const(cSVOPo->op_sv) : Nullch;
4475 assert(proto->op_type == OP_CONST);
4476 ps = SvPVx_const(((SVOP*)proto)->op_sv, ps_len);
4481 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4482 SV * const sv = sv_newmortal();
4483 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4484 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
4485 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4486 aname = SvPVX_const(sv);
4491 gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
4492 : gv_fetchpv(aname ? aname
4493 : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4494 gv_fetch_flags, SVt_PVCV);
4503 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4504 maximum a prototype before. */
4505 if (SvTYPE(gv) > SVt_NULL) {
4506 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4507 && ckWARN_d(WARN_PROTOTYPE))
4509 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
4511 cv_ckproto((CV*)gv, NULL, ps);
4514 sv_setpvn((SV*)gv, ps, ps_len);
4516 sv_setiv((SV*)gv, -1);
4517 SvREFCNT_dec(PL_compcv);
4518 cv = PL_compcv = NULL;
4519 PL_sub_generation++;
4523 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4525 #ifdef GV_UNIQUE_CHECK
4526 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4527 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4531 if (!block || !ps || *ps || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
4534 const_sv = op_const_sv(block, Nullcv);
4537 const bool exists = CvROOT(cv) || CvXSUB(cv);
4539 #ifdef GV_UNIQUE_CHECK
4540 if (exists && GvUNIQUE(gv)) {
4541 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4545 /* if the subroutine doesn't exist and wasn't pre-declared
4546 * with a prototype, assume it will be AUTOLOADed,
4547 * skipping the prototype check
4549 if (exists || SvPOK(cv))
4550 cv_ckproto(cv, gv, ps);
4551 /* already defined (or promised)? */
4552 if (exists || GvASSUMECV(gv)) {
4553 if (!block && !attrs) {
4554 if (CvFLAGS(PL_compcv)) {
4555 /* might have had built-in attrs applied */
4556 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4558 /* just a "sub foo;" when &foo is already defined */
4559 SAVEFREESV(PL_compcv);
4563 if (ckWARN(WARN_REDEFINE)
4565 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4567 const line_t oldline = CopLINE(PL_curcop);
4568 if (PL_copline != NOLINE)
4569 CopLINE_set(PL_curcop, PL_copline);
4570 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4571 CvCONST(cv) ? "Constant subroutine %s redefined"
4572 : "Subroutine %s redefined", name);
4573 CopLINE_set(PL_curcop, oldline);
4581 (void)SvREFCNT_inc(const_sv);
4583 assert(!CvROOT(cv) && !CvCONST(cv));
4584 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
4585 CvXSUBANY(cv).any_ptr = const_sv;
4586 CvXSUB(cv) = const_sv_xsub;
4591 cv = newCONSTSUB(NULL, name, const_sv);
4594 SvREFCNT_dec(PL_compcv);
4596 PL_sub_generation++;
4603 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4604 * before we clobber PL_compcv.
4608 /* Might have had built-in attributes applied -- propagate them. */
4609 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4610 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4611 stash = GvSTASH(CvGV(cv));
4612 else if (CvSTASH(cv))
4613 stash = CvSTASH(cv);
4615 stash = PL_curstash;
4618 /* possibly about to re-define existing subr -- ignore old cv */
4619 rcv = (SV*)PL_compcv;
4620 if (name && GvSTASH(gv))
4621 stash = GvSTASH(gv);
4623 stash = PL_curstash;
4625 apply_attrs(stash, rcv, attrs, FALSE);
4627 if (cv) { /* must reuse cv if autoloaded */
4629 /* got here with just attrs -- work done, so bug out */
4630 SAVEFREESV(PL_compcv);
4633 /* transfer PL_compcv to cv */
4635 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4636 if (!CvWEAKOUTSIDE(cv))
4637 SvREFCNT_dec(CvOUTSIDE(cv));
4638 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4639 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
4640 CvOUTSIDE(PL_compcv) = 0;
4641 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4642 CvPADLIST(PL_compcv) = 0;
4643 /* inner references to PL_compcv must be fixed up ... */
4644 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
4645 /* ... before we throw it away */
4646 SvREFCNT_dec(PL_compcv);
4648 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4649 ++PL_sub_generation;
4656 PL_sub_generation++;
4660 CvFILE_set_from_cop(cv, PL_curcop);
4661 CvSTASH(cv) = PL_curstash;
4664 sv_setpvn((SV*)cv, ps, ps_len);
4666 if (PL_error_count) {
4670 const char *s = strrchr(name, ':');
4672 if (strEQ(s, "BEGIN")) {
4673 const char not_safe[] =
4674 "BEGIN not safe after errors--compilation aborted";
4675 if (PL_in_eval & EVAL_KEEPERR)
4676 Perl_croak(aTHX_ not_safe);
4678 /* force display of errors found but not reported */
4679 sv_catpv(ERRSV, not_safe);
4680 Perl_croak(aTHX_ "%"SVf, ERRSV);
4689 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4690 mod(scalarseq(block), OP_LEAVESUBLV));
4693 /* This makes sub {}; work as expected. */
4694 if (block->op_type == OP_STUB) {
4696 block = newSTATEOP(0, Nullch, 0);
4698 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4700 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4701 OpREFCNT_set(CvROOT(cv), 1);
4702 CvSTART(cv) = LINKLIST(CvROOT(cv));
4703 CvROOT(cv)->op_next = 0;
4704 CALL_PEEP(CvSTART(cv));
4706 /* now that optimizer has done its work, adjust pad values */
4708 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4711 assert(!CvCONST(cv));
4712 if (ps && !*ps && op_const_sv(block, cv))
4716 if (name || aname) {
4718 const char * const tname = (name ? name : aname);
4720 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4721 SV * const sv = newSV(0);
4722 SV * const tmpstr = sv_newmortal();
4723 GV * const db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4726 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4728 (long)PL_subline, (long)CopLINE(PL_curcop));
4729 gv_efullname3(tmpstr, gv, Nullch);
4730 hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0);
4731 hv = GvHVn(db_postponed);
4732 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
4733 CV * const pcv = GvCV(db_postponed);
4739 call_sv((SV*)pcv, G_DISCARD);
4744 if ((s = strrchr(tname,':')))
4749 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4752 if (strEQ(s, "BEGIN") && !PL_error_count) {
4753 const I32 oldscope = PL_scopestack_ix;
4755 SAVECOPFILE(&PL_compiling);
4756 SAVECOPLINE(&PL_compiling);
4759 PL_beginav = newAV();
4760 DEBUG_x( dump_sub(gv) );
4761 av_push(PL_beginav, (SV*)cv);
4762 GvCV(gv) = 0; /* cv has been hijacked */
4763 call_list(oldscope, PL_beginav);
4765 PL_curcop = &PL_compiling;
4766 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4769 else if (strEQ(s, "END") && !PL_error_count) {
4772 DEBUG_x( dump_sub(gv) );
4773 av_unshift(PL_endav, 1);
4774 av_store(PL_endav, 0, (SV*)cv);
4775 GvCV(gv) = 0; /* cv has been hijacked */
4777 else if (strEQ(s, "CHECK") && !PL_error_count) {
4779 PL_checkav = newAV();
4780 DEBUG_x( dump_sub(gv) );
4781 if (PL_main_start && ckWARN(WARN_VOID))
4782 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4783 av_unshift(PL_checkav, 1);
4784 av_store(PL_checkav, 0, (SV*)cv);
4785 GvCV(gv) = 0; /* cv has been hijacked */
4787 else if (strEQ(s, "INIT") && !PL_error_count) {
4789 PL_initav = newAV();
4790 DEBUG_x( dump_sub(gv) );
4791 if (PL_main_start && ckWARN(WARN_VOID))
4792 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4793 av_push(PL_initav, (SV*)cv);
4794 GvCV(gv) = 0; /* cv has been hijacked */
4799 PL_copline = NOLINE;
4804 /* XXX unsafe for threads if eval_owner isn't held */
4806 =for apidoc newCONSTSUB
4808 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4809 eligible for inlining at compile-time.
4815 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
4822 SAVECOPLINE(PL_curcop);
4823 CopLINE_set(PL_curcop, PL_copline);
4826 PL_hints &= ~HINT_BLOCK_SCOPE;
4829 SAVESPTR(PL_curstash);
4830 SAVECOPSTASH(PL_curcop);
4831 PL_curstash = stash;
4832 CopSTASH_set(PL_curcop,stash);
4835 cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
4836 CvXSUBANY(cv).any_ptr = sv;
4838 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
4842 CopSTASH_free(PL_curcop);
4850 =for apidoc U||newXS
4852 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4858 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
4861 GV * const gv = gv_fetchpv(name ? name :
4862 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4863 GV_ADDMULTI, SVt_PVCV);
4867 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4869 if ((cv = (name ? GvCV(gv) : Nullcv))) {
4871 /* just a cached method */
4875 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4876 /* already defined (or promised) */
4877 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
4878 if (ckWARN(WARN_REDEFINE)) {
4879 GV * const gvcv = CvGV(cv);
4881 HV * const stash = GvSTASH(gvcv);
4883 const char *name = HvNAME_get(stash);
4884 if ( strEQ(name,"autouse") ) {
4885 const line_t oldline = CopLINE(PL_curcop);
4886 if (PL_copline != NOLINE)
4887 CopLINE_set(PL_curcop, PL_copline);
4888 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4889 CvCONST(cv) ? "Constant subroutine %s redefined"
4890 : "Subroutine %s redefined"
4892 CopLINE_set(PL_curcop, oldline);
4902 if (cv) /* must reuse cv if autoloaded */
4906 sv_upgrade((SV *)cv, SVt_PVCV);
4910 PL_sub_generation++;
4914 (void)gv_fetchfile(filename);
4915 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
4916 an external constant string */
4917 CvXSUB(cv) = subaddr;
4920 const char *s = strrchr(name,':');
4926 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4929 if (strEQ(s, "BEGIN")) {
4931 PL_beginav = newAV();
4932 av_push(PL_beginav, (SV*)cv);
4933 GvCV(gv) = 0; /* cv has been hijacked */
4935 else if (strEQ(s, "END")) {
4938 av_unshift(PL_endav, 1);
4939 av_store(PL_endav, 0, (SV*)cv);
4940 GvCV(gv) = 0; /* cv has been hijacked */
4942 else if (strEQ(s, "CHECK")) {
4944 PL_checkav = newAV();
4945 if (PL_main_start && ckWARN(WARN_VOID))
4946 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4947 av_unshift(PL_checkav, 1);
4948 av_store(PL_checkav, 0, (SV*)cv);
4949 GvCV(gv) = 0; /* cv has been hijacked */
4951 else if (strEQ(s, "INIT")) {
4953 PL_initav = newAV();
4954 if (PL_main_start && ckWARN(WARN_VOID))
4955 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4956 av_push(PL_initav, (SV*)cv);
4957 GvCV(gv) = 0; /* cv has been hijacked */
4968 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4974 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
4975 : gv_fetchpv("STDOUT", GV_ADD, SVt_PVFM);
4977 #ifdef GV_UNIQUE_CHECK
4979 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
4983 if ((cv = GvFORM(gv))) {
4984 if (ckWARN(WARN_REDEFINE)) {
4985 const line_t oldline = CopLINE(PL_curcop);
4986 if (PL_copline != NOLINE)
4987 CopLINE_set(PL_curcop, PL_copline);
4988 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4989 o ? "Format %"SVf" redefined"
4990 : "Format STDOUT redefined" ,cSVOPo->op_sv);
4991 CopLINE_set(PL_curcop, oldline);
4998 CvFILE_set_from_cop(cv, PL_curcop);
5001 pad_tidy(padtidy_FORMAT);
5002 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5003 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5004 OpREFCNT_set(CvROOT(cv), 1);
5005 CvSTART(cv) = LINKLIST(CvROOT(cv));
5006 CvROOT(cv)->op_next = 0;
5007 CALL_PEEP(CvSTART(cv));
5009 PL_copline = NOLINE;
5014 Perl_newANONLIST(pTHX_ OP *o)
5016 return newUNOP(OP_REFGEN, 0,
5017 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5021 Perl_newANONHASH(pTHX_ OP *o)
5023 return newUNOP(OP_REFGEN, 0,
5024 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5028 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5030 return newANONATTRSUB(floor, proto, Nullop, block);
5034 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5036 return newUNOP(OP_REFGEN, 0,
5037 newSVOP(OP_ANONCODE, 0,
5038 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5042 Perl_oopsAV(pTHX_ OP *o)
5045 switch (o->op_type) {
5047 o->op_type = OP_PADAV;
5048 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5049 return ref(o, OP_RV2AV);
5052 o->op_type = OP_RV2AV;
5053 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5058 if (ckWARN_d(WARN_INTERNAL))
5059 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
5066 Perl_oopsHV(pTHX_ OP *o)
5069 switch (o->op_type) {
5072 o->op_type = OP_PADHV;
5073 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5074 return ref(o, OP_RV2HV);
5078 o->op_type = OP_RV2HV;
5079 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5084 if (ckWARN_d(WARN_INTERNAL))
5085 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
5092 Perl_newAVREF(pTHX_ OP *o)
5095 if (o->op_type == OP_PADANY) {
5096 o->op_type = OP_PADAV;
5097 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5100 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5101 && ckWARN(WARN_DEPRECATED)) {
5102 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5103 "Using an array as a reference is deprecated");
5105 return newUNOP(OP_RV2AV, 0, scalar(o));
5109 Perl_newGVREF(pTHX_ I32 type, OP *o)
5111 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5112 return newUNOP(OP_NULL, 0, o);
5113 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5117 Perl_newHVREF(pTHX_ OP *o)
5120 if (o->op_type == OP_PADANY) {
5121 o->op_type = OP_PADHV;
5122 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5125 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5126 && ckWARN(WARN_DEPRECATED)) {
5127 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5128 "Using a hash as a reference is deprecated");
5130 return newUNOP(OP_RV2HV, 0, scalar(o));
5134 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5136 return newUNOP(OP_RV2CV, flags, scalar(o));
5140 Perl_newSVREF(pTHX_ OP *o)
5143 if (o->op_type == OP_PADANY) {
5144 o->op_type = OP_PADSV;
5145 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5148 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5149 o->op_flags |= OPpDONE_SVREF;
5152 return newUNOP(OP_RV2SV, 0, scalar(o));
5155 /* Check routines. See the comments at the top of this file for details
5156 * on when these are called */
5159 Perl_ck_anoncode(pTHX_ OP *o)
5161 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
5162 cSVOPo->op_sv = Nullsv;
5167 Perl_ck_bitop(pTHX_ OP *o)
5170 #define OP_IS_NUMCOMPARE(op) \
5171 ((op) == OP_LT || (op) == OP_I_LT || \
5172 (op) == OP_GT || (op) == OP_I_GT || \
5173 (op) == OP_LE || (op) == OP_I_LE || \
5174 (op) == OP_GE || (op) == OP_I_GE || \
5175 (op) == OP_EQ || (op) == OP_I_EQ || \
5176 (op) == OP_NE || (op) == OP_I_NE || \
5177 (op) == OP_NCMP || (op) == OP_I_NCMP)
5178 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
5179 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
5180 && (o->op_type == OP_BIT_OR
5181 || o->op_type == OP_BIT_AND
5182 || o->op_type == OP_BIT_XOR))
5184 const OP * const left = cBINOPo->op_first;
5185 const OP * const right = left->op_sibling;
5186 if ((OP_IS_NUMCOMPARE(left->op_type) &&
5187 (left->op_flags & OPf_PARENS) == 0) ||
5188 (OP_IS_NUMCOMPARE(right->op_type) &&
5189 (right->op_flags & OPf_PARENS) == 0))
5190 if (ckWARN(WARN_PRECEDENCE))
5191 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
5192 "Possible precedence problem on bitwise %c operator",
5193 o->op_type == OP_BIT_OR ? '|'
5194 : o->op_type == OP_BIT_AND ? '&' : '^'
5201 Perl_ck_concat(pTHX_ OP *o)
5203 const OP * const kid = cUNOPo->op_first;
5204 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
5205 !(kUNOP->op_first->op_flags & OPf_MOD))
5206 o->op_flags |= OPf_STACKED;
5211 Perl_ck_spair(pTHX_ OP *o)
5214 if (o->op_flags & OPf_KIDS) {
5217 const OPCODE type = o->op_type;
5218 o = modkids(ck_fun(o), type);
5219 kid = cUNOPo->op_first;
5220 newop = kUNOP->op_first->op_sibling;
5222 (newop->op_sibling ||
5223 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5224 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5225 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5229 op_free(kUNOP->op_first);
5230 kUNOP->op_first = newop;
5232 o->op_ppaddr = PL_ppaddr[++o->op_type];
5237 Perl_ck_delete(pTHX_ OP *o)
5241 if (o->op_flags & OPf_KIDS) {
5242 OP * const kid = cUNOPo->op_first;
5243 switch (kid->op_type) {
5245 o->op_flags |= OPf_SPECIAL;
5248 o->op_private |= OPpSLICE;
5251 o->op_flags |= OPf_SPECIAL;
5256 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5265 Perl_ck_die(pTHX_ OP *o)
5268 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5274 Perl_ck_eof(pTHX_ OP *o)
5277 const I32 type = o->op_type;
5279 if (o->op_flags & OPf_KIDS) {
5280 if (cLISTOPo->op_first->op_type == OP_STUB) {
5282 o = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
5290 Perl_ck_eval(pTHX_ OP *o)
5293 PL_hints |= HINT_BLOCK_SCOPE;
5294 if (o->op_flags & OPf_KIDS) {
5295 SVOP * const kid = (SVOP*)cUNOPo->op_first;
5298 o->op_flags &= ~OPf_KIDS;
5301 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
5304 cUNOPo->op_first = 0;
5307 NewOp(1101, enter, 1, LOGOP);
5308 enter->op_type = OP_ENTERTRY;
5309 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5310 enter->op_private = 0;
5312 /* establish postfix order */
5313 enter->op_next = (OP*)enter;
5315 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5316 o->op_type = OP_LEAVETRY;
5317 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5318 enter->op_other = o;
5328 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5330 o->op_targ = (PADOFFSET)PL_hints;
5331 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
5332 /* Store a copy of %^H that pp_entereval can pick up */
5333 OP *hhop = newSVOP(OP_CONST, 0, (SV*)newHVhv(GvHV(PL_hintgv)));
5334 cUNOPo->op_first->op_sibling = hhop;
5335 o->op_private |= OPpEVAL_HAS_HH;
5341 Perl_ck_exit(pTHX_ OP *o)
5344 HV * const table = GvHV(PL_hintgv);
5346 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
5347 if (svp && *svp && SvTRUE(*svp))
5348 o->op_private |= OPpEXIT_VMSISH;
5350 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5356 Perl_ck_exec(pTHX_ OP *o)
5358 if (o->op_flags & OPf_STACKED) {
5361 kid = cUNOPo->op_first->op_sibling;
5362 if (kid->op_type == OP_RV2GV)
5371 Perl_ck_exists(pTHX_ OP *o)
5375 if (o->op_flags & OPf_KIDS) {
5376 OP * const kid = cUNOPo->op_first;
5377 if (kid->op_type == OP_ENTERSUB) {
5378 (void) ref(kid, o->op_type);
5379 if (kid->op_type != OP_RV2CV && !PL_error_count)
5380 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5382 o->op_private |= OPpEXISTS_SUB;
5384 else if (kid->op_type == OP_AELEM)
5385 o->op_flags |= OPf_SPECIAL;
5386 else if (kid->op_type != OP_HELEM)
5387 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5395 Perl_ck_rvconst(pTHX_ register OP *o)
5398 SVOP * const kid = (SVOP*)cUNOPo->op_first;
5400 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5401 if (o->op_type == OP_RV2CV)
5402 o->op_private &= ~1;
5404 if (kid->op_type == OP_CONST) {
5407 SV * const kidsv = kid->op_sv;
5409 /* Is it a constant from cv_const_sv()? */
5410 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5411 SV * const rsv = SvRV(kidsv);
5412 const int svtype = SvTYPE(rsv);
5413 const char *badtype = Nullch;
5415 switch (o->op_type) {
5417 if (svtype > SVt_PVMG)
5418 badtype = "a SCALAR";
5421 if (svtype != SVt_PVAV)
5422 badtype = "an ARRAY";
5425 if (svtype != SVt_PVHV)
5429 if (svtype != SVt_PVCV)
5434 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5437 else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
5438 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
5439 /* If this is an access to a stash, disable "strict refs", because
5440 * stashes aren't auto-vivified at compile-time (unless we store
5441 * symbols in them), and we don't want to produce a run-time
5442 * stricture error when auto-vivifying the stash. */
5443 const char *s = SvPV_nolen(kidsv);
5444 const STRLEN l = SvCUR(kidsv);
5445 if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
5446 o->op_private &= ~HINT_STRICT_REFS;
5448 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5449 const char *badthing = Nullch;
5450 switch (o->op_type) {
5452 badthing = "a SCALAR";
5455 badthing = "an ARRAY";
5458 badthing = "a HASH";
5463 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
5467 * This is a little tricky. We only want to add the symbol if we
5468 * didn't add it in the lexer. Otherwise we get duplicate strict
5469 * warnings. But if we didn't add it in the lexer, we must at
5470 * least pretend like we wanted to add it even if it existed before,
5471 * or we get possible typo warnings. OPpCONST_ENTERED says
5472 * whether the lexer already added THIS instance of this symbol.
5474 iscv = (o->op_type == OP_RV2CV) * 2;
5476 gv = gv_fetchsv(kidsv,
5477 iscv | !(kid->op_private & OPpCONST_ENTERED),
5480 : o->op_type == OP_RV2SV
5482 : o->op_type == OP_RV2AV
5484 : o->op_type == OP_RV2HV
5487 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5489 kid->op_type = OP_GV;
5490 SvREFCNT_dec(kid->op_sv);
5492 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5493 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5494 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
5496 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv));
5498 kid->op_sv = SvREFCNT_inc(gv);
5500 kid->op_private = 0;
5501 kid->op_ppaddr = PL_ppaddr[OP_GV];
5508 Perl_ck_ftst(pTHX_ OP *o)
5511 const I32 type = o->op_type;
5513 if (o->op_flags & OPf_REF) {
5516 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5517 SVOP * const kid = (SVOP*)cUNOPo->op_first;
5519 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5520 OP * const newop = newGVOP(type, OPf_REF,
5521 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
5527 if ((PL_hints & HINT_FILETEST_ACCESS) &&
5528 OP_IS_FILETEST_ACCESS(o))
5529 o->op_private |= OPpFT_ACCESS;
5531 if (PL_check[kid->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst)
5532 && kid->op_type != OP_STAT && kid->op_type != OP_LSTAT)
5533 o->op_private |= OPpFT_STACKED;
5537 if (type == OP_FTTTY)
5538 o = newGVOP(type, OPf_REF, PL_stdingv);
5540 o = newUNOP(type, 0, newDEFSVOP());
5546 Perl_ck_fun(pTHX_ OP *o)
5549 const int type = o->op_type;
5550 register I32 oa = PL_opargs[type] >> OASHIFT;
5552 if (o->op_flags & OPf_STACKED) {
5553 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5556 return no_fh_allowed(o);
5559 if (o->op_flags & OPf_KIDS) {
5560 OP **tokid = &cLISTOPo->op_first;
5561 register OP *kid = cLISTOPo->op_first;
5565 if (kid->op_type == OP_PUSHMARK ||
5566 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5568 tokid = &kid->op_sibling;
5569 kid = kid->op_sibling;
5571 if (!kid && PL_opargs[type] & OA_DEFGV)
5572 *tokid = kid = newDEFSVOP();
5576 sibl = kid->op_sibling;
5579 /* list seen where single (scalar) arg expected? */
5580 if (numargs == 1 && !(oa >> 4)
5581 && kid->op_type == OP_LIST && type != OP_SCALAR)
5583 return too_many_arguments(o,PL_op_desc[type]);
5596 if ((type == OP_PUSH || type == OP_UNSHIFT)
5597 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5598 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5599 "Useless use of %s with no values",
5602 if (kid->op_type == OP_CONST &&
5603 (kid->op_private & OPpCONST_BARE))
5605 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
5606 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
5607 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5608 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5609 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
5610 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
5613 kid->op_sibling = sibl;
5616 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5617 bad_type(numargs, "array", PL_op_desc[type], kid);
5621 if (kid->op_type == OP_CONST &&
5622 (kid->op_private & OPpCONST_BARE))
5624 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
5625 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
5626 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5627 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5628 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
5629 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
5632 kid->op_sibling = sibl;
5635 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5636 bad_type(numargs, "hash", PL_op_desc[type], kid);
5641 OP * const newop = newUNOP(OP_NULL, 0, kid);
5642 kid->op_sibling = 0;
5644 newop->op_next = newop;
5646 kid->op_sibling = sibl;
5651 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5652 if (kid->op_type == OP_CONST &&
5653 (kid->op_private & OPpCONST_BARE))
5655 OP * const newop = newGVOP(OP_GV, 0,
5656 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
5657 if (!(o->op_private & 1) && /* if not unop */
5658 kid == cLISTOPo->op_last)
5659 cLISTOPo->op_last = newop;
5663 else if (kid->op_type == OP_READLINE) {
5664 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5665 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5668 I32 flags = OPf_SPECIAL;
5672 /* is this op a FH constructor? */
5673 if (is_handle_constructor(o,numargs)) {
5674 const char *name = Nullch;
5678 /* Set a flag to tell rv2gv to vivify
5679 * need to "prove" flag does not mean something
5680 * else already - NI-S 1999/05/07
5683 if (kid->op_type == OP_PADSV) {
5684 name = PAD_COMPNAME_PV(kid->op_targ);
5685 /* SvCUR of a pad namesv can't be trusted
5686 * (see PL_generation), so calc its length
5692 else if (kid->op_type == OP_RV2SV
5693 && kUNOP->op_first->op_type == OP_GV)
5695 GV * const gv = cGVOPx_gv(kUNOP->op_first);
5697 len = GvNAMELEN(gv);
5699 else if (kid->op_type == OP_AELEM
5700 || kid->op_type == OP_HELEM)
5702 OP *op = ((BINOP*)kid)->op_first;
5705 SV *tmpstr = Nullsv;
5706 const char * const a =
5707 kid->op_type == OP_AELEM ?
5709 if (((op->op_type == OP_RV2AV) ||
5710 (op->op_type == OP_RV2HV)) &&
5711 (op = ((UNOP*)op)->op_first) &&
5712 (op->op_type == OP_GV)) {
5713 /* packagevar $a[] or $h{} */
5714 GV * const gv = cGVOPx_gv(op);
5722 else if (op->op_type == OP_PADAV
5723 || op->op_type == OP_PADHV) {
5724 /* lexicalvar $a[] or $h{} */
5725 const char * const padname =
5726 PAD_COMPNAME_PV(op->op_targ);
5735 name = SvPV_const(tmpstr, len);
5740 name = "__ANONIO__";
5747 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5748 namesv = PAD_SVl(targ);
5749 SvUPGRADE(namesv, SVt_PV);
5751 sv_setpvn(namesv, "$", 1);
5752 sv_catpvn(namesv, name, len);
5755 kid->op_sibling = 0;
5756 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5757 kid->op_targ = targ;
5758 kid->op_private |= priv;
5760 kid->op_sibling = sibl;
5766 mod(scalar(kid), type);
5770 tokid = &kid->op_sibling;
5771 kid = kid->op_sibling;
5773 o->op_private |= numargs;
5775 return too_many_arguments(o,OP_DESC(o));
5778 else if (PL_opargs[type] & OA_DEFGV) {
5780 return newUNOP(type, 0, newDEFSVOP());
5784 while (oa & OA_OPTIONAL)
5786 if (oa && oa != OA_LIST)
5787 return too_few_arguments(o,OP_DESC(o));
5793 Perl_ck_glob(pTHX_ OP *o)
5799 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5800 append_elem(OP_GLOB, o, newDEFSVOP());
5802 if (!((gv = gv_fetchpv("glob", 0, SVt_PVCV))
5803 && GvCVu(gv) && GvIMPORTED_CV(gv)))
5805 gv = gv_fetchpv("CORE::GLOBAL::glob", 0, SVt_PVCV);
5808 #if !defined(PERL_EXTERNAL_GLOB)
5809 /* XXX this can be tightened up and made more failsafe. */
5810 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
5813 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5814 newSVpvs("File::Glob"), Nullsv, Nullsv, Nullsv);
5815 gv = gv_fetchpv("CORE::GLOBAL::glob", 0, SVt_PVCV);
5816 glob_gv = gv_fetchpv("File::Glob::csh_glob", 0, SVt_PVCV);
5817 GvCV(gv) = GvCV(glob_gv);
5818 (void)SvREFCNT_inc((SV*)GvCV(gv));
5819 GvIMPORTED_CV_on(gv);
5822 #endif /* PERL_EXTERNAL_GLOB */
5824 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5825 append_elem(OP_GLOB, o,
5826 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5827 o->op_type = OP_LIST;
5828 o->op_ppaddr = PL_ppaddr[OP_LIST];
5829 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5830 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5831 cLISTOPo->op_first->op_targ = 0;
5832 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5833 append_elem(OP_LIST, o,
5834 scalar(newUNOP(OP_RV2CV, 0,
5835 newGVOP(OP_GV, 0, gv)))));
5836 o = newUNOP(OP_NULL, 0, ck_subr(o));
5837 o->op_targ = OP_GLOB; /* hint at what it used to be */
5840 gv = newGVgen("main");
5842 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5848 Perl_ck_grep(pTHX_ OP *o)
5853 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5856 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5857 NewOp(1101, gwop, 1, LOGOP);
5859 if (o->op_flags & OPf_STACKED) {
5862 kid = cLISTOPo->op_first->op_sibling;
5863 if (!cUNOPx(kid)->op_next)
5864 Perl_croak(aTHX_ "panic: ck_grep");
5865 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
5868 kid->op_next = (OP*)gwop;
5869 o->op_flags &= ~OPf_STACKED;
5871 kid = cLISTOPo->op_first->op_sibling;
5872 if (type == OP_MAPWHILE)
5879 kid = cLISTOPo->op_first->op_sibling;
5880 if (kid->op_type != OP_NULL)
5881 Perl_croak(aTHX_ "panic: ck_grep");
5882 kid = kUNOP->op_first;
5884 gwop->op_type = type;
5885 gwop->op_ppaddr = PL_ppaddr[type];
5886 gwop->op_first = listkids(o);
5887 gwop->op_flags |= OPf_KIDS;
5888 gwop->op_other = LINKLIST(kid);
5889 kid->op_next = (OP*)gwop;
5890 offset = pad_findmy("$_");
5891 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
5892 o->op_private = gwop->op_private = 0;
5893 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5896 o->op_private = gwop->op_private = OPpGREP_LEX;
5897 gwop->op_targ = o->op_targ = offset;
5900 kid = cLISTOPo->op_first->op_sibling;
5901 if (!kid || !kid->op_sibling)
5902 return too_few_arguments(o,OP_DESC(o));
5903 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5904 mod(kid, OP_GREPSTART);
5910 Perl_ck_index(pTHX_ OP *o)
5912 if (o->op_flags & OPf_KIDS) {
5913 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5915 kid = kid->op_sibling; /* get past "big" */
5916 if (kid && kid->op_type == OP_CONST)
5917 fbm_compile(((SVOP*)kid)->op_sv, 0);
5923 Perl_ck_lengthconst(pTHX_ OP *o)
5925 /* XXX length optimization goes here */
5930 Perl_ck_lfun(pTHX_ OP *o)
5932 const OPCODE type = o->op_type;
5933 return modkids(ck_fun(o), type);
5937 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5939 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
5940 switch (cUNOPo->op_first->op_type) {
5942 /* This is needed for
5943 if (defined %stash::)
5944 to work. Do not break Tk.
5946 break; /* Globals via GV can be undef */
5948 case OP_AASSIGN: /* Is this a good idea? */
5949 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5950 "defined(@array) is deprecated");
5951 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5952 "\t(Maybe you should just omit the defined()?)\n");
5955 /* This is needed for
5956 if (defined %stash::)
5957 to work. Do not break Tk.
5959 break; /* Globals via GV can be undef */
5961 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5962 "defined(%%hash) is deprecated");
5963 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5964 "\t(Maybe you should just omit the defined()?)\n");
5975 Perl_ck_rfun(pTHX_ OP *o)
5977 const OPCODE type = o->op_type;
5978 return refkids(ck_fun(o), type);
5982 Perl_ck_listiob(pTHX_ OP *o)
5986 kid = cLISTOPo->op_first;
5989 kid = cLISTOPo->op_first;
5991 if (kid->op_type == OP_PUSHMARK)
5992 kid = kid->op_sibling;
5993 if (kid && o->op_flags & OPf_STACKED)
5994 kid = kid->op_sibling;
5995 else if (kid && !kid->op_sibling) { /* print HANDLE; */
5996 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5997 o->op_flags |= OPf_STACKED; /* make it a filehandle */
5998 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5999 cLISTOPo->op_first->op_sibling = kid;
6000 cLISTOPo->op_last = kid;
6001 kid = kid->op_sibling;
6006 append_elem(o->op_type, o, newDEFSVOP());
6012 Perl_ck_say(pTHX_ OP *o)
6015 o->op_type = OP_PRINT;
6016 cLISTOPo->op_last = cLISTOPo->op_last->op_sibling
6017 = newSVOP(OP_CONST, 0, newSVpvs("\n"));
6022 Perl_ck_smartmatch(pTHX_ OP *o)
6025 if (0 == (o->op_flags & OPf_SPECIAL)) {
6026 OP *first = cBINOPo->op_first;
6027 OP *second = first->op_sibling;
6029 /* Implicitly take a reference to an array or hash */
6030 first->op_sibling = Nullop;
6031 first = cBINOPo->op_first = ref_array_or_hash(first);
6032 second = first->op_sibling = ref_array_or_hash(second);
6034 /* Implicitly take a reference to a regular expression */
6035 if (first->op_type == OP_MATCH) {
6036 first->op_type = OP_QR;
6037 first->op_ppaddr = PL_ppaddr[OP_QR];
6039 if (second->op_type == OP_MATCH) {
6040 second->op_type = OP_QR;
6041 second->op_ppaddr = PL_ppaddr[OP_QR];
6050 Perl_ck_sassign(pTHX_ OP *o)
6052 OP *kid = cLISTOPo->op_first;
6053 /* has a disposable target? */
6054 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6055 && !(kid->op_flags & OPf_STACKED)
6056 /* Cannot steal the second time! */
6057 && !(kid->op_private & OPpTARGET_MY))
6059 OP * const kkid = kid->op_sibling;
6061 /* Can just relocate the target. */
6062 if (kkid && kkid->op_type == OP_PADSV
6063 && !(kkid->op_private & OPpLVAL_INTRO))
6065 kid->op_targ = kkid->op_targ;
6067 /* Now we do not need PADSV and SASSIGN. */
6068 kid->op_sibling = o->op_sibling; /* NULL */
6069 cLISTOPo->op_first = NULL;
6072 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6080 Perl_ck_match(pTHX_ OP *o)
6083 if (o->op_type != OP_QR && PL_compcv) {
6084 const I32 offset = pad_findmy("$_");
6085 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS(offset) & SVpad_OUR)) {
6086 o->op_targ = offset;
6087 o->op_private |= OPpTARGET_MY;
6090 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
6091 o->op_private |= OPpRUNTIME;
6096 Perl_ck_method(pTHX_ OP *o)
6098 OP * const kid = cUNOPo->op_first;
6099 if (kid->op_type == OP_CONST) {
6100 SV* sv = kSVOP->op_sv;
6101 const char * const method = SvPVX_const(sv);
6102 if (!(strchr(method, ':') || strchr(method, '\''))) {
6104 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6105 sv = newSVpvn_share(method, SvCUR(sv), 0);
6108 kSVOP->op_sv = Nullsv;
6110 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6119 Perl_ck_null(pTHX_ OP *o)
6125 Perl_ck_open(pTHX_ OP *o)
6128 HV * const table = GvHV(PL_hintgv);
6130 SV **svp = hv_fetchs(table, "open_IN", FALSE);
6132 const I32 mode = mode_from_discipline(*svp);
6133 if (mode & O_BINARY)
6134 o->op_private |= OPpOPEN_IN_RAW;
6135 else if (mode & O_TEXT)
6136 o->op_private |= OPpOPEN_IN_CRLF;
6139 svp = hv_fetchs(table, "open_OUT", FALSE);
6141 const I32 mode = mode_from_discipline(*svp);
6142 if (mode & O_BINARY)
6143 o->op_private |= OPpOPEN_OUT_RAW;
6144 else if (mode & O_TEXT)
6145 o->op_private |= OPpOPEN_OUT_CRLF;
6148 if (o->op_type == OP_BACKTICK)
6151 /* In case of three-arg dup open remove strictness
6152 * from the last arg if it is a bareword. */
6153 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
6154 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
6158 if ((last->op_type == OP_CONST) && /* The bareword. */
6159 (last->op_private & OPpCONST_BARE) &&
6160 (last->op_private & OPpCONST_STRICT) &&
6161 (oa = first->op_sibling) && /* The fh. */
6162 (oa = oa->op_sibling) && /* The mode. */
6163 (oa->op_type == OP_CONST) &&
6164 SvPOK(((SVOP*)oa)->op_sv) &&
6165 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
6166 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
6167 (last == oa->op_sibling)) /* The bareword. */
6168 last->op_private &= ~OPpCONST_STRICT;
6174 Perl_ck_repeat(pTHX_ OP *o)
6176 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6177 o->op_private |= OPpREPEAT_DOLIST;
6178 cBINOPo->op_first = force_list(cBINOPo->op_first);
6186 Perl_ck_require(pTHX_ OP *o)
6191 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6192 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6194 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6195 SV * const sv = kid->op_sv;
6196 U32 was_readonly = SvREADONLY(sv);
6201 sv_force_normal_flags(sv, 0);
6202 assert(!SvREADONLY(sv));
6209 for (s = SvPVX(sv); *s; s++) {
6210 if (*s == ':' && s[1] == ':') {
6211 const STRLEN len = strlen(s+2)+1;
6213 Move(s+2, s+1, len, char);
6214 SvCUR_set(sv, SvCUR(sv) - 1);
6217 sv_catpvs(sv, ".pm");
6218 SvFLAGS(sv) |= was_readonly;
6222 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
6223 /* handle override, if any */
6224 gv = gv_fetchpv("require", 0, SVt_PVCV);
6225 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
6226 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
6227 gv = gvp ? *gvp : Nullgv;
6231 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6232 OP * const kid = cUNOPo->op_first;
6233 cUNOPo->op_first = 0;
6235 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
6236 append_elem(OP_LIST, kid,
6237 scalar(newUNOP(OP_RV2CV, 0,
6246 Perl_ck_return(pTHX_ OP *o)
6249 if (CvLVALUE(PL_compcv)) {
6251 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6252 mod(kid, OP_LEAVESUBLV);
6258 Perl_ck_select(pTHX_ OP *o)
6262 if (o->op_flags & OPf_KIDS) {
6263 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6264 if (kid && kid->op_sibling) {
6265 o->op_type = OP_SSELECT;
6266 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6268 return fold_constants(o);
6272 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6273 if (kid && kid->op_type == OP_RV2GV)
6274 kid->op_private &= ~HINT_STRICT_REFS;
6279 Perl_ck_shift(pTHX_ OP *o)
6282 const I32 type = o->op_type;
6284 if (!(o->op_flags & OPf_KIDS)) {
6288 argop = newUNOP(OP_RV2AV, 0,
6289 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
6290 return newUNOP(type, 0, scalar(argop));
6292 return scalar(modkids(ck_fun(o), type));
6296 Perl_ck_sort(pTHX_ OP *o)
6301 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0)
6303 HV * const hinthv = GvHV(PL_hintgv);
6305 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
6307 const I32 sorthints = (I32)SvIV(*svp);
6308 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
6309 o->op_private |= OPpSORT_QSORT;
6310 if ((sorthints & HINT_SORT_STABLE) != 0)
6311 o->op_private |= OPpSORT_STABLE;
6316 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6318 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6319 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6321 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6323 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6325 if (kid->op_type == OP_SCOPE) {
6329 else if (kid->op_type == OP_LEAVE) {
6330 if (o->op_type == OP_SORT) {
6331 op_null(kid); /* wipe out leave */
6334 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6335 if (k->op_next == kid)
6337 /* don't descend into loops */
6338 else if (k->op_type == OP_ENTERLOOP
6339 || k->op_type == OP_ENTERITER)
6341 k = cLOOPx(k)->op_lastop;
6346 kid->op_next = 0; /* just disconnect the leave */
6347 k = kLISTOP->op_first;
6352 if (o->op_type == OP_SORT) {
6353 /* provide scalar context for comparison function/block */
6359 o->op_flags |= OPf_SPECIAL;
6361 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6364 firstkid = firstkid->op_sibling;
6367 /* provide list context for arguments */
6368 if (o->op_type == OP_SORT)
6375 S_simplify_sort(pTHX_ OP *o)
6378 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6383 if (!(o->op_flags & OPf_STACKED))
6385 GvMULTI_on(gv_fetchpv("a", GV_ADD, SVt_PV));
6386 GvMULTI_on(gv_fetchpv("b", GV_ADD, SVt_PV));
6387 kid = kUNOP->op_first; /* get past null */
6388 if (kid->op_type != OP_SCOPE)
6390 kid = kLISTOP->op_last; /* get past scope */
6391 switch(kid->op_type) {
6399 k = kid; /* remember this node*/
6400 if (kBINOP->op_first->op_type != OP_RV2SV)
6402 kid = kBINOP->op_first; /* get past cmp */
6403 if (kUNOP->op_first->op_type != OP_GV)
6405 kid = kUNOP->op_first; /* get past rv2sv */
6407 if (GvSTASH(gv) != PL_curstash)
6409 gvname = GvNAME(gv);
6410 if (*gvname == 'a' && gvname[1] == '\0')
6412 else if (*gvname == 'b' && gvname[1] == '\0')
6417 kid = k; /* back to cmp */
6418 if (kBINOP->op_last->op_type != OP_RV2SV)
6420 kid = kBINOP->op_last; /* down to 2nd arg */
6421 if (kUNOP->op_first->op_type != OP_GV)
6423 kid = kUNOP->op_first; /* get past rv2sv */
6425 if (GvSTASH(gv) != PL_curstash)
6427 gvname = GvNAME(gv);
6429 ? !(*gvname == 'a' && gvname[1] == '\0')
6430 : !(*gvname == 'b' && gvname[1] == '\0'))
6432 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6434 o->op_private |= OPpSORT_DESCEND;
6435 if (k->op_type == OP_NCMP)
6436 o->op_private |= OPpSORT_NUMERIC;
6437 if (k->op_type == OP_I_NCMP)
6438 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6439 kid = cLISTOPo->op_first->op_sibling;
6440 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6441 op_free(kid); /* then delete it */
6445 Perl_ck_split(pTHX_ OP *o)
6450 if (o->op_flags & OPf_STACKED)
6451 return no_fh_allowed(o);
6453 kid = cLISTOPo->op_first;
6454 if (kid->op_type != OP_NULL)
6455 Perl_croak(aTHX_ "panic: ck_split");
6456 kid = kid->op_sibling;
6457 op_free(cLISTOPo->op_first);
6458 cLISTOPo->op_first = kid;
6460 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
6461 cLISTOPo->op_last = kid; /* There was only one element previously */
6464 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6465 OP * const sibl = kid->op_sibling;
6466 kid->op_sibling = 0;
6467 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
6468 if (cLISTOPo->op_first == cLISTOPo->op_last)
6469 cLISTOPo->op_last = kid;
6470 cLISTOPo->op_first = kid;
6471 kid->op_sibling = sibl;
6474 kid->op_type = OP_PUSHRE;
6475 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6477 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
6478 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
6479 "Use of /g modifier is meaningless in split");
6482 if (!kid->op_sibling)
6483 append_elem(OP_SPLIT, o, newDEFSVOP());
6485 kid = kid->op_sibling;
6488 if (!kid->op_sibling)
6489 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6491 kid = kid->op_sibling;
6494 if (kid->op_sibling)
6495 return too_many_arguments(o,OP_DESC(o));
6501 Perl_ck_join(pTHX_ OP *o)
6503 const OP * const kid = cLISTOPo->op_first->op_sibling;
6504 if (kid && kid->op_type == OP_MATCH) {
6505 if (ckWARN(WARN_SYNTAX)) {
6506 const REGEXP *re = PM_GETRE(kPMOP);
6507 const char *pmstr = re ? re->precomp : "STRING";
6508 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6509 "/%s/ should probably be written as \"%s\"",
6517 Perl_ck_subr(pTHX_ OP *o)
6520 OP *prev = ((cUNOPo->op_first->op_sibling)
6521 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6522 OP *o2 = prev->op_sibling;
6529 I32 contextclass = 0;
6533 o->op_private |= OPpENTERSUB_HASTARG;
6534 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6535 if (cvop->op_type == OP_RV2CV) {
6537 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6538 op_null(cvop); /* disable rv2cv */
6539 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6540 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6541 GV *gv = cGVOPx_gv(tmpop);
6544 tmpop->op_private |= OPpEARLY_CV;
6547 namegv = CvANON(cv) ? gv : CvGV(cv);
6548 proto = SvPV_nolen((SV*)cv);
6550 if (CvASSERTION(cv)) {
6551 if (PL_hints & HINT_ASSERTING) {
6552 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
6553 o->op_private |= OPpENTERSUB_DB;
6557 if (!(PL_hints & HINT_ASSERTIONSSEEN) && ckWARN(WARN_ASSERTIONS)) {
6558 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
6559 "Impossible to activate assertion call");
6566 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6567 if (o2->op_type == OP_CONST)
6568 o2->op_private &= ~OPpCONST_STRICT;
6569 else if (o2->op_type == OP_LIST) {
6570 OP * const o = ((UNOP*)o2)->op_first->op_sibling;
6571 if (o && o->op_type == OP_CONST)
6572 o->op_private &= ~OPpCONST_STRICT;
6575 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6576 if (PERLDB_SUB && PL_curstash != PL_debstash)
6577 o->op_private |= OPpENTERSUB_DB;
6578 while (o2 != cvop) {
6582 return too_many_arguments(o, gv_ename(namegv));
6600 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6602 arg == 1 ? "block or sub {}" : "sub {}",
6603 gv_ename(namegv), o2);
6606 /* '*' allows any scalar type, including bareword */
6609 if (o2->op_type == OP_RV2GV)
6610 goto wrapref; /* autoconvert GLOB -> GLOBref */
6611 else if (o2->op_type == OP_CONST)
6612 o2->op_private &= ~OPpCONST_STRICT;
6613 else if (o2->op_type == OP_ENTERSUB) {
6614 /* accidental subroutine, revert to bareword */
6615 OP *gvop = ((UNOP*)o2)->op_first;
6616 if (gvop && gvop->op_type == OP_NULL) {
6617 gvop = ((UNOP*)gvop)->op_first;
6619 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6622 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6623 (gvop = ((UNOP*)gvop)->op_first) &&
6624 gvop->op_type == OP_GV)
6626 GV * const gv = cGVOPx_gv(gvop);
6627 OP * const sibling = o2->op_sibling;
6628 SV * const n = newSVpvs("");
6630 gv_fullname4(n, gv, "", FALSE);
6631 o2 = newSVOP(OP_CONST, 0, n);
6632 prev->op_sibling = o2;
6633 o2->op_sibling = sibling;
6649 if (contextclass++ == 0) {
6650 e = strchr(proto, ']');
6651 if (!e || e == proto)
6660 /* XXX We shouldn't be modifying proto, so we can const proto */
6665 while (*--p != '[');
6666 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
6667 gv_ename(namegv), o2);
6673 if (o2->op_type == OP_RV2GV)
6676 bad_type(arg, "symbol", gv_ename(namegv), o2);
6679 if (o2->op_type == OP_ENTERSUB)
6682 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6685 if (o2->op_type == OP_RV2SV ||
6686 o2->op_type == OP_PADSV ||
6687 o2->op_type == OP_HELEM ||
6688 o2->op_type == OP_AELEM ||
6689 o2->op_type == OP_THREADSV)
6692 bad_type(arg, "scalar", gv_ename(namegv), o2);
6695 if (o2->op_type == OP_RV2AV ||
6696 o2->op_type == OP_PADAV)
6699 bad_type(arg, "array", gv_ename(namegv), o2);
6702 if (o2->op_type == OP_RV2HV ||
6703 o2->op_type == OP_PADHV)
6706 bad_type(arg, "hash", gv_ename(namegv), o2);
6711 OP* const sib = kid->op_sibling;
6712 kid->op_sibling = 0;
6713 o2 = newUNOP(OP_REFGEN, 0, kid);
6714 o2->op_sibling = sib;
6715 prev->op_sibling = o2;
6717 if (contextclass && e) {
6732 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
6733 gv_ename(namegv), cv);
6738 mod(o2, OP_ENTERSUB);
6740 o2 = o2->op_sibling;
6742 if (proto && !optional &&
6743 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6744 return too_few_arguments(o, gv_ename(namegv));
6747 o=newSVOP(OP_CONST, 0, newSViv(0));
6753 Perl_ck_svconst(pTHX_ OP *o)
6755 SvREADONLY_on(cSVOPo->op_sv);
6760 Perl_ck_trunc(pTHX_ OP *o)
6762 if (o->op_flags & OPf_KIDS) {
6763 SVOP *kid = (SVOP*)cUNOPo->op_first;
6765 if (kid->op_type == OP_NULL)
6766 kid = (SVOP*)kid->op_sibling;
6767 if (kid && kid->op_type == OP_CONST &&
6768 (kid->op_private & OPpCONST_BARE))
6770 o->op_flags |= OPf_SPECIAL;
6771 kid->op_private &= ~OPpCONST_STRICT;
6778 Perl_ck_unpack(pTHX_ OP *o)
6780 OP *kid = cLISTOPo->op_first;
6781 if (kid->op_sibling) {
6782 kid = kid->op_sibling;
6783 if (!kid->op_sibling)
6784 kid->op_sibling = newDEFSVOP();
6790 Perl_ck_substr(pTHX_ OP *o)
6793 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6794 OP *kid = cLISTOPo->op_first;
6796 if (kid->op_type == OP_NULL)
6797 kid = kid->op_sibling;
6799 kid->op_flags |= OPf_MOD;
6805 /* A peephole optimizer. We visit the ops in the order they're to execute.
6806 * See the comments at the top of this file for more details about when
6807 * peep() is called */
6810 Perl_peep(pTHX_ register OP *o)
6813 register OP* oldop = NULL;
6815 if (!o || o->op_opt)
6819 SAVEVPTR(PL_curcop);
6820 for (; o; o = o->op_next) {
6824 switch (o->op_type) {
6828 PL_curcop = ((COP*)o); /* for warnings */
6833 if (cSVOPo->op_private & OPpCONST_STRICT)
6834 no_bareword_allowed(o);
6836 case OP_METHOD_NAMED:
6837 /* Relocate sv to the pad for thread safety.
6838 * Despite being a "constant", the SV is written to,
6839 * for reference counts, sv_upgrade() etc. */
6841 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6842 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6843 /* If op_sv is already a PADTMP then it is being used by
6844 * some pad, so make a copy. */
6845 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6846 SvREADONLY_on(PAD_SVl(ix));
6847 SvREFCNT_dec(cSVOPo->op_sv);
6849 else if (o->op_type == OP_CONST
6850 && cSVOPo->op_sv == &PL_sv_undef) {
6851 /* PL_sv_undef is hack - it's unsafe to store it in the
6852 AV that is the pad, because av_fetch treats values of
6853 PL_sv_undef as a "free" AV entry and will merrily
6854 replace them with a new SV, causing pad_alloc to think
6855 that this pad slot is free. (When, clearly, it is not)
6857 SvOK_off(PAD_SVl(ix));
6858 SvPADTMP_on(PAD_SVl(ix));
6859 SvREADONLY_on(PAD_SVl(ix));
6862 SvREFCNT_dec(PAD_SVl(ix));
6863 SvPADTMP_on(cSVOPo->op_sv);
6864 PAD_SETSV(ix, cSVOPo->op_sv);
6865 /* XXX I don't know how this isn't readonly already. */
6866 SvREADONLY_on(PAD_SVl(ix));
6868 cSVOPo->op_sv = Nullsv;
6876 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6877 if (o->op_next->op_private & OPpTARGET_MY) {
6878 if (o->op_flags & OPf_STACKED) /* chained concats */
6879 goto ignore_optimization;
6881 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6882 o->op_targ = o->op_next->op_targ;
6883 o->op_next->op_targ = 0;
6884 o->op_private |= OPpTARGET_MY;
6887 op_null(o->op_next);
6889 ignore_optimization:
6893 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6895 break; /* Scalar stub must produce undef. List stub is noop */
6899 if (o->op_targ == OP_NEXTSTATE
6900 || o->op_targ == OP_DBSTATE
6901 || o->op_targ == OP_SETSTATE)
6903 PL_curcop = ((COP*)o);
6905 /* XXX: We avoid setting op_seq here to prevent later calls
6906 to peep() from mistakenly concluding that optimisation
6907 has already occurred. This doesn't fix the real problem,
6908 though (See 20010220.007). AMS 20010719 */
6909 /* op_seq functionality is now replaced by op_opt */
6910 if (oldop && o->op_next) {
6911 oldop->op_next = o->op_next;
6919 if (oldop && o->op_next) {
6920 oldop->op_next = o->op_next;
6928 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
6929 OP* const pop = (o->op_type == OP_PADAV) ?
6930 o->op_next : o->op_next->op_next;
6932 if (pop && pop->op_type == OP_CONST &&
6933 ((PL_op = pop->op_next)) &&
6934 pop->op_next->op_type == OP_AELEM &&
6935 !(pop->op_next->op_private &
6936 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6937 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6942 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
6943 no_bareword_allowed(pop);
6944 if (o->op_type == OP_GV)
6945 op_null(o->op_next);
6946 op_null(pop->op_next);
6948 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6949 o->op_next = pop->op_next->op_next;
6950 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6951 o->op_private = (U8)i;
6952 if (o->op_type == OP_GV) {
6957 o->op_flags |= OPf_SPECIAL;
6958 o->op_type = OP_AELEMFAST;
6964 if (o->op_next->op_type == OP_RV2SV) {
6965 if (!(o->op_next->op_private & OPpDEREF)) {
6966 op_null(o->op_next);
6967 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6969 o->op_next = o->op_next->op_next;
6970 o->op_type = OP_GVSV;
6971 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6974 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6975 GV * const gv = cGVOPo_gv;
6976 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
6977 /* XXX could check prototype here instead of just carping */
6978 SV * const sv = sv_newmortal();
6979 gv_efullname3(sv, gv, Nullch);
6980 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
6981 "%"SVf"() called too early to check prototype",
6985 else if (o->op_next->op_type == OP_READLINE
6986 && o->op_next->op_next->op_type == OP_CONCAT
6987 && (o->op_next->op_next->op_flags & OPf_STACKED))
6989 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6990 o->op_type = OP_RCATLINE;
6991 o->op_flags |= OPf_STACKED;
6992 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
6993 op_null(o->op_next->op_next);
6994 op_null(o->op_next);
7011 while (cLOGOP->op_other->op_type == OP_NULL)
7012 cLOGOP->op_other = cLOGOP->op_other->op_next;
7013 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
7019 while (cLOOP->op_redoop->op_type == OP_NULL)
7020 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
7021 peep(cLOOP->op_redoop);
7022 while (cLOOP->op_nextop->op_type == OP_NULL)
7023 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
7024 peep(cLOOP->op_nextop);
7025 while (cLOOP->op_lastop->op_type == OP_NULL)
7026 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
7027 peep(cLOOP->op_lastop);
7034 while (cPMOP->op_pmreplstart &&
7035 cPMOP->op_pmreplstart->op_type == OP_NULL)
7036 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
7037 peep(cPMOP->op_pmreplstart);
7042 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
7043 && ckWARN(WARN_SYNTAX))
7045 if (o->op_next->op_sibling &&
7046 o->op_next->op_sibling->op_type != OP_EXIT &&
7047 o->op_next->op_sibling->op_type != OP_WARN &&
7048 o->op_next->op_sibling->op_type != OP_DIE) {
7049 const line_t oldline = CopLINE(PL_curcop);
7051 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
7052 Perl_warner(aTHX_ packWARN(WARN_EXEC),
7053 "Statement unlikely to be reached");
7054 Perl_warner(aTHX_ packWARN(WARN_EXEC),
7055 "\t(Maybe you meant system() when you said exec()?)\n");
7056 CopLINE_set(PL_curcop, oldline);
7066 const char *key = NULL;
7071 if (((BINOP*)o)->op_last->op_type != OP_CONST)
7074 /* Make the CONST have a shared SV */
7075 svp = cSVOPx_svp(((BINOP*)o)->op_last);
7076 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
7077 key = SvPV_const(sv, keylen);
7078 lexname = newSVpvn_share(key,
7079 SvUTF8(sv) ? -(I32)keylen : keylen,
7085 if ((o->op_private & (OPpLVAL_INTRO)))
7088 rop = (UNOP*)((BINOP*)o)->op_first;
7089 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7091 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7092 if (!(SvFLAGS(lexname) & SVpad_TYPED))
7094 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
7095 if (!fields || !GvHV(*fields))
7097 key = SvPV_const(*svp, keylen);
7098 if (!hv_fetch(GvHV(*fields), key,
7099 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
7101 Perl_croak(aTHX_ "No such class field \"%s\" "
7102 "in variable %s of type %s",
7103 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
7116 SVOP *first_key_op, *key_op;
7118 if ((o->op_private & (OPpLVAL_INTRO))
7119 /* I bet there's always a pushmark... */
7120 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
7121 /* hmmm, no optimization if list contains only one key. */
7123 rop = (UNOP*)((LISTOP*)o)->op_last;
7124 if (rop->op_type != OP_RV2HV)
7126 if (rop->op_first->op_type == OP_PADSV)
7127 /* @$hash{qw(keys here)} */
7128 rop = (UNOP*)rop->op_first;
7130 /* @{$hash}{qw(keys here)} */
7131 if (rop->op_first->op_type == OP_SCOPE
7132 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
7134 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
7140 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
7141 if (!(SvFLAGS(lexname) & SVpad_TYPED))
7143 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
7144 if (!fields || !GvHV(*fields))
7146 /* Again guessing that the pushmark can be jumped over.... */
7147 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
7148 ->op_first->op_sibling;
7149 for (key_op = first_key_op; key_op;
7150 key_op = (SVOP*)key_op->op_sibling) {
7151 if (key_op->op_type != OP_CONST)
7153 svp = cSVOPx_svp(key_op);
7154 key = SvPV_const(*svp, keylen);
7155 if (!hv_fetch(GvHV(*fields), key,
7156 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
7158 Perl_croak(aTHX_ "No such class field \"%s\" "
7159 "in variable %s of type %s",
7160 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
7167 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
7171 /* check that RHS of sort is a single plain array */
7172 OP *oright = cUNOPo->op_first;
7173 if (!oright || oright->op_type != OP_PUSHMARK)
7176 /* reverse sort ... can be optimised. */
7177 if (!cUNOPo->op_sibling) {
7178 /* Nothing follows us on the list. */
7179 OP * const reverse = o->op_next;
7181 if (reverse->op_type == OP_REVERSE &&
7182 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
7183 OP * const pushmark = cUNOPx(reverse)->op_first;
7184 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
7185 && (cUNOPx(pushmark)->op_sibling == o)) {
7186 /* reverse -> pushmark -> sort */
7187 o->op_private |= OPpSORT_REVERSE;
7189 pushmark->op_next = oright->op_next;
7195 /* make @a = sort @a act in-place */
7199 oright = cUNOPx(oright)->op_sibling;
7202 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
7203 oright = cUNOPx(oright)->op_sibling;
7207 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
7208 || oright->op_next != o
7209 || (oright->op_private & OPpLVAL_INTRO)
7213 /* o2 follows the chain of op_nexts through the LHS of the
7214 * assign (if any) to the aassign op itself */
7216 if (!o2 || o2->op_type != OP_NULL)
7219 if (!o2 || o2->op_type != OP_PUSHMARK)
7222 if (o2 && o2->op_type == OP_GV)
7225 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
7226 || (o2->op_private & OPpLVAL_INTRO)
7231 if (!o2 || o2->op_type != OP_NULL)
7234 if (!o2 || o2->op_type != OP_AASSIGN
7235 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
7238 /* check that the sort is the first arg on RHS of assign */
7240 o2 = cUNOPx(o2)->op_first;
7241 if (!o2 || o2->op_type != OP_NULL)
7243 o2 = cUNOPx(o2)->op_first;
7244 if (!o2 || o2->op_type != OP_PUSHMARK)
7246 if (o2->op_sibling != o)
7249 /* check the array is the same on both sides */
7250 if (oleft->op_type == OP_RV2AV) {
7251 if (oright->op_type != OP_RV2AV
7252 || !cUNOPx(oright)->op_first
7253 || cUNOPx(oright)->op_first->op_type != OP_GV
7254 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
7255 cGVOPx_gv(cUNOPx(oright)->op_first)
7259 else if (oright->op_type != OP_PADAV
7260 || oright->op_targ != oleft->op_targ
7264 /* transfer MODishness etc from LHS arg to RHS arg */
7265 oright->op_flags = oleft->op_flags;
7266 o->op_private |= OPpSORT_INPLACE;
7268 /* excise push->gv->rv2av->null->aassign */
7269 o2 = o->op_next->op_next;
7270 op_null(o2); /* PUSHMARK */
7272 if (o2->op_type == OP_GV) {
7273 op_null(o2); /* GV */
7276 op_null(o2); /* RV2AV or PADAV */
7277 o2 = o2->op_next->op_next;
7278 op_null(o2); /* AASSIGN */
7280 o->op_next = o2->op_next;
7286 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
7288 LISTOP *enter, *exlist;
7291 enter = (LISTOP *) o->op_next;
7294 if (enter->op_type == OP_NULL) {
7295 enter = (LISTOP *) enter->op_next;
7299 /* for $a (...) will have OP_GV then OP_RV2GV here.
7300 for (...) just has an OP_GV. */
7301 if (enter->op_type == OP_GV) {
7302 gvop = (OP *) enter;
7303 enter = (LISTOP *) enter->op_next;
7306 if (enter->op_type == OP_RV2GV) {
7307 enter = (LISTOP *) enter->op_next;
7313 if (enter->op_type != OP_ENTERITER)
7316 iter = enter->op_next;
7317 if (!iter || iter->op_type != OP_ITER)
7320 expushmark = enter->op_first;
7321 if (!expushmark || expushmark->op_type != OP_NULL
7322 || expushmark->op_targ != OP_PUSHMARK)
7325 exlist = (LISTOP *) expushmark->op_sibling;
7326 if (!exlist || exlist->op_type != OP_NULL
7327 || exlist->op_targ != OP_LIST)
7330 if (exlist->op_last != o) {
7331 /* Mmm. Was expecting to point back to this op. */
7334 theirmark = exlist->op_first;
7335 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
7338 if (theirmark->op_sibling != o) {
7339 /* There's something between the mark and the reverse, eg
7340 for (1, reverse (...))
7345 ourmark = ((LISTOP *)o)->op_first;
7346 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
7349 ourlast = ((LISTOP *)o)->op_last;
7350 if (!ourlast || ourlast->op_next != o)
7353 rv2av = ourmark->op_sibling;
7354 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
7355 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
7356 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
7357 /* We're just reversing a single array. */
7358 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
7359 enter->op_flags |= OPf_STACKED;
7362 /* We don't have control over who points to theirmark, so sacrifice
7364 theirmark->op_next = ourmark->op_next;
7365 theirmark->op_flags = ourmark->op_flags;
7366 ourlast->op_next = gvop ? gvop : (OP *) enter;
7369 enter->op_private |= OPpITER_REVERSED;
7370 iter->op_private |= OPpITER_REVERSED;
7377 UNOP *refgen, *rv2cv;
7380 /* I do not understand this, but if o->op_opt isn't set to 1,
7381 various tests in ext/B/t/bytecode.t fail with no readily
7387 if ((o->op_flags && OPf_WANT) != OPf_WANT_VOID)
7390 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
7393 rv2gv = ((BINOP *)o)->op_last;
7394 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
7397 refgen = (UNOP *)((BINOP *)o)->op_first;
7399 if (!refgen || refgen->op_type != OP_REFGEN)
7402 exlist = (LISTOP *)refgen->op_first;
7403 if (!exlist || exlist->op_type != OP_NULL
7404 || exlist->op_targ != OP_LIST)
7407 if (exlist->op_first->op_type != OP_PUSHMARK)
7410 rv2cv = (UNOP*)exlist->op_last;
7412 if (rv2cv->op_type != OP_RV2CV)
7415 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
7416 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
7417 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
7419 o->op_private |= OPpASSIGN_CV_TO_GV;
7420 rv2gv->op_private |= OPpDONT_INIT_GV;
7421 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
7437 Perl_custom_op_name(pTHX_ const OP* o)
7440 const IV index = PTR2IV(o->op_ppaddr);
7444 if (!PL_custom_op_names) /* This probably shouldn't happen */
7445 return (char *)PL_op_name[OP_CUSTOM];
7447 keysv = sv_2mortal(newSViv(index));
7449 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
7451 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
7453 return SvPV_nolen(HeVAL(he));
7457 Perl_custom_op_desc(pTHX_ const OP* o)
7460 const IV index = PTR2IV(o->op_ppaddr);
7464 if (!PL_custom_op_descs)
7465 return (char *)PL_op_desc[OP_CUSTOM];
7467 keysv = sv_2mortal(newSViv(index));
7469 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
7471 return (char *)PL_op_desc[OP_CUSTOM];
7473 return SvPV_nolen(HeVAL(he));
7478 /* Efficient sub that returns a constant scalar value. */
7480 const_sv_xsub(pTHX_ CV* cv)
7486 Perl_croak(aTHX_ "usage: %s::%s()",
7487 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7491 ST(0) = (SV*)XSANY.any_ptr;
7497 * c-indentation-style: bsd
7499 * indent-tabs-mode: t
7502 * ex: set ts=8 sts=4 sw=4 noet: