3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * "You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
13 * our Mr. Bilbo's first cousin on the mother's side (her mother being the
14 * youngest of the Old Took's daughters); and Mr. Drogo was his second
15 * cousin. So Mr. Frodo is his first *and* second cousin, once removed
16 * either way, as the saying is, if you follow me." --the Gaffer
19 /* This file contains the functions that create, manipulate and optimize
20 * the OP structures that hold a compiled perl program.
22 * A Perl program is compiled into a tree of OPs. Each op contains
23 * structural pointers (eg to its siblings and the next op in the
24 * execution sequence), a pointer to the function that would execute the
25 * op, plus any data specific to that op. For example, an OP_CONST op
26 * points to the pp_const() function and to an SV containing the constant
27 * value. When pp_const() is executed, its job is to push that SV onto the
30 * OPs are mainly created by the newFOO() functions, which are mainly
31 * called from the parser (in perly.y) as the code is parsed. For example
32 * the Perl code $a + $b * $c would cause the equivalent of the following
33 * to be called (oversimplifying a bit):
35 * newBINOP(OP_ADD, flags,
37 * newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
40 * Note that during the build of miniperl, a temporary copy of this file
41 * is made, called opmini.c.
45 Perl's compiler is essentially a 3-pass compiler with interleaved phases:
49 An execution-order pass
51 The bottom-up pass is represented by all the "newOP" routines and
52 the ck_ routines. The bottom-upness is actually driven by yacc.
53 So at the point that a ck_ routine fires, we have no idea what the
54 context is, either upward in the syntax tree, or either forward or
55 backward in the execution order. (The bottom-up parser builds that
56 part of the execution order it knows about, but if you follow the "next"
57 links around, you'll find it's actually a closed loop through the
60 Whenever the bottom-up parser gets to a node that supplies context to
61 its components, it invokes that portion of the top-down pass that applies
62 to that part of the subtree (and marks the top node as processed, so
63 if a node further up supplies context, it doesn't have to take the
64 plunge again). As a particular subcase of this, as the new node is
65 built, it takes all the closed execution loops of its subcomponents
66 and links them into a new closed loop for the higher level node. But
67 it's still not the real execution order.
69 The actual execution order is not known till we get a grammar reduction
70 to a top-level unit like a subroutine or file that will be called by
71 "name" rather than via a "next" pointer. At that point, we can call
72 into peep() to do that code's portion of the 3rd pass. It has to be
73 recursive, but it's recursive on basic blocks, not on tree nodes.
81 #define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
83 #if defined(PL_OP_SLAB_ALLOC)
85 #ifndef PERL_SLAB_SIZE
86 #define PERL_SLAB_SIZE 2048
90 Perl_Slab_Alloc(pTHX_ int m, size_t sz)
93 * To make incrementing use count easy PL_OpSlab is an I32 *
94 * To make inserting the link to slab PL_OpPtr is I32 **
95 * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
96 * Add an overhead for pointer to slab and round up as a number of pointers
98 sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
99 if ((PL_OpSpace -= sz) < 0) {
100 PL_OpPtr = (I32 **) PerlMemShared_malloc(PERL_SLAB_SIZE*sizeof(I32*));
104 Zero(PL_OpPtr,PERL_SLAB_SIZE,I32 **);
105 /* We reserve the 0'th I32 sized chunk as a use count */
106 PL_OpSlab = (I32 *) PL_OpPtr;
107 /* Reduce size by the use count word, and by the size we need.
108 * Latter is to mimic the '-=' in the if() above
110 PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
111 /* Allocation pointer starts at the top.
112 Theory: because we build leaves before trunk allocating at end
113 means that at run time access is cache friendly upward
115 PL_OpPtr += PERL_SLAB_SIZE;
117 assert( PL_OpSpace >= 0 );
118 /* Move the allocation pointer down */
120 assert( PL_OpPtr > (I32 **) PL_OpSlab );
121 *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */
122 (*PL_OpSlab)++; /* Increment use count of slab */
123 assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
124 assert( *PL_OpSlab > 0 );
125 return (void *)(PL_OpPtr + 1);
129 Perl_Slab_Free(pTHX_ void *op)
131 I32 * const * const ptr = (I32 **) op;
132 I32 * const slab = ptr[-1];
133 assert( ptr-1 > (I32 **) slab );
134 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
136 if (--(*slab) == 0) {
138 # define PerlMemShared PerlMem
141 PerlMemShared_free(slab);
142 if (slab == PL_OpSlab) {
149 * In the following definition, the ", (OP*)0" is just to make the compiler
150 * think the expression is of the right type: croak actually does a Siglongjmp.
152 #define CHECKOP(type,o) \
153 ((PL_op_mask && PL_op_mask[type]) \
154 ? ( op_free((OP*)o), \
155 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
157 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
159 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
162 S_gv_ename(pTHX_ GV *gv)
164 SV* const tmpsv = sv_newmortal();
165 gv_efullname3(tmpsv, gv, NULL);
166 return SvPV_nolen_const(tmpsv);
170 S_no_fh_allowed(pTHX_ OP *o)
172 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
178 S_too_few_arguments(pTHX_ OP *o, const char *name)
180 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
185 S_too_many_arguments(pTHX_ OP *o, const char *name)
187 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
192 S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid)
194 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
195 (int)n, name, t, OP_DESC(kid)));
199 S_no_bareword_allowed(pTHX_ const OP *o)
202 return; /* various ok barewords are hidden in extra OP_NULL */
203 qerror(Perl_mess(aTHX_
204 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
208 /* "register" allocation */
211 Perl_allocmy(pTHX_ char *name)
215 const bool is_our = (PL_in_my == KEY_our);
217 /* complain about "my $<special_var>" etc etc */
221 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
222 (name[1] == '_' && (*name == '$' || name[2]))))
224 /* name[2] is true if strlen(name) > 2 */
225 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
226 /* 1999-02-27 mjd@plover.com */
228 p = strchr(name, '\0');
229 /* The next block assumes the buffer is at least 205 chars
230 long. At present, it's always at least 256 chars. */
232 strcpy(name+200, "...");
238 /* Move everything else down one character */
239 for (; p-name > 2; p--)
241 name[2] = toCTRL(name[1]);
244 yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
247 /* check for duplicate declaration */
248 pad_check_dup(name, is_our, (PL_curstash ? PL_curstash : PL_defstash));
250 if (PL_in_my_stash && *name != '$') {
251 yyerror(Perl_form(aTHX_
252 "Can't declare class for non-scalar %s in \"%s\"",
253 name, is_our ? "our" : "my"));
256 /* allocate a spare slot and store the name in that slot */
258 off = pad_add_name(name,
261 /* $_ is always in main::, even with our */
262 ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
273 Perl_op_free(pTHX_ OP *o)
278 if (!o || o->op_static)
282 if (o->op_private & OPpREFCOUNTED) {
293 refcnt = OpREFCNT_dec(o);
304 if (o->op_flags & OPf_KIDS) {
305 register OP *kid, *nextkid;
306 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
307 nextkid = kid->op_sibling; /* Get before next freeing kid */
312 type = (OPCODE)o->op_targ;
314 /* COP* is not cleared by op_clear() so that we may track line
315 * numbers etc even after null() */
316 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
321 #ifdef DEBUG_LEAKING_SCALARS
328 Perl_op_clear(pTHX_ OP *o)
333 /* if (o->op_madprop && o->op_madprop->mad_next)
335 /* FIXME for MAD - if I uncomment these two lines t/op/pack.t fails with
336 "modification of a read only value" for a reason I can't fathom why.
337 It's the "" stringification of $_, where $_ was set to '' in a foreach
338 loop, but it defies simplification into a small test case.
339 However, commenting them out has caused ext/List/Util/t/weak.t to fail
342 mad_free(o->op_madprop);
348 switch (o->op_type) {
349 case OP_NULL: /* Was holding old type, if any. */
350 if (PL_madskills && o->op_targ != OP_NULL) {
351 o->op_type = o->op_targ;
355 case OP_ENTEREVAL: /* Was holding hints. */
359 if (!(o->op_flags & OPf_REF)
360 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
366 if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
367 /* not an OP_PADAV replacement */
369 if (cPADOPo->op_padix > 0) {
370 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
371 * may still exist on the pad */
372 pad_swipe(cPADOPo->op_padix, TRUE);
373 cPADOPo->op_padix = 0;
376 SvREFCNT_dec(cSVOPo->op_sv);
377 cSVOPo->op_sv = NULL;
381 case OP_METHOD_NAMED:
383 SvREFCNT_dec(cSVOPo->op_sv);
384 cSVOPo->op_sv = NULL;
387 Even if op_clear does a pad_free for the target of the op,
388 pad_free doesn't actually remove the sv that exists in the pad;
389 instead it lives on. This results in that it could be reused as
390 a target later on when the pad was reallocated.
393 pad_swipe(o->op_targ,1);
402 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
406 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
407 SvREFCNT_dec(cSVOPo->op_sv);
408 cSVOPo->op_sv = NULL;
411 Safefree(cPVOPo->op_pv);
412 cPVOPo->op_pv = NULL;
416 op_free(cPMOPo->op_pmreplroot);
420 if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) {
421 /* No GvIN_PAD_off here, because other references may still
422 * exist on the pad */
423 pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot), TRUE);
426 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
433 HV * const pmstash = PmopSTASH(cPMOPo);
434 if (pmstash && !SvIS_FREED(pmstash)) {
435 MAGIC * const mg = mg_find((SV*)pmstash, PERL_MAGIC_symtab);
437 PMOP *pmop = (PMOP*) mg->mg_obj;
438 PMOP *lastpmop = NULL;
440 if (cPMOPo == pmop) {
442 lastpmop->op_pmnext = pmop->op_pmnext;
444 mg->mg_obj = (SV*) pmop->op_pmnext;
448 pmop = pmop->op_pmnext;
452 PmopSTASH_free(cPMOPo);
454 cPMOPo->op_pmreplroot = NULL;
455 /* we use the "SAFE" version of the PM_ macros here
456 * since sv_clean_all might release some PMOPs
457 * after PL_regex_padav has been cleared
458 * and the clearing of PL_regex_padav needs to
459 * happen before sv_clean_all
461 ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
462 PM_SETRE_SAFE(cPMOPo, NULL);
464 if(PL_regex_pad) { /* We could be in destruction */
465 av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
466 SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
467 PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
474 if (o->op_targ > 0) {
475 pad_free(o->op_targ);
481 S_cop_free(pTHX_ COP* cop)
483 Safefree(cop->cop_label); /* FIXME: treaddead ??? */
486 if (! specialWARN(cop->cop_warnings))
487 SvREFCNT_dec(cop->cop_warnings);
488 if (! specialCopIO(cop->cop_io)) {
492 SvREFCNT_dec(cop->cop_io);
498 Perl_op_null(pTHX_ OP *o)
501 if (o->op_type == OP_NULL)
505 o->op_targ = o->op_type;
506 o->op_type = OP_NULL;
507 o->op_ppaddr = PL_ppaddr[OP_NULL];
511 Perl_op_refcnt_lock(pTHX)
519 Perl_op_refcnt_unlock(pTHX)
526 /* Contextualizers */
528 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
531 Perl_linklist(pTHX_ OP *o)
538 /* establish postfix order */
539 first = cUNOPo->op_first;
542 o->op_next = LINKLIST(first);
545 if (kid->op_sibling) {
546 kid->op_next = LINKLIST(kid->op_sibling);
547 kid = kid->op_sibling;
561 Perl_scalarkids(pTHX_ OP *o)
563 if (o && o->op_flags & OPf_KIDS) {
565 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
572 S_scalarboolean(pTHX_ OP *o)
575 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
576 if (ckWARN(WARN_SYNTAX)) {
577 const line_t oldline = CopLINE(PL_curcop);
579 if (PL_copline != NOLINE)
580 CopLINE_set(PL_curcop, PL_copline);
581 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
582 CopLINE_set(PL_curcop, oldline);
589 Perl_scalar(pTHX_ OP *o)
594 /* assumes no premature commitment */
595 if (!o || PL_error_count || (o->op_flags & OPf_WANT)
596 || o->op_type == OP_RETURN)
601 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
603 switch (o->op_type) {
605 scalar(cBINOPo->op_first);
610 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
614 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
615 if (!kPMOP->op_pmreplroot)
616 deprecate_old("implicit split to @_");
624 if (o->op_flags & OPf_KIDS) {
625 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
631 kid = cLISTOPo->op_first;
633 while ((kid = kid->op_sibling)) {
639 WITH_THR(PL_curcop = &PL_compiling);
644 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
650 WITH_THR(PL_curcop = &PL_compiling);
653 if (ckWARN(WARN_VOID))
654 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
660 Perl_scalarvoid(pTHX_ OP *o)
664 const char* useless = NULL;
668 /* trailing mad null ops don't count as "there" for void processing */
670 o->op_type != OP_NULL &&
672 o->op_sibling->op_type == OP_NULL)
675 for (sib = o->op_sibling;
676 sib && sib->op_type == OP_NULL;
677 sib = sib->op_sibling) ;
683 if (o->op_type == OP_NEXTSTATE
684 || o->op_type == OP_SETSTATE
685 || o->op_type == OP_DBSTATE
686 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
687 || o->op_targ == OP_SETSTATE
688 || o->op_targ == OP_DBSTATE)))
689 PL_curcop = (COP*)o; /* for warning below */
691 /* assumes no premature commitment */
692 want = o->op_flags & OPf_WANT;
693 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
694 || o->op_type == OP_RETURN)
699 if ((o->op_private & OPpTARGET_MY)
700 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
702 return scalar(o); /* As if inside SASSIGN */
705 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
707 switch (o->op_type) {
709 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
713 if (o->op_flags & OPf_STACKED)
717 if (o->op_private == 4)
789 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
790 useless = OP_DESC(o);
794 kid = cUNOPo->op_first;
795 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
796 kid->op_type != OP_TRANS) {
799 useless = "negative pattern binding (!~)";
806 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
807 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
808 useless = "a variable";
813 if (cSVOPo->op_private & OPpCONST_STRICT)
814 no_bareword_allowed(o);
816 if (ckWARN(WARN_VOID)) {
817 useless = "a constant";
818 if (o->op_private & OPpCONST_ARYBASE)
820 /* don't warn on optimised away booleans, eg
821 * use constant Foo, 5; Foo || print; */
822 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
824 /* the constants 0 and 1 are permitted as they are
825 conventionally used as dummies in constructs like
826 1 while some_condition_with_side_effects; */
827 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
829 else if (SvPOK(sv)) {
830 /* perl4's way of mixing documentation and code
831 (before the invention of POD) was based on a
832 trick to mix nroff and perl code. The trick was
833 built upon these three nroff macros being used in
834 void context. The pink camel has the details in
835 the script wrapman near page 319. */
836 const char * const maybe_macro = SvPVX_const(sv);
837 if (strnEQ(maybe_macro, "di", 2) ||
838 strnEQ(maybe_macro, "ds", 2) ||
839 strnEQ(maybe_macro, "ig", 2))
844 op_null(o); /* don't execute or even remember it */
848 o->op_type = OP_PREINC; /* pre-increment is faster */
849 o->op_ppaddr = PL_ppaddr[OP_PREINC];
853 o->op_type = OP_PREDEC; /* pre-decrement is faster */
854 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
858 o->op_type = OP_I_PREINC; /* pre-increment is faster */
859 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
863 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
864 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
873 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
878 if (o->op_flags & OPf_STACKED)
885 if (!(o->op_flags & OPf_KIDS))
896 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
903 /* all requires must return a boolean value */
904 o->op_flags &= ~OPf_WANT;
909 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
910 if (!kPMOP->op_pmreplroot)
911 deprecate_old("implicit split to @_");
915 if (useless && ckWARN(WARN_VOID))
916 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
921 Perl_listkids(pTHX_ OP *o)
923 if (o && o->op_flags & OPf_KIDS) {
925 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
932 Perl_list(pTHX_ OP *o)
937 /* assumes no premature commitment */
938 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
939 || o->op_type == OP_RETURN)
944 if ((o->op_private & OPpTARGET_MY)
945 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
947 return o; /* As if inside SASSIGN */
950 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
952 switch (o->op_type) {
955 list(cBINOPo->op_first);
960 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
968 if (!(o->op_flags & OPf_KIDS))
970 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
971 list(cBINOPo->op_first);
972 return gen_constant_list(o);
979 kid = cLISTOPo->op_first;
981 while ((kid = kid->op_sibling)) {
987 WITH_THR(PL_curcop = &PL_compiling);
991 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
997 WITH_THR(PL_curcop = &PL_compiling);
1000 /* all requires must return a boolean value */
1001 o->op_flags &= ~OPf_WANT;
1008 Perl_scalarseq(pTHX_ OP *o)
1012 if (o->op_type == OP_LINESEQ ||
1013 o->op_type == OP_SCOPE ||
1014 o->op_type == OP_LEAVE ||
1015 o->op_type == OP_LEAVETRY)
1018 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1019 if (kid->op_sibling) {
1023 PL_curcop = &PL_compiling;
1025 o->op_flags &= ~OPf_PARENS;
1026 if (PL_hints & HINT_BLOCK_SCOPE)
1027 o->op_flags |= OPf_PARENS;
1030 o = newOP(OP_STUB, 0);
1035 S_modkids(pTHX_ OP *o, I32 type)
1037 if (o && o->op_flags & OPf_KIDS) {
1039 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1045 /* Propagate lvalue ("modifiable") context to an op and its children.
1046 * 'type' represents the context type, roughly based on the type of op that
1047 * would do the modifying, although local() is represented by OP_NULL.
1048 * It's responsible for detecting things that can't be modified, flag
1049 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
1050 * might have to vivify a reference in $x), and so on.
1052 * For example, "$a+1 = 2" would cause mod() to be called with o being
1053 * OP_ADD and type being OP_SASSIGN, and would output an error.
1057 Perl_mod(pTHX_ OP *o, I32 type)
1061 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1064 if (!o || PL_error_count)
1067 if ((o->op_private & OPpTARGET_MY)
1068 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1073 switch (o->op_type) {
1079 if (!(o->op_private & OPpCONST_ARYBASE))
1082 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1083 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
1087 SAVEI32(PL_compiling.cop_arybase);
1088 PL_compiling.cop_arybase = 0;
1090 else if (type == OP_REFGEN)
1093 Perl_croak(aTHX_ "That use of $[ is unsupported");
1096 if (o->op_flags & OPf_PARENS || PL_madskills)
1100 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1101 !(o->op_flags & OPf_STACKED)) {
1102 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1103 /* The default is to set op_private to the number of children,
1104 which for a UNOP such as RV2CV is always 1. And w're using
1105 the bit for a flag in RV2CV, so we need it clear. */
1106 o->op_private &= ~1;
1107 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1108 assert(cUNOPo->op_first->op_type == OP_NULL);
1109 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1112 else if (o->op_private & OPpENTERSUB_NOMOD)
1114 else { /* lvalue subroutine call */
1115 o->op_private |= OPpLVAL_INTRO;
1116 PL_modcount = RETURN_UNLIMITED_NUMBER;
1117 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1118 /* Backward compatibility mode: */
1119 o->op_private |= OPpENTERSUB_INARGS;
1122 else { /* Compile-time error message: */
1123 OP *kid = cUNOPo->op_first;
1127 if (kid->op_type == OP_PUSHMARK)
1129 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1131 "panic: unexpected lvalue entersub "
1132 "args: type/targ %ld:%"UVuf,
1133 (long)kid->op_type, (UV)kid->op_targ);
1134 kid = kLISTOP->op_first;
1136 while (kid->op_sibling)
1137 kid = kid->op_sibling;
1138 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1140 if (kid->op_type == OP_METHOD_NAMED
1141 || kid->op_type == OP_METHOD)
1145 NewOp(1101, newop, 1, UNOP);
1146 newop->op_type = OP_RV2CV;
1147 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1148 newop->op_first = NULL;
1149 newop->op_next = (OP*)newop;
1150 kid->op_sibling = (OP*)newop;
1151 newop->op_private |= OPpLVAL_INTRO;
1152 newop->op_private &= ~1;
1156 if (kid->op_type != OP_RV2CV)
1158 "panic: unexpected lvalue entersub "
1159 "entry via type/targ %ld:%"UVuf,
1160 (long)kid->op_type, (UV)kid->op_targ);
1161 kid->op_private |= OPpLVAL_INTRO;
1162 break; /* Postpone until runtime */
1166 kid = kUNOP->op_first;
1167 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1168 kid = kUNOP->op_first;
1169 if (kid->op_type == OP_NULL)
1171 "Unexpected constant lvalue entersub "
1172 "entry via type/targ %ld:%"UVuf,
1173 (long)kid->op_type, (UV)kid->op_targ);
1174 if (kid->op_type != OP_GV) {
1175 /* Restore RV2CV to check lvalueness */
1177 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1178 okid->op_next = kid->op_next;
1179 kid->op_next = okid;
1182 okid->op_next = NULL;
1183 okid->op_type = OP_RV2CV;
1185 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1186 okid->op_private |= OPpLVAL_INTRO;
1187 okid->op_private &= ~1;
1191 cv = GvCV(kGVOP_gv);
1201 /* grep, foreach, subcalls, refgen */
1202 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1204 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1205 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1207 : (o->op_type == OP_ENTERSUB
1208 ? "non-lvalue subroutine call"
1210 type ? PL_op_desc[type] : "local"));
1224 case OP_RIGHT_SHIFT:
1233 if (!(o->op_flags & OPf_STACKED))
1240 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1246 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1247 PL_modcount = RETURN_UNLIMITED_NUMBER;
1248 return o; /* Treat \(@foo) like ordinary list. */
1252 if (scalar_mod_type(o, type))
1254 ref(cUNOPo->op_first, o->op_type);
1258 if (type == OP_LEAVESUBLV)
1259 o->op_private |= OPpMAYBE_LVSUB;
1265 PL_modcount = RETURN_UNLIMITED_NUMBER;
1268 ref(cUNOPo->op_first, o->op_type);
1273 PL_hints |= HINT_BLOCK_SCOPE;
1288 PL_modcount = RETURN_UNLIMITED_NUMBER;
1289 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1290 return o; /* Treat \(@foo) like ordinary list. */
1291 if (scalar_mod_type(o, type))
1293 if (type == OP_LEAVESUBLV)
1294 o->op_private |= OPpMAYBE_LVSUB;
1298 if (!type) /* local() */
1299 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1300 PAD_COMPNAME_PV(o->op_targ));
1308 if (type != OP_SASSIGN)
1312 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1317 if (type == OP_LEAVESUBLV)
1318 o->op_private |= OPpMAYBE_LVSUB;
1320 pad_free(o->op_targ);
1321 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1322 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1323 if (o->op_flags & OPf_KIDS)
1324 mod(cBINOPo->op_first->op_sibling, type);
1329 ref(cBINOPo->op_first, o->op_type);
1330 if (type == OP_ENTERSUB &&
1331 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1332 o->op_private |= OPpLVAL_DEFER;
1333 if (type == OP_LEAVESUBLV)
1334 o->op_private |= OPpMAYBE_LVSUB;
1344 if (o->op_flags & OPf_KIDS)
1345 mod(cLISTOPo->op_last, type);
1350 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1352 else if (!(o->op_flags & OPf_KIDS))
1354 if (o->op_targ != OP_LIST) {
1355 mod(cBINOPo->op_first, type);
1361 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1366 if (type != OP_LEAVESUBLV)
1368 break; /* mod()ing was handled by ck_return() */
1371 /* [20011101.069] File test operators interpret OPf_REF to mean that
1372 their argument is a filehandle; thus \stat(".") should not set
1374 if (type == OP_REFGEN &&
1375 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1378 if (type != OP_LEAVESUBLV)
1379 o->op_flags |= OPf_MOD;
1381 if (type == OP_AASSIGN || type == OP_SASSIGN)
1382 o->op_flags |= OPf_SPECIAL|OPf_REF;
1383 else if (!type) { /* local() */
1386 o->op_private |= OPpLVAL_INTRO;
1387 o->op_flags &= ~OPf_SPECIAL;
1388 PL_hints |= HINT_BLOCK_SCOPE;
1393 if (ckWARN(WARN_SYNTAX)) {
1394 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1395 "Useless localization of %s", OP_DESC(o));
1399 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1400 && type != OP_LEAVESUBLV)
1401 o->op_flags |= OPf_REF;
1406 S_scalar_mod_type(const OP *o, I32 type)
1410 if (o->op_type == OP_RV2GV)
1434 case OP_RIGHT_SHIFT:
1453 S_is_handle_constructor(const OP *o, I32 numargs)
1455 switch (o->op_type) {
1463 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1476 Perl_refkids(pTHX_ OP *o, I32 type)
1478 if (o && o->op_flags & OPf_KIDS) {
1480 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1487 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
1492 if (!o || PL_error_count)
1495 switch (o->op_type) {
1497 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1498 !(o->op_flags & OPf_STACKED)) {
1499 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1500 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1501 assert(cUNOPo->op_first->op_type == OP_NULL);
1502 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1503 o->op_flags |= OPf_SPECIAL;
1504 o->op_private &= ~1;
1509 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1510 doref(kid, type, set_op_ref);
1513 if (type == OP_DEFINED)
1514 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1515 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1518 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1519 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1520 : type == OP_RV2HV ? OPpDEREF_HV
1522 o->op_flags |= OPf_MOD;
1527 o->op_flags |= OPf_MOD; /* XXX ??? */
1533 o->op_flags |= OPf_REF;
1536 if (type == OP_DEFINED)
1537 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1538 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1544 o->op_flags |= OPf_REF;
1549 if (!(o->op_flags & OPf_KIDS))
1551 doref(cBINOPo->op_first, type, set_op_ref);
1555 doref(cBINOPo->op_first, o->op_type, set_op_ref);
1556 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1557 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1558 : type == OP_RV2HV ? OPpDEREF_HV
1560 o->op_flags |= OPf_MOD;
1570 if (!(o->op_flags & OPf_KIDS))
1572 doref(cLISTOPo->op_last, type, set_op_ref);
1582 S_dup_attrlist(pTHX_ OP *o)
1587 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1588 * where the first kid is OP_PUSHMARK and the remaining ones
1589 * are OP_CONST. We need to push the OP_CONST values.
1591 if (o->op_type == OP_CONST)
1592 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
1594 else if (o->op_type == OP_NULL)
1598 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1600 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1601 if (o->op_type == OP_CONST)
1602 rop = append_elem(OP_LIST, rop,
1603 newSVOP(OP_CONST, o->op_flags,
1604 SvREFCNT_inc_NN(cSVOPo->op_sv)));
1611 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1616 /* fake up C<use attributes $pkg,$rv,@attrs> */
1617 ENTER; /* need to protect against side-effects of 'use' */
1619 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1621 #define ATTRSMODULE "attributes"
1622 #define ATTRSMODULE_PM "attributes.pm"
1625 /* Don't force the C<use> if we don't need it. */
1626 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
1627 if (svp && *svp != &PL_sv_undef)
1628 /*EMPTY*/; /* already in %INC */
1630 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1631 newSVpvs(ATTRSMODULE), NULL);
1634 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1635 newSVpvs(ATTRSMODULE),
1637 prepend_elem(OP_LIST,
1638 newSVOP(OP_CONST, 0, stashsv),
1639 prepend_elem(OP_LIST,
1640 newSVOP(OP_CONST, 0,
1642 dup_attrlist(attrs))));
1648 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1651 OP *pack, *imop, *arg;
1657 assert(target->op_type == OP_PADSV ||
1658 target->op_type == OP_PADHV ||
1659 target->op_type == OP_PADAV);
1661 /* Ensure that attributes.pm is loaded. */
1662 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1664 /* Need package name for method call. */
1665 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
1667 /* Build up the real arg-list. */
1668 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1670 arg = newOP(OP_PADSV, 0);
1671 arg->op_targ = target->op_targ;
1672 arg = prepend_elem(OP_LIST,
1673 newSVOP(OP_CONST, 0, stashsv),
1674 prepend_elem(OP_LIST,
1675 newUNOP(OP_REFGEN, 0,
1676 mod(arg, OP_REFGEN)),
1677 dup_attrlist(attrs)));
1679 /* Fake up a method call to import */
1680 meth = newSVpvs_share("import");
1681 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1682 append_elem(OP_LIST,
1683 prepend_elem(OP_LIST, pack, list(arg)),
1684 newSVOP(OP_METHOD_NAMED, 0, meth)));
1685 imop->op_private |= OPpENTERSUB_NOMOD;
1687 /* Combine the ops. */
1688 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1692 =notfor apidoc apply_attrs_string
1694 Attempts to apply a list of attributes specified by the C<attrstr> and
1695 C<len> arguments to the subroutine identified by the C<cv> argument which
1696 is expected to be associated with the package identified by the C<stashpv>
1697 argument (see L<attributes>). It gets this wrong, though, in that it
1698 does not correctly identify the boundaries of the individual attribute
1699 specifications within C<attrstr>. This is not really intended for the
1700 public API, but has to be listed here for systems such as AIX which
1701 need an explicit export list for symbols. (It's called from XS code
1702 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1703 to respect attribute syntax properly would be welcome.
1709 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
1710 const char *attrstr, STRLEN len)
1715 len = strlen(attrstr);
1719 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1721 const char * const sstr = attrstr;
1722 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1723 attrs = append_elem(OP_LIST, attrs,
1724 newSVOP(OP_CONST, 0,
1725 newSVpvn(sstr, attrstr-sstr)));
1729 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1730 newSVpvs(ATTRSMODULE),
1731 NULL, prepend_elem(OP_LIST,
1732 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1733 prepend_elem(OP_LIST,
1734 newSVOP(OP_CONST, 0,
1740 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
1745 if (!o || PL_error_count)
1750 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
1751 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
1755 if (type == OP_LIST) {
1757 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1758 my_kid(kid, attrs, imopsp);
1759 } else if (type == OP_UNDEF
1765 } else if (type == OP_RV2SV || /* "our" declaration */
1767 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1768 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1769 yyerror(Perl_form(aTHX_ "Can't declare %s in %s",
1770 OP_DESC(o), PL_in_my == KEY_our ? "our" : "my"));
1772 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
1774 PL_in_my_stash = NULL;
1775 apply_attrs(GvSTASH(gv),
1776 (type == OP_RV2SV ? GvSV(gv) :
1777 type == OP_RV2AV ? (SV*)GvAV(gv) :
1778 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1781 o->op_private |= OPpOUR_INTRO;
1784 else if (type != OP_PADSV &&
1787 type != OP_PUSHMARK)
1789 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1791 PL_in_my == KEY_our ? "our" : "my"));
1794 else if (attrs && type != OP_PUSHMARK) {
1798 PL_in_my_stash = NULL;
1800 /* check for C<my Dog $spot> when deciding package */
1801 stash = PAD_COMPNAME_TYPE(o->op_targ);
1803 stash = PL_curstash;
1804 apply_attrs_my(stash, o, attrs, imopsp);
1806 o->op_flags |= OPf_MOD;
1807 o->op_private |= OPpLVAL_INTRO;
1812 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1816 int maybe_scalar = 0;
1818 /* [perl #17376]: this appears to be premature, and results in code such as
1819 C< our(%x); > executing in list mode rather than void mode */
1821 if (o->op_flags & OPf_PARENS)
1831 o = my_kid(o, attrs, &rops);
1833 if (maybe_scalar && o->op_type == OP_PADSV) {
1834 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
1835 o->op_private |= OPpLVAL_INTRO;
1838 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
1841 PL_in_my_stash = NULL;
1846 Perl_my(pTHX_ OP *o)
1848 return my_attrs(o, NULL);
1852 Perl_sawparens(pTHX_ OP *o)
1854 PERL_UNUSED_CONTEXT;
1856 o->op_flags |= OPf_PARENS;
1861 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
1866 if ( (left->op_type == OP_RV2AV ||
1867 left->op_type == OP_RV2HV ||
1868 left->op_type == OP_PADAV ||
1869 left->op_type == OP_PADHV)
1870 && ckWARN(WARN_MISC))
1872 const char * const desc = PL_op_desc[(right->op_type == OP_SUBST ||
1873 right->op_type == OP_TRANS)
1874 ? right->op_type : OP_MATCH];
1875 const char * const sample = ((left->op_type == OP_RV2AV ||
1876 left->op_type == OP_PADAV)
1877 ? "@array" : "%hash");
1878 Perl_warner(aTHX_ packWARN(WARN_MISC),
1879 "Applying %s to %s will act on scalar(%s)",
1880 desc, sample, sample);
1883 if (right->op_type == OP_CONST &&
1884 cSVOPx(right)->op_private & OPpCONST_BARE &&
1885 cSVOPx(right)->op_private & OPpCONST_STRICT)
1887 no_bareword_allowed(right);
1890 ismatchop = right->op_type == OP_MATCH ||
1891 right->op_type == OP_SUBST ||
1892 right->op_type == OP_TRANS;
1893 if (ismatchop && right->op_private & OPpTARGET_MY) {
1895 right->op_private &= ~OPpTARGET_MY;
1897 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
1898 right->op_flags |= OPf_STACKED;
1899 if (right->op_type != OP_MATCH &&
1900 ! (right->op_type == OP_TRANS &&
1901 right->op_private & OPpTRANS_IDENTICAL))
1902 left = mod(left, right->op_type);
1903 if (right->op_type == OP_TRANS)
1904 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
1906 o = prepend_elem(right->op_type, scalar(left), right);
1908 return newUNOP(OP_NOT, 0, scalar(o));
1912 return bind_match(type, left,
1913 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
1917 Perl_invert(pTHX_ OP *o)
1921 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
1925 Perl_scope(pTHX_ OP *o)
1929 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
1930 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
1931 o->op_type = OP_LEAVE;
1932 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
1934 else if (o->op_type == OP_LINESEQ) {
1936 o->op_type = OP_SCOPE;
1937 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
1938 kid = ((LISTOP*)o)->op_first;
1939 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
1942 /* The following deals with things like 'do {1 for 1}' */
1943 kid = kid->op_sibling;
1945 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
1950 o = newLISTOP(OP_SCOPE, 0, o, NULL);
1956 Perl_block_start(pTHX_ int full)
1959 const int retval = PL_savestack_ix;
1960 pad_block_start(full);
1962 PL_hints &= ~HINT_BLOCK_SCOPE;
1963 SAVESPTR(PL_compiling.cop_warnings);
1964 if (! specialWARN(PL_compiling.cop_warnings)) {
1965 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
1966 SAVEFREESV(PL_compiling.cop_warnings) ;
1968 SAVESPTR(PL_compiling.cop_io);
1969 if (! specialCopIO(PL_compiling.cop_io)) {
1970 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
1971 SAVEFREESV(PL_compiling.cop_io) ;
1977 Perl_block_end(pTHX_ I32 floor, OP *seq)
1980 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
1981 OP* const retval = scalarseq(seq);
1983 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
1985 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
1994 const I32 offset = pad_findmy("$_");
1995 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
1996 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
1999 OP * const o = newOP(OP_PADSV, 0);
2000 o->op_targ = offset;
2006 Perl_newPROG(pTHX_ OP *o)
2012 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2013 ((PL_in_eval & EVAL_KEEPERR)
2014 ? OPf_SPECIAL : 0), o);
2015 PL_eval_start = linklist(PL_eval_root);
2016 PL_eval_root->op_private |= OPpREFCOUNTED;
2017 OpREFCNT_set(PL_eval_root, 1);
2018 PL_eval_root->op_next = 0;
2019 CALL_PEEP(PL_eval_start);
2022 if (o->op_type == OP_STUB) {
2023 PL_comppad_name = 0;
2028 PL_main_root = scope(sawparens(scalarvoid(o)));
2029 PL_curcop = &PL_compiling;
2030 PL_main_start = LINKLIST(PL_main_root);
2031 PL_main_root->op_private |= OPpREFCOUNTED;
2032 OpREFCNT_set(PL_main_root, 1);
2033 PL_main_root->op_next = 0;
2034 CALL_PEEP(PL_main_start);
2037 /* Register with debugger */
2039 CV * const cv = get_cv("DB::postponed", FALSE);
2043 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2045 call_sv((SV*)cv, G_DISCARD);
2052 Perl_localize(pTHX_ OP *o, I32 lex)
2055 if (o->op_flags & OPf_PARENS)
2056 /* [perl #17376]: this appears to be premature, and results in code such as
2057 C< our(%x); > executing in list mode rather than void mode */
2064 if ( PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ','
2065 && ckWARN(WARN_PARENTHESIS))
2067 char *s = PL_bufptr;
2070 /* some heuristics to detect a potential error */
2071 while (*s && (strchr(", \t\n", *s)))
2075 if (*s && strchr("@$%*", *s) && *++s
2076 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2079 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2081 while (*s && (strchr(", \t\n", *s)))
2087 if (sigil && (*s == ';' || *s == '=')) {
2088 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2089 "Parentheses missing around \"%s\" list",
2090 lex ? (PL_in_my == KEY_our ? "our" : "my")
2098 o = mod(o, OP_NULL); /* a bit kludgey */
2100 PL_in_my_stash = NULL;
2105 Perl_jmaybe(pTHX_ OP *o)
2107 if (o->op_type == OP_LIST) {
2109 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL,
2111 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2117 Perl_fold_constants(pTHX_ register OP *o)
2122 I32 type = o->op_type;
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 && (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 && (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_ const 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 const 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 = NULL;
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)
5813 if (o->op_flags & OPf_KIDS) {
5814 if (cLISTOPo->op_first->op_type == OP_STUB) {
5816 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
5818 op_getmad(o,newop,'O');
5830 Perl_ck_eval(pTHX_ OP *o)
5833 PL_hints |= HINT_BLOCK_SCOPE;
5834 if (o->op_flags & OPf_KIDS) {
5835 SVOP * const kid = (SVOP*)cUNOPo->op_first;
5838 o->op_flags &= ~OPf_KIDS;
5841 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
5847 cUNOPo->op_first = 0;
5852 NewOp(1101, enter, 1, LOGOP);
5853 enter->op_type = OP_ENTERTRY;
5854 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5855 enter->op_private = 0;
5857 /* establish postfix order */
5858 enter->op_next = (OP*)enter;
5860 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5861 o->op_type = OP_LEAVETRY;
5862 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5863 enter->op_other = o;
5864 op_getmad(oldo,o,'O');
5878 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5879 op_getmad(oldo,o,'O');
5881 o->op_targ = (PADOFFSET)PL_hints;
5882 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
5883 /* Store a copy of %^H that pp_entereval can pick up */
5884 OP *hhop = newSVOP(OP_CONST, 0, (SV*)newHVhv(GvHV(PL_hintgv)));
5885 cUNOPo->op_first->op_sibling = hhop;
5886 o->op_private |= OPpEVAL_HAS_HH;
5892 Perl_ck_exit(pTHX_ OP *o)
5895 HV * const table = GvHV(PL_hintgv);
5897 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
5898 if (svp && *svp && SvTRUE(*svp))
5899 o->op_private |= OPpEXIT_VMSISH;
5901 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5907 Perl_ck_exec(pTHX_ OP *o)
5909 if (o->op_flags & OPf_STACKED) {
5912 kid = cUNOPo->op_first->op_sibling;
5913 if (kid->op_type == OP_RV2GV)
5922 Perl_ck_exists(pTHX_ OP *o)
5926 if (o->op_flags & OPf_KIDS) {
5927 OP * const kid = cUNOPo->op_first;
5928 if (kid->op_type == OP_ENTERSUB) {
5929 (void) ref(kid, o->op_type);
5930 if (kid->op_type != OP_RV2CV && !PL_error_count)
5931 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5933 o->op_private |= OPpEXISTS_SUB;
5935 else if (kid->op_type == OP_AELEM)
5936 o->op_flags |= OPf_SPECIAL;
5937 else if (kid->op_type != OP_HELEM)
5938 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5946 Perl_ck_rvconst(pTHX_ register OP *o)
5949 SVOP * const kid = (SVOP*)cUNOPo->op_first;
5951 o->op_private |= (PL_hints & HINT_STRICT_REFS);
5952 if (o->op_type == OP_RV2CV)
5953 o->op_private &= ~1;
5955 if (kid->op_type == OP_CONST) {
5958 SV * const kidsv = kid->op_sv;
5960 /* Is it a constant from cv_const_sv()? */
5961 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5962 SV * const rsv = SvRV(kidsv);
5963 const int svtype = SvTYPE(rsv);
5964 const char *badtype = NULL;
5966 switch (o->op_type) {
5968 if (svtype > SVt_PVMG)
5969 badtype = "a SCALAR";
5972 if (svtype != SVt_PVAV)
5973 badtype = "an ARRAY";
5976 if (svtype != SVt_PVHV)
5980 if (svtype != SVt_PVCV)
5985 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5988 else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
5989 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
5990 /* If this is an access to a stash, disable "strict refs", because
5991 * stashes aren't auto-vivified at compile-time (unless we store
5992 * symbols in them), and we don't want to produce a run-time
5993 * stricture error when auto-vivifying the stash. */
5994 const char *s = SvPV_nolen(kidsv);
5995 const STRLEN l = SvCUR(kidsv);
5996 if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
5997 o->op_private &= ~HINT_STRICT_REFS;
5999 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
6000 const char *badthing;
6001 switch (o->op_type) {
6003 badthing = "a SCALAR";
6006 badthing = "an ARRAY";
6009 badthing = "a HASH";
6017 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
6021 * This is a little tricky. We only want to add the symbol if we
6022 * didn't add it in the lexer. Otherwise we get duplicate strict
6023 * warnings. But if we didn't add it in the lexer, we must at
6024 * least pretend like we wanted to add it even if it existed before,
6025 * or we get possible typo warnings. OPpCONST_ENTERED says
6026 * whether the lexer already added THIS instance of this symbol.
6028 iscv = (o->op_type == OP_RV2CV) * 2;
6030 gv = gv_fetchsv(kidsv,
6031 iscv | !(kid->op_private & OPpCONST_ENTERED),
6034 : o->op_type == OP_RV2SV
6036 : o->op_type == OP_RV2AV
6038 : o->op_type == OP_RV2HV
6041 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
6043 kid->op_type = OP_GV;
6044 SvREFCNT_dec(kid->op_sv);
6046 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
6047 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
6048 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
6050 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc_simple_NN(gv));
6052 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
6054 kid->op_private = 0;
6055 kid->op_ppaddr = PL_ppaddr[OP_GV];
6062 Perl_ck_ftst(pTHX_ OP *o)
6065 const I32 type = o->op_type;
6067 if (o->op_flags & OPf_REF) {
6070 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
6071 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6073 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6074 OP * const newop = newGVOP(type, OPf_REF,
6075 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
6077 op_getmad(o,newop,'O');
6083 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o))
6084 o->op_private |= OPpFT_ACCESS;
6085 if (PL_check[kid->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst)
6086 && kid->op_type != OP_STAT && kid->op_type != OP_LSTAT)
6087 o->op_private |= OPpFT_STACKED;
6095 if (type == OP_FTTTY)
6096 o = newGVOP(type, OPf_REF, PL_stdingv);
6098 o = newUNOP(type, 0, newDEFSVOP());
6099 op_getmad(oldo,o,'O');
6105 Perl_ck_fun(pTHX_ OP *o)
6108 const int type = o->op_type;
6109 register I32 oa = PL_opargs[type] >> OASHIFT;
6111 if (o->op_flags & OPf_STACKED) {
6112 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
6115 return no_fh_allowed(o);
6118 if (o->op_flags & OPf_KIDS) {
6119 OP **tokid = &cLISTOPo->op_first;
6120 register OP *kid = cLISTOPo->op_first;
6124 if (kid->op_type == OP_PUSHMARK ||
6125 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
6127 tokid = &kid->op_sibling;
6128 kid = kid->op_sibling;
6130 if (!kid && PL_opargs[type] & OA_DEFGV)
6131 *tokid = kid = newDEFSVOP();
6135 sibl = kid->op_sibling;
6137 if (!sibl && kid->op_type == OP_STUB) {
6144 /* list seen where single (scalar) arg expected? */
6145 if (numargs == 1 && !(oa >> 4)
6146 && kid->op_type == OP_LIST && type != OP_SCALAR)
6148 return too_many_arguments(o,PL_op_desc[type]);
6161 if ((type == OP_PUSH || type == OP_UNSHIFT)
6162 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
6163 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6164 "Useless use of %s with no values",
6167 if (kid->op_type == OP_CONST &&
6168 (kid->op_private & OPpCONST_BARE))
6170 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
6171 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
6172 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6173 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6174 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
6175 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
6177 op_getmad(kid,newop,'K');
6182 kid->op_sibling = sibl;
6185 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
6186 bad_type(numargs, "array", PL_op_desc[type], kid);
6190 if (kid->op_type == OP_CONST &&
6191 (kid->op_private & OPpCONST_BARE))
6193 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
6194 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
6195 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6196 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6197 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
6198 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
6200 op_getmad(kid,newop,'K');
6205 kid->op_sibling = sibl;
6208 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
6209 bad_type(numargs, "hash", PL_op_desc[type], kid);
6214 OP * const newop = newUNOP(OP_NULL, 0, kid);
6215 kid->op_sibling = 0;
6217 newop->op_next = newop;
6219 kid->op_sibling = sibl;
6224 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
6225 if (kid->op_type == OP_CONST &&
6226 (kid->op_private & OPpCONST_BARE))
6228 OP * const newop = newGVOP(OP_GV, 0,
6229 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
6230 if (!(o->op_private & 1) && /* if not unop */
6231 kid == cLISTOPo->op_last)
6232 cLISTOPo->op_last = newop;
6234 op_getmad(kid,newop,'K');
6240 else if (kid->op_type == OP_READLINE) {
6241 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
6242 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
6245 I32 flags = OPf_SPECIAL;
6249 /* is this op a FH constructor? */
6250 if (is_handle_constructor(o,numargs)) {
6251 const char *name = NULL;
6255 /* Set a flag to tell rv2gv to vivify
6256 * need to "prove" flag does not mean something
6257 * else already - NI-S 1999/05/07
6260 if (kid->op_type == OP_PADSV) {
6261 name = PAD_COMPNAME_PV(kid->op_targ);
6262 /* SvCUR of a pad namesv can't be trusted
6263 * (see PL_generation), so calc its length
6269 else if (kid->op_type == OP_RV2SV
6270 && kUNOP->op_first->op_type == OP_GV)
6272 GV * const gv = cGVOPx_gv(kUNOP->op_first);
6274 len = GvNAMELEN(gv);
6276 else if (kid->op_type == OP_AELEM
6277 || kid->op_type == OP_HELEM)
6279 OP *op = ((BINOP*)kid)->op_first;
6283 const char * const a =
6284 kid->op_type == OP_AELEM ?
6286 if (((op->op_type == OP_RV2AV) ||
6287 (op->op_type == OP_RV2HV)) &&
6288 (op = ((UNOP*)op)->op_first) &&
6289 (op->op_type == OP_GV)) {
6290 /* packagevar $a[] or $h{} */
6291 GV * const gv = cGVOPx_gv(op);
6299 else if (op->op_type == OP_PADAV
6300 || op->op_type == OP_PADHV) {
6301 /* lexicalvar $a[] or $h{} */
6302 const char * const padname =
6303 PAD_COMPNAME_PV(op->op_targ);
6312 name = SvPV_const(tmpstr, len);
6317 name = "__ANONIO__";
6324 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
6325 namesv = PAD_SVl(targ);
6326 SvUPGRADE(namesv, SVt_PV);
6328 sv_setpvn(namesv, "$", 1);
6329 sv_catpvn(namesv, name, len);
6332 kid->op_sibling = 0;
6333 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
6334 kid->op_targ = targ;
6335 kid->op_private |= priv;
6337 kid->op_sibling = sibl;
6343 mod(scalar(kid), type);
6347 tokid = &kid->op_sibling;
6348 kid = kid->op_sibling;
6351 if (kid && kid->op_type != OP_STUB)
6352 return too_many_arguments(o,OP_DESC(o));
6353 o->op_private |= numargs;
6355 /* FIXME - should the numargs move as for the PERL_MAD case? */
6356 o->op_private |= numargs;
6358 return too_many_arguments(o,OP_DESC(o));
6362 else if (PL_opargs[type] & OA_DEFGV) {
6364 OP *newop = newUNOP(type, 0, newDEFSVOP());
6365 op_getmad(o,newop,'O');
6368 /* Ordering of these two is important to keep f_map.t passing. */
6370 return newUNOP(type, 0, newDEFSVOP());
6375 while (oa & OA_OPTIONAL)
6377 if (oa && oa != OA_LIST)
6378 return too_few_arguments(o,OP_DESC(o));
6384 Perl_ck_glob(pTHX_ OP *o)
6390 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
6391 append_elem(OP_GLOB, o, newDEFSVOP());
6393 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
6394 && GvCVu(gv) && GvIMPORTED_CV(gv)))
6396 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6399 #if !defined(PERL_EXTERNAL_GLOB)
6400 /* XXX this can be tightened up and made more failsafe. */
6401 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
6404 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
6405 newSVpvs("File::Glob"), NULL, NULL, NULL);
6406 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6407 glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
6408 GvCV(gv) = GvCV(glob_gv);
6409 SvREFCNT_inc_void((SV*)GvCV(gv));
6410 GvIMPORTED_CV_on(gv);
6413 #endif /* PERL_EXTERNAL_GLOB */
6415 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6416 append_elem(OP_GLOB, o,
6417 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
6418 o->op_type = OP_LIST;
6419 o->op_ppaddr = PL_ppaddr[OP_LIST];
6420 cLISTOPo->op_first->op_type = OP_PUSHMARK;
6421 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
6422 cLISTOPo->op_first->op_targ = 0;
6423 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
6424 append_elem(OP_LIST, o,
6425 scalar(newUNOP(OP_RV2CV, 0,
6426 newGVOP(OP_GV, 0, gv)))));
6427 o = newUNOP(OP_NULL, 0, ck_subr(o));
6428 o->op_targ = OP_GLOB; /* hint at what it used to be */
6431 gv = newGVgen("main");
6433 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
6439 Perl_ck_grep(pTHX_ OP *o)
6444 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
6447 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
6448 /* don't allocate gwop here, as we may leak it if PL_error_count > 0 */
6450 if (o->op_flags & OPf_STACKED) {
6453 kid = cLISTOPo->op_first->op_sibling;
6454 if (!cUNOPx(kid)->op_next)
6455 Perl_croak(aTHX_ "panic: ck_grep");
6456 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
6459 NewOp(1101, gwop, 1, LOGOP);
6460 kid->op_next = (OP*)gwop;
6461 o->op_flags &= ~OPf_STACKED;
6463 kid = cLISTOPo->op_first->op_sibling;
6464 if (type == OP_MAPWHILE)
6471 kid = cLISTOPo->op_first->op_sibling;
6472 if (kid->op_type != OP_NULL)
6473 Perl_croak(aTHX_ "panic: ck_grep");
6474 kid = kUNOP->op_first;
6477 NewOp(1101, gwop, 1, LOGOP);
6478 gwop->op_type = type;
6479 gwop->op_ppaddr = PL_ppaddr[type];
6480 gwop->op_first = listkids(o);
6481 gwop->op_flags |= OPf_KIDS;
6482 gwop->op_other = LINKLIST(kid);
6483 kid->op_next = (OP*)gwop;
6484 offset = pad_findmy("$_");
6485 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
6486 o->op_private = gwop->op_private = 0;
6487 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
6490 o->op_private = gwop->op_private = OPpGREP_LEX;
6491 gwop->op_targ = o->op_targ = offset;
6494 kid = cLISTOPo->op_first->op_sibling;
6495 if (!kid || !kid->op_sibling)
6496 return too_few_arguments(o,OP_DESC(o));
6497 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
6498 mod(kid, OP_GREPSTART);
6504 Perl_ck_index(pTHX_ OP *o)
6506 if (o->op_flags & OPf_KIDS) {
6507 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6509 kid = kid->op_sibling; /* get past "big" */
6510 if (kid && kid->op_type == OP_CONST)
6511 fbm_compile(((SVOP*)kid)->op_sv, 0);
6517 Perl_ck_lengthconst(pTHX_ OP *o)
6519 /* XXX length optimization goes here */
6524 Perl_ck_lfun(pTHX_ OP *o)
6526 const OPCODE type = o->op_type;
6527 return modkids(ck_fun(o), type);
6531 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
6533 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
6534 switch (cUNOPo->op_first->op_type) {
6536 /* This is needed for
6537 if (defined %stash::)
6538 to work. Do not break Tk.
6540 break; /* Globals via GV can be undef */
6542 case OP_AASSIGN: /* Is this a good idea? */
6543 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6544 "defined(@array) is deprecated");
6545 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6546 "\t(Maybe you should just omit the defined()?)\n");
6549 /* This is needed for
6550 if (defined %stash::)
6551 to work. Do not break Tk.
6553 break; /* Globals via GV can be undef */
6555 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6556 "defined(%%hash) is deprecated");
6557 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6558 "\t(Maybe you should just omit the defined()?)\n");
6569 Perl_ck_rfun(pTHX_ OP *o)
6571 const OPCODE type = o->op_type;
6572 return refkids(ck_fun(o), type);
6576 Perl_ck_listiob(pTHX_ OP *o)
6580 kid = cLISTOPo->op_first;
6583 kid = cLISTOPo->op_first;
6585 if (kid->op_type == OP_PUSHMARK)
6586 kid = kid->op_sibling;
6587 if (kid && o->op_flags & OPf_STACKED)
6588 kid = kid->op_sibling;
6589 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6590 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6591 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6592 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6593 cLISTOPo->op_first->op_sibling = kid;
6594 cLISTOPo->op_last = kid;
6595 kid = kid->op_sibling;
6600 append_elem(o->op_type, o, newDEFSVOP());
6606 Perl_ck_say(pTHX_ OP *o)
6609 o->op_type = OP_PRINT;
6610 cLISTOPo->op_last = cLISTOPo->op_last->op_sibling
6611 = newSVOP(OP_CONST, 0, newSVpvs("\n"));
6616 Perl_ck_smartmatch(pTHX_ OP *o)
6619 if (0 == (o->op_flags & OPf_SPECIAL)) {
6620 OP *first = cBINOPo->op_first;
6621 OP *second = first->op_sibling;
6623 /* Implicitly take a reference to an array or hash */
6624 first->op_sibling = NULL;
6625 first = cBINOPo->op_first = ref_array_or_hash(first);
6626 second = first->op_sibling = ref_array_or_hash(second);
6628 /* Implicitly take a reference to a regular expression */
6629 if (first->op_type == OP_MATCH) {
6630 first->op_type = OP_QR;
6631 first->op_ppaddr = PL_ppaddr[OP_QR];
6633 if (second->op_type == OP_MATCH) {
6634 second->op_type = OP_QR;
6635 second->op_ppaddr = PL_ppaddr[OP_QR];
6644 Perl_ck_sassign(pTHX_ OP *o)
6646 OP *kid = cLISTOPo->op_first;
6647 /* has a disposable target? */
6648 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6649 && !(kid->op_flags & OPf_STACKED)
6650 /* Cannot steal the second time! */
6651 && !(kid->op_private & OPpTARGET_MY))
6653 OP * const kkid = kid->op_sibling;
6655 /* Can just relocate the target. */
6656 if (kkid && kkid->op_type == OP_PADSV
6657 && !(kkid->op_private & OPpLVAL_INTRO))
6659 kid->op_targ = kkid->op_targ;
6661 /* Now we do not need PADSV and SASSIGN. */
6662 kid->op_sibling = o->op_sibling; /* NULL */
6663 cLISTOPo->op_first = NULL;
6665 op_getmad(o,kid,'O');
6666 op_getmad(kkid,kid,'M');
6671 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6679 Perl_ck_match(pTHX_ OP *o)
6682 if (o->op_type != OP_QR && PL_compcv) {
6683 const I32 offset = pad_findmy("$_");
6684 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
6685 o->op_targ = offset;
6686 o->op_private |= OPpTARGET_MY;
6689 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
6690 o->op_private |= OPpRUNTIME;
6695 Perl_ck_method(pTHX_ OP *o)
6697 OP * const kid = cUNOPo->op_first;
6698 if (kid->op_type == OP_CONST) {
6699 SV* sv = kSVOP->op_sv;
6700 const char * const method = SvPVX_const(sv);
6701 if (!(strchr(method, ':') || strchr(method, '\''))) {
6703 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6704 sv = newSVpvn_share(method, SvCUR(sv), 0);
6707 kSVOP->op_sv = NULL;
6709 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6711 op_getmad(o,cmop,'O');
6722 Perl_ck_null(pTHX_ OP *o)
6724 PERL_UNUSED_CONTEXT;
6729 Perl_ck_open(pTHX_ OP *o)
6732 HV * const table = GvHV(PL_hintgv);
6734 SV **svp = hv_fetchs(table, "open_IN", FALSE);
6736 const I32 mode = mode_from_discipline(*svp);
6737 if (mode & O_BINARY)
6738 o->op_private |= OPpOPEN_IN_RAW;
6739 else if (mode & O_TEXT)
6740 o->op_private |= OPpOPEN_IN_CRLF;
6743 svp = hv_fetchs(table, "open_OUT", FALSE);
6745 const I32 mode = mode_from_discipline(*svp);
6746 if (mode & O_BINARY)
6747 o->op_private |= OPpOPEN_OUT_RAW;
6748 else if (mode & O_TEXT)
6749 o->op_private |= OPpOPEN_OUT_CRLF;
6752 if (o->op_type == OP_BACKTICK)
6755 /* In case of three-arg dup open remove strictness
6756 * from the last arg if it is a bareword. */
6757 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
6758 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
6762 if ((last->op_type == OP_CONST) && /* The bareword. */
6763 (last->op_private & OPpCONST_BARE) &&
6764 (last->op_private & OPpCONST_STRICT) &&
6765 (oa = first->op_sibling) && /* The fh. */
6766 (oa = oa->op_sibling) && /* The mode. */
6767 (oa->op_type == OP_CONST) &&
6768 SvPOK(((SVOP*)oa)->op_sv) &&
6769 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
6770 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
6771 (last == oa->op_sibling)) /* The bareword. */
6772 last->op_private &= ~OPpCONST_STRICT;
6778 Perl_ck_repeat(pTHX_ OP *o)
6780 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6781 o->op_private |= OPpREPEAT_DOLIST;
6782 cBINOPo->op_first = force_list(cBINOPo->op_first);
6790 Perl_ck_require(pTHX_ OP *o)
6795 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6796 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6798 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6799 SV * const sv = kid->op_sv;
6800 U32 was_readonly = SvREADONLY(sv);
6805 sv_force_normal_flags(sv, 0);
6806 assert(!SvREADONLY(sv));
6813 for (s = SvPVX(sv); *s; s++) {
6814 if (*s == ':' && s[1] == ':') {
6815 const STRLEN len = strlen(s+2)+1;
6817 Move(s+2, s+1, len, char);
6818 SvCUR_set(sv, SvCUR(sv) - 1);
6821 sv_catpvs(sv, ".pm");
6822 SvFLAGS(sv) |= was_readonly;
6826 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
6827 /* handle override, if any */
6828 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
6829 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
6830 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
6831 gv = gvp ? *gvp : NULL;
6835 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6836 OP * const kid = cUNOPo->op_first;
6839 cUNOPo->op_first = 0;
6843 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
6844 append_elem(OP_LIST, kid,
6845 scalar(newUNOP(OP_RV2CV, 0,
6848 op_getmad(o,newop,'O');
6856 Perl_ck_return(pTHX_ OP *o)
6859 if (CvLVALUE(PL_compcv)) {
6861 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6862 mod(kid, OP_LEAVESUBLV);
6868 Perl_ck_select(pTHX_ OP *o)
6872 if (o->op_flags & OPf_KIDS) {
6873 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6874 if (kid && kid->op_sibling) {
6875 o->op_type = OP_SSELECT;
6876 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6878 return fold_constants(o);
6882 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6883 if (kid && kid->op_type == OP_RV2GV)
6884 kid->op_private &= ~HINT_STRICT_REFS;
6889 Perl_ck_shift(pTHX_ OP *o)
6892 const I32 type = o->op_type;
6894 if (!(o->op_flags & OPf_KIDS)) {
6896 /* FIXME - this can be refactored to reduce code in #ifdefs */
6898 OP * const oldo = o;
6902 argop = newUNOP(OP_RV2AV, 0,
6903 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
6905 o = newUNOP(type, 0, scalar(argop));
6906 op_getmad(oldo,o,'O');
6909 return newUNOP(type, 0, scalar(argop));
6912 return scalar(modkids(ck_fun(o), type));
6916 Perl_ck_sort(pTHX_ OP *o)
6921 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0)
6923 HV * const hinthv = GvHV(PL_hintgv);
6925 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
6927 const I32 sorthints = (I32)SvIV(*svp);
6928 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
6929 o->op_private |= OPpSORT_QSORT;
6930 if ((sorthints & HINT_SORT_STABLE) != 0)
6931 o->op_private |= OPpSORT_STABLE;
6936 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6938 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6939 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
6941 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
6943 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6945 if (kid->op_type == OP_SCOPE) {
6949 else if (kid->op_type == OP_LEAVE) {
6950 if (o->op_type == OP_SORT) {
6951 op_null(kid); /* wipe out leave */
6954 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6955 if (k->op_next == kid)
6957 /* don't descend into loops */
6958 else if (k->op_type == OP_ENTERLOOP
6959 || k->op_type == OP_ENTERITER)
6961 k = cLOOPx(k)->op_lastop;
6966 kid->op_next = 0; /* just disconnect the leave */
6967 k = kLISTOP->op_first;
6972 if (o->op_type == OP_SORT) {
6973 /* provide scalar context for comparison function/block */
6979 o->op_flags |= OPf_SPECIAL;
6981 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6984 firstkid = firstkid->op_sibling;
6987 /* provide list context for arguments */
6988 if (o->op_type == OP_SORT)
6995 S_simplify_sort(pTHX_ OP *o)
6998 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7003 if (!(o->op_flags & OPf_STACKED))
7005 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7006 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
7007 kid = kUNOP->op_first; /* get past null */
7008 if (kid->op_type != OP_SCOPE)
7010 kid = kLISTOP->op_last; /* get past scope */
7011 switch(kid->op_type) {
7019 k = kid; /* remember this node*/
7020 if (kBINOP->op_first->op_type != OP_RV2SV)
7022 kid = kBINOP->op_first; /* get past cmp */
7023 if (kUNOP->op_first->op_type != OP_GV)
7025 kid = kUNOP->op_first; /* get past rv2sv */
7027 if (GvSTASH(gv) != PL_curstash)
7029 gvname = GvNAME(gv);
7030 if (*gvname == 'a' && gvname[1] == '\0')
7032 else if (*gvname == 'b' && gvname[1] == '\0')
7037 kid = k; /* back to cmp */
7038 if (kBINOP->op_last->op_type != OP_RV2SV)
7040 kid = kBINOP->op_last; /* down to 2nd arg */
7041 if (kUNOP->op_first->op_type != OP_GV)
7043 kid = kUNOP->op_first; /* get past rv2sv */
7045 if (GvSTASH(gv) != PL_curstash)
7047 gvname = GvNAME(gv);
7049 ? !(*gvname == 'a' && gvname[1] == '\0')
7050 : !(*gvname == 'b' && gvname[1] == '\0'))
7052 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
7054 o->op_private |= OPpSORT_DESCEND;
7055 if (k->op_type == OP_NCMP)
7056 o->op_private |= OPpSORT_NUMERIC;
7057 if (k->op_type == OP_I_NCMP)
7058 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
7059 kid = cLISTOPo->op_first->op_sibling;
7060 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
7062 op_getmad(kid,o,'S'); /* then delete it */
7064 op_free(kid); /* then delete it */
7069 Perl_ck_split(pTHX_ OP *o)
7074 if (o->op_flags & OPf_STACKED)
7075 return no_fh_allowed(o);
7077 kid = cLISTOPo->op_first;
7078 if (kid->op_type != OP_NULL)
7079 Perl_croak(aTHX_ "panic: ck_split");
7080 kid = kid->op_sibling;
7081 op_free(cLISTOPo->op_first);
7082 cLISTOPo->op_first = kid;
7084 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
7085 cLISTOPo->op_last = kid; /* There was only one element previously */
7088 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
7089 OP * const sibl = kid->op_sibling;
7090 kid->op_sibling = 0;
7091 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
7092 if (cLISTOPo->op_first == cLISTOPo->op_last)
7093 cLISTOPo->op_last = kid;
7094 cLISTOPo->op_first = kid;
7095 kid->op_sibling = sibl;
7098 kid->op_type = OP_PUSHRE;
7099 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
7101 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
7102 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
7103 "Use of /g modifier is meaningless in split");
7106 if (!kid->op_sibling)
7107 append_elem(OP_SPLIT, o, newDEFSVOP());
7109 kid = kid->op_sibling;
7112 if (!kid->op_sibling)
7113 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
7115 kid = kid->op_sibling;
7118 if (kid->op_sibling)
7119 return too_many_arguments(o,OP_DESC(o));
7125 Perl_ck_join(pTHX_ OP *o)
7127 const OP * const kid = cLISTOPo->op_first->op_sibling;
7128 if (kid && kid->op_type == OP_MATCH) {
7129 if (ckWARN(WARN_SYNTAX)) {
7130 const REGEXP *re = PM_GETRE(kPMOP);
7131 const char *pmstr = re ? re->precomp : "STRING";
7132 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7133 "/%s/ should probably be written as \"%s\"",
7141 Perl_ck_subr(pTHX_ OP *o)
7144 OP *prev = ((cUNOPo->op_first->op_sibling)
7145 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
7146 OP *o2 = prev->op_sibling;
7153 I32 contextclass = 0;
7157 o->op_private |= OPpENTERSUB_HASTARG;
7158 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
7159 if (cvop->op_type == OP_RV2CV) {
7161 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
7162 op_null(cvop); /* disable rv2cv */
7163 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
7164 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
7165 GV *gv = cGVOPx_gv(tmpop);
7168 tmpop->op_private |= OPpEARLY_CV;
7171 namegv = CvANON(cv) ? gv : CvGV(cv);
7172 proto = SvPV_nolen((SV*)cv);
7174 if (CvASSERTION(cv)) {
7175 if (PL_hints & HINT_ASSERTING) {
7176 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
7177 o->op_private |= OPpENTERSUB_DB;
7181 if (!(PL_hints & HINT_ASSERTIONSSEEN) && ckWARN(WARN_ASSERTIONS)) {
7182 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
7183 "Impossible to activate assertion call");
7190 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7191 if (o2->op_type == OP_CONST)
7192 o2->op_private &= ~OPpCONST_STRICT;
7193 else if (o2->op_type == OP_LIST) {
7194 OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
7195 if (sib && sib->op_type == OP_CONST)
7196 sib->op_private &= ~OPpCONST_STRICT;
7199 o->op_private |= (PL_hints & HINT_STRICT_REFS);
7200 if (PERLDB_SUB && PL_curstash != PL_debstash)
7201 o->op_private |= OPpENTERSUB_DB;
7202 while (o2 != cvop) {
7204 if (PL_madskills && o2->op_type == OP_NULL)
7205 o3 = ((UNOP*)o2)->op_first;
7211 return too_many_arguments(o, gv_ename(namegv));
7229 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
7231 arg == 1 ? "block or sub {}" : "sub {}",
7232 gv_ename(namegv), o3);
7235 /* '*' allows any scalar type, including bareword */
7238 if (o3->op_type == OP_RV2GV)
7239 goto wrapref; /* autoconvert GLOB -> GLOBref */
7240 else if (o3->op_type == OP_CONST)
7241 o3->op_private &= ~OPpCONST_STRICT;
7242 else if (o3->op_type == OP_ENTERSUB) {
7243 /* accidental subroutine, revert to bareword */
7244 OP *gvop = ((UNOP*)o3)->op_first;
7245 if (gvop && gvop->op_type == OP_NULL) {
7246 gvop = ((UNOP*)gvop)->op_first;
7248 for (; gvop->op_sibling; gvop = gvop->op_sibling)
7251 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
7252 (gvop = ((UNOP*)gvop)->op_first) &&
7253 gvop->op_type == OP_GV)
7255 GV * const gv = cGVOPx_gv(gvop);
7256 OP * const sibling = o2->op_sibling;
7257 SV * const n = newSVpvs("");
7259 OP * const oldo2 = o2;
7263 gv_fullname4(n, gv, "", FALSE);
7264 o2 = newSVOP(OP_CONST, 0, n);
7265 op_getmad(oldo2,o2,'O');
7266 prev->op_sibling = o2;
7267 o2->op_sibling = sibling;
7283 if (contextclass++ == 0) {
7284 e = strchr(proto, ']');
7285 if (!e || e == proto)
7294 /* XXX We shouldn't be modifying proto, so we can const proto */
7299 while (*--p != '[');
7300 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
7301 gv_ename(namegv), o3);
7307 if (o3->op_type == OP_RV2GV)
7310 bad_type(arg, "symbol", gv_ename(namegv), o3);
7313 if (o3->op_type == OP_ENTERSUB)
7316 bad_type(arg, "subroutine entry", gv_ename(namegv),
7320 if (o3->op_type == OP_RV2SV ||
7321 o3->op_type == OP_PADSV ||
7322 o3->op_type == OP_HELEM ||
7323 o3->op_type == OP_AELEM ||
7324 o3->op_type == OP_THREADSV)
7327 bad_type(arg, "scalar", gv_ename(namegv), o3);
7330 if (o3->op_type == OP_RV2AV ||
7331 o3->op_type == OP_PADAV)
7334 bad_type(arg, "array", gv_ename(namegv), o3);
7337 if (o3->op_type == OP_RV2HV ||
7338 o3->op_type == OP_PADHV)
7341 bad_type(arg, "hash", gv_ename(namegv), o3);
7346 OP* const sib = kid->op_sibling;
7347 kid->op_sibling = 0;
7348 o2 = newUNOP(OP_REFGEN, 0, kid);
7349 o2->op_sibling = sib;
7350 prev->op_sibling = o2;
7352 if (contextclass && e) {
7367 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
7368 gv_ename(namegv), cv);
7373 mod(o2, OP_ENTERSUB);
7375 o2 = o2->op_sibling;
7377 if (proto && !optional &&
7378 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
7379 return too_few_arguments(o, gv_ename(namegv));
7382 OP * const oldo = o;
7386 o=newSVOP(OP_CONST, 0, newSViv(0));
7387 op_getmad(oldo,o,'O');
7393 Perl_ck_svconst(pTHX_ OP *o)
7395 PERL_UNUSED_CONTEXT;
7396 SvREADONLY_on(cSVOPo->op_sv);
7401 Perl_ck_chdir(pTHX_ OP *o)
7403 if (o->op_flags & OPf_KIDS) {
7404 SVOP *kid = (SVOP*)cUNOPo->op_first;
7406 if (kid && kid->op_type == OP_CONST &&
7407 (kid->op_private & OPpCONST_BARE))
7409 o->op_flags |= OPf_SPECIAL;
7410 kid->op_private &= ~OPpCONST_STRICT;
7417 Perl_ck_trunc(pTHX_ OP *o)
7419 if (o->op_flags & OPf_KIDS) {
7420 SVOP *kid = (SVOP*)cUNOPo->op_first;
7422 if (kid->op_type == OP_NULL)
7423 kid = (SVOP*)kid->op_sibling;
7424 if (kid && kid->op_type == OP_CONST &&
7425 (kid->op_private & OPpCONST_BARE))
7427 o->op_flags |= OPf_SPECIAL;
7428 kid->op_private &= ~OPpCONST_STRICT;
7435 Perl_ck_unpack(pTHX_ OP *o)
7437 OP *kid = cLISTOPo->op_first;
7438 if (kid->op_sibling) {
7439 kid = kid->op_sibling;
7440 if (!kid->op_sibling)
7441 kid->op_sibling = newDEFSVOP();
7447 Perl_ck_substr(pTHX_ OP *o)
7450 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
7451 OP *kid = cLISTOPo->op_first;
7453 if (kid->op_type == OP_NULL)
7454 kid = kid->op_sibling;
7456 kid->op_flags |= OPf_MOD;
7462 /* A peephole optimizer. We visit the ops in the order they're to execute.
7463 * See the comments at the top of this file for more details about when
7464 * peep() is called */
7467 Perl_peep(pTHX_ register OP *o)
7470 register OP* oldop = NULL;
7472 if (!o || o->op_opt)
7476 SAVEVPTR(PL_curcop);
7477 for (; o; o = o->op_next) {
7481 switch (o->op_type) {
7485 PL_curcop = ((COP*)o); /* for warnings */
7490 if (cSVOPo->op_private & OPpCONST_STRICT)
7491 no_bareword_allowed(o);
7493 case OP_METHOD_NAMED:
7494 /* Relocate sv to the pad for thread safety.
7495 * Despite being a "constant", the SV is written to,
7496 * for reference counts, sv_upgrade() etc. */
7498 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
7499 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
7500 /* If op_sv is already a PADTMP then it is being used by
7501 * some pad, so make a copy. */
7502 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
7503 SvREADONLY_on(PAD_SVl(ix));
7504 SvREFCNT_dec(cSVOPo->op_sv);
7506 else if (o->op_type == OP_CONST
7507 && cSVOPo->op_sv == &PL_sv_undef) {
7508 /* PL_sv_undef is hack - it's unsafe to store it in the
7509 AV that is the pad, because av_fetch treats values of
7510 PL_sv_undef as a "free" AV entry and will merrily
7511 replace them with a new SV, causing pad_alloc to think
7512 that this pad slot is free. (When, clearly, it is not)
7514 SvOK_off(PAD_SVl(ix));
7515 SvPADTMP_on(PAD_SVl(ix));
7516 SvREADONLY_on(PAD_SVl(ix));
7519 SvREFCNT_dec(PAD_SVl(ix));
7520 SvPADTMP_on(cSVOPo->op_sv);
7521 PAD_SETSV(ix, cSVOPo->op_sv);
7522 /* XXX I don't know how this isn't readonly already. */
7523 SvREADONLY_on(PAD_SVl(ix));
7525 cSVOPo->op_sv = NULL;
7533 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
7534 if (o->op_next->op_private & OPpTARGET_MY) {
7535 if (o->op_flags & OPf_STACKED) /* chained concats */
7536 goto ignore_optimization;
7538 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
7539 o->op_targ = o->op_next->op_targ;
7540 o->op_next->op_targ = 0;
7541 o->op_private |= OPpTARGET_MY;
7544 op_null(o->op_next);
7546 ignore_optimization:
7550 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
7552 break; /* Scalar stub must produce undef. List stub is noop */
7556 if (o->op_targ == OP_NEXTSTATE
7557 || o->op_targ == OP_DBSTATE
7558 || o->op_targ == OP_SETSTATE)
7560 PL_curcop = ((COP*)o);
7562 /* XXX: We avoid setting op_seq here to prevent later calls
7563 to peep() from mistakenly concluding that optimisation
7564 has already occurred. This doesn't fix the real problem,
7565 though (See 20010220.007). AMS 20010719 */
7566 /* op_seq functionality is now replaced by op_opt */
7567 if (oldop && o->op_next) {
7568 oldop->op_next = o->op_next;
7576 if (oldop && o->op_next) {
7577 oldop->op_next = o->op_next;
7585 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
7586 OP* const pop = (o->op_type == OP_PADAV) ?
7587 o->op_next : o->op_next->op_next;
7589 if (pop && pop->op_type == OP_CONST &&
7590 ((PL_op = pop->op_next)) &&
7591 pop->op_next->op_type == OP_AELEM &&
7592 !(pop->op_next->op_private &
7593 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
7594 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
7599 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
7600 no_bareword_allowed(pop);
7601 if (o->op_type == OP_GV)
7602 op_null(o->op_next);
7603 op_null(pop->op_next);
7605 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
7606 o->op_next = pop->op_next->op_next;
7607 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
7608 o->op_private = (U8)i;
7609 if (o->op_type == OP_GV) {
7614 o->op_flags |= OPf_SPECIAL;
7615 o->op_type = OP_AELEMFAST;
7621 if (o->op_next->op_type == OP_RV2SV) {
7622 if (!(o->op_next->op_private & OPpDEREF)) {
7623 op_null(o->op_next);
7624 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
7626 o->op_next = o->op_next->op_next;
7627 o->op_type = OP_GVSV;
7628 o->op_ppaddr = PL_ppaddr[OP_GVSV];
7631 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
7632 GV * const gv = cGVOPo_gv;
7633 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
7634 /* XXX could check prototype here instead of just carping */
7635 SV * const sv = sv_newmortal();
7636 gv_efullname3(sv, gv, NULL);
7637 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
7638 "%"SVf"() called too early to check prototype",
7642 else if (o->op_next->op_type == OP_READLINE
7643 && o->op_next->op_next->op_type == OP_CONCAT
7644 && (o->op_next->op_next->op_flags & OPf_STACKED))
7646 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
7647 o->op_type = OP_RCATLINE;
7648 o->op_flags |= OPf_STACKED;
7649 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
7650 op_null(o->op_next->op_next);
7651 op_null(o->op_next);
7668 while (cLOGOP->op_other->op_type == OP_NULL)
7669 cLOGOP->op_other = cLOGOP->op_other->op_next;
7670 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
7676 while (cLOOP->op_redoop->op_type == OP_NULL)
7677 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
7678 peep(cLOOP->op_redoop);
7679 while (cLOOP->op_nextop->op_type == OP_NULL)
7680 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
7681 peep(cLOOP->op_nextop);
7682 while (cLOOP->op_lastop->op_type == OP_NULL)
7683 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
7684 peep(cLOOP->op_lastop);
7691 while (cPMOP->op_pmreplstart &&
7692 cPMOP->op_pmreplstart->op_type == OP_NULL)
7693 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
7694 peep(cPMOP->op_pmreplstart);
7699 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
7700 && ckWARN(WARN_SYNTAX))
7702 if (o->op_next->op_sibling &&
7703 o->op_next->op_sibling->op_type != OP_EXIT &&
7704 o->op_next->op_sibling->op_type != OP_WARN &&
7705 o->op_next->op_sibling->op_type != OP_DIE) {
7706 const line_t oldline = CopLINE(PL_curcop);
7708 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
7709 Perl_warner(aTHX_ packWARN(WARN_EXEC),
7710 "Statement unlikely to be reached");
7711 Perl_warner(aTHX_ packWARN(WARN_EXEC),
7712 "\t(Maybe you meant system() when you said exec()?)\n");
7713 CopLINE_set(PL_curcop, oldline);
7723 const char *key = NULL;
7728 if (((BINOP*)o)->op_last->op_type != OP_CONST)
7731 /* Make the CONST have a shared SV */
7732 svp = cSVOPx_svp(((BINOP*)o)->op_last);
7733 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
7734 key = SvPV_const(sv, keylen);
7735 lexname = newSVpvn_share(key,
7736 SvUTF8(sv) ? -(I32)keylen : keylen,
7742 if ((o->op_private & (OPpLVAL_INTRO)))
7745 rop = (UNOP*)((BINOP*)o)->op_first;
7746 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7748 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7749 if (!SvPAD_TYPED(lexname))
7751 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
7752 if (!fields || !GvHV(*fields))
7754 key = SvPV_const(*svp, keylen);
7755 if (!hv_fetch(GvHV(*fields), key,
7756 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
7758 Perl_croak(aTHX_ "No such class field \"%s\" "
7759 "in variable %s of type %s",
7760 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
7773 SVOP *first_key_op, *key_op;
7775 if ((o->op_private & (OPpLVAL_INTRO))
7776 /* I bet there's always a pushmark... */
7777 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
7778 /* hmmm, no optimization if list contains only one key. */
7780 rop = (UNOP*)((LISTOP*)o)->op_last;
7781 if (rop->op_type != OP_RV2HV)
7783 if (rop->op_first->op_type == OP_PADSV)
7784 /* @$hash{qw(keys here)} */
7785 rop = (UNOP*)rop->op_first;
7787 /* @{$hash}{qw(keys here)} */
7788 if (rop->op_first->op_type == OP_SCOPE
7789 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
7791 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
7797 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
7798 if (!SvPAD_TYPED(lexname))
7800 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
7801 if (!fields || !GvHV(*fields))
7803 /* Again guessing that the pushmark can be jumped over.... */
7804 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
7805 ->op_first->op_sibling;
7806 for (key_op = first_key_op; key_op;
7807 key_op = (SVOP*)key_op->op_sibling) {
7808 if (key_op->op_type != OP_CONST)
7810 svp = cSVOPx_svp(key_op);
7811 key = SvPV_const(*svp, keylen);
7812 if (!hv_fetch(GvHV(*fields), key,
7813 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
7815 Perl_croak(aTHX_ "No such class field \"%s\" "
7816 "in variable %s of type %s",
7817 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
7824 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
7828 /* check that RHS of sort is a single plain array */
7829 OP *oright = cUNOPo->op_first;
7830 if (!oright || oright->op_type != OP_PUSHMARK)
7833 /* reverse sort ... can be optimised. */
7834 if (!cUNOPo->op_sibling) {
7835 /* Nothing follows us on the list. */
7836 OP * const reverse = o->op_next;
7838 if (reverse->op_type == OP_REVERSE &&
7839 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
7840 OP * const pushmark = cUNOPx(reverse)->op_first;
7841 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
7842 && (cUNOPx(pushmark)->op_sibling == o)) {
7843 /* reverse -> pushmark -> sort */
7844 o->op_private |= OPpSORT_REVERSE;
7846 pushmark->op_next = oright->op_next;
7852 /* make @a = sort @a act in-place */
7856 oright = cUNOPx(oright)->op_sibling;
7859 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
7860 oright = cUNOPx(oright)->op_sibling;
7864 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
7865 || oright->op_next != o
7866 || (oright->op_private & OPpLVAL_INTRO)
7870 /* o2 follows the chain of op_nexts through the LHS of the
7871 * assign (if any) to the aassign op itself */
7873 if (!o2 || o2->op_type != OP_NULL)
7876 if (!o2 || o2->op_type != OP_PUSHMARK)
7879 if (o2 && o2->op_type == OP_GV)
7882 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
7883 || (o2->op_private & OPpLVAL_INTRO)
7888 if (!o2 || o2->op_type != OP_NULL)
7891 if (!o2 || o2->op_type != OP_AASSIGN
7892 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
7895 /* check that the sort is the first arg on RHS of assign */
7897 o2 = cUNOPx(o2)->op_first;
7898 if (!o2 || o2->op_type != OP_NULL)
7900 o2 = cUNOPx(o2)->op_first;
7901 if (!o2 || o2->op_type != OP_PUSHMARK)
7903 if (o2->op_sibling != o)
7906 /* check the array is the same on both sides */
7907 if (oleft->op_type == OP_RV2AV) {
7908 if (oright->op_type != OP_RV2AV
7909 || !cUNOPx(oright)->op_first
7910 || cUNOPx(oright)->op_first->op_type != OP_GV
7911 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
7912 cGVOPx_gv(cUNOPx(oright)->op_first)
7916 else if (oright->op_type != OP_PADAV
7917 || oright->op_targ != oleft->op_targ
7921 /* transfer MODishness etc from LHS arg to RHS arg */
7922 oright->op_flags = oleft->op_flags;
7923 o->op_private |= OPpSORT_INPLACE;
7925 /* excise push->gv->rv2av->null->aassign */
7926 o2 = o->op_next->op_next;
7927 op_null(o2); /* PUSHMARK */
7929 if (o2->op_type == OP_GV) {
7930 op_null(o2); /* GV */
7933 op_null(o2); /* RV2AV or PADAV */
7934 o2 = o2->op_next->op_next;
7935 op_null(o2); /* AASSIGN */
7937 o->op_next = o2->op_next;
7943 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
7945 LISTOP *enter, *exlist;
7948 enter = (LISTOP *) o->op_next;
7951 if (enter->op_type == OP_NULL) {
7952 enter = (LISTOP *) enter->op_next;
7956 /* for $a (...) will have OP_GV then OP_RV2GV here.
7957 for (...) just has an OP_GV. */
7958 if (enter->op_type == OP_GV) {
7959 gvop = (OP *) enter;
7960 enter = (LISTOP *) enter->op_next;
7963 if (enter->op_type == OP_RV2GV) {
7964 enter = (LISTOP *) enter->op_next;
7970 if (enter->op_type != OP_ENTERITER)
7973 iter = enter->op_next;
7974 if (!iter || iter->op_type != OP_ITER)
7977 expushmark = enter->op_first;
7978 if (!expushmark || expushmark->op_type != OP_NULL
7979 || expushmark->op_targ != OP_PUSHMARK)
7982 exlist = (LISTOP *) expushmark->op_sibling;
7983 if (!exlist || exlist->op_type != OP_NULL
7984 || exlist->op_targ != OP_LIST)
7987 if (exlist->op_last != o) {
7988 /* Mmm. Was expecting to point back to this op. */
7991 theirmark = exlist->op_first;
7992 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
7995 if (theirmark->op_sibling != o) {
7996 /* There's something between the mark and the reverse, eg
7997 for (1, reverse (...))
8002 ourmark = ((LISTOP *)o)->op_first;
8003 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
8006 ourlast = ((LISTOP *)o)->op_last;
8007 if (!ourlast || ourlast->op_next != o)
8010 rv2av = ourmark->op_sibling;
8011 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
8012 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
8013 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
8014 /* We're just reversing a single array. */
8015 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
8016 enter->op_flags |= OPf_STACKED;
8019 /* We don't have control over who points to theirmark, so sacrifice
8021 theirmark->op_next = ourmark->op_next;
8022 theirmark->op_flags = ourmark->op_flags;
8023 ourlast->op_next = gvop ? gvop : (OP *) enter;
8026 enter->op_private |= OPpITER_REVERSED;
8027 iter->op_private |= OPpITER_REVERSED;
8034 UNOP *refgen, *rv2cv;
8037 /* I do not understand this, but if o->op_opt isn't set to 1,
8038 various tests in ext/B/t/bytecode.t fail with no readily
8044 if ((o->op_flags && OPf_WANT) != OPf_WANT_VOID)
8047 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
8050 rv2gv = ((BINOP *)o)->op_last;
8051 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
8054 refgen = (UNOP *)((BINOP *)o)->op_first;
8056 if (!refgen || refgen->op_type != OP_REFGEN)
8059 exlist = (LISTOP *)refgen->op_first;
8060 if (!exlist || exlist->op_type != OP_NULL
8061 || exlist->op_targ != OP_LIST)
8064 if (exlist->op_first->op_type != OP_PUSHMARK)
8067 rv2cv = (UNOP*)exlist->op_last;
8069 if (rv2cv->op_type != OP_RV2CV)
8072 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
8073 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
8074 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
8076 o->op_private |= OPpASSIGN_CV_TO_GV;
8077 rv2gv->op_private |= OPpDONT_INIT_GV;
8078 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
8094 Perl_custom_op_name(pTHX_ const OP* o)
8097 const IV index = PTR2IV(o->op_ppaddr);
8101 if (!PL_custom_op_names) /* This probably shouldn't happen */
8102 return (char *)PL_op_name[OP_CUSTOM];
8104 keysv = sv_2mortal(newSViv(index));
8106 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
8108 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
8110 return SvPV_nolen(HeVAL(he));
8114 Perl_custom_op_desc(pTHX_ const OP* o)
8117 const IV index = PTR2IV(o->op_ppaddr);
8121 if (!PL_custom_op_descs)
8122 return (char *)PL_op_desc[OP_CUSTOM];
8124 keysv = sv_2mortal(newSViv(index));
8126 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
8128 return (char *)PL_op_desc[OP_CUSTOM];
8130 return SvPV_nolen(HeVAL(he));
8135 /* Efficient sub that returns a constant scalar value. */
8137 const_sv_xsub(pTHX_ CV* cv)
8144 Perl_croak(aTHX_ "usage: %s::%s()",
8145 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
8149 ST(0) = (SV*)XSANY.any_ptr;
8155 * c-indentation-style: bsd
8157 * indent-tabs-mode: t
8160 * ex: set ts=8 sts=4 sw=4 noet: