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)
1748 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
1749 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
1754 if (type == OP_LIST) {
1756 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1757 my_kid(kid, attrs, imopsp);
1758 } else if (type == OP_UNDEF
1764 } else if (type == OP_RV2SV || /* "our" declaration */
1766 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1767 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1768 yyerror(Perl_form(aTHX_ "Can't declare %s in %s",
1769 OP_DESC(o), PL_in_my == KEY_our ? "our" : "my"));
1771 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
1773 PL_in_my_stash = NULL;
1774 apply_attrs(GvSTASH(gv),
1775 (type == OP_RV2SV ? GvSV(gv) :
1776 type == OP_RV2AV ? (SV*)GvAV(gv) :
1777 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1780 o->op_private |= OPpOUR_INTRO;
1783 else if (type != OP_PADSV &&
1786 type != OP_PUSHMARK)
1788 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1790 PL_in_my == KEY_our ? "our" : "my"));
1793 else if (attrs && type != OP_PUSHMARK) {
1797 PL_in_my_stash = NULL;
1799 /* check for C<my Dog $spot> when deciding package */
1800 stash = PAD_COMPNAME_TYPE(o->op_targ);
1802 stash = PL_curstash;
1803 apply_attrs_my(stash, o, attrs, imopsp);
1805 o->op_flags |= OPf_MOD;
1806 o->op_private |= OPpLVAL_INTRO;
1811 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1815 int maybe_scalar = 0;
1817 /* [perl #17376]: this appears to be premature, and results in code such as
1818 C< our(%x); > executing in list mode rather than void mode */
1820 if (o->op_flags & OPf_PARENS)
1830 o = my_kid(o, attrs, &rops);
1832 if (maybe_scalar && o->op_type == OP_PADSV) {
1833 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
1834 o->op_private |= OPpLVAL_INTRO;
1837 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
1840 PL_in_my_stash = NULL;
1845 Perl_my(pTHX_ OP *o)
1847 return my_attrs(o, NULL);
1851 Perl_sawparens(pTHX_ OP *o)
1853 PERL_UNUSED_CONTEXT;
1855 o->op_flags |= OPf_PARENS;
1860 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
1865 if ( (left->op_type == OP_RV2AV ||
1866 left->op_type == OP_RV2HV ||
1867 left->op_type == OP_PADAV ||
1868 left->op_type == OP_PADHV)
1869 && ckWARN(WARN_MISC))
1871 const char * const desc = PL_op_desc[(right->op_type == OP_SUBST ||
1872 right->op_type == OP_TRANS)
1873 ? right->op_type : OP_MATCH];
1874 const char * const sample = ((left->op_type == OP_RV2AV ||
1875 left->op_type == OP_PADAV)
1876 ? "@array" : "%hash");
1877 Perl_warner(aTHX_ packWARN(WARN_MISC),
1878 "Applying %s to %s will act on scalar(%s)",
1879 desc, sample, sample);
1882 if (right->op_type == OP_CONST &&
1883 cSVOPx(right)->op_private & OPpCONST_BARE &&
1884 cSVOPx(right)->op_private & OPpCONST_STRICT)
1886 no_bareword_allowed(right);
1889 ismatchop = right->op_type == OP_MATCH ||
1890 right->op_type == OP_SUBST ||
1891 right->op_type == OP_TRANS;
1892 if (ismatchop && right->op_private & OPpTARGET_MY) {
1894 right->op_private &= ~OPpTARGET_MY;
1896 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
1897 right->op_flags |= OPf_STACKED;
1898 if (right->op_type != OP_MATCH &&
1899 ! (right->op_type == OP_TRANS &&
1900 right->op_private & OPpTRANS_IDENTICAL))
1901 left = mod(left, right->op_type);
1902 if (right->op_type == OP_TRANS)
1903 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
1905 o = prepend_elem(right->op_type, scalar(left), right);
1907 return newUNOP(OP_NOT, 0, scalar(o));
1911 return bind_match(type, left,
1912 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
1916 Perl_invert(pTHX_ OP *o)
1920 /* XXX need to optimize away NOT NOT here? Or do we let optimizer do it? */
1921 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
1925 Perl_scope(pTHX_ OP *o)
1929 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
1930 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
1931 o->op_type = OP_LEAVE;
1932 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
1934 else if (o->op_type == OP_LINESEQ) {
1936 o->op_type = OP_SCOPE;
1937 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
1938 kid = ((LISTOP*)o)->op_first;
1939 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
1942 /* The following deals with things like 'do {1 for 1}' */
1943 kid = kid->op_sibling;
1945 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
1950 o = newLISTOP(OP_SCOPE, 0, o, NULL);
1956 Perl_block_start(pTHX_ int full)
1959 const int retval = PL_savestack_ix;
1960 pad_block_start(full);
1962 PL_hints &= ~HINT_BLOCK_SCOPE;
1963 SAVESPTR(PL_compiling.cop_warnings);
1964 if (! specialWARN(PL_compiling.cop_warnings)) {
1965 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
1966 SAVEFREESV(PL_compiling.cop_warnings) ;
1968 SAVESPTR(PL_compiling.cop_io);
1969 if (! specialCopIO(PL_compiling.cop_io)) {
1970 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
1971 SAVEFREESV(PL_compiling.cop_io) ;
1977 Perl_block_end(pTHX_ I32 floor, OP *seq)
1980 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
1981 OP* const retval = scalarseq(seq);
1983 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
1985 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
1994 const I32 offset = pad_findmy("$_");
1995 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
1996 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
1999 OP * const o = newOP(OP_PADSV, 0);
2000 o->op_targ = offset;
2006 Perl_newPROG(pTHX_ OP *o)
2012 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2013 ((PL_in_eval & EVAL_KEEPERR)
2014 ? OPf_SPECIAL : 0), o);
2015 PL_eval_start = linklist(PL_eval_root);
2016 PL_eval_root->op_private |= OPpREFCOUNTED;
2017 OpREFCNT_set(PL_eval_root, 1);
2018 PL_eval_root->op_next = 0;
2019 CALL_PEEP(PL_eval_start);
2022 if (o->op_type == OP_STUB) {
2023 PL_comppad_name = 0;
2028 PL_main_root = scope(sawparens(scalarvoid(o)));
2029 PL_curcop = &PL_compiling;
2030 PL_main_start = LINKLIST(PL_main_root);
2031 PL_main_root->op_private |= OPpREFCOUNTED;
2032 OpREFCNT_set(PL_main_root, 1);
2033 PL_main_root->op_next = 0;
2034 CALL_PEEP(PL_main_start);
2037 /* Register with debugger */
2039 CV * const cv = get_cv("DB::postponed", FALSE);
2043 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2045 call_sv((SV*)cv, G_DISCARD);
2052 Perl_localize(pTHX_ OP *o, I32 lex)
2055 if (o->op_flags & OPf_PARENS)
2056 /* [perl #17376]: this appears to be premature, and results in code such as
2057 C< our(%x); > executing in list mode rather than void mode */
2064 if ( PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ','
2065 && ckWARN(WARN_PARENTHESIS))
2067 char *s = PL_bufptr;
2070 /* some heuristics to detect a potential error */
2071 while (*s && (strchr(", \t\n", *s)))
2075 if (*s && strchr("@$%*", *s) && *++s
2076 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2079 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2081 while (*s && (strchr(", \t\n", *s)))
2087 if (sigil && (*s == ';' || *s == '=')) {
2088 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2089 "Parentheses missing around \"%s\" list",
2090 lex ? (PL_in_my == KEY_our ? "our" : "my")
2098 o = mod(o, OP_NULL); /* a bit kludgey */
2100 PL_in_my_stash = NULL;
2105 Perl_jmaybe(pTHX_ OP *o)
2107 if (o->op_type == OP_LIST) {
2109 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL,
2111 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2117 Perl_fold_constants(pTHX_ register OP *o)
2122 I32 type = o->op_type;
2125 if (PL_opargs[type] & OA_RETSCALAR)
2127 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2128 o->op_targ = pad_alloc(type, SVs_PADTMP);
2130 /* integerize op, unless it happens to be C<-foo>.
2131 * XXX should pp_i_negate() do magic string negation instead? */
2132 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2133 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2134 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2136 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2139 if (!(PL_opargs[type] & OA_FOLDCONST))
2144 /* XXX might want a ck_negate() for this */
2145 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2156 /* XXX what about the numeric ops? */
2157 if (PL_hints & HINT_LOCALE)
2162 goto nope; /* Don't try to run w/ errors */
2164 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2165 if ((curop->op_type != OP_CONST ||
2166 (curop->op_private & OPpCONST_BARE)) &&
2167 curop->op_type != OP_LIST &&
2168 curop->op_type != OP_SCALAR &&
2169 curop->op_type != OP_NULL &&
2170 curop->op_type != OP_PUSHMARK)
2176 curop = LINKLIST(o);
2180 sv = *(PL_stack_sp--);
2181 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2182 pad_swipe(o->op_targ, FALSE);
2183 else if (SvTEMP(sv)) { /* grab mortal temp? */
2184 SvREFCNT_inc_simple_void(sv);
2191 if (type == OP_RV2GV)
2192 newop = newGVOP(OP_GV, 0, (GV*)sv);
2194 newop = newSVOP(OP_CONST, 0, sv);
2195 op_getmad(o,newop,'f');
2203 Perl_gen_constant_list(pTHX_ register OP *o)
2207 const I32 oldtmps_floor = PL_tmps_floor;
2211 return o; /* Don't attempt to run with errors */
2213 PL_op = curop = LINKLIST(o);
2220 PL_tmps_floor = oldtmps_floor;
2222 o->op_type = OP_RV2AV;
2223 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2224 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2225 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2226 o->op_opt = 0; /* needs to be revisited in peep() */
2227 curop = ((UNOP*)o)->op_first;
2228 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
2230 op_getmad(curop,o,'O');
2239 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2242 if (!o || o->op_type != OP_LIST)
2243 o = newLISTOP(OP_LIST, 0, o, NULL);
2245 o->op_flags &= ~OPf_WANT;
2247 if (!(PL_opargs[type] & OA_MARK))
2248 op_null(cLISTOPo->op_first);
2250 o->op_type = (OPCODE)type;
2251 o->op_ppaddr = PL_ppaddr[type];
2252 o->op_flags |= flags;
2254 o = CHECKOP(type, o);
2255 if (o->op_type != (unsigned)type)
2258 return fold_constants(o);
2261 /* List constructors */
2264 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2272 if (first->op_type != (unsigned)type
2273 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2275 return newLISTOP(type, 0, first, last);
2278 if (first->op_flags & OPf_KIDS)
2279 ((LISTOP*)first)->op_last->op_sibling = last;
2281 first->op_flags |= OPf_KIDS;
2282 ((LISTOP*)first)->op_first = last;
2284 ((LISTOP*)first)->op_last = last;
2289 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2297 if (first->op_type != (unsigned)type)
2298 return prepend_elem(type, (OP*)first, (OP*)last);
2300 if (last->op_type != (unsigned)type)
2301 return append_elem(type, (OP*)first, (OP*)last);
2303 first->op_last->op_sibling = last->op_first;
2304 first->op_last = last->op_last;
2305 first->op_flags |= (last->op_flags & OPf_KIDS);
2308 if (last->op_first && first->op_madprop) {
2309 MADPROP *mp = last->op_first->op_madprop;
2311 while (mp->mad_next)
2313 mp->mad_next = first->op_madprop;
2316 last->op_first->op_madprop = first->op_madprop;
2319 first->op_madprop = last->op_madprop;
2320 last->op_madprop = 0;
2329 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2337 if (last->op_type == (unsigned)type) {
2338 if (type == OP_LIST) { /* already a PUSHMARK there */
2339 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2340 ((LISTOP*)last)->op_first->op_sibling = first;
2341 if (!(first->op_flags & OPf_PARENS))
2342 last->op_flags &= ~OPf_PARENS;
2345 if (!(last->op_flags & OPf_KIDS)) {
2346 ((LISTOP*)last)->op_last = first;
2347 last->op_flags |= OPf_KIDS;
2349 first->op_sibling = ((LISTOP*)last)->op_first;
2350 ((LISTOP*)last)->op_first = first;
2352 last->op_flags |= OPf_KIDS;
2356 return newLISTOP(type, 0, first, last);
2364 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2367 Newxz(tk, 1, TOKEN);
2368 tk->tk_type = (OPCODE)optype;
2369 tk->tk_type = 12345;
2371 tk->tk_mad = madprop;
2376 Perl_token_free(pTHX_ TOKEN* tk)
2378 if (tk->tk_type != 12345)
2380 mad_free(tk->tk_mad);
2385 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2389 if (tk->tk_type != 12345) {
2390 Perl_warner(aTHX_ packWARN(WARN_MISC),
2391 "Invalid TOKEN object ignored");
2398 /* faked up qw list? */
2400 tm->mad_type == MAD_SV &&
2401 SvPVX((SV*)tm->mad_val)[0] == 'q')
2408 /* pretend constant fold didn't happen? */
2409 if (mp->mad_key == 'f' &&
2410 (o->op_type == OP_CONST ||
2411 o->op_type == OP_GV) )
2413 token_getmad(tk,(OP*)mp->mad_val,slot);
2427 if (mp->mad_key == 'X')
2428 mp->mad_key = slot; /* just change the first one */
2438 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
2447 /* pretend constant fold didn't happen? */
2448 if (mp->mad_key == 'f' &&
2449 (o->op_type == OP_CONST ||
2450 o->op_type == OP_GV) )
2452 op_getmad(from,(OP*)mp->mad_val,slot);
2459 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
2462 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
2468 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
2477 /* pretend constant fold didn't happen? */
2478 if (mp->mad_key == 'f' &&
2479 (o->op_type == OP_CONST ||
2480 o->op_type == OP_GV) )
2482 op_getmad(from,(OP*)mp->mad_val,slot);
2489 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
2492 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
2496 PerlIO_printf(PerlIO_stderr(),
2497 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
2503 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
2521 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
2525 addmad(tm, &(o->op_madprop), slot);
2529 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
2550 Perl_newMADsv(pTHX_ char key, SV* sv)
2552 return newMADPROP(key, MAD_SV, sv, 0);
2556 Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
2559 Newxz(mp, 1, MADPROP);
2562 mp->mad_vlen = vlen;
2563 mp->mad_type = type;
2565 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
2570 Perl_mad_free(pTHX_ MADPROP* mp)
2572 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
2576 mad_free(mp->mad_next);
2577 /* if (PL_lex_state != LEX_NOTPARSING && mp->mad_vlen)
2578 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
2579 switch (mp->mad_type) {
2583 Safefree((char*)mp->mad_val);
2586 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
2587 op_free((OP*)mp->mad_val);
2590 sv_free((SV*)mp->mad_val);
2593 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
2602 Perl_newNULLLIST(pTHX)
2604 return newOP(OP_STUB, 0);
2608 Perl_force_list(pTHX_ OP *o)
2610 if (!o || o->op_type != OP_LIST)
2611 o = newLISTOP(OP_LIST, 0, o, NULL);
2617 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2622 NewOp(1101, listop, 1, LISTOP);
2624 listop->op_type = (OPCODE)type;
2625 listop->op_ppaddr = PL_ppaddr[type];
2628 listop->op_flags = (U8)flags;
2632 else if (!first && last)
2635 first->op_sibling = last;
2636 listop->op_first = first;
2637 listop->op_last = last;
2638 if (type == OP_LIST) {
2639 OP* const pushop = newOP(OP_PUSHMARK, 0);
2640 pushop->op_sibling = first;
2641 listop->op_first = pushop;
2642 listop->op_flags |= OPf_KIDS;
2644 listop->op_last = pushop;
2647 return CHECKOP(type, listop);
2651 Perl_newOP(pTHX_ I32 type, I32 flags)
2655 NewOp(1101, o, 1, OP);
2656 o->op_type = (OPCODE)type;
2657 o->op_ppaddr = PL_ppaddr[type];
2658 o->op_flags = (U8)flags;
2661 o->op_private = (U8)(0 | (flags >> 8));
2662 if (PL_opargs[type] & OA_RETSCALAR)
2664 if (PL_opargs[type] & OA_TARGET)
2665 o->op_targ = pad_alloc(type, SVs_PADTMP);
2666 return CHECKOP(type, o);
2670 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2676 first = newOP(OP_STUB, 0);
2677 if (PL_opargs[type] & OA_MARK)
2678 first = force_list(first);
2680 NewOp(1101, unop, 1, UNOP);
2681 unop->op_type = (OPCODE)type;
2682 unop->op_ppaddr = PL_ppaddr[type];
2683 unop->op_first = first;
2684 unop->op_flags = (U8)(flags | OPf_KIDS);
2685 unop->op_private = (U8)(1 | (flags >> 8));
2686 unop = (UNOP*) CHECKOP(type, unop);
2690 return fold_constants((OP *) unop);
2694 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2698 NewOp(1101, binop, 1, BINOP);
2701 first = newOP(OP_NULL, 0);
2703 binop->op_type = (OPCODE)type;
2704 binop->op_ppaddr = PL_ppaddr[type];
2705 binop->op_first = first;
2706 binop->op_flags = (U8)(flags | OPf_KIDS);
2709 binop->op_private = (U8)(1 | (flags >> 8));
2712 binop->op_private = (U8)(2 | (flags >> 8));
2713 first->op_sibling = last;
2716 binop = (BINOP*)CHECKOP(type, binop);
2717 if (binop->op_next || binop->op_type != (OPCODE)type)
2720 binop->op_last = binop->op_first->op_sibling;
2722 return fold_constants((OP *)binop);
2725 static int uvcompare(const void *a, const void *b)
2726 __attribute__nonnull__(1)
2727 __attribute__nonnull__(2)
2728 __attribute__pure__;
2729 static int uvcompare(const void *a, const void *b)
2731 if (*((const UV *)a) < (*(const UV *)b))
2733 if (*((const UV *)a) > (*(const UV *)b))
2735 if (*((const UV *)a+1) < (*(const UV *)b+1))
2737 if (*((const UV *)a+1) > (*(const UV *)b+1))
2743 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2746 SV * const tstr = ((SVOP*)expr)->op_sv;
2747 SV * const rstr = ((SVOP*)repl)->op_sv;
2750 const U8 *t = (U8*)SvPV_const(tstr, tlen);
2751 const U8 *r = (U8*)SvPV_const(rstr, rlen);
2755 register short *tbl;
2757 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
2758 const I32 squash = o->op_private & OPpTRANS_SQUASH;
2759 I32 del = o->op_private & OPpTRANS_DELETE;
2760 PL_hints |= HINT_BLOCK_SCOPE;
2763 o->op_private |= OPpTRANS_FROM_UTF;
2766 o->op_private |= OPpTRANS_TO_UTF;
2768 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2769 SV* const listsv = newSVpvs("# comment\n");
2771 const U8* tend = t + tlen;
2772 const U8* rend = r + rlen;
2786 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2787 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2793 t = tsave = bytes_to_utf8(t, &len);
2796 if (!to_utf && rlen) {
2798 r = rsave = bytes_to_utf8(r, &len);
2802 /* There are several snags with this code on EBCDIC:
2803 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2804 2. scan_const() in toke.c has encoded chars in native encoding which makes
2805 ranges at least in EBCDIC 0..255 range the bottom odd.
2809 U8 tmpbuf[UTF8_MAXBYTES+1];
2812 Newx(cp, 2*tlen, UV);
2814 transv = newSVpvs("");
2816 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2818 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2820 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2824 cp[2*i+1] = cp[2*i];
2828 qsort(cp, i, 2*sizeof(UV), uvcompare);
2829 for (j = 0; j < i; j++) {
2831 diff = val - nextmin;
2833 t = uvuni_to_utf8(tmpbuf,nextmin);
2834 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2836 U8 range_mark = UTF_TO_NATIVE(0xff);
2837 t = uvuni_to_utf8(tmpbuf, val - 1);
2838 sv_catpvn(transv, (char *)&range_mark, 1);
2839 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2846 t = uvuni_to_utf8(tmpbuf,nextmin);
2847 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2849 U8 range_mark = UTF_TO_NATIVE(0xff);
2850 sv_catpvn(transv, (char *)&range_mark, 1);
2852 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2853 UNICODE_ALLOW_SUPER);
2854 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2855 t = (const U8*)SvPVX_const(transv);
2856 tlen = SvCUR(transv);
2860 else if (!rlen && !del) {
2861 r = t; rlen = tlen; rend = tend;
2864 if ((!rlen && !del) || t == r ||
2865 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2867 o->op_private |= OPpTRANS_IDENTICAL;
2871 while (t < tend || tfirst <= tlast) {
2872 /* see if we need more "t" chars */
2873 if (tfirst > tlast) {
2874 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2876 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2878 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2885 /* now see if we need more "r" chars */
2886 if (rfirst > rlast) {
2888 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2890 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2892 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2901 rfirst = rlast = 0xffffffff;
2905 /* now see which range will peter our first, if either. */
2906 tdiff = tlast - tfirst;
2907 rdiff = rlast - rfirst;
2914 if (rfirst == 0xffffffff) {
2915 diff = tdiff; /* oops, pretend rdiff is infinite */
2917 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2918 (long)tfirst, (long)tlast);
2920 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2924 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2925 (long)tfirst, (long)(tfirst + diff),
2928 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2929 (long)tfirst, (long)rfirst);
2931 if (rfirst + diff > max)
2932 max = rfirst + diff;
2934 grows = (tfirst < rfirst &&
2935 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2947 else if (max > 0xff)
2952 Safefree(cPVOPo->op_pv);
2953 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2954 SvREFCNT_dec(listsv);
2955 SvREFCNT_dec(transv);
2957 if (!del && havefinal && rlen)
2958 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2959 newSVuv((UV)final), 0);
2962 o->op_private |= OPpTRANS_GROWS;
2968 op_getmad(expr,o,'e');
2969 op_getmad(repl,o,'r');
2977 tbl = (short*)cPVOPo->op_pv;
2979 Zero(tbl, 256, short);
2980 for (i = 0; i < (I32)tlen; i++)
2982 for (i = 0, j = 0; i < 256; i++) {
2984 if (j >= (I32)rlen) {
2993 if (i < 128 && r[j] >= 128)
3003 o->op_private |= OPpTRANS_IDENTICAL;
3005 else if (j >= (I32)rlen)
3008 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
3009 tbl[0x100] = (short)(rlen - j);
3010 for (i=0; i < (I32)rlen - j; i++)
3011 tbl[0x101+i] = r[j+i];
3015 if (!rlen && !del) {
3018 o->op_private |= OPpTRANS_IDENTICAL;
3020 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3021 o->op_private |= OPpTRANS_IDENTICAL;
3023 for (i = 0; i < 256; i++)
3025 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3026 if (j >= (I32)rlen) {
3028 if (tbl[t[i]] == -1)
3034 if (tbl[t[i]] == -1) {
3035 if (t[i] < 128 && r[j] >= 128)
3042 o->op_private |= OPpTRANS_GROWS;
3044 op_getmad(expr,o,'e');
3045 op_getmad(repl,o,'r');
3055 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3060 NewOp(1101, pmop, 1, PMOP);
3061 pmop->op_type = (OPCODE)type;
3062 pmop->op_ppaddr = PL_ppaddr[type];
3063 pmop->op_flags = (U8)flags;
3064 pmop->op_private = (U8)(0 | (flags >> 8));
3066 if (PL_hints & HINT_RE_TAINT)
3067 pmop->op_pmpermflags |= PMf_RETAINT;
3068 if (PL_hints & HINT_LOCALE)
3069 pmop->op_pmpermflags |= PMf_LOCALE;
3070 pmop->op_pmflags = pmop->op_pmpermflags;
3073 if (av_len((AV*) PL_regex_pad[0]) > -1) {
3074 SV * const repointer = av_pop((AV*)PL_regex_pad[0]);
3075 pmop->op_pmoffset = SvIV(repointer);
3076 SvREPADTMP_off(repointer);
3077 sv_setiv(repointer,0);
3079 SV * const repointer = newSViv(0);
3080 av_push(PL_regex_padav, SvREFCNT_inc_simple_NN(repointer));
3081 pmop->op_pmoffset = av_len(PL_regex_padav);
3082 PL_regex_pad = AvARRAY(PL_regex_padav);
3086 /* link into pm list */
3087 if (type != OP_TRANS && PL_curstash) {
3088 MAGIC *mg = mg_find((SV*)PL_curstash, PERL_MAGIC_symtab);
3091 mg = sv_magicext((SV*)PL_curstash, 0, PERL_MAGIC_symtab, 0, 0, 0);
3093 pmop->op_pmnext = (PMOP*)mg->mg_obj;
3094 mg->mg_obj = (SV*)pmop;
3095 PmopSTASH_set(pmop,PL_curstash);
3098 return CHECKOP(type, pmop);
3101 /* Given some sort of match op o, and an expression expr containing a
3102 * pattern, either compile expr into a regex and attach it to o (if it's
3103 * constant), or convert expr into a runtime regcomp op sequence (if it's
3106 * isreg indicates that the pattern is part of a regex construct, eg
3107 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3108 * split "pattern", which aren't. In the former case, expr will be a list
3109 * if the pattern contains more than one term (eg /a$b/) or if it contains
3110 * a replacement, ie s/// or tr///.
3114 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
3119 I32 repl_has_vars = 0;
3123 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
3124 /* last element in list is the replacement; pop it */
3126 repl = cLISTOPx(expr)->op_last;
3127 kid = cLISTOPx(expr)->op_first;
3128 while (kid->op_sibling != repl)
3129 kid = kid->op_sibling;
3130 kid->op_sibling = NULL;
3131 cLISTOPx(expr)->op_last = kid;
3134 if (isreg && expr->op_type == OP_LIST &&
3135 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3137 /* convert single element list to element */
3138 OP* const oe = expr;
3139 expr = cLISTOPx(oe)->op_first->op_sibling;
3140 cLISTOPx(oe)->op_first->op_sibling = NULL;
3141 cLISTOPx(oe)->op_last = NULL;
3145 if (o->op_type == OP_TRANS) {
3146 return pmtrans(o, expr, repl);
3149 reglist = isreg && expr->op_type == OP_LIST;
3153 PL_hints |= HINT_BLOCK_SCOPE;
3156 if (expr->op_type == OP_CONST) {
3158 SV * const pat = ((SVOP*)expr)->op_sv;
3159 const char *p = SvPV_const(pat, plen);
3160 if ((o->op_flags & OPf_SPECIAL) && (*p == ' ' && p[1] == '\0')) {
3161 U32 was_readonly = SvREADONLY(pat);
3165 sv_force_normal_flags(pat, 0);
3166 assert(!SvREADONLY(pat));
3169 SvREADONLY_off(pat);
3173 sv_setpvn(pat, "\\s+", 3);
3175 SvFLAGS(pat) |= was_readonly;
3177 p = SvPV_const(pat, plen);
3178 pm->op_pmflags |= PMf_SKIPWHITE;
3181 pm->op_pmdynflags |= PMdf_UTF8;
3182 /* FIXME - can we make this function take const char * args? */
3183 PM_SETRE(pm, CALLREGCOMP(aTHX_ (char*)p, (char*)p + plen, pm));
3184 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
3185 pm->op_pmflags |= PMf_WHITE;
3187 op_getmad(expr,(OP*)pm,'e');
3193 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3194 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3196 : OP_REGCMAYBE),0,expr);
3198 NewOp(1101, rcop, 1, LOGOP);
3199 rcop->op_type = OP_REGCOMP;
3200 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3201 rcop->op_first = scalar(expr);
3202 rcop->op_flags |= OPf_KIDS
3203 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3204 | (reglist ? OPf_STACKED : 0);
3205 rcop->op_private = 1;
3208 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3210 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
3213 /* establish postfix order */
3214 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3216 rcop->op_next = expr;
3217 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3220 rcop->op_next = LINKLIST(expr);
3221 expr->op_next = (OP*)rcop;
3224 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3229 if (pm->op_pmflags & PMf_EVAL) {
3231 if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
3232 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
3234 else if (repl->op_type == OP_CONST)
3238 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3239 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3240 if (curop->op_type == OP_GV) {
3241 GV * const gv = cGVOPx_gv(curop);
3243 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3246 else if (curop->op_type == OP_RV2CV)
3248 else if (curop->op_type == OP_RV2SV ||
3249 curop->op_type == OP_RV2AV ||
3250 curop->op_type == OP_RV2HV ||
3251 curop->op_type == OP_RV2GV) {
3252 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3255 else if (curop->op_type == OP_PADSV ||
3256 curop->op_type == OP_PADAV ||
3257 curop->op_type == OP_PADHV ||
3258 curop->op_type == OP_PADANY) {
3261 else if (curop->op_type == OP_PUSHRE)
3262 /*EMPTY*/; /* Okay here, dangerous in newASSIGNOP */
3272 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
3273 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3274 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
3275 prepend_elem(o->op_type, scalar(repl), o);
3278 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3279 pm->op_pmflags |= PMf_MAYBE_CONST;
3280 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3282 NewOp(1101, rcop, 1, LOGOP);
3283 rcop->op_type = OP_SUBSTCONT;
3284 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3285 rcop->op_first = scalar(repl);
3286 rcop->op_flags |= OPf_KIDS;
3287 rcop->op_private = 1;
3290 /* establish postfix order */
3291 rcop->op_next = LINKLIST(repl);
3292 repl->op_next = (OP*)rcop;
3294 pm->op_pmreplroot = scalar((OP*)rcop);
3295 pm->op_pmreplstart = LINKLIST(rcop);
3304 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3308 NewOp(1101, svop, 1, SVOP);
3309 svop->op_type = (OPCODE)type;
3310 svop->op_ppaddr = PL_ppaddr[type];
3312 svop->op_next = (OP*)svop;
3313 svop->op_flags = (U8)flags;
3314 if (PL_opargs[type] & OA_RETSCALAR)
3316 if (PL_opargs[type] & OA_TARGET)
3317 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3318 return CHECKOP(type, svop);
3322 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3326 NewOp(1101, padop, 1, PADOP);
3327 padop->op_type = (OPCODE)type;
3328 padop->op_ppaddr = PL_ppaddr[type];
3329 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3330 SvREFCNT_dec(PAD_SVl(padop->op_padix));
3331 PAD_SETSV(padop->op_padix, sv);
3334 padop->op_next = (OP*)padop;
3335 padop->op_flags = (U8)flags;
3336 if (PL_opargs[type] & OA_RETSCALAR)
3338 if (PL_opargs[type] & OA_TARGET)
3339 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3340 return CHECKOP(type, padop);
3344 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3350 return newPADOP(type, flags, SvREFCNT_inc_simple(gv));
3352 return newSVOP(type, flags, SvREFCNT_inc_simple(gv));
3357 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3361 NewOp(1101, pvop, 1, PVOP);
3362 pvop->op_type = (OPCODE)type;
3363 pvop->op_ppaddr = PL_ppaddr[type];
3365 pvop->op_next = (OP*)pvop;
3366 pvop->op_flags = (U8)flags;
3367 if (PL_opargs[type] & OA_RETSCALAR)
3369 if (PL_opargs[type] & OA_TARGET)
3370 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3371 return CHECKOP(type, pvop);
3379 Perl_package(pTHX_ OP *o)
3388 save_hptr(&PL_curstash);
3389 save_item(PL_curstname);
3391 name = SvPV_const(cSVOPo->op_sv, len);
3392 PL_curstash = gv_stashpvn(name, len, TRUE);
3393 sv_setpvn(PL_curstname, name, len);
3395 PL_hints |= HINT_BLOCK_SCOPE;
3396 PL_copline = NOLINE;
3402 if (!PL_madskills) {
3407 pegop = newOP(OP_NULL,0);
3408 op_getmad(o,pegop,'P');
3418 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3425 OP *pegop = newOP(OP_NULL,0);
3428 if (idop->op_type != OP_CONST)
3429 Perl_croak(aTHX_ "Module name must be constant");
3432 op_getmad(idop,pegop,'U');
3437 SV * const vesv = ((SVOP*)version)->op_sv;
3440 op_getmad(version,pegop,'V');
3441 if (!arg && !SvNIOKp(vesv)) {
3448 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3449 Perl_croak(aTHX_ "Version number must be constant number");
3451 /* Make copy of idop so we don't free it twice */
3452 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3454 /* Fake up a method call to VERSION */
3455 meth = newSVpvs_share("VERSION");
3456 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3457 append_elem(OP_LIST,
3458 prepend_elem(OP_LIST, pack, list(version)),
3459 newSVOP(OP_METHOD_NAMED, 0, meth)));
3463 /* Fake up an import/unimport */
3464 if (arg && arg->op_type == OP_STUB) {
3466 op_getmad(arg,pegop,'S');
3467 imop = arg; /* no import on explicit () */
3469 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3470 imop = NULL; /* use 5.0; */
3472 idop->op_private |= OPpCONST_NOVER;
3478 op_getmad(arg,pegop,'A');
3480 /* Make copy of idop so we don't free it twice */
3481 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3483 /* Fake up a method call to import/unimport */
3485 ? newSVpvs_share("import") : newSVpvs_share("unimport");
3486 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3487 append_elem(OP_LIST,
3488 prepend_elem(OP_LIST, pack, list(arg)),
3489 newSVOP(OP_METHOD_NAMED, 0, meth)));
3492 /* Fake up the BEGIN {}, which does its thing immediately. */
3494 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
3497 append_elem(OP_LINESEQ,
3498 append_elem(OP_LINESEQ,
3499 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
3500 newSTATEOP(0, NULL, veop)),
3501 newSTATEOP(0, NULL, imop) ));
3503 /* The "did you use incorrect case?" warning used to be here.
3504 * The problem is that on case-insensitive filesystems one
3505 * might get false positives for "use" (and "require"):
3506 * "use Strict" or "require CARP" will work. This causes
3507 * portability problems for the script: in case-strict
3508 * filesystems the script will stop working.
3510 * The "incorrect case" warning checked whether "use Foo"
3511 * imported "Foo" to your namespace, but that is wrong, too:
3512 * there is no requirement nor promise in the language that
3513 * a Foo.pm should or would contain anything in package "Foo".
3515 * There is very little Configure-wise that can be done, either:
3516 * the case-sensitivity of the build filesystem of Perl does not
3517 * help in guessing the case-sensitivity of the runtime environment.
3520 PL_hints |= HINT_BLOCK_SCOPE;
3521 PL_copline = NOLINE;
3523 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3526 if (!PL_madskills) {
3527 /* FIXME - don't allocate pegop if !PL_madskills */
3536 =head1 Embedding Functions
3538 =for apidoc load_module
3540 Loads the module whose name is pointed to by the string part of name.
3541 Note that the actual module name, not its filename, should be given.
3542 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3543 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3544 (or 0 for no flags). ver, if specified, provides version semantics
3545 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3546 arguments can be used to specify arguments to the module's import()
3547 method, similar to C<use Foo::Bar VERSION LIST>.
3552 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3555 va_start(args, ver);
3556 vload_module(flags, name, ver, &args);
3560 #ifdef PERL_IMPLICIT_CONTEXT
3562 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3566 va_start(args, ver);
3567 vload_module(flags, name, ver, &args);
3573 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3578 OP * const modname = newSVOP(OP_CONST, 0, name);
3579 modname->op_private |= OPpCONST_BARE;
3581 veop = newSVOP(OP_CONST, 0, ver);
3585 if (flags & PERL_LOADMOD_NOIMPORT) {
3586 imop = sawparens(newNULLLIST());
3588 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3589 imop = va_arg(*args, OP*);
3594 sv = va_arg(*args, SV*);
3596 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3597 sv = va_arg(*args, SV*);
3601 const line_t ocopline = PL_copline;
3602 COP * const ocurcop = PL_curcop;
3603 const int oexpect = PL_expect;
3605 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3606 veop, modname, imop);
3607 PL_expect = oexpect;
3608 PL_copline = ocopline;
3609 PL_curcop = ocurcop;
3614 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
3620 if (!force_builtin) {
3621 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
3622 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
3623 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
3624 gv = gvp ? *gvp : NULL;
3628 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3629 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3630 append_elem(OP_LIST, term,
3631 scalar(newUNOP(OP_RV2CV, 0,
3636 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3642 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3644 return newBINOP(OP_LSLICE, flags,
3645 list(force_list(subscript)),
3646 list(force_list(listval)) );
3650 S_is_list_assignment(pTHX_ register const OP *o)
3655 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3656 o = cUNOPo->op_first;
3658 if (o->op_type == OP_COND_EXPR) {
3659 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
3660 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3665 yyerror("Assignment to both a list and a scalar");
3669 if (o->op_type == OP_LIST &&
3670 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3671 o->op_private & OPpLVAL_INTRO)
3674 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3675 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3676 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3679 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3682 if (o->op_type == OP_RV2SV)
3689 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3695 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3696 return newLOGOP(optype, 0,
3697 mod(scalar(left), optype),
3698 newUNOP(OP_SASSIGN, 0, scalar(right)));
3701 return newBINOP(optype, OPf_STACKED,
3702 mod(scalar(left), optype), scalar(right));
3706 if (is_list_assignment(left)) {
3710 /* Grandfathering $[ assignment here. Bletch.*/
3711 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
3712 PL_eval_start = (left->op_type == OP_CONST) ? right : 0;
3713 left = mod(left, OP_AASSIGN);
3716 else if (left->op_type == OP_CONST) {
3718 /* Result of assignment is always 1 (or we'd be dead already) */
3719 return newSVOP(OP_CONST, 0, newSViv(1));
3721 curop = list(force_list(left));
3722 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3723 o->op_private = (U8)(0 | (flags >> 8));
3725 /* PL_generation sorcery:
3726 * an assignment like ($a,$b) = ($c,$d) is easier than
3727 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3728 * To detect whether there are common vars, the global var
3729 * PL_generation is incremented for each assign op we compile.
3730 * Then, while compiling the assign op, we run through all the
3731 * variables on both sides of the assignment, setting a spare slot
3732 * in each of them to PL_generation. If any of them already have
3733 * that value, we know we've got commonality. We could use a
3734 * single bit marker, but then we'd have to make 2 passes, first
3735 * to clear the flag, then to test and set it. To find somewhere
3736 * to store these values, evil chicanery is done with SvCUR().
3739 if (!(left->op_private & OPpLVAL_INTRO)) {
3742 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3743 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3744 if (curop->op_type == OP_GV) {
3745 GV *gv = cGVOPx_gv(curop);
3747 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
3749 GvASSIGN_GENERATION_set(gv, PL_generation);
3751 else if (curop->op_type == OP_PADSV ||
3752 curop->op_type == OP_PADAV ||
3753 curop->op_type == OP_PADHV ||
3754 curop->op_type == OP_PADANY)
3756 if (PAD_COMPNAME_GEN(curop->op_targ)
3757 == (STRLEN)PL_generation)
3759 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
3762 else if (curop->op_type == OP_RV2CV)
3764 else if (curop->op_type == OP_RV2SV ||
3765 curop->op_type == OP_RV2AV ||
3766 curop->op_type == OP_RV2HV ||
3767 curop->op_type == OP_RV2GV) {
3768 if (lastop->op_type != OP_GV) /* funny deref? */
3771 else if (curop->op_type == OP_PUSHRE) {
3772 if (((PMOP*)curop)->op_pmreplroot) {
3774 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3775 ((PMOP*)curop)->op_pmreplroot));
3777 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3780 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
3782 GvASSIGN_GENERATION_set(gv, PL_generation);
3783 GvASSIGN_GENERATION_set(gv, PL_generation);
3792 o->op_private |= OPpASSIGN_COMMON;
3794 if (right && right->op_type == OP_SPLIT) {
3796 if ((tmpop = ((LISTOP*)right)->op_first) &&
3797 tmpop->op_type == OP_PUSHRE)
3799 PMOP * const pm = (PMOP*)tmpop;
3800 if (left->op_type == OP_RV2AV &&
3801 !(left->op_private & OPpLVAL_INTRO) &&
3802 !(o->op_private & OPpASSIGN_COMMON) )
3804 tmpop = ((UNOP*)left)->op_first;
3805 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3807 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3808 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3810 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3811 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
3813 pm->op_pmflags |= PMf_ONCE;
3814 tmpop = cUNOPo->op_first; /* to list (nulled) */
3815 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3816 tmpop->op_sibling = NULL; /* don't free split */
3817 right->op_next = tmpop->op_next; /* fix starting loc */
3819 op_getmad(o,right,'R'); /* blow off assign */
3821 op_free(o); /* blow off assign */
3823 right->op_flags &= ~OPf_WANT;
3824 /* "I don't know and I don't care." */
3829 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3830 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3832 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3834 sv_setiv(sv, PL_modcount+1);
3842 right = newOP(OP_UNDEF, 0);
3843 if (right->op_type == OP_READLINE) {
3844 right->op_flags |= OPf_STACKED;
3845 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3848 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3849 o = newBINOP(OP_SASSIGN, flags,
3850 scalar(right), mod(scalar(left), OP_SASSIGN) );
3856 o = newSVOP(OP_CONST, 0, newSViv(PL_compiling.cop_arybase));
3857 o->op_private |= OPpCONST_ARYBASE;
3864 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3867 const U32 seq = intro_my();
3870 NewOp(1101, cop, 1, COP);
3871 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3872 cop->op_type = OP_DBSTATE;
3873 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3876 cop->op_type = OP_NEXTSTATE;
3877 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3879 cop->op_flags = (U8)flags;
3880 cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
3882 cop->op_private |= NATIVE_HINTS;
3884 PL_compiling.op_private = cop->op_private;
3885 cop->op_next = (OP*)cop;
3888 cop->cop_label = label;
3889 PL_hints |= HINT_BLOCK_SCOPE;
3892 cop->cop_arybase = PL_curcop->cop_arybase;
3893 if (specialWARN(PL_curcop->cop_warnings))
3894 cop->cop_warnings = PL_curcop->cop_warnings ;
3896 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3897 if (specialCopIO(PL_curcop->cop_io))
3898 cop->cop_io = PL_curcop->cop_io;
3900 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3903 if (PL_copline == NOLINE)
3904 CopLINE_set(cop, CopLINE(PL_curcop));
3906 CopLINE_set(cop, PL_copline);
3907 PL_copline = NOLINE;
3910 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3912 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3914 CopSTASH_set(cop, PL_curstash);
3916 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3917 SV * const * const svp = av_fetch(CopFILEAVx(PL_curcop), (I32)CopLINE(cop), FALSE);
3918 if (svp && *svp != &PL_sv_undef ) {
3919 (void)SvIOK_on(*svp);
3920 SvIV_set(*svp, PTR2IV(cop));
3924 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3929 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3932 return new_logop(type, flags, &first, &other);
3936 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3941 OP *first = *firstp;
3942 OP * const other = *otherp;
3944 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3945 return newBINOP(type, flags, scalar(first), scalar(other));
3947 scalarboolean(first);
3948 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3949 if (first->op_type == OP_NOT
3950 && (first->op_flags & OPf_SPECIAL)
3951 && (first->op_flags & OPf_KIDS)) {
3952 if (type == OP_AND || type == OP_OR) {
3958 first = *firstp = cUNOPo->op_first;
3960 first->op_next = o->op_next;
3961 cUNOPo->op_first = NULL;
3963 op_getmad(o,first,'O');
3969 if (first->op_type == OP_CONST) {
3970 if (first->op_private & OPpCONST_STRICT)
3971 no_bareword_allowed(first);
3972 else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
3973 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
3974 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
3975 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
3976 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
3978 if (other->op_type == OP_CONST)
3979 other->op_private |= OPpCONST_SHORTCIRCUIT;
3981 OP *newop = newUNOP(OP_NULL, 0, other);
3982 op_getmad(first, newop, '1');
3983 newop->op_targ = type; /* set "was" field */
3990 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
3991 const OP *o2 = other;
3992 if ( ! (o2->op_type == OP_LIST
3993 && (( o2 = cUNOPx(o2)->op_first))
3994 && o2->op_type == OP_PUSHMARK
3995 && (( o2 = o2->op_sibling)) )
3998 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
3999 || o2->op_type == OP_PADHV)
4000 && o2->op_private & OPpLVAL_INTRO
4001 && ckWARN(WARN_DEPRECATED))
4003 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4004 "Deprecated use of my() in false conditional");
4008 if (first->op_type == OP_CONST)
4009 first->op_private |= OPpCONST_SHORTCIRCUIT;
4011 first = newUNOP(OP_NULL, 0, first);
4012 op_getmad(other, first, '2');
4013 first->op_targ = type; /* set "was" field */
4020 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
4021 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
4023 const OP * const k1 = ((UNOP*)first)->op_first;
4024 const OP * const k2 = k1->op_sibling;
4026 switch (first->op_type)
4029 if (k2 && k2->op_type == OP_READLINE
4030 && (k2->op_flags & OPf_STACKED)
4031 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4033 warnop = k2->op_type;
4038 if (k1->op_type == OP_READDIR
4039 || k1->op_type == OP_GLOB
4040 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4041 || k1->op_type == OP_EACH)
4043 warnop = ((k1->op_type == OP_NULL)
4044 ? (OPCODE)k1->op_targ : k1->op_type);
4049 const line_t oldline = CopLINE(PL_curcop);
4050 CopLINE_set(PL_curcop, PL_copline);
4051 Perl_warner(aTHX_ packWARN(WARN_MISC),
4052 "Value of %s%s can be \"0\"; test with defined()",
4054 ((warnop == OP_READLINE || warnop == OP_GLOB)
4055 ? " construct" : "() operator"));
4056 CopLINE_set(PL_curcop, oldline);
4063 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
4064 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
4066 NewOp(1101, logop, 1, LOGOP);
4068 logop->op_type = (OPCODE)type;
4069 logop->op_ppaddr = PL_ppaddr[type];
4070 logop->op_first = first;
4071 logop->op_flags = (U8)(flags | OPf_KIDS);
4072 logop->op_other = LINKLIST(other);
4073 logop->op_private = (U8)(1 | (flags >> 8));
4075 /* establish postfix order */
4076 logop->op_next = LINKLIST(first);
4077 first->op_next = (OP*)logop;
4078 first->op_sibling = other;
4080 CHECKOP(type,logop);
4082 o = newUNOP(OP_NULL, 0, (OP*)logop);
4089 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
4097 return newLOGOP(OP_AND, 0, first, trueop);
4099 return newLOGOP(OP_OR, 0, first, falseop);
4101 scalarboolean(first);
4102 if (first->op_type == OP_CONST) {
4103 if (first->op_private & OPpCONST_BARE &&
4104 first->op_private & OPpCONST_STRICT) {
4105 no_bareword_allowed(first);
4107 if (SvTRUE(((SVOP*)first)->op_sv)) {
4110 trueop = newUNOP(OP_NULL, 0, trueop);
4111 op_getmad(first,trueop,'C');
4112 op_getmad(falseop,trueop,'e');
4114 /* FIXME for MAD - should there be an ELSE here? */
4124 falseop = newUNOP(OP_NULL, 0, falseop);
4125 op_getmad(first,falseop,'C');
4126 op_getmad(trueop,falseop,'t');
4128 /* FIXME for MAD - should there be an ELSE here? */
4136 NewOp(1101, logop, 1, LOGOP);
4137 logop->op_type = OP_COND_EXPR;
4138 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4139 logop->op_first = first;
4140 logop->op_flags = (U8)(flags | OPf_KIDS);
4141 logop->op_private = (U8)(1 | (flags >> 8));
4142 logop->op_other = LINKLIST(trueop);
4143 logop->op_next = LINKLIST(falseop);
4145 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
4148 /* establish postfix order */
4149 start = LINKLIST(first);
4150 first->op_next = (OP*)logop;
4152 first->op_sibling = trueop;
4153 trueop->op_sibling = falseop;
4154 o = newUNOP(OP_NULL, 0, (OP*)logop);
4156 trueop->op_next = falseop->op_next = o;
4163 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4172 NewOp(1101, range, 1, LOGOP);
4174 range->op_type = OP_RANGE;
4175 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4176 range->op_first = left;
4177 range->op_flags = OPf_KIDS;
4178 leftstart = LINKLIST(left);
4179 range->op_other = LINKLIST(right);
4180 range->op_private = (U8)(1 | (flags >> 8));
4182 left->op_sibling = right;
4184 range->op_next = (OP*)range;
4185 flip = newUNOP(OP_FLIP, flags, (OP*)range);
4186 flop = newUNOP(OP_FLOP, 0, flip);
4187 o = newUNOP(OP_NULL, 0, flop);
4189 range->op_next = leftstart;
4191 left->op_next = flip;
4192 right->op_next = flop;
4194 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4195 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4196 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4197 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4199 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4200 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4203 if (!flip->op_private || !flop->op_private)
4204 linklist(o); /* blow off optimizer unless constant */
4210 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4215 const bool once = block && block->op_flags & OPf_SPECIAL &&
4216 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4218 PERL_UNUSED_ARG(debuggable);
4221 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4222 return block; /* do {} while 0 does once */
4223 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4224 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4225 expr = newUNOP(OP_DEFINED, 0,
4226 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4227 } else if (expr->op_flags & OPf_KIDS) {
4228 const OP * const k1 = ((UNOP*)expr)->op_first;
4229 const OP * const k2 = k1 ? k1->op_sibling : NULL;
4230 switch (expr->op_type) {
4232 if (k2 && k2->op_type == OP_READLINE
4233 && (k2->op_flags & OPf_STACKED)
4234 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4235 expr = newUNOP(OP_DEFINED, 0, expr);
4239 if (k1->op_type == OP_READDIR
4240 || k1->op_type == OP_GLOB
4241 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4242 || k1->op_type == OP_EACH)
4243 expr = newUNOP(OP_DEFINED, 0, expr);
4249 /* if block is null, the next append_elem() would put UNSTACK, a scalar
4250 * op, in listop. This is wrong. [perl #27024] */
4252 block = newOP(OP_NULL, 0);
4253 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4254 o = new_logop(OP_AND, 0, &expr, &listop);
4257 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4259 if (once && o != listop)
4260 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4263 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
4265 o->op_flags |= flags;
4267 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4272 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
4273 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
4282 PERL_UNUSED_ARG(debuggable);
4285 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4286 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4287 expr = newUNOP(OP_DEFINED, 0,
4288 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4289 } else if (expr->op_flags & OPf_KIDS) {
4290 const OP * const k1 = ((UNOP*)expr)->op_first;
4291 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
4292 switch (expr->op_type) {
4294 if (k2 && k2->op_type == OP_READLINE
4295 && (k2->op_flags & OPf_STACKED)
4296 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4297 expr = newUNOP(OP_DEFINED, 0, expr);
4301 if (k1->op_type == OP_READDIR
4302 || k1->op_type == OP_GLOB
4303 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4304 || k1->op_type == OP_EACH)
4305 expr = newUNOP(OP_DEFINED, 0, expr);
4312 block = newOP(OP_NULL, 0);
4313 else if (cont || has_my) {
4314 block = scope(block);
4318 next = LINKLIST(cont);
4321 OP * const unstack = newOP(OP_UNSTACK, 0);
4324 cont = append_elem(OP_LINESEQ, cont, unstack);
4327 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4328 redo = LINKLIST(listop);
4331 PL_copline = (line_t)whileline;
4333 o = new_logop(OP_AND, 0, &expr, &listop);
4334 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4335 op_free(expr); /* oops, it's a while (0) */
4337 return NULL; /* listop already freed by new_logop */
4340 ((LISTOP*)listop)->op_last->op_next =
4341 (o == listop ? redo : LINKLIST(o));
4347 NewOp(1101,loop,1,LOOP);
4348 loop->op_type = OP_ENTERLOOP;
4349 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4350 loop->op_private = 0;
4351 loop->op_next = (OP*)loop;
4354 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4356 loop->op_redoop = redo;
4357 loop->op_lastop = o;
4358 o->op_private |= loopflags;
4361 loop->op_nextop = next;
4363 loop->op_nextop = o;
4365 o->op_flags |= flags;
4366 o->op_private |= (flags >> 8);
4371 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
4376 PADOFFSET padoff = 0;
4382 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4383 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
4384 sv->op_type = OP_RV2GV;
4385 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4386 if (cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
4387 iterpflags |= OPpITER_DEF;
4389 else if (sv->op_type == OP_PADSV) { /* private variable */
4390 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
4391 padoff = sv->op_targ;
4400 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4401 padoff = sv->op_targ;
4406 iterflags |= OPf_SPECIAL;
4412 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4413 if (padoff && strEQ(PAD_COMPNAME_PV(padoff), "$_"))
4414 iterpflags |= OPpITER_DEF;
4417 const I32 offset = pad_findmy("$_");
4418 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
4419 sv = newGVOP(OP_GV, 0, PL_defgv);
4424 iterpflags |= OPpITER_DEF;
4426 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4427 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4428 iterflags |= OPf_STACKED;
4430 else if (expr->op_type == OP_NULL &&
4431 (expr->op_flags & OPf_KIDS) &&
4432 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4434 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4435 * set the STACKED flag to indicate that these values are to be
4436 * treated as min/max values by 'pp_iterinit'.
4438 UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4439 LOGOP* const range = (LOGOP*) flip->op_first;
4440 OP* const left = range->op_first;
4441 OP* const right = left->op_sibling;
4444 range->op_flags &= ~OPf_KIDS;
4445 range->op_first = NULL;
4447 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4448 listop->op_first->op_next = range->op_next;
4449 left->op_next = range->op_other;
4450 right->op_next = (OP*)listop;
4451 listop->op_next = listop->op_first;
4454 op_getmad(expr,(OP*)listop,'O');
4458 expr = (OP*)(listop);
4460 iterflags |= OPf_STACKED;
4463 expr = mod(force_list(expr), OP_GREPSTART);
4466 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4467 append_elem(OP_LIST, expr, scalar(sv))));
4468 assert(!loop->op_next);
4469 /* for my $x () sets OPpLVAL_INTRO;
4470 * for our $x () sets OPpOUR_INTRO */
4471 loop->op_private = (U8)iterpflags;
4472 #ifdef PL_OP_SLAB_ALLOC
4475 NewOp(1234,tmp,1,LOOP);
4476 Copy(loop,tmp,1,LISTOP);
4481 Renew(loop, 1, LOOP);
4483 loop->op_targ = padoff;
4484 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
4486 op_getmad(madsv, (OP*)loop, 'v');
4487 PL_copline = forline;
4488 return newSTATEOP(0, label, wop);
4492 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4497 if (type != OP_GOTO || label->op_type == OP_CONST) {
4498 /* "last()" means "last" */
4499 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4500 o = newOP(type, OPf_SPECIAL);
4502 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4503 ? SvPVx_nolen_const(((SVOP*)label)->op_sv)
4507 op_getmad(label,o,'L');
4513 /* Check whether it's going to be a goto &function */
4514 if (label->op_type == OP_ENTERSUB
4515 && !(label->op_flags & OPf_STACKED))
4516 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4517 o = newUNOP(type, OPf_STACKED, label);
4519 PL_hints |= HINT_BLOCK_SCOPE;
4523 /* if the condition is a literal array or hash
4524 (or @{ ... } etc), make a reference to it.
4527 S_ref_array_or_hash(pTHX_ OP *cond)
4530 && (cond->op_type == OP_RV2AV
4531 || cond->op_type == OP_PADAV
4532 || cond->op_type == OP_RV2HV
4533 || cond->op_type == OP_PADHV))
4535 return newUNOP(OP_REFGEN,
4536 0, mod(cond, OP_REFGEN));
4542 /* These construct the optree fragments representing given()
4545 entergiven and enterwhen are LOGOPs; the op_other pointer
4546 points up to the associated leave op. We need this so we
4547 can put it in the context and make break/continue work.
4548 (Also, of course, pp_enterwhen will jump straight to
4549 op_other if the match fails.)
4554 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
4555 I32 enter_opcode, I32 leave_opcode,
4556 PADOFFSET entertarg)
4562 NewOp(1101, enterop, 1, LOGOP);
4563 enterop->op_type = enter_opcode;
4564 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
4565 enterop->op_flags = (U8) OPf_KIDS;
4566 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
4567 enterop->op_private = 0;
4569 o = newUNOP(leave_opcode, 0, (OP *) enterop);
4572 enterop->op_first = scalar(cond);
4573 cond->op_sibling = block;
4575 o->op_next = LINKLIST(cond);
4576 cond->op_next = (OP *) enterop;
4579 /* This is a default {} block */
4580 enterop->op_first = block;
4581 enterop->op_flags |= OPf_SPECIAL;
4583 o->op_next = (OP *) enterop;
4586 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
4587 entergiven and enterwhen both
4590 enterop->op_next = LINKLIST(block);
4591 block->op_next = enterop->op_other = o;
4596 /* Does this look like a boolean operation? For these purposes
4597 a boolean operation is:
4598 - a subroutine call [*]
4599 - a logical connective
4600 - a comparison operator
4601 - a filetest operator, with the exception of -s -M -A -C
4602 - defined(), exists() or eof()
4603 - /$re/ or $foo =~ /$re/
4605 [*] possibly surprising
4609 S_looks_like_bool(pTHX_ OP *o)
4612 switch(o->op_type) {
4614 return looks_like_bool(cLOGOPo->op_first);
4618 looks_like_bool(cLOGOPo->op_first)
4619 && looks_like_bool(cLOGOPo->op_first->op_sibling));
4623 case OP_NOT: case OP_XOR:
4624 /* Note that OP_DOR is not here */
4626 case OP_EQ: case OP_NE: case OP_LT:
4627 case OP_GT: case OP_LE: case OP_GE:
4629 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
4630 case OP_I_GT: case OP_I_LE: case OP_I_GE:
4632 case OP_SEQ: case OP_SNE: case OP_SLT:
4633 case OP_SGT: case OP_SLE: case OP_SGE:
4637 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
4638 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
4639 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
4640 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
4641 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
4642 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
4643 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
4644 case OP_FTTEXT: case OP_FTBINARY:
4646 case OP_DEFINED: case OP_EXISTS:
4647 case OP_MATCH: case OP_EOF:
4652 /* Detect comparisons that have been optimized away */
4653 if (cSVOPo->op_sv == &PL_sv_yes
4654 || cSVOPo->op_sv == &PL_sv_no)
4665 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
4669 return newGIVWHENOP(
4670 ref_array_or_hash(cond),
4672 OP_ENTERGIVEN, OP_LEAVEGIVEN,
4676 /* If cond is null, this is a default {} block */
4678 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
4680 bool cond_llb = (!cond || looks_like_bool(cond));
4686 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
4688 scalar(ref_array_or_hash(cond)));
4691 return newGIVWHENOP(
4693 append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
4694 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
4698 =for apidoc cv_undef
4700 Clear out all the active components of a CV. This can happen either
4701 by an explicit C<undef &foo>, or by the reference count going to zero.
4702 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
4703 children can still follow the full lexical scope chain.
4709 Perl_cv_undef(pTHX_ CV *cv)
4713 if (CvFILE(cv) && !CvISXSUB(cv)) {
4714 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4715 Safefree(CvFILE(cv));
4720 if (!CvISXSUB(cv) && CvROOT(cv)) {
4721 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
4722 Perl_croak(aTHX_ "Can't undef active subroutine");
4725 PAD_SAVE_SETNULLPAD();
4727 op_free(CvROOT(cv));
4732 SvPOK_off((SV*)cv); /* forget prototype */
4737 /* remove CvOUTSIDE unless this is an undef rather than a free */
4738 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
4739 if (!CvWEAKOUTSIDE(cv))
4740 SvREFCNT_dec(CvOUTSIDE(cv));
4741 CvOUTSIDE(cv) = NULL;
4744 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4747 if (CvISXSUB(cv) && CvXSUB(cv)) {
4750 /* delete all flags except WEAKOUTSIDE */
4751 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
4755 Perl_cv_ckproto(pTHX_ const CV *cv, const GV *gv, const char *p)
4757 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX_const(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4758 SV* const msg = sv_newmortal();
4762 gv_efullname3(name = sv_newmortal(), gv, NULL);
4763 sv_setpv(msg, "Prototype mismatch:");
4765 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4767 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (const SV *)cv);
4769 sv_catpvs(msg, ": none");
4770 sv_catpvs(msg, " vs ");
4772 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4774 sv_catpvs(msg, "none");
4775 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
4779 static void const_sv_xsub(pTHX_ CV* cv);
4783 =head1 Optree Manipulation Functions
4785 =for apidoc cv_const_sv
4787 If C<cv> is a constant sub eligible for inlining. returns the constant
4788 value returned by the sub. Otherwise, returns NULL.
4790 Constant subs can be created with C<newCONSTSUB> or as described in
4791 L<perlsub/"Constant Functions">.
4796 Perl_cv_const_sv(pTHX_ CV *cv)
4798 PERL_UNUSED_CONTEXT;
4801 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
4803 return CvCONST(cv) ? (SV*)CvXSUBANY(cv).any_ptr : NULL;
4806 /* op_const_sv: examine an optree to determine whether it's in-lineable.
4807 * Can be called in 3 ways:
4810 * look for a single OP_CONST with attached value: return the value
4812 * cv && CvCLONE(cv) && !CvCONST(cv)
4814 * examine the clone prototype, and if contains only a single
4815 * OP_CONST referencing a pad const, or a single PADSV referencing
4816 * an outer lexical, return a non-zero value to indicate the CV is
4817 * a candidate for "constizing" at clone time
4821 * We have just cloned an anon prototype that was marked as a const
4822 * candidiate. Try to grab the current value, and in the case of
4823 * PADSV, ignore it if it has multiple references. Return the value.
4827 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
4835 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4836 o = cLISTOPo->op_first->op_sibling;
4838 for (; o; o = o->op_next) {
4839 const OPCODE type = o->op_type;
4841 if (sv && o->op_next == o)
4843 if (o->op_next != o) {
4844 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4846 if (type == OP_DBSTATE)
4849 if (type == OP_LEAVESUB || type == OP_RETURN)
4853 if (type == OP_CONST && cSVOPo->op_sv)
4855 else if (cv && type == OP_CONST) {
4856 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4860 else if (cv && type == OP_PADSV) {
4861 if (CvCONST(cv)) { /* newly cloned anon */
4862 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4863 /* the candidate should have 1 ref from this pad and 1 ref
4864 * from the parent */
4865 if (!sv || SvREFCNT(sv) != 2)
4872 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
4873 sv = &PL_sv_undef; /* an arbitrary non-null value */
4888 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4891 /* This would be the return value, but the return cannot be reached. */
4892 OP* pegop = newOP(OP_NULL, 0);
4895 PERL_UNUSED_ARG(floor);
4905 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4907 NORETURN_FUNCTION_END;
4912 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4914 return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
4918 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4925 register CV *cv = NULL;
4927 /* If the subroutine has no body, no attributes, and no builtin attributes
4928 then it's just a sub declaration, and we may be able to get away with
4929 storing with a placeholder scalar in the symbol table, rather than a
4930 full GV and CV. If anything is present then it will take a full CV to
4932 const I32 gv_fetch_flags
4933 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
4935 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
4936 const char * const name = o ? SvPVx_nolen_const(cSVOPo->op_sv) : NULL;
4939 assert(proto->op_type == OP_CONST);
4940 ps = SvPVx_const(((SVOP*)proto)->op_sv, ps_len);
4945 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4946 SV * const sv = sv_newmortal();
4947 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4948 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
4949 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4950 aname = SvPVX_const(sv);
4955 gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
4956 : gv_fetchpv(aname ? aname
4957 : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4958 gv_fetch_flags, SVt_PVCV);
4960 if (!PL_madskills) {
4969 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
4970 maximum a prototype before. */
4971 if (SvTYPE(gv) > SVt_NULL) {
4972 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4973 && ckWARN_d(WARN_PROTOTYPE))
4975 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
4977 cv_ckproto((CV*)gv, NULL, ps);
4980 sv_setpvn((SV*)gv, ps, ps_len);
4982 sv_setiv((SV*)gv, -1);
4983 SvREFCNT_dec(PL_compcv);
4984 cv = PL_compcv = NULL;
4985 PL_sub_generation++;
4989 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
4991 #ifdef GV_UNIQUE_CHECK
4992 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4993 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4997 if (!block || !ps || *ps || attrs
4998 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5000 || block->op_type == OP_NULL
5005 const_sv = op_const_sv(block, NULL);
5008 const bool exists = CvROOT(cv) || CvXSUB(cv);
5010 #ifdef GV_UNIQUE_CHECK
5011 if (exists && GvUNIQUE(gv)) {
5012 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
5016 /* if the subroutine doesn't exist and wasn't pre-declared
5017 * with a prototype, assume it will be AUTOLOADed,
5018 * skipping the prototype check
5020 if (exists || SvPOK(cv))
5021 cv_ckproto(cv, gv, ps);
5022 /* already defined (or promised)? */
5023 if (exists || GvASSUMECV(gv)) {
5026 || block->op_type == OP_NULL
5029 if (CvFLAGS(PL_compcv)) {
5030 /* might have had built-in attrs applied */
5031 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5033 /* just a "sub foo;" when &foo is already defined */
5034 SAVEFREESV(PL_compcv);
5039 && block->op_type != OP_NULL
5042 if (ckWARN(WARN_REDEFINE)
5044 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
5046 const line_t oldline = CopLINE(PL_curcop);
5047 if (PL_copline != NOLINE)
5048 CopLINE_set(PL_curcop, PL_copline);
5049 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5050 CvCONST(cv) ? "Constant subroutine %s redefined"
5051 : "Subroutine %s redefined", name);
5052 CopLINE_set(PL_curcop, oldline);
5055 if (!PL_minus_c) /* keep old one around for madskills */
5058 /* (PL_madskills unset in used file.) */
5066 SvREFCNT_inc_void_NN(const_sv);
5068 assert(!CvROOT(cv) && !CvCONST(cv));
5069 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
5070 CvXSUBANY(cv).any_ptr = const_sv;
5071 CvXSUB(cv) = const_sv_xsub;
5077 cv = newCONSTSUB(NULL, name, const_sv);
5079 PL_sub_generation++;
5083 SvREFCNT_dec(PL_compcv);
5091 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
5092 * before we clobber PL_compcv.
5096 || block->op_type == OP_NULL
5100 /* Might have had built-in attributes applied -- propagate them. */
5101 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5102 if (CvGV(cv) && GvSTASH(CvGV(cv)))
5103 stash = GvSTASH(CvGV(cv));
5104 else if (CvSTASH(cv))
5105 stash = CvSTASH(cv);
5107 stash = PL_curstash;
5110 /* possibly about to re-define existing subr -- ignore old cv */
5111 rcv = (SV*)PL_compcv;
5112 if (name && GvSTASH(gv))
5113 stash = GvSTASH(gv);
5115 stash = PL_curstash;
5117 apply_attrs(stash, rcv, attrs, FALSE);
5119 if (cv) { /* must reuse cv if autoloaded */
5126 || block->op_type == OP_NULL) && !PL_madskills
5129 /* got here with just attrs -- work done, so bug out */
5130 SAVEFREESV(PL_compcv);
5133 /* transfer PL_compcv to cv */
5135 CvFLAGS(cv) = CvFLAGS(PL_compcv);
5136 if (!CvWEAKOUTSIDE(cv))
5137 SvREFCNT_dec(CvOUTSIDE(cv));
5138 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
5139 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
5140 CvOUTSIDE(PL_compcv) = 0;
5141 CvPADLIST(cv) = CvPADLIST(PL_compcv);
5142 CvPADLIST(PL_compcv) = 0;
5143 /* inner references to PL_compcv must be fixed up ... */
5144 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
5145 /* ... before we throw it away */
5146 SvREFCNT_dec(PL_compcv);
5148 if (PERLDB_INTER)/* Advice debugger on the new sub. */
5149 ++PL_sub_generation;
5156 if (strEQ(name, "import")) {
5157 PL_formfeed = (SV*)cv;
5158 Perl_warner(aTHX_ packWARN(WARN_VOID), "%lx\n", (long)cv);
5162 PL_sub_generation++;
5166 CvFILE_set_from_cop(cv, PL_curcop);
5167 CvSTASH(cv) = PL_curstash;
5170 sv_setpvn((SV*)cv, ps, ps_len);
5172 if (PL_error_count) {
5176 const char *s = strrchr(name, ':');
5178 if (strEQ(s, "BEGIN")) {
5179 const char not_safe[] =
5180 "BEGIN not safe after errors--compilation aborted";
5181 if (PL_in_eval & EVAL_KEEPERR)
5182 Perl_croak(aTHX_ not_safe);
5184 /* force display of errors found but not reported */
5185 sv_catpv(ERRSV, not_safe);
5186 Perl_croak(aTHX_ "%"SVf, ERRSV);
5196 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5197 mod(scalarseq(block), OP_LEAVESUBLV));
5200 /* This makes sub {}; work as expected. */
5201 if (block->op_type == OP_STUB) {
5202 OP* newblock = newSTATEOP(0, NULL, 0);
5204 op_getmad(block,newblock,'B');
5210 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5212 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5213 OpREFCNT_set(CvROOT(cv), 1);
5214 CvSTART(cv) = LINKLIST(CvROOT(cv));
5215 CvROOT(cv)->op_next = 0;
5216 CALL_PEEP(CvSTART(cv));
5218 /* now that optimizer has done its work, adjust pad values */
5220 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
5223 assert(!CvCONST(cv));
5224 if (ps && !*ps && op_const_sv(block, cv))
5228 if (name || aname) {
5230 const char * const tname = (name ? name : aname);
5232 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5233 SV * const sv = newSV(0);
5234 SV * const tmpstr = sv_newmortal();
5235 GV * const db_postponed = gv_fetchpvs("DB::postponed",
5236 GV_ADDMULTI, SVt_PVHV);
5239 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5241 (long)PL_subline, (long)CopLINE(PL_curcop));
5242 gv_efullname3(tmpstr, gv, NULL);
5243 hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0);
5244 hv = GvHVn(db_postponed);
5245 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
5246 CV * const pcv = GvCV(db_postponed);
5252 call_sv((SV*)pcv, G_DISCARD);
5257 if ((s = strrchr(tname,':')))
5262 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5265 if (strEQ(s, "BEGIN") && !PL_error_count) {
5266 const I32 oldscope = PL_scopestack_ix;
5268 SAVECOPFILE(&PL_compiling);
5269 SAVECOPLINE(&PL_compiling);
5272 PL_beginav = newAV();
5273 DEBUG_x( dump_sub(gv) );
5274 av_push(PL_beginav, (SV*)cv);
5275 GvCV(gv) = 0; /* cv has been hijacked */
5276 call_list(oldscope, PL_beginav);
5278 PL_curcop = &PL_compiling;
5279 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
5282 else if (strEQ(s, "END") && !PL_error_count) {
5285 DEBUG_x( dump_sub(gv) );
5286 av_unshift(PL_endav, 1);
5287 av_store(PL_endav, 0, (SV*)cv);
5288 GvCV(gv) = 0; /* cv has been hijacked */
5290 else if (strEQ(s, "CHECK") && !PL_error_count) {
5292 PL_checkav = newAV();
5293 DEBUG_x( dump_sub(gv) );
5294 if (PL_main_start && ckWARN(WARN_VOID))
5295 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
5296 av_unshift(PL_checkav, 1);
5297 av_store(PL_checkav, 0, (SV*)cv);
5298 GvCV(gv) = 0; /* cv has been hijacked */
5300 else if (strEQ(s, "INIT") && !PL_error_count) {
5302 PL_initav = newAV();
5303 DEBUG_x( dump_sub(gv) );
5304 if (PL_main_start && ckWARN(WARN_VOID))
5305 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
5306 av_push(PL_initav, (SV*)cv);
5307 GvCV(gv) = 0; /* cv has been hijacked */
5312 PL_copline = NOLINE;
5317 /* XXX unsafe for threads if eval_owner isn't held */
5319 =for apidoc newCONSTSUB
5321 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5322 eligible for inlining at compile-time.
5328 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
5335 SAVECOPLINE(PL_curcop);
5336 CopLINE_set(PL_curcop, PL_copline);
5339 PL_hints &= ~HINT_BLOCK_SCOPE;
5342 SAVESPTR(PL_curstash);
5343 SAVECOPSTASH(PL_curcop);
5344 PL_curstash = stash;
5345 CopSTASH_set(PL_curcop,stash);
5348 cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
5349 CvXSUBANY(cv).any_ptr = sv;
5351 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
5355 CopSTASH_free(PL_curcop);
5363 =for apidoc U||newXS
5365 Used by C<xsubpp> to hook up XSUBs as Perl subs.
5371 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
5374 GV * const gv = gv_fetchpv(name ? name :
5375 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5376 GV_ADDMULTI, SVt_PVCV);
5380 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
5382 if ((cv = (name ? GvCV(gv) : NULL))) {
5384 /* just a cached method */
5388 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5389 /* already defined (or promised) */
5390 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
5391 if (ckWARN(WARN_REDEFINE)) {
5392 GV * const gvcv = CvGV(cv);
5394 HV * const stash = GvSTASH(gvcv);
5396 const char *redefined_name = HvNAME_get(stash);
5397 if ( strEQ(redefined_name,"autouse") ) {
5398 const line_t oldline = CopLINE(PL_curcop);
5399 if (PL_copline != NOLINE)
5400 CopLINE_set(PL_curcop, PL_copline);
5401 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5402 CvCONST(cv) ? "Constant subroutine %s redefined"
5403 : "Subroutine %s redefined"
5405 CopLINE_set(PL_curcop, oldline);
5415 if (cv) /* must reuse cv if autoloaded */
5419 sv_upgrade((SV *)cv, SVt_PVCV);
5423 PL_sub_generation++;
5427 (void)gv_fetchfile(filename);
5428 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
5429 an external constant string */
5431 CvXSUB(cv) = subaddr;
5434 const char *s = strrchr(name,':');
5440 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5443 if (strEQ(s, "BEGIN")) {
5445 PL_beginav = newAV();
5446 av_push(PL_beginav, (SV*)cv);
5447 GvCV(gv) = 0; /* cv has been hijacked */
5449 else if (strEQ(s, "END")) {
5452 av_unshift(PL_endav, 1);
5453 av_store(PL_endav, 0, (SV*)cv);
5454 GvCV(gv) = 0; /* cv has been hijacked */
5456 else if (strEQ(s, "CHECK")) {
5458 PL_checkav = newAV();
5459 if (PL_main_start && ckWARN(WARN_VOID))
5460 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
5461 av_unshift(PL_checkav, 1);
5462 av_store(PL_checkav, 0, (SV*)cv);
5463 GvCV(gv) = 0; /* cv has been hijacked */
5465 else if (strEQ(s, "INIT")) {
5467 PL_initav = newAV();
5468 if (PL_main_start && ckWARN(WARN_VOID))
5469 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
5470 av_push(PL_initav, (SV*)cv);
5471 GvCV(gv) = 0; /* cv has been hijacked */
5486 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5491 OP* pegop = newOP(OP_NULL, 0);
5495 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
5496 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
5498 #ifdef GV_UNIQUE_CHECK
5500 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5504 if ((cv = GvFORM(gv))) {
5505 if (ckWARN(WARN_REDEFINE)) {
5506 const line_t oldline = CopLINE(PL_curcop);
5507 if (PL_copline != NOLINE)
5508 CopLINE_set(PL_curcop, PL_copline);
5509 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5510 o ? "Format %"SVf" redefined"
5511 : "Format STDOUT redefined" ,cSVOPo->op_sv);
5512 CopLINE_set(PL_curcop, oldline);
5519 CvFILE_set_from_cop(cv, PL_curcop);
5522 pad_tidy(padtidy_FORMAT);
5523 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5524 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5525 OpREFCNT_set(CvROOT(cv), 1);
5526 CvSTART(cv) = LINKLIST(CvROOT(cv));
5527 CvROOT(cv)->op_next = 0;
5528 CALL_PEEP(CvSTART(cv));
5530 op_getmad(o,pegop,'n');
5531 op_getmad_weak(block, pegop, 'b');
5535 PL_copline = NOLINE;
5543 Perl_newANONLIST(pTHX_ OP *o)
5545 return newUNOP(OP_REFGEN, 0,
5546 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5550 Perl_newANONHASH(pTHX_ OP *o)
5552 return newUNOP(OP_REFGEN, 0,
5553 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5557 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5559 return newANONATTRSUB(floor, proto, NULL, block);
5563 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5565 return newUNOP(OP_REFGEN, 0,
5566 newSVOP(OP_ANONCODE, 0,
5567 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5571 Perl_oopsAV(pTHX_ OP *o)
5574 switch (o->op_type) {
5576 o->op_type = OP_PADAV;
5577 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5578 return ref(o, OP_RV2AV);
5581 o->op_type = OP_RV2AV;
5582 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5587 if (ckWARN_d(WARN_INTERNAL))
5588 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
5595 Perl_oopsHV(pTHX_ OP *o)
5598 switch (o->op_type) {
5601 o->op_type = OP_PADHV;
5602 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5603 return ref(o, OP_RV2HV);
5607 o->op_type = OP_RV2HV;
5608 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5613 if (ckWARN_d(WARN_INTERNAL))
5614 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
5621 Perl_newAVREF(pTHX_ OP *o)
5624 if (o->op_type == OP_PADANY) {
5625 o->op_type = OP_PADAV;
5626 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5629 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5630 && ckWARN(WARN_DEPRECATED)) {
5631 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5632 "Using an array as a reference is deprecated");
5634 return newUNOP(OP_RV2AV, 0, scalar(o));
5638 Perl_newGVREF(pTHX_ I32 type, OP *o)
5640 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5641 return newUNOP(OP_NULL, 0, o);
5642 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5646 Perl_newHVREF(pTHX_ OP *o)
5649 if (o->op_type == OP_PADANY) {
5650 o->op_type = OP_PADHV;
5651 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5654 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5655 && ckWARN(WARN_DEPRECATED)) {
5656 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5657 "Using a hash as a reference is deprecated");
5659 return newUNOP(OP_RV2HV, 0, scalar(o));
5663 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5665 return newUNOP(OP_RV2CV, flags, scalar(o));
5669 Perl_newSVREF(pTHX_ OP *o)
5672 if (o->op_type == OP_PADANY) {
5673 o->op_type = OP_PADSV;
5674 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5677 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5678 o->op_flags |= OPpDONE_SVREF;
5681 return newUNOP(OP_RV2SV, 0, scalar(o));
5684 /* Check routines. See the comments at the top of this file for details
5685 * on when these are called */
5688 Perl_ck_anoncode(pTHX_ OP *o)
5690 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
5692 cSVOPo->op_sv = Nullsv;
5697 Perl_ck_bitop(pTHX_ OP *o)
5700 #define OP_IS_NUMCOMPARE(op) \
5701 ((op) == OP_LT || (op) == OP_I_LT || \
5702 (op) == OP_GT || (op) == OP_I_GT || \
5703 (op) == OP_LE || (op) == OP_I_LE || \
5704 (op) == OP_GE || (op) == OP_I_GE || \
5705 (op) == OP_EQ || (op) == OP_I_EQ || \
5706 (op) == OP_NE || (op) == OP_I_NE || \
5707 (op) == OP_NCMP || (op) == OP_I_NCMP)
5708 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
5709 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
5710 && (o->op_type == OP_BIT_OR
5711 || o->op_type == OP_BIT_AND
5712 || o->op_type == OP_BIT_XOR))
5714 const OP * const left = cBINOPo->op_first;
5715 const OP * const right = left->op_sibling;
5716 if ((OP_IS_NUMCOMPARE(left->op_type) &&
5717 (left->op_flags & OPf_PARENS) == 0) ||
5718 (OP_IS_NUMCOMPARE(right->op_type) &&
5719 (right->op_flags & OPf_PARENS) == 0))
5720 if (ckWARN(WARN_PRECEDENCE))
5721 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
5722 "Possible precedence problem on bitwise %c operator",
5723 o->op_type == OP_BIT_OR ? '|'
5724 : o->op_type == OP_BIT_AND ? '&' : '^'
5731 Perl_ck_concat(pTHX_ OP *o)
5733 const OP * const kid = cUNOPo->op_first;
5734 PERL_UNUSED_CONTEXT;
5735 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
5736 !(kUNOP->op_first->op_flags & OPf_MOD))
5737 o->op_flags |= OPf_STACKED;
5742 Perl_ck_spair(pTHX_ OP *o)
5745 if (o->op_flags & OPf_KIDS) {
5748 const OPCODE type = o->op_type;
5749 o = modkids(ck_fun(o), type);
5750 kid = cUNOPo->op_first;
5751 newop = kUNOP->op_first->op_sibling;
5753 (newop->op_sibling ||
5754 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5755 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5756 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5761 op_getmad(kUNOP->op_first,newop,'K');
5763 op_free(kUNOP->op_first);
5765 kUNOP->op_first = newop;
5767 o->op_ppaddr = PL_ppaddr[++o->op_type];
5772 Perl_ck_delete(pTHX_ OP *o)
5776 if (o->op_flags & OPf_KIDS) {
5777 OP * const kid = cUNOPo->op_first;
5778 switch (kid->op_type) {
5780 o->op_flags |= OPf_SPECIAL;
5783 o->op_private |= OPpSLICE;
5786 o->op_flags |= OPf_SPECIAL;
5791 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5800 Perl_ck_die(pTHX_ OP *o)
5803 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5809 Perl_ck_eof(pTHX_ OP *o)
5812 const I32 type = o->op_type;
5814 if (o->op_flags & OPf_KIDS) {
5815 if (cLISTOPo->op_first->op_type == OP_STUB) {
5817 = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
5819 op_getmad(o,newop,'O');
5831 Perl_ck_eval(pTHX_ OP *o)
5834 PL_hints |= HINT_BLOCK_SCOPE;
5835 if (o->op_flags & OPf_KIDS) {
5836 SVOP * const kid = (SVOP*)cUNOPo->op_first;
5839 o->op_flags &= ~OPf_KIDS;
5842 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
5848 cUNOPo->op_first = 0;
5853 NewOp(1101, enter, 1, LOGOP);
5854 enter->op_type = OP_ENTERTRY;
5855 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5856 enter->op_private = 0;
5858 /* establish postfix order */
5859 enter->op_next = (OP*)enter;
5861 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5862 o->op_type = OP_LEAVETRY;
5863 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5864 enter->op_other = o;
5865 op_getmad(oldo,o,'O');
5879 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5880 op_getmad(oldo,o,'O');
5882 o->op_targ = (PADOFFSET)PL_hints;
5883 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
5884 /* Store a copy of %^H that pp_entereval can pick up */
5885 OP *hhop = newSVOP(OP_CONST, 0, (SV*)newHVhv(GvHV(PL_hintgv)));
5886 cUNOPo->op_first->op_sibling = hhop;
5887 o->op_private |= OPpEVAL_HAS_HH;
5893 Perl_ck_exit(pTHX_ OP *o)
5896 HV * const table = GvHV(PL_hintgv);
5898 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
5899 if (svp && *svp && SvTRUE(*svp))
5900 o->op_private |= OPpEXIT_VMSISH;
5902 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5908 Perl_ck_exec(pTHX_ OP *o)
5910 if (o->op_flags & OPf_STACKED) {
5913 kid = cUNOPo->op_first->op_sibling;
5914 if (kid->op_type == OP_RV2GV)
5923 Perl_ck_exists(pTHX_ OP *o)
5927 if (o->op_flags & OPf_KIDS) {
5928 OP * const kid = cUNOPo->op_first;
5929 if (kid->op_type == OP_ENTERSUB) {
5930 (void) ref(kid, o->op_type);
5931 if (kid->op_type != OP_RV2CV && !PL_error_count)
5932 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5934 o->op_private |= OPpEXISTS_SUB;
5936 else if (kid->op_type == OP_AELEM)
5937 o->op_flags |= OPf_SPECIAL;
5938 else if (kid->op_type != OP_HELEM)
5939 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5947 Perl_ck_rvconst(pTHX_ register OP *o)
5950 SVOP * const kid = (SVOP*)cUNOPo->op_first;
5952 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5953 if (o->op_type == OP_RV2CV)
5954 o->op_private &= ~1;
5956 if (kid->op_type == OP_CONST) {
5959 SV * const kidsv = kid->op_sv;
5961 /* Is it a constant from cv_const_sv()? */
5962 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5963 SV * const rsv = SvRV(kidsv);
5964 const int svtype = SvTYPE(rsv);
5965 const char *badtype = NULL;
5967 switch (o->op_type) {
5969 if (svtype > SVt_PVMG)
5970 badtype = "a SCALAR";
5973 if (svtype != SVt_PVAV)
5974 badtype = "an ARRAY";
5977 if (svtype != SVt_PVHV)
5981 if (svtype != SVt_PVCV)
5986 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5989 else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
5990 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
5991 /* If this is an access to a stash, disable "strict refs", because
5992 * stashes aren't auto-vivified at compile-time (unless we store
5993 * symbols in them), and we don't want to produce a run-time
5994 * stricture error when auto-vivifying the stash. */
5995 const char *s = SvPV_nolen(kidsv);
5996 const STRLEN l = SvCUR(kidsv);
5997 if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
5998 o->op_private &= ~HINT_STRICT_REFS;
6000 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
6001 const char *badthing;
6002 switch (o->op_type) {
6004 badthing = "a SCALAR";
6007 badthing = "an ARRAY";
6010 badthing = "a HASH";
6018 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
6022 * This is a little tricky. We only want to add the symbol if we
6023 * didn't add it in the lexer. Otherwise we get duplicate strict
6024 * warnings. But if we didn't add it in the lexer, we must at
6025 * least pretend like we wanted to add it even if it existed before,
6026 * or we get possible typo warnings. OPpCONST_ENTERED says
6027 * whether the lexer already added THIS instance of this symbol.
6029 iscv = (o->op_type == OP_RV2CV) * 2;
6031 gv = gv_fetchsv(kidsv,
6032 iscv | !(kid->op_private & OPpCONST_ENTERED),
6035 : o->op_type == OP_RV2SV
6037 : o->op_type == OP_RV2AV
6039 : o->op_type == OP_RV2HV
6042 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
6044 kid->op_type = OP_GV;
6045 SvREFCNT_dec(kid->op_sv);
6047 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
6048 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
6049 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
6051 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc_simple_NN(gv));
6053 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
6055 kid->op_private = 0;
6056 kid->op_ppaddr = PL_ppaddr[OP_GV];
6063 Perl_ck_ftst(pTHX_ OP *o)
6066 const I32 type = o->op_type;
6068 if (o->op_flags & OPf_REF) {
6071 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
6072 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6074 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6075 OP * const newop = newGVOP(type, OPf_REF,
6076 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
6078 op_getmad(o,newop,'O');
6086 if ((PL_hints & HINT_FILETEST_ACCESS) &&
6087 OP_IS_FILETEST_ACCESS(o))
6088 o->op_private |= OPpFT_ACCESS;
6090 if (PL_check[kid->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst)
6091 && kid->op_type != OP_STAT && kid->op_type != OP_LSTAT)
6092 o->op_private |= OPpFT_STACKED;
6100 if (type == OP_FTTTY)
6101 o = newGVOP(type, OPf_REF, PL_stdingv);
6103 o = newUNOP(type, 0, newDEFSVOP());
6104 op_getmad(oldo,o,'O');
6110 Perl_ck_fun(pTHX_ OP *o)
6113 const int type = o->op_type;
6114 register I32 oa = PL_opargs[type] >> OASHIFT;
6116 if (o->op_flags & OPf_STACKED) {
6117 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
6120 return no_fh_allowed(o);
6123 if (o->op_flags & OPf_KIDS) {
6124 OP **tokid = &cLISTOPo->op_first;
6125 register OP *kid = cLISTOPo->op_first;
6129 if (kid->op_type == OP_PUSHMARK ||
6130 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
6132 tokid = &kid->op_sibling;
6133 kid = kid->op_sibling;
6135 if (!kid && PL_opargs[type] & OA_DEFGV)
6136 *tokid = kid = newDEFSVOP();
6140 sibl = kid->op_sibling;
6142 if (!sibl && kid->op_type == OP_STUB) {
6149 /* list seen where single (scalar) arg expected? */
6150 if (numargs == 1 && !(oa >> 4)
6151 && kid->op_type == OP_LIST && type != OP_SCALAR)
6153 return too_many_arguments(o,PL_op_desc[type]);
6166 if ((type == OP_PUSH || type == OP_UNSHIFT)
6167 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
6168 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6169 "Useless use of %s with no values",
6172 if (kid->op_type == OP_CONST &&
6173 (kid->op_private & OPpCONST_BARE))
6175 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
6176 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
6177 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6178 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6179 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
6180 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
6182 op_getmad(kid,newop,'K');
6187 kid->op_sibling = sibl;
6190 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
6191 bad_type(numargs, "array", PL_op_desc[type], kid);
6195 if (kid->op_type == OP_CONST &&
6196 (kid->op_private & OPpCONST_BARE))
6198 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
6199 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
6200 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6201 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6202 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
6203 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
6205 op_getmad(kid,newop,'K');
6210 kid->op_sibling = sibl;
6213 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
6214 bad_type(numargs, "hash", PL_op_desc[type], kid);
6219 OP * const newop = newUNOP(OP_NULL, 0, kid);
6220 kid->op_sibling = 0;
6222 newop->op_next = newop;
6224 kid->op_sibling = sibl;
6229 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
6230 if (kid->op_type == OP_CONST &&
6231 (kid->op_private & OPpCONST_BARE))
6233 OP * const newop = newGVOP(OP_GV, 0,
6234 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
6235 if (!(o->op_private & 1) && /* if not unop */
6236 kid == cLISTOPo->op_last)
6237 cLISTOPo->op_last = newop;
6239 op_getmad(kid,newop,'K');
6245 else if (kid->op_type == OP_READLINE) {
6246 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
6247 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
6250 I32 flags = OPf_SPECIAL;
6254 /* is this op a FH constructor? */
6255 if (is_handle_constructor(o,numargs)) {
6256 const char *name = NULL;
6260 /* Set a flag to tell rv2gv to vivify
6261 * need to "prove" flag does not mean something
6262 * else already - NI-S 1999/05/07
6265 if (kid->op_type == OP_PADSV) {
6266 name = PAD_COMPNAME_PV(kid->op_targ);
6267 /* SvCUR of a pad namesv can't be trusted
6268 * (see PL_generation), so calc its length
6274 else if (kid->op_type == OP_RV2SV
6275 && kUNOP->op_first->op_type == OP_GV)
6277 GV * const gv = cGVOPx_gv(kUNOP->op_first);
6279 len = GvNAMELEN(gv);
6281 else if (kid->op_type == OP_AELEM
6282 || kid->op_type == OP_HELEM)
6284 OP *op = ((BINOP*)kid)->op_first;
6288 const char * const a =
6289 kid->op_type == OP_AELEM ?
6291 if (((op->op_type == OP_RV2AV) ||
6292 (op->op_type == OP_RV2HV)) &&
6293 (op = ((UNOP*)op)->op_first) &&
6294 (op->op_type == OP_GV)) {
6295 /* packagevar $a[] or $h{} */
6296 GV * const gv = cGVOPx_gv(op);
6304 else if (op->op_type == OP_PADAV
6305 || op->op_type == OP_PADHV) {
6306 /* lexicalvar $a[] or $h{} */
6307 const char * const padname =
6308 PAD_COMPNAME_PV(op->op_targ);
6317 name = SvPV_const(tmpstr, len);
6322 name = "__ANONIO__";
6329 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
6330 namesv = PAD_SVl(targ);
6331 SvUPGRADE(namesv, SVt_PV);
6333 sv_setpvn(namesv, "$", 1);
6334 sv_catpvn(namesv, name, len);
6337 kid->op_sibling = 0;
6338 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
6339 kid->op_targ = targ;
6340 kid->op_private |= priv;
6342 kid->op_sibling = sibl;
6348 mod(scalar(kid), type);
6352 tokid = &kid->op_sibling;
6353 kid = kid->op_sibling;
6356 if (kid && kid->op_type != OP_STUB)
6357 return too_many_arguments(o,OP_DESC(o));
6358 o->op_private |= numargs;
6360 /* FIXME - should the numargs move as for the PERL_MAD case? */
6361 o->op_private |= numargs;
6363 return too_many_arguments(o,OP_DESC(o));
6367 else if (PL_opargs[type] & OA_DEFGV) {
6369 OP *newop = newUNOP(type, 0, newDEFSVOP());
6370 op_getmad(o,newop,'O');
6373 /* Ordering of these two is important to keep f_map.t passing. */
6375 return newUNOP(type, 0, newDEFSVOP());
6380 while (oa & OA_OPTIONAL)
6382 if (oa && oa != OA_LIST)
6383 return too_few_arguments(o,OP_DESC(o));
6389 Perl_ck_glob(pTHX_ OP *o)
6395 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
6396 append_elem(OP_GLOB, o, newDEFSVOP());
6398 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
6399 && GvCVu(gv) && GvIMPORTED_CV(gv)))
6401 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6404 #if !defined(PERL_EXTERNAL_GLOB)
6405 /* XXX this can be tightened up and made more failsafe. */
6406 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
6409 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
6410 newSVpvs("File::Glob"), NULL, NULL, NULL);
6411 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6412 glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
6413 GvCV(gv) = GvCV(glob_gv);
6414 SvREFCNT_inc_void((SV*)GvCV(gv));
6415 GvIMPORTED_CV_on(gv);
6418 #endif /* PERL_EXTERNAL_GLOB */
6420 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6421 append_elem(OP_GLOB, o,
6422 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
6423 o->op_type = OP_LIST;
6424 o->op_ppaddr = PL_ppaddr[OP_LIST];
6425 cLISTOPo->op_first->op_type = OP_PUSHMARK;
6426 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
6427 cLISTOPo->op_first->op_targ = 0;
6428 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
6429 append_elem(OP_LIST, o,
6430 scalar(newUNOP(OP_RV2CV, 0,
6431 newGVOP(OP_GV, 0, gv)))));
6432 o = newUNOP(OP_NULL, 0, ck_subr(o));
6433 o->op_targ = OP_GLOB; /* hint at what it used to be */
6436 gv = newGVgen("main");
6438 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
6444 Perl_ck_grep(pTHX_ OP *o)
6449 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
6452 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
6453 /* don't allocate gwop here, as we may leak it if PL_error_count > 0 */
6455 if (o->op_flags & OPf_STACKED) {
6458 kid = cLISTOPo->op_first->op_sibling;
6459 if (!cUNOPx(kid)->op_next)
6460 Perl_croak(aTHX_ "panic: ck_grep");
6461 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
6464 NewOp(1101, gwop, 1, LOGOP);
6465 kid->op_next = (OP*)gwop;
6466 o->op_flags &= ~OPf_STACKED;
6468 kid = cLISTOPo->op_first->op_sibling;
6469 if (type == OP_MAPWHILE)
6476 kid = cLISTOPo->op_first->op_sibling;
6477 if (kid->op_type != OP_NULL)
6478 Perl_croak(aTHX_ "panic: ck_grep");
6479 kid = kUNOP->op_first;
6482 NewOp(1101, gwop, 1, LOGOP);
6483 gwop->op_type = type;
6484 gwop->op_ppaddr = PL_ppaddr[type];
6485 gwop->op_first = listkids(o);
6486 gwop->op_flags |= OPf_KIDS;
6487 gwop->op_other = LINKLIST(kid);
6488 kid->op_next = (OP*)gwop;
6489 offset = pad_findmy("$_");
6490 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
6491 o->op_private = gwop->op_private = 0;
6492 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
6495 o->op_private = gwop->op_private = OPpGREP_LEX;
6496 gwop->op_targ = o->op_targ = offset;
6499 kid = cLISTOPo->op_first->op_sibling;
6500 if (!kid || !kid->op_sibling)
6501 return too_few_arguments(o,OP_DESC(o));
6502 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
6503 mod(kid, OP_GREPSTART);
6509 Perl_ck_index(pTHX_ OP *o)
6511 if (o->op_flags & OPf_KIDS) {
6512 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6514 kid = kid->op_sibling; /* get past "big" */
6515 if (kid && kid->op_type == OP_CONST)
6516 fbm_compile(((SVOP*)kid)->op_sv, 0);
6522 Perl_ck_lengthconst(pTHX_ OP *o)
6524 /* XXX length optimization goes here */
6529 Perl_ck_lfun(pTHX_ OP *o)
6531 const OPCODE type = o->op_type;
6532 return modkids(ck_fun(o), type);
6536 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
6538 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
6539 switch (cUNOPo->op_first->op_type) {
6541 /* This is needed for
6542 if (defined %stash::)
6543 to work. Do not break Tk.
6545 break; /* Globals via GV can be undef */
6547 case OP_AASSIGN: /* Is this a good idea? */
6548 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6549 "defined(@array) is deprecated");
6550 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6551 "\t(Maybe you should just omit the defined()?)\n");
6554 /* This is needed for
6555 if (defined %stash::)
6556 to work. Do not break Tk.
6558 break; /* Globals via GV can be undef */
6560 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6561 "defined(%%hash) is deprecated");
6562 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6563 "\t(Maybe you should just omit the defined()?)\n");
6574 Perl_ck_rfun(pTHX_ OP *o)
6576 const OPCODE type = o->op_type;
6577 return refkids(ck_fun(o), type);
6581 Perl_ck_listiob(pTHX_ OP *o)
6585 kid = cLISTOPo->op_first;
6588 kid = cLISTOPo->op_first;
6590 if (kid->op_type == OP_PUSHMARK)
6591 kid = kid->op_sibling;
6592 if (kid && o->op_flags & OPf_STACKED)
6593 kid = kid->op_sibling;
6594 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6595 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6596 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6597 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6598 cLISTOPo->op_first->op_sibling = kid;
6599 cLISTOPo->op_last = kid;
6600 kid = kid->op_sibling;
6605 append_elem(o->op_type, o, newDEFSVOP());
6611 Perl_ck_say(pTHX_ OP *o)
6614 o->op_type = OP_PRINT;
6615 cLISTOPo->op_last = cLISTOPo->op_last->op_sibling
6616 = newSVOP(OP_CONST, 0, newSVpvs("\n"));
6621 Perl_ck_smartmatch(pTHX_ OP *o)
6624 if (0 == (o->op_flags & OPf_SPECIAL)) {
6625 OP *first = cBINOPo->op_first;
6626 OP *second = first->op_sibling;
6628 /* Implicitly take a reference to an array or hash */
6629 first->op_sibling = NULL;
6630 first = cBINOPo->op_first = ref_array_or_hash(first);
6631 second = first->op_sibling = ref_array_or_hash(second);
6633 /* Implicitly take a reference to a regular expression */
6634 if (first->op_type == OP_MATCH) {
6635 first->op_type = OP_QR;
6636 first->op_ppaddr = PL_ppaddr[OP_QR];
6638 if (second->op_type == OP_MATCH) {
6639 second->op_type = OP_QR;
6640 second->op_ppaddr = PL_ppaddr[OP_QR];
6649 Perl_ck_sassign(pTHX_ OP *o)
6651 OP *kid = cLISTOPo->op_first;
6652 /* has a disposable target? */
6653 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6654 && !(kid->op_flags & OPf_STACKED)
6655 /* Cannot steal the second time! */
6656 && !(kid->op_private & OPpTARGET_MY))
6658 OP * const kkid = kid->op_sibling;
6660 /* Can just relocate the target. */
6661 if (kkid && kkid->op_type == OP_PADSV
6662 && !(kkid->op_private & OPpLVAL_INTRO))
6664 kid->op_targ = kkid->op_targ;
6666 /* Now we do not need PADSV and SASSIGN. */
6667 kid->op_sibling = o->op_sibling; /* NULL */
6668 cLISTOPo->op_first = NULL;
6670 op_getmad(o,kid,'O');
6671 op_getmad(kkid,kid,'M');
6676 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6684 Perl_ck_match(pTHX_ OP *o)
6687 if (o->op_type != OP_QR && PL_compcv) {
6688 const I32 offset = pad_findmy("$_");
6689 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
6690 o->op_targ = offset;
6691 o->op_private |= OPpTARGET_MY;
6694 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
6695 o->op_private |= OPpRUNTIME;
6700 Perl_ck_method(pTHX_ OP *o)
6702 OP * const kid = cUNOPo->op_first;
6703 if (kid->op_type == OP_CONST) {
6704 SV* sv = kSVOP->op_sv;
6705 const char * const method = SvPVX_const(sv);
6706 if (!(strchr(method, ':') || strchr(method, '\''))) {
6708 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6709 sv = newSVpvn_share(method, SvCUR(sv), 0);
6712 kSVOP->op_sv = NULL;
6714 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6716 op_getmad(o,cmop,'O');
6727 Perl_ck_null(pTHX_ OP *o)
6729 PERL_UNUSED_CONTEXT;
6734 Perl_ck_open(pTHX_ OP *o)
6737 HV * const table = GvHV(PL_hintgv);
6739 SV **svp = hv_fetchs(table, "open_IN", FALSE);
6741 const I32 mode = mode_from_discipline(*svp);
6742 if (mode & O_BINARY)
6743 o->op_private |= OPpOPEN_IN_RAW;
6744 else if (mode & O_TEXT)
6745 o->op_private |= OPpOPEN_IN_CRLF;
6748 svp = hv_fetchs(table, "open_OUT", FALSE);
6750 const I32 mode = mode_from_discipline(*svp);
6751 if (mode & O_BINARY)
6752 o->op_private |= OPpOPEN_OUT_RAW;
6753 else if (mode & O_TEXT)
6754 o->op_private |= OPpOPEN_OUT_CRLF;
6757 if (o->op_type == OP_BACKTICK)
6760 /* In case of three-arg dup open remove strictness
6761 * from the last arg if it is a bareword. */
6762 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
6763 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
6767 if ((last->op_type == OP_CONST) && /* The bareword. */
6768 (last->op_private & OPpCONST_BARE) &&
6769 (last->op_private & OPpCONST_STRICT) &&
6770 (oa = first->op_sibling) && /* The fh. */
6771 (oa = oa->op_sibling) && /* The mode. */
6772 (oa->op_type == OP_CONST) &&
6773 SvPOK(((SVOP*)oa)->op_sv) &&
6774 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
6775 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
6776 (last == oa->op_sibling)) /* The bareword. */
6777 last->op_private &= ~OPpCONST_STRICT;
6783 Perl_ck_repeat(pTHX_ OP *o)
6785 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6786 o->op_private |= OPpREPEAT_DOLIST;
6787 cBINOPo->op_first = force_list(cBINOPo->op_first);
6795 Perl_ck_require(pTHX_ OP *o)
6800 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6801 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6803 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6804 SV * const sv = kid->op_sv;
6805 U32 was_readonly = SvREADONLY(sv);
6810 sv_force_normal_flags(sv, 0);
6811 assert(!SvREADONLY(sv));
6818 for (s = SvPVX(sv); *s; s++) {
6819 if (*s == ':' && s[1] == ':') {
6820 const STRLEN len = strlen(s+2)+1;
6822 Move(s+2, s+1, len, char);
6823 SvCUR_set(sv, SvCUR(sv) - 1);
6826 sv_catpvs(sv, ".pm");
6827 SvFLAGS(sv) |= was_readonly;
6831 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
6832 /* handle override, if any */
6833 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
6834 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
6835 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
6836 gv = gvp ? *gvp : NULL;
6840 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6841 OP * const kid = cUNOPo->op_first;
6844 cUNOPo->op_first = 0;
6848 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
6849 append_elem(OP_LIST, kid,
6850 scalar(newUNOP(OP_RV2CV, 0,
6853 op_getmad(o,newop,'O');
6861 Perl_ck_return(pTHX_ OP *o)
6864 if (CvLVALUE(PL_compcv)) {
6866 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6867 mod(kid, OP_LEAVESUBLV);
6873 Perl_ck_select(pTHX_ OP *o)
6877 if (o->op_flags & OPf_KIDS) {
6878 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6879 if (kid && kid->op_sibling) {
6880 o->op_type = OP_SSELECT;
6881 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6883 return fold_constants(o);
6887 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6888 if (kid && kid->op_type == OP_RV2GV)
6889 kid->op_private &= ~HINT_STRICT_REFS;
6894 Perl_ck_shift(pTHX_ OP *o)
6897 const I32 type = o->op_type;
6899 if (!(o->op_flags & OPf_KIDS)) {
6901 /* FIXME - this can be refactored to reduce code in #ifdefs */
6907 argop = newUNOP(OP_RV2AV, 0,
6908 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
6910 o = newUNOP(type, 0, scalar(argop));
6911 op_getmad(oldo,o,'O');
6914 return newUNOP(type, 0, scalar(argop));
6917 return scalar(modkids(ck_fun(o), type));
6921 Perl_ck_sort(pTHX_ OP *o)
6926 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0)
6928 HV * const hinthv = GvHV(PL_hintgv);
6930 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
6932 const I32 sorthints = (I32)SvIV(*svp);
6933 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
6934 o->op_private |= OPpSORT_QSORT;
6935 if ((sorthints & HINT_SORT_STABLE) != 0)
6936 o->op_private |= OPpSORT_STABLE;
6941 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6943 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6944 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6946 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6948 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6950 if (kid->op_type == OP_SCOPE) {
6954 else if (kid->op_type == OP_LEAVE) {
6955 if (o->op_type == OP_SORT) {
6956 op_null(kid); /* wipe out leave */
6959 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6960 if (k->op_next == kid)
6962 /* don't descend into loops */
6963 else if (k->op_type == OP_ENTERLOOP
6964 || k->op_type == OP_ENTERITER)
6966 k = cLOOPx(k)->op_lastop;
6971 kid->op_next = 0; /* just disconnect the leave */
6972 k = kLISTOP->op_first;
6977 if (o->op_type == OP_SORT) {
6978 /* provide scalar context for comparison function/block */
6984 o->op_flags |= OPf_SPECIAL;
6986 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6989 firstkid = firstkid->op_sibling;
6992 /* provide list context for arguments */
6993 if (o->op_type == OP_SORT)
7000 S_simplify_sort(pTHX_ OP *o)
7003 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7008 if (!(o->op_flags & OPf_STACKED))
7010 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7011 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
7012 kid = kUNOP->op_first; /* get past null */
7013 if (kid->op_type != OP_SCOPE)
7015 kid = kLISTOP->op_last; /* get past scope */
7016 switch(kid->op_type) {
7024 k = kid; /* remember this node*/
7025 if (kBINOP->op_first->op_type != OP_RV2SV)
7027 kid = kBINOP->op_first; /* get past cmp */
7028 if (kUNOP->op_first->op_type != OP_GV)
7030 kid = kUNOP->op_first; /* get past rv2sv */
7032 if (GvSTASH(gv) != PL_curstash)
7034 gvname = GvNAME(gv);
7035 if (*gvname == 'a' && gvname[1] == '\0')
7037 else if (*gvname == 'b' && gvname[1] == '\0')
7042 kid = k; /* back to cmp */
7043 if (kBINOP->op_last->op_type != OP_RV2SV)
7045 kid = kBINOP->op_last; /* down to 2nd arg */
7046 if (kUNOP->op_first->op_type != OP_GV)
7048 kid = kUNOP->op_first; /* get past rv2sv */
7050 if (GvSTASH(gv) != PL_curstash)
7052 gvname = GvNAME(gv);
7054 ? !(*gvname == 'a' && gvname[1] == '\0')
7055 : !(*gvname == 'b' && gvname[1] == '\0'))
7057 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
7059 o->op_private |= OPpSORT_DESCEND;
7060 if (k->op_type == OP_NCMP)
7061 o->op_private |= OPpSORT_NUMERIC;
7062 if (k->op_type == OP_I_NCMP)
7063 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
7064 kid = cLISTOPo->op_first->op_sibling;
7065 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
7067 op_getmad(kid,o,'S'); /* then delete it */
7069 op_free(kid); /* then delete it */
7074 Perl_ck_split(pTHX_ OP *o)
7079 if (o->op_flags & OPf_STACKED)
7080 return no_fh_allowed(o);
7082 kid = cLISTOPo->op_first;
7083 if (kid->op_type != OP_NULL)
7084 Perl_croak(aTHX_ "panic: ck_split");
7085 kid = kid->op_sibling;
7086 op_free(cLISTOPo->op_first);
7087 cLISTOPo->op_first = kid;
7089 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
7090 cLISTOPo->op_last = kid; /* There was only one element previously */
7093 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
7094 OP * const sibl = kid->op_sibling;
7095 kid->op_sibling = 0;
7096 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
7097 if (cLISTOPo->op_first == cLISTOPo->op_last)
7098 cLISTOPo->op_last = kid;
7099 cLISTOPo->op_first = kid;
7100 kid->op_sibling = sibl;
7103 kid->op_type = OP_PUSHRE;
7104 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
7106 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
7107 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
7108 "Use of /g modifier is meaningless in split");
7111 if (!kid->op_sibling)
7112 append_elem(OP_SPLIT, o, newDEFSVOP());
7114 kid = kid->op_sibling;
7117 if (!kid->op_sibling)
7118 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
7120 kid = kid->op_sibling;
7123 if (kid->op_sibling)
7124 return too_many_arguments(o,OP_DESC(o));
7130 Perl_ck_join(pTHX_ OP *o)
7132 const OP * const kid = cLISTOPo->op_first->op_sibling;
7133 if (kid && kid->op_type == OP_MATCH) {
7134 if (ckWARN(WARN_SYNTAX)) {
7135 const REGEXP *re = PM_GETRE(kPMOP);
7136 const char *pmstr = re ? re->precomp : "STRING";
7137 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7138 "/%s/ should probably be written as \"%s\"",
7146 Perl_ck_subr(pTHX_ OP *o)
7149 OP *prev = ((cUNOPo->op_first->op_sibling)
7150 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
7151 OP *o2 = prev->op_sibling;
7158 I32 contextclass = 0;
7162 o->op_private |= OPpENTERSUB_HASTARG;
7163 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
7164 if (cvop->op_type == OP_RV2CV) {
7166 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
7167 op_null(cvop); /* disable rv2cv */
7168 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
7169 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
7170 GV *gv = cGVOPx_gv(tmpop);
7173 tmpop->op_private |= OPpEARLY_CV;
7176 namegv = CvANON(cv) ? gv : CvGV(cv);
7177 proto = SvPV_nolen((SV*)cv);
7179 if (CvASSERTION(cv)) {
7180 if (PL_hints & HINT_ASSERTING) {
7181 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
7182 o->op_private |= OPpENTERSUB_DB;
7186 if (!(PL_hints & HINT_ASSERTIONSSEEN) && ckWARN(WARN_ASSERTIONS)) {
7187 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
7188 "Impossible to activate assertion call");
7195 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7196 if (o2->op_type == OP_CONST)
7197 o2->op_private &= ~OPpCONST_STRICT;
7198 else if (o2->op_type == OP_LIST) {
7199 OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
7200 if (sib && sib->op_type == OP_CONST)
7201 sib->op_private &= ~OPpCONST_STRICT;
7204 o->op_private |= (PL_hints & HINT_STRICT_REFS);
7205 if (PERLDB_SUB && PL_curstash != PL_debstash)
7206 o->op_private |= OPpENTERSUB_DB;
7207 while (o2 != cvop) {
7209 if (PL_madskills && o2->op_type == OP_NULL)
7210 o3 = ((UNOP*)o2)->op_first;
7216 return too_many_arguments(o, gv_ename(namegv));
7234 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
7236 arg == 1 ? "block or sub {}" : "sub {}",
7237 gv_ename(namegv), o3);
7240 /* '*' allows any scalar type, including bareword */
7243 if (o3->op_type == OP_RV2GV)
7244 goto wrapref; /* autoconvert GLOB -> GLOBref */
7245 else if (o3->op_type == OP_CONST)
7246 o3->op_private &= ~OPpCONST_STRICT;
7247 else if (o3->op_type == OP_ENTERSUB) {
7248 /* accidental subroutine, revert to bareword */
7249 OP *gvop = ((UNOP*)o3)->op_first;
7250 if (gvop && gvop->op_type == OP_NULL) {
7251 gvop = ((UNOP*)gvop)->op_first;
7253 for (; gvop->op_sibling; gvop = gvop->op_sibling)
7256 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
7257 (gvop = ((UNOP*)gvop)->op_first) &&
7258 gvop->op_type == OP_GV)
7260 GV * const gv = cGVOPx_gv(gvop);
7261 OP * const sibling = o2->op_sibling;
7262 SV * const n = newSVpvs("");
7268 gv_fullname4(n, gv, "", FALSE);
7269 o2 = newSVOP(OP_CONST, 0, n);
7270 op_getmad(oldo2,o2,'O');
7271 prev->op_sibling = o2;
7272 o2->op_sibling = sibling;
7288 if (contextclass++ == 0) {
7289 e = strchr(proto, ']');
7290 if (!e || e == proto)
7299 /* XXX We shouldn't be modifying proto, so we can const proto */
7304 while (*--p != '[');
7305 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
7306 gv_ename(namegv), o3);
7312 if (o3->op_type == OP_RV2GV)
7315 bad_type(arg, "symbol", gv_ename(namegv), o3);
7318 if (o3->op_type == OP_ENTERSUB)
7321 bad_type(arg, "subroutine entry", gv_ename(namegv),
7325 if (o3->op_type == OP_RV2SV ||
7326 o3->op_type == OP_PADSV ||
7327 o3->op_type == OP_HELEM ||
7328 o3->op_type == OP_AELEM ||
7329 o3->op_type == OP_THREADSV)
7332 bad_type(arg, "scalar", gv_ename(namegv), o3);
7335 if (o3->op_type == OP_RV2AV ||
7336 o3->op_type == OP_PADAV)
7339 bad_type(arg, "array", gv_ename(namegv), o3);
7342 if (o3->op_type == OP_RV2HV ||
7343 o3->op_type == OP_PADHV)
7346 bad_type(arg, "hash", gv_ename(namegv), o3);
7351 OP* const sib = kid->op_sibling;
7352 kid->op_sibling = 0;
7353 o2 = newUNOP(OP_REFGEN, 0, kid);
7354 o2->op_sibling = sib;
7355 prev->op_sibling = o2;
7357 if (contextclass && e) {
7372 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
7373 gv_ename(namegv), cv);
7378 mod(o2, OP_ENTERSUB);
7380 o2 = o2->op_sibling;
7382 if (proto && !optional &&
7383 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
7384 return too_few_arguments(o, gv_ename(namegv));
7391 o=newSVOP(OP_CONST, 0, newSViv(0));
7392 op_getmad(oldo,o,'O');
7398 Perl_ck_svconst(pTHX_ OP *o)
7400 PERL_UNUSED_CONTEXT;
7401 SvREADONLY_on(cSVOPo->op_sv);
7406 Perl_ck_chdir(pTHX_ OP *o)
7408 if (o->op_flags & OPf_KIDS) {
7409 SVOP *kid = (SVOP*)cUNOPo->op_first;
7411 if (kid && kid->op_type == OP_CONST &&
7412 (kid->op_private & OPpCONST_BARE))
7414 o->op_flags |= OPf_SPECIAL;
7415 kid->op_private &= ~OPpCONST_STRICT;
7422 Perl_ck_trunc(pTHX_ OP *o)
7424 if (o->op_flags & OPf_KIDS) {
7425 SVOP *kid = (SVOP*)cUNOPo->op_first;
7427 if (kid->op_type == OP_NULL)
7428 kid = (SVOP*)kid->op_sibling;
7429 if (kid && kid->op_type == OP_CONST &&
7430 (kid->op_private & OPpCONST_BARE))
7432 o->op_flags |= OPf_SPECIAL;
7433 kid->op_private &= ~OPpCONST_STRICT;
7440 Perl_ck_unpack(pTHX_ OP *o)
7442 OP *kid = cLISTOPo->op_first;
7443 if (kid->op_sibling) {
7444 kid = kid->op_sibling;
7445 if (!kid->op_sibling)
7446 kid->op_sibling = newDEFSVOP();
7452 Perl_ck_substr(pTHX_ OP *o)
7455 if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
7456 OP *kid = cLISTOPo->op_first;
7458 if (kid->op_type == OP_NULL)
7459 kid = kid->op_sibling;
7461 kid->op_flags |= OPf_MOD;
7467 /* A peephole optimizer. We visit the ops in the order they're to execute.
7468 * See the comments at the top of this file for more details about when
7469 * peep() is called */
7472 Perl_peep(pTHX_ register OP *o)
7475 register OP* oldop = NULL;
7477 if (!o || o->op_opt)
7481 SAVEVPTR(PL_curcop);
7482 for (; o; o = o->op_next) {
7486 switch (o->op_type) {
7490 PL_curcop = ((COP*)o); /* for warnings */
7495 if (cSVOPo->op_private & OPpCONST_STRICT)
7496 no_bareword_allowed(o);
7498 case OP_METHOD_NAMED:
7499 /* Relocate sv to the pad for thread safety.
7500 * Despite being a "constant", the SV is written to,
7501 * for reference counts, sv_upgrade() etc. */
7503 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
7504 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
7505 /* If op_sv is already a PADTMP then it is being used by
7506 * some pad, so make a copy. */
7507 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
7508 SvREADONLY_on(PAD_SVl(ix));
7509 SvREFCNT_dec(cSVOPo->op_sv);
7511 else if (o->op_type == OP_CONST
7512 && cSVOPo->op_sv == &PL_sv_undef) {
7513 /* PL_sv_undef is hack - it's unsafe to store it in the
7514 AV that is the pad, because av_fetch treats values of
7515 PL_sv_undef as a "free" AV entry and will merrily
7516 replace them with a new SV, causing pad_alloc to think
7517 that this pad slot is free. (When, clearly, it is not)
7519 SvOK_off(PAD_SVl(ix));
7520 SvPADTMP_on(PAD_SVl(ix));
7521 SvREADONLY_on(PAD_SVl(ix));
7524 SvREFCNT_dec(PAD_SVl(ix));
7525 SvPADTMP_on(cSVOPo->op_sv);
7526 PAD_SETSV(ix, cSVOPo->op_sv);
7527 /* XXX I don't know how this isn't readonly already. */
7528 SvREADONLY_on(PAD_SVl(ix));
7530 cSVOPo->op_sv = NULL;
7538 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
7539 if (o->op_next->op_private & OPpTARGET_MY) {
7540 if (o->op_flags & OPf_STACKED) /* chained concats */
7541 goto ignore_optimization;
7543 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
7544 o->op_targ = o->op_next->op_targ;
7545 o->op_next->op_targ = 0;
7546 o->op_private |= OPpTARGET_MY;
7549 op_null(o->op_next);
7551 ignore_optimization:
7555 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
7557 break; /* Scalar stub must produce undef. List stub is noop */
7561 if (o->op_targ == OP_NEXTSTATE
7562 || o->op_targ == OP_DBSTATE
7563 || o->op_targ == OP_SETSTATE)
7565 PL_curcop = ((COP*)o);
7567 /* XXX: We avoid setting op_seq here to prevent later calls
7568 to peep() from mistakenly concluding that optimisation
7569 has already occurred. This doesn't fix the real problem,
7570 though (See 20010220.007). AMS 20010719 */
7571 /* op_seq functionality is now replaced by op_opt */
7572 if (oldop && o->op_next) {
7573 oldop->op_next = o->op_next;
7581 if (oldop && o->op_next) {
7582 oldop->op_next = o->op_next;
7590 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
7591 OP* const pop = (o->op_type == OP_PADAV) ?
7592 o->op_next : o->op_next->op_next;
7594 if (pop && pop->op_type == OP_CONST &&
7595 ((PL_op = pop->op_next)) &&
7596 pop->op_next->op_type == OP_AELEM &&
7597 !(pop->op_next->op_private &
7598 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
7599 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
7604 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
7605 no_bareword_allowed(pop);
7606 if (o->op_type == OP_GV)
7607 op_null(o->op_next);
7608 op_null(pop->op_next);
7610 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
7611 o->op_next = pop->op_next->op_next;
7612 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
7613 o->op_private = (U8)i;
7614 if (o->op_type == OP_GV) {
7619 o->op_flags |= OPf_SPECIAL;
7620 o->op_type = OP_AELEMFAST;
7626 if (o->op_next->op_type == OP_RV2SV) {
7627 if (!(o->op_next->op_private & OPpDEREF)) {
7628 op_null(o->op_next);
7629 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
7631 o->op_next = o->op_next->op_next;
7632 o->op_type = OP_GVSV;
7633 o->op_ppaddr = PL_ppaddr[OP_GVSV];
7636 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
7637 GV * const gv = cGVOPo_gv;
7638 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
7639 /* XXX could check prototype here instead of just carping */
7640 SV * const sv = sv_newmortal();
7641 gv_efullname3(sv, gv, NULL);
7642 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
7643 "%"SVf"() called too early to check prototype",
7647 else if (o->op_next->op_type == OP_READLINE
7648 && o->op_next->op_next->op_type == OP_CONCAT
7649 && (o->op_next->op_next->op_flags & OPf_STACKED))
7651 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
7652 o->op_type = OP_RCATLINE;
7653 o->op_flags |= OPf_STACKED;
7654 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
7655 op_null(o->op_next->op_next);
7656 op_null(o->op_next);
7673 while (cLOGOP->op_other->op_type == OP_NULL)
7674 cLOGOP->op_other = cLOGOP->op_other->op_next;
7675 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
7681 while (cLOOP->op_redoop->op_type == OP_NULL)
7682 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
7683 peep(cLOOP->op_redoop);
7684 while (cLOOP->op_nextop->op_type == OP_NULL)
7685 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
7686 peep(cLOOP->op_nextop);
7687 while (cLOOP->op_lastop->op_type == OP_NULL)
7688 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
7689 peep(cLOOP->op_lastop);
7696 while (cPMOP->op_pmreplstart &&
7697 cPMOP->op_pmreplstart->op_type == OP_NULL)
7698 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
7699 peep(cPMOP->op_pmreplstart);
7704 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
7705 && ckWARN(WARN_SYNTAX))
7707 if (o->op_next->op_sibling &&
7708 o->op_next->op_sibling->op_type != OP_EXIT &&
7709 o->op_next->op_sibling->op_type != OP_WARN &&
7710 o->op_next->op_sibling->op_type != OP_DIE) {
7711 const line_t oldline = CopLINE(PL_curcop);
7713 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
7714 Perl_warner(aTHX_ packWARN(WARN_EXEC),
7715 "Statement unlikely to be reached");
7716 Perl_warner(aTHX_ packWARN(WARN_EXEC),
7717 "\t(Maybe you meant system() when you said exec()?)\n");
7718 CopLINE_set(PL_curcop, oldline);
7728 const char *key = NULL;
7733 if (((BINOP*)o)->op_last->op_type != OP_CONST)
7736 /* Make the CONST have a shared SV */
7737 svp = cSVOPx_svp(((BINOP*)o)->op_last);
7738 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
7739 key = SvPV_const(sv, keylen);
7740 lexname = newSVpvn_share(key,
7741 SvUTF8(sv) ? -(I32)keylen : keylen,
7747 if ((o->op_private & (OPpLVAL_INTRO)))
7750 rop = (UNOP*)((BINOP*)o)->op_first;
7751 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7753 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7754 if (!SvPAD_TYPED(lexname))
7756 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
7757 if (!fields || !GvHV(*fields))
7759 key = SvPV_const(*svp, keylen);
7760 if (!hv_fetch(GvHV(*fields), key,
7761 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
7763 Perl_croak(aTHX_ "No such class field \"%s\" "
7764 "in variable %s of type %s",
7765 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
7778 SVOP *first_key_op, *key_op;
7780 if ((o->op_private & (OPpLVAL_INTRO))
7781 /* I bet there's always a pushmark... */
7782 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
7783 /* hmmm, no optimization if list contains only one key. */
7785 rop = (UNOP*)((LISTOP*)o)->op_last;
7786 if (rop->op_type != OP_RV2HV)
7788 if (rop->op_first->op_type == OP_PADSV)
7789 /* @$hash{qw(keys here)} */
7790 rop = (UNOP*)rop->op_first;
7792 /* @{$hash}{qw(keys here)} */
7793 if (rop->op_first->op_type == OP_SCOPE
7794 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
7796 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
7802 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
7803 if (!SvPAD_TYPED(lexname))
7805 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
7806 if (!fields || !GvHV(*fields))
7808 /* Again guessing that the pushmark can be jumped over.... */
7809 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
7810 ->op_first->op_sibling;
7811 for (key_op = first_key_op; key_op;
7812 key_op = (SVOP*)key_op->op_sibling) {
7813 if (key_op->op_type != OP_CONST)
7815 svp = cSVOPx_svp(key_op);
7816 key = SvPV_const(*svp, keylen);
7817 if (!hv_fetch(GvHV(*fields), key,
7818 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
7820 Perl_croak(aTHX_ "No such class field \"%s\" "
7821 "in variable %s of type %s",
7822 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
7829 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
7833 /* check that RHS of sort is a single plain array */
7834 OP *oright = cUNOPo->op_first;
7835 if (!oright || oright->op_type != OP_PUSHMARK)
7838 /* reverse sort ... can be optimised. */
7839 if (!cUNOPo->op_sibling) {
7840 /* Nothing follows us on the list. */
7841 OP * const reverse = o->op_next;
7843 if (reverse->op_type == OP_REVERSE &&
7844 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
7845 OP * const pushmark = cUNOPx(reverse)->op_first;
7846 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
7847 && (cUNOPx(pushmark)->op_sibling == o)) {
7848 /* reverse -> pushmark -> sort */
7849 o->op_private |= OPpSORT_REVERSE;
7851 pushmark->op_next = oright->op_next;
7857 /* make @a = sort @a act in-place */
7861 oright = cUNOPx(oright)->op_sibling;
7864 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
7865 oright = cUNOPx(oright)->op_sibling;
7869 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
7870 || oright->op_next != o
7871 || (oright->op_private & OPpLVAL_INTRO)
7875 /* o2 follows the chain of op_nexts through the LHS of the
7876 * assign (if any) to the aassign op itself */
7878 if (!o2 || o2->op_type != OP_NULL)
7881 if (!o2 || o2->op_type != OP_PUSHMARK)
7884 if (o2 && o2->op_type == OP_GV)
7887 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
7888 || (o2->op_private & OPpLVAL_INTRO)
7893 if (!o2 || o2->op_type != OP_NULL)
7896 if (!o2 || o2->op_type != OP_AASSIGN
7897 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
7900 /* check that the sort is the first arg on RHS of assign */
7902 o2 = cUNOPx(o2)->op_first;
7903 if (!o2 || o2->op_type != OP_NULL)
7905 o2 = cUNOPx(o2)->op_first;
7906 if (!o2 || o2->op_type != OP_PUSHMARK)
7908 if (o2->op_sibling != o)
7911 /* check the array is the same on both sides */
7912 if (oleft->op_type == OP_RV2AV) {
7913 if (oright->op_type != OP_RV2AV
7914 || !cUNOPx(oright)->op_first
7915 || cUNOPx(oright)->op_first->op_type != OP_GV
7916 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
7917 cGVOPx_gv(cUNOPx(oright)->op_first)
7921 else if (oright->op_type != OP_PADAV
7922 || oright->op_targ != oleft->op_targ
7926 /* transfer MODishness etc from LHS arg to RHS arg */
7927 oright->op_flags = oleft->op_flags;
7928 o->op_private |= OPpSORT_INPLACE;
7930 /* excise push->gv->rv2av->null->aassign */
7931 o2 = o->op_next->op_next;
7932 op_null(o2); /* PUSHMARK */
7934 if (o2->op_type == OP_GV) {
7935 op_null(o2); /* GV */
7938 op_null(o2); /* RV2AV or PADAV */
7939 o2 = o2->op_next->op_next;
7940 op_null(o2); /* AASSIGN */
7942 o->op_next = o2->op_next;
7948 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
7950 LISTOP *enter, *exlist;
7953 enter = (LISTOP *) o->op_next;
7956 if (enter->op_type == OP_NULL) {
7957 enter = (LISTOP *) enter->op_next;
7961 /* for $a (...) will have OP_GV then OP_RV2GV here.
7962 for (...) just has an OP_GV. */
7963 if (enter->op_type == OP_GV) {
7964 gvop = (OP *) enter;
7965 enter = (LISTOP *) enter->op_next;
7968 if (enter->op_type == OP_RV2GV) {
7969 enter = (LISTOP *) enter->op_next;
7975 if (enter->op_type != OP_ENTERITER)
7978 iter = enter->op_next;
7979 if (!iter || iter->op_type != OP_ITER)
7982 expushmark = enter->op_first;
7983 if (!expushmark || expushmark->op_type != OP_NULL
7984 || expushmark->op_targ != OP_PUSHMARK)
7987 exlist = (LISTOP *) expushmark->op_sibling;
7988 if (!exlist || exlist->op_type != OP_NULL
7989 || exlist->op_targ != OP_LIST)
7992 if (exlist->op_last != o) {
7993 /* Mmm. Was expecting to point back to this op. */
7996 theirmark = exlist->op_first;
7997 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
8000 if (theirmark->op_sibling != o) {
8001 /* There's something between the mark and the reverse, eg
8002 for (1, reverse (...))
8007 ourmark = ((LISTOP *)o)->op_first;
8008 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
8011 ourlast = ((LISTOP *)o)->op_last;
8012 if (!ourlast || ourlast->op_next != o)
8015 rv2av = ourmark->op_sibling;
8016 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
8017 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
8018 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
8019 /* We're just reversing a single array. */
8020 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
8021 enter->op_flags |= OPf_STACKED;
8024 /* We don't have control over who points to theirmark, so sacrifice
8026 theirmark->op_next = ourmark->op_next;
8027 theirmark->op_flags = ourmark->op_flags;
8028 ourlast->op_next = gvop ? gvop : (OP *) enter;
8031 enter->op_private |= OPpITER_REVERSED;
8032 iter->op_private |= OPpITER_REVERSED;
8039 UNOP *refgen, *rv2cv;
8042 /* I do not understand this, but if o->op_opt isn't set to 1,
8043 various tests in ext/B/t/bytecode.t fail with no readily
8049 if ((o->op_flags && OPf_WANT) != OPf_WANT_VOID)
8052 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
8055 rv2gv = ((BINOP *)o)->op_last;
8056 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
8059 refgen = (UNOP *)((BINOP *)o)->op_first;
8061 if (!refgen || refgen->op_type != OP_REFGEN)
8064 exlist = (LISTOP *)refgen->op_first;
8065 if (!exlist || exlist->op_type != OP_NULL
8066 || exlist->op_targ != OP_LIST)
8069 if (exlist->op_first->op_type != OP_PUSHMARK)
8072 rv2cv = (UNOP*)exlist->op_last;
8074 if (rv2cv->op_type != OP_RV2CV)
8077 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
8078 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
8079 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
8081 o->op_private |= OPpASSIGN_CV_TO_GV;
8082 rv2gv->op_private |= OPpDONT_INIT_GV;
8083 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
8099 Perl_custom_op_name(pTHX_ const OP* o)
8102 const IV index = PTR2IV(o->op_ppaddr);
8106 if (!PL_custom_op_names) /* This probably shouldn't happen */
8107 return (char *)PL_op_name[OP_CUSTOM];
8109 keysv = sv_2mortal(newSViv(index));
8111 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
8113 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
8115 return SvPV_nolen(HeVAL(he));
8119 Perl_custom_op_desc(pTHX_ const OP* o)
8122 const IV index = PTR2IV(o->op_ppaddr);
8126 if (!PL_custom_op_descs)
8127 return (char *)PL_op_desc[OP_CUSTOM];
8129 keysv = sv_2mortal(newSViv(index));
8131 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
8133 return (char *)PL_op_desc[OP_CUSTOM];
8135 return SvPV_nolen(HeVAL(he));
8140 /* Efficient sub that returns a constant scalar value. */
8142 const_sv_xsub(pTHX_ CV* cv)
8149 Perl_croak(aTHX_ "usage: %s::%s()",
8150 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
8154 ST(0) = (SV*)XSANY.any_ptr;
8160 * c-indentation-style: bsd
8162 * indent-tabs-mode: t
8165 * ex: set ts=8 sts=4 sw=4 noet: