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_fetchpvs(";", GV_ADD,
2055 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2061 Perl_fold_constants(pTHX_ register OP *o)
2065 I32 type = o->op_type;
2068 if (PL_opargs[type] & OA_RETSCALAR)
2070 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2071 o->op_targ = pad_alloc(type, SVs_PADTMP);
2073 /* integerize op, unless it happens to be C<-foo>.
2074 * XXX should pp_i_negate() do magic string negation instead? */
2075 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2076 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2077 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2079 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2082 if (!(PL_opargs[type] & OA_FOLDCONST))
2087 /* XXX might want a ck_negate() for this */
2088 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2099 /* XXX what about the numeric ops? */
2100 if (PL_hints & HINT_LOCALE)
2105 goto nope; /* Don't try to run w/ errors */
2107 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2108 if ((curop->op_type != OP_CONST ||
2109 (curop->op_private & OPpCONST_BARE)) &&
2110 curop->op_type != OP_LIST &&
2111 curop->op_type != OP_SCALAR &&
2112 curop->op_type != OP_NULL &&
2113 curop->op_type != OP_PUSHMARK)
2119 curop = LINKLIST(o);
2123 sv = *(PL_stack_sp--);
2124 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2125 pad_swipe(o->op_targ, FALSE);
2126 else if (SvTEMP(sv)) { /* grab mortal temp? */
2127 (void)SvREFCNT_inc(sv);
2131 if (type == OP_RV2GV)
2132 return newGVOP(OP_GV, 0, (GV*)sv);
2133 return newSVOP(OP_CONST, 0, sv);
2140 Perl_gen_constant_list(pTHX_ register OP *o)
2144 const I32 oldtmps_floor = PL_tmps_floor;
2148 return o; /* Don't attempt to run with errors */
2150 PL_op = curop = LINKLIST(o);
2157 PL_tmps_floor = oldtmps_floor;
2159 o->op_type = OP_RV2AV;
2160 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2161 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2162 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2163 o->op_opt = 0; /* needs to be revisited in peep() */
2164 curop = ((UNOP*)o)->op_first;
2165 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2172 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2175 if (!o || o->op_type != OP_LIST)
2176 o = newLISTOP(OP_LIST, 0, o, Nullop);
2178 o->op_flags &= ~OPf_WANT;
2180 if (!(PL_opargs[type] & OA_MARK))
2181 op_null(cLISTOPo->op_first);
2183 o->op_type = (OPCODE)type;
2184 o->op_ppaddr = PL_ppaddr[type];
2185 o->op_flags |= flags;
2187 o = CHECKOP(type, o);
2188 if (o->op_type != (unsigned)type)
2191 return fold_constants(o);
2194 /* List constructors */
2197 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2205 if (first->op_type != (unsigned)type
2206 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2208 return newLISTOP(type, 0, first, last);
2211 if (first->op_flags & OPf_KIDS)
2212 ((LISTOP*)first)->op_last->op_sibling = last;
2214 first->op_flags |= OPf_KIDS;
2215 ((LISTOP*)first)->op_first = last;
2217 ((LISTOP*)first)->op_last = last;
2222 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2230 if (first->op_type != (unsigned)type)
2231 return prepend_elem(type, (OP*)first, (OP*)last);
2233 if (last->op_type != (unsigned)type)
2234 return append_elem(type, (OP*)first, (OP*)last);
2236 first->op_last->op_sibling = last->op_first;
2237 first->op_last = last->op_last;
2238 first->op_flags |= (last->op_flags & OPf_KIDS);
2246 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2254 if (last->op_type == (unsigned)type) {
2255 if (type == OP_LIST) { /* already a PUSHMARK there */
2256 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2257 ((LISTOP*)last)->op_first->op_sibling = first;
2258 if (!(first->op_flags & OPf_PARENS))
2259 last->op_flags &= ~OPf_PARENS;
2262 if (!(last->op_flags & OPf_KIDS)) {
2263 ((LISTOP*)last)->op_last = first;
2264 last->op_flags |= OPf_KIDS;
2266 first->op_sibling = ((LISTOP*)last)->op_first;
2267 ((LISTOP*)last)->op_first = first;
2269 last->op_flags |= OPf_KIDS;
2273 return newLISTOP(type, 0, first, last);
2279 Perl_newNULLLIST(pTHX)
2281 return newOP(OP_STUB, 0);
2285 Perl_force_list(pTHX_ OP *o)
2287 if (!o || o->op_type != OP_LIST)
2288 o = newLISTOP(OP_LIST, 0, o, Nullop);
2294 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2299 NewOp(1101, listop, 1, LISTOP);
2301 listop->op_type = (OPCODE)type;
2302 listop->op_ppaddr = PL_ppaddr[type];
2305 listop->op_flags = (U8)flags;
2309 else if (!first && last)
2312 first->op_sibling = last;
2313 listop->op_first = first;
2314 listop->op_last = last;
2315 if (type == OP_LIST) {
2316 OP* const pushop = newOP(OP_PUSHMARK, 0);
2317 pushop->op_sibling = first;
2318 listop->op_first = pushop;
2319 listop->op_flags |= OPf_KIDS;
2321 listop->op_last = pushop;
2324 return CHECKOP(type, listop);
2328 Perl_newOP(pTHX_ I32 type, I32 flags)
2332 NewOp(1101, o, 1, OP);
2333 o->op_type = (OPCODE)type;
2334 o->op_ppaddr = PL_ppaddr[type];
2335 o->op_flags = (U8)flags;
2338 o->op_private = (U8)(0 | (flags >> 8));
2339 if (PL_opargs[type] & OA_RETSCALAR)
2341 if (PL_opargs[type] & OA_TARGET)
2342 o->op_targ = pad_alloc(type, SVs_PADTMP);
2343 return CHECKOP(type, o);
2347 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2353 first = newOP(OP_STUB, 0);
2354 if (PL_opargs[type] & OA_MARK)
2355 first = force_list(first);
2357 NewOp(1101, unop, 1, UNOP);
2358 unop->op_type = (OPCODE)type;
2359 unop->op_ppaddr = PL_ppaddr[type];
2360 unop->op_first = first;
2361 unop->op_flags = (U8)(flags | OPf_KIDS);
2362 unop->op_private = (U8)(1 | (flags >> 8));
2363 unop = (UNOP*) CHECKOP(type, unop);
2367 return fold_constants((OP *) unop);
2371 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2375 NewOp(1101, binop, 1, BINOP);
2378 first = newOP(OP_NULL, 0);
2380 binop->op_type = (OPCODE)type;
2381 binop->op_ppaddr = PL_ppaddr[type];
2382 binop->op_first = first;
2383 binop->op_flags = (U8)(flags | OPf_KIDS);
2386 binop->op_private = (U8)(1 | (flags >> 8));
2389 binop->op_private = (U8)(2 | (flags >> 8));
2390 first->op_sibling = last;
2393 binop = (BINOP*)CHECKOP(type, binop);
2394 if (binop->op_next || binop->op_type != (OPCODE)type)
2397 binop->op_last = binop->op_first->op_sibling;
2399 return fold_constants((OP *)binop);
2402 static int uvcompare(const void *a, const void *b) __attribute__nonnull__(1) __attribute__nonnull__(2) __attribute__pure__;
2403 static int uvcompare(const void *a, const void *b)
2405 if (*((const UV *)a) < (*(const UV *)b))
2407 if (*((const UV *)a) > (*(const UV *)b))
2409 if (*((const UV *)a+1) < (*(const UV *)b+1))
2411 if (*((const UV *)a+1) > (*(const UV *)b+1))
2417 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2420 SV * const tstr = ((SVOP*)expr)->op_sv;
2421 SV * const rstr = ((SVOP*)repl)->op_sv;
2424 const U8 *t = (U8*)SvPV_const(tstr, tlen);
2425 const U8 *r = (U8*)SvPV_const(rstr, rlen);
2429 register short *tbl;
2431 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
2432 const I32 squash = o->op_private & OPpTRANS_SQUASH;
2433 I32 del = o->op_private & OPpTRANS_DELETE;
2434 PL_hints |= HINT_BLOCK_SCOPE;
2437 o->op_private |= OPpTRANS_FROM_UTF;
2440 o->op_private |= OPpTRANS_TO_UTF;
2442 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2443 SV* const listsv = newSVpvs("# comment\n");
2445 const U8* tend = t + tlen;
2446 const U8* rend = r + rlen;
2460 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2461 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2467 t = tsave = bytes_to_utf8(t, &len);
2470 if (!to_utf && rlen) {
2472 r = rsave = bytes_to_utf8(r, &len);
2476 /* There are several snags with this code on EBCDIC:
2477 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2478 2. scan_const() in toke.c has encoded chars in native encoding which makes
2479 ranges at least in EBCDIC 0..255 range the bottom odd.
2483 U8 tmpbuf[UTF8_MAXBYTES+1];
2486 Newx(cp, 2*tlen, UV);
2488 transv = newSVpvs("");
2490 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2492 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2494 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2498 cp[2*i+1] = cp[2*i];
2502 qsort(cp, i, 2*sizeof(UV), uvcompare);
2503 for (j = 0; j < i; j++) {
2505 diff = val - nextmin;
2507 t = uvuni_to_utf8(tmpbuf,nextmin);
2508 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2510 U8 range_mark = UTF_TO_NATIVE(0xff);
2511 t = uvuni_to_utf8(tmpbuf, val - 1);
2512 sv_catpvn(transv, (char *)&range_mark, 1);
2513 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2520 t = uvuni_to_utf8(tmpbuf,nextmin);
2521 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2523 U8 range_mark = UTF_TO_NATIVE(0xff);
2524 sv_catpvn(transv, (char *)&range_mark, 1);
2526 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2527 UNICODE_ALLOW_SUPER);
2528 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2529 t = (const U8*)SvPVX_const(transv);
2530 tlen = SvCUR(transv);
2534 else if (!rlen && !del) {
2535 r = t; rlen = tlen; rend = tend;
2538 if ((!rlen && !del) || t == r ||
2539 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2541 o->op_private |= OPpTRANS_IDENTICAL;
2545 while (t < tend || tfirst <= tlast) {
2546 /* see if we need more "t" chars */
2547 if (tfirst > tlast) {
2548 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2550 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2552 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2559 /* now see if we need more "r" chars */
2560 if (rfirst > rlast) {
2562 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2564 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2566 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2575 rfirst = rlast = 0xffffffff;
2579 /* now see which range will peter our first, if either. */
2580 tdiff = tlast - tfirst;
2581 rdiff = rlast - rfirst;
2588 if (rfirst == 0xffffffff) {
2589 diff = tdiff; /* oops, pretend rdiff is infinite */
2591 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2592 (long)tfirst, (long)tlast);
2594 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2598 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2599 (long)tfirst, (long)(tfirst + diff),
2602 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2603 (long)tfirst, (long)rfirst);
2605 if (rfirst + diff > max)
2606 max = rfirst + diff;
2608 grows = (tfirst < rfirst &&
2609 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2621 else if (max > 0xff)
2626 Safefree(cPVOPo->op_pv);
2627 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2628 SvREFCNT_dec(listsv);
2630 SvREFCNT_dec(transv);
2632 if (!del && havefinal && rlen)
2633 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2634 newSVuv((UV)final), 0);
2637 o->op_private |= OPpTRANS_GROWS;
2649 tbl = (short*)cPVOPo->op_pv;
2651 Zero(tbl, 256, short);
2652 for (i = 0; i < (I32)tlen; i++)
2654 for (i = 0, j = 0; i < 256; i++) {
2656 if (j >= (I32)rlen) {
2665 if (i < 128 && r[j] >= 128)
2675 o->op_private |= OPpTRANS_IDENTICAL;
2677 else if (j >= (I32)rlen)
2680 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2681 tbl[0x100] = (short)(rlen - j);
2682 for (i=0; i < (I32)rlen - j; i++)
2683 tbl[0x101+i] = r[j+i];
2687 if (!rlen && !del) {
2690 o->op_private |= OPpTRANS_IDENTICAL;
2692 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
2693 o->op_private |= OPpTRANS_IDENTICAL;
2695 for (i = 0; i < 256; i++)
2697 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
2698 if (j >= (I32)rlen) {
2700 if (tbl[t[i]] == -1)
2706 if (tbl[t[i]] == -1) {
2707 if (t[i] < 128 && r[j] >= 128)
2714 o->op_private |= OPpTRANS_GROWS;
2722 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2727 NewOp(1101, pmop, 1, PMOP);
2728 pmop->op_type = (OPCODE)type;
2729 pmop->op_ppaddr = PL_ppaddr[type];
2730 pmop->op_flags = (U8)flags;
2731 pmop->op_private = (U8)(0 | (flags >> 8));
2733 if (PL_hints & HINT_RE_TAINT)
2734 pmop->op_pmpermflags |= PMf_RETAINT;
2735 if (PL_hints & HINT_LOCALE)
2736 pmop->op_pmpermflags |= PMf_LOCALE;
2737 pmop->op_pmflags = pmop->op_pmpermflags;
2740 if (av_len((AV*) PL_regex_pad[0]) > -1) {
2741 SV * const repointer = av_pop((AV*)PL_regex_pad[0]);
2742 pmop->op_pmoffset = SvIV(repointer);
2743 SvREPADTMP_off(repointer);
2744 sv_setiv(repointer,0);
2746 SV * const repointer = newSViv(0);
2747 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
2748 pmop->op_pmoffset = av_len(PL_regex_padav);
2749 PL_regex_pad = AvARRAY(PL_regex_padav);
2753 /* link into pm list */
2754 if (type != OP_TRANS && PL_curstash) {
2755 MAGIC *mg = mg_find((SV*)PL_curstash, PERL_MAGIC_symtab);
2758 mg = sv_magicext((SV*)PL_curstash, 0, PERL_MAGIC_symtab, 0, 0, 0);
2760 pmop->op_pmnext = (PMOP*)mg->mg_obj;
2761 mg->mg_obj = (SV*)pmop;
2762 PmopSTASH_set(pmop,PL_curstash);
2765 return CHECKOP(type, pmop);
2768 /* Given some sort of match op o, and an expression expr containing a
2769 * pattern, either compile expr into a regex and attach it to o (if it's
2770 * constant), or convert expr into a runtime regcomp op sequence (if it's
2773 * isreg indicates that the pattern is part of a regex construct, eg
2774 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
2775 * split "pattern", which aren't. In the former case, expr will be a list
2776 * if the pattern contains more than one term (eg /a$b/) or if it contains
2777 * a replacement, ie s/// or tr///.
2781 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
2786 I32 repl_has_vars = 0;
2790 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
2791 /* last element in list is the replacement; pop it */
2793 repl = cLISTOPx(expr)->op_last;
2794 kid = cLISTOPx(expr)->op_first;
2795 while (kid->op_sibling != repl)
2796 kid = kid->op_sibling;
2797 kid->op_sibling = Nullop;
2798 cLISTOPx(expr)->op_last = kid;
2801 if (isreg && expr->op_type == OP_LIST &&
2802 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
2804 /* convert single element list to element */
2805 OP* const oe = expr;
2806 expr = cLISTOPx(oe)->op_first->op_sibling;
2807 cLISTOPx(oe)->op_first->op_sibling = Nullop;
2808 cLISTOPx(oe)->op_last = Nullop;
2812 if (o->op_type == OP_TRANS) {
2813 return pmtrans(o, expr, repl);
2816 reglist = isreg && expr->op_type == OP_LIST;
2820 PL_hints |= HINT_BLOCK_SCOPE;
2823 if (expr->op_type == OP_CONST) {
2825 SV * const pat = ((SVOP*)expr)->op_sv;
2826 const char *p = SvPV_const(pat, plen);
2827 if ((o->op_flags & OPf_SPECIAL) && (*p == ' ' && p[1] == '\0')) {
2828 U32 was_readonly = SvREADONLY(pat);
2832 sv_force_normal_flags(pat, 0);
2833 assert(!SvREADONLY(pat));
2836 SvREADONLY_off(pat);
2840 sv_setpvn(pat, "\\s+", 3);
2842 SvFLAGS(pat) |= was_readonly;
2844 p = SvPV_const(pat, plen);
2845 pm->op_pmflags |= PMf_SKIPWHITE;
2848 pm->op_pmdynflags |= PMdf_UTF8;
2849 /* FIXME - can we make this function take const char * args? */
2850 PM_SETRE(pm, CALLREGCOMP(aTHX_ (char*)p, (char*)p + plen, pm));
2851 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
2852 pm->op_pmflags |= PMf_WHITE;
2856 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
2857 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2859 : OP_REGCMAYBE),0,expr);
2861 NewOp(1101, rcop, 1, LOGOP);
2862 rcop->op_type = OP_REGCOMP;
2863 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
2864 rcop->op_first = scalar(expr);
2865 rcop->op_flags |= OPf_KIDS
2866 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
2867 | (reglist ? OPf_STACKED : 0);
2868 rcop->op_private = 1;
2871 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
2873 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
2876 /* establish postfix order */
2877 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
2879 rcop->op_next = expr;
2880 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
2883 rcop->op_next = LINKLIST(expr);
2884 expr->op_next = (OP*)rcop;
2887 prepend_elem(o->op_type, scalar((OP*)rcop), o);
2892 if (pm->op_pmflags & PMf_EVAL) {
2894 if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
2895 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
2897 else if (repl->op_type == OP_CONST)
2901 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
2902 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
2903 if (curop->op_type == OP_GV) {
2904 GV * const gv = cGVOPx_gv(curop);
2906 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
2909 else if (curop->op_type == OP_RV2CV)
2911 else if (curop->op_type == OP_RV2SV ||
2912 curop->op_type == OP_RV2AV ||
2913 curop->op_type == OP_RV2HV ||
2914 curop->op_type == OP_RV2GV) {
2915 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
2918 else if (curop->op_type == OP_PADSV ||
2919 curop->op_type == OP_PADAV ||
2920 curop->op_type == OP_PADHV ||
2921 curop->op_type == OP_PADANY) {
2924 else if (curop->op_type == OP_PUSHRE)
2925 ; /* Okay here, dangerous in newASSIGNOP */
2935 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
2936 pm->op_pmflags |= PMf_CONST; /* const for long enough */
2937 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
2938 prepend_elem(o->op_type, scalar(repl), o);
2941 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
2942 pm->op_pmflags |= PMf_MAYBE_CONST;
2943 pm->op_pmpermflags |= PMf_MAYBE_CONST;
2945 NewOp(1101, rcop, 1, LOGOP);
2946 rcop->op_type = OP_SUBSTCONT;
2947 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
2948 rcop->op_first = scalar(repl);
2949 rcop->op_flags |= OPf_KIDS;
2950 rcop->op_private = 1;
2953 /* establish postfix order */
2954 rcop->op_next = LINKLIST(repl);
2955 repl->op_next = (OP*)rcop;
2957 pm->op_pmreplroot = scalar((OP*)rcop);
2958 pm->op_pmreplstart = LINKLIST(rcop);
2967 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
2971 NewOp(1101, svop, 1, SVOP);
2972 svop->op_type = (OPCODE)type;
2973 svop->op_ppaddr = PL_ppaddr[type];
2975 svop->op_next = (OP*)svop;
2976 svop->op_flags = (U8)flags;
2977 if (PL_opargs[type] & OA_RETSCALAR)
2979 if (PL_opargs[type] & OA_TARGET)
2980 svop->op_targ = pad_alloc(type, SVs_PADTMP);
2981 return CHECKOP(type, svop);
2985 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
2989 NewOp(1101, padop, 1, PADOP);
2990 padop->op_type = (OPCODE)type;
2991 padop->op_ppaddr = PL_ppaddr[type];
2992 padop->op_padix = pad_alloc(type, SVs_PADTMP);
2993 SvREFCNT_dec(PAD_SVl(padop->op_padix));
2994 PAD_SETSV(padop->op_padix, sv);
2997 padop->op_next = (OP*)padop;
2998 padop->op_flags = (U8)flags;
2999 if (PL_opargs[type] & OA_RETSCALAR)
3001 if (PL_opargs[type] & OA_TARGET)
3002 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3003 return CHECKOP(type, padop);
3007 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3013 return newPADOP(type, flags, SvREFCNT_inc(gv));
3015 return newSVOP(type, flags, SvREFCNT_inc(gv));
3020 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3024 NewOp(1101, pvop, 1, PVOP);
3025 pvop->op_type = (OPCODE)type;
3026 pvop->op_ppaddr = PL_ppaddr[type];
3028 pvop->op_next = (OP*)pvop;
3029 pvop->op_flags = (U8)flags;
3030 if (PL_opargs[type] & OA_RETSCALAR)
3032 if (PL_opargs[type] & OA_TARGET)
3033 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3034 return CHECKOP(type, pvop);
3038 Perl_package(pTHX_ OP *o)
3044 save_hptr(&PL_curstash);
3045 save_item(PL_curstname);
3047 name = SvPV_const(cSVOPo->op_sv, len);
3048 PL_curstash = gv_stashpvn(name, len, TRUE);
3049 sv_setpvn(PL_curstname, name, len);
3052 PL_hints |= HINT_BLOCK_SCOPE;
3053 PL_copline = NOLINE;
3058 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3065 if (idop->op_type != OP_CONST)
3066 Perl_croak(aTHX_ "Module name must be constant");
3071 SV * const vesv = ((SVOP*)version)->op_sv;
3073 if (!arg && !SvNIOKp(vesv)) {
3080 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3081 Perl_croak(aTHX_ "Version number must be constant number");
3083 /* Make copy of idop so we don't free it twice */
3084 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3086 /* Fake up a method call to VERSION */
3087 meth = newSVpvs_share("VERSION");
3088 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3089 append_elem(OP_LIST,
3090 prepend_elem(OP_LIST, pack, list(version)),
3091 newSVOP(OP_METHOD_NAMED, 0, meth)));
3095 /* Fake up an import/unimport */
3096 if (arg && arg->op_type == OP_STUB)
3097 imop = arg; /* no import on explicit () */
3098 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3099 imop = Nullop; /* use 5.0; */
3101 idop->op_private |= OPpCONST_NOVER;
3106 /* Make copy of idop so we don't free it twice */
3107 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3109 /* Fake up a method call to import/unimport */
3111 ? newSVpvs_share("import") : newSVpvs_share("unimport");
3112 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3113 append_elem(OP_LIST,
3114 prepend_elem(OP_LIST, pack, list(arg)),
3115 newSVOP(OP_METHOD_NAMED, 0, meth)));
3118 /* Fake up the BEGIN {}, which does its thing immediately. */
3120 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
3123 append_elem(OP_LINESEQ,
3124 append_elem(OP_LINESEQ,
3125 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, idop)),
3126 newSTATEOP(0, Nullch, veop)),
3127 newSTATEOP(0, Nullch, imop) ));
3129 /* The "did you use incorrect case?" warning used to be here.
3130 * The problem is that on case-insensitive filesystems one
3131 * might get false positives for "use" (and "require"):
3132 * "use Strict" or "require CARP" will work. This causes
3133 * portability problems for the script: in case-strict
3134 * filesystems the script will stop working.
3136 * The "incorrect case" warning checked whether "use Foo"
3137 * imported "Foo" to your namespace, but that is wrong, too:
3138 * there is no requirement nor promise in the language that
3139 * a Foo.pm should or would contain anything in package "Foo".
3141 * There is very little Configure-wise that can be done, either:
3142 * the case-sensitivity of the build filesystem of Perl does not
3143 * help in guessing the case-sensitivity of the runtime environment.
3146 PL_hints |= HINT_BLOCK_SCOPE;
3147 PL_copline = NOLINE;
3149 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3153 =head1 Embedding Functions
3155 =for apidoc load_module
3157 Loads the module whose name is pointed to by the string part of name.
3158 Note that the actual module name, not its filename, should be given.
3159 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3160 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3161 (or 0 for no flags). ver, if specified, provides version semantics
3162 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3163 arguments can be used to specify arguments to the module's import()
3164 method, similar to C<use Foo::Bar VERSION LIST>.
3169 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3172 va_start(args, ver);
3173 vload_module(flags, name, ver, &args);
3177 #ifdef PERL_IMPLICIT_CONTEXT
3179 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3183 va_start(args, ver);
3184 vload_module(flags, name, ver, &args);
3190 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3195 OP * const modname = newSVOP(OP_CONST, 0, name);
3196 modname->op_private |= OPpCONST_BARE;
3198 veop = newSVOP(OP_CONST, 0, ver);
3202 if (flags & PERL_LOADMOD_NOIMPORT) {
3203 imop = sawparens(newNULLLIST());
3205 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3206 imop = va_arg(*args, OP*);
3211 sv = va_arg(*args, SV*);
3213 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3214 sv = va_arg(*args, SV*);
3218 const line_t ocopline = PL_copline;
3219 COP * const ocurcop = PL_curcop;
3220 const int oexpect = PL_expect;
3222 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3223 veop, modname, imop);
3224 PL_expect = oexpect;
3225 PL_copline = ocopline;
3226 PL_curcop = ocurcop;
3231 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
3237 if (!force_builtin) {
3238 gv = gv_fetchpvs("do", 0, SVt_PVCV);
3239 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
3240 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
3241 gv = gvp ? *gvp : Nullgv;
3245 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3246 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3247 append_elem(OP_LIST, term,
3248 scalar(newUNOP(OP_RV2CV, 0,
3253 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3259 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3261 return newBINOP(OP_LSLICE, flags,
3262 list(force_list(subscript)),
3263 list(force_list(listval)) );
3267 S_is_list_assignment(pTHX_ register const OP *o)
3272 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3273 o = cUNOPo->op_first;
3275 if (o->op_type == OP_COND_EXPR) {
3276 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
3277 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3282 yyerror("Assignment to both a list and a scalar");
3286 if (o->op_type == OP_LIST &&
3287 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3288 o->op_private & OPpLVAL_INTRO)
3291 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3292 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3293 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3296 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3299 if (o->op_type == OP_RV2SV)
3306 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3312 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3313 return newLOGOP(optype, 0,
3314 mod(scalar(left), optype),
3315 newUNOP(OP_SASSIGN, 0, scalar(right)));
3318 return newBINOP(optype, OPf_STACKED,
3319 mod(scalar(left), optype), scalar(right));
3323 if (is_list_assignment(left)) {
3327 /* Grandfathering $[ assignment here. Bletch.*/
3328 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
3329 PL_eval_start = (left->op_type == OP_CONST) ? right : 0;
3330 left = mod(left, OP_AASSIGN);
3333 else if (left->op_type == OP_CONST) {
3334 /* Result of assignment is always 1 (or we'd be dead already) */
3335 return newSVOP(OP_CONST, 0, newSViv(1));
3337 curop = list(force_list(left));
3338 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3339 o->op_private = (U8)(0 | (flags >> 8));
3341 /* PL_generation sorcery:
3342 * an assignment like ($a,$b) = ($c,$d) is easier than
3343 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3344 * To detect whether there are common vars, the global var
3345 * PL_generation is incremented for each assign op we compile.
3346 * Then, while compiling the assign op, we run through all the
3347 * variables on both sides of the assignment, setting a spare slot
3348 * in each of them to PL_generation. If any of them already have
3349 * that value, we know we've got commonality. We could use a
3350 * single bit marker, but then we'd have to make 2 passes, first
3351 * to clear the flag, then to test and set it. To find somewhere
3352 * to store these values, evil chicanery is done with SvCUR().
3355 if (!(left->op_private & OPpLVAL_INTRO)) {
3358 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3359 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3360 if (curop->op_type == OP_GV) {
3361 GV *gv = cGVOPx_gv(curop);
3362 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3364 SvCUR_set(gv, PL_generation);
3366 else if (curop->op_type == OP_PADSV ||
3367 curop->op_type == OP_PADAV ||
3368 curop->op_type == OP_PADHV ||
3369 curop->op_type == OP_PADANY)
3371 if (PAD_COMPNAME_GEN(curop->op_targ)
3372 == (STRLEN)PL_generation)
3374 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
3377 else if (curop->op_type == OP_RV2CV)
3379 else if (curop->op_type == OP_RV2SV ||
3380 curop->op_type == OP_RV2AV ||
3381 curop->op_type == OP_RV2HV ||
3382 curop->op_type == OP_RV2GV) {
3383 if (lastop->op_type != OP_GV) /* funny deref? */
3386 else if (curop->op_type == OP_PUSHRE) {
3387 if (((PMOP*)curop)->op_pmreplroot) {
3389 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3390 ((PMOP*)curop)->op_pmreplroot));
3392 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3394 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3396 SvCUR_set(gv, PL_generation);
3405 o->op_private |= OPpASSIGN_COMMON;
3407 if (right && right->op_type == OP_SPLIT) {
3409 if ((tmpop = ((LISTOP*)right)->op_first) &&
3410 tmpop->op_type == OP_PUSHRE)
3412 PMOP * const pm = (PMOP*)tmpop;
3413 if (left->op_type == OP_RV2AV &&
3414 !(left->op_private & OPpLVAL_INTRO) &&
3415 !(o->op_private & OPpASSIGN_COMMON) )
3417 tmpop = ((UNOP*)left)->op_first;
3418 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3420 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3421 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3423 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3424 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3426 pm->op_pmflags |= PMf_ONCE;
3427 tmpop = cUNOPo->op_first; /* to list (nulled) */
3428 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3429 tmpop->op_sibling = Nullop; /* don't free split */
3430 right->op_next = tmpop->op_next; /* fix starting loc */
3431 op_free(o); /* blow off assign */
3432 right->op_flags &= ~OPf_WANT;
3433 /* "I don't know and I don't care." */
3438 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3439 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3441 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3443 sv_setiv(sv, PL_modcount+1);
3451 right = newOP(OP_UNDEF, 0);
3452 if (right->op_type == OP_READLINE) {
3453 right->op_flags |= OPf_STACKED;
3454 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3457 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3458 o = newBINOP(OP_SASSIGN, flags,
3459 scalar(right), mod(scalar(left), OP_SASSIGN) );
3463 o = newSVOP(OP_CONST, 0, newSViv(PL_compiling.cop_arybase));
3470 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3473 const U32 seq = intro_my();
3476 NewOp(1101, cop, 1, COP);
3477 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3478 cop->op_type = OP_DBSTATE;
3479 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3482 cop->op_type = OP_NEXTSTATE;
3483 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3485 cop->op_flags = (U8)flags;
3486 cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
3488 cop->op_private |= NATIVE_HINTS;
3490 PL_compiling.op_private = cop->op_private;
3491 cop->op_next = (OP*)cop;
3494 cop->cop_label = label;
3495 PL_hints |= HINT_BLOCK_SCOPE;
3498 cop->cop_arybase = PL_curcop->cop_arybase;
3499 if (specialWARN(PL_curcop->cop_warnings))
3500 cop->cop_warnings = PL_curcop->cop_warnings ;
3502 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3503 if (specialCopIO(PL_curcop->cop_io))
3504 cop->cop_io = PL_curcop->cop_io;
3506 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3509 if (PL_copline == NOLINE)
3510 CopLINE_set(cop, CopLINE(PL_curcop));
3512 CopLINE_set(cop, PL_copline);
3513 PL_copline = NOLINE;
3516 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3518 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3520 CopSTASH_set(cop, PL_curstash);
3522 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3523 SV * const * const svp = av_fetch(CopFILEAVx(PL_curcop), (I32)CopLINE(cop), FALSE);
3524 if (svp && *svp != &PL_sv_undef ) {
3525 (void)SvIOK_on(*svp);
3526 SvIV_set(*svp, PTR2IV(cop));
3530 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3535 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3538 return new_logop(type, flags, &first, &other);
3542 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3547 OP *first = *firstp;
3548 OP * const other = *otherp;
3550 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3551 return newBINOP(type, flags, scalar(first), scalar(other));
3553 scalarboolean(first);
3554 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3555 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3556 if (type == OP_AND || type == OP_OR) {
3562 first = *firstp = cUNOPo->op_first;
3564 first->op_next = o->op_next;
3565 cUNOPo->op_first = Nullop;
3569 if (first->op_type == OP_CONST) {
3570 if (first->op_private & OPpCONST_STRICT)
3571 no_bareword_allowed(first);
3572 else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
3573 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
3574 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
3575 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
3576 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
3579 if (other->op_type == OP_CONST)
3580 other->op_private |= OPpCONST_SHORTCIRCUIT;
3584 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
3585 const OP *o2 = other;
3586 if ( ! (o2->op_type == OP_LIST
3587 && (( o2 = cUNOPx(o2)->op_first))
3588 && o2->op_type == OP_PUSHMARK
3589 && (( o2 = o2->op_sibling)) )
3592 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
3593 || o2->op_type == OP_PADHV)
3594 && o2->op_private & OPpLVAL_INTRO
3595 && ckWARN(WARN_DEPRECATED))
3597 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
3598 "Deprecated use of my() in false conditional");
3603 if (first->op_type == OP_CONST)
3604 first->op_private |= OPpCONST_SHORTCIRCUIT;
3608 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
3609 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
3611 const OP * const k1 = ((UNOP*)first)->op_first;
3612 const OP * const k2 = k1->op_sibling;
3614 switch (first->op_type)
3617 if (k2 && k2->op_type == OP_READLINE
3618 && (k2->op_flags & OPf_STACKED)
3619 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3621 warnop = k2->op_type;
3626 if (k1->op_type == OP_READDIR
3627 || k1->op_type == OP_GLOB
3628 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3629 || k1->op_type == OP_EACH)
3631 warnop = ((k1->op_type == OP_NULL)
3632 ? (OPCODE)k1->op_targ : k1->op_type);
3637 const line_t oldline = CopLINE(PL_curcop);
3638 CopLINE_set(PL_curcop, PL_copline);
3639 Perl_warner(aTHX_ packWARN(WARN_MISC),
3640 "Value of %s%s can be \"0\"; test with defined()",
3642 ((warnop == OP_READLINE || warnop == OP_GLOB)
3643 ? " construct" : "() operator"));
3644 CopLINE_set(PL_curcop, oldline);
3651 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
3652 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3654 NewOp(1101, logop, 1, LOGOP);
3656 logop->op_type = (OPCODE)type;
3657 logop->op_ppaddr = PL_ppaddr[type];
3658 logop->op_first = first;
3659 logop->op_flags = (U8)(flags | OPf_KIDS);
3660 logop->op_other = LINKLIST(other);
3661 logop->op_private = (U8)(1 | (flags >> 8));
3663 /* establish postfix order */
3664 logop->op_next = LINKLIST(first);
3665 first->op_next = (OP*)logop;
3666 first->op_sibling = other;
3668 CHECKOP(type,logop);
3670 o = newUNOP(OP_NULL, 0, (OP*)logop);
3677 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3685 return newLOGOP(OP_AND, 0, first, trueop);
3687 return newLOGOP(OP_OR, 0, first, falseop);
3689 scalarboolean(first);
3690 if (first->op_type == OP_CONST) {
3691 if (first->op_private & OPpCONST_BARE &&
3692 first->op_private & OPpCONST_STRICT) {
3693 no_bareword_allowed(first);
3695 if (SvTRUE(((SVOP*)first)->op_sv)) {
3706 NewOp(1101, logop, 1, LOGOP);
3707 logop->op_type = OP_COND_EXPR;
3708 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3709 logop->op_first = first;
3710 logop->op_flags = (U8)(flags | OPf_KIDS);
3711 logop->op_private = (U8)(1 | (flags >> 8));
3712 logop->op_other = LINKLIST(trueop);
3713 logop->op_next = LINKLIST(falseop);
3715 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
3718 /* establish postfix order */
3719 start = LINKLIST(first);
3720 first->op_next = (OP*)logop;
3722 first->op_sibling = trueop;
3723 trueop->op_sibling = falseop;
3724 o = newUNOP(OP_NULL, 0, (OP*)logop);
3726 trueop->op_next = falseop->op_next = o;
3733 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3742 NewOp(1101, range, 1, LOGOP);
3744 range->op_type = OP_RANGE;
3745 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3746 range->op_first = left;
3747 range->op_flags = OPf_KIDS;
3748 leftstart = LINKLIST(left);
3749 range->op_other = LINKLIST(right);
3750 range->op_private = (U8)(1 | (flags >> 8));
3752 left->op_sibling = right;
3754 range->op_next = (OP*)range;
3755 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3756 flop = newUNOP(OP_FLOP, 0, flip);
3757 o = newUNOP(OP_NULL, 0, flop);
3759 range->op_next = leftstart;
3761 left->op_next = flip;
3762 right->op_next = flop;
3764 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3765 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3766 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3767 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3769 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3770 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3773 if (!flip->op_private || !flop->op_private)
3774 linklist(o); /* blow off optimizer unless constant */
3780 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3785 const bool once = block && block->op_flags & OPf_SPECIAL &&
3786 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3788 PERL_UNUSED_ARG(debuggable);
3791 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3792 return block; /* do {} while 0 does once */
3793 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3794 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3795 expr = newUNOP(OP_DEFINED, 0,
3796 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3797 } else if (expr->op_flags & OPf_KIDS) {
3798 const OP * const k1 = ((UNOP*)expr)->op_first;
3799 const OP * const k2 = k1 ? k1->op_sibling : NULL;
3800 switch (expr->op_type) {
3802 if (k2 && k2->op_type == OP_READLINE
3803 && (k2->op_flags & OPf_STACKED)
3804 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3805 expr = newUNOP(OP_DEFINED, 0, expr);
3809 if (k1->op_type == OP_READDIR
3810 || k1->op_type == OP_GLOB
3811 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3812 || k1->op_type == OP_EACH)
3813 expr = newUNOP(OP_DEFINED, 0, expr);
3819 /* if block is null, the next append_elem() would put UNSTACK, a scalar
3820 * op, in listop. This is wrong. [perl #27024] */
3822 block = newOP(OP_NULL, 0);
3823 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3824 o = new_logop(OP_AND, 0, &expr, &listop);
3827 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3829 if (once && o != listop)
3830 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3833 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3835 o->op_flags |= flags;
3837 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3842 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
3843 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
3852 PERL_UNUSED_ARG(debuggable);
3855 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3856 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3857 expr = newUNOP(OP_DEFINED, 0,
3858 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3859 } else if (expr->op_flags & OPf_KIDS) {
3860 const OP * const k1 = ((UNOP*)expr)->op_first;
3861 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
3862 switch (expr->op_type) {
3864 if (k2 && k2->op_type == OP_READLINE
3865 && (k2->op_flags & OPf_STACKED)
3866 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3867 expr = newUNOP(OP_DEFINED, 0, expr);
3871 if (k1->op_type == OP_READDIR
3872 || k1->op_type == OP_GLOB
3873 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3874 || k1->op_type == OP_EACH)
3875 expr = newUNOP(OP_DEFINED, 0, expr);
3882 block = newOP(OP_NULL, 0);
3883 else if (cont || has_my) {
3884 block = scope(block);
3888 next = LINKLIST(cont);
3891 OP * const unstack = newOP(OP_UNSTACK, 0);
3894 cont = append_elem(OP_LINESEQ, cont, unstack);
3897 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3898 redo = LINKLIST(listop);
3901 PL_copline = (line_t)whileline;
3903 o = new_logop(OP_AND, 0, &expr, &listop);
3904 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3905 op_free(expr); /* oops, it's a while (0) */
3907 return Nullop; /* listop already freed by new_logop */
3910 ((LISTOP*)listop)->op_last->op_next =
3911 (o == listop ? redo : LINKLIST(o));
3917 NewOp(1101,loop,1,LOOP);
3918 loop->op_type = OP_ENTERLOOP;
3919 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3920 loop->op_private = 0;
3921 loop->op_next = (OP*)loop;
3924 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
3926 loop->op_redoop = redo;
3927 loop->op_lastop = o;
3928 o->op_private |= loopflags;
3931 loop->op_nextop = next;
3933 loop->op_nextop = o;
3935 o->op_flags |= flags;
3936 o->op_private |= (flags >> 8);
3941 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
3946 PADOFFSET padoff = 0;
3951 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
3952 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
3953 sv->op_type = OP_RV2GV;
3954 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
3955 if (cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
3956 iterpflags |= OPpITER_DEF;
3958 else if (sv->op_type == OP_PADSV) { /* private variable */
3959 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
3960 padoff = sv->op_targ;
3965 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
3966 padoff = sv->op_targ;
3968 iterflags |= OPf_SPECIAL;
3973 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
3974 if (padoff && strEQ(PAD_COMPNAME_PV(padoff), "$_"))
3975 iterpflags |= OPpITER_DEF;
3978 const I32 offset = pad_findmy("$_");
3979 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
3980 sv = newGVOP(OP_GV, 0, PL_defgv);
3985 iterpflags |= OPpITER_DEF;
3987 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
3988 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
3989 iterflags |= OPf_STACKED;
3991 else if (expr->op_type == OP_NULL &&
3992 (expr->op_flags & OPf_KIDS) &&
3993 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
3995 /* Basically turn for($x..$y) into the same as for($x,$y), but we
3996 * set the STACKED flag to indicate that these values are to be
3997 * treated as min/max values by 'pp_iterinit'.
3999 UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4000 LOGOP* const range = (LOGOP*) flip->op_first;
4001 OP* const left = range->op_first;
4002 OP* const right = left->op_sibling;
4005 range->op_flags &= ~OPf_KIDS;
4006 range->op_first = Nullop;
4008 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4009 listop->op_first->op_next = range->op_next;
4010 left->op_next = range->op_other;
4011 right->op_next = (OP*)listop;
4012 listop->op_next = listop->op_first;
4015 expr = (OP*)(listop);
4017 iterflags |= OPf_STACKED;
4020 expr = mod(force_list(expr), OP_GREPSTART);
4023 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4024 append_elem(OP_LIST, expr, scalar(sv))));
4025 assert(!loop->op_next);
4026 /* for my $x () sets OPpLVAL_INTRO;
4027 * for our $x () sets OPpOUR_INTRO */
4028 loop->op_private = (U8)iterpflags;
4029 #ifdef PL_OP_SLAB_ALLOC
4032 NewOp(1234,tmp,1,LOOP);
4033 Copy(loop,tmp,1,LISTOP);
4038 Renew(loop, 1, LOOP);
4040 loop->op_targ = padoff;
4041 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
4042 PL_copline = forline;
4043 return newSTATEOP(0, label, wop);
4047 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4052 if (type != OP_GOTO || label->op_type == OP_CONST) {
4053 /* "last()" means "last" */
4054 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4055 o = newOP(type, OPf_SPECIAL);
4057 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4058 ? SvPVx_nolen_const(((SVOP*)label)->op_sv)
4064 /* Check whether it's going to be a goto &function */
4065 if (label->op_type == OP_ENTERSUB
4066 && !(label->op_flags & OPf_STACKED))
4067 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4068 o = newUNOP(type, OPf_STACKED, label);
4070 PL_hints |= HINT_BLOCK_SCOPE;
4074 /* if the condition is a literal array or hash
4075 (or @{ ... } etc), make a reference to it.
4078 S_ref_array_or_hash(pTHX_ OP *cond)
4081 && (cond->op_type == OP_RV2AV
4082 || cond->op_type == OP_PADAV
4083 || cond->op_type == OP_RV2HV
4084 || cond->op_type == OP_PADHV))
4086 return newUNOP(OP_REFGEN,
4087 0, mod(cond, OP_REFGEN));
4093 /* These construct the optree fragments representing given()
4096 entergiven and enterwhen are LOGOPs; the op_other pointer
4097 points up to the associated leave op. We need this so we
4098 can put it in the context and make break/continue work.
4099 (Also, of course, pp_enterwhen will jump straight to
4100 op_other if the match fails.)
4105 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
4106 I32 enter_opcode, I32 leave_opcode,
4107 PADOFFSET entertarg)
4113 NewOp(1101, enterop, 1, LOGOP);
4114 enterop->op_type = enter_opcode;
4115 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
4116 enterop->op_flags = (U8) OPf_KIDS;
4117 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
4118 enterop->op_private = 0;
4120 o = newUNOP(leave_opcode, 0, (OP *) enterop);
4123 enterop->op_first = scalar(cond);
4124 cond->op_sibling = block;
4126 o->op_next = LINKLIST(cond);
4127 cond->op_next = (OP *) enterop;
4130 /* This is a default {} block */
4131 enterop->op_first = block;
4132 enterop->op_flags |= OPf_SPECIAL;
4134 o->op_next = (OP *) enterop;
4137 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
4138 entergiven and enterwhen both
4141 enterop->op_next = LINKLIST(block);
4142 block->op_next = enterop->op_other = o;
4147 /* Does this look like a boolean operation? For these purposes
4148 a boolean operation is:
4149 - a subroutine call [*]
4150 - a logical connective
4151 - a comparison operator
4152 - a filetest operator, with the exception of -s -M -A -C
4153 - defined(), exists() or eof()
4154 - /$re/ or $foo =~ /$re/
4156 [*] possibly surprising
4160 S_looks_like_bool(pTHX_ OP *o)
4163 switch(o->op_type) {
4165 return looks_like_bool(cLOGOPo->op_first);
4169 looks_like_bool(cLOGOPo->op_first)
4170 && looks_like_bool(cLOGOPo->op_first->op_sibling));
4174 case OP_NOT: case OP_XOR:
4175 /* Note that OP_DOR is not here */
4177 case OP_EQ: case OP_NE: case OP_LT:
4178 case OP_GT: case OP_LE: case OP_GE:
4180 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
4181 case OP_I_GT: case OP_I_LE: case OP_I_GE:
4183 case OP_SEQ: case OP_SNE: case OP_SLT:
4184 case OP_SGT: case OP_SLE: case OP_SGE:
4188 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
4189 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
4190 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
4191 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
4192 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
4193 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
4194 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
4195 case OP_FTTEXT: case OP_FTBINARY:
4197 case OP_DEFINED: case OP_EXISTS:
4198 case OP_MATCH: case OP_EOF:
4203 /* Detect comparisons that have been optimized away */
4204 if (cSVOPo->op_sv == &PL_sv_yes
4205 || cSVOPo->op_sv == &PL_sv_no)
4216 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
4220 return newGIVWHENOP(
4221 ref_array_or_hash(cond),
4223 OP_ENTERGIVEN, OP_LEAVEGIVEN,
4227 /* If cond is null, this is a default {} block */
4229 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
4231 bool cond_llb = (!cond || looks_like_bool(cond));
4237 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
4239 scalar(ref_array_or_hash(cond)));
4242 return newGIVWHENOP(
4244 append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
4245 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
4249 =for apidoc cv_undef
4251 Clear out all the active components of a CV. This can happen either
4252 by an explicit C<undef &foo>, or by the reference count going to zero.
4253 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
4254 children can still follow the full lexical scope chain.
4260 Perl_cv_undef(pTHX_ CV *cv)
4264 if (CvFILE(cv) && !CvXSUB(cv)) {
4265 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4266 Safefree(CvFILE(cv));
4271 if (!CvXSUB(cv) && CvROOT(cv)) {
4273 Perl_croak(aTHX_ "Can't undef active subroutine");
4276 PAD_SAVE_SETNULLPAD();
4278 op_free(CvROOT(cv));
4279 CvROOT(cv) = Nullop;
4280 CvSTART(cv) = Nullop;
4283 SvPOK_off((SV*)cv); /* forget prototype */
4288 /* remove CvOUTSIDE unless this is an undef rather than a free */
4289 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
4290 if (!CvWEAKOUTSIDE(cv))
4291 SvREFCNT_dec(CvOUTSIDE(cv));
4292 CvOUTSIDE(cv) = Nullcv;
4295 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4301 /* delete all flags except WEAKOUTSIDE */
4302 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
4306 Perl_cv_ckproto(pTHX_ const CV *cv, const GV *gv, const char *p)
4308 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX_const(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4309 SV* const msg = sv_newmortal();
4313 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4314 sv_setpv(msg, "Prototype mismatch:");
4316 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4318 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (const SV *)cv);
4320 sv_catpvs(msg, ": none");
4321 sv_catpvs(msg, " vs ");
4323 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4325 sv_catpvs(msg, "none");
4326 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
4330 static void const_sv_xsub(pTHX_ CV* cv);
4334 =head1 Optree Manipulation Functions
4336 =for apidoc cv_const_sv
4338 If C<cv> is a constant sub eligible for inlining. returns the constant
4339 value returned by the sub. Otherwise, returns NULL.
4341 Constant subs can be created with C<newCONSTSUB> or as described in
4342 L<perlsub/"Constant Functions">.
4347 Perl_cv_const_sv(pTHX_ CV *cv)
4351 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
4353 return CvCONST(cv) ? (SV*)CvXSUBANY(cv).any_ptr : NULL;
4356 /* op_const_sv: examine an optree to determine whether it's in-lineable.
4357 * Can be called in 3 ways:
4360 * look for a single OP_CONST with attached value: return the value
4362 * cv && CvCLONE(cv) && !CvCONST(cv)
4364 * examine the clone prototype, and if contains only a single
4365 * OP_CONST referencing a pad const, or a single PADSV referencing
4366 * an outer lexical, return a non-zero value to indicate the CV is
4367 * a candidate for "constizing" at clone time
4371 * We have just cloned an anon prototype that was marked as a const
4372 * candidiate. Try to grab the current value, and in the case of
4373 * PADSV, ignore it if it has multiple references. Return the value.
4377 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
4385 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4386 o = cLISTOPo->op_first->op_sibling;
4388 for (; o; o = o->op_next) {
4389 const OPCODE type = o->op_type;
4391 if (sv && o->op_next == o)
4393 if (o->op_next != o) {
4394 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4396 if (type == OP_DBSTATE)
4399 if (type == OP_LEAVESUB || type == OP_RETURN)
4403 if (type == OP_CONST && cSVOPo->op_sv)
4405 else if (cv && type == OP_CONST) {
4406 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4410 else if (cv && type == OP_PADSV) {
4411 if (CvCONST(cv)) { /* newly cloned anon */
4412 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4413 /* the candidate should have 1 ref from this pad and 1 ref
4414 * from the parent */
4415 if (!sv || SvREFCNT(sv) != 2)
4422 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
4423 sv = &PL_sv_undef; /* an arbitrary non-null value */
4434 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4436 PERL_UNUSED_ARG(floor);
4446 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4450 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4452 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4456 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4463 register CV *cv = NULL;
4465 /* If the subroutine has no body, no attributes, and no builtin attributes
4466 then it's just a sub declaration, and we may be able to get away with
4467 storing with a placeholder scalar in the symbol table, rather than a
4468 full GV and CV. If anything is present then it will take a full CV to
4470 const I32 gv_fetch_flags
4471 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
4472 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
4473 const char * const name = o ? SvPVx_nolen_const(cSVOPo->op_sv) : Nullch;
4476 assert(proto->op_type == OP_CONST);
4477 ps = SvPVx_const(((SVOP*)proto)->op_sv, ps_len);
4482 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4483 SV * const sv = sv_newmortal();
4484 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4485 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
4486 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4487 aname = SvPVX_const(sv);
4492 gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
4493 : gv_fetchpv(aname ? aname
4494 : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4495 gv_fetch_flags, SVt_PVCV);
4504 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4505 maximum a prototype before. */
4506 if (SvTYPE(gv) > SVt_NULL) {
4507 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4508 && ckWARN_d(WARN_PROTOTYPE))
4510 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
4512 cv_ckproto((CV*)gv, NULL, ps);
4515 sv_setpvn((SV*)gv, ps, ps_len);
4517 sv_setiv((SV*)gv, -1);
4518 SvREFCNT_dec(PL_compcv);
4519 cv = PL_compcv = NULL;
4520 PL_sub_generation++;
4524 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4526 #ifdef GV_UNIQUE_CHECK
4527 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4528 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4532 if (!block || !ps || *ps || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
4535 const_sv = op_const_sv(block, Nullcv);
4538 const bool exists = CvROOT(cv) || CvXSUB(cv);
4540 #ifdef GV_UNIQUE_CHECK
4541 if (exists && GvUNIQUE(gv)) {
4542 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4546 /* if the subroutine doesn't exist and wasn't pre-declared
4547 * with a prototype, assume it will be AUTOLOADed,
4548 * skipping the prototype check
4550 if (exists || SvPOK(cv))
4551 cv_ckproto(cv, gv, ps);
4552 /* already defined (or promised)? */
4553 if (exists || GvASSUMECV(gv)) {
4554 if (!block && !attrs) {
4555 if (CvFLAGS(PL_compcv)) {
4556 /* might have had built-in attrs applied */
4557 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4559 /* just a "sub foo;" when &foo is already defined */
4560 SAVEFREESV(PL_compcv);
4564 if (ckWARN(WARN_REDEFINE)
4566 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4568 const line_t oldline = CopLINE(PL_curcop);
4569 if (PL_copline != NOLINE)
4570 CopLINE_set(PL_curcop, PL_copline);
4571 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4572 CvCONST(cv) ? "Constant subroutine %s redefined"
4573 : "Subroutine %s redefined", name);
4574 CopLINE_set(PL_curcop, oldline);
4582 (void)SvREFCNT_inc(const_sv);
4584 assert(!CvROOT(cv) && !CvCONST(cv));
4585 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
4586 CvXSUBANY(cv).any_ptr = const_sv;
4587 CvXSUB(cv) = const_sv_xsub;
4592 cv = newCONSTSUB(NULL, name, const_sv);
4595 SvREFCNT_dec(PL_compcv);
4597 PL_sub_generation++;
4604 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4605 * before we clobber PL_compcv.
4609 /* Might have had built-in attributes applied -- propagate them. */
4610 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4611 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4612 stash = GvSTASH(CvGV(cv));
4613 else if (CvSTASH(cv))
4614 stash = CvSTASH(cv);
4616 stash = PL_curstash;
4619 /* possibly about to re-define existing subr -- ignore old cv */
4620 rcv = (SV*)PL_compcv;
4621 if (name && GvSTASH(gv))
4622 stash = GvSTASH(gv);
4624 stash = PL_curstash;
4626 apply_attrs(stash, rcv, attrs, FALSE);
4628 if (cv) { /* must reuse cv if autoloaded */
4630 /* got here with just attrs -- work done, so bug out */
4631 SAVEFREESV(PL_compcv);
4634 /* transfer PL_compcv to cv */
4636 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4637 if (!CvWEAKOUTSIDE(cv))
4638 SvREFCNT_dec(CvOUTSIDE(cv));
4639 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4640 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
4641 CvOUTSIDE(PL_compcv) = 0;
4642 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4643 CvPADLIST(PL_compcv) = 0;
4644 /* inner references to PL_compcv must be fixed up ... */
4645 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
4646 /* ... before we throw it away */
4647 SvREFCNT_dec(PL_compcv);
4649 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4650 ++PL_sub_generation;
4657 PL_sub_generation++;
4661 CvFILE_set_from_cop(cv, PL_curcop);
4662 CvSTASH(cv) = PL_curstash;
4665 sv_setpvn((SV*)cv, ps, ps_len);
4667 if (PL_error_count) {
4671 const char *s = strrchr(name, ':');
4673 if (strEQ(s, "BEGIN")) {
4674 const char not_safe[] =
4675 "BEGIN not safe after errors--compilation aborted";
4676 if (PL_in_eval & EVAL_KEEPERR)
4677 Perl_croak(aTHX_ not_safe);
4679 /* force display of errors found but not reported */
4680 sv_catpv(ERRSV, not_safe);
4681 Perl_croak(aTHX_ "%"SVf, ERRSV);
4690 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4691 mod(scalarseq(block), OP_LEAVESUBLV));
4694 /* This makes sub {}; work as expected. */
4695 if (block->op_type == OP_STUB) {
4697 block = newSTATEOP(0, Nullch, 0);
4699 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4701 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4702 OpREFCNT_set(CvROOT(cv), 1);
4703 CvSTART(cv) = LINKLIST(CvROOT(cv));
4704 CvROOT(cv)->op_next = 0;
4705 CALL_PEEP(CvSTART(cv));
4707 /* now that optimizer has done its work, adjust pad values */
4709 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4712 assert(!CvCONST(cv));
4713 if (ps && !*ps && op_const_sv(block, cv))
4717 if (name || aname) {
4719 const char * const tname = (name ? name : aname);
4721 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4722 SV * const sv = newSV(0);
4723 SV * const tmpstr = sv_newmortal();
4724 GV * const db_postponed = gv_fetchpvs("DB::postponed",
4725 GV_ADDMULTI, SVt_PVHV);
4728 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4730 (long)PL_subline, (long)CopLINE(PL_curcop));
4731 gv_efullname3(tmpstr, gv, Nullch);
4732 hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0);
4733 hv = GvHVn(db_postponed);
4734 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
4735 CV * const pcv = GvCV(db_postponed);
4741 call_sv((SV*)pcv, G_DISCARD);
4746 if ((s = strrchr(tname,':')))
4751 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4754 if (strEQ(s, "BEGIN") && !PL_error_count) {
4755 const I32 oldscope = PL_scopestack_ix;
4757 SAVECOPFILE(&PL_compiling);
4758 SAVECOPLINE(&PL_compiling);
4761 PL_beginav = newAV();
4762 DEBUG_x( dump_sub(gv) );
4763 av_push(PL_beginav, (SV*)cv);
4764 GvCV(gv) = 0; /* cv has been hijacked */
4765 call_list(oldscope, PL_beginav);
4767 PL_curcop = &PL_compiling;
4768 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4771 else if (strEQ(s, "END") && !PL_error_count) {
4774 DEBUG_x( dump_sub(gv) );
4775 av_unshift(PL_endav, 1);
4776 av_store(PL_endav, 0, (SV*)cv);
4777 GvCV(gv) = 0; /* cv has been hijacked */
4779 else if (strEQ(s, "CHECK") && !PL_error_count) {
4781 PL_checkav = newAV();
4782 DEBUG_x( dump_sub(gv) );
4783 if (PL_main_start && ckWARN(WARN_VOID))
4784 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4785 av_unshift(PL_checkav, 1);
4786 av_store(PL_checkav, 0, (SV*)cv);
4787 GvCV(gv) = 0; /* cv has been hijacked */
4789 else if (strEQ(s, "INIT") && !PL_error_count) {
4791 PL_initav = newAV();
4792 DEBUG_x( dump_sub(gv) );
4793 if (PL_main_start && ckWARN(WARN_VOID))
4794 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4795 av_push(PL_initav, (SV*)cv);
4796 GvCV(gv) = 0; /* cv has been hijacked */
4801 PL_copline = NOLINE;
4806 /* XXX unsafe for threads if eval_owner isn't held */
4808 =for apidoc newCONSTSUB
4810 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4811 eligible for inlining at compile-time.
4817 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
4824 SAVECOPLINE(PL_curcop);
4825 CopLINE_set(PL_curcop, PL_copline);
4828 PL_hints &= ~HINT_BLOCK_SCOPE;
4831 SAVESPTR(PL_curstash);
4832 SAVECOPSTASH(PL_curcop);
4833 PL_curstash = stash;
4834 CopSTASH_set(PL_curcop,stash);
4837 cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
4838 CvXSUBANY(cv).any_ptr = sv;
4840 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
4844 CopSTASH_free(PL_curcop);
4852 =for apidoc U||newXS
4854 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4860 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
4863 GV * const gv = gv_fetchpv(name ? name :
4864 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4865 GV_ADDMULTI, SVt_PVCV);
4869 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4871 if ((cv = (name ? GvCV(gv) : Nullcv))) {
4873 /* just a cached method */
4877 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4878 /* already defined (or promised) */
4879 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
4880 if (ckWARN(WARN_REDEFINE)) {
4881 GV * const gvcv = CvGV(cv);
4883 HV * const stash = GvSTASH(gvcv);
4885 const char *name = HvNAME_get(stash);
4886 if ( strEQ(name,"autouse") ) {
4887 const line_t oldline = CopLINE(PL_curcop);
4888 if (PL_copline != NOLINE)
4889 CopLINE_set(PL_curcop, PL_copline);
4890 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4891 CvCONST(cv) ? "Constant subroutine %s redefined"
4892 : "Subroutine %s redefined"
4894 CopLINE_set(PL_curcop, oldline);
4904 if (cv) /* must reuse cv if autoloaded */
4908 sv_upgrade((SV *)cv, SVt_PVCV);
4912 PL_sub_generation++;
4916 (void)gv_fetchfile(filename);
4917 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
4918 an external constant string */
4919 CvXSUB(cv) = subaddr;
4922 const char *s = strrchr(name,':');
4928 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4931 if (strEQ(s, "BEGIN")) {
4933 PL_beginav = newAV();
4934 av_push(PL_beginav, (SV*)cv);
4935 GvCV(gv) = 0; /* cv has been hijacked */
4937 else if (strEQ(s, "END")) {
4940 av_unshift(PL_endav, 1);
4941 av_store(PL_endav, 0, (SV*)cv);
4942 GvCV(gv) = 0; /* cv has been hijacked */
4944 else if (strEQ(s, "CHECK")) {
4946 PL_checkav = newAV();
4947 if (PL_main_start && ckWARN(WARN_VOID))
4948 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4949 av_unshift(PL_checkav, 1);
4950 av_store(PL_checkav, 0, (SV*)cv);
4951 GvCV(gv) = 0; /* cv has been hijacked */
4953 else if (strEQ(s, "INIT")) {
4955 PL_initav = newAV();
4956 if (PL_main_start && ckWARN(WARN_VOID))
4957 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4958 av_push(PL_initav, (SV*)cv);
4959 GvCV(gv) = 0; /* cv has been hijacked */
4970 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4976 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
4977 : gv_fetchpvs("STDOUT", GV_ADD, SVt_PVFM);
4979 #ifdef GV_UNIQUE_CHECK
4981 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
4985 if ((cv = GvFORM(gv))) {
4986 if (ckWARN(WARN_REDEFINE)) {
4987 const line_t oldline = CopLINE(PL_curcop);
4988 if (PL_copline != NOLINE)
4989 CopLINE_set(PL_curcop, PL_copline);
4990 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4991 o ? "Format %"SVf" redefined"
4992 : "Format STDOUT redefined" ,cSVOPo->op_sv);
4993 CopLINE_set(PL_curcop, oldline);
5000 CvFILE_set_from_cop(cv, PL_curcop);
5003 pad_tidy(padtidy_FORMAT);
5004 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5005 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5006 OpREFCNT_set(CvROOT(cv), 1);
5007 CvSTART(cv) = LINKLIST(CvROOT(cv));
5008 CvROOT(cv)->op_next = 0;
5009 CALL_PEEP(CvSTART(cv));
5011 PL_copline = NOLINE;
5016 Perl_newANONLIST(pTHX_ OP *o)
5018 return newUNOP(OP_REFGEN, 0,
5019 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5023 Perl_newANONHASH(pTHX_ OP *o)
5025 return newUNOP(OP_REFGEN, 0,
5026 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5030 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5032 return newANONATTRSUB(floor, proto, Nullop, block);
5036 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5038 return newUNOP(OP_REFGEN, 0,
5039 newSVOP(OP_ANONCODE, 0,
5040 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5044 Perl_oopsAV(pTHX_ OP *o)
5047 switch (o->op_type) {
5049 o->op_type = OP_PADAV;
5050 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5051 return ref(o, OP_RV2AV);
5054 o->op_type = OP_RV2AV;
5055 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5060 if (ckWARN_d(WARN_INTERNAL))
5061 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
5068 Perl_oopsHV(pTHX_ OP *o)
5071 switch (o->op_type) {
5074 o->op_type = OP_PADHV;
5075 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5076 return ref(o, OP_RV2HV);
5080 o->op_type = OP_RV2HV;
5081 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5086 if (ckWARN_d(WARN_INTERNAL))
5087 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
5094 Perl_newAVREF(pTHX_ OP *o)
5097 if (o->op_type == OP_PADANY) {
5098 o->op_type = OP_PADAV;
5099 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5102 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5103 && ckWARN(WARN_DEPRECATED)) {
5104 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5105 "Using an array as a reference is deprecated");
5107 return newUNOP(OP_RV2AV, 0, scalar(o));
5111 Perl_newGVREF(pTHX_ I32 type, OP *o)
5113 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5114 return newUNOP(OP_NULL, 0, o);
5115 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5119 Perl_newHVREF(pTHX_ OP *o)
5122 if (o->op_type == OP_PADANY) {
5123 o->op_type = OP_PADHV;
5124 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5127 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5128 && ckWARN(WARN_DEPRECATED)) {
5129 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5130 "Using a hash as a reference is deprecated");
5132 return newUNOP(OP_RV2HV, 0, scalar(o));
5136 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5138 return newUNOP(OP_RV2CV, flags, scalar(o));
5142 Perl_newSVREF(pTHX_ OP *o)
5145 if (o->op_type == OP_PADANY) {
5146 o->op_type = OP_PADSV;
5147 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5150 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5151 o->op_flags |= OPpDONE_SVREF;
5154 return newUNOP(OP_RV2SV, 0, scalar(o));
5157 /* Check routines. See the comments at the top of this file for details
5158 * on when these are called */
5161 Perl_ck_anoncode(pTHX_ OP *o)
5163 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
5164 cSVOPo->op_sv = Nullsv;
5169 Perl_ck_bitop(pTHX_ OP *o)
5172 #define OP_IS_NUMCOMPARE(op) \
5173 ((op) == OP_LT || (op) == OP_I_LT || \
5174 (op) == OP_GT || (op) == OP_I_GT || \
5175 (op) == OP_LE || (op) == OP_I_LE || \
5176 (op) == OP_GE || (op) == OP_I_GE || \
5177 (op) == OP_EQ || (op) == OP_I_EQ || \
5178 (op) == OP_NE || (op) == OP_I_NE || \
5179 (op) == OP_NCMP || (op) == OP_I_NCMP)
5180 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
5181 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
5182 && (o->op_type == OP_BIT_OR
5183 || o->op_type == OP_BIT_AND
5184 || o->op_type == OP_BIT_XOR))
5186 const OP * const left = cBINOPo->op_first;
5187 const OP * const right = left->op_sibling;
5188 if ((OP_IS_NUMCOMPARE(left->op_type) &&
5189 (left->op_flags & OPf_PARENS) == 0) ||
5190 (OP_IS_NUMCOMPARE(right->op_type) &&
5191 (right->op_flags & OPf_PARENS) == 0))
5192 if (ckWARN(WARN_PRECEDENCE))
5193 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
5194 "Possible precedence problem on bitwise %c operator",
5195 o->op_type == OP_BIT_OR ? '|'
5196 : o->op_type == OP_BIT_AND ? '&' : '^'
5203 Perl_ck_concat(pTHX_ OP *o)
5205 const OP * const kid = cUNOPo->op_first;
5206 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
5207 !(kUNOP->op_first->op_flags & OPf_MOD))
5208 o->op_flags |= OPf_STACKED;
5213 Perl_ck_spair(pTHX_ OP *o)
5216 if (o->op_flags & OPf_KIDS) {
5219 const OPCODE type = o->op_type;
5220 o = modkids(ck_fun(o), type);
5221 kid = cUNOPo->op_first;
5222 newop = kUNOP->op_first->op_sibling;
5224 (newop->op_sibling ||
5225 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5226 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5227 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5231 op_free(kUNOP->op_first);
5232 kUNOP->op_first = newop;
5234 o->op_ppaddr = PL_ppaddr[++o->op_type];
5239 Perl_ck_delete(pTHX_ OP *o)
5243 if (o->op_flags & OPf_KIDS) {
5244 OP * const kid = cUNOPo->op_first;
5245 switch (kid->op_type) {
5247 o->op_flags |= OPf_SPECIAL;
5250 o->op_private |= OPpSLICE;
5253 o->op_flags |= OPf_SPECIAL;
5258 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5267 Perl_ck_die(pTHX_ OP *o)
5270 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5276 Perl_ck_eof(pTHX_ OP *o)
5279 const I32 type = o->op_type;
5281 if (o->op_flags & OPf_KIDS) {
5282 if (cLISTOPo->op_first->op_type == OP_STUB) {
5284 o = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
5292 Perl_ck_eval(pTHX_ OP *o)
5295 PL_hints |= HINT_BLOCK_SCOPE;
5296 if (o->op_flags & OPf_KIDS) {
5297 SVOP * const kid = (SVOP*)cUNOPo->op_first;
5300 o->op_flags &= ~OPf_KIDS;
5303 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
5306 cUNOPo->op_first = 0;
5309 NewOp(1101, enter, 1, LOGOP);
5310 enter->op_type = OP_ENTERTRY;
5311 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5312 enter->op_private = 0;
5314 /* establish postfix order */
5315 enter->op_next = (OP*)enter;
5317 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5318 o->op_type = OP_LEAVETRY;
5319 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5320 enter->op_other = o;
5330 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5332 o->op_targ = (PADOFFSET)PL_hints;
5333 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
5334 /* Store a copy of %^H that pp_entereval can pick up */
5335 OP *hhop = newSVOP(OP_CONST, 0, (SV*)newHVhv(GvHV(PL_hintgv)));
5336 cUNOPo->op_first->op_sibling = hhop;
5337 o->op_private |= OPpEVAL_HAS_HH;
5343 Perl_ck_exit(pTHX_ OP *o)
5346 HV * const table = GvHV(PL_hintgv);
5348 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
5349 if (svp && *svp && SvTRUE(*svp))
5350 o->op_private |= OPpEXIT_VMSISH;
5352 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5358 Perl_ck_exec(pTHX_ OP *o)
5360 if (o->op_flags & OPf_STACKED) {
5363 kid = cUNOPo->op_first->op_sibling;
5364 if (kid->op_type == OP_RV2GV)
5373 Perl_ck_exists(pTHX_ OP *o)
5377 if (o->op_flags & OPf_KIDS) {
5378 OP * const kid = cUNOPo->op_first;
5379 if (kid->op_type == OP_ENTERSUB) {
5380 (void) ref(kid, o->op_type);
5381 if (kid->op_type != OP_RV2CV && !PL_error_count)
5382 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5384 o->op_private |= OPpEXISTS_SUB;
5386 else if (kid->op_type == OP_AELEM)
5387 o->op_flags |= OPf_SPECIAL;
5388 else if (kid->op_type != OP_HELEM)
5389 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5397 Perl_ck_rvconst(pTHX_ register OP *o)
5400 SVOP * const kid = (SVOP*)cUNOPo->op_first;
5402 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5403 if (o->op_type == OP_RV2CV)
5404 o->op_private &= ~1;
5406 if (kid->op_type == OP_CONST) {
5409 SV * const kidsv = kid->op_sv;
5411 /* Is it a constant from cv_const_sv()? */
5412 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5413 SV * const rsv = SvRV(kidsv);
5414 const int svtype = SvTYPE(rsv);
5415 const char *badtype = Nullch;
5417 switch (o->op_type) {
5419 if (svtype > SVt_PVMG)
5420 badtype = "a SCALAR";
5423 if (svtype != SVt_PVAV)
5424 badtype = "an ARRAY";
5427 if (svtype != SVt_PVHV)
5431 if (svtype != SVt_PVCV)
5436 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5439 else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
5440 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
5441 /* If this is an access to a stash, disable "strict refs", because
5442 * stashes aren't auto-vivified at compile-time (unless we store
5443 * symbols in them), and we don't want to produce a run-time
5444 * stricture error when auto-vivifying the stash. */
5445 const char *s = SvPV_nolen(kidsv);
5446 const STRLEN l = SvCUR(kidsv);
5447 if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
5448 o->op_private &= ~HINT_STRICT_REFS;
5450 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5451 const char *badthing = Nullch;
5452 switch (o->op_type) {
5454 badthing = "a SCALAR";
5457 badthing = "an ARRAY";
5460 badthing = "a HASH";
5465 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
5469 * This is a little tricky. We only want to add the symbol if we
5470 * didn't add it in the lexer. Otherwise we get duplicate strict
5471 * warnings. But if we didn't add it in the lexer, we must at
5472 * least pretend like we wanted to add it even if it existed before,
5473 * or we get possible typo warnings. OPpCONST_ENTERED says
5474 * whether the lexer already added THIS instance of this symbol.
5476 iscv = (o->op_type == OP_RV2CV) * 2;
5478 gv = gv_fetchsv(kidsv,
5479 iscv | !(kid->op_private & OPpCONST_ENTERED),
5482 : o->op_type == OP_RV2SV
5484 : o->op_type == OP_RV2AV
5486 : o->op_type == OP_RV2HV
5489 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5491 kid->op_type = OP_GV;
5492 SvREFCNT_dec(kid->op_sv);
5494 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5495 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5496 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
5498 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv));
5500 kid->op_sv = SvREFCNT_inc(gv);
5502 kid->op_private = 0;
5503 kid->op_ppaddr = PL_ppaddr[OP_GV];
5510 Perl_ck_ftst(pTHX_ OP *o)
5513 const I32 type = o->op_type;
5515 if (o->op_flags & OPf_REF) {
5518 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5519 SVOP * const kid = (SVOP*)cUNOPo->op_first;
5521 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5522 OP * const newop = newGVOP(type, OPf_REF,
5523 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
5529 if ((PL_hints & HINT_FILETEST_ACCESS) &&
5530 OP_IS_FILETEST_ACCESS(o))
5531 o->op_private |= OPpFT_ACCESS;
5533 if (PL_check[kid->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst)
5534 && kid->op_type != OP_STAT && kid->op_type != OP_LSTAT)
5535 o->op_private |= OPpFT_STACKED;
5539 if (type == OP_FTTTY)
5540 o = newGVOP(type, OPf_REF, PL_stdingv);
5542 o = newUNOP(type, 0, newDEFSVOP());
5548 Perl_ck_fun(pTHX_ OP *o)
5551 const int type = o->op_type;
5552 register I32 oa = PL_opargs[type] >> OASHIFT;
5554 if (o->op_flags & OPf_STACKED) {
5555 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5558 return no_fh_allowed(o);
5561 if (o->op_flags & OPf_KIDS) {
5562 OP **tokid = &cLISTOPo->op_first;
5563 register OP *kid = cLISTOPo->op_first;
5567 if (kid->op_type == OP_PUSHMARK ||
5568 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5570 tokid = &kid->op_sibling;
5571 kid = kid->op_sibling;
5573 if (!kid && PL_opargs[type] & OA_DEFGV)
5574 *tokid = kid = newDEFSVOP();
5578 sibl = kid->op_sibling;
5581 /* list seen where single (scalar) arg expected? */
5582 if (numargs == 1 && !(oa >> 4)
5583 && kid->op_type == OP_LIST && type != OP_SCALAR)
5585 return too_many_arguments(o,PL_op_desc[type]);
5598 if ((type == OP_PUSH || type == OP_UNSHIFT)
5599 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5600 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5601 "Useless use of %s with no values",
5604 if (kid->op_type == OP_CONST &&
5605 (kid->op_private & OPpCONST_BARE))
5607 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
5608 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
5609 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5610 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5611 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
5612 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
5615 kid->op_sibling = sibl;
5618 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5619 bad_type(numargs, "array", PL_op_desc[type], kid);
5623 if (kid->op_type == OP_CONST &&
5624 (kid->op_private & OPpCONST_BARE))
5626 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
5627 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
5628 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5629 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5630 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
5631 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
5634 kid->op_sibling = sibl;
5637 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5638 bad_type(numargs, "hash", PL_op_desc[type], kid);
5643 OP * const newop = newUNOP(OP_NULL, 0, kid);
5644 kid->op_sibling = 0;
5646 newop->op_next = newop;
5648 kid->op_sibling = sibl;
5653 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5654 if (kid->op_type == OP_CONST &&
5655 (kid->op_private & OPpCONST_BARE))
5657 OP * const newop = newGVOP(OP_GV, 0,
5658 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
5659 if (!(o->op_private & 1) && /* if not unop */
5660 kid == cLISTOPo->op_last)
5661 cLISTOPo->op_last = newop;
5665 else if (kid->op_type == OP_READLINE) {
5666 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5667 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5670 I32 flags = OPf_SPECIAL;
5674 /* is this op a FH constructor? */
5675 if (is_handle_constructor(o,numargs)) {
5676 const char *name = Nullch;
5680 /* Set a flag to tell rv2gv to vivify
5681 * need to "prove" flag does not mean something
5682 * else already - NI-S 1999/05/07
5685 if (kid->op_type == OP_PADSV) {
5686 name = PAD_COMPNAME_PV(kid->op_targ);
5687 /* SvCUR of a pad namesv can't be trusted
5688 * (see PL_generation), so calc its length
5694 else if (kid->op_type == OP_RV2SV
5695 && kUNOP->op_first->op_type == OP_GV)
5697 GV * const gv = cGVOPx_gv(kUNOP->op_first);
5699 len = GvNAMELEN(gv);
5701 else if (kid->op_type == OP_AELEM
5702 || kid->op_type == OP_HELEM)
5704 OP *op = ((BINOP*)kid)->op_first;
5707 SV *tmpstr = Nullsv;
5708 const char * const a =
5709 kid->op_type == OP_AELEM ?
5711 if (((op->op_type == OP_RV2AV) ||
5712 (op->op_type == OP_RV2HV)) &&
5713 (op = ((UNOP*)op)->op_first) &&
5714 (op->op_type == OP_GV)) {
5715 /* packagevar $a[] or $h{} */
5716 GV * const gv = cGVOPx_gv(op);
5724 else if (op->op_type == OP_PADAV
5725 || op->op_type == OP_PADHV) {
5726 /* lexicalvar $a[] or $h{} */
5727 const char * const padname =
5728 PAD_COMPNAME_PV(op->op_targ);
5737 name = SvPV_const(tmpstr, len);
5742 name = "__ANONIO__";
5749 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5750 namesv = PAD_SVl(targ);
5751 SvUPGRADE(namesv, SVt_PV);
5753 sv_setpvn(namesv, "$", 1);
5754 sv_catpvn(namesv, name, len);
5757 kid->op_sibling = 0;
5758 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5759 kid->op_targ = targ;
5760 kid->op_private |= priv;
5762 kid->op_sibling = sibl;
5768 mod(scalar(kid), type);
5772 tokid = &kid->op_sibling;
5773 kid = kid->op_sibling;
5775 o->op_private |= numargs;
5777 return too_many_arguments(o,OP_DESC(o));
5780 else if (PL_opargs[type] & OA_DEFGV) {
5782 return newUNOP(type, 0, newDEFSVOP());
5786 while (oa & OA_OPTIONAL)
5788 if (oa && oa != OA_LIST)
5789 return too_few_arguments(o,OP_DESC(o));
5795 Perl_ck_glob(pTHX_ OP *o)
5801 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5802 append_elem(OP_GLOB, o, newDEFSVOP());
5804 if (!((gv = gv_fetchpvs("glob", 0, SVt_PVCV))
5805 && GvCVu(gv) && GvIMPORTED_CV(gv)))
5807 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
5810 #if !defined(PERL_EXTERNAL_GLOB)
5811 /* XXX this can be tightened up and made more failsafe. */
5812 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
5815 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5816 newSVpvs("File::Glob"), Nullsv, Nullsv, Nullsv);
5817 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
5818 glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
5819 GvCV(gv) = GvCV(glob_gv);
5820 (void)SvREFCNT_inc((SV*)GvCV(gv));
5821 GvIMPORTED_CV_on(gv);
5824 #endif /* PERL_EXTERNAL_GLOB */
5826 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5827 append_elem(OP_GLOB, o,
5828 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5829 o->op_type = OP_LIST;
5830 o->op_ppaddr = PL_ppaddr[OP_LIST];
5831 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5832 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5833 cLISTOPo->op_first->op_targ = 0;
5834 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5835 append_elem(OP_LIST, o,
5836 scalar(newUNOP(OP_RV2CV, 0,
5837 newGVOP(OP_GV, 0, gv)))));
5838 o = newUNOP(OP_NULL, 0, ck_subr(o));
5839 o->op_targ = OP_GLOB; /* hint at what it used to be */
5842 gv = newGVgen("main");
5844 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5850 Perl_ck_grep(pTHX_ OP *o)
5855 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5858 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5859 NewOp(1101, gwop, 1, LOGOP);
5861 if (o->op_flags & OPf_STACKED) {
5864 kid = cLISTOPo->op_first->op_sibling;
5865 if (!cUNOPx(kid)->op_next)
5866 Perl_croak(aTHX_ "panic: ck_grep");
5867 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
5870 kid->op_next = (OP*)gwop;
5871 o->op_flags &= ~OPf_STACKED;
5873 kid = cLISTOPo->op_first->op_sibling;
5874 if (type == OP_MAPWHILE)
5881 kid = cLISTOPo->op_first->op_sibling;
5882 if (kid->op_type != OP_NULL)
5883 Perl_croak(aTHX_ "panic: ck_grep");
5884 kid = kUNOP->op_first;
5886 gwop->op_type = type;
5887 gwop->op_ppaddr = PL_ppaddr[type];
5888 gwop->op_first = listkids(o);
5889 gwop->op_flags |= OPf_KIDS;
5890 gwop->op_other = LINKLIST(kid);
5891 kid->op_next = (OP*)gwop;
5892 offset = pad_findmy("$_");
5893 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
5894 o->op_private = gwop->op_private = 0;
5895 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5898 o->op_private = gwop->op_private = OPpGREP_LEX;
5899 gwop->op_targ = o->op_targ = offset;
5902 kid = cLISTOPo->op_first->op_sibling;
5903 if (!kid || !kid->op_sibling)
5904 return too_few_arguments(o,OP_DESC(o));
5905 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5906 mod(kid, OP_GREPSTART);
5912 Perl_ck_index(pTHX_ OP *o)
5914 if (o->op_flags & OPf_KIDS) {
5915 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5917 kid = kid->op_sibling; /* get past "big" */
5918 if (kid && kid->op_type == OP_CONST)
5919 fbm_compile(((SVOP*)kid)->op_sv, 0);
5925 Perl_ck_lengthconst(pTHX_ OP *o)
5927 /* XXX length optimization goes here */
5932 Perl_ck_lfun(pTHX_ OP *o)
5934 const OPCODE type = o->op_type;
5935 return modkids(ck_fun(o), type);
5939 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5941 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
5942 switch (cUNOPo->op_first->op_type) {
5944 /* This is needed for
5945 if (defined %stash::)
5946 to work. Do not break Tk.
5948 break; /* Globals via GV can be undef */
5950 case OP_AASSIGN: /* Is this a good idea? */
5951 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5952 "defined(@array) is deprecated");
5953 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5954 "\t(Maybe you should just omit the defined()?)\n");
5957 /* This is needed for
5958 if (defined %stash::)
5959 to work. Do not break Tk.
5961 break; /* Globals via GV can be undef */
5963 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5964 "defined(%%hash) is deprecated");
5965 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5966 "\t(Maybe you should just omit the defined()?)\n");
5977 Perl_ck_rfun(pTHX_ OP *o)
5979 const OPCODE type = o->op_type;
5980 return refkids(ck_fun(o), type);
5984 Perl_ck_listiob(pTHX_ OP *o)
5988 kid = cLISTOPo->op_first;
5991 kid = cLISTOPo->op_first;
5993 if (kid->op_type == OP_PUSHMARK)
5994 kid = kid->op_sibling;
5995 if (kid && o->op_flags & OPf_STACKED)
5996 kid = kid->op_sibling;
5997 else if (kid && !kid->op_sibling) { /* print HANDLE; */
5998 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5999 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6000 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6001 cLISTOPo->op_first->op_sibling = kid;
6002 cLISTOPo->op_last = kid;
6003 kid = kid->op_sibling;
6008 append_elem(o->op_type, o, newDEFSVOP());
6014 Perl_ck_say(pTHX_ OP *o)
6017 o->op_type = OP_PRINT;
6018 cLISTOPo->op_last = cLISTOPo->op_last->op_sibling
6019 = newSVOP(OP_CONST, 0, newSVpvs("\n"));
6024 Perl_ck_smartmatch(pTHX_ OP *o)
6027 if (0 == (o->op_flags & OPf_SPECIAL)) {
6028 OP *first = cBINOPo->op_first;
6029 OP *second = first->op_sibling;
6031 /* Implicitly take a reference to an array or hash */
6032 first->op_sibling = Nullop;
6033 first = cBINOPo->op_first = ref_array_or_hash(first);
6034 second = first->op_sibling = ref_array_or_hash(second);
6036 /* Implicitly take a reference to a regular expression */
6037 if (first->op_type == OP_MATCH) {
6038 first->op_type = OP_QR;
6039 first->op_ppaddr = PL_ppaddr[OP_QR];
6041 if (second->op_type == OP_MATCH) {
6042 second->op_type = OP_QR;
6043 second->op_ppaddr = PL_ppaddr[OP_QR];
6052 Perl_ck_sassign(pTHX_ OP *o)
6054 OP *kid = cLISTOPo->op_first;
6055 /* has a disposable target? */
6056 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6057 && !(kid->op_flags & OPf_STACKED)
6058 /* Cannot steal the second time! */
6059 && !(kid->op_private & OPpTARGET_MY))
6061 OP * const kkid = kid->op_sibling;
6063 /* Can just relocate the target. */
6064 if (kkid && kkid->op_type == OP_PADSV
6065 && !(kkid->op_private & OPpLVAL_INTRO))
6067 kid->op_targ = kkid->op_targ;
6069 /* Now we do not need PADSV and SASSIGN. */
6070 kid->op_sibling = o->op_sibling; /* NULL */
6071 cLISTOPo->op_first = NULL;
6074 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6082 Perl_ck_match(pTHX_ OP *o)
6085 if (o->op_type != OP_QR && PL_compcv) {
6086 const I32 offset = pad_findmy("$_");
6087 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS(offset) & SVpad_OUR)) {
6088 o->op_targ = offset;
6089 o->op_private |= OPpTARGET_MY;
6092 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
6093 o->op_private |= OPpRUNTIME;
6098 Perl_ck_method(pTHX_ OP *o)
6100 OP * const kid = cUNOPo->op_first;
6101 if (kid->op_type == OP_CONST) {
6102 SV* sv = kSVOP->op_sv;
6103 const char * const method = SvPVX_const(sv);
6104 if (!(strchr(method, ':') || strchr(method, '\''))) {
6106 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6107 sv = newSVpvn_share(method, SvCUR(sv), 0);
6110 kSVOP->op_sv = Nullsv;
6112 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6121 Perl_ck_null(pTHX_ OP *o)
6127 Perl_ck_open(pTHX_ OP *o)
6130 HV * const table = GvHV(PL_hintgv);
6132 SV **svp = hv_fetchs(table, "open_IN", FALSE);
6134 const I32 mode = mode_from_discipline(*svp);
6135 if (mode & O_BINARY)
6136 o->op_private |= OPpOPEN_IN_RAW;
6137 else if (mode & O_TEXT)
6138 o->op_private |= OPpOPEN_IN_CRLF;
6141 svp = hv_fetchs(table, "open_OUT", FALSE);
6143 const I32 mode = mode_from_discipline(*svp);
6144 if (mode & O_BINARY)
6145 o->op_private |= OPpOPEN_OUT_RAW;
6146 else if (mode & O_TEXT)
6147 o->op_private |= OPpOPEN_OUT_CRLF;
6150 if (o->op_type == OP_BACKTICK)
6153 /* In case of three-arg dup open remove strictness
6154 * from the last arg if it is a bareword. */
6155 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
6156 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
6160 if ((last->op_type == OP_CONST) && /* The bareword. */
6161 (last->op_private & OPpCONST_BARE) &&
6162 (last->op_private & OPpCONST_STRICT) &&
6163 (oa = first->op_sibling) && /* The fh. */
6164 (oa = oa->op_sibling) && /* The mode. */
6165 (oa->op_type == OP_CONST) &&
6166 SvPOK(((SVOP*)oa)->op_sv) &&
6167 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
6168 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
6169 (last == oa->op_sibling)) /* The bareword. */
6170 last->op_private &= ~OPpCONST_STRICT;
6176 Perl_ck_repeat(pTHX_ OP *o)
6178 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6179 o->op_private |= OPpREPEAT_DOLIST;
6180 cBINOPo->op_first = force_list(cBINOPo->op_first);
6188 Perl_ck_require(pTHX_ OP *o)
6193 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6194 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6196 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6197 SV * const sv = kid->op_sv;
6198 U32 was_readonly = SvREADONLY(sv);
6203 sv_force_normal_flags(sv, 0);
6204 assert(!SvREADONLY(sv));
6211 for (s = SvPVX(sv); *s; s++) {
6212 if (*s == ':' && s[1] == ':') {
6213 const STRLEN len = strlen(s+2)+1;
6215 Move(s+2, s+1, len, char);
6216 SvCUR_set(sv, SvCUR(sv) - 1);
6219 sv_catpvs(sv, ".pm");
6220 SvFLAGS(sv) |= was_readonly;
6224 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
6225 /* handle override, if any */
6226 gv = gv_fetchpvs("require", 0, SVt_PVCV);
6227 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
6228 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
6229 gv = gvp ? *gvp : Nullgv;
6233 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6234 OP * const kid = cUNOPo->op_first;
6235 cUNOPo->op_first = 0;
6237 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
6238 append_elem(OP_LIST, kid,
6239 scalar(newUNOP(OP_RV2CV, 0,
6248 Perl_ck_return(pTHX_ OP *o)
6251 if (CvLVALUE(PL_compcv)) {
6253 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6254 mod(kid, OP_LEAVESUBLV);
6260 Perl_ck_select(pTHX_ OP *o)
6264 if (o->op_flags & OPf_KIDS) {
6265 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6266 if (kid && kid->op_sibling) {
6267 o->op_type = OP_SSELECT;
6268 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6270 return fold_constants(o);
6274 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6275 if (kid && kid->op_type == OP_RV2GV)
6276 kid->op_private &= ~HINT_STRICT_REFS;
6281 Perl_ck_shift(pTHX_ OP *o)
6284 const I32 type = o->op_type;
6286 if (!(o->op_flags & OPf_KIDS)) {
6290 argop = newUNOP(OP_RV2AV, 0,
6291 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
6292 return newUNOP(type, 0, scalar(argop));
6294 return scalar(modkids(ck_fun(o), type));
6298 Perl_ck_sort(pTHX_ OP *o)
6303 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0)
6305 HV * const hinthv = GvHV(PL_hintgv);
6307 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
6309 const I32 sorthints = (I32)SvIV(*svp);
6310 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
6311 o->op_private |= OPpSORT_QSORT;
6312 if ((sorthints & HINT_SORT_STABLE) != 0)
6313 o->op_private |= OPpSORT_STABLE;
6318 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6320 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6321 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6323 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6325 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6327 if (kid->op_type == OP_SCOPE) {
6331 else if (kid->op_type == OP_LEAVE) {
6332 if (o->op_type == OP_SORT) {
6333 op_null(kid); /* wipe out leave */
6336 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6337 if (k->op_next == kid)
6339 /* don't descend into loops */
6340 else if (k->op_type == OP_ENTERLOOP
6341 || k->op_type == OP_ENTERITER)
6343 k = cLOOPx(k)->op_lastop;
6348 kid->op_next = 0; /* just disconnect the leave */
6349 k = kLISTOP->op_first;
6354 if (o->op_type == OP_SORT) {
6355 /* provide scalar context for comparison function/block */
6361 o->op_flags |= OPf_SPECIAL;
6363 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6366 firstkid = firstkid->op_sibling;
6369 /* provide list context for arguments */
6370 if (o->op_type == OP_SORT)
6377 S_simplify_sort(pTHX_ OP *o)
6380 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6385 if (!(o->op_flags & OPf_STACKED))
6387 GvMULTI_on(gv_fetchpvs("a", GV_ADD, SVt_PV));
6388 GvMULTI_on(gv_fetchpvs("b", GV_ADD, SVt_PV));
6389 kid = kUNOP->op_first; /* get past null */
6390 if (kid->op_type != OP_SCOPE)
6392 kid = kLISTOP->op_last; /* get past scope */
6393 switch(kid->op_type) {
6401 k = kid; /* remember this node*/
6402 if (kBINOP->op_first->op_type != OP_RV2SV)
6404 kid = kBINOP->op_first; /* get past cmp */
6405 if (kUNOP->op_first->op_type != OP_GV)
6407 kid = kUNOP->op_first; /* get past rv2sv */
6409 if (GvSTASH(gv) != PL_curstash)
6411 gvname = GvNAME(gv);
6412 if (*gvname == 'a' && gvname[1] == '\0')
6414 else if (*gvname == 'b' && gvname[1] == '\0')
6419 kid = k; /* back to cmp */
6420 if (kBINOP->op_last->op_type != OP_RV2SV)
6422 kid = kBINOP->op_last; /* down to 2nd arg */
6423 if (kUNOP->op_first->op_type != OP_GV)
6425 kid = kUNOP->op_first; /* get past rv2sv */
6427 if (GvSTASH(gv) != PL_curstash)
6429 gvname = GvNAME(gv);
6431 ? !(*gvname == 'a' && gvname[1] == '\0')
6432 : !(*gvname == 'b' && gvname[1] == '\0'))
6434 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6436 o->op_private |= OPpSORT_DESCEND;
6437 if (k->op_type == OP_NCMP)
6438 o->op_private |= OPpSORT_NUMERIC;
6439 if (k->op_type == OP_I_NCMP)
6440 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6441 kid = cLISTOPo->op_first->op_sibling;
6442 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6443 op_free(kid); /* then delete it */
6447 Perl_ck_split(pTHX_ OP *o)
6452 if (o->op_flags & OPf_STACKED)
6453 return no_fh_allowed(o);
6455 kid = cLISTOPo->op_first;
6456 if (kid->op_type != OP_NULL)
6457 Perl_croak(aTHX_ "panic: ck_split");
6458 kid = kid->op_sibling;
6459 op_free(cLISTOPo->op_first);
6460 cLISTOPo->op_first = kid;
6462 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
6463 cLISTOPo->op_last = kid; /* There was only one element previously */
6466 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6467 OP * const sibl = kid->op_sibling;
6468 kid->op_sibling = 0;
6469 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
6470 if (cLISTOPo->op_first == cLISTOPo->op_last)
6471 cLISTOPo->op_last = kid;
6472 cLISTOPo->op_first = kid;
6473 kid->op_sibling = sibl;
6476 kid->op_type = OP_PUSHRE;
6477 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6479 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
6480 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
6481 "Use of /g modifier is meaningless in split");
6484 if (!kid->op_sibling)
6485 append_elem(OP_SPLIT, o, newDEFSVOP());
6487 kid = kid->op_sibling;
6490 if (!kid->op_sibling)
6491 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6493 kid = kid->op_sibling;
6496 if (kid->op_sibling)
6497 return too_many_arguments(o,OP_DESC(o));
6503 Perl_ck_join(pTHX_ OP *o)
6505 const OP * const kid = cLISTOPo->op_first->op_sibling;
6506 if (kid && kid->op_type == OP_MATCH) {
6507 if (ckWARN(WARN_SYNTAX)) {
6508 const REGEXP *re = PM_GETRE(kPMOP);
6509 const char *pmstr = re ? re->precomp : "STRING";
6510 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6511 "/%s/ should probably be written as \"%s\"",
6519 Perl_ck_subr(pTHX_ OP *o)
6522 OP *prev = ((cUNOPo->op_first->op_sibling)
6523 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6524 OP *o2 = prev->op_sibling;
6531 I32 contextclass = 0;
6535 o->op_private |= OPpENTERSUB_HASTARG;
6536 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6537 if (cvop->op_type == OP_RV2CV) {
6539 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6540 op_null(cvop); /* disable rv2cv */
6541 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6542 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6543 GV *gv = cGVOPx_gv(tmpop);
6546 tmpop->op_private |= OPpEARLY_CV;
6549 namegv = CvANON(cv) ? gv : CvGV(cv);
6550 proto = SvPV_nolen((SV*)cv);
6552 if (CvASSERTION(cv)) {
6553 if (PL_hints & HINT_ASSERTING) {
6554 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
6555 o->op_private |= OPpENTERSUB_DB;
6559 if (!(PL_hints & HINT_ASSERTIONSSEEN) && ckWARN(WARN_ASSERTIONS)) {
6560 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
6561 "Impossible to activate assertion call");
6568 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6569 if (o2->op_type == OP_CONST)
6570 o2->op_private &= ~OPpCONST_STRICT;
6571 else if (o2->op_type == OP_LIST) {
6572 OP * const o = ((UNOP*)o2)->op_first->op_sibling;
6573 if (o && o->op_type == OP_CONST)
6574 o->op_private &= ~OPpCONST_STRICT;
6577 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6578 if (PERLDB_SUB && PL_curstash != PL_debstash)
6579 o->op_private |= OPpENTERSUB_DB;
6580 while (o2 != cvop) {
6584 return too_many_arguments(o, gv_ename(namegv));
6602 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6604 arg == 1 ? "block or sub {}" : "sub {}",
6605 gv_ename(namegv), o2);
6608 /* '*' allows any scalar type, including bareword */
6611 if (o2->op_type == OP_RV2GV)
6612 goto wrapref; /* autoconvert GLOB -> GLOBref */
6613 else if (o2->op_type == OP_CONST)
6614 o2->op_private &= ~OPpCONST_STRICT;
6615 else if (o2->op_type == OP_ENTERSUB) {
6616 /* accidental subroutine, revert to bareword */
6617 OP *gvop = ((UNOP*)o2)->op_first;
6618 if (gvop && gvop->op_type == OP_NULL) {
6619 gvop = ((UNOP*)gvop)->op_first;
6621 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6624 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6625 (gvop = ((UNOP*)gvop)->op_first) &&
6626 gvop->op_type == OP_GV)
6628 GV * const gv = cGVOPx_gv(gvop);
6629 OP * const sibling = o2->op_sibling;
6630 SV * const n = newSVpvs("");
6632 gv_fullname4(n, gv, "", FALSE);
6633 o2 = newSVOP(OP_CONST, 0, n);
6634 prev->op_sibling = o2;
6635 o2->op_sibling = sibling;
6651 if (contextclass++ == 0) {
6652 e = strchr(proto, ']');
6653 if (!e || e == proto)
6662 /* XXX We shouldn't be modifying proto, so we can const proto */
6667 while (*--p != '[');
6668 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
6669 gv_ename(namegv), o2);
6675 if (o2->op_type == OP_RV2GV)
6678 bad_type(arg, "symbol", gv_ename(namegv), o2);
6681 if (o2->op_type == OP_ENTERSUB)
6684 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6687 if (o2->op_type == OP_RV2SV ||
6688 o2->op_type == OP_PADSV ||
6689 o2->op_type == OP_HELEM ||
6690 o2->op_type == OP_AELEM ||
6691 o2->op_type == OP_THREADSV)
6694 bad_type(arg, "scalar", gv_ename(namegv), o2);
6697 if (o2->op_type == OP_RV2AV ||
6698 o2->op_type == OP_PADAV)
6701 bad_type(arg, "array", gv_ename(namegv), o2);
6704 if (o2->op_type == OP_RV2HV ||
6705 o2->op_type == OP_PADHV)
6708 bad_type(arg, "hash", gv_ename(namegv), o2);
6713 OP* const sib = kid->op_sibling;
6714 kid->op_sibling = 0;
6715 o2 = newUNOP(OP_REFGEN, 0, kid);
6716 o2->op_sibling = sib;
6717 prev->op_sibling = o2;
6719 if (contextclass && e) {
6734 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
6735 gv_ename(namegv), cv);
6740 mod(o2, OP_ENTERSUB);
6742 o2 = o2->op_sibling;
6744 if (proto && !optional &&
6745 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6746 return too_few_arguments(o, gv_ename(namegv));
6749 o=newSVOP(OP_CONST, 0, newSViv(0));
6755 Perl_ck_svconst(pTHX_ OP *o)
6757 SvREADONLY_on(cSVOPo->op_sv);
6762 Perl_ck_trunc(pTHX_ OP *o)
6764 if (o->op_flags & OPf_KIDS) {
6765 SVOP *kid = (SVOP*)cUNOPo->op_first;
6767 if (kid->op_type == OP_NULL)
6768 kid = (SVOP*)kid->op_sibling;
6769 if (kid && kid->op_type == OP_CONST &&
6770 (kid->op_private & OPpCONST_BARE))
6772 o->op_flags |= OPf_SPECIAL;
6773 kid->op_private &= ~OPpCONST_STRICT;
6780 Perl_ck_unpack(pTHX_ OP *o)
6782 OP *kid = cLISTOPo->op_first;
6783 if (kid->op_sibling) {
6784 kid = kid->op_sibling;
6785 if (!kid->op_sibling)
6786 kid->op_sibling = newDEFSVOP();
6792 Perl_ck_substr(pTHX_ OP *o)
6795 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6796 OP *kid = cLISTOPo->op_first;
6798 if (kid->op_type == OP_NULL)
6799 kid = kid->op_sibling;
6801 kid->op_flags |= OPf_MOD;
6807 /* A peephole optimizer. We visit the ops in the order they're to execute.
6808 * See the comments at the top of this file for more details about when
6809 * peep() is called */
6812 Perl_peep(pTHX_ register OP *o)
6815 register OP* oldop = NULL;
6817 if (!o || o->op_opt)
6821 SAVEVPTR(PL_curcop);
6822 for (; o; o = o->op_next) {
6826 switch (o->op_type) {
6830 PL_curcop = ((COP*)o); /* for warnings */
6835 if (cSVOPo->op_private & OPpCONST_STRICT)
6836 no_bareword_allowed(o);
6838 case OP_METHOD_NAMED:
6839 /* Relocate sv to the pad for thread safety.
6840 * Despite being a "constant", the SV is written to,
6841 * for reference counts, sv_upgrade() etc. */
6843 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6844 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6845 /* If op_sv is already a PADTMP then it is being used by
6846 * some pad, so make a copy. */
6847 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6848 SvREADONLY_on(PAD_SVl(ix));
6849 SvREFCNT_dec(cSVOPo->op_sv);
6851 else if (o->op_type == OP_CONST
6852 && cSVOPo->op_sv == &PL_sv_undef) {
6853 /* PL_sv_undef is hack - it's unsafe to store it in the
6854 AV that is the pad, because av_fetch treats values of
6855 PL_sv_undef as a "free" AV entry and will merrily
6856 replace them with a new SV, causing pad_alloc to think
6857 that this pad slot is free. (When, clearly, it is not)
6859 SvOK_off(PAD_SVl(ix));
6860 SvPADTMP_on(PAD_SVl(ix));
6861 SvREADONLY_on(PAD_SVl(ix));
6864 SvREFCNT_dec(PAD_SVl(ix));
6865 SvPADTMP_on(cSVOPo->op_sv);
6866 PAD_SETSV(ix, cSVOPo->op_sv);
6867 /* XXX I don't know how this isn't readonly already. */
6868 SvREADONLY_on(PAD_SVl(ix));
6870 cSVOPo->op_sv = Nullsv;
6878 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6879 if (o->op_next->op_private & OPpTARGET_MY) {
6880 if (o->op_flags & OPf_STACKED) /* chained concats */
6881 goto ignore_optimization;
6883 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6884 o->op_targ = o->op_next->op_targ;
6885 o->op_next->op_targ = 0;
6886 o->op_private |= OPpTARGET_MY;
6889 op_null(o->op_next);
6891 ignore_optimization:
6895 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6897 break; /* Scalar stub must produce undef. List stub is noop */
6901 if (o->op_targ == OP_NEXTSTATE
6902 || o->op_targ == OP_DBSTATE
6903 || o->op_targ == OP_SETSTATE)
6905 PL_curcop = ((COP*)o);
6907 /* XXX: We avoid setting op_seq here to prevent later calls
6908 to peep() from mistakenly concluding that optimisation
6909 has already occurred. This doesn't fix the real problem,
6910 though (See 20010220.007). AMS 20010719 */
6911 /* op_seq functionality is now replaced by op_opt */
6912 if (oldop && o->op_next) {
6913 oldop->op_next = o->op_next;
6921 if (oldop && o->op_next) {
6922 oldop->op_next = o->op_next;
6930 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
6931 OP* const pop = (o->op_type == OP_PADAV) ?
6932 o->op_next : o->op_next->op_next;
6934 if (pop && pop->op_type == OP_CONST &&
6935 ((PL_op = pop->op_next)) &&
6936 pop->op_next->op_type == OP_AELEM &&
6937 !(pop->op_next->op_private &
6938 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6939 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6944 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
6945 no_bareword_allowed(pop);
6946 if (o->op_type == OP_GV)
6947 op_null(o->op_next);
6948 op_null(pop->op_next);
6950 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6951 o->op_next = pop->op_next->op_next;
6952 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6953 o->op_private = (U8)i;
6954 if (o->op_type == OP_GV) {
6959 o->op_flags |= OPf_SPECIAL;
6960 o->op_type = OP_AELEMFAST;
6966 if (o->op_next->op_type == OP_RV2SV) {
6967 if (!(o->op_next->op_private & OPpDEREF)) {
6968 op_null(o->op_next);
6969 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6971 o->op_next = o->op_next->op_next;
6972 o->op_type = OP_GVSV;
6973 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6976 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6977 GV * const gv = cGVOPo_gv;
6978 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
6979 /* XXX could check prototype here instead of just carping */
6980 SV * const sv = sv_newmortal();
6981 gv_efullname3(sv, gv, Nullch);
6982 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
6983 "%"SVf"() called too early to check prototype",
6987 else if (o->op_next->op_type == OP_READLINE
6988 && o->op_next->op_next->op_type == OP_CONCAT
6989 && (o->op_next->op_next->op_flags & OPf_STACKED))
6991 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6992 o->op_type = OP_RCATLINE;
6993 o->op_flags |= OPf_STACKED;
6994 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
6995 op_null(o->op_next->op_next);
6996 op_null(o->op_next);
7013 while (cLOGOP->op_other->op_type == OP_NULL)
7014 cLOGOP->op_other = cLOGOP->op_other->op_next;
7015 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
7021 while (cLOOP->op_redoop->op_type == OP_NULL)
7022 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
7023 peep(cLOOP->op_redoop);
7024 while (cLOOP->op_nextop->op_type == OP_NULL)
7025 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
7026 peep(cLOOP->op_nextop);
7027 while (cLOOP->op_lastop->op_type == OP_NULL)
7028 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
7029 peep(cLOOP->op_lastop);
7036 while (cPMOP->op_pmreplstart &&
7037 cPMOP->op_pmreplstart->op_type == OP_NULL)
7038 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
7039 peep(cPMOP->op_pmreplstart);
7044 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
7045 && ckWARN(WARN_SYNTAX))
7047 if (o->op_next->op_sibling &&
7048 o->op_next->op_sibling->op_type != OP_EXIT &&
7049 o->op_next->op_sibling->op_type != OP_WARN &&
7050 o->op_next->op_sibling->op_type != OP_DIE) {
7051 const line_t oldline = CopLINE(PL_curcop);
7053 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
7054 Perl_warner(aTHX_ packWARN(WARN_EXEC),
7055 "Statement unlikely to be reached");
7056 Perl_warner(aTHX_ packWARN(WARN_EXEC),
7057 "\t(Maybe you meant system() when you said exec()?)\n");
7058 CopLINE_set(PL_curcop, oldline);
7068 const char *key = NULL;
7073 if (((BINOP*)o)->op_last->op_type != OP_CONST)
7076 /* Make the CONST have a shared SV */
7077 svp = cSVOPx_svp(((BINOP*)o)->op_last);
7078 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
7079 key = SvPV_const(sv, keylen);
7080 lexname = newSVpvn_share(key,
7081 SvUTF8(sv) ? -(I32)keylen : keylen,
7087 if ((o->op_private & (OPpLVAL_INTRO)))
7090 rop = (UNOP*)((BINOP*)o)->op_first;
7091 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7093 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7094 if (!(SvFLAGS(lexname) & SVpad_TYPED))
7096 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
7097 if (!fields || !GvHV(*fields))
7099 key = SvPV_const(*svp, keylen);
7100 if (!hv_fetch(GvHV(*fields), key,
7101 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
7103 Perl_croak(aTHX_ "No such class field \"%s\" "
7104 "in variable %s of type %s",
7105 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
7118 SVOP *first_key_op, *key_op;
7120 if ((o->op_private & (OPpLVAL_INTRO))
7121 /* I bet there's always a pushmark... */
7122 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
7123 /* hmmm, no optimization if list contains only one key. */
7125 rop = (UNOP*)((LISTOP*)o)->op_last;
7126 if (rop->op_type != OP_RV2HV)
7128 if (rop->op_first->op_type == OP_PADSV)
7129 /* @$hash{qw(keys here)} */
7130 rop = (UNOP*)rop->op_first;
7132 /* @{$hash}{qw(keys here)} */
7133 if (rop->op_first->op_type == OP_SCOPE
7134 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
7136 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
7142 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
7143 if (!(SvFLAGS(lexname) & SVpad_TYPED))
7145 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
7146 if (!fields || !GvHV(*fields))
7148 /* Again guessing that the pushmark can be jumped over.... */
7149 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
7150 ->op_first->op_sibling;
7151 for (key_op = first_key_op; key_op;
7152 key_op = (SVOP*)key_op->op_sibling) {
7153 if (key_op->op_type != OP_CONST)
7155 svp = cSVOPx_svp(key_op);
7156 key = SvPV_const(*svp, keylen);
7157 if (!hv_fetch(GvHV(*fields), key,
7158 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
7160 Perl_croak(aTHX_ "No such class field \"%s\" "
7161 "in variable %s of type %s",
7162 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
7169 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
7173 /* check that RHS of sort is a single plain array */
7174 OP *oright = cUNOPo->op_first;
7175 if (!oright || oright->op_type != OP_PUSHMARK)
7178 /* reverse sort ... can be optimised. */
7179 if (!cUNOPo->op_sibling) {
7180 /* Nothing follows us on the list. */
7181 OP * const reverse = o->op_next;
7183 if (reverse->op_type == OP_REVERSE &&
7184 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
7185 OP * const pushmark = cUNOPx(reverse)->op_first;
7186 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
7187 && (cUNOPx(pushmark)->op_sibling == o)) {
7188 /* reverse -> pushmark -> sort */
7189 o->op_private |= OPpSORT_REVERSE;
7191 pushmark->op_next = oright->op_next;
7197 /* make @a = sort @a act in-place */
7201 oright = cUNOPx(oright)->op_sibling;
7204 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
7205 oright = cUNOPx(oright)->op_sibling;
7209 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
7210 || oright->op_next != o
7211 || (oright->op_private & OPpLVAL_INTRO)
7215 /* o2 follows the chain of op_nexts through the LHS of the
7216 * assign (if any) to the aassign op itself */
7218 if (!o2 || o2->op_type != OP_NULL)
7221 if (!o2 || o2->op_type != OP_PUSHMARK)
7224 if (o2 && o2->op_type == OP_GV)
7227 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
7228 || (o2->op_private & OPpLVAL_INTRO)
7233 if (!o2 || o2->op_type != OP_NULL)
7236 if (!o2 || o2->op_type != OP_AASSIGN
7237 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
7240 /* check that the sort is the first arg on RHS of assign */
7242 o2 = cUNOPx(o2)->op_first;
7243 if (!o2 || o2->op_type != OP_NULL)
7245 o2 = cUNOPx(o2)->op_first;
7246 if (!o2 || o2->op_type != OP_PUSHMARK)
7248 if (o2->op_sibling != o)
7251 /* check the array is the same on both sides */
7252 if (oleft->op_type == OP_RV2AV) {
7253 if (oright->op_type != OP_RV2AV
7254 || !cUNOPx(oright)->op_first
7255 || cUNOPx(oright)->op_first->op_type != OP_GV
7256 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
7257 cGVOPx_gv(cUNOPx(oright)->op_first)
7261 else if (oright->op_type != OP_PADAV
7262 || oright->op_targ != oleft->op_targ
7266 /* transfer MODishness etc from LHS arg to RHS arg */
7267 oright->op_flags = oleft->op_flags;
7268 o->op_private |= OPpSORT_INPLACE;
7270 /* excise push->gv->rv2av->null->aassign */
7271 o2 = o->op_next->op_next;
7272 op_null(o2); /* PUSHMARK */
7274 if (o2->op_type == OP_GV) {
7275 op_null(o2); /* GV */
7278 op_null(o2); /* RV2AV or PADAV */
7279 o2 = o2->op_next->op_next;
7280 op_null(o2); /* AASSIGN */
7282 o->op_next = o2->op_next;
7288 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
7290 LISTOP *enter, *exlist;
7293 enter = (LISTOP *) o->op_next;
7296 if (enter->op_type == OP_NULL) {
7297 enter = (LISTOP *) enter->op_next;
7301 /* for $a (...) will have OP_GV then OP_RV2GV here.
7302 for (...) just has an OP_GV. */
7303 if (enter->op_type == OP_GV) {
7304 gvop = (OP *) enter;
7305 enter = (LISTOP *) enter->op_next;
7308 if (enter->op_type == OP_RV2GV) {
7309 enter = (LISTOP *) enter->op_next;
7315 if (enter->op_type != OP_ENTERITER)
7318 iter = enter->op_next;
7319 if (!iter || iter->op_type != OP_ITER)
7322 expushmark = enter->op_first;
7323 if (!expushmark || expushmark->op_type != OP_NULL
7324 || expushmark->op_targ != OP_PUSHMARK)
7327 exlist = (LISTOP *) expushmark->op_sibling;
7328 if (!exlist || exlist->op_type != OP_NULL
7329 || exlist->op_targ != OP_LIST)
7332 if (exlist->op_last != o) {
7333 /* Mmm. Was expecting to point back to this op. */
7336 theirmark = exlist->op_first;
7337 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
7340 if (theirmark->op_sibling != o) {
7341 /* There's something between the mark and the reverse, eg
7342 for (1, reverse (...))
7347 ourmark = ((LISTOP *)o)->op_first;
7348 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
7351 ourlast = ((LISTOP *)o)->op_last;
7352 if (!ourlast || ourlast->op_next != o)
7355 rv2av = ourmark->op_sibling;
7356 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
7357 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
7358 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
7359 /* We're just reversing a single array. */
7360 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
7361 enter->op_flags |= OPf_STACKED;
7364 /* We don't have control over who points to theirmark, so sacrifice
7366 theirmark->op_next = ourmark->op_next;
7367 theirmark->op_flags = ourmark->op_flags;
7368 ourlast->op_next = gvop ? gvop : (OP *) enter;
7371 enter->op_private |= OPpITER_REVERSED;
7372 iter->op_private |= OPpITER_REVERSED;
7379 UNOP *refgen, *rv2cv;
7382 /* I do not understand this, but if o->op_opt isn't set to 1,
7383 various tests in ext/B/t/bytecode.t fail with no readily
7389 if ((o->op_flags && OPf_WANT) != OPf_WANT_VOID)
7392 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
7395 rv2gv = ((BINOP *)o)->op_last;
7396 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
7399 refgen = (UNOP *)((BINOP *)o)->op_first;
7401 if (!refgen || refgen->op_type != OP_REFGEN)
7404 exlist = (LISTOP *)refgen->op_first;
7405 if (!exlist || exlist->op_type != OP_NULL
7406 || exlist->op_targ != OP_LIST)
7409 if (exlist->op_first->op_type != OP_PUSHMARK)
7412 rv2cv = (UNOP*)exlist->op_last;
7414 if (rv2cv->op_type != OP_RV2CV)
7417 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
7418 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
7419 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
7421 o->op_private |= OPpASSIGN_CV_TO_GV;
7422 rv2gv->op_private |= OPpDONT_INIT_GV;
7423 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
7439 Perl_custom_op_name(pTHX_ const OP* o)
7442 const IV index = PTR2IV(o->op_ppaddr);
7446 if (!PL_custom_op_names) /* This probably shouldn't happen */
7447 return (char *)PL_op_name[OP_CUSTOM];
7449 keysv = sv_2mortal(newSViv(index));
7451 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
7453 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
7455 return SvPV_nolen(HeVAL(he));
7459 Perl_custom_op_desc(pTHX_ const OP* o)
7462 const IV index = PTR2IV(o->op_ppaddr);
7466 if (!PL_custom_op_descs)
7467 return (char *)PL_op_desc[OP_CUSTOM];
7469 keysv = sv_2mortal(newSViv(index));
7471 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
7473 return (char *)PL_op_desc[OP_CUSTOM];
7475 return SvPV_nolen(HeVAL(he));
7480 /* Efficient sub that returns a constant scalar value. */
7482 const_sv_xsub(pTHX_ CV* cv)
7488 Perl_croak(aTHX_ "usage: %s::%s()",
7489 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7493 ST(0) = (SV*)XSANY.any_ptr;
7499 * c-indentation-style: bsd
7501 * indent-tabs-mode: t
7504 * ex: set ts=8 sts=4 sw=4 noet: