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 ", NULL" is just to make the compiler
150 * think the expression is of the right type: croak actually does a Siglongjmp.
152 #define CHECKOP(type,o) \
153 ((PL_op_mask && PL_op_mask[type]) \
154 ? ( op_free((OP*)o), \
155 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
157 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
159 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
162 S_gv_ename(pTHX_ GV *gv)
164 SV* const tmpsv = sv_newmortal();
165 gv_efullname3(tmpsv, gv, NULL);
166 return SvPV_nolen_const(tmpsv);
170 S_no_fh_allowed(pTHX_ OP *o)
172 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
178 S_too_few_arguments(pTHX_ OP *o, const char *name)
180 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
185 S_too_many_arguments(pTHX_ OP *o, const char *name)
187 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
192 S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid)
194 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
195 (int)n, name, t, OP_DESC(kid)));
199 S_no_bareword_allowed(pTHX_ const OP *o)
201 qerror(Perl_mess(aTHX_
202 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
206 /* "register" allocation */
209 Perl_allocmy(pTHX_ char *name)
213 const bool is_our = (PL_in_my == KEY_our);
215 /* complain about "my $<special_var>" etc etc */
219 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
220 (name[1] == '_' && (*name == '$' || name[2]))))
222 /* name[2] is true if strlen(name) > 2 */
223 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
224 /* 1999-02-27 mjd@plover.com */
226 p = strchr(name, '\0');
227 /* The next block assumes the buffer is at least 205 chars
228 long. At present, it's always at least 256 chars. */
230 strcpy(name+200, "...");
236 /* Move everything else down one character */
237 for (; p-name > 2; p--)
239 name[2] = toCTRL(name[1]);
242 yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
245 /* check for duplicate declaration */
246 pad_check_dup(name, is_our, (PL_curstash ? PL_curstash : PL_defstash));
248 if (PL_in_my_stash && *name != '$') {
249 yyerror(Perl_form(aTHX_
250 "Can't declare class for non-scalar %s in \"%s\"",
251 name, is_our ? "our" : "my"));
254 /* allocate a spare slot and store the name in that slot */
256 off = pad_add_name(name,
259 /* $_ is always in main::, even with our */
260 ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
271 Perl_op_free(pTHX_ OP *o)
277 if (!o || o->op_static)
280 if (o->op_private & OPpREFCOUNTED) {
281 switch (o->op_type) {
289 refcnt = OpREFCNT_dec(o);
299 if (o->op_flags & OPf_KIDS) {
300 register OP *kid, *nextkid;
301 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
302 nextkid = kid->op_sibling; /* Get before next freeing kid */
308 type = (OPCODE)o->op_targ;
310 /* COP* is not cleared by op_clear() so that we may track line
311 * numbers etc even after null() */
312 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
317 #ifdef DEBUG_LEAKING_SCALARS
324 Perl_op_clear(pTHX_ OP *o)
328 switch (o->op_type) {
329 case OP_NULL: /* Was holding old type, if any. */
330 case OP_ENTEREVAL: /* Was holding hints. */
334 if (!(o->op_flags & OPf_REF)
335 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
341 if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
342 /* not an OP_PADAV replacement */
344 if (cPADOPo->op_padix > 0) {
345 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
346 * may still exist on the pad */
347 pad_swipe(cPADOPo->op_padix, TRUE);
348 cPADOPo->op_padix = 0;
351 SvREFCNT_dec(cSVOPo->op_sv);
352 cSVOPo->op_sv = NULL;
356 case OP_METHOD_NAMED:
358 SvREFCNT_dec(cSVOPo->op_sv);
359 cSVOPo->op_sv = NULL;
362 Even if op_clear does a pad_free for the target of the op,
363 pad_free doesn't actually remove the sv that exists in the pad;
364 instead it lives on. This results in that it could be reused as
365 a target later on when the pad was reallocated.
368 pad_swipe(o->op_targ,1);
377 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
381 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
382 SvREFCNT_dec(cSVOPo->op_sv);
383 cSVOPo->op_sv = NULL;
386 Safefree(cPVOPo->op_pv);
387 cPVOPo->op_pv = NULL;
391 op_free(cPMOPo->op_pmreplroot);
395 if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) {
396 /* No GvIN_PAD_off here, because other references may still
397 * exist on the pad */
398 pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot), TRUE);
401 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
408 HV * const pmstash = PmopSTASH(cPMOPo);
409 if (pmstash && !SvIS_FREED(pmstash)) {
410 MAGIC * const mg = mg_find((SV*)pmstash, PERL_MAGIC_symtab);
412 PMOP *pmop = (PMOP*) mg->mg_obj;
413 PMOP *lastpmop = NULL;
415 if (cPMOPo == pmop) {
417 lastpmop->op_pmnext = pmop->op_pmnext;
419 mg->mg_obj = (SV*) pmop->op_pmnext;
423 pmop = pmop->op_pmnext;
427 PmopSTASH_free(cPMOPo);
429 cPMOPo->op_pmreplroot = NULL;
430 /* we use the "SAFE" version of the PM_ macros here
431 * since sv_clean_all might release some PMOPs
432 * after PL_regex_padav has been cleared
433 * and the clearing of PL_regex_padav needs to
434 * happen before sv_clean_all
436 ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
437 PM_SETRE_SAFE(cPMOPo, NULL);
439 if(PL_regex_pad) { /* We could be in destruction */
440 av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
441 SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
442 PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
449 if (o->op_targ > 0) {
450 pad_free(o->op_targ);
456 S_cop_free(pTHX_ COP* cop)
458 Safefree(cop->cop_label); /* FIXME: treaddead ??? */
461 if (! specialWARN(cop->cop_warnings))
462 SvREFCNT_dec(cop->cop_warnings);
463 if (! specialCopIO(cop->cop_io)) {
467 char *s = SvPV(cop->cop_io,len);
468 Perl_warn(aTHX_ "io='%.*s'",(int) len,s); /* ??? --jhi */
471 SvREFCNT_dec(cop->cop_io);
477 Perl_op_null(pTHX_ OP *o)
480 if (o->op_type == OP_NULL)
483 o->op_targ = o->op_type;
484 o->op_type = OP_NULL;
485 o->op_ppaddr = PL_ppaddr[OP_NULL];
489 Perl_op_refcnt_lock(pTHX)
496 Perl_op_refcnt_unlock(pTHX)
502 /* Contextualizers */
504 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
507 Perl_linklist(pTHX_ OP *o)
514 /* establish postfix order */
515 first = cUNOPo->op_first;
518 o->op_next = LINKLIST(first);
521 if (kid->op_sibling) {
522 kid->op_next = LINKLIST(kid->op_sibling);
523 kid = kid->op_sibling;
537 Perl_scalarkids(pTHX_ OP *o)
539 if (o && o->op_flags & OPf_KIDS) {
541 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
548 S_scalarboolean(pTHX_ OP *o)
551 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
552 if (ckWARN(WARN_SYNTAX)) {
553 const line_t oldline = CopLINE(PL_curcop);
555 if (PL_copline != NOLINE)
556 CopLINE_set(PL_curcop, PL_copline);
557 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
558 CopLINE_set(PL_curcop, oldline);
565 Perl_scalar(pTHX_ OP *o)
570 /* assumes no premature commitment */
571 if (!o || PL_error_count || (o->op_flags & OPf_WANT)
572 || o->op_type == OP_RETURN)
577 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
579 switch (o->op_type) {
581 scalar(cBINOPo->op_first);
586 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
590 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
591 if (!kPMOP->op_pmreplroot)
592 deprecate_old("implicit split to @_");
600 if (o->op_flags & OPf_KIDS) {
601 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
607 kid = cLISTOPo->op_first;
609 while ((kid = kid->op_sibling)) {
615 WITH_THR(PL_curcop = &PL_compiling);
620 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
626 WITH_THR(PL_curcop = &PL_compiling);
629 if (ckWARN(WARN_VOID))
630 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
636 Perl_scalarvoid(pTHX_ OP *o)
640 const char* useless = NULL;
644 if (o->op_type == OP_NEXTSTATE
645 || o->op_type == OP_SETSTATE
646 || o->op_type == OP_DBSTATE
647 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
648 || o->op_targ == OP_SETSTATE
649 || o->op_targ == OP_DBSTATE)))
650 PL_curcop = (COP*)o; /* for warning below */
652 /* assumes no premature commitment */
653 want = o->op_flags & OPf_WANT;
654 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
655 || o->op_type == OP_RETURN)
660 if ((o->op_private & OPpTARGET_MY)
661 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
663 return scalar(o); /* As if inside SASSIGN */
666 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
668 switch (o->op_type) {
670 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
674 if (o->op_flags & OPf_STACKED)
678 if (o->op_private == 4)
750 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
751 useless = OP_DESC(o);
755 kid = cUNOPo->op_first;
756 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
757 kid->op_type != OP_TRANS) {
760 useless = "negative pattern binding (!~)";
767 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
768 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
769 useless = "a variable";
774 if (cSVOPo->op_private & OPpCONST_STRICT)
775 no_bareword_allowed(o);
777 if (ckWARN(WARN_VOID)) {
778 useless = "a constant";
779 /* don't warn on optimised away booleans, eg
780 * use constant Foo, 5; Foo || print; */
781 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
783 /* the constants 0 and 1 are permitted as they are
784 conventionally used as dummies in constructs like
785 1 while some_condition_with_side_effects; */
786 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
788 else if (SvPOK(sv)) {
789 /* perl4's way of mixing documentation and code
790 (before the invention of POD) was based on a
791 trick to mix nroff and perl code. The trick was
792 built upon these three nroff macros being used in
793 void context. The pink camel has the details in
794 the script wrapman near page 319. */
795 const char * const maybe_macro = SvPVX_const(sv);
796 if (strnEQ(maybe_macro, "di", 2) ||
797 strnEQ(maybe_macro, "ds", 2) ||
798 strnEQ(maybe_macro, "ig", 2))
803 op_null(o); /* don't execute or even remember it */
807 o->op_type = OP_PREINC; /* pre-increment is faster */
808 o->op_ppaddr = PL_ppaddr[OP_PREINC];
812 o->op_type = OP_PREDEC; /* pre-decrement is faster */
813 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
817 o->op_type = OP_I_PREINC; /* pre-increment is faster */
818 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
822 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
823 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
832 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
837 if (o->op_flags & OPf_STACKED)
844 if (!(o->op_flags & OPf_KIDS))
855 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
862 /* all requires must return a boolean value */
863 o->op_flags &= ~OPf_WANT;
868 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
869 if (!kPMOP->op_pmreplroot)
870 deprecate_old("implicit split to @_");
874 if (useless && ckWARN(WARN_VOID))
875 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
880 Perl_listkids(pTHX_ OP *o)
882 if (o && o->op_flags & OPf_KIDS) {
884 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
891 Perl_list(pTHX_ OP *o)
896 /* assumes no premature commitment */
897 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
898 || o->op_type == OP_RETURN)
903 if ((o->op_private & OPpTARGET_MY)
904 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
906 return o; /* As if inside SASSIGN */
909 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
911 switch (o->op_type) {
914 list(cBINOPo->op_first);
919 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
927 if (!(o->op_flags & OPf_KIDS))
929 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
930 list(cBINOPo->op_first);
931 return gen_constant_list(o);
938 kid = cLISTOPo->op_first;
940 while ((kid = kid->op_sibling)) {
946 WITH_THR(PL_curcop = &PL_compiling);
950 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
956 WITH_THR(PL_curcop = &PL_compiling);
959 /* all requires must return a boolean value */
960 o->op_flags &= ~OPf_WANT;
967 Perl_scalarseq(pTHX_ OP *o)
971 if (o->op_type == OP_LINESEQ ||
972 o->op_type == OP_SCOPE ||
973 o->op_type == OP_LEAVE ||
974 o->op_type == OP_LEAVETRY)
977 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
978 if (kid->op_sibling) {
982 PL_curcop = &PL_compiling;
984 o->op_flags &= ~OPf_PARENS;
985 if (PL_hints & HINT_BLOCK_SCOPE)
986 o->op_flags |= OPf_PARENS;
989 o = newOP(OP_STUB, 0);
994 S_modkids(pTHX_ OP *o, I32 type)
996 if (o && o->op_flags & OPf_KIDS) {
998 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1004 /* Propagate lvalue ("modifiable") context to an op and its children.
1005 * 'type' represents the context type, roughly based on the type of op that
1006 * would do the modifying, although local() is represented by OP_NULL.
1007 * It's responsible for detecting things that can't be modified, flag
1008 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
1009 * might have to vivify a reference in $x), and so on.
1011 * For example, "$a+1 = 2" would cause mod() to be called with o being
1012 * OP_ADD and type being OP_SASSIGN, and would output an error.
1016 Perl_mod(pTHX_ OP *o, I32 type)
1020 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1023 if (!o || PL_error_count)
1026 if ((o->op_private & OPpTARGET_MY)
1027 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1032 switch (o->op_type) {
1038 if (!(o->op_private & (OPpCONST_ARYBASE)))
1041 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1042 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
1046 SAVEI32(PL_compiling.cop_arybase);
1047 PL_compiling.cop_arybase = 0;
1049 else if (type == OP_REFGEN)
1052 Perl_croak(aTHX_ "That use of $[ is unsupported");
1055 if (o->op_flags & OPf_PARENS)
1059 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1060 !(o->op_flags & OPf_STACKED)) {
1061 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1062 /* The default is to set op_private to the number of children,
1063 which for a UNOP such as RV2CV is always 1. And w're using
1064 the bit for a flag in RV2CV, so we need it clear. */
1065 o->op_private &= ~1;
1066 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1067 assert(cUNOPo->op_first->op_type == OP_NULL);
1068 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1071 else if (o->op_private & OPpENTERSUB_NOMOD)
1073 else { /* lvalue subroutine call */
1074 o->op_private |= OPpLVAL_INTRO;
1075 PL_modcount = RETURN_UNLIMITED_NUMBER;
1076 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1077 /* Backward compatibility mode: */
1078 o->op_private |= OPpENTERSUB_INARGS;
1081 else { /* Compile-time error message: */
1082 OP *kid = cUNOPo->op_first;
1086 if (kid->op_type == OP_PUSHMARK)
1088 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1090 "panic: unexpected lvalue entersub "
1091 "args: type/targ %ld:%"UVuf,
1092 (long)kid->op_type, (UV)kid->op_targ);
1093 kid = kLISTOP->op_first;
1095 while (kid->op_sibling)
1096 kid = kid->op_sibling;
1097 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1099 if (kid->op_type == OP_METHOD_NAMED
1100 || kid->op_type == OP_METHOD)
1104 NewOp(1101, newop, 1, UNOP);
1105 newop->op_type = OP_RV2CV;
1106 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1107 newop->op_first = NULL;
1108 newop->op_next = (OP*)newop;
1109 kid->op_sibling = (OP*)newop;
1110 newop->op_private |= OPpLVAL_INTRO;
1111 newop->op_private &= ~1;
1115 if (kid->op_type != OP_RV2CV)
1117 "panic: unexpected lvalue entersub "
1118 "entry via type/targ %ld:%"UVuf,
1119 (long)kid->op_type, (UV)kid->op_targ);
1120 kid->op_private |= OPpLVAL_INTRO;
1121 break; /* Postpone until runtime */
1125 kid = kUNOP->op_first;
1126 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1127 kid = kUNOP->op_first;
1128 if (kid->op_type == OP_NULL)
1130 "Unexpected constant lvalue entersub "
1131 "entry via type/targ %ld:%"UVuf,
1132 (long)kid->op_type, (UV)kid->op_targ);
1133 if (kid->op_type != OP_GV) {
1134 /* Restore RV2CV to check lvalueness */
1136 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1137 okid->op_next = kid->op_next;
1138 kid->op_next = okid;
1141 okid->op_next = NULL;
1142 okid->op_type = OP_RV2CV;
1144 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1145 okid->op_private |= OPpLVAL_INTRO;
1146 okid->op_private &= ~1;
1150 cv = GvCV(kGVOP_gv);
1160 /* grep, foreach, subcalls, refgen */
1161 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1163 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1164 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1166 : (o->op_type == OP_ENTERSUB
1167 ? "non-lvalue subroutine call"
1169 type ? PL_op_desc[type] : "local"));
1183 case OP_RIGHT_SHIFT:
1192 if (!(o->op_flags & OPf_STACKED))
1199 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1205 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1206 PL_modcount = RETURN_UNLIMITED_NUMBER;
1207 return o; /* Treat \(@foo) like ordinary list. */
1211 if (scalar_mod_type(o, type))
1213 ref(cUNOPo->op_first, o->op_type);
1217 if (type == OP_LEAVESUBLV)
1218 o->op_private |= OPpMAYBE_LVSUB;
1224 PL_modcount = RETURN_UNLIMITED_NUMBER;
1227 ref(cUNOPo->op_first, o->op_type);
1232 PL_hints |= HINT_BLOCK_SCOPE;
1247 PL_modcount = RETURN_UNLIMITED_NUMBER;
1248 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1249 return o; /* Treat \(@foo) like ordinary list. */
1250 if (scalar_mod_type(o, type))
1252 if (type == OP_LEAVESUBLV)
1253 o->op_private |= OPpMAYBE_LVSUB;
1257 if (!type) /* local() */
1258 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1259 PAD_COMPNAME_PV(o->op_targ));
1267 if (type != OP_SASSIGN)
1271 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1276 if (type == OP_LEAVESUBLV)
1277 o->op_private |= OPpMAYBE_LVSUB;
1279 pad_free(o->op_targ);
1280 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1281 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1282 if (o->op_flags & OPf_KIDS)
1283 mod(cBINOPo->op_first->op_sibling, type);
1288 ref(cBINOPo->op_first, o->op_type);
1289 if (type == OP_ENTERSUB &&
1290 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1291 o->op_private |= OPpLVAL_DEFER;
1292 if (type == OP_LEAVESUBLV)
1293 o->op_private |= OPpMAYBE_LVSUB;
1303 if (o->op_flags & OPf_KIDS)
1304 mod(cLISTOPo->op_last, type);
1309 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1311 else if (!(o->op_flags & OPf_KIDS))
1313 if (o->op_targ != OP_LIST) {
1314 mod(cBINOPo->op_first, type);
1320 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1325 if (type != OP_LEAVESUBLV)
1327 break; /* mod()ing was handled by ck_return() */
1330 /* [20011101.069] File test operators interpret OPf_REF to mean that
1331 their argument is a filehandle; thus \stat(".") should not set
1333 if (type == OP_REFGEN &&
1334 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1337 if (type != OP_LEAVESUBLV)
1338 o->op_flags |= OPf_MOD;
1340 if (type == OP_AASSIGN || type == OP_SASSIGN)
1341 o->op_flags |= OPf_SPECIAL|OPf_REF;
1342 else if (!type) { /* local() */
1345 o->op_private |= OPpLVAL_INTRO;
1346 o->op_flags &= ~OPf_SPECIAL;
1347 PL_hints |= HINT_BLOCK_SCOPE;
1352 if (ckWARN(WARN_SYNTAX)) {
1353 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1354 "Useless localization of %s", OP_DESC(o));
1358 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1359 && type != OP_LEAVESUBLV)
1360 o->op_flags |= OPf_REF;
1365 S_scalar_mod_type(const OP *o, I32 type)
1369 if (o->op_type == OP_RV2GV)
1393 case OP_RIGHT_SHIFT:
1412 S_is_handle_constructor(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 NULL, 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, NULL);
1797 Perl_sawparens(pTHX_ OP *o)
1800 o->op_flags |= OPf_PARENS;
1805 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
1810 if ( (left->op_type == OP_RV2AV ||
1811 left->op_type == OP_RV2HV ||
1812 left->op_type == OP_PADAV ||
1813 left->op_type == OP_PADHV)
1814 && ckWARN(WARN_MISC))
1816 const char * const desc = PL_op_desc[(right->op_type == OP_SUBST ||
1817 right->op_type == OP_TRANS)
1818 ? right->op_type : OP_MATCH];
1819 const char * const sample = ((left->op_type == OP_RV2AV ||
1820 left->op_type == OP_PADAV)
1821 ? "@array" : "%hash");
1822 Perl_warner(aTHX_ packWARN(WARN_MISC),
1823 "Applying %s to %s will act on scalar(%s)",
1824 desc, sample, sample);
1827 if (right->op_type == OP_CONST &&
1828 cSVOPx(right)->op_private & OPpCONST_BARE &&
1829 cSVOPx(right)->op_private & OPpCONST_STRICT)
1831 no_bareword_allowed(right);
1834 ismatchop = right->op_type == OP_MATCH ||
1835 right->op_type == OP_SUBST ||
1836 right->op_type == OP_TRANS;
1837 if (ismatchop && right->op_private & OPpTARGET_MY) {
1839 right->op_private &= ~OPpTARGET_MY;
1841 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
1842 right->op_flags |= OPf_STACKED;
1843 if (right->op_type != OP_MATCH &&
1844 ! (right->op_type == OP_TRANS &&
1845 right->op_private & OPpTRANS_IDENTICAL))
1846 left = mod(left, right->op_type);
1847 if (right->op_type == OP_TRANS)
1848 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
1850 o = prepend_elem(right->op_type, scalar(left), right);
1852 return newUNOP(OP_NOT, 0, scalar(o));
1856 return bind_match(type, left,
1857 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
1861 Perl_invert(pTHX_ OP *o)
1865 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
1866 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
1870 Perl_scope(pTHX_ OP *o)
1874 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
1875 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
1876 o->op_type = OP_LEAVE;
1877 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
1879 else if (o->op_type == OP_LINESEQ) {
1881 o->op_type = OP_SCOPE;
1882 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
1883 kid = ((LISTOP*)o)->op_first;
1884 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
1887 /* The following deals with things like 'do {1 for 1}' */
1888 kid = kid->op_sibling;
1890 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
1895 o = newLISTOP(OP_SCOPE, 0, o, NULL);
1901 Perl_block_start(pTHX_ int full)
1904 const int retval = PL_savestack_ix;
1905 pad_block_start(full);
1907 PL_hints &= ~HINT_BLOCK_SCOPE;
1908 SAVESPTR(PL_compiling.cop_warnings);
1909 if (! specialWARN(PL_compiling.cop_warnings)) {
1910 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
1911 SAVEFREESV(PL_compiling.cop_warnings) ;
1913 SAVESPTR(PL_compiling.cop_io);
1914 if (! specialCopIO(PL_compiling.cop_io)) {
1915 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
1916 SAVEFREESV(PL_compiling.cop_io) ;
1922 Perl_block_end(pTHX_ I32 floor, OP *seq)
1925 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
1926 OP* const retval = scalarseq(seq);
1928 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
1930 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
1939 const I32 offset = pad_findmy("$_");
1940 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
1941 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
1944 OP * const o = newOP(OP_PADSV, 0);
1945 o->op_targ = offset;
1951 Perl_newPROG(pTHX_ OP *o)
1957 PL_eval_root = newUNOP(OP_LEAVEEVAL,
1958 ((PL_in_eval & EVAL_KEEPERR)
1959 ? OPf_SPECIAL : 0), o);
1960 PL_eval_start = linklist(PL_eval_root);
1961 PL_eval_root->op_private |= OPpREFCOUNTED;
1962 OpREFCNT_set(PL_eval_root, 1);
1963 PL_eval_root->op_next = 0;
1964 CALL_PEEP(PL_eval_start);
1967 if (o->op_type == OP_STUB) {
1968 PL_comppad_name = 0;
1973 PL_main_root = scope(sawparens(scalarvoid(o)));
1974 PL_curcop = &PL_compiling;
1975 PL_main_start = LINKLIST(PL_main_root);
1976 PL_main_root->op_private |= OPpREFCOUNTED;
1977 OpREFCNT_set(PL_main_root, 1);
1978 PL_main_root->op_next = 0;
1979 CALL_PEEP(PL_main_start);
1982 /* Register with debugger */
1984 CV * const cv = get_cv("DB::postponed", FALSE);
1988 XPUSHs((SV*)CopFILEGV(&PL_compiling));
1990 call_sv((SV*)cv, G_DISCARD);
1997 Perl_localize(pTHX_ OP *o, I32 lex)
2000 if (o->op_flags & OPf_PARENS)
2001 /* [perl #17376]: this appears to be premature, and results in code such as
2002 C< our(%x); > executing in list mode rather than void mode */
2009 if ( PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ','
2010 && ckWARN(WARN_PARENTHESIS))
2012 char *s = PL_bufptr;
2015 /* some heuristics to detect a potential error */
2016 while (*s && (strchr(", \t\n", *s)))
2020 if (*s && strchr("@$%*", *s) && *++s
2021 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2024 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2026 while (*s && (strchr(", \t\n", *s)))
2032 if (sigil && (*s == ';' || *s == '=')) {
2033 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2034 "Parentheses missing around \"%s\" list",
2035 lex ? (PL_in_my == KEY_our ? "our" : "my")
2043 o = mod(o, OP_NULL); /* a bit kludgey */
2045 PL_in_my_stash = NULL;
2050 Perl_jmaybe(pTHX_ OP *o)
2052 if (o->op_type == OP_LIST) {
2054 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL,
2056 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2062 Perl_fold_constants(pTHX_ register OP *o)
2066 I32 type = o->op_type;
2069 if (PL_opargs[type] & OA_RETSCALAR)
2071 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2072 o->op_targ = pad_alloc(type, SVs_PADTMP);
2074 /* integerize op, unless it happens to be C<-foo>.
2075 * XXX should pp_i_negate() do magic string negation instead? */
2076 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2077 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2078 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2080 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2083 if (!(PL_opargs[type] & OA_FOLDCONST))
2088 /* XXX might want a ck_negate() for this */
2089 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2100 /* XXX what about the numeric ops? */
2101 if (PL_hints & HINT_LOCALE)
2106 goto nope; /* Don't try to run w/ errors */
2108 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2109 if ((curop->op_type != OP_CONST ||
2110 (curop->op_private & OPpCONST_BARE)) &&
2111 curop->op_type != OP_LIST &&
2112 curop->op_type != OP_SCALAR &&
2113 curop->op_type != OP_NULL &&
2114 curop->op_type != OP_PUSHMARK)
2120 curop = LINKLIST(o);
2124 sv = *(PL_stack_sp--);
2125 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2126 pad_swipe(o->op_targ, FALSE);
2127 else if (SvTEMP(sv)) { /* grab mortal temp? */
2128 (void)SvREFCNT_inc(sv);
2132 if (type == OP_RV2GV)
2133 return newGVOP(OP_GV, 0, (GV*)sv);
2134 return newSVOP(OP_CONST, 0, sv);
2141 Perl_gen_constant_list(pTHX_ register OP *o)
2145 const I32 oldtmps_floor = PL_tmps_floor;
2149 return o; /* Don't attempt to run with errors */
2151 PL_op = curop = LINKLIST(o);
2158 PL_tmps_floor = oldtmps_floor;
2160 o->op_type = OP_RV2AV;
2161 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2162 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2163 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2164 o->op_opt = 0; /* needs to be revisited in peep() */
2165 curop = ((UNOP*)o)->op_first;
2166 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2173 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2176 if (!o || o->op_type != OP_LIST)
2177 o = newLISTOP(OP_LIST, 0, o, NULL);
2179 o->op_flags &= ~OPf_WANT;
2181 if (!(PL_opargs[type] & OA_MARK))
2182 op_null(cLISTOPo->op_first);
2184 o->op_type = (OPCODE)type;
2185 o->op_ppaddr = PL_ppaddr[type];
2186 o->op_flags |= flags;
2188 o = CHECKOP(type, o);
2189 if (o->op_type != (unsigned)type)
2192 return fold_constants(o);
2195 /* List constructors */
2198 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2206 if (first->op_type != (unsigned)type
2207 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2209 return newLISTOP(type, 0, first, last);
2212 if (first->op_flags & OPf_KIDS)
2213 ((LISTOP*)first)->op_last->op_sibling = last;
2215 first->op_flags |= OPf_KIDS;
2216 ((LISTOP*)first)->op_first = last;
2218 ((LISTOP*)first)->op_last = last;
2223 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2231 if (first->op_type != (unsigned)type)
2232 return prepend_elem(type, (OP*)first, (OP*)last);
2234 if (last->op_type != (unsigned)type)
2235 return append_elem(type, (OP*)first, (OP*)last);
2237 first->op_last->op_sibling = last->op_first;
2238 first->op_last = last->op_last;
2239 first->op_flags |= (last->op_flags & OPf_KIDS);
2247 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2255 if (last->op_type == (unsigned)type) {
2256 if (type == OP_LIST) { /* already a PUSHMARK there */
2257 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2258 ((LISTOP*)last)->op_first->op_sibling = first;
2259 if (!(first->op_flags & OPf_PARENS))
2260 last->op_flags &= ~OPf_PARENS;
2263 if (!(last->op_flags & OPf_KIDS)) {
2264 ((LISTOP*)last)->op_last = first;
2265 last->op_flags |= OPf_KIDS;
2267 first->op_sibling = ((LISTOP*)last)->op_first;
2268 ((LISTOP*)last)->op_first = first;
2270 last->op_flags |= OPf_KIDS;
2274 return newLISTOP(type, 0, first, last);
2280 Perl_newNULLLIST(pTHX)
2282 return newOP(OP_STUB, 0);
2286 Perl_force_list(pTHX_ OP *o)
2288 if (!o || o->op_type != OP_LIST)
2289 o = newLISTOP(OP_LIST, 0, o, NULL);
2295 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2300 NewOp(1101, listop, 1, LISTOP);
2302 listop->op_type = (OPCODE)type;
2303 listop->op_ppaddr = PL_ppaddr[type];
2306 listop->op_flags = (U8)flags;
2310 else if (!first && last)
2313 first->op_sibling = last;
2314 listop->op_first = first;
2315 listop->op_last = last;
2316 if (type == OP_LIST) {
2317 OP* const pushop = newOP(OP_PUSHMARK, 0);
2318 pushop->op_sibling = first;
2319 listop->op_first = pushop;
2320 listop->op_flags |= OPf_KIDS;
2322 listop->op_last = pushop;
2325 return CHECKOP(type, listop);
2329 Perl_newOP(pTHX_ I32 type, I32 flags)
2333 NewOp(1101, o, 1, OP);
2334 o->op_type = (OPCODE)type;
2335 o->op_ppaddr = PL_ppaddr[type];
2336 o->op_flags = (U8)flags;
2339 o->op_private = (U8)(0 | (flags >> 8));
2340 if (PL_opargs[type] & OA_RETSCALAR)
2342 if (PL_opargs[type] & OA_TARGET)
2343 o->op_targ = pad_alloc(type, SVs_PADTMP);
2344 return CHECKOP(type, o);
2348 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2354 first = newOP(OP_STUB, 0);
2355 if (PL_opargs[type] & OA_MARK)
2356 first = force_list(first);
2358 NewOp(1101, unop, 1, UNOP);
2359 unop->op_type = (OPCODE)type;
2360 unop->op_ppaddr = PL_ppaddr[type];
2361 unop->op_first = first;
2362 unop->op_flags = (U8)(flags | OPf_KIDS);
2363 unop->op_private = (U8)(1 | (flags >> 8));
2364 unop = (UNOP*) CHECKOP(type, unop);
2368 return fold_constants((OP *) unop);
2372 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2376 NewOp(1101, binop, 1, BINOP);
2379 first = newOP(OP_NULL, 0);
2381 binop->op_type = (OPCODE)type;
2382 binop->op_ppaddr = PL_ppaddr[type];
2383 binop->op_first = first;
2384 binop->op_flags = (U8)(flags | OPf_KIDS);
2387 binop->op_private = (U8)(1 | (flags >> 8));
2390 binop->op_private = (U8)(2 | (flags >> 8));
2391 first->op_sibling = last;
2394 binop = (BINOP*)CHECKOP(type, binop);
2395 if (binop->op_next || binop->op_type != (OPCODE)type)
2398 binop->op_last = binop->op_first->op_sibling;
2400 return fold_constants((OP *)binop);
2403 static int uvcompare(const void *a, const void *b)
2404 __attribute__nonnull__(1)
2405 __attribute__nonnull__(2)
2406 __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 = NULL;
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 = NULL;
2812 cLISTOPx(oe)->op_last = NULL;
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 = NULL; /* 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, NULL, newUNOP(OP_REQUIRE, 0, idop)),
3130 newSTATEOP(0, NULL, veop)),
3131 newSTATEOP(0, NULL, 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_fetchpvs("do", GV_NOTQUAL, 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 : NULL;
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 = NULL; /* 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 = NULL; /* 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 = NULL;
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 NULL; /* 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 = NULL;
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));
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) = NULL;
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, NULL);
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, NULL, 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) : NULL;
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)) ? NULL : 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, NULL);
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, NULL, 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);
4727 SV * const tmpstr = sv_newmortal();
4728 GV * const db_postponed = gv_fetchpvs("DB::postponed",
4729 GV_ADDMULTI, SVt_PVHV);
4732 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4734 (long)PL_subline, (long)CopLINE(PL_curcop));
4735 gv_efullname3(tmpstr, gv, NULL);
4736 hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0);
4737 hv = GvHVn(db_postponed);
4738 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
4739 CV * const pcv = GvCV(db_postponed);
4745 call_sv((SV*)pcv, G_DISCARD);
4750 if ((s = strrchr(tname,':')))
4755 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4758 if (strEQ(s, "BEGIN") && !PL_error_count) {
4759 const I32 oldscope = PL_scopestack_ix;
4761 SAVECOPFILE(&PL_compiling);
4762 SAVECOPLINE(&PL_compiling);
4765 PL_beginav = newAV();
4766 DEBUG_x( dump_sub(gv) );
4767 av_push(PL_beginav, (SV*)cv);
4768 GvCV(gv) = 0; /* cv has been hijacked */
4769 call_list(oldscope, PL_beginav);
4771 PL_curcop = &PL_compiling;
4772 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4775 else if (strEQ(s, "END") && !PL_error_count) {
4778 DEBUG_x( dump_sub(gv) );
4779 av_unshift(PL_endav, 1);
4780 av_store(PL_endav, 0, (SV*)cv);
4781 GvCV(gv) = 0; /* cv has been hijacked */
4783 else if (strEQ(s, "CHECK") && !PL_error_count) {
4785 PL_checkav = newAV();
4786 DEBUG_x( dump_sub(gv) );
4787 if (PL_main_start && ckWARN(WARN_VOID))
4788 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4789 av_unshift(PL_checkav, 1);
4790 av_store(PL_checkav, 0, (SV*)cv);
4791 GvCV(gv) = 0; /* cv has been hijacked */
4793 else if (strEQ(s, "INIT") && !PL_error_count) {
4795 PL_initav = newAV();
4796 DEBUG_x( dump_sub(gv) );
4797 if (PL_main_start && ckWARN(WARN_VOID))
4798 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4799 av_push(PL_initav, (SV*)cv);
4800 GvCV(gv) = 0; /* cv has been hijacked */
4805 PL_copline = NOLINE;
4810 /* XXX unsafe for threads if eval_owner isn't held */
4812 =for apidoc newCONSTSUB
4814 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4815 eligible for inlining at compile-time.
4821 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
4828 SAVECOPLINE(PL_curcop);
4829 CopLINE_set(PL_curcop, PL_copline);
4832 PL_hints &= ~HINT_BLOCK_SCOPE;
4835 SAVESPTR(PL_curstash);
4836 SAVECOPSTASH(PL_curcop);
4837 PL_curstash = stash;
4838 CopSTASH_set(PL_curcop,stash);
4841 cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
4842 CvXSUBANY(cv).any_ptr = sv;
4844 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
4848 CopSTASH_free(PL_curcop);
4856 =for apidoc U||newXS
4858 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4864 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
4867 GV * const gv = gv_fetchpv(name ? name :
4868 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4869 GV_ADDMULTI, SVt_PVCV);
4873 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4875 if ((cv = (name ? GvCV(gv) : NULL))) {
4877 /* just a cached method */
4881 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4882 /* already defined (or promised) */
4883 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
4884 if (ckWARN(WARN_REDEFINE)) {
4885 GV * const gvcv = CvGV(cv);
4887 HV * const stash = GvSTASH(gvcv);
4889 const char *redefined_name = HvNAME_get(stash);
4890 if ( strEQ(redefined_name,"autouse") ) {
4891 const line_t oldline = CopLINE(PL_curcop);
4892 if (PL_copline != NOLINE)
4893 CopLINE_set(PL_curcop, PL_copline);
4894 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4895 CvCONST(cv) ? "Constant subroutine %s redefined"
4896 : "Subroutine %s redefined"
4898 CopLINE_set(PL_curcop, oldline);
4908 if (cv) /* must reuse cv if autoloaded */
4912 sv_upgrade((SV *)cv, SVt_PVCV);
4916 PL_sub_generation++;
4920 (void)gv_fetchfile(filename);
4921 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
4922 an external constant string */
4923 CvXSUB(cv) = subaddr;
4926 const char *s = strrchr(name,':');
4932 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4935 if (strEQ(s, "BEGIN")) {
4937 PL_beginav = newAV();
4938 av_push(PL_beginav, (SV*)cv);
4939 GvCV(gv) = 0; /* cv has been hijacked */
4941 else if (strEQ(s, "END")) {
4944 av_unshift(PL_endav, 1);
4945 av_store(PL_endav, 0, (SV*)cv);
4946 GvCV(gv) = 0; /* cv has been hijacked */
4948 else if (strEQ(s, "CHECK")) {
4950 PL_checkav = newAV();
4951 if (PL_main_start && ckWARN(WARN_VOID))
4952 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4953 av_unshift(PL_checkav, 1);
4954 av_store(PL_checkav, 0, (SV*)cv);
4955 GvCV(gv) = 0; /* cv has been hijacked */
4957 else if (strEQ(s, "INIT")) {
4959 PL_initav = newAV();
4960 if (PL_main_start && ckWARN(WARN_VOID))
4961 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4962 av_push(PL_initav, (SV*)cv);
4963 GvCV(gv) = 0; /* cv has been hijacked */
4974 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4980 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
4981 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
4983 #ifdef GV_UNIQUE_CHECK
4985 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
4989 if ((cv = GvFORM(gv))) {
4990 if (ckWARN(WARN_REDEFINE)) {
4991 const line_t oldline = CopLINE(PL_curcop);
4992 if (PL_copline != NOLINE)
4993 CopLINE_set(PL_curcop, PL_copline);
4994 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4995 o ? "Format %"SVf" redefined"
4996 : "Format STDOUT redefined" ,cSVOPo->op_sv);
4997 CopLINE_set(PL_curcop, oldline);
5004 CvFILE_set_from_cop(cv, PL_curcop);
5007 pad_tidy(padtidy_FORMAT);
5008 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5009 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5010 OpREFCNT_set(CvROOT(cv), 1);
5011 CvSTART(cv) = LINKLIST(CvROOT(cv));
5012 CvROOT(cv)->op_next = 0;
5013 CALL_PEEP(CvSTART(cv));
5015 PL_copline = NOLINE;
5020 Perl_newANONLIST(pTHX_ OP *o)
5022 return newUNOP(OP_REFGEN, 0,
5023 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5027 Perl_newANONHASH(pTHX_ OP *o)
5029 return newUNOP(OP_REFGEN, 0,
5030 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5034 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5036 return newANONATTRSUB(floor, proto, NULL, block);
5040 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5042 return newUNOP(OP_REFGEN, 0,
5043 newSVOP(OP_ANONCODE, 0,
5044 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5048 Perl_oopsAV(pTHX_ OP *o)
5051 switch (o->op_type) {
5053 o->op_type = OP_PADAV;
5054 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5055 return ref(o, OP_RV2AV);
5058 o->op_type = OP_RV2AV;
5059 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5064 if (ckWARN_d(WARN_INTERNAL))
5065 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
5072 Perl_oopsHV(pTHX_ OP *o)
5075 switch (o->op_type) {
5078 o->op_type = OP_PADHV;
5079 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5080 return ref(o, OP_RV2HV);
5084 o->op_type = OP_RV2HV;
5085 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5090 if (ckWARN_d(WARN_INTERNAL))
5091 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
5098 Perl_newAVREF(pTHX_ OP *o)
5101 if (o->op_type == OP_PADANY) {
5102 o->op_type = OP_PADAV;
5103 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5106 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5107 && ckWARN(WARN_DEPRECATED)) {
5108 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5109 "Using an array as a reference is deprecated");
5111 return newUNOP(OP_RV2AV, 0, scalar(o));
5115 Perl_newGVREF(pTHX_ I32 type, OP *o)
5117 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5118 return newUNOP(OP_NULL, 0, o);
5119 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5123 Perl_newHVREF(pTHX_ OP *o)
5126 if (o->op_type == OP_PADANY) {
5127 o->op_type = OP_PADHV;
5128 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5131 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5132 && ckWARN(WARN_DEPRECATED)) {
5133 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5134 "Using a hash as a reference is deprecated");
5136 return newUNOP(OP_RV2HV, 0, scalar(o));
5140 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5142 return newUNOP(OP_RV2CV, flags, scalar(o));
5146 Perl_newSVREF(pTHX_ OP *o)
5149 if (o->op_type == OP_PADANY) {
5150 o->op_type = OP_PADSV;
5151 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5154 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5155 o->op_flags |= OPpDONE_SVREF;
5158 return newUNOP(OP_RV2SV, 0, scalar(o));
5161 /* Check routines. See the comments at the top of this file for details
5162 * on when these are called */
5165 Perl_ck_anoncode(pTHX_ OP *o)
5167 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
5168 cSVOPo->op_sv = NULL;
5173 Perl_ck_bitop(pTHX_ OP *o)
5176 #define OP_IS_NUMCOMPARE(op) \
5177 ((op) == OP_LT || (op) == OP_I_LT || \
5178 (op) == OP_GT || (op) == OP_I_GT || \
5179 (op) == OP_LE || (op) == OP_I_LE || \
5180 (op) == OP_GE || (op) == OP_I_GE || \
5181 (op) == OP_EQ || (op) == OP_I_EQ || \
5182 (op) == OP_NE || (op) == OP_I_NE || \
5183 (op) == OP_NCMP || (op) == OP_I_NCMP)
5184 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
5185 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
5186 && (o->op_type == OP_BIT_OR
5187 || o->op_type == OP_BIT_AND
5188 || o->op_type == OP_BIT_XOR))
5190 const OP * const left = cBINOPo->op_first;
5191 const OP * const right = left->op_sibling;
5192 if ((OP_IS_NUMCOMPARE(left->op_type) &&
5193 (left->op_flags & OPf_PARENS) == 0) ||
5194 (OP_IS_NUMCOMPARE(right->op_type) &&
5195 (right->op_flags & OPf_PARENS) == 0))
5196 if (ckWARN(WARN_PRECEDENCE))
5197 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
5198 "Possible precedence problem on bitwise %c operator",
5199 o->op_type == OP_BIT_OR ? '|'
5200 : o->op_type == OP_BIT_AND ? '&' : '^'
5207 Perl_ck_concat(pTHX_ OP *o)
5209 const OP * const kid = cUNOPo->op_first;
5210 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
5211 !(kUNOP->op_first->op_flags & OPf_MOD))
5212 o->op_flags |= OPf_STACKED;
5217 Perl_ck_spair(pTHX_ OP *o)
5220 if (o->op_flags & OPf_KIDS) {
5223 const OPCODE type = o->op_type;
5224 o = modkids(ck_fun(o), type);
5225 kid = cUNOPo->op_first;
5226 newop = kUNOP->op_first->op_sibling;
5228 (newop->op_sibling ||
5229 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5230 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5231 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5235 op_free(kUNOP->op_first);
5236 kUNOP->op_first = newop;
5238 o->op_ppaddr = PL_ppaddr[++o->op_type];
5243 Perl_ck_delete(pTHX_ OP *o)
5247 if (o->op_flags & OPf_KIDS) {
5248 OP * const kid = cUNOPo->op_first;
5249 switch (kid->op_type) {
5251 o->op_flags |= OPf_SPECIAL;
5254 o->op_private |= OPpSLICE;
5257 o->op_flags |= OPf_SPECIAL;
5262 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5271 Perl_ck_die(pTHX_ OP *o)
5274 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5280 Perl_ck_eof(pTHX_ OP *o)
5283 const I32 type = o->op_type;
5285 if (o->op_flags & OPf_KIDS) {
5286 if (cLISTOPo->op_first->op_type == OP_STUB) {
5288 o = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
5296 Perl_ck_eval(pTHX_ OP *o)
5299 PL_hints |= HINT_BLOCK_SCOPE;
5300 if (o->op_flags & OPf_KIDS) {
5301 SVOP * const kid = (SVOP*)cUNOPo->op_first;
5304 o->op_flags &= ~OPf_KIDS;
5307 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
5310 cUNOPo->op_first = 0;
5313 NewOp(1101, enter, 1, LOGOP);
5314 enter->op_type = OP_ENTERTRY;
5315 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5316 enter->op_private = 0;
5318 /* establish postfix order */
5319 enter->op_next = (OP*)enter;
5321 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5322 o->op_type = OP_LEAVETRY;
5323 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5324 enter->op_other = o;
5334 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5336 o->op_targ = (PADOFFSET)PL_hints;
5337 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
5338 /* Store a copy of %^H that pp_entereval can pick up */
5339 OP *hhop = newSVOP(OP_CONST, 0, (SV*)newHVhv(GvHV(PL_hintgv)));
5340 cUNOPo->op_first->op_sibling = hhop;
5341 o->op_private |= OPpEVAL_HAS_HH;
5347 Perl_ck_exit(pTHX_ OP *o)
5350 HV * const table = GvHV(PL_hintgv);
5352 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
5353 if (svp && *svp && SvTRUE(*svp))
5354 o->op_private |= OPpEXIT_VMSISH;
5356 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5362 Perl_ck_exec(pTHX_ OP *o)
5364 if (o->op_flags & OPf_STACKED) {
5367 kid = cUNOPo->op_first->op_sibling;
5368 if (kid->op_type == OP_RV2GV)
5377 Perl_ck_exists(pTHX_ OP *o)
5381 if (o->op_flags & OPf_KIDS) {
5382 OP * const kid = cUNOPo->op_first;
5383 if (kid->op_type == OP_ENTERSUB) {
5384 (void) ref(kid, o->op_type);
5385 if (kid->op_type != OP_RV2CV && !PL_error_count)
5386 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5388 o->op_private |= OPpEXISTS_SUB;
5390 else if (kid->op_type == OP_AELEM)
5391 o->op_flags |= OPf_SPECIAL;
5392 else if (kid->op_type != OP_HELEM)
5393 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5401 Perl_ck_rvconst(pTHX_ register OP *o)
5404 SVOP * const kid = (SVOP*)cUNOPo->op_first;
5406 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5407 if (o->op_type == OP_RV2CV)
5408 o->op_private &= ~1;
5410 if (kid->op_type == OP_CONST) {
5413 SV * const kidsv = kid->op_sv;
5415 /* Is it a constant from cv_const_sv()? */
5416 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5417 SV * const rsv = SvRV(kidsv);
5418 const int svtype = SvTYPE(rsv);
5419 const char *badtype = NULL;
5421 switch (o->op_type) {
5423 if (svtype > SVt_PVMG)
5424 badtype = "a SCALAR";
5427 if (svtype != SVt_PVAV)
5428 badtype = "an ARRAY";
5431 if (svtype != SVt_PVHV)
5435 if (svtype != SVt_PVCV)
5440 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5443 else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
5444 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
5445 /* If this is an access to a stash, disable "strict refs", because
5446 * stashes aren't auto-vivified at compile-time (unless we store
5447 * symbols in them), and we don't want to produce a run-time
5448 * stricture error when auto-vivifying the stash. */
5449 const char *s = SvPV_nolen(kidsv);
5450 const STRLEN l = SvCUR(kidsv);
5451 if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
5452 o->op_private &= ~HINT_STRICT_REFS;
5454 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5455 const char *badthing;
5456 switch (o->op_type) {
5458 badthing = "a SCALAR";
5461 badthing = "an ARRAY";
5464 badthing = "a HASH";
5472 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
5476 * This is a little tricky. We only want to add the symbol if we
5477 * didn't add it in the lexer. Otherwise we get duplicate strict
5478 * warnings. But if we didn't add it in the lexer, we must at
5479 * least pretend like we wanted to add it even if it existed before,
5480 * or we get possible typo warnings. OPpCONST_ENTERED says
5481 * whether the lexer already added THIS instance of this symbol.
5483 iscv = (o->op_type == OP_RV2CV) * 2;
5485 gv = gv_fetchsv(kidsv,
5486 iscv | !(kid->op_private & OPpCONST_ENTERED),
5489 : o->op_type == OP_RV2SV
5491 : o->op_type == OP_RV2AV
5493 : o->op_type == OP_RV2HV
5496 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5498 kid->op_type = OP_GV;
5499 SvREFCNT_dec(kid->op_sv);
5501 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5502 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5503 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
5505 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv));
5507 kid->op_sv = SvREFCNT_inc(gv);
5509 kid->op_private = 0;
5510 kid->op_ppaddr = PL_ppaddr[OP_GV];
5517 Perl_ck_ftst(pTHX_ OP *o)
5520 const I32 type = o->op_type;
5522 if (o->op_flags & OPf_REF) {
5525 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5526 SVOP * const kid = (SVOP*)cUNOPo->op_first;
5528 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5529 OP * const newop = newGVOP(type, OPf_REF,
5530 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
5536 if ((PL_hints & HINT_FILETEST_ACCESS) &&
5537 OP_IS_FILETEST_ACCESS(o))
5538 o->op_private |= OPpFT_ACCESS;
5540 if (PL_check[kid->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst)
5541 && kid->op_type != OP_STAT && kid->op_type != OP_LSTAT)
5542 o->op_private |= OPpFT_STACKED;
5546 if (type == OP_FTTTY)
5547 o = newGVOP(type, OPf_REF, PL_stdingv);
5549 o = newUNOP(type, 0, newDEFSVOP());
5555 Perl_ck_fun(pTHX_ OP *o)
5558 const int type = o->op_type;
5559 register I32 oa = PL_opargs[type] >> OASHIFT;
5561 if (o->op_flags & OPf_STACKED) {
5562 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5565 return no_fh_allowed(o);
5568 if (o->op_flags & OPf_KIDS) {
5569 OP **tokid = &cLISTOPo->op_first;
5570 register OP *kid = cLISTOPo->op_first;
5574 if (kid->op_type == OP_PUSHMARK ||
5575 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5577 tokid = &kid->op_sibling;
5578 kid = kid->op_sibling;
5580 if (!kid && PL_opargs[type] & OA_DEFGV)
5581 *tokid = kid = newDEFSVOP();
5585 sibl = kid->op_sibling;
5588 /* list seen where single (scalar) arg expected? */
5589 if (numargs == 1 && !(oa >> 4)
5590 && kid->op_type == OP_LIST && type != OP_SCALAR)
5592 return too_many_arguments(o,PL_op_desc[type]);
5605 if ((type == OP_PUSH || type == OP_UNSHIFT)
5606 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5607 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5608 "Useless use of %s with no values",
5611 if (kid->op_type == OP_CONST &&
5612 (kid->op_private & OPpCONST_BARE))
5614 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
5615 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
5616 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5617 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5618 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
5619 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
5622 kid->op_sibling = sibl;
5625 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5626 bad_type(numargs, "array", PL_op_desc[type], kid);
5630 if (kid->op_type == OP_CONST &&
5631 (kid->op_private & OPpCONST_BARE))
5633 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
5634 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
5635 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5636 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5637 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
5638 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
5641 kid->op_sibling = sibl;
5644 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5645 bad_type(numargs, "hash", PL_op_desc[type], kid);
5650 OP * const newop = newUNOP(OP_NULL, 0, kid);
5651 kid->op_sibling = 0;
5653 newop->op_next = newop;
5655 kid->op_sibling = sibl;
5660 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5661 if (kid->op_type == OP_CONST &&
5662 (kid->op_private & OPpCONST_BARE))
5664 OP * const newop = newGVOP(OP_GV, 0,
5665 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
5666 if (!(o->op_private & 1) && /* if not unop */
5667 kid == cLISTOPo->op_last)
5668 cLISTOPo->op_last = newop;
5672 else if (kid->op_type == OP_READLINE) {
5673 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5674 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5677 I32 flags = OPf_SPECIAL;
5681 /* is this op a FH constructor? */
5682 if (is_handle_constructor(o,numargs)) {
5683 const char *name = NULL;
5687 /* Set a flag to tell rv2gv to vivify
5688 * need to "prove" flag does not mean something
5689 * else already - NI-S 1999/05/07
5692 if (kid->op_type == OP_PADSV) {
5693 name = PAD_COMPNAME_PV(kid->op_targ);
5694 /* SvCUR of a pad namesv can't be trusted
5695 * (see PL_generation), so calc its length
5701 else if (kid->op_type == OP_RV2SV
5702 && kUNOP->op_first->op_type == OP_GV)
5704 GV * const gv = cGVOPx_gv(kUNOP->op_first);
5706 len = GvNAMELEN(gv);
5708 else if (kid->op_type == OP_AELEM
5709 || kid->op_type == OP_HELEM)
5711 OP *op = ((BINOP*)kid)->op_first;
5715 const char * const a =
5716 kid->op_type == OP_AELEM ?
5718 if (((op->op_type == OP_RV2AV) ||
5719 (op->op_type == OP_RV2HV)) &&
5720 (op = ((UNOP*)op)->op_first) &&
5721 (op->op_type == OP_GV)) {
5722 /* packagevar $a[] or $h{} */
5723 GV * const gv = cGVOPx_gv(op);
5731 else if (op->op_type == OP_PADAV
5732 || op->op_type == OP_PADHV) {
5733 /* lexicalvar $a[] or $h{} */
5734 const char * const padname =
5735 PAD_COMPNAME_PV(op->op_targ);
5744 name = SvPV_const(tmpstr, len);
5749 name = "__ANONIO__";
5756 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5757 namesv = PAD_SVl(targ);
5758 SvUPGRADE(namesv, SVt_PV);
5760 sv_setpvn(namesv, "$", 1);
5761 sv_catpvn(namesv, name, len);
5764 kid->op_sibling = 0;
5765 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5766 kid->op_targ = targ;
5767 kid->op_private |= priv;
5769 kid->op_sibling = sibl;
5775 mod(scalar(kid), type);
5779 tokid = &kid->op_sibling;
5780 kid = kid->op_sibling;
5782 o->op_private |= numargs;
5784 return too_many_arguments(o,OP_DESC(o));
5787 else if (PL_opargs[type] & OA_DEFGV) {
5789 return newUNOP(type, 0, newDEFSVOP());
5793 while (oa & OA_OPTIONAL)
5795 if (oa && oa != OA_LIST)
5796 return too_few_arguments(o,OP_DESC(o));
5802 Perl_ck_glob(pTHX_ OP *o)
5808 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5809 append_elem(OP_GLOB, o, newDEFSVOP());
5811 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
5812 && GvCVu(gv) && GvIMPORTED_CV(gv)))
5814 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
5817 #if !defined(PERL_EXTERNAL_GLOB)
5818 /* XXX this can be tightened up and made more failsafe. */
5819 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
5822 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5823 newSVpvs("File::Glob"), NULL, NULL, NULL);
5824 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
5825 glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
5826 GvCV(gv) = GvCV(glob_gv);
5827 (void)SvREFCNT_inc((SV*)GvCV(gv));
5828 GvIMPORTED_CV_on(gv);
5831 #endif /* PERL_EXTERNAL_GLOB */
5833 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5834 append_elem(OP_GLOB, o,
5835 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5836 o->op_type = OP_LIST;
5837 o->op_ppaddr = PL_ppaddr[OP_LIST];
5838 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5839 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5840 cLISTOPo->op_first->op_targ = 0;
5841 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5842 append_elem(OP_LIST, o,
5843 scalar(newUNOP(OP_RV2CV, 0,
5844 newGVOP(OP_GV, 0, gv)))));
5845 o = newUNOP(OP_NULL, 0, ck_subr(o));
5846 o->op_targ = OP_GLOB; /* hint at what it used to be */
5849 gv = newGVgen("main");
5851 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5857 Perl_ck_grep(pTHX_ OP *o)
5862 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5865 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5866 NewOp(1101, gwop, 1, LOGOP);
5868 if (o->op_flags & OPf_STACKED) {
5871 kid = cLISTOPo->op_first->op_sibling;
5872 if (!cUNOPx(kid)->op_next)
5873 Perl_croak(aTHX_ "panic: ck_grep");
5874 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
5877 kid->op_next = (OP*)gwop;
5878 o->op_flags &= ~OPf_STACKED;
5880 kid = cLISTOPo->op_first->op_sibling;
5881 if (type == OP_MAPWHILE)
5888 kid = cLISTOPo->op_first->op_sibling;
5889 if (kid->op_type != OP_NULL)
5890 Perl_croak(aTHX_ "panic: ck_grep");
5891 kid = kUNOP->op_first;
5893 gwop->op_type = type;
5894 gwop->op_ppaddr = PL_ppaddr[type];
5895 gwop->op_first = listkids(o);
5896 gwop->op_flags |= OPf_KIDS;
5897 gwop->op_other = LINKLIST(kid);
5898 kid->op_next = (OP*)gwop;
5899 offset = pad_findmy("$_");
5900 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
5901 o->op_private = gwop->op_private = 0;
5902 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5905 o->op_private = gwop->op_private = OPpGREP_LEX;
5906 gwop->op_targ = o->op_targ = offset;
5909 kid = cLISTOPo->op_first->op_sibling;
5910 if (!kid || !kid->op_sibling)
5911 return too_few_arguments(o,OP_DESC(o));
5912 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5913 mod(kid, OP_GREPSTART);
5919 Perl_ck_index(pTHX_ OP *o)
5921 if (o->op_flags & OPf_KIDS) {
5922 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5924 kid = kid->op_sibling; /* get past "big" */
5925 if (kid && kid->op_type == OP_CONST)
5926 fbm_compile(((SVOP*)kid)->op_sv, 0);
5932 Perl_ck_lengthconst(pTHX_ OP *o)
5934 /* XXX length optimization goes here */
5939 Perl_ck_lfun(pTHX_ OP *o)
5941 const OPCODE type = o->op_type;
5942 return modkids(ck_fun(o), type);
5946 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5948 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
5949 switch (cUNOPo->op_first->op_type) {
5951 /* This is needed for
5952 if (defined %stash::)
5953 to work. Do not break Tk.
5955 break; /* Globals via GV can be undef */
5957 case OP_AASSIGN: /* Is this a good idea? */
5958 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5959 "defined(@array) is deprecated");
5960 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5961 "\t(Maybe you should just omit the defined()?)\n");
5964 /* This is needed for
5965 if (defined %stash::)
5966 to work. Do not break Tk.
5968 break; /* Globals via GV can be undef */
5970 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5971 "defined(%%hash) is deprecated");
5972 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5973 "\t(Maybe you should just omit the defined()?)\n");
5984 Perl_ck_rfun(pTHX_ OP *o)
5986 const OPCODE type = o->op_type;
5987 return refkids(ck_fun(o), type);
5991 Perl_ck_listiob(pTHX_ OP *o)
5995 kid = cLISTOPo->op_first;
5998 kid = cLISTOPo->op_first;
6000 if (kid->op_type == OP_PUSHMARK)
6001 kid = kid->op_sibling;
6002 if (kid && o->op_flags & OPf_STACKED)
6003 kid = kid->op_sibling;
6004 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6005 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6006 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6007 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6008 cLISTOPo->op_first->op_sibling = kid;
6009 cLISTOPo->op_last = kid;
6010 kid = kid->op_sibling;
6015 append_elem(o->op_type, o, newDEFSVOP());
6021 Perl_ck_say(pTHX_ OP *o)
6024 o->op_type = OP_PRINT;
6025 cLISTOPo->op_last = cLISTOPo->op_last->op_sibling
6026 = newSVOP(OP_CONST, 0, newSVpvs("\n"));
6031 Perl_ck_smartmatch(pTHX_ OP *o)
6034 if (0 == (o->op_flags & OPf_SPECIAL)) {
6035 OP *first = cBINOPo->op_first;
6036 OP *second = first->op_sibling;
6038 /* Implicitly take a reference to an array or hash */
6039 first->op_sibling = NULL;
6040 first = cBINOPo->op_first = ref_array_or_hash(first);
6041 second = first->op_sibling = ref_array_or_hash(second);
6043 /* Implicitly take a reference to a regular expression */
6044 if (first->op_type == OP_MATCH) {
6045 first->op_type = OP_QR;
6046 first->op_ppaddr = PL_ppaddr[OP_QR];
6048 if (second->op_type == OP_MATCH) {
6049 second->op_type = OP_QR;
6050 second->op_ppaddr = PL_ppaddr[OP_QR];
6059 Perl_ck_sassign(pTHX_ OP *o)
6061 OP *kid = cLISTOPo->op_first;
6062 /* has a disposable target? */
6063 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6064 && !(kid->op_flags & OPf_STACKED)
6065 /* Cannot steal the second time! */
6066 && !(kid->op_private & OPpTARGET_MY))
6068 OP * const kkid = kid->op_sibling;
6070 /* Can just relocate the target. */
6071 if (kkid && kkid->op_type == OP_PADSV
6072 && !(kkid->op_private & OPpLVAL_INTRO))
6074 kid->op_targ = kkid->op_targ;
6076 /* Now we do not need PADSV and SASSIGN. */
6077 kid->op_sibling = o->op_sibling; /* NULL */
6078 cLISTOPo->op_first = NULL;
6081 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6089 Perl_ck_match(pTHX_ OP *o)
6092 if (o->op_type != OP_QR && PL_compcv) {
6093 const I32 offset = pad_findmy("$_");
6094 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS(offset) & SVpad_OUR)) {
6095 o->op_targ = offset;
6096 o->op_private |= OPpTARGET_MY;
6099 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
6100 o->op_private |= OPpRUNTIME;
6105 Perl_ck_method(pTHX_ OP *o)
6107 OP * const kid = cUNOPo->op_first;
6108 if (kid->op_type == OP_CONST) {
6109 SV* sv = kSVOP->op_sv;
6110 const char * const method = SvPVX_const(sv);
6111 if (!(strchr(method, ':') || strchr(method, '\''))) {
6113 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6114 sv = newSVpvn_share(method, SvCUR(sv), 0);
6117 kSVOP->op_sv = NULL;
6119 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6128 Perl_ck_null(pTHX_ OP *o)
6134 Perl_ck_open(pTHX_ OP *o)
6137 HV * const table = GvHV(PL_hintgv);
6139 SV **svp = hv_fetchs(table, "open_IN", FALSE);
6141 const I32 mode = mode_from_discipline(*svp);
6142 if (mode & O_BINARY)
6143 o->op_private |= OPpOPEN_IN_RAW;
6144 else if (mode & O_TEXT)
6145 o->op_private |= OPpOPEN_IN_CRLF;
6148 svp = hv_fetchs(table, "open_OUT", FALSE);
6150 const I32 mode = mode_from_discipline(*svp);
6151 if (mode & O_BINARY)
6152 o->op_private |= OPpOPEN_OUT_RAW;
6153 else if (mode & O_TEXT)
6154 o->op_private |= OPpOPEN_OUT_CRLF;
6157 if (o->op_type == OP_BACKTICK)
6160 /* In case of three-arg dup open remove strictness
6161 * from the last arg if it is a bareword. */
6162 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
6163 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
6167 if ((last->op_type == OP_CONST) && /* The bareword. */
6168 (last->op_private & OPpCONST_BARE) &&
6169 (last->op_private & OPpCONST_STRICT) &&
6170 (oa = first->op_sibling) && /* The fh. */
6171 (oa = oa->op_sibling) && /* The mode. */
6172 (oa->op_type == OP_CONST) &&
6173 SvPOK(((SVOP*)oa)->op_sv) &&
6174 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
6175 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
6176 (last == oa->op_sibling)) /* The bareword. */
6177 last->op_private &= ~OPpCONST_STRICT;
6183 Perl_ck_repeat(pTHX_ OP *o)
6185 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6186 o->op_private |= OPpREPEAT_DOLIST;
6187 cBINOPo->op_first = force_list(cBINOPo->op_first);
6195 Perl_ck_require(pTHX_ OP *o)
6200 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6201 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6203 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6204 SV * const sv = kid->op_sv;
6205 U32 was_readonly = SvREADONLY(sv);
6210 sv_force_normal_flags(sv, 0);
6211 assert(!SvREADONLY(sv));
6218 for (s = SvPVX(sv); *s; s++) {
6219 if (*s == ':' && s[1] == ':') {
6220 const STRLEN len = strlen(s+2)+1;
6222 Move(s+2, s+1, len, char);
6223 SvCUR_set(sv, SvCUR(sv) - 1);
6226 sv_catpvs(sv, ".pm");
6227 SvFLAGS(sv) |= was_readonly;
6231 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
6232 /* handle override, if any */
6233 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
6234 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
6235 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
6236 gv = gvp ? *gvp : NULL;
6240 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6241 OP * const kid = cUNOPo->op_first;
6242 cUNOPo->op_first = 0;
6244 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
6245 append_elem(OP_LIST, kid,
6246 scalar(newUNOP(OP_RV2CV, 0,
6255 Perl_ck_return(pTHX_ OP *o)
6258 if (CvLVALUE(PL_compcv)) {
6260 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6261 mod(kid, OP_LEAVESUBLV);
6267 Perl_ck_select(pTHX_ OP *o)
6271 if (o->op_flags & OPf_KIDS) {
6272 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6273 if (kid && kid->op_sibling) {
6274 o->op_type = OP_SSELECT;
6275 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6277 return fold_constants(o);
6281 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6282 if (kid && kid->op_type == OP_RV2GV)
6283 kid->op_private &= ~HINT_STRICT_REFS;
6288 Perl_ck_shift(pTHX_ OP *o)
6291 const I32 type = o->op_type;
6293 if (!(o->op_flags & OPf_KIDS)) {
6297 argop = newUNOP(OP_RV2AV, 0,
6298 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
6299 return newUNOP(type, 0, scalar(argop));
6301 return scalar(modkids(ck_fun(o), type));
6305 Perl_ck_sort(pTHX_ OP *o)
6310 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0)
6312 HV * const hinthv = GvHV(PL_hintgv);
6314 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
6316 const I32 sorthints = (I32)SvIV(*svp);
6317 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
6318 o->op_private |= OPpSORT_QSORT;
6319 if ((sorthints & HINT_SORT_STABLE) != 0)
6320 o->op_private |= OPpSORT_STABLE;
6325 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6327 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6328 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6330 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6332 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6334 if (kid->op_type == OP_SCOPE) {
6338 else if (kid->op_type == OP_LEAVE) {
6339 if (o->op_type == OP_SORT) {
6340 op_null(kid); /* wipe out leave */
6343 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6344 if (k->op_next == kid)
6346 /* don't descend into loops */
6347 else if (k->op_type == OP_ENTERLOOP
6348 || k->op_type == OP_ENTERITER)
6350 k = cLOOPx(k)->op_lastop;
6355 kid->op_next = 0; /* just disconnect the leave */
6356 k = kLISTOP->op_first;
6361 if (o->op_type == OP_SORT) {
6362 /* provide scalar context for comparison function/block */
6368 o->op_flags |= OPf_SPECIAL;
6370 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6373 firstkid = firstkid->op_sibling;
6376 /* provide list context for arguments */
6377 if (o->op_type == OP_SORT)
6384 S_simplify_sort(pTHX_ OP *o)
6387 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6392 if (!(o->op_flags & OPf_STACKED))
6394 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
6395 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
6396 kid = kUNOP->op_first; /* get past null */
6397 if (kid->op_type != OP_SCOPE)
6399 kid = kLISTOP->op_last; /* get past scope */
6400 switch(kid->op_type) {
6408 k = kid; /* remember this node*/
6409 if (kBINOP->op_first->op_type != OP_RV2SV)
6411 kid = kBINOP->op_first; /* get past cmp */
6412 if (kUNOP->op_first->op_type != OP_GV)
6414 kid = kUNOP->op_first; /* get past rv2sv */
6416 if (GvSTASH(gv) != PL_curstash)
6418 gvname = GvNAME(gv);
6419 if (*gvname == 'a' && gvname[1] == '\0')
6421 else if (*gvname == 'b' && gvname[1] == '\0')
6426 kid = k; /* back to cmp */
6427 if (kBINOP->op_last->op_type != OP_RV2SV)
6429 kid = kBINOP->op_last; /* down to 2nd arg */
6430 if (kUNOP->op_first->op_type != OP_GV)
6432 kid = kUNOP->op_first; /* get past rv2sv */
6434 if (GvSTASH(gv) != PL_curstash)
6436 gvname = GvNAME(gv);
6438 ? !(*gvname == 'a' && gvname[1] == '\0')
6439 : !(*gvname == 'b' && gvname[1] == '\0'))
6441 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6443 o->op_private |= OPpSORT_DESCEND;
6444 if (k->op_type == OP_NCMP)
6445 o->op_private |= OPpSORT_NUMERIC;
6446 if (k->op_type == OP_I_NCMP)
6447 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6448 kid = cLISTOPo->op_first->op_sibling;
6449 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6450 op_free(kid); /* then delete it */
6454 Perl_ck_split(pTHX_ OP *o)
6459 if (o->op_flags & OPf_STACKED)
6460 return no_fh_allowed(o);
6462 kid = cLISTOPo->op_first;
6463 if (kid->op_type != OP_NULL)
6464 Perl_croak(aTHX_ "panic: ck_split");
6465 kid = kid->op_sibling;
6466 op_free(cLISTOPo->op_first);
6467 cLISTOPo->op_first = kid;
6469 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
6470 cLISTOPo->op_last = kid; /* There was only one element previously */
6473 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6474 OP * const sibl = kid->op_sibling;
6475 kid->op_sibling = 0;
6476 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
6477 if (cLISTOPo->op_first == cLISTOPo->op_last)
6478 cLISTOPo->op_last = kid;
6479 cLISTOPo->op_first = kid;
6480 kid->op_sibling = sibl;
6483 kid->op_type = OP_PUSHRE;
6484 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6486 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
6487 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
6488 "Use of /g modifier is meaningless in split");
6491 if (!kid->op_sibling)
6492 append_elem(OP_SPLIT, o, newDEFSVOP());
6494 kid = kid->op_sibling;
6497 if (!kid->op_sibling)
6498 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6500 kid = kid->op_sibling;
6503 if (kid->op_sibling)
6504 return too_many_arguments(o,OP_DESC(o));
6510 Perl_ck_join(pTHX_ OP *o)
6512 const OP * const kid = cLISTOPo->op_first->op_sibling;
6513 if (kid && kid->op_type == OP_MATCH) {
6514 if (ckWARN(WARN_SYNTAX)) {
6515 const REGEXP *re = PM_GETRE(kPMOP);
6516 const char *pmstr = re ? re->precomp : "STRING";
6517 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6518 "/%s/ should probably be written as \"%s\"",
6526 Perl_ck_subr(pTHX_ OP *o)
6529 OP *prev = ((cUNOPo->op_first->op_sibling)
6530 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6531 OP *o2 = prev->op_sibling;
6538 I32 contextclass = 0;
6542 o->op_private |= OPpENTERSUB_HASTARG;
6543 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6544 if (cvop->op_type == OP_RV2CV) {
6546 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6547 op_null(cvop); /* disable rv2cv */
6548 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6549 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6550 GV *gv = cGVOPx_gv(tmpop);
6553 tmpop->op_private |= OPpEARLY_CV;
6556 namegv = CvANON(cv) ? gv : CvGV(cv);
6557 proto = SvPV_nolen((SV*)cv);
6559 if (CvASSERTION(cv)) {
6560 if (PL_hints & HINT_ASSERTING) {
6561 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
6562 o->op_private |= OPpENTERSUB_DB;
6566 if (!(PL_hints & HINT_ASSERTIONSSEEN) && ckWARN(WARN_ASSERTIONS)) {
6567 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
6568 "Impossible to activate assertion call");
6575 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6576 if (o2->op_type == OP_CONST)
6577 o2->op_private &= ~OPpCONST_STRICT;
6578 else if (o2->op_type == OP_LIST) {
6579 OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
6580 if (sib && sib->op_type == OP_CONST)
6581 sib->op_private &= ~OPpCONST_STRICT;
6584 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6585 if (PERLDB_SUB && PL_curstash != PL_debstash)
6586 o->op_private |= OPpENTERSUB_DB;
6587 while (o2 != cvop) {
6591 return too_many_arguments(o, gv_ename(namegv));
6609 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6611 arg == 1 ? "block or sub {}" : "sub {}",
6612 gv_ename(namegv), o2);
6615 /* '*' allows any scalar type, including bareword */
6618 if (o2->op_type == OP_RV2GV)
6619 goto wrapref; /* autoconvert GLOB -> GLOBref */
6620 else if (o2->op_type == OP_CONST)
6621 o2->op_private &= ~OPpCONST_STRICT;
6622 else if (o2->op_type == OP_ENTERSUB) {
6623 /* accidental subroutine, revert to bareword */
6624 OP *gvop = ((UNOP*)o2)->op_first;
6625 if (gvop && gvop->op_type == OP_NULL) {
6626 gvop = ((UNOP*)gvop)->op_first;
6628 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6631 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6632 (gvop = ((UNOP*)gvop)->op_first) &&
6633 gvop->op_type == OP_GV)
6635 GV * const gv = cGVOPx_gv(gvop);
6636 OP * const sibling = o2->op_sibling;
6637 SV * const n = newSVpvs("");
6639 gv_fullname4(n, gv, "", FALSE);
6640 o2 = newSVOP(OP_CONST, 0, n);
6641 prev->op_sibling = o2;
6642 o2->op_sibling = sibling;
6658 if (contextclass++ == 0) {
6659 e = strchr(proto, ']');
6660 if (!e || e == proto)
6669 /* XXX We shouldn't be modifying proto, so we can const proto */
6674 while (*--p != '[');
6675 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
6676 gv_ename(namegv), o2);
6682 if (o2->op_type == OP_RV2GV)
6685 bad_type(arg, "symbol", gv_ename(namegv), o2);
6688 if (o2->op_type == OP_ENTERSUB)
6691 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6694 if (o2->op_type == OP_RV2SV ||
6695 o2->op_type == OP_PADSV ||
6696 o2->op_type == OP_HELEM ||
6697 o2->op_type == OP_AELEM ||
6698 o2->op_type == OP_THREADSV)
6701 bad_type(arg, "scalar", gv_ename(namegv), o2);
6704 if (o2->op_type == OP_RV2AV ||
6705 o2->op_type == OP_PADAV)
6708 bad_type(arg, "array", gv_ename(namegv), o2);
6711 if (o2->op_type == OP_RV2HV ||
6712 o2->op_type == OP_PADHV)
6715 bad_type(arg, "hash", gv_ename(namegv), o2);
6720 OP* const sib = kid->op_sibling;
6721 kid->op_sibling = 0;
6722 o2 = newUNOP(OP_REFGEN, 0, kid);
6723 o2->op_sibling = sib;
6724 prev->op_sibling = o2;
6726 if (contextclass && e) {
6741 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
6742 gv_ename(namegv), cv);
6747 mod(o2, OP_ENTERSUB);
6749 o2 = o2->op_sibling;
6751 if (proto && !optional &&
6752 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6753 return too_few_arguments(o, gv_ename(namegv));
6756 o=newSVOP(OP_CONST, 0, newSViv(0));
6762 Perl_ck_svconst(pTHX_ OP *o)
6764 SvREADONLY_on(cSVOPo->op_sv);
6769 Perl_ck_chdir(pTHX_ OP *o)
6771 if (o->op_flags & OPf_KIDS) {
6772 SVOP *kid = (SVOP*)cUNOPo->op_first;
6774 if (kid && kid->op_type == OP_CONST &&
6775 (kid->op_private & OPpCONST_BARE))
6777 o->op_flags |= OPf_SPECIAL;
6778 kid->op_private &= ~OPpCONST_STRICT;
6785 Perl_ck_trunc(pTHX_ OP *o)
6787 if (o->op_flags & OPf_KIDS) {
6788 SVOP *kid = (SVOP*)cUNOPo->op_first;
6790 if (kid->op_type == OP_NULL)
6791 kid = (SVOP*)kid->op_sibling;
6792 if (kid && kid->op_type == OP_CONST &&
6793 (kid->op_private & OPpCONST_BARE))
6795 o->op_flags |= OPf_SPECIAL;
6796 kid->op_private &= ~OPpCONST_STRICT;
6803 Perl_ck_unpack(pTHX_ OP *o)
6805 OP *kid = cLISTOPo->op_first;
6806 if (kid->op_sibling) {
6807 kid = kid->op_sibling;
6808 if (!kid->op_sibling)
6809 kid->op_sibling = newDEFSVOP();
6815 Perl_ck_substr(pTHX_ OP *o)
6818 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6819 OP *kid = cLISTOPo->op_first;
6821 if (kid->op_type == OP_NULL)
6822 kid = kid->op_sibling;
6824 kid->op_flags |= OPf_MOD;
6830 /* A peephole optimizer. We visit the ops in the order they're to execute.
6831 * See the comments at the top of this file for more details about when
6832 * peep() is called */
6835 Perl_peep(pTHX_ register OP *o)
6838 register OP* oldop = NULL;
6840 if (!o || o->op_opt)
6844 SAVEVPTR(PL_curcop);
6845 for (; o; o = o->op_next) {
6849 switch (o->op_type) {
6853 PL_curcop = ((COP*)o); /* for warnings */
6858 if (cSVOPo->op_private & OPpCONST_STRICT)
6859 no_bareword_allowed(o);
6861 case OP_METHOD_NAMED:
6862 /* Relocate sv to the pad for thread safety.
6863 * Despite being a "constant", the SV is written to,
6864 * for reference counts, sv_upgrade() etc. */
6866 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6867 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6868 /* If op_sv is already a PADTMP then it is being used by
6869 * some pad, so make a copy. */
6870 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6871 SvREADONLY_on(PAD_SVl(ix));
6872 SvREFCNT_dec(cSVOPo->op_sv);
6874 else if (o->op_type == OP_CONST
6875 && cSVOPo->op_sv == &PL_sv_undef) {
6876 /* PL_sv_undef is hack - it's unsafe to store it in the
6877 AV that is the pad, because av_fetch treats values of
6878 PL_sv_undef as a "free" AV entry and will merrily
6879 replace them with a new SV, causing pad_alloc to think
6880 that this pad slot is free. (When, clearly, it is not)
6882 SvOK_off(PAD_SVl(ix));
6883 SvPADTMP_on(PAD_SVl(ix));
6884 SvREADONLY_on(PAD_SVl(ix));
6887 SvREFCNT_dec(PAD_SVl(ix));
6888 SvPADTMP_on(cSVOPo->op_sv);
6889 PAD_SETSV(ix, cSVOPo->op_sv);
6890 /* XXX I don't know how this isn't readonly already. */
6891 SvREADONLY_on(PAD_SVl(ix));
6893 cSVOPo->op_sv = NULL;
6901 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6902 if (o->op_next->op_private & OPpTARGET_MY) {
6903 if (o->op_flags & OPf_STACKED) /* chained concats */
6904 goto ignore_optimization;
6906 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6907 o->op_targ = o->op_next->op_targ;
6908 o->op_next->op_targ = 0;
6909 o->op_private |= OPpTARGET_MY;
6912 op_null(o->op_next);
6914 ignore_optimization:
6918 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6920 break; /* Scalar stub must produce undef. List stub is noop */
6924 if (o->op_targ == OP_NEXTSTATE
6925 || o->op_targ == OP_DBSTATE
6926 || o->op_targ == OP_SETSTATE)
6928 PL_curcop = ((COP*)o);
6930 /* XXX: We avoid setting op_seq here to prevent later calls
6931 to peep() from mistakenly concluding that optimisation
6932 has already occurred. This doesn't fix the real problem,
6933 though (See 20010220.007). AMS 20010719 */
6934 /* op_seq functionality is now replaced by op_opt */
6935 if (oldop && o->op_next) {
6936 oldop->op_next = o->op_next;
6944 if (oldop && o->op_next) {
6945 oldop->op_next = o->op_next;
6953 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
6954 OP* const pop = (o->op_type == OP_PADAV) ?
6955 o->op_next : o->op_next->op_next;
6957 if (pop && pop->op_type == OP_CONST &&
6958 ((PL_op = pop->op_next)) &&
6959 pop->op_next->op_type == OP_AELEM &&
6960 !(pop->op_next->op_private &
6961 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6962 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6967 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
6968 no_bareword_allowed(pop);
6969 if (o->op_type == OP_GV)
6970 op_null(o->op_next);
6971 op_null(pop->op_next);
6973 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6974 o->op_next = pop->op_next->op_next;
6975 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6976 o->op_private = (U8)i;
6977 if (o->op_type == OP_GV) {
6982 o->op_flags |= OPf_SPECIAL;
6983 o->op_type = OP_AELEMFAST;
6989 if (o->op_next->op_type == OP_RV2SV) {
6990 if (!(o->op_next->op_private & OPpDEREF)) {
6991 op_null(o->op_next);
6992 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6994 o->op_next = o->op_next->op_next;
6995 o->op_type = OP_GVSV;
6996 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6999 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
7000 GV * const gv = cGVOPo_gv;
7001 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
7002 /* XXX could check prototype here instead of just carping */
7003 SV * const sv = sv_newmortal();
7004 gv_efullname3(sv, gv, NULL);
7005 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
7006 "%"SVf"() called too early to check prototype",
7010 else if (o->op_next->op_type == OP_READLINE
7011 && o->op_next->op_next->op_type == OP_CONCAT
7012 && (o->op_next->op_next->op_flags & OPf_STACKED))
7014 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
7015 o->op_type = OP_RCATLINE;
7016 o->op_flags |= OPf_STACKED;
7017 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
7018 op_null(o->op_next->op_next);
7019 op_null(o->op_next);
7036 while (cLOGOP->op_other->op_type == OP_NULL)
7037 cLOGOP->op_other = cLOGOP->op_other->op_next;
7038 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
7044 while (cLOOP->op_redoop->op_type == OP_NULL)
7045 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
7046 peep(cLOOP->op_redoop);
7047 while (cLOOP->op_nextop->op_type == OP_NULL)
7048 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
7049 peep(cLOOP->op_nextop);
7050 while (cLOOP->op_lastop->op_type == OP_NULL)
7051 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
7052 peep(cLOOP->op_lastop);
7059 while (cPMOP->op_pmreplstart &&
7060 cPMOP->op_pmreplstart->op_type == OP_NULL)
7061 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
7062 peep(cPMOP->op_pmreplstart);
7067 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
7068 && ckWARN(WARN_SYNTAX))
7070 if (o->op_next->op_sibling &&
7071 o->op_next->op_sibling->op_type != OP_EXIT &&
7072 o->op_next->op_sibling->op_type != OP_WARN &&
7073 o->op_next->op_sibling->op_type != OP_DIE) {
7074 const line_t oldline = CopLINE(PL_curcop);
7076 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
7077 Perl_warner(aTHX_ packWARN(WARN_EXEC),
7078 "Statement unlikely to be reached");
7079 Perl_warner(aTHX_ packWARN(WARN_EXEC),
7080 "\t(Maybe you meant system() when you said exec()?)\n");
7081 CopLINE_set(PL_curcop, oldline);
7091 const char *key = NULL;
7096 if (((BINOP*)o)->op_last->op_type != OP_CONST)
7099 /* Make the CONST have a shared SV */
7100 svp = cSVOPx_svp(((BINOP*)o)->op_last);
7101 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
7102 key = SvPV_const(sv, keylen);
7103 lexname = newSVpvn_share(key,
7104 SvUTF8(sv) ? -(I32)keylen : keylen,
7110 if ((o->op_private & (OPpLVAL_INTRO)))
7113 rop = (UNOP*)((BINOP*)o)->op_first;
7114 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7116 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7117 if (!(SvFLAGS(lexname) & SVpad_TYPED))
7119 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
7120 if (!fields || !GvHV(*fields))
7122 key = SvPV_const(*svp, keylen);
7123 if (!hv_fetch(GvHV(*fields), key,
7124 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
7126 Perl_croak(aTHX_ "No such class field \"%s\" "
7127 "in variable %s of type %s",
7128 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
7141 SVOP *first_key_op, *key_op;
7143 if ((o->op_private & (OPpLVAL_INTRO))
7144 /* I bet there's always a pushmark... */
7145 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
7146 /* hmmm, no optimization if list contains only one key. */
7148 rop = (UNOP*)((LISTOP*)o)->op_last;
7149 if (rop->op_type != OP_RV2HV)
7151 if (rop->op_first->op_type == OP_PADSV)
7152 /* @$hash{qw(keys here)} */
7153 rop = (UNOP*)rop->op_first;
7155 /* @{$hash}{qw(keys here)} */
7156 if (rop->op_first->op_type == OP_SCOPE
7157 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
7159 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
7165 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
7166 if (!(SvFLAGS(lexname) & SVpad_TYPED))
7168 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
7169 if (!fields || !GvHV(*fields))
7171 /* Again guessing that the pushmark can be jumped over.... */
7172 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
7173 ->op_first->op_sibling;
7174 for (key_op = first_key_op; key_op;
7175 key_op = (SVOP*)key_op->op_sibling) {
7176 if (key_op->op_type != OP_CONST)
7178 svp = cSVOPx_svp(key_op);
7179 key = SvPV_const(*svp, keylen);
7180 if (!hv_fetch(GvHV(*fields), key,
7181 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
7183 Perl_croak(aTHX_ "No such class field \"%s\" "
7184 "in variable %s of type %s",
7185 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
7192 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
7196 /* check that RHS of sort is a single plain array */
7197 OP *oright = cUNOPo->op_first;
7198 if (!oright || oright->op_type != OP_PUSHMARK)
7201 /* reverse sort ... can be optimised. */
7202 if (!cUNOPo->op_sibling) {
7203 /* Nothing follows us on the list. */
7204 OP * const reverse = o->op_next;
7206 if (reverse->op_type == OP_REVERSE &&
7207 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
7208 OP * const pushmark = cUNOPx(reverse)->op_first;
7209 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
7210 && (cUNOPx(pushmark)->op_sibling == o)) {
7211 /* reverse -> pushmark -> sort */
7212 o->op_private |= OPpSORT_REVERSE;
7214 pushmark->op_next = oright->op_next;
7220 /* make @a = sort @a act in-place */
7224 oright = cUNOPx(oright)->op_sibling;
7227 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
7228 oright = cUNOPx(oright)->op_sibling;
7232 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
7233 || oright->op_next != o
7234 || (oright->op_private & OPpLVAL_INTRO)
7238 /* o2 follows the chain of op_nexts through the LHS of the
7239 * assign (if any) to the aassign op itself */
7241 if (!o2 || o2->op_type != OP_NULL)
7244 if (!o2 || o2->op_type != OP_PUSHMARK)
7247 if (o2 && o2->op_type == OP_GV)
7250 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
7251 || (o2->op_private & OPpLVAL_INTRO)
7256 if (!o2 || o2->op_type != OP_NULL)
7259 if (!o2 || o2->op_type != OP_AASSIGN
7260 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
7263 /* check that the sort is the first arg on RHS of assign */
7265 o2 = cUNOPx(o2)->op_first;
7266 if (!o2 || o2->op_type != OP_NULL)
7268 o2 = cUNOPx(o2)->op_first;
7269 if (!o2 || o2->op_type != OP_PUSHMARK)
7271 if (o2->op_sibling != o)
7274 /* check the array is the same on both sides */
7275 if (oleft->op_type == OP_RV2AV) {
7276 if (oright->op_type != OP_RV2AV
7277 || !cUNOPx(oright)->op_first
7278 || cUNOPx(oright)->op_first->op_type != OP_GV
7279 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
7280 cGVOPx_gv(cUNOPx(oright)->op_first)
7284 else if (oright->op_type != OP_PADAV
7285 || oright->op_targ != oleft->op_targ
7289 /* transfer MODishness etc from LHS arg to RHS arg */
7290 oright->op_flags = oleft->op_flags;
7291 o->op_private |= OPpSORT_INPLACE;
7293 /* excise push->gv->rv2av->null->aassign */
7294 o2 = o->op_next->op_next;
7295 op_null(o2); /* PUSHMARK */
7297 if (o2->op_type == OP_GV) {
7298 op_null(o2); /* GV */
7301 op_null(o2); /* RV2AV or PADAV */
7302 o2 = o2->op_next->op_next;
7303 op_null(o2); /* AASSIGN */
7305 o->op_next = o2->op_next;
7311 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
7313 LISTOP *enter, *exlist;
7316 enter = (LISTOP *) o->op_next;
7319 if (enter->op_type == OP_NULL) {
7320 enter = (LISTOP *) enter->op_next;
7324 /* for $a (...) will have OP_GV then OP_RV2GV here.
7325 for (...) just has an OP_GV. */
7326 if (enter->op_type == OP_GV) {
7327 gvop = (OP *) enter;
7328 enter = (LISTOP *) enter->op_next;
7331 if (enter->op_type == OP_RV2GV) {
7332 enter = (LISTOP *) enter->op_next;
7338 if (enter->op_type != OP_ENTERITER)
7341 iter = enter->op_next;
7342 if (!iter || iter->op_type != OP_ITER)
7345 expushmark = enter->op_first;
7346 if (!expushmark || expushmark->op_type != OP_NULL
7347 || expushmark->op_targ != OP_PUSHMARK)
7350 exlist = (LISTOP *) expushmark->op_sibling;
7351 if (!exlist || exlist->op_type != OP_NULL
7352 || exlist->op_targ != OP_LIST)
7355 if (exlist->op_last != o) {
7356 /* Mmm. Was expecting to point back to this op. */
7359 theirmark = exlist->op_first;
7360 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
7363 if (theirmark->op_sibling != o) {
7364 /* There's something between the mark and the reverse, eg
7365 for (1, reverse (...))
7370 ourmark = ((LISTOP *)o)->op_first;
7371 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
7374 ourlast = ((LISTOP *)o)->op_last;
7375 if (!ourlast || ourlast->op_next != o)
7378 rv2av = ourmark->op_sibling;
7379 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
7380 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
7381 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
7382 /* We're just reversing a single array. */
7383 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
7384 enter->op_flags |= OPf_STACKED;
7387 /* We don't have control over who points to theirmark, so sacrifice
7389 theirmark->op_next = ourmark->op_next;
7390 theirmark->op_flags = ourmark->op_flags;
7391 ourlast->op_next = gvop ? gvop : (OP *) enter;
7394 enter->op_private |= OPpITER_REVERSED;
7395 iter->op_private |= OPpITER_REVERSED;
7402 UNOP *refgen, *rv2cv;
7405 /* I do not understand this, but if o->op_opt isn't set to 1,
7406 various tests in ext/B/t/bytecode.t fail with no readily
7412 if ((o->op_flags && OPf_WANT) != OPf_WANT_VOID)
7415 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
7418 rv2gv = ((BINOP *)o)->op_last;
7419 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
7422 refgen = (UNOP *)((BINOP *)o)->op_first;
7424 if (!refgen || refgen->op_type != OP_REFGEN)
7427 exlist = (LISTOP *)refgen->op_first;
7428 if (!exlist || exlist->op_type != OP_NULL
7429 || exlist->op_targ != OP_LIST)
7432 if (exlist->op_first->op_type != OP_PUSHMARK)
7435 rv2cv = (UNOP*)exlist->op_last;
7437 if (rv2cv->op_type != OP_RV2CV)
7440 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
7441 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
7442 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
7444 o->op_private |= OPpASSIGN_CV_TO_GV;
7445 rv2gv->op_private |= OPpDONT_INIT_GV;
7446 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
7462 Perl_custom_op_name(pTHX_ const OP* o)
7465 const IV index = PTR2IV(o->op_ppaddr);
7469 if (!PL_custom_op_names) /* This probably shouldn't happen */
7470 return (char *)PL_op_name[OP_CUSTOM];
7472 keysv = sv_2mortal(newSViv(index));
7474 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
7476 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
7478 return SvPV_nolen(HeVAL(he));
7482 Perl_custom_op_desc(pTHX_ const OP* o)
7485 const IV index = PTR2IV(o->op_ppaddr);
7489 if (!PL_custom_op_descs)
7490 return (char *)PL_op_desc[OP_CUSTOM];
7492 keysv = sv_2mortal(newSViv(index));
7494 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
7496 return (char *)PL_op_desc[OP_CUSTOM];
7498 return SvPV_nolen(HeVAL(he));
7503 /* Efficient sub that returns a constant scalar value. */
7505 const_sv_xsub(pTHX_ CV* cv)
7511 Perl_croak(aTHX_ "usage: %s::%s()",
7512 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7516 ST(0) = (SV*)XSANY.any_ptr;
7522 * c-indentation-style: bsd
7524 * indent-tabs-mode: t
7527 * ex: set ts=8 sts=4 sw=4 noet: