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)))
1040 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1041 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
1045 SAVEI32(PL_compiling.cop_arybase);
1046 PL_compiling.cop_arybase = 0;
1048 else if (type == OP_REFGEN)
1051 Perl_croak(aTHX_ "That use of $[ is unsupported");
1054 if (o->op_flags & OPf_PARENS)
1058 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1059 !(o->op_flags & OPf_STACKED)) {
1060 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1061 /* The default is to set op_private to the number of children,
1062 which for a UNOP such as RV2CV is always 1. And w're using
1063 the bit for a flag in RV2CV, so we need it clear. */
1064 o->op_private &= ~1;
1065 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1066 assert(cUNOPo->op_first->op_type == OP_NULL);
1067 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1070 else if (o->op_private & OPpENTERSUB_NOMOD)
1072 else { /* lvalue subroutine call */
1073 o->op_private |= OPpLVAL_INTRO;
1074 PL_modcount = RETURN_UNLIMITED_NUMBER;
1075 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1076 /* Backward compatibility mode: */
1077 o->op_private |= OPpENTERSUB_INARGS;
1080 else { /* Compile-time error message: */
1081 OP *kid = cUNOPo->op_first;
1085 if (kid->op_type == OP_PUSHMARK)
1087 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1089 "panic: unexpected lvalue entersub "
1090 "args: type/targ %ld:%"UVuf,
1091 (long)kid->op_type, (UV)kid->op_targ);
1092 kid = kLISTOP->op_first;
1094 while (kid->op_sibling)
1095 kid = kid->op_sibling;
1096 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1098 if (kid->op_type == OP_METHOD_NAMED
1099 || kid->op_type == OP_METHOD)
1103 NewOp(1101, newop, 1, UNOP);
1104 newop->op_type = OP_RV2CV;
1105 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1106 newop->op_first = Nullop;
1107 newop->op_next = (OP*)newop;
1108 kid->op_sibling = (OP*)newop;
1109 newop->op_private |= OPpLVAL_INTRO;
1110 newop->op_private &= ~1;
1114 if (kid->op_type != OP_RV2CV)
1116 "panic: unexpected lvalue entersub "
1117 "entry via type/targ %ld:%"UVuf,
1118 (long)kid->op_type, (UV)kid->op_targ);
1119 kid->op_private |= OPpLVAL_INTRO;
1120 break; /* Postpone until runtime */
1124 kid = kUNOP->op_first;
1125 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1126 kid = kUNOP->op_first;
1127 if (kid->op_type == OP_NULL)
1129 "Unexpected constant lvalue entersub "
1130 "entry via type/targ %ld:%"UVuf,
1131 (long)kid->op_type, (UV)kid->op_targ);
1132 if (kid->op_type != OP_GV) {
1133 /* Restore RV2CV to check lvalueness */
1135 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1136 okid->op_next = kid->op_next;
1137 kid->op_next = okid;
1140 okid->op_next = Nullop;
1141 okid->op_type = OP_RV2CV;
1143 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1144 okid->op_private |= OPpLVAL_INTRO;
1145 okid->op_private &= ~1;
1149 cv = GvCV(kGVOP_gv);
1159 /* grep, foreach, subcalls, refgen, m//g */
1160 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN
1161 || type == OP_MATCH)
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 /* s/// and tr/// modify their arg.
1844 * m//g also indirectly modifies the arg by setting pos magic on it */
1845 if ( (right->op_type == OP_MATCH &&
1846 (cPMOPx(right)->op_pmflags & PMf_GLOBAL))
1847 || (right->op_type == OP_SUBST)
1848 || (right->op_type == OP_TRANS &&
1849 ! (right->op_private & OPpTRANS_IDENTICAL))
1851 left = mod(left, right->op_type);
1852 if (right->op_type == OP_TRANS)
1853 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
1855 o = prepend_elem(right->op_type, scalar(left), right);
1857 return newUNOP(OP_NOT, 0, scalar(o));
1861 return bind_match(type, left,
1862 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
1866 Perl_invert(pTHX_ OP *o)
1870 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
1871 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
1875 Perl_scope(pTHX_ OP *o)
1879 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
1880 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
1881 o->op_type = OP_LEAVE;
1882 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
1884 else if (o->op_type == OP_LINESEQ) {
1886 o->op_type = OP_SCOPE;
1887 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
1888 kid = ((LISTOP*)o)->op_first;
1889 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
1892 /* The following deals with things like 'do {1 for 1}' */
1893 kid = kid->op_sibling;
1895 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
1900 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
1906 Perl_block_start(pTHX_ int full)
1909 const int retval = PL_savestack_ix;
1910 pad_block_start(full);
1912 PL_hints &= ~HINT_BLOCK_SCOPE;
1913 SAVESPTR(PL_compiling.cop_warnings);
1914 if (! specialWARN(PL_compiling.cop_warnings)) {
1915 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
1916 SAVEFREESV(PL_compiling.cop_warnings) ;
1918 SAVESPTR(PL_compiling.cop_io);
1919 if (! specialCopIO(PL_compiling.cop_io)) {
1920 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
1921 SAVEFREESV(PL_compiling.cop_io) ;
1927 Perl_block_end(pTHX_ I32 floor, OP *seq)
1930 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
1931 OP* const retval = scalarseq(seq);
1933 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
1935 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
1944 const I32 offset = pad_findmy("$_");
1945 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
1946 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
1949 OP * const o = newOP(OP_PADSV, 0);
1950 o->op_targ = offset;
1956 Perl_newPROG(pTHX_ OP *o)
1962 PL_eval_root = newUNOP(OP_LEAVEEVAL,
1963 ((PL_in_eval & EVAL_KEEPERR)
1964 ? OPf_SPECIAL : 0), o);
1965 PL_eval_start = linklist(PL_eval_root);
1966 PL_eval_root->op_private |= OPpREFCOUNTED;
1967 OpREFCNT_set(PL_eval_root, 1);
1968 PL_eval_root->op_next = 0;
1969 CALL_PEEP(PL_eval_start);
1972 if (o->op_type == OP_STUB) {
1973 PL_comppad_name = 0;
1978 PL_main_root = scope(sawparens(scalarvoid(o)));
1979 PL_curcop = &PL_compiling;
1980 PL_main_start = LINKLIST(PL_main_root);
1981 PL_main_root->op_private |= OPpREFCOUNTED;
1982 OpREFCNT_set(PL_main_root, 1);
1983 PL_main_root->op_next = 0;
1984 CALL_PEEP(PL_main_start);
1987 /* Register with debugger */
1989 CV * const cv = get_cv("DB::postponed", FALSE);
1993 XPUSHs((SV*)CopFILEGV(&PL_compiling));
1995 call_sv((SV*)cv, G_DISCARD);
2002 Perl_localize(pTHX_ OP *o, I32 lex)
2005 if (o->op_flags & OPf_PARENS)
2006 /* [perl #17376]: this appears to be premature, and results in code such as
2007 C< our(%x); > executing in list mode rather than void mode */
2014 if ( PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ','
2015 && ckWARN(WARN_PARENTHESIS))
2017 char *s = PL_bufptr;
2020 /* some heuristics to detect a potential error */
2021 while (*s && (strchr(", \t\n", *s)))
2025 if (*s && strchr("@$%*", *s) && *++s
2026 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2029 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2031 while (*s && (strchr(", \t\n", *s)))
2037 if (sigil && (*s == ';' || *s == '=')) {
2038 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2039 "Parentheses missing around \"%s\" list",
2040 lex ? (PL_in_my == KEY_our ? "our" : "my")
2048 o = mod(o, OP_NULL); /* a bit kludgey */
2050 PL_in_my_stash = NULL;
2055 Perl_jmaybe(pTHX_ OP *o)
2057 if (o->op_type == OP_LIST) {
2058 OP * const o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", GV_ADD, SVt_PV)));
2059 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2065 Perl_fold_constants(pTHX_ register OP *o)
2069 I32 type = o->op_type;
2072 if (PL_opargs[type] & OA_RETSCALAR)
2074 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2075 o->op_targ = pad_alloc(type, SVs_PADTMP);
2077 /* integerize op, unless it happens to be C<-foo>.
2078 * XXX should pp_i_negate() do magic string negation instead? */
2079 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2080 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2081 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2083 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2086 if (!(PL_opargs[type] & OA_FOLDCONST))
2091 /* XXX might want a ck_negate() for this */
2092 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2103 /* XXX what about the numeric ops? */
2104 if (PL_hints & HINT_LOCALE)
2109 goto nope; /* Don't try to run w/ errors */
2111 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2112 if ((curop->op_type != OP_CONST ||
2113 (curop->op_private & OPpCONST_BARE)) &&
2114 curop->op_type != OP_LIST &&
2115 curop->op_type != OP_SCALAR &&
2116 curop->op_type != OP_NULL &&
2117 curop->op_type != OP_PUSHMARK)
2123 curop = LINKLIST(o);
2127 sv = *(PL_stack_sp--);
2128 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2129 pad_swipe(o->op_targ, FALSE);
2130 else if (SvTEMP(sv)) { /* grab mortal temp? */
2131 (void)SvREFCNT_inc(sv);
2135 if (type == OP_RV2GV)
2136 return newGVOP(OP_GV, 0, (GV*)sv);
2137 return newSVOP(OP_CONST, 0, sv);
2144 Perl_gen_constant_list(pTHX_ register OP *o)
2148 const I32 oldtmps_floor = PL_tmps_floor;
2152 return o; /* Don't attempt to run with errors */
2154 PL_op = curop = LINKLIST(o);
2161 PL_tmps_floor = oldtmps_floor;
2163 o->op_type = OP_RV2AV;
2164 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2165 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2166 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2167 o->op_opt = 0; /* needs to be revisited in peep() */
2168 curop = ((UNOP*)o)->op_first;
2169 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2176 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2179 if (!o || o->op_type != OP_LIST)
2180 o = newLISTOP(OP_LIST, 0, o, Nullop);
2182 o->op_flags &= ~OPf_WANT;
2184 if (!(PL_opargs[type] & OA_MARK))
2185 op_null(cLISTOPo->op_first);
2187 o->op_type = (OPCODE)type;
2188 o->op_ppaddr = PL_ppaddr[type];
2189 o->op_flags |= flags;
2191 o = CHECKOP(type, o);
2192 if (o->op_type != (unsigned)type)
2195 return fold_constants(o);
2198 /* List constructors */
2201 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2209 if (first->op_type != (unsigned)type
2210 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2212 return newLISTOP(type, 0, first, last);
2215 if (first->op_flags & OPf_KIDS)
2216 ((LISTOP*)first)->op_last->op_sibling = last;
2218 first->op_flags |= OPf_KIDS;
2219 ((LISTOP*)first)->op_first = last;
2221 ((LISTOP*)first)->op_last = last;
2226 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2234 if (first->op_type != (unsigned)type)
2235 return prepend_elem(type, (OP*)first, (OP*)last);
2237 if (last->op_type != (unsigned)type)
2238 return append_elem(type, (OP*)first, (OP*)last);
2240 first->op_last->op_sibling = last->op_first;
2241 first->op_last = last->op_last;
2242 first->op_flags |= (last->op_flags & OPf_KIDS);
2250 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2258 if (last->op_type == (unsigned)type) {
2259 if (type == OP_LIST) { /* already a PUSHMARK there */
2260 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2261 ((LISTOP*)last)->op_first->op_sibling = first;
2262 if (!(first->op_flags & OPf_PARENS))
2263 last->op_flags &= ~OPf_PARENS;
2266 if (!(last->op_flags & OPf_KIDS)) {
2267 ((LISTOP*)last)->op_last = first;
2268 last->op_flags |= OPf_KIDS;
2270 first->op_sibling = ((LISTOP*)last)->op_first;
2271 ((LISTOP*)last)->op_first = first;
2273 last->op_flags |= OPf_KIDS;
2277 return newLISTOP(type, 0, first, last);
2283 Perl_newNULLLIST(pTHX)
2285 return newOP(OP_STUB, 0);
2289 Perl_force_list(pTHX_ OP *o)
2291 if (!o || o->op_type != OP_LIST)
2292 o = newLISTOP(OP_LIST, 0, o, Nullop);
2298 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2303 NewOp(1101, listop, 1, LISTOP);
2305 listop->op_type = (OPCODE)type;
2306 listop->op_ppaddr = PL_ppaddr[type];
2309 listop->op_flags = (U8)flags;
2313 else if (!first && last)
2316 first->op_sibling = last;
2317 listop->op_first = first;
2318 listop->op_last = last;
2319 if (type == OP_LIST) {
2320 OP* const pushop = newOP(OP_PUSHMARK, 0);
2321 pushop->op_sibling = first;
2322 listop->op_first = pushop;
2323 listop->op_flags |= OPf_KIDS;
2325 listop->op_last = pushop;
2328 return CHECKOP(type, listop);
2332 Perl_newOP(pTHX_ I32 type, I32 flags)
2336 NewOp(1101, o, 1, OP);
2337 o->op_type = (OPCODE)type;
2338 o->op_ppaddr = PL_ppaddr[type];
2339 o->op_flags = (U8)flags;
2342 o->op_private = (U8)(0 | (flags >> 8));
2343 if (PL_opargs[type] & OA_RETSCALAR)
2345 if (PL_opargs[type] & OA_TARGET)
2346 o->op_targ = pad_alloc(type, SVs_PADTMP);
2347 return CHECKOP(type, o);
2351 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2357 first = newOP(OP_STUB, 0);
2358 if (PL_opargs[type] & OA_MARK)
2359 first = force_list(first);
2361 NewOp(1101, unop, 1, UNOP);
2362 unop->op_type = (OPCODE)type;
2363 unop->op_ppaddr = PL_ppaddr[type];
2364 unop->op_first = first;
2365 unop->op_flags = (U8)(flags | OPf_KIDS);
2366 unop->op_private = (U8)(1 | (flags >> 8));
2367 unop = (UNOP*) CHECKOP(type, unop);
2371 return fold_constants((OP *) unop);
2375 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2379 NewOp(1101, binop, 1, BINOP);
2382 first = newOP(OP_NULL, 0);
2384 binop->op_type = (OPCODE)type;
2385 binop->op_ppaddr = PL_ppaddr[type];
2386 binop->op_first = first;
2387 binop->op_flags = (U8)(flags | OPf_KIDS);
2390 binop->op_private = (U8)(1 | (flags >> 8));
2393 binop->op_private = (U8)(2 | (flags >> 8));
2394 first->op_sibling = last;
2397 binop = (BINOP*)CHECKOP(type, binop);
2398 if (binop->op_next || binop->op_type != (OPCODE)type)
2401 binop->op_last = binop->op_first->op_sibling;
2403 return fold_constants((OP *)binop);
2406 static int uvcompare(const void *a, const void *b) __attribute__nonnull__(1) __attribute__nonnull__(2) __attribute__pure__;
2407 static int uvcompare(const void *a, const void *b)
2409 if (*((const UV *)a) < (*(const UV *)b))
2411 if (*((const UV *)a) > (*(const UV *)b))
2413 if (*((const UV *)a+1) < (*(const UV *)b+1))
2415 if (*((const UV *)a+1) > (*(const UV *)b+1))
2421 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2424 SV * const tstr = ((SVOP*)expr)->op_sv;
2425 SV * const rstr = ((SVOP*)repl)->op_sv;
2428 const U8 *t = (U8*)SvPV_const(tstr, tlen);
2429 const U8 *r = (U8*)SvPV_const(rstr, rlen);
2433 register short *tbl;
2435 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
2436 const I32 squash = o->op_private & OPpTRANS_SQUASH;
2437 I32 del = o->op_private & OPpTRANS_DELETE;
2438 PL_hints |= HINT_BLOCK_SCOPE;
2441 o->op_private |= OPpTRANS_FROM_UTF;
2444 o->op_private |= OPpTRANS_TO_UTF;
2446 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2447 SV* const listsv = newSVpvs("# comment\n");
2449 const U8* tend = t + tlen;
2450 const U8* rend = r + rlen;
2464 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2465 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2471 t = tsave = bytes_to_utf8(t, &len);
2474 if (!to_utf && rlen) {
2476 r = rsave = bytes_to_utf8(r, &len);
2480 /* There are several snags with this code on EBCDIC:
2481 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2482 2. scan_const() in toke.c has encoded chars in native encoding which makes
2483 ranges at least in EBCDIC 0..255 range the bottom odd.
2487 U8 tmpbuf[UTF8_MAXBYTES+1];
2490 Newx(cp, 2*tlen, UV);
2492 transv = newSVpvs("");
2494 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2496 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2498 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2502 cp[2*i+1] = cp[2*i];
2506 qsort(cp, i, 2*sizeof(UV), uvcompare);
2507 for (j = 0; j < i; j++) {
2509 diff = val - nextmin;
2511 t = uvuni_to_utf8(tmpbuf,nextmin);
2512 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2514 U8 range_mark = UTF_TO_NATIVE(0xff);
2515 t = uvuni_to_utf8(tmpbuf, val - 1);
2516 sv_catpvn(transv, (char *)&range_mark, 1);
2517 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2524 t = uvuni_to_utf8(tmpbuf,nextmin);
2525 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2527 U8 range_mark = UTF_TO_NATIVE(0xff);
2528 sv_catpvn(transv, (char *)&range_mark, 1);
2530 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2531 UNICODE_ALLOW_SUPER);
2532 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2533 t = (const U8*)SvPVX_const(transv);
2534 tlen = SvCUR(transv);
2538 else if (!rlen && !del) {
2539 r = t; rlen = tlen; rend = tend;
2542 if ((!rlen && !del) || t == r ||
2543 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2545 o->op_private |= OPpTRANS_IDENTICAL;
2549 while (t < tend || tfirst <= tlast) {
2550 /* see if we need more "t" chars */
2551 if (tfirst > tlast) {
2552 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2554 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2556 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2563 /* now see if we need more "r" chars */
2564 if (rfirst > rlast) {
2566 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2568 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2570 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2579 rfirst = rlast = 0xffffffff;
2583 /* now see which range will peter our first, if either. */
2584 tdiff = tlast - tfirst;
2585 rdiff = rlast - rfirst;
2592 if (rfirst == 0xffffffff) {
2593 diff = tdiff; /* oops, pretend rdiff is infinite */
2595 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2596 (long)tfirst, (long)tlast);
2598 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2602 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2603 (long)tfirst, (long)(tfirst + diff),
2606 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2607 (long)tfirst, (long)rfirst);
2609 if (rfirst + diff > max)
2610 max = rfirst + diff;
2612 grows = (tfirst < rfirst &&
2613 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2625 else if (max > 0xff)
2630 Safefree(cPVOPo->op_pv);
2631 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2632 SvREFCNT_dec(listsv);
2634 SvREFCNT_dec(transv);
2636 if (!del && havefinal && rlen)
2637 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2638 newSVuv((UV)final), 0);
2641 o->op_private |= OPpTRANS_GROWS;
2653 tbl = (short*)cPVOPo->op_pv;
2655 Zero(tbl, 256, short);
2656 for (i = 0; i < (I32)tlen; i++)
2658 for (i = 0, j = 0; i < 256; i++) {
2660 if (j >= (I32)rlen) {
2669 if (i < 128 && r[j] >= 128)
2679 o->op_private |= OPpTRANS_IDENTICAL;
2681 else if (j >= (I32)rlen)
2684 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2685 tbl[0x100] = (short)(rlen - j);
2686 for (i=0; i < (I32)rlen - j; i++)
2687 tbl[0x101+i] = r[j+i];
2691 if (!rlen && !del) {
2694 o->op_private |= OPpTRANS_IDENTICAL;
2696 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
2697 o->op_private |= OPpTRANS_IDENTICAL;
2699 for (i = 0; i < 256; i++)
2701 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
2702 if (j >= (I32)rlen) {
2704 if (tbl[t[i]] == -1)
2710 if (tbl[t[i]] == -1) {
2711 if (t[i] < 128 && r[j] >= 128)
2718 o->op_private |= OPpTRANS_GROWS;
2726 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2731 NewOp(1101, pmop, 1, PMOP);
2732 pmop->op_type = (OPCODE)type;
2733 pmop->op_ppaddr = PL_ppaddr[type];
2734 pmop->op_flags = (U8)flags;
2735 pmop->op_private = (U8)(0 | (flags >> 8));
2737 if (PL_hints & HINT_RE_TAINT)
2738 pmop->op_pmpermflags |= PMf_RETAINT;
2739 if (PL_hints & HINT_LOCALE)
2740 pmop->op_pmpermflags |= PMf_LOCALE;
2741 pmop->op_pmflags = pmop->op_pmpermflags;
2744 if (av_len((AV*) PL_regex_pad[0]) > -1) {
2745 SV * const repointer = av_pop((AV*)PL_regex_pad[0]);
2746 pmop->op_pmoffset = SvIV(repointer);
2747 SvREPADTMP_off(repointer);
2748 sv_setiv(repointer,0);
2750 SV * const repointer = newSViv(0);
2751 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
2752 pmop->op_pmoffset = av_len(PL_regex_padav);
2753 PL_regex_pad = AvARRAY(PL_regex_padav);
2757 /* link into pm list */
2758 if (type != OP_TRANS && PL_curstash) {
2759 MAGIC *mg = mg_find((SV*)PL_curstash, PERL_MAGIC_symtab);
2762 mg = sv_magicext((SV*)PL_curstash, 0, PERL_MAGIC_symtab, 0, 0, 0);
2764 pmop->op_pmnext = (PMOP*)mg->mg_obj;
2765 mg->mg_obj = (SV*)pmop;
2766 PmopSTASH_set(pmop,PL_curstash);
2769 return CHECKOP(type, pmop);
2772 /* Given some sort of match op o, and an expression expr containing a
2773 * pattern, either compile expr into a regex and attach it to o (if it's
2774 * constant), or convert expr into a runtime regcomp op sequence (if it's
2777 * isreg indicates that the pattern is part of a regex construct, eg
2778 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
2779 * split "pattern", which aren't. In the former case, expr will be a list
2780 * if the pattern contains more than one term (eg /a$b/) or if it contains
2781 * a replacement, ie s/// or tr///.
2785 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
2790 I32 repl_has_vars = 0;
2794 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
2795 /* last element in list is the replacement; pop it */
2797 repl = cLISTOPx(expr)->op_last;
2798 kid = cLISTOPx(expr)->op_first;
2799 while (kid->op_sibling != repl)
2800 kid = kid->op_sibling;
2801 kid->op_sibling = Nullop;
2802 cLISTOPx(expr)->op_last = kid;
2805 if (isreg && expr->op_type == OP_LIST &&
2806 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
2808 /* convert single element list to element */
2809 OP* const oe = expr;
2810 expr = cLISTOPx(oe)->op_first->op_sibling;
2811 cLISTOPx(oe)->op_first->op_sibling = Nullop;
2812 cLISTOPx(oe)->op_last = Nullop;
2816 if (o->op_type == OP_TRANS) {
2817 return pmtrans(o, expr, repl);
2820 reglist = isreg && expr->op_type == OP_LIST;
2824 PL_hints |= HINT_BLOCK_SCOPE;
2827 if (expr->op_type == OP_CONST) {
2829 SV * const pat = ((SVOP*)expr)->op_sv;
2830 const char *p = SvPV_const(pat, plen);
2831 if ((o->op_flags & OPf_SPECIAL) && (*p == ' ' && p[1] == '\0')) {
2832 U32 was_readonly = SvREADONLY(pat);
2836 sv_force_normal_flags(pat, 0);
2837 assert(!SvREADONLY(pat));
2840 SvREADONLY_off(pat);
2844 sv_setpvn(pat, "\\s+", 3);
2846 SvFLAGS(pat) |= was_readonly;
2848 p = SvPV_const(pat, plen);
2849 pm->op_pmflags |= PMf_SKIPWHITE;
2852 pm->op_pmdynflags |= PMdf_UTF8;
2853 /* FIXME - can we make this function take const char * args? */
2854 PM_SETRE(pm, CALLREGCOMP(aTHX_ (char*)p, (char*)p + plen, pm));
2855 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
2856 pm->op_pmflags |= PMf_WHITE;
2860 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
2861 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2863 : OP_REGCMAYBE),0,expr);
2865 NewOp(1101, rcop, 1, LOGOP);
2866 rcop->op_type = OP_REGCOMP;
2867 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
2868 rcop->op_first = scalar(expr);
2869 rcop->op_flags |= OPf_KIDS
2870 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
2871 | (reglist ? OPf_STACKED : 0);
2872 rcop->op_private = 1;
2875 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
2877 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
2880 /* establish postfix order */
2881 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
2883 rcop->op_next = expr;
2884 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
2887 rcop->op_next = LINKLIST(expr);
2888 expr->op_next = (OP*)rcop;
2891 prepend_elem(o->op_type, scalar((OP*)rcop), o);
2896 if (pm->op_pmflags & PMf_EVAL) {
2898 if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
2899 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
2901 else if (repl->op_type == OP_CONST)
2905 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
2906 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
2907 if (curop->op_type == OP_GV) {
2908 GV * const gv = cGVOPx_gv(curop);
2910 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
2913 else if (curop->op_type == OP_RV2CV)
2915 else if (curop->op_type == OP_RV2SV ||
2916 curop->op_type == OP_RV2AV ||
2917 curop->op_type == OP_RV2HV ||
2918 curop->op_type == OP_RV2GV) {
2919 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
2922 else if (curop->op_type == OP_PADSV ||
2923 curop->op_type == OP_PADAV ||
2924 curop->op_type == OP_PADHV ||
2925 curop->op_type == OP_PADANY) {
2928 else if (curop->op_type == OP_PUSHRE)
2929 ; /* Okay here, dangerous in newASSIGNOP */
2939 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
2940 pm->op_pmflags |= PMf_CONST; /* const for long enough */
2941 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
2942 prepend_elem(o->op_type, scalar(repl), o);
2945 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
2946 pm->op_pmflags |= PMf_MAYBE_CONST;
2947 pm->op_pmpermflags |= PMf_MAYBE_CONST;
2949 NewOp(1101, rcop, 1, LOGOP);
2950 rcop->op_type = OP_SUBSTCONT;
2951 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
2952 rcop->op_first = scalar(repl);
2953 rcop->op_flags |= OPf_KIDS;
2954 rcop->op_private = 1;
2957 /* establish postfix order */
2958 rcop->op_next = LINKLIST(repl);
2959 repl->op_next = (OP*)rcop;
2961 pm->op_pmreplroot = scalar((OP*)rcop);
2962 pm->op_pmreplstart = LINKLIST(rcop);
2971 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
2975 NewOp(1101, svop, 1, SVOP);
2976 svop->op_type = (OPCODE)type;
2977 svop->op_ppaddr = PL_ppaddr[type];
2979 svop->op_next = (OP*)svop;
2980 svop->op_flags = (U8)flags;
2981 if (PL_opargs[type] & OA_RETSCALAR)
2983 if (PL_opargs[type] & OA_TARGET)
2984 svop->op_targ = pad_alloc(type, SVs_PADTMP);
2985 return CHECKOP(type, svop);
2989 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
2993 NewOp(1101, padop, 1, PADOP);
2994 padop->op_type = (OPCODE)type;
2995 padop->op_ppaddr = PL_ppaddr[type];
2996 padop->op_padix = pad_alloc(type, SVs_PADTMP);
2997 SvREFCNT_dec(PAD_SVl(padop->op_padix));
2998 PAD_SETSV(padop->op_padix, sv);
3001 padop->op_next = (OP*)padop;
3002 padop->op_flags = (U8)flags;
3003 if (PL_opargs[type] & OA_RETSCALAR)
3005 if (PL_opargs[type] & OA_TARGET)
3006 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3007 return CHECKOP(type, padop);
3011 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3017 return newPADOP(type, flags, SvREFCNT_inc(gv));
3019 return newSVOP(type, flags, SvREFCNT_inc(gv));
3024 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3028 NewOp(1101, pvop, 1, PVOP);
3029 pvop->op_type = (OPCODE)type;
3030 pvop->op_ppaddr = PL_ppaddr[type];
3032 pvop->op_next = (OP*)pvop;
3033 pvop->op_flags = (U8)flags;
3034 if (PL_opargs[type] & OA_RETSCALAR)
3036 if (PL_opargs[type] & OA_TARGET)
3037 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3038 return CHECKOP(type, pvop);
3042 Perl_package(pTHX_ OP *o)
3048 save_hptr(&PL_curstash);
3049 save_item(PL_curstname);
3051 name = SvPV_const(cSVOPo->op_sv, len);
3052 PL_curstash = gv_stashpvn(name, len, TRUE);
3053 sv_setpvn(PL_curstname, name, len);
3056 PL_hints |= HINT_BLOCK_SCOPE;
3057 PL_copline = NOLINE;
3062 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3069 if (idop->op_type != OP_CONST)
3070 Perl_croak(aTHX_ "Module name must be constant");
3075 SV * const vesv = ((SVOP*)version)->op_sv;
3077 if (!arg && !SvNIOKp(vesv)) {
3084 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3085 Perl_croak(aTHX_ "Version number must be constant number");
3087 /* Make copy of idop so we don't free it twice */
3088 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3090 /* Fake up a method call to VERSION */
3091 meth = newSVpvs_share("VERSION");
3092 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3093 append_elem(OP_LIST,
3094 prepend_elem(OP_LIST, pack, list(version)),
3095 newSVOP(OP_METHOD_NAMED, 0, meth)));
3099 /* Fake up an import/unimport */
3100 if (arg && arg->op_type == OP_STUB)
3101 imop = arg; /* no import on explicit () */
3102 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3103 imop = Nullop; /* use 5.0; */
3105 idop->op_private |= OPpCONST_NOVER;
3110 /* Make copy of idop so we don't free it twice */
3111 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3113 /* Fake up a method call to import/unimport */
3115 ? newSVpvs_share("import") : newSVpvs_share("unimport");
3116 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3117 append_elem(OP_LIST,
3118 prepend_elem(OP_LIST, pack, list(arg)),
3119 newSVOP(OP_METHOD_NAMED, 0, meth)));
3122 /* Fake up the BEGIN {}, which does its thing immediately. */
3124 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
3127 append_elem(OP_LINESEQ,
3128 append_elem(OP_LINESEQ,
3129 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, idop)),
3130 newSTATEOP(0, Nullch, veop)),
3131 newSTATEOP(0, Nullch, imop) ));
3133 /* The "did you use incorrect case?" warning used to be here.
3134 * The problem is that on case-insensitive filesystems one
3135 * might get false positives for "use" (and "require"):
3136 * "use Strict" or "require CARP" will work. This causes
3137 * portability problems for the script: in case-strict
3138 * filesystems the script will stop working.
3140 * The "incorrect case" warning checked whether "use Foo"
3141 * imported "Foo" to your namespace, but that is wrong, too:
3142 * there is no requirement nor promise in the language that
3143 * a Foo.pm should or would contain anything in package "Foo".
3145 * There is very little Configure-wise that can be done, either:
3146 * the case-sensitivity of the build filesystem of Perl does not
3147 * help in guessing the case-sensitivity of the runtime environment.
3150 PL_hints |= HINT_BLOCK_SCOPE;
3151 PL_copline = NOLINE;
3153 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3157 =head1 Embedding Functions
3159 =for apidoc load_module
3161 Loads the module whose name is pointed to by the string part of name.
3162 Note that the actual module name, not its filename, should be given.
3163 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3164 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3165 (or 0 for no flags). ver, if specified, provides version semantics
3166 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3167 arguments can be used to specify arguments to the module's import()
3168 method, similar to C<use Foo::Bar VERSION LIST>.
3173 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3176 va_start(args, ver);
3177 vload_module(flags, name, ver, &args);
3181 #ifdef PERL_IMPLICIT_CONTEXT
3183 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3187 va_start(args, ver);
3188 vload_module(flags, name, ver, &args);
3194 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3199 OP * const modname = newSVOP(OP_CONST, 0, name);
3200 modname->op_private |= OPpCONST_BARE;
3202 veop = newSVOP(OP_CONST, 0, ver);
3206 if (flags & PERL_LOADMOD_NOIMPORT) {
3207 imop = sawparens(newNULLLIST());
3209 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3210 imop = va_arg(*args, OP*);
3215 sv = va_arg(*args, SV*);
3217 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3218 sv = va_arg(*args, SV*);
3222 const line_t ocopline = PL_copline;
3223 COP * const ocurcop = PL_curcop;
3224 const int oexpect = PL_expect;
3226 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3227 veop, modname, imop);
3228 PL_expect = oexpect;
3229 PL_copline = ocopline;
3230 PL_curcop = ocurcop;
3235 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
3241 if (!force_builtin) {
3242 gv = gv_fetchpv("do", 0, SVt_PVCV);
3243 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
3244 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
3245 gv = gvp ? *gvp : Nullgv;
3249 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3250 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3251 append_elem(OP_LIST, term,
3252 scalar(newUNOP(OP_RV2CV, 0,
3257 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3263 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3265 return newBINOP(OP_LSLICE, flags,
3266 list(force_list(subscript)),
3267 list(force_list(listval)) );
3271 S_is_list_assignment(pTHX_ register const OP *o)
3276 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3277 o = cUNOPo->op_first;
3279 if (o->op_type == OP_COND_EXPR) {
3280 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
3281 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3286 yyerror("Assignment to both a list and a scalar");
3290 if (o->op_type == OP_LIST &&
3291 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3292 o->op_private & OPpLVAL_INTRO)
3295 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3296 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3297 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3300 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3303 if (o->op_type == OP_RV2SV)
3310 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3316 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3317 return newLOGOP(optype, 0,
3318 mod(scalar(left), optype),
3319 newUNOP(OP_SASSIGN, 0, scalar(right)));
3322 return newBINOP(optype, OPf_STACKED,
3323 mod(scalar(left), optype), scalar(right));
3327 if (is_list_assignment(left)) {
3331 /* Grandfathering $[ assignment here. Bletch.*/
3332 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
3333 PL_eval_start = (left->op_type == OP_CONST) ? right : 0;
3334 left = mod(left, OP_AASSIGN);
3337 else if (left->op_type == OP_CONST) {
3338 /* Result of assignment is always 1 (or we'd be dead already) */
3339 return newSVOP(OP_CONST, 0, newSViv(1));
3341 curop = list(force_list(left));
3342 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3343 o->op_private = (U8)(0 | (flags >> 8));
3345 /* PL_generation sorcery:
3346 * an assignment like ($a,$b) = ($c,$d) is easier than
3347 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3348 * To detect whether there are common vars, the global var
3349 * PL_generation is incremented for each assign op we compile.
3350 * Then, while compiling the assign op, we run through all the
3351 * variables on both sides of the assignment, setting a spare slot
3352 * in each of them to PL_generation. If any of them already have
3353 * that value, we know we've got commonality. We could use a
3354 * single bit marker, but then we'd have to make 2 passes, first
3355 * to clear the flag, then to test and set it. To find somewhere
3356 * to store these values, evil chicanery is done with SvCUR().
3359 if (!(left->op_private & OPpLVAL_INTRO)) {
3362 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3363 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3364 if (curop->op_type == OP_GV) {
3365 GV *gv = cGVOPx_gv(curop);
3366 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3368 SvCUR_set(gv, PL_generation);
3370 else if (curop->op_type == OP_PADSV ||
3371 curop->op_type == OP_PADAV ||
3372 curop->op_type == OP_PADHV ||
3373 curop->op_type == OP_PADANY)
3375 if (PAD_COMPNAME_GEN(curop->op_targ)
3376 == (STRLEN)PL_generation)
3378 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
3381 else if (curop->op_type == OP_RV2CV)
3383 else if (curop->op_type == OP_RV2SV ||
3384 curop->op_type == OP_RV2AV ||
3385 curop->op_type == OP_RV2HV ||
3386 curop->op_type == OP_RV2GV) {
3387 if (lastop->op_type != OP_GV) /* funny deref? */
3390 else if (curop->op_type == OP_PUSHRE) {
3391 if (((PMOP*)curop)->op_pmreplroot) {
3393 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3394 ((PMOP*)curop)->op_pmreplroot));
3396 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3398 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3400 SvCUR_set(gv, PL_generation);
3409 o->op_private |= OPpASSIGN_COMMON;
3411 if (right && right->op_type == OP_SPLIT) {
3413 if ((tmpop = ((LISTOP*)right)->op_first) &&
3414 tmpop->op_type == OP_PUSHRE)
3416 PMOP * const pm = (PMOP*)tmpop;
3417 if (left->op_type == OP_RV2AV &&
3418 !(left->op_private & OPpLVAL_INTRO) &&
3419 !(o->op_private & OPpASSIGN_COMMON) )
3421 tmpop = ((UNOP*)left)->op_first;
3422 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3424 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3425 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3427 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3428 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3430 pm->op_pmflags |= PMf_ONCE;
3431 tmpop = cUNOPo->op_first; /* to list (nulled) */
3432 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3433 tmpop->op_sibling = Nullop; /* don't free split */
3434 right->op_next = tmpop->op_next; /* fix starting loc */
3435 op_free(o); /* blow off assign */
3436 right->op_flags &= ~OPf_WANT;
3437 /* "I don't know and I don't care." */
3442 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3443 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3445 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3447 sv_setiv(sv, PL_modcount+1);
3455 right = newOP(OP_UNDEF, 0);
3456 if (right->op_type == OP_READLINE) {
3457 right->op_flags |= OPf_STACKED;
3458 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3461 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3462 o = newBINOP(OP_SASSIGN, flags,
3463 scalar(right), mod(scalar(left), OP_SASSIGN) );
3467 o = newSVOP(OP_CONST, 0, newSViv(PL_compiling.cop_arybase));
3474 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3477 const U32 seq = intro_my();
3480 NewOp(1101, cop, 1, COP);
3481 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3482 cop->op_type = OP_DBSTATE;
3483 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3486 cop->op_type = OP_NEXTSTATE;
3487 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3489 cop->op_flags = (U8)flags;
3490 cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
3492 cop->op_private |= NATIVE_HINTS;
3494 PL_compiling.op_private = cop->op_private;
3495 cop->op_next = (OP*)cop;
3498 cop->cop_label = label;
3499 PL_hints |= HINT_BLOCK_SCOPE;
3502 cop->cop_arybase = PL_curcop->cop_arybase;
3503 if (specialWARN(PL_curcop->cop_warnings))
3504 cop->cop_warnings = PL_curcop->cop_warnings ;
3506 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3507 if (specialCopIO(PL_curcop->cop_io))
3508 cop->cop_io = PL_curcop->cop_io;
3510 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3513 if (PL_copline == NOLINE)
3514 CopLINE_set(cop, CopLINE(PL_curcop));
3516 CopLINE_set(cop, PL_copline);
3517 PL_copline = NOLINE;
3520 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3522 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3524 CopSTASH_set(cop, PL_curstash);
3526 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3527 SV * const * const svp = av_fetch(CopFILEAVx(PL_curcop), (I32)CopLINE(cop), FALSE);
3528 if (svp && *svp != &PL_sv_undef ) {
3529 (void)SvIOK_on(*svp);
3530 SvIV_set(*svp, PTR2IV(cop));
3534 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3539 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3542 return new_logop(type, flags, &first, &other);
3546 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3551 OP *first = *firstp;
3552 OP * const other = *otherp;
3554 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3555 return newBINOP(type, flags, scalar(first), scalar(other));
3557 scalarboolean(first);
3558 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3559 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3560 if (type == OP_AND || type == OP_OR) {
3566 first = *firstp = cUNOPo->op_first;
3568 first->op_next = o->op_next;
3569 cUNOPo->op_first = Nullop;
3573 if (first->op_type == OP_CONST) {
3574 if (first->op_private & OPpCONST_STRICT)
3575 no_bareword_allowed(first);
3576 else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
3577 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
3578 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
3579 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
3580 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
3583 if (other->op_type == OP_CONST)
3584 other->op_private |= OPpCONST_SHORTCIRCUIT;
3588 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
3589 const OP *o2 = other;
3590 if ( ! (o2->op_type == OP_LIST
3591 && (( o2 = cUNOPx(o2)->op_first))
3592 && o2->op_type == OP_PUSHMARK
3593 && (( o2 = o2->op_sibling)) )
3596 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
3597 || o2->op_type == OP_PADHV)
3598 && o2->op_private & OPpLVAL_INTRO
3599 && ckWARN(WARN_DEPRECATED))
3601 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
3602 "Deprecated use of my() in false conditional");
3607 if (first->op_type == OP_CONST)
3608 first->op_private |= OPpCONST_SHORTCIRCUIT;
3612 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
3613 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
3615 const OP * const k1 = ((UNOP*)first)->op_first;
3616 const OP * const k2 = k1->op_sibling;
3618 switch (first->op_type)
3621 if (k2 && k2->op_type == OP_READLINE
3622 && (k2->op_flags & OPf_STACKED)
3623 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3625 warnop = k2->op_type;
3630 if (k1->op_type == OP_READDIR
3631 || k1->op_type == OP_GLOB
3632 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3633 || k1->op_type == OP_EACH)
3635 warnop = ((k1->op_type == OP_NULL)
3636 ? (OPCODE)k1->op_targ : k1->op_type);
3641 const line_t oldline = CopLINE(PL_curcop);
3642 CopLINE_set(PL_curcop, PL_copline);
3643 Perl_warner(aTHX_ packWARN(WARN_MISC),
3644 "Value of %s%s can be \"0\"; test with defined()",
3646 ((warnop == OP_READLINE || warnop == OP_GLOB)
3647 ? " construct" : "() operator"));
3648 CopLINE_set(PL_curcop, oldline);
3655 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
3656 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3658 NewOp(1101, logop, 1, LOGOP);
3660 logop->op_type = (OPCODE)type;
3661 logop->op_ppaddr = PL_ppaddr[type];
3662 logop->op_first = first;
3663 logop->op_flags = (U8)(flags | OPf_KIDS);
3664 logop->op_other = LINKLIST(other);
3665 logop->op_private = (U8)(1 | (flags >> 8));
3667 /* establish postfix order */
3668 logop->op_next = LINKLIST(first);
3669 first->op_next = (OP*)logop;
3670 first->op_sibling = other;
3672 CHECKOP(type,logop);
3674 o = newUNOP(OP_NULL, 0, (OP*)logop);
3681 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3689 return newLOGOP(OP_AND, 0, first, trueop);
3691 return newLOGOP(OP_OR, 0, first, falseop);
3693 scalarboolean(first);
3694 if (first->op_type == OP_CONST) {
3695 if (first->op_private & OPpCONST_BARE &&
3696 first->op_private & OPpCONST_STRICT) {
3697 no_bareword_allowed(first);
3699 if (SvTRUE(((SVOP*)first)->op_sv)) {
3710 NewOp(1101, logop, 1, LOGOP);
3711 logop->op_type = OP_COND_EXPR;
3712 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3713 logop->op_first = first;
3714 logop->op_flags = (U8)(flags | OPf_KIDS);
3715 logop->op_private = (U8)(1 | (flags >> 8));
3716 logop->op_other = LINKLIST(trueop);
3717 logop->op_next = LINKLIST(falseop);
3719 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
3722 /* establish postfix order */
3723 start = LINKLIST(first);
3724 first->op_next = (OP*)logop;
3726 first->op_sibling = trueop;
3727 trueop->op_sibling = falseop;
3728 o = newUNOP(OP_NULL, 0, (OP*)logop);
3730 trueop->op_next = falseop->op_next = o;
3737 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3746 NewOp(1101, range, 1, LOGOP);
3748 range->op_type = OP_RANGE;
3749 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3750 range->op_first = left;
3751 range->op_flags = OPf_KIDS;
3752 leftstart = LINKLIST(left);
3753 range->op_other = LINKLIST(right);
3754 range->op_private = (U8)(1 | (flags >> 8));
3756 left->op_sibling = right;
3758 range->op_next = (OP*)range;
3759 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3760 flop = newUNOP(OP_FLOP, 0, flip);
3761 o = newUNOP(OP_NULL, 0, flop);
3763 range->op_next = leftstart;
3765 left->op_next = flip;
3766 right->op_next = flop;
3768 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3769 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3770 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3771 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3773 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3774 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3777 if (!flip->op_private || !flop->op_private)
3778 linklist(o); /* blow off optimizer unless constant */
3784 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3789 const bool once = block && block->op_flags & OPf_SPECIAL &&
3790 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3792 PERL_UNUSED_ARG(debuggable);
3795 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3796 return block; /* do {} while 0 does once */
3797 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3798 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3799 expr = newUNOP(OP_DEFINED, 0,
3800 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3801 } else if (expr->op_flags & OPf_KIDS) {
3802 const OP * const k1 = ((UNOP*)expr)->op_first;
3803 const OP * const k2 = k1 ? k1->op_sibling : NULL;
3804 switch (expr->op_type) {
3806 if (k2 && k2->op_type == OP_READLINE
3807 && (k2->op_flags & OPf_STACKED)
3808 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3809 expr = newUNOP(OP_DEFINED, 0, expr);
3813 if (k1->op_type == OP_READDIR
3814 || k1->op_type == OP_GLOB
3815 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3816 || k1->op_type == OP_EACH)
3817 expr = newUNOP(OP_DEFINED, 0, expr);
3823 /* if block is null, the next append_elem() would put UNSTACK, a scalar
3824 * op, in listop. This is wrong. [perl #27024] */
3826 block = newOP(OP_NULL, 0);
3827 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3828 o = new_logop(OP_AND, 0, &expr, &listop);
3831 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3833 if (once && o != listop)
3834 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3837 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3839 o->op_flags |= flags;
3841 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3846 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
3847 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
3856 PERL_UNUSED_ARG(debuggable);
3859 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3860 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3861 expr = newUNOP(OP_DEFINED, 0,
3862 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3863 } else if (expr->op_flags & OPf_KIDS) {
3864 const OP * const k1 = ((UNOP*)expr)->op_first;
3865 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
3866 switch (expr->op_type) {
3868 if (k2 && k2->op_type == OP_READLINE
3869 && (k2->op_flags & OPf_STACKED)
3870 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3871 expr = newUNOP(OP_DEFINED, 0, expr);
3875 if (k1->op_type == OP_READDIR
3876 || k1->op_type == OP_GLOB
3877 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3878 || k1->op_type == OP_EACH)
3879 expr = newUNOP(OP_DEFINED, 0, expr);
3886 block = newOP(OP_NULL, 0);
3887 else if (cont || has_my) {
3888 block = scope(block);
3892 next = LINKLIST(cont);
3895 OP * const unstack = newOP(OP_UNSTACK, 0);
3898 cont = append_elem(OP_LINESEQ, cont, unstack);
3901 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3902 redo = LINKLIST(listop);
3905 PL_copline = (line_t)whileline;
3907 o = new_logop(OP_AND, 0, &expr, &listop);
3908 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3909 op_free(expr); /* oops, it's a while (0) */
3911 return Nullop; /* listop already freed by new_logop */
3914 ((LISTOP*)listop)->op_last->op_next =
3915 (o == listop ? redo : LINKLIST(o));
3921 NewOp(1101,loop,1,LOOP);
3922 loop->op_type = OP_ENTERLOOP;
3923 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3924 loop->op_private = 0;
3925 loop->op_next = (OP*)loop;
3928 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
3930 loop->op_redoop = redo;
3931 loop->op_lastop = o;
3932 o->op_private |= loopflags;
3935 loop->op_nextop = next;
3937 loop->op_nextop = o;
3939 o->op_flags |= flags;
3940 o->op_private |= (flags >> 8);
3945 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
3950 PADOFFSET padoff = 0;
3955 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
3956 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
3957 sv->op_type = OP_RV2GV;
3958 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
3959 if (cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
3960 iterpflags |= OPpITER_DEF;
3962 else if (sv->op_type == OP_PADSV) { /* private variable */
3963 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
3964 padoff = sv->op_targ;
3969 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
3970 padoff = sv->op_targ;
3972 iterflags |= OPf_SPECIAL;
3977 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
3978 if (padoff && strEQ(PAD_COMPNAME_PV(padoff), "$_"))
3979 iterpflags |= OPpITER_DEF;
3982 const I32 offset = pad_findmy("$_");
3983 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
3984 sv = newGVOP(OP_GV, 0, PL_defgv);
3989 iterpflags |= OPpITER_DEF;
3991 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
3992 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
3993 iterflags |= OPf_STACKED;
3995 else if (expr->op_type == OP_NULL &&
3996 (expr->op_flags & OPf_KIDS) &&
3997 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
3999 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4000 * set the STACKED flag to indicate that these values are to be
4001 * treated as min/max values by 'pp_iterinit'.
4003 UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4004 LOGOP* const range = (LOGOP*) flip->op_first;
4005 OP* const left = range->op_first;
4006 OP* const right = left->op_sibling;
4009 range->op_flags &= ~OPf_KIDS;
4010 range->op_first = Nullop;
4012 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4013 listop->op_first->op_next = range->op_next;
4014 left->op_next = range->op_other;
4015 right->op_next = (OP*)listop;
4016 listop->op_next = listop->op_first;
4019 expr = (OP*)(listop);
4021 iterflags |= OPf_STACKED;
4024 expr = mod(force_list(expr), OP_GREPSTART);
4027 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4028 append_elem(OP_LIST, expr, scalar(sv))));
4029 assert(!loop->op_next);
4030 /* for my $x () sets OPpLVAL_INTRO;
4031 * for our $x () sets OPpOUR_INTRO */
4032 loop->op_private = (U8)iterpflags;
4033 #ifdef PL_OP_SLAB_ALLOC
4036 NewOp(1234,tmp,1,LOOP);
4037 Copy(loop,tmp,1,LISTOP);
4042 Renew(loop, 1, LOOP);
4044 loop->op_targ = padoff;
4045 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
4046 PL_copline = forline;
4047 return newSTATEOP(0, label, wop);
4051 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4056 if (type != OP_GOTO || label->op_type == OP_CONST) {
4057 /* "last()" means "last" */
4058 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4059 o = newOP(type, OPf_SPECIAL);
4061 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4062 ? SvPVx_nolen_const(((SVOP*)label)->op_sv)
4068 /* Check whether it's going to be a goto &function */
4069 if (label->op_type == OP_ENTERSUB
4070 && !(label->op_flags & OPf_STACKED))
4071 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4072 o = newUNOP(type, OPf_STACKED, label);
4074 PL_hints |= HINT_BLOCK_SCOPE;
4078 /* if the condition is a literal array or hash
4079 (or @{ ... } etc), make a reference to it.
4082 S_ref_array_or_hash(pTHX_ OP *cond)
4085 && (cond->op_type == OP_RV2AV
4086 || cond->op_type == OP_PADAV
4087 || cond->op_type == OP_RV2HV
4088 || cond->op_type == OP_PADHV))
4090 return newUNOP(OP_REFGEN,
4091 0, mod(cond, OP_REFGEN));
4097 /* These construct the optree fragments representing given()
4100 entergiven and enterwhen are LOGOPs; the op_other pointer
4101 points up to the associated leave op. We need this so we
4102 can put it in the context and make break/continue work.
4103 (Also, of course, pp_enterwhen will jump straight to
4104 op_other if the match fails.)
4109 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
4110 I32 enter_opcode, I32 leave_opcode,
4111 PADOFFSET entertarg)
4117 NewOp(1101, enterop, 1, LOGOP);
4118 enterop->op_type = enter_opcode;
4119 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
4120 enterop->op_flags = (U8) OPf_KIDS;
4121 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
4122 enterop->op_private = 0;
4124 o = newUNOP(leave_opcode, 0, (OP *) enterop);
4127 enterop->op_first = scalar(cond);
4128 cond->op_sibling = block;
4130 o->op_next = LINKLIST(cond);
4131 cond->op_next = (OP *) enterop;
4134 /* This is a default {} block */
4135 enterop->op_first = block;
4136 enterop->op_flags |= OPf_SPECIAL;
4138 o->op_next = (OP *) enterop;
4141 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
4142 entergiven and enterwhen both
4145 enterop->op_next = LINKLIST(block);
4146 block->op_next = enterop->op_other = o;
4151 /* Does this look like a boolean operation? For these purposes
4152 a boolean operation is:
4153 - a subroutine call [*]
4154 - a logical connective
4155 - a comparison operator
4156 - a filetest operator, with the exception of -s -M -A -C
4157 - defined(), exists() or eof()
4158 - /$re/ or $foo =~ /$re/
4160 [*] possibly surprising
4164 S_looks_like_bool(pTHX_ OP *o)
4167 switch(o->op_type) {
4169 return looks_like_bool(cLOGOPo->op_first);
4173 looks_like_bool(cLOGOPo->op_first)
4174 && looks_like_bool(cLOGOPo->op_first->op_sibling));
4178 case OP_NOT: case OP_XOR:
4179 /* Note that OP_DOR is not here */
4181 case OP_EQ: case OP_NE: case OP_LT:
4182 case OP_GT: case OP_LE: case OP_GE:
4184 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
4185 case OP_I_GT: case OP_I_LE: case OP_I_GE:
4187 case OP_SEQ: case OP_SNE: case OP_SLT:
4188 case OP_SGT: case OP_SLE: case OP_SGE:
4192 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
4193 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
4194 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
4195 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
4196 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
4197 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
4198 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
4199 case OP_FTTEXT: case OP_FTBINARY:
4201 case OP_DEFINED: case OP_EXISTS:
4202 case OP_MATCH: case OP_EOF:
4207 /* Detect comparisons that have been optimized away */
4208 if (cSVOPo->op_sv == &PL_sv_yes
4209 || cSVOPo->op_sv == &PL_sv_no)
4220 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
4224 return newGIVWHENOP(
4225 ref_array_or_hash(cond),
4227 OP_ENTERGIVEN, OP_LEAVEGIVEN,
4231 /* If cond is null, this is a default {} block */
4233 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
4235 bool cond_llb = (!cond || looks_like_bool(cond));
4241 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
4243 scalar(ref_array_or_hash(cond)));
4246 return newGIVWHENOP(
4248 append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
4249 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
4253 =for apidoc cv_undef
4255 Clear out all the active components of a CV. This can happen either
4256 by an explicit C<undef &foo>, or by the reference count going to zero.
4257 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
4258 children can still follow the full lexical scope chain.
4264 Perl_cv_undef(pTHX_ CV *cv)
4268 if (CvFILE(cv) && !CvXSUB(cv)) {
4269 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4270 Safefree(CvFILE(cv));
4275 if (!CvXSUB(cv) && CvROOT(cv)) {
4277 Perl_croak(aTHX_ "Can't undef active subroutine");
4280 PAD_SAVE_SETNULLPAD();
4282 op_free(CvROOT(cv));
4283 CvROOT(cv) = Nullop;
4284 CvSTART(cv) = Nullop;
4287 SvPOK_off((SV*)cv); /* forget prototype */
4292 /* remove CvOUTSIDE unless this is an undef rather than a free */
4293 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
4294 if (!CvWEAKOUTSIDE(cv))
4295 SvREFCNT_dec(CvOUTSIDE(cv));
4296 CvOUTSIDE(cv) = Nullcv;
4299 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4305 /* delete all flags except WEAKOUTSIDE */
4306 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
4310 Perl_cv_ckproto(pTHX_ const CV *cv, const GV *gv, const char *p)
4312 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX_const(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4313 SV* const msg = sv_newmortal();
4317 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4318 sv_setpv(msg, "Prototype mismatch:");
4320 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4322 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (const SV *)cv);
4324 sv_catpvs(msg, ": none");
4325 sv_catpvs(msg, " vs ");
4327 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4329 sv_catpvs(msg, "none");
4330 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
4334 static void const_sv_xsub(pTHX_ CV* cv);
4338 =head1 Optree Manipulation Functions
4340 =for apidoc cv_const_sv
4342 If C<cv> is a constant sub eligible for inlining. returns the constant
4343 value returned by the sub. Otherwise, returns NULL.
4345 Constant subs can be created with C<newCONSTSUB> or as described in
4346 L<perlsub/"Constant Functions">.
4351 Perl_cv_const_sv(pTHX_ CV *cv)
4355 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
4357 return CvCONST(cv) ? (SV*)CvXSUBANY(cv).any_ptr : NULL;
4360 /* op_const_sv: examine an optree to determine whether it's in-lineable.
4361 * Can be called in 3 ways:
4364 * look for a single OP_CONST with attached value: return the value
4366 * cv && CvCLONE(cv) && !CvCONST(cv)
4368 * examine the clone prototype, and if contains only a single
4369 * OP_CONST referencing a pad const, or a single PADSV referencing
4370 * an outer lexical, return a non-zero value to indicate the CV is
4371 * a candidate for "constizing" at clone time
4375 * We have just cloned an anon prototype that was marked as a const
4376 * candidiate. Try to grab the current value, and in the case of
4377 * PADSV, ignore it if it has multiple references. Return the value.
4381 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
4389 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4390 o = cLISTOPo->op_first->op_sibling;
4392 for (; o; o = o->op_next) {
4393 const OPCODE type = o->op_type;
4395 if (sv && o->op_next == o)
4397 if (o->op_next != o) {
4398 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4400 if (type == OP_DBSTATE)
4403 if (type == OP_LEAVESUB || type == OP_RETURN)
4407 if (type == OP_CONST && cSVOPo->op_sv)
4409 else if (cv && type == OP_CONST) {
4410 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4414 else if (cv && type == OP_PADSV) {
4415 if (CvCONST(cv)) { /* newly cloned anon */
4416 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4417 /* the candidate should have 1 ref from this pad and 1 ref
4418 * from the parent */
4419 if (!sv || SvREFCNT(sv) != 2)
4426 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
4427 sv = &PL_sv_undef; /* an arbitrary non-null value */
4438 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4440 PERL_UNUSED_ARG(floor);
4450 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4454 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4456 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4460 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4467 register CV *cv = NULL;
4469 /* If the subroutine has no body, no attributes, and no builtin attributes
4470 then it's just a sub declaration, and we may be able to get away with
4471 storing with a placeholder scalar in the symbol table, rather than a
4472 full GV and CV. If anything is present then it will take a full CV to
4474 const I32 gv_fetch_flags
4475 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
4476 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
4477 const char * const name = o ? SvPVx_nolen_const(cSVOPo->op_sv) : Nullch;
4480 assert(proto->op_type == OP_CONST);
4481 ps = SvPVx_const(((SVOP*)proto)->op_sv, ps_len);
4486 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4487 SV * const sv = sv_newmortal();
4488 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4489 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
4490 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4491 aname = SvPVX_const(sv);
4496 gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
4497 : gv_fetchpv(aname ? aname
4498 : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4499 gv_fetch_flags, SVt_PVCV);
4508 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4509 maximum a prototype before. */
4510 if (SvTYPE(gv) > SVt_NULL) {
4511 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4512 && ckWARN_d(WARN_PROTOTYPE))
4514 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
4516 cv_ckproto((CV*)gv, NULL, ps);
4519 sv_setpvn((SV*)gv, ps, ps_len);
4521 sv_setiv((SV*)gv, -1);
4522 SvREFCNT_dec(PL_compcv);
4523 cv = PL_compcv = NULL;
4524 PL_sub_generation++;
4528 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4530 #ifdef GV_UNIQUE_CHECK
4531 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4532 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4536 if (!block || !ps || *ps || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
4539 const_sv = op_const_sv(block, Nullcv);
4542 const bool exists = CvROOT(cv) || CvXSUB(cv);
4544 #ifdef GV_UNIQUE_CHECK
4545 if (exists && GvUNIQUE(gv)) {
4546 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4550 /* if the subroutine doesn't exist and wasn't pre-declared
4551 * with a prototype, assume it will be AUTOLOADed,
4552 * skipping the prototype check
4554 if (exists || SvPOK(cv))
4555 cv_ckproto(cv, gv, ps);
4556 /* already defined (or promised)? */
4557 if (exists || GvASSUMECV(gv)) {
4558 if (!block && !attrs) {
4559 if (CvFLAGS(PL_compcv)) {
4560 /* might have had built-in attrs applied */
4561 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4563 /* just a "sub foo;" when &foo is already defined */
4564 SAVEFREESV(PL_compcv);
4568 if (ckWARN(WARN_REDEFINE)
4570 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4572 const line_t oldline = CopLINE(PL_curcop);
4573 if (PL_copline != NOLINE)
4574 CopLINE_set(PL_curcop, PL_copline);
4575 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4576 CvCONST(cv) ? "Constant subroutine %s redefined"
4577 : "Subroutine %s redefined", name);
4578 CopLINE_set(PL_curcop, oldline);
4586 (void)SvREFCNT_inc(const_sv);
4588 assert(!CvROOT(cv) && !CvCONST(cv));
4589 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
4590 CvXSUBANY(cv).any_ptr = const_sv;
4591 CvXSUB(cv) = const_sv_xsub;
4596 cv = newCONSTSUB(NULL, name, const_sv);
4599 SvREFCNT_dec(PL_compcv);
4601 PL_sub_generation++;
4608 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4609 * before we clobber PL_compcv.
4613 /* Might have had built-in attributes applied -- propagate them. */
4614 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4615 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4616 stash = GvSTASH(CvGV(cv));
4617 else if (CvSTASH(cv))
4618 stash = CvSTASH(cv);
4620 stash = PL_curstash;
4623 /* possibly about to re-define existing subr -- ignore old cv */
4624 rcv = (SV*)PL_compcv;
4625 if (name && GvSTASH(gv))
4626 stash = GvSTASH(gv);
4628 stash = PL_curstash;
4630 apply_attrs(stash, rcv, attrs, FALSE);
4632 if (cv) { /* must reuse cv if autoloaded */
4634 /* got here with just attrs -- work done, so bug out */
4635 SAVEFREESV(PL_compcv);
4638 /* transfer PL_compcv to cv */
4640 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4641 if (!CvWEAKOUTSIDE(cv))
4642 SvREFCNT_dec(CvOUTSIDE(cv));
4643 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4644 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
4645 CvOUTSIDE(PL_compcv) = 0;
4646 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4647 CvPADLIST(PL_compcv) = 0;
4648 /* inner references to PL_compcv must be fixed up ... */
4649 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
4650 /* ... before we throw it away */
4651 SvREFCNT_dec(PL_compcv);
4653 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4654 ++PL_sub_generation;
4661 PL_sub_generation++;
4665 CvFILE_set_from_cop(cv, PL_curcop);
4666 CvSTASH(cv) = PL_curstash;
4669 sv_setpvn((SV*)cv, ps, ps_len);
4671 if (PL_error_count) {
4675 const char *s = strrchr(name, ':');
4677 if (strEQ(s, "BEGIN")) {
4678 const char not_safe[] =
4679 "BEGIN not safe after errors--compilation aborted";
4680 if (PL_in_eval & EVAL_KEEPERR)
4681 Perl_croak(aTHX_ not_safe);
4683 /* force display of errors found but not reported */
4684 sv_catpv(ERRSV, not_safe);
4685 Perl_croak(aTHX_ "%"SVf, ERRSV);
4694 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4695 mod(scalarseq(block), OP_LEAVESUBLV));
4698 /* This makes sub {}; work as expected. */
4699 if (block->op_type == OP_STUB) {
4701 block = newSTATEOP(0, Nullch, 0);
4703 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4705 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4706 OpREFCNT_set(CvROOT(cv), 1);
4707 CvSTART(cv) = LINKLIST(CvROOT(cv));
4708 CvROOT(cv)->op_next = 0;
4709 CALL_PEEP(CvSTART(cv));
4711 /* now that optimizer has done its work, adjust pad values */
4713 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4716 assert(!CvCONST(cv));
4717 if (ps && !*ps && op_const_sv(block, cv))
4721 if (name || aname) {
4723 const char * const tname = (name ? name : aname);
4725 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4726 SV * const sv = NEWSV(0,0);
4727 SV * const tmpstr = sv_newmortal();
4728 GV * const db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4731 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4733 (long)PL_subline, (long)CopLINE(PL_curcop));
4734 gv_efullname3(tmpstr, gv, Nullch);
4735 hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0);
4736 hv = GvHVn(db_postponed);
4737 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
4738 CV * const pcv = GvCV(db_postponed);
4744 call_sv((SV*)pcv, G_DISCARD);
4749 if ((s = strrchr(tname,':')))
4754 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4757 if (strEQ(s, "BEGIN") && !PL_error_count) {
4758 const I32 oldscope = PL_scopestack_ix;
4760 SAVECOPFILE(&PL_compiling);
4761 SAVECOPLINE(&PL_compiling);
4764 PL_beginav = newAV();
4765 DEBUG_x( dump_sub(gv) );
4766 av_push(PL_beginav, (SV*)cv);
4767 GvCV(gv) = 0; /* cv has been hijacked */
4768 call_list(oldscope, PL_beginav);
4770 PL_curcop = &PL_compiling;
4771 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4774 else if (strEQ(s, "END") && !PL_error_count) {
4777 DEBUG_x( dump_sub(gv) );
4778 av_unshift(PL_endav, 1);
4779 av_store(PL_endav, 0, (SV*)cv);
4780 GvCV(gv) = 0; /* cv has been hijacked */
4782 else if (strEQ(s, "CHECK") && !PL_error_count) {
4784 PL_checkav = newAV();
4785 DEBUG_x( dump_sub(gv) );
4786 if (PL_main_start && ckWARN(WARN_VOID))
4787 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4788 av_unshift(PL_checkav, 1);
4789 av_store(PL_checkav, 0, (SV*)cv);
4790 GvCV(gv) = 0; /* cv has been hijacked */
4792 else if (strEQ(s, "INIT") && !PL_error_count) {
4794 PL_initav = newAV();
4795 DEBUG_x( dump_sub(gv) );
4796 if (PL_main_start && ckWARN(WARN_VOID))
4797 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4798 av_push(PL_initav, (SV*)cv);
4799 GvCV(gv) = 0; /* cv has been hijacked */
4804 PL_copline = NOLINE;
4809 /* XXX unsafe for threads if eval_owner isn't held */
4811 =for apidoc newCONSTSUB
4813 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4814 eligible for inlining at compile-time.
4820 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
4827 SAVECOPLINE(PL_curcop);
4828 CopLINE_set(PL_curcop, PL_copline);
4831 PL_hints &= ~HINT_BLOCK_SCOPE;
4834 SAVESPTR(PL_curstash);
4835 SAVECOPSTASH(PL_curcop);
4836 PL_curstash = stash;
4837 CopSTASH_set(PL_curcop,stash);
4840 cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
4841 CvXSUBANY(cv).any_ptr = sv;
4843 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
4847 CopSTASH_free(PL_curcop);
4855 =for apidoc U||newXS
4857 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4863 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
4866 GV * const gv = gv_fetchpv(name ? name :
4867 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4868 GV_ADDMULTI, SVt_PVCV);
4872 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4874 if ((cv = (name ? GvCV(gv) : Nullcv))) {
4876 /* just a cached method */
4880 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4881 /* already defined (or promised) */
4882 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
4883 if (ckWARN(WARN_REDEFINE)) {
4884 GV * const gvcv = CvGV(cv);
4886 HV * const stash = GvSTASH(gvcv);
4888 const char *name = HvNAME_get(stash);
4889 if ( strEQ(name,"autouse") ) {
4890 const line_t oldline = CopLINE(PL_curcop);
4891 if (PL_copline != NOLINE)
4892 CopLINE_set(PL_curcop, PL_copline);
4893 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4894 CvCONST(cv) ? "Constant subroutine %s redefined"
4895 : "Subroutine %s redefined"
4897 CopLINE_set(PL_curcop, oldline);
4907 if (cv) /* must reuse cv if autoloaded */
4910 cv = (CV*)NEWSV(1105,0);
4911 sv_upgrade((SV *)cv, SVt_PVCV);
4915 PL_sub_generation++;
4919 (void)gv_fetchfile(filename);
4920 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
4921 an external constant string */
4922 CvXSUB(cv) = subaddr;
4925 const char *s = strrchr(name,':');
4931 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4934 if (strEQ(s, "BEGIN")) {
4936 PL_beginav = newAV();
4937 av_push(PL_beginav, (SV*)cv);
4938 GvCV(gv) = 0; /* cv has been hijacked */
4940 else if (strEQ(s, "END")) {
4943 av_unshift(PL_endav, 1);
4944 av_store(PL_endav, 0, (SV*)cv);
4945 GvCV(gv) = 0; /* cv has been hijacked */
4947 else if (strEQ(s, "CHECK")) {
4949 PL_checkav = newAV();
4950 if (PL_main_start && ckWARN(WARN_VOID))
4951 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4952 av_unshift(PL_checkav, 1);
4953 av_store(PL_checkav, 0, (SV*)cv);
4954 GvCV(gv) = 0; /* cv has been hijacked */
4956 else if (strEQ(s, "INIT")) {
4958 PL_initav = newAV();
4959 if (PL_main_start && ckWARN(WARN_VOID))
4960 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4961 av_push(PL_initav, (SV*)cv);
4962 GvCV(gv) = 0; /* cv has been hijacked */
4973 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4979 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
4980 : gv_fetchpv("STDOUT", GV_ADD, SVt_PVFM);
4982 #ifdef GV_UNIQUE_CHECK
4984 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
4988 if ((cv = GvFORM(gv))) {
4989 if (ckWARN(WARN_REDEFINE)) {
4990 const line_t oldline = CopLINE(PL_curcop);
4991 if (PL_copline != NOLINE)
4992 CopLINE_set(PL_curcop, PL_copline);
4993 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4994 o ? "Format %"SVf" redefined"
4995 : "Format STDOUT redefined" ,cSVOPo->op_sv);
4996 CopLINE_set(PL_curcop, oldline);
5003 CvFILE_set_from_cop(cv, PL_curcop);
5006 pad_tidy(padtidy_FORMAT);
5007 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5008 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5009 OpREFCNT_set(CvROOT(cv), 1);
5010 CvSTART(cv) = LINKLIST(CvROOT(cv));
5011 CvROOT(cv)->op_next = 0;
5012 CALL_PEEP(CvSTART(cv));
5014 PL_copline = NOLINE;
5019 Perl_newANONLIST(pTHX_ OP *o)
5021 return newUNOP(OP_REFGEN, 0,
5022 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5026 Perl_newANONHASH(pTHX_ OP *o)
5028 return newUNOP(OP_REFGEN, 0,
5029 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5033 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5035 return newANONATTRSUB(floor, proto, Nullop, block);
5039 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5041 return newUNOP(OP_REFGEN, 0,
5042 newSVOP(OP_ANONCODE, 0,
5043 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5047 Perl_oopsAV(pTHX_ OP *o)
5050 switch (o->op_type) {
5052 o->op_type = OP_PADAV;
5053 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5054 return ref(o, OP_RV2AV);
5057 o->op_type = OP_RV2AV;
5058 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5063 if (ckWARN_d(WARN_INTERNAL))
5064 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
5071 Perl_oopsHV(pTHX_ OP *o)
5074 switch (o->op_type) {
5077 o->op_type = OP_PADHV;
5078 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5079 return ref(o, OP_RV2HV);
5083 o->op_type = OP_RV2HV;
5084 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5089 if (ckWARN_d(WARN_INTERNAL))
5090 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
5097 Perl_newAVREF(pTHX_ OP *o)
5100 if (o->op_type == OP_PADANY) {
5101 o->op_type = OP_PADAV;
5102 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5105 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5106 && ckWARN(WARN_DEPRECATED)) {
5107 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5108 "Using an array as a reference is deprecated");
5110 return newUNOP(OP_RV2AV, 0, scalar(o));
5114 Perl_newGVREF(pTHX_ I32 type, OP *o)
5116 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5117 return newUNOP(OP_NULL, 0, o);
5118 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5122 Perl_newHVREF(pTHX_ OP *o)
5125 if (o->op_type == OP_PADANY) {
5126 o->op_type = OP_PADHV;
5127 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5130 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5131 && ckWARN(WARN_DEPRECATED)) {
5132 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5133 "Using a hash as a reference is deprecated");
5135 return newUNOP(OP_RV2HV, 0, scalar(o));
5139 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5141 return newUNOP(OP_RV2CV, flags, scalar(o));
5145 Perl_newSVREF(pTHX_ OP *o)
5148 if (o->op_type == OP_PADANY) {
5149 o->op_type = OP_PADSV;
5150 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5153 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5154 o->op_flags |= OPpDONE_SVREF;
5157 return newUNOP(OP_RV2SV, 0, scalar(o));
5160 /* Check routines. See the comments at the top of this file for details
5161 * on when these are called */
5164 Perl_ck_anoncode(pTHX_ OP *o)
5166 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
5167 cSVOPo->op_sv = Nullsv;
5172 Perl_ck_bitop(pTHX_ OP *o)
5175 #define OP_IS_NUMCOMPARE(op) \
5176 ((op) == OP_LT || (op) == OP_I_LT || \
5177 (op) == OP_GT || (op) == OP_I_GT || \
5178 (op) == OP_LE || (op) == OP_I_LE || \
5179 (op) == OP_GE || (op) == OP_I_GE || \
5180 (op) == OP_EQ || (op) == OP_I_EQ || \
5181 (op) == OP_NE || (op) == OP_I_NE || \
5182 (op) == OP_NCMP || (op) == OP_I_NCMP)
5183 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
5184 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
5185 && (o->op_type == OP_BIT_OR
5186 || o->op_type == OP_BIT_AND
5187 || o->op_type == OP_BIT_XOR))
5189 const OP * const left = cBINOPo->op_first;
5190 const OP * const right = left->op_sibling;
5191 if ((OP_IS_NUMCOMPARE(left->op_type) &&
5192 (left->op_flags & OPf_PARENS) == 0) ||
5193 (OP_IS_NUMCOMPARE(right->op_type) &&
5194 (right->op_flags & OPf_PARENS) == 0))
5195 if (ckWARN(WARN_PRECEDENCE))
5196 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
5197 "Possible precedence problem on bitwise %c operator",
5198 o->op_type == OP_BIT_OR ? '|'
5199 : o->op_type == OP_BIT_AND ? '&' : '^'
5206 Perl_ck_concat(pTHX_ OP *o)
5208 const OP * const kid = cUNOPo->op_first;
5209 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
5210 !(kUNOP->op_first->op_flags & OPf_MOD))
5211 o->op_flags |= OPf_STACKED;
5216 Perl_ck_spair(pTHX_ OP *o)
5219 if (o->op_flags & OPf_KIDS) {
5222 const OPCODE type = o->op_type;
5223 o = modkids(ck_fun(o), type);
5224 kid = cUNOPo->op_first;
5225 newop = kUNOP->op_first->op_sibling;
5227 (newop->op_sibling ||
5228 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5229 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5230 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5234 op_free(kUNOP->op_first);
5235 kUNOP->op_first = newop;
5237 o->op_ppaddr = PL_ppaddr[++o->op_type];
5242 Perl_ck_delete(pTHX_ OP *o)
5246 if (o->op_flags & OPf_KIDS) {
5247 OP * const kid = cUNOPo->op_first;
5248 switch (kid->op_type) {
5250 o->op_flags |= OPf_SPECIAL;
5253 o->op_private |= OPpSLICE;
5256 o->op_flags |= OPf_SPECIAL;
5261 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5270 Perl_ck_die(pTHX_ OP *o)
5273 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5279 Perl_ck_eof(pTHX_ OP *o)
5282 const I32 type = o->op_type;
5284 if (o->op_flags & OPf_KIDS) {
5285 if (cLISTOPo->op_first->op_type == OP_STUB) {
5287 o = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
5295 Perl_ck_eval(pTHX_ OP *o)
5298 PL_hints |= HINT_BLOCK_SCOPE;
5299 if (o->op_flags & OPf_KIDS) {
5300 SVOP * const kid = (SVOP*)cUNOPo->op_first;
5303 o->op_flags &= ~OPf_KIDS;
5306 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
5309 cUNOPo->op_first = 0;
5312 NewOp(1101, enter, 1, LOGOP);
5313 enter->op_type = OP_ENTERTRY;
5314 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5315 enter->op_private = 0;
5317 /* establish postfix order */
5318 enter->op_next = (OP*)enter;
5320 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5321 o->op_type = OP_LEAVETRY;
5322 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5323 enter->op_other = o;
5333 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5335 o->op_targ = (PADOFFSET)PL_hints;
5336 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
5337 /* Store a copy of %^H that pp_entereval can pick up */
5338 OP *hhop = newSVOP(OP_CONST, 0, (SV*)newHVhv(GvHV(PL_hintgv)));
5339 cUNOPo->op_first->op_sibling = hhop;
5340 o->op_private |= OPpEVAL_HAS_HH;
5346 Perl_ck_exit(pTHX_ OP *o)
5349 HV * const table = GvHV(PL_hintgv);
5351 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
5352 if (svp && *svp && SvTRUE(*svp))
5353 o->op_private |= OPpEXIT_VMSISH;
5355 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5361 Perl_ck_exec(pTHX_ OP *o)
5363 if (o->op_flags & OPf_STACKED) {
5366 kid = cUNOPo->op_first->op_sibling;
5367 if (kid->op_type == OP_RV2GV)
5376 Perl_ck_exists(pTHX_ OP *o)
5380 if (o->op_flags & OPf_KIDS) {
5381 OP * const kid = cUNOPo->op_first;
5382 if (kid->op_type == OP_ENTERSUB) {
5383 (void) ref(kid, o->op_type);
5384 if (kid->op_type != OP_RV2CV && !PL_error_count)
5385 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5387 o->op_private |= OPpEXISTS_SUB;
5389 else if (kid->op_type == OP_AELEM)
5390 o->op_flags |= OPf_SPECIAL;
5391 else if (kid->op_type != OP_HELEM)
5392 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5400 Perl_ck_rvconst(pTHX_ register OP *o)
5403 SVOP * const kid = (SVOP*)cUNOPo->op_first;
5405 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5406 if (o->op_type == OP_RV2CV)
5407 o->op_private &= ~1;
5409 if (kid->op_type == OP_CONST) {
5412 SV * const kidsv = kid->op_sv;
5414 /* Is it a constant from cv_const_sv()? */
5415 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5416 SV * const rsv = SvRV(kidsv);
5417 const int svtype = SvTYPE(rsv);
5418 const char *badtype = Nullch;
5420 switch (o->op_type) {
5422 if (svtype > SVt_PVMG)
5423 badtype = "a SCALAR";
5426 if (svtype != SVt_PVAV)
5427 badtype = "an ARRAY";
5430 if (svtype != SVt_PVHV)
5434 if (svtype != SVt_PVCV)
5439 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5442 else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
5443 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
5444 /* If this is an access to a stash, disable "strict refs", because
5445 * stashes aren't auto-vivified at compile-time (unless we store
5446 * symbols in them), and we don't want to produce a run-time
5447 * stricture error when auto-vivifying the stash. */
5448 const char *s = SvPV_nolen(kidsv);
5449 const STRLEN l = SvCUR(kidsv);
5450 if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
5451 o->op_private &= ~HINT_STRICT_REFS;
5453 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5454 const char *badthing = Nullch;
5455 switch (o->op_type) {
5457 badthing = "a SCALAR";
5460 badthing = "an ARRAY";
5463 badthing = "a HASH";
5468 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
5472 * This is a little tricky. We only want to add the symbol if we
5473 * didn't add it in the lexer. Otherwise we get duplicate strict
5474 * warnings. But if we didn't add it in the lexer, we must at
5475 * least pretend like we wanted to add it even if it existed before,
5476 * or we get possible typo warnings. OPpCONST_ENTERED says
5477 * whether the lexer already added THIS instance of this symbol.
5479 iscv = (o->op_type == OP_RV2CV) * 2;
5481 gv = gv_fetchsv(kidsv,
5482 iscv | !(kid->op_private & OPpCONST_ENTERED),
5485 : o->op_type == OP_RV2SV
5487 : o->op_type == OP_RV2AV
5489 : o->op_type == OP_RV2HV
5492 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5494 kid->op_type = OP_GV;
5495 SvREFCNT_dec(kid->op_sv);
5497 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5498 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5499 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
5501 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv));
5503 kid->op_sv = SvREFCNT_inc(gv);
5505 kid->op_private = 0;
5506 kid->op_ppaddr = PL_ppaddr[OP_GV];
5513 Perl_ck_ftst(pTHX_ OP *o)
5516 const I32 type = o->op_type;
5518 if (o->op_flags & OPf_REF) {
5521 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5522 SVOP * const kid = (SVOP*)cUNOPo->op_first;
5524 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5525 OP * const newop = newGVOP(type, OPf_REF,
5526 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
5532 if ((PL_hints & HINT_FILETEST_ACCESS) &&
5533 OP_IS_FILETEST_ACCESS(o))
5534 o->op_private |= OPpFT_ACCESS;
5536 if (PL_check[kid->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst)
5537 && kid->op_type != OP_STAT && kid->op_type != OP_LSTAT)
5538 o->op_private |= OPpFT_STACKED;
5542 if (type == OP_FTTTY)
5543 o = newGVOP(type, OPf_REF, PL_stdingv);
5545 o = newUNOP(type, 0, newDEFSVOP());
5551 Perl_ck_fun(pTHX_ OP *o)
5554 const int type = o->op_type;
5555 register I32 oa = PL_opargs[type] >> OASHIFT;
5557 if (o->op_flags & OPf_STACKED) {
5558 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5561 return no_fh_allowed(o);
5564 if (o->op_flags & OPf_KIDS) {
5565 OP **tokid = &cLISTOPo->op_first;
5566 register OP *kid = cLISTOPo->op_first;
5570 if (kid->op_type == OP_PUSHMARK ||
5571 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5573 tokid = &kid->op_sibling;
5574 kid = kid->op_sibling;
5576 if (!kid && PL_opargs[type] & OA_DEFGV)
5577 *tokid = kid = newDEFSVOP();
5581 sibl = kid->op_sibling;
5584 /* list seen where single (scalar) arg expected? */
5585 if (numargs == 1 && !(oa >> 4)
5586 && kid->op_type == OP_LIST && type != OP_SCALAR)
5588 return too_many_arguments(o,PL_op_desc[type]);
5601 if ((type == OP_PUSH || type == OP_UNSHIFT)
5602 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5603 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5604 "Useless use of %s with no values",
5607 if (kid->op_type == OP_CONST &&
5608 (kid->op_private & OPpCONST_BARE))
5610 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
5611 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
5612 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5613 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5614 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
5615 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
5618 kid->op_sibling = sibl;
5621 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5622 bad_type(numargs, "array", PL_op_desc[type], kid);
5626 if (kid->op_type == OP_CONST &&
5627 (kid->op_private & OPpCONST_BARE))
5629 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
5630 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
5631 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5632 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5633 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
5634 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
5637 kid->op_sibling = sibl;
5640 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5641 bad_type(numargs, "hash", PL_op_desc[type], kid);
5646 OP * const newop = newUNOP(OP_NULL, 0, kid);
5647 kid->op_sibling = 0;
5649 newop->op_next = newop;
5651 kid->op_sibling = sibl;
5656 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5657 if (kid->op_type == OP_CONST &&
5658 (kid->op_private & OPpCONST_BARE))
5660 OP * const newop = newGVOP(OP_GV, 0,
5661 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
5662 if (!(o->op_private & 1) && /* if not unop */
5663 kid == cLISTOPo->op_last)
5664 cLISTOPo->op_last = newop;
5668 else if (kid->op_type == OP_READLINE) {
5669 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5670 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5673 I32 flags = OPf_SPECIAL;
5677 /* is this op a FH constructor? */
5678 if (is_handle_constructor(o,numargs)) {
5679 const char *name = Nullch;
5683 /* Set a flag to tell rv2gv to vivify
5684 * need to "prove" flag does not mean something
5685 * else already - NI-S 1999/05/07
5688 if (kid->op_type == OP_PADSV) {
5689 name = PAD_COMPNAME_PV(kid->op_targ);
5690 /* SvCUR of a pad namesv can't be trusted
5691 * (see PL_generation), so calc its length
5697 else if (kid->op_type == OP_RV2SV
5698 && kUNOP->op_first->op_type == OP_GV)
5700 GV * const gv = cGVOPx_gv(kUNOP->op_first);
5702 len = GvNAMELEN(gv);
5704 else if (kid->op_type == OP_AELEM
5705 || kid->op_type == OP_HELEM)
5707 OP *op = ((BINOP*)kid)->op_first;
5710 SV *tmpstr = Nullsv;
5711 const char * const a =
5712 kid->op_type == OP_AELEM ?
5714 if (((op->op_type == OP_RV2AV) ||
5715 (op->op_type == OP_RV2HV)) &&
5716 (op = ((UNOP*)op)->op_first) &&
5717 (op->op_type == OP_GV)) {
5718 /* packagevar $a[] or $h{} */
5719 GV * const gv = cGVOPx_gv(op);
5727 else if (op->op_type == OP_PADAV
5728 || op->op_type == OP_PADHV) {
5729 /* lexicalvar $a[] or $h{} */
5730 const char * const padname =
5731 PAD_COMPNAME_PV(op->op_targ);
5740 name = SvPV_const(tmpstr, len);
5745 name = "__ANONIO__";
5752 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5753 namesv = PAD_SVl(targ);
5754 SvUPGRADE(namesv, SVt_PV);
5756 sv_setpvn(namesv, "$", 1);
5757 sv_catpvn(namesv, name, len);
5760 kid->op_sibling = 0;
5761 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5762 kid->op_targ = targ;
5763 kid->op_private |= priv;
5765 kid->op_sibling = sibl;
5771 mod(scalar(kid), type);
5775 tokid = &kid->op_sibling;
5776 kid = kid->op_sibling;
5778 o->op_private |= numargs;
5780 return too_many_arguments(o,OP_DESC(o));
5783 else if (PL_opargs[type] & OA_DEFGV) {
5785 return newUNOP(type, 0, newDEFSVOP());
5789 while (oa & OA_OPTIONAL)
5791 if (oa && oa != OA_LIST)
5792 return too_few_arguments(o,OP_DESC(o));
5798 Perl_ck_glob(pTHX_ OP *o)
5804 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5805 append_elem(OP_GLOB, o, newDEFSVOP());
5807 if (!((gv = gv_fetchpv("glob", 0, SVt_PVCV))
5808 && GvCVu(gv) && GvIMPORTED_CV(gv)))
5810 gv = gv_fetchpv("CORE::GLOBAL::glob", 0, SVt_PVCV);
5813 #if !defined(PERL_EXTERNAL_GLOB)
5814 /* XXX this can be tightened up and made more failsafe. */
5815 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
5818 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5819 newSVpvs("File::Glob"), Nullsv, Nullsv, Nullsv);
5820 gv = gv_fetchpv("CORE::GLOBAL::glob", 0, SVt_PVCV);
5821 glob_gv = gv_fetchpv("File::Glob::csh_glob", 0, SVt_PVCV);
5822 GvCV(gv) = GvCV(glob_gv);
5823 (void)SvREFCNT_inc((SV*)GvCV(gv));
5824 GvIMPORTED_CV_on(gv);
5827 #endif /* PERL_EXTERNAL_GLOB */
5829 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5830 append_elem(OP_GLOB, o,
5831 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5832 o->op_type = OP_LIST;
5833 o->op_ppaddr = PL_ppaddr[OP_LIST];
5834 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5835 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5836 cLISTOPo->op_first->op_targ = 0;
5837 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5838 append_elem(OP_LIST, o,
5839 scalar(newUNOP(OP_RV2CV, 0,
5840 newGVOP(OP_GV, 0, gv)))));
5841 o = newUNOP(OP_NULL, 0, ck_subr(o));
5842 o->op_targ = OP_GLOB; /* hint at what it used to be */
5845 gv = newGVgen("main");
5847 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5853 Perl_ck_grep(pTHX_ OP *o)
5858 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5861 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5862 NewOp(1101, gwop, 1, LOGOP);
5864 if (o->op_flags & OPf_STACKED) {
5867 kid = cLISTOPo->op_first->op_sibling;
5868 if (!cUNOPx(kid)->op_next)
5869 Perl_croak(aTHX_ "panic: ck_grep");
5870 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
5873 kid->op_next = (OP*)gwop;
5874 o->op_flags &= ~OPf_STACKED;
5876 kid = cLISTOPo->op_first->op_sibling;
5877 if (type == OP_MAPWHILE)
5884 kid = cLISTOPo->op_first->op_sibling;
5885 if (kid->op_type != OP_NULL)
5886 Perl_croak(aTHX_ "panic: ck_grep");
5887 kid = kUNOP->op_first;
5889 gwop->op_type = type;
5890 gwop->op_ppaddr = PL_ppaddr[type];
5891 gwop->op_first = listkids(o);
5892 gwop->op_flags |= OPf_KIDS;
5893 gwop->op_other = LINKLIST(kid);
5894 kid->op_next = (OP*)gwop;
5895 offset = pad_findmy("$_");
5896 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
5897 o->op_private = gwop->op_private = 0;
5898 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5901 o->op_private = gwop->op_private = OPpGREP_LEX;
5902 gwop->op_targ = o->op_targ = offset;
5905 kid = cLISTOPo->op_first->op_sibling;
5906 if (!kid || !kid->op_sibling)
5907 return too_few_arguments(o,OP_DESC(o));
5908 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5909 mod(kid, OP_GREPSTART);
5915 Perl_ck_index(pTHX_ OP *o)
5917 if (o->op_flags & OPf_KIDS) {
5918 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5920 kid = kid->op_sibling; /* get past "big" */
5921 if (kid && kid->op_type == OP_CONST)
5922 fbm_compile(((SVOP*)kid)->op_sv, 0);
5928 Perl_ck_lengthconst(pTHX_ OP *o)
5930 /* XXX length optimization goes here */
5935 Perl_ck_lfun(pTHX_ OP *o)
5937 const OPCODE type = o->op_type;
5938 return modkids(ck_fun(o), type);
5942 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5944 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
5945 switch (cUNOPo->op_first->op_type) {
5947 /* This is needed for
5948 if (defined %stash::)
5949 to work. Do not break Tk.
5951 break; /* Globals via GV can be undef */
5953 case OP_AASSIGN: /* Is this a good idea? */
5954 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5955 "defined(@array) is deprecated");
5956 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5957 "\t(Maybe you should just omit the defined()?)\n");
5960 /* This is needed for
5961 if (defined %stash::)
5962 to work. Do not break Tk.
5964 break; /* Globals via GV can be undef */
5966 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5967 "defined(%%hash) is deprecated");
5968 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5969 "\t(Maybe you should just omit the defined()?)\n");
5980 Perl_ck_rfun(pTHX_ OP *o)
5982 const OPCODE type = o->op_type;
5983 return refkids(ck_fun(o), type);
5987 Perl_ck_listiob(pTHX_ OP *o)
5991 kid = cLISTOPo->op_first;
5994 kid = cLISTOPo->op_first;
5996 if (kid->op_type == OP_PUSHMARK)
5997 kid = kid->op_sibling;
5998 if (kid && o->op_flags & OPf_STACKED)
5999 kid = kid->op_sibling;
6000 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6001 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6002 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6003 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6004 cLISTOPo->op_first->op_sibling = kid;
6005 cLISTOPo->op_last = kid;
6006 kid = kid->op_sibling;
6011 append_elem(o->op_type, o, newDEFSVOP());
6017 Perl_ck_say(pTHX_ OP *o)
6020 o->op_type = OP_PRINT;
6021 cLISTOPo->op_last = cLISTOPo->op_last->op_sibling
6022 = newSVOP(OP_CONST, 0, newSVpvs("\n"));
6027 Perl_ck_smartmatch(pTHX_ OP *o)
6030 if (0 == (o->op_flags & OPf_SPECIAL)) {
6031 OP *first = cBINOPo->op_first;
6032 OP *second = first->op_sibling;
6034 /* Implicitly take a reference to an array or hash */
6035 first->op_sibling = Nullop;
6036 first = cBINOPo->op_first = ref_array_or_hash(first);
6037 second = first->op_sibling = ref_array_or_hash(second);
6039 /* Implicitly take a reference to a regular expression */
6040 if (first->op_type == OP_MATCH) {
6041 first->op_type = OP_QR;
6042 first->op_ppaddr = PL_ppaddr[OP_QR];
6044 if (second->op_type == OP_MATCH) {
6045 second->op_type = OP_QR;
6046 second->op_ppaddr = PL_ppaddr[OP_QR];
6055 Perl_ck_sassign(pTHX_ OP *o)
6057 OP *kid = cLISTOPo->op_first;
6058 /* has a disposable target? */
6059 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6060 && !(kid->op_flags & OPf_STACKED)
6061 /* Cannot steal the second time! */
6062 && !(kid->op_private & OPpTARGET_MY))
6064 OP * const kkid = kid->op_sibling;
6066 /* Can just relocate the target. */
6067 if (kkid && kkid->op_type == OP_PADSV
6068 && !(kkid->op_private & OPpLVAL_INTRO))
6070 kid->op_targ = kkid->op_targ;
6072 /* Now we do not need PADSV and SASSIGN. */
6073 kid->op_sibling = o->op_sibling; /* NULL */
6074 cLISTOPo->op_first = NULL;
6077 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6085 Perl_ck_match(pTHX_ OP *o)
6088 if (o->op_type != OP_QR && PL_compcv) {
6089 const I32 offset = pad_findmy("$_");
6090 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS(offset) & SVpad_OUR)) {
6091 o->op_targ = offset;
6092 o->op_private |= OPpTARGET_MY;
6095 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
6096 o->op_private |= OPpRUNTIME;
6101 Perl_ck_method(pTHX_ OP *o)
6103 OP * const kid = cUNOPo->op_first;
6104 if (kid->op_type == OP_CONST) {
6105 SV* sv = kSVOP->op_sv;
6106 const char * const method = SvPVX_const(sv);
6107 if (!(strchr(method, ':') || strchr(method, '\''))) {
6109 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6110 sv = newSVpvn_share(method, SvCUR(sv), 0);
6113 kSVOP->op_sv = Nullsv;
6115 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6124 Perl_ck_null(pTHX_ OP *o)
6130 Perl_ck_open(pTHX_ OP *o)
6133 HV * const table = GvHV(PL_hintgv);
6135 SV **svp = hv_fetchs(table, "open_IN", FALSE);
6137 const I32 mode = mode_from_discipline(*svp);
6138 if (mode & O_BINARY)
6139 o->op_private |= OPpOPEN_IN_RAW;
6140 else if (mode & O_TEXT)
6141 o->op_private |= OPpOPEN_IN_CRLF;
6144 svp = hv_fetchs(table, "open_OUT", FALSE);
6146 const I32 mode = mode_from_discipline(*svp);
6147 if (mode & O_BINARY)
6148 o->op_private |= OPpOPEN_OUT_RAW;
6149 else if (mode & O_TEXT)
6150 o->op_private |= OPpOPEN_OUT_CRLF;
6153 if (o->op_type == OP_BACKTICK)
6156 /* In case of three-arg dup open remove strictness
6157 * from the last arg if it is a bareword. */
6158 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
6159 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
6163 if ((last->op_type == OP_CONST) && /* The bareword. */
6164 (last->op_private & OPpCONST_BARE) &&
6165 (last->op_private & OPpCONST_STRICT) &&
6166 (oa = first->op_sibling) && /* The fh. */
6167 (oa = oa->op_sibling) && /* The mode. */
6168 (oa->op_type == OP_CONST) &&
6169 SvPOK(((SVOP*)oa)->op_sv) &&
6170 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
6171 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
6172 (last == oa->op_sibling)) /* The bareword. */
6173 last->op_private &= ~OPpCONST_STRICT;
6179 Perl_ck_repeat(pTHX_ OP *o)
6181 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6182 o->op_private |= OPpREPEAT_DOLIST;
6183 cBINOPo->op_first = force_list(cBINOPo->op_first);
6191 Perl_ck_require(pTHX_ OP *o)
6196 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6197 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6199 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6200 SV * const sv = kid->op_sv;
6201 U32 was_readonly = SvREADONLY(sv);
6206 sv_force_normal_flags(sv, 0);
6207 assert(!SvREADONLY(sv));
6214 for (s = SvPVX(sv); *s; s++) {
6215 if (*s == ':' && s[1] == ':') {
6216 const STRLEN len = strlen(s+2)+1;
6218 Move(s+2, s+1, len, char);
6219 SvCUR_set(sv, SvCUR(sv) - 1);
6222 sv_catpvs(sv, ".pm");
6223 SvFLAGS(sv) |= was_readonly;
6227 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
6228 /* handle override, if any */
6229 gv = gv_fetchpv("require", 0, SVt_PVCV);
6230 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
6231 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
6232 gv = gvp ? *gvp : Nullgv;
6236 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6237 OP * const kid = cUNOPo->op_first;
6238 cUNOPo->op_first = 0;
6240 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
6241 append_elem(OP_LIST, kid,
6242 scalar(newUNOP(OP_RV2CV, 0,
6251 Perl_ck_return(pTHX_ OP *o)
6254 if (CvLVALUE(PL_compcv)) {
6256 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6257 mod(kid, OP_LEAVESUBLV);
6263 Perl_ck_select(pTHX_ OP *o)
6267 if (o->op_flags & OPf_KIDS) {
6268 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6269 if (kid && kid->op_sibling) {
6270 o->op_type = OP_SSELECT;
6271 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6273 return fold_constants(o);
6277 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6278 if (kid && kid->op_type == OP_RV2GV)
6279 kid->op_private &= ~HINT_STRICT_REFS;
6284 Perl_ck_shift(pTHX_ OP *o)
6287 const I32 type = o->op_type;
6289 if (!(o->op_flags & OPf_KIDS)) {
6293 argop = newUNOP(OP_RV2AV, 0,
6294 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
6295 return newUNOP(type, 0, scalar(argop));
6297 return scalar(modkids(ck_fun(o), type));
6301 Perl_ck_sort(pTHX_ OP *o)
6306 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0)
6308 HV * const hinthv = GvHV(PL_hintgv);
6310 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
6312 const I32 sorthints = (I32)SvIV(*svp);
6313 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
6314 o->op_private |= OPpSORT_QSORT;
6315 if ((sorthints & HINT_SORT_STABLE) != 0)
6316 o->op_private |= OPpSORT_STABLE;
6321 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6323 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6324 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6326 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6328 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6330 if (kid->op_type == OP_SCOPE) {
6334 else if (kid->op_type == OP_LEAVE) {
6335 if (o->op_type == OP_SORT) {
6336 op_null(kid); /* wipe out leave */
6339 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6340 if (k->op_next == kid)
6342 /* don't descend into loops */
6343 else if (k->op_type == OP_ENTERLOOP
6344 || k->op_type == OP_ENTERITER)
6346 k = cLOOPx(k)->op_lastop;
6351 kid->op_next = 0; /* just disconnect the leave */
6352 k = kLISTOP->op_first;
6357 if (o->op_type == OP_SORT) {
6358 /* provide scalar context for comparison function/block */
6364 o->op_flags |= OPf_SPECIAL;
6366 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6369 firstkid = firstkid->op_sibling;
6372 /* provide list context for arguments */
6373 if (o->op_type == OP_SORT)
6380 S_simplify_sort(pTHX_ OP *o)
6383 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6388 if (!(o->op_flags & OPf_STACKED))
6390 GvMULTI_on(gv_fetchpv("a", GV_ADD, SVt_PV));
6391 GvMULTI_on(gv_fetchpv("b", GV_ADD, SVt_PV));
6392 kid = kUNOP->op_first; /* get past null */
6393 if (kid->op_type != OP_SCOPE)
6395 kid = kLISTOP->op_last; /* get past scope */
6396 switch(kid->op_type) {
6404 k = kid; /* remember this node*/
6405 if (kBINOP->op_first->op_type != OP_RV2SV)
6407 kid = kBINOP->op_first; /* get past cmp */
6408 if (kUNOP->op_first->op_type != OP_GV)
6410 kid = kUNOP->op_first; /* get past rv2sv */
6412 if (GvSTASH(gv) != PL_curstash)
6414 gvname = GvNAME(gv);
6415 if (*gvname == 'a' && gvname[1] == '\0')
6417 else if (*gvname == 'b' && gvname[1] == '\0')
6422 kid = k; /* back to cmp */
6423 if (kBINOP->op_last->op_type != OP_RV2SV)
6425 kid = kBINOP->op_last; /* down to 2nd arg */
6426 if (kUNOP->op_first->op_type != OP_GV)
6428 kid = kUNOP->op_first; /* get past rv2sv */
6430 if (GvSTASH(gv) != PL_curstash)
6432 gvname = GvNAME(gv);
6434 ? !(*gvname == 'a' && gvname[1] == '\0')
6435 : !(*gvname == 'b' && gvname[1] == '\0'))
6437 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6439 o->op_private |= OPpSORT_DESCEND;
6440 if (k->op_type == OP_NCMP)
6441 o->op_private |= OPpSORT_NUMERIC;
6442 if (k->op_type == OP_I_NCMP)
6443 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6444 kid = cLISTOPo->op_first->op_sibling;
6445 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6446 op_free(kid); /* then delete it */
6450 Perl_ck_split(pTHX_ OP *o)
6455 if (o->op_flags & OPf_STACKED)
6456 return no_fh_allowed(o);
6458 kid = cLISTOPo->op_first;
6459 if (kid->op_type != OP_NULL)
6460 Perl_croak(aTHX_ "panic: ck_split");
6461 kid = kid->op_sibling;
6462 op_free(cLISTOPo->op_first);
6463 cLISTOPo->op_first = kid;
6465 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
6466 cLISTOPo->op_last = kid; /* There was only one element previously */
6469 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6470 OP * const sibl = kid->op_sibling;
6471 kid->op_sibling = 0;
6472 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
6473 if (cLISTOPo->op_first == cLISTOPo->op_last)
6474 cLISTOPo->op_last = kid;
6475 cLISTOPo->op_first = kid;
6476 kid->op_sibling = sibl;
6479 kid->op_type = OP_PUSHRE;
6480 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6482 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
6483 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
6484 "Use of /g modifier is meaningless in split");
6487 if (!kid->op_sibling)
6488 append_elem(OP_SPLIT, o, newDEFSVOP());
6490 kid = kid->op_sibling;
6493 if (!kid->op_sibling)
6494 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6496 kid = kid->op_sibling;
6499 if (kid->op_sibling)
6500 return too_many_arguments(o,OP_DESC(o));
6506 Perl_ck_join(pTHX_ OP *o)
6508 const OP * const kid = cLISTOPo->op_first->op_sibling;
6509 if (kid && kid->op_type == OP_MATCH) {
6510 if (ckWARN(WARN_SYNTAX)) {
6511 const REGEXP *re = PM_GETRE(kPMOP);
6512 const char *pmstr = re ? re->precomp : "STRING";
6513 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6514 "/%s/ should probably be written as \"%s\"",
6522 Perl_ck_subr(pTHX_ OP *o)
6525 OP *prev = ((cUNOPo->op_first->op_sibling)
6526 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6527 OP *o2 = prev->op_sibling;
6534 I32 contextclass = 0;
6538 o->op_private |= OPpENTERSUB_HASTARG;
6539 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6540 if (cvop->op_type == OP_RV2CV) {
6542 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6543 op_null(cvop); /* disable rv2cv */
6544 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6545 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6546 GV *gv = cGVOPx_gv(tmpop);
6549 tmpop->op_private |= OPpEARLY_CV;
6552 namegv = CvANON(cv) ? gv : CvGV(cv);
6553 proto = SvPV_nolen((SV*)cv);
6555 if (CvASSERTION(cv)) {
6556 if (PL_hints & HINT_ASSERTING) {
6557 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
6558 o->op_private |= OPpENTERSUB_DB;
6562 if (!(PL_hints & HINT_ASSERTIONSSEEN) && ckWARN(WARN_ASSERTIONS)) {
6563 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
6564 "Impossible to activate assertion call");
6571 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6572 if (o2->op_type == OP_CONST)
6573 o2->op_private &= ~OPpCONST_STRICT;
6574 else if (o2->op_type == OP_LIST) {
6575 OP * const o = ((UNOP*)o2)->op_first->op_sibling;
6576 if (o && o->op_type == OP_CONST)
6577 o->op_private &= ~OPpCONST_STRICT;
6580 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6581 if (PERLDB_SUB && PL_curstash != PL_debstash)
6582 o->op_private |= OPpENTERSUB_DB;
6583 while (o2 != cvop) {
6587 return too_many_arguments(o, gv_ename(namegv));
6605 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6607 arg == 1 ? "block or sub {}" : "sub {}",
6608 gv_ename(namegv), o2);
6611 /* '*' allows any scalar type, including bareword */
6614 if (o2->op_type == OP_RV2GV)
6615 goto wrapref; /* autoconvert GLOB -> GLOBref */
6616 else if (o2->op_type == OP_CONST)
6617 o2->op_private &= ~OPpCONST_STRICT;
6618 else if (o2->op_type == OP_ENTERSUB) {
6619 /* accidental subroutine, revert to bareword */
6620 OP *gvop = ((UNOP*)o2)->op_first;
6621 if (gvop && gvop->op_type == OP_NULL) {
6622 gvop = ((UNOP*)gvop)->op_first;
6624 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6627 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6628 (gvop = ((UNOP*)gvop)->op_first) &&
6629 gvop->op_type == OP_GV)
6631 GV * const gv = cGVOPx_gv(gvop);
6632 OP * const sibling = o2->op_sibling;
6633 SV * const n = newSVpvs("");
6635 gv_fullname4(n, gv, "", FALSE);
6636 o2 = newSVOP(OP_CONST, 0, n);
6637 prev->op_sibling = o2;
6638 o2->op_sibling = sibling;
6654 if (contextclass++ == 0) {
6655 e = strchr(proto, ']');
6656 if (!e || e == proto)
6665 /* XXX We shouldn't be modifying proto, so we can const proto */
6670 while (*--p != '[');
6671 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
6672 gv_ename(namegv), o2);
6678 if (o2->op_type == OP_RV2GV)
6681 bad_type(arg, "symbol", gv_ename(namegv), o2);
6684 if (o2->op_type == OP_ENTERSUB)
6687 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6690 if (o2->op_type == OP_RV2SV ||
6691 o2->op_type == OP_PADSV ||
6692 o2->op_type == OP_HELEM ||
6693 o2->op_type == OP_AELEM ||
6694 o2->op_type == OP_THREADSV)
6697 bad_type(arg, "scalar", gv_ename(namegv), o2);
6700 if (o2->op_type == OP_RV2AV ||
6701 o2->op_type == OP_PADAV)
6704 bad_type(arg, "array", gv_ename(namegv), o2);
6707 if (o2->op_type == OP_RV2HV ||
6708 o2->op_type == OP_PADHV)
6711 bad_type(arg, "hash", gv_ename(namegv), o2);
6716 OP* const sib = kid->op_sibling;
6717 kid->op_sibling = 0;
6718 o2 = newUNOP(OP_REFGEN, 0, kid);
6719 o2->op_sibling = sib;
6720 prev->op_sibling = o2;
6722 if (contextclass && e) {
6737 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
6738 gv_ename(namegv), cv);
6743 mod(o2, OP_ENTERSUB);
6745 o2 = o2->op_sibling;
6747 if (proto && !optional &&
6748 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6749 return too_few_arguments(o, gv_ename(namegv));
6752 o=newSVOP(OP_CONST, 0, newSViv(0));
6758 Perl_ck_svconst(pTHX_ OP *o)
6760 SvREADONLY_on(cSVOPo->op_sv);
6765 Perl_ck_trunc(pTHX_ OP *o)
6767 if (o->op_flags & OPf_KIDS) {
6768 SVOP *kid = (SVOP*)cUNOPo->op_first;
6770 if (kid->op_type == OP_NULL)
6771 kid = (SVOP*)kid->op_sibling;
6772 if (kid && kid->op_type == OP_CONST &&
6773 (kid->op_private & OPpCONST_BARE))
6775 o->op_flags |= OPf_SPECIAL;
6776 kid->op_private &= ~OPpCONST_STRICT;
6783 Perl_ck_unpack(pTHX_ OP *o)
6785 OP *kid = cLISTOPo->op_first;
6786 if (kid->op_sibling) {
6787 kid = kid->op_sibling;
6788 if (!kid->op_sibling)
6789 kid->op_sibling = newDEFSVOP();
6795 Perl_ck_substr(pTHX_ OP *o)
6798 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6799 OP *kid = cLISTOPo->op_first;
6801 if (kid->op_type == OP_NULL)
6802 kid = kid->op_sibling;
6804 kid->op_flags |= OPf_MOD;
6810 /* A peephole optimizer. We visit the ops in the order they're to execute.
6811 * See the comments at the top of this file for more details about when
6812 * peep() is called */
6815 Perl_peep(pTHX_ register OP *o)
6818 register OP* oldop = NULL;
6820 if (!o || o->op_opt)
6824 SAVEVPTR(PL_curcop);
6825 for (; o; o = o->op_next) {
6829 switch (o->op_type) {
6833 PL_curcop = ((COP*)o); /* for warnings */
6838 if (cSVOPo->op_private & OPpCONST_STRICT)
6839 no_bareword_allowed(o);
6841 case OP_METHOD_NAMED:
6842 /* Relocate sv to the pad for thread safety.
6843 * Despite being a "constant", the SV is written to,
6844 * for reference counts, sv_upgrade() etc. */
6846 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6847 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6848 /* If op_sv is already a PADTMP then it is being used by
6849 * some pad, so make a copy. */
6850 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6851 SvREADONLY_on(PAD_SVl(ix));
6852 SvREFCNT_dec(cSVOPo->op_sv);
6854 else if (o->op_type == OP_CONST
6855 && cSVOPo->op_sv == &PL_sv_undef) {
6856 /* PL_sv_undef is hack - it's unsafe to store it in the
6857 AV that is the pad, because av_fetch treats values of
6858 PL_sv_undef as a "free" AV entry and will merrily
6859 replace them with a new SV, causing pad_alloc to think
6860 that this pad slot is free. (When, clearly, it is not)
6862 SvOK_off(PAD_SVl(ix));
6863 SvPADTMP_on(PAD_SVl(ix));
6864 SvREADONLY_on(PAD_SVl(ix));
6867 SvREFCNT_dec(PAD_SVl(ix));
6868 SvPADTMP_on(cSVOPo->op_sv);
6869 PAD_SETSV(ix, cSVOPo->op_sv);
6870 /* XXX I don't know how this isn't readonly already. */
6871 SvREADONLY_on(PAD_SVl(ix));
6873 cSVOPo->op_sv = Nullsv;
6881 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6882 if (o->op_next->op_private & OPpTARGET_MY) {
6883 if (o->op_flags & OPf_STACKED) /* chained concats */
6884 goto ignore_optimization;
6886 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6887 o->op_targ = o->op_next->op_targ;
6888 o->op_next->op_targ = 0;
6889 o->op_private |= OPpTARGET_MY;
6892 op_null(o->op_next);
6894 ignore_optimization:
6898 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6900 break; /* Scalar stub must produce undef. List stub is noop */
6904 if (o->op_targ == OP_NEXTSTATE
6905 || o->op_targ == OP_DBSTATE
6906 || o->op_targ == OP_SETSTATE)
6908 PL_curcop = ((COP*)o);
6910 /* XXX: We avoid setting op_seq here to prevent later calls
6911 to peep() from mistakenly concluding that optimisation
6912 has already occurred. This doesn't fix the real problem,
6913 though (See 20010220.007). AMS 20010719 */
6914 /* op_seq functionality is now replaced by op_opt */
6915 if (oldop && o->op_next) {
6916 oldop->op_next = o->op_next;
6924 if (oldop && o->op_next) {
6925 oldop->op_next = o->op_next;
6933 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
6934 OP* const pop = (o->op_type == OP_PADAV) ?
6935 o->op_next : o->op_next->op_next;
6937 if (pop && pop->op_type == OP_CONST &&
6938 ((PL_op = pop->op_next)) &&
6939 pop->op_next->op_type == OP_AELEM &&
6940 !(pop->op_next->op_private &
6941 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6942 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6947 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
6948 no_bareword_allowed(pop);
6949 if (o->op_type == OP_GV)
6950 op_null(o->op_next);
6951 op_null(pop->op_next);
6953 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6954 o->op_next = pop->op_next->op_next;
6955 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6956 o->op_private = (U8)i;
6957 if (o->op_type == OP_GV) {
6962 o->op_flags |= OPf_SPECIAL;
6963 o->op_type = OP_AELEMFAST;
6969 if (o->op_next->op_type == OP_RV2SV) {
6970 if (!(o->op_next->op_private & OPpDEREF)) {
6971 op_null(o->op_next);
6972 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6974 o->op_next = o->op_next->op_next;
6975 o->op_type = OP_GVSV;
6976 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6979 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6980 GV * const gv = cGVOPo_gv;
6981 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
6982 /* XXX could check prototype here instead of just carping */
6983 SV * const sv = sv_newmortal();
6984 gv_efullname3(sv, gv, Nullch);
6985 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
6986 "%"SVf"() called too early to check prototype",
6990 else if (o->op_next->op_type == OP_READLINE
6991 && o->op_next->op_next->op_type == OP_CONCAT
6992 && (o->op_next->op_next->op_flags & OPf_STACKED))
6994 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6995 o->op_type = OP_RCATLINE;
6996 o->op_flags |= OPf_STACKED;
6997 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
6998 op_null(o->op_next->op_next);
6999 op_null(o->op_next);
7016 while (cLOGOP->op_other->op_type == OP_NULL)
7017 cLOGOP->op_other = cLOGOP->op_other->op_next;
7018 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
7024 while (cLOOP->op_redoop->op_type == OP_NULL)
7025 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
7026 peep(cLOOP->op_redoop);
7027 while (cLOOP->op_nextop->op_type == OP_NULL)
7028 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
7029 peep(cLOOP->op_nextop);
7030 while (cLOOP->op_lastop->op_type == OP_NULL)
7031 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
7032 peep(cLOOP->op_lastop);
7039 while (cPMOP->op_pmreplstart &&
7040 cPMOP->op_pmreplstart->op_type == OP_NULL)
7041 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
7042 peep(cPMOP->op_pmreplstart);
7047 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
7048 && ckWARN(WARN_SYNTAX))
7050 if (o->op_next->op_sibling &&
7051 o->op_next->op_sibling->op_type != OP_EXIT &&
7052 o->op_next->op_sibling->op_type != OP_WARN &&
7053 o->op_next->op_sibling->op_type != OP_DIE) {
7054 const line_t oldline = CopLINE(PL_curcop);
7056 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
7057 Perl_warner(aTHX_ packWARN(WARN_EXEC),
7058 "Statement unlikely to be reached");
7059 Perl_warner(aTHX_ packWARN(WARN_EXEC),
7060 "\t(Maybe you meant system() when you said exec()?)\n");
7061 CopLINE_set(PL_curcop, oldline);
7071 const char *key = NULL;
7076 if (((BINOP*)o)->op_last->op_type != OP_CONST)
7079 /* Make the CONST have a shared SV */
7080 svp = cSVOPx_svp(((BINOP*)o)->op_last);
7081 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
7082 key = SvPV_const(sv, keylen);
7083 lexname = newSVpvn_share(key,
7084 SvUTF8(sv) ? -(I32)keylen : keylen,
7090 if ((o->op_private & (OPpLVAL_INTRO)))
7093 rop = (UNOP*)((BINOP*)o)->op_first;
7094 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7096 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7097 if (!(SvFLAGS(lexname) & SVpad_TYPED))
7099 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
7100 if (!fields || !GvHV(*fields))
7102 key = SvPV_const(*svp, keylen);
7103 if (!hv_fetch(GvHV(*fields), key,
7104 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
7106 Perl_croak(aTHX_ "No such class field \"%s\" "
7107 "in variable %s of type %s",
7108 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
7121 SVOP *first_key_op, *key_op;
7123 if ((o->op_private & (OPpLVAL_INTRO))
7124 /* I bet there's always a pushmark... */
7125 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
7126 /* hmmm, no optimization if list contains only one key. */
7128 rop = (UNOP*)((LISTOP*)o)->op_last;
7129 if (rop->op_type != OP_RV2HV)
7131 if (rop->op_first->op_type == OP_PADSV)
7132 /* @$hash{qw(keys here)} */
7133 rop = (UNOP*)rop->op_first;
7135 /* @{$hash}{qw(keys here)} */
7136 if (rop->op_first->op_type == OP_SCOPE
7137 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
7139 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
7145 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
7146 if (!(SvFLAGS(lexname) & SVpad_TYPED))
7148 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
7149 if (!fields || !GvHV(*fields))
7151 /* Again guessing that the pushmark can be jumped over.... */
7152 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
7153 ->op_first->op_sibling;
7154 for (key_op = first_key_op; key_op;
7155 key_op = (SVOP*)key_op->op_sibling) {
7156 if (key_op->op_type != OP_CONST)
7158 svp = cSVOPx_svp(key_op);
7159 key = SvPV_const(*svp, keylen);
7160 if (!hv_fetch(GvHV(*fields), key,
7161 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
7163 Perl_croak(aTHX_ "No such class field \"%s\" "
7164 "in variable %s of type %s",
7165 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
7172 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
7176 /* check that RHS of sort is a single plain array */
7177 OP *oright = cUNOPo->op_first;
7178 if (!oright || oright->op_type != OP_PUSHMARK)
7181 /* reverse sort ... can be optimised. */
7182 if (!cUNOPo->op_sibling) {
7183 /* Nothing follows us on the list. */
7184 OP * const reverse = o->op_next;
7186 if (reverse->op_type == OP_REVERSE &&
7187 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
7188 OP * const pushmark = cUNOPx(reverse)->op_first;
7189 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
7190 && (cUNOPx(pushmark)->op_sibling == o)) {
7191 /* reverse -> pushmark -> sort */
7192 o->op_private |= OPpSORT_REVERSE;
7194 pushmark->op_next = oright->op_next;
7200 /* make @a = sort @a act in-place */
7204 oright = cUNOPx(oright)->op_sibling;
7207 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
7208 oright = cUNOPx(oright)->op_sibling;
7212 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
7213 || oright->op_next != o
7214 || (oright->op_private & OPpLVAL_INTRO)
7218 /* o2 follows the chain of op_nexts through the LHS of the
7219 * assign (if any) to the aassign op itself */
7221 if (!o2 || o2->op_type != OP_NULL)
7224 if (!o2 || o2->op_type != OP_PUSHMARK)
7227 if (o2 && o2->op_type == OP_GV)
7230 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
7231 || (o2->op_private & OPpLVAL_INTRO)
7236 if (!o2 || o2->op_type != OP_NULL)
7239 if (!o2 || o2->op_type != OP_AASSIGN
7240 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
7243 /* check that the sort is the first arg on RHS of assign */
7245 o2 = cUNOPx(o2)->op_first;
7246 if (!o2 || o2->op_type != OP_NULL)
7248 o2 = cUNOPx(o2)->op_first;
7249 if (!o2 || o2->op_type != OP_PUSHMARK)
7251 if (o2->op_sibling != o)
7254 /* check the array is the same on both sides */
7255 if (oleft->op_type == OP_RV2AV) {
7256 if (oright->op_type != OP_RV2AV
7257 || !cUNOPx(oright)->op_first
7258 || cUNOPx(oright)->op_first->op_type != OP_GV
7259 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
7260 cGVOPx_gv(cUNOPx(oright)->op_first)
7264 else if (oright->op_type != OP_PADAV
7265 || oright->op_targ != oleft->op_targ
7269 /* transfer MODishness etc from LHS arg to RHS arg */
7270 oright->op_flags = oleft->op_flags;
7271 o->op_private |= OPpSORT_INPLACE;
7273 /* excise push->gv->rv2av->null->aassign */
7274 o2 = o->op_next->op_next;
7275 op_null(o2); /* PUSHMARK */
7277 if (o2->op_type == OP_GV) {
7278 op_null(o2); /* GV */
7281 op_null(o2); /* RV2AV or PADAV */
7282 o2 = o2->op_next->op_next;
7283 op_null(o2); /* AASSIGN */
7285 o->op_next = o2->op_next;
7291 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
7293 LISTOP *enter, *exlist;
7296 enter = (LISTOP *) o->op_next;
7299 if (enter->op_type == OP_NULL) {
7300 enter = (LISTOP *) enter->op_next;
7304 /* for $a (...) will have OP_GV then OP_RV2GV here.
7305 for (...) just has an OP_GV. */
7306 if (enter->op_type == OP_GV) {
7307 gvop = (OP *) enter;
7308 enter = (LISTOP *) enter->op_next;
7311 if (enter->op_type == OP_RV2GV) {
7312 enter = (LISTOP *) enter->op_next;
7318 if (enter->op_type != OP_ENTERITER)
7321 iter = enter->op_next;
7322 if (!iter || iter->op_type != OP_ITER)
7325 expushmark = enter->op_first;
7326 if (!expushmark || expushmark->op_type != OP_NULL
7327 || expushmark->op_targ != OP_PUSHMARK)
7330 exlist = (LISTOP *) expushmark->op_sibling;
7331 if (!exlist || exlist->op_type != OP_NULL
7332 || exlist->op_targ != OP_LIST)
7335 if (exlist->op_last != o) {
7336 /* Mmm. Was expecting to point back to this op. */
7339 theirmark = exlist->op_first;
7340 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
7343 if (theirmark->op_sibling != o) {
7344 /* There's something between the mark and the reverse, eg
7345 for (1, reverse (...))
7350 ourmark = ((LISTOP *)o)->op_first;
7351 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
7354 ourlast = ((LISTOP *)o)->op_last;
7355 if (!ourlast || ourlast->op_next != o)
7358 rv2av = ourmark->op_sibling;
7359 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
7360 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
7361 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
7362 /* We're just reversing a single array. */
7363 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
7364 enter->op_flags |= OPf_STACKED;
7367 /* We don't have control over who points to theirmark, so sacrifice
7369 theirmark->op_next = ourmark->op_next;
7370 theirmark->op_flags = ourmark->op_flags;
7371 ourlast->op_next = gvop ? gvop : (OP *) enter;
7374 enter->op_private |= OPpITER_REVERSED;
7375 iter->op_private |= OPpITER_REVERSED;
7382 UNOP *refgen, *rv2cv;
7385 /* I do not understand this, but if o->op_opt isn't set to 1,
7386 various tests in ext/B/t/bytecode.t fail with no readily
7392 if ((o->op_flags && OPf_WANT) != OPf_WANT_VOID)
7395 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
7398 rv2gv = ((BINOP *)o)->op_last;
7399 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
7402 refgen = (UNOP *)((BINOP *)o)->op_first;
7404 if (!refgen || refgen->op_type != OP_REFGEN)
7407 exlist = (LISTOP *)refgen->op_first;
7408 if (!exlist || exlist->op_type != OP_NULL
7409 || exlist->op_targ != OP_LIST)
7412 if (exlist->op_first->op_type != OP_PUSHMARK)
7415 rv2cv = (UNOP*)exlist->op_last;
7417 if (rv2cv->op_type != OP_RV2CV)
7420 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
7421 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
7422 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
7424 o->op_private |= OPpASSIGN_CV_TO_GV;
7425 rv2gv->op_private |= OPpDONT_INIT_GV;
7426 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
7442 Perl_custom_op_name(pTHX_ const OP* o)
7445 const IV index = PTR2IV(o->op_ppaddr);
7449 if (!PL_custom_op_names) /* This probably shouldn't happen */
7450 return (char *)PL_op_name[OP_CUSTOM];
7452 keysv = sv_2mortal(newSViv(index));
7454 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
7456 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
7458 return SvPV_nolen(HeVAL(he));
7462 Perl_custom_op_desc(pTHX_ const OP* o)
7465 const IV index = PTR2IV(o->op_ppaddr);
7469 if (!PL_custom_op_descs)
7470 return (char *)PL_op_desc[OP_CUSTOM];
7472 keysv = sv_2mortal(newSViv(index));
7474 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
7476 return (char *)PL_op_desc[OP_CUSTOM];
7478 return SvPV_nolen(HeVAL(he));
7483 /* Efficient sub that returns a constant scalar value. */
7485 const_sv_xsub(pTHX_ CV* cv)
7491 Perl_croak(aTHX_ "usage: %s::%s()",
7492 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7496 ST(0) = (SV*)XSANY.any_ptr;
7502 * c-indentation-style: bsd
7504 * indent-tabs-mode: t
7507 * ex: set ts=8 sts=4 sw=4 noet: