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.
339 However, commenting them out has caused ext/List/Util/t/weak.t to fail
342 mad_free(o->op_madprop);
348 switch (o->op_type) {
349 case OP_NULL: /* Was holding old type, if any. */
350 if (PL_madskills && o->op_targ != OP_NULL) {
351 o->op_type = o->op_targ;
355 case OP_ENTEREVAL: /* Was holding hints. */
359 if (!(o->op_flags & OPf_REF)
360 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
366 if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
367 /* not an OP_PADAV replacement */
369 if (cPADOPo->op_padix > 0) {
370 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
371 * may still exist on the pad */
372 pad_swipe(cPADOPo->op_padix, TRUE);
373 cPADOPo->op_padix = 0;
376 SvREFCNT_dec(cSVOPo->op_sv);
377 cSVOPo->op_sv = NULL;
381 case OP_METHOD_NAMED:
383 SvREFCNT_dec(cSVOPo->op_sv);
384 cSVOPo->op_sv = NULL;
387 Even if op_clear does a pad_free for the target of the op,
388 pad_free doesn't actually remove the sv that exists in the pad;
389 instead it lives on. This results in that it could be reused as
390 a target later on when the pad was reallocated.
393 pad_swipe(o->op_targ,1);
402 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
406 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
407 SvREFCNT_dec(cSVOPo->op_sv);
408 cSVOPo->op_sv = NULL;
411 Safefree(cPVOPo->op_pv);
412 cPVOPo->op_pv = NULL;
416 op_free(cPMOPo->op_pmreplroot);
420 if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) {
421 /* No GvIN_PAD_off here, because other references may still
422 * exist on the pad */
423 pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot), TRUE);
426 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
433 HV * const pmstash = PmopSTASH(cPMOPo);
434 if (pmstash && !SvIS_FREED(pmstash)) {
435 MAGIC * const mg = mg_find((SV*)pmstash, PERL_MAGIC_symtab);
437 PMOP *pmop = (PMOP*) mg->mg_obj;
438 PMOP *lastpmop = NULL;
440 if (cPMOPo == pmop) {
442 lastpmop->op_pmnext = pmop->op_pmnext;
444 mg->mg_obj = (SV*) pmop->op_pmnext;
448 pmop = pmop->op_pmnext;
452 PmopSTASH_free(cPMOPo);
454 cPMOPo->op_pmreplroot = NULL;
455 /* we use the "SAFE" version of the PM_ macros here
456 * since sv_clean_all might release some PMOPs
457 * after PL_regex_padav has been cleared
458 * and the clearing of PL_regex_padav needs to
459 * happen before sv_clean_all
461 ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
462 PM_SETRE_SAFE(cPMOPo, NULL);
464 if(PL_regex_pad) { /* We could be in destruction */
465 av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
466 SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
467 PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
474 if (o->op_targ > 0) {
475 pad_free(o->op_targ);
481 S_cop_free(pTHX_ COP* cop)
483 Safefree(cop->cop_label); /* FIXME: treaddead ??? */
486 if (! specialWARN(cop->cop_warnings))
487 SvREFCNT_dec(cop->cop_warnings);
488 if (! specialCopIO(cop->cop_io)) {
492 SvREFCNT_dec(cop->cop_io);
498 Perl_op_null(pTHX_ OP *o)
501 if (o->op_type == OP_NULL)
505 o->op_targ = o->op_type;
506 o->op_type = OP_NULL;
507 o->op_ppaddr = PL_ppaddr[OP_NULL];
511 Perl_op_refcnt_lock(pTHX)
519 Perl_op_refcnt_unlock(pTHX)
526 /* Contextualizers */
528 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
531 Perl_linklist(pTHX_ OP *o)
538 /* establish postfix order */
539 first = cUNOPo->op_first;
542 o->op_next = LINKLIST(first);
545 if (kid->op_sibling) {
546 kid->op_next = LINKLIST(kid->op_sibling);
547 kid = kid->op_sibling;
561 Perl_scalarkids(pTHX_ OP *o)
563 if (o && o->op_flags & OPf_KIDS) {
565 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
572 S_scalarboolean(pTHX_ OP *o)
575 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
576 if (ckWARN(WARN_SYNTAX)) {
577 const line_t oldline = CopLINE(PL_curcop);
579 if (PL_copline != NOLINE)
580 CopLINE_set(PL_curcop, PL_copline);
581 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
582 CopLINE_set(PL_curcop, oldline);
589 Perl_scalar(pTHX_ OP *o)
594 /* assumes no premature commitment */
595 if (!o || PL_error_count || (o->op_flags & OPf_WANT)
596 || o->op_type == OP_RETURN)
601 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
603 switch (o->op_type) {
605 scalar(cBINOPo->op_first);
610 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
614 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
615 if (!kPMOP->op_pmreplroot)
616 deprecate_old("implicit split to @_");
624 if (o->op_flags & OPf_KIDS) {
625 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
631 kid = cLISTOPo->op_first;
633 while ((kid = kid->op_sibling)) {
639 WITH_THR(PL_curcop = &PL_compiling);
644 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
650 WITH_THR(PL_curcop = &PL_compiling);
653 if (ckWARN(WARN_VOID))
654 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
660 Perl_scalarvoid(pTHX_ OP *o)
664 const char* useless = NULL;
668 /* trailing mad null ops don't count as "there" for void processing */
670 o->op_type != OP_NULL &&
672 o->op_sibling->op_type == OP_NULL)
675 for (sib = o->op_sibling;
676 sib && sib->op_type == OP_NULL;
677 sib = sib->op_sibling) ;
683 if (o->op_type == OP_NEXTSTATE
684 || o->op_type == OP_SETSTATE
685 || o->op_type == OP_DBSTATE
686 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
687 || o->op_targ == OP_SETSTATE
688 || o->op_targ == OP_DBSTATE)))
689 PL_curcop = (COP*)o; /* for warning below */
691 /* assumes no premature commitment */
692 want = o->op_flags & OPf_WANT;
693 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
694 || o->op_type == OP_RETURN)
699 if ((o->op_private & OPpTARGET_MY)
700 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
702 return scalar(o); /* As if inside SASSIGN */
705 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
707 switch (o->op_type) {
709 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
713 if (o->op_flags & OPf_STACKED)
717 if (o->op_private == 4)
789 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
790 useless = OP_DESC(o);
794 kid = cUNOPo->op_first;
795 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
796 kid->op_type != OP_TRANS) {
799 useless = "negative pattern binding (!~)";
806 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
807 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
808 useless = "a variable";
813 if (cSVOPo->op_private & OPpCONST_STRICT)
814 no_bareword_allowed(o);
816 if (ckWARN(WARN_VOID)) {
817 useless = "a constant";
818 if (o->op_private & OPpCONST_ARYBASE)
820 /* don't warn on optimised away booleans, eg
821 * use constant Foo, 5; Foo || print; */
822 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
824 /* the constants 0 and 1 are permitted as they are
825 conventionally used as dummies in constructs like
826 1 while some_condition_with_side_effects; */
827 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
829 else if (SvPOK(sv)) {
830 /* perl4's way of mixing documentation and code
831 (before the invention of POD) was based on a
832 trick to mix nroff and perl code. The trick was
833 built upon these three nroff macros being used in
834 void context. The pink camel has the details in
835 the script wrapman near page 319. */
836 const char * const maybe_macro = SvPVX_const(sv);
837 if (strnEQ(maybe_macro, "di", 2) ||
838 strnEQ(maybe_macro, "ds", 2) ||
839 strnEQ(maybe_macro, "ig", 2))
844 op_null(o); /* don't execute or even remember it */
848 o->op_type = OP_PREINC; /* pre-increment is faster */
849 o->op_ppaddr = PL_ppaddr[OP_PREINC];
853 o->op_type = OP_PREDEC; /* pre-decrement is faster */
854 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
858 o->op_type = OP_I_PREINC; /* pre-increment is faster */
859 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
863 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
864 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
873 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
878 if (o->op_flags & OPf_STACKED)
885 if (!(o->op_flags & OPf_KIDS))
896 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
903 /* all requires must return a boolean value */
904 o->op_flags &= ~OPf_WANT;
909 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
910 if (!kPMOP->op_pmreplroot)
911 deprecate_old("implicit split to @_");
915 if (useless && ckWARN(WARN_VOID))
916 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
921 Perl_listkids(pTHX_ OP *o)
923 if (o && o->op_flags & OPf_KIDS) {
925 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
932 Perl_list(pTHX_ OP *o)
937 /* assumes no premature commitment */
938 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
939 || o->op_type == OP_RETURN)
944 if ((o->op_private & OPpTARGET_MY)
945 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
947 return o; /* As if inside SASSIGN */
950 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
952 switch (o->op_type) {
955 list(cBINOPo->op_first);
960 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
968 if (!(o->op_flags & OPf_KIDS))
970 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
971 list(cBINOPo->op_first);
972 return gen_constant_list(o);
979 kid = cLISTOPo->op_first;
981 while ((kid = kid->op_sibling)) {
987 WITH_THR(PL_curcop = &PL_compiling);
991 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
997 WITH_THR(PL_curcop = &PL_compiling);
1000 /* all requires must return a boolean value */
1001 o->op_flags &= ~OPf_WANT;
1008 Perl_scalarseq(pTHX_ OP *o)
1012 if (o->op_type == OP_LINESEQ ||
1013 o->op_type == OP_SCOPE ||
1014 o->op_type == OP_LEAVE ||
1015 o->op_type == OP_LEAVETRY)
1018 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1019 if (kid->op_sibling) {
1023 PL_curcop = &PL_compiling;
1025 o->op_flags &= ~OPf_PARENS;
1026 if (PL_hints & HINT_BLOCK_SCOPE)
1027 o->op_flags |= OPf_PARENS;
1030 o = newOP(OP_STUB, 0);
1035 S_modkids(pTHX_ OP *o, I32 type)
1037 if (o && o->op_flags & OPf_KIDS) {
1039 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1045 /* Propagate lvalue ("modifiable") context to an op and its children.
1046 * 'type' represents the context type, roughly based on the type of op that
1047 * would do the modifying, although local() is represented by OP_NULL.
1048 * It's responsible for detecting things that can't be modified, flag
1049 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
1050 * might have to vivify a reference in $x), and so on.
1052 * For example, "$a+1 = 2" would cause mod() to be called with o being
1053 * OP_ADD and type being OP_SASSIGN, and would output an error.
1057 Perl_mod(pTHX_ OP *o, I32 type)
1061 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1064 if (!o || PL_error_count)
1067 if ((o->op_private & OPpTARGET_MY)
1068 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1073 switch (o->op_type) {
1079 if (!(o->op_private & OPpCONST_ARYBASE))
1082 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1083 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
1087 SAVEI32(PL_compiling.cop_arybase);
1088 PL_compiling.cop_arybase = 0;
1090 else if (type == OP_REFGEN)
1093 Perl_croak(aTHX_ "That use of $[ is unsupported");
1096 if (o->op_flags & OPf_PARENS || PL_madskills)
1100 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1101 !(o->op_flags & OPf_STACKED)) {
1102 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1103 /* The default is to set op_private to the number of children,
1104 which for a UNOP such as RV2CV is always 1. And w're using
1105 the bit for a flag in RV2CV, so we need it clear. */
1106 o->op_private &= ~1;
1107 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1108 assert(cUNOPo->op_first->op_type == OP_NULL);
1109 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1112 else if (o->op_private & OPpENTERSUB_NOMOD)
1114 else { /* lvalue subroutine call */
1115 o->op_private |= OPpLVAL_INTRO;
1116 PL_modcount = RETURN_UNLIMITED_NUMBER;
1117 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1118 /* Backward compatibility mode: */
1119 o->op_private |= OPpENTERSUB_INARGS;
1122 else { /* Compile-time error message: */
1123 OP *kid = cUNOPo->op_first;
1127 if (kid->op_type == OP_PUSHMARK)
1129 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1131 "panic: unexpected lvalue entersub "
1132 "args: type/targ %ld:%"UVuf,
1133 (long)kid->op_type, (UV)kid->op_targ);
1134 kid = kLISTOP->op_first;
1136 while (kid->op_sibling)
1137 kid = kid->op_sibling;
1138 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1140 if (kid->op_type == OP_METHOD_NAMED
1141 || kid->op_type == OP_METHOD)
1145 NewOp(1101, newop, 1, UNOP);
1146 newop->op_type = OP_RV2CV;
1147 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1148 newop->op_first = NULL;
1149 newop->op_next = (OP*)newop;
1150 kid->op_sibling = (OP*)newop;
1151 newop->op_private |= OPpLVAL_INTRO;
1152 newop->op_private &= ~1;
1156 if (kid->op_type != OP_RV2CV)
1158 "panic: unexpected lvalue entersub "
1159 "entry via type/targ %ld:%"UVuf,
1160 (long)kid->op_type, (UV)kid->op_targ);
1161 kid->op_private |= OPpLVAL_INTRO;
1162 break; /* Postpone until runtime */
1166 kid = kUNOP->op_first;
1167 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1168 kid = kUNOP->op_first;
1169 if (kid->op_type == OP_NULL)
1171 "Unexpected constant lvalue entersub "
1172 "entry via type/targ %ld:%"UVuf,
1173 (long)kid->op_type, (UV)kid->op_targ);
1174 if (kid->op_type != OP_GV) {
1175 /* Restore RV2CV to check lvalueness */
1177 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1178 okid->op_next = kid->op_next;
1179 kid->op_next = okid;
1182 okid->op_next = NULL;
1183 okid->op_type = OP_RV2CV;
1185 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1186 okid->op_private |= OPpLVAL_INTRO;
1187 okid->op_private &= ~1;
1191 cv = GvCV(kGVOP_gv);
1201 /* grep, foreach, subcalls, refgen */
1202 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1204 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1205 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1207 : (o->op_type == OP_ENTERSUB
1208 ? "non-lvalue subroutine call"
1210 type ? PL_op_desc[type] : "local"));
1224 case OP_RIGHT_SHIFT:
1233 if (!(o->op_flags & OPf_STACKED))
1240 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1246 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1247 PL_modcount = RETURN_UNLIMITED_NUMBER;
1248 return o; /* Treat \(@foo) like ordinary list. */
1252 if (scalar_mod_type(o, type))
1254 ref(cUNOPo->op_first, o->op_type);
1258 if (type == OP_LEAVESUBLV)
1259 o->op_private |= OPpMAYBE_LVSUB;
1265 PL_modcount = RETURN_UNLIMITED_NUMBER;
1268 ref(cUNOPo->op_first, o->op_type);
1273 PL_hints |= HINT_BLOCK_SCOPE;
1288 PL_modcount = RETURN_UNLIMITED_NUMBER;
1289 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1290 return o; /* Treat \(@foo) like ordinary list. */
1291 if (scalar_mod_type(o, type))
1293 if (type == OP_LEAVESUBLV)
1294 o->op_private |= OPpMAYBE_LVSUB;
1298 if (!type) /* local() */
1299 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1300 PAD_COMPNAME_PV(o->op_targ));
1308 if (type != OP_SASSIGN)
1312 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1317 if (type == OP_LEAVESUBLV)
1318 o->op_private |= OPpMAYBE_LVSUB;
1320 pad_free(o->op_targ);
1321 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1322 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1323 if (o->op_flags & OPf_KIDS)
1324 mod(cBINOPo->op_first->op_sibling, type);
1329 ref(cBINOPo->op_first, o->op_type);
1330 if (type == OP_ENTERSUB &&
1331 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1332 o->op_private |= OPpLVAL_DEFER;
1333 if (type == OP_LEAVESUBLV)
1334 o->op_private |= OPpMAYBE_LVSUB;
1344 if (o->op_flags & OPf_KIDS)
1345 mod(cLISTOPo->op_last, type);
1350 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1352 else if (!(o->op_flags & OPf_KIDS))
1354 if (o->op_targ != OP_LIST) {
1355 mod(cBINOPo->op_first, type);
1361 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1366 if (type != OP_LEAVESUBLV)
1368 break; /* mod()ing was handled by ck_return() */
1371 /* [20011101.069] File test operators interpret OPf_REF to mean that
1372 their argument is a filehandle; thus \stat(".") should not set
1374 if (type == OP_REFGEN &&
1375 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1378 if (type != OP_LEAVESUBLV)
1379 o->op_flags |= OPf_MOD;
1381 if (type == OP_AASSIGN || type == OP_SASSIGN)
1382 o->op_flags |= OPf_SPECIAL|OPf_REF;
1383 else if (!type) { /* local() */
1386 o->op_private |= OPpLVAL_INTRO;
1387 o->op_flags &= ~OPf_SPECIAL;
1388 PL_hints |= HINT_BLOCK_SCOPE;
1393 if (ckWARN(WARN_SYNTAX)) {
1394 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1395 "Useless localization of %s", OP_DESC(o));
1399 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1400 && type != OP_LEAVESUBLV)
1401 o->op_flags |= OPf_REF;
1406 S_scalar_mod_type(const OP *o, I32 type)
1410 if (o->op_type == OP_RV2GV)
1434 case OP_RIGHT_SHIFT:
1453 S_is_handle_constructor(const OP *o, I32 numargs)
1455 switch (o->op_type) {
1463 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1476 Perl_refkids(pTHX_ OP *o, I32 type)
1478 if (o && o->op_flags & OPf_KIDS) {
1480 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1487 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
1492 if (!o || PL_error_count)
1495 switch (o->op_type) {
1497 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1498 !(o->op_flags & OPf_STACKED)) {
1499 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1500 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1501 assert(cUNOPo->op_first->op_type == OP_NULL);
1502 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1503 o->op_flags |= OPf_SPECIAL;
1504 o->op_private &= ~1;
1509 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1510 doref(kid, type, set_op_ref);
1513 if (type == OP_DEFINED)
1514 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1515 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1518 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1519 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1520 : type == OP_RV2HV ? OPpDEREF_HV
1522 o->op_flags |= OPf_MOD;
1527 o->op_flags |= OPf_MOD; /* XXX ??? */
1533 o->op_flags |= OPf_REF;
1536 if (type == OP_DEFINED)
1537 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1538 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1544 o->op_flags |= OPf_REF;
1549 if (!(o->op_flags & OPf_KIDS))
1551 doref(cBINOPo->op_first, type, set_op_ref);
1555 doref(cBINOPo->op_first, o->op_type, set_op_ref);
1556 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1557 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1558 : type == OP_RV2HV ? OPpDEREF_HV
1560 o->op_flags |= OPf_MOD;
1570 if (!(o->op_flags & OPf_KIDS))
1572 doref(cLISTOPo->op_last, type, set_op_ref);
1582 S_dup_attrlist(pTHX_ OP *o)
1587 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1588 * where the first kid is OP_PUSHMARK and the remaining ones
1589 * are OP_CONST. We need to push the OP_CONST values.
1591 if (o->op_type == OP_CONST)
1592 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
1594 else if (o->op_type == OP_NULL)
1598 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1600 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1601 if (o->op_type == OP_CONST)
1602 rop = append_elem(OP_LIST, rop,
1603 newSVOP(OP_CONST, o->op_flags,
1604 SvREFCNT_inc_NN(cSVOPo->op_sv)));
1611 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1616 /* fake up C<use attributes $pkg,$rv,@attrs> */
1617 ENTER; /* need to protect against side-effects of 'use' */
1619 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1621 #define ATTRSMODULE "attributes"
1622 #define ATTRSMODULE_PM "attributes.pm"
1625 /* Don't force the C<use> if we don't need it. */
1626 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
1627 if (svp && *svp != &PL_sv_undef)
1628 /*EMPTY*/; /* already in %INC */
1630 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1631 newSVpvs(ATTRSMODULE), NULL);
1634 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1635 newSVpvs(ATTRSMODULE),
1637 prepend_elem(OP_LIST,
1638 newSVOP(OP_CONST, 0, stashsv),
1639 prepend_elem(OP_LIST,
1640 newSVOP(OP_CONST, 0,
1642 dup_attrlist(attrs))));
1648 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1651 OP *pack, *imop, *arg;
1657 assert(target->op_type == OP_PADSV ||
1658 target->op_type == OP_PADHV ||
1659 target->op_type == OP_PADAV);
1661 /* Ensure that attributes.pm is loaded. */
1662 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1664 /* Need package name for method call. */
1665 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
1667 /* Build up the real arg-list. */
1668 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1670 arg = newOP(OP_PADSV, 0);
1671 arg->op_targ = target->op_targ;
1672 arg = prepend_elem(OP_LIST,
1673 newSVOP(OP_CONST, 0, stashsv),
1674 prepend_elem(OP_LIST,
1675 newUNOP(OP_REFGEN, 0,
1676 mod(arg, OP_REFGEN)),
1677 dup_attrlist(attrs)));
1679 /* Fake up a method call to import */
1680 meth = newSVpvs_share("import");
1681 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1682 append_elem(OP_LIST,
1683 prepend_elem(OP_LIST, pack, list(arg)),
1684 newSVOP(OP_METHOD_NAMED, 0, meth)));
1685 imop->op_private |= OPpENTERSUB_NOMOD;
1687 /* Combine the ops. */
1688 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1692 =notfor apidoc apply_attrs_string
1694 Attempts to apply a list of attributes specified by the C<attrstr> and
1695 C<len> arguments to the subroutine identified by the C<cv> argument which
1696 is expected to be associated with the package identified by the C<stashpv>
1697 argument (see L<attributes>). It gets this wrong, though, in that it
1698 does not correctly identify the boundaries of the individual attribute
1699 specifications within C<attrstr>. This is not really intended for the
1700 public API, but has to be listed here for systems such as AIX which
1701 need an explicit export list for symbols. (It's called from XS code
1702 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1703 to respect attribute syntax properly would be welcome.
1709 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
1710 const char *attrstr, STRLEN len)
1715 len = strlen(attrstr);
1719 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1721 const char * const sstr = attrstr;
1722 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1723 attrs = append_elem(OP_LIST, attrs,
1724 newSVOP(OP_CONST, 0,
1725 newSVpvn(sstr, attrstr-sstr)));
1729 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1730 newSVpvs(ATTRSMODULE),
1731 NULL, prepend_elem(OP_LIST,
1732 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1733 prepend_elem(OP_LIST,
1734 newSVOP(OP_CONST, 0,
1740 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
1745 if (!o || PL_error_count)
1750 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
1751 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
1755 if (type == OP_LIST) {
1757 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1758 my_kid(kid, attrs, imopsp);
1759 } else if (type == OP_UNDEF
1765 } else if (type == OP_RV2SV || /* "our" declaration */
1767 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1768 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1769 yyerror(Perl_form(aTHX_ "Can't declare %s in %s",
1770 OP_DESC(o), PL_in_my == KEY_our ? "our" : "my"));
1772 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
1774 PL_in_my_stash = NULL;
1775 apply_attrs(GvSTASH(gv),
1776 (type == OP_RV2SV ? GvSV(gv) :
1777 type == OP_RV2AV ? (SV*)GvAV(gv) :
1778 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1781 o->op_private |= OPpOUR_INTRO;
1784 else if (type != OP_PADSV &&
1787 type != OP_PUSHMARK)
1789 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1791 PL_in_my == KEY_our ? "our" : "my"));
1794 else if (attrs && type != OP_PUSHMARK) {
1798 PL_in_my_stash = NULL;
1800 /* check for C<my Dog $spot> when deciding package */
1801 stash = PAD_COMPNAME_TYPE(o->op_targ);
1803 stash = PL_curstash;
1804 apply_attrs_my(stash, o, attrs, imopsp);
1806 o->op_flags |= OPf_MOD;
1807 o->op_private |= OPpLVAL_INTRO;
1812 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1816 int maybe_scalar = 0;
1818 /* [perl #17376]: this appears to be premature, and results in code such as
1819 C< our(%x); > executing in list mode rather than void mode */
1821 if (o->op_flags & OPf_PARENS)
1831 o = my_kid(o, attrs, &rops);
1833 if (maybe_scalar && o->op_type == OP_PADSV) {
1834 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
1835 o->op_private |= OPpLVAL_INTRO;
1838 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
1841 PL_in_my_stash = NULL;
1846 Perl_my(pTHX_ OP *o)
1848 return my_attrs(o, NULL);
1852 Perl_sawparens(pTHX_ OP *o)
1854 PERL_UNUSED_CONTEXT;
1856 o->op_flags |= OPf_PARENS;
1861 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
1866 if ( (left->op_type == OP_RV2AV ||
1867 left->op_type == OP_RV2HV ||
1868 left->op_type == OP_PADAV ||
1869 left->op_type == OP_PADHV)
1870 && ckWARN(WARN_MISC))
1872 const char * const desc = PL_op_desc[(right->op_type == OP_SUBST ||
1873 right->op_type == OP_TRANS)
1874 ? right->op_type : OP_MATCH];
1875 const char * const sample = ((left->op_type == OP_RV2AV ||
1876 left->op_type == OP_PADAV)
1877 ? "@array" : "%hash");
1878 Perl_warner(aTHX_ packWARN(WARN_MISC),
1879 "Applying %s to %s will act on scalar(%s)",
1880 desc, sample, sample);
1883 if (right->op_type == OP_CONST &&
1884 cSVOPx(right)->op_private & OPpCONST_BARE &&
1885 cSVOPx(right)->op_private & OPpCONST_STRICT)
1887 no_bareword_allowed(right);
1890 ismatchop = right->op_type == OP_MATCH ||
1891 right->op_type == OP_SUBST ||
1892 right->op_type == OP_TRANS;
1893 if (ismatchop && right->op_private & OPpTARGET_MY) {
1895 right->op_private &= ~OPpTARGET_MY;
1897 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
1898 right->op_flags |= OPf_STACKED;
1899 if (right->op_type != OP_MATCH &&
1900 ! (right->op_type == OP_TRANS &&
1901 right->op_private & OPpTRANS_IDENTICAL))
1902 left = mod(left, right->op_type);
1903 if (right->op_type == OP_TRANS)
1904 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
1906 o = prepend_elem(right->op_type, scalar(left), right);
1908 return newUNOP(OP_NOT, 0, scalar(o));
1912 return bind_match(type, left,
1913 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
1917 Perl_invert(pTHX_ OP *o)
1921 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
1925 Perl_scope(pTHX_ OP *o)
1929 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
1930 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
1931 o->op_type = OP_LEAVE;
1932 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
1934 else if (o->op_type == OP_LINESEQ) {
1936 o->op_type = OP_SCOPE;
1937 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
1938 kid = ((LISTOP*)o)->op_first;
1939 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
1942 /* The following deals with things like 'do {1 for 1}' */
1943 kid = kid->op_sibling;
1945 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
1950 o = newLISTOP(OP_SCOPE, 0, o, NULL);
1956 Perl_block_start(pTHX_ int full)
1959 const int retval = PL_savestack_ix;
1960 pad_block_start(full);
1962 PL_hints &= ~HINT_BLOCK_SCOPE;
1963 SAVESPTR(PL_compiling.cop_warnings);
1964 if (! specialWARN(PL_compiling.cop_warnings)) {
1965 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
1966 SAVEFREESV(PL_compiling.cop_warnings) ;
1968 SAVESPTR(PL_compiling.cop_io);
1969 if (! specialCopIO(PL_compiling.cop_io)) {
1970 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
1971 SAVEFREESV(PL_compiling.cop_io) ;
1977 Perl_block_end(pTHX_ I32 floor, OP *seq)
1980 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
1981 OP* const retval = scalarseq(seq);
1983 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
1985 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
1994 const I32 offset = pad_findmy("$_");
1995 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
1996 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
1999 OP * const o = newOP(OP_PADSV, 0);
2000 o->op_targ = offset;
2006 Perl_newPROG(pTHX_ OP *o)
2012 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2013 ((PL_in_eval & EVAL_KEEPERR)
2014 ? OPf_SPECIAL : 0), o);
2015 PL_eval_start = linklist(PL_eval_root);
2016 PL_eval_root->op_private |= OPpREFCOUNTED;
2017 OpREFCNT_set(PL_eval_root, 1);
2018 PL_eval_root->op_next = 0;
2019 CALL_PEEP(PL_eval_start);
2022 if (o->op_type == OP_STUB) {
2023 PL_comppad_name = 0;
2028 PL_main_root = scope(sawparens(scalarvoid(o)));
2029 PL_curcop = &PL_compiling;
2030 PL_main_start = LINKLIST(PL_main_root);
2031 PL_main_root->op_private |= OPpREFCOUNTED;
2032 OpREFCNT_set(PL_main_root, 1);
2033 PL_main_root->op_next = 0;
2034 CALL_PEEP(PL_main_start);
2037 /* Register with debugger */
2039 CV * const cv = get_cv("DB::postponed", FALSE);
2043 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2045 call_sv((SV*)cv, G_DISCARD);
2052 Perl_localize(pTHX_ OP *o, I32 lex)
2055 if (o->op_flags & OPf_PARENS)
2056 /* [perl #17376]: this appears to be premature, and results in code such as
2057 C< our(%x); > executing in list mode rather than void mode */
2064 if ( PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ','
2065 && ckWARN(WARN_PARENTHESIS))
2067 char *s = PL_bufptr;
2070 /* some heuristics to detect a potential error */
2071 while (*s && (strchr(", \t\n", *s)))
2075 if (*s && strchr("@$%*", *s) && *++s
2076 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2079 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2081 while (*s && (strchr(", \t\n", *s)))
2087 if (sigil && (*s == ';' || *s == '=')) {
2088 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2089 "Parentheses missing around \"%s\" list",
2090 lex ? (PL_in_my == KEY_our ? "our" : "my")
2098 o = mod(o, OP_NULL); /* a bit kludgey */
2100 PL_in_my_stash = NULL;
2105 Perl_jmaybe(pTHX_ OP *o)
2107 if (o->op_type == OP_LIST) {
2109 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL,
2111 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2117 Perl_fold_constants(pTHX_ register OP *o)
2122 I32 type = o->op_type;
2129 if (PL_opargs[type] & OA_RETSCALAR)
2131 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2132 o->op_targ = pad_alloc(type, SVs_PADTMP);
2134 /* integerize op, unless it happens to be C<-foo>.
2135 * XXX should pp_i_negate() do magic string negation instead? */
2136 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2137 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2138 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2140 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2143 if (!(PL_opargs[type] & OA_FOLDCONST))
2148 /* XXX might want a ck_negate() for this */
2149 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2160 /* XXX what about the numeric ops? */
2161 if (PL_hints & HINT_LOCALE)
2166 goto nope; /* Don't try to run w/ errors */
2168 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2169 if ((curop->op_type != OP_CONST ||
2170 (curop->op_private & OPpCONST_BARE)) &&
2171 curop->op_type != OP_LIST &&
2172 curop->op_type != OP_SCALAR &&
2173 curop->op_type != OP_NULL &&
2174 curop->op_type != OP_PUSHMARK)
2180 curop = LINKLIST(o);
2181 old_next = o->op_next;
2185 oldscope = PL_scopestack_ix;
2186 create_eval_scope(G_FAKINGEVAL);
2193 sv = *(PL_stack_sp--);
2194 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2195 pad_swipe(o->op_targ, FALSE);
2196 else if (SvTEMP(sv)) { /* grab mortal temp? */
2197 SvREFCNT_inc_simple_void(sv);
2202 /* Something tried to die. Abandon constant folding. */
2203 /* Pretend the error never happened. */
2204 sv_setpvn(ERRSV,"",0);
2205 o->op_next = old_next;
2209 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
2210 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
2215 if (PL_scopestack_ix > oldscope)
2216 delete_eval_scope();
2224 if (type == OP_RV2GV)
2225 newop = newGVOP(OP_GV, 0, (GV*)sv);
2227 newop = newSVOP(OP_CONST, 0, sv);
2228 op_getmad(o,newop,'f');
2236 Perl_gen_constant_list(pTHX_ register OP *o)
2240 const I32 oldtmps_floor = PL_tmps_floor;
2244 return o; /* Don't attempt to run with errors */
2246 PL_op = curop = LINKLIST(o);
2253 PL_tmps_floor = oldtmps_floor;
2255 o->op_type = OP_RV2AV;
2256 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2257 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2258 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2259 o->op_opt = 0; /* needs to be revisited in peep() */
2260 curop = ((UNOP*)o)->op_first;
2261 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
2263 op_getmad(curop,o,'O');
2272 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2275 if (!o || o->op_type != OP_LIST)
2276 o = newLISTOP(OP_LIST, 0, o, NULL);
2278 o->op_flags &= ~OPf_WANT;
2280 if (!(PL_opargs[type] & OA_MARK))
2281 op_null(cLISTOPo->op_first);
2283 o->op_type = (OPCODE)type;
2284 o->op_ppaddr = PL_ppaddr[type];
2285 o->op_flags |= flags;
2287 o = CHECKOP(type, o);
2288 if (o->op_type != (unsigned)type)
2291 return fold_constants(o);
2294 /* List constructors */
2297 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2305 if (first->op_type != (unsigned)type
2306 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2308 return newLISTOP(type, 0, first, last);
2311 if (first->op_flags & OPf_KIDS)
2312 ((LISTOP*)first)->op_last->op_sibling = last;
2314 first->op_flags |= OPf_KIDS;
2315 ((LISTOP*)first)->op_first = last;
2317 ((LISTOP*)first)->op_last = last;
2322 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2330 if (first->op_type != (unsigned)type)
2331 return prepend_elem(type, (OP*)first, (OP*)last);
2333 if (last->op_type != (unsigned)type)
2334 return append_elem(type, (OP*)first, (OP*)last);
2336 first->op_last->op_sibling = last->op_first;
2337 first->op_last = last->op_last;
2338 first->op_flags |= (last->op_flags & OPf_KIDS);
2341 if (last->op_first && first->op_madprop) {
2342 MADPROP *mp = last->op_first->op_madprop;
2344 while (mp->mad_next)
2346 mp->mad_next = first->op_madprop;
2349 last->op_first->op_madprop = first->op_madprop;
2352 first->op_madprop = last->op_madprop;
2353 last->op_madprop = 0;
2362 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2370 if (last->op_type == (unsigned)type) {
2371 if (type == OP_LIST) { /* already a PUSHMARK there */
2372 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2373 ((LISTOP*)last)->op_first->op_sibling = first;
2374 if (!(first->op_flags & OPf_PARENS))
2375 last->op_flags &= ~OPf_PARENS;
2378 if (!(last->op_flags & OPf_KIDS)) {
2379 ((LISTOP*)last)->op_last = first;
2380 last->op_flags |= OPf_KIDS;
2382 first->op_sibling = ((LISTOP*)last)->op_first;
2383 ((LISTOP*)last)->op_first = first;
2385 last->op_flags |= OPf_KIDS;
2389 return newLISTOP(type, 0, first, last);
2397 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2400 Newxz(tk, 1, TOKEN);
2401 tk->tk_type = (OPCODE)optype;
2402 tk->tk_type = 12345;
2404 tk->tk_mad = madprop;
2409 Perl_token_free(pTHX_ TOKEN* tk)
2411 if (tk->tk_type != 12345)
2413 mad_free(tk->tk_mad);
2418 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2422 if (tk->tk_type != 12345) {
2423 Perl_warner(aTHX_ packWARN(WARN_MISC),
2424 "Invalid TOKEN object ignored");
2431 /* faked up qw list? */
2433 tm->mad_type == MAD_SV &&
2434 SvPVX((SV*)tm->mad_val)[0] == 'q')
2441 /* pretend constant fold didn't happen? */
2442 if (mp->mad_key == 'f' &&
2443 (o->op_type == OP_CONST ||
2444 o->op_type == OP_GV) )
2446 token_getmad(tk,(OP*)mp->mad_val,slot);
2460 if (mp->mad_key == 'X')
2461 mp->mad_key = slot; /* just change the first one */
2471 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
2480 /* pretend constant fold didn't happen? */
2481 if (mp->mad_key == 'f' &&
2482 (o->op_type == OP_CONST ||
2483 o->op_type == OP_GV) )
2485 op_getmad(from,(OP*)mp->mad_val,slot);
2492 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
2495 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
2501 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
2510 /* pretend constant fold didn't happen? */
2511 if (mp->mad_key == 'f' &&
2512 (o->op_type == OP_CONST ||
2513 o->op_type == OP_GV) )
2515 op_getmad(from,(OP*)mp->mad_val,slot);
2522 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
2525 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
2529 PerlIO_printf(PerlIO_stderr(),
2530 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
2536 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
2554 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
2558 addmad(tm, &(o->op_madprop), slot);
2562 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
2583 Perl_newMADsv(pTHX_ char key, SV* sv)
2585 return newMADPROP(key, MAD_SV, sv, 0);
2589 Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
2592 Newxz(mp, 1, MADPROP);
2595 mp->mad_vlen = vlen;
2596 mp->mad_type = type;
2598 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
2603 Perl_mad_free(pTHX_ MADPROP* mp)
2605 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
2609 mad_free(mp->mad_next);
2610 /* if (PL_lex_state != LEX_NOTPARSING && mp->mad_vlen)
2611 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
2612 switch (mp->mad_type) {
2616 Safefree((char*)mp->mad_val);
2619 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
2620 op_free((OP*)mp->mad_val);
2623 sv_free((SV*)mp->mad_val);
2626 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
2635 Perl_newNULLLIST(pTHX)
2637 return newOP(OP_STUB, 0);
2641 Perl_force_list(pTHX_ OP *o)
2643 if (!o || o->op_type != OP_LIST)
2644 o = newLISTOP(OP_LIST, 0, o, NULL);
2650 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2655 NewOp(1101, listop, 1, LISTOP);
2657 listop->op_type = (OPCODE)type;
2658 listop->op_ppaddr = PL_ppaddr[type];
2661 listop->op_flags = (U8)flags;
2665 else if (!first && last)
2668 first->op_sibling = last;
2669 listop->op_first = first;
2670 listop->op_last = last;
2671 if (type == OP_LIST) {
2672 OP* const pushop = newOP(OP_PUSHMARK, 0);
2673 pushop->op_sibling = first;
2674 listop->op_first = pushop;
2675 listop->op_flags |= OPf_KIDS;
2677 listop->op_last = pushop;
2680 return CHECKOP(type, listop);
2684 Perl_newOP(pTHX_ I32 type, I32 flags)
2688 NewOp(1101, o, 1, OP);
2689 o->op_type = (OPCODE)type;
2690 o->op_ppaddr = PL_ppaddr[type];
2691 o->op_flags = (U8)flags;
2694 o->op_private = (U8)(0 | (flags >> 8));
2695 if (PL_opargs[type] & OA_RETSCALAR)
2697 if (PL_opargs[type] & OA_TARGET)
2698 o->op_targ = pad_alloc(type, SVs_PADTMP);
2699 return CHECKOP(type, o);
2703 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2709 first = newOP(OP_STUB, 0);
2710 if (PL_opargs[type] & OA_MARK)
2711 first = force_list(first);
2713 NewOp(1101, unop, 1, UNOP);
2714 unop->op_type = (OPCODE)type;
2715 unop->op_ppaddr = PL_ppaddr[type];
2716 unop->op_first = first;
2717 unop->op_flags = (U8)(flags | OPf_KIDS);
2718 unop->op_private = (U8)(1 | (flags >> 8));
2719 unop = (UNOP*) CHECKOP(type, unop);
2723 return fold_constants((OP *) unop);
2727 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2731 NewOp(1101, binop, 1, BINOP);
2734 first = newOP(OP_NULL, 0);
2736 binop->op_type = (OPCODE)type;
2737 binop->op_ppaddr = PL_ppaddr[type];
2738 binop->op_first = first;
2739 binop->op_flags = (U8)(flags | OPf_KIDS);
2742 binop->op_private = (U8)(1 | (flags >> 8));
2745 binop->op_private = (U8)(2 | (flags >> 8));
2746 first->op_sibling = last;
2749 binop = (BINOP*)CHECKOP(type, binop);
2750 if (binop->op_next || binop->op_type != (OPCODE)type)
2753 binop->op_last = binop->op_first->op_sibling;
2755 return fold_constants((OP *)binop);
2758 static int uvcompare(const void *a, const void *b)
2759 __attribute__nonnull__(1)
2760 __attribute__nonnull__(2)
2761 __attribute__pure__;
2762 static int uvcompare(const void *a, const void *b)
2764 if (*((const UV *)a) < (*(const UV *)b))
2766 if (*((const UV *)a) > (*(const UV *)b))
2768 if (*((const UV *)a+1) < (*(const UV *)b+1))
2770 if (*((const UV *)a+1) > (*(const UV *)b+1))
2776 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2779 SV * const tstr = ((SVOP*)expr)->op_sv;
2780 SV * const rstr = ((SVOP*)repl)->op_sv;
2783 const U8 *t = (U8*)SvPV_const(tstr, tlen);
2784 const U8 *r = (U8*)SvPV_const(rstr, rlen);
2788 register short *tbl;
2790 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
2791 const I32 squash = o->op_private & OPpTRANS_SQUASH;
2792 I32 del = o->op_private & OPpTRANS_DELETE;
2793 PL_hints |= HINT_BLOCK_SCOPE;
2796 o->op_private |= OPpTRANS_FROM_UTF;
2799 o->op_private |= OPpTRANS_TO_UTF;
2801 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2802 SV* const listsv = newSVpvs("# comment\n");
2804 const U8* tend = t + tlen;
2805 const U8* rend = r + rlen;
2819 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2820 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2826 t = tsave = bytes_to_utf8(t, &len);
2829 if (!to_utf && rlen) {
2831 r = rsave = bytes_to_utf8(r, &len);
2835 /* There are several snags with this code on EBCDIC:
2836 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2837 2. scan_const() in toke.c has encoded chars in native encoding which makes
2838 ranges at least in EBCDIC 0..255 range the bottom odd.
2842 U8 tmpbuf[UTF8_MAXBYTES+1];
2845 Newx(cp, 2*tlen, UV);
2847 transv = newSVpvs("");
2849 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2851 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2853 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2857 cp[2*i+1] = cp[2*i];
2861 qsort(cp, i, 2*sizeof(UV), uvcompare);
2862 for (j = 0; j < i; j++) {
2864 diff = val - nextmin;
2866 t = uvuni_to_utf8(tmpbuf,nextmin);
2867 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2869 U8 range_mark = UTF_TO_NATIVE(0xff);
2870 t = uvuni_to_utf8(tmpbuf, val - 1);
2871 sv_catpvn(transv, (char *)&range_mark, 1);
2872 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2879 t = uvuni_to_utf8(tmpbuf,nextmin);
2880 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2882 U8 range_mark = UTF_TO_NATIVE(0xff);
2883 sv_catpvn(transv, (char *)&range_mark, 1);
2885 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2886 UNICODE_ALLOW_SUPER);
2887 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2888 t = (const U8*)SvPVX_const(transv);
2889 tlen = SvCUR(transv);
2893 else if (!rlen && !del) {
2894 r = t; rlen = tlen; rend = tend;
2897 if ((!rlen && !del) || t == r ||
2898 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2900 o->op_private |= OPpTRANS_IDENTICAL;
2904 while (t < tend || tfirst <= tlast) {
2905 /* see if we need more "t" chars */
2906 if (tfirst > tlast) {
2907 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2909 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2911 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2918 /* now see if we need more "r" chars */
2919 if (rfirst > rlast) {
2921 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2923 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2925 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2934 rfirst = rlast = 0xffffffff;
2938 /* now see which range will peter our first, if either. */
2939 tdiff = tlast - tfirst;
2940 rdiff = rlast - rfirst;
2947 if (rfirst == 0xffffffff) {
2948 diff = tdiff; /* oops, pretend rdiff is infinite */
2950 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2951 (long)tfirst, (long)tlast);
2953 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2957 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2958 (long)tfirst, (long)(tfirst + diff),
2961 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2962 (long)tfirst, (long)rfirst);
2964 if (rfirst + diff > max)
2965 max = rfirst + diff;
2967 grows = (tfirst < rfirst &&
2968 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2980 else if (max > 0xff)
2985 Safefree(cPVOPo->op_pv);
2986 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2987 SvREFCNT_dec(listsv);
2988 SvREFCNT_dec(transv);
2990 if (!del && havefinal && rlen)
2991 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2992 newSVuv((UV)final), 0);
2995 o->op_private |= OPpTRANS_GROWS;
3001 op_getmad(expr,o,'e');
3002 op_getmad(repl,o,'r');
3010 tbl = (short*)cPVOPo->op_pv;
3012 Zero(tbl, 256, short);
3013 for (i = 0; i < (I32)tlen; i++)
3015 for (i = 0, j = 0; i < 256; i++) {
3017 if (j >= (I32)rlen) {
3026 if (i < 128 && r[j] >= 128)
3036 o->op_private |= OPpTRANS_IDENTICAL;
3038 else if (j >= (I32)rlen)
3041 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
3042 tbl[0x100] = (short)(rlen - j);
3043 for (i=0; i < (I32)rlen - j; i++)
3044 tbl[0x101+i] = r[j+i];
3048 if (!rlen && !del) {
3051 o->op_private |= OPpTRANS_IDENTICAL;
3053 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3054 o->op_private |= OPpTRANS_IDENTICAL;
3056 for (i = 0; i < 256; i++)
3058 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3059 if (j >= (I32)rlen) {
3061 if (tbl[t[i]] == -1)
3067 if (tbl[t[i]] == -1) {
3068 if (t[i] < 128 && r[j] >= 128)
3075 o->op_private |= OPpTRANS_GROWS;
3077 op_getmad(expr,o,'e');
3078 op_getmad(repl,o,'r');
3088 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3093 NewOp(1101, pmop, 1, PMOP);
3094 pmop->op_type = (OPCODE)type;
3095 pmop->op_ppaddr = PL_ppaddr[type];
3096 pmop->op_flags = (U8)flags;
3097 pmop->op_private = (U8)(0 | (flags >> 8));
3099 if (PL_hints & HINT_RE_TAINT)
3100 pmop->op_pmpermflags |= PMf_RETAINT;
3101 if (PL_hints & HINT_LOCALE)
3102 pmop->op_pmpermflags |= PMf_LOCALE;
3103 pmop->op_pmflags = pmop->op_pmpermflags;
3106 if (av_len((AV*) PL_regex_pad[0]) > -1) {
3107 SV * const repointer = av_pop((AV*)PL_regex_pad[0]);
3108 pmop->op_pmoffset = SvIV(repointer);
3109 SvREPADTMP_off(repointer);
3110 sv_setiv(repointer,0);
3112 SV * const repointer = newSViv(0);
3113 av_push(PL_regex_padav, SvREFCNT_inc_simple_NN(repointer));
3114 pmop->op_pmoffset = av_len(PL_regex_padav);
3115 PL_regex_pad = AvARRAY(PL_regex_padav);
3119 /* link into pm list */
3120 if (type != OP_TRANS && PL_curstash) {
3121 MAGIC *mg = mg_find((SV*)PL_curstash, PERL_MAGIC_symtab);
3124 mg = sv_magicext((SV*)PL_curstash, 0, PERL_MAGIC_symtab, 0, 0, 0);
3126 pmop->op_pmnext = (PMOP*)mg->mg_obj;
3127 mg->mg_obj = (SV*)pmop;
3128 PmopSTASH_set(pmop,PL_curstash);
3131 return CHECKOP(type, pmop);
3134 /* Given some sort of match op o, and an expression expr containing a
3135 * pattern, either compile expr into a regex and attach it to o (if it's
3136 * constant), or convert expr into a runtime regcomp op sequence (if it's
3139 * isreg indicates that the pattern is part of a regex construct, eg
3140 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3141 * split "pattern", which aren't. In the former case, expr will be a list
3142 * if the pattern contains more than one term (eg /a$b/) or if it contains
3143 * a replacement, ie s/// or tr///.
3147 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
3152 I32 repl_has_vars = 0;
3156 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
3157 /* last element in list is the replacement; pop it */
3159 repl = cLISTOPx(expr)->op_last;
3160 kid = cLISTOPx(expr)->op_first;
3161 while (kid->op_sibling != repl)
3162 kid = kid->op_sibling;
3163 kid->op_sibling = NULL;
3164 cLISTOPx(expr)->op_last = kid;
3167 if (isreg && expr->op_type == OP_LIST &&
3168 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3170 /* convert single element list to element */
3171 OP* const oe = expr;
3172 expr = cLISTOPx(oe)->op_first->op_sibling;
3173 cLISTOPx(oe)->op_first->op_sibling = NULL;
3174 cLISTOPx(oe)->op_last = NULL;
3178 if (o->op_type == OP_TRANS) {
3179 return pmtrans(o, expr, repl);
3182 reglist = isreg && expr->op_type == OP_LIST;
3186 PL_hints |= HINT_BLOCK_SCOPE;
3189 if (expr->op_type == OP_CONST) {
3191 SV * const pat = ((SVOP*)expr)->op_sv;
3192 const char *p = SvPV_const(pat, plen);
3193 if ((o->op_flags & OPf_SPECIAL) && (*p == ' ' && p[1] == '\0')) {
3194 U32 was_readonly = SvREADONLY(pat);
3198 sv_force_normal_flags(pat, 0);
3199 assert(!SvREADONLY(pat));
3202 SvREADONLY_off(pat);
3206 sv_setpvn(pat, "\\s+", 3);
3208 SvFLAGS(pat) |= was_readonly;
3210 p = SvPV_const(pat, plen);
3211 pm->op_pmflags |= PMf_SKIPWHITE;
3214 pm->op_pmdynflags |= PMdf_UTF8;
3215 /* FIXME - can we make this function take const char * args? */
3216 PM_SETRE(pm, CALLREGCOMP(aTHX_ (char*)p, (char*)p + plen, pm));
3217 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
3218 pm->op_pmflags |= PMf_WHITE;
3220 op_getmad(expr,(OP*)pm,'e');
3226 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3227 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3229 : OP_REGCMAYBE),0,expr);
3231 NewOp(1101, rcop, 1, LOGOP);
3232 rcop->op_type = OP_REGCOMP;
3233 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3234 rcop->op_first = scalar(expr);
3235 rcop->op_flags |= OPf_KIDS
3236 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3237 | (reglist ? OPf_STACKED : 0);
3238 rcop->op_private = 1;
3241 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3243 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
3246 /* establish postfix order */
3247 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3249 rcop->op_next = expr;
3250 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3253 rcop->op_next = LINKLIST(expr);
3254 expr->op_next = (OP*)rcop;
3257 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3262 if (pm->op_pmflags & PMf_EVAL) {
3264 if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
3265 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
3267 else if (repl->op_type == OP_CONST)
3271 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3272 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3273 if (curop->op_type == OP_GV) {
3274 GV * const gv = cGVOPx_gv(curop);
3276 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3279 else if (curop->op_type == OP_RV2CV)
3281 else if (curop->op_type == OP_RV2SV ||
3282 curop->op_type == OP_RV2AV ||
3283 curop->op_type == OP_RV2HV ||
3284 curop->op_type == OP_RV2GV) {
3285 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3288 else if (curop->op_type == OP_PADSV ||
3289 curop->op_type == OP_PADAV ||
3290 curop->op_type == OP_PADHV ||
3291 curop->op_type == OP_PADANY) {
3294 else if (curop->op_type == OP_PUSHRE)
3295 /*EMPTY*/; /* Okay here, dangerous in newASSIGNOP */
3305 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
3306 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3307 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
3308 prepend_elem(o->op_type, scalar(repl), o);
3311 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3312 pm->op_pmflags |= PMf_MAYBE_CONST;
3313 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3315 NewOp(1101, rcop, 1, LOGOP);
3316 rcop->op_type = OP_SUBSTCONT;
3317 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3318 rcop->op_first = scalar(repl);
3319 rcop->op_flags |= OPf_KIDS;
3320 rcop->op_private = 1;
3323 /* establish postfix order */
3324 rcop->op_next = LINKLIST(repl);
3325 repl->op_next = (OP*)rcop;
3327 pm->op_pmreplroot = scalar((OP*)rcop);
3328 pm->op_pmreplstart = LINKLIST(rcop);
3337 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3341 NewOp(1101, svop, 1, SVOP);
3342 svop->op_type = (OPCODE)type;
3343 svop->op_ppaddr = PL_ppaddr[type];
3345 svop->op_next = (OP*)svop;
3346 svop->op_flags = (U8)flags;
3347 if (PL_opargs[type] & OA_RETSCALAR)
3349 if (PL_opargs[type] & OA_TARGET)
3350 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3351 return CHECKOP(type, svop);
3355 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3359 NewOp(1101, padop, 1, PADOP);
3360 padop->op_type = (OPCODE)type;
3361 padop->op_ppaddr = PL_ppaddr[type];
3362 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3363 SvREFCNT_dec(PAD_SVl(padop->op_padix));
3364 PAD_SETSV(padop->op_padix, sv);
3367 padop->op_next = (OP*)padop;
3368 padop->op_flags = (U8)flags;
3369 if (PL_opargs[type] & OA_RETSCALAR)
3371 if (PL_opargs[type] & OA_TARGET)
3372 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3373 return CHECKOP(type, padop);
3377 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3383 return newPADOP(type, flags, SvREFCNT_inc_simple(gv));
3385 return newSVOP(type, flags, SvREFCNT_inc_simple(gv));
3390 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3394 NewOp(1101, pvop, 1, PVOP);
3395 pvop->op_type = (OPCODE)type;
3396 pvop->op_ppaddr = PL_ppaddr[type];
3398 pvop->op_next = (OP*)pvop;
3399 pvop->op_flags = (U8)flags;
3400 if (PL_opargs[type] & OA_RETSCALAR)
3402 if (PL_opargs[type] & OA_TARGET)
3403 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3404 return CHECKOP(type, pvop);
3412 Perl_package(pTHX_ OP *o)
3421 save_hptr(&PL_curstash);
3422 save_item(PL_curstname);
3424 name = SvPV_const(cSVOPo->op_sv, len);
3425 PL_curstash = gv_stashpvn(name, len, TRUE);
3426 sv_setpvn(PL_curstname, name, len);
3428 PL_hints |= HINT_BLOCK_SCOPE;
3429 PL_copline = NOLINE;
3435 if (!PL_madskills) {
3440 pegop = newOP(OP_NULL,0);
3441 op_getmad(o,pegop,'P');
3451 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3458 OP *pegop = newOP(OP_NULL,0);
3461 if (idop->op_type != OP_CONST)
3462 Perl_croak(aTHX_ "Module name must be constant");
3465 op_getmad(idop,pegop,'U');
3470 SV * const vesv = ((SVOP*)version)->op_sv;
3473 op_getmad(version,pegop,'V');
3474 if (!arg && !SvNIOKp(vesv)) {
3481 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3482 Perl_croak(aTHX_ "Version number must be constant number");
3484 /* Make copy of idop so we don't free it twice */
3485 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3487 /* Fake up a method call to VERSION */
3488 meth = newSVpvs_share("VERSION");
3489 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3490 append_elem(OP_LIST,
3491 prepend_elem(OP_LIST, pack, list(version)),
3492 newSVOP(OP_METHOD_NAMED, 0, meth)));
3496 /* Fake up an import/unimport */
3497 if (arg && arg->op_type == OP_STUB) {
3499 op_getmad(arg,pegop,'S');
3500 imop = arg; /* no import on explicit () */
3502 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3503 imop = NULL; /* use 5.0; */
3505 idop->op_private |= OPpCONST_NOVER;
3511 op_getmad(arg,pegop,'A');
3513 /* Make copy of idop so we don't free it twice */
3514 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3516 /* Fake up a method call to import/unimport */
3518 ? newSVpvs_share("import") : newSVpvs_share("unimport");
3519 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3520 append_elem(OP_LIST,
3521 prepend_elem(OP_LIST, pack, list(arg)),
3522 newSVOP(OP_METHOD_NAMED, 0, meth)));
3525 /* Fake up the BEGIN {}, which does its thing immediately. */
3527 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
3530 append_elem(OP_LINESEQ,
3531 append_elem(OP_LINESEQ,
3532 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
3533 newSTATEOP(0, NULL, veop)),
3534 newSTATEOP(0, NULL, imop) ));
3536 /* The "did you use incorrect case?" warning used to be here.
3537 * The problem is that on case-insensitive filesystems one
3538 * might get false positives for "use" (and "require"):
3539 * "use Strict" or "require CARP" will work. This causes
3540 * portability problems for the script: in case-strict
3541 * filesystems the script will stop working.
3543 * The "incorrect case" warning checked whether "use Foo"
3544 * imported "Foo" to your namespace, but that is wrong, too:
3545 * there is no requirement nor promise in the language that
3546 * a Foo.pm should or would contain anything in package "Foo".
3548 * There is very little Configure-wise that can be done, either:
3549 * the case-sensitivity of the build filesystem of Perl does not
3550 * help in guessing the case-sensitivity of the runtime environment.
3553 PL_hints |= HINT_BLOCK_SCOPE;
3554 PL_copline = NOLINE;
3556 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3559 if (!PL_madskills) {
3560 /* FIXME - don't allocate pegop if !PL_madskills */
3569 =head1 Embedding Functions
3571 =for apidoc load_module
3573 Loads the module whose name is pointed to by the string part of name.
3574 Note that the actual module name, not its filename, should be given.
3575 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3576 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3577 (or 0 for no flags). ver, if specified, provides version semantics
3578 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3579 arguments can be used to specify arguments to the module's import()
3580 method, similar to C<use Foo::Bar VERSION LIST>.
3585 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3588 va_start(args, ver);
3589 vload_module(flags, name, ver, &args);
3593 #ifdef PERL_IMPLICIT_CONTEXT
3595 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3599 va_start(args, ver);
3600 vload_module(flags, name, ver, &args);
3606 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3611 OP * const modname = newSVOP(OP_CONST, 0, name);
3612 modname->op_private |= OPpCONST_BARE;
3614 veop = newSVOP(OP_CONST, 0, ver);
3618 if (flags & PERL_LOADMOD_NOIMPORT) {
3619 imop = sawparens(newNULLLIST());
3621 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3622 imop = va_arg(*args, OP*);
3627 sv = va_arg(*args, SV*);
3629 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3630 sv = va_arg(*args, SV*);
3634 const line_t ocopline = PL_copline;
3635 COP * const ocurcop = PL_curcop;
3636 const int oexpect = PL_expect;
3638 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3639 veop, modname, imop);
3640 PL_expect = oexpect;
3641 PL_copline = ocopline;
3642 PL_curcop = ocurcop;
3647 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
3653 if (!force_builtin) {
3654 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
3655 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
3656 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
3657 gv = gvp ? *gvp : NULL;
3661 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3662 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3663 append_elem(OP_LIST, term,
3664 scalar(newUNOP(OP_RV2CV, 0,
3669 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3675 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3677 return newBINOP(OP_LSLICE, flags,
3678 list(force_list(subscript)),
3679 list(force_list(listval)) );
3683 S_is_list_assignment(pTHX_ register const OP *o)
3688 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3689 o = cUNOPo->op_first;
3691 if (o->op_type == OP_COND_EXPR) {
3692 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
3693 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3698 yyerror("Assignment to both a list and a scalar");
3702 if (o->op_type == OP_LIST &&
3703 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3704 o->op_private & OPpLVAL_INTRO)
3707 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3708 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3709 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3712 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3715 if (o->op_type == OP_RV2SV)
3722 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3728 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3729 return newLOGOP(optype, 0,
3730 mod(scalar(left), optype),
3731 newUNOP(OP_SASSIGN, 0, scalar(right)));
3734 return newBINOP(optype, OPf_STACKED,
3735 mod(scalar(left), optype), scalar(right));
3739 if (is_list_assignment(left)) {
3743 /* Grandfathering $[ assignment here. Bletch.*/
3744 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
3745 PL_eval_start = (left->op_type == OP_CONST) ? right : 0;
3746 left = mod(left, OP_AASSIGN);
3749 else if (left->op_type == OP_CONST) {
3751 /* Result of assignment is always 1 (or we'd be dead already) */
3752 return newSVOP(OP_CONST, 0, newSViv(1));
3754 curop = list(force_list(left));
3755 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3756 o->op_private = (U8)(0 | (flags >> 8));
3758 /* PL_generation sorcery:
3759 * an assignment like ($a,$b) = ($c,$d) is easier than
3760 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3761 * To detect whether there are common vars, the global var
3762 * PL_generation is incremented for each assign op we compile.
3763 * Then, while compiling the assign op, we run through all the
3764 * variables on both sides of the assignment, setting a spare slot
3765 * in each of them to PL_generation. If any of them already have
3766 * that value, we know we've got commonality. We could use a
3767 * single bit marker, but then we'd have to make 2 passes, first
3768 * to clear the flag, then to test and set it. To find somewhere
3769 * to store these values, evil chicanery is done with SvCUR().
3772 if (!(left->op_private & OPpLVAL_INTRO)) {
3775 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3776 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3777 if (curop->op_type == OP_GV) {
3778 GV *gv = cGVOPx_gv(curop);
3780 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
3782 GvASSIGN_GENERATION_set(gv, PL_generation);
3784 else if (curop->op_type == OP_PADSV ||
3785 curop->op_type == OP_PADAV ||
3786 curop->op_type == OP_PADHV ||
3787 curop->op_type == OP_PADANY)
3789 if (PAD_COMPNAME_GEN(curop->op_targ)
3790 == (STRLEN)PL_generation)
3792 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
3795 else if (curop->op_type == OP_RV2CV)
3797 else if (curop->op_type == OP_RV2SV ||
3798 curop->op_type == OP_RV2AV ||
3799 curop->op_type == OP_RV2HV ||
3800 curop->op_type == OP_RV2GV) {
3801 if (lastop->op_type != OP_GV) /* funny deref? */
3804 else if (curop->op_type == OP_PUSHRE) {
3805 if (((PMOP*)curop)->op_pmreplroot) {
3807 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3808 ((PMOP*)curop)->op_pmreplroot));
3810 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3813 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
3815 GvASSIGN_GENERATION_set(gv, PL_generation);
3816 GvASSIGN_GENERATION_set(gv, PL_generation);
3825 o->op_private |= OPpASSIGN_COMMON;
3827 if (right && right->op_type == OP_SPLIT) {
3829 if ((tmpop = ((LISTOP*)right)->op_first) &&
3830 tmpop->op_type == OP_PUSHRE)
3832 PMOP * const pm = (PMOP*)tmpop;
3833 if (left->op_type == OP_RV2AV &&
3834 !(left->op_private & OPpLVAL_INTRO) &&
3835 !(o->op_private & OPpASSIGN_COMMON) )
3837 tmpop = ((UNOP*)left)->op_first;
3838 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3840 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3841 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3843 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3844 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
3846 pm->op_pmflags |= PMf_ONCE;
3847 tmpop = cUNOPo->op_first; /* to list (nulled) */
3848 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3849 tmpop->op_sibling = NULL; /* don't free split */
3850 right->op_next = tmpop->op_next; /* fix starting loc */
3852 op_getmad(o,right,'R'); /* blow off assign */
3854 op_free(o); /* blow off assign */
3856 right->op_flags &= ~OPf_WANT;
3857 /* "I don't know and I don't care." */
3862 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3863 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3865 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3867 sv_setiv(sv, PL_modcount+1);
3875 right = newOP(OP_UNDEF, 0);
3876 if (right->op_type == OP_READLINE) {
3877 right->op_flags |= OPf_STACKED;
3878 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3881 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3882 o = newBINOP(OP_SASSIGN, flags,
3883 scalar(right), mod(scalar(left), OP_SASSIGN) );
3889 o = newSVOP(OP_CONST, 0, newSViv(PL_compiling.cop_arybase));
3890 o->op_private |= OPpCONST_ARYBASE;
3897 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3900 const U32 seq = intro_my();
3903 NewOp(1101, cop, 1, COP);
3904 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3905 cop->op_type = OP_DBSTATE;
3906 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3909 cop->op_type = OP_NEXTSTATE;
3910 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3912 cop->op_flags = (U8)flags;
3913 cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
3915 cop->op_private |= NATIVE_HINTS;
3917 PL_compiling.op_private = cop->op_private;
3918 cop->op_next = (OP*)cop;
3921 cop->cop_label = label;
3922 PL_hints |= HINT_BLOCK_SCOPE;
3925 cop->cop_arybase = PL_curcop->cop_arybase;
3926 if (specialWARN(PL_curcop->cop_warnings))
3927 cop->cop_warnings = PL_curcop->cop_warnings ;
3929 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3930 if (specialCopIO(PL_curcop->cop_io))
3931 cop->cop_io = PL_curcop->cop_io;
3933 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3936 if (PL_copline == NOLINE)
3937 CopLINE_set(cop, CopLINE(PL_curcop));
3939 CopLINE_set(cop, PL_copline);
3940 PL_copline = NOLINE;
3943 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3945 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3947 CopSTASH_set(cop, PL_curstash);
3949 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3950 SV * const * const svp = av_fetch(CopFILEAVx(PL_curcop), (I32)CopLINE(cop), FALSE);
3951 if (svp && *svp != &PL_sv_undef ) {
3952 (void)SvIOK_on(*svp);
3953 SvIV_set(*svp, PTR2IV(cop));
3957 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3962 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3965 return new_logop(type, flags, &first, &other);
3969 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3974 OP *first = *firstp;
3975 OP * const other = *otherp;
3977 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3978 return newBINOP(type, flags, scalar(first), scalar(other));
3980 scalarboolean(first);
3981 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3982 if (first->op_type == OP_NOT
3983 && (first->op_flags & OPf_SPECIAL)
3984 && (first->op_flags & OPf_KIDS)) {
3985 if (type == OP_AND || type == OP_OR) {
3991 first = *firstp = cUNOPo->op_first;
3993 first->op_next = o->op_next;
3994 cUNOPo->op_first = NULL;
3996 op_getmad(o,first,'O');
4002 if (first->op_type == OP_CONST) {
4003 if (first->op_private & OPpCONST_STRICT)
4004 no_bareword_allowed(first);
4005 else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
4006 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
4007 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
4008 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
4009 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
4011 if (other->op_type == OP_CONST)
4012 other->op_private |= OPpCONST_SHORTCIRCUIT;
4014 OP *newop = newUNOP(OP_NULL, 0, other);
4015 op_getmad(first, newop, '1');
4016 newop->op_targ = type; /* set "was" field */
4023 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
4024 const OP *o2 = other;
4025 if ( ! (o2->op_type == OP_LIST
4026 && (( o2 = cUNOPx(o2)->op_first))
4027 && o2->op_type == OP_PUSHMARK
4028 && (( o2 = o2->op_sibling)) )
4031 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
4032 || o2->op_type == OP_PADHV)
4033 && o2->op_private & OPpLVAL_INTRO
4034 && ckWARN(WARN_DEPRECATED))
4036 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4037 "Deprecated use of my() in false conditional");
4041 if (first->op_type == OP_CONST)
4042 first->op_private |= OPpCONST_SHORTCIRCUIT;
4044 first = newUNOP(OP_NULL, 0, first);
4045 op_getmad(other, first, '2');
4046 first->op_targ = type; /* set "was" field */
4053 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
4054 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
4056 const OP * const k1 = ((UNOP*)first)->op_first;
4057 const OP * const k2 = k1->op_sibling;
4059 switch (first->op_type)
4062 if (k2 && k2->op_type == OP_READLINE
4063 && (k2->op_flags & OPf_STACKED)
4064 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4066 warnop = k2->op_type;
4071 if (k1->op_type == OP_READDIR
4072 || k1->op_type == OP_GLOB
4073 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4074 || k1->op_type == OP_EACH)
4076 warnop = ((k1->op_type == OP_NULL)
4077 ? (OPCODE)k1->op_targ : k1->op_type);
4082 const line_t oldline = CopLINE(PL_curcop);
4083 CopLINE_set(PL_curcop, PL_copline);
4084 Perl_warner(aTHX_ packWARN(WARN_MISC),
4085 "Value of %s%s can be \"0\"; test with defined()",
4087 ((warnop == OP_READLINE || warnop == OP_GLOB)
4088 ? " construct" : "() operator"));
4089 CopLINE_set(PL_curcop, oldline);
4096 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
4097 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
4099 NewOp(1101, logop, 1, LOGOP);
4101 logop->op_type = (OPCODE)type;
4102 logop->op_ppaddr = PL_ppaddr[type];
4103 logop->op_first = first;
4104 logop->op_flags = (U8)(flags | OPf_KIDS);
4105 logop->op_other = LINKLIST(other);
4106 logop->op_private = (U8)(1 | (flags >> 8));
4108 /* establish postfix order */
4109 logop->op_next = LINKLIST(first);
4110 first->op_next = (OP*)logop;
4111 first->op_sibling = other;
4113 CHECKOP(type,logop);
4115 o = newUNOP(OP_NULL, 0, (OP*)logop);
4122 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
4130 return newLOGOP(OP_AND, 0, first, trueop);
4132 return newLOGOP(OP_OR, 0, first, falseop);
4134 scalarboolean(first);
4135 if (first->op_type == OP_CONST) {
4136 if (first->op_private & OPpCONST_BARE &&
4137 first->op_private & OPpCONST_STRICT) {
4138 no_bareword_allowed(first);
4140 if (SvTRUE(((SVOP*)first)->op_sv)) {
4143 trueop = newUNOP(OP_NULL, 0, trueop);
4144 op_getmad(first,trueop,'C');
4145 op_getmad(falseop,trueop,'e');
4147 /* FIXME for MAD - should there be an ELSE here? */
4157 falseop = newUNOP(OP_NULL, 0, falseop);
4158 op_getmad(first,falseop,'C');
4159 op_getmad(trueop,falseop,'t');
4161 /* FIXME for MAD - should there be an ELSE here? */
4169 NewOp(1101, logop, 1, LOGOP);
4170 logop->op_type = OP_COND_EXPR;
4171 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4172 logop->op_first = first;
4173 logop->op_flags = (U8)(flags | OPf_KIDS);
4174 logop->op_private = (U8)(1 | (flags >> 8));
4175 logop->op_other = LINKLIST(trueop);
4176 logop->op_next = LINKLIST(falseop);
4178 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
4181 /* establish postfix order */
4182 start = LINKLIST(first);
4183 first->op_next = (OP*)logop;
4185 first->op_sibling = trueop;
4186 trueop->op_sibling = falseop;
4187 o = newUNOP(OP_NULL, 0, (OP*)logop);
4189 trueop->op_next = falseop->op_next = o;
4196 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4205 NewOp(1101, range, 1, LOGOP);
4207 range->op_type = OP_RANGE;
4208 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4209 range->op_first = left;
4210 range->op_flags = OPf_KIDS;
4211 leftstart = LINKLIST(left);
4212 range->op_other = LINKLIST(right);
4213 range->op_private = (U8)(1 | (flags >> 8));
4215 left->op_sibling = right;
4217 range->op_next = (OP*)range;
4218 flip = newUNOP(OP_FLIP, flags, (OP*)range);
4219 flop = newUNOP(OP_FLOP, 0, flip);
4220 o = newUNOP(OP_NULL, 0, flop);
4222 range->op_next = leftstart;
4224 left->op_next = flip;
4225 right->op_next = flop;
4227 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4228 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4229 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4230 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4232 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4233 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4236 if (!flip->op_private || !flop->op_private)
4237 linklist(o); /* blow off optimizer unless constant */
4243 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4248 const bool once = block && block->op_flags & OPf_SPECIAL &&
4249 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4251 PERL_UNUSED_ARG(debuggable);
4254 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4255 return block; /* do {} while 0 does once */
4256 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4257 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4258 expr = newUNOP(OP_DEFINED, 0,
4259 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4260 } else if (expr->op_flags & OPf_KIDS) {
4261 const OP * const k1 = ((UNOP*)expr)->op_first;
4262 const OP * const k2 = k1 ? k1->op_sibling : NULL;
4263 switch (expr->op_type) {
4265 if (k2 && k2->op_type == OP_READLINE
4266 && (k2->op_flags & OPf_STACKED)
4267 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4268 expr = newUNOP(OP_DEFINED, 0, expr);
4272 if (k1 && (k1->op_type == OP_READDIR
4273 || k1->op_type == OP_GLOB
4274 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4275 || k1->op_type == OP_EACH))
4276 expr = newUNOP(OP_DEFINED, 0, expr);
4282 /* if block is null, the next append_elem() would put UNSTACK, a scalar
4283 * op, in listop. This is wrong. [perl #27024] */
4285 block = newOP(OP_NULL, 0);
4286 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4287 o = new_logop(OP_AND, 0, &expr, &listop);
4290 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4292 if (once && o != listop)
4293 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4296 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
4298 o->op_flags |= flags;
4300 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4305 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
4306 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
4315 PERL_UNUSED_ARG(debuggable);
4318 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4319 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4320 expr = newUNOP(OP_DEFINED, 0,
4321 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4322 } else if (expr->op_flags & OPf_KIDS) {
4323 const OP * const k1 = ((UNOP*)expr)->op_first;
4324 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
4325 switch (expr->op_type) {
4327 if (k2 && k2->op_type == OP_READLINE
4328 && (k2->op_flags & OPf_STACKED)
4329 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4330 expr = newUNOP(OP_DEFINED, 0, expr);
4334 if (k1 && (k1->op_type == OP_READDIR
4335 || k1->op_type == OP_GLOB
4336 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4337 || k1->op_type == OP_EACH))
4338 expr = newUNOP(OP_DEFINED, 0, expr);
4345 block = newOP(OP_NULL, 0);
4346 else if (cont || has_my) {
4347 block = scope(block);
4351 next = LINKLIST(cont);
4354 OP * const unstack = newOP(OP_UNSTACK, 0);
4357 cont = append_elem(OP_LINESEQ, cont, unstack);
4360 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4361 redo = LINKLIST(listop);
4364 PL_copline = (line_t)whileline;
4366 o = new_logop(OP_AND, 0, &expr, &listop);
4367 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4368 op_free(expr); /* oops, it's a while (0) */
4370 return NULL; /* listop already freed by new_logop */
4373 ((LISTOP*)listop)->op_last->op_next =
4374 (o == listop ? redo : LINKLIST(o));
4380 NewOp(1101,loop,1,LOOP);
4381 loop->op_type = OP_ENTERLOOP;
4382 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4383 loop->op_private = 0;
4384 loop->op_next = (OP*)loop;
4387 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4389 loop->op_redoop = redo;
4390 loop->op_lastop = o;
4391 o->op_private |= loopflags;
4394 loop->op_nextop = next;
4396 loop->op_nextop = o;
4398 o->op_flags |= flags;
4399 o->op_private |= (flags >> 8);
4404 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
4409 PADOFFSET padoff = 0;
4415 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4416 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
4417 sv->op_type = OP_RV2GV;
4418 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4419 if (cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
4420 iterpflags |= OPpITER_DEF;
4422 else if (sv->op_type == OP_PADSV) { /* private variable */
4423 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
4424 padoff = sv->op_targ;
4433 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4434 padoff = sv->op_targ;
4439 iterflags |= OPf_SPECIAL;
4445 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4446 if (padoff && strEQ(PAD_COMPNAME_PV(padoff), "$_"))
4447 iterpflags |= OPpITER_DEF;
4450 const I32 offset = pad_findmy("$_");
4451 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
4452 sv = newGVOP(OP_GV, 0, PL_defgv);
4457 iterpflags |= OPpITER_DEF;
4459 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4460 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4461 iterflags |= OPf_STACKED;
4463 else if (expr->op_type == OP_NULL &&
4464 (expr->op_flags & OPf_KIDS) &&
4465 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4467 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4468 * set the STACKED flag to indicate that these values are to be
4469 * treated as min/max values by 'pp_iterinit'.
4471 UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4472 LOGOP* const range = (LOGOP*) flip->op_first;
4473 OP* const left = range->op_first;
4474 OP* const right = left->op_sibling;
4477 range->op_flags &= ~OPf_KIDS;
4478 range->op_first = NULL;
4480 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4481 listop->op_first->op_next = range->op_next;
4482 left->op_next = range->op_other;
4483 right->op_next = (OP*)listop;
4484 listop->op_next = listop->op_first;
4487 op_getmad(expr,(OP*)listop,'O');
4491 expr = (OP*)(listop);
4493 iterflags |= OPf_STACKED;
4496 expr = mod(force_list(expr), OP_GREPSTART);
4499 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4500 append_elem(OP_LIST, expr, scalar(sv))));
4501 assert(!loop->op_next);
4502 /* for my $x () sets OPpLVAL_INTRO;
4503 * for our $x () sets OPpOUR_INTRO */
4504 loop->op_private = (U8)iterpflags;
4505 #ifdef PL_OP_SLAB_ALLOC
4508 NewOp(1234,tmp,1,LOOP);
4509 Copy(loop,tmp,1,LISTOP);
4514 Renew(loop, 1, LOOP);
4516 loop->op_targ = padoff;
4517 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
4519 op_getmad(madsv, (OP*)loop, 'v');
4520 PL_copline = forline;
4521 return newSTATEOP(0, label, wop);
4525 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4530 if (type != OP_GOTO || label->op_type == OP_CONST) {
4531 /* "last()" means "last" */
4532 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4533 o = newOP(type, OPf_SPECIAL);
4535 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4536 ? SvPVx_nolen_const(((SVOP*)label)->op_sv)
4540 op_getmad(label,o,'L');
4546 /* Check whether it's going to be a goto &function */
4547 if (label->op_type == OP_ENTERSUB
4548 && !(label->op_flags & OPf_STACKED))
4549 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4550 o = newUNOP(type, OPf_STACKED, label);
4552 PL_hints |= HINT_BLOCK_SCOPE;
4556 /* if the condition is a literal array or hash
4557 (or @{ ... } etc), make a reference to it.
4560 S_ref_array_or_hash(pTHX_ OP *cond)
4563 && (cond->op_type == OP_RV2AV
4564 || cond->op_type == OP_PADAV
4565 || cond->op_type == OP_RV2HV
4566 || cond->op_type == OP_PADHV))
4568 return newUNOP(OP_REFGEN,
4569 0, mod(cond, OP_REFGEN));
4575 /* These construct the optree fragments representing given()
4578 entergiven and enterwhen are LOGOPs; the op_other pointer
4579 points up to the associated leave op. We need this so we
4580 can put it in the context and make break/continue work.
4581 (Also, of course, pp_enterwhen will jump straight to
4582 op_other if the match fails.)
4587 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
4588 I32 enter_opcode, I32 leave_opcode,
4589 PADOFFSET entertarg)
4595 NewOp(1101, enterop, 1, LOGOP);
4596 enterop->op_type = enter_opcode;
4597 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
4598 enterop->op_flags = (U8) OPf_KIDS;
4599 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
4600 enterop->op_private = 0;
4602 o = newUNOP(leave_opcode, 0, (OP *) enterop);
4605 enterop->op_first = scalar(cond);
4606 cond->op_sibling = block;
4608 o->op_next = LINKLIST(cond);
4609 cond->op_next = (OP *) enterop;
4612 /* This is a default {} block */
4613 enterop->op_first = block;
4614 enterop->op_flags |= OPf_SPECIAL;
4616 o->op_next = (OP *) enterop;
4619 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
4620 entergiven and enterwhen both
4623 enterop->op_next = LINKLIST(block);
4624 block->op_next = enterop->op_other = o;
4629 /* Does this look like a boolean operation? For these purposes
4630 a boolean operation is:
4631 - a subroutine call [*]
4632 - a logical connective
4633 - a comparison operator
4634 - a filetest operator, with the exception of -s -M -A -C
4635 - defined(), exists() or eof()
4636 - /$re/ or $foo =~ /$re/
4638 [*] possibly surprising
4642 S_looks_like_bool(pTHX_ const OP *o)
4645 switch(o->op_type) {
4647 return looks_like_bool(cLOGOPo->op_first);
4651 looks_like_bool(cLOGOPo->op_first)
4652 && looks_like_bool(cLOGOPo->op_first->op_sibling));
4656 case OP_NOT: case OP_XOR:
4657 /* Note that OP_DOR is not here */
4659 case OP_EQ: case OP_NE: case OP_LT:
4660 case OP_GT: case OP_LE: case OP_GE:
4662 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
4663 case OP_I_GT: case OP_I_LE: case OP_I_GE:
4665 case OP_SEQ: case OP_SNE: case OP_SLT:
4666 case OP_SGT: case OP_SLE: case OP_SGE:
4670 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
4671 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
4672 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
4673 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
4674 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
4675 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
4676 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
4677 case OP_FTTEXT: case OP_FTBINARY:
4679 case OP_DEFINED: case OP_EXISTS:
4680 case OP_MATCH: case OP_EOF:
4685 /* Detect comparisons that have been optimized away */
4686 if (cSVOPo->op_sv == &PL_sv_yes
4687 || cSVOPo->op_sv == &PL_sv_no)
4698 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
4702 return newGIVWHENOP(
4703 ref_array_or_hash(cond),
4705 OP_ENTERGIVEN, OP_LEAVEGIVEN,
4709 /* If cond is null, this is a default {} block */
4711 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
4713 const bool cond_llb = (!cond || looks_like_bool(cond));
4719 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
4721 scalar(ref_array_or_hash(cond)));
4724 return newGIVWHENOP(
4726 append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
4727 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
4731 =for apidoc cv_undef
4733 Clear out all the active components of a CV. This can happen either
4734 by an explicit C<undef &foo>, or by the reference count going to zero.
4735 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
4736 children can still follow the full lexical scope chain.
4742 Perl_cv_undef(pTHX_ CV *cv)
4746 if (CvFILE(cv) && !CvISXSUB(cv)) {
4747 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4748 Safefree(CvFILE(cv));
4753 if (!CvISXSUB(cv) && CvROOT(cv)) {
4754 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
4755 Perl_croak(aTHX_ "Can't undef active subroutine");
4758 PAD_SAVE_SETNULLPAD();
4760 op_free(CvROOT(cv));
4765 SvPOK_off((SV*)cv); /* forget prototype */
4770 /* remove CvOUTSIDE unless this is an undef rather than a free */
4771 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
4772 if (!CvWEAKOUTSIDE(cv))
4773 SvREFCNT_dec(CvOUTSIDE(cv));
4774 CvOUTSIDE(cv) = NULL;
4777 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4780 if (CvISXSUB(cv) && CvXSUB(cv)) {
4783 /* delete all flags except WEAKOUTSIDE */
4784 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
4788 Perl_cv_ckproto(pTHX_ const CV *cv, const GV *gv, const char *p)
4790 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX_const(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4791 SV* const msg = sv_newmortal();
4795 gv_efullname3(name = sv_newmortal(), gv, NULL);
4796 sv_setpv(msg, "Prototype mismatch:");
4798 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4800 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (const SV *)cv);
4802 sv_catpvs(msg, ": none");
4803 sv_catpvs(msg, " vs ");
4805 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4807 sv_catpvs(msg, "none");
4808 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
4812 static void const_sv_xsub(pTHX_ CV* cv);
4816 =head1 Optree Manipulation Functions
4818 =for apidoc cv_const_sv
4820 If C<cv> is a constant sub eligible for inlining. returns the constant
4821 value returned by the sub. Otherwise, returns NULL.
4823 Constant subs can be created with C<newCONSTSUB> or as described in
4824 L<perlsub/"Constant Functions">.
4829 Perl_cv_const_sv(pTHX_ CV *cv)
4831 PERL_UNUSED_CONTEXT;
4834 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
4836 return CvCONST(cv) ? (SV*)CvXSUBANY(cv).any_ptr : NULL;
4839 /* op_const_sv: examine an optree to determine whether it's in-lineable.
4840 * Can be called in 3 ways:
4843 * look for a single OP_CONST with attached value: return the value
4845 * cv && CvCLONE(cv) && !CvCONST(cv)
4847 * examine the clone prototype, and if contains only a single
4848 * OP_CONST referencing a pad const, or a single PADSV referencing
4849 * an outer lexical, return a non-zero value to indicate the CV is
4850 * a candidate for "constizing" at clone time
4854 * We have just cloned an anon prototype that was marked as a const
4855 * candidiate. Try to grab the current value, and in the case of
4856 * PADSV, ignore it if it has multiple references. Return the value.
4860 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
4868 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4869 o = cLISTOPo->op_first->op_sibling;
4871 for (; o; o = o->op_next) {
4872 const OPCODE type = o->op_type;
4874 if (sv && o->op_next == o)
4876 if (o->op_next != o) {
4877 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4879 if (type == OP_DBSTATE)
4882 if (type == OP_LEAVESUB || type == OP_RETURN)
4886 if (type == OP_CONST && cSVOPo->op_sv)
4888 else if (cv && type == OP_CONST) {
4889 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4893 else if (cv && type == OP_PADSV) {
4894 if (CvCONST(cv)) { /* newly cloned anon */
4895 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4896 /* the candidate should have 1 ref from this pad and 1 ref
4897 * from the parent */
4898 if (!sv || SvREFCNT(sv) != 2)
4905 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
4906 sv = &PL_sv_undef; /* an arbitrary non-null value */
4921 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4924 /* This would be the return value, but the return cannot be reached. */
4925 OP* pegop = newOP(OP_NULL, 0);
4928 PERL_UNUSED_ARG(floor);
4938 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4940 NORETURN_FUNCTION_END;
4945 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4947 return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
4951 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4958 register CV *cv = NULL;
4960 /* If the subroutine has no body, no attributes, and no builtin attributes
4961 then it's just a sub declaration, and we may be able to get away with
4962 storing with a placeholder scalar in the symbol table, rather than a
4963 full GV and CV. If anything is present then it will take a full CV to
4965 const I32 gv_fetch_flags
4966 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
4968 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
4969 const char * const name = o ? SvPVx_nolen_const(cSVOPo->op_sv) : NULL;
4972 assert(proto->op_type == OP_CONST);
4973 ps = SvPVx_const(((SVOP*)proto)->op_sv, ps_len);
4978 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4979 SV * const sv = sv_newmortal();
4980 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4981 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
4982 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4983 aname = SvPVX_const(sv);
4988 gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
4989 : gv_fetchpv(aname ? aname
4990 : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4991 gv_fetch_flags, SVt_PVCV);
4993 if (!PL_madskills) {
5002 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
5003 maximum a prototype before. */
5004 if (SvTYPE(gv) > SVt_NULL) {
5005 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
5006 && ckWARN_d(WARN_PROTOTYPE))
5008 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
5010 cv_ckproto((CV*)gv, NULL, ps);
5013 sv_setpvn((SV*)gv, ps, ps_len);
5015 sv_setiv((SV*)gv, -1);
5016 SvREFCNT_dec(PL_compcv);
5017 cv = PL_compcv = NULL;
5018 PL_sub_generation++;
5022 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
5024 #ifdef GV_UNIQUE_CHECK
5025 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
5026 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
5030 if (!block || !ps || *ps || attrs
5031 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5033 || block->op_type == OP_NULL
5038 const_sv = op_const_sv(block, NULL);
5041 const bool exists = CvROOT(cv) || CvXSUB(cv);
5043 #ifdef GV_UNIQUE_CHECK
5044 if (exists && GvUNIQUE(gv)) {
5045 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
5049 /* if the subroutine doesn't exist and wasn't pre-declared
5050 * with a prototype, assume it will be AUTOLOADed,
5051 * skipping the prototype check
5053 if (exists || SvPOK(cv))
5054 cv_ckproto(cv, gv, ps);
5055 /* already defined (or promised)? */
5056 if (exists || GvASSUMECV(gv)) {
5059 || block->op_type == OP_NULL
5062 if (CvFLAGS(PL_compcv)) {
5063 /* might have had built-in attrs applied */
5064 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5066 /* just a "sub foo;" when &foo is already defined */
5067 SAVEFREESV(PL_compcv);
5072 && block->op_type != OP_NULL
5075 if (ckWARN(WARN_REDEFINE)
5077 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
5079 const line_t oldline = CopLINE(PL_curcop);
5080 if (PL_copline != NOLINE)
5081 CopLINE_set(PL_curcop, PL_copline);
5082 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5083 CvCONST(cv) ? "Constant subroutine %s redefined"
5084 : "Subroutine %s redefined", name);
5085 CopLINE_set(PL_curcop, oldline);
5088 if (!PL_minus_c) /* keep old one around for madskills */
5091 /* (PL_madskills unset in used file.) */
5099 SvREFCNT_inc_void_NN(const_sv);
5101 assert(!CvROOT(cv) && !CvCONST(cv));
5102 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
5103 CvXSUBANY(cv).any_ptr = const_sv;
5104 CvXSUB(cv) = const_sv_xsub;
5110 cv = newCONSTSUB(NULL, name, const_sv);
5112 PL_sub_generation++;
5116 SvREFCNT_dec(PL_compcv);
5124 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
5125 * before we clobber PL_compcv.
5129 || block->op_type == OP_NULL
5133 /* Might have had built-in attributes applied -- propagate them. */
5134 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5135 if (CvGV(cv) && GvSTASH(CvGV(cv)))
5136 stash = GvSTASH(CvGV(cv));
5137 else if (CvSTASH(cv))
5138 stash = CvSTASH(cv);
5140 stash = PL_curstash;
5143 /* possibly about to re-define existing subr -- ignore old cv */
5144 rcv = (SV*)PL_compcv;
5145 if (name && GvSTASH(gv))
5146 stash = GvSTASH(gv);
5148 stash = PL_curstash;
5150 apply_attrs(stash, rcv, attrs, FALSE);
5152 if (cv) { /* must reuse cv if autoloaded */
5159 || block->op_type == OP_NULL) && !PL_madskills
5162 /* got here with just attrs -- work done, so bug out */
5163 SAVEFREESV(PL_compcv);
5166 /* transfer PL_compcv to cv */
5168 CvFLAGS(cv) = CvFLAGS(PL_compcv);
5169 if (!CvWEAKOUTSIDE(cv))
5170 SvREFCNT_dec(CvOUTSIDE(cv));
5171 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
5172 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
5173 CvOUTSIDE(PL_compcv) = 0;
5174 CvPADLIST(cv) = CvPADLIST(PL_compcv);
5175 CvPADLIST(PL_compcv) = 0;
5176 /* inner references to PL_compcv must be fixed up ... */
5177 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
5178 /* ... before we throw it away */
5179 SvREFCNT_dec(PL_compcv);
5181 if (PERLDB_INTER)/* Advice debugger on the new sub. */
5182 ++PL_sub_generation;
5189 if (strEQ(name, "import")) {
5190 PL_formfeed = (SV*)cv;
5191 Perl_warner(aTHX_ packWARN(WARN_VOID), "%lx\n", (long)cv);
5195 PL_sub_generation++;
5199 CvFILE_set_from_cop(cv, PL_curcop);
5200 CvSTASH(cv) = PL_curstash;
5203 sv_setpvn((SV*)cv, ps, ps_len);
5205 if (PL_error_count) {
5209 const char *s = strrchr(name, ':');
5211 if (strEQ(s, "BEGIN")) {
5212 const char not_safe[] =
5213 "BEGIN not safe after errors--compilation aborted";
5214 if (PL_in_eval & EVAL_KEEPERR)
5215 Perl_croak(aTHX_ not_safe);
5217 /* force display of errors found but not reported */
5218 sv_catpv(ERRSV, not_safe);
5219 Perl_croak(aTHX_ "%"SVf, ERRSV);
5229 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5230 mod(scalarseq(block), OP_LEAVESUBLV));
5233 /* This makes sub {}; work as expected. */
5234 if (block->op_type == OP_STUB) {
5235 OP* newblock = newSTATEOP(0, NULL, 0);
5237 op_getmad(block,newblock,'B');
5243 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5245 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5246 OpREFCNT_set(CvROOT(cv), 1);
5247 CvSTART(cv) = LINKLIST(CvROOT(cv));
5248 CvROOT(cv)->op_next = 0;
5249 CALL_PEEP(CvSTART(cv));
5251 /* now that optimizer has done its work, adjust pad values */
5253 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
5256 assert(!CvCONST(cv));
5257 if (ps && !*ps && op_const_sv(block, cv))
5261 if (name || aname) {
5263 const char * const tname = (name ? name : aname);
5265 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5266 SV * const sv = newSV(0);
5267 SV * const tmpstr = sv_newmortal();
5268 GV * const db_postponed = gv_fetchpvs("DB::postponed",
5269 GV_ADDMULTI, SVt_PVHV);
5272 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5274 (long)PL_subline, (long)CopLINE(PL_curcop));
5275 gv_efullname3(tmpstr, gv, NULL);
5276 hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0);
5277 hv = GvHVn(db_postponed);
5278 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
5279 CV * const pcv = GvCV(db_postponed);
5285 call_sv((SV*)pcv, G_DISCARD);
5290 if ((s = strrchr(tname,':')))
5295 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5298 if (strEQ(s, "BEGIN") && !PL_error_count) {
5299 const I32 oldscope = PL_scopestack_ix;
5301 SAVECOPFILE(&PL_compiling);
5302 SAVECOPLINE(&PL_compiling);
5305 PL_beginav = newAV();
5306 DEBUG_x( dump_sub(gv) );
5307 av_push(PL_beginav, (SV*)cv);
5308 GvCV(gv) = 0; /* cv has been hijacked */
5309 call_list(oldscope, PL_beginav);
5311 PL_curcop = &PL_compiling;
5312 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
5315 else if (strEQ(s, "END") && !PL_error_count) {
5318 DEBUG_x( dump_sub(gv) );
5319 av_unshift(PL_endav, 1);
5320 av_store(PL_endav, 0, (SV*)cv);
5321 GvCV(gv) = 0; /* cv has been hijacked */
5323 else if (strEQ(s, "CHECK") && !PL_error_count) {
5325 PL_checkav = newAV();
5326 DEBUG_x( dump_sub(gv) );
5327 if (PL_main_start && ckWARN(WARN_VOID))
5328 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
5329 av_unshift(PL_checkav, 1);
5330 av_store(PL_checkav, 0, (SV*)cv);
5331 GvCV(gv) = 0; /* cv has been hijacked */
5333 else if (strEQ(s, "INIT") && !PL_error_count) {
5335 PL_initav = newAV();
5336 DEBUG_x( dump_sub(gv) );
5337 if (PL_main_start && ckWARN(WARN_VOID))
5338 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
5339 av_push(PL_initav, (SV*)cv);
5340 GvCV(gv) = 0; /* cv has been hijacked */
5345 PL_copline = NOLINE;
5350 /* XXX unsafe for threads if eval_owner isn't held */
5352 =for apidoc newCONSTSUB
5354 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5355 eligible for inlining at compile-time.
5361 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
5368 SAVECOPLINE(PL_curcop);
5369 CopLINE_set(PL_curcop, PL_copline);
5372 PL_hints &= ~HINT_BLOCK_SCOPE;
5375 SAVESPTR(PL_curstash);
5376 SAVECOPSTASH(PL_curcop);
5377 PL_curstash = stash;
5378 CopSTASH_set(PL_curcop,stash);
5381 cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
5382 CvXSUBANY(cv).any_ptr = sv;
5384 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
5388 CopSTASH_free(PL_curcop);
5396 =for apidoc U||newXS
5398 Used by C<xsubpp> to hook up XSUBs as Perl subs.
5404 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
5407 GV * const gv = gv_fetchpv(name ? name :
5408 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5409 GV_ADDMULTI, SVt_PVCV);
5413 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
5415 if ((cv = (name ? GvCV(gv) : NULL))) {
5417 /* just a cached method */
5421 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5422 /* already defined (or promised) */
5423 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
5424 if (ckWARN(WARN_REDEFINE)) {
5425 GV * const gvcv = CvGV(cv);
5427 HV * const stash = GvSTASH(gvcv);
5429 const char *redefined_name = HvNAME_get(stash);
5430 if ( strEQ(redefined_name,"autouse") ) {
5431 const line_t oldline = CopLINE(PL_curcop);
5432 if (PL_copline != NOLINE)
5433 CopLINE_set(PL_curcop, PL_copline);
5434 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5435 CvCONST(cv) ? "Constant subroutine %s redefined"
5436 : "Subroutine %s redefined"
5438 CopLINE_set(PL_curcop, oldline);
5448 if (cv) /* must reuse cv if autoloaded */
5452 sv_upgrade((SV *)cv, SVt_PVCV);
5456 PL_sub_generation++;
5460 (void)gv_fetchfile(filename);
5461 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
5462 an external constant string */
5464 CvXSUB(cv) = subaddr;
5467 const char *s = strrchr(name,':');
5473 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5476 if (strEQ(s, "BEGIN")) {
5478 PL_beginav = newAV();
5479 av_push(PL_beginav, (SV*)cv);
5480 GvCV(gv) = 0; /* cv has been hijacked */
5482 else if (strEQ(s, "END")) {
5485 av_unshift(PL_endav, 1);
5486 av_store(PL_endav, 0, (SV*)cv);
5487 GvCV(gv) = 0; /* cv has been hijacked */
5489 else if (strEQ(s, "CHECK")) {
5491 PL_checkav = newAV();
5492 if (PL_main_start && ckWARN(WARN_VOID))
5493 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
5494 av_unshift(PL_checkav, 1);
5495 av_store(PL_checkav, 0, (SV*)cv);
5496 GvCV(gv) = 0; /* cv has been hijacked */
5498 else if (strEQ(s, "INIT")) {
5500 PL_initav = newAV();
5501 if (PL_main_start && ckWARN(WARN_VOID))
5502 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
5503 av_push(PL_initav, (SV*)cv);
5504 GvCV(gv) = 0; /* cv has been hijacked */
5519 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5524 OP* pegop = newOP(OP_NULL, 0);
5528 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
5529 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
5531 #ifdef GV_UNIQUE_CHECK
5533 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5537 if ((cv = GvFORM(gv))) {
5538 if (ckWARN(WARN_REDEFINE)) {
5539 const line_t oldline = CopLINE(PL_curcop);
5540 if (PL_copline != NOLINE)
5541 CopLINE_set(PL_curcop, PL_copline);
5542 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5543 o ? "Format %"SVf" redefined"
5544 : "Format STDOUT redefined" ,cSVOPo->op_sv);
5545 CopLINE_set(PL_curcop, oldline);
5552 CvFILE_set_from_cop(cv, PL_curcop);
5555 pad_tidy(padtidy_FORMAT);
5556 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5557 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5558 OpREFCNT_set(CvROOT(cv), 1);
5559 CvSTART(cv) = LINKLIST(CvROOT(cv));
5560 CvROOT(cv)->op_next = 0;
5561 CALL_PEEP(CvSTART(cv));
5563 op_getmad(o,pegop,'n');
5564 op_getmad_weak(block, pegop, 'b');
5568 PL_copline = NOLINE;
5576 Perl_newANONLIST(pTHX_ OP *o)
5578 return newUNOP(OP_REFGEN, 0,
5579 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5583 Perl_newANONHASH(pTHX_ OP *o)
5585 return newUNOP(OP_REFGEN, 0,
5586 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5590 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5592 return newANONATTRSUB(floor, proto, NULL, block);
5596 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5598 return newUNOP(OP_REFGEN, 0,
5599 newSVOP(OP_ANONCODE, 0,
5600 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5604 Perl_oopsAV(pTHX_ OP *o)
5607 switch (o->op_type) {
5609 o->op_type = OP_PADAV;
5610 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5611 return ref(o, OP_RV2AV);
5614 o->op_type = OP_RV2AV;
5615 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5620 if (ckWARN_d(WARN_INTERNAL))
5621 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
5628 Perl_oopsHV(pTHX_ OP *o)
5631 switch (o->op_type) {
5634 o->op_type = OP_PADHV;
5635 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5636 return ref(o, OP_RV2HV);
5640 o->op_type = OP_RV2HV;
5641 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5646 if (ckWARN_d(WARN_INTERNAL))
5647 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
5654 Perl_newAVREF(pTHX_ OP *o)
5657 if (o->op_type == OP_PADANY) {
5658 o->op_type = OP_PADAV;
5659 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5662 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5663 && ckWARN(WARN_DEPRECATED)) {
5664 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5665 "Using an array as a reference is deprecated");
5667 return newUNOP(OP_RV2AV, 0, scalar(o));
5671 Perl_newGVREF(pTHX_ I32 type, OP *o)
5673 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5674 return newUNOP(OP_NULL, 0, o);
5675 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5679 Perl_newHVREF(pTHX_ OP *o)
5682 if (o->op_type == OP_PADANY) {
5683 o->op_type = OP_PADHV;
5684 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5687 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5688 && ckWARN(WARN_DEPRECATED)) {
5689 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5690 "Using a hash as a reference is deprecated");
5692 return newUNOP(OP_RV2HV, 0, scalar(o));
5696 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5698 return newUNOP(OP_RV2CV, flags, scalar(o));
5702 Perl_newSVREF(pTHX_ OP *o)
5705 if (o->op_type == OP_PADANY) {
5706 o->op_type = OP_PADSV;
5707 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5710 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5711 o->op_flags |= OPpDONE_SVREF;
5714 return newUNOP(OP_RV2SV, 0, scalar(o));
5717 /* Check routines. See the comments at the top of this file for details
5718 * on when these are called */
5721 Perl_ck_anoncode(pTHX_ OP *o)
5723 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
5725 cSVOPo->op_sv = NULL;
5730 Perl_ck_bitop(pTHX_ OP *o)
5733 #define OP_IS_NUMCOMPARE(op) \
5734 ((op) == OP_LT || (op) == OP_I_LT || \
5735 (op) == OP_GT || (op) == OP_I_GT || \
5736 (op) == OP_LE || (op) == OP_I_LE || \
5737 (op) == OP_GE || (op) == OP_I_GE || \
5738 (op) == OP_EQ || (op) == OP_I_EQ || \
5739 (op) == OP_NE || (op) == OP_I_NE || \
5740 (op) == OP_NCMP || (op) == OP_I_NCMP)
5741 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
5742 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
5743 && (o->op_type == OP_BIT_OR
5744 || o->op_type == OP_BIT_AND
5745 || o->op_type == OP_BIT_XOR))
5747 const OP * const left = cBINOPo->op_first;
5748 const OP * const right = left->op_sibling;
5749 if ((OP_IS_NUMCOMPARE(left->op_type) &&
5750 (left->op_flags & OPf_PARENS) == 0) ||
5751 (OP_IS_NUMCOMPARE(right->op_type) &&
5752 (right->op_flags & OPf_PARENS) == 0))
5753 if (ckWARN(WARN_PRECEDENCE))
5754 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
5755 "Possible precedence problem on bitwise %c operator",
5756 o->op_type == OP_BIT_OR ? '|'
5757 : o->op_type == OP_BIT_AND ? '&' : '^'
5764 Perl_ck_concat(pTHX_ OP *o)
5766 const OP * const kid = cUNOPo->op_first;
5767 PERL_UNUSED_CONTEXT;
5768 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
5769 !(kUNOP->op_first->op_flags & OPf_MOD))
5770 o->op_flags |= OPf_STACKED;
5775 Perl_ck_spair(pTHX_ OP *o)
5778 if (o->op_flags & OPf_KIDS) {
5781 const OPCODE type = o->op_type;
5782 o = modkids(ck_fun(o), type);
5783 kid = cUNOPo->op_first;
5784 newop = kUNOP->op_first->op_sibling;
5786 (newop->op_sibling ||
5787 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5788 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5789 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5794 op_getmad(kUNOP->op_first,newop,'K');
5796 op_free(kUNOP->op_first);
5798 kUNOP->op_first = newop;
5800 o->op_ppaddr = PL_ppaddr[++o->op_type];
5805 Perl_ck_delete(pTHX_ OP *o)
5809 if (o->op_flags & OPf_KIDS) {
5810 OP * const kid = cUNOPo->op_first;
5811 switch (kid->op_type) {
5813 o->op_flags |= OPf_SPECIAL;
5816 o->op_private |= OPpSLICE;
5819 o->op_flags |= OPf_SPECIAL;
5824 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5833 Perl_ck_die(pTHX_ OP *o)
5836 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5842 Perl_ck_eof(pTHX_ OP *o)
5846 if (o->op_flags & OPf_KIDS) {
5847 if (cLISTOPo->op_first->op_type == OP_STUB) {
5849 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
5851 op_getmad(o,newop,'O');
5863 Perl_ck_eval(pTHX_ OP *o)
5866 PL_hints |= HINT_BLOCK_SCOPE;
5867 if (o->op_flags & OPf_KIDS) {
5868 SVOP * const kid = (SVOP*)cUNOPo->op_first;
5871 o->op_flags &= ~OPf_KIDS;
5874 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
5880 cUNOPo->op_first = 0;
5885 NewOp(1101, enter, 1, LOGOP);
5886 enter->op_type = OP_ENTERTRY;
5887 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5888 enter->op_private = 0;
5890 /* establish postfix order */
5891 enter->op_next = (OP*)enter;
5893 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5894 o->op_type = OP_LEAVETRY;
5895 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5896 enter->op_other = o;
5897 op_getmad(oldo,o,'O');
5911 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5912 op_getmad(oldo,o,'O');
5914 o->op_targ = (PADOFFSET)PL_hints;
5915 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
5916 /* Store a copy of %^H that pp_entereval can pick up */
5917 OP *hhop = newSVOP(OP_CONST, 0, (SV*)newHVhv(GvHV(PL_hintgv)));
5918 cUNOPo->op_first->op_sibling = hhop;
5919 o->op_private |= OPpEVAL_HAS_HH;
5925 Perl_ck_exit(pTHX_ OP *o)
5928 HV * const table = GvHV(PL_hintgv);
5930 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
5931 if (svp && *svp && SvTRUE(*svp))
5932 o->op_private |= OPpEXIT_VMSISH;
5934 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5940 Perl_ck_exec(pTHX_ OP *o)
5942 if (o->op_flags & OPf_STACKED) {
5945 kid = cUNOPo->op_first->op_sibling;
5946 if (kid->op_type == OP_RV2GV)
5955 Perl_ck_exists(pTHX_ OP *o)
5959 if (o->op_flags & OPf_KIDS) {
5960 OP * const kid = cUNOPo->op_first;
5961 if (kid->op_type == OP_ENTERSUB) {
5962 (void) ref(kid, o->op_type);
5963 if (kid->op_type != OP_RV2CV && !PL_error_count)
5964 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5966 o->op_private |= OPpEXISTS_SUB;
5968 else if (kid->op_type == OP_AELEM)
5969 o->op_flags |= OPf_SPECIAL;
5970 else if (kid->op_type != OP_HELEM)
5971 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5979 Perl_ck_rvconst(pTHX_ register OP *o)
5982 SVOP * const kid = (SVOP*)cUNOPo->op_first;
5984 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5985 if (o->op_type == OP_RV2CV)
5986 o->op_private &= ~1;
5988 if (kid->op_type == OP_CONST) {
5991 SV * const kidsv = kid->op_sv;
5993 /* Is it a constant from cv_const_sv()? */
5994 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5995 SV * const rsv = SvRV(kidsv);
5996 const int svtype = SvTYPE(rsv);
5997 const char *badtype = NULL;
5999 switch (o->op_type) {
6001 if (svtype > SVt_PVMG)
6002 badtype = "a SCALAR";
6005 if (svtype != SVt_PVAV)
6006 badtype = "an ARRAY";
6009 if (svtype != SVt_PVHV)
6013 if (svtype != SVt_PVCV)
6018 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
6021 else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
6022 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
6023 /* If this is an access to a stash, disable "strict refs", because
6024 * stashes aren't auto-vivified at compile-time (unless we store
6025 * symbols in them), and we don't want to produce a run-time
6026 * stricture error when auto-vivifying the stash. */
6027 const char *s = SvPV_nolen(kidsv);
6028 const STRLEN l = SvCUR(kidsv);
6029 if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
6030 o->op_private &= ~HINT_STRICT_REFS;
6032 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
6033 const char *badthing;
6034 switch (o->op_type) {
6036 badthing = "a SCALAR";
6039 badthing = "an ARRAY";
6042 badthing = "a HASH";
6050 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
6054 * This is a little tricky. We only want to add the symbol if we
6055 * didn't add it in the lexer. Otherwise we get duplicate strict
6056 * warnings. But if we didn't add it in the lexer, we must at
6057 * least pretend like we wanted to add it even if it existed before,
6058 * or we get possible typo warnings. OPpCONST_ENTERED says
6059 * whether the lexer already added THIS instance of this symbol.
6061 iscv = (o->op_type == OP_RV2CV) * 2;
6063 gv = gv_fetchsv(kidsv,
6064 iscv | !(kid->op_private & OPpCONST_ENTERED),
6067 : o->op_type == OP_RV2SV
6069 : o->op_type == OP_RV2AV
6071 : o->op_type == OP_RV2HV
6074 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
6076 kid->op_type = OP_GV;
6077 SvREFCNT_dec(kid->op_sv);
6079 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
6080 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
6081 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
6083 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc_simple_NN(gv));
6085 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
6087 kid->op_private = 0;
6088 kid->op_ppaddr = PL_ppaddr[OP_GV];
6095 Perl_ck_ftst(pTHX_ OP *o)
6098 const I32 type = o->op_type;
6100 if (o->op_flags & OPf_REF) {
6103 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
6104 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6106 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6107 OP * const newop = newGVOP(type, OPf_REF,
6108 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
6110 op_getmad(o,newop,'O');
6116 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o))
6117 o->op_private |= OPpFT_ACCESS;
6118 if (PL_check[kid->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst)
6119 && kid->op_type != OP_STAT && kid->op_type != OP_LSTAT)
6120 o->op_private |= OPpFT_STACKED;
6128 if (type == OP_FTTTY)
6129 o = newGVOP(type, OPf_REF, PL_stdingv);
6131 o = newUNOP(type, 0, newDEFSVOP());
6132 op_getmad(oldo,o,'O');
6138 Perl_ck_fun(pTHX_ OP *o)
6141 const int type = o->op_type;
6142 register I32 oa = PL_opargs[type] >> OASHIFT;
6144 if (o->op_flags & OPf_STACKED) {
6145 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
6148 return no_fh_allowed(o);
6151 if (o->op_flags & OPf_KIDS) {
6152 OP **tokid = &cLISTOPo->op_first;
6153 register OP *kid = cLISTOPo->op_first;
6157 if (kid->op_type == OP_PUSHMARK ||
6158 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
6160 tokid = &kid->op_sibling;
6161 kid = kid->op_sibling;
6163 if (!kid && PL_opargs[type] & OA_DEFGV)
6164 *tokid = kid = newDEFSVOP();
6168 sibl = kid->op_sibling;
6170 if (!sibl && kid->op_type == OP_STUB) {
6177 /* list seen where single (scalar) arg expected? */
6178 if (numargs == 1 && !(oa >> 4)
6179 && kid->op_type == OP_LIST && type != OP_SCALAR)
6181 return too_many_arguments(o,PL_op_desc[type]);
6194 if ((type == OP_PUSH || type == OP_UNSHIFT)
6195 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
6196 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6197 "Useless use of %s with no values",
6200 if (kid->op_type == OP_CONST &&
6201 (kid->op_private & OPpCONST_BARE))
6203 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
6204 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
6205 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6206 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6207 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
6208 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
6210 op_getmad(kid,newop,'K');
6215 kid->op_sibling = sibl;
6218 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
6219 bad_type(numargs, "array", PL_op_desc[type], kid);
6223 if (kid->op_type == OP_CONST &&
6224 (kid->op_private & OPpCONST_BARE))
6226 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
6227 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
6228 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6229 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6230 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
6231 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
6233 op_getmad(kid,newop,'K');
6238 kid->op_sibling = sibl;
6241 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
6242 bad_type(numargs, "hash", PL_op_desc[type], kid);
6247 OP * const newop = newUNOP(OP_NULL, 0, kid);
6248 kid->op_sibling = 0;
6250 newop->op_next = newop;
6252 kid->op_sibling = sibl;
6257 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
6258 if (kid->op_type == OP_CONST &&
6259 (kid->op_private & OPpCONST_BARE))
6261 OP * const newop = newGVOP(OP_GV, 0,
6262 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
6263 if (!(o->op_private & 1) && /* if not unop */
6264 kid == cLISTOPo->op_last)
6265 cLISTOPo->op_last = newop;
6267 op_getmad(kid,newop,'K');
6273 else if (kid->op_type == OP_READLINE) {
6274 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
6275 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
6278 I32 flags = OPf_SPECIAL;
6282 /* is this op a FH constructor? */
6283 if (is_handle_constructor(o,numargs)) {
6284 const char *name = NULL;
6288 /* Set a flag to tell rv2gv to vivify
6289 * need to "prove" flag does not mean something
6290 * else already - NI-S 1999/05/07
6293 if (kid->op_type == OP_PADSV) {
6294 name = PAD_COMPNAME_PV(kid->op_targ);
6295 /* SvCUR of a pad namesv can't be trusted
6296 * (see PL_generation), so calc its length
6302 else if (kid->op_type == OP_RV2SV
6303 && kUNOP->op_first->op_type == OP_GV)
6305 GV * const gv = cGVOPx_gv(kUNOP->op_first);
6307 len = GvNAMELEN(gv);
6309 else if (kid->op_type == OP_AELEM
6310 || kid->op_type == OP_HELEM)
6312 OP *op = ((BINOP*)kid)->op_first;
6316 const char * const a =
6317 kid->op_type == OP_AELEM ?
6319 if (((op->op_type == OP_RV2AV) ||
6320 (op->op_type == OP_RV2HV)) &&
6321 (op = ((UNOP*)op)->op_first) &&
6322 (op->op_type == OP_GV)) {
6323 /* packagevar $a[] or $h{} */
6324 GV * const gv = cGVOPx_gv(op);
6332 else if (op->op_type == OP_PADAV
6333 || op->op_type == OP_PADHV) {
6334 /* lexicalvar $a[] or $h{} */
6335 const char * const padname =
6336 PAD_COMPNAME_PV(op->op_targ);
6345 name = SvPV_const(tmpstr, len);
6350 name = "__ANONIO__";
6357 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
6358 namesv = PAD_SVl(targ);
6359 SvUPGRADE(namesv, SVt_PV);
6361 sv_setpvn(namesv, "$", 1);
6362 sv_catpvn(namesv, name, len);
6365 kid->op_sibling = 0;
6366 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
6367 kid->op_targ = targ;
6368 kid->op_private |= priv;
6370 kid->op_sibling = sibl;
6376 mod(scalar(kid), type);
6380 tokid = &kid->op_sibling;
6381 kid = kid->op_sibling;
6384 if (kid && kid->op_type != OP_STUB)
6385 return too_many_arguments(o,OP_DESC(o));
6386 o->op_private |= numargs;
6388 /* FIXME - should the numargs move as for the PERL_MAD case? */
6389 o->op_private |= numargs;
6391 return too_many_arguments(o,OP_DESC(o));
6395 else if (PL_opargs[type] & OA_DEFGV) {
6397 OP *newop = newUNOP(type, 0, newDEFSVOP());
6398 op_getmad(o,newop,'O');
6401 /* Ordering of these two is important to keep f_map.t passing. */
6403 return newUNOP(type, 0, newDEFSVOP());
6408 while (oa & OA_OPTIONAL)
6410 if (oa && oa != OA_LIST)
6411 return too_few_arguments(o,OP_DESC(o));
6417 Perl_ck_glob(pTHX_ OP *o)
6423 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
6424 append_elem(OP_GLOB, o, newDEFSVOP());
6426 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
6427 && GvCVu(gv) && GvIMPORTED_CV(gv)))
6429 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6432 #if !defined(PERL_EXTERNAL_GLOB)
6433 /* XXX this can be tightened up and made more failsafe. */
6434 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
6437 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
6438 newSVpvs("File::Glob"), NULL, NULL, NULL);
6439 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6440 glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
6441 GvCV(gv) = GvCV(glob_gv);
6442 SvREFCNT_inc_void((SV*)GvCV(gv));
6443 GvIMPORTED_CV_on(gv);
6446 #endif /* PERL_EXTERNAL_GLOB */
6448 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6449 append_elem(OP_GLOB, o,
6450 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
6451 o->op_type = OP_LIST;
6452 o->op_ppaddr = PL_ppaddr[OP_LIST];
6453 cLISTOPo->op_first->op_type = OP_PUSHMARK;
6454 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
6455 cLISTOPo->op_first->op_targ = 0;
6456 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
6457 append_elem(OP_LIST, o,
6458 scalar(newUNOP(OP_RV2CV, 0,
6459 newGVOP(OP_GV, 0, gv)))));
6460 o = newUNOP(OP_NULL, 0, ck_subr(o));
6461 o->op_targ = OP_GLOB; /* hint at what it used to be */
6464 gv = newGVgen("main");
6466 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
6472 Perl_ck_grep(pTHX_ OP *o)
6477 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
6480 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
6481 /* don't allocate gwop here, as we may leak it if PL_error_count > 0 */
6483 if (o->op_flags & OPf_STACKED) {
6486 kid = cLISTOPo->op_first->op_sibling;
6487 if (!cUNOPx(kid)->op_next)
6488 Perl_croak(aTHX_ "panic: ck_grep");
6489 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
6492 NewOp(1101, gwop, 1, LOGOP);
6493 kid->op_next = (OP*)gwop;
6494 o->op_flags &= ~OPf_STACKED;
6496 kid = cLISTOPo->op_first->op_sibling;
6497 if (type == OP_MAPWHILE)
6504 kid = cLISTOPo->op_first->op_sibling;
6505 if (kid->op_type != OP_NULL)
6506 Perl_croak(aTHX_ "panic: ck_grep");
6507 kid = kUNOP->op_first;
6510 NewOp(1101, gwop, 1, LOGOP);
6511 gwop->op_type = type;
6512 gwop->op_ppaddr = PL_ppaddr[type];
6513 gwop->op_first = listkids(o);
6514 gwop->op_flags |= OPf_KIDS;
6515 gwop->op_other = LINKLIST(kid);
6516 kid->op_next = (OP*)gwop;
6517 offset = pad_findmy("$_");
6518 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
6519 o->op_private = gwop->op_private = 0;
6520 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
6523 o->op_private = gwop->op_private = OPpGREP_LEX;
6524 gwop->op_targ = o->op_targ = offset;
6527 kid = cLISTOPo->op_first->op_sibling;
6528 if (!kid || !kid->op_sibling)
6529 return too_few_arguments(o,OP_DESC(o));
6530 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
6531 mod(kid, OP_GREPSTART);
6537 Perl_ck_index(pTHX_ OP *o)
6539 if (o->op_flags & OPf_KIDS) {
6540 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6542 kid = kid->op_sibling; /* get past "big" */
6543 if (kid && kid->op_type == OP_CONST)
6544 fbm_compile(((SVOP*)kid)->op_sv, 0);
6550 Perl_ck_lengthconst(pTHX_ OP *o)
6552 /* XXX length optimization goes here */
6557 Perl_ck_lfun(pTHX_ OP *o)
6559 const OPCODE type = o->op_type;
6560 return modkids(ck_fun(o), type);
6564 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
6566 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
6567 switch (cUNOPo->op_first->op_type) {
6569 /* This is needed for
6570 if (defined %stash::)
6571 to work. Do not break Tk.
6573 break; /* Globals via GV can be undef */
6575 case OP_AASSIGN: /* Is this a good idea? */
6576 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6577 "defined(@array) is deprecated");
6578 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6579 "\t(Maybe you should just omit the defined()?)\n");
6582 /* This is needed for
6583 if (defined %stash::)
6584 to work. Do not break Tk.
6586 break; /* Globals via GV can be undef */
6588 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6589 "defined(%%hash) is deprecated");
6590 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6591 "\t(Maybe you should just omit the defined()?)\n");
6602 Perl_ck_rfun(pTHX_ OP *o)
6604 const OPCODE type = o->op_type;
6605 return refkids(ck_fun(o), type);
6609 Perl_ck_listiob(pTHX_ OP *o)
6613 kid = cLISTOPo->op_first;
6616 kid = cLISTOPo->op_first;
6618 if (kid->op_type == OP_PUSHMARK)
6619 kid = kid->op_sibling;
6620 if (kid && o->op_flags & OPf_STACKED)
6621 kid = kid->op_sibling;
6622 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6623 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6624 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6625 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6626 cLISTOPo->op_first->op_sibling = kid;
6627 cLISTOPo->op_last = kid;
6628 kid = kid->op_sibling;
6633 append_elem(o->op_type, o, newDEFSVOP());
6639 Perl_ck_say(pTHX_ OP *o)
6642 o->op_type = OP_PRINT;
6643 cLISTOPo->op_last = cLISTOPo->op_last->op_sibling
6644 = newSVOP(OP_CONST, 0, newSVpvs("\n"));
6649 Perl_ck_smartmatch(pTHX_ OP *o)
6652 if (0 == (o->op_flags & OPf_SPECIAL)) {
6653 OP *first = cBINOPo->op_first;
6654 OP *second = first->op_sibling;
6656 /* Implicitly take a reference to an array or hash */
6657 first->op_sibling = NULL;
6658 first = cBINOPo->op_first = ref_array_or_hash(first);
6659 second = first->op_sibling = ref_array_or_hash(second);
6661 /* Implicitly take a reference to a regular expression */
6662 if (first->op_type == OP_MATCH) {
6663 first->op_type = OP_QR;
6664 first->op_ppaddr = PL_ppaddr[OP_QR];
6666 if (second->op_type == OP_MATCH) {
6667 second->op_type = OP_QR;
6668 second->op_ppaddr = PL_ppaddr[OP_QR];
6677 Perl_ck_sassign(pTHX_ OP *o)
6679 OP *kid = cLISTOPo->op_first;
6680 /* has a disposable target? */
6681 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6682 && !(kid->op_flags & OPf_STACKED)
6683 /* Cannot steal the second time! */
6684 && !(kid->op_private & OPpTARGET_MY))
6686 OP * const kkid = kid->op_sibling;
6688 /* Can just relocate the target. */
6689 if (kkid && kkid->op_type == OP_PADSV
6690 && !(kkid->op_private & OPpLVAL_INTRO))
6692 kid->op_targ = kkid->op_targ;
6694 /* Now we do not need PADSV and SASSIGN. */
6695 kid->op_sibling = o->op_sibling; /* NULL */
6696 cLISTOPo->op_first = NULL;
6698 op_getmad(o,kid,'O');
6699 op_getmad(kkid,kid,'M');
6704 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6712 Perl_ck_match(pTHX_ OP *o)
6715 if (o->op_type != OP_QR && PL_compcv) {
6716 const I32 offset = pad_findmy("$_");
6717 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
6718 o->op_targ = offset;
6719 o->op_private |= OPpTARGET_MY;
6722 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
6723 o->op_private |= OPpRUNTIME;
6728 Perl_ck_method(pTHX_ OP *o)
6730 OP * const kid = cUNOPo->op_first;
6731 if (kid->op_type == OP_CONST) {
6732 SV* sv = kSVOP->op_sv;
6733 const char * const method = SvPVX_const(sv);
6734 if (!(strchr(method, ':') || strchr(method, '\''))) {
6736 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6737 sv = newSVpvn_share(method, SvCUR(sv), 0);
6740 kSVOP->op_sv = NULL;
6742 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6744 op_getmad(o,cmop,'O');
6755 Perl_ck_null(pTHX_ OP *o)
6757 PERL_UNUSED_CONTEXT;
6762 Perl_ck_open(pTHX_ OP *o)
6765 HV * const table = GvHV(PL_hintgv);
6767 SV **svp = hv_fetchs(table, "open_IN", FALSE);
6769 const I32 mode = mode_from_discipline(*svp);
6770 if (mode & O_BINARY)
6771 o->op_private |= OPpOPEN_IN_RAW;
6772 else if (mode & O_TEXT)
6773 o->op_private |= OPpOPEN_IN_CRLF;
6776 svp = hv_fetchs(table, "open_OUT", FALSE);
6778 const I32 mode = mode_from_discipline(*svp);
6779 if (mode & O_BINARY)
6780 o->op_private |= OPpOPEN_OUT_RAW;
6781 else if (mode & O_TEXT)
6782 o->op_private |= OPpOPEN_OUT_CRLF;
6785 if (o->op_type == OP_BACKTICK)
6788 /* In case of three-arg dup open remove strictness
6789 * from the last arg if it is a bareword. */
6790 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
6791 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
6795 if ((last->op_type == OP_CONST) && /* The bareword. */
6796 (last->op_private & OPpCONST_BARE) &&
6797 (last->op_private & OPpCONST_STRICT) &&
6798 (oa = first->op_sibling) && /* The fh. */
6799 (oa = oa->op_sibling) && /* The mode. */
6800 (oa->op_type == OP_CONST) &&
6801 SvPOK(((SVOP*)oa)->op_sv) &&
6802 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
6803 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
6804 (last == oa->op_sibling)) /* The bareword. */
6805 last->op_private &= ~OPpCONST_STRICT;
6811 Perl_ck_repeat(pTHX_ OP *o)
6813 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6814 o->op_private |= OPpREPEAT_DOLIST;
6815 cBINOPo->op_first = force_list(cBINOPo->op_first);
6823 Perl_ck_require(pTHX_ OP *o)
6828 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6829 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6831 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6832 SV * const sv = kid->op_sv;
6833 U32 was_readonly = SvREADONLY(sv);
6838 sv_force_normal_flags(sv, 0);
6839 assert(!SvREADONLY(sv));
6846 for (s = SvPVX(sv); *s; s++) {
6847 if (*s == ':' && s[1] == ':') {
6848 const STRLEN len = strlen(s+2)+1;
6850 Move(s+2, s+1, len, char);
6851 SvCUR_set(sv, SvCUR(sv) - 1);
6854 sv_catpvs(sv, ".pm");
6855 SvFLAGS(sv) |= was_readonly;
6859 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
6860 /* handle override, if any */
6861 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
6862 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
6863 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
6864 gv = gvp ? *gvp : NULL;
6868 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6869 OP * const kid = cUNOPo->op_first;
6872 cUNOPo->op_first = 0;
6876 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
6877 append_elem(OP_LIST, kid,
6878 scalar(newUNOP(OP_RV2CV, 0,
6881 op_getmad(o,newop,'O');
6889 Perl_ck_return(pTHX_ OP *o)
6892 if (CvLVALUE(PL_compcv)) {
6894 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6895 mod(kid, OP_LEAVESUBLV);
6901 Perl_ck_select(pTHX_ OP *o)
6905 if (o->op_flags & OPf_KIDS) {
6906 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6907 if (kid && kid->op_sibling) {
6908 o->op_type = OP_SSELECT;
6909 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6911 return fold_constants(o);
6915 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6916 if (kid && kid->op_type == OP_RV2GV)
6917 kid->op_private &= ~HINT_STRICT_REFS;
6922 Perl_ck_shift(pTHX_ OP *o)
6925 const I32 type = o->op_type;
6927 if (!(o->op_flags & OPf_KIDS)) {
6929 /* FIXME - this can be refactored to reduce code in #ifdefs */
6931 OP * const oldo = o;
6935 argop = newUNOP(OP_RV2AV, 0,
6936 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
6938 o = newUNOP(type, 0, scalar(argop));
6939 op_getmad(oldo,o,'O');
6942 return newUNOP(type, 0, scalar(argop));
6945 return scalar(modkids(ck_fun(o), type));
6949 Perl_ck_sort(pTHX_ OP *o)
6954 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0)
6956 HV * const hinthv = GvHV(PL_hintgv);
6958 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
6960 const I32 sorthints = (I32)SvIV(*svp);
6961 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
6962 o->op_private |= OPpSORT_QSORT;
6963 if ((sorthints & HINT_SORT_STABLE) != 0)
6964 o->op_private |= OPpSORT_STABLE;
6969 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6971 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6972 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6974 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6976 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6978 if (kid->op_type == OP_SCOPE) {
6982 else if (kid->op_type == OP_LEAVE) {
6983 if (o->op_type == OP_SORT) {
6984 op_null(kid); /* wipe out leave */
6987 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6988 if (k->op_next == kid)
6990 /* don't descend into loops */
6991 else if (k->op_type == OP_ENTERLOOP
6992 || k->op_type == OP_ENTERITER)
6994 k = cLOOPx(k)->op_lastop;
6999 kid->op_next = 0; /* just disconnect the leave */
7000 k = kLISTOP->op_first;
7005 if (o->op_type == OP_SORT) {
7006 /* provide scalar context for comparison function/block */
7012 o->op_flags |= OPf_SPECIAL;
7014 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
7017 firstkid = firstkid->op_sibling;
7020 /* provide list context for arguments */
7021 if (o->op_type == OP_SORT)
7028 S_simplify_sort(pTHX_ OP *o)
7031 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7036 if (!(o->op_flags & OPf_STACKED))
7038 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7039 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
7040 kid = kUNOP->op_first; /* get past null */
7041 if (kid->op_type != OP_SCOPE)
7043 kid = kLISTOP->op_last; /* get past scope */
7044 switch(kid->op_type) {
7052 k = kid; /* remember this node*/
7053 if (kBINOP->op_first->op_type != OP_RV2SV)
7055 kid = kBINOP->op_first; /* get past cmp */
7056 if (kUNOP->op_first->op_type != OP_GV)
7058 kid = kUNOP->op_first; /* get past rv2sv */
7060 if (GvSTASH(gv) != PL_curstash)
7062 gvname = GvNAME(gv);
7063 if (*gvname == 'a' && gvname[1] == '\0')
7065 else if (*gvname == 'b' && gvname[1] == '\0')
7070 kid = k; /* back to cmp */
7071 if (kBINOP->op_last->op_type != OP_RV2SV)
7073 kid = kBINOP->op_last; /* down to 2nd arg */
7074 if (kUNOP->op_first->op_type != OP_GV)
7076 kid = kUNOP->op_first; /* get past rv2sv */
7078 if (GvSTASH(gv) != PL_curstash)
7080 gvname = GvNAME(gv);
7082 ? !(*gvname == 'a' && gvname[1] == '\0')
7083 : !(*gvname == 'b' && gvname[1] == '\0'))
7085 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
7087 o->op_private |= OPpSORT_DESCEND;
7088 if (k->op_type == OP_NCMP)
7089 o->op_private |= OPpSORT_NUMERIC;
7090 if (k->op_type == OP_I_NCMP)
7091 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
7092 kid = cLISTOPo->op_first->op_sibling;
7093 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
7095 op_getmad(kid,o,'S'); /* then delete it */
7097 op_free(kid); /* then delete it */
7102 Perl_ck_split(pTHX_ OP *o)
7107 if (o->op_flags & OPf_STACKED)
7108 return no_fh_allowed(o);
7110 kid = cLISTOPo->op_first;
7111 if (kid->op_type != OP_NULL)
7112 Perl_croak(aTHX_ "panic: ck_split");
7113 kid = kid->op_sibling;
7114 op_free(cLISTOPo->op_first);
7115 cLISTOPo->op_first = kid;
7117 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
7118 cLISTOPo->op_last = kid; /* There was only one element previously */
7121 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
7122 OP * const sibl = kid->op_sibling;
7123 kid->op_sibling = 0;
7124 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
7125 if (cLISTOPo->op_first == cLISTOPo->op_last)
7126 cLISTOPo->op_last = kid;
7127 cLISTOPo->op_first = kid;
7128 kid->op_sibling = sibl;
7131 kid->op_type = OP_PUSHRE;
7132 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
7134 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
7135 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
7136 "Use of /g modifier is meaningless in split");
7139 if (!kid->op_sibling)
7140 append_elem(OP_SPLIT, o, newDEFSVOP());
7142 kid = kid->op_sibling;
7145 if (!kid->op_sibling)
7146 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
7148 kid = kid->op_sibling;
7151 if (kid->op_sibling)
7152 return too_many_arguments(o,OP_DESC(o));
7158 Perl_ck_join(pTHX_ OP *o)
7160 const OP * const kid = cLISTOPo->op_first->op_sibling;
7161 if (kid && kid->op_type == OP_MATCH) {
7162 if (ckWARN(WARN_SYNTAX)) {
7163 const REGEXP *re = PM_GETRE(kPMOP);
7164 const char *pmstr = re ? re->precomp : "STRING";
7165 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7166 "/%s/ should probably be written as \"%s\"",
7174 Perl_ck_subr(pTHX_ OP *o)
7177 OP *prev = ((cUNOPo->op_first->op_sibling)
7178 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
7179 OP *o2 = prev->op_sibling;
7186 I32 contextclass = 0;
7190 o->op_private |= OPpENTERSUB_HASTARG;
7191 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
7192 if (cvop->op_type == OP_RV2CV) {
7194 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
7195 op_null(cvop); /* disable rv2cv */
7196 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
7197 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
7198 GV *gv = cGVOPx_gv(tmpop);
7201 tmpop->op_private |= OPpEARLY_CV;
7204 namegv = CvANON(cv) ? gv : CvGV(cv);
7205 proto = SvPV_nolen((SV*)cv);
7207 if (CvASSERTION(cv)) {
7208 if (PL_hints & HINT_ASSERTING) {
7209 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
7210 o->op_private |= OPpENTERSUB_DB;
7214 if (!(PL_hints & HINT_ASSERTIONSSEEN) && ckWARN(WARN_ASSERTIONS)) {
7215 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
7216 "Impossible to activate assertion call");
7223 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7224 if (o2->op_type == OP_CONST)
7225 o2->op_private &= ~OPpCONST_STRICT;
7226 else if (o2->op_type == OP_LIST) {
7227 OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
7228 if (sib && sib->op_type == OP_CONST)
7229 sib->op_private &= ~OPpCONST_STRICT;
7232 o->op_private |= (PL_hints & HINT_STRICT_REFS);
7233 if (PERLDB_SUB && PL_curstash != PL_debstash)
7234 o->op_private |= OPpENTERSUB_DB;
7235 while (o2 != cvop) {
7237 if (PL_madskills && o2->op_type == OP_NULL)
7238 o3 = ((UNOP*)o2)->op_first;
7244 return too_many_arguments(o, gv_ename(namegv));
7262 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
7264 arg == 1 ? "block or sub {}" : "sub {}",
7265 gv_ename(namegv), o3);
7268 /* '*' allows any scalar type, including bareword */
7271 if (o3->op_type == OP_RV2GV)
7272 goto wrapref; /* autoconvert GLOB -> GLOBref */
7273 else if (o3->op_type == OP_CONST)
7274 o3->op_private &= ~OPpCONST_STRICT;
7275 else if (o3->op_type == OP_ENTERSUB) {
7276 /* accidental subroutine, revert to bareword */
7277 OP *gvop = ((UNOP*)o3)->op_first;
7278 if (gvop && gvop->op_type == OP_NULL) {
7279 gvop = ((UNOP*)gvop)->op_first;
7281 for (; gvop->op_sibling; gvop = gvop->op_sibling)
7284 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
7285 (gvop = ((UNOP*)gvop)->op_first) &&
7286 gvop->op_type == OP_GV)
7288 GV * const gv = cGVOPx_gv(gvop);
7289 OP * const sibling = o2->op_sibling;
7290 SV * const n = newSVpvs("");
7292 OP * const oldo2 = o2;
7296 gv_fullname4(n, gv, "", FALSE);
7297 o2 = newSVOP(OP_CONST, 0, n);
7298 op_getmad(oldo2,o2,'O');
7299 prev->op_sibling = o2;
7300 o2->op_sibling = sibling;
7316 if (contextclass++ == 0) {
7317 e = strchr(proto, ']');
7318 if (!e || e == proto)
7327 /* XXX We shouldn't be modifying proto, so we can const proto */
7332 while (*--p != '[');
7333 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
7334 gv_ename(namegv), o3);
7340 if (o3->op_type == OP_RV2GV)
7343 bad_type(arg, "symbol", gv_ename(namegv), o3);
7346 if (o3->op_type == OP_ENTERSUB)
7349 bad_type(arg, "subroutine entry", gv_ename(namegv),
7353 if (o3->op_type == OP_RV2SV ||
7354 o3->op_type == OP_PADSV ||
7355 o3->op_type == OP_HELEM ||
7356 o3->op_type == OP_AELEM ||
7357 o3->op_type == OP_THREADSV)
7360 bad_type(arg, "scalar", gv_ename(namegv), o3);
7363 if (o3->op_type == OP_RV2AV ||
7364 o3->op_type == OP_PADAV)
7367 bad_type(arg, "array", gv_ename(namegv), o3);
7370 if (o3->op_type == OP_RV2HV ||
7371 o3->op_type == OP_PADHV)
7374 bad_type(arg, "hash", gv_ename(namegv), o3);
7379 OP* const sib = kid->op_sibling;
7380 kid->op_sibling = 0;
7381 o2 = newUNOP(OP_REFGEN, 0, kid);
7382 o2->op_sibling = sib;
7383 prev->op_sibling = o2;
7385 if (contextclass && e) {
7400 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
7401 gv_ename(namegv), cv);
7406 mod(o2, OP_ENTERSUB);
7408 o2 = o2->op_sibling;
7410 if (proto && !optional &&
7411 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
7412 return too_few_arguments(o, gv_ename(namegv));
7415 OP * const oldo = o;
7419 o=newSVOP(OP_CONST, 0, newSViv(0));
7420 op_getmad(oldo,o,'O');
7426 Perl_ck_svconst(pTHX_ OP *o)
7428 PERL_UNUSED_CONTEXT;
7429 SvREADONLY_on(cSVOPo->op_sv);
7434 Perl_ck_chdir(pTHX_ OP *o)
7436 if (o->op_flags & OPf_KIDS) {
7437 SVOP *kid = (SVOP*)cUNOPo->op_first;
7439 if (kid && kid->op_type == OP_CONST &&
7440 (kid->op_private & OPpCONST_BARE))
7442 o->op_flags |= OPf_SPECIAL;
7443 kid->op_private &= ~OPpCONST_STRICT;
7450 Perl_ck_trunc(pTHX_ OP *o)
7452 if (o->op_flags & OPf_KIDS) {
7453 SVOP *kid = (SVOP*)cUNOPo->op_first;
7455 if (kid->op_type == OP_NULL)
7456 kid = (SVOP*)kid->op_sibling;
7457 if (kid && kid->op_type == OP_CONST &&
7458 (kid->op_private & OPpCONST_BARE))
7460 o->op_flags |= OPf_SPECIAL;
7461 kid->op_private &= ~OPpCONST_STRICT;
7468 Perl_ck_unpack(pTHX_ OP *o)
7470 OP *kid = cLISTOPo->op_first;
7471 if (kid->op_sibling) {
7472 kid = kid->op_sibling;
7473 if (!kid->op_sibling)
7474 kid->op_sibling = newDEFSVOP();
7480 Perl_ck_substr(pTHX_ OP *o)
7483 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
7484 OP *kid = cLISTOPo->op_first;
7486 if (kid->op_type == OP_NULL)
7487 kid = kid->op_sibling;
7489 kid->op_flags |= OPf_MOD;
7495 /* A peephole optimizer. We visit the ops in the order they're to execute.
7496 * See the comments at the top of this file for more details about when
7497 * peep() is called */
7500 Perl_peep(pTHX_ register OP *o)
7503 register OP* oldop = NULL;
7505 if (!o || o->op_opt)
7509 SAVEVPTR(PL_curcop);
7510 for (; o; o = o->op_next) {
7514 switch (o->op_type) {
7518 PL_curcop = ((COP*)o); /* for warnings */
7523 if (cSVOPo->op_private & OPpCONST_STRICT)
7524 no_bareword_allowed(o);
7526 case OP_METHOD_NAMED:
7527 /* Relocate sv to the pad for thread safety.
7528 * Despite being a "constant", the SV is written to,
7529 * for reference counts, sv_upgrade() etc. */
7531 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
7532 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
7533 /* If op_sv is already a PADTMP then it is being used by
7534 * some pad, so make a copy. */
7535 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
7536 SvREADONLY_on(PAD_SVl(ix));
7537 SvREFCNT_dec(cSVOPo->op_sv);
7539 else if (o->op_type == OP_CONST
7540 && cSVOPo->op_sv == &PL_sv_undef) {
7541 /* PL_sv_undef is hack - it's unsafe to store it in the
7542 AV that is the pad, because av_fetch treats values of
7543 PL_sv_undef as a "free" AV entry and will merrily
7544 replace them with a new SV, causing pad_alloc to think
7545 that this pad slot is free. (When, clearly, it is not)
7547 SvOK_off(PAD_SVl(ix));
7548 SvPADTMP_on(PAD_SVl(ix));
7549 SvREADONLY_on(PAD_SVl(ix));
7552 SvREFCNT_dec(PAD_SVl(ix));
7553 SvPADTMP_on(cSVOPo->op_sv);
7554 PAD_SETSV(ix, cSVOPo->op_sv);
7555 /* XXX I don't know how this isn't readonly already. */
7556 SvREADONLY_on(PAD_SVl(ix));
7558 cSVOPo->op_sv = NULL;
7566 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
7567 if (o->op_next->op_private & OPpTARGET_MY) {
7568 if (o->op_flags & OPf_STACKED) /* chained concats */
7569 goto ignore_optimization;
7571 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
7572 o->op_targ = o->op_next->op_targ;
7573 o->op_next->op_targ = 0;
7574 o->op_private |= OPpTARGET_MY;
7577 op_null(o->op_next);
7579 ignore_optimization:
7583 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
7585 break; /* Scalar stub must produce undef. List stub is noop */
7589 if (o->op_targ == OP_NEXTSTATE
7590 || o->op_targ == OP_DBSTATE
7591 || o->op_targ == OP_SETSTATE)
7593 PL_curcop = ((COP*)o);
7595 /* XXX: We avoid setting op_seq here to prevent later calls
7596 to peep() from mistakenly concluding that optimisation
7597 has already occurred. This doesn't fix the real problem,
7598 though (See 20010220.007). AMS 20010719 */
7599 /* op_seq functionality is now replaced by op_opt */
7600 if (oldop && o->op_next) {
7601 oldop->op_next = o->op_next;
7609 if (oldop && o->op_next) {
7610 oldop->op_next = o->op_next;
7618 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
7619 OP* const pop = (o->op_type == OP_PADAV) ?
7620 o->op_next : o->op_next->op_next;
7622 if (pop && pop->op_type == OP_CONST &&
7623 ((PL_op = pop->op_next)) &&
7624 pop->op_next->op_type == OP_AELEM &&
7625 !(pop->op_next->op_private &
7626 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
7627 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
7632 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
7633 no_bareword_allowed(pop);
7634 if (o->op_type == OP_GV)
7635 op_null(o->op_next);
7636 op_null(pop->op_next);
7638 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
7639 o->op_next = pop->op_next->op_next;
7640 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
7641 o->op_private = (U8)i;
7642 if (o->op_type == OP_GV) {
7647 o->op_flags |= OPf_SPECIAL;
7648 o->op_type = OP_AELEMFAST;
7654 if (o->op_next->op_type == OP_RV2SV) {
7655 if (!(o->op_next->op_private & OPpDEREF)) {
7656 op_null(o->op_next);
7657 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
7659 o->op_next = o->op_next->op_next;
7660 o->op_type = OP_GVSV;
7661 o->op_ppaddr = PL_ppaddr[OP_GVSV];
7664 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
7665 GV * const gv = cGVOPo_gv;
7666 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
7667 /* XXX could check prototype here instead of just carping */
7668 SV * const sv = sv_newmortal();
7669 gv_efullname3(sv, gv, NULL);
7670 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
7671 "%"SVf"() called too early to check prototype",
7675 else if (o->op_next->op_type == OP_READLINE
7676 && o->op_next->op_next->op_type == OP_CONCAT
7677 && (o->op_next->op_next->op_flags & OPf_STACKED))
7679 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
7680 o->op_type = OP_RCATLINE;
7681 o->op_flags |= OPf_STACKED;
7682 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
7683 op_null(o->op_next->op_next);
7684 op_null(o->op_next);
7701 while (cLOGOP->op_other->op_type == OP_NULL)
7702 cLOGOP->op_other = cLOGOP->op_other->op_next;
7703 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
7709 while (cLOOP->op_redoop->op_type == OP_NULL)
7710 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
7711 peep(cLOOP->op_redoop);
7712 while (cLOOP->op_nextop->op_type == OP_NULL)
7713 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
7714 peep(cLOOP->op_nextop);
7715 while (cLOOP->op_lastop->op_type == OP_NULL)
7716 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
7717 peep(cLOOP->op_lastop);
7724 while (cPMOP->op_pmreplstart &&
7725 cPMOP->op_pmreplstart->op_type == OP_NULL)
7726 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
7727 peep(cPMOP->op_pmreplstart);
7732 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
7733 && ckWARN(WARN_SYNTAX))
7735 if (o->op_next->op_sibling &&
7736 o->op_next->op_sibling->op_type != OP_EXIT &&
7737 o->op_next->op_sibling->op_type != OP_WARN &&
7738 o->op_next->op_sibling->op_type != OP_DIE) {
7739 const line_t oldline = CopLINE(PL_curcop);
7741 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
7742 Perl_warner(aTHX_ packWARN(WARN_EXEC),
7743 "Statement unlikely to be reached");
7744 Perl_warner(aTHX_ packWARN(WARN_EXEC),
7745 "\t(Maybe you meant system() when you said exec()?)\n");
7746 CopLINE_set(PL_curcop, oldline);
7756 const char *key = NULL;
7761 if (((BINOP*)o)->op_last->op_type != OP_CONST)
7764 /* Make the CONST have a shared SV */
7765 svp = cSVOPx_svp(((BINOP*)o)->op_last);
7766 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
7767 key = SvPV_const(sv, keylen);
7768 lexname = newSVpvn_share(key,
7769 SvUTF8(sv) ? -(I32)keylen : keylen,
7775 if ((o->op_private & (OPpLVAL_INTRO)))
7778 rop = (UNOP*)((BINOP*)o)->op_first;
7779 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7781 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7782 if (!SvPAD_TYPED(lexname))
7784 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
7785 if (!fields || !GvHV(*fields))
7787 key = SvPV_const(*svp, keylen);
7788 if (!hv_fetch(GvHV(*fields), key,
7789 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
7791 Perl_croak(aTHX_ "No such class field \"%s\" "
7792 "in variable %s of type %s",
7793 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
7806 SVOP *first_key_op, *key_op;
7808 if ((o->op_private & (OPpLVAL_INTRO))
7809 /* I bet there's always a pushmark... */
7810 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
7811 /* hmmm, no optimization if list contains only one key. */
7813 rop = (UNOP*)((LISTOP*)o)->op_last;
7814 if (rop->op_type != OP_RV2HV)
7816 if (rop->op_first->op_type == OP_PADSV)
7817 /* @$hash{qw(keys here)} */
7818 rop = (UNOP*)rop->op_first;
7820 /* @{$hash}{qw(keys here)} */
7821 if (rop->op_first->op_type == OP_SCOPE
7822 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
7824 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
7830 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
7831 if (!SvPAD_TYPED(lexname))
7833 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
7834 if (!fields || !GvHV(*fields))
7836 /* Again guessing that the pushmark can be jumped over.... */
7837 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
7838 ->op_first->op_sibling;
7839 for (key_op = first_key_op; key_op;
7840 key_op = (SVOP*)key_op->op_sibling) {
7841 if (key_op->op_type != OP_CONST)
7843 svp = cSVOPx_svp(key_op);
7844 key = SvPV_const(*svp, keylen);
7845 if (!hv_fetch(GvHV(*fields), key,
7846 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
7848 Perl_croak(aTHX_ "No such class field \"%s\" "
7849 "in variable %s of type %s",
7850 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
7857 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
7861 /* check that RHS of sort is a single plain array */
7862 OP *oright = cUNOPo->op_first;
7863 if (!oright || oright->op_type != OP_PUSHMARK)
7866 /* reverse sort ... can be optimised. */
7867 if (!cUNOPo->op_sibling) {
7868 /* Nothing follows us on the list. */
7869 OP * const reverse = o->op_next;
7871 if (reverse->op_type == OP_REVERSE &&
7872 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
7873 OP * const pushmark = cUNOPx(reverse)->op_first;
7874 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
7875 && (cUNOPx(pushmark)->op_sibling == o)) {
7876 /* reverse -> pushmark -> sort */
7877 o->op_private |= OPpSORT_REVERSE;
7879 pushmark->op_next = oright->op_next;
7885 /* make @a = sort @a act in-place */
7889 oright = cUNOPx(oright)->op_sibling;
7892 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
7893 oright = cUNOPx(oright)->op_sibling;
7897 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
7898 || oright->op_next != o
7899 || (oright->op_private & OPpLVAL_INTRO)
7903 /* o2 follows the chain of op_nexts through the LHS of the
7904 * assign (if any) to the aassign op itself */
7906 if (!o2 || o2->op_type != OP_NULL)
7909 if (!o2 || o2->op_type != OP_PUSHMARK)
7912 if (o2 && o2->op_type == OP_GV)
7915 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
7916 || (o2->op_private & OPpLVAL_INTRO)
7921 if (!o2 || o2->op_type != OP_NULL)
7924 if (!o2 || o2->op_type != OP_AASSIGN
7925 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
7928 /* check that the sort is the first arg on RHS of assign */
7930 o2 = cUNOPx(o2)->op_first;
7931 if (!o2 || o2->op_type != OP_NULL)
7933 o2 = cUNOPx(o2)->op_first;
7934 if (!o2 || o2->op_type != OP_PUSHMARK)
7936 if (o2->op_sibling != o)
7939 /* check the array is the same on both sides */
7940 if (oleft->op_type == OP_RV2AV) {
7941 if (oright->op_type != OP_RV2AV
7942 || !cUNOPx(oright)->op_first
7943 || cUNOPx(oright)->op_first->op_type != OP_GV
7944 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
7945 cGVOPx_gv(cUNOPx(oright)->op_first)
7949 else if (oright->op_type != OP_PADAV
7950 || oright->op_targ != oleft->op_targ
7954 /* transfer MODishness etc from LHS arg to RHS arg */
7955 oright->op_flags = oleft->op_flags;
7956 o->op_private |= OPpSORT_INPLACE;
7958 /* excise push->gv->rv2av->null->aassign */
7959 o2 = o->op_next->op_next;
7960 op_null(o2); /* PUSHMARK */
7962 if (o2->op_type == OP_GV) {
7963 op_null(o2); /* GV */
7966 op_null(o2); /* RV2AV or PADAV */
7967 o2 = o2->op_next->op_next;
7968 op_null(o2); /* AASSIGN */
7970 o->op_next = o2->op_next;
7976 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
7978 LISTOP *enter, *exlist;
7981 enter = (LISTOP *) o->op_next;
7984 if (enter->op_type == OP_NULL) {
7985 enter = (LISTOP *) enter->op_next;
7989 /* for $a (...) will have OP_GV then OP_RV2GV here.
7990 for (...) just has an OP_GV. */
7991 if (enter->op_type == OP_GV) {
7992 gvop = (OP *) enter;
7993 enter = (LISTOP *) enter->op_next;
7996 if (enter->op_type == OP_RV2GV) {
7997 enter = (LISTOP *) enter->op_next;
8003 if (enter->op_type != OP_ENTERITER)
8006 iter = enter->op_next;
8007 if (!iter || iter->op_type != OP_ITER)
8010 expushmark = enter->op_first;
8011 if (!expushmark || expushmark->op_type != OP_NULL
8012 || expushmark->op_targ != OP_PUSHMARK)
8015 exlist = (LISTOP *) expushmark->op_sibling;
8016 if (!exlist || exlist->op_type != OP_NULL
8017 || exlist->op_targ != OP_LIST)
8020 if (exlist->op_last != o) {
8021 /* Mmm. Was expecting to point back to this op. */
8024 theirmark = exlist->op_first;
8025 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
8028 if (theirmark->op_sibling != o) {
8029 /* There's something between the mark and the reverse, eg
8030 for (1, reverse (...))
8035 ourmark = ((LISTOP *)o)->op_first;
8036 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
8039 ourlast = ((LISTOP *)o)->op_last;
8040 if (!ourlast || ourlast->op_next != o)
8043 rv2av = ourmark->op_sibling;
8044 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
8045 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
8046 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
8047 /* We're just reversing a single array. */
8048 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
8049 enter->op_flags |= OPf_STACKED;
8052 /* We don't have control over who points to theirmark, so sacrifice
8054 theirmark->op_next = ourmark->op_next;
8055 theirmark->op_flags = ourmark->op_flags;
8056 ourlast->op_next = gvop ? gvop : (OP *) enter;
8059 enter->op_private |= OPpITER_REVERSED;
8060 iter->op_private |= OPpITER_REVERSED;
8067 UNOP *refgen, *rv2cv;
8070 /* I do not understand this, but if o->op_opt isn't set to 1,
8071 various tests in ext/B/t/bytecode.t fail with no readily
8077 if ((o->op_flags && OPf_WANT) != OPf_WANT_VOID)
8080 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
8083 rv2gv = ((BINOP *)o)->op_last;
8084 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
8087 refgen = (UNOP *)((BINOP *)o)->op_first;
8089 if (!refgen || refgen->op_type != OP_REFGEN)
8092 exlist = (LISTOP *)refgen->op_first;
8093 if (!exlist || exlist->op_type != OP_NULL
8094 || exlist->op_targ != OP_LIST)
8097 if (exlist->op_first->op_type != OP_PUSHMARK)
8100 rv2cv = (UNOP*)exlist->op_last;
8102 if (rv2cv->op_type != OP_RV2CV)
8105 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
8106 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
8107 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
8109 o->op_private |= OPpASSIGN_CV_TO_GV;
8110 rv2gv->op_private |= OPpDONT_INIT_GV;
8111 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
8127 Perl_custom_op_name(pTHX_ const OP* o)
8130 const IV index = PTR2IV(o->op_ppaddr);
8134 if (!PL_custom_op_names) /* This probably shouldn't happen */
8135 return (char *)PL_op_name[OP_CUSTOM];
8137 keysv = sv_2mortal(newSViv(index));
8139 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
8141 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
8143 return SvPV_nolen(HeVAL(he));
8147 Perl_custom_op_desc(pTHX_ const OP* o)
8150 const IV index = PTR2IV(o->op_ppaddr);
8154 if (!PL_custom_op_descs)
8155 return (char *)PL_op_desc[OP_CUSTOM];
8157 keysv = sv_2mortal(newSViv(index));
8159 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
8161 return (char *)PL_op_desc[OP_CUSTOM];
8163 return SvPV_nolen(HeVAL(he));
8168 /* Efficient sub that returns a constant scalar value. */
8170 const_sv_xsub(pTHX_ CV* cv)
8177 Perl_croak(aTHX_ "usage: %s::%s()",
8178 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
8182 ST(0) = (SV*)XSANY.any_ptr;
8188 * c-indentation-style: bsd
8190 * indent-tabs-mode: t
8193 * ex: set ts=8 sts=4 sw=4 noet: