3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * "You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
13 * our Mr. Bilbo's first cousin on the mother's side (her mother being the
14 * youngest of the Old Took's daughters); and Mr. Drogo was his second
15 * cousin. So Mr. Frodo is his first *and* second cousin, once removed
16 * either way, as the saying is, if you follow me." --the Gaffer
19 /* This file contains the functions that create, manipulate and optimize
20 * the OP structures that hold a compiled perl program.
22 * A Perl program is compiled into a tree of OPs. Each op contains
23 * structural pointers (eg to its siblings and the next op in the
24 * execution sequence), a pointer to the function that would execute the
25 * op, plus any data specific to that op. For example, an OP_CONST op
26 * points to the pp_const() function and to an SV containing the constant
27 * value. When pp_const() is executed, its job is to push that SV onto the
30 * OPs are mainly created by the newFOO() functions, which are mainly
31 * called from the parser (in perly.y) as the code is parsed. For example
32 * the Perl code $a + $b * $c would cause the equivalent of the following
33 * to be called (oversimplifying a bit):
35 * newBINOP(OP_ADD, flags,
37 * newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
40 * Note that during the build of miniperl, a temporary copy of this file
41 * is made, called opmini.c.
45 Perl's compiler is essentially a 3-pass compiler with interleaved phases:
49 An execution-order pass
51 The bottom-up pass is represented by all the "newOP" routines and
52 the ck_ routines. The bottom-upness is actually driven by yacc.
53 So at the point that a ck_ routine fires, we have no idea what the
54 context is, either upward in the syntax tree, or either forward or
55 backward in the execution order. (The bottom-up parser builds that
56 part of the execution order it knows about, but if you follow the "next"
57 links around, you'll find it's actually a closed loop through the
60 Whenever the bottom-up parser gets to a node that supplies context to
61 its components, it invokes that portion of the top-down pass that applies
62 to that part of the subtree (and marks the top node as processed, so
63 if a node further up supplies context, it doesn't have to take the
64 plunge again). As a particular subcase of this, as the new node is
65 built, it takes all the closed execution loops of its subcomponents
66 and links them into a new closed loop for the higher level node. But
67 it's still not the real execution order.
69 The actual execution order is not known till we get a grammar reduction
70 to a top-level unit like a subroutine or file that will be called by
71 "name" rather than via a "next" pointer. At that point, we can call
72 into peep() to do that code's portion of the 3rd pass. It has to be
73 recursive, but it's recursive on basic blocks, not on tree nodes.
81 #define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
83 #if defined(PL_OP_SLAB_ALLOC)
85 #ifndef PERL_SLAB_SIZE
86 #define PERL_SLAB_SIZE 2048
90 Perl_Slab_Alloc(pTHX_ int m, size_t sz)
93 * To make incrementing use count easy PL_OpSlab is an I32 *
94 * To make inserting the link to slab PL_OpPtr is I32 **
95 * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
96 * Add an overhead for pointer to slab and round up as a number of pointers
98 sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
99 if ((PL_OpSpace -= sz) < 0) {
100 PL_OpPtr = (I32 **) PerlMemShared_malloc(PERL_SLAB_SIZE*sizeof(I32*));
104 Zero(PL_OpPtr,PERL_SLAB_SIZE,I32 **);
105 /* We reserve the 0'th I32 sized chunk as a use count */
106 PL_OpSlab = (I32 *) PL_OpPtr;
107 /* Reduce size by the use count word, and by the size we need.
108 * Latter is to mimic the '-=' in the if() above
110 PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
111 /* Allocation pointer starts at the top.
112 Theory: because we build leaves before trunk allocating at end
113 means that at run time access is cache friendly upward
115 PL_OpPtr += PERL_SLAB_SIZE;
117 assert( PL_OpSpace >= 0 );
118 /* Move the allocation pointer down */
120 assert( PL_OpPtr > (I32 **) PL_OpSlab );
121 *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */
122 (*PL_OpSlab)++; /* Increment use count of slab */
123 assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
124 assert( *PL_OpSlab > 0 );
125 return (void *)(PL_OpPtr + 1);
129 Perl_Slab_Free(pTHX_ void *op)
131 I32 * const * const ptr = (I32 **) op;
132 I32 * const slab = ptr[-1];
133 assert( ptr-1 > (I32 **) slab );
134 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
136 if (--(*slab) == 0) {
138 # define PerlMemShared PerlMem
141 PerlMemShared_free(slab);
142 if (slab == PL_OpSlab) {
149 * In the following definition, the ", (OP*)0" is just to make the compiler
150 * think the expression is of the right type: croak actually does a Siglongjmp.
152 #define CHECKOP(type,o) \
153 ((PL_op_mask && PL_op_mask[type]) \
154 ? ( op_free((OP*)o), \
155 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
157 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
159 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
162 S_gv_ename(pTHX_ GV *gv)
164 SV* const tmpsv = sv_newmortal();
165 gv_efullname3(tmpsv, gv, NULL);
166 return SvPV_nolen_const(tmpsv);
170 S_no_fh_allowed(pTHX_ OP *o)
172 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
178 S_too_few_arguments(pTHX_ OP *o, const char *name)
180 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
185 S_too_many_arguments(pTHX_ OP *o, const char *name)
187 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
192 S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid)
194 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
195 (int)n, name, t, OP_DESC(kid)));
199 S_no_bareword_allowed(pTHX_ const OP *o)
202 return; /* various ok barewords are hidden in extra OP_NULL */
203 qerror(Perl_mess(aTHX_
204 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
208 /* "register" allocation */
211 Perl_allocmy(pTHX_ char *name)
215 const bool is_our = (PL_in_my == KEY_our);
217 /* complain about "my $<special_var>" etc etc */
221 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
222 (name[1] == '_' && (*name == '$' || name[2]))))
224 /* name[2] is true if strlen(name) > 2 */
225 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
226 /* 1999-02-27 mjd@plover.com */
228 p = strchr(name, '\0');
229 /* The next block assumes the buffer is at least 205 chars
230 long. At present, it's always at least 256 chars. */
232 strcpy(name+200, "...");
238 /* Move everything else down one character */
239 for (; p-name > 2; p--)
241 name[2] = toCTRL(name[1]);
244 yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
247 /* check for duplicate declaration */
248 pad_check_dup(name, is_our, (PL_curstash ? PL_curstash : PL_defstash));
250 if (PL_in_my_stash && *name != '$') {
251 yyerror(Perl_form(aTHX_
252 "Can't declare class for non-scalar %s in \"%s\"",
253 name, is_our ? "our" : "my"));
256 /* allocate a spare slot and store the name in that slot */
258 off = pad_add_name(name,
261 /* $_ is always in main::, even with our */
262 ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
273 Perl_op_free(pTHX_ OP *o)
278 if (!o || o->op_static)
282 if (o->op_private & OPpREFCOUNTED) {
293 refcnt = OpREFCNT_dec(o);
304 if (o->op_flags & OPf_KIDS) {
305 register OP *kid, *nextkid;
306 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
307 nextkid = kid->op_sibling; /* Get before next freeing kid */
312 type = (OPCODE)o->op_targ;
314 /* COP* is not cleared by op_clear() so that we may track line
315 * numbers etc even after null() */
316 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
321 #ifdef DEBUG_LEAKING_SCALARS
328 Perl_op_clear(pTHX_ OP *o)
333 /* if (o->op_madprop && o->op_madprop->mad_next)
335 /* FIXME for MAD - if I uncomment these two lines t/op/pack.t fails with
336 "modification of a read only value" for a reason I can't fathom why.
337 It's the "" stringification of $_, where $_ was set to '' in a foreach
338 loop, but it defies simplification into a small test case. */
340 mad_free(o->op_madprop);
346 switch (o->op_type) {
347 case OP_NULL: /* Was holding old type, if any. */
348 if (PL_madskills && o->op_targ != OP_NULL) {
349 o->op_type = o->op_targ;
353 case OP_ENTEREVAL: /* Was holding hints. */
357 if (!(o->op_flags & OPf_REF)
358 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
364 if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
365 /* not an OP_PADAV replacement */
367 if (cPADOPo->op_padix > 0) {
368 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
369 * may still exist on the pad */
370 pad_swipe(cPADOPo->op_padix, TRUE);
371 cPADOPo->op_padix = 0;
374 SvREFCNT_dec(cSVOPo->op_sv);
375 cSVOPo->op_sv = NULL;
379 case OP_METHOD_NAMED:
381 SvREFCNT_dec(cSVOPo->op_sv);
382 cSVOPo->op_sv = NULL;
385 Even if op_clear does a pad_free for the target of the op,
386 pad_free doesn't actually remove the sv that exists in the pad;
387 instead it lives on. This results in that it could be reused as
388 a target later on when the pad was reallocated.
391 pad_swipe(o->op_targ,1);
400 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
404 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
405 SvREFCNT_dec(cSVOPo->op_sv);
406 cSVOPo->op_sv = NULL;
409 Safefree(cPVOPo->op_pv);
410 cPVOPo->op_pv = NULL;
414 op_free(cPMOPo->op_pmreplroot);
418 if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) {
419 /* No GvIN_PAD_off here, because other references may still
420 * exist on the pad */
421 pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot), TRUE);
424 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
431 HV * const pmstash = PmopSTASH(cPMOPo);
432 if (pmstash && !SvIS_FREED(pmstash)) {
433 MAGIC * const mg = mg_find((SV*)pmstash, PERL_MAGIC_symtab);
435 PMOP *pmop = (PMOP*) mg->mg_obj;
436 PMOP *lastpmop = NULL;
438 if (cPMOPo == pmop) {
440 lastpmop->op_pmnext = pmop->op_pmnext;
442 mg->mg_obj = (SV*) pmop->op_pmnext;
446 pmop = pmop->op_pmnext;
450 PmopSTASH_free(cPMOPo);
452 cPMOPo->op_pmreplroot = NULL;
453 /* we use the "SAFE" version of the PM_ macros here
454 * since sv_clean_all might release some PMOPs
455 * after PL_regex_padav has been cleared
456 * and the clearing of PL_regex_padav needs to
457 * happen before sv_clean_all
459 ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
460 PM_SETRE_SAFE(cPMOPo, NULL);
462 if(PL_regex_pad) { /* We could be in destruction */
463 av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
464 SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
465 PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
472 if (o->op_targ > 0) {
473 pad_free(o->op_targ);
479 S_cop_free(pTHX_ COP* cop)
481 Safefree(cop->cop_label); /* FIXME: treaddead ??? */
484 if (! specialWARN(cop->cop_warnings))
485 SvREFCNT_dec(cop->cop_warnings);
486 if (! specialCopIO(cop->cop_io)) {
490 SvREFCNT_dec(cop->cop_io);
496 Perl_op_null(pTHX_ OP *o)
499 if (o->op_type == OP_NULL)
503 o->op_targ = o->op_type;
504 o->op_type = OP_NULL;
505 o->op_ppaddr = PL_ppaddr[OP_NULL];
509 Perl_op_refcnt_lock(pTHX)
517 Perl_op_refcnt_unlock(pTHX)
524 /* Contextualizers */
526 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
529 Perl_linklist(pTHX_ OP *o)
536 /* establish postfix order */
537 first = cUNOPo->op_first;
540 o->op_next = LINKLIST(first);
543 if (kid->op_sibling) {
544 kid->op_next = LINKLIST(kid->op_sibling);
545 kid = kid->op_sibling;
559 Perl_scalarkids(pTHX_ OP *o)
561 if (o && o->op_flags & OPf_KIDS) {
563 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
570 S_scalarboolean(pTHX_ OP *o)
573 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
574 if (ckWARN(WARN_SYNTAX)) {
575 const line_t oldline = CopLINE(PL_curcop);
577 if (PL_copline != NOLINE)
578 CopLINE_set(PL_curcop, PL_copline);
579 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
580 CopLINE_set(PL_curcop, oldline);
587 Perl_scalar(pTHX_ OP *o)
592 /* assumes no premature commitment */
593 if (!o || PL_error_count || (o->op_flags & OPf_WANT)
594 || o->op_type == OP_RETURN)
599 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
601 switch (o->op_type) {
603 scalar(cBINOPo->op_first);
608 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
612 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
613 if (!kPMOP->op_pmreplroot)
614 deprecate_old("implicit split to @_");
622 if (o->op_flags & OPf_KIDS) {
623 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
629 kid = cLISTOPo->op_first;
631 while ((kid = kid->op_sibling)) {
637 WITH_THR(PL_curcop = &PL_compiling);
642 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
648 WITH_THR(PL_curcop = &PL_compiling);
651 if (ckWARN(WARN_VOID))
652 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
658 Perl_scalarvoid(pTHX_ OP *o)
662 const char* useless = NULL;
666 /* trailing mad null ops don't count as "there" for void processing */
668 o->op_type != OP_NULL &&
670 o->op_sibling->op_type == OP_NULL)
673 for (sib = o->op_sibling;
674 sib && sib->op_type == OP_NULL;
675 sib = sib->op_sibling) ;
681 if (o->op_type == OP_NEXTSTATE
682 || o->op_type == OP_SETSTATE
683 || o->op_type == OP_DBSTATE
684 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
685 || o->op_targ == OP_SETSTATE
686 || o->op_targ == OP_DBSTATE)))
687 PL_curcop = (COP*)o; /* for warning below */
689 /* assumes no premature commitment */
690 want = o->op_flags & OPf_WANT;
691 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
692 || o->op_type == OP_RETURN)
697 if ((o->op_private & OPpTARGET_MY)
698 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
700 return scalar(o); /* As if inside SASSIGN */
703 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
705 switch (o->op_type) {
707 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
711 if (o->op_flags & OPf_STACKED)
715 if (o->op_private == 4)
787 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
788 useless = OP_DESC(o);
792 kid = cUNOPo->op_first;
793 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
794 kid->op_type != OP_TRANS) {
797 useless = "negative pattern binding (!~)";
804 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
805 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
806 useless = "a variable";
811 if (cSVOPo->op_private & OPpCONST_STRICT)
812 no_bareword_allowed(o);
814 if (ckWARN(WARN_VOID)) {
815 useless = "a constant";
816 if (o->op_private & OPpCONST_ARYBASE)
818 /* don't warn on optimised away booleans, eg
819 * use constant Foo, 5; Foo || print; */
820 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
822 /* the constants 0 and 1 are permitted as they are
823 conventionally used as dummies in constructs like
824 1 while some_condition_with_side_effects; */
825 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
827 else if (SvPOK(sv)) {
828 /* perl4's way of mixing documentation and code
829 (before the invention of POD) was based on a
830 trick to mix nroff and perl code. The trick was
831 built upon these three nroff macros being used in
832 void context. The pink camel has the details in
833 the script wrapman near page 319. */
834 const char * const maybe_macro = SvPVX_const(sv);
835 if (strnEQ(maybe_macro, "di", 2) ||
836 strnEQ(maybe_macro, "ds", 2) ||
837 strnEQ(maybe_macro, "ig", 2))
842 op_null(o); /* don't execute or even remember it */
846 o->op_type = OP_PREINC; /* pre-increment is faster */
847 o->op_ppaddr = PL_ppaddr[OP_PREINC];
851 o->op_type = OP_PREDEC; /* pre-decrement is faster */
852 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
856 o->op_type = OP_I_PREINC; /* pre-increment is faster */
857 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
861 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
862 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
871 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
876 if (o->op_flags & OPf_STACKED)
883 if (!(o->op_flags & OPf_KIDS))
894 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
901 /* all requires must return a boolean value */
902 o->op_flags &= ~OPf_WANT;
907 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
908 if (!kPMOP->op_pmreplroot)
909 deprecate_old("implicit split to @_");
913 if (useless && ckWARN(WARN_VOID))
914 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
919 Perl_listkids(pTHX_ OP *o)
921 if (o && o->op_flags & OPf_KIDS) {
923 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
930 Perl_list(pTHX_ OP *o)
935 /* assumes no premature commitment */
936 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
937 || o->op_type == OP_RETURN)
942 if ((o->op_private & OPpTARGET_MY)
943 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
945 return o; /* As if inside SASSIGN */
948 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
950 switch (o->op_type) {
953 list(cBINOPo->op_first);
958 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
966 if (!(o->op_flags & OPf_KIDS))
968 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
969 list(cBINOPo->op_first);
970 return gen_constant_list(o);
977 kid = cLISTOPo->op_first;
979 while ((kid = kid->op_sibling)) {
985 WITH_THR(PL_curcop = &PL_compiling);
989 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
995 WITH_THR(PL_curcop = &PL_compiling);
998 /* all requires must return a boolean value */
999 o->op_flags &= ~OPf_WANT;
1006 Perl_scalarseq(pTHX_ OP *o)
1010 if (o->op_type == OP_LINESEQ ||
1011 o->op_type == OP_SCOPE ||
1012 o->op_type == OP_LEAVE ||
1013 o->op_type == OP_LEAVETRY)
1016 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1017 if (kid->op_sibling) {
1021 PL_curcop = &PL_compiling;
1023 o->op_flags &= ~OPf_PARENS;
1024 if (PL_hints & HINT_BLOCK_SCOPE)
1025 o->op_flags |= OPf_PARENS;
1028 o = newOP(OP_STUB, 0);
1033 S_modkids(pTHX_ OP *o, I32 type)
1035 if (o && o->op_flags & OPf_KIDS) {
1037 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1043 /* Propagate lvalue ("modifiable") context to an op and its children.
1044 * 'type' represents the context type, roughly based on the type of op that
1045 * would do the modifying, although local() is represented by OP_NULL.
1046 * It's responsible for detecting things that can't be modified, flag
1047 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
1048 * might have to vivify a reference in $x), and so on.
1050 * For example, "$a+1 = 2" would cause mod() to be called with o being
1051 * OP_ADD and type being OP_SASSIGN, and would output an error.
1055 Perl_mod(pTHX_ OP *o, I32 type)
1059 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1062 if (!o || PL_error_count)
1065 if ((o->op_private & OPpTARGET_MY)
1066 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1071 switch (o->op_type) {
1077 if (!(o->op_private & OPpCONST_ARYBASE))
1080 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1081 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
1085 SAVEI32(PL_compiling.cop_arybase);
1086 PL_compiling.cop_arybase = 0;
1088 else if (type == OP_REFGEN)
1091 Perl_croak(aTHX_ "That use of $[ is unsupported");
1094 if (o->op_flags & OPf_PARENS || PL_madskills)
1098 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1099 !(o->op_flags & OPf_STACKED)) {
1100 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1101 /* The default is to set op_private to the number of children,
1102 which for a UNOP such as RV2CV is always 1. And w're using
1103 the bit for a flag in RV2CV, so we need it clear. */
1104 o->op_private &= ~1;
1105 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1106 assert(cUNOPo->op_first->op_type == OP_NULL);
1107 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1110 else if (o->op_private & OPpENTERSUB_NOMOD)
1112 else { /* lvalue subroutine call */
1113 o->op_private |= OPpLVAL_INTRO;
1114 PL_modcount = RETURN_UNLIMITED_NUMBER;
1115 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1116 /* Backward compatibility mode: */
1117 o->op_private |= OPpENTERSUB_INARGS;
1120 else { /* Compile-time error message: */
1121 OP *kid = cUNOPo->op_first;
1125 if (kid->op_type == OP_PUSHMARK)
1127 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1129 "panic: unexpected lvalue entersub "
1130 "args: type/targ %ld:%"UVuf,
1131 (long)kid->op_type, (UV)kid->op_targ);
1132 kid = kLISTOP->op_first;
1134 while (kid->op_sibling)
1135 kid = kid->op_sibling;
1136 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1138 if (kid->op_type == OP_METHOD_NAMED
1139 || kid->op_type == OP_METHOD)
1143 NewOp(1101, newop, 1, UNOP);
1144 newop->op_type = OP_RV2CV;
1145 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1146 newop->op_first = NULL;
1147 newop->op_next = (OP*)newop;
1148 kid->op_sibling = (OP*)newop;
1149 newop->op_private |= OPpLVAL_INTRO;
1150 newop->op_private &= ~1;
1154 if (kid->op_type != OP_RV2CV)
1156 "panic: unexpected lvalue entersub "
1157 "entry via type/targ %ld:%"UVuf,
1158 (long)kid->op_type, (UV)kid->op_targ);
1159 kid->op_private |= OPpLVAL_INTRO;
1160 break; /* Postpone until runtime */
1164 kid = kUNOP->op_first;
1165 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1166 kid = kUNOP->op_first;
1167 if (kid->op_type == OP_NULL)
1169 "Unexpected constant lvalue entersub "
1170 "entry via type/targ %ld:%"UVuf,
1171 (long)kid->op_type, (UV)kid->op_targ);
1172 if (kid->op_type != OP_GV) {
1173 /* Restore RV2CV to check lvalueness */
1175 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1176 okid->op_next = kid->op_next;
1177 kid->op_next = okid;
1180 okid->op_next = NULL;
1181 okid->op_type = OP_RV2CV;
1183 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1184 okid->op_private |= OPpLVAL_INTRO;
1185 okid->op_private &= ~1;
1189 cv = GvCV(kGVOP_gv);
1199 /* grep, foreach, subcalls, refgen */
1200 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1202 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1203 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1205 : (o->op_type == OP_ENTERSUB
1206 ? "non-lvalue subroutine call"
1208 type ? PL_op_desc[type] : "local"));
1222 case OP_RIGHT_SHIFT:
1231 if (!(o->op_flags & OPf_STACKED))
1238 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1244 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1245 PL_modcount = RETURN_UNLIMITED_NUMBER;
1246 return o; /* Treat \(@foo) like ordinary list. */
1250 if (scalar_mod_type(o, type))
1252 ref(cUNOPo->op_first, o->op_type);
1256 if (type == OP_LEAVESUBLV)
1257 o->op_private |= OPpMAYBE_LVSUB;
1263 PL_modcount = RETURN_UNLIMITED_NUMBER;
1266 ref(cUNOPo->op_first, o->op_type);
1271 PL_hints |= HINT_BLOCK_SCOPE;
1286 PL_modcount = RETURN_UNLIMITED_NUMBER;
1287 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1288 return o; /* Treat \(@foo) like ordinary list. */
1289 if (scalar_mod_type(o, type))
1291 if (type == OP_LEAVESUBLV)
1292 o->op_private |= OPpMAYBE_LVSUB;
1296 if (!type) /* local() */
1297 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1298 PAD_COMPNAME_PV(o->op_targ));
1306 if (type != OP_SASSIGN)
1310 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1315 if (type == OP_LEAVESUBLV)
1316 o->op_private |= OPpMAYBE_LVSUB;
1318 pad_free(o->op_targ);
1319 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1320 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1321 if (o->op_flags & OPf_KIDS)
1322 mod(cBINOPo->op_first->op_sibling, type);
1327 ref(cBINOPo->op_first, o->op_type);
1328 if (type == OP_ENTERSUB &&
1329 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1330 o->op_private |= OPpLVAL_DEFER;
1331 if (type == OP_LEAVESUBLV)
1332 o->op_private |= OPpMAYBE_LVSUB;
1342 if (o->op_flags & OPf_KIDS)
1343 mod(cLISTOPo->op_last, type);
1348 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1350 else if (!(o->op_flags & OPf_KIDS))
1352 if (o->op_targ != OP_LIST) {
1353 mod(cBINOPo->op_first, type);
1359 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1364 if (type != OP_LEAVESUBLV)
1366 break; /* mod()ing was handled by ck_return() */
1369 /* [20011101.069] File test operators interpret OPf_REF to mean that
1370 their argument is a filehandle; thus \stat(".") should not set
1372 if (type == OP_REFGEN &&
1373 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1376 if (type != OP_LEAVESUBLV)
1377 o->op_flags |= OPf_MOD;
1379 if (type == OP_AASSIGN || type == OP_SASSIGN)
1380 o->op_flags |= OPf_SPECIAL|OPf_REF;
1381 else if (!type) { /* local() */
1384 o->op_private |= OPpLVAL_INTRO;
1385 o->op_flags &= ~OPf_SPECIAL;
1386 PL_hints |= HINT_BLOCK_SCOPE;
1391 if (ckWARN(WARN_SYNTAX)) {
1392 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1393 "Useless localization of %s", OP_DESC(o));
1397 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1398 && type != OP_LEAVESUBLV)
1399 o->op_flags |= OPf_REF;
1404 S_scalar_mod_type(const OP *o, I32 type)
1408 if (o->op_type == OP_RV2GV)
1432 case OP_RIGHT_SHIFT:
1451 S_is_handle_constructor(const OP *o, I32 numargs)
1453 switch (o->op_type) {
1461 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1474 Perl_refkids(pTHX_ OP *o, I32 type)
1476 if (o && o->op_flags & OPf_KIDS) {
1478 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1485 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
1490 if (!o || PL_error_count)
1493 switch (o->op_type) {
1495 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1496 !(o->op_flags & OPf_STACKED)) {
1497 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1498 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1499 assert(cUNOPo->op_first->op_type == OP_NULL);
1500 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1501 o->op_flags |= OPf_SPECIAL;
1502 o->op_private &= ~1;
1507 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1508 doref(kid, type, set_op_ref);
1511 if (type == OP_DEFINED)
1512 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1513 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1516 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1517 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1518 : type == OP_RV2HV ? OPpDEREF_HV
1520 o->op_flags |= OPf_MOD;
1525 o->op_flags |= OPf_MOD; /* XXX ??? */
1531 o->op_flags |= OPf_REF;
1534 if (type == OP_DEFINED)
1535 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1536 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1542 o->op_flags |= OPf_REF;
1547 if (!(o->op_flags & OPf_KIDS))
1549 doref(cBINOPo->op_first, type, set_op_ref);
1553 doref(cBINOPo->op_first, o->op_type, set_op_ref);
1554 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1555 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1556 : type == OP_RV2HV ? OPpDEREF_HV
1558 o->op_flags |= OPf_MOD;
1568 if (!(o->op_flags & OPf_KIDS))
1570 doref(cLISTOPo->op_last, type, set_op_ref);
1580 S_dup_attrlist(pTHX_ OP *o)
1585 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1586 * where the first kid is OP_PUSHMARK and the remaining ones
1587 * are OP_CONST. We need to push the OP_CONST values.
1589 if (o->op_type == OP_CONST)
1590 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
1592 else if (o->op_type == OP_NULL)
1596 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1598 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1599 if (o->op_type == OP_CONST)
1600 rop = append_elem(OP_LIST, rop,
1601 newSVOP(OP_CONST, o->op_flags,
1602 SvREFCNT_inc_NN(cSVOPo->op_sv)));
1609 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1614 /* fake up C<use attributes $pkg,$rv,@attrs> */
1615 ENTER; /* need to protect against side-effects of 'use' */
1617 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1619 #define ATTRSMODULE "attributes"
1620 #define ATTRSMODULE_PM "attributes.pm"
1623 /* Don't force the C<use> if we don't need it. */
1624 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
1625 if (svp && *svp != &PL_sv_undef)
1626 /*EMPTY*/; /* already in %INC */
1628 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1629 newSVpvs(ATTRSMODULE), NULL);
1632 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1633 newSVpvs(ATTRSMODULE),
1635 prepend_elem(OP_LIST,
1636 newSVOP(OP_CONST, 0, stashsv),
1637 prepend_elem(OP_LIST,
1638 newSVOP(OP_CONST, 0,
1640 dup_attrlist(attrs))));
1646 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1649 OP *pack, *imop, *arg;
1655 assert(target->op_type == OP_PADSV ||
1656 target->op_type == OP_PADHV ||
1657 target->op_type == OP_PADAV);
1659 /* Ensure that attributes.pm is loaded. */
1660 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1662 /* Need package name for method call. */
1663 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
1665 /* Build up the real arg-list. */
1666 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1668 arg = newOP(OP_PADSV, 0);
1669 arg->op_targ = target->op_targ;
1670 arg = prepend_elem(OP_LIST,
1671 newSVOP(OP_CONST, 0, stashsv),
1672 prepend_elem(OP_LIST,
1673 newUNOP(OP_REFGEN, 0,
1674 mod(arg, OP_REFGEN)),
1675 dup_attrlist(attrs)));
1677 /* Fake up a method call to import */
1678 meth = newSVpvs_share("import");
1679 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1680 append_elem(OP_LIST,
1681 prepend_elem(OP_LIST, pack, list(arg)),
1682 newSVOP(OP_METHOD_NAMED, 0, meth)));
1683 imop->op_private |= OPpENTERSUB_NOMOD;
1685 /* Combine the ops. */
1686 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1690 =notfor apidoc apply_attrs_string
1692 Attempts to apply a list of attributes specified by the C<attrstr> and
1693 C<len> arguments to the subroutine identified by the C<cv> argument which
1694 is expected to be associated with the package identified by the C<stashpv>
1695 argument (see L<attributes>). It gets this wrong, though, in that it
1696 does not correctly identify the boundaries of the individual attribute
1697 specifications within C<attrstr>. This is not really intended for the
1698 public API, but has to be listed here for systems such as AIX which
1699 need an explicit export list for symbols. (It's called from XS code
1700 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1701 to respect attribute syntax properly would be welcome.
1707 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
1708 const char *attrstr, STRLEN len)
1713 len = strlen(attrstr);
1717 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1719 const char * const sstr = attrstr;
1720 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1721 attrs = append_elem(OP_LIST, attrs,
1722 newSVOP(OP_CONST, 0,
1723 newSVpvn(sstr, attrstr-sstr)));
1727 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1728 newSVpvs(ATTRSMODULE),
1729 NULL, prepend_elem(OP_LIST,
1730 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1731 prepend_elem(OP_LIST,
1732 newSVOP(OP_CONST, 0,
1738 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
1743 if (!o || PL_error_count)
1746 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
1747 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
1752 if (type == OP_LIST) {
1754 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1755 my_kid(kid, attrs, imopsp);
1756 } else if (type == OP_UNDEF
1762 } else if (type == OP_RV2SV || /* "our" declaration */
1764 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1765 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1766 yyerror(Perl_form(aTHX_ "Can't declare %s in %s",
1767 OP_DESC(o), PL_in_my == KEY_our ? "our" : "my"));
1769 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
1771 PL_in_my_stash = NULL;
1772 apply_attrs(GvSTASH(gv),
1773 (type == OP_RV2SV ? GvSV(gv) :
1774 type == OP_RV2AV ? (SV*)GvAV(gv) :
1775 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1778 o->op_private |= OPpOUR_INTRO;
1781 else if (type != OP_PADSV &&
1784 type != OP_PUSHMARK)
1786 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1788 PL_in_my == KEY_our ? "our" : "my"));
1791 else if (attrs && type != OP_PUSHMARK) {
1795 PL_in_my_stash = NULL;
1797 /* check for C<my Dog $spot> when deciding package */
1798 stash = PAD_COMPNAME_TYPE(o->op_targ);
1800 stash = PL_curstash;
1801 apply_attrs_my(stash, o, attrs, imopsp);
1803 o->op_flags |= OPf_MOD;
1804 o->op_private |= OPpLVAL_INTRO;
1809 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1813 int maybe_scalar = 0;
1815 /* [perl #17376]: this appears to be premature, and results in code such as
1816 C< our(%x); > executing in list mode rather than void mode */
1818 if (o->op_flags & OPf_PARENS)
1828 o = my_kid(o, attrs, &rops);
1830 if (maybe_scalar && o->op_type == OP_PADSV) {
1831 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
1832 o->op_private |= OPpLVAL_INTRO;
1835 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
1838 PL_in_my_stash = NULL;
1843 Perl_my(pTHX_ OP *o)
1845 return my_attrs(o, NULL);
1849 Perl_sawparens(pTHX_ OP *o)
1851 PERL_UNUSED_CONTEXT;
1853 o->op_flags |= OPf_PARENS;
1858 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
1863 if ( (left->op_type == OP_RV2AV ||
1864 left->op_type == OP_RV2HV ||
1865 left->op_type == OP_PADAV ||
1866 left->op_type == OP_PADHV)
1867 && ckWARN(WARN_MISC))
1869 const char * const desc = PL_op_desc[(right->op_type == OP_SUBST ||
1870 right->op_type == OP_TRANS)
1871 ? right->op_type : OP_MATCH];
1872 const char * const sample = ((left->op_type == OP_RV2AV ||
1873 left->op_type == OP_PADAV)
1874 ? "@array" : "%hash");
1875 Perl_warner(aTHX_ packWARN(WARN_MISC),
1876 "Applying %s to %s will act on scalar(%s)",
1877 desc, sample, sample);
1880 if (right->op_type == OP_CONST &&
1881 cSVOPx(right)->op_private & OPpCONST_BARE &&
1882 cSVOPx(right)->op_private & OPpCONST_STRICT)
1884 no_bareword_allowed(right);
1887 ismatchop = right->op_type == OP_MATCH ||
1888 right->op_type == OP_SUBST ||
1889 right->op_type == OP_TRANS;
1890 if (ismatchop && right->op_private & OPpTARGET_MY) {
1892 right->op_private &= ~OPpTARGET_MY;
1894 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
1895 right->op_flags |= OPf_STACKED;
1896 if (right->op_type != OP_MATCH &&
1897 ! (right->op_type == OP_TRANS &&
1898 right->op_private & OPpTRANS_IDENTICAL))
1899 left = mod(left, right->op_type);
1900 if (right->op_type == OP_TRANS)
1901 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
1903 o = prepend_elem(right->op_type, scalar(left), right);
1905 return newUNOP(OP_NOT, 0, scalar(o));
1909 return bind_match(type, left,
1910 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
1914 Perl_invert(pTHX_ OP *o)
1918 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
1919 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
1923 Perl_scope(pTHX_ OP *o)
1927 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
1928 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
1929 o->op_type = OP_LEAVE;
1930 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
1932 else if (o->op_type == OP_LINESEQ) {
1934 o->op_type = OP_SCOPE;
1935 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
1936 kid = ((LISTOP*)o)->op_first;
1937 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
1940 /* The following deals with things like 'do {1 for 1}' */
1941 kid = kid->op_sibling;
1943 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
1948 o = newLISTOP(OP_SCOPE, 0, o, NULL);
1954 Perl_block_start(pTHX_ int full)
1957 const int retval = PL_savestack_ix;
1958 pad_block_start(full);
1960 PL_hints &= ~HINT_BLOCK_SCOPE;
1961 SAVESPTR(PL_compiling.cop_warnings);
1962 if (! specialWARN(PL_compiling.cop_warnings)) {
1963 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
1964 SAVEFREESV(PL_compiling.cop_warnings) ;
1966 SAVESPTR(PL_compiling.cop_io);
1967 if (! specialCopIO(PL_compiling.cop_io)) {
1968 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
1969 SAVEFREESV(PL_compiling.cop_io) ;
1975 Perl_block_end(pTHX_ I32 floor, OP *seq)
1978 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
1979 OP* const retval = scalarseq(seq);
1981 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
1983 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
1992 const I32 offset = pad_findmy("$_");
1993 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
1994 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
1997 OP * const o = newOP(OP_PADSV, 0);
1998 o->op_targ = offset;
2004 Perl_newPROG(pTHX_ OP *o)
2010 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2011 ((PL_in_eval & EVAL_KEEPERR)
2012 ? OPf_SPECIAL : 0), o);
2013 PL_eval_start = linklist(PL_eval_root);
2014 PL_eval_root->op_private |= OPpREFCOUNTED;
2015 OpREFCNT_set(PL_eval_root, 1);
2016 PL_eval_root->op_next = 0;
2017 CALL_PEEP(PL_eval_start);
2020 if (o->op_type == OP_STUB) {
2021 PL_comppad_name = 0;
2026 PL_main_root = scope(sawparens(scalarvoid(o)));
2027 PL_curcop = &PL_compiling;
2028 PL_main_start = LINKLIST(PL_main_root);
2029 PL_main_root->op_private |= OPpREFCOUNTED;
2030 OpREFCNT_set(PL_main_root, 1);
2031 PL_main_root->op_next = 0;
2032 CALL_PEEP(PL_main_start);
2035 /* Register with debugger */
2037 CV * const cv = get_cv("DB::postponed", FALSE);
2041 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2043 call_sv((SV*)cv, G_DISCARD);
2050 Perl_localize(pTHX_ OP *o, I32 lex)
2053 if (o->op_flags & OPf_PARENS)
2054 /* [perl #17376]: this appears to be premature, and results in code such as
2055 C< our(%x); > executing in list mode rather than void mode */
2062 if ( PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ','
2063 && ckWARN(WARN_PARENTHESIS))
2065 char *s = PL_bufptr;
2068 /* some heuristics to detect a potential error */
2069 while (*s && (strchr(", \t\n", *s)))
2073 if (*s && strchr("@$%*", *s) && *++s
2074 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2077 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2079 while (*s && (strchr(", \t\n", *s)))
2085 if (sigil && (*s == ';' || *s == '=')) {
2086 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2087 "Parentheses missing around \"%s\" list",
2088 lex ? (PL_in_my == KEY_our ? "our" : "my")
2096 o = mod(o, OP_NULL); /* a bit kludgey */
2098 PL_in_my_stash = NULL;
2103 Perl_jmaybe(pTHX_ OP *o)
2105 if (o->op_type == OP_LIST) {
2107 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL,
2109 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2115 Perl_fold_constants(pTHX_ register OP *o)
2120 I32 type = o->op_type;
2123 if (PL_opargs[type] & OA_RETSCALAR)
2125 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2126 o->op_targ = pad_alloc(type, SVs_PADTMP);
2128 /* integerize op, unless it happens to be C<-foo>.
2129 * XXX should pp_i_negate() do magic string negation instead? */
2130 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2131 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2132 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2134 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2137 if (!(PL_opargs[type] & OA_FOLDCONST))
2142 /* XXX might want a ck_negate() for this */
2143 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2154 /* XXX what about the numeric ops? */
2155 if (PL_hints & HINT_LOCALE)
2160 goto nope; /* Don't try to run w/ errors */
2162 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2163 if ((curop->op_type != OP_CONST ||
2164 (curop->op_private & OPpCONST_BARE)) &&
2165 curop->op_type != OP_LIST &&
2166 curop->op_type != OP_SCALAR &&
2167 curop->op_type != OP_NULL &&
2168 curop->op_type != OP_PUSHMARK)
2174 curop = LINKLIST(o);
2178 sv = *(PL_stack_sp--);
2179 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2180 pad_swipe(o->op_targ, FALSE);
2181 else if (SvTEMP(sv)) { /* grab mortal temp? */
2182 SvREFCNT_inc_simple_void(sv);
2189 if (type == OP_RV2GV)
2190 newop = newGVOP(OP_GV, 0, (GV*)sv);
2192 newop = newSVOP(OP_CONST, 0, sv);
2193 op_getmad(o,newop,'f');
2201 Perl_gen_constant_list(pTHX_ register OP *o)
2205 const I32 oldtmps_floor = PL_tmps_floor;
2209 return o; /* Don't attempt to run with errors */
2211 PL_op = curop = LINKLIST(o);
2218 PL_tmps_floor = oldtmps_floor;
2220 o->op_type = OP_RV2AV;
2221 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2222 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2223 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2224 o->op_opt = 0; /* needs to be revisited in peep() */
2225 curop = ((UNOP*)o)->op_first;
2226 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
2228 op_getmad(curop,o,'O');
2237 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2240 if (!o || o->op_type != OP_LIST)
2241 o = newLISTOP(OP_LIST, 0, o, NULL);
2243 o->op_flags &= ~OPf_WANT;
2245 if (!(PL_opargs[type] & OA_MARK))
2246 op_null(cLISTOPo->op_first);
2248 o->op_type = (OPCODE)type;
2249 o->op_ppaddr = PL_ppaddr[type];
2250 o->op_flags |= flags;
2252 o = CHECKOP(type, o);
2253 if (o->op_type != (unsigned)type)
2256 return fold_constants(o);
2259 /* List constructors */
2262 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2270 if (first->op_type != (unsigned)type
2271 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2273 return newLISTOP(type, 0, first, last);
2276 if (first->op_flags & OPf_KIDS)
2277 ((LISTOP*)first)->op_last->op_sibling = last;
2279 first->op_flags |= OPf_KIDS;
2280 ((LISTOP*)first)->op_first = last;
2282 ((LISTOP*)first)->op_last = last;
2287 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2295 if (first->op_type != (unsigned)type)
2296 return prepend_elem(type, (OP*)first, (OP*)last);
2298 if (last->op_type != (unsigned)type)
2299 return append_elem(type, (OP*)first, (OP*)last);
2301 first->op_last->op_sibling = last->op_first;
2302 first->op_last = last->op_last;
2303 first->op_flags |= (last->op_flags & OPf_KIDS);
2306 if (last->op_first && first->op_madprop) {
2307 MADPROP *mp = last->op_first->op_madprop;
2309 while (mp->mad_next)
2311 mp->mad_next = first->op_madprop;
2314 last->op_first->op_madprop = first->op_madprop;
2317 first->op_madprop = last->op_madprop;
2318 last->op_madprop = 0;
2327 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2335 if (last->op_type == (unsigned)type) {
2336 if (type == OP_LIST) { /* already a PUSHMARK there */
2337 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2338 ((LISTOP*)last)->op_first->op_sibling = first;
2339 if (!(first->op_flags & OPf_PARENS))
2340 last->op_flags &= ~OPf_PARENS;
2343 if (!(last->op_flags & OPf_KIDS)) {
2344 ((LISTOP*)last)->op_last = first;
2345 last->op_flags |= OPf_KIDS;
2347 first->op_sibling = ((LISTOP*)last)->op_first;
2348 ((LISTOP*)last)->op_first = first;
2350 last->op_flags |= OPf_KIDS;
2354 return newLISTOP(type, 0, first, last);
2362 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2365 Newxz(tk, 1, TOKEN);
2366 tk->tk_type = (OPCODE)optype;
2367 tk->tk_type = 12345;
2369 tk->tk_mad = madprop;
2374 Perl_token_free(pTHX_ TOKEN* tk)
2376 if (tk->tk_type != 12345)
2378 mad_free(tk->tk_mad);
2383 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2387 if (tk->tk_type != 12345) {
2388 Perl_warner(aTHX_ packWARN(WARN_MISC),
2389 "Invalid TOKEN object ignored");
2396 /* faked up qw list? */
2398 tm->mad_type == MAD_SV &&
2399 SvPVX((SV*)tm->mad_val)[0] == 'q')
2406 /* pretend constant fold didn't happen? */
2407 if (mp->mad_key == 'f' &&
2408 (o->op_type == OP_CONST ||
2409 o->op_type == OP_GV) )
2411 token_getmad(tk,(OP*)mp->mad_val,slot);
2425 if (mp->mad_key == 'X')
2426 mp->mad_key = slot; /* just change the first one */
2436 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
2445 /* pretend constant fold didn't happen? */
2446 if (mp->mad_key == 'f' &&
2447 (o->op_type == OP_CONST ||
2448 o->op_type == OP_GV) )
2450 op_getmad(from,(OP*)mp->mad_val,slot);
2457 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
2460 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
2466 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
2475 /* pretend constant fold didn't happen? */
2476 if (mp->mad_key == 'f' &&
2477 (o->op_type == OP_CONST ||
2478 o->op_type == OP_GV) )
2480 op_getmad(from,(OP*)mp->mad_val,slot);
2487 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
2490 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
2494 PerlIO_printf(PerlIO_stderr(),
2495 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
2501 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
2519 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
2523 addmad(tm, &(o->op_madprop), slot);
2527 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
2548 Perl_newMADsv(pTHX_ char key, SV* sv)
2550 return newMADPROP(key, MAD_SV, sv, 0);
2554 Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
2557 Newxz(mp, 1, MADPROP);
2560 mp->mad_vlen = vlen;
2561 mp->mad_type = type;
2563 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
2568 Perl_mad_free(pTHX_ MADPROP* mp)
2570 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
2574 mad_free(mp->mad_next);
2575 /* if (PL_lex_state != LEX_NOTPARSING && mp->mad_vlen)
2576 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
2577 switch (mp->mad_type) {
2581 Safefree((char*)mp->mad_val);
2584 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
2585 op_free((OP*)mp->mad_val);
2588 sv_free((SV*)mp->mad_val);
2591 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
2600 Perl_newNULLLIST(pTHX)
2602 return newOP(OP_STUB, 0);
2606 Perl_force_list(pTHX_ OP *o)
2608 if (!o || o->op_type != OP_LIST)
2609 o = newLISTOP(OP_LIST, 0, o, NULL);
2615 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2620 NewOp(1101, listop, 1, LISTOP);
2622 listop->op_type = (OPCODE)type;
2623 listop->op_ppaddr = PL_ppaddr[type];
2626 listop->op_flags = (U8)flags;
2630 else if (!first && last)
2633 first->op_sibling = last;
2634 listop->op_first = first;
2635 listop->op_last = last;
2636 if (type == OP_LIST) {
2637 OP* const pushop = newOP(OP_PUSHMARK, 0);
2638 pushop->op_sibling = first;
2639 listop->op_first = pushop;
2640 listop->op_flags |= OPf_KIDS;
2642 listop->op_last = pushop;
2645 return CHECKOP(type, listop);
2649 Perl_newOP(pTHX_ I32 type, I32 flags)
2653 NewOp(1101, o, 1, OP);
2654 o->op_type = (OPCODE)type;
2655 o->op_ppaddr = PL_ppaddr[type];
2656 o->op_flags = (U8)flags;
2659 o->op_private = (U8)(0 | (flags >> 8));
2660 if (PL_opargs[type] & OA_RETSCALAR)
2662 if (PL_opargs[type] & OA_TARGET)
2663 o->op_targ = pad_alloc(type, SVs_PADTMP);
2664 return CHECKOP(type, o);
2668 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2674 first = newOP(OP_STUB, 0);
2675 if (PL_opargs[type] & OA_MARK)
2676 first = force_list(first);
2678 NewOp(1101, unop, 1, UNOP);
2679 unop->op_type = (OPCODE)type;
2680 unop->op_ppaddr = PL_ppaddr[type];
2681 unop->op_first = first;
2682 unop->op_flags = (U8)(flags | OPf_KIDS);
2683 unop->op_private = (U8)(1 | (flags >> 8));
2684 unop = (UNOP*) CHECKOP(type, unop);
2688 return fold_constants((OP *) unop);
2692 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2696 NewOp(1101, binop, 1, BINOP);
2699 first = newOP(OP_NULL, 0);
2701 binop->op_type = (OPCODE)type;
2702 binop->op_ppaddr = PL_ppaddr[type];
2703 binop->op_first = first;
2704 binop->op_flags = (U8)(flags | OPf_KIDS);
2707 binop->op_private = (U8)(1 | (flags >> 8));
2710 binop->op_private = (U8)(2 | (flags >> 8));
2711 first->op_sibling = last;
2714 binop = (BINOP*)CHECKOP(type, binop);
2715 if (binop->op_next || binop->op_type != (OPCODE)type)
2718 binop->op_last = binop->op_first->op_sibling;
2720 return fold_constants((OP *)binop);
2723 static int uvcompare(const void *a, const void *b)
2724 __attribute__nonnull__(1)
2725 __attribute__nonnull__(2)
2726 __attribute__pure__;
2727 static int uvcompare(const void *a, const void *b)
2729 if (*((const UV *)a) < (*(const UV *)b))
2731 if (*((const UV *)a) > (*(const UV *)b))
2733 if (*((const UV *)a+1) < (*(const UV *)b+1))
2735 if (*((const UV *)a+1) > (*(const UV *)b+1))
2741 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2744 SV * const tstr = ((SVOP*)expr)->op_sv;
2745 SV * const rstr = ((SVOP*)repl)->op_sv;
2748 const U8 *t = (U8*)SvPV_const(tstr, tlen);
2749 const U8 *r = (U8*)SvPV_const(rstr, rlen);
2753 register short *tbl;
2755 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
2756 const I32 squash = o->op_private & OPpTRANS_SQUASH;
2757 I32 del = o->op_private & OPpTRANS_DELETE;
2758 PL_hints |= HINT_BLOCK_SCOPE;
2761 o->op_private |= OPpTRANS_FROM_UTF;
2764 o->op_private |= OPpTRANS_TO_UTF;
2766 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2767 SV* const listsv = newSVpvs("# comment\n");
2769 const U8* tend = t + tlen;
2770 const U8* rend = r + rlen;
2784 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2785 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2791 t = tsave = bytes_to_utf8(t, &len);
2794 if (!to_utf && rlen) {
2796 r = rsave = bytes_to_utf8(r, &len);
2800 /* There are several snags with this code on EBCDIC:
2801 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2802 2. scan_const() in toke.c has encoded chars in native encoding which makes
2803 ranges at least in EBCDIC 0..255 range the bottom odd.
2807 U8 tmpbuf[UTF8_MAXBYTES+1];
2810 Newx(cp, 2*tlen, UV);
2812 transv = newSVpvs("");
2814 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2816 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2818 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2822 cp[2*i+1] = cp[2*i];
2826 qsort(cp, i, 2*sizeof(UV), uvcompare);
2827 for (j = 0; j < i; j++) {
2829 diff = val - nextmin;
2831 t = uvuni_to_utf8(tmpbuf,nextmin);
2832 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2834 U8 range_mark = UTF_TO_NATIVE(0xff);
2835 t = uvuni_to_utf8(tmpbuf, val - 1);
2836 sv_catpvn(transv, (char *)&range_mark, 1);
2837 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2844 t = uvuni_to_utf8(tmpbuf,nextmin);
2845 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2847 U8 range_mark = UTF_TO_NATIVE(0xff);
2848 sv_catpvn(transv, (char *)&range_mark, 1);
2850 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2851 UNICODE_ALLOW_SUPER);
2852 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2853 t = (const U8*)SvPVX_const(transv);
2854 tlen = SvCUR(transv);
2858 else if (!rlen && !del) {
2859 r = t; rlen = tlen; rend = tend;
2862 if ((!rlen && !del) || t == r ||
2863 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2865 o->op_private |= OPpTRANS_IDENTICAL;
2869 while (t < tend || tfirst <= tlast) {
2870 /* see if we need more "t" chars */
2871 if (tfirst > tlast) {
2872 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2874 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2876 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2883 /* now see if we need more "r" chars */
2884 if (rfirst > rlast) {
2886 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2888 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2890 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2899 rfirst = rlast = 0xffffffff;
2903 /* now see which range will peter our first, if either. */
2904 tdiff = tlast - tfirst;
2905 rdiff = rlast - rfirst;
2912 if (rfirst == 0xffffffff) {
2913 diff = tdiff; /* oops, pretend rdiff is infinite */
2915 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2916 (long)tfirst, (long)tlast);
2918 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2922 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2923 (long)tfirst, (long)(tfirst + diff),
2926 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2927 (long)tfirst, (long)rfirst);
2929 if (rfirst + diff > max)
2930 max = rfirst + diff;
2932 grows = (tfirst < rfirst &&
2933 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2945 else if (max > 0xff)
2950 Safefree(cPVOPo->op_pv);
2951 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2952 SvREFCNT_dec(listsv);
2953 SvREFCNT_dec(transv);
2955 if (!del && havefinal && rlen)
2956 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2957 newSVuv((UV)final), 0);
2960 o->op_private |= OPpTRANS_GROWS;
2966 op_getmad(expr,o,'e');
2967 op_getmad(repl,o,'r');
2975 tbl = (short*)cPVOPo->op_pv;
2977 Zero(tbl, 256, short);
2978 for (i = 0; i < (I32)tlen; i++)
2980 for (i = 0, j = 0; i < 256; i++) {
2982 if (j >= (I32)rlen) {
2991 if (i < 128 && r[j] >= 128)
3001 o->op_private |= OPpTRANS_IDENTICAL;
3003 else if (j >= (I32)rlen)
3006 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
3007 tbl[0x100] = (short)(rlen - j);
3008 for (i=0; i < (I32)rlen - j; i++)
3009 tbl[0x101+i] = r[j+i];
3013 if (!rlen && !del) {
3016 o->op_private |= OPpTRANS_IDENTICAL;
3018 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3019 o->op_private |= OPpTRANS_IDENTICAL;
3021 for (i = 0; i < 256; i++)
3023 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3024 if (j >= (I32)rlen) {
3026 if (tbl[t[i]] == -1)
3032 if (tbl[t[i]] == -1) {
3033 if (t[i] < 128 && r[j] >= 128)
3040 o->op_private |= OPpTRANS_GROWS;
3042 op_getmad(expr,o,'e');
3043 op_getmad(repl,o,'r');
3053 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3058 NewOp(1101, pmop, 1, PMOP);
3059 pmop->op_type = (OPCODE)type;
3060 pmop->op_ppaddr = PL_ppaddr[type];
3061 pmop->op_flags = (U8)flags;
3062 pmop->op_private = (U8)(0 | (flags >> 8));
3064 if (PL_hints & HINT_RE_TAINT)
3065 pmop->op_pmpermflags |= PMf_RETAINT;
3066 if (PL_hints & HINT_LOCALE)
3067 pmop->op_pmpermflags |= PMf_LOCALE;
3068 pmop->op_pmflags = pmop->op_pmpermflags;
3071 if (av_len((AV*) PL_regex_pad[0]) > -1) {
3072 SV * const repointer = av_pop((AV*)PL_regex_pad[0]);
3073 pmop->op_pmoffset = SvIV(repointer);
3074 SvREPADTMP_off(repointer);
3075 sv_setiv(repointer,0);
3077 SV * const repointer = newSViv(0);
3078 av_push(PL_regex_padav, SvREFCNT_inc_simple_NN(repointer));
3079 pmop->op_pmoffset = av_len(PL_regex_padav);
3080 PL_regex_pad = AvARRAY(PL_regex_padav);
3084 /* link into pm list */
3085 if (type != OP_TRANS && PL_curstash) {
3086 MAGIC *mg = mg_find((SV*)PL_curstash, PERL_MAGIC_symtab);
3089 mg = sv_magicext((SV*)PL_curstash, 0, PERL_MAGIC_symtab, 0, 0, 0);
3091 pmop->op_pmnext = (PMOP*)mg->mg_obj;
3092 mg->mg_obj = (SV*)pmop;
3093 PmopSTASH_set(pmop,PL_curstash);
3096 return CHECKOP(type, pmop);
3099 /* Given some sort of match op o, and an expression expr containing a
3100 * pattern, either compile expr into a regex and attach it to o (if it's
3101 * constant), or convert expr into a runtime regcomp op sequence (if it's
3104 * isreg indicates that the pattern is part of a regex construct, eg
3105 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3106 * split "pattern", which aren't. In the former case, expr will be a list
3107 * if the pattern contains more than one term (eg /a$b/) or if it contains
3108 * a replacement, ie s/// or tr///.
3112 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
3117 I32 repl_has_vars = 0;
3121 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
3122 /* last element in list is the replacement; pop it */
3124 repl = cLISTOPx(expr)->op_last;
3125 kid = cLISTOPx(expr)->op_first;
3126 while (kid->op_sibling != repl)
3127 kid = kid->op_sibling;
3128 kid->op_sibling = NULL;
3129 cLISTOPx(expr)->op_last = kid;
3132 if (isreg && expr->op_type == OP_LIST &&
3133 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3135 /* convert single element list to element */
3136 OP* const oe = expr;
3137 expr = cLISTOPx(oe)->op_first->op_sibling;
3138 cLISTOPx(oe)->op_first->op_sibling = NULL;
3139 cLISTOPx(oe)->op_last = NULL;
3143 if (o->op_type == OP_TRANS) {
3144 return pmtrans(o, expr, repl);
3147 reglist = isreg && expr->op_type == OP_LIST;
3151 PL_hints |= HINT_BLOCK_SCOPE;
3154 if (expr->op_type == OP_CONST) {
3156 SV * const pat = ((SVOP*)expr)->op_sv;
3157 const char *p = SvPV_const(pat, plen);
3158 if ((o->op_flags & OPf_SPECIAL) && (*p == ' ' && p[1] == '\0')) {
3159 U32 was_readonly = SvREADONLY(pat);
3163 sv_force_normal_flags(pat, 0);
3164 assert(!SvREADONLY(pat));
3167 SvREADONLY_off(pat);
3171 sv_setpvn(pat, "\\s+", 3);
3173 SvFLAGS(pat) |= was_readonly;
3175 p = SvPV_const(pat, plen);
3176 pm->op_pmflags |= PMf_SKIPWHITE;
3179 pm->op_pmdynflags |= PMdf_UTF8;
3180 /* FIXME - can we make this function take const char * args? */
3181 PM_SETRE(pm, CALLREGCOMP(aTHX_ (char*)p, (char*)p + plen, pm));
3182 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
3183 pm->op_pmflags |= PMf_WHITE;
3185 op_getmad(expr,(OP*)pm,'e');
3191 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3192 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3194 : OP_REGCMAYBE),0,expr);
3196 NewOp(1101, rcop, 1, LOGOP);
3197 rcop->op_type = OP_REGCOMP;
3198 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3199 rcop->op_first = scalar(expr);
3200 rcop->op_flags |= OPf_KIDS
3201 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3202 | (reglist ? OPf_STACKED : 0);
3203 rcop->op_private = 1;
3206 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3208 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
3211 /* establish postfix order */
3212 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3214 rcop->op_next = expr;
3215 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3218 rcop->op_next = LINKLIST(expr);
3219 expr->op_next = (OP*)rcop;
3222 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3227 if (pm->op_pmflags & PMf_EVAL) {
3229 if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
3230 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
3232 else if (repl->op_type == OP_CONST)
3236 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3237 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3238 if (curop->op_type == OP_GV) {
3239 GV * const gv = cGVOPx_gv(curop);
3241 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3244 else if (curop->op_type == OP_RV2CV)
3246 else if (curop->op_type == OP_RV2SV ||
3247 curop->op_type == OP_RV2AV ||
3248 curop->op_type == OP_RV2HV ||
3249 curop->op_type == OP_RV2GV) {
3250 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3253 else if (curop->op_type == OP_PADSV ||
3254 curop->op_type == OP_PADAV ||
3255 curop->op_type == OP_PADHV ||
3256 curop->op_type == OP_PADANY) {
3259 else if (curop->op_type == OP_PUSHRE)
3260 /*EMPTY*/; /* Okay here, dangerous in newASSIGNOP */
3270 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
3271 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3272 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
3273 prepend_elem(o->op_type, scalar(repl), o);
3276 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3277 pm->op_pmflags |= PMf_MAYBE_CONST;
3278 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3280 NewOp(1101, rcop, 1, LOGOP);
3281 rcop->op_type = OP_SUBSTCONT;
3282 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3283 rcop->op_first = scalar(repl);
3284 rcop->op_flags |= OPf_KIDS;
3285 rcop->op_private = 1;
3288 /* establish postfix order */
3289 rcop->op_next = LINKLIST(repl);
3290 repl->op_next = (OP*)rcop;
3292 pm->op_pmreplroot = scalar((OP*)rcop);
3293 pm->op_pmreplstart = LINKLIST(rcop);
3302 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3306 NewOp(1101, svop, 1, SVOP);
3307 svop->op_type = (OPCODE)type;
3308 svop->op_ppaddr = PL_ppaddr[type];
3310 svop->op_next = (OP*)svop;
3311 svop->op_flags = (U8)flags;
3312 if (PL_opargs[type] & OA_RETSCALAR)
3314 if (PL_opargs[type] & OA_TARGET)
3315 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3316 return CHECKOP(type, svop);
3320 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3324 NewOp(1101, padop, 1, PADOP);
3325 padop->op_type = (OPCODE)type;
3326 padop->op_ppaddr = PL_ppaddr[type];
3327 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3328 SvREFCNT_dec(PAD_SVl(padop->op_padix));
3329 PAD_SETSV(padop->op_padix, sv);
3332 padop->op_next = (OP*)padop;
3333 padop->op_flags = (U8)flags;
3334 if (PL_opargs[type] & OA_RETSCALAR)
3336 if (PL_opargs[type] & OA_TARGET)
3337 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3338 return CHECKOP(type, padop);
3342 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3348 return newPADOP(type, flags, SvREFCNT_inc_simple(gv));
3350 return newSVOP(type, flags, SvREFCNT_inc_simple(gv));
3355 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3359 NewOp(1101, pvop, 1, PVOP);
3360 pvop->op_type = (OPCODE)type;
3361 pvop->op_ppaddr = PL_ppaddr[type];
3363 pvop->op_next = (OP*)pvop;
3364 pvop->op_flags = (U8)flags;
3365 if (PL_opargs[type] & OA_RETSCALAR)
3367 if (PL_opargs[type] & OA_TARGET)
3368 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3369 return CHECKOP(type, pvop);
3377 Perl_package(pTHX_ OP *o)
3386 save_hptr(&PL_curstash);
3387 save_item(PL_curstname);
3389 name = SvPV_const(cSVOPo->op_sv, len);
3390 PL_curstash = gv_stashpvn(name, len, TRUE);
3391 sv_setpvn(PL_curstname, name, len);
3393 PL_hints |= HINT_BLOCK_SCOPE;
3394 PL_copline = NOLINE;
3400 if (!PL_madskills) {
3405 pegop = newOP(OP_NULL,0);
3406 op_getmad(o,pegop,'P');
3416 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3423 OP *pegop = newOP(OP_NULL,0);
3426 if (idop->op_type != OP_CONST)
3427 Perl_croak(aTHX_ "Module name must be constant");
3430 op_getmad(idop,pegop,'U');
3435 SV * const vesv = ((SVOP*)version)->op_sv;
3438 op_getmad(version,pegop,'V');
3439 if (!arg && !SvNIOKp(vesv)) {
3446 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3447 Perl_croak(aTHX_ "Version number must be constant number");
3449 /* Make copy of idop so we don't free it twice */
3450 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3452 /* Fake up a method call to VERSION */
3453 meth = newSVpvs_share("VERSION");
3454 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3455 append_elem(OP_LIST,
3456 prepend_elem(OP_LIST, pack, list(version)),
3457 newSVOP(OP_METHOD_NAMED, 0, meth)));
3461 /* Fake up an import/unimport */
3462 if (arg && arg->op_type == OP_STUB) {
3464 op_getmad(arg,pegop,'S');
3465 imop = arg; /* no import on explicit () */
3467 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3468 imop = NULL; /* use 5.0; */
3470 idop->op_private |= OPpCONST_NOVER;
3476 op_getmad(arg,pegop,'A');
3478 /* Make copy of idop so we don't free it twice */
3479 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3481 /* Fake up a method call to import/unimport */
3483 ? newSVpvs_share("import") : newSVpvs_share("unimport");
3484 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3485 append_elem(OP_LIST,
3486 prepend_elem(OP_LIST, pack, list(arg)),
3487 newSVOP(OP_METHOD_NAMED, 0, meth)));
3490 /* Fake up the BEGIN {}, which does its thing immediately. */
3492 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
3495 append_elem(OP_LINESEQ,
3496 append_elem(OP_LINESEQ,
3497 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
3498 newSTATEOP(0, NULL, veop)),
3499 newSTATEOP(0, NULL, imop) ));
3501 /* The "did you use incorrect case?" warning used to be here.
3502 * The problem is that on case-insensitive filesystems one
3503 * might get false positives for "use" (and "require"):
3504 * "use Strict" or "require CARP" will work. This causes
3505 * portability problems for the script: in case-strict
3506 * filesystems the script will stop working.
3508 * The "incorrect case" warning checked whether "use Foo"
3509 * imported "Foo" to your namespace, but that is wrong, too:
3510 * there is no requirement nor promise in the language that
3511 * a Foo.pm should or would contain anything in package "Foo".
3513 * There is very little Configure-wise that can be done, either:
3514 * the case-sensitivity of the build filesystem of Perl does not
3515 * help in guessing the case-sensitivity of the runtime environment.
3518 PL_hints |= HINT_BLOCK_SCOPE;
3519 PL_copline = NOLINE;
3521 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3524 if (!PL_madskills) {
3525 /* FIXME - don't allocate pegop if !PL_madskills */
3534 =head1 Embedding Functions
3536 =for apidoc load_module
3538 Loads the module whose name is pointed to by the string part of name.
3539 Note that the actual module name, not its filename, should be given.
3540 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3541 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3542 (or 0 for no flags). ver, if specified, provides version semantics
3543 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3544 arguments can be used to specify arguments to the module's import()
3545 method, similar to C<use Foo::Bar VERSION LIST>.
3550 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3553 va_start(args, ver);
3554 vload_module(flags, name, ver, &args);
3558 #ifdef PERL_IMPLICIT_CONTEXT
3560 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3564 va_start(args, ver);
3565 vload_module(flags, name, ver, &args);
3571 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3576 OP * const modname = newSVOP(OP_CONST, 0, name);
3577 modname->op_private |= OPpCONST_BARE;
3579 veop = newSVOP(OP_CONST, 0, ver);
3583 if (flags & PERL_LOADMOD_NOIMPORT) {
3584 imop = sawparens(newNULLLIST());
3586 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3587 imop = va_arg(*args, OP*);
3592 sv = va_arg(*args, SV*);
3594 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3595 sv = va_arg(*args, SV*);
3599 const line_t ocopline = PL_copline;
3600 COP * const ocurcop = PL_curcop;
3601 const int oexpect = PL_expect;
3603 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3604 veop, modname, imop);
3605 PL_expect = oexpect;
3606 PL_copline = ocopline;
3607 PL_curcop = ocurcop;
3612 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
3618 if (!force_builtin) {
3619 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
3620 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
3621 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
3622 gv = gvp ? *gvp : NULL;
3626 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3627 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3628 append_elem(OP_LIST, term,
3629 scalar(newUNOP(OP_RV2CV, 0,
3634 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3640 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3642 return newBINOP(OP_LSLICE, flags,
3643 list(force_list(subscript)),
3644 list(force_list(listval)) );
3648 S_is_list_assignment(pTHX_ register const OP *o)
3653 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3654 o = cUNOPo->op_first;
3656 if (o->op_type == OP_COND_EXPR) {
3657 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
3658 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3663 yyerror("Assignment to both a list and a scalar");
3667 if (o->op_type == OP_LIST &&
3668 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3669 o->op_private & OPpLVAL_INTRO)
3672 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3673 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3674 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3677 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3680 if (o->op_type == OP_RV2SV)
3687 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3693 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3694 return newLOGOP(optype, 0,
3695 mod(scalar(left), optype),
3696 newUNOP(OP_SASSIGN, 0, scalar(right)));
3699 return newBINOP(optype, OPf_STACKED,
3700 mod(scalar(left), optype), scalar(right));
3704 if (is_list_assignment(left)) {
3708 /* Grandfathering $[ assignment here. Bletch.*/
3709 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
3710 PL_eval_start = (left->op_type == OP_CONST) ? right : 0;
3711 left = mod(left, OP_AASSIGN);
3714 else if (left->op_type == OP_CONST) {
3716 /* Result of assignment is always 1 (or we'd be dead already) */
3717 return newSVOP(OP_CONST, 0, newSViv(1));
3719 curop = list(force_list(left));
3720 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3721 o->op_private = (U8)(0 | (flags >> 8));
3723 /* PL_generation sorcery:
3724 * an assignment like ($a,$b) = ($c,$d) is easier than
3725 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3726 * To detect whether there are common vars, the global var
3727 * PL_generation is incremented for each assign op we compile.
3728 * Then, while compiling the assign op, we run through all the
3729 * variables on both sides of the assignment, setting a spare slot
3730 * in each of them to PL_generation. If any of them already have
3731 * that value, we know we've got commonality. We could use a
3732 * single bit marker, but then we'd have to make 2 passes, first
3733 * to clear the flag, then to test and set it. To find somewhere
3734 * to store these values, evil chicanery is done with SvCUR().
3737 if (!(left->op_private & OPpLVAL_INTRO)) {
3740 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3741 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3742 if (curop->op_type == OP_GV) {
3743 GV *gv = cGVOPx_gv(curop);
3745 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
3747 GvASSIGN_GENERATION_set(gv, PL_generation);
3749 else if (curop->op_type == OP_PADSV ||
3750 curop->op_type == OP_PADAV ||
3751 curop->op_type == OP_PADHV ||
3752 curop->op_type == OP_PADANY)
3754 if (PAD_COMPNAME_GEN(curop->op_targ)
3755 == (STRLEN)PL_generation)
3757 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
3760 else if (curop->op_type == OP_RV2CV)
3762 else if (curop->op_type == OP_RV2SV ||
3763 curop->op_type == OP_RV2AV ||
3764 curop->op_type == OP_RV2HV ||
3765 curop->op_type == OP_RV2GV) {
3766 if (lastop->op_type != OP_GV) /* funny deref? */
3769 else if (curop->op_type == OP_PUSHRE) {
3770 if (((PMOP*)curop)->op_pmreplroot) {
3772 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3773 ((PMOP*)curop)->op_pmreplroot));
3775 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3778 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
3780 GvASSIGN_GENERATION_set(gv, PL_generation);
3781 GvASSIGN_GENERATION_set(gv, PL_generation);
3790 o->op_private |= OPpASSIGN_COMMON;
3792 if (right && right->op_type == OP_SPLIT) {
3794 if ((tmpop = ((LISTOP*)right)->op_first) &&
3795 tmpop->op_type == OP_PUSHRE)
3797 PMOP * const pm = (PMOP*)tmpop;
3798 if (left->op_type == OP_RV2AV &&
3799 !(left->op_private & OPpLVAL_INTRO) &&
3800 !(o->op_private & OPpASSIGN_COMMON) )
3802 tmpop = ((UNOP*)left)->op_first;
3803 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3805 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3806 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3808 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3809 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
3811 pm->op_pmflags |= PMf_ONCE;
3812 tmpop = cUNOPo->op_first; /* to list (nulled) */
3813 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3814 tmpop->op_sibling = NULL; /* don't free split */
3815 right->op_next = tmpop->op_next; /* fix starting loc */
3817 op_getmad(o,right,'R'); /* blow off assign */
3819 op_free(o); /* blow off assign */
3821 right->op_flags &= ~OPf_WANT;
3822 /* "I don't know and I don't care." */
3827 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3828 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3830 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3832 sv_setiv(sv, PL_modcount+1);
3840 right = newOP(OP_UNDEF, 0);
3841 if (right->op_type == OP_READLINE) {
3842 right->op_flags |= OPf_STACKED;
3843 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3846 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3847 o = newBINOP(OP_SASSIGN, flags,
3848 scalar(right), mod(scalar(left), OP_SASSIGN) );
3854 o = newSVOP(OP_CONST, 0, newSViv(PL_compiling.cop_arybase));
3855 o->op_private |= OPpCONST_ARYBASE;
3862 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3865 const U32 seq = intro_my();
3868 NewOp(1101, cop, 1, COP);
3869 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3870 cop->op_type = OP_DBSTATE;
3871 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3874 cop->op_type = OP_NEXTSTATE;
3875 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3877 cop->op_flags = (U8)flags;
3878 cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
3880 cop->op_private |= NATIVE_HINTS;
3882 PL_compiling.op_private = cop->op_private;
3883 cop->op_next = (OP*)cop;
3886 cop->cop_label = label;
3887 PL_hints |= HINT_BLOCK_SCOPE;
3890 cop->cop_arybase = PL_curcop->cop_arybase;
3891 if (specialWARN(PL_curcop->cop_warnings))
3892 cop->cop_warnings = PL_curcop->cop_warnings ;
3894 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3895 if (specialCopIO(PL_curcop->cop_io))
3896 cop->cop_io = PL_curcop->cop_io;
3898 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3901 if (PL_copline == NOLINE)
3902 CopLINE_set(cop, CopLINE(PL_curcop));
3904 CopLINE_set(cop, PL_copline);
3905 PL_copline = NOLINE;
3908 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3910 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3912 CopSTASH_set(cop, PL_curstash);
3914 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3915 SV * const * const svp = av_fetch(CopFILEAVx(PL_curcop), (I32)CopLINE(cop), FALSE);
3916 if (svp && *svp != &PL_sv_undef ) {
3917 (void)SvIOK_on(*svp);
3918 SvIV_set(*svp, PTR2IV(cop));
3922 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3927 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3930 return new_logop(type, flags, &first, &other);
3934 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3939 OP *first = *firstp;
3940 OP * const other = *otherp;
3942 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3943 return newBINOP(type, flags, scalar(first), scalar(other));
3945 scalarboolean(first);
3946 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3947 if (first->op_type == OP_NOT
3948 && (first->op_flags & OPf_SPECIAL)
3949 && (first->op_flags & OPf_KIDS)) {
3950 if (type == OP_AND || type == OP_OR) {
3956 first = *firstp = cUNOPo->op_first;
3958 first->op_next = o->op_next;
3959 cUNOPo->op_first = NULL;
3961 op_getmad(o,first,'O');
3967 if (first->op_type == OP_CONST) {
3968 if (first->op_private & OPpCONST_STRICT)
3969 no_bareword_allowed(first);
3970 else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
3971 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
3972 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
3973 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
3974 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
3976 if (other->op_type == OP_CONST)
3977 other->op_private |= OPpCONST_SHORTCIRCUIT;
3979 OP *newop = newUNOP(OP_NULL, 0, other);
3980 op_getmad(first, newop, '1');
3981 newop->op_targ = type; /* set "was" field */
3988 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
3989 const OP *o2 = other;
3990 if ( ! (o2->op_type == OP_LIST
3991 && (( o2 = cUNOPx(o2)->op_first))
3992 && o2->op_type == OP_PUSHMARK
3993 && (( o2 = o2->op_sibling)) )
3996 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
3997 || o2->op_type == OP_PADHV)
3998 && o2->op_private & OPpLVAL_INTRO
3999 && ckWARN(WARN_DEPRECATED))
4001 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4002 "Deprecated use of my() in false conditional");
4006 if (first->op_type == OP_CONST)
4007 first->op_private |= OPpCONST_SHORTCIRCUIT;
4009 first = newUNOP(OP_NULL, 0, first);
4010 op_getmad(other, first, '2');
4011 first->op_targ = type; /* set "was" field */
4018 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
4019 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
4021 const OP * const k1 = ((UNOP*)first)->op_first;
4022 const OP * const k2 = k1->op_sibling;
4024 switch (first->op_type)
4027 if (k2 && k2->op_type == OP_READLINE
4028 && (k2->op_flags & OPf_STACKED)
4029 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4031 warnop = k2->op_type;
4036 if (k1->op_type == OP_READDIR
4037 || k1->op_type == OP_GLOB
4038 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4039 || k1->op_type == OP_EACH)
4041 warnop = ((k1->op_type == OP_NULL)
4042 ? (OPCODE)k1->op_targ : k1->op_type);
4047 const line_t oldline = CopLINE(PL_curcop);
4048 CopLINE_set(PL_curcop, PL_copline);
4049 Perl_warner(aTHX_ packWARN(WARN_MISC),
4050 "Value of %s%s can be \"0\"; test with defined()",
4052 ((warnop == OP_READLINE || warnop == OP_GLOB)
4053 ? " construct" : "() operator"));
4054 CopLINE_set(PL_curcop, oldline);
4061 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
4062 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
4064 NewOp(1101, logop, 1, LOGOP);
4066 logop->op_type = (OPCODE)type;
4067 logop->op_ppaddr = PL_ppaddr[type];
4068 logop->op_first = first;
4069 logop->op_flags = (U8)(flags | OPf_KIDS);
4070 logop->op_other = LINKLIST(other);
4071 logop->op_private = (U8)(1 | (flags >> 8));
4073 /* establish postfix order */
4074 logop->op_next = LINKLIST(first);
4075 first->op_next = (OP*)logop;
4076 first->op_sibling = other;
4078 CHECKOP(type,logop);
4080 o = newUNOP(OP_NULL, 0, (OP*)logop);
4087 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
4095 return newLOGOP(OP_AND, 0, first, trueop);
4097 return newLOGOP(OP_OR, 0, first, falseop);
4099 scalarboolean(first);
4100 if (first->op_type == OP_CONST) {
4101 if (first->op_private & OPpCONST_BARE &&
4102 first->op_private & OPpCONST_STRICT) {
4103 no_bareword_allowed(first);
4105 if (SvTRUE(((SVOP*)first)->op_sv)) {
4108 trueop = newUNOP(OP_NULL, 0, trueop);
4109 op_getmad(first,trueop,'C');
4110 op_getmad(falseop,trueop,'e');
4112 /* FIXME for MAD - should there be an ELSE here? */
4122 falseop = newUNOP(OP_NULL, 0, falseop);
4123 op_getmad(first,falseop,'C');
4124 op_getmad(trueop,falseop,'t');
4126 /* FIXME for MAD - should there be an ELSE here? */
4134 NewOp(1101, logop, 1, LOGOP);
4135 logop->op_type = OP_COND_EXPR;
4136 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4137 logop->op_first = first;
4138 logop->op_flags = (U8)(flags | OPf_KIDS);
4139 logop->op_private = (U8)(1 | (flags >> 8));
4140 logop->op_other = LINKLIST(trueop);
4141 logop->op_next = LINKLIST(falseop);
4143 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
4146 /* establish postfix order */
4147 start = LINKLIST(first);
4148 first->op_next = (OP*)logop;
4150 first->op_sibling = trueop;
4151 trueop->op_sibling = falseop;
4152 o = newUNOP(OP_NULL, 0, (OP*)logop);
4154 trueop->op_next = falseop->op_next = o;
4161 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4170 NewOp(1101, range, 1, LOGOP);
4172 range->op_type = OP_RANGE;
4173 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4174 range->op_first = left;
4175 range->op_flags = OPf_KIDS;
4176 leftstart = LINKLIST(left);
4177 range->op_other = LINKLIST(right);
4178 range->op_private = (U8)(1 | (flags >> 8));
4180 left->op_sibling = right;
4182 range->op_next = (OP*)range;
4183 flip = newUNOP(OP_FLIP, flags, (OP*)range);
4184 flop = newUNOP(OP_FLOP, 0, flip);
4185 o = newUNOP(OP_NULL, 0, flop);
4187 range->op_next = leftstart;
4189 left->op_next = flip;
4190 right->op_next = flop;
4192 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4193 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4194 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4195 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4197 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4198 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4201 if (!flip->op_private || !flop->op_private)
4202 linklist(o); /* blow off optimizer unless constant */
4208 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4213 const bool once = block && block->op_flags & OPf_SPECIAL &&
4214 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4216 PERL_UNUSED_ARG(debuggable);
4219 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4220 return block; /* do {} while 0 does once */
4221 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4222 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4223 expr = newUNOP(OP_DEFINED, 0,
4224 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4225 } else if (expr->op_flags & OPf_KIDS) {
4226 const OP * const k1 = ((UNOP*)expr)->op_first;
4227 const OP * const k2 = k1 ? k1->op_sibling : NULL;
4228 switch (expr->op_type) {
4230 if (k2 && k2->op_type == OP_READLINE
4231 && (k2->op_flags & OPf_STACKED)
4232 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4233 expr = newUNOP(OP_DEFINED, 0, expr);
4237 if (k1->op_type == OP_READDIR
4238 || k1->op_type == OP_GLOB
4239 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4240 || k1->op_type == OP_EACH)
4241 expr = newUNOP(OP_DEFINED, 0, expr);
4247 /* if block is null, the next append_elem() would put UNSTACK, a scalar
4248 * op, in listop. This is wrong. [perl #27024] */
4250 block = newOP(OP_NULL, 0);
4251 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4252 o = new_logop(OP_AND, 0, &expr, &listop);
4255 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4257 if (once && o != listop)
4258 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4261 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
4263 o->op_flags |= flags;
4265 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4270 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
4271 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
4280 PERL_UNUSED_ARG(debuggable);
4283 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4284 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4285 expr = newUNOP(OP_DEFINED, 0,
4286 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4287 } else if (expr->op_flags & OPf_KIDS) {
4288 const OP * const k1 = ((UNOP*)expr)->op_first;
4289 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
4290 switch (expr->op_type) {
4292 if (k2 && k2->op_type == OP_READLINE
4293 && (k2->op_flags & OPf_STACKED)
4294 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4295 expr = newUNOP(OP_DEFINED, 0, expr);
4299 if (k1->op_type == OP_READDIR
4300 || k1->op_type == OP_GLOB
4301 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4302 || k1->op_type == OP_EACH)
4303 expr = newUNOP(OP_DEFINED, 0, expr);
4310 block = newOP(OP_NULL, 0);
4311 else if (cont || has_my) {
4312 block = scope(block);
4316 next = LINKLIST(cont);
4319 OP * const unstack = newOP(OP_UNSTACK, 0);
4322 cont = append_elem(OP_LINESEQ, cont, unstack);
4325 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4326 redo = LINKLIST(listop);
4329 PL_copline = (line_t)whileline;
4331 o = new_logop(OP_AND, 0, &expr, &listop);
4332 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4333 op_free(expr); /* oops, it's a while (0) */
4335 return NULL; /* listop already freed by new_logop */
4338 ((LISTOP*)listop)->op_last->op_next =
4339 (o == listop ? redo : LINKLIST(o));
4345 NewOp(1101,loop,1,LOOP);
4346 loop->op_type = OP_ENTERLOOP;
4347 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4348 loop->op_private = 0;
4349 loop->op_next = (OP*)loop;
4352 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4354 loop->op_redoop = redo;
4355 loop->op_lastop = o;
4356 o->op_private |= loopflags;
4359 loop->op_nextop = next;
4361 loop->op_nextop = o;
4363 o->op_flags |= flags;
4364 o->op_private |= (flags >> 8);
4369 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
4374 PADOFFSET padoff = 0;
4380 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4381 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
4382 sv->op_type = OP_RV2GV;
4383 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4384 if (cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
4385 iterpflags |= OPpITER_DEF;
4387 else if (sv->op_type == OP_PADSV) { /* private variable */
4388 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
4389 padoff = sv->op_targ;
4398 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4399 padoff = sv->op_targ;
4404 iterflags |= OPf_SPECIAL;
4410 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4411 if (padoff && strEQ(PAD_COMPNAME_PV(padoff), "$_"))
4412 iterpflags |= OPpITER_DEF;
4415 const I32 offset = pad_findmy("$_");
4416 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
4417 sv = newGVOP(OP_GV, 0, PL_defgv);
4422 iterpflags |= OPpITER_DEF;
4424 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4425 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4426 iterflags |= OPf_STACKED;
4428 else if (expr->op_type == OP_NULL &&
4429 (expr->op_flags & OPf_KIDS) &&
4430 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4432 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4433 * set the STACKED flag to indicate that these values are to be
4434 * treated as min/max values by 'pp_iterinit'.
4436 UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4437 LOGOP* const range = (LOGOP*) flip->op_first;
4438 OP* const left = range->op_first;
4439 OP* const right = left->op_sibling;
4442 range->op_flags &= ~OPf_KIDS;
4443 range->op_first = NULL;
4445 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4446 listop->op_first->op_next = range->op_next;
4447 left->op_next = range->op_other;
4448 right->op_next = (OP*)listop;
4449 listop->op_next = listop->op_first;
4452 op_getmad(expr,(OP*)listop,'O');
4456 expr = (OP*)(listop);
4458 iterflags |= OPf_STACKED;
4461 expr = mod(force_list(expr), OP_GREPSTART);
4464 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4465 append_elem(OP_LIST, expr, scalar(sv))));
4466 assert(!loop->op_next);
4467 /* for my $x () sets OPpLVAL_INTRO;
4468 * for our $x () sets OPpOUR_INTRO */
4469 loop->op_private = (U8)iterpflags;
4470 #ifdef PL_OP_SLAB_ALLOC
4473 NewOp(1234,tmp,1,LOOP);
4474 Copy(loop,tmp,1,LISTOP);
4479 Renew(loop, 1, LOOP);
4481 loop->op_targ = padoff;
4482 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
4484 op_getmad(madsv, (OP*)loop, 'v');
4485 PL_copline = forline;
4486 return newSTATEOP(0, label, wop);
4490 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4495 if (type != OP_GOTO || label->op_type == OP_CONST) {
4496 /* "last()" means "last" */
4497 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4498 o = newOP(type, OPf_SPECIAL);
4500 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4501 ? SvPVx_nolen_const(((SVOP*)label)->op_sv)
4505 op_getmad(label,o,'L');
4511 /* Check whether it's going to be a goto &function */
4512 if (label->op_type == OP_ENTERSUB
4513 && !(label->op_flags & OPf_STACKED))
4514 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4515 o = newUNOP(type, OPf_STACKED, label);
4517 PL_hints |= HINT_BLOCK_SCOPE;
4521 /* if the condition is a literal array or hash
4522 (or @{ ... } etc), make a reference to it.
4525 S_ref_array_or_hash(pTHX_ OP *cond)
4528 && (cond->op_type == OP_RV2AV
4529 || cond->op_type == OP_PADAV
4530 || cond->op_type == OP_RV2HV
4531 || cond->op_type == OP_PADHV))
4533 return newUNOP(OP_REFGEN,
4534 0, mod(cond, OP_REFGEN));
4540 /* These construct the optree fragments representing given()
4543 entergiven and enterwhen are LOGOPs; the op_other pointer
4544 points up to the associated leave op. We need this so we
4545 can put it in the context and make break/continue work.
4546 (Also, of course, pp_enterwhen will jump straight to
4547 op_other if the match fails.)
4552 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
4553 I32 enter_opcode, I32 leave_opcode,
4554 PADOFFSET entertarg)
4560 NewOp(1101, enterop, 1, LOGOP);
4561 enterop->op_type = enter_opcode;
4562 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
4563 enterop->op_flags = (U8) OPf_KIDS;
4564 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
4565 enterop->op_private = 0;
4567 o = newUNOP(leave_opcode, 0, (OP *) enterop);
4570 enterop->op_first = scalar(cond);
4571 cond->op_sibling = block;
4573 o->op_next = LINKLIST(cond);
4574 cond->op_next = (OP *) enterop;
4577 /* This is a default {} block */
4578 enterop->op_first = block;
4579 enterop->op_flags |= OPf_SPECIAL;
4581 o->op_next = (OP *) enterop;
4584 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
4585 entergiven and enterwhen both
4588 enterop->op_next = LINKLIST(block);
4589 block->op_next = enterop->op_other = o;
4594 /* Does this look like a boolean operation? For these purposes
4595 a boolean operation is:
4596 - a subroutine call [*]
4597 - a logical connective
4598 - a comparison operator
4599 - a filetest operator, with the exception of -s -M -A -C
4600 - defined(), exists() or eof()
4601 - /$re/ or $foo =~ /$re/
4603 [*] possibly surprising
4607 S_looks_like_bool(pTHX_ OP *o)
4610 switch(o->op_type) {
4612 return looks_like_bool(cLOGOPo->op_first);
4616 looks_like_bool(cLOGOPo->op_first)
4617 && looks_like_bool(cLOGOPo->op_first->op_sibling));
4621 case OP_NOT: case OP_XOR:
4622 /* Note that OP_DOR is not here */
4624 case OP_EQ: case OP_NE: case OP_LT:
4625 case OP_GT: case OP_LE: case OP_GE:
4627 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
4628 case OP_I_GT: case OP_I_LE: case OP_I_GE:
4630 case OP_SEQ: case OP_SNE: case OP_SLT:
4631 case OP_SGT: case OP_SLE: case OP_SGE:
4635 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
4636 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
4637 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
4638 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
4639 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
4640 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
4641 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
4642 case OP_FTTEXT: case OP_FTBINARY:
4644 case OP_DEFINED: case OP_EXISTS:
4645 case OP_MATCH: case OP_EOF:
4650 /* Detect comparisons that have been optimized away */
4651 if (cSVOPo->op_sv == &PL_sv_yes
4652 || cSVOPo->op_sv == &PL_sv_no)
4663 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
4667 return newGIVWHENOP(
4668 ref_array_or_hash(cond),
4670 OP_ENTERGIVEN, OP_LEAVEGIVEN,
4674 /* If cond is null, this is a default {} block */
4676 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
4678 bool cond_llb = (!cond || looks_like_bool(cond));
4684 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
4686 scalar(ref_array_or_hash(cond)));
4689 return newGIVWHENOP(
4691 append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
4692 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
4696 =for apidoc cv_undef
4698 Clear out all the active components of a CV. This can happen either
4699 by an explicit C<undef &foo>, or by the reference count going to zero.
4700 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
4701 children can still follow the full lexical scope chain.
4707 Perl_cv_undef(pTHX_ CV *cv)
4711 if (CvFILE(cv) && !CvISXSUB(cv)) {
4712 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4713 Safefree(CvFILE(cv));
4718 if (!CvISXSUB(cv) && CvROOT(cv)) {
4719 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
4720 Perl_croak(aTHX_ "Can't undef active subroutine");
4723 PAD_SAVE_SETNULLPAD();
4725 op_free(CvROOT(cv));
4730 SvPOK_off((SV*)cv); /* forget prototype */
4735 /* remove CvOUTSIDE unless this is an undef rather than a free */
4736 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
4737 if (!CvWEAKOUTSIDE(cv))
4738 SvREFCNT_dec(CvOUTSIDE(cv));
4739 CvOUTSIDE(cv) = NULL;
4742 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4745 if (CvISXSUB(cv) && CvXSUB(cv)) {
4748 /* delete all flags except WEAKOUTSIDE */
4749 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
4753 Perl_cv_ckproto(pTHX_ const CV *cv, const GV *gv, const char *p)
4755 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX_const(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4756 SV* const msg = sv_newmortal();
4760 gv_efullname3(name = sv_newmortal(), gv, NULL);
4761 sv_setpv(msg, "Prototype mismatch:");
4763 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4765 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (const SV *)cv);
4767 sv_catpvs(msg, ": none");
4768 sv_catpvs(msg, " vs ");
4770 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4772 sv_catpvs(msg, "none");
4773 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
4777 static void const_sv_xsub(pTHX_ CV* cv);
4781 =head1 Optree Manipulation Functions
4783 =for apidoc cv_const_sv
4785 If C<cv> is a constant sub eligible for inlining. returns the constant
4786 value returned by the sub. Otherwise, returns NULL.
4788 Constant subs can be created with C<newCONSTSUB> or as described in
4789 L<perlsub/"Constant Functions">.
4794 Perl_cv_const_sv(pTHX_ CV *cv)
4796 PERL_UNUSED_CONTEXT;
4799 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
4801 return CvCONST(cv) ? (SV*)CvXSUBANY(cv).any_ptr : NULL;
4804 /* op_const_sv: examine an optree to determine whether it's in-lineable.
4805 * Can be called in 3 ways:
4808 * look for a single OP_CONST with attached value: return the value
4810 * cv && CvCLONE(cv) && !CvCONST(cv)
4812 * examine the clone prototype, and if contains only a single
4813 * OP_CONST referencing a pad const, or a single PADSV referencing
4814 * an outer lexical, return a non-zero value to indicate the CV is
4815 * a candidate for "constizing" at clone time
4819 * We have just cloned an anon prototype that was marked as a const
4820 * candidiate. Try to grab the current value, and in the case of
4821 * PADSV, ignore it if it has multiple references. Return the value.
4825 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
4833 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4834 o = cLISTOPo->op_first->op_sibling;
4836 for (; o; o = o->op_next) {
4837 const OPCODE type = o->op_type;
4839 if (sv && o->op_next == o)
4841 if (o->op_next != o) {
4842 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4844 if (type == OP_DBSTATE)
4847 if (type == OP_LEAVESUB || type == OP_RETURN)
4851 if (type == OP_CONST && cSVOPo->op_sv)
4853 else if (cv && type == OP_CONST) {
4854 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4858 else if (cv && type == OP_PADSV) {
4859 if (CvCONST(cv)) { /* newly cloned anon */
4860 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4861 /* the candidate should have 1 ref from this pad and 1 ref
4862 * from the parent */
4863 if (!sv || SvREFCNT(sv) != 2)
4870 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
4871 sv = &PL_sv_undef; /* an arbitrary non-null value */
4886 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4889 /* This would be the return value, but the return cannot be reached. */
4890 OP* pegop = newOP(OP_NULL, 0);
4893 PERL_UNUSED_ARG(floor);
4903 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4905 NORETURN_FUNCTION_END;
4910 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4912 return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
4916 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4923 register CV *cv = NULL;
4925 /* If the subroutine has no body, no attributes, and no builtin attributes
4926 then it's just a sub declaration, and we may be able to get away with
4927 storing with a placeholder scalar in the symbol table, rather than a
4928 full GV and CV. If anything is present then it will take a full CV to
4930 const I32 gv_fetch_flags
4931 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
4933 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
4934 const char * const name = o ? SvPVx_nolen_const(cSVOPo->op_sv) : NULL;
4937 assert(proto->op_type == OP_CONST);
4938 ps = SvPVx_const(((SVOP*)proto)->op_sv, ps_len);
4943 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4944 SV * const sv = sv_newmortal();
4945 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4946 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
4947 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4948 aname = SvPVX_const(sv);
4953 gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
4954 : gv_fetchpv(aname ? aname
4955 : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4956 gv_fetch_flags, SVt_PVCV);
4958 if (!PL_madskills) {
4967 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4968 maximum a prototype before. */
4969 if (SvTYPE(gv) > SVt_NULL) {
4970 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4971 && ckWARN_d(WARN_PROTOTYPE))
4973 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
4975 cv_ckproto((CV*)gv, NULL, ps);
4978 sv_setpvn((SV*)gv, ps, ps_len);
4980 sv_setiv((SV*)gv, -1);
4981 SvREFCNT_dec(PL_compcv);
4982 cv = PL_compcv = NULL;
4983 PL_sub_generation++;
4987 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
4989 #ifdef GV_UNIQUE_CHECK
4990 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4991 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4995 if (!block || !ps || *ps || attrs
4996 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
4998 || block->op_type == OP_NULL
5003 const_sv = op_const_sv(block, NULL);
5006 const bool exists = CvROOT(cv) || CvXSUB(cv);
5008 #ifdef GV_UNIQUE_CHECK
5009 if (exists && GvUNIQUE(gv)) {
5010 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
5014 /* if the subroutine doesn't exist and wasn't pre-declared
5015 * with a prototype, assume it will be AUTOLOADed,
5016 * skipping the prototype check
5018 if (exists || SvPOK(cv))
5019 cv_ckproto(cv, gv, ps);
5020 /* already defined (or promised)? */
5021 if (exists || GvASSUMECV(gv)) {
5024 || block->op_type == OP_NULL
5027 if (CvFLAGS(PL_compcv)) {
5028 /* might have had built-in attrs applied */
5029 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5031 /* just a "sub foo;" when &foo is already defined */
5032 SAVEFREESV(PL_compcv);
5037 && block->op_type != OP_NULL
5040 if (ckWARN(WARN_REDEFINE)
5042 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
5044 const line_t oldline = CopLINE(PL_curcop);
5045 if (PL_copline != NOLINE)
5046 CopLINE_set(PL_curcop, PL_copline);
5047 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5048 CvCONST(cv) ? "Constant subroutine %s redefined"
5049 : "Subroutine %s redefined", name);
5050 CopLINE_set(PL_curcop, oldline);
5053 if (!PL_minus_c) /* keep old one around for madskills */
5056 /* (PL_madskills unset in used file.) */
5064 SvREFCNT_inc_void_NN(const_sv);
5066 assert(!CvROOT(cv) && !CvCONST(cv));
5067 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
5068 CvXSUBANY(cv).any_ptr = const_sv;
5069 CvXSUB(cv) = const_sv_xsub;
5075 cv = newCONSTSUB(NULL, name, const_sv);
5077 PL_sub_generation++;
5081 SvREFCNT_dec(PL_compcv);
5089 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
5090 * before we clobber PL_compcv.
5094 || block->op_type == OP_NULL
5098 /* Might have had built-in attributes applied -- propagate them. */
5099 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5100 if (CvGV(cv) && GvSTASH(CvGV(cv)))
5101 stash = GvSTASH(CvGV(cv));
5102 else if (CvSTASH(cv))
5103 stash = CvSTASH(cv);
5105 stash = PL_curstash;
5108 /* possibly about to re-define existing subr -- ignore old cv */
5109 rcv = (SV*)PL_compcv;
5110 if (name && GvSTASH(gv))
5111 stash = GvSTASH(gv);
5113 stash = PL_curstash;
5115 apply_attrs(stash, rcv, attrs, FALSE);
5117 if (cv) { /* must reuse cv if autoloaded */
5124 || block->op_type == OP_NULL) && !PL_madskills
5127 /* got here with just attrs -- work done, so bug out */
5128 SAVEFREESV(PL_compcv);
5131 /* transfer PL_compcv to cv */
5133 CvFLAGS(cv) = CvFLAGS(PL_compcv);
5134 if (!CvWEAKOUTSIDE(cv))
5135 SvREFCNT_dec(CvOUTSIDE(cv));
5136 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
5137 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
5138 CvOUTSIDE(PL_compcv) = 0;
5139 CvPADLIST(cv) = CvPADLIST(PL_compcv);
5140 CvPADLIST(PL_compcv) = 0;
5141 /* inner references to PL_compcv must be fixed up ... */
5142 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
5143 /* ... before we throw it away */
5144 SvREFCNT_dec(PL_compcv);
5146 if (PERLDB_INTER)/* Advice debugger on the new sub. */
5147 ++PL_sub_generation;
5154 if (strEQ(name, "import")) {
5155 PL_formfeed = (SV*)cv;
5156 Perl_warner(aTHX_ packWARN(WARN_VOID), "%lx\n", (long)cv);
5160 PL_sub_generation++;
5164 CvFILE_set_from_cop(cv, PL_curcop);
5165 CvSTASH(cv) = PL_curstash;
5168 sv_setpvn((SV*)cv, ps, ps_len);
5170 if (PL_error_count) {
5174 const char *s = strrchr(name, ':');
5176 if (strEQ(s, "BEGIN")) {
5177 const char not_safe[] =
5178 "BEGIN not safe after errors--compilation aborted";
5179 if (PL_in_eval & EVAL_KEEPERR)
5180 Perl_croak(aTHX_ not_safe);
5182 /* force display of errors found but not reported */
5183 sv_catpv(ERRSV, not_safe);
5184 Perl_croak(aTHX_ "%"SVf, ERRSV);
5194 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5195 mod(scalarseq(block), OP_LEAVESUBLV));
5198 /* This makes sub {}; work as expected. */
5199 if (block->op_type == OP_STUB) {
5200 OP* newblock = newSTATEOP(0, NULL, 0);
5202 op_getmad(block,newblock,'B');
5208 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5210 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5211 OpREFCNT_set(CvROOT(cv), 1);
5212 CvSTART(cv) = LINKLIST(CvROOT(cv));
5213 CvROOT(cv)->op_next = 0;
5214 CALL_PEEP(CvSTART(cv));
5216 /* now that optimizer has done its work, adjust pad values */
5218 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
5221 assert(!CvCONST(cv));
5222 if (ps && !*ps && op_const_sv(block, cv))
5226 if (name || aname) {
5228 const char * const tname = (name ? name : aname);
5230 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5231 SV * const sv = newSV(0);
5232 SV * const tmpstr = sv_newmortal();
5233 GV * const db_postponed = gv_fetchpvs("DB::postponed",
5234 GV_ADDMULTI, SVt_PVHV);
5237 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5239 (long)PL_subline, (long)CopLINE(PL_curcop));
5240 gv_efullname3(tmpstr, gv, NULL);
5241 hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0);
5242 hv = GvHVn(db_postponed);
5243 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
5244 CV * const pcv = GvCV(db_postponed);
5250 call_sv((SV*)pcv, G_DISCARD);
5255 if ((s = strrchr(tname,':')))
5260 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5263 if (strEQ(s, "BEGIN") && !PL_error_count) {
5264 const I32 oldscope = PL_scopestack_ix;
5266 SAVECOPFILE(&PL_compiling);
5267 SAVECOPLINE(&PL_compiling);
5270 PL_beginav = newAV();
5271 DEBUG_x( dump_sub(gv) );
5272 av_push(PL_beginav, (SV*)cv);
5273 GvCV(gv) = 0; /* cv has been hijacked */
5274 call_list(oldscope, PL_beginav);
5276 PL_curcop = &PL_compiling;
5277 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
5280 else if (strEQ(s, "END") && !PL_error_count) {
5283 DEBUG_x( dump_sub(gv) );
5284 av_unshift(PL_endav, 1);
5285 av_store(PL_endav, 0, (SV*)cv);
5286 GvCV(gv) = 0; /* cv has been hijacked */
5288 else if (strEQ(s, "CHECK") && !PL_error_count) {
5290 PL_checkav = newAV();
5291 DEBUG_x( dump_sub(gv) );
5292 if (PL_main_start && ckWARN(WARN_VOID))
5293 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
5294 av_unshift(PL_checkav, 1);
5295 av_store(PL_checkav, 0, (SV*)cv);
5296 GvCV(gv) = 0; /* cv has been hijacked */
5298 else if (strEQ(s, "INIT") && !PL_error_count) {
5300 PL_initav = newAV();
5301 DEBUG_x( dump_sub(gv) );
5302 if (PL_main_start && ckWARN(WARN_VOID))
5303 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
5304 av_push(PL_initav, (SV*)cv);
5305 GvCV(gv) = 0; /* cv has been hijacked */
5310 PL_copline = NOLINE;
5315 /* XXX unsafe for threads if eval_owner isn't held */
5317 =for apidoc newCONSTSUB
5319 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5320 eligible for inlining at compile-time.
5326 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
5333 SAVECOPLINE(PL_curcop);
5334 CopLINE_set(PL_curcop, PL_copline);
5337 PL_hints &= ~HINT_BLOCK_SCOPE;
5340 SAVESPTR(PL_curstash);
5341 SAVECOPSTASH(PL_curcop);
5342 PL_curstash = stash;
5343 CopSTASH_set(PL_curcop,stash);
5346 cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
5347 CvXSUBANY(cv).any_ptr = sv;
5349 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
5353 CopSTASH_free(PL_curcop);
5361 =for apidoc U||newXS
5363 Used by C<xsubpp> to hook up XSUBs as Perl subs.
5369 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
5372 GV * const gv = gv_fetchpv(name ? name :
5373 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5374 GV_ADDMULTI, SVt_PVCV);
5378 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
5380 if ((cv = (name ? GvCV(gv) : NULL))) {
5382 /* just a cached method */
5386 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5387 /* already defined (or promised) */
5388 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
5389 if (ckWARN(WARN_REDEFINE)) {
5390 GV * const gvcv = CvGV(cv);
5392 HV * const stash = GvSTASH(gvcv);
5394 const char *redefined_name = HvNAME_get(stash);
5395 if ( strEQ(redefined_name,"autouse") ) {
5396 const line_t oldline = CopLINE(PL_curcop);
5397 if (PL_copline != NOLINE)
5398 CopLINE_set(PL_curcop, PL_copline);
5399 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5400 CvCONST(cv) ? "Constant subroutine %s redefined"
5401 : "Subroutine %s redefined"
5403 CopLINE_set(PL_curcop, oldline);
5413 if (cv) /* must reuse cv if autoloaded */
5417 sv_upgrade((SV *)cv, SVt_PVCV);
5421 PL_sub_generation++;
5425 (void)gv_fetchfile(filename);
5426 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
5427 an external constant string */
5429 CvXSUB(cv) = subaddr;
5432 const char *s = strrchr(name,':');
5438 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5441 if (strEQ(s, "BEGIN")) {
5443 PL_beginav = newAV();
5444 av_push(PL_beginav, (SV*)cv);
5445 GvCV(gv) = 0; /* cv has been hijacked */
5447 else if (strEQ(s, "END")) {
5450 av_unshift(PL_endav, 1);
5451 av_store(PL_endav, 0, (SV*)cv);
5452 GvCV(gv) = 0; /* cv has been hijacked */
5454 else if (strEQ(s, "CHECK")) {
5456 PL_checkav = newAV();
5457 if (PL_main_start && ckWARN(WARN_VOID))
5458 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
5459 av_unshift(PL_checkav, 1);
5460 av_store(PL_checkav, 0, (SV*)cv);
5461 GvCV(gv) = 0; /* cv has been hijacked */
5463 else if (strEQ(s, "INIT")) {
5465 PL_initav = newAV();
5466 if (PL_main_start && ckWARN(WARN_VOID))
5467 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
5468 av_push(PL_initav, (SV*)cv);
5469 GvCV(gv) = 0; /* cv has been hijacked */
5484 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5489 OP* pegop = newOP(OP_NULL, 0);
5493 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
5494 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
5496 #ifdef GV_UNIQUE_CHECK
5498 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5502 if ((cv = GvFORM(gv))) {
5503 if (ckWARN(WARN_REDEFINE)) {
5504 const line_t oldline = CopLINE(PL_curcop);
5505 if (PL_copline != NOLINE)
5506 CopLINE_set(PL_curcop, PL_copline);
5507 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5508 o ? "Format %"SVf" redefined"
5509 : "Format STDOUT redefined" ,cSVOPo->op_sv);
5510 CopLINE_set(PL_curcop, oldline);
5517 CvFILE_set_from_cop(cv, PL_curcop);
5520 pad_tidy(padtidy_FORMAT);
5521 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5522 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5523 OpREFCNT_set(CvROOT(cv), 1);
5524 CvSTART(cv) = LINKLIST(CvROOT(cv));
5525 CvROOT(cv)->op_next = 0;
5526 CALL_PEEP(CvSTART(cv));
5528 op_getmad(o,pegop,'n');
5529 op_getmad_weak(block, pegop, 'b');
5533 PL_copline = NOLINE;
5541 Perl_newANONLIST(pTHX_ OP *o)
5543 return newUNOP(OP_REFGEN, 0,
5544 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5548 Perl_newANONHASH(pTHX_ OP *o)
5550 return newUNOP(OP_REFGEN, 0,
5551 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5555 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5557 return newANONATTRSUB(floor, proto, NULL, block);
5561 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5563 return newUNOP(OP_REFGEN, 0,
5564 newSVOP(OP_ANONCODE, 0,
5565 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5569 Perl_oopsAV(pTHX_ OP *o)
5572 switch (o->op_type) {
5574 o->op_type = OP_PADAV;
5575 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5576 return ref(o, OP_RV2AV);
5579 o->op_type = OP_RV2AV;
5580 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5585 if (ckWARN_d(WARN_INTERNAL))
5586 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
5593 Perl_oopsHV(pTHX_ OP *o)
5596 switch (o->op_type) {
5599 o->op_type = OP_PADHV;
5600 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5601 return ref(o, OP_RV2HV);
5605 o->op_type = OP_RV2HV;
5606 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5611 if (ckWARN_d(WARN_INTERNAL))
5612 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
5619 Perl_newAVREF(pTHX_ OP *o)
5622 if (o->op_type == OP_PADANY) {
5623 o->op_type = OP_PADAV;
5624 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5627 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5628 && ckWARN(WARN_DEPRECATED)) {
5629 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5630 "Using an array as a reference is deprecated");
5632 return newUNOP(OP_RV2AV, 0, scalar(o));
5636 Perl_newGVREF(pTHX_ I32 type, OP *o)
5638 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5639 return newUNOP(OP_NULL, 0, o);
5640 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5644 Perl_newHVREF(pTHX_ OP *o)
5647 if (o->op_type == OP_PADANY) {
5648 o->op_type = OP_PADHV;
5649 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5652 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5653 && ckWARN(WARN_DEPRECATED)) {
5654 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5655 "Using a hash as a reference is deprecated");
5657 return newUNOP(OP_RV2HV, 0, scalar(o));
5661 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5663 return newUNOP(OP_RV2CV, flags, scalar(o));
5667 Perl_newSVREF(pTHX_ OP *o)
5670 if (o->op_type == OP_PADANY) {
5671 o->op_type = OP_PADSV;
5672 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5675 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5676 o->op_flags |= OPpDONE_SVREF;
5679 return newUNOP(OP_RV2SV, 0, scalar(o));
5682 /* Check routines. See the comments at the top of this file for details
5683 * on when these are called */
5686 Perl_ck_anoncode(pTHX_ OP *o)
5688 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
5690 cSVOPo->op_sv = Nullsv;
5695 Perl_ck_bitop(pTHX_ OP *o)
5698 #define OP_IS_NUMCOMPARE(op) \
5699 ((op) == OP_LT || (op) == OP_I_LT || \
5700 (op) == OP_GT || (op) == OP_I_GT || \
5701 (op) == OP_LE || (op) == OP_I_LE || \
5702 (op) == OP_GE || (op) == OP_I_GE || \
5703 (op) == OP_EQ || (op) == OP_I_EQ || \
5704 (op) == OP_NE || (op) == OP_I_NE || \
5705 (op) == OP_NCMP || (op) == OP_I_NCMP)
5706 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
5707 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
5708 && (o->op_type == OP_BIT_OR
5709 || o->op_type == OP_BIT_AND
5710 || o->op_type == OP_BIT_XOR))
5712 const OP * const left = cBINOPo->op_first;
5713 const OP * const right = left->op_sibling;
5714 if ((OP_IS_NUMCOMPARE(left->op_type) &&
5715 (left->op_flags & OPf_PARENS) == 0) ||
5716 (OP_IS_NUMCOMPARE(right->op_type) &&
5717 (right->op_flags & OPf_PARENS) == 0))
5718 if (ckWARN(WARN_PRECEDENCE))
5719 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
5720 "Possible precedence problem on bitwise %c operator",
5721 o->op_type == OP_BIT_OR ? '|'
5722 : o->op_type == OP_BIT_AND ? '&' : '^'
5729 Perl_ck_concat(pTHX_ OP *o)
5731 const OP * const kid = cUNOPo->op_first;
5732 PERL_UNUSED_CONTEXT;
5733 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
5734 !(kUNOP->op_first->op_flags & OPf_MOD))
5735 o->op_flags |= OPf_STACKED;
5740 Perl_ck_spair(pTHX_ OP *o)
5743 if (o->op_flags & OPf_KIDS) {
5746 const OPCODE type = o->op_type;
5747 o = modkids(ck_fun(o), type);
5748 kid = cUNOPo->op_first;
5749 newop = kUNOP->op_first->op_sibling;
5751 (newop->op_sibling ||
5752 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5753 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5754 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5759 op_getmad(kUNOP->op_first,newop,'K');
5761 op_free(kUNOP->op_first);
5763 kUNOP->op_first = newop;
5765 o->op_ppaddr = PL_ppaddr[++o->op_type];
5770 Perl_ck_delete(pTHX_ OP *o)
5774 if (o->op_flags & OPf_KIDS) {
5775 OP * const kid = cUNOPo->op_first;
5776 switch (kid->op_type) {
5778 o->op_flags |= OPf_SPECIAL;
5781 o->op_private |= OPpSLICE;
5784 o->op_flags |= OPf_SPECIAL;
5789 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5798 Perl_ck_die(pTHX_ OP *o)
5801 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5807 Perl_ck_eof(pTHX_ OP *o)
5810 const I32 type = o->op_type;
5812 if (o->op_flags & OPf_KIDS) {
5813 if (cLISTOPo->op_first->op_type == OP_STUB) {
5815 = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
5817 op_getmad(o,newop,'O');
5829 Perl_ck_eval(pTHX_ OP *o)
5832 PL_hints |= HINT_BLOCK_SCOPE;
5833 if (o->op_flags & OPf_KIDS) {
5834 SVOP * const kid = (SVOP*)cUNOPo->op_first;
5837 o->op_flags &= ~OPf_KIDS;
5840 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
5846 cUNOPo->op_first = 0;
5851 NewOp(1101, enter, 1, LOGOP);
5852 enter->op_type = OP_ENTERTRY;
5853 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5854 enter->op_private = 0;
5856 /* establish postfix order */
5857 enter->op_next = (OP*)enter;
5859 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5860 o->op_type = OP_LEAVETRY;
5861 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5862 enter->op_other = o;
5863 op_getmad(oldo,o,'O');
5877 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5878 op_getmad(oldo,o,'O');
5880 o->op_targ = (PADOFFSET)PL_hints;
5881 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
5882 /* Store a copy of %^H that pp_entereval can pick up */
5883 OP *hhop = newSVOP(OP_CONST, 0, (SV*)newHVhv(GvHV(PL_hintgv)));
5884 cUNOPo->op_first->op_sibling = hhop;
5885 o->op_private |= OPpEVAL_HAS_HH;
5891 Perl_ck_exit(pTHX_ OP *o)
5894 HV * const table = GvHV(PL_hintgv);
5896 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
5897 if (svp && *svp && SvTRUE(*svp))
5898 o->op_private |= OPpEXIT_VMSISH;
5900 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5906 Perl_ck_exec(pTHX_ OP *o)
5908 if (o->op_flags & OPf_STACKED) {
5911 kid = cUNOPo->op_first->op_sibling;
5912 if (kid->op_type == OP_RV2GV)
5921 Perl_ck_exists(pTHX_ OP *o)
5925 if (o->op_flags & OPf_KIDS) {
5926 OP * const kid = cUNOPo->op_first;
5927 if (kid->op_type == OP_ENTERSUB) {
5928 (void) ref(kid, o->op_type);
5929 if (kid->op_type != OP_RV2CV && !PL_error_count)
5930 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5932 o->op_private |= OPpEXISTS_SUB;
5934 else if (kid->op_type == OP_AELEM)
5935 o->op_flags |= OPf_SPECIAL;
5936 else if (kid->op_type != OP_HELEM)
5937 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5945 Perl_ck_rvconst(pTHX_ register OP *o)
5948 SVOP * const kid = (SVOP*)cUNOPo->op_first;
5950 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5951 if (o->op_type == OP_RV2CV)
5952 o->op_private &= ~1;
5954 if (kid->op_type == OP_CONST) {
5957 SV * const kidsv = kid->op_sv;
5959 /* Is it a constant from cv_const_sv()? */
5960 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5961 SV * const rsv = SvRV(kidsv);
5962 const int svtype = SvTYPE(rsv);
5963 const char *badtype = NULL;
5965 switch (o->op_type) {
5967 if (svtype > SVt_PVMG)
5968 badtype = "a SCALAR";
5971 if (svtype != SVt_PVAV)
5972 badtype = "an ARRAY";
5975 if (svtype != SVt_PVHV)
5979 if (svtype != SVt_PVCV)
5984 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5987 else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
5988 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
5989 /* If this is an access to a stash, disable "strict refs", because
5990 * stashes aren't auto-vivified at compile-time (unless we store
5991 * symbols in them), and we don't want to produce a run-time
5992 * stricture error when auto-vivifying the stash. */
5993 const char *s = SvPV_nolen(kidsv);
5994 const STRLEN l = SvCUR(kidsv);
5995 if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
5996 o->op_private &= ~HINT_STRICT_REFS;
5998 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5999 const char *badthing;
6000 switch (o->op_type) {
6002 badthing = "a SCALAR";
6005 badthing = "an ARRAY";
6008 badthing = "a HASH";
6016 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
6020 * This is a little tricky. We only want to add the symbol if we
6021 * didn't add it in the lexer. Otherwise we get duplicate strict
6022 * warnings. But if we didn't add it in the lexer, we must at
6023 * least pretend like we wanted to add it even if it existed before,
6024 * or we get possible typo warnings. OPpCONST_ENTERED says
6025 * whether the lexer already added THIS instance of this symbol.
6027 iscv = (o->op_type == OP_RV2CV) * 2;
6029 gv = gv_fetchsv(kidsv,
6030 iscv | !(kid->op_private & OPpCONST_ENTERED),
6033 : o->op_type == OP_RV2SV
6035 : o->op_type == OP_RV2AV
6037 : o->op_type == OP_RV2HV
6040 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
6042 kid->op_type = OP_GV;
6043 SvREFCNT_dec(kid->op_sv);
6045 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
6046 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
6047 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
6049 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc_simple_NN(gv));
6051 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
6053 kid->op_private = 0;
6054 kid->op_ppaddr = PL_ppaddr[OP_GV];
6061 Perl_ck_ftst(pTHX_ OP *o)
6064 const I32 type = o->op_type;
6066 if (o->op_flags & OPf_REF) {
6069 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
6070 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6072 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6073 OP * const newop = newGVOP(type, OPf_REF,
6074 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
6076 op_getmad(o,newop,'O');
6084 if ((PL_hints & HINT_FILETEST_ACCESS) &&
6085 OP_IS_FILETEST_ACCESS(o))
6086 o->op_private |= OPpFT_ACCESS;
6088 if (PL_check[kid->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst)
6089 && kid->op_type != OP_STAT && kid->op_type != OP_LSTAT)
6090 o->op_private |= OPpFT_STACKED;
6098 if (type == OP_FTTTY)
6099 o = newGVOP(type, OPf_REF, PL_stdingv);
6101 o = newUNOP(type, 0, newDEFSVOP());
6102 op_getmad(oldo,o,'O');
6108 Perl_ck_fun(pTHX_ OP *o)
6111 const int type = o->op_type;
6112 register I32 oa = PL_opargs[type] >> OASHIFT;
6114 if (o->op_flags & OPf_STACKED) {
6115 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
6118 return no_fh_allowed(o);
6121 if (o->op_flags & OPf_KIDS) {
6122 OP **tokid = &cLISTOPo->op_first;
6123 register OP *kid = cLISTOPo->op_first;
6127 if (kid->op_type == OP_PUSHMARK ||
6128 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
6130 tokid = &kid->op_sibling;
6131 kid = kid->op_sibling;
6133 if (!kid && PL_opargs[type] & OA_DEFGV)
6134 *tokid = kid = newDEFSVOP();
6138 sibl = kid->op_sibling;
6140 if (!sibl && kid->op_type == OP_STUB) {
6147 /* list seen where single (scalar) arg expected? */
6148 if (numargs == 1 && !(oa >> 4)
6149 && kid->op_type == OP_LIST && type != OP_SCALAR)
6151 return too_many_arguments(o,PL_op_desc[type]);
6164 if ((type == OP_PUSH || type == OP_UNSHIFT)
6165 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
6166 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6167 "Useless use of %s with no values",
6170 if (kid->op_type == OP_CONST &&
6171 (kid->op_private & OPpCONST_BARE))
6173 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
6174 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
6175 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6176 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6177 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
6178 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
6180 op_getmad(kid,newop,'K');
6185 kid->op_sibling = sibl;
6188 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
6189 bad_type(numargs, "array", PL_op_desc[type], kid);
6193 if (kid->op_type == OP_CONST &&
6194 (kid->op_private & OPpCONST_BARE))
6196 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
6197 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
6198 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6199 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6200 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
6201 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
6203 op_getmad(kid,newop,'K');
6208 kid->op_sibling = sibl;
6211 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
6212 bad_type(numargs, "hash", PL_op_desc[type], kid);
6217 OP * const newop = newUNOP(OP_NULL, 0, kid);
6218 kid->op_sibling = 0;
6220 newop->op_next = newop;
6222 kid->op_sibling = sibl;
6227 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
6228 if (kid->op_type == OP_CONST &&
6229 (kid->op_private & OPpCONST_BARE))
6231 OP * const newop = newGVOP(OP_GV, 0,
6232 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
6233 if (!(o->op_private & 1) && /* if not unop */
6234 kid == cLISTOPo->op_last)
6235 cLISTOPo->op_last = newop;
6237 op_getmad(kid,newop,'K');
6243 else if (kid->op_type == OP_READLINE) {
6244 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
6245 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
6248 I32 flags = OPf_SPECIAL;
6252 /* is this op a FH constructor? */
6253 if (is_handle_constructor(o,numargs)) {
6254 const char *name = NULL;
6258 /* Set a flag to tell rv2gv to vivify
6259 * need to "prove" flag does not mean something
6260 * else already - NI-S 1999/05/07
6263 if (kid->op_type == OP_PADSV) {
6264 name = PAD_COMPNAME_PV(kid->op_targ);
6265 /* SvCUR of a pad namesv can't be trusted
6266 * (see PL_generation), so calc its length
6272 else if (kid->op_type == OP_RV2SV
6273 && kUNOP->op_first->op_type == OP_GV)
6275 GV * const gv = cGVOPx_gv(kUNOP->op_first);
6277 len = GvNAMELEN(gv);
6279 else if (kid->op_type == OP_AELEM
6280 || kid->op_type == OP_HELEM)
6282 OP *op = ((BINOP*)kid)->op_first;
6286 const char * const a =
6287 kid->op_type == OP_AELEM ?
6289 if (((op->op_type == OP_RV2AV) ||
6290 (op->op_type == OP_RV2HV)) &&
6291 (op = ((UNOP*)op)->op_first) &&
6292 (op->op_type == OP_GV)) {
6293 /* packagevar $a[] or $h{} */
6294 GV * const gv = cGVOPx_gv(op);
6302 else if (op->op_type == OP_PADAV
6303 || op->op_type == OP_PADHV) {
6304 /* lexicalvar $a[] or $h{} */
6305 const char * const padname =
6306 PAD_COMPNAME_PV(op->op_targ);
6315 name = SvPV_const(tmpstr, len);
6320 name = "__ANONIO__";
6327 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
6328 namesv = PAD_SVl(targ);
6329 SvUPGRADE(namesv, SVt_PV);
6331 sv_setpvn(namesv, "$", 1);
6332 sv_catpvn(namesv, name, len);
6335 kid->op_sibling = 0;
6336 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
6337 kid->op_targ = targ;
6338 kid->op_private |= priv;
6340 kid->op_sibling = sibl;
6346 mod(scalar(kid), type);
6350 tokid = &kid->op_sibling;
6351 kid = kid->op_sibling;
6354 if (kid && kid->op_type != OP_STUB)
6355 return too_many_arguments(o,OP_DESC(o));
6356 o->op_private |= numargs;
6358 /* FIXME - should the numargs move as for the PERL_MAD case? */
6359 o->op_private |= numargs;
6361 return too_many_arguments(o,OP_DESC(o));
6365 else if (PL_opargs[type] & OA_DEFGV) {
6366 OP *newop = newUNOP(type, 0, newDEFSVOP());
6368 op_getmad(o,newop,'O');
6376 while (oa & OA_OPTIONAL)
6378 if (oa && oa != OA_LIST)
6379 return too_few_arguments(o,OP_DESC(o));
6385 Perl_ck_glob(pTHX_ OP *o)
6391 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
6392 append_elem(OP_GLOB, o, newDEFSVOP());
6394 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
6395 && GvCVu(gv) && GvIMPORTED_CV(gv)))
6397 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6400 #if !defined(PERL_EXTERNAL_GLOB)
6401 /* XXX this can be tightened up and made more failsafe. */
6402 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
6405 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
6406 newSVpvs("File::Glob"), NULL, NULL, NULL);
6407 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6408 glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
6409 GvCV(gv) = GvCV(glob_gv);
6410 SvREFCNT_inc_void((SV*)GvCV(gv));
6411 GvIMPORTED_CV_on(gv);
6414 #endif /* PERL_EXTERNAL_GLOB */
6416 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6417 append_elem(OP_GLOB, o,
6418 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
6419 o->op_type = OP_LIST;
6420 o->op_ppaddr = PL_ppaddr[OP_LIST];
6421 cLISTOPo->op_first->op_type = OP_PUSHMARK;
6422 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
6423 cLISTOPo->op_first->op_targ = 0;
6424 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
6425 append_elem(OP_LIST, o,
6426 scalar(newUNOP(OP_RV2CV, 0,
6427 newGVOP(OP_GV, 0, gv)))));
6428 o = newUNOP(OP_NULL, 0, ck_subr(o));
6429 o->op_targ = OP_GLOB; /* hint at what it used to be */
6432 gv = newGVgen("main");
6434 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
6440 Perl_ck_grep(pTHX_ OP *o)
6445 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
6448 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
6449 NewOp(1101, gwop, 1, LOGOP);
6451 if (o->op_flags & OPf_STACKED) {
6454 kid = cLISTOPo->op_first->op_sibling;
6455 if (!cUNOPx(kid)->op_next)
6456 Perl_croak(aTHX_ "panic: ck_grep");
6457 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
6460 kid->op_next = (OP*)gwop;
6461 o->op_flags &= ~OPf_STACKED;
6463 kid = cLISTOPo->op_first->op_sibling;
6464 if (type == OP_MAPWHILE)
6471 kid = cLISTOPo->op_first->op_sibling;
6472 if (kid->op_type != OP_NULL)
6473 Perl_croak(aTHX_ "panic: ck_grep");
6474 kid = kUNOP->op_first;
6476 gwop->op_type = type;
6477 gwop->op_ppaddr = PL_ppaddr[type];
6478 gwop->op_first = listkids(o);
6479 gwop->op_flags |= OPf_KIDS;
6480 gwop->op_other = LINKLIST(kid);
6481 kid->op_next = (OP*)gwop;
6482 offset = pad_findmy("$_");
6483 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
6484 o->op_private = gwop->op_private = 0;
6485 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
6488 o->op_private = gwop->op_private = OPpGREP_LEX;
6489 gwop->op_targ = o->op_targ = offset;
6492 kid = cLISTOPo->op_first->op_sibling;
6493 if (!kid || !kid->op_sibling)
6494 return too_few_arguments(o,OP_DESC(o));
6495 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
6496 mod(kid, OP_GREPSTART);
6502 Perl_ck_index(pTHX_ OP *o)
6504 if (o->op_flags & OPf_KIDS) {
6505 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6507 kid = kid->op_sibling; /* get past "big" */
6508 if (kid && kid->op_type == OP_CONST)
6509 fbm_compile(((SVOP*)kid)->op_sv, 0);
6515 Perl_ck_lengthconst(pTHX_ OP *o)
6517 /* XXX length optimization goes here */
6522 Perl_ck_lfun(pTHX_ OP *o)
6524 const OPCODE type = o->op_type;
6525 return modkids(ck_fun(o), type);
6529 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
6531 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
6532 switch (cUNOPo->op_first->op_type) {
6534 /* This is needed for
6535 if (defined %stash::)
6536 to work. Do not break Tk.
6538 break; /* Globals via GV can be undef */
6540 case OP_AASSIGN: /* Is this a good idea? */
6541 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6542 "defined(@array) is deprecated");
6543 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6544 "\t(Maybe you should just omit the defined()?)\n");
6547 /* This is needed for
6548 if (defined %stash::)
6549 to work. Do not break Tk.
6551 break; /* Globals via GV can be undef */
6553 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6554 "defined(%%hash) is deprecated");
6555 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6556 "\t(Maybe you should just omit the defined()?)\n");
6567 Perl_ck_rfun(pTHX_ OP *o)
6569 const OPCODE type = o->op_type;
6570 return refkids(ck_fun(o), type);
6574 Perl_ck_listiob(pTHX_ OP *o)
6578 kid = cLISTOPo->op_first;
6581 kid = cLISTOPo->op_first;
6583 if (kid->op_type == OP_PUSHMARK)
6584 kid = kid->op_sibling;
6585 if (kid && o->op_flags & OPf_STACKED)
6586 kid = kid->op_sibling;
6587 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6588 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6589 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6590 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6591 cLISTOPo->op_first->op_sibling = kid;
6592 cLISTOPo->op_last = kid;
6593 kid = kid->op_sibling;
6598 append_elem(o->op_type, o, newDEFSVOP());
6604 Perl_ck_say(pTHX_ OP *o)
6607 o->op_type = OP_PRINT;
6608 cLISTOPo->op_last = cLISTOPo->op_last->op_sibling
6609 = newSVOP(OP_CONST, 0, newSVpvs("\n"));
6614 Perl_ck_smartmatch(pTHX_ OP *o)
6617 if (0 == (o->op_flags & OPf_SPECIAL)) {
6618 OP *first = cBINOPo->op_first;
6619 OP *second = first->op_sibling;
6621 /* Implicitly take a reference to an array or hash */
6622 first->op_sibling = NULL;
6623 first = cBINOPo->op_first = ref_array_or_hash(first);
6624 second = first->op_sibling = ref_array_or_hash(second);
6626 /* Implicitly take a reference to a regular expression */
6627 if (first->op_type == OP_MATCH) {
6628 first->op_type = OP_QR;
6629 first->op_ppaddr = PL_ppaddr[OP_QR];
6631 if (second->op_type == OP_MATCH) {
6632 second->op_type = OP_QR;
6633 second->op_ppaddr = PL_ppaddr[OP_QR];
6642 Perl_ck_sassign(pTHX_ OP *o)
6644 OP *kid = cLISTOPo->op_first;
6645 /* has a disposable target? */
6646 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6647 && !(kid->op_flags & OPf_STACKED)
6648 /* Cannot steal the second time! */
6649 && !(kid->op_private & OPpTARGET_MY))
6651 OP * const kkid = kid->op_sibling;
6653 /* Can just relocate the target. */
6654 if (kkid && kkid->op_type == OP_PADSV
6655 && !(kkid->op_private & OPpLVAL_INTRO))
6657 kid->op_targ = kkid->op_targ;
6659 /* Now we do not need PADSV and SASSIGN. */
6660 kid->op_sibling = o->op_sibling; /* NULL */
6661 cLISTOPo->op_first = NULL;
6663 op_getmad(o,kid,'O');
6664 op_getmad(kkid,kid,'M');
6669 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6677 Perl_ck_match(pTHX_ OP *o)
6680 if (o->op_type != OP_QR && PL_compcv) {
6681 const I32 offset = pad_findmy("$_");
6682 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
6683 o->op_targ = offset;
6684 o->op_private |= OPpTARGET_MY;
6687 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
6688 o->op_private |= OPpRUNTIME;
6693 Perl_ck_method(pTHX_ OP *o)
6695 OP * const kid = cUNOPo->op_first;
6696 if (kid->op_type == OP_CONST) {
6697 SV* sv = kSVOP->op_sv;
6698 const char * const method = SvPVX_const(sv);
6699 if (!(strchr(method, ':') || strchr(method, '\''))) {
6701 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6702 sv = newSVpvn_share(method, SvCUR(sv), 0);
6705 kSVOP->op_sv = NULL;
6707 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6709 op_getmad(o,cmop,'O');
6720 Perl_ck_null(pTHX_ OP *o)
6722 PERL_UNUSED_CONTEXT;
6727 Perl_ck_open(pTHX_ OP *o)
6730 HV * const table = GvHV(PL_hintgv);
6732 SV **svp = hv_fetchs(table, "open_IN", FALSE);
6734 const I32 mode = mode_from_discipline(*svp);
6735 if (mode & O_BINARY)
6736 o->op_private |= OPpOPEN_IN_RAW;
6737 else if (mode & O_TEXT)
6738 o->op_private |= OPpOPEN_IN_CRLF;
6741 svp = hv_fetchs(table, "open_OUT", FALSE);
6743 const I32 mode = mode_from_discipline(*svp);
6744 if (mode & O_BINARY)
6745 o->op_private |= OPpOPEN_OUT_RAW;
6746 else if (mode & O_TEXT)
6747 o->op_private |= OPpOPEN_OUT_CRLF;
6750 if (o->op_type == OP_BACKTICK)
6753 /* In case of three-arg dup open remove strictness
6754 * from the last arg if it is a bareword. */
6755 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
6756 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
6760 if ((last->op_type == OP_CONST) && /* The bareword. */
6761 (last->op_private & OPpCONST_BARE) &&
6762 (last->op_private & OPpCONST_STRICT) &&
6763 (oa = first->op_sibling) && /* The fh. */
6764 (oa = oa->op_sibling) && /* The mode. */
6765 (oa->op_type == OP_CONST) &&
6766 SvPOK(((SVOP*)oa)->op_sv) &&
6767 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
6768 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
6769 (last == oa->op_sibling)) /* The bareword. */
6770 last->op_private &= ~OPpCONST_STRICT;
6776 Perl_ck_repeat(pTHX_ OP *o)
6778 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6779 o->op_private |= OPpREPEAT_DOLIST;
6780 cBINOPo->op_first = force_list(cBINOPo->op_first);
6788 Perl_ck_require(pTHX_ OP *o)
6793 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6794 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6796 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6797 SV * const sv = kid->op_sv;
6798 U32 was_readonly = SvREADONLY(sv);
6803 sv_force_normal_flags(sv, 0);
6804 assert(!SvREADONLY(sv));
6811 for (s = SvPVX(sv); *s; s++) {
6812 if (*s == ':' && s[1] == ':') {
6813 const STRLEN len = strlen(s+2)+1;
6815 Move(s+2, s+1, len, char);
6816 SvCUR_set(sv, SvCUR(sv) - 1);
6819 sv_catpvs(sv, ".pm");
6820 SvFLAGS(sv) |= was_readonly;
6824 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
6825 /* handle override, if any */
6826 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
6827 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
6828 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
6829 gv = gvp ? *gvp : NULL;
6833 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6834 OP * const kid = cUNOPo->op_first;
6836 = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
6837 append_elem(OP_LIST, kid,
6838 scalar(newUNOP(OP_RV2CV, 0,
6841 cUNOPo->op_first = 0;
6843 op_getmad(o,newop,'O');
6854 Perl_ck_return(pTHX_ OP *o)
6857 if (CvLVALUE(PL_compcv)) {
6859 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6860 mod(kid, OP_LEAVESUBLV);
6866 Perl_ck_select(pTHX_ OP *o)
6870 if (o->op_flags & OPf_KIDS) {
6871 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6872 if (kid && kid->op_sibling) {
6873 o->op_type = OP_SSELECT;
6874 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6876 return fold_constants(o);
6880 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6881 if (kid && kid->op_type == OP_RV2GV)
6882 kid->op_private &= ~HINT_STRICT_REFS;
6887 Perl_ck_shift(pTHX_ OP *o)
6890 const I32 type = o->op_type;
6892 if (!(o->op_flags & OPf_KIDS)) {
6894 /* FIXME - this can be refactored to reduce code in #ifdefs */
6900 argop = newUNOP(OP_RV2AV, 0,
6901 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
6903 o = newUNOP(type, 0, scalar(argop));
6904 op_getmad(oldo,o,'O');
6907 return newUNOP(type, 0, scalar(argop));
6910 return scalar(modkids(ck_fun(o), type));
6914 Perl_ck_sort(pTHX_ OP *o)
6919 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0)
6921 HV * const hinthv = GvHV(PL_hintgv);
6923 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
6925 const I32 sorthints = (I32)SvIV(*svp);
6926 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
6927 o->op_private |= OPpSORT_QSORT;
6928 if ((sorthints & HINT_SORT_STABLE) != 0)
6929 o->op_private |= OPpSORT_STABLE;
6934 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6936 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6937 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6939 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6941 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6943 if (kid->op_type == OP_SCOPE) {
6947 else if (kid->op_type == OP_LEAVE) {
6948 if (o->op_type == OP_SORT) {
6949 op_null(kid); /* wipe out leave */
6952 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6953 if (k->op_next == kid)
6955 /* don't descend into loops */
6956 else if (k->op_type == OP_ENTERLOOP
6957 || k->op_type == OP_ENTERITER)
6959 k = cLOOPx(k)->op_lastop;
6964 kid->op_next = 0; /* just disconnect the leave */
6965 k = kLISTOP->op_first;
6970 if (o->op_type == OP_SORT) {
6971 /* provide scalar context for comparison function/block */
6977 o->op_flags |= OPf_SPECIAL;
6979 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6982 firstkid = firstkid->op_sibling;
6985 /* provide list context for arguments */
6986 if (o->op_type == OP_SORT)
6993 S_simplify_sort(pTHX_ OP *o)
6996 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7001 if (!(o->op_flags & OPf_STACKED))
7003 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7004 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
7005 kid = kUNOP->op_first; /* get past null */
7006 if (kid->op_type != OP_SCOPE)
7008 kid = kLISTOP->op_last; /* get past scope */
7009 switch(kid->op_type) {
7017 k = kid; /* remember this node*/
7018 if (kBINOP->op_first->op_type != OP_RV2SV)
7020 kid = kBINOP->op_first; /* get past cmp */
7021 if (kUNOP->op_first->op_type != OP_GV)
7023 kid = kUNOP->op_first; /* get past rv2sv */
7025 if (GvSTASH(gv) != PL_curstash)
7027 gvname = GvNAME(gv);
7028 if (*gvname == 'a' && gvname[1] == '\0')
7030 else if (*gvname == 'b' && gvname[1] == '\0')
7035 kid = k; /* back to cmp */
7036 if (kBINOP->op_last->op_type != OP_RV2SV)
7038 kid = kBINOP->op_last; /* down to 2nd arg */
7039 if (kUNOP->op_first->op_type != OP_GV)
7041 kid = kUNOP->op_first; /* get past rv2sv */
7043 if (GvSTASH(gv) != PL_curstash)
7045 gvname = GvNAME(gv);
7047 ? !(*gvname == 'a' && gvname[1] == '\0')
7048 : !(*gvname == 'b' && gvname[1] == '\0'))
7050 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
7052 o->op_private |= OPpSORT_DESCEND;
7053 if (k->op_type == OP_NCMP)
7054 o->op_private |= OPpSORT_NUMERIC;
7055 if (k->op_type == OP_I_NCMP)
7056 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
7057 kid = cLISTOPo->op_first->op_sibling;
7058 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
7060 op_getmad(kid,o,'S'); /* then delete it */
7062 op_free(kid); /* then delete it */
7067 Perl_ck_split(pTHX_ OP *o)
7072 if (o->op_flags & OPf_STACKED)
7073 return no_fh_allowed(o);
7075 kid = cLISTOPo->op_first;
7076 if (kid->op_type != OP_NULL)
7077 Perl_croak(aTHX_ "panic: ck_split");
7078 kid = kid->op_sibling;
7079 op_free(cLISTOPo->op_first);
7080 cLISTOPo->op_first = kid;
7082 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
7083 cLISTOPo->op_last = kid; /* There was only one element previously */
7086 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
7087 OP * const sibl = kid->op_sibling;
7088 kid->op_sibling = 0;
7089 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
7090 if (cLISTOPo->op_first == cLISTOPo->op_last)
7091 cLISTOPo->op_last = kid;
7092 cLISTOPo->op_first = kid;
7093 kid->op_sibling = sibl;
7096 kid->op_type = OP_PUSHRE;
7097 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
7099 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
7100 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
7101 "Use of /g modifier is meaningless in split");
7104 if (!kid->op_sibling)
7105 append_elem(OP_SPLIT, o, newDEFSVOP());
7107 kid = kid->op_sibling;
7110 if (!kid->op_sibling)
7111 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
7113 kid = kid->op_sibling;
7116 if (kid->op_sibling)
7117 return too_many_arguments(o,OP_DESC(o));
7123 Perl_ck_join(pTHX_ OP *o)
7125 const OP * const kid = cLISTOPo->op_first->op_sibling;
7126 if (kid && kid->op_type == OP_MATCH) {
7127 if (ckWARN(WARN_SYNTAX)) {
7128 const REGEXP *re = PM_GETRE(kPMOP);
7129 const char *pmstr = re ? re->precomp : "STRING";
7130 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7131 "/%s/ should probably be written as \"%s\"",
7139 Perl_ck_subr(pTHX_ OP *o)
7142 OP *prev = ((cUNOPo->op_first->op_sibling)
7143 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
7144 OP *o2 = prev->op_sibling;
7151 I32 contextclass = 0;
7155 o->op_private |= OPpENTERSUB_HASTARG;
7156 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
7157 if (cvop->op_type == OP_RV2CV) {
7159 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
7160 op_null(cvop); /* disable rv2cv */
7161 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
7162 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
7163 GV *gv = cGVOPx_gv(tmpop);
7166 tmpop->op_private |= OPpEARLY_CV;
7169 namegv = CvANON(cv) ? gv : CvGV(cv);
7170 proto = SvPV_nolen((SV*)cv);
7172 if (CvASSERTION(cv)) {
7173 if (PL_hints & HINT_ASSERTING) {
7174 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
7175 o->op_private |= OPpENTERSUB_DB;
7179 if (!(PL_hints & HINT_ASSERTIONSSEEN) && ckWARN(WARN_ASSERTIONS)) {
7180 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
7181 "Impossible to activate assertion call");
7188 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7189 if (o2->op_type == OP_CONST)
7190 o2->op_private &= ~OPpCONST_STRICT;
7191 else if (o2->op_type == OP_LIST) {
7192 OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
7193 if (sib && sib->op_type == OP_CONST)
7194 sib->op_private &= ~OPpCONST_STRICT;
7197 o->op_private |= (PL_hints & HINT_STRICT_REFS);
7198 if (PERLDB_SUB && PL_curstash != PL_debstash)
7199 o->op_private |= OPpENTERSUB_DB;
7200 while (o2 != cvop) {
7202 if (PL_madskills && o2->op_type == OP_NULL)
7203 o3 = ((UNOP*)o2)->op_first;
7209 return too_many_arguments(o, gv_ename(namegv));
7227 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
7229 arg == 1 ? "block or sub {}" : "sub {}",
7230 gv_ename(namegv), o3);
7233 /* '*' allows any scalar type, including bareword */
7236 if (o3->op_type == OP_RV2GV)
7237 goto wrapref; /* autoconvert GLOB -> GLOBref */
7238 else if (o3->op_type == OP_CONST)
7239 o3->op_private &= ~OPpCONST_STRICT;
7240 else if (o3->op_type == OP_ENTERSUB) {
7241 /* accidental subroutine, revert to bareword */
7242 OP *gvop = ((UNOP*)o3)->op_first;
7243 if (gvop && gvop->op_type == OP_NULL) {
7244 gvop = ((UNOP*)gvop)->op_first;
7246 for (; gvop->op_sibling; gvop = gvop->op_sibling)
7249 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
7250 (gvop = ((UNOP*)gvop)->op_first) &&
7251 gvop->op_type == OP_GV)
7253 GV * const gv = cGVOPx_gv(gvop);
7254 OP * const sibling = o2->op_sibling;
7255 SV * const n = newSVpvs("");
7261 gv_fullname4(n, gv, "", FALSE);
7262 o2 = newSVOP(OP_CONST, 0, n);
7263 op_getmad(oldo2,o2,'O');
7264 prev->op_sibling = o2;
7265 o2->op_sibling = sibling;
7281 if (contextclass++ == 0) {
7282 e = strchr(proto, ']');
7283 if (!e || e == proto)
7292 /* XXX We shouldn't be modifying proto, so we can const proto */
7297 while (*--p != '[');
7298 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
7299 gv_ename(namegv), o3);
7305 if (o3->op_type == OP_RV2GV)
7308 bad_type(arg, "symbol", gv_ename(namegv), o3);
7311 if (o3->op_type == OP_ENTERSUB)
7314 bad_type(arg, "subroutine entry", gv_ename(namegv),
7318 if (o3->op_type == OP_RV2SV ||
7319 o3->op_type == OP_PADSV ||
7320 o3->op_type == OP_HELEM ||
7321 o3->op_type == OP_AELEM ||
7322 o3->op_type == OP_THREADSV)
7325 bad_type(arg, "scalar", gv_ename(namegv), o3);
7328 if (o3->op_type == OP_RV2AV ||
7329 o3->op_type == OP_PADAV)
7332 bad_type(arg, "array", gv_ename(namegv), o3);
7335 if (o3->op_type == OP_RV2HV ||
7336 o3->op_type == OP_PADHV)
7339 bad_type(arg, "hash", gv_ename(namegv), o3);
7344 OP* const sib = kid->op_sibling;
7345 kid->op_sibling = 0;
7346 o2 = newUNOP(OP_REFGEN, 0, kid);
7347 o2->op_sibling = sib;
7348 prev->op_sibling = o2;
7350 if (contextclass && e) {
7365 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
7366 gv_ename(namegv), cv);
7371 mod(o2, OP_ENTERSUB);
7373 o2 = o2->op_sibling;
7375 if (proto && !optional &&
7376 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
7377 return too_few_arguments(o, gv_ename(namegv));
7384 o=newSVOP(OP_CONST, 0, newSViv(0));
7385 op_getmad(oldo,o,'O');
7391 Perl_ck_svconst(pTHX_ OP *o)
7393 PERL_UNUSED_CONTEXT;
7394 SvREADONLY_on(cSVOPo->op_sv);
7399 Perl_ck_chdir(pTHX_ OP *o)
7401 if (o->op_flags & OPf_KIDS) {
7402 SVOP *kid = (SVOP*)cUNOPo->op_first;
7404 if (kid && kid->op_type == OP_CONST &&
7405 (kid->op_private & OPpCONST_BARE))
7407 o->op_flags |= OPf_SPECIAL;
7408 kid->op_private &= ~OPpCONST_STRICT;
7415 Perl_ck_trunc(pTHX_ OP *o)
7417 if (o->op_flags & OPf_KIDS) {
7418 SVOP *kid = (SVOP*)cUNOPo->op_first;
7420 if (kid->op_type == OP_NULL)
7421 kid = (SVOP*)kid->op_sibling;
7422 if (kid && kid->op_type == OP_CONST &&
7423 (kid->op_private & OPpCONST_BARE))
7425 o->op_flags |= OPf_SPECIAL;
7426 kid->op_private &= ~OPpCONST_STRICT;
7433 Perl_ck_unpack(pTHX_ OP *o)
7435 OP *kid = cLISTOPo->op_first;
7436 if (kid->op_sibling) {
7437 kid = kid->op_sibling;
7438 if (!kid->op_sibling)
7439 kid->op_sibling = newDEFSVOP();
7445 Perl_ck_substr(pTHX_ OP *o)
7448 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
7449 OP *kid = cLISTOPo->op_first;
7451 if (kid->op_type == OP_NULL)
7452 kid = kid->op_sibling;
7454 kid->op_flags |= OPf_MOD;
7460 /* A peephole optimizer. We visit the ops in the order they're to execute.
7461 * See the comments at the top of this file for more details about when
7462 * peep() is called */
7465 Perl_peep(pTHX_ register OP *o)
7468 register OP* oldop = NULL;
7470 if (!o || o->op_opt)
7474 SAVEVPTR(PL_curcop);
7475 for (; o; o = o->op_next) {
7479 switch (o->op_type) {
7483 PL_curcop = ((COP*)o); /* for warnings */
7488 if (cSVOPo->op_private & OPpCONST_STRICT)
7489 no_bareword_allowed(o);
7491 case OP_METHOD_NAMED:
7492 /* Relocate sv to the pad for thread safety.
7493 * Despite being a "constant", the SV is written to,
7494 * for reference counts, sv_upgrade() etc. */
7496 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
7497 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
7498 /* If op_sv is already a PADTMP then it is being used by
7499 * some pad, so make a copy. */
7500 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
7501 SvREADONLY_on(PAD_SVl(ix));
7502 SvREFCNT_dec(cSVOPo->op_sv);
7504 else if (o->op_type == OP_CONST
7505 && cSVOPo->op_sv == &PL_sv_undef) {
7506 /* PL_sv_undef is hack - it's unsafe to store it in the
7507 AV that is the pad, because av_fetch treats values of
7508 PL_sv_undef as a "free" AV entry and will merrily
7509 replace them with a new SV, causing pad_alloc to think
7510 that this pad slot is free. (When, clearly, it is not)
7512 SvOK_off(PAD_SVl(ix));
7513 SvPADTMP_on(PAD_SVl(ix));
7514 SvREADONLY_on(PAD_SVl(ix));
7517 SvREFCNT_dec(PAD_SVl(ix));
7518 SvPADTMP_on(cSVOPo->op_sv);
7519 PAD_SETSV(ix, cSVOPo->op_sv);
7520 /* XXX I don't know how this isn't readonly already. */
7521 SvREADONLY_on(PAD_SVl(ix));
7523 cSVOPo->op_sv = NULL;
7531 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
7532 if (o->op_next->op_private & OPpTARGET_MY) {
7533 if (o->op_flags & OPf_STACKED) /* chained concats */
7534 goto ignore_optimization;
7536 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
7537 o->op_targ = o->op_next->op_targ;
7538 o->op_next->op_targ = 0;
7539 o->op_private |= OPpTARGET_MY;
7542 op_null(o->op_next);
7544 ignore_optimization:
7548 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
7550 break; /* Scalar stub must produce undef. List stub is noop */
7554 if (o->op_targ == OP_NEXTSTATE
7555 || o->op_targ == OP_DBSTATE
7556 || o->op_targ == OP_SETSTATE)
7558 PL_curcop = ((COP*)o);
7560 /* XXX: We avoid setting op_seq here to prevent later calls
7561 to peep() from mistakenly concluding that optimisation
7562 has already occurred. This doesn't fix the real problem,
7563 though (See 20010220.007). AMS 20010719 */
7564 /* op_seq functionality is now replaced by op_opt */
7565 if (oldop && o->op_next) {
7566 oldop->op_next = o->op_next;
7574 if (oldop && o->op_next) {
7575 oldop->op_next = o->op_next;
7583 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
7584 OP* const pop = (o->op_type == OP_PADAV) ?
7585 o->op_next : o->op_next->op_next;
7587 if (pop && pop->op_type == OP_CONST &&
7588 ((PL_op = pop->op_next)) &&
7589 pop->op_next->op_type == OP_AELEM &&
7590 !(pop->op_next->op_private &
7591 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
7592 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
7597 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
7598 no_bareword_allowed(pop);
7599 if (o->op_type == OP_GV)
7600 op_null(o->op_next);
7601 op_null(pop->op_next);
7603 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
7604 o->op_next = pop->op_next->op_next;
7605 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
7606 o->op_private = (U8)i;
7607 if (o->op_type == OP_GV) {
7612 o->op_flags |= OPf_SPECIAL;
7613 o->op_type = OP_AELEMFAST;
7619 if (o->op_next->op_type == OP_RV2SV) {
7620 if (!(o->op_next->op_private & OPpDEREF)) {
7621 op_null(o->op_next);
7622 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
7624 o->op_next = o->op_next->op_next;
7625 o->op_type = OP_GVSV;
7626 o->op_ppaddr = PL_ppaddr[OP_GVSV];
7629 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
7630 GV * const gv = cGVOPo_gv;
7631 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
7632 /* XXX could check prototype here instead of just carping */
7633 SV * const sv = sv_newmortal();
7634 gv_efullname3(sv, gv, NULL);
7635 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
7636 "%"SVf"() called too early to check prototype",
7640 else if (o->op_next->op_type == OP_READLINE
7641 && o->op_next->op_next->op_type == OP_CONCAT
7642 && (o->op_next->op_next->op_flags & OPf_STACKED))
7644 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
7645 o->op_type = OP_RCATLINE;
7646 o->op_flags |= OPf_STACKED;
7647 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
7648 op_null(o->op_next->op_next);
7649 op_null(o->op_next);
7666 while (cLOGOP->op_other->op_type == OP_NULL)
7667 cLOGOP->op_other = cLOGOP->op_other->op_next;
7668 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
7674 while (cLOOP->op_redoop->op_type == OP_NULL)
7675 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
7676 peep(cLOOP->op_redoop);
7677 while (cLOOP->op_nextop->op_type == OP_NULL)
7678 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
7679 peep(cLOOP->op_nextop);
7680 while (cLOOP->op_lastop->op_type == OP_NULL)
7681 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
7682 peep(cLOOP->op_lastop);
7689 while (cPMOP->op_pmreplstart &&
7690 cPMOP->op_pmreplstart->op_type == OP_NULL)
7691 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
7692 peep(cPMOP->op_pmreplstart);
7697 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
7698 && ckWARN(WARN_SYNTAX))
7700 if (o->op_next->op_sibling &&
7701 o->op_next->op_sibling->op_type != OP_EXIT &&
7702 o->op_next->op_sibling->op_type != OP_WARN &&
7703 o->op_next->op_sibling->op_type != OP_DIE) {
7704 const line_t oldline = CopLINE(PL_curcop);
7706 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
7707 Perl_warner(aTHX_ packWARN(WARN_EXEC),
7708 "Statement unlikely to be reached");
7709 Perl_warner(aTHX_ packWARN(WARN_EXEC),
7710 "\t(Maybe you meant system() when you said exec()?)\n");
7711 CopLINE_set(PL_curcop, oldline);
7721 const char *key = NULL;
7726 if (((BINOP*)o)->op_last->op_type != OP_CONST)
7729 /* Make the CONST have a shared SV */
7730 svp = cSVOPx_svp(((BINOP*)o)->op_last);
7731 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
7732 key = SvPV_const(sv, keylen);
7733 lexname = newSVpvn_share(key,
7734 SvUTF8(sv) ? -(I32)keylen : keylen,
7740 if ((o->op_private & (OPpLVAL_INTRO)))
7743 rop = (UNOP*)((BINOP*)o)->op_first;
7744 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7746 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7747 if (!SvPAD_TYPED(lexname))
7749 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
7750 if (!fields || !GvHV(*fields))
7752 key = SvPV_const(*svp, keylen);
7753 if (!hv_fetch(GvHV(*fields), key,
7754 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
7756 Perl_croak(aTHX_ "No such class field \"%s\" "
7757 "in variable %s of type %s",
7758 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
7771 SVOP *first_key_op, *key_op;
7773 if ((o->op_private & (OPpLVAL_INTRO))
7774 /* I bet there's always a pushmark... */
7775 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
7776 /* hmmm, no optimization if list contains only one key. */
7778 rop = (UNOP*)((LISTOP*)o)->op_last;
7779 if (rop->op_type != OP_RV2HV)
7781 if (rop->op_first->op_type == OP_PADSV)
7782 /* @$hash{qw(keys here)} */
7783 rop = (UNOP*)rop->op_first;
7785 /* @{$hash}{qw(keys here)} */
7786 if (rop->op_first->op_type == OP_SCOPE
7787 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
7789 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
7795 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
7796 if (!SvPAD_TYPED(lexname))
7798 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
7799 if (!fields || !GvHV(*fields))
7801 /* Again guessing that the pushmark can be jumped over.... */
7802 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
7803 ->op_first->op_sibling;
7804 for (key_op = first_key_op; key_op;
7805 key_op = (SVOP*)key_op->op_sibling) {
7806 if (key_op->op_type != OP_CONST)
7808 svp = cSVOPx_svp(key_op);
7809 key = SvPV_const(*svp, keylen);
7810 if (!hv_fetch(GvHV(*fields), key,
7811 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
7813 Perl_croak(aTHX_ "No such class field \"%s\" "
7814 "in variable %s of type %s",
7815 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
7822 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
7826 /* check that RHS of sort is a single plain array */
7827 OP *oright = cUNOPo->op_first;
7828 if (!oright || oright->op_type != OP_PUSHMARK)
7831 /* reverse sort ... can be optimised. */
7832 if (!cUNOPo->op_sibling) {
7833 /* Nothing follows us on the list. */
7834 OP * const reverse = o->op_next;
7836 if (reverse->op_type == OP_REVERSE &&
7837 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
7838 OP * const pushmark = cUNOPx(reverse)->op_first;
7839 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
7840 && (cUNOPx(pushmark)->op_sibling == o)) {
7841 /* reverse -> pushmark -> sort */
7842 o->op_private |= OPpSORT_REVERSE;
7844 pushmark->op_next = oright->op_next;
7850 /* make @a = sort @a act in-place */
7854 oright = cUNOPx(oright)->op_sibling;
7857 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
7858 oright = cUNOPx(oright)->op_sibling;
7862 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
7863 || oright->op_next != o
7864 || (oright->op_private & OPpLVAL_INTRO)
7868 /* o2 follows the chain of op_nexts through the LHS of the
7869 * assign (if any) to the aassign op itself */
7871 if (!o2 || o2->op_type != OP_NULL)
7874 if (!o2 || o2->op_type != OP_PUSHMARK)
7877 if (o2 && o2->op_type == OP_GV)
7880 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
7881 || (o2->op_private & OPpLVAL_INTRO)
7886 if (!o2 || o2->op_type != OP_NULL)
7889 if (!o2 || o2->op_type != OP_AASSIGN
7890 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
7893 /* check that the sort is the first arg on RHS of assign */
7895 o2 = cUNOPx(o2)->op_first;
7896 if (!o2 || o2->op_type != OP_NULL)
7898 o2 = cUNOPx(o2)->op_first;
7899 if (!o2 || o2->op_type != OP_PUSHMARK)
7901 if (o2->op_sibling != o)
7904 /* check the array is the same on both sides */
7905 if (oleft->op_type == OP_RV2AV) {
7906 if (oright->op_type != OP_RV2AV
7907 || !cUNOPx(oright)->op_first
7908 || cUNOPx(oright)->op_first->op_type != OP_GV
7909 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
7910 cGVOPx_gv(cUNOPx(oright)->op_first)
7914 else if (oright->op_type != OP_PADAV
7915 || oright->op_targ != oleft->op_targ
7919 /* transfer MODishness etc from LHS arg to RHS arg */
7920 oright->op_flags = oleft->op_flags;
7921 o->op_private |= OPpSORT_INPLACE;
7923 /* excise push->gv->rv2av->null->aassign */
7924 o2 = o->op_next->op_next;
7925 op_null(o2); /* PUSHMARK */
7927 if (o2->op_type == OP_GV) {
7928 op_null(o2); /* GV */
7931 op_null(o2); /* RV2AV or PADAV */
7932 o2 = o2->op_next->op_next;
7933 op_null(o2); /* AASSIGN */
7935 o->op_next = o2->op_next;
7941 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
7943 LISTOP *enter, *exlist;
7946 enter = (LISTOP *) o->op_next;
7949 if (enter->op_type == OP_NULL) {
7950 enter = (LISTOP *) enter->op_next;
7954 /* for $a (...) will have OP_GV then OP_RV2GV here.
7955 for (...) just has an OP_GV. */
7956 if (enter->op_type == OP_GV) {
7957 gvop = (OP *) enter;
7958 enter = (LISTOP *) enter->op_next;
7961 if (enter->op_type == OP_RV2GV) {
7962 enter = (LISTOP *) enter->op_next;
7968 if (enter->op_type != OP_ENTERITER)
7971 iter = enter->op_next;
7972 if (!iter || iter->op_type != OP_ITER)
7975 expushmark = enter->op_first;
7976 if (!expushmark || expushmark->op_type != OP_NULL
7977 || expushmark->op_targ != OP_PUSHMARK)
7980 exlist = (LISTOP *) expushmark->op_sibling;
7981 if (!exlist || exlist->op_type != OP_NULL
7982 || exlist->op_targ != OP_LIST)
7985 if (exlist->op_last != o) {
7986 /* Mmm. Was expecting to point back to this op. */
7989 theirmark = exlist->op_first;
7990 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
7993 if (theirmark->op_sibling != o) {
7994 /* There's something between the mark and the reverse, eg
7995 for (1, reverse (...))
8000 ourmark = ((LISTOP *)o)->op_first;
8001 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
8004 ourlast = ((LISTOP *)o)->op_last;
8005 if (!ourlast || ourlast->op_next != o)
8008 rv2av = ourmark->op_sibling;
8009 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
8010 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
8011 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
8012 /* We're just reversing a single array. */
8013 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
8014 enter->op_flags |= OPf_STACKED;
8017 /* We don't have control over who points to theirmark, so sacrifice
8019 theirmark->op_next = ourmark->op_next;
8020 theirmark->op_flags = ourmark->op_flags;
8021 ourlast->op_next = gvop ? gvop : (OP *) enter;
8024 enter->op_private |= OPpITER_REVERSED;
8025 iter->op_private |= OPpITER_REVERSED;
8032 UNOP *refgen, *rv2cv;
8035 /* I do not understand this, but if o->op_opt isn't set to 1,
8036 various tests in ext/B/t/bytecode.t fail with no readily
8042 if ((o->op_flags && OPf_WANT) != OPf_WANT_VOID)
8045 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
8048 rv2gv = ((BINOP *)o)->op_last;
8049 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
8052 refgen = (UNOP *)((BINOP *)o)->op_first;
8054 if (!refgen || refgen->op_type != OP_REFGEN)
8057 exlist = (LISTOP *)refgen->op_first;
8058 if (!exlist || exlist->op_type != OP_NULL
8059 || exlist->op_targ != OP_LIST)
8062 if (exlist->op_first->op_type != OP_PUSHMARK)
8065 rv2cv = (UNOP*)exlist->op_last;
8067 if (rv2cv->op_type != OP_RV2CV)
8070 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
8071 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
8072 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
8074 o->op_private |= OPpASSIGN_CV_TO_GV;
8075 rv2gv->op_private |= OPpDONT_INIT_GV;
8076 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
8092 Perl_custom_op_name(pTHX_ const OP* o)
8095 const IV index = PTR2IV(o->op_ppaddr);
8099 if (!PL_custom_op_names) /* This probably shouldn't happen */
8100 return (char *)PL_op_name[OP_CUSTOM];
8102 keysv = sv_2mortal(newSViv(index));
8104 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
8106 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
8108 return SvPV_nolen(HeVAL(he));
8112 Perl_custom_op_desc(pTHX_ const OP* o)
8115 const IV index = PTR2IV(o->op_ppaddr);
8119 if (!PL_custom_op_descs)
8120 return (char *)PL_op_desc[OP_CUSTOM];
8122 keysv = sv_2mortal(newSViv(index));
8124 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
8126 return (char *)PL_op_desc[OP_CUSTOM];
8128 return SvPV_nolen(HeVAL(he));
8133 /* Efficient sub that returns a constant scalar value. */
8135 const_sv_xsub(pTHX_ CV* cv)
8142 Perl_croak(aTHX_ "usage: %s::%s()",
8143 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
8147 ST(0) = (SV*)XSANY.any_ptr;
8153 * c-indentation-style: bsd
8155 * indent-tabs-mode: t
8158 * ex: set ts=8 sts=4 sw=4 noet: