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 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
1922 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
1926 Perl_scope(pTHX_ OP *o)
1930 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
1931 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
1932 o->op_type = OP_LEAVE;
1933 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
1935 else if (o->op_type == OP_LINESEQ) {
1937 o->op_type = OP_SCOPE;
1938 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
1939 kid = ((LISTOP*)o)->op_first;
1940 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
1943 /* The following deals with things like 'do {1 for 1}' */
1944 kid = kid->op_sibling;
1946 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
1951 o = newLISTOP(OP_SCOPE, 0, o, NULL);
1957 Perl_block_start(pTHX_ int full)
1960 const int retval = PL_savestack_ix;
1961 pad_block_start(full);
1963 PL_hints &= ~HINT_BLOCK_SCOPE;
1964 SAVESPTR(PL_compiling.cop_warnings);
1965 if (! specialWARN(PL_compiling.cop_warnings)) {
1966 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
1967 SAVEFREESV(PL_compiling.cop_warnings) ;
1969 SAVESPTR(PL_compiling.cop_io);
1970 if (! specialCopIO(PL_compiling.cop_io)) {
1971 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
1972 SAVEFREESV(PL_compiling.cop_io) ;
1978 Perl_block_end(pTHX_ I32 floor, OP *seq)
1981 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
1982 OP* const retval = scalarseq(seq);
1984 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
1986 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
1995 const I32 offset = pad_findmy("$_");
1996 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
1997 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2000 OP * const o = newOP(OP_PADSV, 0);
2001 o->op_targ = offset;
2007 Perl_newPROG(pTHX_ OP *o)
2013 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2014 ((PL_in_eval & EVAL_KEEPERR)
2015 ? OPf_SPECIAL : 0), o);
2016 PL_eval_start = linklist(PL_eval_root);
2017 PL_eval_root->op_private |= OPpREFCOUNTED;
2018 OpREFCNT_set(PL_eval_root, 1);
2019 PL_eval_root->op_next = 0;
2020 CALL_PEEP(PL_eval_start);
2023 if (o->op_type == OP_STUB) {
2024 PL_comppad_name = 0;
2029 PL_main_root = scope(sawparens(scalarvoid(o)));
2030 PL_curcop = &PL_compiling;
2031 PL_main_start = LINKLIST(PL_main_root);
2032 PL_main_root->op_private |= OPpREFCOUNTED;
2033 OpREFCNT_set(PL_main_root, 1);
2034 PL_main_root->op_next = 0;
2035 CALL_PEEP(PL_main_start);
2038 /* Register with debugger */
2040 CV * const cv = get_cv("DB::postponed", FALSE);
2044 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2046 call_sv((SV*)cv, G_DISCARD);
2053 Perl_localize(pTHX_ OP *o, I32 lex)
2056 if (o->op_flags & OPf_PARENS)
2057 /* [perl #17376]: this appears to be premature, and results in code such as
2058 C< our(%x); > executing in list mode rather than void mode */
2065 if ( PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ','
2066 && ckWARN(WARN_PARENTHESIS))
2068 char *s = PL_bufptr;
2071 /* some heuristics to detect a potential error */
2072 while (*s && (strchr(", \t\n", *s)))
2076 if (*s && strchr("@$%*", *s) && *++s
2077 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2080 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2082 while (*s && (strchr(", \t\n", *s)))
2088 if (sigil && (*s == ';' || *s == '=')) {
2089 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2090 "Parentheses missing around \"%s\" list",
2091 lex ? (PL_in_my == KEY_our ? "our" : "my")
2099 o = mod(o, OP_NULL); /* a bit kludgey */
2101 PL_in_my_stash = NULL;
2106 Perl_jmaybe(pTHX_ OP *o)
2108 if (o->op_type == OP_LIST) {
2110 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL,
2112 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2118 Perl_fold_constants(pTHX_ register OP *o)
2123 I32 type = o->op_type;
2126 if (PL_opargs[type] & OA_RETSCALAR)
2128 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2129 o->op_targ = pad_alloc(type, SVs_PADTMP);
2131 /* integerize op, unless it happens to be C<-foo>.
2132 * XXX should pp_i_negate() do magic string negation instead? */
2133 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2134 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2135 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2137 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2140 if (!(PL_opargs[type] & OA_FOLDCONST))
2145 /* XXX might want a ck_negate() for this */
2146 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2157 /* XXX what about the numeric ops? */
2158 if (PL_hints & HINT_LOCALE)
2163 goto nope; /* Don't try to run w/ errors */
2165 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2166 if ((curop->op_type != OP_CONST ||
2167 (curop->op_private & OPpCONST_BARE)) &&
2168 curop->op_type != OP_LIST &&
2169 curop->op_type != OP_SCALAR &&
2170 curop->op_type != OP_NULL &&
2171 curop->op_type != OP_PUSHMARK)
2177 curop = LINKLIST(o);
2181 sv = *(PL_stack_sp--);
2182 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2183 pad_swipe(o->op_targ, FALSE);
2184 else if (SvTEMP(sv)) { /* grab mortal temp? */
2185 SvREFCNT_inc_simple_void(sv);
2192 if (type == OP_RV2GV)
2193 newop = newGVOP(OP_GV, 0, (GV*)sv);
2195 newop = newSVOP(OP_CONST, 0, sv);
2196 op_getmad(o,newop,'f');
2204 Perl_gen_constant_list(pTHX_ register OP *o)
2208 const I32 oldtmps_floor = PL_tmps_floor;
2212 return o; /* Don't attempt to run with errors */
2214 PL_op = curop = LINKLIST(o);
2221 PL_tmps_floor = oldtmps_floor;
2223 o->op_type = OP_RV2AV;
2224 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2225 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2226 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2227 o->op_opt = 0; /* needs to be revisited in peep() */
2228 curop = ((UNOP*)o)->op_first;
2229 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
2231 op_getmad(curop,o,'O');
2240 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2243 if (!o || o->op_type != OP_LIST)
2244 o = newLISTOP(OP_LIST, 0, o, NULL);
2246 o->op_flags &= ~OPf_WANT;
2248 if (!(PL_opargs[type] & OA_MARK))
2249 op_null(cLISTOPo->op_first);
2251 o->op_type = (OPCODE)type;
2252 o->op_ppaddr = PL_ppaddr[type];
2253 o->op_flags |= flags;
2255 o = CHECKOP(type, o);
2256 if (o->op_type != (unsigned)type)
2259 return fold_constants(o);
2262 /* List constructors */
2265 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2273 if (first->op_type != (unsigned)type
2274 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2276 return newLISTOP(type, 0, first, last);
2279 if (first->op_flags & OPf_KIDS)
2280 ((LISTOP*)first)->op_last->op_sibling = last;
2282 first->op_flags |= OPf_KIDS;
2283 ((LISTOP*)first)->op_first = last;
2285 ((LISTOP*)first)->op_last = last;
2290 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2298 if (first->op_type != (unsigned)type)
2299 return prepend_elem(type, (OP*)first, (OP*)last);
2301 if (last->op_type != (unsigned)type)
2302 return append_elem(type, (OP*)first, (OP*)last);
2304 first->op_last->op_sibling = last->op_first;
2305 first->op_last = last->op_last;
2306 first->op_flags |= (last->op_flags & OPf_KIDS);
2309 if (last->op_first && first->op_madprop) {
2310 MADPROP *mp = last->op_first->op_madprop;
2312 while (mp->mad_next)
2314 mp->mad_next = first->op_madprop;
2317 last->op_first->op_madprop = first->op_madprop;
2320 first->op_madprop = last->op_madprop;
2321 last->op_madprop = 0;
2330 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2338 if (last->op_type == (unsigned)type) {
2339 if (type == OP_LIST) { /* already a PUSHMARK there */
2340 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2341 ((LISTOP*)last)->op_first->op_sibling = first;
2342 if (!(first->op_flags & OPf_PARENS))
2343 last->op_flags &= ~OPf_PARENS;
2346 if (!(last->op_flags & OPf_KIDS)) {
2347 ((LISTOP*)last)->op_last = first;
2348 last->op_flags |= OPf_KIDS;
2350 first->op_sibling = ((LISTOP*)last)->op_first;
2351 ((LISTOP*)last)->op_first = first;
2353 last->op_flags |= OPf_KIDS;
2357 return newLISTOP(type, 0, first, last);
2365 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2368 Newxz(tk, 1, TOKEN);
2369 tk->tk_type = (OPCODE)optype;
2370 tk->tk_type = 12345;
2372 tk->tk_mad = madprop;
2377 Perl_token_free(pTHX_ TOKEN* tk)
2379 if (tk->tk_type != 12345)
2381 mad_free(tk->tk_mad);
2386 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2390 if (tk->tk_type != 12345) {
2391 Perl_warner(aTHX_ packWARN(WARN_MISC),
2392 "Invalid TOKEN object ignored");
2399 /* faked up qw list? */
2401 tm->mad_type == MAD_SV &&
2402 SvPVX((SV*)tm->mad_val)[0] == 'q')
2409 /* pretend constant fold didn't happen? */
2410 if (mp->mad_key == 'f' &&
2411 (o->op_type == OP_CONST ||
2412 o->op_type == OP_GV) )
2414 token_getmad(tk,(OP*)mp->mad_val,slot);
2428 if (mp->mad_key == 'X')
2429 mp->mad_key = slot; /* just change the first one */
2439 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
2448 /* pretend constant fold didn't happen? */
2449 if (mp->mad_key == 'f' &&
2450 (o->op_type == OP_CONST ||
2451 o->op_type == OP_GV) )
2453 op_getmad(from,(OP*)mp->mad_val,slot);
2460 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
2463 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
2469 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
2478 /* pretend constant fold didn't happen? */
2479 if (mp->mad_key == 'f' &&
2480 (o->op_type == OP_CONST ||
2481 o->op_type == OP_GV) )
2483 op_getmad(from,(OP*)mp->mad_val,slot);
2490 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
2493 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
2497 PerlIO_printf(PerlIO_stderr(),
2498 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
2504 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
2522 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
2526 addmad(tm, &(o->op_madprop), slot);
2530 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
2551 Perl_newMADsv(pTHX_ char key, SV* sv)
2553 return newMADPROP(key, MAD_SV, sv, 0);
2557 Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
2560 Newxz(mp, 1, MADPROP);
2563 mp->mad_vlen = vlen;
2564 mp->mad_type = type;
2566 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
2571 Perl_mad_free(pTHX_ MADPROP* mp)
2573 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
2577 mad_free(mp->mad_next);
2578 /* if (PL_lex_state != LEX_NOTPARSING && mp->mad_vlen)
2579 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
2580 switch (mp->mad_type) {
2584 Safefree((char*)mp->mad_val);
2587 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
2588 op_free((OP*)mp->mad_val);
2591 sv_free((SV*)mp->mad_val);
2594 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
2603 Perl_newNULLLIST(pTHX)
2605 return newOP(OP_STUB, 0);
2609 Perl_force_list(pTHX_ OP *o)
2611 if (!o || o->op_type != OP_LIST)
2612 o = newLISTOP(OP_LIST, 0, o, NULL);
2618 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2623 NewOp(1101, listop, 1, LISTOP);
2625 listop->op_type = (OPCODE)type;
2626 listop->op_ppaddr = PL_ppaddr[type];
2629 listop->op_flags = (U8)flags;
2633 else if (!first && last)
2636 first->op_sibling = last;
2637 listop->op_first = first;
2638 listop->op_last = last;
2639 if (type == OP_LIST) {
2640 OP* const pushop = newOP(OP_PUSHMARK, 0);
2641 pushop->op_sibling = first;
2642 listop->op_first = pushop;
2643 listop->op_flags |= OPf_KIDS;
2645 listop->op_last = pushop;
2648 return CHECKOP(type, listop);
2652 Perl_newOP(pTHX_ I32 type, I32 flags)
2656 NewOp(1101, o, 1, OP);
2657 o->op_type = (OPCODE)type;
2658 o->op_ppaddr = PL_ppaddr[type];
2659 o->op_flags = (U8)flags;
2662 o->op_private = (U8)(0 | (flags >> 8));
2663 if (PL_opargs[type] & OA_RETSCALAR)
2665 if (PL_opargs[type] & OA_TARGET)
2666 o->op_targ = pad_alloc(type, SVs_PADTMP);
2667 return CHECKOP(type, o);
2671 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2677 first = newOP(OP_STUB, 0);
2678 if (PL_opargs[type] & OA_MARK)
2679 first = force_list(first);
2681 NewOp(1101, unop, 1, UNOP);
2682 unop->op_type = (OPCODE)type;
2683 unop->op_ppaddr = PL_ppaddr[type];
2684 unop->op_first = first;
2685 unop->op_flags = (U8)(flags | OPf_KIDS);
2686 unop->op_private = (U8)(1 | (flags >> 8));
2687 unop = (UNOP*) CHECKOP(type, unop);
2691 return fold_constants((OP *) unop);
2695 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2699 NewOp(1101, binop, 1, BINOP);
2702 first = newOP(OP_NULL, 0);
2704 binop->op_type = (OPCODE)type;
2705 binop->op_ppaddr = PL_ppaddr[type];
2706 binop->op_first = first;
2707 binop->op_flags = (U8)(flags | OPf_KIDS);
2710 binop->op_private = (U8)(1 | (flags >> 8));
2713 binop->op_private = (U8)(2 | (flags >> 8));
2714 first->op_sibling = last;
2717 binop = (BINOP*)CHECKOP(type, binop);
2718 if (binop->op_next || binop->op_type != (OPCODE)type)
2721 binop->op_last = binop->op_first->op_sibling;
2723 return fold_constants((OP *)binop);
2726 static int uvcompare(const void *a, const void *b)
2727 __attribute__nonnull__(1)
2728 __attribute__nonnull__(2)
2729 __attribute__pure__;
2730 static int uvcompare(const void *a, const void *b)
2732 if (*((const UV *)a) < (*(const UV *)b))
2734 if (*((const UV *)a) > (*(const UV *)b))
2736 if (*((const UV *)a+1) < (*(const UV *)b+1))
2738 if (*((const UV *)a+1) > (*(const UV *)b+1))
2744 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2747 SV * const tstr = ((SVOP*)expr)->op_sv;
2748 SV * const rstr = ((SVOP*)repl)->op_sv;
2751 const U8 *t = (U8*)SvPV_const(tstr, tlen);
2752 const U8 *r = (U8*)SvPV_const(rstr, rlen);
2756 register short *tbl;
2758 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
2759 const I32 squash = o->op_private & OPpTRANS_SQUASH;
2760 I32 del = o->op_private & OPpTRANS_DELETE;
2761 PL_hints |= HINT_BLOCK_SCOPE;
2764 o->op_private |= OPpTRANS_FROM_UTF;
2767 o->op_private |= OPpTRANS_TO_UTF;
2769 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2770 SV* const listsv = newSVpvs("# comment\n");
2772 const U8* tend = t + tlen;
2773 const U8* rend = r + rlen;
2787 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2788 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2794 t = tsave = bytes_to_utf8(t, &len);
2797 if (!to_utf && rlen) {
2799 r = rsave = bytes_to_utf8(r, &len);
2803 /* There are several snags with this code on EBCDIC:
2804 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2805 2. scan_const() in toke.c has encoded chars in native encoding which makes
2806 ranges at least in EBCDIC 0..255 range the bottom odd.
2810 U8 tmpbuf[UTF8_MAXBYTES+1];
2813 Newx(cp, 2*tlen, UV);
2815 transv = newSVpvs("");
2817 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2819 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2821 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2825 cp[2*i+1] = cp[2*i];
2829 qsort(cp, i, 2*sizeof(UV), uvcompare);
2830 for (j = 0; j < i; j++) {
2832 diff = val - nextmin;
2834 t = uvuni_to_utf8(tmpbuf,nextmin);
2835 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2837 U8 range_mark = UTF_TO_NATIVE(0xff);
2838 t = uvuni_to_utf8(tmpbuf, val - 1);
2839 sv_catpvn(transv, (char *)&range_mark, 1);
2840 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2847 t = uvuni_to_utf8(tmpbuf,nextmin);
2848 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2850 U8 range_mark = UTF_TO_NATIVE(0xff);
2851 sv_catpvn(transv, (char *)&range_mark, 1);
2853 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2854 UNICODE_ALLOW_SUPER);
2855 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2856 t = (const U8*)SvPVX_const(transv);
2857 tlen = SvCUR(transv);
2861 else if (!rlen && !del) {
2862 r = t; rlen = tlen; rend = tend;
2865 if ((!rlen && !del) || t == r ||
2866 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2868 o->op_private |= OPpTRANS_IDENTICAL;
2872 while (t < tend || tfirst <= tlast) {
2873 /* see if we need more "t" chars */
2874 if (tfirst > tlast) {
2875 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2877 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2879 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2886 /* now see if we need more "r" chars */
2887 if (rfirst > rlast) {
2889 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2891 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2893 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2902 rfirst = rlast = 0xffffffff;
2906 /* now see which range will peter our first, if either. */
2907 tdiff = tlast - tfirst;
2908 rdiff = rlast - rfirst;
2915 if (rfirst == 0xffffffff) {
2916 diff = tdiff; /* oops, pretend rdiff is infinite */
2918 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2919 (long)tfirst, (long)tlast);
2921 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2925 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2926 (long)tfirst, (long)(tfirst + diff),
2929 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2930 (long)tfirst, (long)rfirst);
2932 if (rfirst + diff > max)
2933 max = rfirst + diff;
2935 grows = (tfirst < rfirst &&
2936 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2948 else if (max > 0xff)
2953 Safefree(cPVOPo->op_pv);
2954 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2955 SvREFCNT_dec(listsv);
2956 SvREFCNT_dec(transv);
2958 if (!del && havefinal && rlen)
2959 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2960 newSVuv((UV)final), 0);
2963 o->op_private |= OPpTRANS_GROWS;
2969 op_getmad(expr,o,'e');
2970 op_getmad(repl,o,'r');
2978 tbl = (short*)cPVOPo->op_pv;
2980 Zero(tbl, 256, short);
2981 for (i = 0; i < (I32)tlen; i++)
2983 for (i = 0, j = 0; i < 256; i++) {
2985 if (j >= (I32)rlen) {
2994 if (i < 128 && r[j] >= 128)
3004 o->op_private |= OPpTRANS_IDENTICAL;
3006 else if (j >= (I32)rlen)
3009 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
3010 tbl[0x100] = (short)(rlen - j);
3011 for (i=0; i < (I32)rlen - j; i++)
3012 tbl[0x101+i] = r[j+i];
3016 if (!rlen && !del) {
3019 o->op_private |= OPpTRANS_IDENTICAL;
3021 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3022 o->op_private |= OPpTRANS_IDENTICAL;
3024 for (i = 0; i < 256; i++)
3026 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3027 if (j >= (I32)rlen) {
3029 if (tbl[t[i]] == -1)
3035 if (tbl[t[i]] == -1) {
3036 if (t[i] < 128 && r[j] >= 128)
3043 o->op_private |= OPpTRANS_GROWS;
3045 op_getmad(expr,o,'e');
3046 op_getmad(repl,o,'r');
3056 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3061 NewOp(1101, pmop, 1, PMOP);
3062 pmop->op_type = (OPCODE)type;
3063 pmop->op_ppaddr = PL_ppaddr[type];
3064 pmop->op_flags = (U8)flags;
3065 pmop->op_private = (U8)(0 | (flags >> 8));
3067 if (PL_hints & HINT_RE_TAINT)
3068 pmop->op_pmpermflags |= PMf_RETAINT;
3069 if (PL_hints & HINT_LOCALE)
3070 pmop->op_pmpermflags |= PMf_LOCALE;
3071 pmop->op_pmflags = pmop->op_pmpermflags;
3074 if (av_len((AV*) PL_regex_pad[0]) > -1) {
3075 SV * const repointer = av_pop((AV*)PL_regex_pad[0]);
3076 pmop->op_pmoffset = SvIV(repointer);
3077 SvREPADTMP_off(repointer);
3078 sv_setiv(repointer,0);
3080 SV * const repointer = newSViv(0);
3081 av_push(PL_regex_padav, SvREFCNT_inc_simple_NN(repointer));
3082 pmop->op_pmoffset = av_len(PL_regex_padav);
3083 PL_regex_pad = AvARRAY(PL_regex_padav);
3087 /* link into pm list */
3088 if (type != OP_TRANS && PL_curstash) {
3089 MAGIC *mg = mg_find((SV*)PL_curstash, PERL_MAGIC_symtab);
3092 mg = sv_magicext((SV*)PL_curstash, 0, PERL_MAGIC_symtab, 0, 0, 0);
3094 pmop->op_pmnext = (PMOP*)mg->mg_obj;
3095 mg->mg_obj = (SV*)pmop;
3096 PmopSTASH_set(pmop,PL_curstash);
3099 return CHECKOP(type, pmop);
3102 /* Given some sort of match op o, and an expression expr containing a
3103 * pattern, either compile expr into a regex and attach it to o (if it's
3104 * constant), or convert expr into a runtime regcomp op sequence (if it's
3107 * isreg indicates that the pattern is part of a regex construct, eg
3108 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3109 * split "pattern", which aren't. In the former case, expr will be a list
3110 * if the pattern contains more than one term (eg /a$b/) or if it contains
3111 * a replacement, ie s/// or tr///.
3115 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
3120 I32 repl_has_vars = 0;
3124 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
3125 /* last element in list is the replacement; pop it */
3127 repl = cLISTOPx(expr)->op_last;
3128 kid = cLISTOPx(expr)->op_first;
3129 while (kid->op_sibling != repl)
3130 kid = kid->op_sibling;
3131 kid->op_sibling = NULL;
3132 cLISTOPx(expr)->op_last = kid;
3135 if (isreg && expr->op_type == OP_LIST &&
3136 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3138 /* convert single element list to element */
3139 OP* const oe = expr;
3140 expr = cLISTOPx(oe)->op_first->op_sibling;
3141 cLISTOPx(oe)->op_first->op_sibling = NULL;
3142 cLISTOPx(oe)->op_last = NULL;
3146 if (o->op_type == OP_TRANS) {
3147 return pmtrans(o, expr, repl);
3150 reglist = isreg && expr->op_type == OP_LIST;
3154 PL_hints |= HINT_BLOCK_SCOPE;
3157 if (expr->op_type == OP_CONST) {
3159 SV * const pat = ((SVOP*)expr)->op_sv;
3160 const char *p = SvPV_const(pat, plen);
3161 if ((o->op_flags & OPf_SPECIAL) && (*p == ' ' && p[1] == '\0')) {
3162 U32 was_readonly = SvREADONLY(pat);
3166 sv_force_normal_flags(pat, 0);
3167 assert(!SvREADONLY(pat));
3170 SvREADONLY_off(pat);
3174 sv_setpvn(pat, "\\s+", 3);
3176 SvFLAGS(pat) |= was_readonly;
3178 p = SvPV_const(pat, plen);
3179 pm->op_pmflags |= PMf_SKIPWHITE;
3182 pm->op_pmdynflags |= PMdf_UTF8;
3183 /* FIXME - can we make this function take const char * args? */
3184 PM_SETRE(pm, CALLREGCOMP(aTHX_ (char*)p, (char*)p + plen, pm));
3185 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
3186 pm->op_pmflags |= PMf_WHITE;
3188 op_getmad(expr,(OP*)pm,'e');
3194 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3195 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3197 : OP_REGCMAYBE),0,expr);
3199 NewOp(1101, rcop, 1, LOGOP);
3200 rcop->op_type = OP_REGCOMP;
3201 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3202 rcop->op_first = scalar(expr);
3203 rcop->op_flags |= OPf_KIDS
3204 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3205 | (reglist ? OPf_STACKED : 0);
3206 rcop->op_private = 1;
3209 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3211 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
3214 /* establish postfix order */
3215 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3217 rcop->op_next = expr;
3218 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3221 rcop->op_next = LINKLIST(expr);
3222 expr->op_next = (OP*)rcop;
3225 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3230 if (pm->op_pmflags & PMf_EVAL) {
3232 if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
3233 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
3235 else if (repl->op_type == OP_CONST)
3239 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3240 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3241 if (curop->op_type == OP_GV) {
3242 GV * const gv = cGVOPx_gv(curop);
3244 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3247 else if (curop->op_type == OP_RV2CV)
3249 else if (curop->op_type == OP_RV2SV ||
3250 curop->op_type == OP_RV2AV ||
3251 curop->op_type == OP_RV2HV ||
3252 curop->op_type == OP_RV2GV) {
3253 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3256 else if (curop->op_type == OP_PADSV ||
3257 curop->op_type == OP_PADAV ||
3258 curop->op_type == OP_PADHV ||
3259 curop->op_type == OP_PADANY) {
3262 else if (curop->op_type == OP_PUSHRE)
3263 /*EMPTY*/; /* Okay here, dangerous in newASSIGNOP */
3273 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
3274 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3275 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
3276 prepend_elem(o->op_type, scalar(repl), o);
3279 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3280 pm->op_pmflags |= PMf_MAYBE_CONST;
3281 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3283 NewOp(1101, rcop, 1, LOGOP);
3284 rcop->op_type = OP_SUBSTCONT;
3285 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3286 rcop->op_first = scalar(repl);
3287 rcop->op_flags |= OPf_KIDS;
3288 rcop->op_private = 1;
3291 /* establish postfix order */
3292 rcop->op_next = LINKLIST(repl);
3293 repl->op_next = (OP*)rcop;
3295 pm->op_pmreplroot = scalar((OP*)rcop);
3296 pm->op_pmreplstart = LINKLIST(rcop);
3305 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3309 NewOp(1101, svop, 1, SVOP);
3310 svop->op_type = (OPCODE)type;
3311 svop->op_ppaddr = PL_ppaddr[type];
3313 svop->op_next = (OP*)svop;
3314 svop->op_flags = (U8)flags;
3315 if (PL_opargs[type] & OA_RETSCALAR)
3317 if (PL_opargs[type] & OA_TARGET)
3318 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3319 return CHECKOP(type, svop);
3323 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3327 NewOp(1101, padop, 1, PADOP);
3328 padop->op_type = (OPCODE)type;
3329 padop->op_ppaddr = PL_ppaddr[type];
3330 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3331 SvREFCNT_dec(PAD_SVl(padop->op_padix));
3332 PAD_SETSV(padop->op_padix, sv);
3335 padop->op_next = (OP*)padop;
3336 padop->op_flags = (U8)flags;
3337 if (PL_opargs[type] & OA_RETSCALAR)
3339 if (PL_opargs[type] & OA_TARGET)
3340 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3341 return CHECKOP(type, padop);
3345 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3351 return newPADOP(type, flags, SvREFCNT_inc_simple(gv));
3353 return newSVOP(type, flags, SvREFCNT_inc_simple(gv));
3358 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3362 NewOp(1101, pvop, 1, PVOP);
3363 pvop->op_type = (OPCODE)type;
3364 pvop->op_ppaddr = PL_ppaddr[type];
3366 pvop->op_next = (OP*)pvop;
3367 pvop->op_flags = (U8)flags;
3368 if (PL_opargs[type] & OA_RETSCALAR)
3370 if (PL_opargs[type] & OA_TARGET)
3371 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3372 return CHECKOP(type, pvop);
3380 Perl_package(pTHX_ OP *o)
3389 save_hptr(&PL_curstash);
3390 save_item(PL_curstname);
3392 name = SvPV_const(cSVOPo->op_sv, len);
3393 PL_curstash = gv_stashpvn(name, len, TRUE);
3394 sv_setpvn(PL_curstname, name, len);
3396 PL_hints |= HINT_BLOCK_SCOPE;
3397 PL_copline = NOLINE;
3403 if (!PL_madskills) {
3408 pegop = newOP(OP_NULL,0);
3409 op_getmad(o,pegop,'P');
3419 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3426 OP *pegop = newOP(OP_NULL,0);
3429 if (idop->op_type != OP_CONST)
3430 Perl_croak(aTHX_ "Module name must be constant");
3433 op_getmad(idop,pegop,'U');
3438 SV * const vesv = ((SVOP*)version)->op_sv;
3441 op_getmad(version,pegop,'V');
3442 if (!arg && !SvNIOKp(vesv)) {
3449 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3450 Perl_croak(aTHX_ "Version number must be constant number");
3452 /* Make copy of idop so we don't free it twice */
3453 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3455 /* Fake up a method call to VERSION */
3456 meth = newSVpvs_share("VERSION");
3457 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3458 append_elem(OP_LIST,
3459 prepend_elem(OP_LIST, pack, list(version)),
3460 newSVOP(OP_METHOD_NAMED, 0, meth)));
3464 /* Fake up an import/unimport */
3465 if (arg && arg->op_type == OP_STUB) {
3467 op_getmad(arg,pegop,'S');
3468 imop = arg; /* no import on explicit () */
3470 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3471 imop = NULL; /* use 5.0; */
3473 idop->op_private |= OPpCONST_NOVER;
3479 op_getmad(arg,pegop,'A');
3481 /* Make copy of idop so we don't free it twice */
3482 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3484 /* Fake up a method call to import/unimport */
3486 ? newSVpvs_share("import") : newSVpvs_share("unimport");
3487 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3488 append_elem(OP_LIST,
3489 prepend_elem(OP_LIST, pack, list(arg)),
3490 newSVOP(OP_METHOD_NAMED, 0, meth)));
3493 /* Fake up the BEGIN {}, which does its thing immediately. */
3495 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
3498 append_elem(OP_LINESEQ,
3499 append_elem(OP_LINESEQ,
3500 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
3501 newSTATEOP(0, NULL, veop)),
3502 newSTATEOP(0, NULL, imop) ));
3504 /* The "did you use incorrect case?" warning used to be here.
3505 * The problem is that on case-insensitive filesystems one
3506 * might get false positives for "use" (and "require"):
3507 * "use Strict" or "require CARP" will work. This causes
3508 * portability problems for the script: in case-strict
3509 * filesystems the script will stop working.
3511 * The "incorrect case" warning checked whether "use Foo"
3512 * imported "Foo" to your namespace, but that is wrong, too:
3513 * there is no requirement nor promise in the language that
3514 * a Foo.pm should or would contain anything in package "Foo".
3516 * There is very little Configure-wise that can be done, either:
3517 * the case-sensitivity of the build filesystem of Perl does not
3518 * help in guessing the case-sensitivity of the runtime environment.
3521 PL_hints |= HINT_BLOCK_SCOPE;
3522 PL_copline = NOLINE;
3524 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3527 if (!PL_madskills) {
3528 /* FIXME - don't allocate pegop if !PL_madskills */
3537 =head1 Embedding Functions
3539 =for apidoc load_module
3541 Loads the module whose name is pointed to by the string part of name.
3542 Note that the actual module name, not its filename, should be given.
3543 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3544 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3545 (or 0 for no flags). ver, if specified, provides version semantics
3546 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3547 arguments can be used to specify arguments to the module's import()
3548 method, similar to C<use Foo::Bar VERSION LIST>.
3553 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3556 va_start(args, ver);
3557 vload_module(flags, name, ver, &args);
3561 #ifdef PERL_IMPLICIT_CONTEXT
3563 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3567 va_start(args, ver);
3568 vload_module(flags, name, ver, &args);
3574 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3579 OP * const modname = newSVOP(OP_CONST, 0, name);
3580 modname->op_private |= OPpCONST_BARE;
3582 veop = newSVOP(OP_CONST, 0, ver);
3586 if (flags & PERL_LOADMOD_NOIMPORT) {
3587 imop = sawparens(newNULLLIST());
3589 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3590 imop = va_arg(*args, OP*);
3595 sv = va_arg(*args, SV*);
3597 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3598 sv = va_arg(*args, SV*);
3602 const line_t ocopline = PL_copline;
3603 COP * const ocurcop = PL_curcop;
3604 const int oexpect = PL_expect;
3606 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3607 veop, modname, imop);
3608 PL_expect = oexpect;
3609 PL_copline = ocopline;
3610 PL_curcop = ocurcop;
3615 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
3621 if (!force_builtin) {
3622 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
3623 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
3624 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
3625 gv = gvp ? *gvp : NULL;
3629 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3630 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3631 append_elem(OP_LIST, term,
3632 scalar(newUNOP(OP_RV2CV, 0,
3637 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3643 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3645 return newBINOP(OP_LSLICE, flags,
3646 list(force_list(subscript)),
3647 list(force_list(listval)) );
3651 S_is_list_assignment(pTHX_ register const OP *o)
3656 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3657 o = cUNOPo->op_first;
3659 if (o->op_type == OP_COND_EXPR) {
3660 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
3661 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3666 yyerror("Assignment to both a list and a scalar");
3670 if (o->op_type == OP_LIST &&
3671 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3672 o->op_private & OPpLVAL_INTRO)
3675 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3676 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3677 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3680 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3683 if (o->op_type == OP_RV2SV)
3690 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3696 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3697 return newLOGOP(optype, 0,
3698 mod(scalar(left), optype),
3699 newUNOP(OP_SASSIGN, 0, scalar(right)));
3702 return newBINOP(optype, OPf_STACKED,
3703 mod(scalar(left), optype), scalar(right));
3707 if (is_list_assignment(left)) {
3711 /* Grandfathering $[ assignment here. Bletch.*/
3712 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
3713 PL_eval_start = (left->op_type == OP_CONST) ? right : 0;
3714 left = mod(left, OP_AASSIGN);
3717 else if (left->op_type == OP_CONST) {
3719 /* Result of assignment is always 1 (or we'd be dead already) */
3720 return newSVOP(OP_CONST, 0, newSViv(1));
3722 curop = list(force_list(left));
3723 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3724 o->op_private = (U8)(0 | (flags >> 8));
3726 /* PL_generation sorcery:
3727 * an assignment like ($a,$b) = ($c,$d) is easier than
3728 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3729 * To detect whether there are common vars, the global var
3730 * PL_generation is incremented for each assign op we compile.
3731 * Then, while compiling the assign op, we run through all the
3732 * variables on both sides of the assignment, setting a spare slot
3733 * in each of them to PL_generation. If any of them already have
3734 * that value, we know we've got commonality. We could use a
3735 * single bit marker, but then we'd have to make 2 passes, first
3736 * to clear the flag, then to test and set it. To find somewhere
3737 * to store these values, evil chicanery is done with SvCUR().
3740 if (!(left->op_private & OPpLVAL_INTRO)) {
3743 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3744 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3745 if (curop->op_type == OP_GV) {
3746 GV *gv = cGVOPx_gv(curop);
3748 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
3750 GvASSIGN_GENERATION_set(gv, PL_generation);
3752 else if (curop->op_type == OP_PADSV ||
3753 curop->op_type == OP_PADAV ||
3754 curop->op_type == OP_PADHV ||
3755 curop->op_type == OP_PADANY)
3757 if (PAD_COMPNAME_GEN(curop->op_targ)
3758 == (STRLEN)PL_generation)
3760 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
3763 else if (curop->op_type == OP_RV2CV)
3765 else if (curop->op_type == OP_RV2SV ||
3766 curop->op_type == OP_RV2AV ||
3767 curop->op_type == OP_RV2HV ||
3768 curop->op_type == OP_RV2GV) {
3769 if (lastop->op_type != OP_GV) /* funny deref? */
3772 else if (curop->op_type == OP_PUSHRE) {
3773 if (((PMOP*)curop)->op_pmreplroot) {
3775 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3776 ((PMOP*)curop)->op_pmreplroot));
3778 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3781 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
3783 GvASSIGN_GENERATION_set(gv, PL_generation);
3784 GvASSIGN_GENERATION_set(gv, PL_generation);
3793 o->op_private |= OPpASSIGN_COMMON;
3795 if (right && right->op_type == OP_SPLIT) {
3797 if ((tmpop = ((LISTOP*)right)->op_first) &&
3798 tmpop->op_type == OP_PUSHRE)
3800 PMOP * const pm = (PMOP*)tmpop;
3801 if (left->op_type == OP_RV2AV &&
3802 !(left->op_private & OPpLVAL_INTRO) &&
3803 !(o->op_private & OPpASSIGN_COMMON) )
3805 tmpop = ((UNOP*)left)->op_first;
3806 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3808 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3809 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3811 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3812 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
3814 pm->op_pmflags |= PMf_ONCE;
3815 tmpop = cUNOPo->op_first; /* to list (nulled) */
3816 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3817 tmpop->op_sibling = NULL; /* don't free split */
3818 right->op_next = tmpop->op_next; /* fix starting loc */
3820 op_getmad(o,right,'R'); /* blow off assign */
3822 op_free(o); /* blow off assign */
3824 right->op_flags &= ~OPf_WANT;
3825 /* "I don't know and I don't care." */
3830 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3831 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3833 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3835 sv_setiv(sv, PL_modcount+1);
3843 right = newOP(OP_UNDEF, 0);
3844 if (right->op_type == OP_READLINE) {
3845 right->op_flags |= OPf_STACKED;
3846 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3849 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3850 o = newBINOP(OP_SASSIGN, flags,
3851 scalar(right), mod(scalar(left), OP_SASSIGN) );
3857 o = newSVOP(OP_CONST, 0, newSViv(PL_compiling.cop_arybase));
3858 o->op_private |= OPpCONST_ARYBASE;
3865 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3868 const U32 seq = intro_my();
3871 NewOp(1101, cop, 1, COP);
3872 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3873 cop->op_type = OP_DBSTATE;
3874 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3877 cop->op_type = OP_NEXTSTATE;
3878 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3880 cop->op_flags = (U8)flags;
3881 cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
3883 cop->op_private |= NATIVE_HINTS;
3885 PL_compiling.op_private = cop->op_private;
3886 cop->op_next = (OP*)cop;
3889 cop->cop_label = label;
3890 PL_hints |= HINT_BLOCK_SCOPE;
3893 cop->cop_arybase = PL_curcop->cop_arybase;
3894 if (specialWARN(PL_curcop->cop_warnings))
3895 cop->cop_warnings = PL_curcop->cop_warnings ;
3897 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3898 if (specialCopIO(PL_curcop->cop_io))
3899 cop->cop_io = PL_curcop->cop_io;
3901 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3904 if (PL_copline == NOLINE)
3905 CopLINE_set(cop, CopLINE(PL_curcop));
3907 CopLINE_set(cop, PL_copline);
3908 PL_copline = NOLINE;
3911 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3913 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3915 CopSTASH_set(cop, PL_curstash);
3917 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3918 SV * const * const svp = av_fetch(CopFILEAVx(PL_curcop), (I32)CopLINE(cop), FALSE);
3919 if (svp && *svp != &PL_sv_undef ) {
3920 (void)SvIOK_on(*svp);
3921 SvIV_set(*svp, PTR2IV(cop));
3925 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3930 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3933 return new_logop(type, flags, &first, &other);
3937 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3942 OP *first = *firstp;
3943 OP * const other = *otherp;
3945 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3946 return newBINOP(type, flags, scalar(first), scalar(other));
3948 scalarboolean(first);
3949 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3950 if (first->op_type == OP_NOT
3951 && (first->op_flags & OPf_SPECIAL)
3952 && (first->op_flags & OPf_KIDS)) {
3953 if (type == OP_AND || type == OP_OR) {
3959 first = *firstp = cUNOPo->op_first;
3961 first->op_next = o->op_next;
3962 cUNOPo->op_first = NULL;
3964 op_getmad(o,first,'O');
3970 if (first->op_type == OP_CONST) {
3971 if (first->op_private & OPpCONST_STRICT)
3972 no_bareword_allowed(first);
3973 else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
3974 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
3975 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
3976 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
3977 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
3979 if (other->op_type == OP_CONST)
3980 other->op_private |= OPpCONST_SHORTCIRCUIT;
3982 OP *newop = newUNOP(OP_NULL, 0, other);
3983 op_getmad(first, newop, '1');
3984 newop->op_targ = type; /* set "was" field */
3991 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
3992 const OP *o2 = other;
3993 if ( ! (o2->op_type == OP_LIST
3994 && (( o2 = cUNOPx(o2)->op_first))
3995 && o2->op_type == OP_PUSHMARK
3996 && (( o2 = o2->op_sibling)) )
3999 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
4000 || o2->op_type == OP_PADHV)
4001 && o2->op_private & OPpLVAL_INTRO
4002 && ckWARN(WARN_DEPRECATED))
4004 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4005 "Deprecated use of my() in false conditional");
4009 if (first->op_type == OP_CONST)
4010 first->op_private |= OPpCONST_SHORTCIRCUIT;
4012 first = newUNOP(OP_NULL, 0, first);
4013 op_getmad(other, first, '2');
4014 first->op_targ = type; /* set "was" field */
4021 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
4022 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
4024 const OP * const k1 = ((UNOP*)first)->op_first;
4025 const OP * const k2 = k1->op_sibling;
4027 switch (first->op_type)
4030 if (k2 && k2->op_type == OP_READLINE
4031 && (k2->op_flags & OPf_STACKED)
4032 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4034 warnop = k2->op_type;
4039 if (k1->op_type == OP_READDIR
4040 || k1->op_type == OP_GLOB
4041 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4042 || k1->op_type == OP_EACH)
4044 warnop = ((k1->op_type == OP_NULL)
4045 ? (OPCODE)k1->op_targ : k1->op_type);
4050 const line_t oldline = CopLINE(PL_curcop);
4051 CopLINE_set(PL_curcop, PL_copline);
4052 Perl_warner(aTHX_ packWARN(WARN_MISC),
4053 "Value of %s%s can be \"0\"; test with defined()",
4055 ((warnop == OP_READLINE || warnop == OP_GLOB)
4056 ? " construct" : "() operator"));
4057 CopLINE_set(PL_curcop, oldline);
4064 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
4065 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
4067 NewOp(1101, logop, 1, LOGOP);
4069 logop->op_type = (OPCODE)type;
4070 logop->op_ppaddr = PL_ppaddr[type];
4071 logop->op_first = first;
4072 logop->op_flags = (U8)(flags | OPf_KIDS);
4073 logop->op_other = LINKLIST(other);
4074 logop->op_private = (U8)(1 | (flags >> 8));
4076 /* establish postfix order */
4077 logop->op_next = LINKLIST(first);
4078 first->op_next = (OP*)logop;
4079 first->op_sibling = other;
4081 CHECKOP(type,logop);
4083 o = newUNOP(OP_NULL, 0, (OP*)logop);
4090 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
4098 return newLOGOP(OP_AND, 0, first, trueop);
4100 return newLOGOP(OP_OR, 0, first, falseop);
4102 scalarboolean(first);
4103 if (first->op_type == OP_CONST) {
4104 if (first->op_private & OPpCONST_BARE &&
4105 first->op_private & OPpCONST_STRICT) {
4106 no_bareword_allowed(first);
4108 if (SvTRUE(((SVOP*)first)->op_sv)) {
4111 trueop = newUNOP(OP_NULL, 0, trueop);
4112 op_getmad(first,trueop,'C');
4113 op_getmad(falseop,trueop,'e');
4115 /* FIXME for MAD - should there be an ELSE here? */
4125 falseop = newUNOP(OP_NULL, 0, falseop);
4126 op_getmad(first,falseop,'C');
4127 op_getmad(trueop,falseop,'t');
4129 /* FIXME for MAD - should there be an ELSE here? */
4137 NewOp(1101, logop, 1, LOGOP);
4138 logop->op_type = OP_COND_EXPR;
4139 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4140 logop->op_first = first;
4141 logop->op_flags = (U8)(flags | OPf_KIDS);
4142 logop->op_private = (U8)(1 | (flags >> 8));
4143 logop->op_other = LINKLIST(trueop);
4144 logop->op_next = LINKLIST(falseop);
4146 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
4149 /* establish postfix order */
4150 start = LINKLIST(first);
4151 first->op_next = (OP*)logop;
4153 first->op_sibling = trueop;
4154 trueop->op_sibling = falseop;
4155 o = newUNOP(OP_NULL, 0, (OP*)logop);
4157 trueop->op_next = falseop->op_next = o;
4164 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4173 NewOp(1101, range, 1, LOGOP);
4175 range->op_type = OP_RANGE;
4176 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4177 range->op_first = left;
4178 range->op_flags = OPf_KIDS;
4179 leftstart = LINKLIST(left);
4180 range->op_other = LINKLIST(right);
4181 range->op_private = (U8)(1 | (flags >> 8));
4183 left->op_sibling = right;
4185 range->op_next = (OP*)range;
4186 flip = newUNOP(OP_FLIP, flags, (OP*)range);
4187 flop = newUNOP(OP_FLOP, 0, flip);
4188 o = newUNOP(OP_NULL, 0, flop);
4190 range->op_next = leftstart;
4192 left->op_next = flip;
4193 right->op_next = flop;
4195 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4196 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4197 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4198 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4200 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4201 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4204 if (!flip->op_private || !flop->op_private)
4205 linklist(o); /* blow off optimizer unless constant */
4211 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4216 const bool once = block && block->op_flags & OPf_SPECIAL &&
4217 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4219 PERL_UNUSED_ARG(debuggable);
4222 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4223 return block; /* do {} while 0 does once */
4224 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4225 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4226 expr = newUNOP(OP_DEFINED, 0,
4227 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4228 } else if (expr->op_flags & OPf_KIDS) {
4229 const OP * const k1 = ((UNOP*)expr)->op_first;
4230 const OP * const k2 = k1 ? k1->op_sibling : NULL;
4231 switch (expr->op_type) {
4233 if (k2 && k2->op_type == OP_READLINE
4234 && (k2->op_flags & OPf_STACKED)
4235 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4236 expr = newUNOP(OP_DEFINED, 0, expr);
4240 if (k1 && (k1->op_type == OP_READDIR
4241 || k1->op_type == OP_GLOB
4242 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4243 || k1->op_type == OP_EACH))
4244 expr = newUNOP(OP_DEFINED, 0, expr);
4250 /* if block is null, the next append_elem() would put UNSTACK, a scalar
4251 * op, in listop. This is wrong. [perl #27024] */
4253 block = newOP(OP_NULL, 0);
4254 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4255 o = new_logop(OP_AND, 0, &expr, &listop);
4258 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4260 if (once && o != listop)
4261 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4264 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
4266 o->op_flags |= flags;
4268 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4273 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
4274 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
4283 PERL_UNUSED_ARG(debuggable);
4286 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4287 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4288 expr = newUNOP(OP_DEFINED, 0,
4289 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4290 } else if (expr->op_flags & OPf_KIDS) {
4291 const OP * const k1 = ((UNOP*)expr)->op_first;
4292 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
4293 switch (expr->op_type) {
4295 if (k2 && k2->op_type == OP_READLINE
4296 && (k2->op_flags & OPf_STACKED)
4297 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4298 expr = newUNOP(OP_DEFINED, 0, expr);
4302 if (k1 && (k1->op_type == OP_READDIR
4303 || k1->op_type == OP_GLOB
4304 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4305 || k1->op_type == OP_EACH))
4306 expr = newUNOP(OP_DEFINED, 0, expr);
4313 block = newOP(OP_NULL, 0);
4314 else if (cont || has_my) {
4315 block = scope(block);
4319 next = LINKLIST(cont);
4322 OP * const unstack = newOP(OP_UNSTACK, 0);
4325 cont = append_elem(OP_LINESEQ, cont, unstack);
4328 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4329 redo = LINKLIST(listop);
4332 PL_copline = (line_t)whileline;
4334 o = new_logop(OP_AND, 0, &expr, &listop);
4335 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4336 op_free(expr); /* oops, it's a while (0) */
4338 return NULL; /* listop already freed by new_logop */
4341 ((LISTOP*)listop)->op_last->op_next =
4342 (o == listop ? redo : LINKLIST(o));
4348 NewOp(1101,loop,1,LOOP);
4349 loop->op_type = OP_ENTERLOOP;
4350 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4351 loop->op_private = 0;
4352 loop->op_next = (OP*)loop;
4355 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4357 loop->op_redoop = redo;
4358 loop->op_lastop = o;
4359 o->op_private |= loopflags;
4362 loop->op_nextop = next;
4364 loop->op_nextop = o;
4366 o->op_flags |= flags;
4367 o->op_private |= (flags >> 8);
4372 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
4377 PADOFFSET padoff = 0;
4383 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4384 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
4385 sv->op_type = OP_RV2GV;
4386 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4387 if (cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
4388 iterpflags |= OPpITER_DEF;
4390 else if (sv->op_type == OP_PADSV) { /* private variable */
4391 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
4392 padoff = sv->op_targ;
4401 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4402 padoff = sv->op_targ;
4407 iterflags |= OPf_SPECIAL;
4413 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4414 if (padoff && strEQ(PAD_COMPNAME_PV(padoff), "$_"))
4415 iterpflags |= OPpITER_DEF;
4418 const I32 offset = pad_findmy("$_");
4419 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
4420 sv = newGVOP(OP_GV, 0, PL_defgv);
4425 iterpflags |= OPpITER_DEF;
4427 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4428 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4429 iterflags |= OPf_STACKED;
4431 else if (expr->op_type == OP_NULL &&
4432 (expr->op_flags & OPf_KIDS) &&
4433 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4435 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4436 * set the STACKED flag to indicate that these values are to be
4437 * treated as min/max values by 'pp_iterinit'.
4439 UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4440 LOGOP* const range = (LOGOP*) flip->op_first;
4441 OP* const left = range->op_first;
4442 OP* const right = left->op_sibling;
4445 range->op_flags &= ~OPf_KIDS;
4446 range->op_first = NULL;
4448 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4449 listop->op_first->op_next = range->op_next;
4450 left->op_next = range->op_other;
4451 right->op_next = (OP*)listop;
4452 listop->op_next = listop->op_first;
4455 op_getmad(expr,(OP*)listop,'O');
4459 expr = (OP*)(listop);
4461 iterflags |= OPf_STACKED;
4464 expr = mod(force_list(expr), OP_GREPSTART);
4467 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4468 append_elem(OP_LIST, expr, scalar(sv))));
4469 assert(!loop->op_next);
4470 /* for my $x () sets OPpLVAL_INTRO;
4471 * for our $x () sets OPpOUR_INTRO */
4472 loop->op_private = (U8)iterpflags;
4473 #ifdef PL_OP_SLAB_ALLOC
4476 NewOp(1234,tmp,1,LOOP);
4477 Copy(loop,tmp,1,LISTOP);
4482 Renew(loop, 1, LOOP);
4484 loop->op_targ = padoff;
4485 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
4487 op_getmad(madsv, (OP*)loop, 'v');
4488 PL_copline = forline;
4489 return newSTATEOP(0, label, wop);
4493 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4498 if (type != OP_GOTO || label->op_type == OP_CONST) {
4499 /* "last()" means "last" */
4500 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4501 o = newOP(type, OPf_SPECIAL);
4503 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4504 ? SvPVx_nolen_const(((SVOP*)label)->op_sv)
4508 op_getmad(label,o,'L');
4514 /* Check whether it's going to be a goto &function */
4515 if (label->op_type == OP_ENTERSUB
4516 && !(label->op_flags & OPf_STACKED))
4517 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4518 o = newUNOP(type, OPf_STACKED, label);
4520 PL_hints |= HINT_BLOCK_SCOPE;
4524 /* if the condition is a literal array or hash
4525 (or @{ ... } etc), make a reference to it.
4528 S_ref_array_or_hash(pTHX_ OP *cond)
4531 && (cond->op_type == OP_RV2AV
4532 || cond->op_type == OP_PADAV
4533 || cond->op_type == OP_RV2HV
4534 || cond->op_type == OP_PADHV))
4536 return newUNOP(OP_REFGEN,
4537 0, mod(cond, OP_REFGEN));
4543 /* These construct the optree fragments representing given()
4546 entergiven and enterwhen are LOGOPs; the op_other pointer
4547 points up to the associated leave op. We need this so we
4548 can put it in the context and make break/continue work.
4549 (Also, of course, pp_enterwhen will jump straight to
4550 op_other if the match fails.)
4555 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
4556 I32 enter_opcode, I32 leave_opcode,
4557 PADOFFSET entertarg)
4563 NewOp(1101, enterop, 1, LOGOP);
4564 enterop->op_type = enter_opcode;
4565 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
4566 enterop->op_flags = (U8) OPf_KIDS;
4567 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
4568 enterop->op_private = 0;
4570 o = newUNOP(leave_opcode, 0, (OP *) enterop);
4573 enterop->op_first = scalar(cond);
4574 cond->op_sibling = block;
4576 o->op_next = LINKLIST(cond);
4577 cond->op_next = (OP *) enterop;
4580 /* This is a default {} block */
4581 enterop->op_first = block;
4582 enterop->op_flags |= OPf_SPECIAL;
4584 o->op_next = (OP *) enterop;
4587 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
4588 entergiven and enterwhen both
4591 enterop->op_next = LINKLIST(block);
4592 block->op_next = enterop->op_other = o;
4597 /* Does this look like a boolean operation? For these purposes
4598 a boolean operation is:
4599 - a subroutine call [*]
4600 - a logical connective
4601 - a comparison operator
4602 - a filetest operator, with the exception of -s -M -A -C
4603 - defined(), exists() or eof()
4604 - /$re/ or $foo =~ /$re/
4606 [*] possibly surprising
4610 S_looks_like_bool(pTHX_ OP *o)
4613 switch(o->op_type) {
4615 return looks_like_bool(cLOGOPo->op_first);
4619 looks_like_bool(cLOGOPo->op_first)
4620 && looks_like_bool(cLOGOPo->op_first->op_sibling));
4624 case OP_NOT: case OP_XOR:
4625 /* Note that OP_DOR is not here */
4627 case OP_EQ: case OP_NE: case OP_LT:
4628 case OP_GT: case OP_LE: case OP_GE:
4630 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
4631 case OP_I_GT: case OP_I_LE: case OP_I_GE:
4633 case OP_SEQ: case OP_SNE: case OP_SLT:
4634 case OP_SGT: case OP_SLE: case OP_SGE:
4638 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
4639 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
4640 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
4641 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
4642 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
4643 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
4644 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
4645 case OP_FTTEXT: case OP_FTBINARY:
4647 case OP_DEFINED: case OP_EXISTS:
4648 case OP_MATCH: case OP_EOF:
4653 /* Detect comparisons that have been optimized away */
4654 if (cSVOPo->op_sv == &PL_sv_yes
4655 || cSVOPo->op_sv == &PL_sv_no)
4666 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
4670 return newGIVWHENOP(
4671 ref_array_or_hash(cond),
4673 OP_ENTERGIVEN, OP_LEAVEGIVEN,
4677 /* If cond is null, this is a default {} block */
4679 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
4681 bool cond_llb = (!cond || looks_like_bool(cond));
4687 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
4689 scalar(ref_array_or_hash(cond)));
4692 return newGIVWHENOP(
4694 append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
4695 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
4699 =for apidoc cv_undef
4701 Clear out all the active components of a CV. This can happen either
4702 by an explicit C<undef &foo>, or by the reference count going to zero.
4703 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
4704 children can still follow the full lexical scope chain.
4710 Perl_cv_undef(pTHX_ CV *cv)
4714 if (CvFILE(cv) && !CvISXSUB(cv)) {
4715 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4716 Safefree(CvFILE(cv));
4721 if (!CvISXSUB(cv) && CvROOT(cv)) {
4722 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
4723 Perl_croak(aTHX_ "Can't undef active subroutine");
4726 PAD_SAVE_SETNULLPAD();
4728 op_free(CvROOT(cv));
4733 SvPOK_off((SV*)cv); /* forget prototype */
4738 /* remove CvOUTSIDE unless this is an undef rather than a free */
4739 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
4740 if (!CvWEAKOUTSIDE(cv))
4741 SvREFCNT_dec(CvOUTSIDE(cv));
4742 CvOUTSIDE(cv) = NULL;
4745 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4748 if (CvISXSUB(cv) && CvXSUB(cv)) {
4751 /* delete all flags except WEAKOUTSIDE */
4752 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
4756 Perl_cv_ckproto(pTHX_ const CV *cv, const GV *gv, const char *p)
4758 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX_const(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4759 SV* const msg = sv_newmortal();
4763 gv_efullname3(name = sv_newmortal(), gv, NULL);
4764 sv_setpv(msg, "Prototype mismatch:");
4766 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4768 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (const SV *)cv);
4770 sv_catpvs(msg, ": none");
4771 sv_catpvs(msg, " vs ");
4773 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4775 sv_catpvs(msg, "none");
4776 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
4780 static void const_sv_xsub(pTHX_ CV* cv);
4784 =head1 Optree Manipulation Functions
4786 =for apidoc cv_const_sv
4788 If C<cv> is a constant sub eligible for inlining. returns the constant
4789 value returned by the sub. Otherwise, returns NULL.
4791 Constant subs can be created with C<newCONSTSUB> or as described in
4792 L<perlsub/"Constant Functions">.
4797 Perl_cv_const_sv(pTHX_ CV *cv)
4799 PERL_UNUSED_CONTEXT;
4802 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
4804 return CvCONST(cv) ? (SV*)CvXSUBANY(cv).any_ptr : NULL;
4807 /* op_const_sv: examine an optree to determine whether it's in-lineable.
4808 * Can be called in 3 ways:
4811 * look for a single OP_CONST with attached value: return the value
4813 * cv && CvCLONE(cv) && !CvCONST(cv)
4815 * examine the clone prototype, and if contains only a single
4816 * OP_CONST referencing a pad const, or a single PADSV referencing
4817 * an outer lexical, return a non-zero value to indicate the CV is
4818 * a candidate for "constizing" at clone time
4822 * We have just cloned an anon prototype that was marked as a const
4823 * candidiate. Try to grab the current value, and in the case of
4824 * PADSV, ignore it if it has multiple references. Return the value.
4828 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
4836 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4837 o = cLISTOPo->op_first->op_sibling;
4839 for (; o; o = o->op_next) {
4840 const OPCODE type = o->op_type;
4842 if (sv && o->op_next == o)
4844 if (o->op_next != o) {
4845 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4847 if (type == OP_DBSTATE)
4850 if (type == OP_LEAVESUB || type == OP_RETURN)
4854 if (type == OP_CONST && cSVOPo->op_sv)
4856 else if (cv && type == OP_CONST) {
4857 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4861 else if (cv && type == OP_PADSV) {
4862 if (CvCONST(cv)) { /* newly cloned anon */
4863 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4864 /* the candidate should have 1 ref from this pad and 1 ref
4865 * from the parent */
4866 if (!sv || SvREFCNT(sv) != 2)
4873 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
4874 sv = &PL_sv_undef; /* an arbitrary non-null value */
4889 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4892 /* This would be the return value, but the return cannot be reached. */
4893 OP* pegop = newOP(OP_NULL, 0);
4896 PERL_UNUSED_ARG(floor);
4906 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4908 NORETURN_FUNCTION_END;
4913 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4915 return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
4919 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4926 register CV *cv = NULL;
4928 /* If the subroutine has no body, no attributes, and no builtin attributes
4929 then it's just a sub declaration, and we may be able to get away with
4930 storing with a placeholder scalar in the symbol table, rather than a
4931 full GV and CV. If anything is present then it will take a full CV to
4933 const I32 gv_fetch_flags
4934 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
4936 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
4937 const char * const name = o ? SvPVx_nolen_const(cSVOPo->op_sv) : NULL;
4940 assert(proto->op_type == OP_CONST);
4941 ps = SvPVx_const(((SVOP*)proto)->op_sv, ps_len);
4946 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4947 SV * const sv = sv_newmortal();
4948 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4949 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
4950 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4951 aname = SvPVX_const(sv);
4956 gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
4957 : gv_fetchpv(aname ? aname
4958 : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4959 gv_fetch_flags, SVt_PVCV);
4961 if (!PL_madskills) {
4970 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4971 maximum a prototype before. */
4972 if (SvTYPE(gv) > SVt_NULL) {
4973 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4974 && ckWARN_d(WARN_PROTOTYPE))
4976 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
4978 cv_ckproto((CV*)gv, NULL, ps);
4981 sv_setpvn((SV*)gv, ps, ps_len);
4983 sv_setiv((SV*)gv, -1);
4984 SvREFCNT_dec(PL_compcv);
4985 cv = PL_compcv = NULL;
4986 PL_sub_generation++;
4990 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
4992 #ifdef GV_UNIQUE_CHECK
4993 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4994 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4998 if (!block || !ps || *ps || attrs
4999 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5001 || block->op_type == OP_NULL
5006 const_sv = op_const_sv(block, NULL);
5009 const bool exists = CvROOT(cv) || CvXSUB(cv);
5011 #ifdef GV_UNIQUE_CHECK
5012 if (exists && GvUNIQUE(gv)) {
5013 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
5017 /* if the subroutine doesn't exist and wasn't pre-declared
5018 * with a prototype, assume it will be AUTOLOADed,
5019 * skipping the prototype check
5021 if (exists || SvPOK(cv))
5022 cv_ckproto(cv, gv, ps);
5023 /* already defined (or promised)? */
5024 if (exists || GvASSUMECV(gv)) {
5027 || block->op_type == OP_NULL
5030 if (CvFLAGS(PL_compcv)) {
5031 /* might have had built-in attrs applied */
5032 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5034 /* just a "sub foo;" when &foo is already defined */
5035 SAVEFREESV(PL_compcv);
5040 && block->op_type != OP_NULL
5043 if (ckWARN(WARN_REDEFINE)
5045 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
5047 const line_t oldline = CopLINE(PL_curcop);
5048 if (PL_copline != NOLINE)
5049 CopLINE_set(PL_curcop, PL_copline);
5050 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5051 CvCONST(cv) ? "Constant subroutine %s redefined"
5052 : "Subroutine %s redefined", name);
5053 CopLINE_set(PL_curcop, oldline);
5056 if (!PL_minus_c) /* keep old one around for madskills */
5059 /* (PL_madskills unset in used file.) */
5067 SvREFCNT_inc_void_NN(const_sv);
5069 assert(!CvROOT(cv) && !CvCONST(cv));
5070 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
5071 CvXSUBANY(cv).any_ptr = const_sv;
5072 CvXSUB(cv) = const_sv_xsub;
5078 cv = newCONSTSUB(NULL, name, const_sv);
5080 PL_sub_generation++;
5084 SvREFCNT_dec(PL_compcv);
5092 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
5093 * before we clobber PL_compcv.
5097 || block->op_type == OP_NULL
5101 /* Might have had built-in attributes applied -- propagate them. */
5102 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5103 if (CvGV(cv) && GvSTASH(CvGV(cv)))
5104 stash = GvSTASH(CvGV(cv));
5105 else if (CvSTASH(cv))
5106 stash = CvSTASH(cv);
5108 stash = PL_curstash;
5111 /* possibly about to re-define existing subr -- ignore old cv */
5112 rcv = (SV*)PL_compcv;
5113 if (name && GvSTASH(gv))
5114 stash = GvSTASH(gv);
5116 stash = PL_curstash;
5118 apply_attrs(stash, rcv, attrs, FALSE);
5120 if (cv) { /* must reuse cv if autoloaded */
5127 || block->op_type == OP_NULL) && !PL_madskills
5130 /* got here with just attrs -- work done, so bug out */
5131 SAVEFREESV(PL_compcv);
5134 /* transfer PL_compcv to cv */
5136 CvFLAGS(cv) = CvFLAGS(PL_compcv);
5137 if (!CvWEAKOUTSIDE(cv))
5138 SvREFCNT_dec(CvOUTSIDE(cv));
5139 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
5140 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
5141 CvOUTSIDE(PL_compcv) = 0;
5142 CvPADLIST(cv) = CvPADLIST(PL_compcv);
5143 CvPADLIST(PL_compcv) = 0;
5144 /* inner references to PL_compcv must be fixed up ... */
5145 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
5146 /* ... before we throw it away */
5147 SvREFCNT_dec(PL_compcv);
5149 if (PERLDB_INTER)/* Advice debugger on the new sub. */
5150 ++PL_sub_generation;
5157 if (strEQ(name, "import")) {
5158 PL_formfeed = (SV*)cv;
5159 Perl_warner(aTHX_ packWARN(WARN_VOID), "%lx\n", (long)cv);
5163 PL_sub_generation++;
5167 CvFILE_set_from_cop(cv, PL_curcop);
5168 CvSTASH(cv) = PL_curstash;
5171 sv_setpvn((SV*)cv, ps, ps_len);
5173 if (PL_error_count) {
5177 const char *s = strrchr(name, ':');
5179 if (strEQ(s, "BEGIN")) {
5180 const char not_safe[] =
5181 "BEGIN not safe after errors--compilation aborted";
5182 if (PL_in_eval & EVAL_KEEPERR)
5183 Perl_croak(aTHX_ not_safe);
5185 /* force display of errors found but not reported */
5186 sv_catpv(ERRSV, not_safe);
5187 Perl_croak(aTHX_ "%"SVf, ERRSV);
5197 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5198 mod(scalarseq(block), OP_LEAVESUBLV));
5201 /* This makes sub {}; work as expected. */
5202 if (block->op_type == OP_STUB) {
5203 OP* newblock = newSTATEOP(0, NULL, 0);
5205 op_getmad(block,newblock,'B');
5211 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5213 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5214 OpREFCNT_set(CvROOT(cv), 1);
5215 CvSTART(cv) = LINKLIST(CvROOT(cv));
5216 CvROOT(cv)->op_next = 0;
5217 CALL_PEEP(CvSTART(cv));
5219 /* now that optimizer has done its work, adjust pad values */
5221 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
5224 assert(!CvCONST(cv));
5225 if (ps && !*ps && op_const_sv(block, cv))
5229 if (name || aname) {
5231 const char * const tname = (name ? name : aname);
5233 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5234 SV * const sv = newSV(0);
5235 SV * const tmpstr = sv_newmortal();
5236 GV * const db_postponed = gv_fetchpvs("DB::postponed",
5237 GV_ADDMULTI, SVt_PVHV);
5240 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5242 (long)PL_subline, (long)CopLINE(PL_curcop));
5243 gv_efullname3(tmpstr, gv, NULL);
5244 hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0);
5245 hv = GvHVn(db_postponed);
5246 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
5247 CV * const pcv = GvCV(db_postponed);
5253 call_sv((SV*)pcv, G_DISCARD);
5258 if ((s = strrchr(tname,':')))
5263 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5266 if (strEQ(s, "BEGIN") && !PL_error_count) {
5267 const I32 oldscope = PL_scopestack_ix;
5269 SAVECOPFILE(&PL_compiling);
5270 SAVECOPLINE(&PL_compiling);
5273 PL_beginav = newAV();
5274 DEBUG_x( dump_sub(gv) );
5275 av_push(PL_beginav, (SV*)cv);
5276 GvCV(gv) = 0; /* cv has been hijacked */
5277 call_list(oldscope, PL_beginav);
5279 PL_curcop = &PL_compiling;
5280 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
5283 else if (strEQ(s, "END") && !PL_error_count) {
5286 DEBUG_x( dump_sub(gv) );
5287 av_unshift(PL_endav, 1);
5288 av_store(PL_endav, 0, (SV*)cv);
5289 GvCV(gv) = 0; /* cv has been hijacked */
5291 else if (strEQ(s, "CHECK") && !PL_error_count) {
5293 PL_checkav = newAV();
5294 DEBUG_x( dump_sub(gv) );
5295 if (PL_main_start && ckWARN(WARN_VOID))
5296 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
5297 av_unshift(PL_checkav, 1);
5298 av_store(PL_checkav, 0, (SV*)cv);
5299 GvCV(gv) = 0; /* cv has been hijacked */
5301 else if (strEQ(s, "INIT") && !PL_error_count) {
5303 PL_initav = newAV();
5304 DEBUG_x( dump_sub(gv) );
5305 if (PL_main_start && ckWARN(WARN_VOID))
5306 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
5307 av_push(PL_initav, (SV*)cv);
5308 GvCV(gv) = 0; /* cv has been hijacked */
5313 PL_copline = NOLINE;
5318 /* XXX unsafe for threads if eval_owner isn't held */
5320 =for apidoc newCONSTSUB
5322 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5323 eligible for inlining at compile-time.
5329 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
5336 SAVECOPLINE(PL_curcop);
5337 CopLINE_set(PL_curcop, PL_copline);
5340 PL_hints &= ~HINT_BLOCK_SCOPE;
5343 SAVESPTR(PL_curstash);
5344 SAVECOPSTASH(PL_curcop);
5345 PL_curstash = stash;
5346 CopSTASH_set(PL_curcop,stash);
5349 cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
5350 CvXSUBANY(cv).any_ptr = sv;
5352 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
5356 CopSTASH_free(PL_curcop);
5364 =for apidoc U||newXS
5366 Used by C<xsubpp> to hook up XSUBs as Perl subs.
5372 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
5375 GV * const gv = gv_fetchpv(name ? name :
5376 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5377 GV_ADDMULTI, SVt_PVCV);
5381 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
5383 if ((cv = (name ? GvCV(gv) : NULL))) {
5385 /* just a cached method */
5389 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5390 /* already defined (or promised) */
5391 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
5392 if (ckWARN(WARN_REDEFINE)) {
5393 GV * const gvcv = CvGV(cv);
5395 HV * const stash = GvSTASH(gvcv);
5397 const char *redefined_name = HvNAME_get(stash);
5398 if ( strEQ(redefined_name,"autouse") ) {
5399 const line_t oldline = CopLINE(PL_curcop);
5400 if (PL_copline != NOLINE)
5401 CopLINE_set(PL_curcop, PL_copline);
5402 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5403 CvCONST(cv) ? "Constant subroutine %s redefined"
5404 : "Subroutine %s redefined"
5406 CopLINE_set(PL_curcop, oldline);
5416 if (cv) /* must reuse cv if autoloaded */
5420 sv_upgrade((SV *)cv, SVt_PVCV);
5424 PL_sub_generation++;
5428 (void)gv_fetchfile(filename);
5429 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
5430 an external constant string */
5432 CvXSUB(cv) = subaddr;
5435 const char *s = strrchr(name,':');
5441 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5444 if (strEQ(s, "BEGIN")) {
5446 PL_beginav = newAV();
5447 av_push(PL_beginav, (SV*)cv);
5448 GvCV(gv) = 0; /* cv has been hijacked */
5450 else if (strEQ(s, "END")) {
5453 av_unshift(PL_endav, 1);
5454 av_store(PL_endav, 0, (SV*)cv);
5455 GvCV(gv) = 0; /* cv has been hijacked */
5457 else if (strEQ(s, "CHECK")) {
5459 PL_checkav = newAV();
5460 if (PL_main_start && ckWARN(WARN_VOID))
5461 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
5462 av_unshift(PL_checkav, 1);
5463 av_store(PL_checkav, 0, (SV*)cv);
5464 GvCV(gv) = 0; /* cv has been hijacked */
5466 else if (strEQ(s, "INIT")) {
5468 PL_initav = newAV();
5469 if (PL_main_start && ckWARN(WARN_VOID))
5470 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
5471 av_push(PL_initav, (SV*)cv);
5472 GvCV(gv) = 0; /* cv has been hijacked */
5487 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5492 OP* pegop = newOP(OP_NULL, 0);
5496 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
5497 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
5499 #ifdef GV_UNIQUE_CHECK
5501 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5505 if ((cv = GvFORM(gv))) {
5506 if (ckWARN(WARN_REDEFINE)) {
5507 const line_t oldline = CopLINE(PL_curcop);
5508 if (PL_copline != NOLINE)
5509 CopLINE_set(PL_curcop, PL_copline);
5510 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5511 o ? "Format %"SVf" redefined"
5512 : "Format STDOUT redefined" ,cSVOPo->op_sv);
5513 CopLINE_set(PL_curcop, oldline);
5520 CvFILE_set_from_cop(cv, PL_curcop);
5523 pad_tidy(padtidy_FORMAT);
5524 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5525 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5526 OpREFCNT_set(CvROOT(cv), 1);
5527 CvSTART(cv) = LINKLIST(CvROOT(cv));
5528 CvROOT(cv)->op_next = 0;
5529 CALL_PEEP(CvSTART(cv));
5531 op_getmad(o,pegop,'n');
5532 op_getmad_weak(block, pegop, 'b');
5536 PL_copline = NOLINE;
5544 Perl_newANONLIST(pTHX_ OP *o)
5546 return newUNOP(OP_REFGEN, 0,
5547 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5551 Perl_newANONHASH(pTHX_ OP *o)
5553 return newUNOP(OP_REFGEN, 0,
5554 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5558 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5560 return newANONATTRSUB(floor, proto, NULL, block);
5564 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5566 return newUNOP(OP_REFGEN, 0,
5567 newSVOP(OP_ANONCODE, 0,
5568 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5572 Perl_oopsAV(pTHX_ OP *o)
5575 switch (o->op_type) {
5577 o->op_type = OP_PADAV;
5578 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5579 return ref(o, OP_RV2AV);
5582 o->op_type = OP_RV2AV;
5583 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5588 if (ckWARN_d(WARN_INTERNAL))
5589 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
5596 Perl_oopsHV(pTHX_ OP *o)
5599 switch (o->op_type) {
5602 o->op_type = OP_PADHV;
5603 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5604 return ref(o, OP_RV2HV);
5608 o->op_type = OP_RV2HV;
5609 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5614 if (ckWARN_d(WARN_INTERNAL))
5615 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
5622 Perl_newAVREF(pTHX_ OP *o)
5625 if (o->op_type == OP_PADANY) {
5626 o->op_type = OP_PADAV;
5627 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5630 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5631 && ckWARN(WARN_DEPRECATED)) {
5632 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5633 "Using an array as a reference is deprecated");
5635 return newUNOP(OP_RV2AV, 0, scalar(o));
5639 Perl_newGVREF(pTHX_ I32 type, OP *o)
5641 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5642 return newUNOP(OP_NULL, 0, o);
5643 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5647 Perl_newHVREF(pTHX_ OP *o)
5650 if (o->op_type == OP_PADANY) {
5651 o->op_type = OP_PADHV;
5652 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5655 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5656 && ckWARN(WARN_DEPRECATED)) {
5657 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5658 "Using a hash as a reference is deprecated");
5660 return newUNOP(OP_RV2HV, 0, scalar(o));
5664 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5666 return newUNOP(OP_RV2CV, flags, scalar(o));
5670 Perl_newSVREF(pTHX_ OP *o)
5673 if (o->op_type == OP_PADANY) {
5674 o->op_type = OP_PADSV;
5675 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5678 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5679 o->op_flags |= OPpDONE_SVREF;
5682 return newUNOP(OP_RV2SV, 0, scalar(o));
5685 /* Check routines. See the comments at the top of this file for details
5686 * on when these are called */
5689 Perl_ck_anoncode(pTHX_ OP *o)
5691 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
5693 cSVOPo->op_sv = Nullsv;
5698 Perl_ck_bitop(pTHX_ OP *o)
5701 #define OP_IS_NUMCOMPARE(op) \
5702 ((op) == OP_LT || (op) == OP_I_LT || \
5703 (op) == OP_GT || (op) == OP_I_GT || \
5704 (op) == OP_LE || (op) == OP_I_LE || \
5705 (op) == OP_GE || (op) == OP_I_GE || \
5706 (op) == OP_EQ || (op) == OP_I_EQ || \
5707 (op) == OP_NE || (op) == OP_I_NE || \
5708 (op) == OP_NCMP || (op) == OP_I_NCMP)
5709 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
5710 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
5711 && (o->op_type == OP_BIT_OR
5712 || o->op_type == OP_BIT_AND
5713 || o->op_type == OP_BIT_XOR))
5715 const OP * const left = cBINOPo->op_first;
5716 const OP * const right = left->op_sibling;
5717 if ((OP_IS_NUMCOMPARE(left->op_type) &&
5718 (left->op_flags & OPf_PARENS) == 0) ||
5719 (OP_IS_NUMCOMPARE(right->op_type) &&
5720 (right->op_flags & OPf_PARENS) == 0))
5721 if (ckWARN(WARN_PRECEDENCE))
5722 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
5723 "Possible precedence problem on bitwise %c operator",
5724 o->op_type == OP_BIT_OR ? '|'
5725 : o->op_type == OP_BIT_AND ? '&' : '^'
5732 Perl_ck_concat(pTHX_ OP *o)
5734 const OP * const kid = cUNOPo->op_first;
5735 PERL_UNUSED_CONTEXT;
5736 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
5737 !(kUNOP->op_first->op_flags & OPf_MOD))
5738 o->op_flags |= OPf_STACKED;
5743 Perl_ck_spair(pTHX_ OP *o)
5746 if (o->op_flags & OPf_KIDS) {
5749 const OPCODE type = o->op_type;
5750 o = modkids(ck_fun(o), type);
5751 kid = cUNOPo->op_first;
5752 newop = kUNOP->op_first->op_sibling;
5754 (newop->op_sibling ||
5755 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5756 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5757 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5762 op_getmad(kUNOP->op_first,newop,'K');
5764 op_free(kUNOP->op_first);
5766 kUNOP->op_first = newop;
5768 o->op_ppaddr = PL_ppaddr[++o->op_type];
5773 Perl_ck_delete(pTHX_ OP *o)
5777 if (o->op_flags & OPf_KIDS) {
5778 OP * const kid = cUNOPo->op_first;
5779 switch (kid->op_type) {
5781 o->op_flags |= OPf_SPECIAL;
5784 o->op_private |= OPpSLICE;
5787 o->op_flags |= OPf_SPECIAL;
5792 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5801 Perl_ck_die(pTHX_ OP *o)
5804 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5810 Perl_ck_eof(pTHX_ OP *o)
5813 const I32 type = o->op_type;
5815 if (o->op_flags & OPf_KIDS) {
5816 if (cLISTOPo->op_first->op_type == OP_STUB) {
5818 = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
5820 op_getmad(o,newop,'O');
5832 Perl_ck_eval(pTHX_ OP *o)
5835 PL_hints |= HINT_BLOCK_SCOPE;
5836 if (o->op_flags & OPf_KIDS) {
5837 SVOP * const kid = (SVOP*)cUNOPo->op_first;
5840 o->op_flags &= ~OPf_KIDS;
5843 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
5849 cUNOPo->op_first = 0;
5854 NewOp(1101, enter, 1, LOGOP);
5855 enter->op_type = OP_ENTERTRY;
5856 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5857 enter->op_private = 0;
5859 /* establish postfix order */
5860 enter->op_next = (OP*)enter;
5862 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5863 o->op_type = OP_LEAVETRY;
5864 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5865 enter->op_other = o;
5866 op_getmad(oldo,o,'O');
5880 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5881 op_getmad(oldo,o,'O');
5883 o->op_targ = (PADOFFSET)PL_hints;
5884 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
5885 /* Store a copy of %^H that pp_entereval can pick up */
5886 OP *hhop = newSVOP(OP_CONST, 0, (SV*)newHVhv(GvHV(PL_hintgv)));
5887 cUNOPo->op_first->op_sibling = hhop;
5888 o->op_private |= OPpEVAL_HAS_HH;
5894 Perl_ck_exit(pTHX_ OP *o)
5897 HV * const table = GvHV(PL_hintgv);
5899 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
5900 if (svp && *svp && SvTRUE(*svp))
5901 o->op_private |= OPpEXIT_VMSISH;
5903 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5909 Perl_ck_exec(pTHX_ OP *o)
5911 if (o->op_flags & OPf_STACKED) {
5914 kid = cUNOPo->op_first->op_sibling;
5915 if (kid->op_type == OP_RV2GV)
5924 Perl_ck_exists(pTHX_ OP *o)
5928 if (o->op_flags & OPf_KIDS) {
5929 OP * const kid = cUNOPo->op_first;
5930 if (kid->op_type == OP_ENTERSUB) {
5931 (void) ref(kid, o->op_type);
5932 if (kid->op_type != OP_RV2CV && !PL_error_count)
5933 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5935 o->op_private |= OPpEXISTS_SUB;
5937 else if (kid->op_type == OP_AELEM)
5938 o->op_flags |= OPf_SPECIAL;
5939 else if (kid->op_type != OP_HELEM)
5940 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5948 Perl_ck_rvconst(pTHX_ register OP *o)
5951 SVOP * const kid = (SVOP*)cUNOPo->op_first;
5953 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5954 if (o->op_type == OP_RV2CV)
5955 o->op_private &= ~1;
5957 if (kid->op_type == OP_CONST) {
5960 SV * const kidsv = kid->op_sv;
5962 /* Is it a constant from cv_const_sv()? */
5963 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5964 SV * const rsv = SvRV(kidsv);
5965 const int svtype = SvTYPE(rsv);
5966 const char *badtype = NULL;
5968 switch (o->op_type) {
5970 if (svtype > SVt_PVMG)
5971 badtype = "a SCALAR";
5974 if (svtype != SVt_PVAV)
5975 badtype = "an ARRAY";
5978 if (svtype != SVt_PVHV)
5982 if (svtype != SVt_PVCV)
5987 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5990 else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
5991 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
5992 /* If this is an access to a stash, disable "strict refs", because
5993 * stashes aren't auto-vivified at compile-time (unless we store
5994 * symbols in them), and we don't want to produce a run-time
5995 * stricture error when auto-vivifying the stash. */
5996 const char *s = SvPV_nolen(kidsv);
5997 const STRLEN l = SvCUR(kidsv);
5998 if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
5999 o->op_private &= ~HINT_STRICT_REFS;
6001 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
6002 const char *badthing;
6003 switch (o->op_type) {
6005 badthing = "a SCALAR";
6008 badthing = "an ARRAY";
6011 badthing = "a HASH";
6019 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
6023 * This is a little tricky. We only want to add the symbol if we
6024 * didn't add it in the lexer. Otherwise we get duplicate strict
6025 * warnings. But if we didn't add it in the lexer, we must at
6026 * least pretend like we wanted to add it even if it existed before,
6027 * or we get possible typo warnings. OPpCONST_ENTERED says
6028 * whether the lexer already added THIS instance of this symbol.
6030 iscv = (o->op_type == OP_RV2CV) * 2;
6032 gv = gv_fetchsv(kidsv,
6033 iscv | !(kid->op_private & OPpCONST_ENTERED),
6036 : o->op_type == OP_RV2SV
6038 : o->op_type == OP_RV2AV
6040 : o->op_type == OP_RV2HV
6043 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
6045 kid->op_type = OP_GV;
6046 SvREFCNT_dec(kid->op_sv);
6048 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
6049 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
6050 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
6052 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc_simple_NN(gv));
6054 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
6056 kid->op_private = 0;
6057 kid->op_ppaddr = PL_ppaddr[OP_GV];
6064 Perl_ck_ftst(pTHX_ OP *o)
6067 const I32 type = o->op_type;
6069 if (o->op_flags & OPf_REF) {
6072 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
6073 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6075 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6076 OP * const newop = newGVOP(type, OPf_REF,
6077 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
6079 op_getmad(o,newop,'O');
6087 if ((PL_hints & HINT_FILETEST_ACCESS) &&
6088 OP_IS_FILETEST_ACCESS(o))
6089 o->op_private |= OPpFT_ACCESS;
6091 if (PL_check[kid->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst)
6092 && kid->op_type != OP_STAT && kid->op_type != OP_LSTAT)
6093 o->op_private |= OPpFT_STACKED;
6101 if (type == OP_FTTTY)
6102 o = newGVOP(type, OPf_REF, PL_stdingv);
6104 o = newUNOP(type, 0, newDEFSVOP());
6105 op_getmad(oldo,o,'O');
6111 Perl_ck_fun(pTHX_ OP *o)
6114 const int type = o->op_type;
6115 register I32 oa = PL_opargs[type] >> OASHIFT;
6117 if (o->op_flags & OPf_STACKED) {
6118 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
6121 return no_fh_allowed(o);
6124 if (o->op_flags & OPf_KIDS) {
6125 OP **tokid = &cLISTOPo->op_first;
6126 register OP *kid = cLISTOPo->op_first;
6130 if (kid->op_type == OP_PUSHMARK ||
6131 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
6133 tokid = &kid->op_sibling;
6134 kid = kid->op_sibling;
6136 if (!kid && PL_opargs[type] & OA_DEFGV)
6137 *tokid = kid = newDEFSVOP();
6141 sibl = kid->op_sibling;
6143 if (!sibl && kid->op_type == OP_STUB) {
6150 /* list seen where single (scalar) arg expected? */
6151 if (numargs == 1 && !(oa >> 4)
6152 && kid->op_type == OP_LIST && type != OP_SCALAR)
6154 return too_many_arguments(o,PL_op_desc[type]);
6167 if ((type == OP_PUSH || type == OP_UNSHIFT)
6168 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
6169 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6170 "Useless use of %s with no values",
6173 if (kid->op_type == OP_CONST &&
6174 (kid->op_private & OPpCONST_BARE))
6176 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
6177 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
6178 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6179 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6180 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
6181 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
6183 op_getmad(kid,newop,'K');
6188 kid->op_sibling = sibl;
6191 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
6192 bad_type(numargs, "array", PL_op_desc[type], kid);
6196 if (kid->op_type == OP_CONST &&
6197 (kid->op_private & OPpCONST_BARE))
6199 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
6200 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
6201 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6202 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6203 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
6204 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
6206 op_getmad(kid,newop,'K');
6211 kid->op_sibling = sibl;
6214 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
6215 bad_type(numargs, "hash", PL_op_desc[type], kid);
6220 OP * const newop = newUNOP(OP_NULL, 0, kid);
6221 kid->op_sibling = 0;
6223 newop->op_next = newop;
6225 kid->op_sibling = sibl;
6230 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
6231 if (kid->op_type == OP_CONST &&
6232 (kid->op_private & OPpCONST_BARE))
6234 OP * const newop = newGVOP(OP_GV, 0,
6235 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
6236 if (!(o->op_private & 1) && /* if not unop */
6237 kid == cLISTOPo->op_last)
6238 cLISTOPo->op_last = newop;
6240 op_getmad(kid,newop,'K');
6246 else if (kid->op_type == OP_READLINE) {
6247 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
6248 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
6251 I32 flags = OPf_SPECIAL;
6255 /* is this op a FH constructor? */
6256 if (is_handle_constructor(o,numargs)) {
6257 const char *name = NULL;
6261 /* Set a flag to tell rv2gv to vivify
6262 * need to "prove" flag does not mean something
6263 * else already - NI-S 1999/05/07
6266 if (kid->op_type == OP_PADSV) {
6267 name = PAD_COMPNAME_PV(kid->op_targ);
6268 /* SvCUR of a pad namesv can't be trusted
6269 * (see PL_generation), so calc its length
6275 else if (kid->op_type == OP_RV2SV
6276 && kUNOP->op_first->op_type == OP_GV)
6278 GV * const gv = cGVOPx_gv(kUNOP->op_first);
6280 len = GvNAMELEN(gv);
6282 else if (kid->op_type == OP_AELEM
6283 || kid->op_type == OP_HELEM)
6285 OP *op = ((BINOP*)kid)->op_first;
6289 const char * const a =
6290 kid->op_type == OP_AELEM ?
6292 if (((op->op_type == OP_RV2AV) ||
6293 (op->op_type == OP_RV2HV)) &&
6294 (op = ((UNOP*)op)->op_first) &&
6295 (op->op_type == OP_GV)) {
6296 /* packagevar $a[] or $h{} */
6297 GV * const gv = cGVOPx_gv(op);
6305 else if (op->op_type == OP_PADAV
6306 || op->op_type == OP_PADHV) {
6307 /* lexicalvar $a[] or $h{} */
6308 const char * const padname =
6309 PAD_COMPNAME_PV(op->op_targ);
6318 name = SvPV_const(tmpstr, len);
6323 name = "__ANONIO__";
6330 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
6331 namesv = PAD_SVl(targ);
6332 SvUPGRADE(namesv, SVt_PV);
6334 sv_setpvn(namesv, "$", 1);
6335 sv_catpvn(namesv, name, len);
6338 kid->op_sibling = 0;
6339 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
6340 kid->op_targ = targ;
6341 kid->op_private |= priv;
6343 kid->op_sibling = sibl;
6349 mod(scalar(kid), type);
6353 tokid = &kid->op_sibling;
6354 kid = kid->op_sibling;
6357 if (kid && kid->op_type != OP_STUB)
6358 return too_many_arguments(o,OP_DESC(o));
6359 o->op_private |= numargs;
6361 /* FIXME - should the numargs move as for the PERL_MAD case? */
6362 o->op_private |= numargs;
6364 return too_many_arguments(o,OP_DESC(o));
6368 else if (PL_opargs[type] & OA_DEFGV) {
6370 OP *newop = newUNOP(type, 0, newDEFSVOP());
6371 op_getmad(o,newop,'O');
6374 /* Ordering of these two is important to keep f_map.t passing. */
6376 return newUNOP(type, 0, newDEFSVOP());
6381 while (oa & OA_OPTIONAL)
6383 if (oa && oa != OA_LIST)
6384 return too_few_arguments(o,OP_DESC(o));
6390 Perl_ck_glob(pTHX_ OP *o)
6396 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
6397 append_elem(OP_GLOB, o, newDEFSVOP());
6399 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
6400 && GvCVu(gv) && GvIMPORTED_CV(gv)))
6402 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6405 #if !defined(PERL_EXTERNAL_GLOB)
6406 /* XXX this can be tightened up and made more failsafe. */
6407 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
6410 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
6411 newSVpvs("File::Glob"), NULL, NULL, NULL);
6412 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6413 glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
6414 GvCV(gv) = GvCV(glob_gv);
6415 SvREFCNT_inc_void((SV*)GvCV(gv));
6416 GvIMPORTED_CV_on(gv);
6419 #endif /* PERL_EXTERNAL_GLOB */
6421 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6422 append_elem(OP_GLOB, o,
6423 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
6424 o->op_type = OP_LIST;
6425 o->op_ppaddr = PL_ppaddr[OP_LIST];
6426 cLISTOPo->op_first->op_type = OP_PUSHMARK;
6427 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
6428 cLISTOPo->op_first->op_targ = 0;
6429 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
6430 append_elem(OP_LIST, o,
6431 scalar(newUNOP(OP_RV2CV, 0,
6432 newGVOP(OP_GV, 0, gv)))));
6433 o = newUNOP(OP_NULL, 0, ck_subr(o));
6434 o->op_targ = OP_GLOB; /* hint at what it used to be */
6437 gv = newGVgen("main");
6439 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
6445 Perl_ck_grep(pTHX_ OP *o)
6450 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
6453 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
6454 /* don't allocate gwop here, as we may leak it if PL_error_count > 0 */
6456 if (o->op_flags & OPf_STACKED) {
6459 kid = cLISTOPo->op_first->op_sibling;
6460 if (!cUNOPx(kid)->op_next)
6461 Perl_croak(aTHX_ "panic: ck_grep");
6462 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
6465 NewOp(1101, gwop, 1, LOGOP);
6466 kid->op_next = (OP*)gwop;
6467 o->op_flags &= ~OPf_STACKED;
6469 kid = cLISTOPo->op_first->op_sibling;
6470 if (type == OP_MAPWHILE)
6477 kid = cLISTOPo->op_first->op_sibling;
6478 if (kid->op_type != OP_NULL)
6479 Perl_croak(aTHX_ "panic: ck_grep");
6480 kid = kUNOP->op_first;
6483 NewOp(1101, gwop, 1, LOGOP);
6484 gwop->op_type = type;
6485 gwop->op_ppaddr = PL_ppaddr[type];
6486 gwop->op_first = listkids(o);
6487 gwop->op_flags |= OPf_KIDS;
6488 gwop->op_other = LINKLIST(kid);
6489 kid->op_next = (OP*)gwop;
6490 offset = pad_findmy("$_");
6491 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
6492 o->op_private = gwop->op_private = 0;
6493 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
6496 o->op_private = gwop->op_private = OPpGREP_LEX;
6497 gwop->op_targ = o->op_targ = offset;
6500 kid = cLISTOPo->op_first->op_sibling;
6501 if (!kid || !kid->op_sibling)
6502 return too_few_arguments(o,OP_DESC(o));
6503 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
6504 mod(kid, OP_GREPSTART);
6510 Perl_ck_index(pTHX_ OP *o)
6512 if (o->op_flags & OPf_KIDS) {
6513 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6515 kid = kid->op_sibling; /* get past "big" */
6516 if (kid && kid->op_type == OP_CONST)
6517 fbm_compile(((SVOP*)kid)->op_sv, 0);
6523 Perl_ck_lengthconst(pTHX_ OP *o)
6525 /* XXX length optimization goes here */
6530 Perl_ck_lfun(pTHX_ OP *o)
6532 const OPCODE type = o->op_type;
6533 return modkids(ck_fun(o), type);
6537 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
6539 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
6540 switch (cUNOPo->op_first->op_type) {
6542 /* This is needed for
6543 if (defined %stash::)
6544 to work. Do not break Tk.
6546 break; /* Globals via GV can be undef */
6548 case OP_AASSIGN: /* Is this a good idea? */
6549 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6550 "defined(@array) is deprecated");
6551 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6552 "\t(Maybe you should just omit the defined()?)\n");
6555 /* This is needed for
6556 if (defined %stash::)
6557 to work. Do not break Tk.
6559 break; /* Globals via GV can be undef */
6561 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6562 "defined(%%hash) is deprecated");
6563 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6564 "\t(Maybe you should just omit the defined()?)\n");
6575 Perl_ck_rfun(pTHX_ OP *o)
6577 const OPCODE type = o->op_type;
6578 return refkids(ck_fun(o), type);
6582 Perl_ck_listiob(pTHX_ OP *o)
6586 kid = cLISTOPo->op_first;
6589 kid = cLISTOPo->op_first;
6591 if (kid->op_type == OP_PUSHMARK)
6592 kid = kid->op_sibling;
6593 if (kid && o->op_flags & OPf_STACKED)
6594 kid = kid->op_sibling;
6595 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6596 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6597 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6598 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6599 cLISTOPo->op_first->op_sibling = kid;
6600 cLISTOPo->op_last = kid;
6601 kid = kid->op_sibling;
6606 append_elem(o->op_type, o, newDEFSVOP());
6612 Perl_ck_say(pTHX_ OP *o)
6615 o->op_type = OP_PRINT;
6616 cLISTOPo->op_last = cLISTOPo->op_last->op_sibling
6617 = newSVOP(OP_CONST, 0, newSVpvs("\n"));
6622 Perl_ck_smartmatch(pTHX_ OP *o)
6625 if (0 == (o->op_flags & OPf_SPECIAL)) {
6626 OP *first = cBINOPo->op_first;
6627 OP *second = first->op_sibling;
6629 /* Implicitly take a reference to an array or hash */
6630 first->op_sibling = NULL;
6631 first = cBINOPo->op_first = ref_array_or_hash(first);
6632 second = first->op_sibling = ref_array_or_hash(second);
6634 /* Implicitly take a reference to a regular expression */
6635 if (first->op_type == OP_MATCH) {
6636 first->op_type = OP_QR;
6637 first->op_ppaddr = PL_ppaddr[OP_QR];
6639 if (second->op_type == OP_MATCH) {
6640 second->op_type = OP_QR;
6641 second->op_ppaddr = PL_ppaddr[OP_QR];
6650 Perl_ck_sassign(pTHX_ OP *o)
6652 OP *kid = cLISTOPo->op_first;
6653 /* has a disposable target? */
6654 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6655 && !(kid->op_flags & OPf_STACKED)
6656 /* Cannot steal the second time! */
6657 && !(kid->op_private & OPpTARGET_MY))
6659 OP * const kkid = kid->op_sibling;
6661 /* Can just relocate the target. */
6662 if (kkid && kkid->op_type == OP_PADSV
6663 && !(kkid->op_private & OPpLVAL_INTRO))
6665 kid->op_targ = kkid->op_targ;
6667 /* Now we do not need PADSV and SASSIGN. */
6668 kid->op_sibling = o->op_sibling; /* NULL */
6669 cLISTOPo->op_first = NULL;
6671 op_getmad(o,kid,'O');
6672 op_getmad(kkid,kid,'M');
6677 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6685 Perl_ck_match(pTHX_ OP *o)
6688 if (o->op_type != OP_QR && PL_compcv) {
6689 const I32 offset = pad_findmy("$_");
6690 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
6691 o->op_targ = offset;
6692 o->op_private |= OPpTARGET_MY;
6695 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
6696 o->op_private |= OPpRUNTIME;
6701 Perl_ck_method(pTHX_ OP *o)
6703 OP * const kid = cUNOPo->op_first;
6704 if (kid->op_type == OP_CONST) {
6705 SV* sv = kSVOP->op_sv;
6706 const char * const method = SvPVX_const(sv);
6707 if (!(strchr(method, ':') || strchr(method, '\''))) {
6709 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6710 sv = newSVpvn_share(method, SvCUR(sv), 0);
6713 kSVOP->op_sv = NULL;
6715 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6717 op_getmad(o,cmop,'O');
6728 Perl_ck_null(pTHX_ OP *o)
6730 PERL_UNUSED_CONTEXT;
6735 Perl_ck_open(pTHX_ OP *o)
6738 HV * const table = GvHV(PL_hintgv);
6740 SV **svp = hv_fetchs(table, "open_IN", FALSE);
6742 const I32 mode = mode_from_discipline(*svp);
6743 if (mode & O_BINARY)
6744 o->op_private |= OPpOPEN_IN_RAW;
6745 else if (mode & O_TEXT)
6746 o->op_private |= OPpOPEN_IN_CRLF;
6749 svp = hv_fetchs(table, "open_OUT", FALSE);
6751 const I32 mode = mode_from_discipline(*svp);
6752 if (mode & O_BINARY)
6753 o->op_private |= OPpOPEN_OUT_RAW;
6754 else if (mode & O_TEXT)
6755 o->op_private |= OPpOPEN_OUT_CRLF;
6758 if (o->op_type == OP_BACKTICK)
6761 /* In case of three-arg dup open remove strictness
6762 * from the last arg if it is a bareword. */
6763 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
6764 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
6768 if ((last->op_type == OP_CONST) && /* The bareword. */
6769 (last->op_private & OPpCONST_BARE) &&
6770 (last->op_private & OPpCONST_STRICT) &&
6771 (oa = first->op_sibling) && /* The fh. */
6772 (oa = oa->op_sibling) && /* The mode. */
6773 (oa->op_type == OP_CONST) &&
6774 SvPOK(((SVOP*)oa)->op_sv) &&
6775 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
6776 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
6777 (last == oa->op_sibling)) /* The bareword. */
6778 last->op_private &= ~OPpCONST_STRICT;
6784 Perl_ck_repeat(pTHX_ OP *o)
6786 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6787 o->op_private |= OPpREPEAT_DOLIST;
6788 cBINOPo->op_first = force_list(cBINOPo->op_first);
6796 Perl_ck_require(pTHX_ OP *o)
6801 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6802 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6804 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6805 SV * const sv = kid->op_sv;
6806 U32 was_readonly = SvREADONLY(sv);
6811 sv_force_normal_flags(sv, 0);
6812 assert(!SvREADONLY(sv));
6819 for (s = SvPVX(sv); *s; s++) {
6820 if (*s == ':' && s[1] == ':') {
6821 const STRLEN len = strlen(s+2)+1;
6823 Move(s+2, s+1, len, char);
6824 SvCUR_set(sv, SvCUR(sv) - 1);
6827 sv_catpvs(sv, ".pm");
6828 SvFLAGS(sv) |= was_readonly;
6832 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
6833 /* handle override, if any */
6834 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
6835 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
6836 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
6837 gv = gvp ? *gvp : NULL;
6841 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6842 OP * const kid = cUNOPo->op_first;
6845 cUNOPo->op_first = 0;
6849 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
6850 append_elem(OP_LIST, kid,
6851 scalar(newUNOP(OP_RV2CV, 0,
6854 op_getmad(o,newop,'O');
6862 Perl_ck_return(pTHX_ OP *o)
6865 if (CvLVALUE(PL_compcv)) {
6867 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6868 mod(kid, OP_LEAVESUBLV);
6874 Perl_ck_select(pTHX_ OP *o)
6878 if (o->op_flags & OPf_KIDS) {
6879 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6880 if (kid && kid->op_sibling) {
6881 o->op_type = OP_SSELECT;
6882 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6884 return fold_constants(o);
6888 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6889 if (kid && kid->op_type == OP_RV2GV)
6890 kid->op_private &= ~HINT_STRICT_REFS;
6895 Perl_ck_shift(pTHX_ OP *o)
6898 const I32 type = o->op_type;
6900 if (!(o->op_flags & OPf_KIDS)) {
6902 /* FIXME - this can be refactored to reduce code in #ifdefs */
6908 argop = newUNOP(OP_RV2AV, 0,
6909 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
6911 o = newUNOP(type, 0, scalar(argop));
6912 op_getmad(oldo,o,'O');
6915 return newUNOP(type, 0, scalar(argop));
6918 return scalar(modkids(ck_fun(o), type));
6922 Perl_ck_sort(pTHX_ OP *o)
6927 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0)
6929 HV * const hinthv = GvHV(PL_hintgv);
6931 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
6933 const I32 sorthints = (I32)SvIV(*svp);
6934 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
6935 o->op_private |= OPpSORT_QSORT;
6936 if ((sorthints & HINT_SORT_STABLE) != 0)
6937 o->op_private |= OPpSORT_STABLE;
6942 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6944 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6945 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6947 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6949 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6951 if (kid->op_type == OP_SCOPE) {
6955 else if (kid->op_type == OP_LEAVE) {
6956 if (o->op_type == OP_SORT) {
6957 op_null(kid); /* wipe out leave */
6960 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6961 if (k->op_next == kid)
6963 /* don't descend into loops */
6964 else if (k->op_type == OP_ENTERLOOP
6965 || k->op_type == OP_ENTERITER)
6967 k = cLOOPx(k)->op_lastop;
6972 kid->op_next = 0; /* just disconnect the leave */
6973 k = kLISTOP->op_first;
6978 if (o->op_type == OP_SORT) {
6979 /* provide scalar context for comparison function/block */
6985 o->op_flags |= OPf_SPECIAL;
6987 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6990 firstkid = firstkid->op_sibling;
6993 /* provide list context for arguments */
6994 if (o->op_type == OP_SORT)
7001 S_simplify_sort(pTHX_ OP *o)
7004 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7009 if (!(o->op_flags & OPf_STACKED))
7011 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7012 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
7013 kid = kUNOP->op_first; /* get past null */
7014 if (kid->op_type != OP_SCOPE)
7016 kid = kLISTOP->op_last; /* get past scope */
7017 switch(kid->op_type) {
7025 k = kid; /* remember this node*/
7026 if (kBINOP->op_first->op_type != OP_RV2SV)
7028 kid = kBINOP->op_first; /* get past cmp */
7029 if (kUNOP->op_first->op_type != OP_GV)
7031 kid = kUNOP->op_first; /* get past rv2sv */
7033 if (GvSTASH(gv) != PL_curstash)
7035 gvname = GvNAME(gv);
7036 if (*gvname == 'a' && gvname[1] == '\0')
7038 else if (*gvname == 'b' && gvname[1] == '\0')
7043 kid = k; /* back to cmp */
7044 if (kBINOP->op_last->op_type != OP_RV2SV)
7046 kid = kBINOP->op_last; /* down to 2nd arg */
7047 if (kUNOP->op_first->op_type != OP_GV)
7049 kid = kUNOP->op_first; /* get past rv2sv */
7051 if (GvSTASH(gv) != PL_curstash)
7053 gvname = GvNAME(gv);
7055 ? !(*gvname == 'a' && gvname[1] == '\0')
7056 : !(*gvname == 'b' && gvname[1] == '\0'))
7058 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
7060 o->op_private |= OPpSORT_DESCEND;
7061 if (k->op_type == OP_NCMP)
7062 o->op_private |= OPpSORT_NUMERIC;
7063 if (k->op_type == OP_I_NCMP)
7064 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
7065 kid = cLISTOPo->op_first->op_sibling;
7066 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
7068 op_getmad(kid,o,'S'); /* then delete it */
7070 op_free(kid); /* then delete it */
7075 Perl_ck_split(pTHX_ OP *o)
7080 if (o->op_flags & OPf_STACKED)
7081 return no_fh_allowed(o);
7083 kid = cLISTOPo->op_first;
7084 if (kid->op_type != OP_NULL)
7085 Perl_croak(aTHX_ "panic: ck_split");
7086 kid = kid->op_sibling;
7087 op_free(cLISTOPo->op_first);
7088 cLISTOPo->op_first = kid;
7090 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
7091 cLISTOPo->op_last = kid; /* There was only one element previously */
7094 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
7095 OP * const sibl = kid->op_sibling;
7096 kid->op_sibling = 0;
7097 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
7098 if (cLISTOPo->op_first == cLISTOPo->op_last)
7099 cLISTOPo->op_last = kid;
7100 cLISTOPo->op_first = kid;
7101 kid->op_sibling = sibl;
7104 kid->op_type = OP_PUSHRE;
7105 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
7107 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
7108 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
7109 "Use of /g modifier is meaningless in split");
7112 if (!kid->op_sibling)
7113 append_elem(OP_SPLIT, o, newDEFSVOP());
7115 kid = kid->op_sibling;
7118 if (!kid->op_sibling)
7119 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
7121 kid = kid->op_sibling;
7124 if (kid->op_sibling)
7125 return too_many_arguments(o,OP_DESC(o));
7131 Perl_ck_join(pTHX_ OP *o)
7133 const OP * const kid = cLISTOPo->op_first->op_sibling;
7134 if (kid && kid->op_type == OP_MATCH) {
7135 if (ckWARN(WARN_SYNTAX)) {
7136 const REGEXP *re = PM_GETRE(kPMOP);
7137 const char *pmstr = re ? re->precomp : "STRING";
7138 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7139 "/%s/ should probably be written as \"%s\"",
7147 Perl_ck_subr(pTHX_ OP *o)
7150 OP *prev = ((cUNOPo->op_first->op_sibling)
7151 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
7152 OP *o2 = prev->op_sibling;
7159 I32 contextclass = 0;
7163 o->op_private |= OPpENTERSUB_HASTARG;
7164 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
7165 if (cvop->op_type == OP_RV2CV) {
7167 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
7168 op_null(cvop); /* disable rv2cv */
7169 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
7170 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
7171 GV *gv = cGVOPx_gv(tmpop);
7174 tmpop->op_private |= OPpEARLY_CV;
7177 namegv = CvANON(cv) ? gv : CvGV(cv);
7178 proto = SvPV_nolen((SV*)cv);
7180 if (CvASSERTION(cv)) {
7181 if (PL_hints & HINT_ASSERTING) {
7182 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
7183 o->op_private |= OPpENTERSUB_DB;
7187 if (!(PL_hints & HINT_ASSERTIONSSEEN) && ckWARN(WARN_ASSERTIONS)) {
7188 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
7189 "Impossible to activate assertion call");
7196 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7197 if (o2->op_type == OP_CONST)
7198 o2->op_private &= ~OPpCONST_STRICT;
7199 else if (o2->op_type == OP_LIST) {
7200 OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
7201 if (sib && sib->op_type == OP_CONST)
7202 sib->op_private &= ~OPpCONST_STRICT;
7205 o->op_private |= (PL_hints & HINT_STRICT_REFS);
7206 if (PERLDB_SUB && PL_curstash != PL_debstash)
7207 o->op_private |= OPpENTERSUB_DB;
7208 while (o2 != cvop) {
7210 if (PL_madskills && o2->op_type == OP_NULL)
7211 o3 = ((UNOP*)o2)->op_first;
7217 return too_many_arguments(o, gv_ename(namegv));
7235 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
7237 arg == 1 ? "block or sub {}" : "sub {}",
7238 gv_ename(namegv), o3);
7241 /* '*' allows any scalar type, including bareword */
7244 if (o3->op_type == OP_RV2GV)
7245 goto wrapref; /* autoconvert GLOB -> GLOBref */
7246 else if (o3->op_type == OP_CONST)
7247 o3->op_private &= ~OPpCONST_STRICT;
7248 else if (o3->op_type == OP_ENTERSUB) {
7249 /* accidental subroutine, revert to bareword */
7250 OP *gvop = ((UNOP*)o3)->op_first;
7251 if (gvop && gvop->op_type == OP_NULL) {
7252 gvop = ((UNOP*)gvop)->op_first;
7254 for (; gvop->op_sibling; gvop = gvop->op_sibling)
7257 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
7258 (gvop = ((UNOP*)gvop)->op_first) &&
7259 gvop->op_type == OP_GV)
7261 GV * const gv = cGVOPx_gv(gvop);
7262 OP * const sibling = o2->op_sibling;
7263 SV * const n = newSVpvs("");
7269 gv_fullname4(n, gv, "", FALSE);
7270 o2 = newSVOP(OP_CONST, 0, n);
7271 op_getmad(oldo2,o2,'O');
7272 prev->op_sibling = o2;
7273 o2->op_sibling = sibling;
7289 if (contextclass++ == 0) {
7290 e = strchr(proto, ']');
7291 if (!e || e == proto)
7300 /* XXX We shouldn't be modifying proto, so we can const proto */
7305 while (*--p != '[');
7306 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
7307 gv_ename(namegv), o3);
7313 if (o3->op_type == OP_RV2GV)
7316 bad_type(arg, "symbol", gv_ename(namegv), o3);
7319 if (o3->op_type == OP_ENTERSUB)
7322 bad_type(arg, "subroutine entry", gv_ename(namegv),
7326 if (o3->op_type == OP_RV2SV ||
7327 o3->op_type == OP_PADSV ||
7328 o3->op_type == OP_HELEM ||
7329 o3->op_type == OP_AELEM ||
7330 o3->op_type == OP_THREADSV)
7333 bad_type(arg, "scalar", gv_ename(namegv), o3);
7336 if (o3->op_type == OP_RV2AV ||
7337 o3->op_type == OP_PADAV)
7340 bad_type(arg, "array", gv_ename(namegv), o3);
7343 if (o3->op_type == OP_RV2HV ||
7344 o3->op_type == OP_PADHV)
7347 bad_type(arg, "hash", gv_ename(namegv), o3);
7352 OP* const sib = kid->op_sibling;
7353 kid->op_sibling = 0;
7354 o2 = newUNOP(OP_REFGEN, 0, kid);
7355 o2->op_sibling = sib;
7356 prev->op_sibling = o2;
7358 if (contextclass && e) {
7373 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
7374 gv_ename(namegv), cv);
7379 mod(o2, OP_ENTERSUB);
7381 o2 = o2->op_sibling;
7383 if (proto && !optional &&
7384 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
7385 return too_few_arguments(o, gv_ename(namegv));
7392 o=newSVOP(OP_CONST, 0, newSViv(0));
7393 op_getmad(oldo,o,'O');
7399 Perl_ck_svconst(pTHX_ OP *o)
7401 PERL_UNUSED_CONTEXT;
7402 SvREADONLY_on(cSVOPo->op_sv);
7407 Perl_ck_chdir(pTHX_ OP *o)
7409 if (o->op_flags & OPf_KIDS) {
7410 SVOP *kid = (SVOP*)cUNOPo->op_first;
7412 if (kid && kid->op_type == OP_CONST &&
7413 (kid->op_private & OPpCONST_BARE))
7415 o->op_flags |= OPf_SPECIAL;
7416 kid->op_private &= ~OPpCONST_STRICT;
7423 Perl_ck_trunc(pTHX_ OP *o)
7425 if (o->op_flags & OPf_KIDS) {
7426 SVOP *kid = (SVOP*)cUNOPo->op_first;
7428 if (kid->op_type == OP_NULL)
7429 kid = (SVOP*)kid->op_sibling;
7430 if (kid && kid->op_type == OP_CONST &&
7431 (kid->op_private & OPpCONST_BARE))
7433 o->op_flags |= OPf_SPECIAL;
7434 kid->op_private &= ~OPpCONST_STRICT;
7441 Perl_ck_unpack(pTHX_ OP *o)
7443 OP *kid = cLISTOPo->op_first;
7444 if (kid->op_sibling) {
7445 kid = kid->op_sibling;
7446 if (!kid->op_sibling)
7447 kid->op_sibling = newDEFSVOP();
7453 Perl_ck_substr(pTHX_ OP *o)
7456 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
7457 OP *kid = cLISTOPo->op_first;
7459 if (kid->op_type == OP_NULL)
7460 kid = kid->op_sibling;
7462 kid->op_flags |= OPf_MOD;
7468 /* A peephole optimizer. We visit the ops in the order they're to execute.
7469 * See the comments at the top of this file for more details about when
7470 * peep() is called */
7473 Perl_peep(pTHX_ register OP *o)
7476 register OP* oldop = NULL;
7478 if (!o || o->op_opt)
7482 SAVEVPTR(PL_curcop);
7483 for (; o; o = o->op_next) {
7487 switch (o->op_type) {
7491 PL_curcop = ((COP*)o); /* for warnings */
7496 if (cSVOPo->op_private & OPpCONST_STRICT)
7497 no_bareword_allowed(o);
7499 case OP_METHOD_NAMED:
7500 /* Relocate sv to the pad for thread safety.
7501 * Despite being a "constant", the SV is written to,
7502 * for reference counts, sv_upgrade() etc. */
7504 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
7505 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
7506 /* If op_sv is already a PADTMP then it is being used by
7507 * some pad, so make a copy. */
7508 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
7509 SvREADONLY_on(PAD_SVl(ix));
7510 SvREFCNT_dec(cSVOPo->op_sv);
7512 else if (o->op_type == OP_CONST
7513 && cSVOPo->op_sv == &PL_sv_undef) {
7514 /* PL_sv_undef is hack - it's unsafe to store it in the
7515 AV that is the pad, because av_fetch treats values of
7516 PL_sv_undef as a "free" AV entry and will merrily
7517 replace them with a new SV, causing pad_alloc to think
7518 that this pad slot is free. (When, clearly, it is not)
7520 SvOK_off(PAD_SVl(ix));
7521 SvPADTMP_on(PAD_SVl(ix));
7522 SvREADONLY_on(PAD_SVl(ix));
7525 SvREFCNT_dec(PAD_SVl(ix));
7526 SvPADTMP_on(cSVOPo->op_sv);
7527 PAD_SETSV(ix, cSVOPo->op_sv);
7528 /* XXX I don't know how this isn't readonly already. */
7529 SvREADONLY_on(PAD_SVl(ix));
7531 cSVOPo->op_sv = NULL;
7539 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
7540 if (o->op_next->op_private & OPpTARGET_MY) {
7541 if (o->op_flags & OPf_STACKED) /* chained concats */
7542 goto ignore_optimization;
7544 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
7545 o->op_targ = o->op_next->op_targ;
7546 o->op_next->op_targ = 0;
7547 o->op_private |= OPpTARGET_MY;
7550 op_null(o->op_next);
7552 ignore_optimization:
7556 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
7558 break; /* Scalar stub must produce undef. List stub is noop */
7562 if (o->op_targ == OP_NEXTSTATE
7563 || o->op_targ == OP_DBSTATE
7564 || o->op_targ == OP_SETSTATE)
7566 PL_curcop = ((COP*)o);
7568 /* XXX: We avoid setting op_seq here to prevent later calls
7569 to peep() from mistakenly concluding that optimisation
7570 has already occurred. This doesn't fix the real problem,
7571 though (See 20010220.007). AMS 20010719 */
7572 /* op_seq functionality is now replaced by op_opt */
7573 if (oldop && o->op_next) {
7574 oldop->op_next = o->op_next;
7582 if (oldop && o->op_next) {
7583 oldop->op_next = o->op_next;
7591 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
7592 OP* const pop = (o->op_type == OP_PADAV) ?
7593 o->op_next : o->op_next->op_next;
7595 if (pop && pop->op_type == OP_CONST &&
7596 ((PL_op = pop->op_next)) &&
7597 pop->op_next->op_type == OP_AELEM &&
7598 !(pop->op_next->op_private &
7599 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
7600 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
7605 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
7606 no_bareword_allowed(pop);
7607 if (o->op_type == OP_GV)
7608 op_null(o->op_next);
7609 op_null(pop->op_next);
7611 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
7612 o->op_next = pop->op_next->op_next;
7613 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
7614 o->op_private = (U8)i;
7615 if (o->op_type == OP_GV) {
7620 o->op_flags |= OPf_SPECIAL;
7621 o->op_type = OP_AELEMFAST;
7627 if (o->op_next->op_type == OP_RV2SV) {
7628 if (!(o->op_next->op_private & OPpDEREF)) {
7629 op_null(o->op_next);
7630 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
7632 o->op_next = o->op_next->op_next;
7633 o->op_type = OP_GVSV;
7634 o->op_ppaddr = PL_ppaddr[OP_GVSV];
7637 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
7638 GV * const gv = cGVOPo_gv;
7639 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
7640 /* XXX could check prototype here instead of just carping */
7641 SV * const sv = sv_newmortal();
7642 gv_efullname3(sv, gv, NULL);
7643 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
7644 "%"SVf"() called too early to check prototype",
7648 else if (o->op_next->op_type == OP_READLINE
7649 && o->op_next->op_next->op_type == OP_CONCAT
7650 && (o->op_next->op_next->op_flags & OPf_STACKED))
7652 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
7653 o->op_type = OP_RCATLINE;
7654 o->op_flags |= OPf_STACKED;
7655 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
7656 op_null(o->op_next->op_next);
7657 op_null(o->op_next);
7674 while (cLOGOP->op_other->op_type == OP_NULL)
7675 cLOGOP->op_other = cLOGOP->op_other->op_next;
7676 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
7682 while (cLOOP->op_redoop->op_type == OP_NULL)
7683 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
7684 peep(cLOOP->op_redoop);
7685 while (cLOOP->op_nextop->op_type == OP_NULL)
7686 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
7687 peep(cLOOP->op_nextop);
7688 while (cLOOP->op_lastop->op_type == OP_NULL)
7689 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
7690 peep(cLOOP->op_lastop);
7697 while (cPMOP->op_pmreplstart &&
7698 cPMOP->op_pmreplstart->op_type == OP_NULL)
7699 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
7700 peep(cPMOP->op_pmreplstart);
7705 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
7706 && ckWARN(WARN_SYNTAX))
7708 if (o->op_next->op_sibling &&
7709 o->op_next->op_sibling->op_type != OP_EXIT &&
7710 o->op_next->op_sibling->op_type != OP_WARN &&
7711 o->op_next->op_sibling->op_type != OP_DIE) {
7712 const line_t oldline = CopLINE(PL_curcop);
7714 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
7715 Perl_warner(aTHX_ packWARN(WARN_EXEC),
7716 "Statement unlikely to be reached");
7717 Perl_warner(aTHX_ packWARN(WARN_EXEC),
7718 "\t(Maybe you meant system() when you said exec()?)\n");
7719 CopLINE_set(PL_curcop, oldline);
7729 const char *key = NULL;
7734 if (((BINOP*)o)->op_last->op_type != OP_CONST)
7737 /* Make the CONST have a shared SV */
7738 svp = cSVOPx_svp(((BINOP*)o)->op_last);
7739 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
7740 key = SvPV_const(sv, keylen);
7741 lexname = newSVpvn_share(key,
7742 SvUTF8(sv) ? -(I32)keylen : keylen,
7748 if ((o->op_private & (OPpLVAL_INTRO)))
7751 rop = (UNOP*)((BINOP*)o)->op_first;
7752 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7754 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7755 if (!SvPAD_TYPED(lexname))
7757 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
7758 if (!fields || !GvHV(*fields))
7760 key = SvPV_const(*svp, keylen);
7761 if (!hv_fetch(GvHV(*fields), key,
7762 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
7764 Perl_croak(aTHX_ "No such class field \"%s\" "
7765 "in variable %s of type %s",
7766 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
7779 SVOP *first_key_op, *key_op;
7781 if ((o->op_private & (OPpLVAL_INTRO))
7782 /* I bet there's always a pushmark... */
7783 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
7784 /* hmmm, no optimization if list contains only one key. */
7786 rop = (UNOP*)((LISTOP*)o)->op_last;
7787 if (rop->op_type != OP_RV2HV)
7789 if (rop->op_first->op_type == OP_PADSV)
7790 /* @$hash{qw(keys here)} */
7791 rop = (UNOP*)rop->op_first;
7793 /* @{$hash}{qw(keys here)} */
7794 if (rop->op_first->op_type == OP_SCOPE
7795 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
7797 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
7803 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
7804 if (!SvPAD_TYPED(lexname))
7806 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
7807 if (!fields || !GvHV(*fields))
7809 /* Again guessing that the pushmark can be jumped over.... */
7810 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
7811 ->op_first->op_sibling;
7812 for (key_op = first_key_op; key_op;
7813 key_op = (SVOP*)key_op->op_sibling) {
7814 if (key_op->op_type != OP_CONST)
7816 svp = cSVOPx_svp(key_op);
7817 key = SvPV_const(*svp, keylen);
7818 if (!hv_fetch(GvHV(*fields), key,
7819 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
7821 Perl_croak(aTHX_ "No such class field \"%s\" "
7822 "in variable %s of type %s",
7823 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
7830 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
7834 /* check that RHS of sort is a single plain array */
7835 OP *oright = cUNOPo->op_first;
7836 if (!oright || oright->op_type != OP_PUSHMARK)
7839 /* reverse sort ... can be optimised. */
7840 if (!cUNOPo->op_sibling) {
7841 /* Nothing follows us on the list. */
7842 OP * const reverse = o->op_next;
7844 if (reverse->op_type == OP_REVERSE &&
7845 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
7846 OP * const pushmark = cUNOPx(reverse)->op_first;
7847 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
7848 && (cUNOPx(pushmark)->op_sibling == o)) {
7849 /* reverse -> pushmark -> sort */
7850 o->op_private |= OPpSORT_REVERSE;
7852 pushmark->op_next = oright->op_next;
7858 /* make @a = sort @a act in-place */
7862 oright = cUNOPx(oright)->op_sibling;
7865 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
7866 oright = cUNOPx(oright)->op_sibling;
7870 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
7871 || oright->op_next != o
7872 || (oright->op_private & OPpLVAL_INTRO)
7876 /* o2 follows the chain of op_nexts through the LHS of the
7877 * assign (if any) to the aassign op itself */
7879 if (!o2 || o2->op_type != OP_NULL)
7882 if (!o2 || o2->op_type != OP_PUSHMARK)
7885 if (o2 && o2->op_type == OP_GV)
7888 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
7889 || (o2->op_private & OPpLVAL_INTRO)
7894 if (!o2 || o2->op_type != OP_NULL)
7897 if (!o2 || o2->op_type != OP_AASSIGN
7898 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
7901 /* check that the sort is the first arg on RHS of assign */
7903 o2 = cUNOPx(o2)->op_first;
7904 if (!o2 || o2->op_type != OP_NULL)
7906 o2 = cUNOPx(o2)->op_first;
7907 if (!o2 || o2->op_type != OP_PUSHMARK)
7909 if (o2->op_sibling != o)
7912 /* check the array is the same on both sides */
7913 if (oleft->op_type == OP_RV2AV) {
7914 if (oright->op_type != OP_RV2AV
7915 || !cUNOPx(oright)->op_first
7916 || cUNOPx(oright)->op_first->op_type != OP_GV
7917 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
7918 cGVOPx_gv(cUNOPx(oright)->op_first)
7922 else if (oright->op_type != OP_PADAV
7923 || oright->op_targ != oleft->op_targ
7927 /* transfer MODishness etc from LHS arg to RHS arg */
7928 oright->op_flags = oleft->op_flags;
7929 o->op_private |= OPpSORT_INPLACE;
7931 /* excise push->gv->rv2av->null->aassign */
7932 o2 = o->op_next->op_next;
7933 op_null(o2); /* PUSHMARK */
7935 if (o2->op_type == OP_GV) {
7936 op_null(o2); /* GV */
7939 op_null(o2); /* RV2AV or PADAV */
7940 o2 = o2->op_next->op_next;
7941 op_null(o2); /* AASSIGN */
7943 o->op_next = o2->op_next;
7949 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
7951 LISTOP *enter, *exlist;
7954 enter = (LISTOP *) o->op_next;
7957 if (enter->op_type == OP_NULL) {
7958 enter = (LISTOP *) enter->op_next;
7962 /* for $a (...) will have OP_GV then OP_RV2GV here.
7963 for (...) just has an OP_GV. */
7964 if (enter->op_type == OP_GV) {
7965 gvop = (OP *) enter;
7966 enter = (LISTOP *) enter->op_next;
7969 if (enter->op_type == OP_RV2GV) {
7970 enter = (LISTOP *) enter->op_next;
7976 if (enter->op_type != OP_ENTERITER)
7979 iter = enter->op_next;
7980 if (!iter || iter->op_type != OP_ITER)
7983 expushmark = enter->op_first;
7984 if (!expushmark || expushmark->op_type != OP_NULL
7985 || expushmark->op_targ != OP_PUSHMARK)
7988 exlist = (LISTOP *) expushmark->op_sibling;
7989 if (!exlist || exlist->op_type != OP_NULL
7990 || exlist->op_targ != OP_LIST)
7993 if (exlist->op_last != o) {
7994 /* Mmm. Was expecting to point back to this op. */
7997 theirmark = exlist->op_first;
7998 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
8001 if (theirmark->op_sibling != o) {
8002 /* There's something between the mark and the reverse, eg
8003 for (1, reverse (...))
8008 ourmark = ((LISTOP *)o)->op_first;
8009 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
8012 ourlast = ((LISTOP *)o)->op_last;
8013 if (!ourlast || ourlast->op_next != o)
8016 rv2av = ourmark->op_sibling;
8017 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
8018 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
8019 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
8020 /* We're just reversing a single array. */
8021 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
8022 enter->op_flags |= OPf_STACKED;
8025 /* We don't have control over who points to theirmark, so sacrifice
8027 theirmark->op_next = ourmark->op_next;
8028 theirmark->op_flags = ourmark->op_flags;
8029 ourlast->op_next = gvop ? gvop : (OP *) enter;
8032 enter->op_private |= OPpITER_REVERSED;
8033 iter->op_private |= OPpITER_REVERSED;
8040 UNOP *refgen, *rv2cv;
8043 /* I do not understand this, but if o->op_opt isn't set to 1,
8044 various tests in ext/B/t/bytecode.t fail with no readily
8050 if ((o->op_flags && OPf_WANT) != OPf_WANT_VOID)
8053 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
8056 rv2gv = ((BINOP *)o)->op_last;
8057 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
8060 refgen = (UNOP *)((BINOP *)o)->op_first;
8062 if (!refgen || refgen->op_type != OP_REFGEN)
8065 exlist = (LISTOP *)refgen->op_first;
8066 if (!exlist || exlist->op_type != OP_NULL
8067 || exlist->op_targ != OP_LIST)
8070 if (exlist->op_first->op_type != OP_PUSHMARK)
8073 rv2cv = (UNOP*)exlist->op_last;
8075 if (rv2cv->op_type != OP_RV2CV)
8078 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
8079 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
8080 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
8082 o->op_private |= OPpASSIGN_CV_TO_GV;
8083 rv2gv->op_private |= OPpDONT_INIT_GV;
8084 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
8100 Perl_custom_op_name(pTHX_ const OP* o)
8103 const IV index = PTR2IV(o->op_ppaddr);
8107 if (!PL_custom_op_names) /* This probably shouldn't happen */
8108 return (char *)PL_op_name[OP_CUSTOM];
8110 keysv = sv_2mortal(newSViv(index));
8112 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
8114 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
8116 return SvPV_nolen(HeVAL(he));
8120 Perl_custom_op_desc(pTHX_ const OP* o)
8123 const IV index = PTR2IV(o->op_ppaddr);
8127 if (!PL_custom_op_descs)
8128 return (char *)PL_op_desc[OP_CUSTOM];
8130 keysv = sv_2mortal(newSViv(index));
8132 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
8134 return (char *)PL_op_desc[OP_CUSTOM];
8136 return SvPV_nolen(HeVAL(he));
8141 /* Efficient sub that returns a constant scalar value. */
8143 const_sv_xsub(pTHX_ CV* cv)
8150 Perl_croak(aTHX_ "usage: %s::%s()",
8151 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
8155 ST(0) = (SV*)XSANY.any_ptr;
8161 * c-indentation-style: bsd
8163 * indent-tabs-mode: t
8166 * ex: set ts=8 sts=4 sw=4 noet: