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, m//g */
1146 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN
1147 || type == OP_MATCH)
1149 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1150 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1152 : (o->op_type == OP_ENTERSUB
1153 ? "non-lvalue subroutine call"
1155 type ? PL_op_desc[type] : "local"));
1169 case OP_RIGHT_SHIFT:
1178 if (!(o->op_flags & OPf_STACKED))
1185 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1191 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1192 PL_modcount = RETURN_UNLIMITED_NUMBER;
1193 return o; /* Treat \(@foo) like ordinary list. */
1197 if (scalar_mod_type(o, type))
1199 ref(cUNOPo->op_first, o->op_type);
1203 if (type == OP_LEAVESUBLV)
1204 o->op_private |= OPpMAYBE_LVSUB;
1210 PL_modcount = RETURN_UNLIMITED_NUMBER;
1213 ref(cUNOPo->op_first, o->op_type);
1218 PL_hints |= HINT_BLOCK_SCOPE;
1233 PL_modcount = RETURN_UNLIMITED_NUMBER;
1234 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1235 return o; /* Treat \(@foo) like ordinary list. */
1236 if (scalar_mod_type(o, type))
1238 if (type == OP_LEAVESUBLV)
1239 o->op_private |= OPpMAYBE_LVSUB;
1243 if (!type) /* local() */
1244 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1245 PAD_COMPNAME_PV(o->op_targ));
1253 if (type != OP_SASSIGN)
1257 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1262 if (type == OP_LEAVESUBLV)
1263 o->op_private |= OPpMAYBE_LVSUB;
1265 pad_free(o->op_targ);
1266 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1267 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1268 if (o->op_flags & OPf_KIDS)
1269 mod(cBINOPo->op_first->op_sibling, type);
1274 ref(cBINOPo->op_first, o->op_type);
1275 if (type == OP_ENTERSUB &&
1276 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1277 o->op_private |= OPpLVAL_DEFER;
1278 if (type == OP_LEAVESUBLV)
1279 o->op_private |= OPpMAYBE_LVSUB;
1289 if (o->op_flags & OPf_KIDS)
1290 mod(cLISTOPo->op_last, type);
1295 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1297 else if (!(o->op_flags & OPf_KIDS))
1299 if (o->op_targ != OP_LIST) {
1300 mod(cBINOPo->op_first, type);
1306 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1311 if (type != OP_LEAVESUBLV)
1313 break; /* mod()ing was handled by ck_return() */
1316 /* [20011101.069] File test operators interpret OPf_REF to mean that
1317 their argument is a filehandle; thus \stat(".") should not set
1319 if (type == OP_REFGEN &&
1320 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1323 if (type != OP_LEAVESUBLV)
1324 o->op_flags |= OPf_MOD;
1326 if (type == OP_AASSIGN || type == OP_SASSIGN)
1327 o->op_flags |= OPf_SPECIAL|OPf_REF;
1328 else if (!type) { /* local() */
1331 o->op_private |= OPpLVAL_INTRO;
1332 o->op_flags &= ~OPf_SPECIAL;
1333 PL_hints |= HINT_BLOCK_SCOPE;
1338 if (ckWARN(WARN_SYNTAX)) {
1339 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1340 "Useless localization of %s", OP_DESC(o));
1344 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1345 && type != OP_LEAVESUBLV)
1346 o->op_flags |= OPf_REF;
1351 S_scalar_mod_type(pTHX_ const OP *o, I32 type)
1355 if (o->op_type == OP_RV2GV)
1379 case OP_RIGHT_SHIFT:
1398 S_is_handle_constructor(pTHX_ const OP *o, I32 numargs)
1400 switch (o->op_type) {
1408 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1421 Perl_refkids(pTHX_ OP *o, I32 type)
1423 if (o && o->op_flags & OPf_KIDS) {
1425 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1432 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
1437 if (!o || PL_error_count)
1440 switch (o->op_type) {
1442 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1443 !(o->op_flags & OPf_STACKED)) {
1444 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1445 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1446 assert(cUNOPo->op_first->op_type == OP_NULL);
1447 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1448 o->op_flags |= OPf_SPECIAL;
1453 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1454 doref(kid, type, set_op_ref);
1457 if (type == OP_DEFINED)
1458 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1459 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1462 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1463 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1464 : type == OP_RV2HV ? OPpDEREF_HV
1466 o->op_flags |= OPf_MOD;
1471 o->op_flags |= OPf_MOD; /* XXX ??? */
1477 o->op_flags |= OPf_REF;
1480 if (type == OP_DEFINED)
1481 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1482 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1488 o->op_flags |= OPf_REF;
1493 if (!(o->op_flags & OPf_KIDS))
1495 doref(cBINOPo->op_first, type, set_op_ref);
1499 doref(cBINOPo->op_first, o->op_type, set_op_ref);
1500 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1501 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1502 : type == OP_RV2HV ? OPpDEREF_HV
1504 o->op_flags |= OPf_MOD;
1514 if (!(o->op_flags & OPf_KIDS))
1516 doref(cLISTOPo->op_last, type, set_op_ref);
1526 S_dup_attrlist(pTHX_ OP *o)
1530 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1531 * where the first kid is OP_PUSHMARK and the remaining ones
1532 * are OP_CONST. We need to push the OP_CONST values.
1534 if (o->op_type == OP_CONST)
1535 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1537 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1539 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1540 if (o->op_type == OP_CONST)
1541 rop = append_elem(OP_LIST, rop,
1542 newSVOP(OP_CONST, o->op_flags,
1543 SvREFCNT_inc(cSVOPo->op_sv)));
1550 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1555 /* fake up C<use attributes $pkg,$rv,@attrs> */
1556 ENTER; /* need to protect against side-effects of 'use' */
1558 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1560 #define ATTRSMODULE "attributes"
1561 #define ATTRSMODULE_PM "attributes.pm"
1564 /* Don't force the C<use> if we don't need it. */
1565 SV * const * const svp = hv_fetch(GvHVn(PL_incgv), ATTRSMODULE_PM,
1566 sizeof(ATTRSMODULE_PM)-1, 0);
1567 if (svp && *svp != &PL_sv_undef)
1568 ; /* already in %INC */
1570 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1571 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1575 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1576 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1578 prepend_elem(OP_LIST,
1579 newSVOP(OP_CONST, 0, stashsv),
1580 prepend_elem(OP_LIST,
1581 newSVOP(OP_CONST, 0,
1583 dup_attrlist(attrs))));
1589 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1591 OP *pack, *imop, *arg;
1597 assert(target->op_type == OP_PADSV ||
1598 target->op_type == OP_PADHV ||
1599 target->op_type == OP_PADAV);
1601 /* Ensure that attributes.pm is loaded. */
1602 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1604 /* Need package name for method call. */
1605 pack = newSVOP(OP_CONST, 0, newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1));
1607 /* Build up the real arg-list. */
1608 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1610 arg = newOP(OP_PADSV, 0);
1611 arg->op_targ = target->op_targ;
1612 arg = prepend_elem(OP_LIST,
1613 newSVOP(OP_CONST, 0, stashsv),
1614 prepend_elem(OP_LIST,
1615 newUNOP(OP_REFGEN, 0,
1616 mod(arg, OP_REFGEN)),
1617 dup_attrlist(attrs)));
1619 /* Fake up a method call to import */
1620 meth = newSVpvn_share("import", 6, 0);
1621 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1622 append_elem(OP_LIST,
1623 prepend_elem(OP_LIST, pack, list(arg)),
1624 newSVOP(OP_METHOD_NAMED, 0, meth)));
1625 imop->op_private |= OPpENTERSUB_NOMOD;
1627 /* Combine the ops. */
1628 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1632 =notfor apidoc apply_attrs_string
1634 Attempts to apply a list of attributes specified by the C<attrstr> and
1635 C<len> arguments to the subroutine identified by the C<cv> argument which
1636 is expected to be associated with the package identified by the C<stashpv>
1637 argument (see L<attributes>). It gets this wrong, though, in that it
1638 does not correctly identify the boundaries of the individual attribute
1639 specifications within C<attrstr>. This is not really intended for the
1640 public API, but has to be listed here for systems such as AIX which
1641 need an explicit export list for symbols. (It's called from XS code
1642 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1643 to respect attribute syntax properly would be welcome.
1649 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
1650 const char *attrstr, STRLEN len)
1655 len = strlen(attrstr);
1659 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1661 const char * const sstr = attrstr;
1662 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1663 attrs = append_elem(OP_LIST, attrs,
1664 newSVOP(OP_CONST, 0,
1665 newSVpvn(sstr, attrstr-sstr)));
1669 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1670 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1671 Nullsv, prepend_elem(OP_LIST,
1672 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1673 prepend_elem(OP_LIST,
1674 newSVOP(OP_CONST, 0,
1680 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
1684 if (!o || PL_error_count)
1688 if (type == OP_LIST) {
1690 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1691 my_kid(kid, attrs, imopsp);
1692 } else if (type == OP_UNDEF) {
1694 } else if (type == OP_RV2SV || /* "our" declaration */
1696 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1697 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1698 yyerror(Perl_form(aTHX_ "Can't declare %s in %s",
1699 OP_DESC(o), PL_in_my == KEY_our ? "our" : "my"));
1701 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
1703 PL_in_my_stash = NULL;
1704 apply_attrs(GvSTASH(gv),
1705 (type == OP_RV2SV ? GvSV(gv) :
1706 type == OP_RV2AV ? (SV*)GvAV(gv) :
1707 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1710 o->op_private |= OPpOUR_INTRO;
1713 else if (type != OP_PADSV &&
1716 type != OP_PUSHMARK)
1718 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1720 PL_in_my == KEY_our ? "our" : "my"));
1723 else if (attrs && type != OP_PUSHMARK) {
1727 PL_in_my_stash = NULL;
1729 /* check for C<my Dog $spot> when deciding package */
1730 stash = PAD_COMPNAME_TYPE(o->op_targ);
1732 stash = PL_curstash;
1733 apply_attrs_my(stash, o, attrs, imopsp);
1735 o->op_flags |= OPf_MOD;
1736 o->op_private |= OPpLVAL_INTRO;
1741 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1744 int maybe_scalar = 0;
1746 /* [perl #17376]: this appears to be premature, and results in code such as
1747 C< our(%x); > executing in list mode rather than void mode */
1749 if (o->op_flags & OPf_PARENS)
1759 o = my_kid(o, attrs, &rops);
1761 if (maybe_scalar && o->op_type == OP_PADSV) {
1762 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
1763 o->op_private |= OPpLVAL_INTRO;
1766 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
1769 PL_in_my_stash = NULL;
1774 Perl_my(pTHX_ OP *o)
1776 return my_attrs(o, Nullop);
1780 Perl_sawparens(pTHX_ OP *o)
1783 o->op_flags |= OPf_PARENS;
1788 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
1793 if ( (left->op_type == OP_RV2AV ||
1794 left->op_type == OP_RV2HV ||
1795 left->op_type == OP_PADAV ||
1796 left->op_type == OP_PADHV)
1797 && ckWARN(WARN_MISC))
1799 const char * const desc = PL_op_desc[(right->op_type == OP_SUBST ||
1800 right->op_type == OP_TRANS)
1801 ? right->op_type : OP_MATCH];
1802 const char * const sample = ((left->op_type == OP_RV2AV ||
1803 left->op_type == OP_PADAV)
1804 ? "@array" : "%hash");
1805 Perl_warner(aTHX_ packWARN(WARN_MISC),
1806 "Applying %s to %s will act on scalar(%s)",
1807 desc, sample, sample);
1810 if (right->op_type == OP_CONST &&
1811 cSVOPx(right)->op_private & OPpCONST_BARE &&
1812 cSVOPx(right)->op_private & OPpCONST_STRICT)
1814 no_bareword_allowed(right);
1817 ismatchop = right->op_type == OP_MATCH ||
1818 right->op_type == OP_SUBST ||
1819 right->op_type == OP_TRANS;
1820 if (ismatchop && right->op_private & OPpTARGET_MY) {
1822 right->op_private &= ~OPpTARGET_MY;
1824 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
1825 right->op_flags |= OPf_STACKED;
1826 /* s/// and tr/// modify their arg.
1827 * m//g also indirectly modifies the arg by setting pos magic on it */
1828 if ( (right->op_type == OP_MATCH &&
1829 (cPMOPx(right)->op_pmflags & PMf_GLOBAL))
1830 || (right->op_type == OP_SUBST)
1831 || (right->op_type == OP_TRANS &&
1832 ! (right->op_private & OPpTRANS_IDENTICAL))
1834 left = mod(left, right->op_type);
1835 if (right->op_type == OP_TRANS)
1836 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
1838 o = prepend_elem(right->op_type, scalar(left), right);
1840 return newUNOP(OP_NOT, 0, scalar(o));
1844 return bind_match(type, left,
1845 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
1849 Perl_invert(pTHX_ OP *o)
1853 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
1854 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
1858 Perl_scope(pTHX_ OP *o)
1862 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
1863 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
1864 o->op_type = OP_LEAVE;
1865 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
1867 else if (o->op_type == OP_LINESEQ) {
1869 o->op_type = OP_SCOPE;
1870 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
1871 kid = ((LISTOP*)o)->op_first;
1872 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
1875 /* The following deals with things like 'do {1 for 1}' */
1876 kid = kid->op_sibling;
1878 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
1883 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
1889 Perl_block_start(pTHX_ int full)
1891 const int retval = PL_savestack_ix;
1892 pad_block_start(full);
1894 PL_hints &= ~HINT_BLOCK_SCOPE;
1895 SAVESPTR(PL_compiling.cop_warnings);
1896 if (! specialWARN(PL_compiling.cop_warnings)) {
1897 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
1898 SAVEFREESV(PL_compiling.cop_warnings) ;
1900 SAVESPTR(PL_compiling.cop_io);
1901 if (! specialCopIO(PL_compiling.cop_io)) {
1902 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
1903 SAVEFREESV(PL_compiling.cop_io) ;
1909 Perl_block_end(pTHX_ I32 floor, OP *seq)
1911 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
1912 OP* const retval = scalarseq(seq);
1914 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
1916 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
1924 const I32 offset = pad_findmy("$_");
1925 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
1926 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
1929 OP * const o = newOP(OP_PADSV, 0);
1930 o->op_targ = offset;
1936 Perl_newPROG(pTHX_ OP *o)
1941 PL_eval_root = newUNOP(OP_LEAVEEVAL,
1942 ((PL_in_eval & EVAL_KEEPERR)
1943 ? OPf_SPECIAL : 0), o);
1944 PL_eval_start = linklist(PL_eval_root);
1945 PL_eval_root->op_private |= OPpREFCOUNTED;
1946 OpREFCNT_set(PL_eval_root, 1);
1947 PL_eval_root->op_next = 0;
1948 CALL_PEEP(PL_eval_start);
1951 if (o->op_type == OP_STUB) {
1952 PL_comppad_name = 0;
1957 PL_main_root = scope(sawparens(scalarvoid(o)));
1958 PL_curcop = &PL_compiling;
1959 PL_main_start = LINKLIST(PL_main_root);
1960 PL_main_root->op_private |= OPpREFCOUNTED;
1961 OpREFCNT_set(PL_main_root, 1);
1962 PL_main_root->op_next = 0;
1963 CALL_PEEP(PL_main_start);
1966 /* Register with debugger */
1968 CV * const cv = get_cv("DB::postponed", FALSE);
1972 XPUSHs((SV*)CopFILEGV(&PL_compiling));
1974 call_sv((SV*)cv, G_DISCARD);
1981 Perl_localize(pTHX_ OP *o, I32 lex)
1983 if (o->op_flags & OPf_PARENS)
1984 /* [perl #17376]: this appears to be premature, and results in code such as
1985 C< our(%x); > executing in list mode rather than void mode */
1992 if ( PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ','
1993 && ckWARN(WARN_PARENTHESIS))
1995 char *s = PL_bufptr;
1998 /* some heuristics to detect a potential error */
1999 while (*s && (strchr(", \t\n", *s)))
2003 if (*s && strchr("@$%*", *s) && *++s
2004 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2007 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2009 while (*s && (strchr(", \t\n", *s)))
2015 if (sigil && (*s == ';' || *s == '=')) {
2016 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2017 "Parentheses missing around \"%s\" list",
2018 lex ? (PL_in_my == KEY_our ? "our" : "my")
2026 o = mod(o, OP_NULL); /* a bit kludgey */
2028 PL_in_my_stash = NULL;
2033 Perl_jmaybe(pTHX_ OP *o)
2035 if (o->op_type == OP_LIST) {
2037 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", GV_ADD, SVt_PV))),
2038 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2044 Perl_fold_constants(pTHX_ register OP *o)
2048 I32 type = o->op_type;
2051 if (PL_opargs[type] & OA_RETSCALAR)
2053 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2054 o->op_targ = pad_alloc(type, SVs_PADTMP);
2056 /* integerize op, unless it happens to be C<-foo>.
2057 * XXX should pp_i_negate() do magic string negation instead? */
2058 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2059 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2060 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2062 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2065 if (!(PL_opargs[type] & OA_FOLDCONST))
2070 /* XXX might want a ck_negate() for this */
2071 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2082 /* XXX what about the numeric ops? */
2083 if (PL_hints & HINT_LOCALE)
2088 goto nope; /* Don't try to run w/ errors */
2090 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2091 if ((curop->op_type != OP_CONST ||
2092 (curop->op_private & OPpCONST_BARE)) &&
2093 curop->op_type != OP_LIST &&
2094 curop->op_type != OP_SCALAR &&
2095 curop->op_type != OP_NULL &&
2096 curop->op_type != OP_PUSHMARK)
2102 curop = LINKLIST(o);
2106 sv = *(PL_stack_sp--);
2107 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2108 pad_swipe(o->op_targ, FALSE);
2109 else if (SvTEMP(sv)) { /* grab mortal temp? */
2110 (void)SvREFCNT_inc(sv);
2114 if (type == OP_RV2GV)
2115 return newGVOP(OP_GV, 0, (GV*)sv);
2116 return newSVOP(OP_CONST, 0, sv);
2123 Perl_gen_constant_list(pTHX_ register OP *o)
2127 const I32 oldtmps_floor = PL_tmps_floor;
2131 return o; /* Don't attempt to run with errors */
2133 PL_op = curop = LINKLIST(o);
2140 PL_tmps_floor = oldtmps_floor;
2142 o->op_type = OP_RV2AV;
2143 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2144 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2145 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2146 o->op_opt = 0; /* needs to be revisited in peep() */
2147 curop = ((UNOP*)o)->op_first;
2148 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2155 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2158 if (!o || o->op_type != OP_LIST)
2159 o = newLISTOP(OP_LIST, 0, o, Nullop);
2161 o->op_flags &= ~OPf_WANT;
2163 if (!(PL_opargs[type] & OA_MARK))
2164 op_null(cLISTOPo->op_first);
2166 o->op_type = (OPCODE)type;
2167 o->op_ppaddr = PL_ppaddr[type];
2168 o->op_flags |= flags;
2170 o = CHECKOP(type, o);
2171 if (o->op_type != (unsigned)type)
2174 return fold_constants(o);
2177 /* List constructors */
2180 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2188 if (first->op_type != (unsigned)type
2189 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2191 return newLISTOP(type, 0, first, last);
2194 if (first->op_flags & OPf_KIDS)
2195 ((LISTOP*)first)->op_last->op_sibling = last;
2197 first->op_flags |= OPf_KIDS;
2198 ((LISTOP*)first)->op_first = last;
2200 ((LISTOP*)first)->op_last = last;
2205 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2213 if (first->op_type != (unsigned)type)
2214 return prepend_elem(type, (OP*)first, (OP*)last);
2216 if (last->op_type != (unsigned)type)
2217 return append_elem(type, (OP*)first, (OP*)last);
2219 first->op_last->op_sibling = last->op_first;
2220 first->op_last = last->op_last;
2221 first->op_flags |= (last->op_flags & OPf_KIDS);
2229 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2237 if (last->op_type == (unsigned)type) {
2238 if (type == OP_LIST) { /* already a PUSHMARK there */
2239 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2240 ((LISTOP*)last)->op_first->op_sibling = first;
2241 if (!(first->op_flags & OPf_PARENS))
2242 last->op_flags &= ~OPf_PARENS;
2245 if (!(last->op_flags & OPf_KIDS)) {
2246 ((LISTOP*)last)->op_last = first;
2247 last->op_flags |= OPf_KIDS;
2249 first->op_sibling = ((LISTOP*)last)->op_first;
2250 ((LISTOP*)last)->op_first = first;
2252 last->op_flags |= OPf_KIDS;
2256 return newLISTOP(type, 0, first, last);
2262 Perl_newNULLLIST(pTHX)
2264 return newOP(OP_STUB, 0);
2268 Perl_force_list(pTHX_ OP *o)
2270 if (!o || o->op_type != OP_LIST)
2271 o = newLISTOP(OP_LIST, 0, o, Nullop);
2277 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2282 NewOp(1101, listop, 1, LISTOP);
2284 listop->op_type = (OPCODE)type;
2285 listop->op_ppaddr = PL_ppaddr[type];
2288 listop->op_flags = (U8)flags;
2292 else if (!first && last)
2295 first->op_sibling = last;
2296 listop->op_first = first;
2297 listop->op_last = last;
2298 if (type == OP_LIST) {
2299 OP* const pushop = newOP(OP_PUSHMARK, 0);
2300 pushop->op_sibling = first;
2301 listop->op_first = pushop;
2302 listop->op_flags |= OPf_KIDS;
2304 listop->op_last = pushop;
2307 return CHECKOP(type, listop);
2311 Perl_newOP(pTHX_ I32 type, I32 flags)
2315 NewOp(1101, o, 1, OP);
2316 o->op_type = (OPCODE)type;
2317 o->op_ppaddr = PL_ppaddr[type];
2318 o->op_flags = (U8)flags;
2321 o->op_private = (U8)(0 | (flags >> 8));
2322 if (PL_opargs[type] & OA_RETSCALAR)
2324 if (PL_opargs[type] & OA_TARGET)
2325 o->op_targ = pad_alloc(type, SVs_PADTMP);
2326 return CHECKOP(type, o);
2330 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2336 first = newOP(OP_STUB, 0);
2337 if (PL_opargs[type] & OA_MARK)
2338 first = force_list(first);
2340 NewOp(1101, unop, 1, UNOP);
2341 unop->op_type = (OPCODE)type;
2342 unop->op_ppaddr = PL_ppaddr[type];
2343 unop->op_first = first;
2344 unop->op_flags = (U8)(flags | OPf_KIDS);
2345 unop->op_private = (U8)(1 | (flags >> 8));
2346 unop = (UNOP*) CHECKOP(type, unop);
2350 return fold_constants((OP *) unop);
2354 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2358 NewOp(1101, binop, 1, BINOP);
2361 first = newOP(OP_NULL, 0);
2363 binop->op_type = (OPCODE)type;
2364 binop->op_ppaddr = PL_ppaddr[type];
2365 binop->op_first = first;
2366 binop->op_flags = (U8)(flags | OPf_KIDS);
2369 binop->op_private = (U8)(1 | (flags >> 8));
2372 binop->op_private = (U8)(2 | (flags >> 8));
2373 first->op_sibling = last;
2376 binop = (BINOP*)CHECKOP(type, binop);
2377 if (binop->op_next || binop->op_type != (OPCODE)type)
2380 binop->op_last = binop->op_first->op_sibling;
2382 return fold_constants((OP *)binop);
2385 static int uvcompare(const void *a, const void *b) __attribute__nonnull__(1) __attribute__nonnull__(2) __attribute__pure__;
2386 static int uvcompare(const void *a, const void *b)
2388 if (*((const UV *)a) < (*(const UV *)b))
2390 if (*((const UV *)a) > (*(const UV *)b))
2392 if (*((const UV *)a+1) < (*(const UV *)b+1))
2394 if (*((const UV *)a+1) > (*(const UV *)b+1))
2400 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2402 SV * const tstr = ((SVOP*)expr)->op_sv;
2403 SV * const rstr = ((SVOP*)repl)->op_sv;
2406 const U8 *t = (U8*)SvPV_const(tstr, tlen);
2407 const U8 *r = (U8*)SvPV_const(rstr, rlen);
2411 register short *tbl;
2413 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
2414 const I32 squash = o->op_private & OPpTRANS_SQUASH;
2415 I32 del = o->op_private & OPpTRANS_DELETE;
2416 PL_hints |= HINT_BLOCK_SCOPE;
2419 o->op_private |= OPpTRANS_FROM_UTF;
2422 o->op_private |= OPpTRANS_TO_UTF;
2424 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2425 SV* const listsv = newSVpvn("# comment\n",10);
2427 const U8* tend = t + tlen;
2428 const U8* rend = r + rlen;
2442 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2443 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2449 t = tsave = bytes_to_utf8(t, &len);
2452 if (!to_utf && rlen) {
2454 r = rsave = bytes_to_utf8(r, &len);
2458 /* There are several snags with this code on EBCDIC:
2459 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2460 2. scan_const() in toke.c has encoded chars in native encoding which makes
2461 ranges at least in EBCDIC 0..255 range the bottom odd.
2465 U8 tmpbuf[UTF8_MAXBYTES+1];
2468 Newx(cp, 2*tlen, UV);
2470 transv = newSVpvn("",0);
2472 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2474 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2476 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2480 cp[2*i+1] = cp[2*i];
2484 qsort(cp, i, 2*sizeof(UV), uvcompare);
2485 for (j = 0; j < i; j++) {
2487 diff = val - nextmin;
2489 t = uvuni_to_utf8(tmpbuf,nextmin);
2490 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2492 U8 range_mark = UTF_TO_NATIVE(0xff);
2493 t = uvuni_to_utf8(tmpbuf, val - 1);
2494 sv_catpvn(transv, (char *)&range_mark, 1);
2495 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2502 t = uvuni_to_utf8(tmpbuf,nextmin);
2503 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2505 U8 range_mark = UTF_TO_NATIVE(0xff);
2506 sv_catpvn(transv, (char *)&range_mark, 1);
2508 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2509 UNICODE_ALLOW_SUPER);
2510 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2511 t = (const U8*)SvPVX_const(transv);
2512 tlen = SvCUR(transv);
2516 else if (!rlen && !del) {
2517 r = t; rlen = tlen; rend = tend;
2520 if ((!rlen && !del) || t == r ||
2521 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2523 o->op_private |= OPpTRANS_IDENTICAL;
2527 while (t < tend || tfirst <= tlast) {
2528 /* see if we need more "t" chars */
2529 if (tfirst > tlast) {
2530 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2532 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2534 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2541 /* now see if we need more "r" chars */
2542 if (rfirst > rlast) {
2544 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2546 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2548 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2557 rfirst = rlast = 0xffffffff;
2561 /* now see which range will peter our first, if either. */
2562 tdiff = tlast - tfirst;
2563 rdiff = rlast - rfirst;
2570 if (rfirst == 0xffffffff) {
2571 diff = tdiff; /* oops, pretend rdiff is infinite */
2573 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2574 (long)tfirst, (long)tlast);
2576 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2580 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2581 (long)tfirst, (long)(tfirst + diff),
2584 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2585 (long)tfirst, (long)rfirst);
2587 if (rfirst + diff > max)
2588 max = rfirst + diff;
2590 grows = (tfirst < rfirst &&
2591 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2603 else if (max > 0xff)
2608 Safefree(cPVOPo->op_pv);
2609 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2610 SvREFCNT_dec(listsv);
2612 SvREFCNT_dec(transv);
2614 if (!del && havefinal && rlen)
2615 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2616 newSVuv((UV)final), 0);
2619 o->op_private |= OPpTRANS_GROWS;
2631 tbl = (short*)cPVOPo->op_pv;
2633 Zero(tbl, 256, short);
2634 for (i = 0; i < (I32)tlen; i++)
2636 for (i = 0, j = 0; i < 256; i++) {
2638 if (j >= (I32)rlen) {
2647 if (i < 128 && r[j] >= 128)
2657 o->op_private |= OPpTRANS_IDENTICAL;
2659 else if (j >= (I32)rlen)
2662 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2663 tbl[0x100] = (short)(rlen - j);
2664 for (i=0; i < (I32)rlen - j; i++)
2665 tbl[0x101+i] = r[j+i];
2669 if (!rlen && !del) {
2672 o->op_private |= OPpTRANS_IDENTICAL;
2674 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
2675 o->op_private |= OPpTRANS_IDENTICAL;
2677 for (i = 0; i < 256; i++)
2679 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
2680 if (j >= (I32)rlen) {
2682 if (tbl[t[i]] == -1)
2688 if (tbl[t[i]] == -1) {
2689 if (t[i] < 128 && r[j] >= 128)
2696 o->op_private |= OPpTRANS_GROWS;
2704 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2709 NewOp(1101, pmop, 1, PMOP);
2710 pmop->op_type = (OPCODE)type;
2711 pmop->op_ppaddr = PL_ppaddr[type];
2712 pmop->op_flags = (U8)flags;
2713 pmop->op_private = (U8)(0 | (flags >> 8));
2715 if (PL_hints & HINT_RE_TAINT)
2716 pmop->op_pmpermflags |= PMf_RETAINT;
2717 if (PL_hints & HINT_LOCALE)
2718 pmop->op_pmpermflags |= PMf_LOCALE;
2719 pmop->op_pmflags = pmop->op_pmpermflags;
2722 if (av_len((AV*) PL_regex_pad[0]) > -1) {
2723 SV * const repointer = av_pop((AV*)PL_regex_pad[0]);
2724 pmop->op_pmoffset = SvIV(repointer);
2725 SvREPADTMP_off(repointer);
2726 sv_setiv(repointer,0);
2728 SV * const repointer = newSViv(0);
2729 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
2730 pmop->op_pmoffset = av_len(PL_regex_padav);
2731 PL_regex_pad = AvARRAY(PL_regex_padav);
2735 /* link into pm list */
2736 if (type != OP_TRANS && PL_curstash) {
2737 MAGIC *mg = mg_find((SV*)PL_curstash, PERL_MAGIC_symtab);
2740 mg = sv_magicext((SV*)PL_curstash, 0, PERL_MAGIC_symtab, 0, 0, 0);
2742 pmop->op_pmnext = (PMOP*)mg->mg_obj;
2743 mg->mg_obj = (SV*)pmop;
2744 PmopSTASH_set(pmop,PL_curstash);
2747 return CHECKOP(type, pmop);
2750 /* Given some sort of match op o, and an expression expr containing a
2751 * pattern, either compile expr into a regex and attach it to o (if it's
2752 * constant), or convert expr into a runtime regcomp op sequence (if it's
2755 * isreg indicates that the pattern is part of a regex construct, eg
2756 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
2757 * split "pattern", which aren't. In the former case, expr will be a list
2758 * if the pattern contains more than one term (eg /a$b/) or if it contains
2759 * a replacement, ie s/// or tr///.
2763 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
2768 I32 repl_has_vars = 0;
2772 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
2773 /* last element in list is the replacement; pop it */
2775 repl = cLISTOPx(expr)->op_last;
2776 kid = cLISTOPx(expr)->op_first;
2777 while (kid->op_sibling != repl)
2778 kid = kid->op_sibling;
2779 kid->op_sibling = Nullop;
2780 cLISTOPx(expr)->op_last = kid;
2783 if (isreg && expr->op_type == OP_LIST &&
2784 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
2786 /* convert single element list to element */
2787 OP* const oe = expr;
2788 expr = cLISTOPx(oe)->op_first->op_sibling;
2789 cLISTOPx(oe)->op_first->op_sibling = Nullop;
2790 cLISTOPx(oe)->op_last = Nullop;
2794 if (o->op_type == OP_TRANS) {
2795 return pmtrans(o, expr, repl);
2798 reglist = isreg && expr->op_type == OP_LIST;
2802 PL_hints |= HINT_BLOCK_SCOPE;
2805 if (expr->op_type == OP_CONST) {
2807 SV *pat = ((SVOP*)expr)->op_sv;
2808 const char *p = SvPV_const(pat, plen);
2809 if ((o->op_flags & OPf_SPECIAL) && (*p == ' ' && p[1] == '\0')) {
2810 U32 was_readonly = SvREADONLY(pat);
2814 sv_force_normal_flags(pat, 0);
2815 assert(!SvREADONLY(pat));
2818 SvREADONLY_off(pat);
2822 sv_setpvn(pat, "\\s+", 3);
2824 SvFLAGS(pat) |= was_readonly;
2826 p = SvPV_const(pat, plen);
2827 pm->op_pmflags |= PMf_SKIPWHITE;
2830 pm->op_pmdynflags |= PMdf_UTF8;
2831 /* FIXME - can we make this function take const char * args? */
2832 PM_SETRE(pm, CALLREGCOMP(aTHX_ (char*)p, (char*)p + plen, pm));
2833 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
2834 pm->op_pmflags |= PMf_WHITE;
2838 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
2839 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2841 : OP_REGCMAYBE),0,expr);
2843 NewOp(1101, rcop, 1, LOGOP);
2844 rcop->op_type = OP_REGCOMP;
2845 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
2846 rcop->op_first = scalar(expr);
2847 rcop->op_flags |= OPf_KIDS
2848 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
2849 | (reglist ? OPf_STACKED : 0);
2850 rcop->op_private = 1;
2853 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
2855 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
2858 /* establish postfix order */
2859 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
2861 rcop->op_next = expr;
2862 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
2865 rcop->op_next = LINKLIST(expr);
2866 expr->op_next = (OP*)rcop;
2869 prepend_elem(o->op_type, scalar((OP*)rcop), o);
2874 if (pm->op_pmflags & PMf_EVAL) {
2876 if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
2877 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
2879 else if (repl->op_type == OP_CONST)
2883 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
2884 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
2885 if (curop->op_type == OP_GV) {
2886 GV *gv = cGVOPx_gv(curop);
2888 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
2891 else if (curop->op_type == OP_RV2CV)
2893 else if (curop->op_type == OP_RV2SV ||
2894 curop->op_type == OP_RV2AV ||
2895 curop->op_type == OP_RV2HV ||
2896 curop->op_type == OP_RV2GV) {
2897 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
2900 else if (curop->op_type == OP_PADSV ||
2901 curop->op_type == OP_PADAV ||
2902 curop->op_type == OP_PADHV ||
2903 curop->op_type == OP_PADANY) {
2906 else if (curop->op_type == OP_PUSHRE)
2907 ; /* Okay here, dangerous in newASSIGNOP */
2917 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
2918 pm->op_pmflags |= PMf_CONST; /* const for long enough */
2919 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
2920 prepend_elem(o->op_type, scalar(repl), o);
2923 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
2924 pm->op_pmflags |= PMf_MAYBE_CONST;
2925 pm->op_pmpermflags |= PMf_MAYBE_CONST;
2927 NewOp(1101, rcop, 1, LOGOP);
2928 rcop->op_type = OP_SUBSTCONT;
2929 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
2930 rcop->op_first = scalar(repl);
2931 rcop->op_flags |= OPf_KIDS;
2932 rcop->op_private = 1;
2935 /* establish postfix order */
2936 rcop->op_next = LINKLIST(repl);
2937 repl->op_next = (OP*)rcop;
2939 pm->op_pmreplroot = scalar((OP*)rcop);
2940 pm->op_pmreplstart = LINKLIST(rcop);
2949 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
2953 NewOp(1101, svop, 1, SVOP);
2954 svop->op_type = (OPCODE)type;
2955 svop->op_ppaddr = PL_ppaddr[type];
2957 svop->op_next = (OP*)svop;
2958 svop->op_flags = (U8)flags;
2959 if (PL_opargs[type] & OA_RETSCALAR)
2961 if (PL_opargs[type] & OA_TARGET)
2962 svop->op_targ = pad_alloc(type, SVs_PADTMP);
2963 return CHECKOP(type, svop);
2967 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
2971 NewOp(1101, padop, 1, PADOP);
2972 padop->op_type = (OPCODE)type;
2973 padop->op_ppaddr = PL_ppaddr[type];
2974 padop->op_padix = pad_alloc(type, SVs_PADTMP);
2975 SvREFCNT_dec(PAD_SVl(padop->op_padix));
2976 PAD_SETSV(padop->op_padix, sv);
2979 padop->op_next = (OP*)padop;
2980 padop->op_flags = (U8)flags;
2981 if (PL_opargs[type] & OA_RETSCALAR)
2983 if (PL_opargs[type] & OA_TARGET)
2984 padop->op_targ = pad_alloc(type, SVs_PADTMP);
2985 return CHECKOP(type, padop);
2989 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
2995 return newPADOP(type, flags, SvREFCNT_inc(gv));
2997 return newSVOP(type, flags, SvREFCNT_inc(gv));
3002 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3006 NewOp(1101, pvop, 1, PVOP);
3007 pvop->op_type = (OPCODE)type;
3008 pvop->op_ppaddr = PL_ppaddr[type];
3010 pvop->op_next = (OP*)pvop;
3011 pvop->op_flags = (U8)flags;
3012 if (PL_opargs[type] & OA_RETSCALAR)
3014 if (PL_opargs[type] & OA_TARGET)
3015 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3016 return CHECKOP(type, pvop);
3020 Perl_package(pTHX_ OP *o)
3025 save_hptr(&PL_curstash);
3026 save_item(PL_curstname);
3028 name = SvPV_const(cSVOPo->op_sv, len);
3029 PL_curstash = gv_stashpvn(name, len, TRUE);
3030 sv_setpvn(PL_curstname, name, len);
3033 PL_hints |= HINT_BLOCK_SCOPE;
3034 PL_copline = NOLINE;
3039 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3045 if (idop->op_type != OP_CONST)
3046 Perl_croak(aTHX_ "Module name must be constant");
3051 SV * const vesv = ((SVOP*)version)->op_sv;
3053 if (!arg && !SvNIOKp(vesv)) {
3060 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3061 Perl_croak(aTHX_ "Version number must be constant number");
3063 /* Make copy of idop so we don't free it twice */
3064 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3066 /* Fake up a method call to VERSION */
3067 meth = newSVpvn_share("VERSION", 7, 0);
3068 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3069 append_elem(OP_LIST,
3070 prepend_elem(OP_LIST, pack, list(version)),
3071 newSVOP(OP_METHOD_NAMED, 0, meth)));
3075 /* Fake up an import/unimport */
3076 if (arg && arg->op_type == OP_STUB)
3077 imop = arg; /* no import on explicit () */
3078 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3079 imop = Nullop; /* use 5.0; */
3081 idop->op_private |= OPpCONST_NOVER;
3086 /* Make copy of idop so we don't free it twice */
3087 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3089 /* Fake up a method call to import/unimport */
3091 ? newSVpvn_share("import",6, 0) : newSVpvn_share("unimport", 8, 0);
3092 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3093 append_elem(OP_LIST,
3094 prepend_elem(OP_LIST, pack, list(arg)),
3095 newSVOP(OP_METHOD_NAMED, 0, meth)));
3098 /* Fake up the BEGIN {}, which does its thing immediately. */
3100 newSVOP(OP_CONST, 0, newSVpvn_share("BEGIN", 5, 0)),
3103 append_elem(OP_LINESEQ,
3104 append_elem(OP_LINESEQ,
3105 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, idop)),
3106 newSTATEOP(0, Nullch, veop)),
3107 newSTATEOP(0, Nullch, imop) ));
3109 /* The "did you use incorrect case?" warning used to be here.
3110 * The problem is that on case-insensitive filesystems one
3111 * might get false positives for "use" (and "require"):
3112 * "use Strict" or "require CARP" will work. This causes
3113 * portability problems for the script: in case-strict
3114 * filesystems the script will stop working.
3116 * The "incorrect case" warning checked whether "use Foo"
3117 * imported "Foo" to your namespace, but that is wrong, too:
3118 * there is no requirement nor promise in the language that
3119 * a Foo.pm should or would contain anything in package "Foo".
3121 * There is very little Configure-wise that can be done, either:
3122 * the case-sensitivity of the build filesystem of Perl does not
3123 * help in guessing the case-sensitivity of the runtime environment.
3126 PL_hints |= HINT_BLOCK_SCOPE;
3127 PL_copline = NOLINE;
3129 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3133 =head1 Embedding Functions
3135 =for apidoc load_module
3137 Loads the module whose name is pointed to by the string part of name.
3138 Note that the actual module name, not its filename, should be given.
3139 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3140 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3141 (or 0 for no flags). ver, if specified, provides version semantics
3142 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3143 arguments can be used to specify arguments to the module's import()
3144 method, similar to C<use Foo::Bar VERSION LIST>.
3149 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3152 va_start(args, ver);
3153 vload_module(flags, name, ver, &args);
3157 #ifdef PERL_IMPLICIT_CONTEXT
3159 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3163 va_start(args, ver);
3164 vload_module(flags, name, ver, &args);
3170 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3174 OP * const modname = newSVOP(OP_CONST, 0, name);
3175 modname->op_private |= OPpCONST_BARE;
3177 veop = newSVOP(OP_CONST, 0, ver);
3181 if (flags & PERL_LOADMOD_NOIMPORT) {
3182 imop = sawparens(newNULLLIST());
3184 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3185 imop = va_arg(*args, OP*);
3190 sv = va_arg(*args, SV*);
3192 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3193 sv = va_arg(*args, SV*);
3197 const line_t ocopline = PL_copline;
3198 COP * const ocurcop = PL_curcop;
3199 const int oexpect = PL_expect;
3201 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3202 veop, modname, imop);
3203 PL_expect = oexpect;
3204 PL_copline = ocopline;
3205 PL_curcop = ocurcop;
3210 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
3215 if (!force_builtin) {
3216 gv = gv_fetchpv("do", 0, SVt_PVCV);
3217 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
3218 GV * const * const gvp = (GV**)hv_fetch(PL_globalstash, "do", 2, FALSE);
3219 gv = gvp ? *gvp : Nullgv;
3223 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3224 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3225 append_elem(OP_LIST, term,
3226 scalar(newUNOP(OP_RV2CV, 0,
3231 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3237 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3239 return newBINOP(OP_LSLICE, flags,
3240 list(force_list(subscript)),
3241 list(force_list(listval)) );
3245 S_is_list_assignment(pTHX_ register const OP *o)
3250 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3251 o = cUNOPo->op_first;
3253 if (o->op_type == OP_COND_EXPR) {
3254 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
3255 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3260 yyerror("Assignment to both a list and a scalar");
3264 if (o->op_type == OP_LIST &&
3265 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3266 o->op_private & OPpLVAL_INTRO)
3269 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3270 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3271 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3274 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3277 if (o->op_type == OP_RV2SV)
3284 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3289 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3290 return newLOGOP(optype, 0,
3291 mod(scalar(left), optype),
3292 newUNOP(OP_SASSIGN, 0, scalar(right)));
3295 return newBINOP(optype, OPf_STACKED,
3296 mod(scalar(left), optype), scalar(right));
3300 if (is_list_assignment(left)) {
3304 /* Grandfathering $[ assignment here. Bletch.*/
3305 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
3306 PL_eval_start = (left->op_type == OP_CONST) ? right : 0;
3307 left = mod(left, OP_AASSIGN);
3310 else if (left->op_type == OP_CONST) {
3311 /* Result of assignment is always 1 (or we'd be dead already) */
3312 return newSVOP(OP_CONST, 0, newSViv(1));
3314 curop = list(force_list(left));
3315 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3316 o->op_private = (U8)(0 | (flags >> 8));
3318 /* PL_generation sorcery:
3319 * an assignment like ($a,$b) = ($c,$d) is easier than
3320 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3321 * To detect whether there are common vars, the global var
3322 * PL_generation is incremented for each assign op we compile.
3323 * Then, while compiling the assign op, we run through all the
3324 * variables on both sides of the assignment, setting a spare slot
3325 * in each of them to PL_generation. If any of them already have
3326 * that value, we know we've got commonality. We could use a
3327 * single bit marker, but then we'd have to make 2 passes, first
3328 * to clear the flag, then to test and set it. To find somewhere
3329 * to store these values, evil chicanery is done with SvCUR().
3332 if (!(left->op_private & OPpLVAL_INTRO)) {
3335 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3336 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3337 if (curop->op_type == OP_GV) {
3338 GV *gv = cGVOPx_gv(curop);
3339 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3341 SvCUR_set(gv, PL_generation);
3343 else if (curop->op_type == OP_PADSV ||
3344 curop->op_type == OP_PADAV ||
3345 curop->op_type == OP_PADHV ||
3346 curop->op_type == OP_PADANY)
3348 if (PAD_COMPNAME_GEN(curop->op_targ)
3349 == (STRLEN)PL_generation)
3351 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
3354 else if (curop->op_type == OP_RV2CV)
3356 else if (curop->op_type == OP_RV2SV ||
3357 curop->op_type == OP_RV2AV ||
3358 curop->op_type == OP_RV2HV ||
3359 curop->op_type == OP_RV2GV) {
3360 if (lastop->op_type != OP_GV) /* funny deref? */
3363 else if (curop->op_type == OP_PUSHRE) {
3364 if (((PMOP*)curop)->op_pmreplroot) {
3366 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3367 ((PMOP*)curop)->op_pmreplroot));
3369 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3371 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3373 SvCUR_set(gv, PL_generation);
3382 o->op_private |= OPpASSIGN_COMMON;
3384 if (right && right->op_type == OP_SPLIT) {
3386 if ((tmpop = ((LISTOP*)right)->op_first) &&
3387 tmpop->op_type == OP_PUSHRE)
3389 PMOP * const pm = (PMOP*)tmpop;
3390 if (left->op_type == OP_RV2AV &&
3391 !(left->op_private & OPpLVAL_INTRO) &&
3392 !(o->op_private & OPpASSIGN_COMMON) )
3394 tmpop = ((UNOP*)left)->op_first;
3395 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3397 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3398 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3400 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3401 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3403 pm->op_pmflags |= PMf_ONCE;
3404 tmpop = cUNOPo->op_first; /* to list (nulled) */
3405 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3406 tmpop->op_sibling = Nullop; /* don't free split */
3407 right->op_next = tmpop->op_next; /* fix starting loc */
3408 op_free(o); /* blow off assign */
3409 right->op_flags &= ~OPf_WANT;
3410 /* "I don't know and I don't care." */
3415 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3416 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3418 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3420 sv_setiv(sv, PL_modcount+1);
3428 right = newOP(OP_UNDEF, 0);
3429 if (right->op_type == OP_READLINE) {
3430 right->op_flags |= OPf_STACKED;
3431 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3434 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3435 o = newBINOP(OP_SASSIGN, flags,
3436 scalar(right), mod(scalar(left), OP_SASSIGN) );
3440 o = newSVOP(OP_CONST, 0, newSViv(PL_compiling.cop_arybase));
3447 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3450 const U32 seq = intro_my();
3453 NewOp(1101, cop, 1, COP);
3454 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3455 cop->op_type = OP_DBSTATE;
3456 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3459 cop->op_type = OP_NEXTSTATE;
3460 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3462 cop->op_flags = (U8)flags;
3463 cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
3465 cop->op_private |= NATIVE_HINTS;
3467 PL_compiling.op_private = cop->op_private;
3468 cop->op_next = (OP*)cop;
3471 cop->cop_label = label;
3472 PL_hints |= HINT_BLOCK_SCOPE;
3475 cop->cop_arybase = PL_curcop->cop_arybase;
3476 if (specialWARN(PL_curcop->cop_warnings))
3477 cop->cop_warnings = PL_curcop->cop_warnings ;
3479 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3480 if (specialCopIO(PL_curcop->cop_io))
3481 cop->cop_io = PL_curcop->cop_io;
3483 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3486 if (PL_copline == NOLINE)
3487 CopLINE_set(cop, CopLINE(PL_curcop));
3489 CopLINE_set(cop, PL_copline);
3490 PL_copline = NOLINE;
3493 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3495 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3497 CopSTASH_set(cop, PL_curstash);
3499 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3500 SV * const * const svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3501 if (svp && *svp != &PL_sv_undef ) {
3502 (void)SvIOK_on(*svp);
3503 SvIV_set(*svp, PTR2IV(cop));
3507 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3512 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3515 return new_logop(type, flags, &first, &other);
3519 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3524 OP *first = *firstp;
3525 OP * const other = *otherp;
3527 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3528 return newBINOP(type, flags, scalar(first), scalar(other));
3530 scalarboolean(first);
3531 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3532 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3533 if (type == OP_AND || type == OP_OR) {
3539 first = *firstp = cUNOPo->op_first;
3541 first->op_next = o->op_next;
3542 cUNOPo->op_first = Nullop;
3546 if (first->op_type == OP_CONST) {
3547 if (first->op_private & OPpCONST_STRICT)
3548 no_bareword_allowed(first);
3549 else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
3550 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
3551 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
3552 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
3553 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
3556 if (other->op_type == OP_CONST)
3557 other->op_private |= OPpCONST_SHORTCIRCUIT;
3561 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
3562 const OP *o2 = other;
3563 if ( ! (o2->op_type == OP_LIST
3564 && (( o2 = cUNOPx(o2)->op_first))
3565 && o2->op_type == OP_PUSHMARK
3566 && (( o2 = o2->op_sibling)) )
3569 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
3570 || o2->op_type == OP_PADHV)
3571 && o2->op_private & OPpLVAL_INTRO
3572 && ckWARN(WARN_DEPRECATED))
3574 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
3575 "Deprecated use of my() in false conditional");
3580 if (first->op_type == OP_CONST)
3581 first->op_private |= OPpCONST_SHORTCIRCUIT;
3585 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
3586 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
3588 const OP * const k1 = ((UNOP*)first)->op_first;
3589 const OP * const k2 = k1->op_sibling;
3591 switch (first->op_type)
3594 if (k2 && k2->op_type == OP_READLINE
3595 && (k2->op_flags & OPf_STACKED)
3596 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3598 warnop = k2->op_type;
3603 if (k1->op_type == OP_READDIR
3604 || k1->op_type == OP_GLOB
3605 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3606 || k1->op_type == OP_EACH)
3608 warnop = ((k1->op_type == OP_NULL)
3609 ? (OPCODE)k1->op_targ : k1->op_type);
3614 const line_t oldline = CopLINE(PL_curcop);
3615 CopLINE_set(PL_curcop, PL_copline);
3616 Perl_warner(aTHX_ packWARN(WARN_MISC),
3617 "Value of %s%s can be \"0\"; test with defined()",
3619 ((warnop == OP_READLINE || warnop == OP_GLOB)
3620 ? " construct" : "() operator"));
3621 CopLINE_set(PL_curcop, oldline);
3628 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
3629 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3631 NewOp(1101, logop, 1, LOGOP);
3633 logop->op_type = (OPCODE)type;
3634 logop->op_ppaddr = PL_ppaddr[type];
3635 logop->op_first = first;
3636 logop->op_flags = (U8)(flags | OPf_KIDS);
3637 logop->op_other = LINKLIST(other);
3638 logop->op_private = (U8)(1 | (flags >> 8));
3640 /* establish postfix order */
3641 logop->op_next = LINKLIST(first);
3642 first->op_next = (OP*)logop;
3643 first->op_sibling = other;
3645 CHECKOP(type,logop);
3647 o = newUNOP(OP_NULL, 0, (OP*)logop);
3654 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3662 return newLOGOP(OP_AND, 0, first, trueop);
3664 return newLOGOP(OP_OR, 0, first, falseop);
3666 scalarboolean(first);
3667 if (first->op_type == OP_CONST) {
3668 if (first->op_private & OPpCONST_BARE &&
3669 first->op_private & OPpCONST_STRICT) {
3670 no_bareword_allowed(first);
3672 if (SvTRUE(((SVOP*)first)->op_sv)) {
3683 NewOp(1101, logop, 1, LOGOP);
3684 logop->op_type = OP_COND_EXPR;
3685 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3686 logop->op_first = first;
3687 logop->op_flags = (U8)(flags | OPf_KIDS);
3688 logop->op_private = (U8)(1 | (flags >> 8));
3689 logop->op_other = LINKLIST(trueop);
3690 logop->op_next = LINKLIST(falseop);
3692 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
3695 /* establish postfix order */
3696 start = LINKLIST(first);
3697 first->op_next = (OP*)logop;
3699 first->op_sibling = trueop;
3700 trueop->op_sibling = falseop;
3701 o = newUNOP(OP_NULL, 0, (OP*)logop);
3703 trueop->op_next = falseop->op_next = o;
3710 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3719 NewOp(1101, range, 1, LOGOP);
3721 range->op_type = OP_RANGE;
3722 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3723 range->op_first = left;
3724 range->op_flags = OPf_KIDS;
3725 leftstart = LINKLIST(left);
3726 range->op_other = LINKLIST(right);
3727 range->op_private = (U8)(1 | (flags >> 8));
3729 left->op_sibling = right;
3731 range->op_next = (OP*)range;
3732 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3733 flop = newUNOP(OP_FLOP, 0, flip);
3734 o = newUNOP(OP_NULL, 0, flop);
3736 range->op_next = leftstart;
3738 left->op_next = flip;
3739 right->op_next = flop;
3741 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3742 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3743 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3744 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3746 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3747 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3750 if (!flip->op_private || !flop->op_private)
3751 linklist(o); /* blow off optimizer unless constant */
3757 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3761 const bool once = block && block->op_flags & OPf_SPECIAL &&
3762 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3764 PERL_UNUSED_ARG(debuggable);
3767 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3768 return block; /* do {} while 0 does once */
3769 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3770 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3771 expr = newUNOP(OP_DEFINED, 0,
3772 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3773 } else if (expr->op_flags & OPf_KIDS) {
3774 const OP * const k1 = ((UNOP*)expr)->op_first;
3775 const OP * const k2 = k1 ? k1->op_sibling : NULL;
3776 switch (expr->op_type) {
3778 if (k2 && k2->op_type == OP_READLINE
3779 && (k2->op_flags & OPf_STACKED)
3780 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3781 expr = newUNOP(OP_DEFINED, 0, expr);
3785 if (k1->op_type == OP_READDIR
3786 || k1->op_type == OP_GLOB
3787 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3788 || k1->op_type == OP_EACH)
3789 expr = newUNOP(OP_DEFINED, 0, expr);
3795 /* if block is null, the next append_elem() would put UNSTACK, a scalar
3796 * op, in listop. This is wrong. [perl #27024] */
3798 block = newOP(OP_NULL, 0);
3799 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3800 o = new_logop(OP_AND, 0, &expr, &listop);
3803 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3805 if (once && o != listop)
3806 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3809 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3811 o->op_flags |= flags;
3813 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3818 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
3819 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
3828 PERL_UNUSED_ARG(debuggable);
3831 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3832 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3833 expr = newUNOP(OP_DEFINED, 0,
3834 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3835 } else if (expr->op_flags & OPf_KIDS) {
3836 const OP * const k1 = ((UNOP*)expr)->op_first;
3837 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
3838 switch (expr->op_type) {
3840 if (k2 && k2->op_type == OP_READLINE
3841 && (k2->op_flags & OPf_STACKED)
3842 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3843 expr = newUNOP(OP_DEFINED, 0, expr);
3847 if (k1->op_type == OP_READDIR
3848 || k1->op_type == OP_GLOB
3849 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3850 || k1->op_type == OP_EACH)
3851 expr = newUNOP(OP_DEFINED, 0, expr);
3858 block = newOP(OP_NULL, 0);
3859 else if (cont || has_my) {
3860 block = scope(block);
3864 next = LINKLIST(cont);
3867 OP * const unstack = newOP(OP_UNSTACK, 0);
3870 cont = append_elem(OP_LINESEQ, cont, unstack);
3873 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3874 redo = LINKLIST(listop);
3877 PL_copline = (line_t)whileline;
3879 o = new_logop(OP_AND, 0, &expr, &listop);
3880 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3881 op_free(expr); /* oops, it's a while (0) */
3883 return Nullop; /* listop already freed by new_logop */
3886 ((LISTOP*)listop)->op_last->op_next =
3887 (o == listop ? redo : LINKLIST(o));
3893 NewOp(1101,loop,1,LOOP);
3894 loop->op_type = OP_ENTERLOOP;
3895 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3896 loop->op_private = 0;
3897 loop->op_next = (OP*)loop;
3900 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
3902 loop->op_redoop = redo;
3903 loop->op_lastop = o;
3904 o->op_private |= loopflags;
3907 loop->op_nextop = next;
3909 loop->op_nextop = o;
3911 o->op_flags |= flags;
3912 o->op_private |= (flags >> 8);
3917 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
3922 PADOFFSET padoff = 0;
3927 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
3928 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
3929 sv->op_type = OP_RV2GV;
3930 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
3931 if (cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
3932 iterpflags |= OPpITER_DEF;
3934 else if (sv->op_type == OP_PADSV) { /* private variable */
3935 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
3936 padoff = sv->op_targ;
3941 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
3942 padoff = sv->op_targ;
3944 iterflags |= OPf_SPECIAL;
3949 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
3950 if (padoff && strEQ(PAD_COMPNAME_PV(padoff), "$_"))
3951 iterpflags |= OPpITER_DEF;
3954 const I32 offset = pad_findmy("$_");
3955 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
3956 sv = newGVOP(OP_GV, 0, PL_defgv);
3961 iterpflags |= OPpITER_DEF;
3963 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
3964 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
3965 iterflags |= OPf_STACKED;
3967 else if (expr->op_type == OP_NULL &&
3968 (expr->op_flags & OPf_KIDS) &&
3969 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
3971 /* Basically turn for($x..$y) into the same as for($x,$y), but we
3972 * set the STACKED flag to indicate that these values are to be
3973 * treated as min/max values by 'pp_iterinit'.
3975 UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
3976 LOGOP* const range = (LOGOP*) flip->op_first;
3977 OP* const left = range->op_first;
3978 OP* const right = left->op_sibling;
3981 range->op_flags &= ~OPf_KIDS;
3982 range->op_first = Nullop;
3984 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
3985 listop->op_first->op_next = range->op_next;
3986 left->op_next = range->op_other;
3987 right->op_next = (OP*)listop;
3988 listop->op_next = listop->op_first;
3991 expr = (OP*)(listop);
3993 iterflags |= OPf_STACKED;
3996 expr = mod(force_list(expr), OP_GREPSTART);
3999 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4000 append_elem(OP_LIST, expr, scalar(sv))));
4001 assert(!loop->op_next);
4002 /* for my $x () sets OPpLVAL_INTRO;
4003 * for our $x () sets OPpOUR_INTRO */
4004 loop->op_private = (U8)iterpflags;
4005 #ifdef PL_OP_SLAB_ALLOC
4008 NewOp(1234,tmp,1,LOOP);
4009 Copy(loop,tmp,1,LISTOP);
4014 Renew(loop, 1, LOOP);
4016 loop->op_targ = padoff;
4017 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
4018 PL_copline = forline;
4019 return newSTATEOP(0, label, wop);
4023 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4027 if (type != OP_GOTO || label->op_type == OP_CONST) {
4028 /* "last()" means "last" */
4029 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4030 o = newOP(type, OPf_SPECIAL);
4032 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4033 ? SvPVx_nolen_const(((SVOP*)label)->op_sv)
4039 /* Check whether it's going to be a goto &function */
4040 if (label->op_type == OP_ENTERSUB
4041 && !(label->op_flags & OPf_STACKED))
4042 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4043 o = newUNOP(type, OPf_STACKED, label);
4045 PL_hints |= HINT_BLOCK_SCOPE;
4049 /* if the condition is a literal array or hash
4050 (or @{ ... } etc), make a reference to it.
4053 S_ref_array_or_hash(pTHX_ OP *cond)
4056 && (cond->op_type == OP_RV2AV
4057 || cond->op_type == OP_PADAV
4058 || cond->op_type == OP_RV2HV
4059 || cond->op_type == OP_PADHV))
4061 return newUNOP(OP_REFGEN,
4062 0, mod(cond, OP_REFGEN));
4068 /* These construct the optree fragments representing given()
4071 entergiven and enterwhen are LOGOPs; the op_other pointer
4072 points up to the associated leave op. We need this so we
4073 can put it in the context and make break/continue work.
4074 (Also, of course, pp_enterwhen will jump straight to
4075 op_other if the match fails.)
4080 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
4081 I32 enter_opcode, I32 leave_opcode,
4082 PADOFFSET entertarg)
4087 NewOp(1101, enterop, 1, LOGOP);
4088 enterop->op_type = enter_opcode;
4089 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
4090 enterop->op_flags = (U8) OPf_KIDS;
4091 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
4092 enterop->op_private = 0;
4094 o = newUNOP(leave_opcode, 0, (OP *) enterop);
4097 enterop->op_first = scalar(cond);
4098 cond->op_sibling = block;
4100 o->op_next = LINKLIST(cond);
4101 cond->op_next = (OP *) enterop;
4104 /* This is a default {} block */
4105 enterop->op_first = block;
4106 enterop->op_flags |= OPf_SPECIAL;
4108 o->op_next = (OP *) enterop;
4111 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
4112 entergiven and enterwhen both
4115 enterop->op_next = LINKLIST(block);
4116 block->op_next = enterop->op_other = o;
4121 /* Does this look like a boolean operation? For these purposes
4122 a boolean operation is:
4123 - a subroutine call [*]
4124 - a logical connective
4125 - a comparison operator
4126 - a filetest operator, with the exception of -s -M -A -C
4127 - defined(), exists() or eof()
4128 - /$re/ or $foo =~ /$re/
4130 [*] possibly surprising
4134 S_looks_like_bool(pTHX_ OP *o)
4136 switch(o->op_type) {
4138 return looks_like_bool(cLOGOPo->op_first);
4142 looks_like_bool(cLOGOPo->op_first)
4143 && looks_like_bool(cLOGOPo->op_first->op_sibling));
4147 case OP_NOT: case OP_XOR:
4148 /* Note that OP_DOR is not here */
4150 case OP_EQ: case OP_NE: case OP_LT:
4151 case OP_GT: case OP_LE: case OP_GE:
4153 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
4154 case OP_I_GT: case OP_I_LE: case OP_I_GE:
4156 case OP_SEQ: case OP_SNE: case OP_SLT:
4157 case OP_SGT: case OP_SLE: case OP_SGE:
4161 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
4162 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
4163 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
4164 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
4165 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
4166 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
4167 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
4168 case OP_FTTEXT: case OP_FTBINARY:
4170 case OP_DEFINED: case OP_EXISTS:
4171 case OP_MATCH: case OP_EOF:
4176 /* Detect comparisons that have been optimized away */
4177 if (cSVOPo->op_sv == &PL_sv_yes
4178 || cSVOPo->op_sv == &PL_sv_no)
4189 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
4192 return newGIVWHENOP(
4193 ref_array_or_hash(cond),
4195 OP_ENTERGIVEN, OP_LEAVEGIVEN,
4199 /* If cond is null, this is a default {} block */
4201 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
4203 bool cond_llb = (!cond || looks_like_bool(cond));
4209 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
4211 scalar(ref_array_or_hash(cond)));
4214 return newGIVWHENOP(
4216 append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
4217 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
4221 =for apidoc cv_undef
4223 Clear out all the active components of a CV. This can happen either
4224 by an explicit C<undef &foo>, or by the reference count going to zero.
4225 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
4226 children can still follow the full lexical scope chain.
4232 Perl_cv_undef(pTHX_ CV *cv)
4236 if (CvFILE(cv) && !CvXSUB(cv)) {
4237 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4238 Safefree(CvFILE(cv));
4243 if (!CvXSUB(cv) && CvROOT(cv)) {
4245 Perl_croak(aTHX_ "Can't undef active subroutine");
4248 PAD_SAVE_SETNULLPAD();
4250 op_free(CvROOT(cv));
4251 CvROOT(cv) = Nullop;
4252 CvSTART(cv) = Nullop;
4255 SvPOK_off((SV*)cv); /* forget prototype */
4260 /* remove CvOUTSIDE unless this is an undef rather than a free */
4261 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
4262 if (!CvWEAKOUTSIDE(cv))
4263 SvREFCNT_dec(CvOUTSIDE(cv));
4264 CvOUTSIDE(cv) = Nullcv;
4267 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4273 /* delete all flags except WEAKOUTSIDE */
4274 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
4278 Perl_cv_ckproto(pTHX_ const CV *cv, const GV *gv, const char *p)
4280 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX_const(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4281 SV* const msg = sv_newmortal();
4285 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4286 sv_setpv(msg, "Prototype mismatch:");
4288 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4290 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (const SV *)cv);
4292 Perl_sv_catpv(aTHX_ msg, ": none");
4293 sv_catpv(msg, " vs ");
4295 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4297 sv_catpv(msg, "none");
4298 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
4302 static void const_sv_xsub(pTHX_ CV* cv);
4306 =head1 Optree Manipulation Functions
4308 =for apidoc cv_const_sv
4310 If C<cv> is a constant sub eligible for inlining. returns the constant
4311 value returned by the sub. Otherwise, returns NULL.
4313 Constant subs can be created with C<newCONSTSUB> or as described in
4314 L<perlsub/"Constant Functions">.
4319 Perl_cv_const_sv(pTHX_ CV *cv)
4323 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
4325 return CvCONST(cv) ? (SV*)CvXSUBANY(cv).any_ptr : NULL;
4328 /* op_const_sv: examine an optree to determine whether it's in-lineable.
4329 * Can be called in 3 ways:
4332 * look for a single OP_CONST with attached value: return the value
4334 * cv && CvCLONE(cv) && !CvCONST(cv)
4336 * examine the clone prototype, and if contains only a single
4337 * OP_CONST referencing a pad const, or a single PADSV referencing
4338 * an outer lexical, return a non-zero value to indicate the CV is
4339 * a candidate for "constizing" at clone time
4343 * We have just cloned an anon prototype that was marked as a const
4344 * candidiate. Try to grab the current value, and in the case of
4345 * PADSV, ignore it if it has multiple references. Return the value.
4349 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
4356 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4357 o = cLISTOPo->op_first->op_sibling;
4359 for (; o; o = o->op_next) {
4360 const OPCODE type = o->op_type;
4362 if (sv && o->op_next == o)
4364 if (o->op_next != o) {
4365 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4367 if (type == OP_DBSTATE)
4370 if (type == OP_LEAVESUB || type == OP_RETURN)
4374 if (type == OP_CONST && cSVOPo->op_sv)
4376 else if (cv && type == OP_CONST) {
4377 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4381 else if (cv && type == OP_PADSV) {
4382 if (CvCONST(cv)) { /* newly cloned anon */
4383 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4384 /* the candidate should have 1 ref from this pad and 1 ref
4385 * from the parent */
4386 if (!sv || SvREFCNT(sv) != 2)
4393 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
4394 sv = &PL_sv_undef; /* an arbitrary non-null value */
4405 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4407 PERL_UNUSED_ARG(floor);
4417 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4421 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4423 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4427 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4438 const char * const name = o ? SvPVx_nolen_const(cSVOPo->op_sv) : Nullch;
4441 assert(proto->op_type == OP_CONST);
4442 ps = SvPVx_const(((SVOP*)proto)->op_sv, ps_len);
4447 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4448 SV * const sv = sv_newmortal();
4449 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4450 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
4451 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4452 aname = SvPVX_const(sv);
4457 gv_fetch_flags = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
4458 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
4459 gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
4460 : gv_fetchpv(aname ? aname
4461 : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4462 gv_fetch_flags, SVt_PVCV);
4471 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4472 maximum a prototype before. */
4473 if (SvTYPE(gv) > SVt_NULL) {
4474 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4475 && ckWARN_d(WARN_PROTOTYPE))
4477 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
4479 cv_ckproto((CV*)gv, NULL, ps);
4482 sv_setpvn((SV*)gv, ps, ps_len);
4484 sv_setiv((SV*)gv, -1);
4485 SvREFCNT_dec(PL_compcv);
4486 cv = PL_compcv = NULL;
4487 PL_sub_generation++;
4491 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4493 #ifdef GV_UNIQUE_CHECK
4494 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4495 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4499 if (!block || !ps || *ps || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
4502 const_sv = op_const_sv(block, Nullcv);
4505 const bool exists = CvROOT(cv) || CvXSUB(cv);
4507 #ifdef GV_UNIQUE_CHECK
4508 if (exists && GvUNIQUE(gv)) {
4509 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4513 /* if the subroutine doesn't exist and wasn't pre-declared
4514 * with a prototype, assume it will be AUTOLOADed,
4515 * skipping the prototype check
4517 if (exists || SvPOK(cv))
4518 cv_ckproto(cv, gv, ps);
4519 /* already defined (or promised)? */
4520 if (exists || GvASSUMECV(gv)) {
4521 if (!block && !attrs) {
4522 if (CvFLAGS(PL_compcv)) {
4523 /* might have had built-in attrs applied */
4524 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4526 /* just a "sub foo;" when &foo is already defined */
4527 SAVEFREESV(PL_compcv);
4531 if (ckWARN(WARN_REDEFINE)
4533 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4535 const line_t oldline = CopLINE(PL_curcop);
4536 if (PL_copline != NOLINE)
4537 CopLINE_set(PL_curcop, PL_copline);
4538 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4539 CvCONST(cv) ? "Constant subroutine %s redefined"
4540 : "Subroutine %s redefined", name);
4541 CopLINE_set(PL_curcop, oldline);
4549 (void)SvREFCNT_inc(const_sv);
4551 assert(!CvROOT(cv) && !CvCONST(cv));
4552 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
4553 CvXSUBANY(cv).any_ptr = const_sv;
4554 CvXSUB(cv) = const_sv_xsub;
4559 cv = newCONSTSUB(NULL, name, const_sv);
4562 SvREFCNT_dec(PL_compcv);
4564 PL_sub_generation++;
4571 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4572 * before we clobber PL_compcv.
4576 /* Might have had built-in attributes applied -- propagate them. */
4577 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4578 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4579 stash = GvSTASH(CvGV(cv));
4580 else if (CvSTASH(cv))
4581 stash = CvSTASH(cv);
4583 stash = PL_curstash;
4586 /* possibly about to re-define existing subr -- ignore old cv */
4587 rcv = (SV*)PL_compcv;
4588 if (name && GvSTASH(gv))
4589 stash = GvSTASH(gv);
4591 stash = PL_curstash;
4593 apply_attrs(stash, rcv, attrs, FALSE);
4595 if (cv) { /* must reuse cv if autoloaded */
4597 /* got here with just attrs -- work done, so bug out */
4598 SAVEFREESV(PL_compcv);
4601 /* transfer PL_compcv to cv */
4603 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4604 if (!CvWEAKOUTSIDE(cv))
4605 SvREFCNT_dec(CvOUTSIDE(cv));
4606 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4607 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
4608 CvOUTSIDE(PL_compcv) = 0;
4609 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4610 CvPADLIST(PL_compcv) = 0;
4611 /* inner references to PL_compcv must be fixed up ... */
4612 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
4613 /* ... before we throw it away */
4614 SvREFCNT_dec(PL_compcv);
4616 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4617 ++PL_sub_generation;
4624 PL_sub_generation++;
4628 CvFILE_set_from_cop(cv, PL_curcop);
4629 CvSTASH(cv) = PL_curstash;
4632 sv_setpvn((SV*)cv, ps, ps_len);
4634 if (PL_error_count) {
4638 const char *s = strrchr(name, ':');
4640 if (strEQ(s, "BEGIN")) {
4641 const char not_safe[] =
4642 "BEGIN not safe after errors--compilation aborted";
4643 if (PL_in_eval & EVAL_KEEPERR)
4644 Perl_croak(aTHX_ not_safe);
4646 /* force display of errors found but not reported */
4647 sv_catpv(ERRSV, not_safe);
4648 Perl_croak(aTHX_ "%"SVf, ERRSV);
4657 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4658 mod(scalarseq(block), OP_LEAVESUBLV));
4661 /* This makes sub {}; work as expected. */
4662 if (block->op_type == OP_STUB) {
4664 block = newSTATEOP(0, Nullch, 0);
4666 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4668 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4669 OpREFCNT_set(CvROOT(cv), 1);
4670 CvSTART(cv) = LINKLIST(CvROOT(cv));
4671 CvROOT(cv)->op_next = 0;
4672 CALL_PEEP(CvSTART(cv));
4674 /* now that optimizer has done its work, adjust pad values */
4676 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4679 assert(!CvCONST(cv));
4680 if (ps && !*ps && op_const_sv(block, cv))
4684 if (name || aname) {
4686 const char * const tname = (name ? name : aname);
4688 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4689 SV * const sv = NEWSV(0,0);
4690 SV * const tmpstr = sv_newmortal();
4691 GV * const db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4694 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4696 (long)PL_subline, (long)CopLINE(PL_curcop));
4697 gv_efullname3(tmpstr, gv, Nullch);
4698 hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0);
4699 hv = GvHVn(db_postponed);
4700 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
4701 CV * const pcv = GvCV(db_postponed);
4707 call_sv((SV*)pcv, G_DISCARD);
4712 if ((s = strrchr(tname,':')))
4717 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4720 if (strEQ(s, "BEGIN") && !PL_error_count) {
4721 const I32 oldscope = PL_scopestack_ix;
4723 SAVECOPFILE(&PL_compiling);
4724 SAVECOPLINE(&PL_compiling);
4727 PL_beginav = newAV();
4728 DEBUG_x( dump_sub(gv) );
4729 av_push(PL_beginav, (SV*)cv);
4730 GvCV(gv) = 0; /* cv has been hijacked */
4731 call_list(oldscope, PL_beginav);
4733 PL_curcop = &PL_compiling;
4734 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4737 else if (strEQ(s, "END") && !PL_error_count) {
4740 DEBUG_x( dump_sub(gv) );
4741 av_unshift(PL_endav, 1);
4742 av_store(PL_endav, 0, (SV*)cv);
4743 GvCV(gv) = 0; /* cv has been hijacked */
4745 else if (strEQ(s, "CHECK") && !PL_error_count) {
4747 PL_checkav = newAV();
4748 DEBUG_x( dump_sub(gv) );
4749 if (PL_main_start && ckWARN(WARN_VOID))
4750 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4751 av_unshift(PL_checkav, 1);
4752 av_store(PL_checkav, 0, (SV*)cv);
4753 GvCV(gv) = 0; /* cv has been hijacked */
4755 else if (strEQ(s, "INIT") && !PL_error_count) {
4757 PL_initav = newAV();
4758 DEBUG_x( dump_sub(gv) );
4759 if (PL_main_start && ckWARN(WARN_VOID))
4760 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4761 av_push(PL_initav, (SV*)cv);
4762 GvCV(gv) = 0; /* cv has been hijacked */
4767 PL_copline = NOLINE;
4772 /* XXX unsafe for threads if eval_owner isn't held */
4774 =for apidoc newCONSTSUB
4776 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4777 eligible for inlining at compile-time.
4783 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
4790 SAVECOPLINE(PL_curcop);
4791 CopLINE_set(PL_curcop, PL_copline);
4794 PL_hints &= ~HINT_BLOCK_SCOPE;
4797 SAVESPTR(PL_curstash);
4798 SAVECOPSTASH(PL_curcop);
4799 PL_curstash = stash;
4800 CopSTASH_set(PL_curcop,stash);
4803 cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
4804 CvXSUBANY(cv).any_ptr = sv;
4806 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
4810 CopSTASH_free(PL_curcop);
4818 =for apidoc U||newXS
4820 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4826 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
4828 GV * const gv = gv_fetchpv(name ? name :
4829 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4830 GV_ADDMULTI, SVt_PVCV);
4834 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4836 if ((cv = (name ? GvCV(gv) : Nullcv))) {
4838 /* just a cached method */
4842 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4843 /* already defined (or promised) */
4844 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
4845 if (ckWARN(WARN_REDEFINE)) {
4846 GV * const gvcv = CvGV(cv);
4848 HV * const stash = GvSTASH(gvcv);
4850 const char *name = HvNAME_get(stash);
4851 if ( strEQ(name,"autouse") ) {
4852 const line_t oldline = CopLINE(PL_curcop);
4853 if (PL_copline != NOLINE)
4854 CopLINE_set(PL_curcop, PL_copline);
4855 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4856 CvCONST(cv) ? "Constant subroutine %s redefined"
4857 : "Subroutine %s redefined"
4859 CopLINE_set(PL_curcop, oldline);
4869 if (cv) /* must reuse cv if autoloaded */
4872 cv = (CV*)NEWSV(1105,0);
4873 sv_upgrade((SV *)cv, SVt_PVCV);
4877 PL_sub_generation++;
4881 (void)gv_fetchfile(filename);
4882 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
4883 an external constant string */
4884 CvXSUB(cv) = subaddr;
4887 const char *s = strrchr(name,':');
4893 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4896 if (strEQ(s, "BEGIN")) {
4898 PL_beginav = newAV();
4899 av_push(PL_beginav, (SV*)cv);
4900 GvCV(gv) = 0; /* cv has been hijacked */
4902 else if (strEQ(s, "END")) {
4905 av_unshift(PL_endav, 1);
4906 av_store(PL_endav, 0, (SV*)cv);
4907 GvCV(gv) = 0; /* cv has been hijacked */
4909 else if (strEQ(s, "CHECK")) {
4911 PL_checkav = newAV();
4912 if (PL_main_start && ckWARN(WARN_VOID))
4913 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4914 av_unshift(PL_checkav, 1);
4915 av_store(PL_checkav, 0, (SV*)cv);
4916 GvCV(gv) = 0; /* cv has been hijacked */
4918 else if (strEQ(s, "INIT")) {
4920 PL_initav = newAV();
4921 if (PL_main_start && ckWARN(WARN_VOID))
4922 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4923 av_push(PL_initav, (SV*)cv);
4924 GvCV(gv) = 0; /* cv has been hijacked */
4935 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4940 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
4941 : gv_fetchpv("STDOUT", GV_ADD, SVt_PVFM);
4943 #ifdef GV_UNIQUE_CHECK
4945 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
4949 if ((cv = GvFORM(gv))) {
4950 if (ckWARN(WARN_REDEFINE)) {
4951 const line_t oldline = CopLINE(PL_curcop);
4952 if (PL_copline != NOLINE)
4953 CopLINE_set(PL_curcop, PL_copline);
4954 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4955 o ? "Format %"SVf" redefined"
4956 : "Format STDOUT redefined" ,cSVOPo->op_sv);
4957 CopLINE_set(PL_curcop, oldline);
4964 CvFILE_set_from_cop(cv, PL_curcop);
4967 pad_tidy(padtidy_FORMAT);
4968 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
4969 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4970 OpREFCNT_set(CvROOT(cv), 1);
4971 CvSTART(cv) = LINKLIST(CvROOT(cv));
4972 CvROOT(cv)->op_next = 0;
4973 CALL_PEEP(CvSTART(cv));
4975 PL_copline = NOLINE;
4980 Perl_newANONLIST(pTHX_ OP *o)
4982 return newUNOP(OP_REFGEN, 0,
4983 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
4987 Perl_newANONHASH(pTHX_ OP *o)
4989 return newUNOP(OP_REFGEN, 0,
4990 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
4994 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
4996 return newANONATTRSUB(floor, proto, Nullop, block);
5000 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5002 return newUNOP(OP_REFGEN, 0,
5003 newSVOP(OP_ANONCODE, 0,
5004 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5008 Perl_oopsAV(pTHX_ OP *o)
5011 switch (o->op_type) {
5013 o->op_type = OP_PADAV;
5014 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5015 return ref(o, OP_RV2AV);
5018 o->op_type = OP_RV2AV;
5019 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5024 if (ckWARN_d(WARN_INTERNAL))
5025 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
5032 Perl_oopsHV(pTHX_ OP *o)
5035 switch (o->op_type) {
5038 o->op_type = OP_PADHV;
5039 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5040 return ref(o, OP_RV2HV);
5044 o->op_type = OP_RV2HV;
5045 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5050 if (ckWARN_d(WARN_INTERNAL))
5051 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
5058 Perl_newAVREF(pTHX_ OP *o)
5061 if (o->op_type == OP_PADANY) {
5062 o->op_type = OP_PADAV;
5063 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5066 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5067 && ckWARN(WARN_DEPRECATED)) {
5068 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5069 "Using an array as a reference is deprecated");
5071 return newUNOP(OP_RV2AV, 0, scalar(o));
5075 Perl_newGVREF(pTHX_ I32 type, OP *o)
5077 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5078 return newUNOP(OP_NULL, 0, o);
5079 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5083 Perl_newHVREF(pTHX_ OP *o)
5086 if (o->op_type == OP_PADANY) {
5087 o->op_type = OP_PADHV;
5088 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5091 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5092 && ckWARN(WARN_DEPRECATED)) {
5093 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5094 "Using a hash as a reference is deprecated");
5096 return newUNOP(OP_RV2HV, 0, scalar(o));
5100 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5102 return newUNOP(OP_RV2CV, flags, scalar(o));
5106 Perl_newSVREF(pTHX_ OP *o)
5109 if (o->op_type == OP_PADANY) {
5110 o->op_type = OP_PADSV;
5111 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5114 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5115 o->op_flags |= OPpDONE_SVREF;
5118 return newUNOP(OP_RV2SV, 0, scalar(o));
5121 /* Check routines. See the comments at the top of this file for details
5122 * on when these are called */
5125 Perl_ck_anoncode(pTHX_ OP *o)
5127 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
5128 cSVOPo->op_sv = Nullsv;
5133 Perl_ck_bitop(pTHX_ OP *o)
5135 #define OP_IS_NUMCOMPARE(op) \
5136 ((op) == OP_LT || (op) == OP_I_LT || \
5137 (op) == OP_GT || (op) == OP_I_GT || \
5138 (op) == OP_LE || (op) == OP_I_LE || \
5139 (op) == OP_GE || (op) == OP_I_GE || \
5140 (op) == OP_EQ || (op) == OP_I_EQ || \
5141 (op) == OP_NE || (op) == OP_I_NE || \
5142 (op) == OP_NCMP || (op) == OP_I_NCMP)
5143 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
5144 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
5145 && (o->op_type == OP_BIT_OR
5146 || o->op_type == OP_BIT_AND
5147 || o->op_type == OP_BIT_XOR))
5149 const OP * const left = cBINOPo->op_first;
5150 const OP * const right = left->op_sibling;
5151 if ((OP_IS_NUMCOMPARE(left->op_type) &&
5152 (left->op_flags & OPf_PARENS) == 0) ||
5153 (OP_IS_NUMCOMPARE(right->op_type) &&
5154 (right->op_flags & OPf_PARENS) == 0))
5155 if (ckWARN(WARN_PRECEDENCE))
5156 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
5157 "Possible precedence problem on bitwise %c operator",
5158 o->op_type == OP_BIT_OR ? '|'
5159 : o->op_type == OP_BIT_AND ? '&' : '^'
5166 Perl_ck_concat(pTHX_ OP *o)
5168 const OP * const kid = cUNOPo->op_first;
5169 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
5170 !(kUNOP->op_first->op_flags & OPf_MOD))
5171 o->op_flags |= OPf_STACKED;
5176 Perl_ck_spair(pTHX_ OP *o)
5179 if (o->op_flags & OPf_KIDS) {
5182 const OPCODE type = o->op_type;
5183 o = modkids(ck_fun(o), type);
5184 kid = cUNOPo->op_first;
5185 newop = kUNOP->op_first->op_sibling;
5187 (newop->op_sibling ||
5188 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5189 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5190 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5194 op_free(kUNOP->op_first);
5195 kUNOP->op_first = newop;
5197 o->op_ppaddr = PL_ppaddr[++o->op_type];
5202 Perl_ck_delete(pTHX_ OP *o)
5206 if (o->op_flags & OPf_KIDS) {
5207 OP * const kid = cUNOPo->op_first;
5208 switch (kid->op_type) {
5210 o->op_flags |= OPf_SPECIAL;
5213 o->op_private |= OPpSLICE;
5216 o->op_flags |= OPf_SPECIAL;
5221 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5230 Perl_ck_die(pTHX_ OP *o)
5233 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5239 Perl_ck_eof(pTHX_ OP *o)
5241 const I32 type = o->op_type;
5243 if (o->op_flags & OPf_KIDS) {
5244 if (cLISTOPo->op_first->op_type == OP_STUB) {
5246 o = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
5254 Perl_ck_eval(pTHX_ OP *o)
5257 PL_hints |= HINT_BLOCK_SCOPE;
5258 if (o->op_flags & OPf_KIDS) {
5259 SVOP * const kid = (SVOP*)cUNOPo->op_first;
5262 o->op_flags &= ~OPf_KIDS;
5265 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
5268 cUNOPo->op_first = 0;
5271 NewOp(1101, enter, 1, LOGOP);
5272 enter->op_type = OP_ENTERTRY;
5273 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5274 enter->op_private = 0;
5276 /* establish postfix order */
5277 enter->op_next = (OP*)enter;
5279 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5280 o->op_type = OP_LEAVETRY;
5281 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5282 enter->op_other = o;
5292 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5294 o->op_targ = (PADOFFSET)PL_hints;
5295 if ((PL_hints & HINT_HH_FOR_EVAL) != 0 && GvHV(PL_hintgv))
5297 /* Store a copy of %^H that pp_entereval can pick up */
5298 OP *hhop = newSVOP(OP_CONST, 0, (SV*)newHVhv(GvHV(PL_hintgv)));
5299 cUNOPo->op_first->op_sibling = hhop;
5300 o->op_private |= OPpEVAL_HAS_HH;
5306 Perl_ck_exit(pTHX_ OP *o)
5309 HV * const table = GvHV(PL_hintgv);
5311 SV * const * const svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5312 if (svp && *svp && SvTRUE(*svp))
5313 o->op_private |= OPpEXIT_VMSISH;
5315 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5321 Perl_ck_exec(pTHX_ OP *o)
5323 if (o->op_flags & OPf_STACKED) {
5326 kid = cUNOPo->op_first->op_sibling;
5327 if (kid->op_type == OP_RV2GV)
5336 Perl_ck_exists(pTHX_ OP *o)
5339 if (o->op_flags & OPf_KIDS) {
5340 OP * const kid = cUNOPo->op_first;
5341 if (kid->op_type == OP_ENTERSUB) {
5342 (void) ref(kid, o->op_type);
5343 if (kid->op_type != OP_RV2CV && !PL_error_count)
5344 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5346 o->op_private |= OPpEXISTS_SUB;
5348 else if (kid->op_type == OP_AELEM)
5349 o->op_flags |= OPf_SPECIAL;
5350 else if (kid->op_type != OP_HELEM)
5351 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5359 Perl_ck_rvconst(pTHX_ register OP *o)
5362 SVOP * const kid = (SVOP*)cUNOPo->op_first;
5364 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5365 if (kid->op_type == OP_CONST) {
5368 SV * const kidsv = kid->op_sv;
5370 /* Is it a constant from cv_const_sv()? */
5371 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5372 SV * const rsv = SvRV(kidsv);
5373 const int svtype = SvTYPE(rsv);
5374 const char *badtype = Nullch;
5376 switch (o->op_type) {
5378 if (svtype > SVt_PVMG)
5379 badtype = "a SCALAR";
5382 if (svtype != SVt_PVAV)
5383 badtype = "an ARRAY";
5386 if (svtype != SVt_PVHV)
5390 if (svtype != SVt_PVCV)
5395 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5398 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5399 const char *badthing = Nullch;
5400 switch (o->op_type) {
5402 badthing = "a SCALAR";
5405 badthing = "an ARRAY";
5408 badthing = "a HASH";
5413 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
5417 * This is a little tricky. We only want to add the symbol if we
5418 * didn't add it in the lexer. Otherwise we get duplicate strict
5419 * warnings. But if we didn't add it in the lexer, we must at
5420 * least pretend like we wanted to add it even if it existed before,
5421 * or we get possible typo warnings. OPpCONST_ENTERED says
5422 * whether the lexer already added THIS instance of this symbol.
5424 iscv = (o->op_type == OP_RV2CV) * 2;
5426 gv = gv_fetchsv(kidsv,
5427 iscv | !(kid->op_private & OPpCONST_ENTERED),
5430 : o->op_type == OP_RV2SV
5432 : o->op_type == OP_RV2AV
5434 : o->op_type == OP_RV2HV
5437 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5439 kid->op_type = OP_GV;
5440 SvREFCNT_dec(kid->op_sv);
5442 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5443 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5444 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
5446 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv));
5448 kid->op_sv = SvREFCNT_inc(gv);
5450 kid->op_private = 0;
5451 kid->op_ppaddr = PL_ppaddr[OP_GV];
5458 Perl_ck_ftst(pTHX_ OP *o)
5461 const I32 type = o->op_type;
5463 if (o->op_flags & OPf_REF) {
5466 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5467 SVOP * const kid = (SVOP*)cUNOPo->op_first;
5469 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5470 OP * const newop = newGVOP(type, OPf_REF,
5471 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
5477 if ((PL_hints & HINT_FILETEST_ACCESS) &&
5478 OP_IS_FILETEST_ACCESS(o))
5479 o->op_private |= OPpFT_ACCESS;
5481 if (PL_check[kid->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst)
5482 && kid->op_type != OP_STAT && kid->op_type != OP_LSTAT)
5483 o->op_private |= OPpFT_STACKED;
5487 if (type == OP_FTTTY)
5488 o = newGVOP(type, OPf_REF, PL_stdingv);
5490 o = newUNOP(type, 0, newDEFSVOP());
5496 Perl_ck_fun(pTHX_ OP *o)
5498 const int type = o->op_type;
5499 register I32 oa = PL_opargs[type] >> OASHIFT;
5501 if (o->op_flags & OPf_STACKED) {
5502 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5505 return no_fh_allowed(o);
5508 if (o->op_flags & OPf_KIDS) {
5509 OP **tokid = &cLISTOPo->op_first;
5510 register OP *kid = cLISTOPo->op_first;
5514 if (kid->op_type == OP_PUSHMARK ||
5515 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5517 tokid = &kid->op_sibling;
5518 kid = kid->op_sibling;
5520 if (!kid && PL_opargs[type] & OA_DEFGV)
5521 *tokid = kid = newDEFSVOP();
5525 sibl = kid->op_sibling;
5528 /* list seen where single (scalar) arg expected? */
5529 if (numargs == 1 && !(oa >> 4)
5530 && kid->op_type == OP_LIST && type != OP_SCALAR)
5532 return too_many_arguments(o,PL_op_desc[type]);
5545 if ((type == OP_PUSH || type == OP_UNSHIFT)
5546 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5547 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5548 "Useless use of %s with no values",
5551 if (kid->op_type == OP_CONST &&
5552 (kid->op_private & OPpCONST_BARE))
5554 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
5555 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
5556 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5557 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5558 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
5559 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
5562 kid->op_sibling = sibl;
5565 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5566 bad_type(numargs, "array", PL_op_desc[type], kid);
5570 if (kid->op_type == OP_CONST &&
5571 (kid->op_private & OPpCONST_BARE))
5573 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
5574 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
5575 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5576 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5577 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
5578 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
5581 kid->op_sibling = sibl;
5584 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5585 bad_type(numargs, "hash", PL_op_desc[type], kid);
5590 OP * const newop = newUNOP(OP_NULL, 0, kid);
5591 kid->op_sibling = 0;
5593 newop->op_next = newop;
5595 kid->op_sibling = sibl;
5600 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5601 if (kid->op_type == OP_CONST &&
5602 (kid->op_private & OPpCONST_BARE))
5604 OP * const newop = newGVOP(OP_GV, 0,
5605 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
5606 if (!(o->op_private & 1) && /* if not unop */
5607 kid == cLISTOPo->op_last)
5608 cLISTOPo->op_last = newop;
5612 else if (kid->op_type == OP_READLINE) {
5613 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5614 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5617 I32 flags = OPf_SPECIAL;
5621 /* is this op a FH constructor? */
5622 if (is_handle_constructor(o,numargs)) {
5623 const char *name = Nullch;
5627 /* Set a flag to tell rv2gv to vivify
5628 * need to "prove" flag does not mean something
5629 * else already - NI-S 1999/05/07
5632 if (kid->op_type == OP_PADSV) {
5633 name = PAD_COMPNAME_PV(kid->op_targ);
5634 /* SvCUR of a pad namesv can't be trusted
5635 * (see PL_generation), so calc its length
5641 else if (kid->op_type == OP_RV2SV
5642 && kUNOP->op_first->op_type == OP_GV)
5644 GV * const gv = cGVOPx_gv(kUNOP->op_first);
5646 len = GvNAMELEN(gv);
5648 else if (kid->op_type == OP_AELEM
5649 || kid->op_type == OP_HELEM)
5651 OP *op = ((BINOP*)kid)->op_first;
5654 SV *tmpstr = Nullsv;
5655 const char * const a =
5656 kid->op_type == OP_AELEM ?
5658 if (((op->op_type == OP_RV2AV) ||
5659 (op->op_type == OP_RV2HV)) &&
5660 (op = ((UNOP*)op)->op_first) &&
5661 (op->op_type == OP_GV)) {
5662 /* packagevar $a[] or $h{} */
5663 GV * const gv = cGVOPx_gv(op);
5671 else if (op->op_type == OP_PADAV
5672 || op->op_type == OP_PADHV) {
5673 /* lexicalvar $a[] or $h{} */
5674 const char * const padname =
5675 PAD_COMPNAME_PV(op->op_targ);
5684 name = SvPV_const(tmpstr, len);
5689 name = "__ANONIO__";
5696 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5697 namesv = PAD_SVl(targ);
5698 SvUPGRADE(namesv, SVt_PV);
5700 sv_setpvn(namesv, "$", 1);
5701 sv_catpvn(namesv, name, len);
5704 kid->op_sibling = 0;
5705 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5706 kid->op_targ = targ;
5707 kid->op_private |= priv;
5709 kid->op_sibling = sibl;
5715 mod(scalar(kid), type);
5719 tokid = &kid->op_sibling;
5720 kid = kid->op_sibling;
5722 o->op_private |= numargs;
5724 return too_many_arguments(o,OP_DESC(o));
5727 else if (PL_opargs[type] & OA_DEFGV) {
5729 return newUNOP(type, 0, newDEFSVOP());
5733 while (oa & OA_OPTIONAL)
5735 if (oa && oa != OA_LIST)
5736 return too_few_arguments(o,OP_DESC(o));
5742 Perl_ck_glob(pTHX_ OP *o)
5748 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5749 append_elem(OP_GLOB, o, newDEFSVOP());
5751 if (!((gv = gv_fetchpv("glob", 0, SVt_PVCV))
5752 && GvCVu(gv) && GvIMPORTED_CV(gv)))
5754 gv = gv_fetchpv("CORE::GLOBAL::glob", 0, SVt_PVCV);
5757 #if !defined(PERL_EXTERNAL_GLOB)
5758 /* XXX this can be tightened up and made more failsafe. */
5759 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
5762 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5763 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
5764 gv = gv_fetchpv("CORE::GLOBAL::glob", 0, SVt_PVCV);
5765 glob_gv = gv_fetchpv("File::Glob::csh_glob", 0, SVt_PVCV);
5766 GvCV(gv) = GvCV(glob_gv);
5767 (void)SvREFCNT_inc((SV*)GvCV(gv));
5768 GvIMPORTED_CV_on(gv);
5771 #endif /* PERL_EXTERNAL_GLOB */
5773 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5774 append_elem(OP_GLOB, o,
5775 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5776 o->op_type = OP_LIST;
5777 o->op_ppaddr = PL_ppaddr[OP_LIST];
5778 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5779 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5780 cLISTOPo->op_first->op_targ = 0;
5781 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5782 append_elem(OP_LIST, o,
5783 scalar(newUNOP(OP_RV2CV, 0,
5784 newGVOP(OP_GV, 0, gv)))));
5785 o = newUNOP(OP_NULL, 0, ck_subr(o));
5786 o->op_targ = OP_GLOB; /* hint at what it used to be */
5789 gv = newGVgen("main");
5791 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5797 Perl_ck_grep(pTHX_ OP *o)
5802 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5805 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5806 NewOp(1101, gwop, 1, LOGOP);
5808 if (o->op_flags & OPf_STACKED) {
5811 kid = cLISTOPo->op_first->op_sibling;
5812 if (!cUNOPx(kid)->op_next)
5813 Perl_croak(aTHX_ "panic: ck_grep");
5814 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
5817 kid->op_next = (OP*)gwop;
5818 o->op_flags &= ~OPf_STACKED;
5820 kid = cLISTOPo->op_first->op_sibling;
5821 if (type == OP_MAPWHILE)
5828 kid = cLISTOPo->op_first->op_sibling;
5829 if (kid->op_type != OP_NULL)
5830 Perl_croak(aTHX_ "panic: ck_grep");
5831 kid = kUNOP->op_first;
5833 gwop->op_type = type;
5834 gwop->op_ppaddr = PL_ppaddr[type];
5835 gwop->op_first = listkids(o);
5836 gwop->op_flags |= OPf_KIDS;
5837 gwop->op_other = LINKLIST(kid);
5838 kid->op_next = (OP*)gwop;
5839 offset = pad_findmy("$_");
5840 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
5841 o->op_private = gwop->op_private = 0;
5842 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5845 o->op_private = gwop->op_private = OPpGREP_LEX;
5846 gwop->op_targ = o->op_targ = offset;
5849 kid = cLISTOPo->op_first->op_sibling;
5850 if (!kid || !kid->op_sibling)
5851 return too_few_arguments(o,OP_DESC(o));
5852 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5853 mod(kid, OP_GREPSTART);
5859 Perl_ck_index(pTHX_ OP *o)
5861 if (o->op_flags & OPf_KIDS) {
5862 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5864 kid = kid->op_sibling; /* get past "big" */
5865 if (kid && kid->op_type == OP_CONST)
5866 fbm_compile(((SVOP*)kid)->op_sv, 0);
5872 Perl_ck_lengthconst(pTHX_ OP *o)
5874 /* XXX length optimization goes here */
5879 Perl_ck_lfun(pTHX_ OP *o)
5881 const OPCODE type = o->op_type;
5882 return modkids(ck_fun(o), type);
5886 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5888 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
5889 switch (cUNOPo->op_first->op_type) {
5891 /* This is needed for
5892 if (defined %stash::)
5893 to work. Do not break Tk.
5895 break; /* Globals via GV can be undef */
5897 case OP_AASSIGN: /* Is this a good idea? */
5898 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5899 "defined(@array) is deprecated");
5900 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5901 "\t(Maybe you should just omit the defined()?)\n");
5904 /* This is needed for
5905 if (defined %stash::)
5906 to work. Do not break Tk.
5908 break; /* Globals via GV can be undef */
5910 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5911 "defined(%%hash) is deprecated");
5912 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5913 "\t(Maybe you should just omit the defined()?)\n");
5924 Perl_ck_rfun(pTHX_ OP *o)
5926 const OPCODE type = o->op_type;
5927 return refkids(ck_fun(o), type);
5931 Perl_ck_listiob(pTHX_ OP *o)
5935 kid = cLISTOPo->op_first;
5938 kid = cLISTOPo->op_first;
5940 if (kid->op_type == OP_PUSHMARK)
5941 kid = kid->op_sibling;
5942 if (kid && o->op_flags & OPf_STACKED)
5943 kid = kid->op_sibling;
5944 else if (kid && !kid->op_sibling) { /* print HANDLE; */
5945 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5946 o->op_flags |= OPf_STACKED; /* make it a filehandle */
5947 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5948 cLISTOPo->op_first->op_sibling = kid;
5949 cLISTOPo->op_last = kid;
5950 kid = kid->op_sibling;
5955 append_elem(o->op_type, o, newDEFSVOP());
5961 Perl_ck_say(pTHX_ OP *o)
5964 o->op_type = OP_PRINT;
5965 cLISTOPo->op_last = cLISTOPo->op_last->op_sibling
5966 = newSVOP(OP_CONST, 0, newSVpvn("\n", 1));
5971 Perl_ck_smartmatch(pTHX_ OP *o)
5973 if (0 == (o->op_flags & OPf_SPECIAL)) {
5974 OP *first = cBINOPo->op_first;
5975 OP *second = first->op_sibling;
5977 /* Implicitly take a reference to an array or hash */
5978 first->op_sibling = Nullop;
5979 first = cBINOPo->op_first = ref_array_or_hash(first);
5980 second = first->op_sibling = ref_array_or_hash(second);
5982 /* Implicitly take a reference to a regular expression */
5983 if (first->op_type == OP_MATCH) {
5984 first->op_type = OP_QR;
5985 first->op_ppaddr = PL_ppaddr[OP_QR];
5987 if (second->op_type == OP_MATCH) {
5988 second->op_type = OP_QR;
5989 second->op_ppaddr = PL_ppaddr[OP_QR];
5998 Perl_ck_sassign(pTHX_ OP *o)
6000 OP *kid = cLISTOPo->op_first;
6001 /* has a disposable target? */
6002 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6003 && !(kid->op_flags & OPf_STACKED)
6004 /* Cannot steal the second time! */
6005 && !(kid->op_private & OPpTARGET_MY))
6007 OP * const kkid = kid->op_sibling;
6009 /* Can just relocate the target. */
6010 if (kkid && kkid->op_type == OP_PADSV
6011 && !(kkid->op_private & OPpLVAL_INTRO))
6013 kid->op_targ = kkid->op_targ;
6015 /* Now we do not need PADSV and SASSIGN. */
6016 kid->op_sibling = o->op_sibling; /* NULL */
6017 cLISTOPo->op_first = NULL;
6020 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6028 Perl_ck_match(pTHX_ OP *o)
6030 if (o->op_type != OP_QR && PL_compcv) {
6031 const I32 offset = pad_findmy("$_");
6032 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS(offset) & SVpad_OUR)) {
6033 o->op_targ = offset;
6034 o->op_private |= OPpTARGET_MY;
6037 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
6038 o->op_private |= OPpRUNTIME;
6043 Perl_ck_method(pTHX_ OP *o)
6045 OP * const kid = cUNOPo->op_first;
6046 if (kid->op_type == OP_CONST) {
6047 SV* sv = kSVOP->op_sv;
6048 if (!(strchr(SvPVX_const(sv), ':') || strchr(SvPVX_const(sv), '\''))) {
6050 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6051 sv = newSVpvn_share(SvPVX_const(sv), SvCUR(sv), 0);
6054 kSVOP->op_sv = Nullsv;
6056 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6065 Perl_ck_null(pTHX_ OP *o)
6071 Perl_ck_open(pTHX_ OP *o)
6073 HV * const table = GvHV(PL_hintgv);
6075 SV **svp = hv_fetch(table, "open_IN", 7, FALSE);
6077 const I32 mode = mode_from_discipline(*svp);
6078 if (mode & O_BINARY)
6079 o->op_private |= OPpOPEN_IN_RAW;
6080 else if (mode & O_TEXT)
6081 o->op_private |= OPpOPEN_IN_CRLF;
6084 svp = hv_fetch(table, "open_OUT", 8, FALSE);
6086 const I32 mode = mode_from_discipline(*svp);
6087 if (mode & O_BINARY)
6088 o->op_private |= OPpOPEN_OUT_RAW;
6089 else if (mode & O_TEXT)
6090 o->op_private |= OPpOPEN_OUT_CRLF;
6093 if (o->op_type == OP_BACKTICK)
6096 /* In case of three-arg dup open remove strictness
6097 * from the last arg if it is a bareword. */
6098 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
6099 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
6103 if ((last->op_type == OP_CONST) && /* The bareword. */
6104 (last->op_private & OPpCONST_BARE) &&
6105 (last->op_private & OPpCONST_STRICT) &&
6106 (oa = first->op_sibling) && /* The fh. */
6107 (oa = oa->op_sibling) && /* The mode. */
6108 (oa->op_type == OP_CONST) &&
6109 SvPOK(((SVOP*)oa)->op_sv) &&
6110 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
6111 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
6112 (last == oa->op_sibling)) /* The bareword. */
6113 last->op_private &= ~OPpCONST_STRICT;
6119 Perl_ck_repeat(pTHX_ OP *o)
6121 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6122 o->op_private |= OPpREPEAT_DOLIST;
6123 cBINOPo->op_first = force_list(cBINOPo->op_first);
6131 Perl_ck_require(pTHX_ OP *o)
6135 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6136 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6138 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6139 SV * const sv = kid->op_sv;
6140 U32 was_readonly = SvREADONLY(sv);
6145 sv_force_normal_flags(sv, 0);
6146 assert(!SvREADONLY(sv));
6153 for (s = SvPVX(sv); *s; s++) {
6154 if (*s == ':' && s[1] == ':') {
6155 const STRLEN len = strlen(s+2)+1;
6157 Move(s+2, s+1, len, char);
6158 SvCUR_set(sv, SvCUR(sv) - 1);
6161 sv_catpvn(sv, ".pm", 3);
6162 SvFLAGS(sv) |= was_readonly;
6166 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
6167 /* handle override, if any */
6168 gv = gv_fetchpv("require", 0, SVt_PVCV);
6169 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
6170 GV * const * const gvp = (GV**)hv_fetch(PL_globalstash, "require", 7, FALSE);
6171 gv = gvp ? *gvp : Nullgv;
6175 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6176 OP * const kid = cUNOPo->op_first;
6177 cUNOPo->op_first = 0;
6179 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
6180 append_elem(OP_LIST, kid,
6181 scalar(newUNOP(OP_RV2CV, 0,
6190 Perl_ck_return(pTHX_ OP *o)
6192 if (CvLVALUE(PL_compcv)) {
6194 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6195 mod(kid, OP_LEAVESUBLV);
6201 Perl_ck_select(pTHX_ OP *o)
6205 if (o->op_flags & OPf_KIDS) {
6206 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6207 if (kid && kid->op_sibling) {
6208 o->op_type = OP_SSELECT;
6209 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6211 return fold_constants(o);
6215 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6216 if (kid && kid->op_type == OP_RV2GV)
6217 kid->op_private &= ~HINT_STRICT_REFS;
6222 Perl_ck_shift(pTHX_ OP *o)
6224 const I32 type = o->op_type;
6226 if (!(o->op_flags & OPf_KIDS)) {
6230 argop = newUNOP(OP_RV2AV, 0,
6231 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
6232 return newUNOP(type, 0, scalar(argop));
6234 return scalar(modkids(ck_fun(o), type));
6238 Perl_ck_sort(pTHX_ OP *o)
6242 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0)
6244 HV *hinthv = GvHV(PL_hintgv);
6246 SV **svp = hv_fetch(hinthv, "sort", 4, 0);
6248 I32 sorthints = (I32)SvIV(*svp);
6249 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
6250 o->op_private |= OPpSORT_QSORT;
6251 if ((sorthints & HINT_SORT_STABLE) != 0)
6252 o->op_private |= OPpSORT_STABLE;
6257 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6259 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6260 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6262 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6264 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6266 if (kid->op_type == OP_SCOPE) {
6270 else if (kid->op_type == OP_LEAVE) {
6271 if (o->op_type == OP_SORT) {
6272 op_null(kid); /* wipe out leave */
6275 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6276 if (k->op_next == kid)
6278 /* don't descend into loops */
6279 else if (k->op_type == OP_ENTERLOOP
6280 || k->op_type == OP_ENTERITER)
6282 k = cLOOPx(k)->op_lastop;
6287 kid->op_next = 0; /* just disconnect the leave */
6288 k = kLISTOP->op_first;
6293 if (o->op_type == OP_SORT) {
6294 /* provide scalar context for comparison function/block */
6300 o->op_flags |= OPf_SPECIAL;
6302 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6305 firstkid = firstkid->op_sibling;
6308 /* provide list context for arguments */
6309 if (o->op_type == OP_SORT)
6316 S_simplify_sort(pTHX_ OP *o)
6318 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6323 if (!(o->op_flags & OPf_STACKED))
6325 GvMULTI_on(gv_fetchpv("a", GV_ADD, SVt_PV));
6326 GvMULTI_on(gv_fetchpv("b", GV_ADD, SVt_PV));
6327 kid = kUNOP->op_first; /* get past null */
6328 if (kid->op_type != OP_SCOPE)
6330 kid = kLISTOP->op_last; /* get past scope */
6331 switch(kid->op_type) {
6339 k = kid; /* remember this node*/
6340 if (kBINOP->op_first->op_type != OP_RV2SV)
6342 kid = kBINOP->op_first; /* get past cmp */
6343 if (kUNOP->op_first->op_type != OP_GV)
6345 kid = kUNOP->op_first; /* get past rv2sv */
6347 if (GvSTASH(gv) != PL_curstash)
6349 gvname = GvNAME(gv);
6350 if (*gvname == 'a' && gvname[1] == '\0')
6352 else if (*gvname == 'b' && gvname[1] == '\0')
6357 kid = k; /* back to cmp */
6358 if (kBINOP->op_last->op_type != OP_RV2SV)
6360 kid = kBINOP->op_last; /* down to 2nd arg */
6361 if (kUNOP->op_first->op_type != OP_GV)
6363 kid = kUNOP->op_first; /* get past rv2sv */
6365 if (GvSTASH(gv) != PL_curstash)
6367 gvname = GvNAME(gv);
6369 ? !(*gvname == 'a' && gvname[1] == '\0')
6370 : !(*gvname == 'b' && gvname[1] == '\0'))
6372 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6374 o->op_private |= OPpSORT_DESCEND;
6375 if (k->op_type == OP_NCMP)
6376 o->op_private |= OPpSORT_NUMERIC;
6377 if (k->op_type == OP_I_NCMP)
6378 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6379 kid = cLISTOPo->op_first->op_sibling;
6380 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6381 op_free(kid); /* then delete it */
6385 Perl_ck_split(pTHX_ OP *o)
6390 if (o->op_flags & OPf_STACKED)
6391 return no_fh_allowed(o);
6393 kid = cLISTOPo->op_first;
6394 if (kid->op_type != OP_NULL)
6395 Perl_croak(aTHX_ "panic: ck_split");
6396 kid = kid->op_sibling;
6397 op_free(cLISTOPo->op_first);
6398 cLISTOPo->op_first = kid;
6400 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6401 cLISTOPo->op_last = kid; /* There was only one element previously */
6404 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6405 OP * const sibl = kid->op_sibling;
6406 kid->op_sibling = 0;
6407 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
6408 if (cLISTOPo->op_first == cLISTOPo->op_last)
6409 cLISTOPo->op_last = kid;
6410 cLISTOPo->op_first = kid;
6411 kid->op_sibling = sibl;
6414 kid->op_type = OP_PUSHRE;
6415 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6417 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
6418 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
6419 "Use of /g modifier is meaningless in split");
6422 if (!kid->op_sibling)
6423 append_elem(OP_SPLIT, o, newDEFSVOP());
6425 kid = kid->op_sibling;
6428 if (!kid->op_sibling)
6429 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6431 kid = kid->op_sibling;
6434 if (kid->op_sibling)
6435 return too_many_arguments(o,OP_DESC(o));
6441 Perl_ck_join(pTHX_ OP *o)
6443 const OP * const kid = cLISTOPo->op_first->op_sibling;
6444 if (kid && kid->op_type == OP_MATCH) {
6445 if (ckWARN(WARN_SYNTAX)) {
6446 const REGEXP *re = PM_GETRE(kPMOP);
6447 const char *pmstr = re ? re->precomp : "STRING";
6448 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6449 "/%s/ should probably be written as \"%s\"",
6457 Perl_ck_subr(pTHX_ OP *o)
6459 OP *prev = ((cUNOPo->op_first->op_sibling)
6460 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6461 OP *o2 = prev->op_sibling;
6468 I32 contextclass = 0;
6472 o->op_private |= OPpENTERSUB_HASTARG;
6473 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6474 if (cvop->op_type == OP_RV2CV) {
6476 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6477 op_null(cvop); /* disable rv2cv */
6478 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6479 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6480 GV *gv = cGVOPx_gv(tmpop);
6483 tmpop->op_private |= OPpEARLY_CV;
6486 namegv = CvANON(cv) ? gv : CvGV(cv);
6487 proto = SvPV_nolen((SV*)cv);
6489 if (CvASSERTION(cv)) {
6490 if (PL_hints & HINT_ASSERTING) {
6491 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
6492 o->op_private |= OPpENTERSUB_DB;
6496 if (!(PL_hints & HINT_ASSERTIONSSEEN) && ckWARN(WARN_ASSERTIONS)) {
6497 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
6498 "Impossible to activate assertion call");
6505 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6506 if (o2->op_type == OP_CONST)
6507 o2->op_private &= ~OPpCONST_STRICT;
6508 else if (o2->op_type == OP_LIST) {
6509 OP * const o = ((UNOP*)o2)->op_first->op_sibling;
6510 if (o && o->op_type == OP_CONST)
6511 o->op_private &= ~OPpCONST_STRICT;
6514 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6515 if (PERLDB_SUB && PL_curstash != PL_debstash)
6516 o->op_private |= OPpENTERSUB_DB;
6517 while (o2 != cvop) {
6521 return too_many_arguments(o, gv_ename(namegv));
6539 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6541 arg == 1 ? "block or sub {}" : "sub {}",
6542 gv_ename(namegv), o2);
6545 /* '*' allows any scalar type, including bareword */
6548 if (o2->op_type == OP_RV2GV)
6549 goto wrapref; /* autoconvert GLOB -> GLOBref */
6550 else if (o2->op_type == OP_CONST)
6551 o2->op_private &= ~OPpCONST_STRICT;
6552 else if (o2->op_type == OP_ENTERSUB) {
6553 /* accidental subroutine, revert to bareword */
6554 OP *gvop = ((UNOP*)o2)->op_first;
6555 if (gvop && gvop->op_type == OP_NULL) {
6556 gvop = ((UNOP*)gvop)->op_first;
6558 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6561 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6562 (gvop = ((UNOP*)gvop)->op_first) &&
6563 gvop->op_type == OP_GV)
6565 GV * const gv = cGVOPx_gv(gvop);
6566 OP * const sibling = o2->op_sibling;
6567 SV * const n = newSVpvn("",0);
6569 gv_fullname4(n, gv, "", FALSE);
6570 o2 = newSVOP(OP_CONST, 0, n);
6571 prev->op_sibling = o2;
6572 o2->op_sibling = sibling;
6588 if (contextclass++ == 0) {
6589 e = strchr(proto, ']');
6590 if (!e || e == proto)
6599 /* XXX We shouldn't be modifying proto, so we can const proto */
6604 while (*--p != '[');
6605 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
6606 gv_ename(namegv), o2);
6612 if (o2->op_type == OP_RV2GV)
6615 bad_type(arg, "symbol", gv_ename(namegv), o2);
6618 if (o2->op_type == OP_ENTERSUB)
6621 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6624 if (o2->op_type == OP_RV2SV ||
6625 o2->op_type == OP_PADSV ||
6626 o2->op_type == OP_HELEM ||
6627 o2->op_type == OP_AELEM ||
6628 o2->op_type == OP_THREADSV)
6631 bad_type(arg, "scalar", gv_ename(namegv), o2);
6634 if (o2->op_type == OP_RV2AV ||
6635 o2->op_type == OP_PADAV)
6638 bad_type(arg, "array", gv_ename(namegv), o2);
6641 if (o2->op_type == OP_RV2HV ||
6642 o2->op_type == OP_PADHV)
6645 bad_type(arg, "hash", gv_ename(namegv), o2);
6650 OP* const sib = kid->op_sibling;
6651 kid->op_sibling = 0;
6652 o2 = newUNOP(OP_REFGEN, 0, kid);
6653 o2->op_sibling = sib;
6654 prev->op_sibling = o2;
6656 if (contextclass && e) {
6671 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
6672 gv_ename(namegv), cv);
6677 mod(o2, OP_ENTERSUB);
6679 o2 = o2->op_sibling;
6681 if (proto && !optional &&
6682 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6683 return too_few_arguments(o, gv_ename(namegv));
6686 o=newSVOP(OP_CONST, 0, newSViv(0));
6692 Perl_ck_svconst(pTHX_ OP *o)
6694 SvREADONLY_on(cSVOPo->op_sv);
6699 Perl_ck_trunc(pTHX_ OP *o)
6701 if (o->op_flags & OPf_KIDS) {
6702 SVOP *kid = (SVOP*)cUNOPo->op_first;
6704 if (kid->op_type == OP_NULL)
6705 kid = (SVOP*)kid->op_sibling;
6706 if (kid && kid->op_type == OP_CONST &&
6707 (kid->op_private & OPpCONST_BARE))
6709 o->op_flags |= OPf_SPECIAL;
6710 kid->op_private &= ~OPpCONST_STRICT;
6717 Perl_ck_unpack(pTHX_ OP *o)
6719 OP *kid = cLISTOPo->op_first;
6720 if (kid->op_sibling) {
6721 kid = kid->op_sibling;
6722 if (!kid->op_sibling)
6723 kid->op_sibling = newDEFSVOP();
6729 Perl_ck_substr(pTHX_ OP *o)
6732 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6733 OP *kid = cLISTOPo->op_first;
6735 if (kid->op_type == OP_NULL)
6736 kid = kid->op_sibling;
6738 kid->op_flags |= OPf_MOD;
6744 /* A peephole optimizer. We visit the ops in the order they're to execute.
6745 * See the comments at the top of this file for more details about when
6746 * peep() is called */
6749 Perl_peep(pTHX_ register OP *o)
6752 register OP* oldop = 0;
6754 if (!o || o->op_opt)
6758 SAVEVPTR(PL_curcop);
6759 for (; o; o = o->op_next) {
6763 switch (o->op_type) {
6767 PL_curcop = ((COP*)o); /* for warnings */
6772 if (cSVOPo->op_private & OPpCONST_STRICT)
6773 no_bareword_allowed(o);
6775 case OP_METHOD_NAMED:
6776 /* Relocate sv to the pad for thread safety.
6777 * Despite being a "constant", the SV is written to,
6778 * for reference counts, sv_upgrade() etc. */
6780 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6781 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6782 /* If op_sv is already a PADTMP then it is being used by
6783 * some pad, so make a copy. */
6784 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6785 SvREADONLY_on(PAD_SVl(ix));
6786 SvREFCNT_dec(cSVOPo->op_sv);
6789 SvREFCNT_dec(PAD_SVl(ix));
6790 SvPADTMP_on(cSVOPo->op_sv);
6791 PAD_SETSV(ix, cSVOPo->op_sv);
6792 /* XXX I don't know how this isn't readonly already. */
6793 SvREADONLY_on(PAD_SVl(ix));
6795 cSVOPo->op_sv = Nullsv;
6803 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6804 if (o->op_next->op_private & OPpTARGET_MY) {
6805 if (o->op_flags & OPf_STACKED) /* chained concats */
6806 goto ignore_optimization;
6808 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6809 o->op_targ = o->op_next->op_targ;
6810 o->op_next->op_targ = 0;
6811 o->op_private |= OPpTARGET_MY;
6814 op_null(o->op_next);
6816 ignore_optimization:
6820 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6822 break; /* Scalar stub must produce undef. List stub is noop */
6826 if (o->op_targ == OP_NEXTSTATE
6827 || o->op_targ == OP_DBSTATE
6828 || o->op_targ == OP_SETSTATE)
6830 PL_curcop = ((COP*)o);
6832 /* XXX: We avoid setting op_seq here to prevent later calls
6833 to peep() from mistakenly concluding that optimisation
6834 has already occurred. This doesn't fix the real problem,
6835 though (See 20010220.007). AMS 20010719 */
6836 /* op_seq functionality is now replaced by op_opt */
6837 if (oldop && o->op_next) {
6838 oldop->op_next = o->op_next;
6846 if (oldop && o->op_next) {
6847 oldop->op_next = o->op_next;
6855 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
6856 OP* const pop = (o->op_type == OP_PADAV) ?
6857 o->op_next : o->op_next->op_next;
6859 if (pop && pop->op_type == OP_CONST &&
6860 ((PL_op = pop->op_next)) &&
6861 pop->op_next->op_type == OP_AELEM &&
6862 !(pop->op_next->op_private &
6863 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6864 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6869 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
6870 no_bareword_allowed(pop);
6871 if (o->op_type == OP_GV)
6872 op_null(o->op_next);
6873 op_null(pop->op_next);
6875 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6876 o->op_next = pop->op_next->op_next;
6877 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6878 o->op_private = (U8)i;
6879 if (o->op_type == OP_GV) {
6884 o->op_flags |= OPf_SPECIAL;
6885 o->op_type = OP_AELEMFAST;
6891 if (o->op_next->op_type == OP_RV2SV) {
6892 if (!(o->op_next->op_private & OPpDEREF)) {
6893 op_null(o->op_next);
6894 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6896 o->op_next = o->op_next->op_next;
6897 o->op_type = OP_GVSV;
6898 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6901 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6902 GV * const gv = cGVOPo_gv;
6903 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
6904 /* XXX could check prototype here instead of just carping */
6905 SV * const sv = sv_newmortal();
6906 gv_efullname3(sv, gv, Nullch);
6907 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
6908 "%"SVf"() called too early to check prototype",
6912 else if (o->op_next->op_type == OP_READLINE
6913 && o->op_next->op_next->op_type == OP_CONCAT
6914 && (o->op_next->op_next->op_flags & OPf_STACKED))
6916 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6917 o->op_type = OP_RCATLINE;
6918 o->op_flags |= OPf_STACKED;
6919 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
6920 op_null(o->op_next->op_next);
6921 op_null(o->op_next);
6938 while (cLOGOP->op_other->op_type == OP_NULL)
6939 cLOGOP->op_other = cLOGOP->op_other->op_next;
6940 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
6946 while (cLOOP->op_redoop->op_type == OP_NULL)
6947 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6948 peep(cLOOP->op_redoop);
6949 while (cLOOP->op_nextop->op_type == OP_NULL)
6950 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6951 peep(cLOOP->op_nextop);
6952 while (cLOOP->op_lastop->op_type == OP_NULL)
6953 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6954 peep(cLOOP->op_lastop);
6961 while (cPMOP->op_pmreplstart &&
6962 cPMOP->op_pmreplstart->op_type == OP_NULL)
6963 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6964 peep(cPMOP->op_pmreplstart);
6969 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
6970 && ckWARN(WARN_SYNTAX))
6972 if (o->op_next->op_sibling &&
6973 o->op_next->op_sibling->op_type != OP_EXIT &&
6974 o->op_next->op_sibling->op_type != OP_WARN &&
6975 o->op_next->op_sibling->op_type != OP_DIE) {
6976 const line_t oldline = CopLINE(PL_curcop);
6978 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6979 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6980 "Statement unlikely to be reached");
6981 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6982 "\t(Maybe you meant system() when you said exec()?)\n");
6983 CopLINE_set(PL_curcop, oldline);
6993 const char *key = NULL;
6998 if (((BINOP*)o)->op_last->op_type != OP_CONST)
7001 /* Make the CONST have a shared SV */
7002 svp = cSVOPx_svp(((BINOP*)o)->op_last);
7003 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
7004 key = SvPV_const(sv, keylen);
7005 lexname = newSVpvn_share(key,
7006 SvUTF8(sv) ? -(I32)keylen : keylen,
7012 if ((o->op_private & (OPpLVAL_INTRO)))
7015 rop = (UNOP*)((BINOP*)o)->op_first;
7016 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7018 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7019 if (!(SvFLAGS(lexname) & SVpad_TYPED))
7021 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
7022 if (!fields || !GvHV(*fields))
7024 key = SvPV_const(*svp, keylen);
7025 if (!hv_fetch(GvHV(*fields), key,
7026 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
7028 Perl_croak(aTHX_ "No such class field \"%s\" "
7029 "in variable %s of type %s",
7030 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
7043 SVOP *first_key_op, *key_op;
7045 if ((o->op_private & (OPpLVAL_INTRO))
7046 /* I bet there's always a pushmark... */
7047 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
7048 /* hmmm, no optimization if list contains only one key. */
7050 rop = (UNOP*)((LISTOP*)o)->op_last;
7051 if (rop->op_type != OP_RV2HV)
7053 if (rop->op_first->op_type == OP_PADSV)
7054 /* @$hash{qw(keys here)} */
7055 rop = (UNOP*)rop->op_first;
7057 /* @{$hash}{qw(keys here)} */
7058 if (rop->op_first->op_type == OP_SCOPE
7059 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
7061 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
7067 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
7068 if (!(SvFLAGS(lexname) & SVpad_TYPED))
7070 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
7071 if (!fields || !GvHV(*fields))
7073 /* Again guessing that the pushmark can be jumped over.... */
7074 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
7075 ->op_first->op_sibling;
7076 for (key_op = first_key_op; key_op;
7077 key_op = (SVOP*)key_op->op_sibling) {
7078 if (key_op->op_type != OP_CONST)
7080 svp = cSVOPx_svp(key_op);
7081 key = SvPV_const(*svp, keylen);
7082 if (!hv_fetch(GvHV(*fields), key,
7083 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
7085 Perl_croak(aTHX_ "No such class field \"%s\" "
7086 "in variable %s of type %s",
7087 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
7094 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
7098 /* check that RHS of sort is a single plain array */
7099 OP *oright = cUNOPo->op_first;
7100 if (!oright || oright->op_type != OP_PUSHMARK)
7103 /* reverse sort ... can be optimised. */
7104 if (!cUNOPo->op_sibling) {
7105 /* Nothing follows us on the list. */
7106 OP * const reverse = o->op_next;
7108 if (reverse->op_type == OP_REVERSE &&
7109 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
7110 OP * const pushmark = cUNOPx(reverse)->op_first;
7111 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
7112 && (cUNOPx(pushmark)->op_sibling == o)) {
7113 /* reverse -> pushmark -> sort */
7114 o->op_private |= OPpSORT_REVERSE;
7116 pushmark->op_next = oright->op_next;
7122 /* make @a = sort @a act in-place */
7126 oright = cUNOPx(oright)->op_sibling;
7129 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
7130 oright = cUNOPx(oright)->op_sibling;
7134 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
7135 || oright->op_next != o
7136 || (oright->op_private & OPpLVAL_INTRO)
7140 /* o2 follows the chain of op_nexts through the LHS of the
7141 * assign (if any) to the aassign op itself */
7143 if (!o2 || o2->op_type != OP_NULL)
7146 if (!o2 || o2->op_type != OP_PUSHMARK)
7149 if (o2 && o2->op_type == OP_GV)
7152 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
7153 || (o2->op_private & OPpLVAL_INTRO)
7158 if (!o2 || o2->op_type != OP_NULL)
7161 if (!o2 || o2->op_type != OP_AASSIGN
7162 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
7165 /* check that the sort is the first arg on RHS of assign */
7167 o2 = cUNOPx(o2)->op_first;
7168 if (!o2 || o2->op_type != OP_NULL)
7170 o2 = cUNOPx(o2)->op_first;
7171 if (!o2 || o2->op_type != OP_PUSHMARK)
7173 if (o2->op_sibling != o)
7176 /* check the array is the same on both sides */
7177 if (oleft->op_type == OP_RV2AV) {
7178 if (oright->op_type != OP_RV2AV
7179 || !cUNOPx(oright)->op_first
7180 || cUNOPx(oright)->op_first->op_type != OP_GV
7181 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
7182 cGVOPx_gv(cUNOPx(oright)->op_first)
7186 else if (oright->op_type != OP_PADAV
7187 || oright->op_targ != oleft->op_targ
7191 /* transfer MODishness etc from LHS arg to RHS arg */
7192 oright->op_flags = oleft->op_flags;
7193 o->op_private |= OPpSORT_INPLACE;
7195 /* excise push->gv->rv2av->null->aassign */
7196 o2 = o->op_next->op_next;
7197 op_null(o2); /* PUSHMARK */
7199 if (o2->op_type == OP_GV) {
7200 op_null(o2); /* GV */
7203 op_null(o2); /* RV2AV or PADAV */
7204 o2 = o2->op_next->op_next;
7205 op_null(o2); /* AASSIGN */
7207 o->op_next = o2->op_next;
7213 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
7215 LISTOP *enter, *exlist;
7218 enter = (LISTOP *) o->op_next;
7221 if (enter->op_type == OP_NULL) {
7222 enter = (LISTOP *) enter->op_next;
7226 /* for $a (...) will have OP_GV then OP_RV2GV here.
7227 for (...) just has an OP_GV. */
7228 if (enter->op_type == OP_GV) {
7229 gvop = (OP *) enter;
7230 enter = (LISTOP *) enter->op_next;
7233 if (enter->op_type == OP_RV2GV) {
7234 enter = (LISTOP *) enter->op_next;
7240 if (enter->op_type != OP_ENTERITER)
7243 iter = enter->op_next;
7244 if (!iter || iter->op_type != OP_ITER)
7247 expushmark = enter->op_first;
7248 if (!expushmark || expushmark->op_type != OP_NULL
7249 || expushmark->op_targ != OP_PUSHMARK)
7252 exlist = (LISTOP *) expushmark->op_sibling;
7253 if (!exlist || exlist->op_type != OP_NULL
7254 || exlist->op_targ != OP_LIST)
7257 if (exlist->op_last != o) {
7258 /* Mmm. Was expecting to point back to this op. */
7261 theirmark = exlist->op_first;
7262 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
7265 if (theirmark->op_sibling != o) {
7266 /* There's something between the mark and the reverse, eg
7267 for (1, reverse (...))
7272 ourmark = ((LISTOP *)o)->op_first;
7273 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
7276 ourlast = ((LISTOP *)o)->op_last;
7277 if (!ourlast || ourlast->op_next != o)
7280 rv2av = ourmark->op_sibling;
7281 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
7282 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
7283 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
7284 /* We're just reversing a single array. */
7285 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
7286 enter->op_flags |= OPf_STACKED;
7289 /* We don't have control over who points to theirmark, so sacrifice
7291 theirmark->op_next = ourmark->op_next;
7292 theirmark->op_flags = ourmark->op_flags;
7293 ourlast->op_next = gvop ? gvop : (OP *) enter;
7296 enter->op_private |= OPpITER_REVERSED;
7297 iter->op_private |= OPpITER_REVERSED;
7312 Perl_custom_op_name(pTHX_ const OP* o)
7314 const IV index = PTR2IV(o->op_ppaddr);
7318 if (!PL_custom_op_names) /* This probably shouldn't happen */
7319 return (char *)PL_op_name[OP_CUSTOM];
7321 keysv = sv_2mortal(newSViv(index));
7323 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
7325 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
7327 return SvPV_nolen(HeVAL(he));
7331 Perl_custom_op_desc(pTHX_ const OP* o)
7333 const IV index = PTR2IV(o->op_ppaddr);
7337 if (!PL_custom_op_descs)
7338 return (char *)PL_op_desc[OP_CUSTOM];
7340 keysv = sv_2mortal(newSViv(index));
7342 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
7344 return (char *)PL_op_desc[OP_CUSTOM];
7346 return SvPV_nolen(HeVAL(he));
7351 /* Efficient sub that returns a constant scalar value. */
7353 const_sv_xsub(pTHX_ CV* cv)
7358 Perl_croak(aTHX_ "usage: %s::%s()",
7359 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7363 ST(0) = (SV*)XSANY.any_ptr;
7369 * c-indentation-style: bsd
7371 * indent-tabs-mode: t
7374 * ex: set ts=8 sts=4 sw=4 noet: