3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * "You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
13 * our Mr. Bilbo's first cousin on the mother's side (her mother being the
14 * youngest of the Old Took's daughters); and Mr. Drogo was his second
15 * cousin. So Mr. Frodo is his first *and* second cousin, once removed
16 * either way, as the saying is, if you follow me." --the Gaffer
19 /* This file contains the functions that create, manipulate and optimize
20 * the OP structures that hold a compiled perl program.
22 * A Perl program is compiled into a tree of OPs. Each op contains
23 * structural pointers (eg to its siblings and the next op in the
24 * execution sequence), a pointer to the function that would execute the
25 * op, plus any data specific to that op. For example, an OP_CONST op
26 * points to the pp_const() function and to an SV containing the constant
27 * value. When pp_const() is executed, its job is to push that SV onto the
30 * OPs are mainly created by the newFOO() functions, which are mainly
31 * called from the parser (in perly.y) as the code is parsed. For example
32 * the Perl code $a + $b * $c would cause the equivalent of the following
33 * to be called (oversimplifying a bit):
35 * newBINOP(OP_ADD, flags,
37 * newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
40 * Note that during the build of miniperl, a temporary copy of this file
41 * is made, called opmini.c.
45 Perl's compiler is essentially a 3-pass compiler with interleaved phases:
49 An execution-order pass
51 The bottom-up pass is represented by all the "newOP" routines and
52 the ck_ routines. The bottom-upness is actually driven by yacc.
53 So at the point that a ck_ routine fires, we have no idea what the
54 context is, either upward in the syntax tree, or either forward or
55 backward in the execution order. (The bottom-up parser builds that
56 part of the execution order it knows about, but if you follow the "next"
57 links around, you'll find it's actually a closed loop through the
60 Whenever the bottom-up parser gets to a node that supplies context to
61 its components, it invokes that portion of the top-down pass that applies
62 to that part of the subtree (and marks the top node as processed, so
63 if a node further up supplies context, it doesn't have to take the
64 plunge again). As a particular subcase of this, as the new node is
65 built, it takes all the closed execution loops of its subcomponents
66 and links them into a new closed loop for the higher level node. But
67 it's still not the real execution order.
69 The actual execution order is not known till we get a grammar reduction
70 to a top-level unit like a subroutine or file that will be called by
71 "name" rather than via a "next" pointer. At that point, we can call
72 into peep() to do that code's portion of the 3rd pass. It has to be
73 recursive, but it's recursive on basic blocks, not on tree nodes.
81 #define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
83 #if defined(PL_OP_SLAB_ALLOC)
85 #ifndef PERL_SLAB_SIZE
86 #define PERL_SLAB_SIZE 2048
90 Perl_Slab_Alloc(pTHX_ int m, size_t sz)
93 * To make incrementing use count easy PL_OpSlab is an I32 *
94 * To make inserting the link to slab PL_OpPtr is I32 **
95 * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
96 * Add an overhead for pointer to slab and round up as a number of pointers
98 sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
99 if ((PL_OpSpace -= sz) < 0) {
100 PL_OpPtr = (I32 **) PerlMemShared_malloc(PERL_SLAB_SIZE*sizeof(I32*));
104 Zero(PL_OpPtr,PERL_SLAB_SIZE,I32 **);
105 /* We reserve the 0'th I32 sized chunk as a use count */
106 PL_OpSlab = (I32 *) PL_OpPtr;
107 /* Reduce size by the use count word, and by the size we need.
108 * Latter is to mimic the '-=' in the if() above
110 PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
111 /* Allocation pointer starts at the top.
112 Theory: because we build leaves before trunk allocating at end
113 means that at run time access is cache friendly upward
115 PL_OpPtr += PERL_SLAB_SIZE;
117 assert( PL_OpSpace >= 0 );
118 /* Move the allocation pointer down */
120 assert( PL_OpPtr > (I32 **) PL_OpSlab );
121 *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */
122 (*PL_OpSlab)++; /* Increment use count of slab */
123 assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
124 assert( *PL_OpSlab > 0 );
125 return (void *)(PL_OpPtr + 1);
129 Perl_Slab_Free(pTHX_ void *op)
131 I32 * const * const ptr = (I32 **) op;
132 I32 * const slab = ptr[-1];
133 assert( ptr-1 > (I32 **) slab );
134 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
136 if (--(*slab) == 0) {
138 # define PerlMemShared PerlMem
141 PerlMemShared_free(slab);
142 if (slab == PL_OpSlab) {
149 * In the following definition, the ", Nullop" is just to make the compiler
150 * think the expression is of the right type: croak actually does a Siglongjmp.
152 #define CHECKOP(type,o) \
153 ((PL_op_mask && PL_op_mask[type]) \
154 ? ( op_free((OP*)o), \
155 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
157 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
159 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
162 S_gv_ename(pTHX_ GV *gv)
164 SV* const tmpsv = sv_newmortal();
165 gv_efullname3(tmpsv, gv, Nullch);
166 return SvPV_nolen_const(tmpsv);
170 S_no_fh_allowed(pTHX_ OP *o)
172 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
178 S_too_few_arguments(pTHX_ OP *o, const char *name)
180 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
185 S_too_many_arguments(pTHX_ OP *o, const char *name)
187 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
192 S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid)
194 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
195 (int)n, name, t, OP_DESC(kid)));
199 S_no_bareword_allowed(pTHX_ const OP *o)
201 qerror(Perl_mess(aTHX_
202 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
206 /* "register" allocation */
209 Perl_allocmy(pTHX_ char *name)
213 /* 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 = NULL;
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 /* The default is to set op_private to the number of children,
1054 which for a UNOP such as RV2CV is always 1. And w're using
1055 the bit for a flag in RV2CV, so we need it clear. */
1056 o->op_private &= ~1;
1057 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1058 assert(cUNOPo->op_first->op_type == OP_NULL);
1059 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1062 else if (o->op_private & OPpENTERSUB_NOMOD)
1064 else { /* lvalue subroutine call */
1065 o->op_private |= OPpLVAL_INTRO;
1066 PL_modcount = RETURN_UNLIMITED_NUMBER;
1067 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1068 /* Backward compatibility mode: */
1069 o->op_private |= OPpENTERSUB_INARGS;
1072 else { /* Compile-time error message: */
1073 OP *kid = cUNOPo->op_first;
1077 if (kid->op_type == OP_PUSHMARK)
1079 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1081 "panic: unexpected lvalue entersub "
1082 "args: type/targ %ld:%"UVuf,
1083 (long)kid->op_type, (UV)kid->op_targ);
1084 kid = kLISTOP->op_first;
1086 while (kid->op_sibling)
1087 kid = kid->op_sibling;
1088 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1090 if (kid->op_type == OP_METHOD_NAMED
1091 || kid->op_type == OP_METHOD)
1095 NewOp(1101, newop, 1, UNOP);
1096 newop->op_type = OP_RV2CV;
1097 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1098 newop->op_first = Nullop;
1099 newop->op_next = (OP*)newop;
1100 kid->op_sibling = (OP*)newop;
1101 newop->op_private |= OPpLVAL_INTRO;
1102 newop->op_private &= ~1;
1106 if (kid->op_type != OP_RV2CV)
1108 "panic: unexpected lvalue entersub "
1109 "entry via type/targ %ld:%"UVuf,
1110 (long)kid->op_type, (UV)kid->op_targ);
1111 kid->op_private |= OPpLVAL_INTRO;
1112 break; /* Postpone until runtime */
1116 kid = kUNOP->op_first;
1117 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1118 kid = kUNOP->op_first;
1119 if (kid->op_type == OP_NULL)
1121 "Unexpected constant lvalue entersub "
1122 "entry via type/targ %ld:%"UVuf,
1123 (long)kid->op_type, (UV)kid->op_targ);
1124 if (kid->op_type != OP_GV) {
1125 /* Restore RV2CV to check lvalueness */
1127 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1128 okid->op_next = kid->op_next;
1129 kid->op_next = okid;
1132 okid->op_next = Nullop;
1133 okid->op_type = OP_RV2CV;
1135 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1136 okid->op_private |= OPpLVAL_INTRO;
1137 okid->op_private &= ~1;
1141 cv = GvCV(kGVOP_gv);
1151 /* grep, foreach, subcalls, refgen, m//g */
1152 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN
1153 || type == OP_MATCH)
1155 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1156 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1158 : (o->op_type == OP_ENTERSUB
1159 ? "non-lvalue subroutine call"
1161 type ? PL_op_desc[type] : "local"));
1175 case OP_RIGHT_SHIFT:
1184 if (!(o->op_flags & OPf_STACKED))
1191 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1197 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1198 PL_modcount = RETURN_UNLIMITED_NUMBER;
1199 return o; /* Treat \(@foo) like ordinary list. */
1203 if (scalar_mod_type(o, type))
1205 ref(cUNOPo->op_first, o->op_type);
1209 if (type == OP_LEAVESUBLV)
1210 o->op_private |= OPpMAYBE_LVSUB;
1216 PL_modcount = RETURN_UNLIMITED_NUMBER;
1219 ref(cUNOPo->op_first, o->op_type);
1224 PL_hints |= HINT_BLOCK_SCOPE;
1239 PL_modcount = RETURN_UNLIMITED_NUMBER;
1240 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1241 return o; /* Treat \(@foo) like ordinary list. */
1242 if (scalar_mod_type(o, type))
1244 if (type == OP_LEAVESUBLV)
1245 o->op_private |= OPpMAYBE_LVSUB;
1249 if (!type) /* local() */
1250 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1251 PAD_COMPNAME_PV(o->op_targ));
1259 if (type != OP_SASSIGN)
1263 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1268 if (type == OP_LEAVESUBLV)
1269 o->op_private |= OPpMAYBE_LVSUB;
1271 pad_free(o->op_targ);
1272 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1273 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1274 if (o->op_flags & OPf_KIDS)
1275 mod(cBINOPo->op_first->op_sibling, type);
1280 ref(cBINOPo->op_first, o->op_type);
1281 if (type == OP_ENTERSUB &&
1282 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1283 o->op_private |= OPpLVAL_DEFER;
1284 if (type == OP_LEAVESUBLV)
1285 o->op_private |= OPpMAYBE_LVSUB;
1295 if (o->op_flags & OPf_KIDS)
1296 mod(cLISTOPo->op_last, type);
1301 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1303 else if (!(o->op_flags & OPf_KIDS))
1305 if (o->op_targ != OP_LIST) {
1306 mod(cBINOPo->op_first, type);
1312 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1317 if (type != OP_LEAVESUBLV)
1319 break; /* mod()ing was handled by ck_return() */
1322 /* [20011101.069] File test operators interpret OPf_REF to mean that
1323 their argument is a filehandle; thus \stat(".") should not set
1325 if (type == OP_REFGEN &&
1326 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1329 if (type != OP_LEAVESUBLV)
1330 o->op_flags |= OPf_MOD;
1332 if (type == OP_AASSIGN || type == OP_SASSIGN)
1333 o->op_flags |= OPf_SPECIAL|OPf_REF;
1334 else if (!type) { /* local() */
1337 o->op_private |= OPpLVAL_INTRO;
1338 o->op_flags &= ~OPf_SPECIAL;
1339 PL_hints |= HINT_BLOCK_SCOPE;
1344 if (ckWARN(WARN_SYNTAX)) {
1345 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1346 "Useless localization of %s", OP_DESC(o));
1350 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1351 && type != OP_LEAVESUBLV)
1352 o->op_flags |= OPf_REF;
1357 S_scalar_mod_type(pTHX_ const OP *o, I32 type)
1361 if (o->op_type == OP_RV2GV)
1385 case OP_RIGHT_SHIFT:
1404 S_is_handle_constructor(pTHX_ const OP *o, I32 numargs)
1406 switch (o->op_type) {
1414 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1427 Perl_refkids(pTHX_ OP *o, I32 type)
1429 if (o && o->op_flags & OPf_KIDS) {
1431 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1438 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
1443 if (!o || PL_error_count)
1446 switch (o->op_type) {
1448 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1449 !(o->op_flags & OPf_STACKED)) {
1450 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1451 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1452 assert(cUNOPo->op_first->op_type == OP_NULL);
1453 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1454 o->op_flags |= OPf_SPECIAL;
1455 o->op_private &= ~1;
1460 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1461 doref(kid, type, set_op_ref);
1464 if (type == OP_DEFINED)
1465 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1466 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1469 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1470 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1471 : type == OP_RV2HV ? OPpDEREF_HV
1473 o->op_flags |= OPf_MOD;
1478 o->op_flags |= OPf_MOD; /* XXX ??? */
1484 o->op_flags |= OPf_REF;
1487 if (type == OP_DEFINED)
1488 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1489 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1495 o->op_flags |= OPf_REF;
1500 if (!(o->op_flags & OPf_KIDS))
1502 doref(cBINOPo->op_first, type, set_op_ref);
1506 doref(cBINOPo->op_first, o->op_type, set_op_ref);
1507 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1508 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1509 : type == OP_RV2HV ? OPpDEREF_HV
1511 o->op_flags |= OPf_MOD;
1521 if (!(o->op_flags & OPf_KIDS))
1523 doref(cLISTOPo->op_last, type, set_op_ref);
1533 S_dup_attrlist(pTHX_ OP *o)
1537 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1538 * where the first kid is OP_PUSHMARK and the remaining ones
1539 * are OP_CONST. We need to push the OP_CONST values.
1541 if (o->op_type == OP_CONST)
1542 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1544 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1546 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1547 if (o->op_type == OP_CONST)
1548 rop = append_elem(OP_LIST, rop,
1549 newSVOP(OP_CONST, o->op_flags,
1550 SvREFCNT_inc(cSVOPo->op_sv)));
1557 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1562 /* fake up C<use attributes $pkg,$rv,@attrs> */
1563 ENTER; /* need to protect against side-effects of 'use' */
1565 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1567 #define ATTRSMODULE "attributes"
1568 #define ATTRSMODULE_PM "attributes.pm"
1571 /* Don't force the C<use> if we don't need it. */
1572 SV * const * const svp = hv_fetch(GvHVn(PL_incgv), ATTRSMODULE_PM,
1573 sizeof(ATTRSMODULE_PM)-1, 0);
1574 if (svp && *svp != &PL_sv_undef)
1575 ; /* already in %INC */
1577 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1578 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1582 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1583 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1585 prepend_elem(OP_LIST,
1586 newSVOP(OP_CONST, 0, stashsv),
1587 prepend_elem(OP_LIST,
1588 newSVOP(OP_CONST, 0,
1590 dup_attrlist(attrs))));
1596 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1598 OP *pack, *imop, *arg;
1604 assert(target->op_type == OP_PADSV ||
1605 target->op_type == OP_PADHV ||
1606 target->op_type == OP_PADAV);
1608 /* Ensure that attributes.pm is loaded. */
1609 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1611 /* Need package name for method call. */
1612 pack = newSVOP(OP_CONST, 0, newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1));
1614 /* Build up the real arg-list. */
1615 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1617 arg = newOP(OP_PADSV, 0);
1618 arg->op_targ = target->op_targ;
1619 arg = prepend_elem(OP_LIST,
1620 newSVOP(OP_CONST, 0, stashsv),
1621 prepend_elem(OP_LIST,
1622 newUNOP(OP_REFGEN, 0,
1623 mod(arg, OP_REFGEN)),
1624 dup_attrlist(attrs)));
1626 /* Fake up a method call to import */
1627 meth = newSVpvs_share("import");
1628 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1629 append_elem(OP_LIST,
1630 prepend_elem(OP_LIST, pack, list(arg)),
1631 newSVOP(OP_METHOD_NAMED, 0, meth)));
1632 imop->op_private |= OPpENTERSUB_NOMOD;
1634 /* Combine the ops. */
1635 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1639 =notfor apidoc apply_attrs_string
1641 Attempts to apply a list of attributes specified by the C<attrstr> and
1642 C<len> arguments to the subroutine identified by the C<cv> argument which
1643 is expected to be associated with the package identified by the C<stashpv>
1644 argument (see L<attributes>). It gets this wrong, though, in that it
1645 does not correctly identify the boundaries of the individual attribute
1646 specifications within C<attrstr>. This is not really intended for the
1647 public API, but has to be listed here for systems such as AIX which
1648 need an explicit export list for symbols. (It's called from XS code
1649 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1650 to respect attribute syntax properly would be welcome.
1656 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
1657 const char *attrstr, STRLEN len)
1662 len = strlen(attrstr);
1666 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1668 const char * const sstr = attrstr;
1669 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1670 attrs = append_elem(OP_LIST, attrs,
1671 newSVOP(OP_CONST, 0,
1672 newSVpvn(sstr, attrstr-sstr)));
1676 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1677 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1678 Nullsv, prepend_elem(OP_LIST,
1679 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1680 prepend_elem(OP_LIST,
1681 newSVOP(OP_CONST, 0,
1687 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
1691 if (!o || PL_error_count)
1695 if (type == OP_LIST) {
1697 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1698 my_kid(kid, attrs, imopsp);
1699 } else if (type == OP_UNDEF) {
1701 } else if (type == OP_RV2SV || /* "our" declaration */
1703 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1704 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1705 yyerror(Perl_form(aTHX_ "Can't declare %s in %s",
1706 OP_DESC(o), PL_in_my == KEY_our ? "our" : "my"));
1708 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
1710 PL_in_my_stash = NULL;
1711 apply_attrs(GvSTASH(gv),
1712 (type == OP_RV2SV ? GvSV(gv) :
1713 type == OP_RV2AV ? (SV*)GvAV(gv) :
1714 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1717 o->op_private |= OPpOUR_INTRO;
1720 else if (type != OP_PADSV &&
1723 type != OP_PUSHMARK)
1725 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1727 PL_in_my == KEY_our ? "our" : "my"));
1730 else if (attrs && type != OP_PUSHMARK) {
1734 PL_in_my_stash = NULL;
1736 /* check for C<my Dog $spot> when deciding package */
1737 stash = PAD_COMPNAME_TYPE(o->op_targ);
1739 stash = PL_curstash;
1740 apply_attrs_my(stash, o, attrs, imopsp);
1742 o->op_flags |= OPf_MOD;
1743 o->op_private |= OPpLVAL_INTRO;
1748 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1751 int maybe_scalar = 0;
1753 /* [perl #17376]: this appears to be premature, and results in code such as
1754 C< our(%x); > executing in list mode rather than void mode */
1756 if (o->op_flags & OPf_PARENS)
1766 o = my_kid(o, attrs, &rops);
1768 if (maybe_scalar && o->op_type == OP_PADSV) {
1769 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
1770 o->op_private |= OPpLVAL_INTRO;
1773 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
1776 PL_in_my_stash = NULL;
1781 Perl_my(pTHX_ OP *o)
1783 return my_attrs(o, Nullop);
1787 Perl_sawparens(pTHX_ OP *o)
1790 o->op_flags |= OPf_PARENS;
1795 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
1800 if ( (left->op_type == OP_RV2AV ||
1801 left->op_type == OP_RV2HV ||
1802 left->op_type == OP_PADAV ||
1803 left->op_type == OP_PADHV)
1804 && ckWARN(WARN_MISC))
1806 const char * const desc = PL_op_desc[(right->op_type == OP_SUBST ||
1807 right->op_type == OP_TRANS)
1808 ? right->op_type : OP_MATCH];
1809 const char * const sample = ((left->op_type == OP_RV2AV ||
1810 left->op_type == OP_PADAV)
1811 ? "@array" : "%hash");
1812 Perl_warner(aTHX_ packWARN(WARN_MISC),
1813 "Applying %s to %s will act on scalar(%s)",
1814 desc, sample, sample);
1817 if (right->op_type == OP_CONST &&
1818 cSVOPx(right)->op_private & OPpCONST_BARE &&
1819 cSVOPx(right)->op_private & OPpCONST_STRICT)
1821 no_bareword_allowed(right);
1824 ismatchop = right->op_type == OP_MATCH ||
1825 right->op_type == OP_SUBST ||
1826 right->op_type == OP_TRANS;
1827 if (ismatchop && right->op_private & OPpTARGET_MY) {
1829 right->op_private &= ~OPpTARGET_MY;
1831 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
1832 right->op_flags |= OPf_STACKED;
1833 /* s/// and tr/// modify their arg.
1834 * m//g also indirectly modifies the arg by setting pos magic on it */
1835 if ( (right->op_type == OP_MATCH &&
1836 (cPMOPx(right)->op_pmflags & PMf_GLOBAL))
1837 || (right->op_type == OP_SUBST)
1838 || (right->op_type == OP_TRANS &&
1839 ! (right->op_private & OPpTRANS_IDENTICAL))
1841 left = mod(left, right->op_type);
1842 if (right->op_type == OP_TRANS)
1843 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
1845 o = prepend_elem(right->op_type, scalar(left), right);
1847 return newUNOP(OP_NOT, 0, scalar(o));
1851 return bind_match(type, left,
1852 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
1856 Perl_invert(pTHX_ OP *o)
1860 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
1861 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
1865 Perl_scope(pTHX_ OP *o)
1869 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
1870 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
1871 o->op_type = OP_LEAVE;
1872 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
1874 else if (o->op_type == OP_LINESEQ) {
1876 o->op_type = OP_SCOPE;
1877 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
1878 kid = ((LISTOP*)o)->op_first;
1879 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
1882 /* The following deals with things like 'do {1 for 1}' */
1883 kid = kid->op_sibling;
1885 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
1890 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
1896 Perl_block_start(pTHX_ int full)
1898 const int retval = PL_savestack_ix;
1899 pad_block_start(full);
1901 PL_hints &= ~HINT_BLOCK_SCOPE;
1902 SAVESPTR(PL_compiling.cop_warnings);
1903 if (! specialWARN(PL_compiling.cop_warnings)) {
1904 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
1905 SAVEFREESV(PL_compiling.cop_warnings) ;
1907 SAVESPTR(PL_compiling.cop_io);
1908 if (! specialCopIO(PL_compiling.cop_io)) {
1909 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
1910 SAVEFREESV(PL_compiling.cop_io) ;
1916 Perl_block_end(pTHX_ I32 floor, OP *seq)
1918 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
1919 OP* const retval = scalarseq(seq);
1921 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
1923 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
1931 const I32 offset = pad_findmy("$_");
1932 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
1933 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
1936 OP * const o = newOP(OP_PADSV, 0);
1937 o->op_targ = offset;
1943 Perl_newPROG(pTHX_ OP *o)
1948 PL_eval_root = newUNOP(OP_LEAVEEVAL,
1949 ((PL_in_eval & EVAL_KEEPERR)
1950 ? OPf_SPECIAL : 0), o);
1951 PL_eval_start = linklist(PL_eval_root);
1952 PL_eval_root->op_private |= OPpREFCOUNTED;
1953 OpREFCNT_set(PL_eval_root, 1);
1954 PL_eval_root->op_next = 0;
1955 CALL_PEEP(PL_eval_start);
1958 if (o->op_type == OP_STUB) {
1959 PL_comppad_name = 0;
1964 PL_main_root = scope(sawparens(scalarvoid(o)));
1965 PL_curcop = &PL_compiling;
1966 PL_main_start = LINKLIST(PL_main_root);
1967 PL_main_root->op_private |= OPpREFCOUNTED;
1968 OpREFCNT_set(PL_main_root, 1);
1969 PL_main_root->op_next = 0;
1970 CALL_PEEP(PL_main_start);
1973 /* Register with debugger */
1975 CV * const cv = get_cv("DB::postponed", FALSE);
1979 XPUSHs((SV*)CopFILEGV(&PL_compiling));
1981 call_sv((SV*)cv, G_DISCARD);
1988 Perl_localize(pTHX_ OP *o, I32 lex)
1990 if (o->op_flags & OPf_PARENS)
1991 /* [perl #17376]: this appears to be premature, and results in code such as
1992 C< our(%x); > executing in list mode rather than void mode */
1999 if ( PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ','
2000 && ckWARN(WARN_PARENTHESIS))
2002 char *s = PL_bufptr;
2005 /* some heuristics to detect a potential error */
2006 while (*s && (strchr(", \t\n", *s)))
2010 if (*s && strchr("@$%*", *s) && *++s
2011 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2014 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2016 while (*s && (strchr(", \t\n", *s)))
2022 if (sigil && (*s == ';' || *s == '=')) {
2023 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2024 "Parentheses missing around \"%s\" list",
2025 lex ? (PL_in_my == KEY_our ? "our" : "my")
2033 o = mod(o, OP_NULL); /* a bit kludgey */
2035 PL_in_my_stash = NULL;
2040 Perl_jmaybe(pTHX_ OP *o)
2042 if (o->op_type == OP_LIST) {
2044 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", GV_ADD, SVt_PV))),
2045 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2051 Perl_fold_constants(pTHX_ register OP *o)
2055 I32 type = o->op_type;
2058 if (PL_opargs[type] & OA_RETSCALAR)
2060 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2061 o->op_targ = pad_alloc(type, SVs_PADTMP);
2063 /* integerize op, unless it happens to be C<-foo>.
2064 * XXX should pp_i_negate() do magic string negation instead? */
2065 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2066 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2067 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2069 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2072 if (!(PL_opargs[type] & OA_FOLDCONST))
2077 /* XXX might want a ck_negate() for this */
2078 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2089 /* XXX what about the numeric ops? */
2090 if (PL_hints & HINT_LOCALE)
2095 goto nope; /* Don't try to run w/ errors */
2097 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2098 if ((curop->op_type != OP_CONST ||
2099 (curop->op_private & OPpCONST_BARE)) &&
2100 curop->op_type != OP_LIST &&
2101 curop->op_type != OP_SCALAR &&
2102 curop->op_type != OP_NULL &&
2103 curop->op_type != OP_PUSHMARK)
2109 curop = LINKLIST(o);
2113 sv = *(PL_stack_sp--);
2114 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2115 pad_swipe(o->op_targ, FALSE);
2116 else if (SvTEMP(sv)) { /* grab mortal temp? */
2117 (void)SvREFCNT_inc(sv);
2121 if (type == OP_RV2GV)
2122 return newGVOP(OP_GV, 0, (GV*)sv);
2123 return newSVOP(OP_CONST, 0, sv);
2130 Perl_gen_constant_list(pTHX_ register OP *o)
2134 const I32 oldtmps_floor = PL_tmps_floor;
2138 return o; /* Don't attempt to run with errors */
2140 PL_op = curop = LINKLIST(o);
2147 PL_tmps_floor = oldtmps_floor;
2149 o->op_type = OP_RV2AV;
2150 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2151 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2152 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2153 o->op_opt = 0; /* needs to be revisited in peep() */
2154 curop = ((UNOP*)o)->op_first;
2155 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2162 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2165 if (!o || o->op_type != OP_LIST)
2166 o = newLISTOP(OP_LIST, 0, o, Nullop);
2168 o->op_flags &= ~OPf_WANT;
2170 if (!(PL_opargs[type] & OA_MARK))
2171 op_null(cLISTOPo->op_first);
2173 o->op_type = (OPCODE)type;
2174 o->op_ppaddr = PL_ppaddr[type];
2175 o->op_flags |= flags;
2177 o = CHECKOP(type, o);
2178 if (o->op_type != (unsigned)type)
2181 return fold_constants(o);
2184 /* List constructors */
2187 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2195 if (first->op_type != (unsigned)type
2196 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2198 return newLISTOP(type, 0, first, last);
2201 if (first->op_flags & OPf_KIDS)
2202 ((LISTOP*)first)->op_last->op_sibling = last;
2204 first->op_flags |= OPf_KIDS;
2205 ((LISTOP*)first)->op_first = last;
2207 ((LISTOP*)first)->op_last = last;
2212 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2220 if (first->op_type != (unsigned)type)
2221 return prepend_elem(type, (OP*)first, (OP*)last);
2223 if (last->op_type != (unsigned)type)
2224 return append_elem(type, (OP*)first, (OP*)last);
2226 first->op_last->op_sibling = last->op_first;
2227 first->op_last = last->op_last;
2228 first->op_flags |= (last->op_flags & OPf_KIDS);
2236 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2244 if (last->op_type == (unsigned)type) {
2245 if (type == OP_LIST) { /* already a PUSHMARK there */
2246 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2247 ((LISTOP*)last)->op_first->op_sibling = first;
2248 if (!(first->op_flags & OPf_PARENS))
2249 last->op_flags &= ~OPf_PARENS;
2252 if (!(last->op_flags & OPf_KIDS)) {
2253 ((LISTOP*)last)->op_last = first;
2254 last->op_flags |= OPf_KIDS;
2256 first->op_sibling = ((LISTOP*)last)->op_first;
2257 ((LISTOP*)last)->op_first = first;
2259 last->op_flags |= OPf_KIDS;
2263 return newLISTOP(type, 0, first, last);
2269 Perl_newNULLLIST(pTHX)
2271 return newOP(OP_STUB, 0);
2275 Perl_force_list(pTHX_ OP *o)
2277 if (!o || o->op_type != OP_LIST)
2278 o = newLISTOP(OP_LIST, 0, o, Nullop);
2284 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2289 NewOp(1101, listop, 1, LISTOP);
2291 listop->op_type = (OPCODE)type;
2292 listop->op_ppaddr = PL_ppaddr[type];
2295 listop->op_flags = (U8)flags;
2299 else if (!first && last)
2302 first->op_sibling = last;
2303 listop->op_first = first;
2304 listop->op_last = last;
2305 if (type == OP_LIST) {
2306 OP* const pushop = newOP(OP_PUSHMARK, 0);
2307 pushop->op_sibling = first;
2308 listop->op_first = pushop;
2309 listop->op_flags |= OPf_KIDS;
2311 listop->op_last = pushop;
2314 return CHECKOP(type, listop);
2318 Perl_newOP(pTHX_ I32 type, I32 flags)
2322 NewOp(1101, o, 1, OP);
2323 o->op_type = (OPCODE)type;
2324 o->op_ppaddr = PL_ppaddr[type];
2325 o->op_flags = (U8)flags;
2328 o->op_private = (U8)(0 | (flags >> 8));
2329 if (PL_opargs[type] & OA_RETSCALAR)
2331 if (PL_opargs[type] & OA_TARGET)
2332 o->op_targ = pad_alloc(type, SVs_PADTMP);
2333 return CHECKOP(type, o);
2337 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2343 first = newOP(OP_STUB, 0);
2344 if (PL_opargs[type] & OA_MARK)
2345 first = force_list(first);
2347 NewOp(1101, unop, 1, UNOP);
2348 unop->op_type = (OPCODE)type;
2349 unop->op_ppaddr = PL_ppaddr[type];
2350 unop->op_first = first;
2351 unop->op_flags = (U8)(flags | OPf_KIDS);
2352 unop->op_private = (U8)(1 | (flags >> 8));
2353 unop = (UNOP*) CHECKOP(type, unop);
2357 return fold_constants((OP *) unop);
2361 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2365 NewOp(1101, binop, 1, BINOP);
2368 first = newOP(OP_NULL, 0);
2370 binop->op_type = (OPCODE)type;
2371 binop->op_ppaddr = PL_ppaddr[type];
2372 binop->op_first = first;
2373 binop->op_flags = (U8)(flags | OPf_KIDS);
2376 binop->op_private = (U8)(1 | (flags >> 8));
2379 binop->op_private = (U8)(2 | (flags >> 8));
2380 first->op_sibling = last;
2383 binop = (BINOP*)CHECKOP(type, binop);
2384 if (binop->op_next || binop->op_type != (OPCODE)type)
2387 binop->op_last = binop->op_first->op_sibling;
2389 return fold_constants((OP *)binop);
2392 static int uvcompare(const void *a, const void *b) __attribute__nonnull__(1) __attribute__nonnull__(2) __attribute__pure__;
2393 static int uvcompare(const void *a, const void *b)
2395 if (*((const UV *)a) < (*(const UV *)b))
2397 if (*((const UV *)a) > (*(const UV *)b))
2399 if (*((const UV *)a+1) < (*(const UV *)b+1))
2401 if (*((const UV *)a+1) > (*(const UV *)b+1))
2407 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2409 SV * const tstr = ((SVOP*)expr)->op_sv;
2410 SV * const rstr = ((SVOP*)repl)->op_sv;
2413 const U8 *t = (U8*)SvPV_const(tstr, tlen);
2414 const U8 *r = (U8*)SvPV_const(rstr, rlen);
2418 register short *tbl;
2420 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
2421 const I32 squash = o->op_private & OPpTRANS_SQUASH;
2422 I32 del = o->op_private & OPpTRANS_DELETE;
2423 PL_hints |= HINT_BLOCK_SCOPE;
2426 o->op_private |= OPpTRANS_FROM_UTF;
2429 o->op_private |= OPpTRANS_TO_UTF;
2431 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2432 SV* const listsv = newSVpvs("# comment\n");
2434 const U8* tend = t + tlen;
2435 const U8* rend = r + rlen;
2449 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2450 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2456 t = tsave = bytes_to_utf8(t, &len);
2459 if (!to_utf && rlen) {
2461 r = rsave = bytes_to_utf8(r, &len);
2465 /* There are several snags with this code on EBCDIC:
2466 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2467 2. scan_const() in toke.c has encoded chars in native encoding which makes
2468 ranges at least in EBCDIC 0..255 range the bottom odd.
2472 U8 tmpbuf[UTF8_MAXBYTES+1];
2475 Newx(cp, 2*tlen, UV);
2477 transv = newSVpvs("");
2479 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2481 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2483 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2487 cp[2*i+1] = cp[2*i];
2491 qsort(cp, i, 2*sizeof(UV), uvcompare);
2492 for (j = 0; j < i; j++) {
2494 diff = val - nextmin;
2496 t = uvuni_to_utf8(tmpbuf,nextmin);
2497 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2499 U8 range_mark = UTF_TO_NATIVE(0xff);
2500 t = uvuni_to_utf8(tmpbuf, val - 1);
2501 sv_catpvn(transv, (char *)&range_mark, 1);
2502 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2509 t = uvuni_to_utf8(tmpbuf,nextmin);
2510 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2512 U8 range_mark = UTF_TO_NATIVE(0xff);
2513 sv_catpvn(transv, (char *)&range_mark, 1);
2515 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2516 UNICODE_ALLOW_SUPER);
2517 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2518 t = (const U8*)SvPVX_const(transv);
2519 tlen = SvCUR(transv);
2523 else if (!rlen && !del) {
2524 r = t; rlen = tlen; rend = tend;
2527 if ((!rlen && !del) || t == r ||
2528 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2530 o->op_private |= OPpTRANS_IDENTICAL;
2534 while (t < tend || tfirst <= tlast) {
2535 /* see if we need more "t" chars */
2536 if (tfirst > tlast) {
2537 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2539 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2541 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2548 /* now see if we need more "r" chars */
2549 if (rfirst > rlast) {
2551 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2553 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2555 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2564 rfirst = rlast = 0xffffffff;
2568 /* now see which range will peter our first, if either. */
2569 tdiff = tlast - tfirst;
2570 rdiff = rlast - rfirst;
2577 if (rfirst == 0xffffffff) {
2578 diff = tdiff; /* oops, pretend rdiff is infinite */
2580 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2581 (long)tfirst, (long)tlast);
2583 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2587 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2588 (long)tfirst, (long)(tfirst + diff),
2591 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2592 (long)tfirst, (long)rfirst);
2594 if (rfirst + diff > max)
2595 max = rfirst + diff;
2597 grows = (tfirst < rfirst &&
2598 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2610 else if (max > 0xff)
2615 Safefree(cPVOPo->op_pv);
2616 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2617 SvREFCNT_dec(listsv);
2619 SvREFCNT_dec(transv);
2621 if (!del && havefinal && rlen)
2622 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2623 newSVuv((UV)final), 0);
2626 o->op_private |= OPpTRANS_GROWS;
2638 tbl = (short*)cPVOPo->op_pv;
2640 Zero(tbl, 256, short);
2641 for (i = 0; i < (I32)tlen; i++)
2643 for (i = 0, j = 0; i < 256; i++) {
2645 if (j >= (I32)rlen) {
2654 if (i < 128 && r[j] >= 128)
2664 o->op_private |= OPpTRANS_IDENTICAL;
2666 else if (j >= (I32)rlen)
2669 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2670 tbl[0x100] = (short)(rlen - j);
2671 for (i=0; i < (I32)rlen - j; i++)
2672 tbl[0x101+i] = r[j+i];
2676 if (!rlen && !del) {
2679 o->op_private |= OPpTRANS_IDENTICAL;
2681 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
2682 o->op_private |= OPpTRANS_IDENTICAL;
2684 for (i = 0; i < 256; i++)
2686 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
2687 if (j >= (I32)rlen) {
2689 if (tbl[t[i]] == -1)
2695 if (tbl[t[i]] == -1) {
2696 if (t[i] < 128 && r[j] >= 128)
2703 o->op_private |= OPpTRANS_GROWS;
2711 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2716 NewOp(1101, pmop, 1, PMOP);
2717 pmop->op_type = (OPCODE)type;
2718 pmop->op_ppaddr = PL_ppaddr[type];
2719 pmop->op_flags = (U8)flags;
2720 pmop->op_private = (U8)(0 | (flags >> 8));
2722 if (PL_hints & HINT_RE_TAINT)
2723 pmop->op_pmpermflags |= PMf_RETAINT;
2724 if (PL_hints & HINT_LOCALE)
2725 pmop->op_pmpermflags |= PMf_LOCALE;
2726 pmop->op_pmflags = pmop->op_pmpermflags;
2729 if (av_len((AV*) PL_regex_pad[0]) > -1) {
2730 SV * const repointer = av_pop((AV*)PL_regex_pad[0]);
2731 pmop->op_pmoffset = SvIV(repointer);
2732 SvREPADTMP_off(repointer);
2733 sv_setiv(repointer,0);
2735 SV * const repointer = newSViv(0);
2736 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
2737 pmop->op_pmoffset = av_len(PL_regex_padav);
2738 PL_regex_pad = AvARRAY(PL_regex_padav);
2742 /* link into pm list */
2743 if (type != OP_TRANS && PL_curstash) {
2744 MAGIC *mg = mg_find((SV*)PL_curstash, PERL_MAGIC_symtab);
2747 mg = sv_magicext((SV*)PL_curstash, 0, PERL_MAGIC_symtab, 0, 0, 0);
2749 pmop->op_pmnext = (PMOP*)mg->mg_obj;
2750 mg->mg_obj = (SV*)pmop;
2751 PmopSTASH_set(pmop,PL_curstash);
2754 return CHECKOP(type, pmop);
2757 /* Given some sort of match op o, and an expression expr containing a
2758 * pattern, either compile expr into a regex and attach it to o (if it's
2759 * constant), or convert expr into a runtime regcomp op sequence (if it's
2762 * isreg indicates that the pattern is part of a regex construct, eg
2763 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
2764 * split "pattern", which aren't. In the former case, expr will be a list
2765 * if the pattern contains more than one term (eg /a$b/) or if it contains
2766 * a replacement, ie s/// or tr///.
2770 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
2775 I32 repl_has_vars = 0;
2779 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
2780 /* last element in list is the replacement; pop it */
2782 repl = cLISTOPx(expr)->op_last;
2783 kid = cLISTOPx(expr)->op_first;
2784 while (kid->op_sibling != repl)
2785 kid = kid->op_sibling;
2786 kid->op_sibling = Nullop;
2787 cLISTOPx(expr)->op_last = kid;
2790 if (isreg && expr->op_type == OP_LIST &&
2791 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
2793 /* convert single element list to element */
2794 OP* const oe = expr;
2795 expr = cLISTOPx(oe)->op_first->op_sibling;
2796 cLISTOPx(oe)->op_first->op_sibling = Nullop;
2797 cLISTOPx(oe)->op_last = Nullop;
2801 if (o->op_type == OP_TRANS) {
2802 return pmtrans(o, expr, repl);
2805 reglist = isreg && expr->op_type == OP_LIST;
2809 PL_hints |= HINT_BLOCK_SCOPE;
2812 if (expr->op_type == OP_CONST) {
2814 SV *pat = ((SVOP*)expr)->op_sv;
2815 const char *p = SvPV_const(pat, plen);
2816 if ((o->op_flags & OPf_SPECIAL) && (*p == ' ' && p[1] == '\0')) {
2817 U32 was_readonly = SvREADONLY(pat);
2821 sv_force_normal_flags(pat, 0);
2822 assert(!SvREADONLY(pat));
2825 SvREADONLY_off(pat);
2829 sv_setpvn(pat, "\\s+", 3);
2831 SvFLAGS(pat) |= was_readonly;
2833 p = SvPV_const(pat, plen);
2834 pm->op_pmflags |= PMf_SKIPWHITE;
2837 pm->op_pmdynflags |= PMdf_UTF8;
2838 /* FIXME - can we make this function take const char * args? */
2839 PM_SETRE(pm, CALLREGCOMP(aTHX_ (char*)p, (char*)p + plen, pm));
2840 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
2841 pm->op_pmflags |= PMf_WHITE;
2845 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
2846 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2848 : OP_REGCMAYBE),0,expr);
2850 NewOp(1101, rcop, 1, LOGOP);
2851 rcop->op_type = OP_REGCOMP;
2852 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
2853 rcop->op_first = scalar(expr);
2854 rcop->op_flags |= OPf_KIDS
2855 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
2856 | (reglist ? OPf_STACKED : 0);
2857 rcop->op_private = 1;
2860 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
2862 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
2865 /* establish postfix order */
2866 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
2868 rcop->op_next = expr;
2869 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
2872 rcop->op_next = LINKLIST(expr);
2873 expr->op_next = (OP*)rcop;
2876 prepend_elem(o->op_type, scalar((OP*)rcop), o);
2881 if (pm->op_pmflags & PMf_EVAL) {
2883 if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
2884 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
2886 else if (repl->op_type == OP_CONST)
2890 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
2891 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
2892 if (curop->op_type == OP_GV) {
2893 GV *gv = cGVOPx_gv(curop);
2895 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
2898 else if (curop->op_type == OP_RV2CV)
2900 else if (curop->op_type == OP_RV2SV ||
2901 curop->op_type == OP_RV2AV ||
2902 curop->op_type == OP_RV2HV ||
2903 curop->op_type == OP_RV2GV) {
2904 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
2907 else if (curop->op_type == OP_PADSV ||
2908 curop->op_type == OP_PADAV ||
2909 curop->op_type == OP_PADHV ||
2910 curop->op_type == OP_PADANY) {
2913 else if (curop->op_type == OP_PUSHRE)
2914 ; /* Okay here, dangerous in newASSIGNOP */
2924 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
2925 pm->op_pmflags |= PMf_CONST; /* const for long enough */
2926 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
2927 prepend_elem(o->op_type, scalar(repl), o);
2930 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
2931 pm->op_pmflags |= PMf_MAYBE_CONST;
2932 pm->op_pmpermflags |= PMf_MAYBE_CONST;
2934 NewOp(1101, rcop, 1, LOGOP);
2935 rcop->op_type = OP_SUBSTCONT;
2936 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
2937 rcop->op_first = scalar(repl);
2938 rcop->op_flags |= OPf_KIDS;
2939 rcop->op_private = 1;
2942 /* establish postfix order */
2943 rcop->op_next = LINKLIST(repl);
2944 repl->op_next = (OP*)rcop;
2946 pm->op_pmreplroot = scalar((OP*)rcop);
2947 pm->op_pmreplstart = LINKLIST(rcop);
2956 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
2960 NewOp(1101, svop, 1, SVOP);
2961 svop->op_type = (OPCODE)type;
2962 svop->op_ppaddr = PL_ppaddr[type];
2964 svop->op_next = (OP*)svop;
2965 svop->op_flags = (U8)flags;
2966 if (PL_opargs[type] & OA_RETSCALAR)
2968 if (PL_opargs[type] & OA_TARGET)
2969 svop->op_targ = pad_alloc(type, SVs_PADTMP);
2970 return CHECKOP(type, svop);
2974 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
2978 NewOp(1101, padop, 1, PADOP);
2979 padop->op_type = (OPCODE)type;
2980 padop->op_ppaddr = PL_ppaddr[type];
2981 padop->op_padix = pad_alloc(type, SVs_PADTMP);
2982 SvREFCNT_dec(PAD_SVl(padop->op_padix));
2983 PAD_SETSV(padop->op_padix, sv);
2986 padop->op_next = (OP*)padop;
2987 padop->op_flags = (U8)flags;
2988 if (PL_opargs[type] & OA_RETSCALAR)
2990 if (PL_opargs[type] & OA_TARGET)
2991 padop->op_targ = pad_alloc(type, SVs_PADTMP);
2992 return CHECKOP(type, padop);
2996 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3002 return newPADOP(type, flags, SvREFCNT_inc(gv));
3004 return newSVOP(type, flags, SvREFCNT_inc(gv));
3009 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3013 NewOp(1101, pvop, 1, PVOP);
3014 pvop->op_type = (OPCODE)type;
3015 pvop->op_ppaddr = PL_ppaddr[type];
3017 pvop->op_next = (OP*)pvop;
3018 pvop->op_flags = (U8)flags;
3019 if (PL_opargs[type] & OA_RETSCALAR)
3021 if (PL_opargs[type] & OA_TARGET)
3022 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3023 return CHECKOP(type, pvop);
3027 Perl_package(pTHX_ OP *o)
3032 save_hptr(&PL_curstash);
3033 save_item(PL_curstname);
3035 name = SvPV_const(cSVOPo->op_sv, len);
3036 PL_curstash = gv_stashpvn(name, len, TRUE);
3037 sv_setpvn(PL_curstname, name, len);
3040 PL_hints |= HINT_BLOCK_SCOPE;
3041 PL_copline = NOLINE;
3046 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3052 if (idop->op_type != OP_CONST)
3053 Perl_croak(aTHX_ "Module name must be constant");
3058 SV * const vesv = ((SVOP*)version)->op_sv;
3060 if (!arg && !SvNIOKp(vesv)) {
3067 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3068 Perl_croak(aTHX_ "Version number must be constant number");
3070 /* Make copy of idop so we don't free it twice */
3071 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3073 /* Fake up a method call to VERSION */
3074 meth = newSVpvs_share("VERSION");
3075 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3076 append_elem(OP_LIST,
3077 prepend_elem(OP_LIST, pack, list(version)),
3078 newSVOP(OP_METHOD_NAMED, 0, meth)));
3082 /* Fake up an import/unimport */
3083 if (arg && arg->op_type == OP_STUB)
3084 imop = arg; /* no import on explicit () */
3085 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3086 imop = Nullop; /* use 5.0; */
3088 idop->op_private |= OPpCONST_NOVER;
3093 /* Make copy of idop so we don't free it twice */
3094 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3096 /* Fake up a method call to import/unimport */
3098 ? newSVpvs_share("import") : newSVpvs_share("unimport");
3099 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3100 append_elem(OP_LIST,
3101 prepend_elem(OP_LIST, pack, list(arg)),
3102 newSVOP(OP_METHOD_NAMED, 0, meth)));
3105 /* Fake up the BEGIN {}, which does its thing immediately. */
3107 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
3110 append_elem(OP_LINESEQ,
3111 append_elem(OP_LINESEQ,
3112 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, idop)),
3113 newSTATEOP(0, Nullch, veop)),
3114 newSTATEOP(0, Nullch, imop) ));
3116 /* The "did you use incorrect case?" warning used to be here.
3117 * The problem is that on case-insensitive filesystems one
3118 * might get false positives for "use" (and "require"):
3119 * "use Strict" or "require CARP" will work. This causes
3120 * portability problems for the script: in case-strict
3121 * filesystems the script will stop working.
3123 * The "incorrect case" warning checked whether "use Foo"
3124 * imported "Foo" to your namespace, but that is wrong, too:
3125 * there is no requirement nor promise in the language that
3126 * a Foo.pm should or would contain anything in package "Foo".
3128 * There is very little Configure-wise that can be done, either:
3129 * the case-sensitivity of the build filesystem of Perl does not
3130 * help in guessing the case-sensitivity of the runtime environment.
3133 PL_hints |= HINT_BLOCK_SCOPE;
3134 PL_copline = NOLINE;
3136 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3140 =head1 Embedding Functions
3142 =for apidoc load_module
3144 Loads the module whose name is pointed to by the string part of name.
3145 Note that the actual module name, not its filename, should be given.
3146 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3147 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3148 (or 0 for no flags). ver, if specified, provides version semantics
3149 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3150 arguments can be used to specify arguments to the module's import()
3151 method, similar to C<use Foo::Bar VERSION LIST>.
3156 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3159 va_start(args, ver);
3160 vload_module(flags, name, ver, &args);
3164 #ifdef PERL_IMPLICIT_CONTEXT
3166 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3170 va_start(args, ver);
3171 vload_module(flags, name, ver, &args);
3177 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3181 OP * const modname = newSVOP(OP_CONST, 0, name);
3182 modname->op_private |= OPpCONST_BARE;
3184 veop = newSVOP(OP_CONST, 0, ver);
3188 if (flags & PERL_LOADMOD_NOIMPORT) {
3189 imop = sawparens(newNULLLIST());
3191 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3192 imop = va_arg(*args, OP*);
3197 sv = va_arg(*args, SV*);
3199 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3200 sv = va_arg(*args, SV*);
3204 const line_t ocopline = PL_copline;
3205 COP * const ocurcop = PL_curcop;
3206 const int oexpect = PL_expect;
3208 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3209 veop, modname, imop);
3210 PL_expect = oexpect;
3211 PL_copline = ocopline;
3212 PL_curcop = ocurcop;
3217 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
3222 if (!force_builtin) {
3223 gv = gv_fetchpv("do", 0, SVt_PVCV);
3224 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
3225 GV * const * const gvp = (GV**)hv_fetch(PL_globalstash, "do", 2, FALSE);
3226 gv = gvp ? *gvp : Nullgv;
3230 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3231 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3232 append_elem(OP_LIST, term,
3233 scalar(newUNOP(OP_RV2CV, 0,
3238 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3244 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3246 return newBINOP(OP_LSLICE, flags,
3247 list(force_list(subscript)),
3248 list(force_list(listval)) );
3252 S_is_list_assignment(pTHX_ register const OP *o)
3257 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3258 o = cUNOPo->op_first;
3260 if (o->op_type == OP_COND_EXPR) {
3261 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
3262 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3267 yyerror("Assignment to both a list and a scalar");
3271 if (o->op_type == OP_LIST &&
3272 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3273 o->op_private & OPpLVAL_INTRO)
3276 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3277 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3278 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3281 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3284 if (o->op_type == OP_RV2SV)
3291 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3296 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3297 return newLOGOP(optype, 0,
3298 mod(scalar(left), optype),
3299 newUNOP(OP_SASSIGN, 0, scalar(right)));
3302 return newBINOP(optype, OPf_STACKED,
3303 mod(scalar(left), optype), scalar(right));
3307 if (is_list_assignment(left)) {
3311 /* Grandfathering $[ assignment here. Bletch.*/
3312 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
3313 PL_eval_start = (left->op_type == OP_CONST) ? right : 0;
3314 left = mod(left, OP_AASSIGN);
3317 else if (left->op_type == OP_CONST) {
3318 /* Result of assignment is always 1 (or we'd be dead already) */
3319 return newSVOP(OP_CONST, 0, newSViv(1));
3321 curop = list(force_list(left));
3322 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3323 o->op_private = (U8)(0 | (flags >> 8));
3325 /* PL_generation sorcery:
3326 * an assignment like ($a,$b) = ($c,$d) is easier than
3327 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3328 * To detect whether there are common vars, the global var
3329 * PL_generation is incremented for each assign op we compile.
3330 * Then, while compiling the assign op, we run through all the
3331 * variables on both sides of the assignment, setting a spare slot
3332 * in each of them to PL_generation. If any of them already have
3333 * that value, we know we've got commonality. We could use a
3334 * single bit marker, but then we'd have to make 2 passes, first
3335 * to clear the flag, then to test and set it. To find somewhere
3336 * to store these values, evil chicanery is done with SvCUR().
3339 if (!(left->op_private & OPpLVAL_INTRO)) {
3342 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3343 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3344 if (curop->op_type == OP_GV) {
3345 GV *gv = cGVOPx_gv(curop);
3346 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3348 SvCUR_set(gv, PL_generation);
3350 else if (curop->op_type == OP_PADSV ||
3351 curop->op_type == OP_PADAV ||
3352 curop->op_type == OP_PADHV ||
3353 curop->op_type == OP_PADANY)
3355 if (PAD_COMPNAME_GEN(curop->op_targ)
3356 == (STRLEN)PL_generation)
3358 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
3361 else if (curop->op_type == OP_RV2CV)
3363 else if (curop->op_type == OP_RV2SV ||
3364 curop->op_type == OP_RV2AV ||
3365 curop->op_type == OP_RV2HV ||
3366 curop->op_type == OP_RV2GV) {
3367 if (lastop->op_type != OP_GV) /* funny deref? */
3370 else if (curop->op_type == OP_PUSHRE) {
3371 if (((PMOP*)curop)->op_pmreplroot) {
3373 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3374 ((PMOP*)curop)->op_pmreplroot));
3376 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3378 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3380 SvCUR_set(gv, PL_generation);
3389 o->op_private |= OPpASSIGN_COMMON;
3391 if (right && right->op_type == OP_SPLIT) {
3393 if ((tmpop = ((LISTOP*)right)->op_first) &&
3394 tmpop->op_type == OP_PUSHRE)
3396 PMOP * const pm = (PMOP*)tmpop;
3397 if (left->op_type == OP_RV2AV &&
3398 !(left->op_private & OPpLVAL_INTRO) &&
3399 !(o->op_private & OPpASSIGN_COMMON) )
3401 tmpop = ((UNOP*)left)->op_first;
3402 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3404 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3405 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3407 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3408 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3410 pm->op_pmflags |= PMf_ONCE;
3411 tmpop = cUNOPo->op_first; /* to list (nulled) */
3412 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3413 tmpop->op_sibling = Nullop; /* don't free split */
3414 right->op_next = tmpop->op_next; /* fix starting loc */
3415 op_free(o); /* blow off assign */
3416 right->op_flags &= ~OPf_WANT;
3417 /* "I don't know and I don't care." */
3422 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3423 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3425 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3427 sv_setiv(sv, PL_modcount+1);
3435 right = newOP(OP_UNDEF, 0);
3436 if (right->op_type == OP_READLINE) {
3437 right->op_flags |= OPf_STACKED;
3438 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3441 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3442 o = newBINOP(OP_SASSIGN, flags,
3443 scalar(right), mod(scalar(left), OP_SASSIGN) );
3447 o = newSVOP(OP_CONST, 0, newSViv(PL_compiling.cop_arybase));
3454 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3457 const U32 seq = intro_my();
3460 NewOp(1101, cop, 1, COP);
3461 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3462 cop->op_type = OP_DBSTATE;
3463 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3466 cop->op_type = OP_NEXTSTATE;
3467 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3469 cop->op_flags = (U8)flags;
3470 cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
3472 cop->op_private |= NATIVE_HINTS;
3474 PL_compiling.op_private = cop->op_private;
3475 cop->op_next = (OP*)cop;
3478 cop->cop_label = label;
3479 PL_hints |= HINT_BLOCK_SCOPE;
3482 cop->cop_arybase = PL_curcop->cop_arybase;
3483 if (specialWARN(PL_curcop->cop_warnings))
3484 cop->cop_warnings = PL_curcop->cop_warnings ;
3486 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3487 if (specialCopIO(PL_curcop->cop_io))
3488 cop->cop_io = PL_curcop->cop_io;
3490 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3493 if (PL_copline == NOLINE)
3494 CopLINE_set(cop, CopLINE(PL_curcop));
3496 CopLINE_set(cop, PL_copline);
3497 PL_copline = NOLINE;
3500 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3502 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3504 CopSTASH_set(cop, PL_curstash);
3506 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3507 SV * const * const svp = av_fetch(CopFILEAVx(PL_curcop), (I32)CopLINE(cop), FALSE);
3508 if (svp && *svp != &PL_sv_undef ) {
3509 (void)SvIOK_on(*svp);
3510 SvIV_set(*svp, PTR2IV(cop));
3514 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3519 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3522 return new_logop(type, flags, &first, &other);
3526 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3531 OP *first = *firstp;
3532 OP * const other = *otherp;
3534 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3535 return newBINOP(type, flags, scalar(first), scalar(other));
3537 scalarboolean(first);
3538 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3539 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3540 if (type == OP_AND || type == OP_OR) {
3546 first = *firstp = cUNOPo->op_first;
3548 first->op_next = o->op_next;
3549 cUNOPo->op_first = Nullop;
3553 if (first->op_type == OP_CONST) {
3554 if (first->op_private & OPpCONST_STRICT)
3555 no_bareword_allowed(first);
3556 else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
3557 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
3558 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
3559 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
3560 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
3563 if (other->op_type == OP_CONST)
3564 other->op_private |= OPpCONST_SHORTCIRCUIT;
3568 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
3569 const OP *o2 = other;
3570 if ( ! (o2->op_type == OP_LIST
3571 && (( o2 = cUNOPx(o2)->op_first))
3572 && o2->op_type == OP_PUSHMARK
3573 && (( o2 = o2->op_sibling)) )
3576 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
3577 || o2->op_type == OP_PADHV)
3578 && o2->op_private & OPpLVAL_INTRO
3579 && ckWARN(WARN_DEPRECATED))
3581 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
3582 "Deprecated use of my() in false conditional");
3587 if (first->op_type == OP_CONST)
3588 first->op_private |= OPpCONST_SHORTCIRCUIT;
3592 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
3593 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
3595 const OP * const k1 = ((UNOP*)first)->op_first;
3596 const OP * const k2 = k1->op_sibling;
3598 switch (first->op_type)
3601 if (k2 && k2->op_type == OP_READLINE
3602 && (k2->op_flags & OPf_STACKED)
3603 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3605 warnop = k2->op_type;
3610 if (k1->op_type == OP_READDIR
3611 || k1->op_type == OP_GLOB
3612 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3613 || k1->op_type == OP_EACH)
3615 warnop = ((k1->op_type == OP_NULL)
3616 ? (OPCODE)k1->op_targ : k1->op_type);
3621 const line_t oldline = CopLINE(PL_curcop);
3622 CopLINE_set(PL_curcop, PL_copline);
3623 Perl_warner(aTHX_ packWARN(WARN_MISC),
3624 "Value of %s%s can be \"0\"; test with defined()",
3626 ((warnop == OP_READLINE || warnop == OP_GLOB)
3627 ? " construct" : "() operator"));
3628 CopLINE_set(PL_curcop, oldline);
3635 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
3636 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3638 NewOp(1101, logop, 1, LOGOP);
3640 logop->op_type = (OPCODE)type;
3641 logop->op_ppaddr = PL_ppaddr[type];
3642 logop->op_first = first;
3643 logop->op_flags = (U8)(flags | OPf_KIDS);
3644 logop->op_other = LINKLIST(other);
3645 logop->op_private = (U8)(1 | (flags >> 8));
3647 /* establish postfix order */
3648 logop->op_next = LINKLIST(first);
3649 first->op_next = (OP*)logop;
3650 first->op_sibling = other;
3652 CHECKOP(type,logop);
3654 o = newUNOP(OP_NULL, 0, (OP*)logop);
3661 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3669 return newLOGOP(OP_AND, 0, first, trueop);
3671 return newLOGOP(OP_OR, 0, first, falseop);
3673 scalarboolean(first);
3674 if (first->op_type == OP_CONST) {
3675 if (first->op_private & OPpCONST_BARE &&
3676 first->op_private & OPpCONST_STRICT) {
3677 no_bareword_allowed(first);
3679 if (SvTRUE(((SVOP*)first)->op_sv)) {
3690 NewOp(1101, logop, 1, LOGOP);
3691 logop->op_type = OP_COND_EXPR;
3692 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3693 logop->op_first = first;
3694 logop->op_flags = (U8)(flags | OPf_KIDS);
3695 logop->op_private = (U8)(1 | (flags >> 8));
3696 logop->op_other = LINKLIST(trueop);
3697 logop->op_next = LINKLIST(falseop);
3699 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
3702 /* establish postfix order */
3703 start = LINKLIST(first);
3704 first->op_next = (OP*)logop;
3706 first->op_sibling = trueop;
3707 trueop->op_sibling = falseop;
3708 o = newUNOP(OP_NULL, 0, (OP*)logop);
3710 trueop->op_next = falseop->op_next = o;
3717 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3726 NewOp(1101, range, 1, LOGOP);
3728 range->op_type = OP_RANGE;
3729 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3730 range->op_first = left;
3731 range->op_flags = OPf_KIDS;
3732 leftstart = LINKLIST(left);
3733 range->op_other = LINKLIST(right);
3734 range->op_private = (U8)(1 | (flags >> 8));
3736 left->op_sibling = right;
3738 range->op_next = (OP*)range;
3739 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3740 flop = newUNOP(OP_FLOP, 0, flip);
3741 o = newUNOP(OP_NULL, 0, flop);
3743 range->op_next = leftstart;
3745 left->op_next = flip;
3746 right->op_next = flop;
3748 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3749 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3750 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3751 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3753 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3754 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3757 if (!flip->op_private || !flop->op_private)
3758 linklist(o); /* blow off optimizer unless constant */
3764 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3768 const bool once = block && block->op_flags & OPf_SPECIAL &&
3769 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3771 PERL_UNUSED_ARG(debuggable);
3774 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3775 return block; /* do {} while 0 does once */
3776 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3777 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3778 expr = newUNOP(OP_DEFINED, 0,
3779 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3780 } else if (expr->op_flags & OPf_KIDS) {
3781 const OP * const k1 = ((UNOP*)expr)->op_first;
3782 const OP * const k2 = k1 ? k1->op_sibling : NULL;
3783 switch (expr->op_type) {
3785 if (k2 && k2->op_type == OP_READLINE
3786 && (k2->op_flags & OPf_STACKED)
3787 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3788 expr = newUNOP(OP_DEFINED, 0, expr);
3792 if (k1->op_type == OP_READDIR
3793 || k1->op_type == OP_GLOB
3794 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3795 || k1->op_type == OP_EACH)
3796 expr = newUNOP(OP_DEFINED, 0, expr);
3802 /* if block is null, the next append_elem() would put UNSTACK, a scalar
3803 * op, in listop. This is wrong. [perl #27024] */
3805 block = newOP(OP_NULL, 0);
3806 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3807 o = new_logop(OP_AND, 0, &expr, &listop);
3810 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3812 if (once && o != listop)
3813 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3816 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3818 o->op_flags |= flags;
3820 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3825 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
3826 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
3835 PERL_UNUSED_ARG(debuggable);
3838 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3839 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3840 expr = newUNOP(OP_DEFINED, 0,
3841 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3842 } else if (expr->op_flags & OPf_KIDS) {
3843 const OP * const k1 = ((UNOP*)expr)->op_first;
3844 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
3845 switch (expr->op_type) {
3847 if (k2 && k2->op_type == OP_READLINE
3848 && (k2->op_flags & OPf_STACKED)
3849 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3850 expr = newUNOP(OP_DEFINED, 0, expr);
3854 if (k1->op_type == OP_READDIR
3855 || k1->op_type == OP_GLOB
3856 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3857 || k1->op_type == OP_EACH)
3858 expr = newUNOP(OP_DEFINED, 0, expr);
3865 block = newOP(OP_NULL, 0);
3866 else if (cont || has_my) {
3867 block = scope(block);
3871 next = LINKLIST(cont);
3874 OP * const unstack = newOP(OP_UNSTACK, 0);
3877 cont = append_elem(OP_LINESEQ, cont, unstack);
3880 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3881 redo = LINKLIST(listop);
3884 PL_copline = (line_t)whileline;
3886 o = new_logop(OP_AND, 0, &expr, &listop);
3887 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3888 op_free(expr); /* oops, it's a while (0) */
3890 return Nullop; /* listop already freed by new_logop */
3893 ((LISTOP*)listop)->op_last->op_next =
3894 (o == listop ? redo : LINKLIST(o));
3900 NewOp(1101,loop,1,LOOP);
3901 loop->op_type = OP_ENTERLOOP;
3902 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3903 loop->op_private = 0;
3904 loop->op_next = (OP*)loop;
3907 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
3909 loop->op_redoop = redo;
3910 loop->op_lastop = o;
3911 o->op_private |= loopflags;
3914 loop->op_nextop = next;
3916 loop->op_nextop = o;
3918 o->op_flags |= flags;
3919 o->op_private |= (flags >> 8);
3924 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
3929 PADOFFSET padoff = 0;
3934 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
3935 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
3936 sv->op_type = OP_RV2GV;
3937 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
3938 if (cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
3939 iterpflags |= OPpITER_DEF;
3941 else if (sv->op_type == OP_PADSV) { /* private variable */
3942 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
3943 padoff = sv->op_targ;
3948 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
3949 padoff = sv->op_targ;
3951 iterflags |= OPf_SPECIAL;
3956 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
3957 if (padoff && strEQ(PAD_COMPNAME_PV(padoff), "$_"))
3958 iterpflags |= OPpITER_DEF;
3961 const I32 offset = pad_findmy("$_");
3962 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
3963 sv = newGVOP(OP_GV, 0, PL_defgv);
3968 iterpflags |= OPpITER_DEF;
3970 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
3971 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
3972 iterflags |= OPf_STACKED;
3974 else if (expr->op_type == OP_NULL &&
3975 (expr->op_flags & OPf_KIDS) &&
3976 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
3978 /* Basically turn for($x..$y) into the same as for($x,$y), but we
3979 * set the STACKED flag to indicate that these values are to be
3980 * treated as min/max values by 'pp_iterinit'.
3982 UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
3983 LOGOP* const range = (LOGOP*) flip->op_first;
3984 OP* const left = range->op_first;
3985 OP* const right = left->op_sibling;
3988 range->op_flags &= ~OPf_KIDS;
3989 range->op_first = Nullop;
3991 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
3992 listop->op_first->op_next = range->op_next;
3993 left->op_next = range->op_other;
3994 right->op_next = (OP*)listop;
3995 listop->op_next = listop->op_first;
3998 expr = (OP*)(listop);
4000 iterflags |= OPf_STACKED;
4003 expr = mod(force_list(expr), OP_GREPSTART);
4006 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4007 append_elem(OP_LIST, expr, scalar(sv))));
4008 assert(!loop->op_next);
4009 /* for my $x () sets OPpLVAL_INTRO;
4010 * for our $x () sets OPpOUR_INTRO */
4011 loop->op_private = (U8)iterpflags;
4012 #ifdef PL_OP_SLAB_ALLOC
4015 NewOp(1234,tmp,1,LOOP);
4016 Copy(loop,tmp,1,LISTOP);
4021 Renew(loop, 1, LOOP);
4023 loop->op_targ = padoff;
4024 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
4025 PL_copline = forline;
4026 return newSTATEOP(0, label, wop);
4030 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4034 if (type != OP_GOTO || label->op_type == OP_CONST) {
4035 /* "last()" means "last" */
4036 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4037 o = newOP(type, OPf_SPECIAL);
4039 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4040 ? SvPVx_nolen_const(((SVOP*)label)->op_sv)
4046 /* Check whether it's going to be a goto &function */
4047 if (label->op_type == OP_ENTERSUB
4048 && !(label->op_flags & OPf_STACKED))
4049 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4050 o = newUNOP(type, OPf_STACKED, label);
4052 PL_hints |= HINT_BLOCK_SCOPE;
4056 /* if the condition is a literal array or hash
4057 (or @{ ... } etc), make a reference to it.
4060 S_ref_array_or_hash(pTHX_ OP *cond)
4063 && (cond->op_type == OP_RV2AV
4064 || cond->op_type == OP_PADAV
4065 || cond->op_type == OP_RV2HV
4066 || cond->op_type == OP_PADHV))
4068 return newUNOP(OP_REFGEN,
4069 0, mod(cond, OP_REFGEN));
4075 /* These construct the optree fragments representing given()
4078 entergiven and enterwhen are LOGOPs; the op_other pointer
4079 points up to the associated leave op. We need this so we
4080 can put it in the context and make break/continue work.
4081 (Also, of course, pp_enterwhen will jump straight to
4082 op_other if the match fails.)
4087 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
4088 I32 enter_opcode, I32 leave_opcode,
4089 PADOFFSET entertarg)
4094 NewOp(1101, enterop, 1, LOGOP);
4095 enterop->op_type = enter_opcode;
4096 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
4097 enterop->op_flags = (U8) OPf_KIDS;
4098 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
4099 enterop->op_private = 0;
4101 o = newUNOP(leave_opcode, 0, (OP *) enterop);
4104 enterop->op_first = scalar(cond);
4105 cond->op_sibling = block;
4107 o->op_next = LINKLIST(cond);
4108 cond->op_next = (OP *) enterop;
4111 /* This is a default {} block */
4112 enterop->op_first = block;
4113 enterop->op_flags |= OPf_SPECIAL;
4115 o->op_next = (OP *) enterop;
4118 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
4119 entergiven and enterwhen both
4122 enterop->op_next = LINKLIST(block);
4123 block->op_next = enterop->op_other = o;
4128 /* Does this look like a boolean operation? For these purposes
4129 a boolean operation is:
4130 - a subroutine call [*]
4131 - a logical connective
4132 - a comparison operator
4133 - a filetest operator, with the exception of -s -M -A -C
4134 - defined(), exists() or eof()
4135 - /$re/ or $foo =~ /$re/
4137 [*] possibly surprising
4141 S_looks_like_bool(pTHX_ OP *o)
4143 switch(o->op_type) {
4145 return looks_like_bool(cLOGOPo->op_first);
4149 looks_like_bool(cLOGOPo->op_first)
4150 && looks_like_bool(cLOGOPo->op_first->op_sibling));
4154 case OP_NOT: case OP_XOR:
4155 /* Note that OP_DOR is not here */
4157 case OP_EQ: case OP_NE: case OP_LT:
4158 case OP_GT: case OP_LE: case OP_GE:
4160 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
4161 case OP_I_GT: case OP_I_LE: case OP_I_GE:
4163 case OP_SEQ: case OP_SNE: case OP_SLT:
4164 case OP_SGT: case OP_SLE: case OP_SGE:
4168 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
4169 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
4170 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
4171 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
4172 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
4173 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
4174 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
4175 case OP_FTTEXT: case OP_FTBINARY:
4177 case OP_DEFINED: case OP_EXISTS:
4178 case OP_MATCH: case OP_EOF:
4183 /* Detect comparisons that have been optimized away */
4184 if (cSVOPo->op_sv == &PL_sv_yes
4185 || cSVOPo->op_sv == &PL_sv_no)
4196 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
4199 return newGIVWHENOP(
4200 ref_array_or_hash(cond),
4202 OP_ENTERGIVEN, OP_LEAVEGIVEN,
4206 /* If cond is null, this is a default {} block */
4208 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
4210 bool cond_llb = (!cond || looks_like_bool(cond));
4216 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
4218 scalar(ref_array_or_hash(cond)));
4221 return newGIVWHENOP(
4223 append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
4224 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
4228 =for apidoc cv_undef
4230 Clear out all the active components of a CV. This can happen either
4231 by an explicit C<undef &foo>, or by the reference count going to zero.
4232 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
4233 children can still follow the full lexical scope chain.
4239 Perl_cv_undef(pTHX_ CV *cv)
4243 if (CvFILE(cv) && !CvXSUB(cv)) {
4244 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4245 Safefree(CvFILE(cv));
4250 if (!CvXSUB(cv) && CvROOT(cv)) {
4252 Perl_croak(aTHX_ "Can't undef active subroutine");
4255 PAD_SAVE_SETNULLPAD();
4257 op_free(CvROOT(cv));
4258 CvROOT(cv) = Nullop;
4259 CvSTART(cv) = Nullop;
4262 SvPOK_off((SV*)cv); /* forget prototype */
4267 /* remove CvOUTSIDE unless this is an undef rather than a free */
4268 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
4269 if (!CvWEAKOUTSIDE(cv))
4270 SvREFCNT_dec(CvOUTSIDE(cv));
4271 CvOUTSIDE(cv) = Nullcv;
4274 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4280 /* delete all flags except WEAKOUTSIDE */
4281 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
4285 Perl_cv_ckproto(pTHX_ const CV *cv, const GV *gv, const char *p)
4287 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX_const(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4288 SV* const msg = sv_newmortal();
4292 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4293 sv_setpv(msg, "Prototype mismatch:");
4295 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4297 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (const SV *)cv);
4299 sv_catpvs(msg, ": none");
4300 sv_catpvs(msg, " vs ");
4302 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4304 sv_catpvs(msg, "none");
4305 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
4309 static void const_sv_xsub(pTHX_ CV* cv);
4313 =head1 Optree Manipulation Functions
4315 =for apidoc cv_const_sv
4317 If C<cv> is a constant sub eligible for inlining. returns the constant
4318 value returned by the sub. Otherwise, returns NULL.
4320 Constant subs can be created with C<newCONSTSUB> or as described in
4321 L<perlsub/"Constant Functions">.
4326 Perl_cv_const_sv(pTHX_ CV *cv)
4330 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
4332 return CvCONST(cv) ? (SV*)CvXSUBANY(cv).any_ptr : NULL;
4335 /* op_const_sv: examine an optree to determine whether it's in-lineable.
4336 * Can be called in 3 ways:
4339 * look for a single OP_CONST with attached value: return the value
4341 * cv && CvCLONE(cv) && !CvCONST(cv)
4343 * examine the clone prototype, and if contains only a single
4344 * OP_CONST referencing a pad const, or a single PADSV referencing
4345 * an outer lexical, return a non-zero value to indicate the CV is
4346 * a candidate for "constizing" at clone time
4350 * We have just cloned an anon prototype that was marked as a const
4351 * candidiate. Try to grab the current value, and in the case of
4352 * PADSV, ignore it if it has multiple references. Return the value.
4356 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
4363 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4364 o = cLISTOPo->op_first->op_sibling;
4366 for (; o; o = o->op_next) {
4367 const OPCODE type = o->op_type;
4369 if (sv && o->op_next == o)
4371 if (o->op_next != o) {
4372 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4374 if (type == OP_DBSTATE)
4377 if (type == OP_LEAVESUB || type == OP_RETURN)
4381 if (type == OP_CONST && cSVOPo->op_sv)
4383 else if (cv && type == OP_CONST) {
4384 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4388 else if (cv && type == OP_PADSV) {
4389 if (CvCONST(cv)) { /* newly cloned anon */
4390 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4391 /* the candidate should have 1 ref from this pad and 1 ref
4392 * from the parent */
4393 if (!sv || SvREFCNT(sv) != 2)
4400 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
4401 sv = &PL_sv_undef; /* an arbitrary non-null value */
4412 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4414 PERL_UNUSED_ARG(floor);
4424 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4428 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4430 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4434 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4441 register CV *cv = NULL;
4443 /* If the subroutine has no body, no attributes, and no builtin attributes
4444 then it's just a sub declaration, and we may be able to get away with
4445 storing with a placeholder scalar in the symbol table, rather than a
4446 full GV and CV. If anything is present then it will take a full CV to
4448 const I32 gv_fetch_flags
4449 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
4450 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
4451 const char * const name = o ? SvPVx_nolen_const(cSVOPo->op_sv) : Nullch;
4454 assert(proto->op_type == OP_CONST);
4455 ps = SvPVx_const(((SVOP*)proto)->op_sv, ps_len);
4460 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4461 SV * const sv = sv_newmortal();
4462 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4463 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
4464 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4465 aname = SvPVX_const(sv);
4470 gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
4471 : gv_fetchpv(aname ? aname
4472 : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4473 gv_fetch_flags, SVt_PVCV);
4482 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4483 maximum a prototype before. */
4484 if (SvTYPE(gv) > SVt_NULL) {
4485 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4486 && ckWARN_d(WARN_PROTOTYPE))
4488 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
4490 cv_ckproto((CV*)gv, NULL, ps);
4493 sv_setpvn((SV*)gv, ps, ps_len);
4495 sv_setiv((SV*)gv, -1);
4496 SvREFCNT_dec(PL_compcv);
4497 cv = PL_compcv = NULL;
4498 PL_sub_generation++;
4502 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4504 #ifdef GV_UNIQUE_CHECK
4505 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4506 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4510 if (!block || !ps || *ps || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
4513 const_sv = op_const_sv(block, Nullcv);
4516 const bool exists = CvROOT(cv) || CvXSUB(cv);
4518 #ifdef GV_UNIQUE_CHECK
4519 if (exists && GvUNIQUE(gv)) {
4520 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4524 /* if the subroutine doesn't exist and wasn't pre-declared
4525 * with a prototype, assume it will be AUTOLOADed,
4526 * skipping the prototype check
4528 if (exists || SvPOK(cv))
4529 cv_ckproto(cv, gv, ps);
4530 /* already defined (or promised)? */
4531 if (exists || GvASSUMECV(gv)) {
4532 if (!block && !attrs) {
4533 if (CvFLAGS(PL_compcv)) {
4534 /* might have had built-in attrs applied */
4535 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4537 /* just a "sub foo;" when &foo is already defined */
4538 SAVEFREESV(PL_compcv);
4542 if (ckWARN(WARN_REDEFINE)
4544 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4546 const line_t oldline = CopLINE(PL_curcop);
4547 if (PL_copline != NOLINE)
4548 CopLINE_set(PL_curcop, PL_copline);
4549 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4550 CvCONST(cv) ? "Constant subroutine %s redefined"
4551 : "Subroutine %s redefined", name);
4552 CopLINE_set(PL_curcop, oldline);
4560 (void)SvREFCNT_inc(const_sv);
4562 assert(!CvROOT(cv) && !CvCONST(cv));
4563 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
4564 CvXSUBANY(cv).any_ptr = const_sv;
4565 CvXSUB(cv) = const_sv_xsub;
4570 cv = newCONSTSUB(NULL, name, const_sv);
4573 SvREFCNT_dec(PL_compcv);
4575 PL_sub_generation++;
4582 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4583 * before we clobber PL_compcv.
4587 /* Might have had built-in attributes applied -- propagate them. */
4588 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4589 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4590 stash = GvSTASH(CvGV(cv));
4591 else if (CvSTASH(cv))
4592 stash = CvSTASH(cv);
4594 stash = PL_curstash;
4597 /* possibly about to re-define existing subr -- ignore old cv */
4598 rcv = (SV*)PL_compcv;
4599 if (name && GvSTASH(gv))
4600 stash = GvSTASH(gv);
4602 stash = PL_curstash;
4604 apply_attrs(stash, rcv, attrs, FALSE);
4606 if (cv) { /* must reuse cv if autoloaded */
4608 /* got here with just attrs -- work done, so bug out */
4609 SAVEFREESV(PL_compcv);
4612 /* transfer PL_compcv to cv */
4614 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4615 if (!CvWEAKOUTSIDE(cv))
4616 SvREFCNT_dec(CvOUTSIDE(cv));
4617 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4618 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
4619 CvOUTSIDE(PL_compcv) = 0;
4620 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4621 CvPADLIST(PL_compcv) = 0;
4622 /* inner references to PL_compcv must be fixed up ... */
4623 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
4624 /* ... before we throw it away */
4625 SvREFCNT_dec(PL_compcv);
4627 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4628 ++PL_sub_generation;
4635 PL_sub_generation++;
4639 CvFILE_set_from_cop(cv, PL_curcop);
4640 CvSTASH(cv) = PL_curstash;
4643 sv_setpvn((SV*)cv, ps, ps_len);
4645 if (PL_error_count) {
4649 const char *s = strrchr(name, ':');
4651 if (strEQ(s, "BEGIN")) {
4652 const char not_safe[] =
4653 "BEGIN not safe after errors--compilation aborted";
4654 if (PL_in_eval & EVAL_KEEPERR)
4655 Perl_croak(aTHX_ not_safe);
4657 /* force display of errors found but not reported */
4658 sv_catpv(ERRSV, not_safe);
4659 Perl_croak(aTHX_ "%"SVf, ERRSV);
4668 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4669 mod(scalarseq(block), OP_LEAVESUBLV));
4672 /* This makes sub {}; work as expected. */
4673 if (block->op_type == OP_STUB) {
4675 block = newSTATEOP(0, Nullch, 0);
4677 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4679 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4680 OpREFCNT_set(CvROOT(cv), 1);
4681 CvSTART(cv) = LINKLIST(CvROOT(cv));
4682 CvROOT(cv)->op_next = 0;
4683 CALL_PEEP(CvSTART(cv));
4685 /* now that optimizer has done its work, adjust pad values */
4687 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4690 assert(!CvCONST(cv));
4691 if (ps && !*ps && op_const_sv(block, cv))
4695 if (name || aname) {
4697 const char * const tname = (name ? name : aname);
4699 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4700 SV * const sv = NEWSV(0,0);
4701 SV * const tmpstr = sv_newmortal();
4702 GV * const db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4705 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4707 (long)PL_subline, (long)CopLINE(PL_curcop));
4708 gv_efullname3(tmpstr, gv, Nullch);
4709 hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0);
4710 hv = GvHVn(db_postponed);
4711 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
4712 CV * const pcv = GvCV(db_postponed);
4718 call_sv((SV*)pcv, G_DISCARD);
4723 if ((s = strrchr(tname,':')))
4728 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4731 if (strEQ(s, "BEGIN") && !PL_error_count) {
4732 const I32 oldscope = PL_scopestack_ix;
4734 SAVECOPFILE(&PL_compiling);
4735 SAVECOPLINE(&PL_compiling);
4738 PL_beginav = newAV();
4739 DEBUG_x( dump_sub(gv) );
4740 av_push(PL_beginav, (SV*)cv);
4741 GvCV(gv) = 0; /* cv has been hijacked */
4742 call_list(oldscope, PL_beginav);
4744 PL_curcop = &PL_compiling;
4745 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4748 else if (strEQ(s, "END") && !PL_error_count) {
4751 DEBUG_x( dump_sub(gv) );
4752 av_unshift(PL_endav, 1);
4753 av_store(PL_endav, 0, (SV*)cv);
4754 GvCV(gv) = 0; /* cv has been hijacked */
4756 else if (strEQ(s, "CHECK") && !PL_error_count) {
4758 PL_checkav = newAV();
4759 DEBUG_x( dump_sub(gv) );
4760 if (PL_main_start && ckWARN(WARN_VOID))
4761 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4762 av_unshift(PL_checkav, 1);
4763 av_store(PL_checkav, 0, (SV*)cv);
4764 GvCV(gv) = 0; /* cv has been hijacked */
4766 else if (strEQ(s, "INIT") && !PL_error_count) {
4768 PL_initav = newAV();
4769 DEBUG_x( dump_sub(gv) );
4770 if (PL_main_start && ckWARN(WARN_VOID))
4771 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4772 av_push(PL_initav, (SV*)cv);
4773 GvCV(gv) = 0; /* cv has been hijacked */
4778 PL_copline = NOLINE;
4783 /* XXX unsafe for threads if eval_owner isn't held */
4785 =for apidoc newCONSTSUB
4787 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4788 eligible for inlining at compile-time.
4794 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
4801 SAVECOPLINE(PL_curcop);
4802 CopLINE_set(PL_curcop, PL_copline);
4805 PL_hints &= ~HINT_BLOCK_SCOPE;
4808 SAVESPTR(PL_curstash);
4809 SAVECOPSTASH(PL_curcop);
4810 PL_curstash = stash;
4811 CopSTASH_set(PL_curcop,stash);
4814 cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
4815 CvXSUBANY(cv).any_ptr = sv;
4817 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
4821 CopSTASH_free(PL_curcop);
4829 =for apidoc U||newXS
4831 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4837 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
4839 GV * const gv = gv_fetchpv(name ? name :
4840 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4841 GV_ADDMULTI, SVt_PVCV);
4845 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4847 if ((cv = (name ? GvCV(gv) : Nullcv))) {
4849 /* just a cached method */
4853 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4854 /* already defined (or promised) */
4855 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
4856 if (ckWARN(WARN_REDEFINE)) {
4857 GV * const gvcv = CvGV(cv);
4859 HV * const stash = GvSTASH(gvcv);
4861 const char *name = HvNAME_get(stash);
4862 if ( strEQ(name,"autouse") ) {
4863 const line_t oldline = CopLINE(PL_curcop);
4864 if (PL_copline != NOLINE)
4865 CopLINE_set(PL_curcop, PL_copline);
4866 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4867 CvCONST(cv) ? "Constant subroutine %s redefined"
4868 : "Subroutine %s redefined"
4870 CopLINE_set(PL_curcop, oldline);
4880 if (cv) /* must reuse cv if autoloaded */
4883 cv = (CV*)NEWSV(1105,0);
4884 sv_upgrade((SV *)cv, SVt_PVCV);
4888 PL_sub_generation++;
4892 (void)gv_fetchfile(filename);
4893 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
4894 an external constant string */
4895 CvXSUB(cv) = subaddr;
4898 const char *s = strrchr(name,':');
4904 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4907 if (strEQ(s, "BEGIN")) {
4909 PL_beginav = newAV();
4910 av_push(PL_beginav, (SV*)cv);
4911 GvCV(gv) = 0; /* cv has been hijacked */
4913 else if (strEQ(s, "END")) {
4916 av_unshift(PL_endav, 1);
4917 av_store(PL_endav, 0, (SV*)cv);
4918 GvCV(gv) = 0; /* cv has been hijacked */
4920 else if (strEQ(s, "CHECK")) {
4922 PL_checkav = newAV();
4923 if (PL_main_start && ckWARN(WARN_VOID))
4924 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4925 av_unshift(PL_checkav, 1);
4926 av_store(PL_checkav, 0, (SV*)cv);
4927 GvCV(gv) = 0; /* cv has been hijacked */
4929 else if (strEQ(s, "INIT")) {
4931 PL_initav = newAV();
4932 if (PL_main_start && ckWARN(WARN_VOID))
4933 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4934 av_push(PL_initav, (SV*)cv);
4935 GvCV(gv) = 0; /* cv has been hijacked */
4946 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4951 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
4952 : gv_fetchpv("STDOUT", GV_ADD, SVt_PVFM);
4954 #ifdef GV_UNIQUE_CHECK
4956 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
4960 if ((cv = GvFORM(gv))) {
4961 if (ckWARN(WARN_REDEFINE)) {
4962 const line_t oldline = CopLINE(PL_curcop);
4963 if (PL_copline != NOLINE)
4964 CopLINE_set(PL_curcop, PL_copline);
4965 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4966 o ? "Format %"SVf" redefined"
4967 : "Format STDOUT redefined" ,cSVOPo->op_sv);
4968 CopLINE_set(PL_curcop, oldline);
4975 CvFILE_set_from_cop(cv, PL_curcop);
4978 pad_tidy(padtidy_FORMAT);
4979 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
4980 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4981 OpREFCNT_set(CvROOT(cv), 1);
4982 CvSTART(cv) = LINKLIST(CvROOT(cv));
4983 CvROOT(cv)->op_next = 0;
4984 CALL_PEEP(CvSTART(cv));
4986 PL_copline = NOLINE;
4991 Perl_newANONLIST(pTHX_ OP *o)
4993 return newUNOP(OP_REFGEN, 0,
4994 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
4998 Perl_newANONHASH(pTHX_ OP *o)
5000 return newUNOP(OP_REFGEN, 0,
5001 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5005 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5007 return newANONATTRSUB(floor, proto, Nullop, block);
5011 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5013 return newUNOP(OP_REFGEN, 0,
5014 newSVOP(OP_ANONCODE, 0,
5015 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5019 Perl_oopsAV(pTHX_ OP *o)
5022 switch (o->op_type) {
5024 o->op_type = OP_PADAV;
5025 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5026 return ref(o, OP_RV2AV);
5029 o->op_type = OP_RV2AV;
5030 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5035 if (ckWARN_d(WARN_INTERNAL))
5036 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
5043 Perl_oopsHV(pTHX_ OP *o)
5046 switch (o->op_type) {
5049 o->op_type = OP_PADHV;
5050 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5051 return ref(o, OP_RV2HV);
5055 o->op_type = OP_RV2HV;
5056 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5061 if (ckWARN_d(WARN_INTERNAL))
5062 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
5069 Perl_newAVREF(pTHX_ OP *o)
5072 if (o->op_type == OP_PADANY) {
5073 o->op_type = OP_PADAV;
5074 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5077 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5078 && ckWARN(WARN_DEPRECATED)) {
5079 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5080 "Using an array as a reference is deprecated");
5082 return newUNOP(OP_RV2AV, 0, scalar(o));
5086 Perl_newGVREF(pTHX_ I32 type, OP *o)
5088 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5089 return newUNOP(OP_NULL, 0, o);
5090 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5094 Perl_newHVREF(pTHX_ OP *o)
5097 if (o->op_type == OP_PADANY) {
5098 o->op_type = OP_PADHV;
5099 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5102 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5103 && ckWARN(WARN_DEPRECATED)) {
5104 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5105 "Using a hash as a reference is deprecated");
5107 return newUNOP(OP_RV2HV, 0, scalar(o));
5111 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5113 return newUNOP(OP_RV2CV, flags, scalar(o));
5117 Perl_newSVREF(pTHX_ OP *o)
5120 if (o->op_type == OP_PADANY) {
5121 o->op_type = OP_PADSV;
5122 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5125 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5126 o->op_flags |= OPpDONE_SVREF;
5129 return newUNOP(OP_RV2SV, 0, scalar(o));
5132 /* Check routines. See the comments at the top of this file for details
5133 * on when these are called */
5136 Perl_ck_anoncode(pTHX_ OP *o)
5138 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
5139 cSVOPo->op_sv = Nullsv;
5144 Perl_ck_bitop(pTHX_ OP *o)
5146 #define OP_IS_NUMCOMPARE(op) \
5147 ((op) == OP_LT || (op) == OP_I_LT || \
5148 (op) == OP_GT || (op) == OP_I_GT || \
5149 (op) == OP_LE || (op) == OP_I_LE || \
5150 (op) == OP_GE || (op) == OP_I_GE || \
5151 (op) == OP_EQ || (op) == OP_I_EQ || \
5152 (op) == OP_NE || (op) == OP_I_NE || \
5153 (op) == OP_NCMP || (op) == OP_I_NCMP)
5154 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
5155 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
5156 && (o->op_type == OP_BIT_OR
5157 || o->op_type == OP_BIT_AND
5158 || o->op_type == OP_BIT_XOR))
5160 const OP * const left = cBINOPo->op_first;
5161 const OP * const right = left->op_sibling;
5162 if ((OP_IS_NUMCOMPARE(left->op_type) &&
5163 (left->op_flags & OPf_PARENS) == 0) ||
5164 (OP_IS_NUMCOMPARE(right->op_type) &&
5165 (right->op_flags & OPf_PARENS) == 0))
5166 if (ckWARN(WARN_PRECEDENCE))
5167 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
5168 "Possible precedence problem on bitwise %c operator",
5169 o->op_type == OP_BIT_OR ? '|'
5170 : o->op_type == OP_BIT_AND ? '&' : '^'
5177 Perl_ck_concat(pTHX_ OP *o)
5179 const OP * const kid = cUNOPo->op_first;
5180 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
5181 !(kUNOP->op_first->op_flags & OPf_MOD))
5182 o->op_flags |= OPf_STACKED;
5187 Perl_ck_spair(pTHX_ OP *o)
5190 if (o->op_flags & OPf_KIDS) {
5193 const OPCODE type = o->op_type;
5194 o = modkids(ck_fun(o), type);
5195 kid = cUNOPo->op_first;
5196 newop = kUNOP->op_first->op_sibling;
5198 (newop->op_sibling ||
5199 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5200 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5201 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5205 op_free(kUNOP->op_first);
5206 kUNOP->op_first = newop;
5208 o->op_ppaddr = PL_ppaddr[++o->op_type];
5213 Perl_ck_delete(pTHX_ OP *o)
5217 if (o->op_flags & OPf_KIDS) {
5218 OP * const kid = cUNOPo->op_first;
5219 switch (kid->op_type) {
5221 o->op_flags |= OPf_SPECIAL;
5224 o->op_private |= OPpSLICE;
5227 o->op_flags |= OPf_SPECIAL;
5232 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5241 Perl_ck_die(pTHX_ OP *o)
5244 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5250 Perl_ck_eof(pTHX_ OP *o)
5252 const I32 type = o->op_type;
5254 if (o->op_flags & OPf_KIDS) {
5255 if (cLISTOPo->op_first->op_type == OP_STUB) {
5257 o = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
5265 Perl_ck_eval(pTHX_ OP *o)
5268 PL_hints |= HINT_BLOCK_SCOPE;
5269 if (o->op_flags & OPf_KIDS) {
5270 SVOP * const kid = (SVOP*)cUNOPo->op_first;
5273 o->op_flags &= ~OPf_KIDS;
5276 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
5279 cUNOPo->op_first = 0;
5282 NewOp(1101, enter, 1, LOGOP);
5283 enter->op_type = OP_ENTERTRY;
5284 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5285 enter->op_private = 0;
5287 /* establish postfix order */
5288 enter->op_next = (OP*)enter;
5290 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5291 o->op_type = OP_LEAVETRY;
5292 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5293 enter->op_other = o;
5303 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5305 o->op_targ = (PADOFFSET)PL_hints;
5306 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
5307 /* Store a copy of %^H that pp_entereval can pick up */
5308 OP *hhop = newSVOP(OP_CONST, 0, (SV*)newHVhv(GvHV(PL_hintgv)));
5309 cUNOPo->op_first->op_sibling = hhop;
5310 o->op_private |= OPpEVAL_HAS_HH;
5316 Perl_ck_exit(pTHX_ OP *o)
5319 HV * const table = GvHV(PL_hintgv);
5321 SV * const * const svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5322 if (svp && *svp && SvTRUE(*svp))
5323 o->op_private |= OPpEXIT_VMSISH;
5325 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5331 Perl_ck_exec(pTHX_ OP *o)
5333 if (o->op_flags & OPf_STACKED) {
5336 kid = cUNOPo->op_first->op_sibling;
5337 if (kid->op_type == OP_RV2GV)
5346 Perl_ck_exists(pTHX_ OP *o)
5349 if (o->op_flags & OPf_KIDS) {
5350 OP * const kid = cUNOPo->op_first;
5351 if (kid->op_type == OP_ENTERSUB) {
5352 (void) ref(kid, o->op_type);
5353 if (kid->op_type != OP_RV2CV && !PL_error_count)
5354 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5356 o->op_private |= OPpEXISTS_SUB;
5358 else if (kid->op_type == OP_AELEM)
5359 o->op_flags |= OPf_SPECIAL;
5360 else if (kid->op_type != OP_HELEM)
5361 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5369 Perl_ck_rvconst(pTHX_ register OP *o)
5372 SVOP * const kid = (SVOP*)cUNOPo->op_first;
5374 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5375 if (o->op_type == OP_RV2CV)
5376 o->op_private &= ~1;
5378 if (kid->op_type == OP_CONST) {
5381 SV * const kidsv = kid->op_sv;
5383 /* Is it a constant from cv_const_sv()? */
5384 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5385 SV * const rsv = SvRV(kidsv);
5386 const int svtype = SvTYPE(rsv);
5387 const char *badtype = Nullch;
5389 switch (o->op_type) {
5391 if (svtype > SVt_PVMG)
5392 badtype = "a SCALAR";
5395 if (svtype != SVt_PVAV)
5396 badtype = "an ARRAY";
5399 if (svtype != SVt_PVHV)
5403 if (svtype != SVt_PVCV)
5408 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5411 else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
5412 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
5413 /* If this is an access to a stash, disable "strict refs", because
5414 * stashes aren't auto-vivified at compile-time (unless we store
5415 * symbols in them), and we don't want to produce a run-time
5416 * stricture error when auto-vivifying the stash. */
5417 const char *s = SvPV_nolen(kidsv);
5418 const STRLEN l = SvCUR(kidsv);
5419 if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
5420 o->op_private &= ~HINT_STRICT_REFS;
5422 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5423 const char *badthing = Nullch;
5424 switch (o->op_type) {
5426 badthing = "a SCALAR";
5429 badthing = "an ARRAY";
5432 badthing = "a HASH";
5437 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
5441 * This is a little tricky. We only want to add the symbol if we
5442 * didn't add it in the lexer. Otherwise we get duplicate strict
5443 * warnings. But if we didn't add it in the lexer, we must at
5444 * least pretend like we wanted to add it even if it existed before,
5445 * or we get possible typo warnings. OPpCONST_ENTERED says
5446 * whether the lexer already added THIS instance of this symbol.
5448 iscv = (o->op_type == OP_RV2CV) * 2;
5450 gv = gv_fetchsv(kidsv,
5451 iscv | !(kid->op_private & OPpCONST_ENTERED),
5454 : o->op_type == OP_RV2SV
5456 : o->op_type == OP_RV2AV
5458 : o->op_type == OP_RV2HV
5461 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5463 kid->op_type = OP_GV;
5464 SvREFCNT_dec(kid->op_sv);
5466 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5467 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5468 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
5470 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv));
5472 kid->op_sv = SvREFCNT_inc(gv);
5474 kid->op_private = 0;
5475 kid->op_ppaddr = PL_ppaddr[OP_GV];
5482 Perl_ck_ftst(pTHX_ OP *o)
5485 const I32 type = o->op_type;
5487 if (o->op_flags & OPf_REF) {
5490 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5491 SVOP * const kid = (SVOP*)cUNOPo->op_first;
5493 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5494 OP * const newop = newGVOP(type, OPf_REF,
5495 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
5501 if ((PL_hints & HINT_FILETEST_ACCESS) &&
5502 OP_IS_FILETEST_ACCESS(o))
5503 o->op_private |= OPpFT_ACCESS;
5505 if (PL_check[kid->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst)
5506 && kid->op_type != OP_STAT && kid->op_type != OP_LSTAT)
5507 o->op_private |= OPpFT_STACKED;
5511 if (type == OP_FTTTY)
5512 o = newGVOP(type, OPf_REF, PL_stdingv);
5514 o = newUNOP(type, 0, newDEFSVOP());
5520 Perl_ck_fun(pTHX_ OP *o)
5522 const int type = o->op_type;
5523 register I32 oa = PL_opargs[type] >> OASHIFT;
5525 if (o->op_flags & OPf_STACKED) {
5526 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5529 return no_fh_allowed(o);
5532 if (o->op_flags & OPf_KIDS) {
5533 OP **tokid = &cLISTOPo->op_first;
5534 register OP *kid = cLISTOPo->op_first;
5538 if (kid->op_type == OP_PUSHMARK ||
5539 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5541 tokid = &kid->op_sibling;
5542 kid = kid->op_sibling;
5544 if (!kid && PL_opargs[type] & OA_DEFGV)
5545 *tokid = kid = newDEFSVOP();
5549 sibl = kid->op_sibling;
5552 /* list seen where single (scalar) arg expected? */
5553 if (numargs == 1 && !(oa >> 4)
5554 && kid->op_type == OP_LIST && type != OP_SCALAR)
5556 return too_many_arguments(o,PL_op_desc[type]);
5569 if ((type == OP_PUSH || type == OP_UNSHIFT)
5570 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5571 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5572 "Useless use of %s with no values",
5575 if (kid->op_type == OP_CONST &&
5576 (kid->op_private & OPpCONST_BARE))
5578 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
5579 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
5580 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5581 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5582 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
5583 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
5586 kid->op_sibling = sibl;
5589 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5590 bad_type(numargs, "array", PL_op_desc[type], kid);
5594 if (kid->op_type == OP_CONST &&
5595 (kid->op_private & OPpCONST_BARE))
5597 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
5598 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
5599 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5600 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5601 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
5602 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
5605 kid->op_sibling = sibl;
5608 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5609 bad_type(numargs, "hash", PL_op_desc[type], kid);
5614 OP * const newop = newUNOP(OP_NULL, 0, kid);
5615 kid->op_sibling = 0;
5617 newop->op_next = newop;
5619 kid->op_sibling = sibl;
5624 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5625 if (kid->op_type == OP_CONST &&
5626 (kid->op_private & OPpCONST_BARE))
5628 OP * const newop = newGVOP(OP_GV, 0,
5629 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
5630 if (!(o->op_private & 1) && /* if not unop */
5631 kid == cLISTOPo->op_last)
5632 cLISTOPo->op_last = newop;
5636 else if (kid->op_type == OP_READLINE) {
5637 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5638 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5641 I32 flags = OPf_SPECIAL;
5645 /* is this op a FH constructor? */
5646 if (is_handle_constructor(o,numargs)) {
5647 const char *name = Nullch;
5651 /* Set a flag to tell rv2gv to vivify
5652 * need to "prove" flag does not mean something
5653 * else already - NI-S 1999/05/07
5656 if (kid->op_type == OP_PADSV) {
5657 name = PAD_COMPNAME_PV(kid->op_targ);
5658 /* SvCUR of a pad namesv can't be trusted
5659 * (see PL_generation), so calc its length
5665 else if (kid->op_type == OP_RV2SV
5666 && kUNOP->op_first->op_type == OP_GV)
5668 GV * const gv = cGVOPx_gv(kUNOP->op_first);
5670 len = GvNAMELEN(gv);
5672 else if (kid->op_type == OP_AELEM
5673 || kid->op_type == OP_HELEM)
5675 OP *op = ((BINOP*)kid)->op_first;
5678 SV *tmpstr = Nullsv;
5679 const char * const a =
5680 kid->op_type == OP_AELEM ?
5682 if (((op->op_type == OP_RV2AV) ||
5683 (op->op_type == OP_RV2HV)) &&
5684 (op = ((UNOP*)op)->op_first) &&
5685 (op->op_type == OP_GV)) {
5686 /* packagevar $a[] or $h{} */
5687 GV * const gv = cGVOPx_gv(op);
5695 else if (op->op_type == OP_PADAV
5696 || op->op_type == OP_PADHV) {
5697 /* lexicalvar $a[] or $h{} */
5698 const char * const padname =
5699 PAD_COMPNAME_PV(op->op_targ);
5708 name = SvPV_const(tmpstr, len);
5713 name = "__ANONIO__";
5720 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5721 namesv = PAD_SVl(targ);
5722 SvUPGRADE(namesv, SVt_PV);
5724 sv_setpvn(namesv, "$", 1);
5725 sv_catpvn(namesv, name, len);
5728 kid->op_sibling = 0;
5729 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5730 kid->op_targ = targ;
5731 kid->op_private |= priv;
5733 kid->op_sibling = sibl;
5739 mod(scalar(kid), type);
5743 tokid = &kid->op_sibling;
5744 kid = kid->op_sibling;
5746 o->op_private |= numargs;
5748 return too_many_arguments(o,OP_DESC(o));
5751 else if (PL_opargs[type] & OA_DEFGV) {
5753 return newUNOP(type, 0, newDEFSVOP());
5757 while (oa & OA_OPTIONAL)
5759 if (oa && oa != OA_LIST)
5760 return too_few_arguments(o,OP_DESC(o));
5766 Perl_ck_glob(pTHX_ OP *o)
5772 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5773 append_elem(OP_GLOB, o, newDEFSVOP());
5775 if (!((gv = gv_fetchpv("glob", 0, SVt_PVCV))
5776 && GvCVu(gv) && GvIMPORTED_CV(gv)))
5778 gv = gv_fetchpv("CORE::GLOBAL::glob", 0, SVt_PVCV);
5781 #if !defined(PERL_EXTERNAL_GLOB)
5782 /* XXX this can be tightened up and made more failsafe. */
5783 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
5786 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5787 newSVpvs("File::Glob"), Nullsv, Nullsv, Nullsv);
5788 gv = gv_fetchpv("CORE::GLOBAL::glob", 0, SVt_PVCV);
5789 glob_gv = gv_fetchpv("File::Glob::csh_glob", 0, SVt_PVCV);
5790 GvCV(gv) = GvCV(glob_gv);
5791 (void)SvREFCNT_inc((SV*)GvCV(gv));
5792 GvIMPORTED_CV_on(gv);
5795 #endif /* PERL_EXTERNAL_GLOB */
5797 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5798 append_elem(OP_GLOB, o,
5799 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5800 o->op_type = OP_LIST;
5801 o->op_ppaddr = PL_ppaddr[OP_LIST];
5802 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5803 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5804 cLISTOPo->op_first->op_targ = 0;
5805 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5806 append_elem(OP_LIST, o,
5807 scalar(newUNOP(OP_RV2CV, 0,
5808 newGVOP(OP_GV, 0, gv)))));
5809 o = newUNOP(OP_NULL, 0, ck_subr(o));
5810 o->op_targ = OP_GLOB; /* hint at what it used to be */
5813 gv = newGVgen("main");
5815 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5821 Perl_ck_grep(pTHX_ OP *o)
5826 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5829 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5830 NewOp(1101, gwop, 1, LOGOP);
5832 if (o->op_flags & OPf_STACKED) {
5835 kid = cLISTOPo->op_first->op_sibling;
5836 if (!cUNOPx(kid)->op_next)
5837 Perl_croak(aTHX_ "panic: ck_grep");
5838 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
5841 kid->op_next = (OP*)gwop;
5842 o->op_flags &= ~OPf_STACKED;
5844 kid = cLISTOPo->op_first->op_sibling;
5845 if (type == OP_MAPWHILE)
5852 kid = cLISTOPo->op_first->op_sibling;
5853 if (kid->op_type != OP_NULL)
5854 Perl_croak(aTHX_ "panic: ck_grep");
5855 kid = kUNOP->op_first;
5857 gwop->op_type = type;
5858 gwop->op_ppaddr = PL_ppaddr[type];
5859 gwop->op_first = listkids(o);
5860 gwop->op_flags |= OPf_KIDS;
5861 gwop->op_other = LINKLIST(kid);
5862 kid->op_next = (OP*)gwop;
5863 offset = pad_findmy("$_");
5864 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
5865 o->op_private = gwop->op_private = 0;
5866 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5869 o->op_private = gwop->op_private = OPpGREP_LEX;
5870 gwop->op_targ = o->op_targ = offset;
5873 kid = cLISTOPo->op_first->op_sibling;
5874 if (!kid || !kid->op_sibling)
5875 return too_few_arguments(o,OP_DESC(o));
5876 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5877 mod(kid, OP_GREPSTART);
5883 Perl_ck_index(pTHX_ OP *o)
5885 if (o->op_flags & OPf_KIDS) {
5886 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5888 kid = kid->op_sibling; /* get past "big" */
5889 if (kid && kid->op_type == OP_CONST)
5890 fbm_compile(((SVOP*)kid)->op_sv, 0);
5896 Perl_ck_lengthconst(pTHX_ OP *o)
5898 /* XXX length optimization goes here */
5903 Perl_ck_lfun(pTHX_ OP *o)
5905 const OPCODE type = o->op_type;
5906 return modkids(ck_fun(o), type);
5910 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5912 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
5913 switch (cUNOPo->op_first->op_type) {
5915 /* This is needed for
5916 if (defined %stash::)
5917 to work. Do not break Tk.
5919 break; /* Globals via GV can be undef */
5921 case OP_AASSIGN: /* Is this a good idea? */
5922 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5923 "defined(@array) is deprecated");
5924 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5925 "\t(Maybe you should just omit the defined()?)\n");
5928 /* This is needed for
5929 if (defined %stash::)
5930 to work. Do not break Tk.
5932 break; /* Globals via GV can be undef */
5934 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5935 "defined(%%hash) is deprecated");
5936 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5937 "\t(Maybe you should just omit the defined()?)\n");
5948 Perl_ck_rfun(pTHX_ OP *o)
5950 const OPCODE type = o->op_type;
5951 return refkids(ck_fun(o), type);
5955 Perl_ck_listiob(pTHX_ OP *o)
5959 kid = cLISTOPo->op_first;
5962 kid = cLISTOPo->op_first;
5964 if (kid->op_type == OP_PUSHMARK)
5965 kid = kid->op_sibling;
5966 if (kid && o->op_flags & OPf_STACKED)
5967 kid = kid->op_sibling;
5968 else if (kid && !kid->op_sibling) { /* print HANDLE; */
5969 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5970 o->op_flags |= OPf_STACKED; /* make it a filehandle */
5971 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5972 cLISTOPo->op_first->op_sibling = kid;
5973 cLISTOPo->op_last = kid;
5974 kid = kid->op_sibling;
5979 append_elem(o->op_type, o, newDEFSVOP());
5985 Perl_ck_say(pTHX_ OP *o)
5988 o->op_type = OP_PRINT;
5989 cLISTOPo->op_last = cLISTOPo->op_last->op_sibling
5990 = newSVOP(OP_CONST, 0, newSVpvs("\n"));
5995 Perl_ck_smartmatch(pTHX_ OP *o)
5997 if (0 == (o->op_flags & OPf_SPECIAL)) {
5998 OP *first = cBINOPo->op_first;
5999 OP *second = first->op_sibling;
6001 /* Implicitly take a reference to an array or hash */
6002 first->op_sibling = Nullop;
6003 first = cBINOPo->op_first = ref_array_or_hash(first);
6004 second = first->op_sibling = ref_array_or_hash(second);
6006 /* Implicitly take a reference to a regular expression */
6007 if (first->op_type == OP_MATCH) {
6008 first->op_type = OP_QR;
6009 first->op_ppaddr = PL_ppaddr[OP_QR];
6011 if (second->op_type == OP_MATCH) {
6012 second->op_type = OP_QR;
6013 second->op_ppaddr = PL_ppaddr[OP_QR];
6022 Perl_ck_sassign(pTHX_ OP *o)
6024 OP *kid = cLISTOPo->op_first;
6025 /* has a disposable target? */
6026 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6027 && !(kid->op_flags & OPf_STACKED)
6028 /* Cannot steal the second time! */
6029 && !(kid->op_private & OPpTARGET_MY))
6031 OP * const kkid = kid->op_sibling;
6033 /* Can just relocate the target. */
6034 if (kkid && kkid->op_type == OP_PADSV
6035 && !(kkid->op_private & OPpLVAL_INTRO))
6037 kid->op_targ = kkid->op_targ;
6039 /* Now we do not need PADSV and SASSIGN. */
6040 kid->op_sibling = o->op_sibling; /* NULL */
6041 cLISTOPo->op_first = NULL;
6044 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6052 Perl_ck_match(pTHX_ OP *o)
6054 if (o->op_type != OP_QR && PL_compcv) {
6055 const I32 offset = pad_findmy("$_");
6056 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS(offset) & SVpad_OUR)) {
6057 o->op_targ = offset;
6058 o->op_private |= OPpTARGET_MY;
6061 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
6062 o->op_private |= OPpRUNTIME;
6067 Perl_ck_method(pTHX_ OP *o)
6069 OP * const kid = cUNOPo->op_first;
6070 if (kid->op_type == OP_CONST) {
6071 SV* sv = kSVOP->op_sv;
6072 if (!(strchr(SvPVX_const(sv), ':') || strchr(SvPVX_const(sv), '\''))) {
6074 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6075 sv = newSVpvn_share(SvPVX_const(sv), SvCUR(sv), 0);
6078 kSVOP->op_sv = Nullsv;
6080 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6089 Perl_ck_null(pTHX_ OP *o)
6095 Perl_ck_open(pTHX_ OP *o)
6097 HV * const table = GvHV(PL_hintgv);
6099 SV **svp = hv_fetch(table, "open_IN", 7, FALSE);
6101 const I32 mode = mode_from_discipline(*svp);
6102 if (mode & O_BINARY)
6103 o->op_private |= OPpOPEN_IN_RAW;
6104 else if (mode & O_TEXT)
6105 o->op_private |= OPpOPEN_IN_CRLF;
6108 svp = hv_fetch(table, "open_OUT", 8, FALSE);
6110 const I32 mode = mode_from_discipline(*svp);
6111 if (mode & O_BINARY)
6112 o->op_private |= OPpOPEN_OUT_RAW;
6113 else if (mode & O_TEXT)
6114 o->op_private |= OPpOPEN_OUT_CRLF;
6117 if (o->op_type == OP_BACKTICK)
6120 /* In case of three-arg dup open remove strictness
6121 * from the last arg if it is a bareword. */
6122 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
6123 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
6127 if ((last->op_type == OP_CONST) && /* The bareword. */
6128 (last->op_private & OPpCONST_BARE) &&
6129 (last->op_private & OPpCONST_STRICT) &&
6130 (oa = first->op_sibling) && /* The fh. */
6131 (oa = oa->op_sibling) && /* The mode. */
6132 (oa->op_type == OP_CONST) &&
6133 SvPOK(((SVOP*)oa)->op_sv) &&
6134 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
6135 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
6136 (last == oa->op_sibling)) /* The bareword. */
6137 last->op_private &= ~OPpCONST_STRICT;
6143 Perl_ck_repeat(pTHX_ OP *o)
6145 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6146 o->op_private |= OPpREPEAT_DOLIST;
6147 cBINOPo->op_first = force_list(cBINOPo->op_first);
6155 Perl_ck_require(pTHX_ OP *o)
6159 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6160 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6162 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6163 SV * const sv = kid->op_sv;
6164 U32 was_readonly = SvREADONLY(sv);
6169 sv_force_normal_flags(sv, 0);
6170 assert(!SvREADONLY(sv));
6177 for (s = SvPVX(sv); *s; s++) {
6178 if (*s == ':' && s[1] == ':') {
6179 const STRLEN len = strlen(s+2)+1;
6181 Move(s+2, s+1, len, char);
6182 SvCUR_set(sv, SvCUR(sv) - 1);
6185 sv_catpvs(sv, ".pm");
6186 SvFLAGS(sv) |= was_readonly;
6190 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
6191 /* handle override, if any */
6192 gv = gv_fetchpv("require", 0, SVt_PVCV);
6193 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
6194 GV * const * const gvp = (GV**)hv_fetch(PL_globalstash, "require", 7, FALSE);
6195 gv = gvp ? *gvp : Nullgv;
6199 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6200 OP * const kid = cUNOPo->op_first;
6201 cUNOPo->op_first = 0;
6203 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
6204 append_elem(OP_LIST, kid,
6205 scalar(newUNOP(OP_RV2CV, 0,
6214 Perl_ck_return(pTHX_ OP *o)
6216 if (CvLVALUE(PL_compcv)) {
6218 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6219 mod(kid, OP_LEAVESUBLV);
6225 Perl_ck_select(pTHX_ OP *o)
6229 if (o->op_flags & OPf_KIDS) {
6230 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6231 if (kid && kid->op_sibling) {
6232 o->op_type = OP_SSELECT;
6233 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6235 return fold_constants(o);
6239 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6240 if (kid && kid->op_type == OP_RV2GV)
6241 kid->op_private &= ~HINT_STRICT_REFS;
6246 Perl_ck_shift(pTHX_ OP *o)
6248 const I32 type = o->op_type;
6250 if (!(o->op_flags & OPf_KIDS)) {
6254 argop = newUNOP(OP_RV2AV, 0,
6255 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
6256 return newUNOP(type, 0, scalar(argop));
6258 return scalar(modkids(ck_fun(o), type));
6262 Perl_ck_sort(pTHX_ OP *o)
6266 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0)
6268 HV *hinthv = GvHV(PL_hintgv);
6270 SV **svp = hv_fetch(hinthv, "sort", 4, 0);
6272 I32 sorthints = (I32)SvIV(*svp);
6273 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
6274 o->op_private |= OPpSORT_QSORT;
6275 if ((sorthints & HINT_SORT_STABLE) != 0)
6276 o->op_private |= OPpSORT_STABLE;
6281 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6283 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6284 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6286 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6288 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6290 if (kid->op_type == OP_SCOPE) {
6294 else if (kid->op_type == OP_LEAVE) {
6295 if (o->op_type == OP_SORT) {
6296 op_null(kid); /* wipe out leave */
6299 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6300 if (k->op_next == kid)
6302 /* don't descend into loops */
6303 else if (k->op_type == OP_ENTERLOOP
6304 || k->op_type == OP_ENTERITER)
6306 k = cLOOPx(k)->op_lastop;
6311 kid->op_next = 0; /* just disconnect the leave */
6312 k = kLISTOP->op_first;
6317 if (o->op_type == OP_SORT) {
6318 /* provide scalar context for comparison function/block */
6324 o->op_flags |= OPf_SPECIAL;
6326 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6329 firstkid = firstkid->op_sibling;
6332 /* provide list context for arguments */
6333 if (o->op_type == OP_SORT)
6340 S_simplify_sort(pTHX_ OP *o)
6342 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6347 if (!(o->op_flags & OPf_STACKED))
6349 GvMULTI_on(gv_fetchpv("a", GV_ADD, SVt_PV));
6350 GvMULTI_on(gv_fetchpv("b", GV_ADD, SVt_PV));
6351 kid = kUNOP->op_first; /* get past null */
6352 if (kid->op_type != OP_SCOPE)
6354 kid = kLISTOP->op_last; /* get past scope */
6355 switch(kid->op_type) {
6363 k = kid; /* remember this node*/
6364 if (kBINOP->op_first->op_type != OP_RV2SV)
6366 kid = kBINOP->op_first; /* get past cmp */
6367 if (kUNOP->op_first->op_type != OP_GV)
6369 kid = kUNOP->op_first; /* get past rv2sv */
6371 if (GvSTASH(gv) != PL_curstash)
6373 gvname = GvNAME(gv);
6374 if (*gvname == 'a' && gvname[1] == '\0')
6376 else if (*gvname == 'b' && gvname[1] == '\0')
6381 kid = k; /* back to cmp */
6382 if (kBINOP->op_last->op_type != OP_RV2SV)
6384 kid = kBINOP->op_last; /* down to 2nd arg */
6385 if (kUNOP->op_first->op_type != OP_GV)
6387 kid = kUNOP->op_first; /* get past rv2sv */
6389 if (GvSTASH(gv) != PL_curstash)
6391 gvname = GvNAME(gv);
6393 ? !(*gvname == 'a' && gvname[1] == '\0')
6394 : !(*gvname == 'b' && gvname[1] == '\0'))
6396 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6398 o->op_private |= OPpSORT_DESCEND;
6399 if (k->op_type == OP_NCMP)
6400 o->op_private |= OPpSORT_NUMERIC;
6401 if (k->op_type == OP_I_NCMP)
6402 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6403 kid = cLISTOPo->op_first->op_sibling;
6404 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6405 op_free(kid); /* then delete it */
6409 Perl_ck_split(pTHX_ OP *o)
6414 if (o->op_flags & OPf_STACKED)
6415 return no_fh_allowed(o);
6417 kid = cLISTOPo->op_first;
6418 if (kid->op_type != OP_NULL)
6419 Perl_croak(aTHX_ "panic: ck_split");
6420 kid = kid->op_sibling;
6421 op_free(cLISTOPo->op_first);
6422 cLISTOPo->op_first = kid;
6424 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
6425 cLISTOPo->op_last = kid; /* There was only one element previously */
6428 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6429 OP * const sibl = kid->op_sibling;
6430 kid->op_sibling = 0;
6431 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
6432 if (cLISTOPo->op_first == cLISTOPo->op_last)
6433 cLISTOPo->op_last = kid;
6434 cLISTOPo->op_first = kid;
6435 kid->op_sibling = sibl;
6438 kid->op_type = OP_PUSHRE;
6439 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6441 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
6442 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
6443 "Use of /g modifier is meaningless in split");
6446 if (!kid->op_sibling)
6447 append_elem(OP_SPLIT, o, newDEFSVOP());
6449 kid = kid->op_sibling;
6452 if (!kid->op_sibling)
6453 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6455 kid = kid->op_sibling;
6458 if (kid->op_sibling)
6459 return too_many_arguments(o,OP_DESC(o));
6465 Perl_ck_join(pTHX_ OP *o)
6467 const OP * const kid = cLISTOPo->op_first->op_sibling;
6468 if (kid && kid->op_type == OP_MATCH) {
6469 if (ckWARN(WARN_SYNTAX)) {
6470 const REGEXP *re = PM_GETRE(kPMOP);
6471 const char *pmstr = re ? re->precomp : "STRING";
6472 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6473 "/%s/ should probably be written as \"%s\"",
6481 Perl_ck_subr(pTHX_ OP *o)
6483 OP *prev = ((cUNOPo->op_first->op_sibling)
6484 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6485 OP *o2 = prev->op_sibling;
6492 I32 contextclass = 0;
6496 o->op_private |= OPpENTERSUB_HASTARG;
6497 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6498 if (cvop->op_type == OP_RV2CV) {
6500 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6501 op_null(cvop); /* disable rv2cv */
6502 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6503 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6504 GV *gv = cGVOPx_gv(tmpop);
6507 tmpop->op_private |= OPpEARLY_CV;
6510 namegv = CvANON(cv) ? gv : CvGV(cv);
6511 proto = SvPV_nolen((SV*)cv);
6513 if (CvASSERTION(cv)) {
6514 if (PL_hints & HINT_ASSERTING) {
6515 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
6516 o->op_private |= OPpENTERSUB_DB;
6520 if (!(PL_hints & HINT_ASSERTIONSSEEN) && ckWARN(WARN_ASSERTIONS)) {
6521 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
6522 "Impossible to activate assertion call");
6529 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6530 if (o2->op_type == OP_CONST)
6531 o2->op_private &= ~OPpCONST_STRICT;
6532 else if (o2->op_type == OP_LIST) {
6533 OP * const o = ((UNOP*)o2)->op_first->op_sibling;
6534 if (o && o->op_type == OP_CONST)
6535 o->op_private &= ~OPpCONST_STRICT;
6538 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6539 if (PERLDB_SUB && PL_curstash != PL_debstash)
6540 o->op_private |= OPpENTERSUB_DB;
6541 while (o2 != cvop) {
6545 return too_many_arguments(o, gv_ename(namegv));
6563 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6565 arg == 1 ? "block or sub {}" : "sub {}",
6566 gv_ename(namegv), o2);
6569 /* '*' allows any scalar type, including bareword */
6572 if (o2->op_type == OP_RV2GV)
6573 goto wrapref; /* autoconvert GLOB -> GLOBref */
6574 else if (o2->op_type == OP_CONST)
6575 o2->op_private &= ~OPpCONST_STRICT;
6576 else if (o2->op_type == OP_ENTERSUB) {
6577 /* accidental subroutine, revert to bareword */
6578 OP *gvop = ((UNOP*)o2)->op_first;
6579 if (gvop && gvop->op_type == OP_NULL) {
6580 gvop = ((UNOP*)gvop)->op_first;
6582 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6585 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6586 (gvop = ((UNOP*)gvop)->op_first) &&
6587 gvop->op_type == OP_GV)
6589 GV * const gv = cGVOPx_gv(gvop);
6590 OP * const sibling = o2->op_sibling;
6591 SV * const n = newSVpvs("");
6593 gv_fullname4(n, gv, "", FALSE);
6594 o2 = newSVOP(OP_CONST, 0, n);
6595 prev->op_sibling = o2;
6596 o2->op_sibling = sibling;
6612 if (contextclass++ == 0) {
6613 e = strchr(proto, ']');
6614 if (!e || e == proto)
6623 /* XXX We shouldn't be modifying proto, so we can const proto */
6628 while (*--p != '[');
6629 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
6630 gv_ename(namegv), o2);
6636 if (o2->op_type == OP_RV2GV)
6639 bad_type(arg, "symbol", gv_ename(namegv), o2);
6642 if (o2->op_type == OP_ENTERSUB)
6645 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6648 if (o2->op_type == OP_RV2SV ||
6649 o2->op_type == OP_PADSV ||
6650 o2->op_type == OP_HELEM ||
6651 o2->op_type == OP_AELEM ||
6652 o2->op_type == OP_THREADSV)
6655 bad_type(arg, "scalar", gv_ename(namegv), o2);
6658 if (o2->op_type == OP_RV2AV ||
6659 o2->op_type == OP_PADAV)
6662 bad_type(arg, "array", gv_ename(namegv), o2);
6665 if (o2->op_type == OP_RV2HV ||
6666 o2->op_type == OP_PADHV)
6669 bad_type(arg, "hash", gv_ename(namegv), o2);
6674 OP* const sib = kid->op_sibling;
6675 kid->op_sibling = 0;
6676 o2 = newUNOP(OP_REFGEN, 0, kid);
6677 o2->op_sibling = sib;
6678 prev->op_sibling = o2;
6680 if (contextclass && e) {
6695 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
6696 gv_ename(namegv), cv);
6701 mod(o2, OP_ENTERSUB);
6703 o2 = o2->op_sibling;
6705 if (proto && !optional &&
6706 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6707 return too_few_arguments(o, gv_ename(namegv));
6710 o=newSVOP(OP_CONST, 0, newSViv(0));
6716 Perl_ck_svconst(pTHX_ OP *o)
6718 SvREADONLY_on(cSVOPo->op_sv);
6723 Perl_ck_trunc(pTHX_ OP *o)
6725 if (o->op_flags & OPf_KIDS) {
6726 SVOP *kid = (SVOP*)cUNOPo->op_first;
6728 if (kid->op_type == OP_NULL)
6729 kid = (SVOP*)kid->op_sibling;
6730 if (kid && kid->op_type == OP_CONST &&
6731 (kid->op_private & OPpCONST_BARE))
6733 o->op_flags |= OPf_SPECIAL;
6734 kid->op_private &= ~OPpCONST_STRICT;
6741 Perl_ck_unpack(pTHX_ OP *o)
6743 OP *kid = cLISTOPo->op_first;
6744 if (kid->op_sibling) {
6745 kid = kid->op_sibling;
6746 if (!kid->op_sibling)
6747 kid->op_sibling = newDEFSVOP();
6753 Perl_ck_substr(pTHX_ OP *o)
6756 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6757 OP *kid = cLISTOPo->op_first;
6759 if (kid->op_type == OP_NULL)
6760 kid = kid->op_sibling;
6762 kid->op_flags |= OPf_MOD;
6768 /* A peephole optimizer. We visit the ops in the order they're to execute.
6769 * See the comments at the top of this file for more details about when
6770 * peep() is called */
6773 Perl_peep(pTHX_ register OP *o)
6776 register OP* oldop = NULL;
6778 if (!o || o->op_opt)
6782 SAVEVPTR(PL_curcop);
6783 for (; o; o = o->op_next) {
6787 switch (o->op_type) {
6791 PL_curcop = ((COP*)o); /* for warnings */
6796 if (cSVOPo->op_private & OPpCONST_STRICT)
6797 no_bareword_allowed(o);
6799 case OP_METHOD_NAMED:
6800 /* Relocate sv to the pad for thread safety.
6801 * Despite being a "constant", the SV is written to,
6802 * for reference counts, sv_upgrade() etc. */
6804 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6805 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6806 /* If op_sv is already a PADTMP then it is being used by
6807 * some pad, so make a copy. */
6808 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6809 SvREADONLY_on(PAD_SVl(ix));
6810 SvREFCNT_dec(cSVOPo->op_sv);
6812 else if (o->op_type == OP_CONST
6813 && cSVOPo->op_sv == &PL_sv_undef) {
6814 /* PL_sv_undef is hack - it's unsafe to store it in the
6815 AV that is the pad, because av_fetch treats values of
6816 PL_sv_undef as a "free" AV entry and will merrily
6817 replace them with a new SV, causing pad_alloc to think
6818 that this pad slot is free. (When, clearly, it is not)
6820 SvOK_off(PAD_SVl(ix));
6821 SvPADTMP_on(PAD_SVl(ix));
6822 SvREADONLY_on(PAD_SVl(ix));
6825 SvREFCNT_dec(PAD_SVl(ix));
6826 SvPADTMP_on(cSVOPo->op_sv);
6827 PAD_SETSV(ix, cSVOPo->op_sv);
6828 /* XXX I don't know how this isn't readonly already. */
6829 SvREADONLY_on(PAD_SVl(ix));
6831 cSVOPo->op_sv = Nullsv;
6839 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6840 if (o->op_next->op_private & OPpTARGET_MY) {
6841 if (o->op_flags & OPf_STACKED) /* chained concats */
6842 goto ignore_optimization;
6844 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6845 o->op_targ = o->op_next->op_targ;
6846 o->op_next->op_targ = 0;
6847 o->op_private |= OPpTARGET_MY;
6850 op_null(o->op_next);
6852 ignore_optimization:
6856 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6858 break; /* Scalar stub must produce undef. List stub is noop */
6862 if (o->op_targ == OP_NEXTSTATE
6863 || o->op_targ == OP_DBSTATE
6864 || o->op_targ == OP_SETSTATE)
6866 PL_curcop = ((COP*)o);
6868 /* XXX: We avoid setting op_seq here to prevent later calls
6869 to peep() from mistakenly concluding that optimisation
6870 has already occurred. This doesn't fix the real problem,
6871 though (See 20010220.007). AMS 20010719 */
6872 /* op_seq functionality is now replaced by op_opt */
6873 if (oldop && o->op_next) {
6874 oldop->op_next = o->op_next;
6882 if (oldop && o->op_next) {
6883 oldop->op_next = o->op_next;
6891 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
6892 OP* const pop = (o->op_type == OP_PADAV) ?
6893 o->op_next : o->op_next->op_next;
6895 if (pop && pop->op_type == OP_CONST &&
6896 ((PL_op = pop->op_next)) &&
6897 pop->op_next->op_type == OP_AELEM &&
6898 !(pop->op_next->op_private &
6899 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6900 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6905 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
6906 no_bareword_allowed(pop);
6907 if (o->op_type == OP_GV)
6908 op_null(o->op_next);
6909 op_null(pop->op_next);
6911 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6912 o->op_next = pop->op_next->op_next;
6913 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6914 o->op_private = (U8)i;
6915 if (o->op_type == OP_GV) {
6920 o->op_flags |= OPf_SPECIAL;
6921 o->op_type = OP_AELEMFAST;
6927 if (o->op_next->op_type == OP_RV2SV) {
6928 if (!(o->op_next->op_private & OPpDEREF)) {
6929 op_null(o->op_next);
6930 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6932 o->op_next = o->op_next->op_next;
6933 o->op_type = OP_GVSV;
6934 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6937 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6938 GV * const gv = cGVOPo_gv;
6939 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
6940 /* XXX could check prototype here instead of just carping */
6941 SV * const sv = sv_newmortal();
6942 gv_efullname3(sv, gv, Nullch);
6943 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
6944 "%"SVf"() called too early to check prototype",
6948 else if (o->op_next->op_type == OP_READLINE
6949 && o->op_next->op_next->op_type == OP_CONCAT
6950 && (o->op_next->op_next->op_flags & OPf_STACKED))
6952 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6953 o->op_type = OP_RCATLINE;
6954 o->op_flags |= OPf_STACKED;
6955 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
6956 op_null(o->op_next->op_next);
6957 op_null(o->op_next);
6974 while (cLOGOP->op_other->op_type == OP_NULL)
6975 cLOGOP->op_other = cLOGOP->op_other->op_next;
6976 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
6982 while (cLOOP->op_redoop->op_type == OP_NULL)
6983 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6984 peep(cLOOP->op_redoop);
6985 while (cLOOP->op_nextop->op_type == OP_NULL)
6986 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6987 peep(cLOOP->op_nextop);
6988 while (cLOOP->op_lastop->op_type == OP_NULL)
6989 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6990 peep(cLOOP->op_lastop);
6997 while (cPMOP->op_pmreplstart &&
6998 cPMOP->op_pmreplstart->op_type == OP_NULL)
6999 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
7000 peep(cPMOP->op_pmreplstart);
7005 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
7006 && ckWARN(WARN_SYNTAX))
7008 if (o->op_next->op_sibling &&
7009 o->op_next->op_sibling->op_type != OP_EXIT &&
7010 o->op_next->op_sibling->op_type != OP_WARN &&
7011 o->op_next->op_sibling->op_type != OP_DIE) {
7012 const line_t oldline = CopLINE(PL_curcop);
7014 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
7015 Perl_warner(aTHX_ packWARN(WARN_EXEC),
7016 "Statement unlikely to be reached");
7017 Perl_warner(aTHX_ packWARN(WARN_EXEC),
7018 "\t(Maybe you meant system() when you said exec()?)\n");
7019 CopLINE_set(PL_curcop, oldline);
7029 const char *key = NULL;
7034 if (((BINOP*)o)->op_last->op_type != OP_CONST)
7037 /* Make the CONST have a shared SV */
7038 svp = cSVOPx_svp(((BINOP*)o)->op_last);
7039 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
7040 key = SvPV_const(sv, keylen);
7041 lexname = newSVpvn_share(key,
7042 SvUTF8(sv) ? -(I32)keylen : keylen,
7048 if ((o->op_private & (OPpLVAL_INTRO)))
7051 rop = (UNOP*)((BINOP*)o)->op_first;
7052 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7054 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7055 if (!(SvFLAGS(lexname) & SVpad_TYPED))
7057 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
7058 if (!fields || !GvHV(*fields))
7060 key = SvPV_const(*svp, keylen);
7061 if (!hv_fetch(GvHV(*fields), key,
7062 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
7064 Perl_croak(aTHX_ "No such class field \"%s\" "
7065 "in variable %s of type %s",
7066 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
7079 SVOP *first_key_op, *key_op;
7081 if ((o->op_private & (OPpLVAL_INTRO))
7082 /* I bet there's always a pushmark... */
7083 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
7084 /* hmmm, no optimization if list contains only one key. */
7086 rop = (UNOP*)((LISTOP*)o)->op_last;
7087 if (rop->op_type != OP_RV2HV)
7089 if (rop->op_first->op_type == OP_PADSV)
7090 /* @$hash{qw(keys here)} */
7091 rop = (UNOP*)rop->op_first;
7093 /* @{$hash}{qw(keys here)} */
7094 if (rop->op_first->op_type == OP_SCOPE
7095 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
7097 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
7103 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
7104 if (!(SvFLAGS(lexname) & SVpad_TYPED))
7106 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
7107 if (!fields || !GvHV(*fields))
7109 /* Again guessing that the pushmark can be jumped over.... */
7110 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
7111 ->op_first->op_sibling;
7112 for (key_op = first_key_op; key_op;
7113 key_op = (SVOP*)key_op->op_sibling) {
7114 if (key_op->op_type != OP_CONST)
7116 svp = cSVOPx_svp(key_op);
7117 key = SvPV_const(*svp, keylen);
7118 if (!hv_fetch(GvHV(*fields), key,
7119 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
7121 Perl_croak(aTHX_ "No such class field \"%s\" "
7122 "in variable %s of type %s",
7123 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
7130 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
7134 /* check that RHS of sort is a single plain array */
7135 OP *oright = cUNOPo->op_first;
7136 if (!oright || oright->op_type != OP_PUSHMARK)
7139 /* reverse sort ... can be optimised. */
7140 if (!cUNOPo->op_sibling) {
7141 /* Nothing follows us on the list. */
7142 OP * const reverse = o->op_next;
7144 if (reverse->op_type == OP_REVERSE &&
7145 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
7146 OP * const pushmark = cUNOPx(reverse)->op_first;
7147 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
7148 && (cUNOPx(pushmark)->op_sibling == o)) {
7149 /* reverse -> pushmark -> sort */
7150 o->op_private |= OPpSORT_REVERSE;
7152 pushmark->op_next = oright->op_next;
7158 /* make @a = sort @a act in-place */
7162 oright = cUNOPx(oright)->op_sibling;
7165 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
7166 oright = cUNOPx(oright)->op_sibling;
7170 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
7171 || oright->op_next != o
7172 || (oright->op_private & OPpLVAL_INTRO)
7176 /* o2 follows the chain of op_nexts through the LHS of the
7177 * assign (if any) to the aassign op itself */
7179 if (!o2 || o2->op_type != OP_NULL)
7182 if (!o2 || o2->op_type != OP_PUSHMARK)
7185 if (o2 && o2->op_type == OP_GV)
7188 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
7189 || (o2->op_private & OPpLVAL_INTRO)
7194 if (!o2 || o2->op_type != OP_NULL)
7197 if (!o2 || o2->op_type != OP_AASSIGN
7198 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
7201 /* check that the sort is the first arg on RHS of assign */
7203 o2 = cUNOPx(o2)->op_first;
7204 if (!o2 || o2->op_type != OP_NULL)
7206 o2 = cUNOPx(o2)->op_first;
7207 if (!o2 || o2->op_type != OP_PUSHMARK)
7209 if (o2->op_sibling != o)
7212 /* check the array is the same on both sides */
7213 if (oleft->op_type == OP_RV2AV) {
7214 if (oright->op_type != OP_RV2AV
7215 || !cUNOPx(oright)->op_first
7216 || cUNOPx(oright)->op_first->op_type != OP_GV
7217 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
7218 cGVOPx_gv(cUNOPx(oright)->op_first)
7222 else if (oright->op_type != OP_PADAV
7223 || oright->op_targ != oleft->op_targ
7227 /* transfer MODishness etc from LHS arg to RHS arg */
7228 oright->op_flags = oleft->op_flags;
7229 o->op_private |= OPpSORT_INPLACE;
7231 /* excise push->gv->rv2av->null->aassign */
7232 o2 = o->op_next->op_next;
7233 op_null(o2); /* PUSHMARK */
7235 if (o2->op_type == OP_GV) {
7236 op_null(o2); /* GV */
7239 op_null(o2); /* RV2AV or PADAV */
7240 o2 = o2->op_next->op_next;
7241 op_null(o2); /* AASSIGN */
7243 o->op_next = o2->op_next;
7249 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
7251 LISTOP *enter, *exlist;
7254 enter = (LISTOP *) o->op_next;
7257 if (enter->op_type == OP_NULL) {
7258 enter = (LISTOP *) enter->op_next;
7262 /* for $a (...) will have OP_GV then OP_RV2GV here.
7263 for (...) just has an OP_GV. */
7264 if (enter->op_type == OP_GV) {
7265 gvop = (OP *) enter;
7266 enter = (LISTOP *) enter->op_next;
7269 if (enter->op_type == OP_RV2GV) {
7270 enter = (LISTOP *) enter->op_next;
7276 if (enter->op_type != OP_ENTERITER)
7279 iter = enter->op_next;
7280 if (!iter || iter->op_type != OP_ITER)
7283 expushmark = enter->op_first;
7284 if (!expushmark || expushmark->op_type != OP_NULL
7285 || expushmark->op_targ != OP_PUSHMARK)
7288 exlist = (LISTOP *) expushmark->op_sibling;
7289 if (!exlist || exlist->op_type != OP_NULL
7290 || exlist->op_targ != OP_LIST)
7293 if (exlist->op_last != o) {
7294 /* Mmm. Was expecting to point back to this op. */
7297 theirmark = exlist->op_first;
7298 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
7301 if (theirmark->op_sibling != o) {
7302 /* There's something between the mark and the reverse, eg
7303 for (1, reverse (...))
7308 ourmark = ((LISTOP *)o)->op_first;
7309 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
7312 ourlast = ((LISTOP *)o)->op_last;
7313 if (!ourlast || ourlast->op_next != o)
7316 rv2av = ourmark->op_sibling;
7317 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
7318 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
7319 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
7320 /* We're just reversing a single array. */
7321 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
7322 enter->op_flags |= OPf_STACKED;
7325 /* We don't have control over who points to theirmark, so sacrifice
7327 theirmark->op_next = ourmark->op_next;
7328 theirmark->op_flags = ourmark->op_flags;
7329 ourlast->op_next = gvop ? gvop : (OP *) enter;
7332 enter->op_private |= OPpITER_REVERSED;
7333 iter->op_private |= OPpITER_REVERSED;
7340 UNOP *refgen, *rv2cv;
7343 /* I do not understand this, but if o->op_opt isn't set to 1,
7344 various tests in ext/B/t/bytecode.t fail with no readily
7350 if ((o->op_flags && OPf_WANT) != OPf_WANT_VOID)
7353 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
7356 rv2gv = ((BINOP *)o)->op_last;
7357 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
7360 refgen = (UNOP *)((BINOP *)o)->op_first;
7362 if (!refgen || refgen->op_type != OP_REFGEN)
7365 exlist = (LISTOP *)refgen->op_first;
7366 if (!exlist || exlist->op_type != OP_NULL
7367 || exlist->op_targ != OP_LIST)
7370 if (exlist->op_first->op_type != OP_PUSHMARK)
7373 rv2cv = (UNOP*)exlist->op_last;
7375 if (rv2cv->op_type != OP_RV2CV)
7378 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
7379 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
7380 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
7382 o->op_private |= OPpASSIGN_CV_TO_GV;
7383 rv2gv->op_private |= OPpDONT_INIT_GV;
7384 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
7400 Perl_custom_op_name(pTHX_ const OP* o)
7402 const IV index = PTR2IV(o->op_ppaddr);
7406 if (!PL_custom_op_names) /* This probably shouldn't happen */
7407 return (char *)PL_op_name[OP_CUSTOM];
7409 keysv = sv_2mortal(newSViv(index));
7411 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
7413 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
7415 return SvPV_nolen(HeVAL(he));
7419 Perl_custom_op_desc(pTHX_ const OP* o)
7421 const IV index = PTR2IV(o->op_ppaddr);
7425 if (!PL_custom_op_descs)
7426 return (char *)PL_op_desc[OP_CUSTOM];
7428 keysv = sv_2mortal(newSViv(index));
7430 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
7432 return (char *)PL_op_desc[OP_CUSTOM];
7434 return SvPV_nolen(HeVAL(he));
7439 /* Efficient sub that returns a constant scalar value. */
7441 const_sv_xsub(pTHX_ CV* cv)
7446 Perl_croak(aTHX_ "usage: %s::%s()",
7447 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7451 ST(0) = (SV*)XSANY.any_ptr;
7457 * c-indentation-style: bsd
7459 * indent-tabs-mode: t
7462 * ex: set ts=8 sts=4 sw=4 noet: