3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * "You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
13 * our Mr. Bilbo's first cousin on the mother's side (her mother being the
14 * youngest of the Old Took's daughters); and Mr. Drogo was his second
15 * cousin. So Mr. Frodo is his first *and* second cousin, once removed
16 * either way, as the saying is, if you follow me." --the Gaffer
19 /* This file contains the functions that create, manipulate and optimize
20 * the OP structures that hold a compiled perl program.
22 * A Perl program is compiled into a tree of OPs. Each op contains
23 * structural pointers (eg to its siblings and the next op in the
24 * execution sequence), a pointer to the function that would execute the
25 * op, plus any data specific to that op. For example, an OP_CONST op
26 * points to the pp_const() function and to an SV containing the constant
27 * value. When pp_const() is executed, its job is to push that SV onto the
30 * OPs are mainly created by the newFOO() functions, which are mainly
31 * called from the parser (in perly.y) as the code is parsed. For example
32 * the Perl code $a + $b * $c would cause the equivalent of the following
33 * to be called (oversimplifying a bit):
35 * newBINOP(OP_ADD, flags,
37 * newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
40 * Note that during the build of miniperl, a temporary copy of this file
41 * is made, called opmini.c.
45 Perl's compiler is essentially a 3-pass compiler with interleaved phases:
49 An execution-order pass
51 The bottom-up pass is represented by all the "newOP" routines and
52 the ck_ routines. The bottom-upness is actually driven by yacc.
53 So at the point that a ck_ routine fires, we have no idea what the
54 context is, either upward in the syntax tree, or either forward or
55 backward in the execution order. (The bottom-up parser builds that
56 part of the execution order it knows about, but if you follow the "next"
57 links around, you'll find it's actually a closed loop through the
60 Whenever the bottom-up parser gets to a node that supplies context to
61 its components, it invokes that portion of the top-down pass that applies
62 to that part of the subtree (and marks the top node as processed, so
63 if a node further up supplies context, it doesn't have to take the
64 plunge again). As a particular subcase of this, as the new node is
65 built, it takes all the closed execution loops of its subcomponents
66 and links them into a new closed loop for the higher level node. But
67 it's still not the real execution order.
69 The actual execution order is not known till we get a grammar reduction
70 to a top-level unit like a subroutine or file that will be called by
71 "name" rather than via a "next" pointer. At that point, we can call
72 into peep() to do that code's portion of the 3rd pass. It has to be
73 recursive, but it's recursive on basic blocks, not on tree nodes.
81 #define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
83 #if defined(PL_OP_SLAB_ALLOC)
85 #ifndef PERL_SLAB_SIZE
86 #define PERL_SLAB_SIZE 2048
90 Perl_Slab_Alloc(pTHX_ int m, size_t sz)
93 * To make incrementing use count easy PL_OpSlab is an I32 *
94 * To make inserting the link to slab PL_OpPtr is I32 **
95 * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
96 * Add an overhead for pointer to slab and round up as a number of pointers
98 sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
99 if ((PL_OpSpace -= sz) < 0) {
100 PL_OpPtr = (I32 **) PerlMemShared_malloc(PERL_SLAB_SIZE*sizeof(I32*));
104 Zero(PL_OpPtr,PERL_SLAB_SIZE,I32 **);
105 /* We reserve the 0'th I32 sized chunk as a use count */
106 PL_OpSlab = (I32 *) PL_OpPtr;
107 /* Reduce size by the use count word, and by the size we need.
108 * Latter is to mimic the '-=' in the if() above
110 PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
111 /* Allocation pointer starts at the top.
112 Theory: because we build leaves before trunk allocating at end
113 means that at run time access is cache friendly upward
115 PL_OpPtr += PERL_SLAB_SIZE;
117 assert( PL_OpSpace >= 0 );
118 /* Move the allocation pointer down */
120 assert( PL_OpPtr > (I32 **) PL_OpSlab );
121 *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */
122 (*PL_OpSlab)++; /* Increment use count of slab */
123 assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
124 assert( *PL_OpSlab > 0 );
125 return (void *)(PL_OpPtr + 1);
129 Perl_Slab_Free(pTHX_ void *op)
131 I32 * const * const ptr = (I32 **) op;
132 I32 * const slab = ptr[-1];
133 assert( ptr-1 > (I32 **) slab );
134 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
136 if (--(*slab) == 0) {
138 # define PerlMemShared PerlMem
141 PerlMemShared_free(slab);
142 if (slab == PL_OpSlab) {
149 * In the following definition, the ", (OP*)0" is just to make the compiler
150 * think the expression is of the right type: croak actually does a Siglongjmp.
152 #define CHECKOP(type,o) \
153 ((PL_op_mask && PL_op_mask[type]) \
154 ? ( op_free((OP*)o), \
155 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
157 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
159 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
162 S_gv_ename(pTHX_ GV *gv)
164 SV* const tmpsv = sv_newmortal();
165 gv_efullname3(tmpsv, gv, NULL);
166 return SvPV_nolen_const(tmpsv);
170 S_no_fh_allowed(pTHX_ OP *o)
172 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
178 S_too_few_arguments(pTHX_ OP *o, const char *name)
180 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
185 S_too_many_arguments(pTHX_ OP *o, const char *name)
187 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
192 S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid)
194 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
195 (int)n, name, t, OP_DESC(kid)));
199 S_no_bareword_allowed(pTHX_ const OP *o)
201 qerror(Perl_mess(aTHX_
202 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
206 /* "register" allocation */
209 Perl_allocmy(pTHX_ char *name)
213 const bool is_our = (PL_in_my == KEY_our);
215 /* complain about "my $<special_var>" etc etc */
219 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
220 (name[1] == '_' && (*name == '$' || name[2]))))
222 /* name[2] is true if strlen(name) > 2 */
223 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
224 /* 1999-02-27 mjd@plover.com */
226 p = strchr(name, '\0');
227 /* The next block assumes the buffer is at least 205 chars
228 long. At present, it's always at least 256 chars. */
230 strcpy(name+200, "...");
236 /* Move everything else down one character */
237 for (; p-name > 2; p--)
239 name[2] = toCTRL(name[1]);
242 yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
245 /* check for duplicate declaration */
246 pad_check_dup(name, is_our, (PL_curstash ? PL_curstash : PL_defstash));
248 if (PL_in_my_stash && *name != '$') {
249 yyerror(Perl_form(aTHX_
250 "Can't declare class for non-scalar %s in \"%s\"",
251 name, is_our ? "our" : "my"));
254 /* allocate a spare slot and store the name in that slot */
256 off = pad_add_name(name,
259 /* $_ is always in main::, even with our */
260 ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
271 Perl_op_free(pTHX_ OP *o)
276 if (!o || o->op_static)
280 if (o->op_private & OPpREFCOUNTED) {
291 refcnt = OpREFCNT_dec(o);
302 if (o->op_flags & OPf_KIDS) {
303 register OP *kid, *nextkid;
304 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
305 nextkid = kid->op_sibling; /* Get before next freeing kid */
310 type = (OPCODE)o->op_targ;
312 /* COP* is not cleared by op_clear() so that we may track line
313 * numbers etc even after null() */
314 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
319 #ifdef DEBUG_LEAKING_SCALARS
326 Perl_op_clear(pTHX_ OP *o)
330 switch (o->op_type) {
331 case OP_NULL: /* Was holding old type, if any. */
332 case OP_ENTEREVAL: /* Was holding hints. */
336 if (!(o->op_flags & OPf_REF)
337 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
343 if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
344 /* not an OP_PADAV replacement */
346 if (cPADOPo->op_padix > 0) {
347 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
348 * may still exist on the pad */
349 pad_swipe(cPADOPo->op_padix, TRUE);
350 cPADOPo->op_padix = 0;
353 SvREFCNT_dec(cSVOPo->op_sv);
354 cSVOPo->op_sv = NULL;
358 case OP_METHOD_NAMED:
360 SvREFCNT_dec(cSVOPo->op_sv);
361 cSVOPo->op_sv = NULL;
364 Even if op_clear does a pad_free for the target of the op,
365 pad_free doesn't actually remove the sv that exists in the pad;
366 instead it lives on. This results in that it could be reused as
367 a target later on when the pad was reallocated.
370 pad_swipe(o->op_targ,1);
379 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
383 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
384 SvREFCNT_dec(cSVOPo->op_sv);
385 cSVOPo->op_sv = NULL;
388 Safefree(cPVOPo->op_pv);
389 cPVOPo->op_pv = NULL;
393 op_free(cPMOPo->op_pmreplroot);
397 if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) {
398 /* No GvIN_PAD_off here, because other references may still
399 * exist on the pad */
400 pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot), TRUE);
403 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
410 HV * const pmstash = PmopSTASH(cPMOPo);
411 if (pmstash && !SvIS_FREED(pmstash)) {
412 MAGIC * const mg = mg_find((SV*)pmstash, PERL_MAGIC_symtab);
414 PMOP *pmop = (PMOP*) mg->mg_obj;
415 PMOP *lastpmop = NULL;
417 if (cPMOPo == pmop) {
419 lastpmop->op_pmnext = pmop->op_pmnext;
421 mg->mg_obj = (SV*) pmop->op_pmnext;
425 pmop = pmop->op_pmnext;
429 PmopSTASH_free(cPMOPo);
431 cPMOPo->op_pmreplroot = NULL;
432 /* we use the "SAFE" version of the PM_ macros here
433 * since sv_clean_all might release some PMOPs
434 * after PL_regex_padav has been cleared
435 * and the clearing of PL_regex_padav needs to
436 * happen before sv_clean_all
438 ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
439 PM_SETRE_SAFE(cPMOPo, NULL);
441 if(PL_regex_pad) { /* We could be in destruction */
442 av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
443 SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
444 PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
451 if (o->op_targ > 0) {
452 pad_free(o->op_targ);
458 S_cop_free(pTHX_ COP* cop)
460 Safefree(cop->cop_label); /* FIXME: treaddead ??? */
463 if (! specialWARN(cop->cop_warnings))
464 SvREFCNT_dec(cop->cop_warnings);
465 if (! specialCopIO(cop->cop_io)) {
469 SvREFCNT_dec(cop->cop_io);
475 Perl_op_null(pTHX_ OP *o)
478 if (o->op_type == OP_NULL)
481 o->op_targ = o->op_type;
482 o->op_type = OP_NULL;
483 o->op_ppaddr = PL_ppaddr[OP_NULL];
487 Perl_op_refcnt_lock(pTHX)
495 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_NN(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_NN(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 /*EMPTY*/; /* 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)
1799 PERL_UNUSED_CONTEXT;
1801 o->op_flags |= OPf_PARENS;
1806 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
1811 if ( (left->op_type == OP_RV2AV ||
1812 left->op_type == OP_RV2HV ||
1813 left->op_type == OP_PADAV ||
1814 left->op_type == OP_PADHV)
1815 && ckWARN(WARN_MISC))
1817 const char * const desc = PL_op_desc[(right->op_type == OP_SUBST ||
1818 right->op_type == OP_TRANS)
1819 ? right->op_type : OP_MATCH];
1820 const char * const sample = ((left->op_type == OP_RV2AV ||
1821 left->op_type == OP_PADAV)
1822 ? "@array" : "%hash");
1823 Perl_warner(aTHX_ packWARN(WARN_MISC),
1824 "Applying %s to %s will act on scalar(%s)",
1825 desc, sample, sample);
1828 if (right->op_type == OP_CONST &&
1829 cSVOPx(right)->op_private & OPpCONST_BARE &&
1830 cSVOPx(right)->op_private & OPpCONST_STRICT)
1832 no_bareword_allowed(right);
1835 ismatchop = right->op_type == OP_MATCH ||
1836 right->op_type == OP_SUBST ||
1837 right->op_type == OP_TRANS;
1838 if (ismatchop && right->op_private & OPpTARGET_MY) {
1840 right->op_private &= ~OPpTARGET_MY;
1842 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
1843 right->op_flags |= OPf_STACKED;
1844 if (right->op_type != OP_MATCH &&
1845 ! (right->op_type == OP_TRANS &&
1846 right->op_private & OPpTRANS_IDENTICAL))
1847 left = mod(left, right->op_type);
1848 if (right->op_type == OP_TRANS)
1849 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
1851 o = prepend_elem(right->op_type, scalar(left), right);
1853 return newUNOP(OP_NOT, 0, scalar(o));
1857 return bind_match(type, left,
1858 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
1862 Perl_invert(pTHX_ OP *o)
1866 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
1867 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
1871 Perl_scope(pTHX_ OP *o)
1875 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
1876 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
1877 o->op_type = OP_LEAVE;
1878 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
1880 else if (o->op_type == OP_LINESEQ) {
1882 o->op_type = OP_SCOPE;
1883 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
1884 kid = ((LISTOP*)o)->op_first;
1885 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
1888 /* The following deals with things like 'do {1 for 1}' */
1889 kid = kid->op_sibling;
1891 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
1896 o = newLISTOP(OP_SCOPE, 0, o, NULL);
1902 Perl_block_start(pTHX_ int full)
1905 const int retval = PL_savestack_ix;
1906 pad_block_start(full);
1908 PL_hints &= ~HINT_BLOCK_SCOPE;
1909 SAVESPTR(PL_compiling.cop_warnings);
1910 if (! specialWARN(PL_compiling.cop_warnings)) {
1911 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
1912 SAVEFREESV(PL_compiling.cop_warnings) ;
1914 SAVESPTR(PL_compiling.cop_io);
1915 if (! specialCopIO(PL_compiling.cop_io)) {
1916 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
1917 SAVEFREESV(PL_compiling.cop_io) ;
1923 Perl_block_end(pTHX_ I32 floor, OP *seq)
1926 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
1927 OP* const retval = scalarseq(seq);
1929 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
1931 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
1940 const I32 offset = pad_findmy("$_");
1941 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
1942 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
1945 OP * const o = newOP(OP_PADSV, 0);
1946 o->op_targ = offset;
1952 Perl_newPROG(pTHX_ OP *o)
1958 PL_eval_root = newUNOP(OP_LEAVEEVAL,
1959 ((PL_in_eval & EVAL_KEEPERR)
1960 ? OPf_SPECIAL : 0), o);
1961 PL_eval_start = linklist(PL_eval_root);
1962 PL_eval_root->op_private |= OPpREFCOUNTED;
1963 OpREFCNT_set(PL_eval_root, 1);
1964 PL_eval_root->op_next = 0;
1965 CALL_PEEP(PL_eval_start);
1968 if (o->op_type == OP_STUB) {
1969 PL_comppad_name = 0;
1974 PL_main_root = scope(sawparens(scalarvoid(o)));
1975 PL_curcop = &PL_compiling;
1976 PL_main_start = LINKLIST(PL_main_root);
1977 PL_main_root->op_private |= OPpREFCOUNTED;
1978 OpREFCNT_set(PL_main_root, 1);
1979 PL_main_root->op_next = 0;
1980 CALL_PEEP(PL_main_start);
1983 /* Register with debugger */
1985 CV * const cv = get_cv("DB::postponed", FALSE);
1989 XPUSHs((SV*)CopFILEGV(&PL_compiling));
1991 call_sv((SV*)cv, G_DISCARD);
1998 Perl_localize(pTHX_ OP *o, I32 lex)
2001 if (o->op_flags & OPf_PARENS)
2002 /* [perl #17376]: this appears to be premature, and results in code such as
2003 C< our(%x); > executing in list mode rather than void mode */
2010 if ( PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ','
2011 && ckWARN(WARN_PARENTHESIS))
2013 char *s = PL_bufptr;
2016 /* some heuristics to detect a potential error */
2017 while (*s && (strchr(", \t\n", *s)))
2021 if (*s && strchr("@$%*", *s) && *++s
2022 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2025 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2027 while (*s && (strchr(", \t\n", *s)))
2033 if (sigil && (*s == ';' || *s == '=')) {
2034 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2035 "Parentheses missing around \"%s\" list",
2036 lex ? (PL_in_my == KEY_our ? "our" : "my")
2044 o = mod(o, OP_NULL); /* a bit kludgey */
2046 PL_in_my_stash = NULL;
2051 Perl_jmaybe(pTHX_ OP *o)
2053 if (o->op_type == OP_LIST) {
2055 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL,
2057 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2063 Perl_fold_constants(pTHX_ register OP *o)
2067 I32 type = o->op_type;
2070 if (PL_opargs[type] & OA_RETSCALAR)
2072 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2073 o->op_targ = pad_alloc(type, SVs_PADTMP);
2075 /* integerize op, unless it happens to be C<-foo>.
2076 * XXX should pp_i_negate() do magic string negation instead? */
2077 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2078 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2079 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2081 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2084 if (!(PL_opargs[type] & OA_FOLDCONST))
2089 /* XXX might want a ck_negate() for this */
2090 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2101 /* XXX what about the numeric ops? */
2102 if (PL_hints & HINT_LOCALE)
2107 goto nope; /* Don't try to run w/ errors */
2109 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2110 if ((curop->op_type != OP_CONST ||
2111 (curop->op_private & OPpCONST_BARE)) &&
2112 curop->op_type != OP_LIST &&
2113 curop->op_type != OP_SCALAR &&
2114 curop->op_type != OP_NULL &&
2115 curop->op_type != OP_PUSHMARK)
2121 curop = LINKLIST(o);
2125 sv = *(PL_stack_sp--);
2126 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2127 pad_swipe(o->op_targ, FALSE);
2128 else if (SvTEMP(sv)) { /* grab mortal temp? */
2129 SvREFCNT_inc_simple_void(sv);
2133 if (type == OP_RV2GV)
2134 return newGVOP(OP_GV, 0, (GV*)sv);
2135 return newSVOP(OP_CONST, 0, sv);
2142 Perl_gen_constant_list(pTHX_ register OP *o)
2146 const I32 oldtmps_floor = PL_tmps_floor;
2150 return o; /* Don't attempt to run with errors */
2152 PL_op = curop = LINKLIST(o);
2159 PL_tmps_floor = oldtmps_floor;
2161 o->op_type = OP_RV2AV;
2162 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2163 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2164 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2165 o->op_opt = 0; /* needs to be revisited in peep() */
2166 curop = ((UNOP*)o)->op_first;
2167 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
2174 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2177 if (!o || o->op_type != OP_LIST)
2178 o = newLISTOP(OP_LIST, 0, o, NULL);
2180 o->op_flags &= ~OPf_WANT;
2182 if (!(PL_opargs[type] & OA_MARK))
2183 op_null(cLISTOPo->op_first);
2185 o->op_type = (OPCODE)type;
2186 o->op_ppaddr = PL_ppaddr[type];
2187 o->op_flags |= flags;
2189 o = CHECKOP(type, o);
2190 if (o->op_type != (unsigned)type)
2193 return fold_constants(o);
2196 /* List constructors */
2199 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2207 if (first->op_type != (unsigned)type
2208 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2210 return newLISTOP(type, 0, first, last);
2213 if (first->op_flags & OPf_KIDS)
2214 ((LISTOP*)first)->op_last->op_sibling = last;
2216 first->op_flags |= OPf_KIDS;
2217 ((LISTOP*)first)->op_first = last;
2219 ((LISTOP*)first)->op_last = last;
2224 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2232 if (first->op_type != (unsigned)type)
2233 return prepend_elem(type, (OP*)first, (OP*)last);
2235 if (last->op_type != (unsigned)type)
2236 return append_elem(type, (OP*)first, (OP*)last);
2238 first->op_last->op_sibling = last->op_first;
2239 first->op_last = last->op_last;
2240 first->op_flags |= (last->op_flags & OPf_KIDS);
2248 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2256 if (last->op_type == (unsigned)type) {
2257 if (type == OP_LIST) { /* already a PUSHMARK there */
2258 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2259 ((LISTOP*)last)->op_first->op_sibling = first;
2260 if (!(first->op_flags & OPf_PARENS))
2261 last->op_flags &= ~OPf_PARENS;
2264 if (!(last->op_flags & OPf_KIDS)) {
2265 ((LISTOP*)last)->op_last = first;
2266 last->op_flags |= OPf_KIDS;
2268 first->op_sibling = ((LISTOP*)last)->op_first;
2269 ((LISTOP*)last)->op_first = first;
2271 last->op_flags |= OPf_KIDS;
2275 return newLISTOP(type, 0, first, last);
2281 Perl_newNULLLIST(pTHX)
2283 return newOP(OP_STUB, 0);
2287 Perl_force_list(pTHX_ OP *o)
2289 if (!o || o->op_type != OP_LIST)
2290 o = newLISTOP(OP_LIST, 0, o, NULL);
2296 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2301 NewOp(1101, listop, 1, LISTOP);
2303 listop->op_type = (OPCODE)type;
2304 listop->op_ppaddr = PL_ppaddr[type];
2307 listop->op_flags = (U8)flags;
2311 else if (!first && last)
2314 first->op_sibling = last;
2315 listop->op_first = first;
2316 listop->op_last = last;
2317 if (type == OP_LIST) {
2318 OP* const pushop = newOP(OP_PUSHMARK, 0);
2319 pushop->op_sibling = first;
2320 listop->op_first = pushop;
2321 listop->op_flags |= OPf_KIDS;
2323 listop->op_last = pushop;
2326 return CHECKOP(type, listop);
2330 Perl_newOP(pTHX_ I32 type, I32 flags)
2334 NewOp(1101, o, 1, OP);
2335 o->op_type = (OPCODE)type;
2336 o->op_ppaddr = PL_ppaddr[type];
2337 o->op_flags = (U8)flags;
2340 o->op_private = (U8)(0 | (flags >> 8));
2341 if (PL_opargs[type] & OA_RETSCALAR)
2343 if (PL_opargs[type] & OA_TARGET)
2344 o->op_targ = pad_alloc(type, SVs_PADTMP);
2345 return CHECKOP(type, o);
2349 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2355 first = newOP(OP_STUB, 0);
2356 if (PL_opargs[type] & OA_MARK)
2357 first = force_list(first);
2359 NewOp(1101, unop, 1, UNOP);
2360 unop->op_type = (OPCODE)type;
2361 unop->op_ppaddr = PL_ppaddr[type];
2362 unop->op_first = first;
2363 unop->op_flags = (U8)(flags | OPf_KIDS);
2364 unop->op_private = (U8)(1 | (flags >> 8));
2365 unop = (UNOP*) CHECKOP(type, unop);
2369 return fold_constants((OP *) unop);
2373 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2377 NewOp(1101, binop, 1, BINOP);
2380 first = newOP(OP_NULL, 0);
2382 binop->op_type = (OPCODE)type;
2383 binop->op_ppaddr = PL_ppaddr[type];
2384 binop->op_first = first;
2385 binop->op_flags = (U8)(flags | OPf_KIDS);
2388 binop->op_private = (U8)(1 | (flags >> 8));
2391 binop->op_private = (U8)(2 | (flags >> 8));
2392 first->op_sibling = last;
2395 binop = (BINOP*)CHECKOP(type, binop);
2396 if (binop->op_next || binop->op_type != (OPCODE)type)
2399 binop->op_last = binop->op_first->op_sibling;
2401 return fold_constants((OP *)binop);
2404 static int uvcompare(const void *a, const void *b)
2405 __attribute__nonnull__(1)
2406 __attribute__nonnull__(2)
2407 __attribute__pure__;
2408 static int uvcompare(const void *a, const void *b)
2410 if (*((const UV *)a) < (*(const UV *)b))
2412 if (*((const UV *)a) > (*(const UV *)b))
2414 if (*((const UV *)a+1) < (*(const UV *)b+1))
2416 if (*((const UV *)a+1) > (*(const UV *)b+1))
2422 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2425 SV * const tstr = ((SVOP*)expr)->op_sv;
2426 SV * const rstr = ((SVOP*)repl)->op_sv;
2429 const U8 *t = (U8*)SvPV_const(tstr, tlen);
2430 const U8 *r = (U8*)SvPV_const(rstr, rlen);
2434 register short *tbl;
2436 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
2437 const I32 squash = o->op_private & OPpTRANS_SQUASH;
2438 I32 del = o->op_private & OPpTRANS_DELETE;
2439 PL_hints |= HINT_BLOCK_SCOPE;
2442 o->op_private |= OPpTRANS_FROM_UTF;
2445 o->op_private |= OPpTRANS_TO_UTF;
2447 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2448 SV* const listsv = newSVpvs("# comment\n");
2450 const U8* tend = t + tlen;
2451 const U8* rend = r + rlen;
2465 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2466 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2472 t = tsave = bytes_to_utf8(t, &len);
2475 if (!to_utf && rlen) {
2477 r = rsave = bytes_to_utf8(r, &len);
2481 /* There are several snags with this code on EBCDIC:
2482 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2483 2. scan_const() in toke.c has encoded chars in native encoding which makes
2484 ranges at least in EBCDIC 0..255 range the bottom odd.
2488 U8 tmpbuf[UTF8_MAXBYTES+1];
2491 Newx(cp, 2*tlen, UV);
2493 transv = newSVpvs("");
2495 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2497 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2499 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2503 cp[2*i+1] = cp[2*i];
2507 qsort(cp, i, 2*sizeof(UV), uvcompare);
2508 for (j = 0; j < i; j++) {
2510 diff = val - nextmin;
2512 t = uvuni_to_utf8(tmpbuf,nextmin);
2513 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2515 U8 range_mark = UTF_TO_NATIVE(0xff);
2516 t = uvuni_to_utf8(tmpbuf, val - 1);
2517 sv_catpvn(transv, (char *)&range_mark, 1);
2518 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2525 t = uvuni_to_utf8(tmpbuf,nextmin);
2526 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2528 U8 range_mark = UTF_TO_NATIVE(0xff);
2529 sv_catpvn(transv, (char *)&range_mark, 1);
2531 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2532 UNICODE_ALLOW_SUPER);
2533 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2534 t = (const U8*)SvPVX_const(transv);
2535 tlen = SvCUR(transv);
2539 else if (!rlen && !del) {
2540 r = t; rlen = tlen; rend = tend;
2543 if ((!rlen && !del) || t == r ||
2544 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2546 o->op_private |= OPpTRANS_IDENTICAL;
2550 while (t < tend || tfirst <= tlast) {
2551 /* see if we need more "t" chars */
2552 if (tfirst > tlast) {
2553 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2555 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2557 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2564 /* now see if we need more "r" chars */
2565 if (rfirst > rlast) {
2567 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2569 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2571 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2580 rfirst = rlast = 0xffffffff;
2584 /* now see which range will peter our first, if either. */
2585 tdiff = tlast - tfirst;
2586 rdiff = rlast - rfirst;
2593 if (rfirst == 0xffffffff) {
2594 diff = tdiff; /* oops, pretend rdiff is infinite */
2596 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2597 (long)tfirst, (long)tlast);
2599 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2603 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2604 (long)tfirst, (long)(tfirst + diff),
2607 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2608 (long)tfirst, (long)rfirst);
2610 if (rfirst + diff > max)
2611 max = rfirst + diff;
2613 grows = (tfirst < rfirst &&
2614 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2626 else if (max > 0xff)
2631 Safefree(cPVOPo->op_pv);
2632 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2633 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;
2651 tbl = (short*)cPVOPo->op_pv;
2653 Zero(tbl, 256, short);
2654 for (i = 0; i < (I32)tlen; i++)
2656 for (i = 0, j = 0; i < 256; i++) {
2658 if (j >= (I32)rlen) {
2667 if (i < 128 && r[j] >= 128)
2677 o->op_private |= OPpTRANS_IDENTICAL;
2679 else if (j >= (I32)rlen)
2682 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2683 tbl[0x100] = (short)(rlen - j);
2684 for (i=0; i < (I32)rlen - j; i++)
2685 tbl[0x101+i] = r[j+i];
2689 if (!rlen && !del) {
2692 o->op_private |= OPpTRANS_IDENTICAL;
2694 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
2695 o->op_private |= OPpTRANS_IDENTICAL;
2697 for (i = 0; i < 256; i++)
2699 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
2700 if (j >= (I32)rlen) {
2702 if (tbl[t[i]] == -1)
2708 if (tbl[t[i]] == -1) {
2709 if (t[i] < 128 && r[j] >= 128)
2716 o->op_private |= OPpTRANS_GROWS;
2724 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2729 NewOp(1101, pmop, 1, PMOP);
2730 pmop->op_type = (OPCODE)type;
2731 pmop->op_ppaddr = PL_ppaddr[type];
2732 pmop->op_flags = (U8)flags;
2733 pmop->op_private = (U8)(0 | (flags >> 8));
2735 if (PL_hints & HINT_RE_TAINT)
2736 pmop->op_pmpermflags |= PMf_RETAINT;
2737 if (PL_hints & HINT_LOCALE)
2738 pmop->op_pmpermflags |= PMf_LOCALE;
2739 pmop->op_pmflags = pmop->op_pmpermflags;
2742 if (av_len((AV*) PL_regex_pad[0]) > -1) {
2743 SV * const repointer = av_pop((AV*)PL_regex_pad[0]);
2744 pmop->op_pmoffset = SvIV(repointer);
2745 SvREPADTMP_off(repointer);
2746 sv_setiv(repointer,0);
2748 SV * const repointer = newSViv(0);
2749 av_push(PL_regex_padav, SvREFCNT_inc_simple_NN(repointer));
2750 pmop->op_pmoffset = av_len(PL_regex_padav);
2751 PL_regex_pad = AvARRAY(PL_regex_padav);
2755 /* link into pm list */
2756 if (type != OP_TRANS && PL_curstash) {
2757 MAGIC *mg = mg_find((SV*)PL_curstash, PERL_MAGIC_symtab);
2760 mg = sv_magicext((SV*)PL_curstash, 0, PERL_MAGIC_symtab, 0, 0, 0);
2762 pmop->op_pmnext = (PMOP*)mg->mg_obj;
2763 mg->mg_obj = (SV*)pmop;
2764 PmopSTASH_set(pmop,PL_curstash);
2767 return CHECKOP(type, pmop);
2770 /* Given some sort of match op o, and an expression expr containing a
2771 * pattern, either compile expr into a regex and attach it to o (if it's
2772 * constant), or convert expr into a runtime regcomp op sequence (if it's
2775 * isreg indicates that the pattern is part of a regex construct, eg
2776 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
2777 * split "pattern", which aren't. In the former case, expr will be a list
2778 * if the pattern contains more than one term (eg /a$b/) or if it contains
2779 * a replacement, ie s/// or tr///.
2783 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
2788 I32 repl_has_vars = 0;
2792 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
2793 /* last element in list is the replacement; pop it */
2795 repl = cLISTOPx(expr)->op_last;
2796 kid = cLISTOPx(expr)->op_first;
2797 while (kid->op_sibling != repl)
2798 kid = kid->op_sibling;
2799 kid->op_sibling = NULL;
2800 cLISTOPx(expr)->op_last = kid;
2803 if (isreg && expr->op_type == OP_LIST &&
2804 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
2806 /* convert single element list to element */
2807 OP* const oe = expr;
2808 expr = cLISTOPx(oe)->op_first->op_sibling;
2809 cLISTOPx(oe)->op_first->op_sibling = NULL;
2810 cLISTOPx(oe)->op_last = NULL;
2814 if (o->op_type == OP_TRANS) {
2815 return pmtrans(o, expr, repl);
2818 reglist = isreg && expr->op_type == OP_LIST;
2822 PL_hints |= HINT_BLOCK_SCOPE;
2825 if (expr->op_type == OP_CONST) {
2827 SV * const pat = ((SVOP*)expr)->op_sv;
2828 const char *p = SvPV_const(pat, plen);
2829 if ((o->op_flags & OPf_SPECIAL) && (*p == ' ' && p[1] == '\0')) {
2830 U32 was_readonly = SvREADONLY(pat);
2834 sv_force_normal_flags(pat, 0);
2835 assert(!SvREADONLY(pat));
2838 SvREADONLY_off(pat);
2842 sv_setpvn(pat, "\\s+", 3);
2844 SvFLAGS(pat) |= was_readonly;
2846 p = SvPV_const(pat, plen);
2847 pm->op_pmflags |= PMf_SKIPWHITE;
2850 pm->op_pmdynflags |= PMdf_UTF8;
2851 /* FIXME - can we make this function take const char * args? */
2852 PM_SETRE(pm, CALLREGCOMP(aTHX_ (char*)p, (char*)p + plen, pm));
2853 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
2854 pm->op_pmflags |= PMf_WHITE;
2858 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
2859 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2861 : OP_REGCMAYBE),0,expr);
2863 NewOp(1101, rcop, 1, LOGOP);
2864 rcop->op_type = OP_REGCOMP;
2865 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
2866 rcop->op_first = scalar(expr);
2867 rcop->op_flags |= OPf_KIDS
2868 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
2869 | (reglist ? OPf_STACKED : 0);
2870 rcop->op_private = 1;
2873 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
2875 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
2878 /* establish postfix order */
2879 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
2881 rcop->op_next = expr;
2882 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
2885 rcop->op_next = LINKLIST(expr);
2886 expr->op_next = (OP*)rcop;
2889 prepend_elem(o->op_type, scalar((OP*)rcop), o);
2894 if (pm->op_pmflags & PMf_EVAL) {
2896 if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
2897 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
2899 else if (repl->op_type == OP_CONST)
2903 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
2904 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
2905 if (curop->op_type == OP_GV) {
2906 GV * const gv = cGVOPx_gv(curop);
2908 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
2911 else if (curop->op_type == OP_RV2CV)
2913 else if (curop->op_type == OP_RV2SV ||
2914 curop->op_type == OP_RV2AV ||
2915 curop->op_type == OP_RV2HV ||
2916 curop->op_type == OP_RV2GV) {
2917 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
2920 else if (curop->op_type == OP_PADSV ||
2921 curop->op_type == OP_PADAV ||
2922 curop->op_type == OP_PADHV ||
2923 curop->op_type == OP_PADANY) {
2926 else if (curop->op_type == OP_PUSHRE)
2927 /*EMPTY*/; /* Okay here, dangerous in newASSIGNOP */
2937 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
2938 pm->op_pmflags |= PMf_CONST; /* const for long enough */
2939 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
2940 prepend_elem(o->op_type, scalar(repl), o);
2943 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
2944 pm->op_pmflags |= PMf_MAYBE_CONST;
2945 pm->op_pmpermflags |= PMf_MAYBE_CONST;
2947 NewOp(1101, rcop, 1, LOGOP);
2948 rcop->op_type = OP_SUBSTCONT;
2949 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
2950 rcop->op_first = scalar(repl);
2951 rcop->op_flags |= OPf_KIDS;
2952 rcop->op_private = 1;
2955 /* establish postfix order */
2956 rcop->op_next = LINKLIST(repl);
2957 repl->op_next = (OP*)rcop;
2959 pm->op_pmreplroot = scalar((OP*)rcop);
2960 pm->op_pmreplstart = LINKLIST(rcop);
2969 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
2973 NewOp(1101, svop, 1, SVOP);
2974 svop->op_type = (OPCODE)type;
2975 svop->op_ppaddr = PL_ppaddr[type];
2977 svop->op_next = (OP*)svop;
2978 svop->op_flags = (U8)flags;
2979 if (PL_opargs[type] & OA_RETSCALAR)
2981 if (PL_opargs[type] & OA_TARGET)
2982 svop->op_targ = pad_alloc(type, SVs_PADTMP);
2983 return CHECKOP(type, svop);
2987 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
2991 NewOp(1101, padop, 1, PADOP);
2992 padop->op_type = (OPCODE)type;
2993 padop->op_ppaddr = PL_ppaddr[type];
2994 padop->op_padix = pad_alloc(type, SVs_PADTMP);
2995 SvREFCNT_dec(PAD_SVl(padop->op_padix));
2996 PAD_SETSV(padop->op_padix, sv);
2999 padop->op_next = (OP*)padop;
3000 padop->op_flags = (U8)flags;
3001 if (PL_opargs[type] & OA_RETSCALAR)
3003 if (PL_opargs[type] & OA_TARGET)
3004 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3005 return CHECKOP(type, padop);
3009 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3015 return newPADOP(type, flags, SvREFCNT_inc_simple(gv));
3017 return newSVOP(type, flags, SvREFCNT_inc_simple(gv));
3022 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3026 NewOp(1101, pvop, 1, PVOP);
3027 pvop->op_type = (OPCODE)type;
3028 pvop->op_ppaddr = PL_ppaddr[type];
3030 pvop->op_next = (OP*)pvop;
3031 pvop->op_flags = (U8)flags;
3032 if (PL_opargs[type] & OA_RETSCALAR)
3034 if (PL_opargs[type] & OA_TARGET)
3035 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3036 return CHECKOP(type, pvop);
3040 Perl_package(pTHX_ OP *o)
3046 save_hptr(&PL_curstash);
3047 save_item(PL_curstname);
3049 name = SvPV_const(cSVOPo->op_sv, len);
3050 PL_curstash = gv_stashpvn(name, len, TRUE);
3051 sv_setpvn(PL_curstname, name, len);
3054 PL_hints |= HINT_BLOCK_SCOPE;
3055 PL_copline = NOLINE;
3060 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3067 if (idop->op_type != OP_CONST)
3068 Perl_croak(aTHX_ "Module name must be constant");
3073 SV * const vesv = ((SVOP*)version)->op_sv;
3075 if (!arg && !SvNIOKp(vesv)) {
3082 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3083 Perl_croak(aTHX_ "Version number must be constant number");
3085 /* Make copy of idop so we don't free it twice */
3086 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3088 /* Fake up a method call to VERSION */
3089 meth = newSVpvs_share("VERSION");
3090 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3091 append_elem(OP_LIST,
3092 prepend_elem(OP_LIST, pack, list(version)),
3093 newSVOP(OP_METHOD_NAMED, 0, meth)));
3097 /* Fake up an import/unimport */
3098 if (arg && arg->op_type == OP_STUB)
3099 imop = arg; /* no import on explicit () */
3100 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3101 imop = NULL; /* use 5.0; */
3103 idop->op_private |= OPpCONST_NOVER;
3108 /* Make copy of idop so we don't free it twice */
3109 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3111 /* Fake up a method call to import/unimport */
3113 ? newSVpvs_share("import") : newSVpvs_share("unimport");
3114 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3115 append_elem(OP_LIST,
3116 prepend_elem(OP_LIST, pack, list(arg)),
3117 newSVOP(OP_METHOD_NAMED, 0, meth)));
3120 /* Fake up the BEGIN {}, which does its thing immediately. */
3122 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
3125 append_elem(OP_LINESEQ,
3126 append_elem(OP_LINESEQ,
3127 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
3128 newSTATEOP(0, NULL, veop)),
3129 newSTATEOP(0, NULL, imop) ));
3131 /* The "did you use incorrect case?" warning used to be here.
3132 * The problem is that on case-insensitive filesystems one
3133 * might get false positives for "use" (and "require"):
3134 * "use Strict" or "require CARP" will work. This causes
3135 * portability problems for the script: in case-strict
3136 * filesystems the script will stop working.
3138 * The "incorrect case" warning checked whether "use Foo"
3139 * imported "Foo" to your namespace, but that is wrong, too:
3140 * there is no requirement nor promise in the language that
3141 * a Foo.pm should or would contain anything in package "Foo".
3143 * There is very little Configure-wise that can be done, either:
3144 * the case-sensitivity of the build filesystem of Perl does not
3145 * help in guessing the case-sensitivity of the runtime environment.
3148 PL_hints |= HINT_BLOCK_SCOPE;
3149 PL_copline = NOLINE;
3151 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3155 =head1 Embedding Functions
3157 =for apidoc load_module
3159 Loads the module whose name is pointed to by the string part of name.
3160 Note that the actual module name, not its filename, should be given.
3161 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3162 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3163 (or 0 for no flags). ver, if specified, provides version semantics
3164 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3165 arguments can be used to specify arguments to the module's import()
3166 method, similar to C<use Foo::Bar VERSION LIST>.
3171 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3174 va_start(args, ver);
3175 vload_module(flags, name, ver, &args);
3179 #ifdef PERL_IMPLICIT_CONTEXT
3181 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3185 va_start(args, ver);
3186 vload_module(flags, name, ver, &args);
3192 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3197 OP * const modname = newSVOP(OP_CONST, 0, name);
3198 modname->op_private |= OPpCONST_BARE;
3200 veop = newSVOP(OP_CONST, 0, ver);
3204 if (flags & PERL_LOADMOD_NOIMPORT) {
3205 imop = sawparens(newNULLLIST());
3207 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3208 imop = va_arg(*args, OP*);
3213 sv = va_arg(*args, SV*);
3215 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3216 sv = va_arg(*args, SV*);
3220 const line_t ocopline = PL_copline;
3221 COP * const ocurcop = PL_curcop;
3222 const int oexpect = PL_expect;
3224 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3225 veop, modname, imop);
3226 PL_expect = oexpect;
3227 PL_copline = ocopline;
3228 PL_curcop = ocurcop;
3233 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
3239 if (!force_builtin) {
3240 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
3241 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
3242 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
3243 gv = gvp ? *gvp : NULL;
3247 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3248 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3249 append_elem(OP_LIST, term,
3250 scalar(newUNOP(OP_RV2CV, 0,
3255 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3261 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3263 return newBINOP(OP_LSLICE, flags,
3264 list(force_list(subscript)),
3265 list(force_list(listval)) );
3269 S_is_list_assignment(pTHX_ register const OP *o)
3274 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3275 o = cUNOPo->op_first;
3277 if (o->op_type == OP_COND_EXPR) {
3278 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
3279 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3284 yyerror("Assignment to both a list and a scalar");
3288 if (o->op_type == OP_LIST &&
3289 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3290 o->op_private & OPpLVAL_INTRO)
3293 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3294 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3295 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3298 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3301 if (o->op_type == OP_RV2SV)
3308 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3314 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3315 return newLOGOP(optype, 0,
3316 mod(scalar(left), optype),
3317 newUNOP(OP_SASSIGN, 0, scalar(right)));
3320 return newBINOP(optype, OPf_STACKED,
3321 mod(scalar(left), optype), scalar(right));
3325 if (is_list_assignment(left)) {
3329 /* Grandfathering $[ assignment here. Bletch.*/
3330 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
3331 PL_eval_start = (left->op_type == OP_CONST) ? right : 0;
3332 left = mod(left, OP_AASSIGN);
3335 else if (left->op_type == OP_CONST) {
3336 /* Result of assignment is always 1 (or we'd be dead already) */
3337 return newSVOP(OP_CONST, 0, newSViv(1));
3339 curop = list(force_list(left));
3340 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3341 o->op_private = (U8)(0 | (flags >> 8));
3343 /* PL_generation sorcery:
3344 * an assignment like ($a,$b) = ($c,$d) is easier than
3345 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3346 * To detect whether there are common vars, the global var
3347 * PL_generation is incremented for each assign op we compile.
3348 * Then, while compiling the assign op, we run through all the
3349 * variables on both sides of the assignment, setting a spare slot
3350 * in each of them to PL_generation. If any of them already have
3351 * that value, we know we've got commonality. We could use a
3352 * single bit marker, but then we'd have to make 2 passes, first
3353 * to clear the flag, then to test and set it. To find somewhere
3354 * to store these values, evil chicanery is done with SvCUR().
3357 if (!(left->op_private & OPpLVAL_INTRO)) {
3360 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3361 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3362 if (curop->op_type == OP_GV) {
3363 GV *gv = cGVOPx_gv(curop);
3365 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
3367 GvASSIGN_GENERATION_set(gv, PL_generation);
3369 else if (curop->op_type == OP_PADSV ||
3370 curop->op_type == OP_PADAV ||
3371 curop->op_type == OP_PADHV ||
3372 curop->op_type == OP_PADANY)
3374 if (PAD_COMPNAME_GEN(curop->op_targ)
3375 == (STRLEN)PL_generation)
3377 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
3380 else if (curop->op_type == OP_RV2CV)
3382 else if (curop->op_type == OP_RV2SV ||
3383 curop->op_type == OP_RV2AV ||
3384 curop->op_type == OP_RV2HV ||
3385 curop->op_type == OP_RV2GV) {
3386 if (lastop->op_type != OP_GV) /* funny deref? */
3389 else if (curop->op_type == OP_PUSHRE) {
3390 if (((PMOP*)curop)->op_pmreplroot) {
3392 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3393 ((PMOP*)curop)->op_pmreplroot));
3395 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3398 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
3400 GvASSIGN_GENERATION_set(gv, PL_generation);
3401 GvASSIGN_GENERATION_set(gv, PL_generation);
3410 o->op_private |= OPpASSIGN_COMMON;
3412 if (right && right->op_type == OP_SPLIT) {
3414 if ((tmpop = ((LISTOP*)right)->op_first) &&
3415 tmpop->op_type == OP_PUSHRE)
3417 PMOP * const pm = (PMOP*)tmpop;
3418 if (left->op_type == OP_RV2AV &&
3419 !(left->op_private & OPpLVAL_INTRO) &&
3420 !(o->op_private & OPpASSIGN_COMMON) )
3422 tmpop = ((UNOP*)left)->op_first;
3423 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3425 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3426 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3428 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3429 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
3431 pm->op_pmflags |= PMf_ONCE;
3432 tmpop = cUNOPo->op_first; /* to list (nulled) */
3433 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3434 tmpop->op_sibling = NULL; /* don't free split */
3435 right->op_next = tmpop->op_next; /* fix starting loc */
3436 op_free(o); /* blow off assign */
3437 right->op_flags &= ~OPf_WANT;
3438 /* "I don't know and I don't care." */
3443 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3444 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3446 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3448 sv_setiv(sv, PL_modcount+1);
3456 right = newOP(OP_UNDEF, 0);
3457 if (right->op_type == OP_READLINE) {
3458 right->op_flags |= OPf_STACKED;
3459 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3462 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3463 o = newBINOP(OP_SASSIGN, flags,
3464 scalar(right), mod(scalar(left), OP_SASSIGN) );
3468 o = newSVOP(OP_CONST, 0, newSViv(PL_compiling.cop_arybase));
3475 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3478 const U32 seq = intro_my();
3481 NewOp(1101, cop, 1, COP);
3482 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3483 cop->op_type = OP_DBSTATE;
3484 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3487 cop->op_type = OP_NEXTSTATE;
3488 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3490 cop->op_flags = (U8)flags;
3491 cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
3493 cop->op_private |= NATIVE_HINTS;
3495 PL_compiling.op_private = cop->op_private;
3496 cop->op_next = (OP*)cop;
3499 cop->cop_label = label;
3500 PL_hints |= HINT_BLOCK_SCOPE;
3503 cop->cop_arybase = PL_curcop->cop_arybase;
3504 if (specialWARN(PL_curcop->cop_warnings))
3505 cop->cop_warnings = PL_curcop->cop_warnings ;
3507 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3508 if (specialCopIO(PL_curcop->cop_io))
3509 cop->cop_io = PL_curcop->cop_io;
3511 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3514 if (PL_copline == NOLINE)
3515 CopLINE_set(cop, CopLINE(PL_curcop));
3517 CopLINE_set(cop, PL_copline);
3518 PL_copline = NOLINE;
3521 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3523 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3525 CopSTASH_set(cop, PL_curstash);
3527 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3528 SV * const * const svp = av_fetch(CopFILEAVx(PL_curcop), (I32)CopLINE(cop), FALSE);
3529 if (svp && *svp != &PL_sv_undef ) {
3530 (void)SvIOK_on(*svp);
3531 SvIV_set(*svp, PTR2IV(cop));
3535 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3540 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3543 return new_logop(type, flags, &first, &other);
3547 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3552 OP *first = *firstp;
3553 OP * const other = *otherp;
3555 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3556 return newBINOP(type, flags, scalar(first), scalar(other));
3558 scalarboolean(first);
3559 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3560 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3561 if (type == OP_AND || type == OP_OR) {
3567 first = *firstp = cUNOPo->op_first;
3569 first->op_next = o->op_next;
3570 cUNOPo->op_first = NULL;
3574 if (first->op_type == OP_CONST) {
3575 if (first->op_private & OPpCONST_STRICT)
3576 no_bareword_allowed(first);
3577 else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
3578 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
3579 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
3580 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
3581 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
3584 if (other->op_type == OP_CONST)
3585 other->op_private |= OPpCONST_SHORTCIRCUIT;
3589 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
3590 const OP *o2 = other;
3591 if ( ! (o2->op_type == OP_LIST
3592 && (( o2 = cUNOPx(o2)->op_first))
3593 && o2->op_type == OP_PUSHMARK
3594 && (( o2 = o2->op_sibling)) )
3597 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
3598 || o2->op_type == OP_PADHV)
3599 && o2->op_private & OPpLVAL_INTRO
3600 && ckWARN(WARN_DEPRECATED))
3602 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
3603 "Deprecated use of my() in false conditional");
3608 if (first->op_type == OP_CONST)
3609 first->op_private |= OPpCONST_SHORTCIRCUIT;
3613 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
3614 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
3616 const OP * const k1 = ((UNOP*)first)->op_first;
3617 const OP * const k2 = k1->op_sibling;
3619 switch (first->op_type)
3622 if (k2 && k2->op_type == OP_READLINE
3623 && (k2->op_flags & OPf_STACKED)
3624 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3626 warnop = k2->op_type;
3631 if (k1->op_type == OP_READDIR
3632 || k1->op_type == OP_GLOB
3633 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3634 || k1->op_type == OP_EACH)
3636 warnop = ((k1->op_type == OP_NULL)
3637 ? (OPCODE)k1->op_targ : k1->op_type);
3642 const line_t oldline = CopLINE(PL_curcop);
3643 CopLINE_set(PL_curcop, PL_copline);
3644 Perl_warner(aTHX_ packWARN(WARN_MISC),
3645 "Value of %s%s can be \"0\"; test with defined()",
3647 ((warnop == OP_READLINE || warnop == OP_GLOB)
3648 ? " construct" : "() operator"));
3649 CopLINE_set(PL_curcop, oldline);
3656 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
3657 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3659 NewOp(1101, logop, 1, LOGOP);
3661 logop->op_type = (OPCODE)type;
3662 logop->op_ppaddr = PL_ppaddr[type];
3663 logop->op_first = first;
3664 logop->op_flags = (U8)(flags | OPf_KIDS);
3665 logop->op_other = LINKLIST(other);
3666 logop->op_private = (U8)(1 | (flags >> 8));
3668 /* establish postfix order */
3669 logop->op_next = LINKLIST(first);
3670 first->op_next = (OP*)logop;
3671 first->op_sibling = other;
3673 CHECKOP(type,logop);
3675 o = newUNOP(OP_NULL, 0, (OP*)logop);
3682 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3690 return newLOGOP(OP_AND, 0, first, trueop);
3692 return newLOGOP(OP_OR, 0, first, falseop);
3694 scalarboolean(first);
3695 if (first->op_type == OP_CONST) {
3696 if (first->op_private & OPpCONST_BARE &&
3697 first->op_private & OPpCONST_STRICT) {
3698 no_bareword_allowed(first);
3700 if (SvTRUE(((SVOP*)first)->op_sv)) {
3711 NewOp(1101, logop, 1, LOGOP);
3712 logop->op_type = OP_COND_EXPR;
3713 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3714 logop->op_first = first;
3715 logop->op_flags = (U8)(flags | OPf_KIDS);
3716 logop->op_private = (U8)(1 | (flags >> 8));
3717 logop->op_other = LINKLIST(trueop);
3718 logop->op_next = LINKLIST(falseop);
3720 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
3723 /* establish postfix order */
3724 start = LINKLIST(first);
3725 first->op_next = (OP*)logop;
3727 first->op_sibling = trueop;
3728 trueop->op_sibling = falseop;
3729 o = newUNOP(OP_NULL, 0, (OP*)logop);
3731 trueop->op_next = falseop->op_next = o;
3738 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3747 NewOp(1101, range, 1, LOGOP);
3749 range->op_type = OP_RANGE;
3750 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3751 range->op_first = left;
3752 range->op_flags = OPf_KIDS;
3753 leftstart = LINKLIST(left);
3754 range->op_other = LINKLIST(right);
3755 range->op_private = (U8)(1 | (flags >> 8));
3757 left->op_sibling = right;
3759 range->op_next = (OP*)range;
3760 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3761 flop = newUNOP(OP_FLOP, 0, flip);
3762 o = newUNOP(OP_NULL, 0, flop);
3764 range->op_next = leftstart;
3766 left->op_next = flip;
3767 right->op_next = flop;
3769 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3770 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3771 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3772 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3774 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3775 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3778 if (!flip->op_private || !flop->op_private)
3779 linklist(o); /* blow off optimizer unless constant */
3785 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3790 const bool once = block && block->op_flags & OPf_SPECIAL &&
3791 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3793 PERL_UNUSED_ARG(debuggable);
3796 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3797 return block; /* do {} while 0 does once */
3798 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3799 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3800 expr = newUNOP(OP_DEFINED, 0,
3801 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3802 } else if (expr->op_flags & OPf_KIDS) {
3803 const OP * const k1 = ((UNOP*)expr)->op_first;
3804 const OP * const k2 = k1 ? k1->op_sibling : NULL;
3805 switch (expr->op_type) {
3807 if (k2 && k2->op_type == OP_READLINE
3808 && (k2->op_flags & OPf_STACKED)
3809 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3810 expr = newUNOP(OP_DEFINED, 0, expr);
3814 if (k1->op_type == OP_READDIR
3815 || k1->op_type == OP_GLOB
3816 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3817 || k1->op_type == OP_EACH)
3818 expr = newUNOP(OP_DEFINED, 0, expr);
3824 /* if block is null, the next append_elem() would put UNSTACK, a scalar
3825 * op, in listop. This is wrong. [perl #27024] */
3827 block = newOP(OP_NULL, 0);
3828 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3829 o = new_logop(OP_AND, 0, &expr, &listop);
3832 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3834 if (once && o != listop)
3835 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3838 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3840 o->op_flags |= flags;
3842 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3847 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
3848 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
3857 PERL_UNUSED_ARG(debuggable);
3860 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3861 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3862 expr = newUNOP(OP_DEFINED, 0,
3863 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3864 } else if (expr->op_flags & OPf_KIDS) {
3865 const OP * const k1 = ((UNOP*)expr)->op_first;
3866 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
3867 switch (expr->op_type) {
3869 if (k2 && k2->op_type == OP_READLINE
3870 && (k2->op_flags & OPf_STACKED)
3871 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3872 expr = newUNOP(OP_DEFINED, 0, expr);
3876 if (k1->op_type == OP_READDIR
3877 || k1->op_type == OP_GLOB
3878 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3879 || k1->op_type == OP_EACH)
3880 expr = newUNOP(OP_DEFINED, 0, expr);
3887 block = newOP(OP_NULL, 0);
3888 else if (cont || has_my) {
3889 block = scope(block);
3893 next = LINKLIST(cont);
3896 OP * const unstack = newOP(OP_UNSTACK, 0);
3899 cont = append_elem(OP_LINESEQ, cont, unstack);
3902 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3903 redo = LINKLIST(listop);
3906 PL_copline = (line_t)whileline;
3908 o = new_logop(OP_AND, 0, &expr, &listop);
3909 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3910 op_free(expr); /* oops, it's a while (0) */
3912 return NULL; /* listop already freed by new_logop */
3915 ((LISTOP*)listop)->op_last->op_next =
3916 (o == listop ? redo : LINKLIST(o));
3922 NewOp(1101,loop,1,LOOP);
3923 loop->op_type = OP_ENTERLOOP;
3924 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3925 loop->op_private = 0;
3926 loop->op_next = (OP*)loop;
3929 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
3931 loop->op_redoop = redo;
3932 loop->op_lastop = o;
3933 o->op_private |= loopflags;
3936 loop->op_nextop = next;
3938 loop->op_nextop = o;
3940 o->op_flags |= flags;
3941 o->op_private |= (flags >> 8);
3946 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
3951 PADOFFSET padoff = 0;
3956 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
3957 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
3958 sv->op_type = OP_RV2GV;
3959 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
3960 if (cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
3961 iterpflags |= OPpITER_DEF;
3963 else if (sv->op_type == OP_PADSV) { /* private variable */
3964 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
3965 padoff = sv->op_targ;
3970 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
3971 padoff = sv->op_targ;
3973 iterflags |= OPf_SPECIAL;
3978 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
3979 if (padoff && strEQ(PAD_COMPNAME_PV(padoff), "$_"))
3980 iterpflags |= OPpITER_DEF;
3983 const I32 offset = pad_findmy("$_");
3984 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
3985 sv = newGVOP(OP_GV, 0, PL_defgv);
3990 iterpflags |= OPpITER_DEF;
3992 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
3993 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
3994 iterflags |= OPf_STACKED;
3996 else if (expr->op_type == OP_NULL &&
3997 (expr->op_flags & OPf_KIDS) &&
3998 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4000 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4001 * set the STACKED flag to indicate that these values are to be
4002 * treated as min/max values by 'pp_iterinit'.
4004 UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4005 LOGOP* const range = (LOGOP*) flip->op_first;
4006 OP* const left = range->op_first;
4007 OP* const right = left->op_sibling;
4010 range->op_flags &= ~OPf_KIDS;
4011 range->op_first = NULL;
4013 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4014 listop->op_first->op_next = range->op_next;
4015 left->op_next = range->op_other;
4016 right->op_next = (OP*)listop;
4017 listop->op_next = listop->op_first;
4020 expr = (OP*)(listop);
4022 iterflags |= OPf_STACKED;
4025 expr = mod(force_list(expr), OP_GREPSTART);
4028 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4029 append_elem(OP_LIST, expr, scalar(sv))));
4030 assert(!loop->op_next);
4031 /* for my $x () sets OPpLVAL_INTRO;
4032 * for our $x () sets OPpOUR_INTRO */
4033 loop->op_private = (U8)iterpflags;
4034 #ifdef PL_OP_SLAB_ALLOC
4037 NewOp(1234,tmp,1,LOOP);
4038 Copy(loop,tmp,1,LISTOP);
4043 Renew(loop, 1, LOOP);
4045 loop->op_targ = padoff;
4046 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
4047 PL_copline = forline;
4048 return newSTATEOP(0, label, wop);
4052 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4057 if (type != OP_GOTO || label->op_type == OP_CONST) {
4058 /* "last()" means "last" */
4059 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4060 o = newOP(type, OPf_SPECIAL);
4062 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4063 ? SvPVx_nolen_const(((SVOP*)label)->op_sv)
4069 /* Check whether it's going to be a goto &function */
4070 if (label->op_type == OP_ENTERSUB
4071 && !(label->op_flags & OPf_STACKED))
4072 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4073 o = newUNOP(type, OPf_STACKED, label);
4075 PL_hints |= HINT_BLOCK_SCOPE;
4079 /* if the condition is a literal array or hash
4080 (or @{ ... } etc), make a reference to it.
4083 S_ref_array_or_hash(pTHX_ OP *cond)
4086 && (cond->op_type == OP_RV2AV
4087 || cond->op_type == OP_PADAV
4088 || cond->op_type == OP_RV2HV
4089 || cond->op_type == OP_PADHV))
4091 return newUNOP(OP_REFGEN,
4092 0, mod(cond, OP_REFGEN));
4098 /* These construct the optree fragments representing given()
4101 entergiven and enterwhen are LOGOPs; the op_other pointer
4102 points up to the associated leave op. We need this so we
4103 can put it in the context and make break/continue work.
4104 (Also, of course, pp_enterwhen will jump straight to
4105 op_other if the match fails.)
4110 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
4111 I32 enter_opcode, I32 leave_opcode,
4112 PADOFFSET entertarg)
4118 NewOp(1101, enterop, 1, LOGOP);
4119 enterop->op_type = enter_opcode;
4120 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
4121 enterop->op_flags = (U8) OPf_KIDS;
4122 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
4123 enterop->op_private = 0;
4125 o = newUNOP(leave_opcode, 0, (OP *) enterop);
4128 enterop->op_first = scalar(cond);
4129 cond->op_sibling = block;
4131 o->op_next = LINKLIST(cond);
4132 cond->op_next = (OP *) enterop;
4135 /* This is a default {} block */
4136 enterop->op_first = block;
4137 enterop->op_flags |= OPf_SPECIAL;
4139 o->op_next = (OP *) enterop;
4142 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
4143 entergiven and enterwhen both
4146 enterop->op_next = LINKLIST(block);
4147 block->op_next = enterop->op_other = o;
4152 /* Does this look like a boolean operation? For these purposes
4153 a boolean operation is:
4154 - a subroutine call [*]
4155 - a logical connective
4156 - a comparison operator
4157 - a filetest operator, with the exception of -s -M -A -C
4158 - defined(), exists() or eof()
4159 - /$re/ or $foo =~ /$re/
4161 [*] possibly surprising
4165 S_looks_like_bool(pTHX_ OP *o)
4168 switch(o->op_type) {
4170 return looks_like_bool(cLOGOPo->op_first);
4174 looks_like_bool(cLOGOPo->op_first)
4175 && looks_like_bool(cLOGOPo->op_first->op_sibling));
4179 case OP_NOT: case OP_XOR:
4180 /* Note that OP_DOR is not here */
4182 case OP_EQ: case OP_NE: case OP_LT:
4183 case OP_GT: case OP_LE: case OP_GE:
4185 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
4186 case OP_I_GT: case OP_I_LE: case OP_I_GE:
4188 case OP_SEQ: case OP_SNE: case OP_SLT:
4189 case OP_SGT: case OP_SLE: case OP_SGE:
4193 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
4194 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
4195 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
4196 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
4197 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
4198 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
4199 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
4200 case OP_FTTEXT: case OP_FTBINARY:
4202 case OP_DEFINED: case OP_EXISTS:
4203 case OP_MATCH: case OP_EOF:
4208 /* Detect comparisons that have been optimized away */
4209 if (cSVOPo->op_sv == &PL_sv_yes
4210 || cSVOPo->op_sv == &PL_sv_no)
4221 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
4225 return newGIVWHENOP(
4226 ref_array_or_hash(cond),
4228 OP_ENTERGIVEN, OP_LEAVEGIVEN,
4232 /* If cond is null, this is a default {} block */
4234 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
4236 bool cond_llb = (!cond || looks_like_bool(cond));
4242 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
4244 scalar(ref_array_or_hash(cond)));
4247 return newGIVWHENOP(
4249 append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
4250 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
4254 =for apidoc cv_undef
4256 Clear out all the active components of a CV. This can happen either
4257 by an explicit C<undef &foo>, or by the reference count going to zero.
4258 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
4259 children can still follow the full lexical scope chain.
4265 Perl_cv_undef(pTHX_ CV *cv)
4269 if (CvFILE(cv) && !CvISXSUB(cv)) {
4270 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4271 Safefree(CvFILE(cv));
4276 if (!CvISXSUB(cv) && CvROOT(cv)) {
4277 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
4278 Perl_croak(aTHX_ "Can't undef active subroutine");
4281 PAD_SAVE_SETNULLPAD();
4283 op_free(CvROOT(cv));
4288 SvPOK_off((SV*)cv); /* forget prototype */
4293 /* remove CvOUTSIDE unless this is an undef rather than a free */
4294 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
4295 if (!CvWEAKOUTSIDE(cv))
4296 SvREFCNT_dec(CvOUTSIDE(cv));
4297 CvOUTSIDE(cv) = NULL;
4300 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4303 if (CvISXSUB(cv) && CvXSUB(cv)) {
4306 /* delete all flags except WEAKOUTSIDE */
4307 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
4311 Perl_cv_ckproto(pTHX_ const CV *cv, const GV *gv, const char *p)
4313 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX_const(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4314 SV* const msg = sv_newmortal();
4318 gv_efullname3(name = sv_newmortal(), gv, NULL);
4319 sv_setpv(msg, "Prototype mismatch:");
4321 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4323 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (const SV *)cv);
4325 sv_catpvs(msg, ": none");
4326 sv_catpvs(msg, " vs ");
4328 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4330 sv_catpvs(msg, "none");
4331 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
4335 static void const_sv_xsub(pTHX_ CV* cv);
4339 =head1 Optree Manipulation Functions
4341 =for apidoc cv_const_sv
4343 If C<cv> is a constant sub eligible for inlining. returns the constant
4344 value returned by the sub. Otherwise, returns NULL.
4346 Constant subs can be created with C<newCONSTSUB> or as described in
4347 L<perlsub/"Constant Functions">.
4352 Perl_cv_const_sv(pTHX_ CV *cv)
4354 PERL_UNUSED_CONTEXT;
4357 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
4359 return CvCONST(cv) ? (SV*)CvXSUBANY(cv).any_ptr : NULL;
4362 /* op_const_sv: examine an optree to determine whether it's in-lineable.
4363 * Can be called in 3 ways:
4366 * look for a single OP_CONST with attached value: return the value
4368 * cv && CvCLONE(cv) && !CvCONST(cv)
4370 * examine the clone prototype, and if contains only a single
4371 * OP_CONST referencing a pad const, or a single PADSV referencing
4372 * an outer lexical, return a non-zero value to indicate the CV is
4373 * a candidate for "constizing" at clone time
4377 * We have just cloned an anon prototype that was marked as a const
4378 * candidiate. Try to grab the current value, and in the case of
4379 * PADSV, ignore it if it has multiple references. Return the value.
4383 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
4391 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4392 o = cLISTOPo->op_first->op_sibling;
4394 for (; o; o = o->op_next) {
4395 const OPCODE type = o->op_type;
4397 if (sv && o->op_next == o)
4399 if (o->op_next != o) {
4400 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4402 if (type == OP_DBSTATE)
4405 if (type == OP_LEAVESUB || type == OP_RETURN)
4409 if (type == OP_CONST && cSVOPo->op_sv)
4411 else if (cv && type == OP_CONST) {
4412 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4416 else if (cv && type == OP_PADSV) {
4417 if (CvCONST(cv)) { /* newly cloned anon */
4418 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4419 /* the candidate should have 1 ref from this pad and 1 ref
4420 * from the parent */
4421 if (!sv || SvREFCNT(sv) != 2)
4428 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
4429 sv = &PL_sv_undef; /* an arbitrary non-null value */
4440 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4442 PERL_UNUSED_ARG(floor);
4452 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4456 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4458 return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
4462 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4469 register CV *cv = NULL;
4471 /* If the subroutine has no body, no attributes, and no builtin attributes
4472 then it's just a sub declaration, and we may be able to get away with
4473 storing with a placeholder scalar in the symbol table, rather than a
4474 full GV and CV. If anything is present then it will take a full CV to
4476 const I32 gv_fetch_flags
4477 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
4478 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
4479 const char * const name = o ? SvPVx_nolen_const(cSVOPo->op_sv) : NULL;
4482 assert(proto->op_type == OP_CONST);
4483 ps = SvPVx_const(((SVOP*)proto)->op_sv, ps_len);
4488 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4489 SV * const sv = sv_newmortal();
4490 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4491 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
4492 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4493 aname = SvPVX_const(sv);
4498 gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
4499 : gv_fetchpv(aname ? aname
4500 : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4501 gv_fetch_flags, SVt_PVCV);
4510 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4511 maximum a prototype before. */
4512 if (SvTYPE(gv) > SVt_NULL) {
4513 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4514 && ckWARN_d(WARN_PROTOTYPE))
4516 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
4518 cv_ckproto((CV*)gv, NULL, ps);
4521 sv_setpvn((SV*)gv, ps, ps_len);
4523 sv_setiv((SV*)gv, -1);
4524 SvREFCNT_dec(PL_compcv);
4525 cv = PL_compcv = NULL;
4526 PL_sub_generation++;
4530 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
4532 #ifdef GV_UNIQUE_CHECK
4533 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4534 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4538 if (!block || !ps || *ps || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
4541 const_sv = op_const_sv(block, NULL);
4544 const bool exists = CvROOT(cv) || CvXSUB(cv);
4546 #ifdef GV_UNIQUE_CHECK
4547 if (exists && GvUNIQUE(gv)) {
4548 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4552 /* if the subroutine doesn't exist and wasn't pre-declared
4553 * with a prototype, assume it will be AUTOLOADed,
4554 * skipping the prototype check
4556 if (exists || SvPOK(cv))
4557 cv_ckproto(cv, gv, ps);
4558 /* already defined (or promised)? */
4559 if (exists || GvASSUMECV(gv)) {
4560 if (!block && !attrs) {
4561 if (CvFLAGS(PL_compcv)) {
4562 /* might have had built-in attrs applied */
4563 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4565 /* just a "sub foo;" when &foo is already defined */
4566 SAVEFREESV(PL_compcv);
4570 if (ckWARN(WARN_REDEFINE)
4572 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4574 const line_t oldline = CopLINE(PL_curcop);
4575 if (PL_copline != NOLINE)
4576 CopLINE_set(PL_curcop, PL_copline);
4577 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4578 CvCONST(cv) ? "Constant subroutine %s redefined"
4579 : "Subroutine %s redefined", name);
4580 CopLINE_set(PL_curcop, oldline);
4588 SvREFCNT_inc_void_NN(const_sv);
4590 assert(!CvROOT(cv) && !CvCONST(cv));
4591 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
4592 CvXSUBANY(cv).any_ptr = const_sv;
4593 CvXSUB(cv) = const_sv_xsub;
4599 cv = newCONSTSUB(NULL, name, const_sv);
4602 SvREFCNT_dec(PL_compcv);
4604 PL_sub_generation++;
4611 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4612 * before we clobber PL_compcv.
4616 /* Might have had built-in attributes applied -- propagate them. */
4617 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4618 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4619 stash = GvSTASH(CvGV(cv));
4620 else if (CvSTASH(cv))
4621 stash = CvSTASH(cv);
4623 stash = PL_curstash;
4626 /* possibly about to re-define existing subr -- ignore old cv */
4627 rcv = (SV*)PL_compcv;
4628 if (name && GvSTASH(gv))
4629 stash = GvSTASH(gv);
4631 stash = PL_curstash;
4633 apply_attrs(stash, rcv, attrs, FALSE);
4635 if (cv) { /* must reuse cv if autoloaded */
4637 /* got here with just attrs -- work done, so bug out */
4638 SAVEFREESV(PL_compcv);
4641 /* transfer PL_compcv to cv */
4643 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4644 if (!CvWEAKOUTSIDE(cv))
4645 SvREFCNT_dec(CvOUTSIDE(cv));
4646 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4647 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
4648 CvOUTSIDE(PL_compcv) = 0;
4649 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4650 CvPADLIST(PL_compcv) = 0;
4651 /* inner references to PL_compcv must be fixed up ... */
4652 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
4653 /* ... before we throw it away */
4654 SvREFCNT_dec(PL_compcv);
4656 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4657 ++PL_sub_generation;
4664 PL_sub_generation++;
4668 CvFILE_set_from_cop(cv, PL_curcop);
4669 CvSTASH(cv) = PL_curstash;
4672 sv_setpvn((SV*)cv, ps, ps_len);
4674 if (PL_error_count) {
4678 const char *s = strrchr(name, ':');
4680 if (strEQ(s, "BEGIN")) {
4681 const char not_safe[] =
4682 "BEGIN not safe after errors--compilation aborted";
4683 if (PL_in_eval & EVAL_KEEPERR)
4684 Perl_croak(aTHX_ not_safe);
4686 /* force display of errors found but not reported */
4687 sv_catpv(ERRSV, not_safe);
4688 Perl_croak(aTHX_ "%"SVf, ERRSV);
4697 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4698 mod(scalarseq(block), OP_LEAVESUBLV));
4701 /* This makes sub {}; work as expected. */
4702 if (block->op_type == OP_STUB) {
4704 block = newSTATEOP(0, NULL, 0);
4706 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4708 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4709 OpREFCNT_set(CvROOT(cv), 1);
4710 CvSTART(cv) = LINKLIST(CvROOT(cv));
4711 CvROOT(cv)->op_next = 0;
4712 CALL_PEEP(CvSTART(cv));
4714 /* now that optimizer has done its work, adjust pad values */
4716 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4719 assert(!CvCONST(cv));
4720 if (ps && !*ps && op_const_sv(block, cv))
4724 if (name || aname) {
4726 const char * const tname = (name ? name : aname);
4728 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4729 SV * const sv = newSV(0);
4730 SV * const tmpstr = sv_newmortal();
4731 GV * const db_postponed = gv_fetchpvs("DB::postponed",
4732 GV_ADDMULTI, SVt_PVHV);
4735 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4737 (long)PL_subline, (long)CopLINE(PL_curcop));
4738 gv_efullname3(tmpstr, gv, NULL);
4739 hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0);
4740 hv = GvHVn(db_postponed);
4741 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
4742 CV * const pcv = GvCV(db_postponed);
4748 call_sv((SV*)pcv, G_DISCARD);
4753 if ((s = strrchr(tname,':')))
4758 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4761 if (strEQ(s, "BEGIN") && !PL_error_count) {
4762 const I32 oldscope = PL_scopestack_ix;
4764 SAVECOPFILE(&PL_compiling);
4765 SAVECOPLINE(&PL_compiling);
4768 PL_beginav = newAV();
4769 DEBUG_x( dump_sub(gv) );
4770 av_push(PL_beginav, (SV*)cv);
4771 GvCV(gv) = 0; /* cv has been hijacked */
4772 call_list(oldscope, PL_beginav);
4774 PL_curcop = &PL_compiling;
4775 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4778 else if (strEQ(s, "END") && !PL_error_count) {
4781 DEBUG_x( dump_sub(gv) );
4782 av_unshift(PL_endav, 1);
4783 av_store(PL_endav, 0, (SV*)cv);
4784 GvCV(gv) = 0; /* cv has been hijacked */
4786 else if (strEQ(s, "CHECK") && !PL_error_count) {
4788 PL_checkav = newAV();
4789 DEBUG_x( dump_sub(gv) );
4790 if (PL_main_start && ckWARN(WARN_VOID))
4791 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4792 av_unshift(PL_checkav, 1);
4793 av_store(PL_checkav, 0, (SV*)cv);
4794 GvCV(gv) = 0; /* cv has been hijacked */
4796 else if (strEQ(s, "INIT") && !PL_error_count) {
4798 PL_initav = newAV();
4799 DEBUG_x( dump_sub(gv) );
4800 if (PL_main_start && ckWARN(WARN_VOID))
4801 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4802 av_push(PL_initav, (SV*)cv);
4803 GvCV(gv) = 0; /* cv has been hijacked */
4808 PL_copline = NOLINE;
4813 /* XXX unsafe for threads if eval_owner isn't held */
4815 =for apidoc newCONSTSUB
4817 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4818 eligible for inlining at compile-time.
4824 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
4831 SAVECOPLINE(PL_curcop);
4832 CopLINE_set(PL_curcop, PL_copline);
4835 PL_hints &= ~HINT_BLOCK_SCOPE;
4838 SAVESPTR(PL_curstash);
4839 SAVECOPSTASH(PL_curcop);
4840 PL_curstash = stash;
4841 CopSTASH_set(PL_curcop,stash);
4844 cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
4845 CvXSUBANY(cv).any_ptr = sv;
4847 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
4851 CopSTASH_free(PL_curcop);
4859 =for apidoc U||newXS
4861 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4867 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
4870 GV * const gv = gv_fetchpv(name ? name :
4871 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4872 GV_ADDMULTI, SVt_PVCV);
4876 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4878 if ((cv = (name ? GvCV(gv) : NULL))) {
4880 /* just a cached method */
4884 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4885 /* already defined (or promised) */
4886 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
4887 if (ckWARN(WARN_REDEFINE)) {
4888 GV * const gvcv = CvGV(cv);
4890 HV * const stash = GvSTASH(gvcv);
4892 const char *redefined_name = HvNAME_get(stash);
4893 if ( strEQ(redefined_name,"autouse") ) {
4894 const line_t oldline = CopLINE(PL_curcop);
4895 if (PL_copline != NOLINE)
4896 CopLINE_set(PL_curcop, PL_copline);
4897 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4898 CvCONST(cv) ? "Constant subroutine %s redefined"
4899 : "Subroutine %s redefined"
4901 CopLINE_set(PL_curcop, oldline);
4911 if (cv) /* must reuse cv if autoloaded */
4915 sv_upgrade((SV *)cv, SVt_PVCV);
4919 PL_sub_generation++;
4923 (void)gv_fetchfile(filename);
4924 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
4925 an external constant string */
4927 CvXSUB(cv) = subaddr;
4930 const char *s = strrchr(name,':');
4936 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4939 if (strEQ(s, "BEGIN")) {
4941 PL_beginav = newAV();
4942 av_push(PL_beginav, (SV*)cv);
4943 GvCV(gv) = 0; /* cv has been hijacked */
4945 else if (strEQ(s, "END")) {
4948 av_unshift(PL_endav, 1);
4949 av_store(PL_endav, 0, (SV*)cv);
4950 GvCV(gv) = 0; /* cv has been hijacked */
4952 else if (strEQ(s, "CHECK")) {
4954 PL_checkav = newAV();
4955 if (PL_main_start && ckWARN(WARN_VOID))
4956 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4957 av_unshift(PL_checkav, 1);
4958 av_store(PL_checkav, 0, (SV*)cv);
4959 GvCV(gv) = 0; /* cv has been hijacked */
4961 else if (strEQ(s, "INIT")) {
4963 PL_initav = newAV();
4964 if (PL_main_start && ckWARN(WARN_VOID))
4965 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4966 av_push(PL_initav, (SV*)cv);
4967 GvCV(gv) = 0; /* cv has been hijacked */
4978 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4984 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
4985 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
4987 #ifdef GV_UNIQUE_CHECK
4989 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
4993 if ((cv = GvFORM(gv))) {
4994 if (ckWARN(WARN_REDEFINE)) {
4995 const line_t oldline = CopLINE(PL_curcop);
4996 if (PL_copline != NOLINE)
4997 CopLINE_set(PL_curcop, PL_copline);
4998 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4999 o ? "Format %"SVf" redefined"
5000 : "Format STDOUT redefined" ,cSVOPo->op_sv);
5001 CopLINE_set(PL_curcop, oldline);
5008 CvFILE_set_from_cop(cv, PL_curcop);
5011 pad_tidy(padtidy_FORMAT);
5012 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5013 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5014 OpREFCNT_set(CvROOT(cv), 1);
5015 CvSTART(cv) = LINKLIST(CvROOT(cv));
5016 CvROOT(cv)->op_next = 0;
5017 CALL_PEEP(CvSTART(cv));
5019 PL_copline = NOLINE;
5024 Perl_newANONLIST(pTHX_ OP *o)
5026 return newUNOP(OP_REFGEN, 0,
5027 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5031 Perl_newANONHASH(pTHX_ OP *o)
5033 return newUNOP(OP_REFGEN, 0,
5034 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5038 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5040 return newANONATTRSUB(floor, proto, NULL, block);
5044 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5046 return newUNOP(OP_REFGEN, 0,
5047 newSVOP(OP_ANONCODE, 0,
5048 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5052 Perl_oopsAV(pTHX_ OP *o)
5055 switch (o->op_type) {
5057 o->op_type = OP_PADAV;
5058 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5059 return ref(o, OP_RV2AV);
5062 o->op_type = OP_RV2AV;
5063 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5068 if (ckWARN_d(WARN_INTERNAL))
5069 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
5076 Perl_oopsHV(pTHX_ OP *o)
5079 switch (o->op_type) {
5082 o->op_type = OP_PADHV;
5083 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5084 return ref(o, OP_RV2HV);
5088 o->op_type = OP_RV2HV;
5089 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5094 if (ckWARN_d(WARN_INTERNAL))
5095 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
5102 Perl_newAVREF(pTHX_ OP *o)
5105 if (o->op_type == OP_PADANY) {
5106 o->op_type = OP_PADAV;
5107 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5110 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5111 && ckWARN(WARN_DEPRECATED)) {
5112 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5113 "Using an array as a reference is deprecated");
5115 return newUNOP(OP_RV2AV, 0, scalar(o));
5119 Perl_newGVREF(pTHX_ I32 type, OP *o)
5121 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5122 return newUNOP(OP_NULL, 0, o);
5123 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5127 Perl_newHVREF(pTHX_ OP *o)
5130 if (o->op_type == OP_PADANY) {
5131 o->op_type = OP_PADHV;
5132 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5135 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5136 && ckWARN(WARN_DEPRECATED)) {
5137 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5138 "Using a hash as a reference is deprecated");
5140 return newUNOP(OP_RV2HV, 0, scalar(o));
5144 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5146 return newUNOP(OP_RV2CV, flags, scalar(o));
5150 Perl_newSVREF(pTHX_ OP *o)
5153 if (o->op_type == OP_PADANY) {
5154 o->op_type = OP_PADSV;
5155 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5158 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5159 o->op_flags |= OPpDONE_SVREF;
5162 return newUNOP(OP_RV2SV, 0, scalar(o));
5165 /* Check routines. See the comments at the top of this file for details
5166 * on when these are called */
5169 Perl_ck_anoncode(pTHX_ OP *o)
5171 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
5172 cSVOPo->op_sv = NULL;
5177 Perl_ck_bitop(pTHX_ OP *o)
5180 #define OP_IS_NUMCOMPARE(op) \
5181 ((op) == OP_LT || (op) == OP_I_LT || \
5182 (op) == OP_GT || (op) == OP_I_GT || \
5183 (op) == OP_LE || (op) == OP_I_LE || \
5184 (op) == OP_GE || (op) == OP_I_GE || \
5185 (op) == OP_EQ || (op) == OP_I_EQ || \
5186 (op) == OP_NE || (op) == OP_I_NE || \
5187 (op) == OP_NCMP || (op) == OP_I_NCMP)
5188 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
5189 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
5190 && (o->op_type == OP_BIT_OR
5191 || o->op_type == OP_BIT_AND
5192 || o->op_type == OP_BIT_XOR))
5194 const OP * const left = cBINOPo->op_first;
5195 const OP * const right = left->op_sibling;
5196 if ((OP_IS_NUMCOMPARE(left->op_type) &&
5197 (left->op_flags & OPf_PARENS) == 0) ||
5198 (OP_IS_NUMCOMPARE(right->op_type) &&
5199 (right->op_flags & OPf_PARENS) == 0))
5200 if (ckWARN(WARN_PRECEDENCE))
5201 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
5202 "Possible precedence problem on bitwise %c operator",
5203 o->op_type == OP_BIT_OR ? '|'
5204 : o->op_type == OP_BIT_AND ? '&' : '^'
5211 Perl_ck_concat(pTHX_ OP *o)
5213 const OP * const kid = cUNOPo->op_first;
5214 PERL_UNUSED_CONTEXT;
5215 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
5216 !(kUNOP->op_first->op_flags & OPf_MOD))
5217 o->op_flags |= OPf_STACKED;
5222 Perl_ck_spair(pTHX_ OP *o)
5225 if (o->op_flags & OPf_KIDS) {
5228 const OPCODE type = o->op_type;
5229 o = modkids(ck_fun(o), type);
5230 kid = cUNOPo->op_first;
5231 newop = kUNOP->op_first->op_sibling;
5233 (newop->op_sibling ||
5234 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5235 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5236 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5240 op_free(kUNOP->op_first);
5241 kUNOP->op_first = newop;
5243 o->op_ppaddr = PL_ppaddr[++o->op_type];
5248 Perl_ck_delete(pTHX_ OP *o)
5252 if (o->op_flags & OPf_KIDS) {
5253 OP * const kid = cUNOPo->op_first;
5254 switch (kid->op_type) {
5256 o->op_flags |= OPf_SPECIAL;
5259 o->op_private |= OPpSLICE;
5262 o->op_flags |= OPf_SPECIAL;
5267 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5276 Perl_ck_die(pTHX_ OP *o)
5279 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5285 Perl_ck_eof(pTHX_ OP *o)
5288 const I32 type = o->op_type;
5290 if (o->op_flags & OPf_KIDS) {
5291 if (cLISTOPo->op_first->op_type == OP_STUB) {
5293 o = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
5301 Perl_ck_eval(pTHX_ OP *o)
5304 PL_hints |= HINT_BLOCK_SCOPE;
5305 if (o->op_flags & OPf_KIDS) {
5306 SVOP * const kid = (SVOP*)cUNOPo->op_first;
5309 o->op_flags &= ~OPf_KIDS;
5312 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
5315 cUNOPo->op_first = 0;
5318 NewOp(1101, enter, 1, LOGOP);
5319 enter->op_type = OP_ENTERTRY;
5320 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5321 enter->op_private = 0;
5323 /* establish postfix order */
5324 enter->op_next = (OP*)enter;
5326 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5327 o->op_type = OP_LEAVETRY;
5328 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5329 enter->op_other = o;
5339 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5341 o->op_targ = (PADOFFSET)PL_hints;
5342 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
5343 /* Store a copy of %^H that pp_entereval can pick up */
5344 OP *hhop = newSVOP(OP_CONST, 0, (SV*)newHVhv(GvHV(PL_hintgv)));
5345 cUNOPo->op_first->op_sibling = hhop;
5346 o->op_private |= OPpEVAL_HAS_HH;
5352 Perl_ck_exit(pTHX_ OP *o)
5355 HV * const table = GvHV(PL_hintgv);
5357 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
5358 if (svp && *svp && SvTRUE(*svp))
5359 o->op_private |= OPpEXIT_VMSISH;
5361 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5367 Perl_ck_exec(pTHX_ OP *o)
5369 if (o->op_flags & OPf_STACKED) {
5372 kid = cUNOPo->op_first->op_sibling;
5373 if (kid->op_type == OP_RV2GV)
5382 Perl_ck_exists(pTHX_ OP *o)
5386 if (o->op_flags & OPf_KIDS) {
5387 OP * const kid = cUNOPo->op_first;
5388 if (kid->op_type == OP_ENTERSUB) {
5389 (void) ref(kid, o->op_type);
5390 if (kid->op_type != OP_RV2CV && !PL_error_count)
5391 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5393 o->op_private |= OPpEXISTS_SUB;
5395 else if (kid->op_type == OP_AELEM)
5396 o->op_flags |= OPf_SPECIAL;
5397 else if (kid->op_type != OP_HELEM)
5398 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5406 Perl_ck_rvconst(pTHX_ register OP *o)
5409 SVOP * const kid = (SVOP*)cUNOPo->op_first;
5411 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5412 if (o->op_type == OP_RV2CV)
5413 o->op_private &= ~1;
5415 if (kid->op_type == OP_CONST) {
5418 SV * const kidsv = kid->op_sv;
5420 /* Is it a constant from cv_const_sv()? */
5421 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5422 SV * const rsv = SvRV(kidsv);
5423 const int svtype = SvTYPE(rsv);
5424 const char *badtype = NULL;
5426 switch (o->op_type) {
5428 if (svtype > SVt_PVMG)
5429 badtype = "a SCALAR";
5432 if (svtype != SVt_PVAV)
5433 badtype = "an ARRAY";
5436 if (svtype != SVt_PVHV)
5440 if (svtype != SVt_PVCV)
5445 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5448 else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
5449 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
5450 /* If this is an access to a stash, disable "strict refs", because
5451 * stashes aren't auto-vivified at compile-time (unless we store
5452 * symbols in them), and we don't want to produce a run-time
5453 * stricture error when auto-vivifying the stash. */
5454 const char *s = SvPV_nolen(kidsv);
5455 const STRLEN l = SvCUR(kidsv);
5456 if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
5457 o->op_private &= ~HINT_STRICT_REFS;
5459 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5460 const char *badthing;
5461 switch (o->op_type) {
5463 badthing = "a SCALAR";
5466 badthing = "an ARRAY";
5469 badthing = "a HASH";
5477 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
5481 * This is a little tricky. We only want to add the symbol if we
5482 * didn't add it in the lexer. Otherwise we get duplicate strict
5483 * warnings. But if we didn't add it in the lexer, we must at
5484 * least pretend like we wanted to add it even if it existed before,
5485 * or we get possible typo warnings. OPpCONST_ENTERED says
5486 * whether the lexer already added THIS instance of this symbol.
5488 iscv = (o->op_type == OP_RV2CV) * 2;
5490 gv = gv_fetchsv(kidsv,
5491 iscv | !(kid->op_private & OPpCONST_ENTERED),
5494 : o->op_type == OP_RV2SV
5496 : o->op_type == OP_RV2AV
5498 : o->op_type == OP_RV2HV
5501 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5503 kid->op_type = OP_GV;
5504 SvREFCNT_dec(kid->op_sv);
5506 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5507 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5508 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
5510 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc_simple_NN(gv));
5512 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
5514 kid->op_private = 0;
5515 kid->op_ppaddr = PL_ppaddr[OP_GV];
5522 Perl_ck_ftst(pTHX_ OP *o)
5525 const I32 type = o->op_type;
5527 if (o->op_flags & OPf_REF) {
5530 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5531 SVOP * const kid = (SVOP*)cUNOPo->op_first;
5533 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5534 OP * const newop = newGVOP(type, OPf_REF,
5535 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
5541 if ((PL_hints & HINT_FILETEST_ACCESS) &&
5542 OP_IS_FILETEST_ACCESS(o))
5543 o->op_private |= OPpFT_ACCESS;
5545 if (PL_check[kid->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst)
5546 && kid->op_type != OP_STAT && kid->op_type != OP_LSTAT)
5547 o->op_private |= OPpFT_STACKED;
5551 if (type == OP_FTTTY)
5552 o = newGVOP(type, OPf_REF, PL_stdingv);
5554 o = newUNOP(type, 0, newDEFSVOP());
5560 Perl_ck_fun(pTHX_ OP *o)
5563 const int type = o->op_type;
5564 register I32 oa = PL_opargs[type] >> OASHIFT;
5566 if (o->op_flags & OPf_STACKED) {
5567 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5570 return no_fh_allowed(o);
5573 if (o->op_flags & OPf_KIDS) {
5574 OP **tokid = &cLISTOPo->op_first;
5575 register OP *kid = cLISTOPo->op_first;
5579 if (kid->op_type == OP_PUSHMARK ||
5580 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5582 tokid = &kid->op_sibling;
5583 kid = kid->op_sibling;
5585 if (!kid && PL_opargs[type] & OA_DEFGV)
5586 *tokid = kid = newDEFSVOP();
5590 sibl = kid->op_sibling;
5593 /* list seen where single (scalar) arg expected? */
5594 if (numargs == 1 && !(oa >> 4)
5595 && kid->op_type == OP_LIST && type != OP_SCALAR)
5597 return too_many_arguments(o,PL_op_desc[type]);
5610 if ((type == OP_PUSH || type == OP_UNSHIFT)
5611 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5612 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5613 "Useless use of %s with no values",
5616 if (kid->op_type == OP_CONST &&
5617 (kid->op_private & OPpCONST_BARE))
5619 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
5620 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
5621 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5622 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5623 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
5624 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
5627 kid->op_sibling = sibl;
5630 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5631 bad_type(numargs, "array", PL_op_desc[type], kid);
5635 if (kid->op_type == OP_CONST &&
5636 (kid->op_private & OPpCONST_BARE))
5638 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
5639 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
5640 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5641 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5642 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
5643 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
5646 kid->op_sibling = sibl;
5649 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5650 bad_type(numargs, "hash", PL_op_desc[type], kid);
5655 OP * const newop = newUNOP(OP_NULL, 0, kid);
5656 kid->op_sibling = 0;
5658 newop->op_next = newop;
5660 kid->op_sibling = sibl;
5665 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5666 if (kid->op_type == OP_CONST &&
5667 (kid->op_private & OPpCONST_BARE))
5669 OP * const newop = newGVOP(OP_GV, 0,
5670 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
5671 if (!(o->op_private & 1) && /* if not unop */
5672 kid == cLISTOPo->op_last)
5673 cLISTOPo->op_last = newop;
5677 else if (kid->op_type == OP_READLINE) {
5678 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5679 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5682 I32 flags = OPf_SPECIAL;
5686 /* is this op a FH constructor? */
5687 if (is_handle_constructor(o,numargs)) {
5688 const char *name = NULL;
5692 /* Set a flag to tell rv2gv to vivify
5693 * need to "prove" flag does not mean something
5694 * else already - NI-S 1999/05/07
5697 if (kid->op_type == OP_PADSV) {
5698 name = PAD_COMPNAME_PV(kid->op_targ);
5699 /* SvCUR of a pad namesv can't be trusted
5700 * (see PL_generation), so calc its length
5706 else if (kid->op_type == OP_RV2SV
5707 && kUNOP->op_first->op_type == OP_GV)
5709 GV * const gv = cGVOPx_gv(kUNOP->op_first);
5711 len = GvNAMELEN(gv);
5713 else if (kid->op_type == OP_AELEM
5714 || kid->op_type == OP_HELEM)
5716 OP *op = ((BINOP*)kid)->op_first;
5720 const char * const a =
5721 kid->op_type == OP_AELEM ?
5723 if (((op->op_type == OP_RV2AV) ||
5724 (op->op_type == OP_RV2HV)) &&
5725 (op = ((UNOP*)op)->op_first) &&
5726 (op->op_type == OP_GV)) {
5727 /* packagevar $a[] or $h{} */
5728 GV * const gv = cGVOPx_gv(op);
5736 else if (op->op_type == OP_PADAV
5737 || op->op_type == OP_PADHV) {
5738 /* lexicalvar $a[] or $h{} */
5739 const char * const padname =
5740 PAD_COMPNAME_PV(op->op_targ);
5749 name = SvPV_const(tmpstr, len);
5754 name = "__ANONIO__";
5761 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5762 namesv = PAD_SVl(targ);
5763 SvUPGRADE(namesv, SVt_PV);
5765 sv_setpvn(namesv, "$", 1);
5766 sv_catpvn(namesv, name, len);
5769 kid->op_sibling = 0;
5770 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5771 kid->op_targ = targ;
5772 kid->op_private |= priv;
5774 kid->op_sibling = sibl;
5780 mod(scalar(kid), type);
5784 tokid = &kid->op_sibling;
5785 kid = kid->op_sibling;
5787 o->op_private |= numargs;
5789 return too_many_arguments(o,OP_DESC(o));
5792 else if (PL_opargs[type] & OA_DEFGV) {
5794 return newUNOP(type, 0, newDEFSVOP());
5798 while (oa & OA_OPTIONAL)
5800 if (oa && oa != OA_LIST)
5801 return too_few_arguments(o,OP_DESC(o));
5807 Perl_ck_glob(pTHX_ OP *o)
5813 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5814 append_elem(OP_GLOB, o, newDEFSVOP());
5816 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
5817 && GvCVu(gv) && GvIMPORTED_CV(gv)))
5819 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
5822 #if !defined(PERL_EXTERNAL_GLOB)
5823 /* XXX this can be tightened up and made more failsafe. */
5824 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
5827 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5828 newSVpvs("File::Glob"), NULL, NULL, NULL);
5829 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
5830 glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
5831 GvCV(gv) = GvCV(glob_gv);
5832 SvREFCNT_inc_void((SV*)GvCV(gv));
5833 GvIMPORTED_CV_on(gv);
5836 #endif /* PERL_EXTERNAL_GLOB */
5838 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5839 append_elem(OP_GLOB, o,
5840 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5841 o->op_type = OP_LIST;
5842 o->op_ppaddr = PL_ppaddr[OP_LIST];
5843 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5844 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5845 cLISTOPo->op_first->op_targ = 0;
5846 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5847 append_elem(OP_LIST, o,
5848 scalar(newUNOP(OP_RV2CV, 0,
5849 newGVOP(OP_GV, 0, gv)))));
5850 o = newUNOP(OP_NULL, 0, ck_subr(o));
5851 o->op_targ = OP_GLOB; /* hint at what it used to be */
5854 gv = newGVgen("main");
5856 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5862 Perl_ck_grep(pTHX_ OP *o)
5867 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5870 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5871 NewOp(1101, gwop, 1, LOGOP);
5873 if (o->op_flags & OPf_STACKED) {
5876 kid = cLISTOPo->op_first->op_sibling;
5877 if (!cUNOPx(kid)->op_next)
5878 Perl_croak(aTHX_ "panic: ck_grep");
5879 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
5882 kid->op_next = (OP*)gwop;
5883 o->op_flags &= ~OPf_STACKED;
5885 kid = cLISTOPo->op_first->op_sibling;
5886 if (type == OP_MAPWHILE)
5893 kid = cLISTOPo->op_first->op_sibling;
5894 if (kid->op_type != OP_NULL)
5895 Perl_croak(aTHX_ "panic: ck_grep");
5896 kid = kUNOP->op_first;
5898 gwop->op_type = type;
5899 gwop->op_ppaddr = PL_ppaddr[type];
5900 gwop->op_first = listkids(o);
5901 gwop->op_flags |= OPf_KIDS;
5902 gwop->op_other = LINKLIST(kid);
5903 kid->op_next = (OP*)gwop;
5904 offset = pad_findmy("$_");
5905 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
5906 o->op_private = gwop->op_private = 0;
5907 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5910 o->op_private = gwop->op_private = OPpGREP_LEX;
5911 gwop->op_targ = o->op_targ = offset;
5914 kid = cLISTOPo->op_first->op_sibling;
5915 if (!kid || !kid->op_sibling)
5916 return too_few_arguments(o,OP_DESC(o));
5917 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5918 mod(kid, OP_GREPSTART);
5924 Perl_ck_index(pTHX_ OP *o)
5926 if (o->op_flags & OPf_KIDS) {
5927 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5929 kid = kid->op_sibling; /* get past "big" */
5930 if (kid && kid->op_type == OP_CONST)
5931 fbm_compile(((SVOP*)kid)->op_sv, 0);
5937 Perl_ck_lengthconst(pTHX_ OP *o)
5939 /* XXX length optimization goes here */
5944 Perl_ck_lfun(pTHX_ OP *o)
5946 const OPCODE type = o->op_type;
5947 return modkids(ck_fun(o), type);
5951 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5953 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
5954 switch (cUNOPo->op_first->op_type) {
5956 /* This is needed for
5957 if (defined %stash::)
5958 to work. Do not break Tk.
5960 break; /* Globals via GV can be undef */
5962 case OP_AASSIGN: /* Is this a good idea? */
5963 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5964 "defined(@array) is deprecated");
5965 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5966 "\t(Maybe you should just omit the defined()?)\n");
5969 /* This is needed for
5970 if (defined %stash::)
5971 to work. Do not break Tk.
5973 break; /* Globals via GV can be undef */
5975 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5976 "defined(%%hash) is deprecated");
5977 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5978 "\t(Maybe you should just omit the defined()?)\n");
5989 Perl_ck_rfun(pTHX_ OP *o)
5991 const OPCODE type = o->op_type;
5992 return refkids(ck_fun(o), type);
5996 Perl_ck_listiob(pTHX_ OP *o)
6000 kid = cLISTOPo->op_first;
6003 kid = cLISTOPo->op_first;
6005 if (kid->op_type == OP_PUSHMARK)
6006 kid = kid->op_sibling;
6007 if (kid && o->op_flags & OPf_STACKED)
6008 kid = kid->op_sibling;
6009 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6010 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6011 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6012 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6013 cLISTOPo->op_first->op_sibling = kid;
6014 cLISTOPo->op_last = kid;
6015 kid = kid->op_sibling;
6020 append_elem(o->op_type, o, newDEFSVOP());
6026 Perl_ck_say(pTHX_ OP *o)
6029 o->op_type = OP_PRINT;
6030 cLISTOPo->op_last = cLISTOPo->op_last->op_sibling
6031 = newSVOP(OP_CONST, 0, newSVpvs("\n"));
6036 Perl_ck_smartmatch(pTHX_ OP *o)
6039 if (0 == (o->op_flags & OPf_SPECIAL)) {
6040 OP *first = cBINOPo->op_first;
6041 OP *second = first->op_sibling;
6043 /* Implicitly take a reference to an array or hash */
6044 first->op_sibling = NULL;
6045 first = cBINOPo->op_first = ref_array_or_hash(first);
6046 second = first->op_sibling = ref_array_or_hash(second);
6048 /* Implicitly take a reference to a regular expression */
6049 if (first->op_type == OP_MATCH) {
6050 first->op_type = OP_QR;
6051 first->op_ppaddr = PL_ppaddr[OP_QR];
6053 if (second->op_type == OP_MATCH) {
6054 second->op_type = OP_QR;
6055 second->op_ppaddr = PL_ppaddr[OP_QR];
6064 Perl_ck_sassign(pTHX_ OP *o)
6066 OP *kid = cLISTOPo->op_first;
6067 /* has a disposable target? */
6068 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6069 && !(kid->op_flags & OPf_STACKED)
6070 /* Cannot steal the second time! */
6071 && !(kid->op_private & OPpTARGET_MY))
6073 OP * const kkid = kid->op_sibling;
6075 /* Can just relocate the target. */
6076 if (kkid && kkid->op_type == OP_PADSV
6077 && !(kkid->op_private & OPpLVAL_INTRO))
6079 kid->op_targ = kkid->op_targ;
6081 /* Now we do not need PADSV and SASSIGN. */
6082 kid->op_sibling = o->op_sibling; /* NULL */
6083 cLISTOPo->op_first = NULL;
6086 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6094 Perl_ck_match(pTHX_ OP *o)
6097 if (o->op_type != OP_QR && PL_compcv) {
6098 const I32 offset = pad_findmy("$_");
6099 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
6100 o->op_targ = offset;
6101 o->op_private |= OPpTARGET_MY;
6104 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
6105 o->op_private |= OPpRUNTIME;
6110 Perl_ck_method(pTHX_ OP *o)
6112 OP * const kid = cUNOPo->op_first;
6113 if (kid->op_type == OP_CONST) {
6114 SV* sv = kSVOP->op_sv;
6115 const char * const method = SvPVX_const(sv);
6116 if (!(strchr(method, ':') || strchr(method, '\''))) {
6118 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6119 sv = newSVpvn_share(method, SvCUR(sv), 0);
6122 kSVOP->op_sv = NULL;
6124 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6133 Perl_ck_null(pTHX_ OP *o)
6135 PERL_UNUSED_CONTEXT;
6140 Perl_ck_open(pTHX_ OP *o)
6143 HV * const table = GvHV(PL_hintgv);
6145 SV **svp = hv_fetchs(table, "open_IN", FALSE);
6147 const I32 mode = mode_from_discipline(*svp);
6148 if (mode & O_BINARY)
6149 o->op_private |= OPpOPEN_IN_RAW;
6150 else if (mode & O_TEXT)
6151 o->op_private |= OPpOPEN_IN_CRLF;
6154 svp = hv_fetchs(table, "open_OUT", FALSE);
6156 const I32 mode = mode_from_discipline(*svp);
6157 if (mode & O_BINARY)
6158 o->op_private |= OPpOPEN_OUT_RAW;
6159 else if (mode & O_TEXT)
6160 o->op_private |= OPpOPEN_OUT_CRLF;
6163 if (o->op_type == OP_BACKTICK)
6166 /* In case of three-arg dup open remove strictness
6167 * from the last arg if it is a bareword. */
6168 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
6169 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
6173 if ((last->op_type == OP_CONST) && /* The bareword. */
6174 (last->op_private & OPpCONST_BARE) &&
6175 (last->op_private & OPpCONST_STRICT) &&
6176 (oa = first->op_sibling) && /* The fh. */
6177 (oa = oa->op_sibling) && /* The mode. */
6178 (oa->op_type == OP_CONST) &&
6179 SvPOK(((SVOP*)oa)->op_sv) &&
6180 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
6181 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
6182 (last == oa->op_sibling)) /* The bareword. */
6183 last->op_private &= ~OPpCONST_STRICT;
6189 Perl_ck_repeat(pTHX_ OP *o)
6191 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6192 o->op_private |= OPpREPEAT_DOLIST;
6193 cBINOPo->op_first = force_list(cBINOPo->op_first);
6201 Perl_ck_require(pTHX_ OP *o)
6206 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6207 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6209 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6210 SV * const sv = kid->op_sv;
6211 U32 was_readonly = SvREADONLY(sv);
6216 sv_force_normal_flags(sv, 0);
6217 assert(!SvREADONLY(sv));
6224 for (s = SvPVX(sv); *s; s++) {
6225 if (*s == ':' && s[1] == ':') {
6226 const STRLEN len = strlen(s+2)+1;
6228 Move(s+2, s+1, len, char);
6229 SvCUR_set(sv, SvCUR(sv) - 1);
6232 sv_catpvs(sv, ".pm");
6233 SvFLAGS(sv) |= was_readonly;
6237 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
6238 /* handle override, if any */
6239 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
6240 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
6241 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
6242 gv = gvp ? *gvp : NULL;
6246 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6247 OP * const kid = cUNOPo->op_first;
6248 cUNOPo->op_first = 0;
6250 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
6251 append_elem(OP_LIST, kid,
6252 scalar(newUNOP(OP_RV2CV, 0,
6261 Perl_ck_return(pTHX_ OP *o)
6264 if (CvLVALUE(PL_compcv)) {
6266 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6267 mod(kid, OP_LEAVESUBLV);
6273 Perl_ck_select(pTHX_ OP *o)
6277 if (o->op_flags & OPf_KIDS) {
6278 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6279 if (kid && kid->op_sibling) {
6280 o->op_type = OP_SSELECT;
6281 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6283 return fold_constants(o);
6287 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6288 if (kid && kid->op_type == OP_RV2GV)
6289 kid->op_private &= ~HINT_STRICT_REFS;
6294 Perl_ck_shift(pTHX_ OP *o)
6297 const I32 type = o->op_type;
6299 if (!(o->op_flags & OPf_KIDS)) {
6303 argop = newUNOP(OP_RV2AV, 0,
6304 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
6305 return newUNOP(type, 0, scalar(argop));
6307 return scalar(modkids(ck_fun(o), type));
6311 Perl_ck_sort(pTHX_ OP *o)
6316 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0)
6318 HV * const hinthv = GvHV(PL_hintgv);
6320 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
6322 const I32 sorthints = (I32)SvIV(*svp);
6323 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
6324 o->op_private |= OPpSORT_QSORT;
6325 if ((sorthints & HINT_SORT_STABLE) != 0)
6326 o->op_private |= OPpSORT_STABLE;
6331 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6333 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6334 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6336 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6338 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6340 if (kid->op_type == OP_SCOPE) {
6344 else if (kid->op_type == OP_LEAVE) {
6345 if (o->op_type == OP_SORT) {
6346 op_null(kid); /* wipe out leave */
6349 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6350 if (k->op_next == kid)
6352 /* don't descend into loops */
6353 else if (k->op_type == OP_ENTERLOOP
6354 || k->op_type == OP_ENTERITER)
6356 k = cLOOPx(k)->op_lastop;
6361 kid->op_next = 0; /* just disconnect the leave */
6362 k = kLISTOP->op_first;
6367 if (o->op_type == OP_SORT) {
6368 /* provide scalar context for comparison function/block */
6374 o->op_flags |= OPf_SPECIAL;
6376 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6379 firstkid = firstkid->op_sibling;
6382 /* provide list context for arguments */
6383 if (o->op_type == OP_SORT)
6390 S_simplify_sort(pTHX_ OP *o)
6393 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6398 if (!(o->op_flags & OPf_STACKED))
6400 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
6401 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
6402 kid = kUNOP->op_first; /* get past null */
6403 if (kid->op_type != OP_SCOPE)
6405 kid = kLISTOP->op_last; /* get past scope */
6406 switch(kid->op_type) {
6414 k = kid; /* remember this node*/
6415 if (kBINOP->op_first->op_type != OP_RV2SV)
6417 kid = kBINOP->op_first; /* get past cmp */
6418 if (kUNOP->op_first->op_type != OP_GV)
6420 kid = kUNOP->op_first; /* get past rv2sv */
6422 if (GvSTASH(gv) != PL_curstash)
6424 gvname = GvNAME(gv);
6425 if (*gvname == 'a' && gvname[1] == '\0')
6427 else if (*gvname == 'b' && gvname[1] == '\0')
6432 kid = k; /* back to cmp */
6433 if (kBINOP->op_last->op_type != OP_RV2SV)
6435 kid = kBINOP->op_last; /* down to 2nd arg */
6436 if (kUNOP->op_first->op_type != OP_GV)
6438 kid = kUNOP->op_first; /* get past rv2sv */
6440 if (GvSTASH(gv) != PL_curstash)
6442 gvname = GvNAME(gv);
6444 ? !(*gvname == 'a' && gvname[1] == '\0')
6445 : !(*gvname == 'b' && gvname[1] == '\0'))
6447 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6449 o->op_private |= OPpSORT_DESCEND;
6450 if (k->op_type == OP_NCMP)
6451 o->op_private |= OPpSORT_NUMERIC;
6452 if (k->op_type == OP_I_NCMP)
6453 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6454 kid = cLISTOPo->op_first->op_sibling;
6455 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6456 op_free(kid); /* then delete it */
6460 Perl_ck_split(pTHX_ OP *o)
6465 if (o->op_flags & OPf_STACKED)
6466 return no_fh_allowed(o);
6468 kid = cLISTOPo->op_first;
6469 if (kid->op_type != OP_NULL)
6470 Perl_croak(aTHX_ "panic: ck_split");
6471 kid = kid->op_sibling;
6472 op_free(cLISTOPo->op_first);
6473 cLISTOPo->op_first = kid;
6475 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
6476 cLISTOPo->op_last = kid; /* There was only one element previously */
6479 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6480 OP * const sibl = kid->op_sibling;
6481 kid->op_sibling = 0;
6482 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
6483 if (cLISTOPo->op_first == cLISTOPo->op_last)
6484 cLISTOPo->op_last = kid;
6485 cLISTOPo->op_first = kid;
6486 kid->op_sibling = sibl;
6489 kid->op_type = OP_PUSHRE;
6490 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6492 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
6493 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
6494 "Use of /g modifier is meaningless in split");
6497 if (!kid->op_sibling)
6498 append_elem(OP_SPLIT, o, newDEFSVOP());
6500 kid = kid->op_sibling;
6503 if (!kid->op_sibling)
6504 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6506 kid = kid->op_sibling;
6509 if (kid->op_sibling)
6510 return too_many_arguments(o,OP_DESC(o));
6516 Perl_ck_join(pTHX_ OP *o)
6518 const OP * const kid = cLISTOPo->op_first->op_sibling;
6519 if (kid && kid->op_type == OP_MATCH) {
6520 if (ckWARN(WARN_SYNTAX)) {
6521 const REGEXP *re = PM_GETRE(kPMOP);
6522 const char *pmstr = re ? re->precomp : "STRING";
6523 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6524 "/%s/ should probably be written as \"%s\"",
6532 Perl_ck_subr(pTHX_ OP *o)
6535 OP *prev = ((cUNOPo->op_first->op_sibling)
6536 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6537 OP *o2 = prev->op_sibling;
6544 I32 contextclass = 0;
6548 o->op_private |= OPpENTERSUB_HASTARG;
6549 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6550 if (cvop->op_type == OP_RV2CV) {
6552 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6553 op_null(cvop); /* disable rv2cv */
6554 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6555 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6556 GV *gv = cGVOPx_gv(tmpop);
6559 tmpop->op_private |= OPpEARLY_CV;
6562 namegv = CvANON(cv) ? gv : CvGV(cv);
6563 proto = SvPV_nolen((SV*)cv);
6565 if (CvASSERTION(cv)) {
6566 if (PL_hints & HINT_ASSERTING) {
6567 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
6568 o->op_private |= OPpENTERSUB_DB;
6572 if (!(PL_hints & HINT_ASSERTIONSSEEN) && ckWARN(WARN_ASSERTIONS)) {
6573 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
6574 "Impossible to activate assertion call");
6581 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6582 if (o2->op_type == OP_CONST)
6583 o2->op_private &= ~OPpCONST_STRICT;
6584 else if (o2->op_type == OP_LIST) {
6585 OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
6586 if (sib && sib->op_type == OP_CONST)
6587 sib->op_private &= ~OPpCONST_STRICT;
6590 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6591 if (PERLDB_SUB && PL_curstash != PL_debstash)
6592 o->op_private |= OPpENTERSUB_DB;
6593 while (o2 != cvop) {
6597 return too_many_arguments(o, gv_ename(namegv));
6615 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6617 arg == 1 ? "block or sub {}" : "sub {}",
6618 gv_ename(namegv), o2);
6621 /* '*' allows any scalar type, including bareword */
6624 if (o2->op_type == OP_RV2GV)
6625 goto wrapref; /* autoconvert GLOB -> GLOBref */
6626 else if (o2->op_type == OP_CONST)
6627 o2->op_private &= ~OPpCONST_STRICT;
6628 else if (o2->op_type == OP_ENTERSUB) {
6629 /* accidental subroutine, revert to bareword */
6630 OP *gvop = ((UNOP*)o2)->op_first;
6631 if (gvop && gvop->op_type == OP_NULL) {
6632 gvop = ((UNOP*)gvop)->op_first;
6634 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6637 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6638 (gvop = ((UNOP*)gvop)->op_first) &&
6639 gvop->op_type == OP_GV)
6641 GV * const gv = cGVOPx_gv(gvop);
6642 OP * const sibling = o2->op_sibling;
6643 SV * const n = newSVpvs("");
6645 gv_fullname4(n, gv, "", FALSE);
6646 o2 = newSVOP(OP_CONST, 0, n);
6647 prev->op_sibling = o2;
6648 o2->op_sibling = sibling;
6664 if (contextclass++ == 0) {
6665 e = strchr(proto, ']');
6666 if (!e || e == proto)
6675 /* XXX We shouldn't be modifying proto, so we can const proto */
6680 while (*--p != '[');
6681 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
6682 gv_ename(namegv), o2);
6688 if (o2->op_type == OP_RV2GV)
6691 bad_type(arg, "symbol", gv_ename(namegv), o2);
6694 if (o2->op_type == OP_ENTERSUB)
6697 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6700 if (o2->op_type == OP_RV2SV ||
6701 o2->op_type == OP_PADSV ||
6702 o2->op_type == OP_HELEM ||
6703 o2->op_type == OP_AELEM ||
6704 o2->op_type == OP_THREADSV)
6707 bad_type(arg, "scalar", gv_ename(namegv), o2);
6710 if (o2->op_type == OP_RV2AV ||
6711 o2->op_type == OP_PADAV)
6714 bad_type(arg, "array", gv_ename(namegv), o2);
6717 if (o2->op_type == OP_RV2HV ||
6718 o2->op_type == OP_PADHV)
6721 bad_type(arg, "hash", gv_ename(namegv), o2);
6726 OP* const sib = kid->op_sibling;
6727 kid->op_sibling = 0;
6728 o2 = newUNOP(OP_REFGEN, 0, kid);
6729 o2->op_sibling = sib;
6730 prev->op_sibling = o2;
6732 if (contextclass && e) {
6747 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
6748 gv_ename(namegv), cv);
6753 mod(o2, OP_ENTERSUB);
6755 o2 = o2->op_sibling;
6757 if (proto && !optional &&
6758 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6759 return too_few_arguments(o, gv_ename(namegv));
6762 o=newSVOP(OP_CONST, 0, newSViv(0));
6768 Perl_ck_svconst(pTHX_ OP *o)
6770 PERL_UNUSED_CONTEXT;
6771 SvREADONLY_on(cSVOPo->op_sv);
6776 Perl_ck_chdir(pTHX_ OP *o)
6778 if (o->op_flags & OPf_KIDS) {
6779 SVOP *kid = (SVOP*)cUNOPo->op_first;
6781 if (kid && kid->op_type == OP_CONST &&
6782 (kid->op_private & OPpCONST_BARE))
6784 o->op_flags |= OPf_SPECIAL;
6785 kid->op_private &= ~OPpCONST_STRICT;
6792 Perl_ck_trunc(pTHX_ OP *o)
6794 if (o->op_flags & OPf_KIDS) {
6795 SVOP *kid = (SVOP*)cUNOPo->op_first;
6797 if (kid->op_type == OP_NULL)
6798 kid = (SVOP*)kid->op_sibling;
6799 if (kid && kid->op_type == OP_CONST &&
6800 (kid->op_private & OPpCONST_BARE))
6802 o->op_flags |= OPf_SPECIAL;
6803 kid->op_private &= ~OPpCONST_STRICT;
6810 Perl_ck_unpack(pTHX_ OP *o)
6812 OP *kid = cLISTOPo->op_first;
6813 if (kid->op_sibling) {
6814 kid = kid->op_sibling;
6815 if (!kid->op_sibling)
6816 kid->op_sibling = newDEFSVOP();
6822 Perl_ck_substr(pTHX_ OP *o)
6825 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6826 OP *kid = cLISTOPo->op_first;
6828 if (kid->op_type == OP_NULL)
6829 kid = kid->op_sibling;
6831 kid->op_flags |= OPf_MOD;
6837 /* A peephole optimizer. We visit the ops in the order they're to execute.
6838 * See the comments at the top of this file for more details about when
6839 * peep() is called */
6842 Perl_peep(pTHX_ register OP *o)
6845 register OP* oldop = NULL;
6847 if (!o || o->op_opt)
6851 SAVEVPTR(PL_curcop);
6852 for (; o; o = o->op_next) {
6856 switch (o->op_type) {
6860 PL_curcop = ((COP*)o); /* for warnings */
6865 if (cSVOPo->op_private & OPpCONST_STRICT)
6866 no_bareword_allowed(o);
6868 case OP_METHOD_NAMED:
6869 /* Relocate sv to the pad for thread safety.
6870 * Despite being a "constant", the SV is written to,
6871 * for reference counts, sv_upgrade() etc. */
6873 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6874 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6875 /* If op_sv is already a PADTMP then it is being used by
6876 * some pad, so make a copy. */
6877 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6878 SvREADONLY_on(PAD_SVl(ix));
6879 SvREFCNT_dec(cSVOPo->op_sv);
6881 else if (o->op_type == OP_CONST
6882 && cSVOPo->op_sv == &PL_sv_undef) {
6883 /* PL_sv_undef is hack - it's unsafe to store it in the
6884 AV that is the pad, because av_fetch treats values of
6885 PL_sv_undef as a "free" AV entry and will merrily
6886 replace them with a new SV, causing pad_alloc to think
6887 that this pad slot is free. (When, clearly, it is not)
6889 SvOK_off(PAD_SVl(ix));
6890 SvPADTMP_on(PAD_SVl(ix));
6891 SvREADONLY_on(PAD_SVl(ix));
6894 SvREFCNT_dec(PAD_SVl(ix));
6895 SvPADTMP_on(cSVOPo->op_sv);
6896 PAD_SETSV(ix, cSVOPo->op_sv);
6897 /* XXX I don't know how this isn't readonly already. */
6898 SvREADONLY_on(PAD_SVl(ix));
6900 cSVOPo->op_sv = NULL;
6908 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6909 if (o->op_next->op_private & OPpTARGET_MY) {
6910 if (o->op_flags & OPf_STACKED) /* chained concats */
6911 goto ignore_optimization;
6913 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6914 o->op_targ = o->op_next->op_targ;
6915 o->op_next->op_targ = 0;
6916 o->op_private |= OPpTARGET_MY;
6919 op_null(o->op_next);
6921 ignore_optimization:
6925 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6927 break; /* Scalar stub must produce undef. List stub is noop */
6931 if (o->op_targ == OP_NEXTSTATE
6932 || o->op_targ == OP_DBSTATE
6933 || o->op_targ == OP_SETSTATE)
6935 PL_curcop = ((COP*)o);
6937 /* XXX: We avoid setting op_seq here to prevent later calls
6938 to peep() from mistakenly concluding that optimisation
6939 has already occurred. This doesn't fix the real problem,
6940 though (See 20010220.007). AMS 20010719 */
6941 /* op_seq functionality is now replaced by op_opt */
6942 if (oldop && o->op_next) {
6943 oldop->op_next = o->op_next;
6951 if (oldop && o->op_next) {
6952 oldop->op_next = o->op_next;
6960 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
6961 OP* const pop = (o->op_type == OP_PADAV) ?
6962 o->op_next : o->op_next->op_next;
6964 if (pop && pop->op_type == OP_CONST &&
6965 ((PL_op = pop->op_next)) &&
6966 pop->op_next->op_type == OP_AELEM &&
6967 !(pop->op_next->op_private &
6968 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6969 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6974 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
6975 no_bareword_allowed(pop);
6976 if (o->op_type == OP_GV)
6977 op_null(o->op_next);
6978 op_null(pop->op_next);
6980 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6981 o->op_next = pop->op_next->op_next;
6982 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6983 o->op_private = (U8)i;
6984 if (o->op_type == OP_GV) {
6989 o->op_flags |= OPf_SPECIAL;
6990 o->op_type = OP_AELEMFAST;
6996 if (o->op_next->op_type == OP_RV2SV) {
6997 if (!(o->op_next->op_private & OPpDEREF)) {
6998 op_null(o->op_next);
6999 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
7001 o->op_next = o->op_next->op_next;
7002 o->op_type = OP_GVSV;
7003 o->op_ppaddr = PL_ppaddr[OP_GVSV];
7006 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
7007 GV * const gv = cGVOPo_gv;
7008 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
7009 /* XXX could check prototype here instead of just carping */
7010 SV * const sv = sv_newmortal();
7011 gv_efullname3(sv, gv, NULL);
7012 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
7013 "%"SVf"() called too early to check prototype",
7017 else if (o->op_next->op_type == OP_READLINE
7018 && o->op_next->op_next->op_type == OP_CONCAT
7019 && (o->op_next->op_next->op_flags & OPf_STACKED))
7021 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
7022 o->op_type = OP_RCATLINE;
7023 o->op_flags |= OPf_STACKED;
7024 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
7025 op_null(o->op_next->op_next);
7026 op_null(o->op_next);
7043 while (cLOGOP->op_other->op_type == OP_NULL)
7044 cLOGOP->op_other = cLOGOP->op_other->op_next;
7045 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
7051 while (cLOOP->op_redoop->op_type == OP_NULL)
7052 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
7053 peep(cLOOP->op_redoop);
7054 while (cLOOP->op_nextop->op_type == OP_NULL)
7055 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
7056 peep(cLOOP->op_nextop);
7057 while (cLOOP->op_lastop->op_type == OP_NULL)
7058 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
7059 peep(cLOOP->op_lastop);
7066 while (cPMOP->op_pmreplstart &&
7067 cPMOP->op_pmreplstart->op_type == OP_NULL)
7068 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
7069 peep(cPMOP->op_pmreplstart);
7074 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
7075 && ckWARN(WARN_SYNTAX))
7077 if (o->op_next->op_sibling &&
7078 o->op_next->op_sibling->op_type != OP_EXIT &&
7079 o->op_next->op_sibling->op_type != OP_WARN &&
7080 o->op_next->op_sibling->op_type != OP_DIE) {
7081 const line_t oldline = CopLINE(PL_curcop);
7083 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
7084 Perl_warner(aTHX_ packWARN(WARN_EXEC),
7085 "Statement unlikely to be reached");
7086 Perl_warner(aTHX_ packWARN(WARN_EXEC),
7087 "\t(Maybe you meant system() when you said exec()?)\n");
7088 CopLINE_set(PL_curcop, oldline);
7098 const char *key = NULL;
7103 if (((BINOP*)o)->op_last->op_type != OP_CONST)
7106 /* Make the CONST have a shared SV */
7107 svp = cSVOPx_svp(((BINOP*)o)->op_last);
7108 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
7109 key = SvPV_const(sv, keylen);
7110 lexname = newSVpvn_share(key,
7111 SvUTF8(sv) ? -(I32)keylen : keylen,
7117 if ((o->op_private & (OPpLVAL_INTRO)))
7120 rop = (UNOP*)((BINOP*)o)->op_first;
7121 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7123 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7124 if (!SvPAD_TYPED(lexname))
7126 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
7127 if (!fields || !GvHV(*fields))
7129 key = SvPV_const(*svp, keylen);
7130 if (!hv_fetch(GvHV(*fields), key,
7131 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
7133 Perl_croak(aTHX_ "No such class field \"%s\" "
7134 "in variable %s of type %s",
7135 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
7148 SVOP *first_key_op, *key_op;
7150 if ((o->op_private & (OPpLVAL_INTRO))
7151 /* I bet there's always a pushmark... */
7152 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
7153 /* hmmm, no optimization if list contains only one key. */
7155 rop = (UNOP*)((LISTOP*)o)->op_last;
7156 if (rop->op_type != OP_RV2HV)
7158 if (rop->op_first->op_type == OP_PADSV)
7159 /* @$hash{qw(keys here)} */
7160 rop = (UNOP*)rop->op_first;
7162 /* @{$hash}{qw(keys here)} */
7163 if (rop->op_first->op_type == OP_SCOPE
7164 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
7166 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
7172 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
7173 if (!SvPAD_TYPED(lexname))
7175 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
7176 if (!fields || !GvHV(*fields))
7178 /* Again guessing that the pushmark can be jumped over.... */
7179 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
7180 ->op_first->op_sibling;
7181 for (key_op = first_key_op; key_op;
7182 key_op = (SVOP*)key_op->op_sibling) {
7183 if (key_op->op_type != OP_CONST)
7185 svp = cSVOPx_svp(key_op);
7186 key = SvPV_const(*svp, keylen);
7187 if (!hv_fetch(GvHV(*fields), key,
7188 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
7190 Perl_croak(aTHX_ "No such class field \"%s\" "
7191 "in variable %s of type %s",
7192 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
7199 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
7203 /* check that RHS of sort is a single plain array */
7204 OP *oright = cUNOPo->op_first;
7205 if (!oright || oright->op_type != OP_PUSHMARK)
7208 /* reverse sort ... can be optimised. */
7209 if (!cUNOPo->op_sibling) {
7210 /* Nothing follows us on the list. */
7211 OP * const reverse = o->op_next;
7213 if (reverse->op_type == OP_REVERSE &&
7214 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
7215 OP * const pushmark = cUNOPx(reverse)->op_first;
7216 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
7217 && (cUNOPx(pushmark)->op_sibling == o)) {
7218 /* reverse -> pushmark -> sort */
7219 o->op_private |= OPpSORT_REVERSE;
7221 pushmark->op_next = oright->op_next;
7227 /* make @a = sort @a act in-place */
7231 oright = cUNOPx(oright)->op_sibling;
7234 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
7235 oright = cUNOPx(oright)->op_sibling;
7239 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
7240 || oright->op_next != o
7241 || (oright->op_private & OPpLVAL_INTRO)
7245 /* o2 follows the chain of op_nexts through the LHS of the
7246 * assign (if any) to the aassign op itself */
7248 if (!o2 || o2->op_type != OP_NULL)
7251 if (!o2 || o2->op_type != OP_PUSHMARK)
7254 if (o2 && o2->op_type == OP_GV)
7257 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
7258 || (o2->op_private & OPpLVAL_INTRO)
7263 if (!o2 || o2->op_type != OP_NULL)
7266 if (!o2 || o2->op_type != OP_AASSIGN
7267 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
7270 /* check that the sort is the first arg on RHS of assign */
7272 o2 = cUNOPx(o2)->op_first;
7273 if (!o2 || o2->op_type != OP_NULL)
7275 o2 = cUNOPx(o2)->op_first;
7276 if (!o2 || o2->op_type != OP_PUSHMARK)
7278 if (o2->op_sibling != o)
7281 /* check the array is the same on both sides */
7282 if (oleft->op_type == OP_RV2AV) {
7283 if (oright->op_type != OP_RV2AV
7284 || !cUNOPx(oright)->op_first
7285 || cUNOPx(oright)->op_first->op_type != OP_GV
7286 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
7287 cGVOPx_gv(cUNOPx(oright)->op_first)
7291 else if (oright->op_type != OP_PADAV
7292 || oright->op_targ != oleft->op_targ
7296 /* transfer MODishness etc from LHS arg to RHS arg */
7297 oright->op_flags = oleft->op_flags;
7298 o->op_private |= OPpSORT_INPLACE;
7300 /* excise push->gv->rv2av->null->aassign */
7301 o2 = o->op_next->op_next;
7302 op_null(o2); /* PUSHMARK */
7304 if (o2->op_type == OP_GV) {
7305 op_null(o2); /* GV */
7308 op_null(o2); /* RV2AV or PADAV */
7309 o2 = o2->op_next->op_next;
7310 op_null(o2); /* AASSIGN */
7312 o->op_next = o2->op_next;
7318 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
7320 LISTOP *enter, *exlist;
7323 enter = (LISTOP *) o->op_next;
7326 if (enter->op_type == OP_NULL) {
7327 enter = (LISTOP *) enter->op_next;
7331 /* for $a (...) will have OP_GV then OP_RV2GV here.
7332 for (...) just has an OP_GV. */
7333 if (enter->op_type == OP_GV) {
7334 gvop = (OP *) enter;
7335 enter = (LISTOP *) enter->op_next;
7338 if (enter->op_type == OP_RV2GV) {
7339 enter = (LISTOP *) enter->op_next;
7345 if (enter->op_type != OP_ENTERITER)
7348 iter = enter->op_next;
7349 if (!iter || iter->op_type != OP_ITER)
7352 expushmark = enter->op_first;
7353 if (!expushmark || expushmark->op_type != OP_NULL
7354 || expushmark->op_targ != OP_PUSHMARK)
7357 exlist = (LISTOP *) expushmark->op_sibling;
7358 if (!exlist || exlist->op_type != OP_NULL
7359 || exlist->op_targ != OP_LIST)
7362 if (exlist->op_last != o) {
7363 /* Mmm. Was expecting to point back to this op. */
7366 theirmark = exlist->op_first;
7367 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
7370 if (theirmark->op_sibling != o) {
7371 /* There's something between the mark and the reverse, eg
7372 for (1, reverse (...))
7377 ourmark = ((LISTOP *)o)->op_first;
7378 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
7381 ourlast = ((LISTOP *)o)->op_last;
7382 if (!ourlast || ourlast->op_next != o)
7385 rv2av = ourmark->op_sibling;
7386 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
7387 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
7388 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
7389 /* We're just reversing a single array. */
7390 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
7391 enter->op_flags |= OPf_STACKED;
7394 /* We don't have control over who points to theirmark, so sacrifice
7396 theirmark->op_next = ourmark->op_next;
7397 theirmark->op_flags = ourmark->op_flags;
7398 ourlast->op_next = gvop ? gvop : (OP *) enter;
7401 enter->op_private |= OPpITER_REVERSED;
7402 iter->op_private |= OPpITER_REVERSED;
7409 UNOP *refgen, *rv2cv;
7412 /* I do not understand this, but if o->op_opt isn't set to 1,
7413 various tests in ext/B/t/bytecode.t fail with no readily
7419 if ((o->op_flags && OPf_WANT) != OPf_WANT_VOID)
7422 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
7425 rv2gv = ((BINOP *)o)->op_last;
7426 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
7429 refgen = (UNOP *)((BINOP *)o)->op_first;
7431 if (!refgen || refgen->op_type != OP_REFGEN)
7434 exlist = (LISTOP *)refgen->op_first;
7435 if (!exlist || exlist->op_type != OP_NULL
7436 || exlist->op_targ != OP_LIST)
7439 if (exlist->op_first->op_type != OP_PUSHMARK)
7442 rv2cv = (UNOP*)exlist->op_last;
7444 if (rv2cv->op_type != OP_RV2CV)
7447 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
7448 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
7449 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
7451 o->op_private |= OPpASSIGN_CV_TO_GV;
7452 rv2gv->op_private |= OPpDONT_INIT_GV;
7453 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
7469 Perl_custom_op_name(pTHX_ const OP* o)
7472 const IV index = PTR2IV(o->op_ppaddr);
7476 if (!PL_custom_op_names) /* This probably shouldn't happen */
7477 return (char *)PL_op_name[OP_CUSTOM];
7479 keysv = sv_2mortal(newSViv(index));
7481 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
7483 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
7485 return SvPV_nolen(HeVAL(he));
7489 Perl_custom_op_desc(pTHX_ const OP* o)
7492 const IV index = PTR2IV(o->op_ppaddr);
7496 if (!PL_custom_op_descs)
7497 return (char *)PL_op_desc[OP_CUSTOM];
7499 keysv = sv_2mortal(newSViv(index));
7501 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
7503 return (char *)PL_op_desc[OP_CUSTOM];
7505 return SvPV_nolen(HeVAL(he));
7510 /* Efficient sub that returns a constant scalar value. */
7512 const_sv_xsub(pTHX_ CV* cv)
7519 Perl_croak(aTHX_ "usage: %s::%s()",
7520 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7524 ST(0) = (SV*)XSANY.any_ptr;
7530 * c-indentation-style: bsd
7532 * indent-tabs-mode: t
7535 * ex: set ts=8 sts=4 sw=4 noet: