3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * "You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
13 * our Mr. Bilbo's first cousin on the mother's side (her mother being the
14 * youngest of the Old Took's daughters); and Mr. Drogo was his second
15 * cousin. So Mr. Frodo is his first *and* second cousin, once removed
16 * either way, as the saying is, if you follow me." --the Gaffer
19 /* This file contains the functions that create, manipulate and optimize
20 * the OP structures that hold a compiled perl program.
22 * A Perl program is compiled into a tree of OPs. Each op contains
23 * structural pointers (eg to its siblings and the next op in the
24 * execution sequence), a pointer to the function that would execute the
25 * op, plus any data specific to that op. For example, an OP_CONST op
26 * points to the pp_const() function and to an SV containing the constant
27 * value. When pp_const() is executed, its job is to push that SV onto the
30 * OPs are mainly created by the newFOO() functions, which are mainly
31 * called from the parser (in perly.y) as the code is parsed. For example
32 * the Perl code $a + $b * $c would cause the equivalent of the following
33 * to be called (oversimplifying a bit):
35 * newBINOP(OP_ADD, flags,
37 * newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
40 * Note that during the build of miniperl, a temporary copy of this file
41 * is made, called opmini.c.
45 Perl's compiler is essentially a 3-pass compiler with interleaved phases:
49 An execution-order pass
51 The bottom-up pass is represented by all the "newOP" routines and
52 the ck_ routines. The bottom-upness is actually driven by yacc.
53 So at the point that a ck_ routine fires, we have no idea what the
54 context is, either upward in the syntax tree, or either forward or
55 backward in the execution order. (The bottom-up parser builds that
56 part of the execution order it knows about, but if you follow the "next"
57 links around, you'll find it's actually a closed loop through the
60 Whenever the bottom-up parser gets to a node that supplies context to
61 its components, it invokes that portion of the top-down pass that applies
62 to that part of the subtree (and marks the top node as processed, so
63 if a node further up supplies context, it doesn't have to take the
64 plunge again). As a particular subcase of this, as the new node is
65 built, it takes all the closed execution loops of its subcomponents
66 and links them into a new closed loop for the higher level node. But
67 it's still not the real execution order.
69 The actual execution order is not known till we get a grammar reduction
70 to a top-level unit like a subroutine or file that will be called by
71 "name" rather than via a "next" pointer. At that point, we can call
72 into peep() to do that code's portion of the 3rd pass. It has to be
73 recursive, but it's recursive on basic blocks, not on tree nodes.
81 #define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
83 #if defined(PL_OP_SLAB_ALLOC)
85 #ifndef PERL_SLAB_SIZE
86 #define PERL_SLAB_SIZE 2048
90 Perl_Slab_Alloc(pTHX_ int m, size_t sz)
93 * To make incrementing use count easy PL_OpSlab is an I32 *
94 * To make inserting the link to slab PL_OpPtr is I32 **
95 * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
96 * Add an overhead for pointer to slab and round up as a number of pointers
98 sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
99 if ((PL_OpSpace -= sz) < 0) {
100 PL_OpPtr = (I32 **) PerlMemShared_malloc(PERL_SLAB_SIZE*sizeof(I32*));
104 Zero(PL_OpPtr,PERL_SLAB_SIZE,I32 **);
105 /* We reserve the 0'th I32 sized chunk as a use count */
106 PL_OpSlab = (I32 *) PL_OpPtr;
107 /* Reduce size by the use count word, and by the size we need.
108 * Latter is to mimic the '-=' in the if() above
110 PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
111 /* Allocation pointer starts at the top.
112 Theory: because we build leaves before trunk allocating at end
113 means that at run time access is cache friendly upward
115 PL_OpPtr += PERL_SLAB_SIZE;
117 assert( PL_OpSpace >= 0 );
118 /* Move the allocation pointer down */
120 assert( PL_OpPtr > (I32 **) PL_OpSlab );
121 *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */
122 (*PL_OpSlab)++; /* Increment use count of slab */
123 assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
124 assert( *PL_OpSlab > 0 );
125 return (void *)(PL_OpPtr + 1);
129 Perl_Slab_Free(pTHX_ void *op)
131 I32 * const * const ptr = (I32 **) op;
132 I32 * const slab = ptr[-1];
133 assert( ptr-1 > (I32 **) slab );
134 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
136 if (--(*slab) == 0) {
138 # define PerlMemShared PerlMem
141 PerlMemShared_free(slab);
142 if (slab == PL_OpSlab) {
149 * In the following definition, the ", Nullop" is just to make the compiler
150 * think the expression is of the right type: croak actually does a Siglongjmp.
152 #define CHECKOP(type,o) \
153 ((PL_op_mask && PL_op_mask[type]) \
154 ? ( op_free((OP*)o), \
155 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
157 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
159 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
162 S_gv_ename(pTHX_ GV *gv)
164 SV* const tmpsv = sv_newmortal();
165 gv_efullname3(tmpsv, gv, Nullch);
166 return SvPV_nolen_const(tmpsv);
170 S_no_fh_allowed(pTHX_ OP *o)
172 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
178 S_too_few_arguments(pTHX_ OP *o, const char *name)
180 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
185 S_too_many_arguments(pTHX_ OP *o, const char *name)
187 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
192 S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid)
194 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
195 (int)n, name, t, OP_DESC(kid)));
199 S_no_bareword_allowed(pTHX_ const OP *o)
201 qerror(Perl_mess(aTHX_
202 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
206 /* "register" allocation */
209 Perl_allocmy(pTHX_ char *name)
213 /* complain about "my $<special_var>" etc etc */
215 !(PL_in_my == KEY_our ||
217 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
218 (name[1] == '_' && (*name == '$' || name[2]))))
220 /* name[2] is true if strlen(name) > 2 */
221 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
222 /* 1999-02-27 mjd@plover.com */
224 p = strchr(name, '\0');
225 /* The next block assumes the buffer is at least 205 chars
226 long. At present, it's always at least 256 chars. */
228 strcpy(name+200, "...");
234 /* Move everything else down one character */
235 for (; p-name > 2; p--)
237 name[2] = toCTRL(name[1]);
240 yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
243 /* check for duplicate declaration */
245 (bool)(PL_in_my == KEY_our),
246 (PL_curstash ? PL_curstash : PL_defstash)
249 if (PL_in_my_stash && *name != '$') {
250 yyerror(Perl_form(aTHX_
251 "Can't declare class for non-scalar %s in \"%s\"",
252 name, PL_in_my == KEY_our ? "our" : "my"));
255 /* allocate a spare slot and store the name in that slot */
257 off = pad_add_name(name,
260 /* $_ is always in main::, even with our */
261 ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
272 Perl_op_free(pTHX_ OP *o)
278 if (!o || o->op_static)
281 if (o->op_private & OPpREFCOUNTED) {
282 switch (o->op_type) {
290 refcnt = OpREFCNT_dec(o);
300 if (o->op_flags & OPf_KIDS) {
301 register OP *kid, *nextkid;
302 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
303 nextkid = kid->op_sibling; /* Get before next freeing kid */
309 type = (OPCODE)o->op_targ;
311 /* COP* is not cleared by op_clear() so that we may track line
312 * numbers etc even after null() */
313 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
318 #ifdef DEBUG_LEAKING_SCALARS
325 Perl_op_clear(pTHX_ OP *o)
329 switch (o->op_type) {
330 case OP_NULL: /* Was holding old type, if any. */
331 case OP_ENTEREVAL: /* Was holding hints. */
335 if (!(o->op_flags & OPf_REF)
336 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
342 if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
343 /* not an OP_PADAV replacement */
345 if (cPADOPo->op_padix > 0) {
346 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
347 * may still exist on the pad */
348 pad_swipe(cPADOPo->op_padix, TRUE);
349 cPADOPo->op_padix = 0;
352 SvREFCNT_dec(cSVOPo->op_sv);
353 cSVOPo->op_sv = Nullsv;
357 case OP_METHOD_NAMED:
359 SvREFCNT_dec(cSVOPo->op_sv);
360 cSVOPo->op_sv = Nullsv;
363 Even if op_clear does a pad_free for the target of the op,
364 pad_free doesn't actually remove the sv that exists in the pad;
365 instead it lives on. This results in that it could be reused as
366 a target later on when the pad was reallocated.
369 pad_swipe(o->op_targ,1);
378 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
382 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
383 SvREFCNT_dec(cSVOPo->op_sv);
384 cSVOPo->op_sv = Nullsv;
387 Safefree(cPVOPo->op_pv);
388 cPVOPo->op_pv = Nullch;
392 op_free(cPMOPo->op_pmreplroot);
396 if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) {
397 /* No GvIN_PAD_off here, because other references may still
398 * exist on the pad */
399 pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot), TRUE);
402 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
409 HV * const pmstash = PmopSTASH(cPMOPo);
410 if (pmstash && !SvIS_FREED(pmstash)) {
411 MAGIC * const mg = mg_find((SV*)pmstash, PERL_MAGIC_symtab);
413 PMOP *pmop = (PMOP*) mg->mg_obj;
414 PMOP *lastpmop = NULL;
416 if (cPMOPo == pmop) {
418 lastpmop->op_pmnext = pmop->op_pmnext;
420 mg->mg_obj = (SV*) pmop->op_pmnext;
424 pmop = pmop->op_pmnext;
428 PmopSTASH_free(cPMOPo);
430 cPMOPo->op_pmreplroot = Nullop;
431 /* we use the "SAFE" version of the PM_ macros here
432 * since sv_clean_all might release some PMOPs
433 * after PL_regex_padav has been cleared
434 * and the clearing of PL_regex_padav needs to
435 * happen before sv_clean_all
437 ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
438 PM_SETRE_SAFE(cPMOPo, (REGEXP*)NULL);
440 if(PL_regex_pad) { /* We could be in destruction */
441 av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
442 SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
443 PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
450 if (o->op_targ > 0) {
451 pad_free(o->op_targ);
457 S_cop_free(pTHX_ COP* cop)
459 Safefree(cop->cop_label); /* FIXME: treaddead ??? */
462 if (! specialWARN(cop->cop_warnings))
463 SvREFCNT_dec(cop->cop_warnings);
464 if (! specialCopIO(cop->cop_io)) {
468 char *s = SvPV(cop->cop_io,len);
469 Perl_warn(aTHX_ "io='%.*s'",(int) len,s); /* ??? --jhi */
472 SvREFCNT_dec(cop->cop_io);
478 Perl_op_null(pTHX_ OP *o)
481 if (o->op_type == OP_NULL)
484 o->op_targ = o->op_type;
485 o->op_type = OP_NULL;
486 o->op_ppaddr = PL_ppaddr[OP_NULL];
490 Perl_op_refcnt_lock(pTHX)
497 Perl_op_refcnt_unlock(pTHX)
503 /* Contextualizers */
505 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
508 Perl_linklist(pTHX_ OP *o)
514 /* establish postfix order */
515 if (cUNOPo->op_first) {
517 o->op_next = LINKLIST(cUNOPo->op_first);
518 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
520 kid->op_next = LINKLIST(kid->op_sibling);
532 Perl_scalarkids(pTHX_ OP *o)
534 if (o && o->op_flags & OPf_KIDS) {
536 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
543 S_scalarboolean(pTHX_ OP *o)
545 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
546 if (ckWARN(WARN_SYNTAX)) {
547 const line_t oldline = CopLINE(PL_curcop);
549 if (PL_copline != NOLINE)
550 CopLINE_set(PL_curcop, PL_copline);
551 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
552 CopLINE_set(PL_curcop, oldline);
559 Perl_scalar(pTHX_ OP *o)
564 /* assumes no premature commitment */
565 if (!o || PL_error_count || (o->op_flags & OPf_WANT)
566 || o->op_type == OP_RETURN)
571 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
573 switch (o->op_type) {
575 scalar(cBINOPo->op_first);
580 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
584 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
585 if (!kPMOP->op_pmreplroot)
586 deprecate_old("implicit split to @_");
594 if (o->op_flags & OPf_KIDS) {
595 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
601 kid = cLISTOPo->op_first;
603 while ((kid = kid->op_sibling)) {
609 WITH_THR(PL_curcop = &PL_compiling);
614 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
620 WITH_THR(PL_curcop = &PL_compiling);
623 if (ckWARN(WARN_VOID))
624 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
630 Perl_scalarvoid(pTHX_ OP *o)
634 const char* useless = 0;
638 if (o->op_type == OP_NEXTSTATE
639 || o->op_type == OP_SETSTATE
640 || o->op_type == OP_DBSTATE
641 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
642 || o->op_targ == OP_SETSTATE
643 || o->op_targ == OP_DBSTATE)))
644 PL_curcop = (COP*)o; /* for warning below */
646 /* assumes no premature commitment */
647 want = o->op_flags & OPf_WANT;
648 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
649 || o->op_type == OP_RETURN)
654 if ((o->op_private & OPpTARGET_MY)
655 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
657 return scalar(o); /* As if inside SASSIGN */
660 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
662 switch (o->op_type) {
664 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
668 if (o->op_flags & OPf_STACKED)
672 if (o->op_private == 4)
744 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
745 useless = OP_DESC(o);
749 kid = cUNOPo->op_first;
750 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
751 kid->op_type != OP_TRANS) {
754 useless = "negative pattern binding (!~)";
761 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
762 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
763 useless = "a variable";
768 if (cSVOPo->op_private & OPpCONST_STRICT)
769 no_bareword_allowed(o);
771 if (ckWARN(WARN_VOID)) {
772 useless = "a constant";
773 /* don't warn on optimised away booleans, eg
774 * use constant Foo, 5; Foo || print; */
775 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
777 /* the constants 0 and 1 are permitted as they are
778 conventionally used as dummies in constructs like
779 1 while some_condition_with_side_effects; */
780 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
782 else if (SvPOK(sv)) {
783 /* perl4's way of mixing documentation and code
784 (before the invention of POD) was based on a
785 trick to mix nroff and perl code. The trick was
786 built upon these three nroff macros being used in
787 void context. The pink camel has the details in
788 the script wrapman near page 319. */
789 if (strnEQ(SvPVX_const(sv), "di", 2) ||
790 strnEQ(SvPVX_const(sv), "ds", 2) ||
791 strnEQ(SvPVX_const(sv), "ig", 2))
796 op_null(o); /* don't execute or even remember it */
800 o->op_type = OP_PREINC; /* pre-increment is faster */
801 o->op_ppaddr = PL_ppaddr[OP_PREINC];
805 o->op_type = OP_PREDEC; /* pre-decrement is faster */
806 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
810 o->op_type = OP_I_PREINC; /* pre-increment is faster */
811 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
815 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
816 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
825 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
830 if (o->op_flags & OPf_STACKED)
837 if (!(o->op_flags & OPf_KIDS))
848 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
855 /* all requires must return a boolean value */
856 o->op_flags &= ~OPf_WANT;
861 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
862 if (!kPMOP->op_pmreplroot)
863 deprecate_old("implicit split to @_");
867 if (useless && ckWARN(WARN_VOID))
868 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
873 Perl_listkids(pTHX_ OP *o)
875 if (o && o->op_flags & OPf_KIDS) {
877 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
884 Perl_list(pTHX_ OP *o)
889 /* assumes no premature commitment */
890 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
891 || o->op_type == OP_RETURN)
896 if ((o->op_private & OPpTARGET_MY)
897 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
899 return o; /* As if inside SASSIGN */
902 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
904 switch (o->op_type) {
907 list(cBINOPo->op_first);
912 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
920 if (!(o->op_flags & OPf_KIDS))
922 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
923 list(cBINOPo->op_first);
924 return gen_constant_list(o);
931 kid = cLISTOPo->op_first;
933 while ((kid = kid->op_sibling)) {
939 WITH_THR(PL_curcop = &PL_compiling);
943 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
949 WITH_THR(PL_curcop = &PL_compiling);
952 /* all requires must return a boolean value */
953 o->op_flags &= ~OPf_WANT;
960 Perl_scalarseq(pTHX_ OP *o)
963 if (o->op_type == OP_LINESEQ ||
964 o->op_type == OP_SCOPE ||
965 o->op_type == OP_LEAVE ||
966 o->op_type == OP_LEAVETRY)
969 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
970 if (kid->op_sibling) {
974 PL_curcop = &PL_compiling;
976 o->op_flags &= ~OPf_PARENS;
977 if (PL_hints & HINT_BLOCK_SCOPE)
978 o->op_flags |= OPf_PARENS;
981 o = newOP(OP_STUB, 0);
986 S_modkids(pTHX_ OP *o, I32 type)
988 if (o && o->op_flags & OPf_KIDS) {
990 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
996 /* Propagate lvalue ("modifiable") context to an op and its children.
997 * 'type' represents the context type, roughly based on the type of op that
998 * would do the modifying, although local() is represented by OP_NULL.
999 * It's responsible for detecting things that can't be modified, flag
1000 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
1001 * might have to vivify a reference in $x), and so on.
1003 * For example, "$a+1 = 2" would cause mod() to be called with o being
1004 * OP_ADD and type being OP_SASSIGN, and would output an error.
1008 Perl_mod(pTHX_ OP *o, I32 type)
1012 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1015 if (!o || PL_error_count)
1018 if ((o->op_private & OPpTARGET_MY)
1019 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1024 switch (o->op_type) {
1030 if (!(o->op_private & (OPpCONST_ARYBASE)))
1032 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1033 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
1037 SAVEI32(PL_compiling.cop_arybase);
1038 PL_compiling.cop_arybase = 0;
1040 else if (type == OP_REFGEN)
1043 Perl_croak(aTHX_ "That use of $[ is unsupported");
1046 if (o->op_flags & OPf_PARENS)
1050 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1051 !(o->op_flags & OPf_STACKED)) {
1052 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1053 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1054 assert(cUNOPo->op_first->op_type == OP_NULL);
1055 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1058 else if (o->op_private & OPpENTERSUB_NOMOD)
1060 else { /* lvalue subroutine call */
1061 o->op_private |= OPpLVAL_INTRO;
1062 PL_modcount = RETURN_UNLIMITED_NUMBER;
1063 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1064 /* Backward compatibility mode: */
1065 o->op_private |= OPpENTERSUB_INARGS;
1068 else { /* Compile-time error message: */
1069 OP *kid = cUNOPo->op_first;
1073 if (kid->op_type == OP_PUSHMARK)
1075 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1077 "panic: unexpected lvalue entersub "
1078 "args: type/targ %ld:%"UVuf,
1079 (long)kid->op_type, (UV)kid->op_targ);
1080 kid = kLISTOP->op_first;
1082 while (kid->op_sibling)
1083 kid = kid->op_sibling;
1084 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1086 if (kid->op_type == OP_METHOD_NAMED
1087 || kid->op_type == OP_METHOD)
1091 NewOp(1101, newop, 1, UNOP);
1092 newop->op_type = OP_RV2CV;
1093 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1094 newop->op_first = Nullop;
1095 newop->op_next = (OP*)newop;
1096 kid->op_sibling = (OP*)newop;
1097 newop->op_private |= OPpLVAL_INTRO;
1101 if (kid->op_type != OP_RV2CV)
1103 "panic: unexpected lvalue entersub "
1104 "entry via type/targ %ld:%"UVuf,
1105 (long)kid->op_type, (UV)kid->op_targ);
1106 kid->op_private |= OPpLVAL_INTRO;
1107 break; /* Postpone until runtime */
1111 kid = kUNOP->op_first;
1112 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1113 kid = kUNOP->op_first;
1114 if (kid->op_type == OP_NULL)
1116 "Unexpected constant lvalue entersub "
1117 "entry via type/targ %ld:%"UVuf,
1118 (long)kid->op_type, (UV)kid->op_targ);
1119 if (kid->op_type != OP_GV) {
1120 /* Restore RV2CV to check lvalueness */
1122 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1123 okid->op_next = kid->op_next;
1124 kid->op_next = okid;
1127 okid->op_next = Nullop;
1128 okid->op_type = OP_RV2CV;
1130 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1131 okid->op_private |= OPpLVAL_INTRO;
1135 cv = GvCV(kGVOP_gv);
1145 /* grep, foreach, subcalls, refgen */
1146 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1148 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1149 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1151 : (o->op_type == OP_ENTERSUB
1152 ? "non-lvalue subroutine call"
1154 type ? PL_op_desc[type] : "local"));
1168 case OP_RIGHT_SHIFT:
1177 if (!(o->op_flags & OPf_STACKED))
1184 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1190 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1191 PL_modcount = RETURN_UNLIMITED_NUMBER;
1192 return o; /* Treat \(@foo) like ordinary list. */
1196 if (scalar_mod_type(o, type))
1198 ref(cUNOPo->op_first, o->op_type);
1202 if (type == OP_LEAVESUBLV)
1203 o->op_private |= OPpMAYBE_LVSUB;
1209 PL_modcount = RETURN_UNLIMITED_NUMBER;
1212 ref(cUNOPo->op_first, o->op_type);
1217 PL_hints |= HINT_BLOCK_SCOPE;
1232 PL_modcount = RETURN_UNLIMITED_NUMBER;
1233 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1234 return o; /* Treat \(@foo) like ordinary list. */
1235 if (scalar_mod_type(o, type))
1237 if (type == OP_LEAVESUBLV)
1238 o->op_private |= OPpMAYBE_LVSUB;
1242 if (!type) /* local() */
1243 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1244 PAD_COMPNAME_PV(o->op_targ));
1252 if (type != OP_SASSIGN)
1256 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1261 if (type == OP_LEAVESUBLV)
1262 o->op_private |= OPpMAYBE_LVSUB;
1264 pad_free(o->op_targ);
1265 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1266 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1267 if (o->op_flags & OPf_KIDS)
1268 mod(cBINOPo->op_first->op_sibling, type);
1273 ref(cBINOPo->op_first, o->op_type);
1274 if (type == OP_ENTERSUB &&
1275 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1276 o->op_private |= OPpLVAL_DEFER;
1277 if (type == OP_LEAVESUBLV)
1278 o->op_private |= OPpMAYBE_LVSUB;
1288 if (o->op_flags & OPf_KIDS)
1289 mod(cLISTOPo->op_last, type);
1294 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1296 else if (!(o->op_flags & OPf_KIDS))
1298 if (o->op_targ != OP_LIST) {
1299 mod(cBINOPo->op_first, type);
1305 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1310 if (type != OP_LEAVESUBLV)
1312 break; /* mod()ing was handled by ck_return() */
1315 /* [20011101.069] File test operators interpret OPf_REF to mean that
1316 their argument is a filehandle; thus \stat(".") should not set
1318 if (type == OP_REFGEN &&
1319 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1322 if (type != OP_LEAVESUBLV)
1323 o->op_flags |= OPf_MOD;
1325 if (type == OP_AASSIGN || type == OP_SASSIGN)
1326 o->op_flags |= OPf_SPECIAL|OPf_REF;
1327 else if (!type) { /* local() */
1330 o->op_private |= OPpLVAL_INTRO;
1331 o->op_flags &= ~OPf_SPECIAL;
1332 PL_hints |= HINT_BLOCK_SCOPE;
1337 if (ckWARN(WARN_SYNTAX)) {
1338 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1339 "Useless localization of %s", OP_DESC(o));
1343 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1344 && type != OP_LEAVESUBLV)
1345 o->op_flags |= OPf_REF;
1350 S_scalar_mod_type(pTHX_ const OP *o, I32 type)
1354 if (o->op_type == OP_RV2GV)
1378 case OP_RIGHT_SHIFT:
1397 S_is_handle_constructor(pTHX_ const OP *o, I32 numargs)
1399 switch (o->op_type) {
1407 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1420 Perl_refkids(pTHX_ OP *o, I32 type)
1422 if (o && o->op_flags & OPf_KIDS) {
1424 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1431 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
1436 if (!o || PL_error_count)
1439 switch (o->op_type) {
1441 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1442 !(o->op_flags & OPf_STACKED)) {
1443 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1444 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1445 assert(cUNOPo->op_first->op_type == OP_NULL);
1446 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1447 o->op_flags |= OPf_SPECIAL;
1452 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1453 doref(kid, type, set_op_ref);
1456 if (type == OP_DEFINED)
1457 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1458 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1461 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1462 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1463 : type == OP_RV2HV ? OPpDEREF_HV
1465 o->op_flags |= OPf_MOD;
1470 o->op_flags |= OPf_MOD; /* XXX ??? */
1476 o->op_flags |= OPf_REF;
1479 if (type == OP_DEFINED)
1480 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1481 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1487 o->op_flags |= OPf_REF;
1492 if (!(o->op_flags & OPf_KIDS))
1494 doref(cBINOPo->op_first, type, set_op_ref);
1498 doref(cBINOPo->op_first, o->op_type, set_op_ref);
1499 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1500 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1501 : type == OP_RV2HV ? OPpDEREF_HV
1503 o->op_flags |= OPf_MOD;
1513 if (!(o->op_flags & OPf_KIDS))
1515 doref(cLISTOPo->op_last, type, set_op_ref);
1525 S_dup_attrlist(pTHX_ OP *o)
1529 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1530 * where the first kid is OP_PUSHMARK and the remaining ones
1531 * are OP_CONST. We need to push the OP_CONST values.
1533 if (o->op_type == OP_CONST)
1534 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1536 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1538 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1539 if (o->op_type == OP_CONST)
1540 rop = append_elem(OP_LIST, rop,
1541 newSVOP(OP_CONST, o->op_flags,
1542 SvREFCNT_inc(cSVOPo->op_sv)));
1549 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1554 /* fake up C<use attributes $pkg,$rv,@attrs> */
1555 ENTER; /* need to protect against side-effects of 'use' */
1557 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1559 #define ATTRSMODULE "attributes"
1560 #define ATTRSMODULE_PM "attributes.pm"
1563 /* Don't force the C<use> if we don't need it. */
1564 SV * const * const svp = hv_fetch(GvHVn(PL_incgv), ATTRSMODULE_PM,
1565 sizeof(ATTRSMODULE_PM)-1, 0);
1566 if (svp && *svp != &PL_sv_undef)
1567 ; /* already in %INC */
1569 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1570 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1574 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1575 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1577 prepend_elem(OP_LIST,
1578 newSVOP(OP_CONST, 0, stashsv),
1579 prepend_elem(OP_LIST,
1580 newSVOP(OP_CONST, 0,
1582 dup_attrlist(attrs))));
1588 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1590 OP *pack, *imop, *arg;
1596 assert(target->op_type == OP_PADSV ||
1597 target->op_type == OP_PADHV ||
1598 target->op_type == OP_PADAV);
1600 /* Ensure that attributes.pm is loaded. */
1601 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1603 /* Need package name for method call. */
1604 pack = newSVOP(OP_CONST, 0, newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1));
1606 /* Build up the real arg-list. */
1607 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1609 arg = newOP(OP_PADSV, 0);
1610 arg->op_targ = target->op_targ;
1611 arg = prepend_elem(OP_LIST,
1612 newSVOP(OP_CONST, 0, stashsv),
1613 prepend_elem(OP_LIST,
1614 newUNOP(OP_REFGEN, 0,
1615 mod(arg, OP_REFGEN)),
1616 dup_attrlist(attrs)));
1618 /* Fake up a method call to import */
1619 meth = newSVpvn_share("import", 6, 0);
1620 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1621 append_elem(OP_LIST,
1622 prepend_elem(OP_LIST, pack, list(arg)),
1623 newSVOP(OP_METHOD_NAMED, 0, meth)));
1624 imop->op_private |= OPpENTERSUB_NOMOD;
1626 /* Combine the ops. */
1627 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1631 =notfor apidoc apply_attrs_string
1633 Attempts to apply a list of attributes specified by the C<attrstr> and
1634 C<len> arguments to the subroutine identified by the C<cv> argument which
1635 is expected to be associated with the package identified by the C<stashpv>
1636 argument (see L<attributes>). It gets this wrong, though, in that it
1637 does not correctly identify the boundaries of the individual attribute
1638 specifications within C<attrstr>. This is not really intended for the
1639 public API, but has to be listed here for systems such as AIX which
1640 need an explicit export list for symbols. (It's called from XS code
1641 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1642 to respect attribute syntax properly would be welcome.
1648 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
1649 const char *attrstr, STRLEN len)
1654 len = strlen(attrstr);
1658 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1660 const char * const sstr = attrstr;
1661 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1662 attrs = append_elem(OP_LIST, attrs,
1663 newSVOP(OP_CONST, 0,
1664 newSVpvn(sstr, attrstr-sstr)));
1668 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1669 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1670 Nullsv, prepend_elem(OP_LIST,
1671 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1672 prepend_elem(OP_LIST,
1673 newSVOP(OP_CONST, 0,
1679 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
1683 if (!o || PL_error_count)
1687 if (type == OP_LIST) {
1689 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1690 my_kid(kid, attrs, imopsp);
1691 } else if (type == OP_UNDEF) {
1693 } else if (type == OP_RV2SV || /* "our" declaration */
1695 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1696 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1697 yyerror(Perl_form(aTHX_ "Can't declare %s in %s",
1698 OP_DESC(o), PL_in_my == KEY_our ? "our" : "my"));
1700 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
1702 PL_in_my_stash = NULL;
1703 apply_attrs(GvSTASH(gv),
1704 (type == OP_RV2SV ? GvSV(gv) :
1705 type == OP_RV2AV ? (SV*)GvAV(gv) :
1706 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1709 o->op_private |= OPpOUR_INTRO;
1712 else if (type != OP_PADSV &&
1715 type != OP_PUSHMARK)
1717 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1719 PL_in_my == KEY_our ? "our" : "my"));
1722 else if (attrs && type != OP_PUSHMARK) {
1726 PL_in_my_stash = NULL;
1728 /* check for C<my Dog $spot> when deciding package */
1729 stash = PAD_COMPNAME_TYPE(o->op_targ);
1731 stash = PL_curstash;
1732 apply_attrs_my(stash, o, attrs, imopsp);
1734 o->op_flags |= OPf_MOD;
1735 o->op_private |= OPpLVAL_INTRO;
1740 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1743 int maybe_scalar = 0;
1745 /* [perl #17376]: this appears to be premature, and results in code such as
1746 C< our(%x); > executing in list mode rather than void mode */
1748 if (o->op_flags & OPf_PARENS)
1758 o = my_kid(o, attrs, &rops);
1760 if (maybe_scalar && o->op_type == OP_PADSV) {
1761 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
1762 o->op_private |= OPpLVAL_INTRO;
1765 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
1768 PL_in_my_stash = NULL;
1773 Perl_my(pTHX_ OP *o)
1775 return my_attrs(o, Nullop);
1779 Perl_sawparens(pTHX_ OP *o)
1782 o->op_flags |= OPf_PARENS;
1787 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
1792 if ( (left->op_type == OP_RV2AV ||
1793 left->op_type == OP_RV2HV ||
1794 left->op_type == OP_PADAV ||
1795 left->op_type == OP_PADHV)
1796 && ckWARN(WARN_MISC))
1798 const char * const desc = PL_op_desc[(right->op_type == OP_SUBST ||
1799 right->op_type == OP_TRANS)
1800 ? right->op_type : OP_MATCH];
1801 const char * const sample = ((left->op_type == OP_RV2AV ||
1802 left->op_type == OP_PADAV)
1803 ? "@array" : "%hash");
1804 Perl_warner(aTHX_ packWARN(WARN_MISC),
1805 "Applying %s to %s will act on scalar(%s)",
1806 desc, sample, sample);
1809 if (right->op_type == OP_CONST &&
1810 cSVOPx(right)->op_private & OPpCONST_BARE &&
1811 cSVOPx(right)->op_private & OPpCONST_STRICT)
1813 no_bareword_allowed(right);
1816 ismatchop = right->op_type == OP_MATCH ||
1817 right->op_type == OP_SUBST ||
1818 right->op_type == OP_TRANS;
1819 if (ismatchop && right->op_private & OPpTARGET_MY) {
1821 right->op_private &= ~OPpTARGET_MY;
1823 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
1824 right->op_flags |= OPf_STACKED;
1825 if (right->op_type != OP_MATCH &&
1826 ! (right->op_type == OP_TRANS &&
1827 right->op_private & OPpTRANS_IDENTICAL))
1828 left = mod(left, right->op_type);
1829 if (right->op_type == OP_TRANS)
1830 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
1832 o = prepend_elem(right->op_type, scalar(left), right);
1834 return newUNOP(OP_NOT, 0, scalar(o));
1838 return bind_match(type, left,
1839 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
1843 Perl_invert(pTHX_ OP *o)
1847 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
1848 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
1852 Perl_scope(pTHX_ OP *o)
1856 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
1857 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
1858 o->op_type = OP_LEAVE;
1859 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
1861 else if (o->op_type == OP_LINESEQ) {
1863 o->op_type = OP_SCOPE;
1864 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
1865 kid = ((LISTOP*)o)->op_first;
1866 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
1869 /* The following deals with things like 'do {1 for 1}' */
1870 kid = kid->op_sibling;
1872 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
1877 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
1883 Perl_block_start(pTHX_ int full)
1885 const int retval = PL_savestack_ix;
1886 pad_block_start(full);
1888 PL_hints &= ~HINT_BLOCK_SCOPE;
1889 SAVESPTR(PL_compiling.cop_warnings);
1890 if (! specialWARN(PL_compiling.cop_warnings)) {
1891 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
1892 SAVEFREESV(PL_compiling.cop_warnings) ;
1894 SAVESPTR(PL_compiling.cop_io);
1895 if (! specialCopIO(PL_compiling.cop_io)) {
1896 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
1897 SAVEFREESV(PL_compiling.cop_io) ;
1903 Perl_block_end(pTHX_ I32 floor, OP *seq)
1905 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
1906 OP* const retval = scalarseq(seq);
1908 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
1910 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
1918 const I32 offset = pad_findmy("$_");
1919 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
1920 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
1923 OP * const o = newOP(OP_PADSV, 0);
1924 o->op_targ = offset;
1930 Perl_newPROG(pTHX_ OP *o)
1935 PL_eval_root = newUNOP(OP_LEAVEEVAL,
1936 ((PL_in_eval & EVAL_KEEPERR)
1937 ? OPf_SPECIAL : 0), o);
1938 PL_eval_start = linklist(PL_eval_root);
1939 PL_eval_root->op_private |= OPpREFCOUNTED;
1940 OpREFCNT_set(PL_eval_root, 1);
1941 PL_eval_root->op_next = 0;
1942 CALL_PEEP(PL_eval_start);
1945 if (o->op_type == OP_STUB) {
1946 PL_comppad_name = 0;
1951 PL_main_root = scope(sawparens(scalarvoid(o)));
1952 PL_curcop = &PL_compiling;
1953 PL_main_start = LINKLIST(PL_main_root);
1954 PL_main_root->op_private |= OPpREFCOUNTED;
1955 OpREFCNT_set(PL_main_root, 1);
1956 PL_main_root->op_next = 0;
1957 CALL_PEEP(PL_main_start);
1960 /* Register with debugger */
1962 CV * const cv = get_cv("DB::postponed", FALSE);
1966 XPUSHs((SV*)CopFILEGV(&PL_compiling));
1968 call_sv((SV*)cv, G_DISCARD);
1975 Perl_localize(pTHX_ OP *o, I32 lex)
1977 if (o->op_flags & OPf_PARENS)
1978 /* [perl #17376]: this appears to be premature, and results in code such as
1979 C< our(%x); > executing in list mode rather than void mode */
1986 if ( PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ','
1987 && ckWARN(WARN_PARENTHESIS))
1989 char *s = PL_bufptr;
1992 /* some heuristics to detect a potential error */
1993 while (*s && (strchr(", \t\n", *s)))
1997 if (*s && strchr("@$%*", *s) && *++s
1998 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2001 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2003 while (*s && (strchr(", \t\n", *s)))
2009 if (sigil && (*s == ';' || *s == '=')) {
2010 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2011 "Parentheses missing around \"%s\" list",
2012 lex ? (PL_in_my == KEY_our ? "our" : "my")
2020 o = mod(o, OP_NULL); /* a bit kludgey */
2022 PL_in_my_stash = NULL;
2027 Perl_jmaybe(pTHX_ OP *o)
2029 if (o->op_type == OP_LIST) {
2031 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
2032 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2038 Perl_fold_constants(pTHX_ register OP *o)
2042 I32 type = o->op_type;
2045 if (PL_opargs[type] & OA_RETSCALAR)
2047 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2048 o->op_targ = pad_alloc(type, SVs_PADTMP);
2050 /* integerize op, unless it happens to be C<-foo>.
2051 * XXX should pp_i_negate() do magic string negation instead? */
2052 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2053 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2054 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2056 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2059 if (!(PL_opargs[type] & OA_FOLDCONST))
2064 /* XXX might want a ck_negate() for this */
2065 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2076 /* XXX what about the numeric ops? */
2077 if (PL_hints & HINT_LOCALE)
2082 goto nope; /* Don't try to run w/ errors */
2084 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2085 if ((curop->op_type != OP_CONST ||
2086 (curop->op_private & OPpCONST_BARE)) &&
2087 curop->op_type != OP_LIST &&
2088 curop->op_type != OP_SCALAR &&
2089 curop->op_type != OP_NULL &&
2090 curop->op_type != OP_PUSHMARK)
2096 curop = LINKLIST(o);
2100 sv = *(PL_stack_sp--);
2101 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2102 pad_swipe(o->op_targ, FALSE);
2103 else if (SvTEMP(sv)) { /* grab mortal temp? */
2104 (void)SvREFCNT_inc(sv);
2108 if (type == OP_RV2GV)
2109 return newGVOP(OP_GV, 0, (GV*)sv);
2110 return newSVOP(OP_CONST, 0, sv);
2117 Perl_gen_constant_list(pTHX_ register OP *o)
2121 const I32 oldtmps_floor = PL_tmps_floor;
2125 return o; /* Don't attempt to run with errors */
2127 PL_op = curop = LINKLIST(o);
2134 PL_tmps_floor = oldtmps_floor;
2136 o->op_type = OP_RV2AV;
2137 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2138 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2139 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2140 o->op_opt = 0; /* needs to be revisited in peep() */
2141 curop = ((UNOP*)o)->op_first;
2142 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2149 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2152 if (!o || o->op_type != OP_LIST)
2153 o = newLISTOP(OP_LIST, 0, o, Nullop);
2155 o->op_flags &= ~OPf_WANT;
2157 if (!(PL_opargs[type] & OA_MARK))
2158 op_null(cLISTOPo->op_first);
2160 o->op_type = (OPCODE)type;
2161 o->op_ppaddr = PL_ppaddr[type];
2162 o->op_flags |= flags;
2164 o = CHECKOP(type, o);
2165 if (o->op_type != (unsigned)type)
2168 return fold_constants(o);
2171 /* List constructors */
2174 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2182 if (first->op_type != (unsigned)type
2183 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2185 return newLISTOP(type, 0, first, last);
2188 if (first->op_flags & OPf_KIDS)
2189 ((LISTOP*)first)->op_last->op_sibling = last;
2191 first->op_flags |= OPf_KIDS;
2192 ((LISTOP*)first)->op_first = last;
2194 ((LISTOP*)first)->op_last = last;
2199 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2207 if (first->op_type != (unsigned)type)
2208 return prepend_elem(type, (OP*)first, (OP*)last);
2210 if (last->op_type != (unsigned)type)
2211 return append_elem(type, (OP*)first, (OP*)last);
2213 first->op_last->op_sibling = last->op_first;
2214 first->op_last = last->op_last;
2215 first->op_flags |= (last->op_flags & OPf_KIDS);
2223 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2231 if (last->op_type == (unsigned)type) {
2232 if (type == OP_LIST) { /* already a PUSHMARK there */
2233 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2234 ((LISTOP*)last)->op_first->op_sibling = first;
2235 if (!(first->op_flags & OPf_PARENS))
2236 last->op_flags &= ~OPf_PARENS;
2239 if (!(last->op_flags & OPf_KIDS)) {
2240 ((LISTOP*)last)->op_last = first;
2241 last->op_flags |= OPf_KIDS;
2243 first->op_sibling = ((LISTOP*)last)->op_first;
2244 ((LISTOP*)last)->op_first = first;
2246 last->op_flags |= OPf_KIDS;
2250 return newLISTOP(type, 0, first, last);
2256 Perl_newNULLLIST(pTHX)
2258 return newOP(OP_STUB, 0);
2262 Perl_force_list(pTHX_ OP *o)
2264 if (!o || o->op_type != OP_LIST)
2265 o = newLISTOP(OP_LIST, 0, o, Nullop);
2271 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2276 NewOp(1101, listop, 1, LISTOP);
2278 listop->op_type = (OPCODE)type;
2279 listop->op_ppaddr = PL_ppaddr[type];
2282 listop->op_flags = (U8)flags;
2286 else if (!first && last)
2289 first->op_sibling = last;
2290 listop->op_first = first;
2291 listop->op_last = last;
2292 if (type == OP_LIST) {
2293 OP* const pushop = newOP(OP_PUSHMARK, 0);
2294 pushop->op_sibling = first;
2295 listop->op_first = pushop;
2296 listop->op_flags |= OPf_KIDS;
2298 listop->op_last = pushop;
2301 return CHECKOP(type, listop);
2305 Perl_newOP(pTHX_ I32 type, I32 flags)
2309 NewOp(1101, o, 1, OP);
2310 o->op_type = (OPCODE)type;
2311 o->op_ppaddr = PL_ppaddr[type];
2312 o->op_flags = (U8)flags;
2315 o->op_private = (U8)(0 | (flags >> 8));
2316 if (PL_opargs[type] & OA_RETSCALAR)
2318 if (PL_opargs[type] & OA_TARGET)
2319 o->op_targ = pad_alloc(type, SVs_PADTMP);
2320 return CHECKOP(type, o);
2324 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2330 first = newOP(OP_STUB, 0);
2331 if (PL_opargs[type] & OA_MARK)
2332 first = force_list(first);
2334 NewOp(1101, unop, 1, UNOP);
2335 unop->op_type = (OPCODE)type;
2336 unop->op_ppaddr = PL_ppaddr[type];
2337 unop->op_first = first;
2338 unop->op_flags = (U8)(flags | OPf_KIDS);
2339 unop->op_private = (U8)(1 | (flags >> 8));
2340 unop = (UNOP*) CHECKOP(type, unop);
2344 return fold_constants((OP *) unop);
2348 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2352 NewOp(1101, binop, 1, BINOP);
2355 first = newOP(OP_NULL, 0);
2357 binop->op_type = (OPCODE)type;
2358 binop->op_ppaddr = PL_ppaddr[type];
2359 binop->op_first = first;
2360 binop->op_flags = (U8)(flags | OPf_KIDS);
2363 binop->op_private = (U8)(1 | (flags >> 8));
2366 binop->op_private = (U8)(2 | (flags >> 8));
2367 first->op_sibling = last;
2370 binop = (BINOP*)CHECKOP(type, binop);
2371 if (binop->op_next || binop->op_type != (OPCODE)type)
2374 binop->op_last = binop->op_first->op_sibling;
2376 return fold_constants((OP *)binop);
2379 static int uvcompare(const void *a, const void *b) __attribute__nonnull__(1) __attribute__nonnull__(2) __attribute__pure__;
2380 static int uvcompare(const void *a, const void *b)
2382 if (*((const UV *)a) < (*(const UV *)b))
2384 if (*((const UV *)a) > (*(const UV *)b))
2386 if (*((const UV *)a+1) < (*(const UV *)b+1))
2388 if (*((const UV *)a+1) > (*(const UV *)b+1))
2394 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2396 SV * const tstr = ((SVOP*)expr)->op_sv;
2397 SV * const rstr = ((SVOP*)repl)->op_sv;
2400 const U8 *t = (U8*)SvPV_const(tstr, tlen);
2401 const U8 *r = (U8*)SvPV_const(rstr, rlen);
2405 register short *tbl;
2407 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
2408 const I32 squash = o->op_private & OPpTRANS_SQUASH;
2409 I32 del = o->op_private & OPpTRANS_DELETE;
2410 PL_hints |= HINT_BLOCK_SCOPE;
2413 o->op_private |= OPpTRANS_FROM_UTF;
2416 o->op_private |= OPpTRANS_TO_UTF;
2418 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2419 SV* const listsv = newSVpvn("# comment\n",10);
2421 const U8* tend = t + tlen;
2422 const U8* rend = r + rlen;
2436 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2437 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2443 t = tsave = bytes_to_utf8(t, &len);
2446 if (!to_utf && rlen) {
2448 r = rsave = bytes_to_utf8(r, &len);
2452 /* There are several snags with this code on EBCDIC:
2453 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2454 2. scan_const() in toke.c has encoded chars in native encoding which makes
2455 ranges at least in EBCDIC 0..255 range the bottom odd.
2459 U8 tmpbuf[UTF8_MAXBYTES+1];
2462 Newx(cp, 2*tlen, UV);
2464 transv = newSVpvn("",0);
2466 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2468 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2470 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2474 cp[2*i+1] = cp[2*i];
2478 qsort(cp, i, 2*sizeof(UV), uvcompare);
2479 for (j = 0; j < i; j++) {
2481 diff = val - nextmin;
2483 t = uvuni_to_utf8(tmpbuf,nextmin);
2484 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2486 U8 range_mark = UTF_TO_NATIVE(0xff);
2487 t = uvuni_to_utf8(tmpbuf, val - 1);
2488 sv_catpvn(transv, (char *)&range_mark, 1);
2489 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2496 t = uvuni_to_utf8(tmpbuf,nextmin);
2497 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2499 U8 range_mark = UTF_TO_NATIVE(0xff);
2500 sv_catpvn(transv, (char *)&range_mark, 1);
2502 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2503 UNICODE_ALLOW_SUPER);
2504 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2505 t = (const U8*)SvPVX_const(transv);
2506 tlen = SvCUR(transv);
2510 else if (!rlen && !del) {
2511 r = t; rlen = tlen; rend = tend;
2514 if ((!rlen && !del) || t == r ||
2515 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2517 o->op_private |= OPpTRANS_IDENTICAL;
2521 while (t < tend || tfirst <= tlast) {
2522 /* see if we need more "t" chars */
2523 if (tfirst > tlast) {
2524 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2526 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2528 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2535 /* now see if we need more "r" chars */
2536 if (rfirst > rlast) {
2538 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2540 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2542 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2551 rfirst = rlast = 0xffffffff;
2555 /* now see which range will peter our first, if either. */
2556 tdiff = tlast - tfirst;
2557 rdiff = rlast - rfirst;
2564 if (rfirst == 0xffffffff) {
2565 diff = tdiff; /* oops, pretend rdiff is infinite */
2567 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2568 (long)tfirst, (long)tlast);
2570 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2574 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2575 (long)tfirst, (long)(tfirst + diff),
2578 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2579 (long)tfirst, (long)rfirst);
2581 if (rfirst + diff > max)
2582 max = rfirst + diff;
2584 grows = (tfirst < rfirst &&
2585 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2597 else if (max > 0xff)
2602 Safefree(cPVOPo->op_pv);
2603 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2604 SvREFCNT_dec(listsv);
2606 SvREFCNT_dec(transv);
2608 if (!del && havefinal && rlen)
2609 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2610 newSVuv((UV)final), 0);
2613 o->op_private |= OPpTRANS_GROWS;
2625 tbl = (short*)cPVOPo->op_pv;
2627 Zero(tbl, 256, short);
2628 for (i = 0; i < (I32)tlen; i++)
2630 for (i = 0, j = 0; i < 256; i++) {
2632 if (j >= (I32)rlen) {
2641 if (i < 128 && r[j] >= 128)
2651 o->op_private |= OPpTRANS_IDENTICAL;
2653 else if (j >= (I32)rlen)
2656 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2657 tbl[0x100] = (short)(rlen - j);
2658 for (i=0; i < (I32)rlen - j; i++)
2659 tbl[0x101+i] = r[j+i];
2663 if (!rlen && !del) {
2666 o->op_private |= OPpTRANS_IDENTICAL;
2668 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
2669 o->op_private |= OPpTRANS_IDENTICAL;
2671 for (i = 0; i < 256; i++)
2673 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
2674 if (j >= (I32)rlen) {
2676 if (tbl[t[i]] == -1)
2682 if (tbl[t[i]] == -1) {
2683 if (t[i] < 128 && r[j] >= 128)
2690 o->op_private |= OPpTRANS_GROWS;
2698 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2703 NewOp(1101, pmop, 1, PMOP);
2704 pmop->op_type = (OPCODE)type;
2705 pmop->op_ppaddr = PL_ppaddr[type];
2706 pmop->op_flags = (U8)flags;
2707 pmop->op_private = (U8)(0 | (flags >> 8));
2709 if (PL_hints & HINT_RE_TAINT)
2710 pmop->op_pmpermflags |= PMf_RETAINT;
2711 if (PL_hints & HINT_LOCALE)
2712 pmop->op_pmpermflags |= PMf_LOCALE;
2713 pmop->op_pmflags = pmop->op_pmpermflags;
2716 if (av_len((AV*) PL_regex_pad[0]) > -1) {
2717 SV * const repointer = av_pop((AV*)PL_regex_pad[0]);
2718 pmop->op_pmoffset = SvIV(repointer);
2719 SvREPADTMP_off(repointer);
2720 sv_setiv(repointer,0);
2722 SV * const repointer = newSViv(0);
2723 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
2724 pmop->op_pmoffset = av_len(PL_regex_padav);
2725 PL_regex_pad = AvARRAY(PL_regex_padav);
2729 /* link into pm list */
2730 if (type != OP_TRANS && PL_curstash) {
2731 MAGIC *mg = mg_find((SV*)PL_curstash, PERL_MAGIC_symtab);
2734 mg = sv_magicext((SV*)PL_curstash, 0, PERL_MAGIC_symtab, 0, 0, 0);
2736 pmop->op_pmnext = (PMOP*)mg->mg_obj;
2737 mg->mg_obj = (SV*)pmop;
2738 PmopSTASH_set(pmop,PL_curstash);
2741 return CHECKOP(type, pmop);
2744 /* Given some sort of match op o, and an expression expr containing a
2745 * pattern, either compile expr into a regex and attach it to o (if it's
2746 * constant), or convert expr into a runtime regcomp op sequence (if it's
2749 * isreg indicates that the pattern is part of a regex construct, eg
2750 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
2751 * split "pattern", which aren't. In the former case, expr will be a list
2752 * if the pattern contains more than one term (eg /a$b/) or if it contains
2753 * a replacement, ie s/// or tr///.
2757 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
2762 I32 repl_has_vars = 0;
2766 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
2767 /* last element in list is the replacement; pop it */
2769 repl = cLISTOPx(expr)->op_last;
2770 kid = cLISTOPx(expr)->op_first;
2771 while (kid->op_sibling != repl)
2772 kid = kid->op_sibling;
2773 kid->op_sibling = Nullop;
2774 cLISTOPx(expr)->op_last = kid;
2777 if (isreg && expr->op_type == OP_LIST &&
2778 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
2780 /* convert single element list to element */
2781 OP* const oe = expr;
2782 expr = cLISTOPx(oe)->op_first->op_sibling;
2783 cLISTOPx(oe)->op_first->op_sibling = Nullop;
2784 cLISTOPx(oe)->op_last = Nullop;
2788 if (o->op_type == OP_TRANS) {
2789 return pmtrans(o, expr, repl);
2792 reglist = isreg && expr->op_type == OP_LIST;
2796 PL_hints |= HINT_BLOCK_SCOPE;
2799 if (expr->op_type == OP_CONST) {
2801 SV *pat = ((SVOP*)expr)->op_sv;
2802 const char *p = SvPV_const(pat, plen);
2803 if ((o->op_flags & OPf_SPECIAL) && (*p == ' ' && p[1] == '\0')) {
2804 U32 was_readonly = SvREADONLY(pat);
2808 sv_force_normal_flags(pat, 0);
2809 assert(!SvREADONLY(pat));
2812 SvREADONLY_off(pat);
2816 sv_setpvn(pat, "\\s+", 3);
2818 SvFLAGS(pat) |= was_readonly;
2820 p = SvPV_const(pat, plen);
2821 pm->op_pmflags |= PMf_SKIPWHITE;
2824 pm->op_pmdynflags |= PMdf_UTF8;
2825 /* FIXME - can we make this function take const char * args? */
2826 PM_SETRE(pm, CALLREGCOMP(aTHX_ (char*)p, (char*)p + plen, pm));
2827 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
2828 pm->op_pmflags |= PMf_WHITE;
2832 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
2833 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2835 : OP_REGCMAYBE),0,expr);
2837 NewOp(1101, rcop, 1, LOGOP);
2838 rcop->op_type = OP_REGCOMP;
2839 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
2840 rcop->op_first = scalar(expr);
2841 rcop->op_flags |= OPf_KIDS
2842 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
2843 | (reglist ? OPf_STACKED : 0);
2844 rcop->op_private = 1;
2847 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
2849 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
2852 /* establish postfix order */
2853 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
2855 rcop->op_next = expr;
2856 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
2859 rcop->op_next = LINKLIST(expr);
2860 expr->op_next = (OP*)rcop;
2863 prepend_elem(o->op_type, scalar((OP*)rcop), o);
2868 if (pm->op_pmflags & PMf_EVAL) {
2870 if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
2871 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
2873 else if (repl->op_type == OP_CONST)
2877 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
2878 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
2879 if (curop->op_type == OP_GV) {
2880 GV *gv = cGVOPx_gv(curop);
2882 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
2885 else if (curop->op_type == OP_RV2CV)
2887 else if (curop->op_type == OP_RV2SV ||
2888 curop->op_type == OP_RV2AV ||
2889 curop->op_type == OP_RV2HV ||
2890 curop->op_type == OP_RV2GV) {
2891 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
2894 else if (curop->op_type == OP_PADSV ||
2895 curop->op_type == OP_PADAV ||
2896 curop->op_type == OP_PADHV ||
2897 curop->op_type == OP_PADANY) {
2900 else if (curop->op_type == OP_PUSHRE)
2901 ; /* Okay here, dangerous in newASSIGNOP */
2911 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
2912 pm->op_pmflags |= PMf_CONST; /* const for long enough */
2913 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
2914 prepend_elem(o->op_type, scalar(repl), o);
2917 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
2918 pm->op_pmflags |= PMf_MAYBE_CONST;
2919 pm->op_pmpermflags |= PMf_MAYBE_CONST;
2921 NewOp(1101, rcop, 1, LOGOP);
2922 rcop->op_type = OP_SUBSTCONT;
2923 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
2924 rcop->op_first = scalar(repl);
2925 rcop->op_flags |= OPf_KIDS;
2926 rcop->op_private = 1;
2929 /* establish postfix order */
2930 rcop->op_next = LINKLIST(repl);
2931 repl->op_next = (OP*)rcop;
2933 pm->op_pmreplroot = scalar((OP*)rcop);
2934 pm->op_pmreplstart = LINKLIST(rcop);
2943 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
2947 NewOp(1101, svop, 1, SVOP);
2948 svop->op_type = (OPCODE)type;
2949 svop->op_ppaddr = PL_ppaddr[type];
2951 svop->op_next = (OP*)svop;
2952 svop->op_flags = (U8)flags;
2953 if (PL_opargs[type] & OA_RETSCALAR)
2955 if (PL_opargs[type] & OA_TARGET)
2956 svop->op_targ = pad_alloc(type, SVs_PADTMP);
2957 return CHECKOP(type, svop);
2961 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
2965 NewOp(1101, padop, 1, PADOP);
2966 padop->op_type = (OPCODE)type;
2967 padop->op_ppaddr = PL_ppaddr[type];
2968 padop->op_padix = pad_alloc(type, SVs_PADTMP);
2969 SvREFCNT_dec(PAD_SVl(padop->op_padix));
2970 PAD_SETSV(padop->op_padix, sv);
2973 padop->op_next = (OP*)padop;
2974 padop->op_flags = (U8)flags;
2975 if (PL_opargs[type] & OA_RETSCALAR)
2977 if (PL_opargs[type] & OA_TARGET)
2978 padop->op_targ = pad_alloc(type, SVs_PADTMP);
2979 return CHECKOP(type, padop);
2983 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
2989 return newPADOP(type, flags, SvREFCNT_inc(gv));
2991 return newSVOP(type, flags, SvREFCNT_inc(gv));
2996 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3000 NewOp(1101, pvop, 1, PVOP);
3001 pvop->op_type = (OPCODE)type;
3002 pvop->op_ppaddr = PL_ppaddr[type];
3004 pvop->op_next = (OP*)pvop;
3005 pvop->op_flags = (U8)flags;
3006 if (PL_opargs[type] & OA_RETSCALAR)
3008 if (PL_opargs[type] & OA_TARGET)
3009 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3010 return CHECKOP(type, pvop);
3014 Perl_package(pTHX_ OP *o)
3019 save_hptr(&PL_curstash);
3020 save_item(PL_curstname);
3022 name = SvPV_const(cSVOPo->op_sv, len);
3023 PL_curstash = gv_stashpvn(name, len, TRUE);
3024 sv_setpvn(PL_curstname, name, len);
3027 PL_hints |= HINT_BLOCK_SCOPE;
3028 PL_copline = NOLINE;
3033 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3039 if (idop->op_type != OP_CONST)
3040 Perl_croak(aTHX_ "Module name must be constant");
3045 SV * const vesv = ((SVOP*)version)->op_sv;
3047 if (!arg && !SvNIOKp(vesv)) {
3054 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3055 Perl_croak(aTHX_ "Version number must be constant number");
3057 /* Make copy of idop so we don't free it twice */
3058 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3060 /* Fake up a method call to VERSION */
3061 meth = newSVpvn_share("VERSION", 7, 0);
3062 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3063 append_elem(OP_LIST,
3064 prepend_elem(OP_LIST, pack, list(version)),
3065 newSVOP(OP_METHOD_NAMED, 0, meth)));
3069 /* Fake up an import/unimport */
3070 if (arg && arg->op_type == OP_STUB)
3071 imop = arg; /* no import on explicit () */
3072 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3073 imop = Nullop; /* use 5.0; */
3075 idop->op_private |= OPpCONST_NOVER;
3080 /* Make copy of idop so we don't free it twice */
3081 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3083 /* Fake up a method call to import/unimport */
3085 ? newSVpvn_share("import",6, 0) : newSVpvn_share("unimport", 8, 0);
3086 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3087 append_elem(OP_LIST,
3088 prepend_elem(OP_LIST, pack, list(arg)),
3089 newSVOP(OP_METHOD_NAMED, 0, meth)));
3092 /* Fake up the BEGIN {}, which does its thing immediately. */
3094 newSVOP(OP_CONST, 0, newSVpvn_share("BEGIN", 5, 0)),
3097 append_elem(OP_LINESEQ,
3098 append_elem(OP_LINESEQ,
3099 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, idop)),
3100 newSTATEOP(0, Nullch, veop)),
3101 newSTATEOP(0, Nullch, imop) ));
3103 /* The "did you use incorrect case?" warning used to be here.
3104 * The problem is that on case-insensitive filesystems one
3105 * might get false positives for "use" (and "require"):
3106 * "use Strict" or "require CARP" will work. This causes
3107 * portability problems for the script: in case-strict
3108 * filesystems the script will stop working.
3110 * The "incorrect case" warning checked whether "use Foo"
3111 * imported "Foo" to your namespace, but that is wrong, too:
3112 * there is no requirement nor promise in the language that
3113 * a Foo.pm should or would contain anything in package "Foo".
3115 * There is very little Configure-wise that can be done, either:
3116 * the case-sensitivity of the build filesystem of Perl does not
3117 * help in guessing the case-sensitivity of the runtime environment.
3120 PL_hints |= HINT_BLOCK_SCOPE;
3121 PL_copline = NOLINE;
3123 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3127 =head1 Embedding Functions
3129 =for apidoc load_module
3131 Loads the module whose name is pointed to by the string part of name.
3132 Note that the actual module name, not its filename, should be given.
3133 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3134 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3135 (or 0 for no flags). ver, if specified, provides version semantics
3136 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3137 arguments can be used to specify arguments to the module's import()
3138 method, similar to C<use Foo::Bar VERSION LIST>.
3143 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3146 va_start(args, ver);
3147 vload_module(flags, name, ver, &args);
3151 #ifdef PERL_IMPLICIT_CONTEXT
3153 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3157 va_start(args, ver);
3158 vload_module(flags, name, ver, &args);
3164 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3168 OP * const modname = newSVOP(OP_CONST, 0, name);
3169 modname->op_private |= OPpCONST_BARE;
3171 veop = newSVOP(OP_CONST, 0, ver);
3175 if (flags & PERL_LOADMOD_NOIMPORT) {
3176 imop = sawparens(newNULLLIST());
3178 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3179 imop = va_arg(*args, OP*);
3184 sv = va_arg(*args, SV*);
3186 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3187 sv = va_arg(*args, SV*);
3191 const line_t ocopline = PL_copline;
3192 COP * const ocurcop = PL_curcop;
3193 const int oexpect = PL_expect;
3195 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3196 veop, modname, imop);
3197 PL_expect = oexpect;
3198 PL_copline = ocopline;
3199 PL_curcop = ocurcop;
3204 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
3209 if (!force_builtin) {
3210 gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3211 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
3212 GV * const * const gvp = (GV**)hv_fetch(PL_globalstash, "do", 2, FALSE);
3213 gv = gvp ? *gvp : Nullgv;
3217 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3218 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3219 append_elem(OP_LIST, term,
3220 scalar(newUNOP(OP_RV2CV, 0,
3225 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3231 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3233 return newBINOP(OP_LSLICE, flags,
3234 list(force_list(subscript)),
3235 list(force_list(listval)) );
3239 S_is_list_assignment(pTHX_ register const OP *o)
3244 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3245 o = cUNOPo->op_first;
3247 if (o->op_type == OP_COND_EXPR) {
3248 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
3249 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3254 yyerror("Assignment to both a list and a scalar");
3258 if (o->op_type == OP_LIST &&
3259 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3260 o->op_private & OPpLVAL_INTRO)
3263 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3264 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3265 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3268 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3271 if (o->op_type == OP_RV2SV)
3278 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3283 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3284 return newLOGOP(optype, 0,
3285 mod(scalar(left), optype),
3286 newUNOP(OP_SASSIGN, 0, scalar(right)));
3289 return newBINOP(optype, OPf_STACKED,
3290 mod(scalar(left), optype), scalar(right));
3294 if (is_list_assignment(left)) {
3298 /* Grandfathering $[ assignment here. Bletch.*/
3299 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
3300 PL_eval_start = (left->op_type == OP_CONST) ? right : 0;
3301 left = mod(left, OP_AASSIGN);
3304 else if (left->op_type == OP_CONST) {
3305 /* Result of assignment is always 1 (or we'd be dead already) */
3306 return newSVOP(OP_CONST, 0, newSViv(1));
3308 curop = list(force_list(left));
3309 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3310 o->op_private = (U8)(0 | (flags >> 8));
3312 /* PL_generation sorcery:
3313 * an assignment like ($a,$b) = ($c,$d) is easier than
3314 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3315 * To detect whether there are common vars, the global var
3316 * PL_generation is incremented for each assign op we compile.
3317 * Then, while compiling the assign op, we run through all the
3318 * variables on both sides of the assignment, setting a spare slot
3319 * in each of them to PL_generation. If any of them already have
3320 * that value, we know we've got commonality. We could use a
3321 * single bit marker, but then we'd have to make 2 passes, first
3322 * to clear the flag, then to test and set it. To find somewhere
3323 * to store these values, evil chicanery is done with SvCUR().
3326 if (!(left->op_private & OPpLVAL_INTRO)) {
3329 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3330 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3331 if (curop->op_type == OP_GV) {
3332 GV *gv = cGVOPx_gv(curop);
3333 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3335 SvCUR_set(gv, PL_generation);
3337 else if (curop->op_type == OP_PADSV ||
3338 curop->op_type == OP_PADAV ||
3339 curop->op_type == OP_PADHV ||
3340 curop->op_type == OP_PADANY)
3342 if (PAD_COMPNAME_GEN(curop->op_targ)
3343 == (STRLEN)PL_generation)
3345 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
3348 else if (curop->op_type == OP_RV2CV)
3350 else if (curop->op_type == OP_RV2SV ||
3351 curop->op_type == OP_RV2AV ||
3352 curop->op_type == OP_RV2HV ||
3353 curop->op_type == OP_RV2GV) {
3354 if (lastop->op_type != OP_GV) /* funny deref? */
3357 else if (curop->op_type == OP_PUSHRE) {
3358 if (((PMOP*)curop)->op_pmreplroot) {
3360 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3361 ((PMOP*)curop)->op_pmreplroot));
3363 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3365 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3367 SvCUR_set(gv, PL_generation);
3376 o->op_private |= OPpASSIGN_COMMON;
3378 if (right && right->op_type == OP_SPLIT) {
3380 if ((tmpop = ((LISTOP*)right)->op_first) &&
3381 tmpop->op_type == OP_PUSHRE)
3383 PMOP * const pm = (PMOP*)tmpop;
3384 if (left->op_type == OP_RV2AV &&
3385 !(left->op_private & OPpLVAL_INTRO) &&
3386 !(o->op_private & OPpASSIGN_COMMON) )
3388 tmpop = ((UNOP*)left)->op_first;
3389 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3391 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3392 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3394 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3395 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3397 pm->op_pmflags |= PMf_ONCE;
3398 tmpop = cUNOPo->op_first; /* to list (nulled) */
3399 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3400 tmpop->op_sibling = Nullop; /* don't free split */
3401 right->op_next = tmpop->op_next; /* fix starting loc */
3402 op_free(o); /* blow off assign */
3403 right->op_flags &= ~OPf_WANT;
3404 /* "I don't know and I don't care." */
3409 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3410 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3412 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3414 sv_setiv(sv, PL_modcount+1);
3422 right = newOP(OP_UNDEF, 0);
3423 if (right->op_type == OP_READLINE) {
3424 right->op_flags |= OPf_STACKED;
3425 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3428 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3429 o = newBINOP(OP_SASSIGN, flags,
3430 scalar(right), mod(scalar(left), OP_SASSIGN) );
3434 o = newSVOP(OP_CONST, 0, newSViv(PL_compiling.cop_arybase));
3441 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3444 const U32 seq = intro_my();
3447 NewOp(1101, cop, 1, COP);
3448 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3449 cop->op_type = OP_DBSTATE;
3450 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3453 cop->op_type = OP_NEXTSTATE;
3454 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3456 cop->op_flags = (U8)flags;
3457 cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
3459 cop->op_private |= NATIVE_HINTS;
3461 PL_compiling.op_private = cop->op_private;
3462 cop->op_next = (OP*)cop;
3465 cop->cop_label = label;
3466 PL_hints |= HINT_BLOCK_SCOPE;
3469 cop->cop_arybase = PL_curcop->cop_arybase;
3470 if (specialWARN(PL_curcop->cop_warnings))
3471 cop->cop_warnings = PL_curcop->cop_warnings ;
3473 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3474 if (specialCopIO(PL_curcop->cop_io))
3475 cop->cop_io = PL_curcop->cop_io;
3477 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3480 if (PL_copline == NOLINE)
3481 CopLINE_set(cop, CopLINE(PL_curcop));
3483 CopLINE_set(cop, PL_copline);
3484 PL_copline = NOLINE;
3487 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3489 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3491 CopSTASH_set(cop, PL_curstash);
3493 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3494 SV * const * const svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3495 if (svp && *svp != &PL_sv_undef ) {
3496 (void)SvIOK_on(*svp);
3497 SvIV_set(*svp, PTR2IV(cop));
3501 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3506 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3509 return new_logop(type, flags, &first, &other);
3513 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3518 OP *first = *firstp;
3519 OP * const other = *otherp;
3521 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3522 return newBINOP(type, flags, scalar(first), scalar(other));
3524 scalarboolean(first);
3525 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3526 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3527 if (type == OP_AND || type == OP_OR) {
3533 first = *firstp = cUNOPo->op_first;
3535 first->op_next = o->op_next;
3536 cUNOPo->op_first = Nullop;
3540 if (first->op_type == OP_CONST) {
3541 if (first->op_private & OPpCONST_STRICT)
3542 no_bareword_allowed(first);
3543 else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
3544 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
3545 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
3546 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
3547 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
3550 if (other->op_type == OP_CONST)
3551 other->op_private |= OPpCONST_SHORTCIRCUIT;
3555 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
3556 const OP *o2 = other;
3557 if ( ! (o2->op_type == OP_LIST
3558 && (( o2 = cUNOPx(o2)->op_first))
3559 && o2->op_type == OP_PUSHMARK
3560 && (( o2 = o2->op_sibling)) )
3563 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
3564 || o2->op_type == OP_PADHV)
3565 && o2->op_private & OPpLVAL_INTRO
3566 && ckWARN(WARN_DEPRECATED))
3568 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
3569 "Deprecated use of my() in false conditional");
3574 if (first->op_type == OP_CONST)
3575 first->op_private |= OPpCONST_SHORTCIRCUIT;
3579 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
3580 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
3582 const OP * const k1 = ((UNOP*)first)->op_first;
3583 const OP * const k2 = k1->op_sibling;
3585 switch (first->op_type)
3588 if (k2 && k2->op_type == OP_READLINE
3589 && (k2->op_flags & OPf_STACKED)
3590 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3592 warnop = k2->op_type;
3597 if (k1->op_type == OP_READDIR
3598 || k1->op_type == OP_GLOB
3599 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3600 || k1->op_type == OP_EACH)
3602 warnop = ((k1->op_type == OP_NULL)
3603 ? (OPCODE)k1->op_targ : k1->op_type);
3608 const line_t oldline = CopLINE(PL_curcop);
3609 CopLINE_set(PL_curcop, PL_copline);
3610 Perl_warner(aTHX_ packWARN(WARN_MISC),
3611 "Value of %s%s can be \"0\"; test with defined()",
3613 ((warnop == OP_READLINE || warnop == OP_GLOB)
3614 ? " construct" : "() operator"));
3615 CopLINE_set(PL_curcop, oldline);
3622 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
3623 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3625 NewOp(1101, logop, 1, LOGOP);
3627 logop->op_type = (OPCODE)type;
3628 logop->op_ppaddr = PL_ppaddr[type];
3629 logop->op_first = first;
3630 logop->op_flags = (U8)(flags | OPf_KIDS);
3631 logop->op_other = LINKLIST(other);
3632 logop->op_private = (U8)(1 | (flags >> 8));
3634 /* establish postfix order */
3635 logop->op_next = LINKLIST(first);
3636 first->op_next = (OP*)logop;
3637 first->op_sibling = other;
3639 CHECKOP(type,logop);
3641 o = newUNOP(OP_NULL, 0, (OP*)logop);
3648 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3656 return newLOGOP(OP_AND, 0, first, trueop);
3658 return newLOGOP(OP_OR, 0, first, falseop);
3660 scalarboolean(first);
3661 if (first->op_type == OP_CONST) {
3662 if (first->op_private & OPpCONST_BARE &&
3663 first->op_private & OPpCONST_STRICT) {
3664 no_bareword_allowed(first);
3666 if (SvTRUE(((SVOP*)first)->op_sv)) {
3677 NewOp(1101, logop, 1, LOGOP);
3678 logop->op_type = OP_COND_EXPR;
3679 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3680 logop->op_first = first;
3681 logop->op_flags = (U8)(flags | OPf_KIDS);
3682 logop->op_private = (U8)(1 | (flags >> 8));
3683 logop->op_other = LINKLIST(trueop);
3684 logop->op_next = LINKLIST(falseop);
3686 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
3689 /* establish postfix order */
3690 start = LINKLIST(first);
3691 first->op_next = (OP*)logop;
3693 first->op_sibling = trueop;
3694 trueop->op_sibling = falseop;
3695 o = newUNOP(OP_NULL, 0, (OP*)logop);
3697 trueop->op_next = falseop->op_next = o;
3704 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3713 NewOp(1101, range, 1, LOGOP);
3715 range->op_type = OP_RANGE;
3716 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3717 range->op_first = left;
3718 range->op_flags = OPf_KIDS;
3719 leftstart = LINKLIST(left);
3720 range->op_other = LINKLIST(right);
3721 range->op_private = (U8)(1 | (flags >> 8));
3723 left->op_sibling = right;
3725 range->op_next = (OP*)range;
3726 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3727 flop = newUNOP(OP_FLOP, 0, flip);
3728 o = newUNOP(OP_NULL, 0, flop);
3730 range->op_next = leftstart;
3732 left->op_next = flip;
3733 right->op_next = flop;
3735 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3736 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3737 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3738 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3740 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3741 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3744 if (!flip->op_private || !flop->op_private)
3745 linklist(o); /* blow off optimizer unless constant */
3751 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3755 const bool once = block && block->op_flags & OPf_SPECIAL &&
3756 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3758 PERL_UNUSED_ARG(debuggable);
3761 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3762 return block; /* do {} while 0 does once */
3763 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3764 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3765 expr = newUNOP(OP_DEFINED, 0,
3766 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3767 } else if (expr->op_flags & OPf_KIDS) {
3768 const OP * const k1 = ((UNOP*)expr)->op_first;
3769 const OP * const k2 = k1 ? k1->op_sibling : NULL;
3770 switch (expr->op_type) {
3772 if (k2 && k2->op_type == OP_READLINE
3773 && (k2->op_flags & OPf_STACKED)
3774 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3775 expr = newUNOP(OP_DEFINED, 0, expr);
3779 if (k1->op_type == OP_READDIR
3780 || k1->op_type == OP_GLOB
3781 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3782 || k1->op_type == OP_EACH)
3783 expr = newUNOP(OP_DEFINED, 0, expr);
3789 /* if block is null, the next append_elem() would put UNSTACK, a scalar
3790 * op, in listop. This is wrong. [perl #27024] */
3792 block = newOP(OP_NULL, 0);
3793 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3794 o = new_logop(OP_AND, 0, &expr, &listop);
3797 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3799 if (once && o != listop)
3800 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3803 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3805 o->op_flags |= flags;
3807 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3812 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
3813 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
3822 PERL_UNUSED_ARG(debuggable);
3825 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3826 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3827 expr = newUNOP(OP_DEFINED, 0,
3828 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3829 } else if (expr->op_flags & OPf_KIDS) {
3830 const OP * const k1 = ((UNOP*)expr)->op_first;
3831 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
3832 switch (expr->op_type) {
3834 if (k2 && k2->op_type == OP_READLINE
3835 && (k2->op_flags & OPf_STACKED)
3836 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3837 expr = newUNOP(OP_DEFINED, 0, expr);
3841 if (k1->op_type == OP_READDIR
3842 || k1->op_type == OP_GLOB
3843 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3844 || k1->op_type == OP_EACH)
3845 expr = newUNOP(OP_DEFINED, 0, expr);
3852 block = newOP(OP_NULL, 0);
3853 else if (cont || has_my) {
3854 block = scope(block);
3858 next = LINKLIST(cont);
3861 OP * const unstack = newOP(OP_UNSTACK, 0);
3864 cont = append_elem(OP_LINESEQ, cont, unstack);
3867 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3868 redo = LINKLIST(listop);
3871 PL_copline = (line_t)whileline;
3873 o = new_logop(OP_AND, 0, &expr, &listop);
3874 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3875 op_free(expr); /* oops, it's a while (0) */
3877 return Nullop; /* listop already freed by new_logop */
3880 ((LISTOP*)listop)->op_last->op_next =
3881 (o == listop ? redo : LINKLIST(o));
3887 NewOp(1101,loop,1,LOOP);
3888 loop->op_type = OP_ENTERLOOP;
3889 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3890 loop->op_private = 0;
3891 loop->op_next = (OP*)loop;
3894 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
3896 loop->op_redoop = redo;
3897 loop->op_lastop = o;
3898 o->op_private |= loopflags;
3901 loop->op_nextop = next;
3903 loop->op_nextop = o;
3905 o->op_flags |= flags;
3906 o->op_private |= (flags >> 8);
3911 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
3916 PADOFFSET padoff = 0;
3921 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
3922 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
3923 sv->op_type = OP_RV2GV;
3924 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
3925 if (cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
3926 iterpflags |= OPpITER_DEF;
3928 else if (sv->op_type == OP_PADSV) { /* private variable */
3929 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
3930 padoff = sv->op_targ;
3935 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
3936 padoff = sv->op_targ;
3938 iterflags |= OPf_SPECIAL;
3943 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
3944 if (padoff && strEQ(PAD_COMPNAME_PV(padoff), "$_"))
3945 iterpflags |= OPpITER_DEF;
3948 const I32 offset = pad_findmy("$_");
3949 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
3950 sv = newGVOP(OP_GV, 0, PL_defgv);
3955 iterpflags |= OPpITER_DEF;
3957 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
3958 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
3959 iterflags |= OPf_STACKED;
3961 else if (expr->op_type == OP_NULL &&
3962 (expr->op_flags & OPf_KIDS) &&
3963 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
3965 /* Basically turn for($x..$y) into the same as for($x,$y), but we
3966 * set the STACKED flag to indicate that these values are to be
3967 * treated as min/max values by 'pp_iterinit'.
3969 UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
3970 LOGOP* const range = (LOGOP*) flip->op_first;
3971 OP* const left = range->op_first;
3972 OP* const right = left->op_sibling;
3975 range->op_flags &= ~OPf_KIDS;
3976 range->op_first = Nullop;
3978 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
3979 listop->op_first->op_next = range->op_next;
3980 left->op_next = range->op_other;
3981 right->op_next = (OP*)listop;
3982 listop->op_next = listop->op_first;
3985 expr = (OP*)(listop);
3987 iterflags |= OPf_STACKED;
3990 expr = mod(force_list(expr), OP_GREPSTART);
3993 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
3994 append_elem(OP_LIST, expr, scalar(sv))));
3995 assert(!loop->op_next);
3996 /* for my $x () sets OPpLVAL_INTRO;
3997 * for our $x () sets OPpOUR_INTRO */
3998 loop->op_private = (U8)iterpflags;
3999 #ifdef PL_OP_SLAB_ALLOC
4002 NewOp(1234,tmp,1,LOOP);
4003 Copy(loop,tmp,1,LISTOP);
4008 Renew(loop, 1, LOOP);
4010 loop->op_targ = padoff;
4011 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
4012 PL_copline = forline;
4013 return newSTATEOP(0, label, wop);
4017 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4021 if (type != OP_GOTO || label->op_type == OP_CONST) {
4022 /* "last()" means "last" */
4023 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4024 o = newOP(type, OPf_SPECIAL);
4026 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4027 ? SvPVx_nolen_const(((SVOP*)label)->op_sv)
4033 /* Check whether it's going to be a goto &function */
4034 if (label->op_type == OP_ENTERSUB
4035 && !(label->op_flags & OPf_STACKED))
4036 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4037 o = newUNOP(type, OPf_STACKED, label);
4039 PL_hints |= HINT_BLOCK_SCOPE;
4043 /* if the condition is a literal array or hash
4044 (or @{ ... } etc), make a reference to it.
4047 S_ref_array_or_hash(pTHX_ OP *cond)
4050 && (cond->op_type == OP_RV2AV
4051 || cond->op_type == OP_PADAV
4052 || cond->op_type == OP_RV2HV
4053 || cond->op_type == OP_PADHV))
4055 return newUNOP(OP_REFGEN,
4056 0, mod(cond, OP_REFGEN));
4062 /* These construct the optree fragments representing given()
4065 entergiven and enterwhen are LOGOPs; the op_other pointer
4066 points up to the associated leave op. We need this so we
4067 can put it in the context and make break/continue work.
4068 (Also, of course, pp_enterwhen will jump straight to
4069 op_other if the match fails.)
4074 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
4075 I32 enter_opcode, I32 leave_opcode,
4076 PADOFFSET entertarg)
4081 NewOp(1101, enterop, 1, LOGOP);
4082 enterop->op_type = enter_opcode;
4083 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
4084 enterop->op_flags = (U8) OPf_KIDS;
4085 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
4086 enterop->op_private = 0;
4088 o = newUNOP(leave_opcode, 0, (OP *) enterop);
4091 enterop->op_first = scalar(cond);
4092 cond->op_sibling = block;
4094 o->op_next = LINKLIST(cond);
4095 cond->op_next = (OP *) enterop;
4098 /* This is a default {} block */
4099 enterop->op_first = block;
4100 enterop->op_flags |= OPf_SPECIAL;
4102 o->op_next = (OP *) enterop;
4105 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
4106 entergiven and enterwhen both
4109 enterop->op_next = LINKLIST(block);
4110 block->op_next = enterop->op_other = o;
4115 /* Does this look like a boolean operation? For these purposes
4116 a boolean operation is:
4117 - a subroutine call [*]
4118 - a logical connective
4119 - a comparison operator
4120 - a filetest operator, with the exception of -s -M -A -C
4121 - defined(), exists() or eof()
4122 - /$re/ or $foo =~ /$re/
4124 [*] possibly surprising
4128 S_looks_like_bool(pTHX_ OP *o)
4130 switch(o->op_type) {
4132 return looks_like_bool(cLOGOPo->op_first);
4136 looks_like_bool(cLOGOPo->op_first)
4137 && looks_like_bool(cLOGOPo->op_first->op_sibling));
4141 case OP_NOT: case OP_XOR:
4142 /* Note that OP_DOR is not here */
4144 case OP_EQ: case OP_NE: case OP_LT:
4145 case OP_GT: case OP_LE: case OP_GE:
4147 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
4148 case OP_I_GT: case OP_I_LE: case OP_I_GE:
4150 case OP_SEQ: case OP_SNE: case OP_SLT:
4151 case OP_SGT: case OP_SLE: case OP_SGE:
4155 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
4156 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
4157 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
4158 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
4159 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
4160 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
4161 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
4162 case OP_FTTEXT: case OP_FTBINARY:
4164 case OP_DEFINED: case OP_EXISTS:
4165 case OP_MATCH: case OP_EOF:
4170 /* Detect comparisons that have been optimized away */
4171 if (cSVOPo->op_sv == &PL_sv_yes
4172 || cSVOPo->op_sv == &PL_sv_no)
4183 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
4186 return newGIVWHENOP(
4187 ref_array_or_hash(cond),
4189 OP_ENTERGIVEN, OP_LEAVEGIVEN,
4193 /* If cond is null, this is a default {} block */
4195 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
4197 bool cond_llb = (!cond || looks_like_bool(cond));
4203 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
4205 scalar(ref_array_or_hash(cond)));
4208 return newGIVWHENOP(
4210 append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
4211 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
4215 =for apidoc cv_undef
4217 Clear out all the active components of a CV. This can happen either
4218 by an explicit C<undef &foo>, or by the reference count going to zero.
4219 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
4220 children can still follow the full lexical scope chain.
4226 Perl_cv_undef(pTHX_ CV *cv)
4230 if (CvFILE(cv) && !CvXSUB(cv)) {
4231 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4232 Safefree(CvFILE(cv));
4237 if (!CvXSUB(cv) && CvROOT(cv)) {
4239 Perl_croak(aTHX_ "Can't undef active subroutine");
4242 PAD_SAVE_SETNULLPAD();
4244 op_free(CvROOT(cv));
4245 CvROOT(cv) = Nullop;
4246 CvSTART(cv) = Nullop;
4249 SvPOK_off((SV*)cv); /* forget prototype */
4254 /* remove CvOUTSIDE unless this is an undef rather than a free */
4255 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
4256 if (!CvWEAKOUTSIDE(cv))
4257 SvREFCNT_dec(CvOUTSIDE(cv));
4258 CvOUTSIDE(cv) = Nullcv;
4261 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4267 /* delete all flags except WEAKOUTSIDE */
4268 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
4272 Perl_cv_ckproto(pTHX_ const CV *cv, const GV *gv, const char *p)
4274 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX_const(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4275 SV* const msg = sv_newmortal();
4279 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4280 sv_setpv(msg, "Prototype mismatch:");
4282 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4284 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (const SV *)cv);
4286 Perl_sv_catpv(aTHX_ msg, ": none");
4287 sv_catpv(msg, " vs ");
4289 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4291 sv_catpv(msg, "none");
4292 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
4296 static void const_sv_xsub(pTHX_ CV* cv);
4300 =head1 Optree Manipulation Functions
4302 =for apidoc cv_const_sv
4304 If C<cv> is a constant sub eligible for inlining. returns the constant
4305 value returned by the sub. Otherwise, returns NULL.
4307 Constant subs can be created with C<newCONSTSUB> or as described in
4308 L<perlsub/"Constant Functions">.
4313 Perl_cv_const_sv(pTHX_ CV *cv)
4315 if (!cv || !CvCONST(cv))
4317 return (SV*)CvXSUBANY(cv).any_ptr;
4320 /* op_const_sv: examine an optree to determine whether it's in-lineable.
4321 * Can be called in 3 ways:
4324 * look for a single OP_CONST with attached value: return the value
4326 * cv && CvCLONE(cv) && !CvCONST(cv)
4328 * examine the clone prototype, and if contains only a single
4329 * OP_CONST referencing a pad const, or a single PADSV referencing
4330 * an outer lexical, return a non-zero value to indicate the CV is
4331 * a candidate for "constizing" at clone time
4335 * We have just cloned an anon prototype that was marked as a const
4336 * candidiate. Try to grab the current value, and in the case of
4337 * PADSV, ignore it if it has multiple references. Return the value.
4341 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
4348 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4349 o = cLISTOPo->op_first->op_sibling;
4351 for (; o; o = o->op_next) {
4352 const OPCODE type = o->op_type;
4354 if (sv && o->op_next == o)
4356 if (o->op_next != o) {
4357 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4359 if (type == OP_DBSTATE)
4362 if (type == OP_LEAVESUB || type == OP_RETURN)
4366 if (type == OP_CONST && cSVOPo->op_sv)
4368 else if (cv && type == OP_CONST) {
4369 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4373 else if (cv && type == OP_PADSV) {
4374 if (CvCONST(cv)) { /* newly cloned anon */
4375 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4376 /* the candidate should have 1 ref from this pad and 1 ref
4377 * from the parent */
4378 if (!sv || SvREFCNT(sv) != 2)
4385 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
4386 sv = &PL_sv_undef; /* an arbitrary non-null value */
4397 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4399 PERL_UNUSED_ARG(floor);
4409 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4413 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4415 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4419 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4430 const char * const name = o ? SvPVx_nolen_const(cSVOPo->op_sv) : Nullch;
4433 assert(proto->op_type == OP_CONST);
4434 ps = SvPVx_const(((SVOP*)proto)->op_sv, ps_len);
4439 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4440 SV * const sv = sv_newmortal();
4441 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4442 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
4443 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4444 aname = SvPVX_const(sv);
4449 gv_fetch_flags = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
4450 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
4451 gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
4452 : gv_fetchpv(aname ? aname
4453 : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4454 gv_fetch_flags, SVt_PVCV);
4463 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4464 maximum a prototype before. */
4465 if (SvTYPE(gv) > SVt_NULL) {
4466 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4467 && ckWARN_d(WARN_PROTOTYPE))
4469 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
4471 cv_ckproto((CV*)gv, NULL, ps);
4474 sv_setpvn((SV*)gv, ps, ps_len);
4476 sv_setiv((SV*)gv, -1);
4477 SvREFCNT_dec(PL_compcv);
4478 cv = PL_compcv = NULL;
4479 PL_sub_generation++;
4483 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4485 #ifdef GV_UNIQUE_CHECK
4486 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4487 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4491 if (!block || !ps || *ps || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
4494 const_sv = op_const_sv(block, Nullcv);
4497 const bool exists = CvROOT(cv) || CvXSUB(cv);
4499 #ifdef GV_UNIQUE_CHECK
4500 if (exists && GvUNIQUE(gv)) {
4501 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4505 /* if the subroutine doesn't exist and wasn't pre-declared
4506 * with a prototype, assume it will be AUTOLOADed,
4507 * skipping the prototype check
4509 if (exists || SvPOK(cv))
4510 cv_ckproto(cv, gv, ps);
4511 /* already defined (or promised)? */
4512 if (exists || GvASSUMECV(gv)) {
4513 if (!block && !attrs) {
4514 if (CvFLAGS(PL_compcv)) {
4515 /* might have had built-in attrs applied */
4516 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4518 /* just a "sub foo;" when &foo is already defined */
4519 SAVEFREESV(PL_compcv);
4523 if (ckWARN(WARN_REDEFINE)
4525 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4527 const line_t oldline = CopLINE(PL_curcop);
4528 if (PL_copline != NOLINE)
4529 CopLINE_set(PL_curcop, PL_copline);
4530 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4531 CvCONST(cv) ? "Constant subroutine %s redefined"
4532 : "Subroutine %s redefined", name);
4533 CopLINE_set(PL_curcop, oldline);
4541 (void)SvREFCNT_inc(const_sv);
4543 assert(!CvROOT(cv) && !CvCONST(cv));
4544 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
4545 CvXSUBANY(cv).any_ptr = const_sv;
4546 CvXSUB(cv) = const_sv_xsub;
4551 cv = newCONSTSUB(NULL, name, const_sv);
4554 SvREFCNT_dec(PL_compcv);
4556 PL_sub_generation++;
4563 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4564 * before we clobber PL_compcv.
4568 /* Might have had built-in attributes applied -- propagate them. */
4569 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4570 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4571 stash = GvSTASH(CvGV(cv));
4572 else if (CvSTASH(cv))
4573 stash = CvSTASH(cv);
4575 stash = PL_curstash;
4578 /* possibly about to re-define existing subr -- ignore old cv */
4579 rcv = (SV*)PL_compcv;
4580 if (name && GvSTASH(gv))
4581 stash = GvSTASH(gv);
4583 stash = PL_curstash;
4585 apply_attrs(stash, rcv, attrs, FALSE);
4587 if (cv) { /* must reuse cv if autoloaded */
4589 /* got here with just attrs -- work done, so bug out */
4590 SAVEFREESV(PL_compcv);
4593 /* transfer PL_compcv to cv */
4595 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4596 if (!CvWEAKOUTSIDE(cv))
4597 SvREFCNT_dec(CvOUTSIDE(cv));
4598 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4599 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
4600 CvOUTSIDE(PL_compcv) = 0;
4601 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4602 CvPADLIST(PL_compcv) = 0;
4603 /* inner references to PL_compcv must be fixed up ... */
4604 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
4605 /* ... before we throw it away */
4606 SvREFCNT_dec(PL_compcv);
4608 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4609 ++PL_sub_generation;
4616 PL_sub_generation++;
4620 CvFILE_set_from_cop(cv, PL_curcop);
4621 CvSTASH(cv) = PL_curstash;
4624 sv_setpvn((SV*)cv, ps, ps_len);
4626 if (PL_error_count) {
4630 const char *s = strrchr(name, ':');
4632 if (strEQ(s, "BEGIN")) {
4633 const char not_safe[] =
4634 "BEGIN not safe after errors--compilation aborted";
4635 if (PL_in_eval & EVAL_KEEPERR)
4636 Perl_croak(aTHX_ not_safe);
4638 /* force display of errors found but not reported */
4639 sv_catpv(ERRSV, not_safe);
4640 Perl_croak(aTHX_ "%"SVf, ERRSV);
4649 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4650 mod(scalarseq(block), OP_LEAVESUBLV));
4653 /* This makes sub {}; work as expected. */
4654 if (block->op_type == OP_STUB) {
4656 block = newSTATEOP(0, Nullch, 0);
4658 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4660 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4661 OpREFCNT_set(CvROOT(cv), 1);
4662 CvSTART(cv) = LINKLIST(CvROOT(cv));
4663 CvROOT(cv)->op_next = 0;
4664 CALL_PEEP(CvSTART(cv));
4666 /* now that optimizer has done its work, adjust pad values */
4668 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4671 assert(!CvCONST(cv));
4672 if (ps && !*ps && op_const_sv(block, cv))
4676 if (name || aname) {
4678 const char * const tname = (name ? name : aname);
4680 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4681 SV * const sv = NEWSV(0,0);
4682 SV * const tmpstr = sv_newmortal();
4683 GV * const db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4686 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4688 (long)PL_subline, (long)CopLINE(PL_curcop));
4689 gv_efullname3(tmpstr, gv, Nullch);
4690 hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0);
4691 hv = GvHVn(db_postponed);
4692 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
4693 CV * const pcv = GvCV(db_postponed);
4699 call_sv((SV*)pcv, G_DISCARD);
4704 if ((s = strrchr(tname,':')))
4709 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4712 if (strEQ(s, "BEGIN") && !PL_error_count) {
4713 const I32 oldscope = PL_scopestack_ix;
4715 SAVECOPFILE(&PL_compiling);
4716 SAVECOPLINE(&PL_compiling);
4719 PL_beginav = newAV();
4720 DEBUG_x( dump_sub(gv) );
4721 av_push(PL_beginav, (SV*)cv);
4722 GvCV(gv) = 0; /* cv has been hijacked */
4723 call_list(oldscope, PL_beginav);
4725 PL_curcop = &PL_compiling;
4726 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4729 else if (strEQ(s, "END") && !PL_error_count) {
4732 DEBUG_x( dump_sub(gv) );
4733 av_unshift(PL_endav, 1);
4734 av_store(PL_endav, 0, (SV*)cv);
4735 GvCV(gv) = 0; /* cv has been hijacked */
4737 else if (strEQ(s, "CHECK") && !PL_error_count) {
4739 PL_checkav = newAV();
4740 DEBUG_x( dump_sub(gv) );
4741 if (PL_main_start && ckWARN(WARN_VOID))
4742 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4743 av_unshift(PL_checkav, 1);
4744 av_store(PL_checkav, 0, (SV*)cv);
4745 GvCV(gv) = 0; /* cv has been hijacked */
4747 else if (strEQ(s, "INIT") && !PL_error_count) {
4749 PL_initav = newAV();
4750 DEBUG_x( dump_sub(gv) );
4751 if (PL_main_start && ckWARN(WARN_VOID))
4752 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4753 av_push(PL_initav, (SV*)cv);
4754 GvCV(gv) = 0; /* cv has been hijacked */
4759 PL_copline = NOLINE;
4764 /* XXX unsafe for threads if eval_owner isn't held */
4766 =for apidoc newCONSTSUB
4768 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4769 eligible for inlining at compile-time.
4775 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
4782 SAVECOPLINE(PL_curcop);
4783 CopLINE_set(PL_curcop, PL_copline);
4786 PL_hints &= ~HINT_BLOCK_SCOPE;
4789 SAVESPTR(PL_curstash);
4790 SAVECOPSTASH(PL_curcop);
4791 PL_curstash = stash;
4792 CopSTASH_set(PL_curcop,stash);
4795 cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
4796 CvXSUBANY(cv).any_ptr = sv;
4798 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
4802 CopSTASH_free(PL_curcop);
4810 =for apidoc U||newXS
4812 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4818 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
4820 GV * const gv = gv_fetchpv(name ? name :
4821 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4822 GV_ADDMULTI, SVt_PVCV);
4826 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4828 if ((cv = (name ? GvCV(gv) : Nullcv))) {
4830 /* just a cached method */
4834 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4835 /* already defined (or promised) */
4836 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
4837 if (ckWARN(WARN_REDEFINE)) {
4838 GV * const gvcv = CvGV(cv);
4840 HV * const stash = GvSTASH(gvcv);
4842 const char *name = HvNAME_get(stash);
4843 if ( strEQ(name,"autouse") ) {
4844 const line_t oldline = CopLINE(PL_curcop);
4845 if (PL_copline != NOLINE)
4846 CopLINE_set(PL_curcop, PL_copline);
4847 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4848 CvCONST(cv) ? "Constant subroutine %s redefined"
4849 : "Subroutine %s redefined"
4851 CopLINE_set(PL_curcop, oldline);
4861 if (cv) /* must reuse cv if autoloaded */
4864 cv = (CV*)NEWSV(1105,0);
4865 sv_upgrade((SV *)cv, SVt_PVCV);
4869 PL_sub_generation++;
4873 (void)gv_fetchfile(filename);
4874 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
4875 an external constant string */
4876 CvXSUB(cv) = subaddr;
4879 const char *s = strrchr(name,':');
4885 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4888 if (strEQ(s, "BEGIN")) {
4890 PL_beginav = newAV();
4891 av_push(PL_beginav, (SV*)cv);
4892 GvCV(gv) = 0; /* cv has been hijacked */
4894 else if (strEQ(s, "END")) {
4897 av_unshift(PL_endav, 1);
4898 av_store(PL_endav, 0, (SV*)cv);
4899 GvCV(gv) = 0; /* cv has been hijacked */
4901 else if (strEQ(s, "CHECK")) {
4903 PL_checkav = newAV();
4904 if (PL_main_start && ckWARN(WARN_VOID))
4905 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4906 av_unshift(PL_checkav, 1);
4907 av_store(PL_checkav, 0, (SV*)cv);
4908 GvCV(gv) = 0; /* cv has been hijacked */
4910 else if (strEQ(s, "INIT")) {
4912 PL_initav = newAV();
4913 if (PL_main_start && ckWARN(WARN_VOID))
4914 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4915 av_push(PL_initav, (SV*)cv);
4916 GvCV(gv) = 0; /* cv has been hijacked */
4927 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4932 ? gv_fetchsv(cSVOPo->op_sv, TRUE, SVt_PVFM)
4933 : gv_fetchpv("STDOUT", TRUE, SVt_PVFM);
4935 #ifdef GV_UNIQUE_CHECK
4937 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
4941 if ((cv = GvFORM(gv))) {
4942 if (ckWARN(WARN_REDEFINE)) {
4943 const line_t oldline = CopLINE(PL_curcop);
4944 if (PL_copline != NOLINE)
4945 CopLINE_set(PL_curcop, PL_copline);
4946 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4947 o ? "Format %"SVf" redefined"
4948 : "Format STDOUT redefined" ,cSVOPo->op_sv);
4949 CopLINE_set(PL_curcop, oldline);
4956 CvFILE_set_from_cop(cv, PL_curcop);
4959 pad_tidy(padtidy_FORMAT);
4960 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
4961 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4962 OpREFCNT_set(CvROOT(cv), 1);
4963 CvSTART(cv) = LINKLIST(CvROOT(cv));
4964 CvROOT(cv)->op_next = 0;
4965 CALL_PEEP(CvSTART(cv));
4967 PL_copline = NOLINE;
4972 Perl_newANONLIST(pTHX_ OP *o)
4974 return newUNOP(OP_REFGEN, 0,
4975 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
4979 Perl_newANONHASH(pTHX_ OP *o)
4981 return newUNOP(OP_REFGEN, 0,
4982 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
4986 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
4988 return newANONATTRSUB(floor, proto, Nullop, block);
4992 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
4994 return newUNOP(OP_REFGEN, 0,
4995 newSVOP(OP_ANONCODE, 0,
4996 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5000 Perl_oopsAV(pTHX_ OP *o)
5003 switch (o->op_type) {
5005 o->op_type = OP_PADAV;
5006 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5007 return ref(o, OP_RV2AV);
5010 o->op_type = OP_RV2AV;
5011 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5016 if (ckWARN_d(WARN_INTERNAL))
5017 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
5024 Perl_oopsHV(pTHX_ OP *o)
5027 switch (o->op_type) {
5030 o->op_type = OP_PADHV;
5031 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5032 return ref(o, OP_RV2HV);
5036 o->op_type = OP_RV2HV;
5037 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5042 if (ckWARN_d(WARN_INTERNAL))
5043 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
5050 Perl_newAVREF(pTHX_ OP *o)
5053 if (o->op_type == OP_PADANY) {
5054 o->op_type = OP_PADAV;
5055 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5058 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5059 && ckWARN(WARN_DEPRECATED)) {
5060 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5061 "Using an array as a reference is deprecated");
5063 return newUNOP(OP_RV2AV, 0, scalar(o));
5067 Perl_newGVREF(pTHX_ I32 type, OP *o)
5069 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5070 return newUNOP(OP_NULL, 0, o);
5071 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5075 Perl_newHVREF(pTHX_ OP *o)
5078 if (o->op_type == OP_PADANY) {
5079 o->op_type = OP_PADHV;
5080 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5083 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5084 && ckWARN(WARN_DEPRECATED)) {
5085 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5086 "Using a hash as a reference is deprecated");
5088 return newUNOP(OP_RV2HV, 0, scalar(o));
5092 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5094 return newUNOP(OP_RV2CV, flags, scalar(o));
5098 Perl_newSVREF(pTHX_ OP *o)
5101 if (o->op_type == OP_PADANY) {
5102 o->op_type = OP_PADSV;
5103 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5106 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5107 o->op_flags |= OPpDONE_SVREF;
5110 return newUNOP(OP_RV2SV, 0, scalar(o));
5113 /* Check routines. See the comments at the top of this file for details
5114 * on when these are called */
5117 Perl_ck_anoncode(pTHX_ OP *o)
5119 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
5120 cSVOPo->op_sv = Nullsv;
5125 Perl_ck_bitop(pTHX_ OP *o)
5127 #define OP_IS_NUMCOMPARE(op) \
5128 ((op) == OP_LT || (op) == OP_I_LT || \
5129 (op) == OP_GT || (op) == OP_I_GT || \
5130 (op) == OP_LE || (op) == OP_I_LE || \
5131 (op) == OP_GE || (op) == OP_I_GE || \
5132 (op) == OP_EQ || (op) == OP_I_EQ || \
5133 (op) == OP_NE || (op) == OP_I_NE || \
5134 (op) == OP_NCMP || (op) == OP_I_NCMP)
5135 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
5136 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
5137 && (o->op_type == OP_BIT_OR
5138 || o->op_type == OP_BIT_AND
5139 || o->op_type == OP_BIT_XOR))
5141 const OP * const left = cBINOPo->op_first;
5142 const OP * const right = left->op_sibling;
5143 if ((OP_IS_NUMCOMPARE(left->op_type) &&
5144 (left->op_flags & OPf_PARENS) == 0) ||
5145 (OP_IS_NUMCOMPARE(right->op_type) &&
5146 (right->op_flags & OPf_PARENS) == 0))
5147 if (ckWARN(WARN_PRECEDENCE))
5148 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
5149 "Possible precedence problem on bitwise %c operator",
5150 o->op_type == OP_BIT_OR ? '|'
5151 : o->op_type == OP_BIT_AND ? '&' : '^'
5158 Perl_ck_concat(pTHX_ OP *o)
5160 const OP * const kid = cUNOPo->op_first;
5161 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
5162 !(kUNOP->op_first->op_flags & OPf_MOD))
5163 o->op_flags |= OPf_STACKED;
5168 Perl_ck_spair(pTHX_ OP *o)
5171 if (o->op_flags & OPf_KIDS) {
5174 const OPCODE type = o->op_type;
5175 o = modkids(ck_fun(o), type);
5176 kid = cUNOPo->op_first;
5177 newop = kUNOP->op_first->op_sibling;
5179 (newop->op_sibling ||
5180 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5181 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5182 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5186 op_free(kUNOP->op_first);
5187 kUNOP->op_first = newop;
5189 o->op_ppaddr = PL_ppaddr[++o->op_type];
5194 Perl_ck_delete(pTHX_ OP *o)
5198 if (o->op_flags & OPf_KIDS) {
5199 OP * const kid = cUNOPo->op_first;
5200 switch (kid->op_type) {
5202 o->op_flags |= OPf_SPECIAL;
5205 o->op_private |= OPpSLICE;
5208 o->op_flags |= OPf_SPECIAL;
5213 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5222 Perl_ck_die(pTHX_ OP *o)
5225 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5231 Perl_ck_eof(pTHX_ OP *o)
5233 const I32 type = o->op_type;
5235 if (o->op_flags & OPf_KIDS) {
5236 if (cLISTOPo->op_first->op_type == OP_STUB) {
5238 o = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
5246 Perl_ck_eval(pTHX_ OP *o)
5249 PL_hints |= HINT_BLOCK_SCOPE;
5250 if (o->op_flags & OPf_KIDS) {
5251 SVOP * const kid = (SVOP*)cUNOPo->op_first;
5254 o->op_flags &= ~OPf_KIDS;
5257 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
5260 cUNOPo->op_first = 0;
5263 NewOp(1101, enter, 1, LOGOP);
5264 enter->op_type = OP_ENTERTRY;
5265 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5266 enter->op_private = 0;
5268 /* establish postfix order */
5269 enter->op_next = (OP*)enter;
5271 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5272 o->op_type = OP_LEAVETRY;
5273 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5274 enter->op_other = o;
5284 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5286 o->op_targ = (PADOFFSET)PL_hints;
5287 if ((PL_hints & HINT_HH_FOR_EVAL) != 0 && GvHV(PL_hintgv))
5289 /* Store a copy of %^H that pp_entereval can pick up */
5290 OP *hhop = newSVOP(OP_CONST, 0, (SV*)newHVhv(GvHV(PL_hintgv)));
5291 cUNOPo->op_first->op_sibling = hhop;
5292 o->op_private |= OPpEVAL_HAS_HH;
5298 Perl_ck_exit(pTHX_ OP *o)
5301 HV * const table = GvHV(PL_hintgv);
5303 SV * const * const svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5304 if (svp && *svp && SvTRUE(*svp))
5305 o->op_private |= OPpEXIT_VMSISH;
5307 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5313 Perl_ck_exec(pTHX_ OP *o)
5315 if (o->op_flags & OPf_STACKED) {
5318 kid = cUNOPo->op_first->op_sibling;
5319 if (kid->op_type == OP_RV2GV)
5328 Perl_ck_exists(pTHX_ OP *o)
5331 if (o->op_flags & OPf_KIDS) {
5332 OP * const kid = cUNOPo->op_first;
5333 if (kid->op_type == OP_ENTERSUB) {
5334 (void) ref(kid, o->op_type);
5335 if (kid->op_type != OP_RV2CV && !PL_error_count)
5336 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5338 o->op_private |= OPpEXISTS_SUB;
5340 else if (kid->op_type == OP_AELEM)
5341 o->op_flags |= OPf_SPECIAL;
5342 else if (kid->op_type != OP_HELEM)
5343 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5351 Perl_ck_rvconst(pTHX_ register OP *o)
5354 SVOP * const kid = (SVOP*)cUNOPo->op_first;
5356 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5357 if (kid->op_type == OP_CONST) {
5360 SV * const kidsv = kid->op_sv;
5362 /* Is it a constant from cv_const_sv()? */
5363 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5364 SV * const rsv = SvRV(kidsv);
5365 const int svtype = SvTYPE(rsv);
5366 const char *badtype = Nullch;
5368 switch (o->op_type) {
5370 if (svtype > SVt_PVMG)
5371 badtype = "a SCALAR";
5374 if (svtype != SVt_PVAV)
5375 badtype = "an ARRAY";
5378 if (svtype != SVt_PVHV)
5382 if (svtype != SVt_PVCV)
5387 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5390 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5391 const char *badthing = Nullch;
5392 switch (o->op_type) {
5394 badthing = "a SCALAR";
5397 badthing = "an ARRAY";
5400 badthing = "a HASH";
5405 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
5409 * This is a little tricky. We only want to add the symbol if we
5410 * didn't add it in the lexer. Otherwise we get duplicate strict
5411 * warnings. But if we didn't add it in the lexer, we must at
5412 * least pretend like we wanted to add it even if it existed before,
5413 * or we get possible typo warnings. OPpCONST_ENTERED says
5414 * whether the lexer already added THIS instance of this symbol.
5416 iscv = (o->op_type == OP_RV2CV) * 2;
5418 gv = gv_fetchsv(kidsv,
5419 iscv | !(kid->op_private & OPpCONST_ENTERED),
5422 : o->op_type == OP_RV2SV
5424 : o->op_type == OP_RV2AV
5426 : o->op_type == OP_RV2HV
5429 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5431 kid->op_type = OP_GV;
5432 SvREFCNT_dec(kid->op_sv);
5434 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5435 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5436 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
5438 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv));
5440 kid->op_sv = SvREFCNT_inc(gv);
5442 kid->op_private = 0;
5443 kid->op_ppaddr = PL_ppaddr[OP_GV];
5450 Perl_ck_ftst(pTHX_ OP *o)
5453 const I32 type = o->op_type;
5455 if (o->op_flags & OPf_REF) {
5458 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5459 SVOP * const kid = (SVOP*)cUNOPo->op_first;
5461 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5462 OP * const newop = newGVOP(type, OPf_REF,
5463 gv_fetchsv(kid->op_sv, TRUE, SVt_PVIO));
5469 if ((PL_hints & HINT_FILETEST_ACCESS) &&
5470 OP_IS_FILETEST_ACCESS(o))
5471 o->op_private |= OPpFT_ACCESS;
5473 if (PL_check[kid->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst)
5474 && kid->op_type != OP_STAT && kid->op_type != OP_LSTAT)
5475 o->op_private |= OPpFT_STACKED;
5479 if (type == OP_FTTTY)
5480 o = newGVOP(type, OPf_REF, PL_stdingv);
5482 o = newUNOP(type, 0, newDEFSVOP());
5488 Perl_ck_fun(pTHX_ OP *o)
5490 const int type = o->op_type;
5491 register I32 oa = PL_opargs[type] >> OASHIFT;
5493 if (o->op_flags & OPf_STACKED) {
5494 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5497 return no_fh_allowed(o);
5500 if (o->op_flags & OPf_KIDS) {
5501 OP **tokid = &cLISTOPo->op_first;
5502 register OP *kid = cLISTOPo->op_first;
5506 if (kid->op_type == OP_PUSHMARK ||
5507 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5509 tokid = &kid->op_sibling;
5510 kid = kid->op_sibling;
5512 if (!kid && PL_opargs[type] & OA_DEFGV)
5513 *tokid = kid = newDEFSVOP();
5517 sibl = kid->op_sibling;
5520 /* list seen where single (scalar) arg expected? */
5521 if (numargs == 1 && !(oa >> 4)
5522 && kid->op_type == OP_LIST && type != OP_SCALAR)
5524 return too_many_arguments(o,PL_op_desc[type]);
5537 if ((type == OP_PUSH || type == OP_UNSHIFT)
5538 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5539 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5540 "Useless use of %s with no values",
5543 if (kid->op_type == OP_CONST &&
5544 (kid->op_private & OPpCONST_BARE))
5546 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
5547 gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVAV) ));
5548 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5549 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5550 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
5551 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
5554 kid->op_sibling = sibl;
5557 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5558 bad_type(numargs, "array", PL_op_desc[type], kid);
5562 if (kid->op_type == OP_CONST &&
5563 (kid->op_private & OPpCONST_BARE))
5565 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
5566 gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVHV) ));
5567 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5568 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5569 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
5570 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
5573 kid->op_sibling = sibl;
5576 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5577 bad_type(numargs, "hash", PL_op_desc[type], kid);
5582 OP * const newop = newUNOP(OP_NULL, 0, kid);
5583 kid->op_sibling = 0;
5585 newop->op_next = newop;
5587 kid->op_sibling = sibl;
5592 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5593 if (kid->op_type == OP_CONST &&
5594 (kid->op_private & OPpCONST_BARE))
5596 OP * const newop = newGVOP(OP_GV, 0,
5597 gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVIO) );
5598 if (!(o->op_private & 1) && /* if not unop */
5599 kid == cLISTOPo->op_last)
5600 cLISTOPo->op_last = newop;
5604 else if (kid->op_type == OP_READLINE) {
5605 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5606 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5609 I32 flags = OPf_SPECIAL;
5613 /* is this op a FH constructor? */
5614 if (is_handle_constructor(o,numargs)) {
5615 const char *name = Nullch;
5619 /* Set a flag to tell rv2gv to vivify
5620 * need to "prove" flag does not mean something
5621 * else already - NI-S 1999/05/07
5624 if (kid->op_type == OP_PADSV) {
5625 name = PAD_COMPNAME_PV(kid->op_targ);
5626 /* SvCUR of a pad namesv can't be trusted
5627 * (see PL_generation), so calc its length
5633 else if (kid->op_type == OP_RV2SV
5634 && kUNOP->op_first->op_type == OP_GV)
5636 GV * const gv = cGVOPx_gv(kUNOP->op_first);
5638 len = GvNAMELEN(gv);
5640 else if (kid->op_type == OP_AELEM
5641 || kid->op_type == OP_HELEM)
5643 OP *op = ((BINOP*)kid)->op_first;
5646 SV *tmpstr = Nullsv;
5647 const char * const a =
5648 kid->op_type == OP_AELEM ?
5650 if (((op->op_type == OP_RV2AV) ||
5651 (op->op_type == OP_RV2HV)) &&
5652 (op = ((UNOP*)op)->op_first) &&
5653 (op->op_type == OP_GV)) {
5654 /* packagevar $a[] or $h{} */
5655 GV * const gv = cGVOPx_gv(op);
5663 else if (op->op_type == OP_PADAV
5664 || op->op_type == OP_PADHV) {
5665 /* lexicalvar $a[] or $h{} */
5666 const char * const padname =
5667 PAD_COMPNAME_PV(op->op_targ);
5676 name = SvPV_const(tmpstr, len);
5681 name = "__ANONIO__";
5688 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5689 namesv = PAD_SVl(targ);
5690 SvUPGRADE(namesv, SVt_PV);
5692 sv_setpvn(namesv, "$", 1);
5693 sv_catpvn(namesv, name, len);
5696 kid->op_sibling = 0;
5697 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5698 kid->op_targ = targ;
5699 kid->op_private |= priv;
5701 kid->op_sibling = sibl;
5707 mod(scalar(kid), type);
5711 tokid = &kid->op_sibling;
5712 kid = kid->op_sibling;
5714 o->op_private |= numargs;
5716 return too_many_arguments(o,OP_DESC(o));
5719 else if (PL_opargs[type] & OA_DEFGV) {
5721 return newUNOP(type, 0, newDEFSVOP());
5725 while (oa & OA_OPTIONAL)
5727 if (oa && oa != OA_LIST)
5728 return too_few_arguments(o,OP_DESC(o));
5734 Perl_ck_glob(pTHX_ OP *o)
5740 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5741 append_elem(OP_GLOB, o, newDEFSVOP());
5743 if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
5744 && GvCVu(gv) && GvIMPORTED_CV(gv)))
5746 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5749 #if !defined(PERL_EXTERNAL_GLOB)
5750 /* XXX this can be tightened up and made more failsafe. */
5751 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
5754 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5755 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
5756 gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5757 glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
5758 GvCV(gv) = GvCV(glob_gv);
5759 (void)SvREFCNT_inc((SV*)GvCV(gv));
5760 GvIMPORTED_CV_on(gv);
5763 #endif /* PERL_EXTERNAL_GLOB */
5765 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5766 append_elem(OP_GLOB, o,
5767 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5768 o->op_type = OP_LIST;
5769 o->op_ppaddr = PL_ppaddr[OP_LIST];
5770 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5771 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5772 cLISTOPo->op_first->op_targ = 0;
5773 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5774 append_elem(OP_LIST, o,
5775 scalar(newUNOP(OP_RV2CV, 0,
5776 newGVOP(OP_GV, 0, gv)))));
5777 o = newUNOP(OP_NULL, 0, ck_subr(o));
5778 o->op_targ = OP_GLOB; /* hint at what it used to be */
5781 gv = newGVgen("main");
5783 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5789 Perl_ck_grep(pTHX_ OP *o)
5794 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5797 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5798 NewOp(1101, gwop, 1, LOGOP);
5800 if (o->op_flags & OPf_STACKED) {
5803 kid = cLISTOPo->op_first->op_sibling;
5804 if (!cUNOPx(kid)->op_next)
5805 Perl_croak(aTHX_ "panic: ck_grep");
5806 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
5809 kid->op_next = (OP*)gwop;
5810 o->op_flags &= ~OPf_STACKED;
5812 kid = cLISTOPo->op_first->op_sibling;
5813 if (type == OP_MAPWHILE)
5820 kid = cLISTOPo->op_first->op_sibling;
5821 if (kid->op_type != OP_NULL)
5822 Perl_croak(aTHX_ "panic: ck_grep");
5823 kid = kUNOP->op_first;
5825 gwop->op_type = type;
5826 gwop->op_ppaddr = PL_ppaddr[type];
5827 gwop->op_first = listkids(o);
5828 gwop->op_flags |= OPf_KIDS;
5829 gwop->op_other = LINKLIST(kid);
5830 kid->op_next = (OP*)gwop;
5831 offset = pad_findmy("$_");
5832 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
5833 o->op_private = gwop->op_private = 0;
5834 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5837 o->op_private = gwop->op_private = OPpGREP_LEX;
5838 gwop->op_targ = o->op_targ = offset;
5841 kid = cLISTOPo->op_first->op_sibling;
5842 if (!kid || !kid->op_sibling)
5843 return too_few_arguments(o,OP_DESC(o));
5844 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5845 mod(kid, OP_GREPSTART);
5851 Perl_ck_index(pTHX_ OP *o)
5853 if (o->op_flags & OPf_KIDS) {
5854 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5856 kid = kid->op_sibling; /* get past "big" */
5857 if (kid && kid->op_type == OP_CONST)
5858 fbm_compile(((SVOP*)kid)->op_sv, 0);
5864 Perl_ck_lengthconst(pTHX_ OP *o)
5866 /* XXX length optimization goes here */
5871 Perl_ck_lfun(pTHX_ OP *o)
5873 const OPCODE type = o->op_type;
5874 return modkids(ck_fun(o), type);
5878 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5880 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
5881 switch (cUNOPo->op_first->op_type) {
5883 /* This is needed for
5884 if (defined %stash::)
5885 to work. Do not break Tk.
5887 break; /* Globals via GV can be undef */
5889 case OP_AASSIGN: /* Is this a good idea? */
5890 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5891 "defined(@array) is deprecated");
5892 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5893 "\t(Maybe you should just omit the defined()?)\n");
5896 /* This is needed for
5897 if (defined %stash::)
5898 to work. Do not break Tk.
5900 break; /* Globals via GV can be undef */
5902 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5903 "defined(%%hash) is deprecated");
5904 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5905 "\t(Maybe you should just omit the defined()?)\n");
5916 Perl_ck_rfun(pTHX_ OP *o)
5918 const OPCODE type = o->op_type;
5919 return refkids(ck_fun(o), type);
5923 Perl_ck_listiob(pTHX_ OP *o)
5927 kid = cLISTOPo->op_first;
5930 kid = cLISTOPo->op_first;
5932 if (kid->op_type == OP_PUSHMARK)
5933 kid = kid->op_sibling;
5934 if (kid && o->op_flags & OPf_STACKED)
5935 kid = kid->op_sibling;
5936 else if (kid && !kid->op_sibling) { /* print HANDLE; */
5937 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5938 o->op_flags |= OPf_STACKED; /* make it a filehandle */
5939 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5940 cLISTOPo->op_first->op_sibling = kid;
5941 cLISTOPo->op_last = kid;
5942 kid = kid->op_sibling;
5947 append_elem(o->op_type, o, newDEFSVOP());
5953 Perl_ck_say(pTHX_ OP *o)
5956 o->op_type = OP_PRINT;
5957 cLISTOPo->op_last = cLISTOPo->op_last->op_sibling
5958 = newSVOP(OP_CONST, 0, newSVpvn("\n", 1));
5963 Perl_ck_smartmatch(pTHX_ OP *o)
5965 if (0 == (o->op_flags & OPf_SPECIAL)) {
5966 OP *first = cBINOPo->op_first;
5967 OP *second = first->op_sibling;
5969 /* Implicitly take a reference to an array or hash */
5970 first->op_sibling = Nullop;
5971 first = cBINOPo->op_first = ref_array_or_hash(first);
5972 second = first->op_sibling = ref_array_or_hash(second);
5974 /* Implicitly take a reference to a regular expression */
5975 if (first->op_type == OP_MATCH) {
5976 first->op_type = OP_QR;
5977 first->op_ppaddr = PL_ppaddr[OP_QR];
5979 if (second->op_type == OP_MATCH) {
5980 second->op_type = OP_QR;
5981 second->op_ppaddr = PL_ppaddr[OP_QR];
5990 Perl_ck_sassign(pTHX_ OP *o)
5992 OP *kid = cLISTOPo->op_first;
5993 /* has a disposable target? */
5994 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
5995 && !(kid->op_flags & OPf_STACKED)
5996 /* Cannot steal the second time! */
5997 && !(kid->op_private & OPpTARGET_MY))
5999 OP * const kkid = kid->op_sibling;
6001 /* Can just relocate the target. */
6002 if (kkid && kkid->op_type == OP_PADSV
6003 && !(kkid->op_private & OPpLVAL_INTRO))
6005 kid->op_targ = kkid->op_targ;
6007 /* Now we do not need PADSV and SASSIGN. */
6008 kid->op_sibling = o->op_sibling; /* NULL */
6009 cLISTOPo->op_first = NULL;
6012 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6020 Perl_ck_match(pTHX_ OP *o)
6022 if (o->op_type != OP_QR && PL_compcv) {
6023 const I32 offset = pad_findmy("$_");
6024 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS(offset) & SVpad_OUR)) {
6025 o->op_targ = offset;
6026 o->op_private |= OPpTARGET_MY;
6029 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
6030 o->op_private |= OPpRUNTIME;
6035 Perl_ck_method(pTHX_ OP *o)
6037 OP * const kid = cUNOPo->op_first;
6038 if (kid->op_type == OP_CONST) {
6039 SV* sv = kSVOP->op_sv;
6040 if (!(strchr(SvPVX_const(sv), ':') || strchr(SvPVX_const(sv), '\''))) {
6042 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6043 sv = newSVpvn_share(SvPVX_const(sv), SvCUR(sv), 0);
6046 kSVOP->op_sv = Nullsv;
6048 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6057 Perl_ck_null(pTHX_ OP *o)
6063 Perl_ck_open(pTHX_ OP *o)
6065 HV * const table = GvHV(PL_hintgv);
6067 SV **svp = hv_fetch(table, "open_IN", 7, FALSE);
6069 const I32 mode = mode_from_discipline(*svp);
6070 if (mode & O_BINARY)
6071 o->op_private |= OPpOPEN_IN_RAW;
6072 else if (mode & O_TEXT)
6073 o->op_private |= OPpOPEN_IN_CRLF;
6076 svp = hv_fetch(table, "open_OUT", 8, FALSE);
6078 const I32 mode = mode_from_discipline(*svp);
6079 if (mode & O_BINARY)
6080 o->op_private |= OPpOPEN_OUT_RAW;
6081 else if (mode & O_TEXT)
6082 o->op_private |= OPpOPEN_OUT_CRLF;
6085 if (o->op_type == OP_BACKTICK)
6088 /* In case of three-arg dup open remove strictness
6089 * from the last arg if it is a bareword. */
6090 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
6091 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
6095 if ((last->op_type == OP_CONST) && /* The bareword. */
6096 (last->op_private & OPpCONST_BARE) &&
6097 (last->op_private & OPpCONST_STRICT) &&
6098 (oa = first->op_sibling) && /* The fh. */
6099 (oa = oa->op_sibling) && /* The mode. */
6100 (oa->op_type == OP_CONST) &&
6101 SvPOK(((SVOP*)oa)->op_sv) &&
6102 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
6103 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
6104 (last == oa->op_sibling)) /* The bareword. */
6105 last->op_private &= ~OPpCONST_STRICT;
6111 Perl_ck_repeat(pTHX_ OP *o)
6113 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6114 o->op_private |= OPpREPEAT_DOLIST;
6115 cBINOPo->op_first = force_list(cBINOPo->op_first);
6123 Perl_ck_require(pTHX_ OP *o)
6127 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6128 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6130 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6131 SV * const sv = kid->op_sv;
6132 U32 was_readonly = SvREADONLY(sv);
6137 sv_force_normal_flags(sv, 0);
6138 assert(!SvREADONLY(sv));
6145 for (s = SvPVX(sv); *s; s++) {
6146 if (*s == ':' && s[1] == ':') {
6147 const STRLEN len = strlen(s+2)+1;
6149 Move(s+2, s+1, len, char);
6150 SvCUR_set(sv, SvCUR(sv) - 1);
6153 sv_catpvn(sv, ".pm", 3);
6154 SvFLAGS(sv) |= was_readonly;
6158 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
6159 /* handle override, if any */
6160 gv = gv_fetchpv("require", FALSE, SVt_PVCV);
6161 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
6162 GV * const * const gvp = (GV**)hv_fetch(PL_globalstash, "require", 7, FALSE);
6163 gv = gvp ? *gvp : Nullgv;
6167 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6168 OP * const kid = cUNOPo->op_first;
6169 cUNOPo->op_first = 0;
6171 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
6172 append_elem(OP_LIST, kid,
6173 scalar(newUNOP(OP_RV2CV, 0,
6182 Perl_ck_return(pTHX_ OP *o)
6184 if (CvLVALUE(PL_compcv)) {
6186 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6187 mod(kid, OP_LEAVESUBLV);
6193 Perl_ck_select(pTHX_ OP *o)
6197 if (o->op_flags & OPf_KIDS) {
6198 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6199 if (kid && kid->op_sibling) {
6200 o->op_type = OP_SSELECT;
6201 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6203 return fold_constants(o);
6207 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6208 if (kid && kid->op_type == OP_RV2GV)
6209 kid->op_private &= ~HINT_STRICT_REFS;
6214 Perl_ck_shift(pTHX_ OP *o)
6216 const I32 type = o->op_type;
6218 if (!(o->op_flags & OPf_KIDS)) {
6222 argop = newUNOP(OP_RV2AV, 0,
6223 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
6224 return newUNOP(type, 0, scalar(argop));
6226 return scalar(modkids(ck_fun(o), type));
6230 Perl_ck_sort(pTHX_ OP *o)
6234 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0)
6236 HV *hinthv = GvHV(PL_hintgv);
6238 SV **svp = hv_fetch(hinthv, "sort", 4, 0);
6240 I32 sorthints = (I32)SvIV(*svp);
6241 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
6242 o->op_private |= OPpSORT_QSORT;
6243 if ((sorthints & HINT_SORT_STABLE) != 0)
6244 o->op_private |= OPpSORT_STABLE;
6249 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6251 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6252 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6254 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6256 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6258 if (kid->op_type == OP_SCOPE) {
6262 else if (kid->op_type == OP_LEAVE) {
6263 if (o->op_type == OP_SORT) {
6264 op_null(kid); /* wipe out leave */
6267 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6268 if (k->op_next == kid)
6270 /* don't descend into loops */
6271 else if (k->op_type == OP_ENTERLOOP
6272 || k->op_type == OP_ENTERITER)
6274 k = cLOOPx(k)->op_lastop;
6279 kid->op_next = 0; /* just disconnect the leave */
6280 k = kLISTOP->op_first;
6285 if (o->op_type == OP_SORT) {
6286 /* provide scalar context for comparison function/block */
6292 o->op_flags |= OPf_SPECIAL;
6294 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6297 firstkid = firstkid->op_sibling;
6300 /* provide list context for arguments */
6301 if (o->op_type == OP_SORT)
6308 S_simplify_sort(pTHX_ OP *o)
6310 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6315 if (!(o->op_flags & OPf_STACKED))
6317 GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6318 GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6319 kid = kUNOP->op_first; /* get past null */
6320 if (kid->op_type != OP_SCOPE)
6322 kid = kLISTOP->op_last; /* get past scope */
6323 switch(kid->op_type) {
6331 k = kid; /* remember this node*/
6332 if (kBINOP->op_first->op_type != OP_RV2SV)
6334 kid = kBINOP->op_first; /* get past cmp */
6335 if (kUNOP->op_first->op_type != OP_GV)
6337 kid = kUNOP->op_first; /* get past rv2sv */
6339 if (GvSTASH(gv) != PL_curstash)
6341 gvname = GvNAME(gv);
6342 if (*gvname == 'a' && gvname[1] == '\0')
6344 else if (*gvname == 'b' && gvname[1] == '\0')
6349 kid = k; /* back to cmp */
6350 if (kBINOP->op_last->op_type != OP_RV2SV)
6352 kid = kBINOP->op_last; /* down to 2nd arg */
6353 if (kUNOP->op_first->op_type != OP_GV)
6355 kid = kUNOP->op_first; /* get past rv2sv */
6357 if (GvSTASH(gv) != PL_curstash)
6359 gvname = GvNAME(gv);
6361 ? !(*gvname == 'a' && gvname[1] == '\0')
6362 : !(*gvname == 'b' && gvname[1] == '\0'))
6364 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6366 o->op_private |= OPpSORT_DESCEND;
6367 if (k->op_type == OP_NCMP)
6368 o->op_private |= OPpSORT_NUMERIC;
6369 if (k->op_type == OP_I_NCMP)
6370 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6371 kid = cLISTOPo->op_first->op_sibling;
6372 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6373 op_free(kid); /* then delete it */
6377 Perl_ck_split(pTHX_ OP *o)
6382 if (o->op_flags & OPf_STACKED)
6383 return no_fh_allowed(o);
6385 kid = cLISTOPo->op_first;
6386 if (kid->op_type != OP_NULL)
6387 Perl_croak(aTHX_ "panic: ck_split");
6388 kid = kid->op_sibling;
6389 op_free(cLISTOPo->op_first);
6390 cLISTOPo->op_first = kid;
6392 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6393 cLISTOPo->op_last = kid; /* There was only one element previously */
6396 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6397 OP * const sibl = kid->op_sibling;
6398 kid->op_sibling = 0;
6399 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
6400 if (cLISTOPo->op_first == cLISTOPo->op_last)
6401 cLISTOPo->op_last = kid;
6402 cLISTOPo->op_first = kid;
6403 kid->op_sibling = sibl;
6406 kid->op_type = OP_PUSHRE;
6407 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6409 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
6410 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
6411 "Use of /g modifier is meaningless in split");
6414 if (!kid->op_sibling)
6415 append_elem(OP_SPLIT, o, newDEFSVOP());
6417 kid = kid->op_sibling;
6420 if (!kid->op_sibling)
6421 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6423 kid = kid->op_sibling;
6426 if (kid->op_sibling)
6427 return too_many_arguments(o,OP_DESC(o));
6433 Perl_ck_join(pTHX_ OP *o)
6435 const OP * const kid = cLISTOPo->op_first->op_sibling;
6436 if (kid && kid->op_type == OP_MATCH) {
6437 if (ckWARN(WARN_SYNTAX)) {
6438 const REGEXP *re = PM_GETRE(kPMOP);
6439 const char *pmstr = re ? re->precomp : "STRING";
6440 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6441 "/%s/ should probably be written as \"%s\"",
6449 Perl_ck_subr(pTHX_ OP *o)
6451 OP *prev = ((cUNOPo->op_first->op_sibling)
6452 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6453 OP *o2 = prev->op_sibling;
6460 I32 contextclass = 0;
6464 o->op_private |= OPpENTERSUB_HASTARG;
6465 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6466 if (cvop->op_type == OP_RV2CV) {
6468 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6469 op_null(cvop); /* disable rv2cv */
6470 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6471 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6472 GV *gv = cGVOPx_gv(tmpop);
6475 tmpop->op_private |= OPpEARLY_CV;
6478 namegv = CvANON(cv) ? gv : CvGV(cv);
6479 proto = SvPV_nolen((SV*)cv);
6481 if (CvASSERTION(cv)) {
6482 if (PL_hints & HINT_ASSERTING) {
6483 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
6484 o->op_private |= OPpENTERSUB_DB;
6488 if (!(PL_hints & HINT_ASSERTIONSSEEN) && ckWARN(WARN_ASSERTIONS)) {
6489 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
6490 "Impossible to activate assertion call");
6497 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6498 if (o2->op_type == OP_CONST)
6499 o2->op_private &= ~OPpCONST_STRICT;
6500 else if (o2->op_type == OP_LIST) {
6501 OP * const o = ((UNOP*)o2)->op_first->op_sibling;
6502 if (o && o->op_type == OP_CONST)
6503 o->op_private &= ~OPpCONST_STRICT;
6506 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6507 if (PERLDB_SUB && PL_curstash != PL_debstash)
6508 o->op_private |= OPpENTERSUB_DB;
6509 while (o2 != cvop) {
6513 return too_many_arguments(o, gv_ename(namegv));
6531 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6533 arg == 1 ? "block or sub {}" : "sub {}",
6534 gv_ename(namegv), o2);
6537 /* '*' allows any scalar type, including bareword */
6540 if (o2->op_type == OP_RV2GV)
6541 goto wrapref; /* autoconvert GLOB -> GLOBref */
6542 else if (o2->op_type == OP_CONST)
6543 o2->op_private &= ~OPpCONST_STRICT;
6544 else if (o2->op_type == OP_ENTERSUB) {
6545 /* accidental subroutine, revert to bareword */
6546 OP *gvop = ((UNOP*)o2)->op_first;
6547 if (gvop && gvop->op_type == OP_NULL) {
6548 gvop = ((UNOP*)gvop)->op_first;
6550 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6553 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6554 (gvop = ((UNOP*)gvop)->op_first) &&
6555 gvop->op_type == OP_GV)
6557 GV * const gv = cGVOPx_gv(gvop);
6558 OP * const sibling = o2->op_sibling;
6559 SV * const n = newSVpvn("",0);
6561 gv_fullname4(n, gv, "", FALSE);
6562 o2 = newSVOP(OP_CONST, 0, n);
6563 prev->op_sibling = o2;
6564 o2->op_sibling = sibling;
6580 if (contextclass++ == 0) {
6581 e = strchr(proto, ']');
6582 if (!e || e == proto)
6591 /* XXX We shouldn't be modifying proto, so we can const proto */
6596 while (*--p != '[');
6597 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
6598 gv_ename(namegv), o2);
6604 if (o2->op_type == OP_RV2GV)
6607 bad_type(arg, "symbol", gv_ename(namegv), o2);
6610 if (o2->op_type == OP_ENTERSUB)
6613 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6616 if (o2->op_type == OP_RV2SV ||
6617 o2->op_type == OP_PADSV ||
6618 o2->op_type == OP_HELEM ||
6619 o2->op_type == OP_AELEM ||
6620 o2->op_type == OP_THREADSV)
6623 bad_type(arg, "scalar", gv_ename(namegv), o2);
6626 if (o2->op_type == OP_RV2AV ||
6627 o2->op_type == OP_PADAV)
6630 bad_type(arg, "array", gv_ename(namegv), o2);
6633 if (o2->op_type == OP_RV2HV ||
6634 o2->op_type == OP_PADHV)
6637 bad_type(arg, "hash", gv_ename(namegv), o2);
6642 OP* const sib = kid->op_sibling;
6643 kid->op_sibling = 0;
6644 o2 = newUNOP(OP_REFGEN, 0, kid);
6645 o2->op_sibling = sib;
6646 prev->op_sibling = o2;
6648 if (contextclass && e) {
6663 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
6664 gv_ename(namegv), cv);
6669 mod(o2, OP_ENTERSUB);
6671 o2 = o2->op_sibling;
6673 if (proto && !optional &&
6674 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6675 return too_few_arguments(o, gv_ename(namegv));
6678 o=newSVOP(OP_CONST, 0, newSViv(0));
6684 Perl_ck_svconst(pTHX_ OP *o)
6686 SvREADONLY_on(cSVOPo->op_sv);
6691 Perl_ck_trunc(pTHX_ OP *o)
6693 if (o->op_flags & OPf_KIDS) {
6694 SVOP *kid = (SVOP*)cUNOPo->op_first;
6696 if (kid->op_type == OP_NULL)
6697 kid = (SVOP*)kid->op_sibling;
6698 if (kid && kid->op_type == OP_CONST &&
6699 (kid->op_private & OPpCONST_BARE))
6701 o->op_flags |= OPf_SPECIAL;
6702 kid->op_private &= ~OPpCONST_STRICT;
6709 Perl_ck_unpack(pTHX_ OP *o)
6711 OP *kid = cLISTOPo->op_first;
6712 if (kid->op_sibling) {
6713 kid = kid->op_sibling;
6714 if (!kid->op_sibling)
6715 kid->op_sibling = newDEFSVOP();
6721 Perl_ck_substr(pTHX_ OP *o)
6724 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6725 OP *kid = cLISTOPo->op_first;
6727 if (kid->op_type == OP_NULL)
6728 kid = kid->op_sibling;
6730 kid->op_flags |= OPf_MOD;
6736 /* A peephole optimizer. We visit the ops in the order they're to execute.
6737 * See the comments at the top of this file for more details about when
6738 * peep() is called */
6741 Perl_peep(pTHX_ register OP *o)
6744 register OP* oldop = 0;
6746 if (!o || o->op_opt)
6750 SAVEVPTR(PL_curcop);
6751 for (; o; o = o->op_next) {
6755 switch (o->op_type) {
6759 PL_curcop = ((COP*)o); /* for warnings */
6764 if (cSVOPo->op_private & OPpCONST_STRICT)
6765 no_bareword_allowed(o);
6767 case OP_METHOD_NAMED:
6768 /* Relocate sv to the pad for thread safety.
6769 * Despite being a "constant", the SV is written to,
6770 * for reference counts, sv_upgrade() etc. */
6772 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6773 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6774 /* If op_sv is already a PADTMP then it is being used by
6775 * some pad, so make a copy. */
6776 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6777 SvREADONLY_on(PAD_SVl(ix));
6778 SvREFCNT_dec(cSVOPo->op_sv);
6781 SvREFCNT_dec(PAD_SVl(ix));
6782 SvPADTMP_on(cSVOPo->op_sv);
6783 PAD_SETSV(ix, cSVOPo->op_sv);
6784 /* XXX I don't know how this isn't readonly already. */
6785 SvREADONLY_on(PAD_SVl(ix));
6787 cSVOPo->op_sv = Nullsv;
6795 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6796 if (o->op_next->op_private & OPpTARGET_MY) {
6797 if (o->op_flags & OPf_STACKED) /* chained concats */
6798 goto ignore_optimization;
6800 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6801 o->op_targ = o->op_next->op_targ;
6802 o->op_next->op_targ = 0;
6803 o->op_private |= OPpTARGET_MY;
6806 op_null(o->op_next);
6808 ignore_optimization:
6812 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6814 break; /* Scalar stub must produce undef. List stub is noop */
6818 if (o->op_targ == OP_NEXTSTATE
6819 || o->op_targ == OP_DBSTATE
6820 || o->op_targ == OP_SETSTATE)
6822 PL_curcop = ((COP*)o);
6824 /* XXX: We avoid setting op_seq here to prevent later calls
6825 to peep() from mistakenly concluding that optimisation
6826 has already occurred. This doesn't fix the real problem,
6827 though (See 20010220.007). AMS 20010719 */
6828 /* op_seq functionality is now replaced by op_opt */
6829 if (oldop && o->op_next) {
6830 oldop->op_next = o->op_next;
6838 if (oldop && o->op_next) {
6839 oldop->op_next = o->op_next;
6847 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
6848 OP* const pop = (o->op_type == OP_PADAV) ?
6849 o->op_next : o->op_next->op_next;
6851 if (pop && pop->op_type == OP_CONST &&
6852 ((PL_op = pop->op_next)) &&
6853 pop->op_next->op_type == OP_AELEM &&
6854 !(pop->op_next->op_private &
6855 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6856 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6861 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
6862 no_bareword_allowed(pop);
6863 if (o->op_type == OP_GV)
6864 op_null(o->op_next);
6865 op_null(pop->op_next);
6867 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6868 o->op_next = pop->op_next->op_next;
6869 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6870 o->op_private = (U8)i;
6871 if (o->op_type == OP_GV) {
6876 o->op_flags |= OPf_SPECIAL;
6877 o->op_type = OP_AELEMFAST;
6883 if (o->op_next->op_type == OP_RV2SV) {
6884 if (!(o->op_next->op_private & OPpDEREF)) {
6885 op_null(o->op_next);
6886 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6888 o->op_next = o->op_next->op_next;
6889 o->op_type = OP_GVSV;
6890 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6893 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6894 GV * const gv = cGVOPo_gv;
6895 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
6896 /* XXX could check prototype here instead of just carping */
6897 SV * const sv = sv_newmortal();
6898 gv_efullname3(sv, gv, Nullch);
6899 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
6900 "%"SVf"() called too early to check prototype",
6904 else if (o->op_next->op_type == OP_READLINE
6905 && o->op_next->op_next->op_type == OP_CONCAT
6906 && (o->op_next->op_next->op_flags & OPf_STACKED))
6908 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6909 o->op_type = OP_RCATLINE;
6910 o->op_flags |= OPf_STACKED;
6911 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
6912 op_null(o->op_next->op_next);
6913 op_null(o->op_next);
6930 while (cLOGOP->op_other->op_type == OP_NULL)
6931 cLOGOP->op_other = cLOGOP->op_other->op_next;
6932 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
6938 while (cLOOP->op_redoop->op_type == OP_NULL)
6939 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6940 peep(cLOOP->op_redoop);
6941 while (cLOOP->op_nextop->op_type == OP_NULL)
6942 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6943 peep(cLOOP->op_nextop);
6944 while (cLOOP->op_lastop->op_type == OP_NULL)
6945 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6946 peep(cLOOP->op_lastop);
6953 while (cPMOP->op_pmreplstart &&
6954 cPMOP->op_pmreplstart->op_type == OP_NULL)
6955 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6956 peep(cPMOP->op_pmreplstart);
6961 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
6962 && ckWARN(WARN_SYNTAX))
6964 if (o->op_next->op_sibling &&
6965 o->op_next->op_sibling->op_type != OP_EXIT &&
6966 o->op_next->op_sibling->op_type != OP_WARN &&
6967 o->op_next->op_sibling->op_type != OP_DIE) {
6968 const line_t oldline = CopLINE(PL_curcop);
6970 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6971 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6972 "Statement unlikely to be reached");
6973 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6974 "\t(Maybe you meant system() when you said exec()?)\n");
6975 CopLINE_set(PL_curcop, oldline);
6985 const char *key = NULL;
6990 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6993 /* Make the CONST have a shared SV */
6994 svp = cSVOPx_svp(((BINOP*)o)->op_last);
6995 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6996 key = SvPV_const(sv, keylen);
6997 lexname = newSVpvn_share(key,
6998 SvUTF8(sv) ? -(I32)keylen : keylen,
7004 if ((o->op_private & (OPpLVAL_INTRO)))
7007 rop = (UNOP*)((BINOP*)o)->op_first;
7008 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7010 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7011 if (!(SvFLAGS(lexname) & SVpad_TYPED))
7013 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
7014 if (!fields || !GvHV(*fields))
7016 key = SvPV_const(*svp, keylen);
7017 if (!hv_fetch(GvHV(*fields), key,
7018 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
7020 Perl_croak(aTHX_ "No such class field \"%s\" "
7021 "in variable %s of type %s",
7022 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
7035 SVOP *first_key_op, *key_op;
7037 if ((o->op_private & (OPpLVAL_INTRO))
7038 /* I bet there's always a pushmark... */
7039 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
7040 /* hmmm, no optimization if list contains only one key. */
7042 rop = (UNOP*)((LISTOP*)o)->op_last;
7043 if (rop->op_type != OP_RV2HV)
7045 if (rop->op_first->op_type == OP_PADSV)
7046 /* @$hash{qw(keys here)} */
7047 rop = (UNOP*)rop->op_first;
7049 /* @{$hash}{qw(keys here)} */
7050 if (rop->op_first->op_type == OP_SCOPE
7051 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
7053 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
7059 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
7060 if (!(SvFLAGS(lexname) & SVpad_TYPED))
7062 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
7063 if (!fields || !GvHV(*fields))
7065 /* Again guessing that the pushmark can be jumped over.... */
7066 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
7067 ->op_first->op_sibling;
7068 for (key_op = first_key_op; key_op;
7069 key_op = (SVOP*)key_op->op_sibling) {
7070 if (key_op->op_type != OP_CONST)
7072 svp = cSVOPx_svp(key_op);
7073 key = SvPV_const(*svp, keylen);
7074 if (!hv_fetch(GvHV(*fields), key,
7075 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
7077 Perl_croak(aTHX_ "No such class field \"%s\" "
7078 "in variable %s of type %s",
7079 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
7086 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
7090 /* check that RHS of sort is a single plain array */
7091 OP *oright = cUNOPo->op_first;
7092 if (!oright || oright->op_type != OP_PUSHMARK)
7095 /* reverse sort ... can be optimised. */
7096 if (!cUNOPo->op_sibling) {
7097 /* Nothing follows us on the list. */
7098 OP * const reverse = o->op_next;
7100 if (reverse->op_type == OP_REVERSE &&
7101 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
7102 OP * const pushmark = cUNOPx(reverse)->op_first;
7103 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
7104 && (cUNOPx(pushmark)->op_sibling == o)) {
7105 /* reverse -> pushmark -> sort */
7106 o->op_private |= OPpSORT_REVERSE;
7108 pushmark->op_next = oright->op_next;
7114 /* make @a = sort @a act in-place */
7118 oright = cUNOPx(oright)->op_sibling;
7121 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
7122 oright = cUNOPx(oright)->op_sibling;
7126 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
7127 || oright->op_next != o
7128 || (oright->op_private & OPpLVAL_INTRO)
7132 /* o2 follows the chain of op_nexts through the LHS of the
7133 * assign (if any) to the aassign op itself */
7135 if (!o2 || o2->op_type != OP_NULL)
7138 if (!o2 || o2->op_type != OP_PUSHMARK)
7141 if (o2 && o2->op_type == OP_GV)
7144 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
7145 || (o2->op_private & OPpLVAL_INTRO)
7150 if (!o2 || o2->op_type != OP_NULL)
7153 if (!o2 || o2->op_type != OP_AASSIGN
7154 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
7157 /* check that the sort is the first arg on RHS of assign */
7159 o2 = cUNOPx(o2)->op_first;
7160 if (!o2 || o2->op_type != OP_NULL)
7162 o2 = cUNOPx(o2)->op_first;
7163 if (!o2 || o2->op_type != OP_PUSHMARK)
7165 if (o2->op_sibling != o)
7168 /* check the array is the same on both sides */
7169 if (oleft->op_type == OP_RV2AV) {
7170 if (oright->op_type != OP_RV2AV
7171 || !cUNOPx(oright)->op_first
7172 || cUNOPx(oright)->op_first->op_type != OP_GV
7173 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
7174 cGVOPx_gv(cUNOPx(oright)->op_first)
7178 else if (oright->op_type != OP_PADAV
7179 || oright->op_targ != oleft->op_targ
7183 /* transfer MODishness etc from LHS arg to RHS arg */
7184 oright->op_flags = oleft->op_flags;
7185 o->op_private |= OPpSORT_INPLACE;
7187 /* excise push->gv->rv2av->null->aassign */
7188 o2 = o->op_next->op_next;
7189 op_null(o2); /* PUSHMARK */
7191 if (o2->op_type == OP_GV) {
7192 op_null(o2); /* GV */
7195 op_null(o2); /* RV2AV or PADAV */
7196 o2 = o2->op_next->op_next;
7197 op_null(o2); /* AASSIGN */
7199 o->op_next = o2->op_next;
7205 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
7207 LISTOP *enter, *exlist;
7210 enter = (LISTOP *) o->op_next;
7213 if (enter->op_type == OP_NULL) {
7214 enter = (LISTOP *) enter->op_next;
7218 /* for $a (...) will have OP_GV then OP_RV2GV here.
7219 for (...) just has an OP_GV. */
7220 if (enter->op_type == OP_GV) {
7221 gvop = (OP *) enter;
7222 enter = (LISTOP *) enter->op_next;
7225 if (enter->op_type == OP_RV2GV) {
7226 enter = (LISTOP *) enter->op_next;
7232 if (enter->op_type != OP_ENTERITER)
7235 iter = enter->op_next;
7236 if (!iter || iter->op_type != OP_ITER)
7239 expushmark = enter->op_first;
7240 if (!expushmark || expushmark->op_type != OP_NULL
7241 || expushmark->op_targ != OP_PUSHMARK)
7244 exlist = (LISTOP *) expushmark->op_sibling;
7245 if (!exlist || exlist->op_type != OP_NULL
7246 || exlist->op_targ != OP_LIST)
7249 if (exlist->op_last != o) {
7250 /* Mmm. Was expecting to point back to this op. */
7253 theirmark = exlist->op_first;
7254 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
7257 if (theirmark->op_sibling != o) {
7258 /* There's something between the mark and the reverse, eg
7259 for (1, reverse (...))
7264 ourmark = ((LISTOP *)o)->op_first;
7265 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
7268 ourlast = ((LISTOP *)o)->op_last;
7269 if (!ourlast || ourlast->op_next != o)
7272 rv2av = ourmark->op_sibling;
7273 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
7274 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
7275 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
7276 /* We're just reversing a single array. */
7277 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
7278 enter->op_flags |= OPf_STACKED;
7281 /* We don't have control over who points to theirmark, so sacrifice
7283 theirmark->op_next = ourmark->op_next;
7284 theirmark->op_flags = ourmark->op_flags;
7285 ourlast->op_next = gvop ? gvop : (OP *) enter;
7288 enter->op_private |= OPpITER_REVERSED;
7289 iter->op_private |= OPpITER_REVERSED;
7304 Perl_custom_op_name(pTHX_ const OP* o)
7306 const IV index = PTR2IV(o->op_ppaddr);
7310 if (!PL_custom_op_names) /* This probably shouldn't happen */
7311 return (char *)PL_op_name[OP_CUSTOM];
7313 keysv = sv_2mortal(newSViv(index));
7315 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
7317 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
7319 return SvPV_nolen(HeVAL(he));
7323 Perl_custom_op_desc(pTHX_ const OP* o)
7325 const IV index = PTR2IV(o->op_ppaddr);
7329 if (!PL_custom_op_descs)
7330 return (char *)PL_op_desc[OP_CUSTOM];
7332 keysv = sv_2mortal(newSViv(index));
7334 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
7336 return (char *)PL_op_desc[OP_CUSTOM];
7338 return SvPV_nolen(HeVAL(he));
7343 /* Efficient sub that returns a constant scalar value. */
7345 const_sv_xsub(pTHX_ CV* cv)
7350 Perl_croak(aTHX_ "usage: %s::%s()",
7351 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7355 ST(0) = (SV*)XSANY.any_ptr;
7361 * c-indentation-style: bsd
7363 * indent-tabs-mode: t
7366 * ex: set ts=8 sts=4 sw=4 noet: