3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * "You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
13 * our Mr. Bilbo's first cousin on the mother's side (her mother being the
14 * youngest of the Old Took's daughters); and Mr. Drogo was his second
15 * cousin. So Mr. Frodo is his first *and* second cousin, once removed
16 * either way, as the saying is, if you follow me." --the Gaffer
19 /* This file contains the functions that create, manipulate and optimize
20 * the OP structures that hold a compiled perl program.
22 * A Perl program is compiled into a tree of OPs. Each op contains
23 * structural pointers (eg to its siblings and the next op in the
24 * execution sequence), a pointer to the function that would execute the
25 * op, plus any data specific to that op. For example, an OP_CONST op
26 * points to the pp_const() function and to an SV containing the constant
27 * value. When pp_const() is executed, its job is to push that SV onto the
30 * OPs are mainly created by the newFOO() functions, which are mainly
31 * called from the parser (in perly.y) as the code is parsed. For example
32 * the Perl code $a + $b * $c would cause the equivalent of the following
33 * to be called (oversimplifying a bit):
35 * newBINOP(OP_ADD, flags,
37 * newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
40 * Note that during the build of miniperl, a temporary copy of this file
41 * is made, called opmini.c.
45 Perl's compiler is essentially a 3-pass compiler with interleaved phases:
49 An execution-order pass
51 The bottom-up pass is represented by all the "newOP" routines and
52 the ck_ routines. The bottom-upness is actually driven by yacc.
53 So at the point that a ck_ routine fires, we have no idea what the
54 context is, either upward in the syntax tree, or either forward or
55 backward in the execution order. (The bottom-up parser builds that
56 part of the execution order it knows about, but if you follow the "next"
57 links around, you'll find it's actually a closed loop through the
60 Whenever the bottom-up parser gets to a node that supplies context to
61 its components, it invokes that portion of the top-down pass that applies
62 to that part of the subtree (and marks the top node as processed, so
63 if a node further up supplies context, it doesn't have to take the
64 plunge again). As a particular subcase of this, as the new node is
65 built, it takes all the closed execution loops of its subcomponents
66 and links them into a new closed loop for the higher level node. But
67 it's still not the real execution order.
69 The actual execution order is not known till we get a grammar reduction
70 to a top-level unit like a subroutine or file that will be called by
71 "name" rather than via a "next" pointer. At that point, we can call
72 into peep() to do that code's portion of the 3rd pass. It has to be
73 recursive, but it's recursive on basic blocks, not on tree nodes.
81 #define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
83 #if defined(PL_OP_SLAB_ALLOC)
85 #ifndef PERL_SLAB_SIZE
86 #define PERL_SLAB_SIZE 2048
90 Perl_Slab_Alloc(pTHX_ int m, size_t sz)
93 * To make incrementing use count easy PL_OpSlab is an I32 *
94 * To make inserting the link to slab PL_OpPtr is I32 **
95 * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
96 * Add an overhead for pointer to slab and round up as a number of pointers
98 sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
99 if ((PL_OpSpace -= sz) < 0) {
100 PL_OpPtr = (I32 **) PerlMemShared_malloc(PERL_SLAB_SIZE*sizeof(I32*));
104 Zero(PL_OpPtr,PERL_SLAB_SIZE,I32 **);
105 /* We reserve the 0'th I32 sized chunk as a use count */
106 PL_OpSlab = (I32 *) PL_OpPtr;
107 /* Reduce size by the use count word, and by the size we need.
108 * Latter is to mimic the '-=' in the if() above
110 PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
111 /* Allocation pointer starts at the top.
112 Theory: because we build leaves before trunk allocating at end
113 means that at run time access is cache friendly upward
115 PL_OpPtr += PERL_SLAB_SIZE;
117 assert( PL_OpSpace >= 0 );
118 /* Move the allocation pointer down */
120 assert( PL_OpPtr > (I32 **) PL_OpSlab );
121 *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */
122 (*PL_OpSlab)++; /* Increment use count of slab */
123 assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
124 assert( *PL_OpSlab > 0 );
125 return (void *)(PL_OpPtr + 1);
129 Perl_Slab_Free(pTHX_ void *op)
131 I32 * const * const ptr = (I32 **) op;
132 I32 * const slab = ptr[-1];
133 assert( ptr-1 > (I32 **) slab );
134 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
136 if (--(*slab) == 0) {
138 # define PerlMemShared PerlMem
141 PerlMemShared_free(slab);
142 if (slab == PL_OpSlab) {
149 * In the following definition, the ", Nullop" is just to make the compiler
150 * think the expression is of the right type: croak actually does a Siglongjmp.
152 #define CHECKOP(type,o) \
153 ((PL_op_mask && PL_op_mask[type]) \
154 ? ( op_free((OP*)o), \
155 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
157 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
159 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
162 S_gv_ename(pTHX_ GV *gv)
164 SV* const tmpsv = sv_newmortal();
165 gv_efullname3(tmpsv, gv, Nullch);
166 return SvPV_nolen_const(tmpsv);
170 S_no_fh_allowed(pTHX_ OP *o)
172 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
178 S_too_few_arguments(pTHX_ OP *o, const char *name)
180 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
185 S_too_many_arguments(pTHX_ OP *o, const char *name)
187 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
192 S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid)
194 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
195 (int)n, name, t, OP_DESC(kid)));
199 S_no_bareword_allowed(pTHX_ const OP *o)
201 qerror(Perl_mess(aTHX_
202 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
206 /* "register" allocation */
209 Perl_allocmy(pTHX_ char *name)
213 /* complain about "my $<special_var>" etc etc */
215 !(PL_in_my == KEY_our ||
217 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
218 (name[1] == '_' && (*name == '$' || name[2]))))
220 /* name[2] is true if strlen(name) > 2 */
221 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
222 /* 1999-02-27 mjd@plover.com */
224 p = strchr(name, '\0');
225 /* The next block assumes the buffer is at least 205 chars
226 long. At present, it's always at least 256 chars. */
228 strcpy(name+200, "...");
234 /* Move everything else down one character */
235 for (; p-name > 2; p--)
237 name[2] = toCTRL(name[1]);
240 yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
243 /* check for duplicate declaration */
245 (bool)(PL_in_my == KEY_our),
246 (PL_curstash ? PL_curstash : PL_defstash)
249 if (PL_in_my_stash && *name != '$') {
250 yyerror(Perl_form(aTHX_
251 "Can't declare class for non-scalar %s in \"%s\"",
252 name, PL_in_my == KEY_our ? "our" : "my"));
255 /* allocate a spare slot and store the name in that slot */
257 off = pad_add_name(name,
260 /* $_ is always in main::, even with our */
261 ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
272 Perl_op_free(pTHX_ OP *o)
278 if (!o || o->op_static)
281 if (o->op_private & OPpREFCOUNTED) {
282 switch (o->op_type) {
290 refcnt = OpREFCNT_dec(o);
300 if (o->op_flags & OPf_KIDS) {
301 register OP *kid, *nextkid;
302 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
303 nextkid = kid->op_sibling; /* Get before next freeing kid */
309 type = (OPCODE)o->op_targ;
311 /* COP* is not cleared by op_clear() so that we may track line
312 * numbers etc even after null() */
313 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
318 #ifdef DEBUG_LEAKING_SCALARS
325 Perl_op_clear(pTHX_ OP *o)
329 switch (o->op_type) {
330 case OP_NULL: /* Was holding old type, if any. */
331 case OP_ENTEREVAL: /* Was holding hints. */
335 if (!(o->op_flags & OPf_REF)
336 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
342 if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
343 /* not an OP_PADAV replacement */
345 if (cPADOPo->op_padix > 0) {
346 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
347 * may still exist on the pad */
348 pad_swipe(cPADOPo->op_padix, TRUE);
349 cPADOPo->op_padix = 0;
352 SvREFCNT_dec(cSVOPo->op_sv);
353 cSVOPo->op_sv = Nullsv;
357 case OP_METHOD_NAMED:
359 SvREFCNT_dec(cSVOPo->op_sv);
360 cSVOPo->op_sv = Nullsv;
363 Even if op_clear does a pad_free for the target of the op,
364 pad_free doesn't actually remove the sv that exists in the pad;
365 instead it lives on. This results in that it could be reused as
366 a target later on when the pad was reallocated.
369 pad_swipe(o->op_targ,1);
378 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
382 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
383 SvREFCNT_dec(cSVOPo->op_sv);
384 cSVOPo->op_sv = Nullsv;
387 Safefree(cPVOPo->op_pv);
388 cPVOPo->op_pv = Nullch;
392 op_free(cPMOPo->op_pmreplroot);
396 if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) {
397 /* No GvIN_PAD_off here, because other references may still
398 * exist on the pad */
399 pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot), TRUE);
402 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
409 HV * const pmstash = PmopSTASH(cPMOPo);
410 if (pmstash && !SvIS_FREED(pmstash)) {
411 MAGIC * const mg = mg_find((SV*)pmstash, PERL_MAGIC_symtab);
413 PMOP *pmop = (PMOP*) mg->mg_obj;
414 PMOP *lastpmop = NULL;
416 if (cPMOPo == pmop) {
418 lastpmop->op_pmnext = pmop->op_pmnext;
420 mg->mg_obj = (SV*) pmop->op_pmnext;
424 pmop = pmop->op_pmnext;
428 PmopSTASH_free(cPMOPo);
430 cPMOPo->op_pmreplroot = Nullop;
431 /* we use the "SAFE" version of the PM_ macros here
432 * since sv_clean_all might release some PMOPs
433 * after PL_regex_padav has been cleared
434 * and the clearing of PL_regex_padav needs to
435 * happen before sv_clean_all
437 ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
438 PM_SETRE_SAFE(cPMOPo, (REGEXP*)NULL);
440 if(PL_regex_pad) { /* We could be in destruction */
441 av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
442 SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
443 PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
450 if (o->op_targ > 0) {
451 pad_free(o->op_targ);
457 S_cop_free(pTHX_ COP* cop)
459 Safefree(cop->cop_label); /* FIXME: treaddead ??? */
462 if (! specialWARN(cop->cop_warnings))
463 SvREFCNT_dec(cop->cop_warnings);
464 if (! specialCopIO(cop->cop_io)) {
468 char *s = SvPV(cop->cop_io,len);
469 Perl_warn(aTHX_ "io='%.*s'",(int) len,s); /* ??? --jhi */
472 SvREFCNT_dec(cop->cop_io);
478 Perl_op_null(pTHX_ OP *o)
481 if (o->op_type == OP_NULL)
484 o->op_targ = o->op_type;
485 o->op_type = OP_NULL;
486 o->op_ppaddr = PL_ppaddr[OP_NULL];
490 Perl_op_refcnt_lock(pTHX)
497 Perl_op_refcnt_unlock(pTHX)
503 /* Contextualizers */
505 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
508 Perl_linklist(pTHX_ OP *o)
514 /* establish postfix order */
515 if (cUNOPo->op_first) {
517 o->op_next = LINKLIST(cUNOPo->op_first);
518 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
520 kid->op_next = LINKLIST(kid->op_sibling);
532 Perl_scalarkids(pTHX_ OP *o)
534 if (o && o->op_flags & OPf_KIDS) {
536 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
543 S_scalarboolean(pTHX_ OP *o)
545 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
546 if (ckWARN(WARN_SYNTAX)) {
547 const line_t oldline = CopLINE(PL_curcop);
549 if (PL_copline != NOLINE)
550 CopLINE_set(PL_curcop, PL_copline);
551 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
552 CopLINE_set(PL_curcop, oldline);
559 Perl_scalar(pTHX_ OP *o)
564 /* assumes no premature commitment */
565 if (!o || PL_error_count || (o->op_flags & OPf_WANT)
566 || o->op_type == OP_RETURN)
571 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
573 switch (o->op_type) {
575 scalar(cBINOPo->op_first);
580 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
584 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
585 if (!kPMOP->op_pmreplroot)
586 deprecate_old("implicit split to @_");
594 if (o->op_flags & OPf_KIDS) {
595 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
601 kid = cLISTOPo->op_first;
603 while ((kid = kid->op_sibling)) {
609 WITH_THR(PL_curcop = &PL_compiling);
614 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
620 WITH_THR(PL_curcop = &PL_compiling);
623 if (ckWARN(WARN_VOID))
624 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
630 Perl_scalarvoid(pTHX_ OP *o)
634 const char* useless = 0;
638 if (o->op_type == OP_NEXTSTATE
639 || o->op_type == OP_SETSTATE
640 || o->op_type == OP_DBSTATE
641 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
642 || o->op_targ == OP_SETSTATE
643 || o->op_targ == OP_DBSTATE)))
644 PL_curcop = (COP*)o; /* for warning below */
646 /* assumes no premature commitment */
647 want = o->op_flags & OPf_WANT;
648 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
649 || o->op_type == OP_RETURN)
654 if ((o->op_private & OPpTARGET_MY)
655 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
657 return scalar(o); /* As if inside SASSIGN */
660 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
662 switch (o->op_type) {
664 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
668 if (o->op_flags & OPf_STACKED)
672 if (o->op_private == 4)
744 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
745 useless = OP_DESC(o);
749 kid = cUNOPo->op_first;
750 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
751 kid->op_type != OP_TRANS) {
754 useless = "negative pattern binding (!~)";
761 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
762 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
763 useless = "a variable";
768 if (cSVOPo->op_private & OPpCONST_STRICT)
769 no_bareword_allowed(o);
771 if (ckWARN(WARN_VOID)) {
772 useless = "a constant";
773 /* don't warn on optimised away booleans, eg
774 * use constant Foo, 5; Foo || print; */
775 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
777 /* the constants 0 and 1 are permitted as they are
778 conventionally used as dummies in constructs like
779 1 while some_condition_with_side_effects; */
780 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
782 else if (SvPOK(sv)) {
783 /* perl4's way of mixing documentation and code
784 (before the invention of POD) was based on a
785 trick to mix nroff and perl code. The trick was
786 built upon these three nroff macros being used in
787 void context. The pink camel has the details in
788 the script wrapman near page 319. */
789 if (strnEQ(SvPVX_const(sv), "di", 2) ||
790 strnEQ(SvPVX_const(sv), "ds", 2) ||
791 strnEQ(SvPVX_const(sv), "ig", 2))
796 op_null(o); /* don't execute or even remember it */
800 o->op_type = OP_PREINC; /* pre-increment is faster */
801 o->op_ppaddr = PL_ppaddr[OP_PREINC];
805 o->op_type = OP_PREDEC; /* pre-decrement is faster */
806 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
810 o->op_type = OP_I_PREINC; /* pre-increment is faster */
811 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
815 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
816 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
825 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
830 if (o->op_flags & OPf_STACKED)
837 if (!(o->op_flags & OPf_KIDS))
848 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
855 /* all requires must return a boolean value */
856 o->op_flags &= ~OPf_WANT;
861 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
862 if (!kPMOP->op_pmreplroot)
863 deprecate_old("implicit split to @_");
867 if (useless && ckWARN(WARN_VOID))
868 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
873 Perl_listkids(pTHX_ OP *o)
875 if (o && o->op_flags & OPf_KIDS) {
877 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
884 Perl_list(pTHX_ OP *o)
889 /* assumes no premature commitment */
890 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
891 || o->op_type == OP_RETURN)
896 if ((o->op_private & OPpTARGET_MY)
897 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
899 return o; /* As if inside SASSIGN */
902 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
904 switch (o->op_type) {
907 list(cBINOPo->op_first);
912 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
920 if (!(o->op_flags & OPf_KIDS))
922 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
923 list(cBINOPo->op_first);
924 return gen_constant_list(o);
931 kid = cLISTOPo->op_first;
933 while ((kid = kid->op_sibling)) {
939 WITH_THR(PL_curcop = &PL_compiling);
943 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
949 WITH_THR(PL_curcop = &PL_compiling);
952 /* all requires must return a boolean value */
953 o->op_flags &= ~OPf_WANT;
960 Perl_scalarseq(pTHX_ OP *o)
963 if (o->op_type == OP_LINESEQ ||
964 o->op_type == OP_SCOPE ||
965 o->op_type == OP_LEAVE ||
966 o->op_type == OP_LEAVETRY)
969 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
970 if (kid->op_sibling) {
974 PL_curcop = &PL_compiling;
976 o->op_flags &= ~OPf_PARENS;
977 if (PL_hints & HINT_BLOCK_SCOPE)
978 o->op_flags |= OPf_PARENS;
981 o = newOP(OP_STUB, 0);
986 S_modkids(pTHX_ OP *o, I32 type)
988 if (o && o->op_flags & OPf_KIDS) {
990 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
996 /* Propagate lvalue ("modifiable") context to an op and its children.
997 * 'type' represents the context type, roughly based on the type of op that
998 * would do the modifying, although local() is represented by OP_NULL.
999 * It's responsible for detecting things that can't be modified, flag
1000 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
1001 * might have to vivify a reference in $x), and so on.
1003 * For example, "$a+1 = 2" would cause mod() to be called with o being
1004 * OP_ADD and type being OP_SASSIGN, and would output an error.
1008 Perl_mod(pTHX_ OP *o, I32 type)
1012 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1015 if (!o || PL_error_count)
1018 if ((o->op_private & OPpTARGET_MY)
1019 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1024 switch (o->op_type) {
1030 if (!(o->op_private & (OPpCONST_ARYBASE)))
1032 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1033 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
1037 SAVEI32(PL_compiling.cop_arybase);
1038 PL_compiling.cop_arybase = 0;
1040 else if (type == OP_REFGEN)
1043 Perl_croak(aTHX_ "That use of $[ is unsupported");
1046 if (o->op_flags & OPf_PARENS)
1050 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1051 !(o->op_flags & OPf_STACKED)) {
1052 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1053 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1054 assert(cUNOPo->op_first->op_type == OP_NULL);
1055 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1058 else if (o->op_private & OPpENTERSUB_NOMOD)
1060 else { /* lvalue subroutine call */
1061 o->op_private |= OPpLVAL_INTRO;
1062 PL_modcount = RETURN_UNLIMITED_NUMBER;
1063 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1064 /* Backward compatibility mode: */
1065 o->op_private |= OPpENTERSUB_INARGS;
1068 else { /* Compile-time error message: */
1069 OP *kid = cUNOPo->op_first;
1073 if (kid->op_type == OP_PUSHMARK)
1075 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1077 "panic: unexpected lvalue entersub "
1078 "args: type/targ %ld:%"UVuf,
1079 (long)kid->op_type, (UV)kid->op_targ);
1080 kid = kLISTOP->op_first;
1082 while (kid->op_sibling)
1083 kid = kid->op_sibling;
1084 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1086 if (kid->op_type == OP_METHOD_NAMED
1087 || kid->op_type == OP_METHOD)
1091 NewOp(1101, newop, 1, UNOP);
1092 newop->op_type = OP_RV2CV;
1093 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1094 newop->op_first = Nullop;
1095 newop->op_next = (OP*)newop;
1096 kid->op_sibling = (OP*)newop;
1097 newop->op_private |= OPpLVAL_INTRO;
1101 if (kid->op_type != OP_RV2CV)
1103 "panic: unexpected lvalue entersub "
1104 "entry via type/targ %ld:%"UVuf,
1105 (long)kid->op_type, (UV)kid->op_targ);
1106 kid->op_private |= OPpLVAL_INTRO;
1107 break; /* Postpone until runtime */
1111 kid = kUNOP->op_first;
1112 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1113 kid = kUNOP->op_first;
1114 if (kid->op_type == OP_NULL)
1116 "Unexpected constant lvalue entersub "
1117 "entry via type/targ %ld:%"UVuf,
1118 (long)kid->op_type, (UV)kid->op_targ);
1119 if (kid->op_type != OP_GV) {
1120 /* Restore RV2CV to check lvalueness */
1122 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1123 okid->op_next = kid->op_next;
1124 kid->op_next = okid;
1127 okid->op_next = Nullop;
1128 okid->op_type = OP_RV2CV;
1130 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1131 okid->op_private |= OPpLVAL_INTRO;
1135 cv = GvCV(kGVOP_gv);
1145 /* grep, foreach, subcalls, refgen, m//g */
1146 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN
1147 || type == OP_MATCH)
1149 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1150 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1152 : (o->op_type == OP_ENTERSUB
1153 ? "non-lvalue subroutine call"
1155 type ? PL_op_desc[type] : "local"));
1169 case OP_RIGHT_SHIFT:
1178 if (!(o->op_flags & OPf_STACKED))
1185 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1191 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1192 PL_modcount = RETURN_UNLIMITED_NUMBER;
1193 return o; /* Treat \(@foo) like ordinary list. */
1197 if (scalar_mod_type(o, type))
1199 ref(cUNOPo->op_first, o->op_type);
1203 if (type == OP_LEAVESUBLV)
1204 o->op_private |= OPpMAYBE_LVSUB;
1210 PL_modcount = RETURN_UNLIMITED_NUMBER;
1213 ref(cUNOPo->op_first, o->op_type);
1218 PL_hints |= HINT_BLOCK_SCOPE;
1233 PL_modcount = RETURN_UNLIMITED_NUMBER;
1234 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1235 return o; /* Treat \(@foo) like ordinary list. */
1236 if (scalar_mod_type(o, type))
1238 if (type == OP_LEAVESUBLV)
1239 o->op_private |= OPpMAYBE_LVSUB;
1243 if (!type) /* local() */
1244 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1245 PAD_COMPNAME_PV(o->op_targ));
1253 if (type != OP_SASSIGN)
1257 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1262 if (type == OP_LEAVESUBLV)
1263 o->op_private |= OPpMAYBE_LVSUB;
1265 pad_free(o->op_targ);
1266 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1267 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1268 if (o->op_flags & OPf_KIDS)
1269 mod(cBINOPo->op_first->op_sibling, type);
1274 ref(cBINOPo->op_first, o->op_type);
1275 if (type == OP_ENTERSUB &&
1276 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1277 o->op_private |= OPpLVAL_DEFER;
1278 if (type == OP_LEAVESUBLV)
1279 o->op_private |= OPpMAYBE_LVSUB;
1289 if (o->op_flags & OPf_KIDS)
1290 mod(cLISTOPo->op_last, type);
1295 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1297 else if (!(o->op_flags & OPf_KIDS))
1299 if (o->op_targ != OP_LIST) {
1300 mod(cBINOPo->op_first, type);
1306 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1311 if (type != OP_LEAVESUBLV)
1313 break; /* mod()ing was handled by ck_return() */
1316 /* [20011101.069] File test operators interpret OPf_REF to mean that
1317 their argument is a filehandle; thus \stat(".") should not set
1319 if (type == OP_REFGEN &&
1320 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1323 if (type != OP_LEAVESUBLV)
1324 o->op_flags |= OPf_MOD;
1326 if (type == OP_AASSIGN || type == OP_SASSIGN)
1327 o->op_flags |= OPf_SPECIAL|OPf_REF;
1328 else if (!type) { /* local() */
1331 o->op_private |= OPpLVAL_INTRO;
1332 o->op_flags &= ~OPf_SPECIAL;
1333 PL_hints |= HINT_BLOCK_SCOPE;
1338 if (ckWARN(WARN_SYNTAX)) {
1339 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1340 "Useless localization of %s", OP_DESC(o));
1344 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1345 && type != OP_LEAVESUBLV)
1346 o->op_flags |= OPf_REF;
1351 S_scalar_mod_type(pTHX_ const OP *o, I32 type)
1355 if (o->op_type == OP_RV2GV)
1379 case OP_RIGHT_SHIFT:
1398 S_is_handle_constructor(pTHX_ const OP *o, I32 numargs)
1400 switch (o->op_type) {
1408 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1421 Perl_refkids(pTHX_ OP *o, I32 type)
1423 if (o && o->op_flags & OPf_KIDS) {
1425 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1432 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
1437 if (!o || PL_error_count)
1440 switch (o->op_type) {
1442 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1443 !(o->op_flags & OPf_STACKED)) {
1444 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1445 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1446 assert(cUNOPo->op_first->op_type == OP_NULL);
1447 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1448 o->op_flags |= OPf_SPECIAL;
1453 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1454 doref(kid, type, set_op_ref);
1457 if (type == OP_DEFINED)
1458 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1459 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1462 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1463 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1464 : type == OP_RV2HV ? OPpDEREF_HV
1466 o->op_flags |= OPf_MOD;
1471 o->op_flags |= OPf_MOD; /* XXX ??? */
1477 o->op_flags |= OPf_REF;
1480 if (type == OP_DEFINED)
1481 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1482 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1488 o->op_flags |= OPf_REF;
1493 if (!(o->op_flags & OPf_KIDS))
1495 doref(cBINOPo->op_first, type, set_op_ref);
1499 doref(cBINOPo->op_first, o->op_type, set_op_ref);
1500 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1501 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1502 : type == OP_RV2HV ? OPpDEREF_HV
1504 o->op_flags |= OPf_MOD;
1514 if (!(o->op_flags & OPf_KIDS))
1516 doref(cLISTOPo->op_last, type, set_op_ref);
1526 S_dup_attrlist(pTHX_ OP *o)
1530 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1531 * where the first kid is OP_PUSHMARK and the remaining ones
1532 * are OP_CONST. We need to push the OP_CONST values.
1534 if (o->op_type == OP_CONST)
1535 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1537 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1539 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1540 if (o->op_type == OP_CONST)
1541 rop = append_elem(OP_LIST, rop,
1542 newSVOP(OP_CONST, o->op_flags,
1543 SvREFCNT_inc(cSVOPo->op_sv)));
1550 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1555 /* fake up C<use attributes $pkg,$rv,@attrs> */
1556 ENTER; /* need to protect against side-effects of 'use' */
1558 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1560 #define ATTRSMODULE "attributes"
1561 #define ATTRSMODULE_PM "attributes.pm"
1564 /* Don't force the C<use> if we don't need it. */
1565 SV * const * const svp = hv_fetch(GvHVn(PL_incgv), ATTRSMODULE_PM,
1566 sizeof(ATTRSMODULE_PM)-1, 0);
1567 if (svp && *svp != &PL_sv_undef)
1568 ; /* already in %INC */
1570 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1571 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1575 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1576 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1578 prepend_elem(OP_LIST,
1579 newSVOP(OP_CONST, 0, stashsv),
1580 prepend_elem(OP_LIST,
1581 newSVOP(OP_CONST, 0,
1583 dup_attrlist(attrs))));
1589 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1591 OP *pack, *imop, *arg;
1597 assert(target->op_type == OP_PADSV ||
1598 target->op_type == OP_PADHV ||
1599 target->op_type == OP_PADAV);
1601 /* Ensure that attributes.pm is loaded. */
1602 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1604 /* Need package name for method call. */
1605 pack = newSVOP(OP_CONST, 0, newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1));
1607 /* Build up the real arg-list. */
1608 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1610 arg = newOP(OP_PADSV, 0);
1611 arg->op_targ = target->op_targ;
1612 arg = prepend_elem(OP_LIST,
1613 newSVOP(OP_CONST, 0, stashsv),
1614 prepend_elem(OP_LIST,
1615 newUNOP(OP_REFGEN, 0,
1616 mod(arg, OP_REFGEN)),
1617 dup_attrlist(attrs)));
1619 /* Fake up a method call to import */
1620 meth = newSVpvn_share("import", 6, 0);
1621 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1622 append_elem(OP_LIST,
1623 prepend_elem(OP_LIST, pack, list(arg)),
1624 newSVOP(OP_METHOD_NAMED, 0, meth)));
1625 imop->op_private |= OPpENTERSUB_NOMOD;
1627 /* Combine the ops. */
1628 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1632 =notfor apidoc apply_attrs_string
1634 Attempts to apply a list of attributes specified by the C<attrstr> and
1635 C<len> arguments to the subroutine identified by the C<cv> argument which
1636 is expected to be associated with the package identified by the C<stashpv>
1637 argument (see L<attributes>). It gets this wrong, though, in that it
1638 does not correctly identify the boundaries of the individual attribute
1639 specifications within C<attrstr>. This is not really intended for the
1640 public API, but has to be listed here for systems such as AIX which
1641 need an explicit export list for symbols. (It's called from XS code
1642 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1643 to respect attribute syntax properly would be welcome.
1649 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
1650 const char *attrstr, STRLEN len)
1655 len = strlen(attrstr);
1659 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1661 const char * const sstr = attrstr;
1662 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1663 attrs = append_elem(OP_LIST, attrs,
1664 newSVOP(OP_CONST, 0,
1665 newSVpvn(sstr, attrstr-sstr)));
1669 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1670 newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1671 Nullsv, prepend_elem(OP_LIST,
1672 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1673 prepend_elem(OP_LIST,
1674 newSVOP(OP_CONST, 0,
1680 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
1684 if (!o || PL_error_count)
1688 if (type == OP_LIST) {
1690 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1691 my_kid(kid, attrs, imopsp);
1692 } else if (type == OP_UNDEF) {
1694 } else if (type == OP_RV2SV || /* "our" declaration */
1696 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1697 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1698 yyerror(Perl_form(aTHX_ "Can't declare %s in %s",
1699 OP_DESC(o), PL_in_my == KEY_our ? "our" : "my"));
1701 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
1703 PL_in_my_stash = NULL;
1704 apply_attrs(GvSTASH(gv),
1705 (type == OP_RV2SV ? GvSV(gv) :
1706 type == OP_RV2AV ? (SV*)GvAV(gv) :
1707 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1710 o->op_private |= OPpOUR_INTRO;
1713 else if (type != OP_PADSV &&
1716 type != OP_PUSHMARK)
1718 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1720 PL_in_my == KEY_our ? "our" : "my"));
1723 else if (attrs && type != OP_PUSHMARK) {
1727 PL_in_my_stash = NULL;
1729 /* check for C<my Dog $spot> when deciding package */
1730 stash = PAD_COMPNAME_TYPE(o->op_targ);
1732 stash = PL_curstash;
1733 apply_attrs_my(stash, o, attrs, imopsp);
1735 o->op_flags |= OPf_MOD;
1736 o->op_private |= OPpLVAL_INTRO;
1741 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1744 int maybe_scalar = 0;
1746 /* [perl #17376]: this appears to be premature, and results in code such as
1747 C< our(%x); > executing in list mode rather than void mode */
1749 if (o->op_flags & OPf_PARENS)
1759 o = my_kid(o, attrs, &rops);
1761 if (maybe_scalar && o->op_type == OP_PADSV) {
1762 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
1763 o->op_private |= OPpLVAL_INTRO;
1766 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
1769 PL_in_my_stash = NULL;
1774 Perl_my(pTHX_ OP *o)
1776 return my_attrs(o, Nullop);
1780 Perl_sawparens(pTHX_ OP *o)
1783 o->op_flags |= OPf_PARENS;
1788 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
1793 if ( (left->op_type == OP_RV2AV ||
1794 left->op_type == OP_RV2HV ||
1795 left->op_type == OP_PADAV ||
1796 left->op_type == OP_PADHV)
1797 && ckWARN(WARN_MISC))
1799 const char * const desc = PL_op_desc[(right->op_type == OP_SUBST ||
1800 right->op_type == OP_TRANS)
1801 ? right->op_type : OP_MATCH];
1802 const char * const sample = ((left->op_type == OP_RV2AV ||
1803 left->op_type == OP_PADAV)
1804 ? "@array" : "%hash");
1805 Perl_warner(aTHX_ packWARN(WARN_MISC),
1806 "Applying %s to %s will act on scalar(%s)",
1807 desc, sample, sample);
1810 if (right->op_type == OP_CONST &&
1811 cSVOPx(right)->op_private & OPpCONST_BARE &&
1812 cSVOPx(right)->op_private & OPpCONST_STRICT)
1814 no_bareword_allowed(right);
1817 ismatchop = right->op_type == OP_MATCH ||
1818 right->op_type == OP_SUBST ||
1819 right->op_type == OP_TRANS;
1820 if (ismatchop && right->op_private & OPpTARGET_MY) {
1822 right->op_private &= ~OPpTARGET_MY;
1824 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
1825 right->op_flags |= OPf_STACKED;
1826 /* s/// and tr/// modify their arg.
1827 * m//g also indirectly modifies the arg by setting pos magic on it */
1828 if ( (right->op_type == OP_MATCH &&
1829 (cPMOPx(right)->op_pmflags & PMf_GLOBAL))
1830 || (right->op_type == OP_SUBST)
1831 || (right->op_type == OP_TRANS &&
1832 ! (right->op_private & OPpTRANS_IDENTICAL))
1834 left = mod(left, right->op_type);
1835 if (right->op_type == OP_TRANS)
1836 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
1838 o = prepend_elem(right->op_type, scalar(left), right);
1840 return newUNOP(OP_NOT, 0, scalar(o));
1844 return bind_match(type, left,
1845 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
1849 Perl_invert(pTHX_ OP *o)
1853 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
1854 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
1858 Perl_scope(pTHX_ OP *o)
1862 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
1863 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
1864 o->op_type = OP_LEAVE;
1865 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
1867 else if (o->op_type == OP_LINESEQ) {
1869 o->op_type = OP_SCOPE;
1870 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
1871 kid = ((LISTOP*)o)->op_first;
1872 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
1875 /* The following deals with things like 'do {1 for 1}' */
1876 kid = kid->op_sibling;
1878 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
1883 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
1889 Perl_block_start(pTHX_ int full)
1891 const int retval = PL_savestack_ix;
1892 pad_block_start(full);
1894 PL_hints &= ~HINT_BLOCK_SCOPE;
1895 SAVESPTR(PL_compiling.cop_warnings);
1896 if (! specialWARN(PL_compiling.cop_warnings)) {
1897 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
1898 SAVEFREESV(PL_compiling.cop_warnings) ;
1900 SAVESPTR(PL_compiling.cop_io);
1901 if (! specialCopIO(PL_compiling.cop_io)) {
1902 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
1903 SAVEFREESV(PL_compiling.cop_io) ;
1909 Perl_block_end(pTHX_ I32 floor, OP *seq)
1911 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
1912 OP* const retval = scalarseq(seq);
1914 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
1916 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
1924 const I32 offset = pad_findmy("$_");
1925 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
1926 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
1929 OP * const o = newOP(OP_PADSV, 0);
1930 o->op_targ = offset;
1936 Perl_newPROG(pTHX_ OP *o)
1941 PL_eval_root = newUNOP(OP_LEAVEEVAL,
1942 ((PL_in_eval & EVAL_KEEPERR)
1943 ? OPf_SPECIAL : 0), o);
1944 PL_eval_start = linklist(PL_eval_root);
1945 PL_eval_root->op_private |= OPpREFCOUNTED;
1946 OpREFCNT_set(PL_eval_root, 1);
1947 PL_eval_root->op_next = 0;
1948 CALL_PEEP(PL_eval_start);
1951 if (o->op_type == OP_STUB) {
1952 PL_comppad_name = 0;
1957 PL_main_root = scope(sawparens(scalarvoid(o)));
1958 PL_curcop = &PL_compiling;
1959 PL_main_start = LINKLIST(PL_main_root);
1960 PL_main_root->op_private |= OPpREFCOUNTED;
1961 OpREFCNT_set(PL_main_root, 1);
1962 PL_main_root->op_next = 0;
1963 CALL_PEEP(PL_main_start);
1966 /* Register with debugger */
1968 CV * const cv = get_cv("DB::postponed", FALSE);
1972 XPUSHs((SV*)CopFILEGV(&PL_compiling));
1974 call_sv((SV*)cv, G_DISCARD);
1981 Perl_localize(pTHX_ OP *o, I32 lex)
1983 if (o->op_flags & OPf_PARENS)
1984 /* [perl #17376]: this appears to be premature, and results in code such as
1985 C< our(%x); > executing in list mode rather than void mode */
1992 if ( PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ','
1993 && ckWARN(WARN_PARENTHESIS))
1995 char *s = PL_bufptr;
1998 /* some heuristics to detect a potential error */
1999 while (*s && (strchr(", \t\n", *s)))
2003 if (*s && strchr("@$%*", *s) && *++s
2004 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2007 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2009 while (*s && (strchr(", \t\n", *s)))
2015 if (sigil && (*s == ';' || *s == '=')) {
2016 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2017 "Parentheses missing around \"%s\" list",
2018 lex ? (PL_in_my == KEY_our ? "our" : "my")
2026 o = mod(o, OP_NULL); /* a bit kludgey */
2028 PL_in_my_stash = NULL;
2033 Perl_jmaybe(pTHX_ OP *o)
2035 if (o->op_type == OP_LIST) {
2037 o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", GV_ADD, SVt_PV))),
2038 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2044 Perl_fold_constants(pTHX_ register OP *o)
2048 I32 type = o->op_type;
2051 if (PL_opargs[type] & OA_RETSCALAR)
2053 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2054 o->op_targ = pad_alloc(type, SVs_PADTMP);
2056 /* integerize op, unless it happens to be C<-foo>.
2057 * XXX should pp_i_negate() do magic string negation instead? */
2058 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2059 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2060 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2062 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2065 if (!(PL_opargs[type] & OA_FOLDCONST))
2070 /* XXX might want a ck_negate() for this */
2071 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2082 /* XXX what about the numeric ops? */
2083 if (PL_hints & HINT_LOCALE)
2088 goto nope; /* Don't try to run w/ errors */
2090 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2091 if ((curop->op_type != OP_CONST ||
2092 (curop->op_private & OPpCONST_BARE)) &&
2093 curop->op_type != OP_LIST &&
2094 curop->op_type != OP_SCALAR &&
2095 curop->op_type != OP_NULL &&
2096 curop->op_type != OP_PUSHMARK)
2102 curop = LINKLIST(o);
2106 sv = *(PL_stack_sp--);
2107 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2108 pad_swipe(o->op_targ, FALSE);
2109 else if (SvTEMP(sv)) { /* grab mortal temp? */
2110 (void)SvREFCNT_inc(sv);
2114 if (type == OP_RV2GV)
2115 return newGVOP(OP_GV, 0, (GV*)sv);
2116 return newSVOP(OP_CONST, 0, sv);
2123 Perl_gen_constant_list(pTHX_ register OP *o)
2127 const I32 oldtmps_floor = PL_tmps_floor;
2131 return o; /* Don't attempt to run with errors */
2133 PL_op = curop = LINKLIST(o);
2140 PL_tmps_floor = oldtmps_floor;
2142 o->op_type = OP_RV2AV;
2143 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2144 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2145 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2146 o->op_opt = 0; /* needs to be revisited in peep() */
2147 curop = ((UNOP*)o)->op_first;
2148 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2155 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2158 if (!o || o->op_type != OP_LIST)
2159 o = newLISTOP(OP_LIST, 0, o, Nullop);
2161 o->op_flags &= ~OPf_WANT;
2163 if (!(PL_opargs[type] & OA_MARK))
2164 op_null(cLISTOPo->op_first);
2166 o->op_type = (OPCODE)type;
2167 o->op_ppaddr = PL_ppaddr[type];
2168 o->op_flags |= flags;
2170 o = CHECKOP(type, o);
2171 if (o->op_type != (unsigned)type)
2174 return fold_constants(o);
2177 /* List constructors */
2180 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2188 if (first->op_type != (unsigned)type
2189 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2191 return newLISTOP(type, 0, first, last);
2194 if (first->op_flags & OPf_KIDS)
2195 ((LISTOP*)first)->op_last->op_sibling = last;
2197 first->op_flags |= OPf_KIDS;
2198 ((LISTOP*)first)->op_first = last;
2200 ((LISTOP*)first)->op_last = last;
2205 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2213 if (first->op_type != (unsigned)type)
2214 return prepend_elem(type, (OP*)first, (OP*)last);
2216 if (last->op_type != (unsigned)type)
2217 return append_elem(type, (OP*)first, (OP*)last);
2219 first->op_last->op_sibling = last->op_first;
2220 first->op_last = last->op_last;
2221 first->op_flags |= (last->op_flags & OPf_KIDS);
2229 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2237 if (last->op_type == (unsigned)type) {
2238 if (type == OP_LIST) { /* already a PUSHMARK there */
2239 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2240 ((LISTOP*)last)->op_first->op_sibling = first;
2241 if (!(first->op_flags & OPf_PARENS))
2242 last->op_flags &= ~OPf_PARENS;
2245 if (!(last->op_flags & OPf_KIDS)) {
2246 ((LISTOP*)last)->op_last = first;
2247 last->op_flags |= OPf_KIDS;
2249 first->op_sibling = ((LISTOP*)last)->op_first;
2250 ((LISTOP*)last)->op_first = first;
2252 last->op_flags |= OPf_KIDS;
2256 return newLISTOP(type, 0, first, last);
2262 Perl_newNULLLIST(pTHX)
2264 return newOP(OP_STUB, 0);
2268 Perl_force_list(pTHX_ OP *o)
2270 if (!o || o->op_type != OP_LIST)
2271 o = newLISTOP(OP_LIST, 0, o, Nullop);
2277 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2282 NewOp(1101, listop, 1, LISTOP);
2284 listop->op_type = (OPCODE)type;
2285 listop->op_ppaddr = PL_ppaddr[type];
2288 listop->op_flags = (U8)flags;
2292 else if (!first && last)
2295 first->op_sibling = last;
2296 listop->op_first = first;
2297 listop->op_last = last;
2298 if (type == OP_LIST) {
2299 OP* const pushop = newOP(OP_PUSHMARK, 0);
2300 pushop->op_sibling = first;
2301 listop->op_first = pushop;
2302 listop->op_flags |= OPf_KIDS;
2304 listop->op_last = pushop;
2307 return CHECKOP(type, listop);
2311 Perl_newOP(pTHX_ I32 type, I32 flags)
2315 NewOp(1101, o, 1, OP);
2316 o->op_type = (OPCODE)type;
2317 o->op_ppaddr = PL_ppaddr[type];
2318 o->op_flags = (U8)flags;
2321 o->op_private = (U8)(0 | (flags >> 8));
2322 if (PL_opargs[type] & OA_RETSCALAR)
2324 if (PL_opargs[type] & OA_TARGET)
2325 o->op_targ = pad_alloc(type, SVs_PADTMP);
2326 return CHECKOP(type, o);
2330 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2336 first = newOP(OP_STUB, 0);
2337 if (PL_opargs[type] & OA_MARK)
2338 first = force_list(first);
2340 NewOp(1101, unop, 1, UNOP);
2341 unop->op_type = (OPCODE)type;
2342 unop->op_ppaddr = PL_ppaddr[type];
2343 unop->op_first = first;
2344 unop->op_flags = (U8)(flags | OPf_KIDS);
2345 unop->op_private = (U8)(1 | (flags >> 8));
2346 unop = (UNOP*) CHECKOP(type, unop);
2350 return fold_constants((OP *) unop);
2354 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2358 NewOp(1101, binop, 1, BINOP);
2361 first = newOP(OP_NULL, 0);
2363 binop->op_type = (OPCODE)type;
2364 binop->op_ppaddr = PL_ppaddr[type];
2365 binop->op_first = first;
2366 binop->op_flags = (U8)(flags | OPf_KIDS);
2369 binop->op_private = (U8)(1 | (flags >> 8));
2372 binop->op_private = (U8)(2 | (flags >> 8));
2373 first->op_sibling = last;
2376 binop = (BINOP*)CHECKOP(type, binop);
2377 if (binop->op_next || binop->op_type != (OPCODE)type)
2380 binop->op_last = binop->op_first->op_sibling;
2382 return fold_constants((OP *)binop);
2385 static int uvcompare(const void *a, const void *b) __attribute__nonnull__(1) __attribute__nonnull__(2) __attribute__pure__;
2386 static int uvcompare(const void *a, const void *b)
2388 if (*((const UV *)a) < (*(const UV *)b))
2390 if (*((const UV *)a) > (*(const UV *)b))
2392 if (*((const UV *)a+1) < (*(const UV *)b+1))
2394 if (*((const UV *)a+1) > (*(const UV *)b+1))
2400 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2402 SV * const tstr = ((SVOP*)expr)->op_sv;
2403 SV * const rstr = ((SVOP*)repl)->op_sv;
2406 const U8 *t = (U8*)SvPV_const(tstr, tlen);
2407 const U8 *r = (U8*)SvPV_const(rstr, rlen);
2411 register short *tbl;
2413 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
2414 const I32 squash = o->op_private & OPpTRANS_SQUASH;
2415 I32 del = o->op_private & OPpTRANS_DELETE;
2416 PL_hints |= HINT_BLOCK_SCOPE;
2419 o->op_private |= OPpTRANS_FROM_UTF;
2422 o->op_private |= OPpTRANS_TO_UTF;
2424 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2425 SV* const listsv = newSVpvn("# comment\n",10);
2427 const U8* tend = t + tlen;
2428 const U8* rend = r + rlen;
2442 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2443 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2449 t = tsave = bytes_to_utf8(t, &len);
2452 if (!to_utf && rlen) {
2454 r = rsave = bytes_to_utf8(r, &len);
2458 /* There are several snags with this code on EBCDIC:
2459 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2460 2. scan_const() in toke.c has encoded chars in native encoding which makes
2461 ranges at least in EBCDIC 0..255 range the bottom odd.
2465 U8 tmpbuf[UTF8_MAXBYTES+1];
2468 Newx(cp, 2*tlen, UV);
2470 transv = newSVpvn("",0);
2472 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2474 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2476 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2480 cp[2*i+1] = cp[2*i];
2484 qsort(cp, i, 2*sizeof(UV), uvcompare);
2485 for (j = 0; j < i; j++) {
2487 diff = val - nextmin;
2489 t = uvuni_to_utf8(tmpbuf,nextmin);
2490 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2492 U8 range_mark = UTF_TO_NATIVE(0xff);
2493 t = uvuni_to_utf8(tmpbuf, val - 1);
2494 sv_catpvn(transv, (char *)&range_mark, 1);
2495 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2502 t = uvuni_to_utf8(tmpbuf,nextmin);
2503 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2505 U8 range_mark = UTF_TO_NATIVE(0xff);
2506 sv_catpvn(transv, (char *)&range_mark, 1);
2508 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2509 UNICODE_ALLOW_SUPER);
2510 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2511 t = (const U8*)SvPVX_const(transv);
2512 tlen = SvCUR(transv);
2516 else if (!rlen && !del) {
2517 r = t; rlen = tlen; rend = tend;
2520 if ((!rlen && !del) || t == r ||
2521 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2523 o->op_private |= OPpTRANS_IDENTICAL;
2527 while (t < tend || tfirst <= tlast) {
2528 /* see if we need more "t" chars */
2529 if (tfirst > tlast) {
2530 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2532 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2534 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2541 /* now see if we need more "r" chars */
2542 if (rfirst > rlast) {
2544 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2546 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2548 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2557 rfirst = rlast = 0xffffffff;
2561 /* now see which range will peter our first, if either. */
2562 tdiff = tlast - tfirst;
2563 rdiff = rlast - rfirst;
2570 if (rfirst == 0xffffffff) {
2571 diff = tdiff; /* oops, pretend rdiff is infinite */
2573 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2574 (long)tfirst, (long)tlast);
2576 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2580 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2581 (long)tfirst, (long)(tfirst + diff),
2584 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2585 (long)tfirst, (long)rfirst);
2587 if (rfirst + diff > max)
2588 max = rfirst + diff;
2590 grows = (tfirst < rfirst &&
2591 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2603 else if (max > 0xff)
2608 Safefree(cPVOPo->op_pv);
2609 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2610 SvREFCNT_dec(listsv);
2612 SvREFCNT_dec(transv);
2614 if (!del && havefinal && rlen)
2615 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2616 newSVuv((UV)final), 0);
2619 o->op_private |= OPpTRANS_GROWS;
2631 tbl = (short*)cPVOPo->op_pv;
2633 Zero(tbl, 256, short);
2634 for (i = 0; i < (I32)tlen; i++)
2636 for (i = 0, j = 0; i < 256; i++) {
2638 if (j >= (I32)rlen) {
2647 if (i < 128 && r[j] >= 128)
2657 o->op_private |= OPpTRANS_IDENTICAL;
2659 else if (j >= (I32)rlen)
2662 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2663 tbl[0x100] = (short)(rlen - j);
2664 for (i=0; i < (I32)rlen - j; i++)
2665 tbl[0x101+i] = r[j+i];
2669 if (!rlen && !del) {
2672 o->op_private |= OPpTRANS_IDENTICAL;
2674 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
2675 o->op_private |= OPpTRANS_IDENTICAL;
2677 for (i = 0; i < 256; i++)
2679 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
2680 if (j >= (I32)rlen) {
2682 if (tbl[t[i]] == -1)
2688 if (tbl[t[i]] == -1) {
2689 if (t[i] < 128 && r[j] >= 128)
2696 o->op_private |= OPpTRANS_GROWS;
2704 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2709 NewOp(1101, pmop, 1, PMOP);
2710 pmop->op_type = (OPCODE)type;
2711 pmop->op_ppaddr = PL_ppaddr[type];
2712 pmop->op_flags = (U8)flags;
2713 pmop->op_private = (U8)(0 | (flags >> 8));
2715 if (PL_hints & HINT_RE_TAINT)
2716 pmop->op_pmpermflags |= PMf_RETAINT;
2717 if (PL_hints & HINT_LOCALE)
2718 pmop->op_pmpermflags |= PMf_LOCALE;
2719 pmop->op_pmflags = pmop->op_pmpermflags;
2722 if (av_len((AV*) PL_regex_pad[0]) > -1) {
2723 SV * const repointer = av_pop((AV*)PL_regex_pad[0]);
2724 pmop->op_pmoffset = SvIV(repointer);
2725 SvREPADTMP_off(repointer);
2726 sv_setiv(repointer,0);
2728 SV * const repointer = newSViv(0);
2729 av_push(PL_regex_padav,SvREFCNT_inc(repointer));
2730 pmop->op_pmoffset = av_len(PL_regex_padav);
2731 PL_regex_pad = AvARRAY(PL_regex_padav);
2735 /* link into pm list */
2736 if (type != OP_TRANS && PL_curstash) {
2737 MAGIC *mg = mg_find((SV*)PL_curstash, PERL_MAGIC_symtab);
2740 mg = sv_magicext((SV*)PL_curstash, 0, PERL_MAGIC_symtab, 0, 0, 0);
2742 pmop->op_pmnext = (PMOP*)mg->mg_obj;
2743 mg->mg_obj = (SV*)pmop;
2744 PmopSTASH_set(pmop,PL_curstash);
2747 return CHECKOP(type, pmop);
2750 /* Given some sort of match op o, and an expression expr containing a
2751 * pattern, either compile expr into a regex and attach it to o (if it's
2752 * constant), or convert expr into a runtime regcomp op sequence (if it's
2755 * isreg indicates that the pattern is part of a regex construct, eg
2756 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
2757 * split "pattern", which aren't. In the former case, expr will be a list
2758 * if the pattern contains more than one term (eg /a$b/) or if it contains
2759 * a replacement, ie s/// or tr///.
2763 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
2768 I32 repl_has_vars = 0;
2772 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
2773 /* last element in list is the replacement; pop it */
2775 repl = cLISTOPx(expr)->op_last;
2776 kid = cLISTOPx(expr)->op_first;
2777 while (kid->op_sibling != repl)
2778 kid = kid->op_sibling;
2779 kid->op_sibling = Nullop;
2780 cLISTOPx(expr)->op_last = kid;
2783 if (isreg && expr->op_type == OP_LIST &&
2784 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
2786 /* convert single element list to element */
2787 OP* const oe = expr;
2788 expr = cLISTOPx(oe)->op_first->op_sibling;
2789 cLISTOPx(oe)->op_first->op_sibling = Nullop;
2790 cLISTOPx(oe)->op_last = Nullop;
2794 if (o->op_type == OP_TRANS) {
2795 return pmtrans(o, expr, repl);
2798 reglist = isreg && expr->op_type == OP_LIST;
2802 PL_hints |= HINT_BLOCK_SCOPE;
2805 if (expr->op_type == OP_CONST) {
2807 SV *pat = ((SVOP*)expr)->op_sv;
2808 const char *p = SvPV_const(pat, plen);
2809 if ((o->op_flags & OPf_SPECIAL) && (*p == ' ' && p[1] == '\0')) {
2810 U32 was_readonly = SvREADONLY(pat);
2814 sv_force_normal_flags(pat, 0);
2815 assert(!SvREADONLY(pat));
2818 SvREADONLY_off(pat);
2822 sv_setpvn(pat, "\\s+", 3);
2824 SvFLAGS(pat) |= was_readonly;
2826 p = SvPV_const(pat, plen);
2827 pm->op_pmflags |= PMf_SKIPWHITE;
2830 pm->op_pmdynflags |= PMdf_UTF8;
2831 /* FIXME - can we make this function take const char * args? */
2832 PM_SETRE(pm, CALLREGCOMP(aTHX_ (char*)p, (char*)p + plen, pm));
2833 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
2834 pm->op_pmflags |= PMf_WHITE;
2838 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
2839 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2841 : OP_REGCMAYBE),0,expr);
2843 NewOp(1101, rcop, 1, LOGOP);
2844 rcop->op_type = OP_REGCOMP;
2845 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
2846 rcop->op_first = scalar(expr);
2847 rcop->op_flags |= OPf_KIDS
2848 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
2849 | (reglist ? OPf_STACKED : 0);
2850 rcop->op_private = 1;
2853 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
2855 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
2858 /* establish postfix order */
2859 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
2861 rcop->op_next = expr;
2862 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
2865 rcop->op_next = LINKLIST(expr);
2866 expr->op_next = (OP*)rcop;
2869 prepend_elem(o->op_type, scalar((OP*)rcop), o);
2874 if (pm->op_pmflags & PMf_EVAL) {
2876 if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
2877 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
2879 else if (repl->op_type == OP_CONST)
2883 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
2884 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
2885 if (curop->op_type == OP_GV) {
2886 GV *gv = cGVOPx_gv(curop);
2888 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
2891 else if (curop->op_type == OP_RV2CV)
2893 else if (curop->op_type == OP_RV2SV ||
2894 curop->op_type == OP_RV2AV ||
2895 curop->op_type == OP_RV2HV ||
2896 curop->op_type == OP_RV2GV) {
2897 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
2900 else if (curop->op_type == OP_PADSV ||
2901 curop->op_type == OP_PADAV ||
2902 curop->op_type == OP_PADHV ||
2903 curop->op_type == OP_PADANY) {
2906 else if (curop->op_type == OP_PUSHRE)
2907 ; /* Okay here, dangerous in newASSIGNOP */
2917 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
2918 pm->op_pmflags |= PMf_CONST; /* const for long enough */
2919 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
2920 prepend_elem(o->op_type, scalar(repl), o);
2923 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
2924 pm->op_pmflags |= PMf_MAYBE_CONST;
2925 pm->op_pmpermflags |= PMf_MAYBE_CONST;
2927 NewOp(1101, rcop, 1, LOGOP);
2928 rcop->op_type = OP_SUBSTCONT;
2929 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
2930 rcop->op_first = scalar(repl);
2931 rcop->op_flags |= OPf_KIDS;
2932 rcop->op_private = 1;
2935 /* establish postfix order */
2936 rcop->op_next = LINKLIST(repl);
2937 repl->op_next = (OP*)rcop;
2939 pm->op_pmreplroot = scalar((OP*)rcop);
2940 pm->op_pmreplstart = LINKLIST(rcop);
2949 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
2953 NewOp(1101, svop, 1, SVOP);
2954 svop->op_type = (OPCODE)type;
2955 svop->op_ppaddr = PL_ppaddr[type];
2957 svop->op_next = (OP*)svop;
2958 svop->op_flags = (U8)flags;
2959 if (PL_opargs[type] & OA_RETSCALAR)
2961 if (PL_opargs[type] & OA_TARGET)
2962 svop->op_targ = pad_alloc(type, SVs_PADTMP);
2963 return CHECKOP(type, svop);
2967 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
2971 NewOp(1101, padop, 1, PADOP);
2972 padop->op_type = (OPCODE)type;
2973 padop->op_ppaddr = PL_ppaddr[type];
2974 padop->op_padix = pad_alloc(type, SVs_PADTMP);
2975 SvREFCNT_dec(PAD_SVl(padop->op_padix));
2976 PAD_SETSV(padop->op_padix, sv);
2979 padop->op_next = (OP*)padop;
2980 padop->op_flags = (U8)flags;
2981 if (PL_opargs[type] & OA_RETSCALAR)
2983 if (PL_opargs[type] & OA_TARGET)
2984 padop->op_targ = pad_alloc(type, SVs_PADTMP);
2985 return CHECKOP(type, padop);
2989 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
2995 return newPADOP(type, flags, SvREFCNT_inc(gv));
2997 return newSVOP(type, flags, SvREFCNT_inc(gv));
3002 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3006 NewOp(1101, pvop, 1, PVOP);
3007 pvop->op_type = (OPCODE)type;
3008 pvop->op_ppaddr = PL_ppaddr[type];
3010 pvop->op_next = (OP*)pvop;
3011 pvop->op_flags = (U8)flags;
3012 if (PL_opargs[type] & OA_RETSCALAR)
3014 if (PL_opargs[type] & OA_TARGET)
3015 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3016 return CHECKOP(type, pvop);
3020 Perl_package(pTHX_ OP *o)
3025 save_hptr(&PL_curstash);
3026 save_item(PL_curstname);
3028 name = SvPV_const(cSVOPo->op_sv, len);
3029 PL_curstash = gv_stashpvn(name, len, TRUE);
3030 sv_setpvn(PL_curstname, name, len);
3033 PL_hints |= HINT_BLOCK_SCOPE;
3034 PL_copline = NOLINE;
3039 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3045 if (idop->op_type != OP_CONST)
3046 Perl_croak(aTHX_ "Module name must be constant");
3051 SV * const vesv = ((SVOP*)version)->op_sv;
3053 if (!arg && !SvNIOKp(vesv)) {
3060 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3061 Perl_croak(aTHX_ "Version number must be constant number");
3063 /* Make copy of idop so we don't free it twice */
3064 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3066 /* Fake up a method call to VERSION */
3067 meth = newSVpvn_share("VERSION", 7, 0);
3068 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3069 append_elem(OP_LIST,
3070 prepend_elem(OP_LIST, pack, list(version)),
3071 newSVOP(OP_METHOD_NAMED, 0, meth)));
3075 /* Fake up an import/unimport */
3076 if (arg && arg->op_type == OP_STUB)
3077 imop = arg; /* no import on explicit () */
3078 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3079 imop = Nullop; /* use 5.0; */
3081 idop->op_private |= OPpCONST_NOVER;
3086 /* Make copy of idop so we don't free it twice */
3087 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3089 /* Fake up a method call to import/unimport */
3091 ? newSVpvn_share("import",6, 0) : newSVpvn_share("unimport", 8, 0);
3092 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3093 append_elem(OP_LIST,
3094 prepend_elem(OP_LIST, pack, list(arg)),
3095 newSVOP(OP_METHOD_NAMED, 0, meth)));
3098 /* Fake up the BEGIN {}, which does its thing immediately. */
3100 newSVOP(OP_CONST, 0, newSVpvn_share("BEGIN", 5, 0)),
3103 append_elem(OP_LINESEQ,
3104 append_elem(OP_LINESEQ,
3105 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, idop)),
3106 newSTATEOP(0, Nullch, veop)),
3107 newSTATEOP(0, Nullch, imop) ));
3109 /* The "did you use incorrect case?" warning used to be here.
3110 * The problem is that on case-insensitive filesystems one
3111 * might get false positives for "use" (and "require"):
3112 * "use Strict" or "require CARP" will work. This causes
3113 * portability problems for the script: in case-strict
3114 * filesystems the script will stop working.
3116 * The "incorrect case" warning checked whether "use Foo"
3117 * imported "Foo" to your namespace, but that is wrong, too:
3118 * there is no requirement nor promise in the language that
3119 * a Foo.pm should or would contain anything in package "Foo".
3121 * There is very little Configure-wise that can be done, either:
3122 * the case-sensitivity of the build filesystem of Perl does not
3123 * help in guessing the case-sensitivity of the runtime environment.
3126 PL_hints |= HINT_BLOCK_SCOPE;
3127 PL_copline = NOLINE;
3129 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3133 =head1 Embedding Functions
3135 =for apidoc load_module
3137 Loads the module whose name is pointed to by the string part of name.
3138 Note that the actual module name, not its filename, should be given.
3139 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3140 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3141 (or 0 for no flags). ver, if specified, provides version semantics
3142 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3143 arguments can be used to specify arguments to the module's import()
3144 method, similar to C<use Foo::Bar VERSION LIST>.
3149 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3152 va_start(args, ver);
3153 vload_module(flags, name, ver, &args);
3157 #ifdef PERL_IMPLICIT_CONTEXT
3159 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3163 va_start(args, ver);
3164 vload_module(flags, name, ver, &args);
3170 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3174 OP * const modname = newSVOP(OP_CONST, 0, name);
3175 modname->op_private |= OPpCONST_BARE;
3177 veop = newSVOP(OP_CONST, 0, ver);
3181 if (flags & PERL_LOADMOD_NOIMPORT) {
3182 imop = sawparens(newNULLLIST());
3184 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3185 imop = va_arg(*args, OP*);
3190 sv = va_arg(*args, SV*);
3192 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3193 sv = va_arg(*args, SV*);
3197 const line_t ocopline = PL_copline;
3198 COP * const ocurcop = PL_curcop;
3199 const int oexpect = PL_expect;
3201 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3202 veop, modname, imop);
3203 PL_expect = oexpect;
3204 PL_copline = ocopline;
3205 PL_curcop = ocurcop;
3210 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
3215 if (!force_builtin) {
3216 gv = gv_fetchpv("do", 0, SVt_PVCV);
3217 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
3218 GV * const * const gvp = (GV**)hv_fetch(PL_globalstash, "do", 2, FALSE);
3219 gv = gvp ? *gvp : Nullgv;
3223 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3224 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3225 append_elem(OP_LIST, term,
3226 scalar(newUNOP(OP_RV2CV, 0,
3231 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3237 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3239 return newBINOP(OP_LSLICE, flags,
3240 list(force_list(subscript)),
3241 list(force_list(listval)) );
3245 S_is_list_assignment(pTHX_ register const OP *o)
3250 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3251 o = cUNOPo->op_first;
3253 if (o->op_type == OP_COND_EXPR) {
3254 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
3255 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3260 yyerror("Assignment to both a list and a scalar");
3264 if (o->op_type == OP_LIST &&
3265 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3266 o->op_private & OPpLVAL_INTRO)
3269 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3270 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3271 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3274 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3277 if (o->op_type == OP_RV2SV)
3284 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3289 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3290 return newLOGOP(optype, 0,
3291 mod(scalar(left), optype),
3292 newUNOP(OP_SASSIGN, 0, scalar(right)));
3295 return newBINOP(optype, OPf_STACKED,
3296 mod(scalar(left), optype), scalar(right));
3300 if (is_list_assignment(left)) {
3304 /* Grandfathering $[ assignment here. Bletch.*/
3305 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
3306 PL_eval_start = (left->op_type == OP_CONST) ? right : 0;
3307 left = mod(left, OP_AASSIGN);
3310 else if (left->op_type == OP_CONST) {
3311 /* Result of assignment is always 1 (or we'd be dead already) */
3312 return newSVOP(OP_CONST, 0, newSViv(1));
3314 curop = list(force_list(left));
3315 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3316 o->op_private = (U8)(0 | (flags >> 8));
3318 /* PL_generation sorcery:
3319 * an assignment like ($a,$b) = ($c,$d) is easier than
3320 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3321 * To detect whether there are common vars, the global var
3322 * PL_generation is incremented for each assign op we compile.
3323 * Then, while compiling the assign op, we run through all the
3324 * variables on both sides of the assignment, setting a spare slot
3325 * in each of them to PL_generation. If any of them already have
3326 * that value, we know we've got commonality. We could use a
3327 * single bit marker, but then we'd have to make 2 passes, first
3328 * to clear the flag, then to test and set it. To find somewhere
3329 * to store these values, evil chicanery is done with SvCUR().
3332 if (!(left->op_private & OPpLVAL_INTRO)) {
3335 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3336 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3337 if (curop->op_type == OP_GV) {
3338 GV *gv = cGVOPx_gv(curop);
3339 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3341 SvCUR_set(gv, PL_generation);
3343 else if (curop->op_type == OP_PADSV ||
3344 curop->op_type == OP_PADAV ||
3345 curop->op_type == OP_PADHV ||
3346 curop->op_type == OP_PADANY)
3348 if (PAD_COMPNAME_GEN(curop->op_targ)
3349 == (STRLEN)PL_generation)
3351 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
3354 else if (curop->op_type == OP_RV2CV)
3356 else if (curop->op_type == OP_RV2SV ||
3357 curop->op_type == OP_RV2AV ||
3358 curop->op_type == OP_RV2HV ||
3359 curop->op_type == OP_RV2GV) {
3360 if (lastop->op_type != OP_GV) /* funny deref? */
3363 else if (curop->op_type == OP_PUSHRE) {
3364 if (((PMOP*)curop)->op_pmreplroot) {
3366 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3367 ((PMOP*)curop)->op_pmreplroot));
3369 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3371 if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3373 SvCUR_set(gv, PL_generation);
3382 o->op_private |= OPpASSIGN_COMMON;
3384 if (right && right->op_type == OP_SPLIT) {
3386 if ((tmpop = ((LISTOP*)right)->op_first) &&
3387 tmpop->op_type == OP_PUSHRE)
3389 PMOP * const pm = (PMOP*)tmpop;
3390 if (left->op_type == OP_RV2AV &&
3391 !(left->op_private & OPpLVAL_INTRO) &&
3392 !(o->op_private & OPpASSIGN_COMMON) )
3394 tmpop = ((UNOP*)left)->op_first;
3395 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3397 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3398 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3400 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3401 cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */
3403 pm->op_pmflags |= PMf_ONCE;
3404 tmpop = cUNOPo->op_first; /* to list (nulled) */
3405 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3406 tmpop->op_sibling = Nullop; /* don't free split */
3407 right->op_next = tmpop->op_next; /* fix starting loc */
3408 op_free(o); /* blow off assign */
3409 right->op_flags &= ~OPf_WANT;
3410 /* "I don't know and I don't care." */
3415 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3416 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3418 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3420 sv_setiv(sv, PL_modcount+1);
3428 right = newOP(OP_UNDEF, 0);
3429 if (right->op_type == OP_READLINE) {
3430 right->op_flags |= OPf_STACKED;
3431 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3434 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3435 o = newBINOP(OP_SASSIGN, flags,
3436 scalar(right), mod(scalar(left), OP_SASSIGN) );
3440 o = newSVOP(OP_CONST, 0, newSViv(PL_compiling.cop_arybase));
3447 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3450 const U32 seq = intro_my();
3453 NewOp(1101, cop, 1, COP);
3454 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3455 cop->op_type = OP_DBSTATE;
3456 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3459 cop->op_type = OP_NEXTSTATE;
3460 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3462 cop->op_flags = (U8)flags;
3463 cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
3465 cop->op_private |= NATIVE_HINTS;
3467 PL_compiling.op_private = cop->op_private;
3468 cop->op_next = (OP*)cop;
3471 cop->cop_label = label;
3472 PL_hints |= HINT_BLOCK_SCOPE;
3475 cop->cop_arybase = PL_curcop->cop_arybase;
3476 if (specialWARN(PL_curcop->cop_warnings))
3477 cop->cop_warnings = PL_curcop->cop_warnings ;
3479 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3480 if (specialCopIO(PL_curcop->cop_io))
3481 cop->cop_io = PL_curcop->cop_io;
3483 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3486 if (PL_copline == NOLINE)
3487 CopLINE_set(cop, CopLINE(PL_curcop));
3489 CopLINE_set(cop, PL_copline);
3490 PL_copline = NOLINE;
3493 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3495 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3497 CopSTASH_set(cop, PL_curstash);
3499 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3500 SV * const * const svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3501 if (svp && *svp != &PL_sv_undef ) {
3502 (void)SvIOK_on(*svp);
3503 SvIV_set(*svp, PTR2IV(cop));
3507 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3512 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3515 return new_logop(type, flags, &first, &other);
3519 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3524 OP *first = *firstp;
3525 OP * const other = *otherp;
3527 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3528 return newBINOP(type, flags, scalar(first), scalar(other));
3530 scalarboolean(first);
3531 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3532 if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3533 if (type == OP_AND || type == OP_OR) {
3539 first = *firstp = cUNOPo->op_first;
3541 first->op_next = o->op_next;
3542 cUNOPo->op_first = Nullop;
3546 if (first->op_type == OP_CONST) {
3547 if (first->op_private & OPpCONST_STRICT)
3548 no_bareword_allowed(first);
3549 else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
3550 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
3551 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
3552 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
3553 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
3556 if (other->op_type == OP_CONST)
3557 other->op_private |= OPpCONST_SHORTCIRCUIT;
3561 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
3562 const OP *o2 = other;
3563 if ( ! (o2->op_type == OP_LIST
3564 && (( o2 = cUNOPx(o2)->op_first))
3565 && o2->op_type == OP_PUSHMARK
3566 && (( o2 = o2->op_sibling)) )
3569 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
3570 || o2->op_type == OP_PADHV)
3571 && o2->op_private & OPpLVAL_INTRO
3572 && ckWARN(WARN_DEPRECATED))
3574 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
3575 "Deprecated use of my() in false conditional");
3580 if (first->op_type == OP_CONST)
3581 first->op_private |= OPpCONST_SHORTCIRCUIT;
3585 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
3586 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
3588 const OP * const k1 = ((UNOP*)first)->op_first;
3589 const OP * const k2 = k1->op_sibling;
3591 switch (first->op_type)
3594 if (k2 && k2->op_type == OP_READLINE
3595 && (k2->op_flags & OPf_STACKED)
3596 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3598 warnop = k2->op_type;
3603 if (k1->op_type == OP_READDIR
3604 || k1->op_type == OP_GLOB
3605 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3606 || k1->op_type == OP_EACH)
3608 warnop = ((k1->op_type == OP_NULL)
3609 ? (OPCODE)k1->op_targ : k1->op_type);
3614 const line_t oldline = CopLINE(PL_curcop);
3615 CopLINE_set(PL_curcop, PL_copline);
3616 Perl_warner(aTHX_ packWARN(WARN_MISC),
3617 "Value of %s%s can be \"0\"; test with defined()",
3619 ((warnop == OP_READLINE || warnop == OP_GLOB)
3620 ? " construct" : "() operator"));
3621 CopLINE_set(PL_curcop, oldline);
3628 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
3629 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
3631 NewOp(1101, logop, 1, LOGOP);
3633 logop->op_type = (OPCODE)type;
3634 logop->op_ppaddr = PL_ppaddr[type];
3635 logop->op_first = first;
3636 logop->op_flags = (U8)(flags | OPf_KIDS);
3637 logop->op_other = LINKLIST(other);
3638 logop->op_private = (U8)(1 | (flags >> 8));
3640 /* establish postfix order */
3641 logop->op_next = LINKLIST(first);
3642 first->op_next = (OP*)logop;
3643 first->op_sibling = other;
3645 CHECKOP(type,logop);
3647 o = newUNOP(OP_NULL, 0, (OP*)logop);
3654 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3662 return newLOGOP(OP_AND, 0, first, trueop);
3664 return newLOGOP(OP_OR, 0, first, falseop);
3666 scalarboolean(first);
3667 if (first->op_type == OP_CONST) {
3668 if (first->op_private & OPpCONST_BARE &&
3669 first->op_private & OPpCONST_STRICT) {
3670 no_bareword_allowed(first);
3672 if (SvTRUE(((SVOP*)first)->op_sv)) {
3683 NewOp(1101, logop, 1, LOGOP);
3684 logop->op_type = OP_COND_EXPR;
3685 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3686 logop->op_first = first;
3687 logop->op_flags = (U8)(flags | OPf_KIDS);
3688 logop->op_private = (U8)(1 | (flags >> 8));
3689 logop->op_other = LINKLIST(trueop);
3690 logop->op_next = LINKLIST(falseop);
3692 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
3695 /* establish postfix order */
3696 start = LINKLIST(first);
3697 first->op_next = (OP*)logop;
3699 first->op_sibling = trueop;
3700 trueop->op_sibling = falseop;
3701 o = newUNOP(OP_NULL, 0, (OP*)logop);
3703 trueop->op_next = falseop->op_next = o;
3710 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3719 NewOp(1101, range, 1, LOGOP);
3721 range->op_type = OP_RANGE;
3722 range->op_ppaddr = PL_ppaddr[OP_RANGE];
3723 range->op_first = left;
3724 range->op_flags = OPf_KIDS;
3725 leftstart = LINKLIST(left);
3726 range->op_other = LINKLIST(right);
3727 range->op_private = (U8)(1 | (flags >> 8));
3729 left->op_sibling = right;
3731 range->op_next = (OP*)range;
3732 flip = newUNOP(OP_FLIP, flags, (OP*)range);
3733 flop = newUNOP(OP_FLOP, 0, flip);
3734 o = newUNOP(OP_NULL, 0, flop);
3736 range->op_next = leftstart;
3738 left->op_next = flip;
3739 right->op_next = flop;
3741 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3742 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3743 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3744 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3746 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3747 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3750 if (!flip->op_private || !flop->op_private)
3751 linklist(o); /* blow off optimizer unless constant */
3757 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3761 const bool once = block && block->op_flags & OPf_SPECIAL &&
3762 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3764 PERL_UNUSED_ARG(debuggable);
3767 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3768 return block; /* do {} while 0 does once */
3769 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3770 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3771 expr = newUNOP(OP_DEFINED, 0,
3772 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3773 } else if (expr->op_flags & OPf_KIDS) {
3774 const OP * const k1 = ((UNOP*)expr)->op_first;
3775 const OP * const k2 = k1 ? k1->op_sibling : NULL;
3776 switch (expr->op_type) {
3778 if (k2 && k2->op_type == OP_READLINE
3779 && (k2->op_flags & OPf_STACKED)
3780 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3781 expr = newUNOP(OP_DEFINED, 0, expr);
3785 if (k1->op_type == OP_READDIR
3786 || k1->op_type == OP_GLOB
3787 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3788 || k1->op_type == OP_EACH)
3789 expr = newUNOP(OP_DEFINED, 0, expr);
3795 /* if block is null, the next append_elem() would put UNSTACK, a scalar
3796 * op, in listop. This is wrong. [perl #27024] */
3798 block = newOP(OP_NULL, 0);
3799 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3800 o = new_logop(OP_AND, 0, &expr, &listop);
3803 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3805 if (once && o != listop)
3806 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3809 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
3811 o->op_flags |= flags;
3813 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3818 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
3819 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
3828 PERL_UNUSED_ARG(debuggable);
3831 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3832 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3833 expr = newUNOP(OP_DEFINED, 0,
3834 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3835 } else if (expr->op_flags & OPf_KIDS) {
3836 const OP * const k1 = ((UNOP*)expr)->op_first;
3837 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
3838 switch (expr->op_type) {
3840 if (k2 && k2->op_type == OP_READLINE
3841 && (k2->op_flags & OPf_STACKED)
3842 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3843 expr = newUNOP(OP_DEFINED, 0, expr);
3847 if (k1->op_type == OP_READDIR
3848 || k1->op_type == OP_GLOB
3849 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3850 || k1->op_type == OP_EACH)
3851 expr = newUNOP(OP_DEFINED, 0, expr);
3858 block = newOP(OP_NULL, 0);
3859 else if (cont || has_my) {
3860 block = scope(block);
3864 next = LINKLIST(cont);
3867 OP * const unstack = newOP(OP_UNSTACK, 0);
3870 cont = append_elem(OP_LINESEQ, cont, unstack);
3873 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3874 redo = LINKLIST(listop);
3877 PL_copline = (line_t)whileline;
3879 o = new_logop(OP_AND, 0, &expr, &listop);
3880 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3881 op_free(expr); /* oops, it's a while (0) */
3883 return Nullop; /* listop already freed by new_logop */
3886 ((LISTOP*)listop)->op_last->op_next =
3887 (o == listop ? redo : LINKLIST(o));
3893 NewOp(1101,loop,1,LOOP);
3894 loop->op_type = OP_ENTERLOOP;
3895 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3896 loop->op_private = 0;
3897 loop->op_next = (OP*)loop;
3900 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
3902 loop->op_redoop = redo;
3903 loop->op_lastop = o;
3904 o->op_private |= loopflags;
3907 loop->op_nextop = next;
3909 loop->op_nextop = o;
3911 o->op_flags |= flags;
3912 o->op_private |= (flags >> 8);
3917 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
3922 PADOFFSET padoff = 0;
3927 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
3928 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
3929 sv->op_type = OP_RV2GV;
3930 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
3931 if (cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
3932 iterpflags |= OPpITER_DEF;
3934 else if (sv->op_type == OP_PADSV) { /* private variable */
3935 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
3936 padoff = sv->op_targ;
3941 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
3942 padoff = sv->op_targ;
3944 iterflags |= OPf_SPECIAL;
3949 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
3950 if (padoff && strEQ(PAD_COMPNAME_PV(padoff), "$_"))
3951 iterpflags |= OPpITER_DEF;
3954 const I32 offset = pad_findmy("$_");
3955 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
3956 sv = newGVOP(OP_GV, 0, PL_defgv);
3961 iterpflags |= OPpITER_DEF;
3963 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
3964 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
3965 iterflags |= OPf_STACKED;
3967 else if (expr->op_type == OP_NULL &&
3968 (expr->op_flags & OPf_KIDS) &&
3969 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
3971 /* Basically turn for($x..$y) into the same as for($x,$y), but we
3972 * set the STACKED flag to indicate that these values are to be
3973 * treated as min/max values by 'pp_iterinit'.
3975 UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
3976 LOGOP* const range = (LOGOP*) flip->op_first;
3977 OP* const left = range->op_first;
3978 OP* const right = left->op_sibling;
3981 range->op_flags &= ~OPf_KIDS;
3982 range->op_first = Nullop;
3984 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
3985 listop->op_first->op_next = range->op_next;
3986 left->op_next = range->op_other;
3987 right->op_next = (OP*)listop;
3988 listop->op_next = listop->op_first;
3991 expr = (OP*)(listop);
3993 iterflags |= OPf_STACKED;
3996 expr = mod(force_list(expr), OP_GREPSTART);
3999 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4000 append_elem(OP_LIST, expr, scalar(sv))));
4001 assert(!loop->op_next);
4002 /* for my $x () sets OPpLVAL_INTRO;
4003 * for our $x () sets OPpOUR_INTRO */
4004 loop->op_private = (U8)iterpflags;
4005 #ifdef PL_OP_SLAB_ALLOC
4008 NewOp(1234,tmp,1,LOOP);
4009 Copy(loop,tmp,1,LISTOP);
4014 Renew(loop, 1, LOOP);
4016 loop->op_targ = padoff;
4017 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
4018 PL_copline = forline;
4019 return newSTATEOP(0, label, wop);
4023 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4027 if (type != OP_GOTO || label->op_type == OP_CONST) {
4028 /* "last()" means "last" */
4029 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4030 o = newOP(type, OPf_SPECIAL);
4032 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4033 ? SvPVx_nolen_const(((SVOP*)label)->op_sv)
4039 /* Check whether it's going to be a goto &function */
4040 if (label->op_type == OP_ENTERSUB
4041 && !(label->op_flags & OPf_STACKED))
4042 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4043 o = newUNOP(type, OPf_STACKED, label);
4045 PL_hints |= HINT_BLOCK_SCOPE;
4049 /* if the condition is a literal array or hash
4050 (or @{ ... } etc), make a reference to it.
4053 S_ref_array_or_hash(pTHX_ OP *cond)
4056 && (cond->op_type == OP_RV2AV
4057 || cond->op_type == OP_PADAV
4058 || cond->op_type == OP_RV2HV
4059 || cond->op_type == OP_PADHV))
4061 return newUNOP(OP_REFGEN,
4062 0, mod(cond, OP_REFGEN));
4068 /* These construct the optree fragments representing given()
4071 entergiven and enterwhen are LOGOPs; the op_other pointer
4072 points up to the associated leave op. We need this so we
4073 can put it in the context and make break/continue work.
4074 (Also, of course, pp_enterwhen will jump straight to
4075 op_other if the match fails.)
4080 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
4081 I32 enter_opcode, I32 leave_opcode,
4082 PADOFFSET entertarg)
4087 NewOp(1101, enterop, 1, LOGOP);
4088 enterop->op_type = enter_opcode;
4089 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
4090 enterop->op_flags = (U8) OPf_KIDS;
4091 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
4092 enterop->op_private = 0;
4094 o = newUNOP(leave_opcode, 0, (OP *) enterop);
4097 enterop->op_first = scalar(cond);
4098 cond->op_sibling = block;
4100 o->op_next = LINKLIST(cond);
4101 cond->op_next = (OP *) enterop;
4104 /* This is a default {} block */
4105 enterop->op_first = block;
4106 enterop->op_flags |= OPf_SPECIAL;
4108 o->op_next = (OP *) enterop;
4111 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
4112 entergiven and enterwhen both
4115 enterop->op_next = LINKLIST(block);
4116 block->op_next = enterop->op_other = o;
4121 /* Does this look like a boolean operation? For these purposes
4122 a boolean operation is:
4123 - a subroutine call [*]
4124 - a logical connective
4125 - a comparison operator
4126 - a filetest operator, with the exception of -s -M -A -C
4127 - defined(), exists() or eof()
4128 - /$re/ or $foo =~ /$re/
4130 [*] possibly surprising
4134 S_looks_like_bool(pTHX_ OP *o)
4136 switch(o->op_type) {
4138 return looks_like_bool(cLOGOPo->op_first);
4142 looks_like_bool(cLOGOPo->op_first)
4143 && looks_like_bool(cLOGOPo->op_first->op_sibling));
4147 case OP_NOT: case OP_XOR:
4148 /* Note that OP_DOR is not here */
4150 case OP_EQ: case OP_NE: case OP_LT:
4151 case OP_GT: case OP_LE: case OP_GE:
4153 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
4154 case OP_I_GT: case OP_I_LE: case OP_I_GE:
4156 case OP_SEQ: case OP_SNE: case OP_SLT:
4157 case OP_SGT: case OP_SLE: case OP_SGE:
4161 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
4162 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
4163 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
4164 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
4165 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
4166 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
4167 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
4168 case OP_FTTEXT: case OP_FTBINARY:
4170 case OP_DEFINED: case OP_EXISTS:
4171 case OP_MATCH: case OP_EOF:
4176 /* Detect comparisons that have been optimized away */
4177 if (cSVOPo->op_sv == &PL_sv_yes
4178 || cSVOPo->op_sv == &PL_sv_no)
4189 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
4192 return newGIVWHENOP(
4193 ref_array_or_hash(cond),
4195 OP_ENTERGIVEN, OP_LEAVEGIVEN,
4199 /* If cond is null, this is a default {} block */
4201 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
4203 bool cond_llb = (!cond || looks_like_bool(cond));
4209 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
4211 scalar(ref_array_or_hash(cond)));
4214 return newGIVWHENOP(
4216 append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
4217 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
4221 =for apidoc cv_undef
4223 Clear out all the active components of a CV. This can happen either
4224 by an explicit C<undef &foo>, or by the reference count going to zero.
4225 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
4226 children can still follow the full lexical scope chain.
4232 Perl_cv_undef(pTHX_ CV *cv)
4236 if (CvFILE(cv) && !CvXSUB(cv)) {
4237 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4238 Safefree(CvFILE(cv));
4243 if (!CvXSUB(cv) && CvROOT(cv)) {
4245 Perl_croak(aTHX_ "Can't undef active subroutine");
4248 PAD_SAVE_SETNULLPAD();
4250 op_free(CvROOT(cv));
4251 CvROOT(cv) = Nullop;
4252 CvSTART(cv) = Nullop;
4255 SvPOK_off((SV*)cv); /* forget prototype */
4260 /* remove CvOUTSIDE unless this is an undef rather than a free */
4261 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
4262 if (!CvWEAKOUTSIDE(cv))
4263 SvREFCNT_dec(CvOUTSIDE(cv));
4264 CvOUTSIDE(cv) = Nullcv;
4267 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4273 /* delete all flags except WEAKOUTSIDE */
4274 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
4278 Perl_cv_ckproto(pTHX_ const CV *cv, const GV *gv, const char *p)
4280 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX_const(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4281 SV* const msg = sv_newmortal();
4285 gv_efullname3(name = sv_newmortal(), gv, Nullch);
4286 sv_setpv(msg, "Prototype mismatch:");
4288 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4290 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (const SV *)cv);
4292 Perl_sv_catpv(aTHX_ msg, ": none");
4293 sv_catpv(msg, " vs ");
4295 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4297 sv_catpv(msg, "none");
4298 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
4302 static void const_sv_xsub(pTHX_ CV* cv);
4306 =head1 Optree Manipulation Functions
4308 =for apidoc cv_const_sv
4310 If C<cv> is a constant sub eligible for inlining. returns the constant
4311 value returned by the sub. Otherwise, returns NULL.
4313 Constant subs can be created with C<newCONSTSUB> or as described in
4314 L<perlsub/"Constant Functions">.
4319 Perl_cv_const_sv(pTHX_ CV *cv)
4321 if (!cv || !CvCONST(cv))
4323 return (SV*)CvXSUBANY(cv).any_ptr;
4326 /* op_const_sv: examine an optree to determine whether it's in-lineable.
4327 * Can be called in 3 ways:
4330 * look for a single OP_CONST with attached value: return the value
4332 * cv && CvCLONE(cv) && !CvCONST(cv)
4334 * examine the clone prototype, and if contains only a single
4335 * OP_CONST referencing a pad const, or a single PADSV referencing
4336 * an outer lexical, return a non-zero value to indicate the CV is
4337 * a candidate for "constizing" at clone time
4341 * We have just cloned an anon prototype that was marked as a const
4342 * candidiate. Try to grab the current value, and in the case of
4343 * PADSV, ignore it if it has multiple references. Return the value.
4347 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
4354 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4355 o = cLISTOPo->op_first->op_sibling;
4357 for (; o; o = o->op_next) {
4358 const OPCODE type = o->op_type;
4360 if (sv && o->op_next == o)
4362 if (o->op_next != o) {
4363 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4365 if (type == OP_DBSTATE)
4368 if (type == OP_LEAVESUB || type == OP_RETURN)
4372 if (type == OP_CONST && cSVOPo->op_sv)
4374 else if (cv && type == OP_CONST) {
4375 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4379 else if (cv && type == OP_PADSV) {
4380 if (CvCONST(cv)) { /* newly cloned anon */
4381 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4382 /* the candidate should have 1 ref from this pad and 1 ref
4383 * from the parent */
4384 if (!sv || SvREFCNT(sv) != 2)
4391 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
4392 sv = &PL_sv_undef; /* an arbitrary non-null value */
4403 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4405 PERL_UNUSED_ARG(floor);
4415 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4419 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4421 return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4425 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4436 const char * const name = o ? SvPVx_nolen_const(cSVOPo->op_sv) : Nullch;
4439 assert(proto->op_type == OP_CONST);
4440 ps = SvPVx_const(((SVOP*)proto)->op_sv, ps_len);
4445 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4446 SV * const sv = sv_newmortal();
4447 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4448 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
4449 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4450 aname = SvPVX_const(sv);
4455 gv_fetch_flags = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
4456 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
4457 gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
4458 : gv_fetchpv(aname ? aname
4459 : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4460 gv_fetch_flags, SVt_PVCV);
4469 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4470 maximum a prototype before. */
4471 if (SvTYPE(gv) > SVt_NULL) {
4472 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4473 && ckWARN_d(WARN_PROTOTYPE))
4475 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
4477 cv_ckproto((CV*)gv, NULL, ps);
4480 sv_setpvn((SV*)gv, ps, ps_len);
4482 sv_setiv((SV*)gv, -1);
4483 SvREFCNT_dec(PL_compcv);
4484 cv = PL_compcv = NULL;
4485 PL_sub_generation++;
4489 cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4491 #ifdef GV_UNIQUE_CHECK
4492 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4493 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4497 if (!block || !ps || *ps || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
4500 const_sv = op_const_sv(block, Nullcv);
4503 const bool exists = CvROOT(cv) || CvXSUB(cv);
4505 #ifdef GV_UNIQUE_CHECK
4506 if (exists && GvUNIQUE(gv)) {
4507 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4511 /* if the subroutine doesn't exist and wasn't pre-declared
4512 * with a prototype, assume it will be AUTOLOADed,
4513 * skipping the prototype check
4515 if (exists || SvPOK(cv))
4516 cv_ckproto(cv, gv, ps);
4517 /* already defined (or promised)? */
4518 if (exists || GvASSUMECV(gv)) {
4519 if (!block && !attrs) {
4520 if (CvFLAGS(PL_compcv)) {
4521 /* might have had built-in attrs applied */
4522 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4524 /* just a "sub foo;" when &foo is already defined */
4525 SAVEFREESV(PL_compcv);
4529 if (ckWARN(WARN_REDEFINE)
4531 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4533 const line_t oldline = CopLINE(PL_curcop);
4534 if (PL_copline != NOLINE)
4535 CopLINE_set(PL_curcop, PL_copline);
4536 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4537 CvCONST(cv) ? "Constant subroutine %s redefined"
4538 : "Subroutine %s redefined", name);
4539 CopLINE_set(PL_curcop, oldline);
4547 (void)SvREFCNT_inc(const_sv);
4549 assert(!CvROOT(cv) && !CvCONST(cv));
4550 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
4551 CvXSUBANY(cv).any_ptr = const_sv;
4552 CvXSUB(cv) = const_sv_xsub;
4557 cv = newCONSTSUB(NULL, name, const_sv);
4560 SvREFCNT_dec(PL_compcv);
4562 PL_sub_generation++;
4569 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4570 * before we clobber PL_compcv.
4574 /* Might have had built-in attributes applied -- propagate them. */
4575 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4576 if (CvGV(cv) && GvSTASH(CvGV(cv)))
4577 stash = GvSTASH(CvGV(cv));
4578 else if (CvSTASH(cv))
4579 stash = CvSTASH(cv);
4581 stash = PL_curstash;
4584 /* possibly about to re-define existing subr -- ignore old cv */
4585 rcv = (SV*)PL_compcv;
4586 if (name && GvSTASH(gv))
4587 stash = GvSTASH(gv);
4589 stash = PL_curstash;
4591 apply_attrs(stash, rcv, attrs, FALSE);
4593 if (cv) { /* must reuse cv if autoloaded */
4595 /* got here with just attrs -- work done, so bug out */
4596 SAVEFREESV(PL_compcv);
4599 /* transfer PL_compcv to cv */
4601 CvFLAGS(cv) = CvFLAGS(PL_compcv);
4602 if (!CvWEAKOUTSIDE(cv))
4603 SvREFCNT_dec(CvOUTSIDE(cv));
4604 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4605 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
4606 CvOUTSIDE(PL_compcv) = 0;
4607 CvPADLIST(cv) = CvPADLIST(PL_compcv);
4608 CvPADLIST(PL_compcv) = 0;
4609 /* inner references to PL_compcv must be fixed up ... */
4610 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
4611 /* ... before we throw it away */
4612 SvREFCNT_dec(PL_compcv);
4614 if (PERLDB_INTER)/* Advice debugger on the new sub. */
4615 ++PL_sub_generation;
4622 PL_sub_generation++;
4626 CvFILE_set_from_cop(cv, PL_curcop);
4627 CvSTASH(cv) = PL_curstash;
4630 sv_setpvn((SV*)cv, ps, ps_len);
4632 if (PL_error_count) {
4636 const char *s = strrchr(name, ':');
4638 if (strEQ(s, "BEGIN")) {
4639 const char not_safe[] =
4640 "BEGIN not safe after errors--compilation aborted";
4641 if (PL_in_eval & EVAL_KEEPERR)
4642 Perl_croak(aTHX_ not_safe);
4644 /* force display of errors found but not reported */
4645 sv_catpv(ERRSV, not_safe);
4646 Perl_croak(aTHX_ "%"SVf, ERRSV);
4655 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4656 mod(scalarseq(block), OP_LEAVESUBLV));
4659 /* This makes sub {}; work as expected. */
4660 if (block->op_type == OP_STUB) {
4662 block = newSTATEOP(0, Nullch, 0);
4664 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4666 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4667 OpREFCNT_set(CvROOT(cv), 1);
4668 CvSTART(cv) = LINKLIST(CvROOT(cv));
4669 CvROOT(cv)->op_next = 0;
4670 CALL_PEEP(CvSTART(cv));
4672 /* now that optimizer has done its work, adjust pad values */
4674 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4677 assert(!CvCONST(cv));
4678 if (ps && !*ps && op_const_sv(block, cv))
4682 if (name || aname) {
4684 const char * const tname = (name ? name : aname);
4686 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4687 SV * const sv = NEWSV(0,0);
4688 SV * const tmpstr = sv_newmortal();
4689 GV * const db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4692 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4694 (long)PL_subline, (long)CopLINE(PL_curcop));
4695 gv_efullname3(tmpstr, gv, Nullch);
4696 hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0);
4697 hv = GvHVn(db_postponed);
4698 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
4699 CV * const pcv = GvCV(db_postponed);
4705 call_sv((SV*)pcv, G_DISCARD);
4710 if ((s = strrchr(tname,':')))
4715 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4718 if (strEQ(s, "BEGIN") && !PL_error_count) {
4719 const I32 oldscope = PL_scopestack_ix;
4721 SAVECOPFILE(&PL_compiling);
4722 SAVECOPLINE(&PL_compiling);
4725 PL_beginav = newAV();
4726 DEBUG_x( dump_sub(gv) );
4727 av_push(PL_beginav, (SV*)cv);
4728 GvCV(gv) = 0; /* cv has been hijacked */
4729 call_list(oldscope, PL_beginav);
4731 PL_curcop = &PL_compiling;
4732 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4735 else if (strEQ(s, "END") && !PL_error_count) {
4738 DEBUG_x( dump_sub(gv) );
4739 av_unshift(PL_endav, 1);
4740 av_store(PL_endav, 0, (SV*)cv);
4741 GvCV(gv) = 0; /* cv has been hijacked */
4743 else if (strEQ(s, "CHECK") && !PL_error_count) {
4745 PL_checkav = newAV();
4746 DEBUG_x( dump_sub(gv) );
4747 if (PL_main_start && ckWARN(WARN_VOID))
4748 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4749 av_unshift(PL_checkav, 1);
4750 av_store(PL_checkav, 0, (SV*)cv);
4751 GvCV(gv) = 0; /* cv has been hijacked */
4753 else if (strEQ(s, "INIT") && !PL_error_count) {
4755 PL_initav = newAV();
4756 DEBUG_x( dump_sub(gv) );
4757 if (PL_main_start && ckWARN(WARN_VOID))
4758 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4759 av_push(PL_initav, (SV*)cv);
4760 GvCV(gv) = 0; /* cv has been hijacked */
4765 PL_copline = NOLINE;
4770 /* XXX unsafe for threads if eval_owner isn't held */
4772 =for apidoc newCONSTSUB
4774 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4775 eligible for inlining at compile-time.
4781 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
4788 SAVECOPLINE(PL_curcop);
4789 CopLINE_set(PL_curcop, PL_copline);
4792 PL_hints &= ~HINT_BLOCK_SCOPE;
4795 SAVESPTR(PL_curstash);
4796 SAVECOPSTASH(PL_curcop);
4797 PL_curstash = stash;
4798 CopSTASH_set(PL_curcop,stash);
4801 cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
4802 CvXSUBANY(cv).any_ptr = sv;
4804 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
4808 CopSTASH_free(PL_curcop);
4816 =for apidoc U||newXS
4818 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4824 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
4826 GV * const gv = gv_fetchpv(name ? name :
4827 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4828 GV_ADDMULTI, SVt_PVCV);
4832 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4834 if ((cv = (name ? GvCV(gv) : Nullcv))) {
4836 /* just a cached method */
4840 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4841 /* already defined (or promised) */
4842 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
4843 if (ckWARN(WARN_REDEFINE)) {
4844 GV * const gvcv = CvGV(cv);
4846 HV * const stash = GvSTASH(gvcv);
4848 const char *name = HvNAME_get(stash);
4849 if ( strEQ(name,"autouse") ) {
4850 const line_t oldline = CopLINE(PL_curcop);
4851 if (PL_copline != NOLINE)
4852 CopLINE_set(PL_curcop, PL_copline);
4853 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4854 CvCONST(cv) ? "Constant subroutine %s redefined"
4855 : "Subroutine %s redefined"
4857 CopLINE_set(PL_curcop, oldline);
4867 if (cv) /* must reuse cv if autoloaded */
4870 cv = (CV*)NEWSV(1105,0);
4871 sv_upgrade((SV *)cv, SVt_PVCV);
4875 PL_sub_generation++;
4879 (void)gv_fetchfile(filename);
4880 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
4881 an external constant string */
4882 CvXSUB(cv) = subaddr;
4885 const char *s = strrchr(name,':');
4891 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4894 if (strEQ(s, "BEGIN")) {
4896 PL_beginav = newAV();
4897 av_push(PL_beginav, (SV*)cv);
4898 GvCV(gv) = 0; /* cv has been hijacked */
4900 else if (strEQ(s, "END")) {
4903 av_unshift(PL_endav, 1);
4904 av_store(PL_endav, 0, (SV*)cv);
4905 GvCV(gv) = 0; /* cv has been hijacked */
4907 else if (strEQ(s, "CHECK")) {
4909 PL_checkav = newAV();
4910 if (PL_main_start && ckWARN(WARN_VOID))
4911 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4912 av_unshift(PL_checkav, 1);
4913 av_store(PL_checkav, 0, (SV*)cv);
4914 GvCV(gv) = 0; /* cv has been hijacked */
4916 else if (strEQ(s, "INIT")) {
4918 PL_initav = newAV();
4919 if (PL_main_start && ckWARN(WARN_VOID))
4920 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4921 av_push(PL_initav, (SV*)cv);
4922 GvCV(gv) = 0; /* cv has been hijacked */
4933 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4938 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
4939 : gv_fetchpv("STDOUT", GV_ADD, SVt_PVFM);
4941 #ifdef GV_UNIQUE_CHECK
4943 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
4947 if ((cv = GvFORM(gv))) {
4948 if (ckWARN(WARN_REDEFINE)) {
4949 const line_t oldline = CopLINE(PL_curcop);
4950 if (PL_copline != NOLINE)
4951 CopLINE_set(PL_curcop, PL_copline);
4952 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4953 o ? "Format %"SVf" redefined"
4954 : "Format STDOUT redefined" ,cSVOPo->op_sv);
4955 CopLINE_set(PL_curcop, oldline);
4962 CvFILE_set_from_cop(cv, PL_curcop);
4965 pad_tidy(padtidy_FORMAT);
4966 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
4967 CvROOT(cv)->op_private |= OPpREFCOUNTED;
4968 OpREFCNT_set(CvROOT(cv), 1);
4969 CvSTART(cv) = LINKLIST(CvROOT(cv));
4970 CvROOT(cv)->op_next = 0;
4971 CALL_PEEP(CvSTART(cv));
4973 PL_copline = NOLINE;
4978 Perl_newANONLIST(pTHX_ OP *o)
4980 return newUNOP(OP_REFGEN, 0,
4981 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
4985 Perl_newANONHASH(pTHX_ OP *o)
4987 return newUNOP(OP_REFGEN, 0,
4988 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
4992 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
4994 return newANONATTRSUB(floor, proto, Nullop, block);
4998 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5000 return newUNOP(OP_REFGEN, 0,
5001 newSVOP(OP_ANONCODE, 0,
5002 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5006 Perl_oopsAV(pTHX_ OP *o)
5009 switch (o->op_type) {
5011 o->op_type = OP_PADAV;
5012 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5013 return ref(o, OP_RV2AV);
5016 o->op_type = OP_RV2AV;
5017 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5022 if (ckWARN_d(WARN_INTERNAL))
5023 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
5030 Perl_oopsHV(pTHX_ OP *o)
5033 switch (o->op_type) {
5036 o->op_type = OP_PADHV;
5037 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5038 return ref(o, OP_RV2HV);
5042 o->op_type = OP_RV2HV;
5043 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5048 if (ckWARN_d(WARN_INTERNAL))
5049 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
5056 Perl_newAVREF(pTHX_ OP *o)
5059 if (o->op_type == OP_PADANY) {
5060 o->op_type = OP_PADAV;
5061 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5064 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5065 && ckWARN(WARN_DEPRECATED)) {
5066 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5067 "Using an array as a reference is deprecated");
5069 return newUNOP(OP_RV2AV, 0, scalar(o));
5073 Perl_newGVREF(pTHX_ I32 type, OP *o)
5075 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5076 return newUNOP(OP_NULL, 0, o);
5077 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5081 Perl_newHVREF(pTHX_ OP *o)
5084 if (o->op_type == OP_PADANY) {
5085 o->op_type = OP_PADHV;
5086 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5089 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5090 && ckWARN(WARN_DEPRECATED)) {
5091 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5092 "Using a hash as a reference is deprecated");
5094 return newUNOP(OP_RV2HV, 0, scalar(o));
5098 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5100 return newUNOP(OP_RV2CV, flags, scalar(o));
5104 Perl_newSVREF(pTHX_ OP *o)
5107 if (o->op_type == OP_PADANY) {
5108 o->op_type = OP_PADSV;
5109 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5112 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5113 o->op_flags |= OPpDONE_SVREF;
5116 return newUNOP(OP_RV2SV, 0, scalar(o));
5119 /* Check routines. See the comments at the top of this file for details
5120 * on when these are called */
5123 Perl_ck_anoncode(pTHX_ OP *o)
5125 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
5126 cSVOPo->op_sv = Nullsv;
5131 Perl_ck_bitop(pTHX_ OP *o)
5133 #define OP_IS_NUMCOMPARE(op) \
5134 ((op) == OP_LT || (op) == OP_I_LT || \
5135 (op) == OP_GT || (op) == OP_I_GT || \
5136 (op) == OP_LE || (op) == OP_I_LE || \
5137 (op) == OP_GE || (op) == OP_I_GE || \
5138 (op) == OP_EQ || (op) == OP_I_EQ || \
5139 (op) == OP_NE || (op) == OP_I_NE || \
5140 (op) == OP_NCMP || (op) == OP_I_NCMP)
5141 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
5142 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
5143 && (o->op_type == OP_BIT_OR
5144 || o->op_type == OP_BIT_AND
5145 || o->op_type == OP_BIT_XOR))
5147 const OP * const left = cBINOPo->op_first;
5148 const OP * const right = left->op_sibling;
5149 if ((OP_IS_NUMCOMPARE(left->op_type) &&
5150 (left->op_flags & OPf_PARENS) == 0) ||
5151 (OP_IS_NUMCOMPARE(right->op_type) &&
5152 (right->op_flags & OPf_PARENS) == 0))
5153 if (ckWARN(WARN_PRECEDENCE))
5154 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
5155 "Possible precedence problem on bitwise %c operator",
5156 o->op_type == OP_BIT_OR ? '|'
5157 : o->op_type == OP_BIT_AND ? '&' : '^'
5164 Perl_ck_concat(pTHX_ OP *o)
5166 const OP * const kid = cUNOPo->op_first;
5167 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
5168 !(kUNOP->op_first->op_flags & OPf_MOD))
5169 o->op_flags |= OPf_STACKED;
5174 Perl_ck_spair(pTHX_ OP *o)
5177 if (o->op_flags & OPf_KIDS) {
5180 const OPCODE type = o->op_type;
5181 o = modkids(ck_fun(o), type);
5182 kid = cUNOPo->op_first;
5183 newop = kUNOP->op_first->op_sibling;
5185 (newop->op_sibling ||
5186 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5187 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5188 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5192 op_free(kUNOP->op_first);
5193 kUNOP->op_first = newop;
5195 o->op_ppaddr = PL_ppaddr[++o->op_type];
5200 Perl_ck_delete(pTHX_ OP *o)
5204 if (o->op_flags & OPf_KIDS) {
5205 OP * const kid = cUNOPo->op_first;
5206 switch (kid->op_type) {
5208 o->op_flags |= OPf_SPECIAL;
5211 o->op_private |= OPpSLICE;
5214 o->op_flags |= OPf_SPECIAL;
5219 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5228 Perl_ck_die(pTHX_ OP *o)
5231 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5237 Perl_ck_eof(pTHX_ OP *o)
5239 const I32 type = o->op_type;
5241 if (o->op_flags & OPf_KIDS) {
5242 if (cLISTOPo->op_first->op_type == OP_STUB) {
5244 o = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
5252 Perl_ck_eval(pTHX_ OP *o)
5255 PL_hints |= HINT_BLOCK_SCOPE;
5256 if (o->op_flags & OPf_KIDS) {
5257 SVOP * const kid = (SVOP*)cUNOPo->op_first;
5260 o->op_flags &= ~OPf_KIDS;
5263 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
5266 cUNOPo->op_first = 0;
5269 NewOp(1101, enter, 1, LOGOP);
5270 enter->op_type = OP_ENTERTRY;
5271 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5272 enter->op_private = 0;
5274 /* establish postfix order */
5275 enter->op_next = (OP*)enter;
5277 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5278 o->op_type = OP_LEAVETRY;
5279 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5280 enter->op_other = o;
5290 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5292 o->op_targ = (PADOFFSET)PL_hints;
5293 if ((PL_hints & HINT_HH_FOR_EVAL) != 0 && GvHV(PL_hintgv))
5295 /* Store a copy of %^H that pp_entereval can pick up */
5296 OP *hhop = newSVOP(OP_CONST, 0, (SV*)newHVhv(GvHV(PL_hintgv)));
5297 cUNOPo->op_first->op_sibling = hhop;
5298 o->op_private |= OPpEVAL_HAS_HH;
5304 Perl_ck_exit(pTHX_ OP *o)
5307 HV * const table = GvHV(PL_hintgv);
5309 SV * const * const svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5310 if (svp && *svp && SvTRUE(*svp))
5311 o->op_private |= OPpEXIT_VMSISH;
5313 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5319 Perl_ck_exec(pTHX_ OP *o)
5321 if (o->op_flags & OPf_STACKED) {
5324 kid = cUNOPo->op_first->op_sibling;
5325 if (kid->op_type == OP_RV2GV)
5334 Perl_ck_exists(pTHX_ OP *o)
5337 if (o->op_flags & OPf_KIDS) {
5338 OP * const kid = cUNOPo->op_first;
5339 if (kid->op_type == OP_ENTERSUB) {
5340 (void) ref(kid, o->op_type);
5341 if (kid->op_type != OP_RV2CV && !PL_error_count)
5342 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5344 o->op_private |= OPpEXISTS_SUB;
5346 else if (kid->op_type == OP_AELEM)
5347 o->op_flags |= OPf_SPECIAL;
5348 else if (kid->op_type != OP_HELEM)
5349 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5357 Perl_ck_rvconst(pTHX_ register OP *o)
5360 SVOP * const kid = (SVOP*)cUNOPo->op_first;
5362 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5363 if (kid->op_type == OP_CONST) {
5366 SV * const kidsv = kid->op_sv;
5368 /* Is it a constant from cv_const_sv()? */
5369 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5370 SV * const rsv = SvRV(kidsv);
5371 const int svtype = SvTYPE(rsv);
5372 const char *badtype = Nullch;
5374 switch (o->op_type) {
5376 if (svtype > SVt_PVMG)
5377 badtype = "a SCALAR";
5380 if (svtype != SVt_PVAV)
5381 badtype = "an ARRAY";
5384 if (svtype != SVt_PVHV)
5388 if (svtype != SVt_PVCV)
5393 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5396 if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5397 const char *badthing = Nullch;
5398 switch (o->op_type) {
5400 badthing = "a SCALAR";
5403 badthing = "an ARRAY";
5406 badthing = "a HASH";
5411 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
5415 * This is a little tricky. We only want to add the symbol if we
5416 * didn't add it in the lexer. Otherwise we get duplicate strict
5417 * warnings. But if we didn't add it in the lexer, we must at
5418 * least pretend like we wanted to add it even if it existed before,
5419 * or we get possible typo warnings. OPpCONST_ENTERED says
5420 * whether the lexer already added THIS instance of this symbol.
5422 iscv = (o->op_type == OP_RV2CV) * 2;
5424 gv = gv_fetchsv(kidsv,
5425 iscv | !(kid->op_private & OPpCONST_ENTERED),
5428 : o->op_type == OP_RV2SV
5430 : o->op_type == OP_RV2AV
5432 : o->op_type == OP_RV2HV
5435 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5437 kid->op_type = OP_GV;
5438 SvREFCNT_dec(kid->op_sv);
5440 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5441 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5442 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
5444 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv));
5446 kid->op_sv = SvREFCNT_inc(gv);
5448 kid->op_private = 0;
5449 kid->op_ppaddr = PL_ppaddr[OP_GV];
5456 Perl_ck_ftst(pTHX_ OP *o)
5459 const I32 type = o->op_type;
5461 if (o->op_flags & OPf_REF) {
5464 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5465 SVOP * const kid = (SVOP*)cUNOPo->op_first;
5467 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5468 OP * const newop = newGVOP(type, OPf_REF,
5469 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
5475 if ((PL_hints & HINT_FILETEST_ACCESS) &&
5476 OP_IS_FILETEST_ACCESS(o))
5477 o->op_private |= OPpFT_ACCESS;
5479 if (PL_check[kid->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst)
5480 && kid->op_type != OP_STAT && kid->op_type != OP_LSTAT)
5481 o->op_private |= OPpFT_STACKED;
5485 if (type == OP_FTTTY)
5486 o = newGVOP(type, OPf_REF, PL_stdingv);
5488 o = newUNOP(type, 0, newDEFSVOP());
5494 Perl_ck_fun(pTHX_ OP *o)
5496 const int type = o->op_type;
5497 register I32 oa = PL_opargs[type] >> OASHIFT;
5499 if (o->op_flags & OPf_STACKED) {
5500 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5503 return no_fh_allowed(o);
5506 if (o->op_flags & OPf_KIDS) {
5507 OP **tokid = &cLISTOPo->op_first;
5508 register OP *kid = cLISTOPo->op_first;
5512 if (kid->op_type == OP_PUSHMARK ||
5513 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5515 tokid = &kid->op_sibling;
5516 kid = kid->op_sibling;
5518 if (!kid && PL_opargs[type] & OA_DEFGV)
5519 *tokid = kid = newDEFSVOP();
5523 sibl = kid->op_sibling;
5526 /* list seen where single (scalar) arg expected? */
5527 if (numargs == 1 && !(oa >> 4)
5528 && kid->op_type == OP_LIST && type != OP_SCALAR)
5530 return too_many_arguments(o,PL_op_desc[type]);
5543 if ((type == OP_PUSH || type == OP_UNSHIFT)
5544 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5545 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5546 "Useless use of %s with no values",
5549 if (kid->op_type == OP_CONST &&
5550 (kid->op_private & OPpCONST_BARE))
5552 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
5553 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
5554 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5555 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5556 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
5557 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
5560 kid->op_sibling = sibl;
5563 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5564 bad_type(numargs, "array", PL_op_desc[type], kid);
5568 if (kid->op_type == OP_CONST &&
5569 (kid->op_private & OPpCONST_BARE))
5571 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
5572 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
5573 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5574 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5575 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
5576 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
5579 kid->op_sibling = sibl;
5582 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5583 bad_type(numargs, "hash", PL_op_desc[type], kid);
5588 OP * const newop = newUNOP(OP_NULL, 0, kid);
5589 kid->op_sibling = 0;
5591 newop->op_next = newop;
5593 kid->op_sibling = sibl;
5598 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5599 if (kid->op_type == OP_CONST &&
5600 (kid->op_private & OPpCONST_BARE))
5602 OP * const newop = newGVOP(OP_GV, 0,
5603 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
5604 if (!(o->op_private & 1) && /* if not unop */
5605 kid == cLISTOPo->op_last)
5606 cLISTOPo->op_last = newop;
5610 else if (kid->op_type == OP_READLINE) {
5611 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5612 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5615 I32 flags = OPf_SPECIAL;
5619 /* is this op a FH constructor? */
5620 if (is_handle_constructor(o,numargs)) {
5621 const char *name = Nullch;
5625 /* Set a flag to tell rv2gv to vivify
5626 * need to "prove" flag does not mean something
5627 * else already - NI-S 1999/05/07
5630 if (kid->op_type == OP_PADSV) {
5631 name = PAD_COMPNAME_PV(kid->op_targ);
5632 /* SvCUR of a pad namesv can't be trusted
5633 * (see PL_generation), so calc its length
5639 else if (kid->op_type == OP_RV2SV
5640 && kUNOP->op_first->op_type == OP_GV)
5642 GV * const gv = cGVOPx_gv(kUNOP->op_first);
5644 len = GvNAMELEN(gv);
5646 else if (kid->op_type == OP_AELEM
5647 || kid->op_type == OP_HELEM)
5649 OP *op = ((BINOP*)kid)->op_first;
5652 SV *tmpstr = Nullsv;
5653 const char * const a =
5654 kid->op_type == OP_AELEM ?
5656 if (((op->op_type == OP_RV2AV) ||
5657 (op->op_type == OP_RV2HV)) &&
5658 (op = ((UNOP*)op)->op_first) &&
5659 (op->op_type == OP_GV)) {
5660 /* packagevar $a[] or $h{} */
5661 GV * const gv = cGVOPx_gv(op);
5669 else if (op->op_type == OP_PADAV
5670 || op->op_type == OP_PADHV) {
5671 /* lexicalvar $a[] or $h{} */
5672 const char * const padname =
5673 PAD_COMPNAME_PV(op->op_targ);
5682 name = SvPV_const(tmpstr, len);
5687 name = "__ANONIO__";
5694 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5695 namesv = PAD_SVl(targ);
5696 SvUPGRADE(namesv, SVt_PV);
5698 sv_setpvn(namesv, "$", 1);
5699 sv_catpvn(namesv, name, len);
5702 kid->op_sibling = 0;
5703 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5704 kid->op_targ = targ;
5705 kid->op_private |= priv;
5707 kid->op_sibling = sibl;
5713 mod(scalar(kid), type);
5717 tokid = &kid->op_sibling;
5718 kid = kid->op_sibling;
5720 o->op_private |= numargs;
5722 return too_many_arguments(o,OP_DESC(o));
5725 else if (PL_opargs[type] & OA_DEFGV) {
5727 return newUNOP(type, 0, newDEFSVOP());
5731 while (oa & OA_OPTIONAL)
5733 if (oa && oa != OA_LIST)
5734 return too_few_arguments(o,OP_DESC(o));
5740 Perl_ck_glob(pTHX_ OP *o)
5746 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5747 append_elem(OP_GLOB, o, newDEFSVOP());
5749 if (!((gv = gv_fetchpv("glob", 0, SVt_PVCV))
5750 && GvCVu(gv) && GvIMPORTED_CV(gv)))
5752 gv = gv_fetchpv("CORE::GLOBAL::glob", 0, SVt_PVCV);
5755 #if !defined(PERL_EXTERNAL_GLOB)
5756 /* XXX this can be tightened up and made more failsafe. */
5757 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
5760 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
5761 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
5762 gv = gv_fetchpv("CORE::GLOBAL::glob", 0, SVt_PVCV);
5763 glob_gv = gv_fetchpv("File::Glob::csh_glob", 0, SVt_PVCV);
5764 GvCV(gv) = GvCV(glob_gv);
5765 (void)SvREFCNT_inc((SV*)GvCV(gv));
5766 GvIMPORTED_CV_on(gv);
5769 #endif /* PERL_EXTERNAL_GLOB */
5771 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
5772 append_elem(OP_GLOB, o,
5773 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5774 o->op_type = OP_LIST;
5775 o->op_ppaddr = PL_ppaddr[OP_LIST];
5776 cLISTOPo->op_first->op_type = OP_PUSHMARK;
5777 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5778 cLISTOPo->op_first->op_targ = 0;
5779 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5780 append_elem(OP_LIST, o,
5781 scalar(newUNOP(OP_RV2CV, 0,
5782 newGVOP(OP_GV, 0, gv)))));
5783 o = newUNOP(OP_NULL, 0, ck_subr(o));
5784 o->op_targ = OP_GLOB; /* hint at what it used to be */
5787 gv = newGVgen("main");
5789 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5795 Perl_ck_grep(pTHX_ OP *o)
5800 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5803 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5804 NewOp(1101, gwop, 1, LOGOP);
5806 if (o->op_flags & OPf_STACKED) {
5809 kid = cLISTOPo->op_first->op_sibling;
5810 if (!cUNOPx(kid)->op_next)
5811 Perl_croak(aTHX_ "panic: ck_grep");
5812 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
5815 kid->op_next = (OP*)gwop;
5816 o->op_flags &= ~OPf_STACKED;
5818 kid = cLISTOPo->op_first->op_sibling;
5819 if (type == OP_MAPWHILE)
5826 kid = cLISTOPo->op_first->op_sibling;
5827 if (kid->op_type != OP_NULL)
5828 Perl_croak(aTHX_ "panic: ck_grep");
5829 kid = kUNOP->op_first;
5831 gwop->op_type = type;
5832 gwop->op_ppaddr = PL_ppaddr[type];
5833 gwop->op_first = listkids(o);
5834 gwop->op_flags |= OPf_KIDS;
5835 gwop->op_other = LINKLIST(kid);
5836 kid->op_next = (OP*)gwop;
5837 offset = pad_findmy("$_");
5838 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
5839 o->op_private = gwop->op_private = 0;
5840 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5843 o->op_private = gwop->op_private = OPpGREP_LEX;
5844 gwop->op_targ = o->op_targ = offset;
5847 kid = cLISTOPo->op_first->op_sibling;
5848 if (!kid || !kid->op_sibling)
5849 return too_few_arguments(o,OP_DESC(o));
5850 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5851 mod(kid, OP_GREPSTART);
5857 Perl_ck_index(pTHX_ OP *o)
5859 if (o->op_flags & OPf_KIDS) {
5860 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
5862 kid = kid->op_sibling; /* get past "big" */
5863 if (kid && kid->op_type == OP_CONST)
5864 fbm_compile(((SVOP*)kid)->op_sv, 0);
5870 Perl_ck_lengthconst(pTHX_ OP *o)
5872 /* XXX length optimization goes here */
5877 Perl_ck_lfun(pTHX_ OP *o)
5879 const OPCODE type = o->op_type;
5880 return modkids(ck_fun(o), type);
5884 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
5886 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
5887 switch (cUNOPo->op_first->op_type) {
5889 /* This is needed for
5890 if (defined %stash::)
5891 to work. Do not break Tk.
5893 break; /* Globals via GV can be undef */
5895 case OP_AASSIGN: /* Is this a good idea? */
5896 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5897 "defined(@array) is deprecated");
5898 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5899 "\t(Maybe you should just omit the defined()?)\n");
5902 /* This is needed for
5903 if (defined %stash::)
5904 to work. Do not break Tk.
5906 break; /* Globals via GV can be undef */
5908 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5909 "defined(%%hash) is deprecated");
5910 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5911 "\t(Maybe you should just omit the defined()?)\n");
5922 Perl_ck_rfun(pTHX_ OP *o)
5924 const OPCODE type = o->op_type;
5925 return refkids(ck_fun(o), type);
5929 Perl_ck_listiob(pTHX_ OP *o)
5933 kid = cLISTOPo->op_first;
5936 kid = cLISTOPo->op_first;
5938 if (kid->op_type == OP_PUSHMARK)
5939 kid = kid->op_sibling;
5940 if (kid && o->op_flags & OPf_STACKED)
5941 kid = kid->op_sibling;
5942 else if (kid && !kid->op_sibling) { /* print HANDLE; */
5943 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5944 o->op_flags |= OPf_STACKED; /* make it a filehandle */
5945 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5946 cLISTOPo->op_first->op_sibling = kid;
5947 cLISTOPo->op_last = kid;
5948 kid = kid->op_sibling;
5953 append_elem(o->op_type, o, newDEFSVOP());
5959 Perl_ck_say(pTHX_ OP *o)
5962 o->op_type = OP_PRINT;
5963 cLISTOPo->op_last = cLISTOPo->op_last->op_sibling
5964 = newSVOP(OP_CONST, 0, newSVpvn("\n", 1));
5969 Perl_ck_smartmatch(pTHX_ OP *o)
5971 if (0 == (o->op_flags & OPf_SPECIAL)) {
5972 OP *first = cBINOPo->op_first;
5973 OP *second = first->op_sibling;
5975 /* Implicitly take a reference to an array or hash */
5976 first->op_sibling = Nullop;
5977 first = cBINOPo->op_first = ref_array_or_hash(first);
5978 second = first->op_sibling = ref_array_or_hash(second);
5980 /* Implicitly take a reference to a regular expression */
5981 if (first->op_type == OP_MATCH) {
5982 first->op_type = OP_QR;
5983 first->op_ppaddr = PL_ppaddr[OP_QR];
5985 if (second->op_type == OP_MATCH) {
5986 second->op_type = OP_QR;
5987 second->op_ppaddr = PL_ppaddr[OP_QR];
5996 Perl_ck_sassign(pTHX_ OP *o)
5998 OP *kid = cLISTOPo->op_first;
5999 /* has a disposable target? */
6000 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6001 && !(kid->op_flags & OPf_STACKED)
6002 /* Cannot steal the second time! */
6003 && !(kid->op_private & OPpTARGET_MY))
6005 OP * const kkid = kid->op_sibling;
6007 /* Can just relocate the target. */
6008 if (kkid && kkid->op_type == OP_PADSV
6009 && !(kkid->op_private & OPpLVAL_INTRO))
6011 kid->op_targ = kkid->op_targ;
6013 /* Now we do not need PADSV and SASSIGN. */
6014 kid->op_sibling = o->op_sibling; /* NULL */
6015 cLISTOPo->op_first = NULL;
6018 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6026 Perl_ck_match(pTHX_ OP *o)
6028 if (o->op_type != OP_QR && PL_compcv) {
6029 const I32 offset = pad_findmy("$_");
6030 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS(offset) & SVpad_OUR)) {
6031 o->op_targ = offset;
6032 o->op_private |= OPpTARGET_MY;
6035 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
6036 o->op_private |= OPpRUNTIME;
6041 Perl_ck_method(pTHX_ OP *o)
6043 OP * const kid = cUNOPo->op_first;
6044 if (kid->op_type == OP_CONST) {
6045 SV* sv = kSVOP->op_sv;
6046 if (!(strchr(SvPVX_const(sv), ':') || strchr(SvPVX_const(sv), '\''))) {
6048 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6049 sv = newSVpvn_share(SvPVX_const(sv), SvCUR(sv), 0);
6052 kSVOP->op_sv = Nullsv;
6054 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6063 Perl_ck_null(pTHX_ OP *o)
6069 Perl_ck_open(pTHX_ OP *o)
6071 HV * const table = GvHV(PL_hintgv);
6073 SV **svp = hv_fetch(table, "open_IN", 7, FALSE);
6075 const I32 mode = mode_from_discipline(*svp);
6076 if (mode & O_BINARY)
6077 o->op_private |= OPpOPEN_IN_RAW;
6078 else if (mode & O_TEXT)
6079 o->op_private |= OPpOPEN_IN_CRLF;
6082 svp = hv_fetch(table, "open_OUT", 8, FALSE);
6084 const I32 mode = mode_from_discipline(*svp);
6085 if (mode & O_BINARY)
6086 o->op_private |= OPpOPEN_OUT_RAW;
6087 else if (mode & O_TEXT)
6088 o->op_private |= OPpOPEN_OUT_CRLF;
6091 if (o->op_type == OP_BACKTICK)
6094 /* In case of three-arg dup open remove strictness
6095 * from the last arg if it is a bareword. */
6096 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
6097 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
6101 if ((last->op_type == OP_CONST) && /* The bareword. */
6102 (last->op_private & OPpCONST_BARE) &&
6103 (last->op_private & OPpCONST_STRICT) &&
6104 (oa = first->op_sibling) && /* The fh. */
6105 (oa = oa->op_sibling) && /* The mode. */
6106 (oa->op_type == OP_CONST) &&
6107 SvPOK(((SVOP*)oa)->op_sv) &&
6108 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
6109 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
6110 (last == oa->op_sibling)) /* The bareword. */
6111 last->op_private &= ~OPpCONST_STRICT;
6117 Perl_ck_repeat(pTHX_ OP *o)
6119 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6120 o->op_private |= OPpREPEAT_DOLIST;
6121 cBINOPo->op_first = force_list(cBINOPo->op_first);
6129 Perl_ck_require(pTHX_ OP *o)
6133 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6134 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6136 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6137 SV * const sv = kid->op_sv;
6138 U32 was_readonly = SvREADONLY(sv);
6143 sv_force_normal_flags(sv, 0);
6144 assert(!SvREADONLY(sv));
6151 for (s = SvPVX(sv); *s; s++) {
6152 if (*s == ':' && s[1] == ':') {
6153 const STRLEN len = strlen(s+2)+1;
6155 Move(s+2, s+1, len, char);
6156 SvCUR_set(sv, SvCUR(sv) - 1);
6159 sv_catpvn(sv, ".pm", 3);
6160 SvFLAGS(sv) |= was_readonly;
6164 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
6165 /* handle override, if any */
6166 gv = gv_fetchpv("require", 0, SVt_PVCV);
6167 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
6168 GV * const * const gvp = (GV**)hv_fetch(PL_globalstash, "require", 7, FALSE);
6169 gv = gvp ? *gvp : Nullgv;
6173 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6174 OP * const kid = cUNOPo->op_first;
6175 cUNOPo->op_first = 0;
6177 return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
6178 append_elem(OP_LIST, kid,
6179 scalar(newUNOP(OP_RV2CV, 0,
6188 Perl_ck_return(pTHX_ OP *o)
6190 if (CvLVALUE(PL_compcv)) {
6192 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6193 mod(kid, OP_LEAVESUBLV);
6199 Perl_ck_select(pTHX_ OP *o)
6203 if (o->op_flags & OPf_KIDS) {
6204 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6205 if (kid && kid->op_sibling) {
6206 o->op_type = OP_SSELECT;
6207 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6209 return fold_constants(o);
6213 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6214 if (kid && kid->op_type == OP_RV2GV)
6215 kid->op_private &= ~HINT_STRICT_REFS;
6220 Perl_ck_shift(pTHX_ OP *o)
6222 const I32 type = o->op_type;
6224 if (!(o->op_flags & OPf_KIDS)) {
6228 argop = newUNOP(OP_RV2AV, 0,
6229 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
6230 return newUNOP(type, 0, scalar(argop));
6232 return scalar(modkids(ck_fun(o), type));
6236 Perl_ck_sort(pTHX_ OP *o)
6240 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0)
6242 HV *hinthv = GvHV(PL_hintgv);
6244 SV **svp = hv_fetch(hinthv, "sort", 4, 0);
6246 I32 sorthints = (I32)SvIV(*svp);
6247 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
6248 o->op_private |= OPpSORT_QSORT;
6249 if ((sorthints & HINT_SORT_STABLE) != 0)
6250 o->op_private |= OPpSORT_STABLE;
6255 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6257 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6258 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6260 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6262 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6264 if (kid->op_type == OP_SCOPE) {
6268 else if (kid->op_type == OP_LEAVE) {
6269 if (o->op_type == OP_SORT) {
6270 op_null(kid); /* wipe out leave */
6273 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6274 if (k->op_next == kid)
6276 /* don't descend into loops */
6277 else if (k->op_type == OP_ENTERLOOP
6278 || k->op_type == OP_ENTERITER)
6280 k = cLOOPx(k)->op_lastop;
6285 kid->op_next = 0; /* just disconnect the leave */
6286 k = kLISTOP->op_first;
6291 if (o->op_type == OP_SORT) {
6292 /* provide scalar context for comparison function/block */
6298 o->op_flags |= OPf_SPECIAL;
6300 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6303 firstkid = firstkid->op_sibling;
6306 /* provide list context for arguments */
6307 if (o->op_type == OP_SORT)
6314 S_simplify_sort(pTHX_ OP *o)
6316 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6321 if (!(o->op_flags & OPf_STACKED))
6323 GvMULTI_on(gv_fetchpv("a", GV_ADD, SVt_PV));
6324 GvMULTI_on(gv_fetchpv("b", GV_ADD, SVt_PV));
6325 kid = kUNOP->op_first; /* get past null */
6326 if (kid->op_type != OP_SCOPE)
6328 kid = kLISTOP->op_last; /* get past scope */
6329 switch(kid->op_type) {
6337 k = kid; /* remember this node*/
6338 if (kBINOP->op_first->op_type != OP_RV2SV)
6340 kid = kBINOP->op_first; /* get past cmp */
6341 if (kUNOP->op_first->op_type != OP_GV)
6343 kid = kUNOP->op_first; /* get past rv2sv */
6345 if (GvSTASH(gv) != PL_curstash)
6347 gvname = GvNAME(gv);
6348 if (*gvname == 'a' && gvname[1] == '\0')
6350 else if (*gvname == 'b' && gvname[1] == '\0')
6355 kid = k; /* back to cmp */
6356 if (kBINOP->op_last->op_type != OP_RV2SV)
6358 kid = kBINOP->op_last; /* down to 2nd arg */
6359 if (kUNOP->op_first->op_type != OP_GV)
6361 kid = kUNOP->op_first; /* get past rv2sv */
6363 if (GvSTASH(gv) != PL_curstash)
6365 gvname = GvNAME(gv);
6367 ? !(*gvname == 'a' && gvname[1] == '\0')
6368 : !(*gvname == 'b' && gvname[1] == '\0'))
6370 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6372 o->op_private |= OPpSORT_DESCEND;
6373 if (k->op_type == OP_NCMP)
6374 o->op_private |= OPpSORT_NUMERIC;
6375 if (k->op_type == OP_I_NCMP)
6376 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6377 kid = cLISTOPo->op_first->op_sibling;
6378 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6379 op_free(kid); /* then delete it */
6383 Perl_ck_split(pTHX_ OP *o)
6388 if (o->op_flags & OPf_STACKED)
6389 return no_fh_allowed(o);
6391 kid = cLISTOPo->op_first;
6392 if (kid->op_type != OP_NULL)
6393 Perl_croak(aTHX_ "panic: ck_split");
6394 kid = kid->op_sibling;
6395 op_free(cLISTOPo->op_first);
6396 cLISTOPo->op_first = kid;
6398 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6399 cLISTOPo->op_last = kid; /* There was only one element previously */
6402 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6403 OP * const sibl = kid->op_sibling;
6404 kid->op_sibling = 0;
6405 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
6406 if (cLISTOPo->op_first == cLISTOPo->op_last)
6407 cLISTOPo->op_last = kid;
6408 cLISTOPo->op_first = kid;
6409 kid->op_sibling = sibl;
6412 kid->op_type = OP_PUSHRE;
6413 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6415 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
6416 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
6417 "Use of /g modifier is meaningless in split");
6420 if (!kid->op_sibling)
6421 append_elem(OP_SPLIT, o, newDEFSVOP());
6423 kid = kid->op_sibling;
6426 if (!kid->op_sibling)
6427 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6429 kid = kid->op_sibling;
6432 if (kid->op_sibling)
6433 return too_many_arguments(o,OP_DESC(o));
6439 Perl_ck_join(pTHX_ OP *o)
6441 const OP * const kid = cLISTOPo->op_first->op_sibling;
6442 if (kid && kid->op_type == OP_MATCH) {
6443 if (ckWARN(WARN_SYNTAX)) {
6444 const REGEXP *re = PM_GETRE(kPMOP);
6445 const char *pmstr = re ? re->precomp : "STRING";
6446 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6447 "/%s/ should probably be written as \"%s\"",
6455 Perl_ck_subr(pTHX_ OP *o)
6457 OP *prev = ((cUNOPo->op_first->op_sibling)
6458 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6459 OP *o2 = prev->op_sibling;
6466 I32 contextclass = 0;
6470 o->op_private |= OPpENTERSUB_HASTARG;
6471 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6472 if (cvop->op_type == OP_RV2CV) {
6474 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6475 op_null(cvop); /* disable rv2cv */
6476 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6477 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6478 GV *gv = cGVOPx_gv(tmpop);
6481 tmpop->op_private |= OPpEARLY_CV;
6484 namegv = CvANON(cv) ? gv : CvGV(cv);
6485 proto = SvPV_nolen((SV*)cv);
6487 if (CvASSERTION(cv)) {
6488 if (PL_hints & HINT_ASSERTING) {
6489 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
6490 o->op_private |= OPpENTERSUB_DB;
6494 if (!(PL_hints & HINT_ASSERTIONSSEEN) && ckWARN(WARN_ASSERTIONS)) {
6495 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
6496 "Impossible to activate assertion call");
6503 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6504 if (o2->op_type == OP_CONST)
6505 o2->op_private &= ~OPpCONST_STRICT;
6506 else if (o2->op_type == OP_LIST) {
6507 OP * const o = ((UNOP*)o2)->op_first->op_sibling;
6508 if (o && o->op_type == OP_CONST)
6509 o->op_private &= ~OPpCONST_STRICT;
6512 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6513 if (PERLDB_SUB && PL_curstash != PL_debstash)
6514 o->op_private |= OPpENTERSUB_DB;
6515 while (o2 != cvop) {
6519 return too_many_arguments(o, gv_ename(namegv));
6537 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6539 arg == 1 ? "block or sub {}" : "sub {}",
6540 gv_ename(namegv), o2);
6543 /* '*' allows any scalar type, including bareword */
6546 if (o2->op_type == OP_RV2GV)
6547 goto wrapref; /* autoconvert GLOB -> GLOBref */
6548 else if (o2->op_type == OP_CONST)
6549 o2->op_private &= ~OPpCONST_STRICT;
6550 else if (o2->op_type == OP_ENTERSUB) {
6551 /* accidental subroutine, revert to bareword */
6552 OP *gvop = ((UNOP*)o2)->op_first;
6553 if (gvop && gvop->op_type == OP_NULL) {
6554 gvop = ((UNOP*)gvop)->op_first;
6556 for (; gvop->op_sibling; gvop = gvop->op_sibling)
6559 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6560 (gvop = ((UNOP*)gvop)->op_first) &&
6561 gvop->op_type == OP_GV)
6563 GV * const gv = cGVOPx_gv(gvop);
6564 OP * const sibling = o2->op_sibling;
6565 SV * const n = newSVpvn("",0);
6567 gv_fullname4(n, gv, "", FALSE);
6568 o2 = newSVOP(OP_CONST, 0, n);
6569 prev->op_sibling = o2;
6570 o2->op_sibling = sibling;
6586 if (contextclass++ == 0) {
6587 e = strchr(proto, ']');
6588 if (!e || e == proto)
6597 /* XXX We shouldn't be modifying proto, so we can const proto */
6602 while (*--p != '[');
6603 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
6604 gv_ename(namegv), o2);
6610 if (o2->op_type == OP_RV2GV)
6613 bad_type(arg, "symbol", gv_ename(namegv), o2);
6616 if (o2->op_type == OP_ENTERSUB)
6619 bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6622 if (o2->op_type == OP_RV2SV ||
6623 o2->op_type == OP_PADSV ||
6624 o2->op_type == OP_HELEM ||
6625 o2->op_type == OP_AELEM ||
6626 o2->op_type == OP_THREADSV)
6629 bad_type(arg, "scalar", gv_ename(namegv), o2);
6632 if (o2->op_type == OP_RV2AV ||
6633 o2->op_type == OP_PADAV)
6636 bad_type(arg, "array", gv_ename(namegv), o2);
6639 if (o2->op_type == OP_RV2HV ||
6640 o2->op_type == OP_PADHV)
6643 bad_type(arg, "hash", gv_ename(namegv), o2);
6648 OP* const sib = kid->op_sibling;
6649 kid->op_sibling = 0;
6650 o2 = newUNOP(OP_REFGEN, 0, kid);
6651 o2->op_sibling = sib;
6652 prev->op_sibling = o2;
6654 if (contextclass && e) {
6669 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
6670 gv_ename(namegv), cv);
6675 mod(o2, OP_ENTERSUB);
6677 o2 = o2->op_sibling;
6679 if (proto && !optional &&
6680 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6681 return too_few_arguments(o, gv_ename(namegv));
6684 o=newSVOP(OP_CONST, 0, newSViv(0));
6690 Perl_ck_svconst(pTHX_ OP *o)
6692 SvREADONLY_on(cSVOPo->op_sv);
6697 Perl_ck_trunc(pTHX_ OP *o)
6699 if (o->op_flags & OPf_KIDS) {
6700 SVOP *kid = (SVOP*)cUNOPo->op_first;
6702 if (kid->op_type == OP_NULL)
6703 kid = (SVOP*)kid->op_sibling;
6704 if (kid && kid->op_type == OP_CONST &&
6705 (kid->op_private & OPpCONST_BARE))
6707 o->op_flags |= OPf_SPECIAL;
6708 kid->op_private &= ~OPpCONST_STRICT;
6715 Perl_ck_unpack(pTHX_ OP *o)
6717 OP *kid = cLISTOPo->op_first;
6718 if (kid->op_sibling) {
6719 kid = kid->op_sibling;
6720 if (!kid->op_sibling)
6721 kid->op_sibling = newDEFSVOP();
6727 Perl_ck_substr(pTHX_ OP *o)
6730 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6731 OP *kid = cLISTOPo->op_first;
6733 if (kid->op_type == OP_NULL)
6734 kid = kid->op_sibling;
6736 kid->op_flags |= OPf_MOD;
6742 /* A peephole optimizer. We visit the ops in the order they're to execute.
6743 * See the comments at the top of this file for more details about when
6744 * peep() is called */
6747 Perl_peep(pTHX_ register OP *o)
6750 register OP* oldop = 0;
6752 if (!o || o->op_opt)
6756 SAVEVPTR(PL_curcop);
6757 for (; o; o = o->op_next) {
6761 switch (o->op_type) {
6765 PL_curcop = ((COP*)o); /* for warnings */
6770 if (cSVOPo->op_private & OPpCONST_STRICT)
6771 no_bareword_allowed(o);
6773 case OP_METHOD_NAMED:
6774 /* Relocate sv to the pad for thread safety.
6775 * Despite being a "constant", the SV is written to,
6776 * for reference counts, sv_upgrade() etc. */
6778 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6779 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
6780 /* If op_sv is already a PADTMP then it is being used by
6781 * some pad, so make a copy. */
6782 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
6783 SvREADONLY_on(PAD_SVl(ix));
6784 SvREFCNT_dec(cSVOPo->op_sv);
6787 SvREFCNT_dec(PAD_SVl(ix));
6788 SvPADTMP_on(cSVOPo->op_sv);
6789 PAD_SETSV(ix, cSVOPo->op_sv);
6790 /* XXX I don't know how this isn't readonly already. */
6791 SvREADONLY_on(PAD_SVl(ix));
6793 cSVOPo->op_sv = Nullsv;
6801 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6802 if (o->op_next->op_private & OPpTARGET_MY) {
6803 if (o->op_flags & OPf_STACKED) /* chained concats */
6804 goto ignore_optimization;
6806 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6807 o->op_targ = o->op_next->op_targ;
6808 o->op_next->op_targ = 0;
6809 o->op_private |= OPpTARGET_MY;
6812 op_null(o->op_next);
6814 ignore_optimization:
6818 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6820 break; /* Scalar stub must produce undef. List stub is noop */
6824 if (o->op_targ == OP_NEXTSTATE
6825 || o->op_targ == OP_DBSTATE
6826 || o->op_targ == OP_SETSTATE)
6828 PL_curcop = ((COP*)o);
6830 /* XXX: We avoid setting op_seq here to prevent later calls
6831 to peep() from mistakenly concluding that optimisation
6832 has already occurred. This doesn't fix the real problem,
6833 though (See 20010220.007). AMS 20010719 */
6834 /* op_seq functionality is now replaced by op_opt */
6835 if (oldop && o->op_next) {
6836 oldop->op_next = o->op_next;
6844 if (oldop && o->op_next) {
6845 oldop->op_next = o->op_next;
6853 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
6854 OP* const pop = (o->op_type == OP_PADAV) ?
6855 o->op_next : o->op_next->op_next;
6857 if (pop && pop->op_type == OP_CONST &&
6858 ((PL_op = pop->op_next)) &&
6859 pop->op_next->op_type == OP_AELEM &&
6860 !(pop->op_next->op_private &
6861 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6862 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
6867 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
6868 no_bareword_allowed(pop);
6869 if (o->op_type == OP_GV)
6870 op_null(o->op_next);
6871 op_null(pop->op_next);
6873 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6874 o->op_next = pop->op_next->op_next;
6875 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6876 o->op_private = (U8)i;
6877 if (o->op_type == OP_GV) {
6882 o->op_flags |= OPf_SPECIAL;
6883 o->op_type = OP_AELEMFAST;
6889 if (o->op_next->op_type == OP_RV2SV) {
6890 if (!(o->op_next->op_private & OPpDEREF)) {
6891 op_null(o->op_next);
6892 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6894 o->op_next = o->op_next->op_next;
6895 o->op_type = OP_GVSV;
6896 o->op_ppaddr = PL_ppaddr[OP_GVSV];
6899 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6900 GV * const gv = cGVOPo_gv;
6901 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
6902 /* XXX could check prototype here instead of just carping */
6903 SV * const sv = sv_newmortal();
6904 gv_efullname3(sv, gv, Nullch);
6905 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
6906 "%"SVf"() called too early to check prototype",
6910 else if (o->op_next->op_type == OP_READLINE
6911 && o->op_next->op_next->op_type == OP_CONCAT
6912 && (o->op_next->op_next->op_flags & OPf_STACKED))
6914 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
6915 o->op_type = OP_RCATLINE;
6916 o->op_flags |= OPf_STACKED;
6917 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
6918 op_null(o->op_next->op_next);
6919 op_null(o->op_next);
6936 while (cLOGOP->op_other->op_type == OP_NULL)
6937 cLOGOP->op_other = cLOGOP->op_other->op_next;
6938 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
6944 while (cLOOP->op_redoop->op_type == OP_NULL)
6945 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6946 peep(cLOOP->op_redoop);
6947 while (cLOOP->op_nextop->op_type == OP_NULL)
6948 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6949 peep(cLOOP->op_nextop);
6950 while (cLOOP->op_lastop->op_type == OP_NULL)
6951 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6952 peep(cLOOP->op_lastop);
6959 while (cPMOP->op_pmreplstart &&
6960 cPMOP->op_pmreplstart->op_type == OP_NULL)
6961 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6962 peep(cPMOP->op_pmreplstart);
6967 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
6968 && ckWARN(WARN_SYNTAX))
6970 if (o->op_next->op_sibling &&
6971 o->op_next->op_sibling->op_type != OP_EXIT &&
6972 o->op_next->op_sibling->op_type != OP_WARN &&
6973 o->op_next->op_sibling->op_type != OP_DIE) {
6974 const line_t oldline = CopLINE(PL_curcop);
6976 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6977 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6978 "Statement unlikely to be reached");
6979 Perl_warner(aTHX_ packWARN(WARN_EXEC),
6980 "\t(Maybe you meant system() when you said exec()?)\n");
6981 CopLINE_set(PL_curcop, oldline);
6991 const char *key = NULL;
6996 if (((BINOP*)o)->op_last->op_type != OP_CONST)
6999 /* Make the CONST have a shared SV */
7000 svp = cSVOPx_svp(((BINOP*)o)->op_last);
7001 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
7002 key = SvPV_const(sv, keylen);
7003 lexname = newSVpvn_share(key,
7004 SvUTF8(sv) ? -(I32)keylen : keylen,
7010 if ((o->op_private & (OPpLVAL_INTRO)))
7013 rop = (UNOP*)((BINOP*)o)->op_first;
7014 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7016 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7017 if (!(SvFLAGS(lexname) & SVpad_TYPED))
7019 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
7020 if (!fields || !GvHV(*fields))
7022 key = SvPV_const(*svp, keylen);
7023 if (!hv_fetch(GvHV(*fields), key,
7024 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
7026 Perl_croak(aTHX_ "No such class field \"%s\" "
7027 "in variable %s of type %s",
7028 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
7041 SVOP *first_key_op, *key_op;
7043 if ((o->op_private & (OPpLVAL_INTRO))
7044 /* I bet there's always a pushmark... */
7045 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
7046 /* hmmm, no optimization if list contains only one key. */
7048 rop = (UNOP*)((LISTOP*)o)->op_last;
7049 if (rop->op_type != OP_RV2HV)
7051 if (rop->op_first->op_type == OP_PADSV)
7052 /* @$hash{qw(keys here)} */
7053 rop = (UNOP*)rop->op_first;
7055 /* @{$hash}{qw(keys here)} */
7056 if (rop->op_first->op_type == OP_SCOPE
7057 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
7059 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
7065 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
7066 if (!(SvFLAGS(lexname) & SVpad_TYPED))
7068 fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
7069 if (!fields || !GvHV(*fields))
7071 /* Again guessing that the pushmark can be jumped over.... */
7072 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
7073 ->op_first->op_sibling;
7074 for (key_op = first_key_op; key_op;
7075 key_op = (SVOP*)key_op->op_sibling) {
7076 if (key_op->op_type != OP_CONST)
7078 svp = cSVOPx_svp(key_op);
7079 key = SvPV_const(*svp, keylen);
7080 if (!hv_fetch(GvHV(*fields), key,
7081 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
7083 Perl_croak(aTHX_ "No such class field \"%s\" "
7084 "in variable %s of type %s",
7085 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
7092 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
7096 /* check that RHS of sort is a single plain array */
7097 OP *oright = cUNOPo->op_first;
7098 if (!oright || oright->op_type != OP_PUSHMARK)
7101 /* reverse sort ... can be optimised. */
7102 if (!cUNOPo->op_sibling) {
7103 /* Nothing follows us on the list. */
7104 OP * const reverse = o->op_next;
7106 if (reverse->op_type == OP_REVERSE &&
7107 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
7108 OP * const pushmark = cUNOPx(reverse)->op_first;
7109 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
7110 && (cUNOPx(pushmark)->op_sibling == o)) {
7111 /* reverse -> pushmark -> sort */
7112 o->op_private |= OPpSORT_REVERSE;
7114 pushmark->op_next = oright->op_next;
7120 /* make @a = sort @a act in-place */
7124 oright = cUNOPx(oright)->op_sibling;
7127 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
7128 oright = cUNOPx(oright)->op_sibling;
7132 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
7133 || oright->op_next != o
7134 || (oright->op_private & OPpLVAL_INTRO)
7138 /* o2 follows the chain of op_nexts through the LHS of the
7139 * assign (if any) to the aassign op itself */
7141 if (!o2 || o2->op_type != OP_NULL)
7144 if (!o2 || o2->op_type != OP_PUSHMARK)
7147 if (o2 && o2->op_type == OP_GV)
7150 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
7151 || (o2->op_private & OPpLVAL_INTRO)
7156 if (!o2 || o2->op_type != OP_NULL)
7159 if (!o2 || o2->op_type != OP_AASSIGN
7160 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
7163 /* check that the sort is the first arg on RHS of assign */
7165 o2 = cUNOPx(o2)->op_first;
7166 if (!o2 || o2->op_type != OP_NULL)
7168 o2 = cUNOPx(o2)->op_first;
7169 if (!o2 || o2->op_type != OP_PUSHMARK)
7171 if (o2->op_sibling != o)
7174 /* check the array is the same on both sides */
7175 if (oleft->op_type == OP_RV2AV) {
7176 if (oright->op_type != OP_RV2AV
7177 || !cUNOPx(oright)->op_first
7178 || cUNOPx(oright)->op_first->op_type != OP_GV
7179 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
7180 cGVOPx_gv(cUNOPx(oright)->op_first)
7184 else if (oright->op_type != OP_PADAV
7185 || oright->op_targ != oleft->op_targ
7189 /* transfer MODishness etc from LHS arg to RHS arg */
7190 oright->op_flags = oleft->op_flags;
7191 o->op_private |= OPpSORT_INPLACE;
7193 /* excise push->gv->rv2av->null->aassign */
7194 o2 = o->op_next->op_next;
7195 op_null(o2); /* PUSHMARK */
7197 if (o2->op_type == OP_GV) {
7198 op_null(o2); /* GV */
7201 op_null(o2); /* RV2AV or PADAV */
7202 o2 = o2->op_next->op_next;
7203 op_null(o2); /* AASSIGN */
7205 o->op_next = o2->op_next;
7211 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
7213 LISTOP *enter, *exlist;
7216 enter = (LISTOP *) o->op_next;
7219 if (enter->op_type == OP_NULL) {
7220 enter = (LISTOP *) enter->op_next;
7224 /* for $a (...) will have OP_GV then OP_RV2GV here.
7225 for (...) just has an OP_GV. */
7226 if (enter->op_type == OP_GV) {
7227 gvop = (OP *) enter;
7228 enter = (LISTOP *) enter->op_next;
7231 if (enter->op_type == OP_RV2GV) {
7232 enter = (LISTOP *) enter->op_next;
7238 if (enter->op_type != OP_ENTERITER)
7241 iter = enter->op_next;
7242 if (!iter || iter->op_type != OP_ITER)
7245 expushmark = enter->op_first;
7246 if (!expushmark || expushmark->op_type != OP_NULL
7247 || expushmark->op_targ != OP_PUSHMARK)
7250 exlist = (LISTOP *) expushmark->op_sibling;
7251 if (!exlist || exlist->op_type != OP_NULL
7252 || exlist->op_targ != OP_LIST)
7255 if (exlist->op_last != o) {
7256 /* Mmm. Was expecting to point back to this op. */
7259 theirmark = exlist->op_first;
7260 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
7263 if (theirmark->op_sibling != o) {
7264 /* There's something between the mark and the reverse, eg
7265 for (1, reverse (...))
7270 ourmark = ((LISTOP *)o)->op_first;
7271 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
7274 ourlast = ((LISTOP *)o)->op_last;
7275 if (!ourlast || ourlast->op_next != o)
7278 rv2av = ourmark->op_sibling;
7279 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
7280 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
7281 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
7282 /* We're just reversing a single array. */
7283 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
7284 enter->op_flags |= OPf_STACKED;
7287 /* We don't have control over who points to theirmark, so sacrifice
7289 theirmark->op_next = ourmark->op_next;
7290 theirmark->op_flags = ourmark->op_flags;
7291 ourlast->op_next = gvop ? gvop : (OP *) enter;
7294 enter->op_private |= OPpITER_REVERSED;
7295 iter->op_private |= OPpITER_REVERSED;
7310 Perl_custom_op_name(pTHX_ const OP* o)
7312 const IV index = PTR2IV(o->op_ppaddr);
7316 if (!PL_custom_op_names) /* This probably shouldn't happen */
7317 return (char *)PL_op_name[OP_CUSTOM];
7319 keysv = sv_2mortal(newSViv(index));
7321 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
7323 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
7325 return SvPV_nolen(HeVAL(he));
7329 Perl_custom_op_desc(pTHX_ const OP* o)
7331 const IV index = PTR2IV(o->op_ppaddr);
7335 if (!PL_custom_op_descs)
7336 return (char *)PL_op_desc[OP_CUSTOM];
7338 keysv = sv_2mortal(newSViv(index));
7340 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
7342 return (char *)PL_op_desc[OP_CUSTOM];
7344 return SvPV_nolen(HeVAL(he));
7349 /* Efficient sub that returns a constant scalar value. */
7351 const_sv_xsub(pTHX_ CV* cv)
7356 Perl_croak(aTHX_ "usage: %s::%s()",
7357 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7361 ST(0) = (SV*)XSANY.any_ptr;
7367 * c-indentation-style: bsd
7369 * indent-tabs-mode: t
7372 * ex: set ts=8 sts=4 sw=4 noet: