3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * "You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
13 * our Mr. Bilbo's first cousin on the mother's side (her mother being the
14 * youngest of the Old Took's daughters); and Mr. Drogo was his second
15 * cousin. So Mr. Frodo is his first *and* second cousin, once removed
16 * either way, as the saying is, if you follow me." --the Gaffer
19 /* This file contains the functions that create, manipulate and optimize
20 * the OP structures that hold a compiled perl program.
22 * A Perl program is compiled into a tree of OPs. Each op contains
23 * structural pointers (eg to its siblings and the next op in the
24 * execution sequence), a pointer to the function that would execute the
25 * op, plus any data specific to that op. For example, an OP_CONST op
26 * points to the pp_const() function and to an SV containing the constant
27 * value. When pp_const() is executed, its job is to push that SV onto the
30 * OPs are mainly created by the newFOO() functions, which are mainly
31 * called from the parser (in perly.y) as the code is parsed. For example
32 * the Perl code $a + $b * $c would cause the equivalent of the following
33 * to be called (oversimplifying a bit):
35 * newBINOP(OP_ADD, flags,
37 * newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
40 * Note that during the build of miniperl, a temporary copy of this file
41 * is made, called opmini.c.
45 Perl's compiler is essentially a 3-pass compiler with interleaved phases:
49 An execution-order pass
51 The bottom-up pass is represented by all the "newOP" routines and
52 the ck_ routines. The bottom-upness is actually driven by yacc.
53 So at the point that a ck_ routine fires, we have no idea what the
54 context is, either upward in the syntax tree, or either forward or
55 backward in the execution order. (The bottom-up parser builds that
56 part of the execution order it knows about, but if you follow the "next"
57 links around, you'll find it's actually a closed loop through the
60 Whenever the bottom-up parser gets to a node that supplies context to
61 its components, it invokes that portion of the top-down pass that applies
62 to that part of the subtree (and marks the top node as processed, so
63 if a node further up supplies context, it doesn't have to take the
64 plunge again). As a particular subcase of this, as the new node is
65 built, it takes all the closed execution loops of its subcomponents
66 and links them into a new closed loop for the higher level node. But
67 it's still not the real execution order.
69 The actual execution order is not known till we get a grammar reduction
70 to a top-level unit like a subroutine or file that will be called by
71 "name" rather than via a "next" pointer. At that point, we can call
72 into peep() to do that code's portion of the 3rd pass. It has to be
73 recursive, but it's recursive on basic blocks, not on tree nodes.
81 #define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
83 #if defined(PL_OP_SLAB_ALLOC)
85 #ifndef PERL_SLAB_SIZE
86 #define PERL_SLAB_SIZE 2048
90 Perl_Slab_Alloc(pTHX_ int m, size_t sz)
93 * To make incrementing use count easy PL_OpSlab is an I32 *
94 * To make inserting the link to slab PL_OpPtr is I32 **
95 * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
96 * Add an overhead for pointer to slab and round up as a number of pointers
98 sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
99 if ((PL_OpSpace -= sz) < 0) {
100 PL_OpPtr = (I32 **) PerlMemShared_malloc(PERL_SLAB_SIZE*sizeof(I32*));
104 Zero(PL_OpPtr,PERL_SLAB_SIZE,I32 **);
105 /* We reserve the 0'th I32 sized chunk as a use count */
106 PL_OpSlab = (I32 *) PL_OpPtr;
107 /* Reduce size by the use count word, and by the size we need.
108 * Latter is to mimic the '-=' in the if() above
110 PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
111 /* Allocation pointer starts at the top.
112 Theory: because we build leaves before trunk allocating at end
113 means that at run time access is cache friendly upward
115 PL_OpPtr += PERL_SLAB_SIZE;
117 assert( PL_OpSpace >= 0 );
118 /* Move the allocation pointer down */
120 assert( PL_OpPtr > (I32 **) PL_OpSlab );
121 *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */
122 (*PL_OpSlab)++; /* Increment use count of slab */
123 assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
124 assert( *PL_OpSlab > 0 );
125 return (void *)(PL_OpPtr + 1);
129 Perl_Slab_Free(pTHX_ void *op)
131 I32 * const * const ptr = (I32 **) op;
132 I32 * const slab = ptr[-1];
133 assert( ptr-1 > (I32 **) slab );
134 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
136 if (--(*slab) == 0) {
138 # define PerlMemShared PerlMem
141 PerlMemShared_free(slab);
142 if (slab == PL_OpSlab) {
149 * In the following definition, the ", (OP*)0" is just to make the compiler
150 * think the expression is of the right type: croak actually does a Siglongjmp.
152 #define CHECKOP(type,o) \
153 ((PL_op_mask && PL_op_mask[type]) \
154 ? ( op_free((OP*)o), \
155 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
157 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
159 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
162 S_gv_ename(pTHX_ GV *gv)
164 SV* const tmpsv = sv_newmortal();
165 gv_efullname3(tmpsv, gv, NULL);
166 return SvPV_nolen_const(tmpsv);
170 S_no_fh_allowed(pTHX_ OP *o)
172 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
178 S_too_few_arguments(pTHX_ OP *o, const char *name)
180 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
185 S_too_many_arguments(pTHX_ OP *o, const char *name)
187 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
192 S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid)
194 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
195 (int)n, name, t, OP_DESC(kid)));
199 S_no_bareword_allowed(pTHX_ const OP *o)
202 return; /* various ok barewords are hidden in extra OP_NULL */
203 qerror(Perl_mess(aTHX_
204 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
208 /* "register" allocation */
211 Perl_allocmy(pTHX_ char *name)
215 const bool is_our = (PL_in_my == KEY_our);
217 /* complain about "my $<special_var>" etc etc */
221 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
222 (name[1] == '_' && (*name == '$' || name[2]))))
224 /* name[2] is true if strlen(name) > 2 */
225 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
226 /* 1999-02-27 mjd@plover.com */
228 p = strchr(name, '\0');
229 /* The next block assumes the buffer is at least 205 chars
230 long. At present, it's always at least 256 chars. */
232 strcpy(name+200, "...");
238 /* Move everything else down one character */
239 for (; p-name > 2; p--)
241 name[2] = toCTRL(name[1]);
244 yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
247 /* check for duplicate declaration */
248 pad_check_dup(name, is_our, (PL_curstash ? PL_curstash : PL_defstash));
250 if (PL_in_my_stash && *name != '$') {
251 yyerror(Perl_form(aTHX_
252 "Can't declare class for non-scalar %s in \"%s\"",
253 name, is_our ? "our" : "my"));
256 /* allocate a spare slot and store the name in that slot */
258 off = pad_add_name(name,
261 /* $_ is always in main::, even with our */
262 ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
273 Perl_op_free(pTHX_ OP *o)
278 if (!o || o->op_static)
282 if (o->op_private & OPpREFCOUNTED) {
293 refcnt = OpREFCNT_dec(o);
304 if (o->op_flags & OPf_KIDS) {
305 register OP *kid, *nextkid;
306 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
307 nextkid = kid->op_sibling; /* Get before next freeing kid */
312 type = (OPCODE)o->op_targ;
314 /* COP* is not cleared by op_clear() so that we may track line
315 * numbers etc even after null() */
316 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
321 #ifdef DEBUG_LEAKING_SCALARS
328 Perl_op_clear(pTHX_ OP *o)
333 /* if (o->op_madprop && o->op_madprop->mad_next)
335 /* FIXME for MAD - if I uncomment these two lines t/op/pack.t fails with
336 "modification of a read only value" for a reason I can't fathom why.
337 It's the "" stringification of $_, where $_ was set to '' in a foreach
338 loop, but it defies simplification into a small test case.
339 However, commenting them out has caused ext/List/Util/t/weak.t to fail
342 mad_free(o->op_madprop);
348 switch (o->op_type) {
349 case OP_NULL: /* Was holding old type, if any. */
350 if (PL_madskills && o->op_targ != OP_NULL) {
351 o->op_type = o->op_targ;
355 case OP_ENTEREVAL: /* Was holding hints. */
359 if (!(o->op_flags & OPf_REF)
360 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
366 if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
367 /* not an OP_PADAV replacement */
369 if (cPADOPo->op_padix > 0) {
370 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
371 * may still exist on the pad */
372 pad_swipe(cPADOPo->op_padix, TRUE);
373 cPADOPo->op_padix = 0;
376 SvREFCNT_dec(cSVOPo->op_sv);
377 cSVOPo->op_sv = NULL;
381 case OP_METHOD_NAMED:
383 SvREFCNT_dec(cSVOPo->op_sv);
384 cSVOPo->op_sv = NULL;
387 Even if op_clear does a pad_free for the target of the op,
388 pad_free doesn't actually remove the sv that exists in the pad;
389 instead it lives on. This results in that it could be reused as
390 a target later on when the pad was reallocated.
393 pad_swipe(o->op_targ,1);
402 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
406 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
407 SvREFCNT_dec(cSVOPo->op_sv);
408 cSVOPo->op_sv = NULL;
411 Safefree(cPVOPo->op_pv);
412 cPVOPo->op_pv = NULL;
416 op_free(cPMOPo->op_pmreplroot);
420 if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) {
421 /* No GvIN_PAD_off here, because other references may still
422 * exist on the pad */
423 pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot), TRUE);
426 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
433 HV * const pmstash = PmopSTASH(cPMOPo);
434 if (pmstash && !SvIS_FREED(pmstash)) {
435 MAGIC * const mg = mg_find((SV*)pmstash, PERL_MAGIC_symtab);
437 PMOP *pmop = (PMOP*) mg->mg_obj;
438 PMOP *lastpmop = NULL;
440 if (cPMOPo == pmop) {
442 lastpmop->op_pmnext = pmop->op_pmnext;
444 mg->mg_obj = (SV*) pmop->op_pmnext;
448 pmop = pmop->op_pmnext;
452 PmopSTASH_free(cPMOPo);
454 cPMOPo->op_pmreplroot = NULL;
455 /* we use the "SAFE" version of the PM_ macros here
456 * since sv_clean_all might release some PMOPs
457 * after PL_regex_padav has been cleared
458 * and the clearing of PL_regex_padav needs to
459 * happen before sv_clean_all
461 ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
462 PM_SETRE_SAFE(cPMOPo, NULL);
464 if(PL_regex_pad) { /* We could be in destruction */
465 av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
466 SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
467 PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
474 if (o->op_targ > 0) {
475 pad_free(o->op_targ);
481 S_cop_free(pTHX_ COP* cop)
483 Safefree(cop->cop_label); /* FIXME: treaddead ??? */
486 if (! specialWARN(cop->cop_warnings))
487 SvREFCNT_dec(cop->cop_warnings);
488 if (! specialCopIO(cop->cop_io)) {
492 SvREFCNT_dec(cop->cop_io);
498 Perl_op_null(pTHX_ OP *o)
501 if (o->op_type == OP_NULL)
505 o->op_targ = o->op_type;
506 o->op_type = OP_NULL;
507 o->op_ppaddr = PL_ppaddr[OP_NULL];
511 Perl_op_refcnt_lock(pTHX)
519 Perl_op_refcnt_unlock(pTHX)
526 /* Contextualizers */
528 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
531 Perl_linklist(pTHX_ OP *o)
538 /* establish postfix order */
539 first = cUNOPo->op_first;
542 o->op_next = LINKLIST(first);
545 if (kid->op_sibling) {
546 kid->op_next = LINKLIST(kid->op_sibling);
547 kid = kid->op_sibling;
561 Perl_scalarkids(pTHX_ OP *o)
563 if (o && o->op_flags & OPf_KIDS) {
565 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
572 S_scalarboolean(pTHX_ OP *o)
575 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
576 if (ckWARN(WARN_SYNTAX)) {
577 const line_t oldline = CopLINE(PL_curcop);
579 if (PL_copline != NOLINE)
580 CopLINE_set(PL_curcop, PL_copline);
581 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
582 CopLINE_set(PL_curcop, oldline);
589 Perl_scalar(pTHX_ OP *o)
594 /* assumes no premature commitment */
595 if (!o || PL_error_count || (o->op_flags & OPf_WANT)
596 || o->op_type == OP_RETURN)
601 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
603 switch (o->op_type) {
605 scalar(cBINOPo->op_first);
610 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
614 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
615 if (!kPMOP->op_pmreplroot)
616 deprecate_old("implicit split to @_");
624 if (o->op_flags & OPf_KIDS) {
625 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
631 kid = cLISTOPo->op_first;
633 while ((kid = kid->op_sibling)) {
639 WITH_THR(PL_curcop = &PL_compiling);
644 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
650 WITH_THR(PL_curcop = &PL_compiling);
653 if (ckWARN(WARN_VOID))
654 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
660 Perl_scalarvoid(pTHX_ OP *o)
664 const char* useless = NULL;
668 /* trailing mad null ops don't count as "there" for void processing */
670 o->op_type != OP_NULL &&
672 o->op_sibling->op_type == OP_NULL)
675 for (sib = o->op_sibling;
676 sib && sib->op_type == OP_NULL;
677 sib = sib->op_sibling) ;
683 if (o->op_type == OP_NEXTSTATE
684 || o->op_type == OP_SETSTATE
685 || o->op_type == OP_DBSTATE
686 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
687 || o->op_targ == OP_SETSTATE
688 || o->op_targ == OP_DBSTATE)))
689 PL_curcop = (COP*)o; /* for warning below */
691 /* assumes no premature commitment */
692 want = o->op_flags & OPf_WANT;
693 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
694 || o->op_type == OP_RETURN)
699 if ((o->op_private & OPpTARGET_MY)
700 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
702 return scalar(o); /* As if inside SASSIGN */
705 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
707 switch (o->op_type) {
709 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
713 if (o->op_flags & OPf_STACKED)
717 if (o->op_private == 4)
789 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
790 useless = OP_DESC(o);
794 kid = cUNOPo->op_first;
795 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
796 kid->op_type != OP_TRANS) {
799 useless = "negative pattern binding (!~)";
806 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
807 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
808 useless = "a variable";
813 if (cSVOPo->op_private & OPpCONST_STRICT)
814 no_bareword_allowed(o);
816 if (ckWARN(WARN_VOID)) {
817 useless = "a constant";
818 if (o->op_private & OPpCONST_ARYBASE)
820 /* don't warn on optimised away booleans, eg
821 * use constant Foo, 5; Foo || print; */
822 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
824 /* the constants 0 and 1 are permitted as they are
825 conventionally used as dummies in constructs like
826 1 while some_condition_with_side_effects; */
827 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
829 else if (SvPOK(sv)) {
830 /* perl4's way of mixing documentation and code
831 (before the invention of POD) was based on a
832 trick to mix nroff and perl code. The trick was
833 built upon these three nroff macros being used in
834 void context. The pink camel has the details in
835 the script wrapman near page 319. */
836 const char * const maybe_macro = SvPVX_const(sv);
837 if (strnEQ(maybe_macro, "di", 2) ||
838 strnEQ(maybe_macro, "ds", 2) ||
839 strnEQ(maybe_macro, "ig", 2))
844 op_null(o); /* don't execute or even remember it */
848 o->op_type = OP_PREINC; /* pre-increment is faster */
849 o->op_ppaddr = PL_ppaddr[OP_PREINC];
853 o->op_type = OP_PREDEC; /* pre-decrement is faster */
854 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
858 o->op_type = OP_I_PREINC; /* pre-increment is faster */
859 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
863 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
864 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
873 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
878 if (o->op_flags & OPf_STACKED)
885 if (!(o->op_flags & OPf_KIDS))
896 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
903 /* all requires must return a boolean value */
904 o->op_flags &= ~OPf_WANT;
909 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
910 if (!kPMOP->op_pmreplroot)
911 deprecate_old("implicit split to @_");
915 if (useless && ckWARN(WARN_VOID))
916 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
921 Perl_listkids(pTHX_ OP *o)
923 if (o && o->op_flags & OPf_KIDS) {
925 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
932 Perl_list(pTHX_ OP *o)
937 /* assumes no premature commitment */
938 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
939 || o->op_type == OP_RETURN)
944 if ((o->op_private & OPpTARGET_MY)
945 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
947 return o; /* As if inside SASSIGN */
950 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
952 switch (o->op_type) {
955 list(cBINOPo->op_first);
960 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
968 if (!(o->op_flags & OPf_KIDS))
970 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
971 list(cBINOPo->op_first);
972 return gen_constant_list(o);
979 kid = cLISTOPo->op_first;
981 while ((kid = kid->op_sibling)) {
987 WITH_THR(PL_curcop = &PL_compiling);
991 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
997 WITH_THR(PL_curcop = &PL_compiling);
1000 /* all requires must return a boolean value */
1001 o->op_flags &= ~OPf_WANT;
1008 Perl_scalarseq(pTHX_ OP *o)
1012 if (o->op_type == OP_LINESEQ ||
1013 o->op_type == OP_SCOPE ||
1014 o->op_type == OP_LEAVE ||
1015 o->op_type == OP_LEAVETRY)
1018 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1019 if (kid->op_sibling) {
1023 PL_curcop = &PL_compiling;
1025 o->op_flags &= ~OPf_PARENS;
1026 if (PL_hints & HINT_BLOCK_SCOPE)
1027 o->op_flags |= OPf_PARENS;
1030 o = newOP(OP_STUB, 0);
1035 S_modkids(pTHX_ OP *o, I32 type)
1037 if (o && o->op_flags & OPf_KIDS) {
1039 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1045 /* Propagate lvalue ("modifiable") context to an op and its children.
1046 * 'type' represents the context type, roughly based on the type of op that
1047 * would do the modifying, although local() is represented by OP_NULL.
1048 * It's responsible for detecting things that can't be modified, flag
1049 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
1050 * might have to vivify a reference in $x), and so on.
1052 * For example, "$a+1 = 2" would cause mod() to be called with o being
1053 * OP_ADD and type being OP_SASSIGN, and would output an error.
1057 Perl_mod(pTHX_ OP *o, I32 type)
1061 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1064 if (!o || PL_error_count)
1067 if ((o->op_private & OPpTARGET_MY)
1068 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1073 switch (o->op_type) {
1079 if (!(o->op_private & OPpCONST_ARYBASE))
1082 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1083 PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
1087 SAVEI32(PL_compiling.cop_arybase);
1088 PL_compiling.cop_arybase = 0;
1090 else if (type == OP_REFGEN)
1093 Perl_croak(aTHX_ "That use of $[ is unsupported");
1096 if (o->op_flags & OPf_PARENS || PL_madskills)
1100 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1101 !(o->op_flags & OPf_STACKED)) {
1102 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1103 /* The default is to set op_private to the number of children,
1104 which for a UNOP such as RV2CV is always 1. And w're using
1105 the bit for a flag in RV2CV, so we need it clear. */
1106 o->op_private &= ~1;
1107 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1108 assert(cUNOPo->op_first->op_type == OP_NULL);
1109 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1112 else if (o->op_private & OPpENTERSUB_NOMOD)
1114 else { /* lvalue subroutine call */
1115 o->op_private |= OPpLVAL_INTRO;
1116 PL_modcount = RETURN_UNLIMITED_NUMBER;
1117 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1118 /* Backward compatibility mode: */
1119 o->op_private |= OPpENTERSUB_INARGS;
1122 else { /* Compile-time error message: */
1123 OP *kid = cUNOPo->op_first;
1127 if (kid->op_type == OP_PUSHMARK)
1129 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1131 "panic: unexpected lvalue entersub "
1132 "args: type/targ %ld:%"UVuf,
1133 (long)kid->op_type, (UV)kid->op_targ);
1134 kid = kLISTOP->op_first;
1136 while (kid->op_sibling)
1137 kid = kid->op_sibling;
1138 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1140 if (kid->op_type == OP_METHOD_NAMED
1141 || kid->op_type == OP_METHOD)
1145 NewOp(1101, newop, 1, UNOP);
1146 newop->op_type = OP_RV2CV;
1147 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1148 newop->op_first = NULL;
1149 newop->op_next = (OP*)newop;
1150 kid->op_sibling = (OP*)newop;
1151 newop->op_private |= OPpLVAL_INTRO;
1152 newop->op_private &= ~1;
1156 if (kid->op_type != OP_RV2CV)
1158 "panic: unexpected lvalue entersub "
1159 "entry via type/targ %ld:%"UVuf,
1160 (long)kid->op_type, (UV)kid->op_targ);
1161 kid->op_private |= OPpLVAL_INTRO;
1162 break; /* Postpone until runtime */
1166 kid = kUNOP->op_first;
1167 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1168 kid = kUNOP->op_first;
1169 if (kid->op_type == OP_NULL)
1171 "Unexpected constant lvalue entersub "
1172 "entry via type/targ %ld:%"UVuf,
1173 (long)kid->op_type, (UV)kid->op_targ);
1174 if (kid->op_type != OP_GV) {
1175 /* Restore RV2CV to check lvalueness */
1177 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1178 okid->op_next = kid->op_next;
1179 kid->op_next = okid;
1182 okid->op_next = NULL;
1183 okid->op_type = OP_RV2CV;
1185 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1186 okid->op_private |= OPpLVAL_INTRO;
1187 okid->op_private &= ~1;
1191 cv = GvCV(kGVOP_gv);
1201 /* grep, foreach, subcalls, refgen */
1202 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1204 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1205 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1207 : (o->op_type == OP_ENTERSUB
1208 ? "non-lvalue subroutine call"
1210 type ? PL_op_desc[type] : "local"));
1224 case OP_RIGHT_SHIFT:
1233 if (!(o->op_flags & OPf_STACKED))
1240 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1246 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1247 PL_modcount = RETURN_UNLIMITED_NUMBER;
1248 return o; /* Treat \(@foo) like ordinary list. */
1252 if (scalar_mod_type(o, type))
1254 ref(cUNOPo->op_first, o->op_type);
1258 if (type == OP_LEAVESUBLV)
1259 o->op_private |= OPpMAYBE_LVSUB;
1265 PL_modcount = RETURN_UNLIMITED_NUMBER;
1268 ref(cUNOPo->op_first, o->op_type);
1273 PL_hints |= HINT_BLOCK_SCOPE;
1288 PL_modcount = RETURN_UNLIMITED_NUMBER;
1289 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1290 return o; /* Treat \(@foo) like ordinary list. */
1291 if (scalar_mod_type(o, type))
1293 if (type == OP_LEAVESUBLV)
1294 o->op_private |= OPpMAYBE_LVSUB;
1298 if (!type) /* local() */
1299 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1300 PAD_COMPNAME_PV(o->op_targ));
1308 if (type != OP_SASSIGN)
1312 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1317 if (type == OP_LEAVESUBLV)
1318 o->op_private |= OPpMAYBE_LVSUB;
1320 pad_free(o->op_targ);
1321 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1322 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1323 if (o->op_flags & OPf_KIDS)
1324 mod(cBINOPo->op_first->op_sibling, type);
1329 ref(cBINOPo->op_first, o->op_type);
1330 if (type == OP_ENTERSUB &&
1331 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1332 o->op_private |= OPpLVAL_DEFER;
1333 if (type == OP_LEAVESUBLV)
1334 o->op_private |= OPpMAYBE_LVSUB;
1344 if (o->op_flags & OPf_KIDS)
1345 mod(cLISTOPo->op_last, type);
1350 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1352 else if (!(o->op_flags & OPf_KIDS))
1354 if (o->op_targ != OP_LIST) {
1355 mod(cBINOPo->op_first, type);
1361 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1366 if (type != OP_LEAVESUBLV)
1368 break; /* mod()ing was handled by ck_return() */
1371 /* [20011101.069] File test operators interpret OPf_REF to mean that
1372 their argument is a filehandle; thus \stat(".") should not set
1374 if (type == OP_REFGEN &&
1375 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1378 if (type != OP_LEAVESUBLV)
1379 o->op_flags |= OPf_MOD;
1381 if (type == OP_AASSIGN || type == OP_SASSIGN)
1382 o->op_flags |= OPf_SPECIAL|OPf_REF;
1383 else if (!type) { /* local() */
1386 o->op_private |= OPpLVAL_INTRO;
1387 o->op_flags &= ~OPf_SPECIAL;
1388 PL_hints |= HINT_BLOCK_SCOPE;
1393 if (ckWARN(WARN_SYNTAX)) {
1394 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1395 "Useless localization of %s", OP_DESC(o));
1399 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1400 && type != OP_LEAVESUBLV)
1401 o->op_flags |= OPf_REF;
1406 S_scalar_mod_type(const OP *o, I32 type)
1410 if (o->op_type == OP_RV2GV)
1434 case OP_RIGHT_SHIFT:
1453 S_is_handle_constructor(const OP *o, I32 numargs)
1455 switch (o->op_type) {
1463 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1476 Perl_refkids(pTHX_ OP *o, I32 type)
1478 if (o && o->op_flags & OPf_KIDS) {
1480 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1487 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
1492 if (!o || PL_error_count)
1495 switch (o->op_type) {
1497 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1498 !(o->op_flags & OPf_STACKED)) {
1499 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1500 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1501 assert(cUNOPo->op_first->op_type == OP_NULL);
1502 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1503 o->op_flags |= OPf_SPECIAL;
1504 o->op_private &= ~1;
1509 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1510 doref(kid, type, set_op_ref);
1513 if (type == OP_DEFINED)
1514 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1515 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1518 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1519 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1520 : type == OP_RV2HV ? OPpDEREF_HV
1522 o->op_flags |= OPf_MOD;
1527 o->op_flags |= OPf_MOD; /* XXX ??? */
1533 o->op_flags |= OPf_REF;
1536 if (type == OP_DEFINED)
1537 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1538 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1544 o->op_flags |= OPf_REF;
1549 if (!(o->op_flags & OPf_KIDS))
1551 doref(cBINOPo->op_first, type, set_op_ref);
1555 doref(cBINOPo->op_first, o->op_type, set_op_ref);
1556 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1557 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1558 : type == OP_RV2HV ? OPpDEREF_HV
1560 o->op_flags |= OPf_MOD;
1570 if (!(o->op_flags & OPf_KIDS))
1572 doref(cLISTOPo->op_last, type, set_op_ref);
1582 S_dup_attrlist(pTHX_ OP *o)
1587 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1588 * where the first kid is OP_PUSHMARK and the remaining ones
1589 * are OP_CONST. We need to push the OP_CONST values.
1591 if (o->op_type == OP_CONST)
1592 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
1594 else if (o->op_type == OP_NULL)
1598 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1600 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1601 if (o->op_type == OP_CONST)
1602 rop = append_elem(OP_LIST, rop,
1603 newSVOP(OP_CONST, o->op_flags,
1604 SvREFCNT_inc_NN(cSVOPo->op_sv)));
1611 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1616 /* fake up C<use attributes $pkg,$rv,@attrs> */
1617 ENTER; /* need to protect against side-effects of 'use' */
1619 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1621 #define ATTRSMODULE "attributes"
1622 #define ATTRSMODULE_PM "attributes.pm"
1625 /* Don't force the C<use> if we don't need it. */
1626 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
1627 if (svp && *svp != &PL_sv_undef)
1628 /*EMPTY*/; /* already in %INC */
1630 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1631 newSVpvs(ATTRSMODULE), NULL);
1634 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1635 newSVpvs(ATTRSMODULE),
1637 prepend_elem(OP_LIST,
1638 newSVOP(OP_CONST, 0, stashsv),
1639 prepend_elem(OP_LIST,
1640 newSVOP(OP_CONST, 0,
1642 dup_attrlist(attrs))));
1648 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1651 OP *pack, *imop, *arg;
1657 assert(target->op_type == OP_PADSV ||
1658 target->op_type == OP_PADHV ||
1659 target->op_type == OP_PADAV);
1661 /* Ensure that attributes.pm is loaded. */
1662 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1664 /* Need package name for method call. */
1665 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
1667 /* Build up the real arg-list. */
1668 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1670 arg = newOP(OP_PADSV, 0);
1671 arg->op_targ = target->op_targ;
1672 arg = prepend_elem(OP_LIST,
1673 newSVOP(OP_CONST, 0, stashsv),
1674 prepend_elem(OP_LIST,
1675 newUNOP(OP_REFGEN, 0,
1676 mod(arg, OP_REFGEN)),
1677 dup_attrlist(attrs)));
1679 /* Fake up a method call to import */
1680 meth = newSVpvs_share("import");
1681 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1682 append_elem(OP_LIST,
1683 prepend_elem(OP_LIST, pack, list(arg)),
1684 newSVOP(OP_METHOD_NAMED, 0, meth)));
1685 imop->op_private |= OPpENTERSUB_NOMOD;
1687 /* Combine the ops. */
1688 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1692 =notfor apidoc apply_attrs_string
1694 Attempts to apply a list of attributes specified by the C<attrstr> and
1695 C<len> arguments to the subroutine identified by the C<cv> argument which
1696 is expected to be associated with the package identified by the C<stashpv>
1697 argument (see L<attributes>). It gets this wrong, though, in that it
1698 does not correctly identify the boundaries of the individual attribute
1699 specifications within C<attrstr>. This is not really intended for the
1700 public API, but has to be listed here for systems such as AIX which
1701 need an explicit export list for symbols. (It's called from XS code
1702 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1703 to respect attribute syntax properly would be welcome.
1709 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
1710 const char *attrstr, STRLEN len)
1715 len = strlen(attrstr);
1719 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1721 const char * const sstr = attrstr;
1722 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1723 attrs = append_elem(OP_LIST, attrs,
1724 newSVOP(OP_CONST, 0,
1725 newSVpvn(sstr, attrstr-sstr)));
1729 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1730 newSVpvs(ATTRSMODULE),
1731 NULL, prepend_elem(OP_LIST,
1732 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1733 prepend_elem(OP_LIST,
1734 newSVOP(OP_CONST, 0,
1740 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
1745 if (!o || PL_error_count)
1750 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
1751 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
1755 if (type == OP_LIST) {
1757 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1758 my_kid(kid, attrs, imopsp);
1759 } else if (type == OP_UNDEF
1765 } else if (type == OP_RV2SV || /* "our" declaration */
1767 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1768 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1769 yyerror(Perl_form(aTHX_ "Can't declare %s in %s",
1770 OP_DESC(o), PL_in_my == KEY_our ? "our" : "my"));
1772 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
1774 PL_in_my_stash = NULL;
1775 apply_attrs(GvSTASH(gv),
1776 (type == OP_RV2SV ? GvSV(gv) :
1777 type == OP_RV2AV ? (SV*)GvAV(gv) :
1778 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1781 o->op_private |= OPpOUR_INTRO;
1784 else if (type != OP_PADSV &&
1787 type != OP_PUSHMARK)
1789 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1791 PL_in_my == KEY_our ? "our" : "my"));
1794 else if (attrs && type != OP_PUSHMARK) {
1798 PL_in_my_stash = NULL;
1800 /* check for C<my Dog $spot> when deciding package */
1801 stash = PAD_COMPNAME_TYPE(o->op_targ);
1803 stash = PL_curstash;
1804 apply_attrs_my(stash, o, attrs, imopsp);
1806 o->op_flags |= OPf_MOD;
1807 o->op_private |= OPpLVAL_INTRO;
1812 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1816 int maybe_scalar = 0;
1818 /* [perl #17376]: this appears to be premature, and results in code such as
1819 C< our(%x); > executing in list mode rather than void mode */
1821 if (o->op_flags & OPf_PARENS)
1831 o = my_kid(o, attrs, &rops);
1833 if (maybe_scalar && o->op_type == OP_PADSV) {
1834 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
1835 o->op_private |= OPpLVAL_INTRO;
1838 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
1841 PL_in_my_stash = NULL;
1846 Perl_my(pTHX_ OP *o)
1848 return my_attrs(o, NULL);
1852 Perl_sawparens(pTHX_ OP *o)
1854 PERL_UNUSED_CONTEXT;
1856 o->op_flags |= OPf_PARENS;
1861 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
1866 if ( (left->op_type == OP_RV2AV ||
1867 left->op_type == OP_RV2HV ||
1868 left->op_type == OP_PADAV ||
1869 left->op_type == OP_PADHV)
1870 && ckWARN(WARN_MISC))
1872 const char * const desc = PL_op_desc[(right->op_type == OP_SUBST ||
1873 right->op_type == OP_TRANS)
1874 ? right->op_type : OP_MATCH];
1875 const char * const sample = ((left->op_type == OP_RV2AV ||
1876 left->op_type == OP_PADAV)
1877 ? "@array" : "%hash");
1878 Perl_warner(aTHX_ packWARN(WARN_MISC),
1879 "Applying %s to %s will act on scalar(%s)",
1880 desc, sample, sample);
1883 if (right->op_type == OP_CONST &&
1884 cSVOPx(right)->op_private & OPpCONST_BARE &&
1885 cSVOPx(right)->op_private & OPpCONST_STRICT)
1887 no_bareword_allowed(right);
1890 ismatchop = right->op_type == OP_MATCH ||
1891 right->op_type == OP_SUBST ||
1892 right->op_type == OP_TRANS;
1893 if (ismatchop && right->op_private & OPpTARGET_MY) {
1895 right->op_private &= ~OPpTARGET_MY;
1897 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
1898 right->op_flags |= OPf_STACKED;
1899 if (right->op_type != OP_MATCH &&
1900 ! (right->op_type == OP_TRANS &&
1901 right->op_private & OPpTRANS_IDENTICAL))
1902 left = mod(left, right->op_type);
1903 if (right->op_type == OP_TRANS)
1904 o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
1906 o = prepend_elem(right->op_type, scalar(left), right);
1908 return newUNOP(OP_NOT, 0, scalar(o));
1912 return bind_match(type, left,
1913 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
1917 Perl_invert(pTHX_ OP *o)
1921 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
1925 Perl_scope(pTHX_ OP *o)
1929 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
1930 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
1931 o->op_type = OP_LEAVE;
1932 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
1934 else if (o->op_type == OP_LINESEQ) {
1936 o->op_type = OP_SCOPE;
1937 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
1938 kid = ((LISTOP*)o)->op_first;
1939 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
1942 /* The following deals with things like 'do {1 for 1}' */
1943 kid = kid->op_sibling;
1945 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
1950 o = newLISTOP(OP_SCOPE, 0, o, NULL);
1956 Perl_block_start(pTHX_ int full)
1959 const int retval = PL_savestack_ix;
1960 pad_block_start(full);
1962 PL_hints &= ~HINT_BLOCK_SCOPE;
1963 SAVESPTR(PL_compiling.cop_warnings);
1964 if (! specialWARN(PL_compiling.cop_warnings)) {
1965 PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
1966 SAVEFREESV(PL_compiling.cop_warnings) ;
1968 SAVESPTR(PL_compiling.cop_io);
1969 if (! specialCopIO(PL_compiling.cop_io)) {
1970 PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
1971 SAVEFREESV(PL_compiling.cop_io) ;
1977 Perl_block_end(pTHX_ I32 floor, OP *seq)
1980 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
1981 OP* const retval = scalarseq(seq);
1983 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
1985 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
1994 const I32 offset = pad_findmy("$_");
1995 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
1996 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
1999 OP * const o = newOP(OP_PADSV, 0);
2000 o->op_targ = offset;
2006 Perl_newPROG(pTHX_ OP *o)
2012 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2013 ((PL_in_eval & EVAL_KEEPERR)
2014 ? OPf_SPECIAL : 0), o);
2015 PL_eval_start = linklist(PL_eval_root);
2016 PL_eval_root->op_private |= OPpREFCOUNTED;
2017 OpREFCNT_set(PL_eval_root, 1);
2018 PL_eval_root->op_next = 0;
2019 CALL_PEEP(PL_eval_start);
2022 if (o->op_type == OP_STUB) {
2023 PL_comppad_name = 0;
2028 PL_main_root = scope(sawparens(scalarvoid(o)));
2029 PL_curcop = &PL_compiling;
2030 PL_main_start = LINKLIST(PL_main_root);
2031 PL_main_root->op_private |= OPpREFCOUNTED;
2032 OpREFCNT_set(PL_main_root, 1);
2033 PL_main_root->op_next = 0;
2034 CALL_PEEP(PL_main_start);
2037 /* Register with debugger */
2039 CV * const cv = get_cv("DB::postponed", FALSE);
2043 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2045 call_sv((SV*)cv, G_DISCARD);
2052 Perl_localize(pTHX_ OP *o, I32 lex)
2055 if (o->op_flags & OPf_PARENS)
2056 /* [perl #17376]: this appears to be premature, and results in code such as
2057 C< our(%x); > executing in list mode rather than void mode */
2064 if ( PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ','
2065 && ckWARN(WARN_PARENTHESIS))
2067 char *s = PL_bufptr;
2070 /* some heuristics to detect a potential error */
2071 while (*s && (strchr(", \t\n", *s)))
2075 if (*s && strchr("@$%*", *s) && *++s
2076 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2079 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2081 while (*s && (strchr(", \t\n", *s)))
2087 if (sigil && (*s == ';' || *s == '=')) {
2088 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2089 "Parentheses missing around \"%s\" list",
2090 lex ? (PL_in_my == KEY_our ? "our" : "my")
2098 o = mod(o, OP_NULL); /* a bit kludgey */
2100 PL_in_my_stash = NULL;
2105 Perl_jmaybe(pTHX_ OP *o)
2107 if (o->op_type == OP_LIST) {
2109 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL,
2111 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2117 Perl_fold_constants(pTHX_ register OP *o)
2122 I32 type = o->op_type;
2129 if (PL_opargs[type] & OA_RETSCALAR)
2131 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2132 o->op_targ = pad_alloc(type, SVs_PADTMP);
2134 /* integerize op, unless it happens to be C<-foo>.
2135 * XXX should pp_i_negate() do magic string negation instead? */
2136 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2137 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2138 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2140 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2143 if (!(PL_opargs[type] & OA_FOLDCONST))
2148 /* XXX might want a ck_negate() for this */
2149 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2160 /* XXX what about the numeric ops? */
2161 if (PL_hints & HINT_LOCALE)
2166 goto nope; /* Don't try to run w/ errors */
2168 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2169 if ((curop->op_type != OP_CONST ||
2170 (curop->op_private & OPpCONST_BARE)) &&
2171 curop->op_type != OP_LIST &&
2172 curop->op_type != OP_SCALAR &&
2173 curop->op_type != OP_NULL &&
2174 curop->op_type != OP_PUSHMARK)
2180 curop = LINKLIST(o);
2181 old_next = o->op_next;
2185 oldscope = PL_scopestack_ix;
2187 /* we're trying to emulate pp_entertry() here */
2189 register PERL_CONTEXT *cx;
2190 const I32 gimme = GIMME_V;
2195 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
2197 PL_eval_root = PL_op; /* Only needed so that goto works right. */
2199 PL_in_eval = EVAL_INEVAL;
2200 sv_setpvn(ERRSV,"",0);
2207 sv = *(PL_stack_sp--);
2208 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2209 pad_swipe(o->op_targ, FALSE);
2210 else if (SvTEMP(sv)) { /* grab mortal temp? */
2211 SvREFCNT_inc_simple_void(sv);
2216 /* Something tried to die. Abandon constant folding. */
2217 /* Pretend the error never happened. */
2218 sv_setpvn(ERRSV,"",0);
2219 o->op_next = old_next;
2223 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
2224 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
2228 if (PL_scopestack_ix > oldscope) {
2232 register PERL_CONTEXT *cx;
2239 PERL_UNUSED_VAR(newsp);
2240 PERL_UNUSED_VAR(gimme);
2241 PERL_UNUSED_VAR(optype);
2250 if (type == OP_RV2GV)
2251 newop = newGVOP(OP_GV, 0, (GV*)sv);
2253 newop = newSVOP(OP_CONST, 0, sv);
2254 op_getmad(o,newop,'f');
2262 Perl_gen_constant_list(pTHX_ register OP *o)
2266 const I32 oldtmps_floor = PL_tmps_floor;
2270 return o; /* Don't attempt to run with errors */
2272 PL_op = curop = LINKLIST(o);
2279 PL_tmps_floor = oldtmps_floor;
2281 o->op_type = OP_RV2AV;
2282 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2283 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2284 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2285 o->op_opt = 0; /* needs to be revisited in peep() */
2286 curop = ((UNOP*)o)->op_first;
2287 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
2289 op_getmad(curop,o,'O');
2298 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2301 if (!o || o->op_type != OP_LIST)
2302 o = newLISTOP(OP_LIST, 0, o, NULL);
2304 o->op_flags &= ~OPf_WANT;
2306 if (!(PL_opargs[type] & OA_MARK))
2307 op_null(cLISTOPo->op_first);
2309 o->op_type = (OPCODE)type;
2310 o->op_ppaddr = PL_ppaddr[type];
2311 o->op_flags |= flags;
2313 o = CHECKOP(type, o);
2314 if (o->op_type != (unsigned)type)
2317 return fold_constants(o);
2320 /* List constructors */
2323 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2331 if (first->op_type != (unsigned)type
2332 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2334 return newLISTOP(type, 0, first, last);
2337 if (first->op_flags & OPf_KIDS)
2338 ((LISTOP*)first)->op_last->op_sibling = last;
2340 first->op_flags |= OPf_KIDS;
2341 ((LISTOP*)first)->op_first = last;
2343 ((LISTOP*)first)->op_last = last;
2348 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2356 if (first->op_type != (unsigned)type)
2357 return prepend_elem(type, (OP*)first, (OP*)last);
2359 if (last->op_type != (unsigned)type)
2360 return append_elem(type, (OP*)first, (OP*)last);
2362 first->op_last->op_sibling = last->op_first;
2363 first->op_last = last->op_last;
2364 first->op_flags |= (last->op_flags & OPf_KIDS);
2367 if (last->op_first && first->op_madprop) {
2368 MADPROP *mp = last->op_first->op_madprop;
2370 while (mp->mad_next)
2372 mp->mad_next = first->op_madprop;
2375 last->op_first->op_madprop = first->op_madprop;
2378 first->op_madprop = last->op_madprop;
2379 last->op_madprop = 0;
2388 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2396 if (last->op_type == (unsigned)type) {
2397 if (type == OP_LIST) { /* already a PUSHMARK there */
2398 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2399 ((LISTOP*)last)->op_first->op_sibling = first;
2400 if (!(first->op_flags & OPf_PARENS))
2401 last->op_flags &= ~OPf_PARENS;
2404 if (!(last->op_flags & OPf_KIDS)) {
2405 ((LISTOP*)last)->op_last = first;
2406 last->op_flags |= OPf_KIDS;
2408 first->op_sibling = ((LISTOP*)last)->op_first;
2409 ((LISTOP*)last)->op_first = first;
2411 last->op_flags |= OPf_KIDS;
2415 return newLISTOP(type, 0, first, last);
2423 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2426 Newxz(tk, 1, TOKEN);
2427 tk->tk_type = (OPCODE)optype;
2428 tk->tk_type = 12345;
2430 tk->tk_mad = madprop;
2435 Perl_token_free(pTHX_ TOKEN* tk)
2437 if (tk->tk_type != 12345)
2439 mad_free(tk->tk_mad);
2444 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2448 if (tk->tk_type != 12345) {
2449 Perl_warner(aTHX_ packWARN(WARN_MISC),
2450 "Invalid TOKEN object ignored");
2457 /* faked up qw list? */
2459 tm->mad_type == MAD_SV &&
2460 SvPVX((SV*)tm->mad_val)[0] == 'q')
2467 /* pretend constant fold didn't happen? */
2468 if (mp->mad_key == 'f' &&
2469 (o->op_type == OP_CONST ||
2470 o->op_type == OP_GV) )
2472 token_getmad(tk,(OP*)mp->mad_val,slot);
2486 if (mp->mad_key == 'X')
2487 mp->mad_key = slot; /* just change the first one */
2497 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
2506 /* pretend constant fold didn't happen? */
2507 if (mp->mad_key == 'f' &&
2508 (o->op_type == OP_CONST ||
2509 o->op_type == OP_GV) )
2511 op_getmad(from,(OP*)mp->mad_val,slot);
2518 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
2521 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
2527 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
2536 /* pretend constant fold didn't happen? */
2537 if (mp->mad_key == 'f' &&
2538 (o->op_type == OP_CONST ||
2539 o->op_type == OP_GV) )
2541 op_getmad(from,(OP*)mp->mad_val,slot);
2548 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
2551 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
2555 PerlIO_printf(PerlIO_stderr(),
2556 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
2562 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
2580 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
2584 addmad(tm, &(o->op_madprop), slot);
2588 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
2609 Perl_newMADsv(pTHX_ char key, SV* sv)
2611 return newMADPROP(key, MAD_SV, sv, 0);
2615 Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
2618 Newxz(mp, 1, MADPROP);
2621 mp->mad_vlen = vlen;
2622 mp->mad_type = type;
2624 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
2629 Perl_mad_free(pTHX_ MADPROP* mp)
2631 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
2635 mad_free(mp->mad_next);
2636 /* if (PL_lex_state != LEX_NOTPARSING && mp->mad_vlen)
2637 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
2638 switch (mp->mad_type) {
2642 Safefree((char*)mp->mad_val);
2645 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
2646 op_free((OP*)mp->mad_val);
2649 sv_free((SV*)mp->mad_val);
2652 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
2661 Perl_newNULLLIST(pTHX)
2663 return newOP(OP_STUB, 0);
2667 Perl_force_list(pTHX_ OP *o)
2669 if (!o || o->op_type != OP_LIST)
2670 o = newLISTOP(OP_LIST, 0, o, NULL);
2676 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2681 NewOp(1101, listop, 1, LISTOP);
2683 listop->op_type = (OPCODE)type;
2684 listop->op_ppaddr = PL_ppaddr[type];
2687 listop->op_flags = (U8)flags;
2691 else if (!first && last)
2694 first->op_sibling = last;
2695 listop->op_first = first;
2696 listop->op_last = last;
2697 if (type == OP_LIST) {
2698 OP* const pushop = newOP(OP_PUSHMARK, 0);
2699 pushop->op_sibling = first;
2700 listop->op_first = pushop;
2701 listop->op_flags |= OPf_KIDS;
2703 listop->op_last = pushop;
2706 return CHECKOP(type, listop);
2710 Perl_newOP(pTHX_ I32 type, I32 flags)
2714 NewOp(1101, o, 1, OP);
2715 o->op_type = (OPCODE)type;
2716 o->op_ppaddr = PL_ppaddr[type];
2717 o->op_flags = (U8)flags;
2720 o->op_private = (U8)(0 | (flags >> 8));
2721 if (PL_opargs[type] & OA_RETSCALAR)
2723 if (PL_opargs[type] & OA_TARGET)
2724 o->op_targ = pad_alloc(type, SVs_PADTMP);
2725 return CHECKOP(type, o);
2729 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2735 first = newOP(OP_STUB, 0);
2736 if (PL_opargs[type] & OA_MARK)
2737 first = force_list(first);
2739 NewOp(1101, unop, 1, UNOP);
2740 unop->op_type = (OPCODE)type;
2741 unop->op_ppaddr = PL_ppaddr[type];
2742 unop->op_first = first;
2743 unop->op_flags = (U8)(flags | OPf_KIDS);
2744 unop->op_private = (U8)(1 | (flags >> 8));
2745 unop = (UNOP*) CHECKOP(type, unop);
2749 return fold_constants((OP *) unop);
2753 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2757 NewOp(1101, binop, 1, BINOP);
2760 first = newOP(OP_NULL, 0);
2762 binop->op_type = (OPCODE)type;
2763 binop->op_ppaddr = PL_ppaddr[type];
2764 binop->op_first = first;
2765 binop->op_flags = (U8)(flags | OPf_KIDS);
2768 binop->op_private = (U8)(1 | (flags >> 8));
2771 binop->op_private = (U8)(2 | (flags >> 8));
2772 first->op_sibling = last;
2775 binop = (BINOP*)CHECKOP(type, binop);
2776 if (binop->op_next || binop->op_type != (OPCODE)type)
2779 binop->op_last = binop->op_first->op_sibling;
2781 return fold_constants((OP *)binop);
2784 static int uvcompare(const void *a, const void *b)
2785 __attribute__nonnull__(1)
2786 __attribute__nonnull__(2)
2787 __attribute__pure__;
2788 static int uvcompare(const void *a, const void *b)
2790 if (*((const UV *)a) < (*(const UV *)b))
2792 if (*((const UV *)a) > (*(const UV *)b))
2794 if (*((const UV *)a+1) < (*(const UV *)b+1))
2796 if (*((const UV *)a+1) > (*(const UV *)b+1))
2802 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2805 SV * const tstr = ((SVOP*)expr)->op_sv;
2806 SV * const rstr = ((SVOP*)repl)->op_sv;
2809 const U8 *t = (U8*)SvPV_const(tstr, tlen);
2810 const U8 *r = (U8*)SvPV_const(rstr, rlen);
2814 register short *tbl;
2816 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
2817 const I32 squash = o->op_private & OPpTRANS_SQUASH;
2818 I32 del = o->op_private & OPpTRANS_DELETE;
2819 PL_hints |= HINT_BLOCK_SCOPE;
2822 o->op_private |= OPpTRANS_FROM_UTF;
2825 o->op_private |= OPpTRANS_TO_UTF;
2827 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2828 SV* const listsv = newSVpvs("# comment\n");
2830 const U8* tend = t + tlen;
2831 const U8* rend = r + rlen;
2845 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2846 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2852 t = tsave = bytes_to_utf8(t, &len);
2855 if (!to_utf && rlen) {
2857 r = rsave = bytes_to_utf8(r, &len);
2861 /* There are several snags with this code on EBCDIC:
2862 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2863 2. scan_const() in toke.c has encoded chars in native encoding which makes
2864 ranges at least in EBCDIC 0..255 range the bottom odd.
2868 U8 tmpbuf[UTF8_MAXBYTES+1];
2871 Newx(cp, 2*tlen, UV);
2873 transv = newSVpvs("");
2875 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2877 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2879 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2883 cp[2*i+1] = cp[2*i];
2887 qsort(cp, i, 2*sizeof(UV), uvcompare);
2888 for (j = 0; j < i; j++) {
2890 diff = val - nextmin;
2892 t = uvuni_to_utf8(tmpbuf,nextmin);
2893 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2895 U8 range_mark = UTF_TO_NATIVE(0xff);
2896 t = uvuni_to_utf8(tmpbuf, val - 1);
2897 sv_catpvn(transv, (char *)&range_mark, 1);
2898 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2905 t = uvuni_to_utf8(tmpbuf,nextmin);
2906 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2908 U8 range_mark = UTF_TO_NATIVE(0xff);
2909 sv_catpvn(transv, (char *)&range_mark, 1);
2911 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2912 UNICODE_ALLOW_SUPER);
2913 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2914 t = (const U8*)SvPVX_const(transv);
2915 tlen = SvCUR(transv);
2919 else if (!rlen && !del) {
2920 r = t; rlen = tlen; rend = tend;
2923 if ((!rlen && !del) || t == r ||
2924 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2926 o->op_private |= OPpTRANS_IDENTICAL;
2930 while (t < tend || tfirst <= tlast) {
2931 /* see if we need more "t" chars */
2932 if (tfirst > tlast) {
2933 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2935 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2937 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2944 /* now see if we need more "r" chars */
2945 if (rfirst > rlast) {
2947 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2949 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2951 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2960 rfirst = rlast = 0xffffffff;
2964 /* now see which range will peter our first, if either. */
2965 tdiff = tlast - tfirst;
2966 rdiff = rlast - rfirst;
2973 if (rfirst == 0xffffffff) {
2974 diff = tdiff; /* oops, pretend rdiff is infinite */
2976 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2977 (long)tfirst, (long)tlast);
2979 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2983 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2984 (long)tfirst, (long)(tfirst + diff),
2987 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2988 (long)tfirst, (long)rfirst);
2990 if (rfirst + diff > max)
2991 max = rfirst + diff;
2993 grows = (tfirst < rfirst &&
2994 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3006 else if (max > 0xff)
3011 Safefree(cPVOPo->op_pv);
3012 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
3013 SvREFCNT_dec(listsv);
3014 SvREFCNT_dec(transv);
3016 if (!del && havefinal && rlen)
3017 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
3018 newSVuv((UV)final), 0);
3021 o->op_private |= OPpTRANS_GROWS;
3027 op_getmad(expr,o,'e');
3028 op_getmad(repl,o,'r');
3036 tbl = (short*)cPVOPo->op_pv;
3038 Zero(tbl, 256, short);
3039 for (i = 0; i < (I32)tlen; i++)
3041 for (i = 0, j = 0; i < 256; i++) {
3043 if (j >= (I32)rlen) {
3052 if (i < 128 && r[j] >= 128)
3062 o->op_private |= OPpTRANS_IDENTICAL;
3064 else if (j >= (I32)rlen)
3067 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
3068 tbl[0x100] = (short)(rlen - j);
3069 for (i=0; i < (I32)rlen - j; i++)
3070 tbl[0x101+i] = r[j+i];
3074 if (!rlen && !del) {
3077 o->op_private |= OPpTRANS_IDENTICAL;
3079 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3080 o->op_private |= OPpTRANS_IDENTICAL;
3082 for (i = 0; i < 256; i++)
3084 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3085 if (j >= (I32)rlen) {
3087 if (tbl[t[i]] == -1)
3093 if (tbl[t[i]] == -1) {
3094 if (t[i] < 128 && r[j] >= 128)
3101 o->op_private |= OPpTRANS_GROWS;
3103 op_getmad(expr,o,'e');
3104 op_getmad(repl,o,'r');
3114 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3119 NewOp(1101, pmop, 1, PMOP);
3120 pmop->op_type = (OPCODE)type;
3121 pmop->op_ppaddr = PL_ppaddr[type];
3122 pmop->op_flags = (U8)flags;
3123 pmop->op_private = (U8)(0 | (flags >> 8));
3125 if (PL_hints & HINT_RE_TAINT)
3126 pmop->op_pmpermflags |= PMf_RETAINT;
3127 if (PL_hints & HINT_LOCALE)
3128 pmop->op_pmpermflags |= PMf_LOCALE;
3129 pmop->op_pmflags = pmop->op_pmpermflags;
3132 if (av_len((AV*) PL_regex_pad[0]) > -1) {
3133 SV * const repointer = av_pop((AV*)PL_regex_pad[0]);
3134 pmop->op_pmoffset = SvIV(repointer);
3135 SvREPADTMP_off(repointer);
3136 sv_setiv(repointer,0);
3138 SV * const repointer = newSViv(0);
3139 av_push(PL_regex_padav, SvREFCNT_inc_simple_NN(repointer));
3140 pmop->op_pmoffset = av_len(PL_regex_padav);
3141 PL_regex_pad = AvARRAY(PL_regex_padav);
3145 /* link into pm list */
3146 if (type != OP_TRANS && PL_curstash) {
3147 MAGIC *mg = mg_find((SV*)PL_curstash, PERL_MAGIC_symtab);
3150 mg = sv_magicext((SV*)PL_curstash, 0, PERL_MAGIC_symtab, 0, 0, 0);
3152 pmop->op_pmnext = (PMOP*)mg->mg_obj;
3153 mg->mg_obj = (SV*)pmop;
3154 PmopSTASH_set(pmop,PL_curstash);
3157 return CHECKOP(type, pmop);
3160 /* Given some sort of match op o, and an expression expr containing a
3161 * pattern, either compile expr into a regex and attach it to o (if it's
3162 * constant), or convert expr into a runtime regcomp op sequence (if it's
3165 * isreg indicates that the pattern is part of a regex construct, eg
3166 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3167 * split "pattern", which aren't. In the former case, expr will be a list
3168 * if the pattern contains more than one term (eg /a$b/) or if it contains
3169 * a replacement, ie s/// or tr///.
3173 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
3178 I32 repl_has_vars = 0;
3182 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
3183 /* last element in list is the replacement; pop it */
3185 repl = cLISTOPx(expr)->op_last;
3186 kid = cLISTOPx(expr)->op_first;
3187 while (kid->op_sibling != repl)
3188 kid = kid->op_sibling;
3189 kid->op_sibling = NULL;
3190 cLISTOPx(expr)->op_last = kid;
3193 if (isreg && expr->op_type == OP_LIST &&
3194 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3196 /* convert single element list to element */
3197 OP* const oe = expr;
3198 expr = cLISTOPx(oe)->op_first->op_sibling;
3199 cLISTOPx(oe)->op_first->op_sibling = NULL;
3200 cLISTOPx(oe)->op_last = NULL;
3204 if (o->op_type == OP_TRANS) {
3205 return pmtrans(o, expr, repl);
3208 reglist = isreg && expr->op_type == OP_LIST;
3212 PL_hints |= HINT_BLOCK_SCOPE;
3215 if (expr->op_type == OP_CONST) {
3217 SV * const pat = ((SVOP*)expr)->op_sv;
3218 const char *p = SvPV_const(pat, plen);
3219 if ((o->op_flags & OPf_SPECIAL) && (*p == ' ' && p[1] == '\0')) {
3220 U32 was_readonly = SvREADONLY(pat);
3224 sv_force_normal_flags(pat, 0);
3225 assert(!SvREADONLY(pat));
3228 SvREADONLY_off(pat);
3232 sv_setpvn(pat, "\\s+", 3);
3234 SvFLAGS(pat) |= was_readonly;
3236 p = SvPV_const(pat, plen);
3237 pm->op_pmflags |= PMf_SKIPWHITE;
3240 pm->op_pmdynflags |= PMdf_UTF8;
3241 /* FIXME - can we make this function take const char * args? */
3242 PM_SETRE(pm, CALLREGCOMP(aTHX_ (char*)p, (char*)p + plen, pm));
3243 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
3244 pm->op_pmflags |= PMf_WHITE;
3246 op_getmad(expr,(OP*)pm,'e');
3252 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3253 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3255 : OP_REGCMAYBE),0,expr);
3257 NewOp(1101, rcop, 1, LOGOP);
3258 rcop->op_type = OP_REGCOMP;
3259 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3260 rcop->op_first = scalar(expr);
3261 rcop->op_flags |= OPf_KIDS
3262 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3263 | (reglist ? OPf_STACKED : 0);
3264 rcop->op_private = 1;
3267 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3269 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
3272 /* establish postfix order */
3273 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3275 rcop->op_next = expr;
3276 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3279 rcop->op_next = LINKLIST(expr);
3280 expr->op_next = (OP*)rcop;
3283 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3288 if (pm->op_pmflags & PMf_EVAL) {
3290 if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
3291 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
3293 else if (repl->op_type == OP_CONST)
3297 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3298 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3299 if (curop->op_type == OP_GV) {
3300 GV * const gv = cGVOPx_gv(curop);
3302 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3305 else if (curop->op_type == OP_RV2CV)
3307 else if (curop->op_type == OP_RV2SV ||
3308 curop->op_type == OP_RV2AV ||
3309 curop->op_type == OP_RV2HV ||
3310 curop->op_type == OP_RV2GV) {
3311 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3314 else if (curop->op_type == OP_PADSV ||
3315 curop->op_type == OP_PADAV ||
3316 curop->op_type == OP_PADHV ||
3317 curop->op_type == OP_PADANY) {
3320 else if (curop->op_type == OP_PUSHRE)
3321 /*EMPTY*/; /* Okay here, dangerous in newASSIGNOP */
3331 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
3332 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3333 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
3334 prepend_elem(o->op_type, scalar(repl), o);
3337 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3338 pm->op_pmflags |= PMf_MAYBE_CONST;
3339 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3341 NewOp(1101, rcop, 1, LOGOP);
3342 rcop->op_type = OP_SUBSTCONT;
3343 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3344 rcop->op_first = scalar(repl);
3345 rcop->op_flags |= OPf_KIDS;
3346 rcop->op_private = 1;
3349 /* establish postfix order */
3350 rcop->op_next = LINKLIST(repl);
3351 repl->op_next = (OP*)rcop;
3353 pm->op_pmreplroot = scalar((OP*)rcop);
3354 pm->op_pmreplstart = LINKLIST(rcop);
3363 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3367 NewOp(1101, svop, 1, SVOP);
3368 svop->op_type = (OPCODE)type;
3369 svop->op_ppaddr = PL_ppaddr[type];
3371 svop->op_next = (OP*)svop;
3372 svop->op_flags = (U8)flags;
3373 if (PL_opargs[type] & OA_RETSCALAR)
3375 if (PL_opargs[type] & OA_TARGET)
3376 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3377 return CHECKOP(type, svop);
3381 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3385 NewOp(1101, padop, 1, PADOP);
3386 padop->op_type = (OPCODE)type;
3387 padop->op_ppaddr = PL_ppaddr[type];
3388 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3389 SvREFCNT_dec(PAD_SVl(padop->op_padix));
3390 PAD_SETSV(padop->op_padix, sv);
3393 padop->op_next = (OP*)padop;
3394 padop->op_flags = (U8)flags;
3395 if (PL_opargs[type] & OA_RETSCALAR)
3397 if (PL_opargs[type] & OA_TARGET)
3398 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3399 return CHECKOP(type, padop);
3403 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3409 return newPADOP(type, flags, SvREFCNT_inc_simple(gv));
3411 return newSVOP(type, flags, SvREFCNT_inc_simple(gv));
3416 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3420 NewOp(1101, pvop, 1, PVOP);
3421 pvop->op_type = (OPCODE)type;
3422 pvop->op_ppaddr = PL_ppaddr[type];
3424 pvop->op_next = (OP*)pvop;
3425 pvop->op_flags = (U8)flags;
3426 if (PL_opargs[type] & OA_RETSCALAR)
3428 if (PL_opargs[type] & OA_TARGET)
3429 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3430 return CHECKOP(type, pvop);
3438 Perl_package(pTHX_ OP *o)
3447 save_hptr(&PL_curstash);
3448 save_item(PL_curstname);
3450 name = SvPV_const(cSVOPo->op_sv, len);
3451 PL_curstash = gv_stashpvn(name, len, TRUE);
3452 sv_setpvn(PL_curstname, name, len);
3454 PL_hints |= HINT_BLOCK_SCOPE;
3455 PL_copline = NOLINE;
3461 if (!PL_madskills) {
3466 pegop = newOP(OP_NULL,0);
3467 op_getmad(o,pegop,'P');
3477 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3484 OP *pegop = newOP(OP_NULL,0);
3487 if (idop->op_type != OP_CONST)
3488 Perl_croak(aTHX_ "Module name must be constant");
3491 op_getmad(idop,pegop,'U');
3496 SV * const vesv = ((SVOP*)version)->op_sv;
3499 op_getmad(version,pegop,'V');
3500 if (!arg && !SvNIOKp(vesv)) {
3507 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3508 Perl_croak(aTHX_ "Version number must be constant number");
3510 /* Make copy of idop so we don't free it twice */
3511 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3513 /* Fake up a method call to VERSION */
3514 meth = newSVpvs_share("VERSION");
3515 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3516 append_elem(OP_LIST,
3517 prepend_elem(OP_LIST, pack, list(version)),
3518 newSVOP(OP_METHOD_NAMED, 0, meth)));
3522 /* Fake up an import/unimport */
3523 if (arg && arg->op_type == OP_STUB) {
3525 op_getmad(arg,pegop,'S');
3526 imop = arg; /* no import on explicit () */
3528 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3529 imop = NULL; /* use 5.0; */
3531 idop->op_private |= OPpCONST_NOVER;
3537 op_getmad(arg,pegop,'A');
3539 /* Make copy of idop so we don't free it twice */
3540 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3542 /* Fake up a method call to import/unimport */
3544 ? newSVpvs_share("import") : newSVpvs_share("unimport");
3545 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3546 append_elem(OP_LIST,
3547 prepend_elem(OP_LIST, pack, list(arg)),
3548 newSVOP(OP_METHOD_NAMED, 0, meth)));
3551 /* Fake up the BEGIN {}, which does its thing immediately. */
3553 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
3556 append_elem(OP_LINESEQ,
3557 append_elem(OP_LINESEQ,
3558 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
3559 newSTATEOP(0, NULL, veop)),
3560 newSTATEOP(0, NULL, imop) ));
3562 /* The "did you use incorrect case?" warning used to be here.
3563 * The problem is that on case-insensitive filesystems one
3564 * might get false positives for "use" (and "require"):
3565 * "use Strict" or "require CARP" will work. This causes
3566 * portability problems for the script: in case-strict
3567 * filesystems the script will stop working.
3569 * The "incorrect case" warning checked whether "use Foo"
3570 * imported "Foo" to your namespace, but that is wrong, too:
3571 * there is no requirement nor promise in the language that
3572 * a Foo.pm should or would contain anything in package "Foo".
3574 * There is very little Configure-wise that can be done, either:
3575 * the case-sensitivity of the build filesystem of Perl does not
3576 * help in guessing the case-sensitivity of the runtime environment.
3579 PL_hints |= HINT_BLOCK_SCOPE;
3580 PL_copline = NOLINE;
3582 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3585 if (!PL_madskills) {
3586 /* FIXME - don't allocate pegop if !PL_madskills */
3595 =head1 Embedding Functions
3597 =for apidoc load_module
3599 Loads the module whose name is pointed to by the string part of name.
3600 Note that the actual module name, not its filename, should be given.
3601 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3602 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3603 (or 0 for no flags). ver, if specified, provides version semantics
3604 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3605 arguments can be used to specify arguments to the module's import()
3606 method, similar to C<use Foo::Bar VERSION LIST>.
3611 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3614 va_start(args, ver);
3615 vload_module(flags, name, ver, &args);
3619 #ifdef PERL_IMPLICIT_CONTEXT
3621 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3625 va_start(args, ver);
3626 vload_module(flags, name, ver, &args);
3632 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3637 OP * const modname = newSVOP(OP_CONST, 0, name);
3638 modname->op_private |= OPpCONST_BARE;
3640 veop = newSVOP(OP_CONST, 0, ver);
3644 if (flags & PERL_LOADMOD_NOIMPORT) {
3645 imop = sawparens(newNULLLIST());
3647 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3648 imop = va_arg(*args, OP*);
3653 sv = va_arg(*args, SV*);
3655 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3656 sv = va_arg(*args, SV*);
3660 const line_t ocopline = PL_copline;
3661 COP * const ocurcop = PL_curcop;
3662 const int oexpect = PL_expect;
3664 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3665 veop, modname, imop);
3666 PL_expect = oexpect;
3667 PL_copline = ocopline;
3668 PL_curcop = ocurcop;
3673 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
3679 if (!force_builtin) {
3680 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
3681 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
3682 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
3683 gv = gvp ? *gvp : NULL;
3687 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3688 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3689 append_elem(OP_LIST, term,
3690 scalar(newUNOP(OP_RV2CV, 0,
3695 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3701 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3703 return newBINOP(OP_LSLICE, flags,
3704 list(force_list(subscript)),
3705 list(force_list(listval)) );
3709 S_is_list_assignment(pTHX_ register const OP *o)
3714 if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3715 o = cUNOPo->op_first;
3717 if (o->op_type == OP_COND_EXPR) {
3718 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
3719 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3724 yyerror("Assignment to both a list and a scalar");
3728 if (o->op_type == OP_LIST &&
3729 (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3730 o->op_private & OPpLVAL_INTRO)
3733 if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3734 o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3735 o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3738 if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3741 if (o->op_type == OP_RV2SV)
3748 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3754 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3755 return newLOGOP(optype, 0,
3756 mod(scalar(left), optype),
3757 newUNOP(OP_SASSIGN, 0, scalar(right)));
3760 return newBINOP(optype, OPf_STACKED,
3761 mod(scalar(left), optype), scalar(right));
3765 if (is_list_assignment(left)) {
3769 /* Grandfathering $[ assignment here. Bletch.*/
3770 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
3771 PL_eval_start = (left->op_type == OP_CONST) ? right : 0;
3772 left = mod(left, OP_AASSIGN);
3775 else if (left->op_type == OP_CONST) {
3777 /* Result of assignment is always 1 (or we'd be dead already) */
3778 return newSVOP(OP_CONST, 0, newSViv(1));
3780 curop = list(force_list(left));
3781 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3782 o->op_private = (U8)(0 | (flags >> 8));
3784 /* PL_generation sorcery:
3785 * an assignment like ($a,$b) = ($c,$d) is easier than
3786 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3787 * To detect whether there are common vars, the global var
3788 * PL_generation is incremented for each assign op we compile.
3789 * Then, while compiling the assign op, we run through all the
3790 * variables on both sides of the assignment, setting a spare slot
3791 * in each of them to PL_generation. If any of them already have
3792 * that value, we know we've got commonality. We could use a
3793 * single bit marker, but then we'd have to make 2 passes, first
3794 * to clear the flag, then to test and set it. To find somewhere
3795 * to store these values, evil chicanery is done with SvCUR().
3798 if (!(left->op_private & OPpLVAL_INTRO)) {
3801 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3802 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3803 if (curop->op_type == OP_GV) {
3804 GV *gv = cGVOPx_gv(curop);
3806 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
3808 GvASSIGN_GENERATION_set(gv, PL_generation);
3810 else if (curop->op_type == OP_PADSV ||
3811 curop->op_type == OP_PADAV ||
3812 curop->op_type == OP_PADHV ||
3813 curop->op_type == OP_PADANY)
3815 if (PAD_COMPNAME_GEN(curop->op_targ)
3816 == (STRLEN)PL_generation)
3818 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
3821 else if (curop->op_type == OP_RV2CV)
3823 else if (curop->op_type == OP_RV2SV ||
3824 curop->op_type == OP_RV2AV ||
3825 curop->op_type == OP_RV2HV ||
3826 curop->op_type == OP_RV2GV) {
3827 if (lastop->op_type != OP_GV) /* funny deref? */
3830 else if (curop->op_type == OP_PUSHRE) {
3831 if (((PMOP*)curop)->op_pmreplroot) {
3833 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3834 ((PMOP*)curop)->op_pmreplroot));
3836 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3839 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
3841 GvASSIGN_GENERATION_set(gv, PL_generation);
3842 GvASSIGN_GENERATION_set(gv, PL_generation);
3851 o->op_private |= OPpASSIGN_COMMON;
3853 if (right && right->op_type == OP_SPLIT) {
3855 if ((tmpop = ((LISTOP*)right)->op_first) &&
3856 tmpop->op_type == OP_PUSHRE)
3858 PMOP * const pm = (PMOP*)tmpop;
3859 if (left->op_type == OP_RV2AV &&
3860 !(left->op_private & OPpLVAL_INTRO) &&
3861 !(o->op_private & OPpASSIGN_COMMON) )
3863 tmpop = ((UNOP*)left)->op_first;
3864 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3866 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3867 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3869 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3870 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
3872 pm->op_pmflags |= PMf_ONCE;
3873 tmpop = cUNOPo->op_first; /* to list (nulled) */
3874 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3875 tmpop->op_sibling = NULL; /* don't free split */
3876 right->op_next = tmpop->op_next; /* fix starting loc */
3878 op_getmad(o,right,'R'); /* blow off assign */
3880 op_free(o); /* blow off assign */
3882 right->op_flags &= ~OPf_WANT;
3883 /* "I don't know and I don't care." */
3888 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3889 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3891 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3893 sv_setiv(sv, PL_modcount+1);
3901 right = newOP(OP_UNDEF, 0);
3902 if (right->op_type == OP_READLINE) {
3903 right->op_flags |= OPf_STACKED;
3904 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3907 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3908 o = newBINOP(OP_SASSIGN, flags,
3909 scalar(right), mod(scalar(left), OP_SASSIGN) );
3915 o = newSVOP(OP_CONST, 0, newSViv(PL_compiling.cop_arybase));
3916 o->op_private |= OPpCONST_ARYBASE;
3923 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3926 const U32 seq = intro_my();
3929 NewOp(1101, cop, 1, COP);
3930 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3931 cop->op_type = OP_DBSTATE;
3932 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3935 cop->op_type = OP_NEXTSTATE;
3936 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3938 cop->op_flags = (U8)flags;
3939 cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
3941 cop->op_private |= NATIVE_HINTS;
3943 PL_compiling.op_private = cop->op_private;
3944 cop->op_next = (OP*)cop;
3947 cop->cop_label = label;
3948 PL_hints |= HINT_BLOCK_SCOPE;
3951 cop->cop_arybase = PL_curcop->cop_arybase;
3952 if (specialWARN(PL_curcop->cop_warnings))
3953 cop->cop_warnings = PL_curcop->cop_warnings ;
3955 cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3956 if (specialCopIO(PL_curcop->cop_io))
3957 cop->cop_io = PL_curcop->cop_io;
3959 cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3962 if (PL_copline == NOLINE)
3963 CopLINE_set(cop, CopLINE(PL_curcop));
3965 CopLINE_set(cop, PL_copline);
3966 PL_copline = NOLINE;
3969 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3971 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3973 CopSTASH_set(cop, PL_curstash);
3975 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3976 SV * const * const svp = av_fetch(CopFILEAVx(PL_curcop), (I32)CopLINE(cop), FALSE);
3977 if (svp && *svp != &PL_sv_undef ) {
3978 (void)SvIOK_on(*svp);
3979 SvIV_set(*svp, PTR2IV(cop));
3983 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3988 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3991 return new_logop(type, flags, &first, &other);
3995 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
4000 OP *first = *firstp;
4001 OP * const other = *otherp;
4003 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
4004 return newBINOP(type, flags, scalar(first), scalar(other));
4006 scalarboolean(first);
4007 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
4008 if (first->op_type == OP_NOT
4009 && (first->op_flags & OPf_SPECIAL)
4010 && (first->op_flags & OPf_KIDS)) {
4011 if (type == OP_AND || type == OP_OR) {
4017 first = *firstp = cUNOPo->op_first;
4019 first->op_next = o->op_next;
4020 cUNOPo->op_first = NULL;
4022 op_getmad(o,first,'O');
4028 if (first->op_type == OP_CONST) {
4029 if (first->op_private & OPpCONST_STRICT)
4030 no_bareword_allowed(first);
4031 else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
4032 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
4033 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
4034 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
4035 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
4037 if (other->op_type == OP_CONST)
4038 other->op_private |= OPpCONST_SHORTCIRCUIT;
4040 OP *newop = newUNOP(OP_NULL, 0, other);
4041 op_getmad(first, newop, '1');
4042 newop->op_targ = type; /* set "was" field */
4049 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
4050 const OP *o2 = other;
4051 if ( ! (o2->op_type == OP_LIST
4052 && (( o2 = cUNOPx(o2)->op_first))
4053 && o2->op_type == OP_PUSHMARK
4054 && (( o2 = o2->op_sibling)) )
4057 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
4058 || o2->op_type == OP_PADHV)
4059 && o2->op_private & OPpLVAL_INTRO
4060 && ckWARN(WARN_DEPRECATED))
4062 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4063 "Deprecated use of my() in false conditional");
4067 if (first->op_type == OP_CONST)
4068 first->op_private |= OPpCONST_SHORTCIRCUIT;
4070 first = newUNOP(OP_NULL, 0, first);
4071 op_getmad(other, first, '2');
4072 first->op_targ = type; /* set "was" field */
4079 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
4080 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
4082 const OP * const k1 = ((UNOP*)first)->op_first;
4083 const OP * const k2 = k1->op_sibling;
4085 switch (first->op_type)
4088 if (k2 && k2->op_type == OP_READLINE
4089 && (k2->op_flags & OPf_STACKED)
4090 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4092 warnop = k2->op_type;
4097 if (k1->op_type == OP_READDIR
4098 || k1->op_type == OP_GLOB
4099 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4100 || k1->op_type == OP_EACH)
4102 warnop = ((k1->op_type == OP_NULL)
4103 ? (OPCODE)k1->op_targ : k1->op_type);
4108 const line_t oldline = CopLINE(PL_curcop);
4109 CopLINE_set(PL_curcop, PL_copline);
4110 Perl_warner(aTHX_ packWARN(WARN_MISC),
4111 "Value of %s%s can be \"0\"; test with defined()",
4113 ((warnop == OP_READLINE || warnop == OP_GLOB)
4114 ? " construct" : "() operator"));
4115 CopLINE_set(PL_curcop, oldline);
4122 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
4123 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
4125 NewOp(1101, logop, 1, LOGOP);
4127 logop->op_type = (OPCODE)type;
4128 logop->op_ppaddr = PL_ppaddr[type];
4129 logop->op_first = first;
4130 logop->op_flags = (U8)(flags | OPf_KIDS);
4131 logop->op_other = LINKLIST(other);
4132 logop->op_private = (U8)(1 | (flags >> 8));
4134 /* establish postfix order */
4135 logop->op_next = LINKLIST(first);
4136 first->op_next = (OP*)logop;
4137 first->op_sibling = other;
4139 CHECKOP(type,logop);
4141 o = newUNOP(OP_NULL, 0, (OP*)logop);
4148 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
4156 return newLOGOP(OP_AND, 0, first, trueop);
4158 return newLOGOP(OP_OR, 0, first, falseop);
4160 scalarboolean(first);
4161 if (first->op_type == OP_CONST) {
4162 if (first->op_private & OPpCONST_BARE &&
4163 first->op_private & OPpCONST_STRICT) {
4164 no_bareword_allowed(first);
4166 if (SvTRUE(((SVOP*)first)->op_sv)) {
4169 trueop = newUNOP(OP_NULL, 0, trueop);
4170 op_getmad(first,trueop,'C');
4171 op_getmad(falseop,trueop,'e');
4173 /* FIXME for MAD - should there be an ELSE here? */
4183 falseop = newUNOP(OP_NULL, 0, falseop);
4184 op_getmad(first,falseop,'C');
4185 op_getmad(trueop,falseop,'t');
4187 /* FIXME for MAD - should there be an ELSE here? */
4195 NewOp(1101, logop, 1, LOGOP);
4196 logop->op_type = OP_COND_EXPR;
4197 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4198 logop->op_first = first;
4199 logop->op_flags = (U8)(flags | OPf_KIDS);
4200 logop->op_private = (U8)(1 | (flags >> 8));
4201 logop->op_other = LINKLIST(trueop);
4202 logop->op_next = LINKLIST(falseop);
4204 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
4207 /* establish postfix order */
4208 start = LINKLIST(first);
4209 first->op_next = (OP*)logop;
4211 first->op_sibling = trueop;
4212 trueop->op_sibling = falseop;
4213 o = newUNOP(OP_NULL, 0, (OP*)logop);
4215 trueop->op_next = falseop->op_next = o;
4222 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4231 NewOp(1101, range, 1, LOGOP);
4233 range->op_type = OP_RANGE;
4234 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4235 range->op_first = left;
4236 range->op_flags = OPf_KIDS;
4237 leftstart = LINKLIST(left);
4238 range->op_other = LINKLIST(right);
4239 range->op_private = (U8)(1 | (flags >> 8));
4241 left->op_sibling = right;
4243 range->op_next = (OP*)range;
4244 flip = newUNOP(OP_FLIP, flags, (OP*)range);
4245 flop = newUNOP(OP_FLOP, 0, flip);
4246 o = newUNOP(OP_NULL, 0, flop);
4248 range->op_next = leftstart;
4250 left->op_next = flip;
4251 right->op_next = flop;
4253 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4254 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4255 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4256 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4258 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4259 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4262 if (!flip->op_private || !flop->op_private)
4263 linklist(o); /* blow off optimizer unless constant */
4269 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4274 const bool once = block && block->op_flags & OPf_SPECIAL &&
4275 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4277 PERL_UNUSED_ARG(debuggable);
4280 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4281 return block; /* do {} while 0 does once */
4282 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4283 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4284 expr = newUNOP(OP_DEFINED, 0,
4285 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4286 } else if (expr->op_flags & OPf_KIDS) {
4287 const OP * const k1 = ((UNOP*)expr)->op_first;
4288 const OP * const k2 = k1 ? k1->op_sibling : NULL;
4289 switch (expr->op_type) {
4291 if (k2 && k2->op_type == OP_READLINE
4292 && (k2->op_flags & OPf_STACKED)
4293 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4294 expr = newUNOP(OP_DEFINED, 0, expr);
4298 if (k1 && (k1->op_type == OP_READDIR
4299 || k1->op_type == OP_GLOB
4300 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4301 || k1->op_type == OP_EACH))
4302 expr = newUNOP(OP_DEFINED, 0, expr);
4308 /* if block is null, the next append_elem() would put UNSTACK, a scalar
4309 * op, in listop. This is wrong. [perl #27024] */
4311 block = newOP(OP_NULL, 0);
4312 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4313 o = new_logop(OP_AND, 0, &expr, &listop);
4316 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4318 if (once && o != listop)
4319 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4322 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
4324 o->op_flags |= flags;
4326 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4331 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
4332 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
4341 PERL_UNUSED_ARG(debuggable);
4344 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4345 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4346 expr = newUNOP(OP_DEFINED, 0,
4347 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4348 } else if (expr->op_flags & OPf_KIDS) {
4349 const OP * const k1 = ((UNOP*)expr)->op_first;
4350 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
4351 switch (expr->op_type) {
4353 if (k2 && k2->op_type == OP_READLINE
4354 && (k2->op_flags & OPf_STACKED)
4355 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4356 expr = newUNOP(OP_DEFINED, 0, expr);
4360 if (k1 && (k1->op_type == OP_READDIR
4361 || k1->op_type == OP_GLOB
4362 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4363 || k1->op_type == OP_EACH))
4364 expr = newUNOP(OP_DEFINED, 0, expr);
4371 block = newOP(OP_NULL, 0);
4372 else if (cont || has_my) {
4373 block = scope(block);
4377 next = LINKLIST(cont);
4380 OP * const unstack = newOP(OP_UNSTACK, 0);
4383 cont = append_elem(OP_LINESEQ, cont, unstack);
4386 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4387 redo = LINKLIST(listop);
4390 PL_copline = (line_t)whileline;
4392 o = new_logop(OP_AND, 0, &expr, &listop);
4393 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4394 op_free(expr); /* oops, it's a while (0) */
4396 return NULL; /* listop already freed by new_logop */
4399 ((LISTOP*)listop)->op_last->op_next =
4400 (o == listop ? redo : LINKLIST(o));
4406 NewOp(1101,loop,1,LOOP);
4407 loop->op_type = OP_ENTERLOOP;
4408 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4409 loop->op_private = 0;
4410 loop->op_next = (OP*)loop;
4413 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4415 loop->op_redoop = redo;
4416 loop->op_lastop = o;
4417 o->op_private |= loopflags;
4420 loop->op_nextop = next;
4422 loop->op_nextop = o;
4424 o->op_flags |= flags;
4425 o->op_private |= (flags >> 8);
4430 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
4435 PADOFFSET padoff = 0;
4441 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4442 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
4443 sv->op_type = OP_RV2GV;
4444 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4445 if (cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
4446 iterpflags |= OPpITER_DEF;
4448 else if (sv->op_type == OP_PADSV) { /* private variable */
4449 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
4450 padoff = sv->op_targ;
4459 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4460 padoff = sv->op_targ;
4465 iterflags |= OPf_SPECIAL;
4471 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4472 if (padoff && strEQ(PAD_COMPNAME_PV(padoff), "$_"))
4473 iterpflags |= OPpITER_DEF;
4476 const I32 offset = pad_findmy("$_");
4477 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
4478 sv = newGVOP(OP_GV, 0, PL_defgv);
4483 iterpflags |= OPpITER_DEF;
4485 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4486 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4487 iterflags |= OPf_STACKED;
4489 else if (expr->op_type == OP_NULL &&
4490 (expr->op_flags & OPf_KIDS) &&
4491 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4493 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4494 * set the STACKED flag to indicate that these values are to be
4495 * treated as min/max values by 'pp_iterinit'.
4497 UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4498 LOGOP* const range = (LOGOP*) flip->op_first;
4499 OP* const left = range->op_first;
4500 OP* const right = left->op_sibling;
4503 range->op_flags &= ~OPf_KIDS;
4504 range->op_first = NULL;
4506 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4507 listop->op_first->op_next = range->op_next;
4508 left->op_next = range->op_other;
4509 right->op_next = (OP*)listop;
4510 listop->op_next = listop->op_first;
4513 op_getmad(expr,(OP*)listop,'O');
4517 expr = (OP*)(listop);
4519 iterflags |= OPf_STACKED;
4522 expr = mod(force_list(expr), OP_GREPSTART);
4525 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4526 append_elem(OP_LIST, expr, scalar(sv))));
4527 assert(!loop->op_next);
4528 /* for my $x () sets OPpLVAL_INTRO;
4529 * for our $x () sets OPpOUR_INTRO */
4530 loop->op_private = (U8)iterpflags;
4531 #ifdef PL_OP_SLAB_ALLOC
4534 NewOp(1234,tmp,1,LOOP);
4535 Copy(loop,tmp,1,LISTOP);
4540 Renew(loop, 1, LOOP);
4542 loop->op_targ = padoff;
4543 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
4545 op_getmad(madsv, (OP*)loop, 'v');
4546 PL_copline = forline;
4547 return newSTATEOP(0, label, wop);
4551 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4556 if (type != OP_GOTO || label->op_type == OP_CONST) {
4557 /* "last()" means "last" */
4558 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4559 o = newOP(type, OPf_SPECIAL);
4561 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4562 ? SvPVx_nolen_const(((SVOP*)label)->op_sv)
4566 op_getmad(label,o,'L');
4572 /* Check whether it's going to be a goto &function */
4573 if (label->op_type == OP_ENTERSUB
4574 && !(label->op_flags & OPf_STACKED))
4575 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4576 o = newUNOP(type, OPf_STACKED, label);
4578 PL_hints |= HINT_BLOCK_SCOPE;
4582 /* if the condition is a literal array or hash
4583 (or @{ ... } etc), make a reference to it.
4586 S_ref_array_or_hash(pTHX_ OP *cond)
4589 && (cond->op_type == OP_RV2AV
4590 || cond->op_type == OP_PADAV
4591 || cond->op_type == OP_RV2HV
4592 || cond->op_type == OP_PADHV))
4594 return newUNOP(OP_REFGEN,
4595 0, mod(cond, OP_REFGEN));
4601 /* These construct the optree fragments representing given()
4604 entergiven and enterwhen are LOGOPs; the op_other pointer
4605 points up to the associated leave op. We need this so we
4606 can put it in the context and make break/continue work.
4607 (Also, of course, pp_enterwhen will jump straight to
4608 op_other if the match fails.)
4613 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
4614 I32 enter_opcode, I32 leave_opcode,
4615 PADOFFSET entertarg)
4621 NewOp(1101, enterop, 1, LOGOP);
4622 enterop->op_type = enter_opcode;
4623 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
4624 enterop->op_flags = (U8) OPf_KIDS;
4625 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
4626 enterop->op_private = 0;
4628 o = newUNOP(leave_opcode, 0, (OP *) enterop);
4631 enterop->op_first = scalar(cond);
4632 cond->op_sibling = block;
4634 o->op_next = LINKLIST(cond);
4635 cond->op_next = (OP *) enterop;
4638 /* This is a default {} block */
4639 enterop->op_first = block;
4640 enterop->op_flags |= OPf_SPECIAL;
4642 o->op_next = (OP *) enterop;
4645 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
4646 entergiven and enterwhen both
4649 enterop->op_next = LINKLIST(block);
4650 block->op_next = enterop->op_other = o;
4655 /* Does this look like a boolean operation? For these purposes
4656 a boolean operation is:
4657 - a subroutine call [*]
4658 - a logical connective
4659 - a comparison operator
4660 - a filetest operator, with the exception of -s -M -A -C
4661 - defined(), exists() or eof()
4662 - /$re/ or $foo =~ /$re/
4664 [*] possibly surprising
4668 S_looks_like_bool(pTHX_ const OP *o)
4671 switch(o->op_type) {
4673 return looks_like_bool(cLOGOPo->op_first);
4677 looks_like_bool(cLOGOPo->op_first)
4678 && looks_like_bool(cLOGOPo->op_first->op_sibling));
4682 case OP_NOT: case OP_XOR:
4683 /* Note that OP_DOR is not here */
4685 case OP_EQ: case OP_NE: case OP_LT:
4686 case OP_GT: case OP_LE: case OP_GE:
4688 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
4689 case OP_I_GT: case OP_I_LE: case OP_I_GE:
4691 case OP_SEQ: case OP_SNE: case OP_SLT:
4692 case OP_SGT: case OP_SLE: case OP_SGE:
4696 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
4697 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
4698 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
4699 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
4700 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
4701 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
4702 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
4703 case OP_FTTEXT: case OP_FTBINARY:
4705 case OP_DEFINED: case OP_EXISTS:
4706 case OP_MATCH: case OP_EOF:
4711 /* Detect comparisons that have been optimized away */
4712 if (cSVOPo->op_sv == &PL_sv_yes
4713 || cSVOPo->op_sv == &PL_sv_no)
4724 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
4728 return newGIVWHENOP(
4729 ref_array_or_hash(cond),
4731 OP_ENTERGIVEN, OP_LEAVEGIVEN,
4735 /* If cond is null, this is a default {} block */
4737 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
4739 const bool cond_llb = (!cond || looks_like_bool(cond));
4745 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
4747 scalar(ref_array_or_hash(cond)));
4750 return newGIVWHENOP(
4752 append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
4753 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
4757 =for apidoc cv_undef
4759 Clear out all the active components of a CV. This can happen either
4760 by an explicit C<undef &foo>, or by the reference count going to zero.
4761 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
4762 children can still follow the full lexical scope chain.
4768 Perl_cv_undef(pTHX_ CV *cv)
4772 if (CvFILE(cv) && !CvISXSUB(cv)) {
4773 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4774 Safefree(CvFILE(cv));
4779 if (!CvISXSUB(cv) && CvROOT(cv)) {
4780 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
4781 Perl_croak(aTHX_ "Can't undef active subroutine");
4784 PAD_SAVE_SETNULLPAD();
4786 op_free(CvROOT(cv));
4791 SvPOK_off((SV*)cv); /* forget prototype */
4796 /* remove CvOUTSIDE unless this is an undef rather than a free */
4797 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
4798 if (!CvWEAKOUTSIDE(cv))
4799 SvREFCNT_dec(CvOUTSIDE(cv));
4800 CvOUTSIDE(cv) = NULL;
4803 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4806 if (CvISXSUB(cv) && CvXSUB(cv)) {
4809 /* delete all flags except WEAKOUTSIDE */
4810 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
4814 Perl_cv_ckproto(pTHX_ const CV *cv, const GV *gv, const char *p)
4816 if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX_const(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4817 SV* const msg = sv_newmortal();
4821 gv_efullname3(name = sv_newmortal(), gv, NULL);
4822 sv_setpv(msg, "Prototype mismatch:");
4824 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4826 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (const SV *)cv);
4828 sv_catpvs(msg, ": none");
4829 sv_catpvs(msg, " vs ");
4831 Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4833 sv_catpvs(msg, "none");
4834 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
4838 static void const_sv_xsub(pTHX_ CV* cv);
4842 =head1 Optree Manipulation Functions
4844 =for apidoc cv_const_sv
4846 If C<cv> is a constant sub eligible for inlining. returns the constant
4847 value returned by the sub. Otherwise, returns NULL.
4849 Constant subs can be created with C<newCONSTSUB> or as described in
4850 L<perlsub/"Constant Functions">.
4855 Perl_cv_const_sv(pTHX_ CV *cv)
4857 PERL_UNUSED_CONTEXT;
4860 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
4862 return CvCONST(cv) ? (SV*)CvXSUBANY(cv).any_ptr : NULL;
4865 /* op_const_sv: examine an optree to determine whether it's in-lineable.
4866 * Can be called in 3 ways:
4869 * look for a single OP_CONST with attached value: return the value
4871 * cv && CvCLONE(cv) && !CvCONST(cv)
4873 * examine the clone prototype, and if contains only a single
4874 * OP_CONST referencing a pad const, or a single PADSV referencing
4875 * an outer lexical, return a non-zero value to indicate the CV is
4876 * a candidate for "constizing" at clone time
4880 * We have just cloned an anon prototype that was marked as a const
4881 * candidiate. Try to grab the current value, and in the case of
4882 * PADSV, ignore it if it has multiple references. Return the value.
4886 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
4894 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4895 o = cLISTOPo->op_first->op_sibling;
4897 for (; o; o = o->op_next) {
4898 const OPCODE type = o->op_type;
4900 if (sv && o->op_next == o)
4902 if (o->op_next != o) {
4903 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4905 if (type == OP_DBSTATE)
4908 if (type == OP_LEAVESUB || type == OP_RETURN)
4912 if (type == OP_CONST && cSVOPo->op_sv)
4914 else if (cv && type == OP_CONST) {
4915 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4919 else if (cv && type == OP_PADSV) {
4920 if (CvCONST(cv)) { /* newly cloned anon */
4921 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4922 /* the candidate should have 1 ref from this pad and 1 ref
4923 * from the parent */
4924 if (!sv || SvREFCNT(sv) != 2)
4931 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
4932 sv = &PL_sv_undef; /* an arbitrary non-null value */
4947 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4950 /* This would be the return value, but the return cannot be reached. */
4951 OP* pegop = newOP(OP_NULL, 0);
4954 PERL_UNUSED_ARG(floor);
4964 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4966 NORETURN_FUNCTION_END;
4971 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4973 return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
4977 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4984 register CV *cv = NULL;
4986 /* If the subroutine has no body, no attributes, and no builtin attributes
4987 then it's just a sub declaration, and we may be able to get away with
4988 storing with a placeholder scalar in the symbol table, rather than a
4989 full GV and CV. If anything is present then it will take a full CV to
4991 const I32 gv_fetch_flags
4992 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
4994 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
4995 const char * const name = o ? SvPVx_nolen_const(cSVOPo->op_sv) : NULL;
4998 assert(proto->op_type == OP_CONST);
4999 ps = SvPVx_const(((SVOP*)proto)->op_sv, ps_len);
5004 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
5005 SV * const sv = sv_newmortal();
5006 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
5007 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
5008 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
5009 aname = SvPVX_const(sv);
5014 gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
5015 : gv_fetchpv(aname ? aname
5016 : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5017 gv_fetch_flags, SVt_PVCV);
5019 if (!PL_madskills) {
5028 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
5029 maximum a prototype before. */
5030 if (SvTYPE(gv) > SVt_NULL) {
5031 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
5032 && ckWARN_d(WARN_PROTOTYPE))
5034 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
5036 cv_ckproto((CV*)gv, NULL, ps);
5039 sv_setpvn((SV*)gv, ps, ps_len);
5041 sv_setiv((SV*)gv, -1);
5042 SvREFCNT_dec(PL_compcv);
5043 cv = PL_compcv = NULL;
5044 PL_sub_generation++;
5048 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
5050 #ifdef GV_UNIQUE_CHECK
5051 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
5052 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
5056 if (!block || !ps || *ps || attrs
5057 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5059 || block->op_type == OP_NULL
5064 const_sv = op_const_sv(block, NULL);
5067 const bool exists = CvROOT(cv) || CvXSUB(cv);
5069 #ifdef GV_UNIQUE_CHECK
5070 if (exists && GvUNIQUE(gv)) {
5071 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
5075 /* if the subroutine doesn't exist and wasn't pre-declared
5076 * with a prototype, assume it will be AUTOLOADed,
5077 * skipping the prototype check
5079 if (exists || SvPOK(cv))
5080 cv_ckproto(cv, gv, ps);
5081 /* already defined (or promised)? */
5082 if (exists || GvASSUMECV(gv)) {
5085 || block->op_type == OP_NULL
5088 if (CvFLAGS(PL_compcv)) {
5089 /* might have had built-in attrs applied */
5090 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5092 /* just a "sub foo;" when &foo is already defined */
5093 SAVEFREESV(PL_compcv);
5098 && block->op_type != OP_NULL
5101 if (ckWARN(WARN_REDEFINE)
5103 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
5105 const line_t oldline = CopLINE(PL_curcop);
5106 if (PL_copline != NOLINE)
5107 CopLINE_set(PL_curcop, PL_copline);
5108 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5109 CvCONST(cv) ? "Constant subroutine %s redefined"
5110 : "Subroutine %s redefined", name);
5111 CopLINE_set(PL_curcop, oldline);
5114 if (!PL_minus_c) /* keep old one around for madskills */
5117 /* (PL_madskills unset in used file.) */
5125 SvREFCNT_inc_void_NN(const_sv);
5127 assert(!CvROOT(cv) && !CvCONST(cv));
5128 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
5129 CvXSUBANY(cv).any_ptr = const_sv;
5130 CvXSUB(cv) = const_sv_xsub;
5136 cv = newCONSTSUB(NULL, name, const_sv);
5138 PL_sub_generation++;
5142 SvREFCNT_dec(PL_compcv);
5150 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
5151 * before we clobber PL_compcv.
5155 || block->op_type == OP_NULL
5159 /* Might have had built-in attributes applied -- propagate them. */
5160 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5161 if (CvGV(cv) && GvSTASH(CvGV(cv)))
5162 stash = GvSTASH(CvGV(cv));
5163 else if (CvSTASH(cv))
5164 stash = CvSTASH(cv);
5166 stash = PL_curstash;
5169 /* possibly about to re-define existing subr -- ignore old cv */
5170 rcv = (SV*)PL_compcv;
5171 if (name && GvSTASH(gv))
5172 stash = GvSTASH(gv);
5174 stash = PL_curstash;
5176 apply_attrs(stash, rcv, attrs, FALSE);
5178 if (cv) { /* must reuse cv if autoloaded */
5185 || block->op_type == OP_NULL) && !PL_madskills
5188 /* got here with just attrs -- work done, so bug out */
5189 SAVEFREESV(PL_compcv);
5192 /* transfer PL_compcv to cv */
5194 CvFLAGS(cv) = CvFLAGS(PL_compcv);
5195 if (!CvWEAKOUTSIDE(cv))
5196 SvREFCNT_dec(CvOUTSIDE(cv));
5197 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
5198 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
5199 CvOUTSIDE(PL_compcv) = 0;
5200 CvPADLIST(cv) = CvPADLIST(PL_compcv);
5201 CvPADLIST(PL_compcv) = 0;
5202 /* inner references to PL_compcv must be fixed up ... */
5203 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
5204 /* ... before we throw it away */
5205 SvREFCNT_dec(PL_compcv);
5207 if (PERLDB_INTER)/* Advice debugger on the new sub. */
5208 ++PL_sub_generation;
5215 if (strEQ(name, "import")) {
5216 PL_formfeed = (SV*)cv;
5217 Perl_warner(aTHX_ packWARN(WARN_VOID), "%lx\n", (long)cv);
5221 PL_sub_generation++;
5225 CvFILE_set_from_cop(cv, PL_curcop);
5226 CvSTASH(cv) = PL_curstash;
5229 sv_setpvn((SV*)cv, ps, ps_len);
5231 if (PL_error_count) {
5235 const char *s = strrchr(name, ':');
5237 if (strEQ(s, "BEGIN")) {
5238 const char not_safe[] =
5239 "BEGIN not safe after errors--compilation aborted";
5240 if (PL_in_eval & EVAL_KEEPERR)
5241 Perl_croak(aTHX_ not_safe);
5243 /* force display of errors found but not reported */
5244 sv_catpv(ERRSV, not_safe);
5245 Perl_croak(aTHX_ "%"SVf, ERRSV);
5255 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5256 mod(scalarseq(block), OP_LEAVESUBLV));
5259 /* This makes sub {}; work as expected. */
5260 if (block->op_type == OP_STUB) {
5261 OP* newblock = newSTATEOP(0, NULL, 0);
5263 op_getmad(block,newblock,'B');
5269 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5271 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5272 OpREFCNT_set(CvROOT(cv), 1);
5273 CvSTART(cv) = LINKLIST(CvROOT(cv));
5274 CvROOT(cv)->op_next = 0;
5275 CALL_PEEP(CvSTART(cv));
5277 /* now that optimizer has done its work, adjust pad values */
5279 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
5282 assert(!CvCONST(cv));
5283 if (ps && !*ps && op_const_sv(block, cv))
5287 if (name || aname) {
5289 const char * const tname = (name ? name : aname);
5291 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5292 SV * const sv = newSV(0);
5293 SV * const tmpstr = sv_newmortal();
5294 GV * const db_postponed = gv_fetchpvs("DB::postponed",
5295 GV_ADDMULTI, SVt_PVHV);
5298 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5300 (long)PL_subline, (long)CopLINE(PL_curcop));
5301 gv_efullname3(tmpstr, gv, NULL);
5302 hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0);
5303 hv = GvHVn(db_postponed);
5304 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
5305 CV * const pcv = GvCV(db_postponed);
5311 call_sv((SV*)pcv, G_DISCARD);
5316 if ((s = strrchr(tname,':')))
5321 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5324 if (strEQ(s, "BEGIN") && !PL_error_count) {
5325 const I32 oldscope = PL_scopestack_ix;
5327 SAVECOPFILE(&PL_compiling);
5328 SAVECOPLINE(&PL_compiling);
5331 PL_beginav = newAV();
5332 DEBUG_x( dump_sub(gv) );
5333 av_push(PL_beginav, (SV*)cv);
5334 GvCV(gv) = 0; /* cv has been hijacked */
5335 call_list(oldscope, PL_beginav);
5337 PL_curcop = &PL_compiling;
5338 PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
5341 else if (strEQ(s, "END") && !PL_error_count) {
5344 DEBUG_x( dump_sub(gv) );
5345 av_unshift(PL_endav, 1);
5346 av_store(PL_endav, 0, (SV*)cv);
5347 GvCV(gv) = 0; /* cv has been hijacked */
5349 else if (strEQ(s, "CHECK") && !PL_error_count) {
5351 PL_checkav = newAV();
5352 DEBUG_x( dump_sub(gv) );
5353 if (PL_main_start && ckWARN(WARN_VOID))
5354 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
5355 av_unshift(PL_checkav, 1);
5356 av_store(PL_checkav, 0, (SV*)cv);
5357 GvCV(gv) = 0; /* cv has been hijacked */
5359 else if (strEQ(s, "INIT") && !PL_error_count) {
5361 PL_initav = newAV();
5362 DEBUG_x( dump_sub(gv) );
5363 if (PL_main_start && ckWARN(WARN_VOID))
5364 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
5365 av_push(PL_initav, (SV*)cv);
5366 GvCV(gv) = 0; /* cv has been hijacked */
5371 PL_copline = NOLINE;
5376 /* XXX unsafe for threads if eval_owner isn't held */
5378 =for apidoc newCONSTSUB
5380 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5381 eligible for inlining at compile-time.
5387 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
5394 SAVECOPLINE(PL_curcop);
5395 CopLINE_set(PL_curcop, PL_copline);
5398 PL_hints &= ~HINT_BLOCK_SCOPE;
5401 SAVESPTR(PL_curstash);
5402 SAVECOPSTASH(PL_curcop);
5403 PL_curstash = stash;
5404 CopSTASH_set(PL_curcop,stash);
5407 cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
5408 CvXSUBANY(cv).any_ptr = sv;
5410 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
5414 CopSTASH_free(PL_curcop);
5422 =for apidoc U||newXS
5424 Used by C<xsubpp> to hook up XSUBs as Perl subs.
5430 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
5433 GV * const gv = gv_fetchpv(name ? name :
5434 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5435 GV_ADDMULTI, SVt_PVCV);
5439 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
5441 if ((cv = (name ? GvCV(gv) : NULL))) {
5443 /* just a cached method */
5447 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5448 /* already defined (or promised) */
5449 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
5450 if (ckWARN(WARN_REDEFINE)) {
5451 GV * const gvcv = CvGV(cv);
5453 HV * const stash = GvSTASH(gvcv);
5455 const char *redefined_name = HvNAME_get(stash);
5456 if ( strEQ(redefined_name,"autouse") ) {
5457 const line_t oldline = CopLINE(PL_curcop);
5458 if (PL_copline != NOLINE)
5459 CopLINE_set(PL_curcop, PL_copline);
5460 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5461 CvCONST(cv) ? "Constant subroutine %s redefined"
5462 : "Subroutine %s redefined"
5464 CopLINE_set(PL_curcop, oldline);
5474 if (cv) /* must reuse cv if autoloaded */
5478 sv_upgrade((SV *)cv, SVt_PVCV);
5482 PL_sub_generation++;
5486 (void)gv_fetchfile(filename);
5487 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
5488 an external constant string */
5490 CvXSUB(cv) = subaddr;
5493 const char *s = strrchr(name,':');
5499 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5502 if (strEQ(s, "BEGIN")) {
5504 PL_beginav = newAV();
5505 av_push(PL_beginav, (SV*)cv);
5506 GvCV(gv) = 0; /* cv has been hijacked */
5508 else if (strEQ(s, "END")) {
5511 av_unshift(PL_endav, 1);
5512 av_store(PL_endav, 0, (SV*)cv);
5513 GvCV(gv) = 0; /* cv has been hijacked */
5515 else if (strEQ(s, "CHECK")) {
5517 PL_checkav = newAV();
5518 if (PL_main_start && ckWARN(WARN_VOID))
5519 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
5520 av_unshift(PL_checkav, 1);
5521 av_store(PL_checkav, 0, (SV*)cv);
5522 GvCV(gv) = 0; /* cv has been hijacked */
5524 else if (strEQ(s, "INIT")) {
5526 PL_initav = newAV();
5527 if (PL_main_start && ckWARN(WARN_VOID))
5528 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
5529 av_push(PL_initav, (SV*)cv);
5530 GvCV(gv) = 0; /* cv has been hijacked */
5545 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5550 OP* pegop = newOP(OP_NULL, 0);
5554 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
5555 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
5557 #ifdef GV_UNIQUE_CHECK
5559 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5563 if ((cv = GvFORM(gv))) {
5564 if (ckWARN(WARN_REDEFINE)) {
5565 const line_t oldline = CopLINE(PL_curcop);
5566 if (PL_copline != NOLINE)
5567 CopLINE_set(PL_curcop, PL_copline);
5568 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5569 o ? "Format %"SVf" redefined"
5570 : "Format STDOUT redefined" ,cSVOPo->op_sv);
5571 CopLINE_set(PL_curcop, oldline);
5578 CvFILE_set_from_cop(cv, PL_curcop);
5581 pad_tidy(padtidy_FORMAT);
5582 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5583 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5584 OpREFCNT_set(CvROOT(cv), 1);
5585 CvSTART(cv) = LINKLIST(CvROOT(cv));
5586 CvROOT(cv)->op_next = 0;
5587 CALL_PEEP(CvSTART(cv));
5589 op_getmad(o,pegop,'n');
5590 op_getmad_weak(block, pegop, 'b');
5594 PL_copline = NOLINE;
5602 Perl_newANONLIST(pTHX_ OP *o)
5604 return newUNOP(OP_REFGEN, 0,
5605 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5609 Perl_newANONHASH(pTHX_ OP *o)
5611 return newUNOP(OP_REFGEN, 0,
5612 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5616 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5618 return newANONATTRSUB(floor, proto, NULL, block);
5622 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5624 return newUNOP(OP_REFGEN, 0,
5625 newSVOP(OP_ANONCODE, 0,
5626 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5630 Perl_oopsAV(pTHX_ OP *o)
5633 switch (o->op_type) {
5635 o->op_type = OP_PADAV;
5636 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5637 return ref(o, OP_RV2AV);
5640 o->op_type = OP_RV2AV;
5641 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5646 if (ckWARN_d(WARN_INTERNAL))
5647 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
5654 Perl_oopsHV(pTHX_ OP *o)
5657 switch (o->op_type) {
5660 o->op_type = OP_PADHV;
5661 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5662 return ref(o, OP_RV2HV);
5666 o->op_type = OP_RV2HV;
5667 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5672 if (ckWARN_d(WARN_INTERNAL))
5673 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
5680 Perl_newAVREF(pTHX_ OP *o)
5683 if (o->op_type == OP_PADANY) {
5684 o->op_type = OP_PADAV;
5685 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5688 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5689 && ckWARN(WARN_DEPRECATED)) {
5690 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5691 "Using an array as a reference is deprecated");
5693 return newUNOP(OP_RV2AV, 0, scalar(o));
5697 Perl_newGVREF(pTHX_ I32 type, OP *o)
5699 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5700 return newUNOP(OP_NULL, 0, o);
5701 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5705 Perl_newHVREF(pTHX_ OP *o)
5708 if (o->op_type == OP_PADANY) {
5709 o->op_type = OP_PADHV;
5710 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5713 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5714 && ckWARN(WARN_DEPRECATED)) {
5715 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5716 "Using a hash as a reference is deprecated");
5718 return newUNOP(OP_RV2HV, 0, scalar(o));
5722 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5724 return newUNOP(OP_RV2CV, flags, scalar(o));
5728 Perl_newSVREF(pTHX_ OP *o)
5731 if (o->op_type == OP_PADANY) {
5732 o->op_type = OP_PADSV;
5733 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5736 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5737 o->op_flags |= OPpDONE_SVREF;
5740 return newUNOP(OP_RV2SV, 0, scalar(o));
5743 /* Check routines. See the comments at the top of this file for details
5744 * on when these are called */
5747 Perl_ck_anoncode(pTHX_ OP *o)
5749 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
5751 cSVOPo->op_sv = NULL;
5756 Perl_ck_bitop(pTHX_ OP *o)
5759 #define OP_IS_NUMCOMPARE(op) \
5760 ((op) == OP_LT || (op) == OP_I_LT || \
5761 (op) == OP_GT || (op) == OP_I_GT || \
5762 (op) == OP_LE || (op) == OP_I_LE || \
5763 (op) == OP_GE || (op) == OP_I_GE || \
5764 (op) == OP_EQ || (op) == OP_I_EQ || \
5765 (op) == OP_NE || (op) == OP_I_NE || \
5766 (op) == OP_NCMP || (op) == OP_I_NCMP)
5767 o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
5768 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
5769 && (o->op_type == OP_BIT_OR
5770 || o->op_type == OP_BIT_AND
5771 || o->op_type == OP_BIT_XOR))
5773 const OP * const left = cBINOPo->op_first;
5774 const OP * const right = left->op_sibling;
5775 if ((OP_IS_NUMCOMPARE(left->op_type) &&
5776 (left->op_flags & OPf_PARENS) == 0) ||
5777 (OP_IS_NUMCOMPARE(right->op_type) &&
5778 (right->op_flags & OPf_PARENS) == 0))
5779 if (ckWARN(WARN_PRECEDENCE))
5780 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
5781 "Possible precedence problem on bitwise %c operator",
5782 o->op_type == OP_BIT_OR ? '|'
5783 : o->op_type == OP_BIT_AND ? '&' : '^'
5790 Perl_ck_concat(pTHX_ OP *o)
5792 const OP * const kid = cUNOPo->op_first;
5793 PERL_UNUSED_CONTEXT;
5794 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
5795 !(kUNOP->op_first->op_flags & OPf_MOD))
5796 o->op_flags |= OPf_STACKED;
5801 Perl_ck_spair(pTHX_ OP *o)
5804 if (o->op_flags & OPf_KIDS) {
5807 const OPCODE type = o->op_type;
5808 o = modkids(ck_fun(o), type);
5809 kid = cUNOPo->op_first;
5810 newop = kUNOP->op_first->op_sibling;
5812 (newop->op_sibling ||
5813 !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5814 newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5815 newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5820 op_getmad(kUNOP->op_first,newop,'K');
5822 op_free(kUNOP->op_first);
5824 kUNOP->op_first = newop;
5826 o->op_ppaddr = PL_ppaddr[++o->op_type];
5831 Perl_ck_delete(pTHX_ OP *o)
5835 if (o->op_flags & OPf_KIDS) {
5836 OP * const kid = cUNOPo->op_first;
5837 switch (kid->op_type) {
5839 o->op_flags |= OPf_SPECIAL;
5842 o->op_private |= OPpSLICE;
5845 o->op_flags |= OPf_SPECIAL;
5850 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5859 Perl_ck_die(pTHX_ OP *o)
5862 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5868 Perl_ck_eof(pTHX_ OP *o)
5872 if (o->op_flags & OPf_KIDS) {
5873 if (cLISTOPo->op_first->op_type == OP_STUB) {
5875 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
5877 op_getmad(o,newop,'O');
5889 Perl_ck_eval(pTHX_ OP *o)
5892 PL_hints |= HINT_BLOCK_SCOPE;
5893 if (o->op_flags & OPf_KIDS) {
5894 SVOP * const kid = (SVOP*)cUNOPo->op_first;
5897 o->op_flags &= ~OPf_KIDS;
5900 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
5906 cUNOPo->op_first = 0;
5911 NewOp(1101, enter, 1, LOGOP);
5912 enter->op_type = OP_ENTERTRY;
5913 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5914 enter->op_private = 0;
5916 /* establish postfix order */
5917 enter->op_next = (OP*)enter;
5919 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5920 o->op_type = OP_LEAVETRY;
5921 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5922 enter->op_other = o;
5923 op_getmad(oldo,o,'O');
5937 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5938 op_getmad(oldo,o,'O');
5940 o->op_targ = (PADOFFSET)PL_hints;
5941 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
5942 /* Store a copy of %^H that pp_entereval can pick up */
5943 OP *hhop = newSVOP(OP_CONST, 0, (SV*)newHVhv(GvHV(PL_hintgv)));
5944 cUNOPo->op_first->op_sibling = hhop;
5945 o->op_private |= OPpEVAL_HAS_HH;
5951 Perl_ck_exit(pTHX_ OP *o)
5954 HV * const table = GvHV(PL_hintgv);
5956 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
5957 if (svp && *svp && SvTRUE(*svp))
5958 o->op_private |= OPpEXIT_VMSISH;
5960 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5966 Perl_ck_exec(pTHX_ OP *o)
5968 if (o->op_flags & OPf_STACKED) {
5971 kid = cUNOPo->op_first->op_sibling;
5972 if (kid->op_type == OP_RV2GV)
5981 Perl_ck_exists(pTHX_ OP *o)
5985 if (o->op_flags & OPf_KIDS) {
5986 OP * const kid = cUNOPo->op_first;
5987 if (kid->op_type == OP_ENTERSUB) {
5988 (void) ref(kid, o->op_type);
5989 if (kid->op_type != OP_RV2CV && !PL_error_count)
5990 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5992 o->op_private |= OPpEXISTS_SUB;
5994 else if (kid->op_type == OP_AELEM)
5995 o->op_flags |= OPf_SPECIAL;
5996 else if (kid->op_type != OP_HELEM)
5997 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
6005 Perl_ck_rvconst(pTHX_ register OP *o)
6008 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6010 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6011 if (o->op_type == OP_RV2CV)
6012 o->op_private &= ~1;
6014 if (kid->op_type == OP_CONST) {
6017 SV * const kidsv = kid->op_sv;
6019 /* Is it a constant from cv_const_sv()? */
6020 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
6021 SV * const rsv = SvRV(kidsv);
6022 const int svtype = SvTYPE(rsv);
6023 const char *badtype = NULL;
6025 switch (o->op_type) {
6027 if (svtype > SVt_PVMG)
6028 badtype = "a SCALAR";
6031 if (svtype != SVt_PVAV)
6032 badtype = "an ARRAY";
6035 if (svtype != SVt_PVHV)
6039 if (svtype != SVt_PVCV)
6044 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
6047 else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
6048 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
6049 /* If this is an access to a stash, disable "strict refs", because
6050 * stashes aren't auto-vivified at compile-time (unless we store
6051 * symbols in them), and we don't want to produce a run-time
6052 * stricture error when auto-vivifying the stash. */
6053 const char *s = SvPV_nolen(kidsv);
6054 const STRLEN l = SvCUR(kidsv);
6055 if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
6056 o->op_private &= ~HINT_STRICT_REFS;
6058 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
6059 const char *badthing;
6060 switch (o->op_type) {
6062 badthing = "a SCALAR";
6065 badthing = "an ARRAY";
6068 badthing = "a HASH";
6076 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
6080 * This is a little tricky. We only want to add the symbol if we
6081 * didn't add it in the lexer. Otherwise we get duplicate strict
6082 * warnings. But if we didn't add it in the lexer, we must at
6083 * least pretend like we wanted to add it even if it existed before,
6084 * or we get possible typo warnings. OPpCONST_ENTERED says
6085 * whether the lexer already added THIS instance of this symbol.
6087 iscv = (o->op_type == OP_RV2CV) * 2;
6089 gv = gv_fetchsv(kidsv,
6090 iscv | !(kid->op_private & OPpCONST_ENTERED),
6093 : o->op_type == OP_RV2SV
6095 : o->op_type == OP_RV2AV
6097 : o->op_type == OP_RV2HV
6100 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
6102 kid->op_type = OP_GV;
6103 SvREFCNT_dec(kid->op_sv);
6105 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
6106 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
6107 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
6109 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc_simple_NN(gv));
6111 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
6113 kid->op_private = 0;
6114 kid->op_ppaddr = PL_ppaddr[OP_GV];
6121 Perl_ck_ftst(pTHX_ OP *o)
6124 const I32 type = o->op_type;
6126 if (o->op_flags & OPf_REF) {
6129 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
6130 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6132 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6133 OP * const newop = newGVOP(type, OPf_REF,
6134 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
6136 op_getmad(o,newop,'O');
6142 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o))
6143 o->op_private |= OPpFT_ACCESS;
6144 if (PL_check[kid->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst)
6145 && kid->op_type != OP_STAT && kid->op_type != OP_LSTAT)
6146 o->op_private |= OPpFT_STACKED;
6154 if (type == OP_FTTTY)
6155 o = newGVOP(type, OPf_REF, PL_stdingv);
6157 o = newUNOP(type, 0, newDEFSVOP());
6158 op_getmad(oldo,o,'O');
6164 Perl_ck_fun(pTHX_ OP *o)
6167 const int type = o->op_type;
6168 register I32 oa = PL_opargs[type] >> OASHIFT;
6170 if (o->op_flags & OPf_STACKED) {
6171 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
6174 return no_fh_allowed(o);
6177 if (o->op_flags & OPf_KIDS) {
6178 OP **tokid = &cLISTOPo->op_first;
6179 register OP *kid = cLISTOPo->op_first;
6183 if (kid->op_type == OP_PUSHMARK ||
6184 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
6186 tokid = &kid->op_sibling;
6187 kid = kid->op_sibling;
6189 if (!kid && PL_opargs[type] & OA_DEFGV)
6190 *tokid = kid = newDEFSVOP();
6194 sibl = kid->op_sibling;
6196 if (!sibl && kid->op_type == OP_STUB) {
6203 /* list seen where single (scalar) arg expected? */
6204 if (numargs == 1 && !(oa >> 4)
6205 && kid->op_type == OP_LIST && type != OP_SCALAR)
6207 return too_many_arguments(o,PL_op_desc[type]);
6220 if ((type == OP_PUSH || type == OP_UNSHIFT)
6221 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
6222 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6223 "Useless use of %s with no values",
6226 if (kid->op_type == OP_CONST &&
6227 (kid->op_private & OPpCONST_BARE))
6229 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
6230 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
6231 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6232 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6233 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
6234 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
6236 op_getmad(kid,newop,'K');
6241 kid->op_sibling = sibl;
6244 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
6245 bad_type(numargs, "array", PL_op_desc[type], kid);
6249 if (kid->op_type == OP_CONST &&
6250 (kid->op_private & OPpCONST_BARE))
6252 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
6253 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
6254 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6255 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6256 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
6257 ((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
6259 op_getmad(kid,newop,'K');
6264 kid->op_sibling = sibl;
6267 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
6268 bad_type(numargs, "hash", PL_op_desc[type], kid);
6273 OP * const newop = newUNOP(OP_NULL, 0, kid);
6274 kid->op_sibling = 0;
6276 newop->op_next = newop;
6278 kid->op_sibling = sibl;
6283 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
6284 if (kid->op_type == OP_CONST &&
6285 (kid->op_private & OPpCONST_BARE))
6287 OP * const newop = newGVOP(OP_GV, 0,
6288 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
6289 if (!(o->op_private & 1) && /* if not unop */
6290 kid == cLISTOPo->op_last)
6291 cLISTOPo->op_last = newop;
6293 op_getmad(kid,newop,'K');
6299 else if (kid->op_type == OP_READLINE) {
6300 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
6301 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
6304 I32 flags = OPf_SPECIAL;
6308 /* is this op a FH constructor? */
6309 if (is_handle_constructor(o,numargs)) {
6310 const char *name = NULL;
6314 /* Set a flag to tell rv2gv to vivify
6315 * need to "prove" flag does not mean something
6316 * else already - NI-S 1999/05/07
6319 if (kid->op_type == OP_PADSV) {
6320 name = PAD_COMPNAME_PV(kid->op_targ);
6321 /* SvCUR of a pad namesv can't be trusted
6322 * (see PL_generation), so calc its length
6328 else if (kid->op_type == OP_RV2SV
6329 && kUNOP->op_first->op_type == OP_GV)
6331 GV * const gv = cGVOPx_gv(kUNOP->op_first);
6333 len = GvNAMELEN(gv);
6335 else if (kid->op_type == OP_AELEM
6336 || kid->op_type == OP_HELEM)
6338 OP *op = ((BINOP*)kid)->op_first;
6342 const char * const a =
6343 kid->op_type == OP_AELEM ?
6345 if (((op->op_type == OP_RV2AV) ||
6346 (op->op_type == OP_RV2HV)) &&
6347 (op = ((UNOP*)op)->op_first) &&
6348 (op->op_type == OP_GV)) {
6349 /* packagevar $a[] or $h{} */
6350 GV * const gv = cGVOPx_gv(op);
6358 else if (op->op_type == OP_PADAV
6359 || op->op_type == OP_PADHV) {
6360 /* lexicalvar $a[] or $h{} */
6361 const char * const padname =
6362 PAD_COMPNAME_PV(op->op_targ);
6371 name = SvPV_const(tmpstr, len);
6376 name = "__ANONIO__";
6383 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
6384 namesv = PAD_SVl(targ);
6385 SvUPGRADE(namesv, SVt_PV);
6387 sv_setpvn(namesv, "$", 1);
6388 sv_catpvn(namesv, name, len);
6391 kid->op_sibling = 0;
6392 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
6393 kid->op_targ = targ;
6394 kid->op_private |= priv;
6396 kid->op_sibling = sibl;
6402 mod(scalar(kid), type);
6406 tokid = &kid->op_sibling;
6407 kid = kid->op_sibling;
6410 if (kid && kid->op_type != OP_STUB)
6411 return too_many_arguments(o,OP_DESC(o));
6412 o->op_private |= numargs;
6414 /* FIXME - should the numargs move as for the PERL_MAD case? */
6415 o->op_private |= numargs;
6417 return too_many_arguments(o,OP_DESC(o));
6421 else if (PL_opargs[type] & OA_DEFGV) {
6423 OP *newop = newUNOP(type, 0, newDEFSVOP());
6424 op_getmad(o,newop,'O');
6427 /* Ordering of these two is important to keep f_map.t passing. */
6429 return newUNOP(type, 0, newDEFSVOP());
6434 while (oa & OA_OPTIONAL)
6436 if (oa && oa != OA_LIST)
6437 return too_few_arguments(o,OP_DESC(o));
6443 Perl_ck_glob(pTHX_ OP *o)
6449 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
6450 append_elem(OP_GLOB, o, newDEFSVOP());
6452 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
6453 && GvCVu(gv) && GvIMPORTED_CV(gv)))
6455 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6458 #if !defined(PERL_EXTERNAL_GLOB)
6459 /* XXX this can be tightened up and made more failsafe. */
6460 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
6463 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
6464 newSVpvs("File::Glob"), NULL, NULL, NULL);
6465 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6466 glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
6467 GvCV(gv) = GvCV(glob_gv);
6468 SvREFCNT_inc_void((SV*)GvCV(gv));
6469 GvIMPORTED_CV_on(gv);
6472 #endif /* PERL_EXTERNAL_GLOB */
6474 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6475 append_elem(OP_GLOB, o,
6476 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
6477 o->op_type = OP_LIST;
6478 o->op_ppaddr = PL_ppaddr[OP_LIST];
6479 cLISTOPo->op_first->op_type = OP_PUSHMARK;
6480 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
6481 cLISTOPo->op_first->op_targ = 0;
6482 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
6483 append_elem(OP_LIST, o,
6484 scalar(newUNOP(OP_RV2CV, 0,
6485 newGVOP(OP_GV, 0, gv)))));
6486 o = newUNOP(OP_NULL, 0, ck_subr(o));
6487 o->op_targ = OP_GLOB; /* hint at what it used to be */
6490 gv = newGVgen("main");
6492 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
6498 Perl_ck_grep(pTHX_ OP *o)
6503 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
6506 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
6507 /* don't allocate gwop here, as we may leak it if PL_error_count > 0 */
6509 if (o->op_flags & OPf_STACKED) {
6512 kid = cLISTOPo->op_first->op_sibling;
6513 if (!cUNOPx(kid)->op_next)
6514 Perl_croak(aTHX_ "panic: ck_grep");
6515 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
6518 NewOp(1101, gwop, 1, LOGOP);
6519 kid->op_next = (OP*)gwop;
6520 o->op_flags &= ~OPf_STACKED;
6522 kid = cLISTOPo->op_first->op_sibling;
6523 if (type == OP_MAPWHILE)
6530 kid = cLISTOPo->op_first->op_sibling;
6531 if (kid->op_type != OP_NULL)
6532 Perl_croak(aTHX_ "panic: ck_grep");
6533 kid = kUNOP->op_first;
6536 NewOp(1101, gwop, 1, LOGOP);
6537 gwop->op_type = type;
6538 gwop->op_ppaddr = PL_ppaddr[type];
6539 gwop->op_first = listkids(o);
6540 gwop->op_flags |= OPf_KIDS;
6541 gwop->op_other = LINKLIST(kid);
6542 kid->op_next = (OP*)gwop;
6543 offset = pad_findmy("$_");
6544 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
6545 o->op_private = gwop->op_private = 0;
6546 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
6549 o->op_private = gwop->op_private = OPpGREP_LEX;
6550 gwop->op_targ = o->op_targ = offset;
6553 kid = cLISTOPo->op_first->op_sibling;
6554 if (!kid || !kid->op_sibling)
6555 return too_few_arguments(o,OP_DESC(o));
6556 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
6557 mod(kid, OP_GREPSTART);
6563 Perl_ck_index(pTHX_ OP *o)
6565 if (o->op_flags & OPf_KIDS) {
6566 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6568 kid = kid->op_sibling; /* get past "big" */
6569 if (kid && kid->op_type == OP_CONST)
6570 fbm_compile(((SVOP*)kid)->op_sv, 0);
6576 Perl_ck_lengthconst(pTHX_ OP *o)
6578 /* XXX length optimization goes here */
6583 Perl_ck_lfun(pTHX_ OP *o)
6585 const OPCODE type = o->op_type;
6586 return modkids(ck_fun(o), type);
6590 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
6592 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
6593 switch (cUNOPo->op_first->op_type) {
6595 /* This is needed for
6596 if (defined %stash::)
6597 to work. Do not break Tk.
6599 break; /* Globals via GV can be undef */
6601 case OP_AASSIGN: /* Is this a good idea? */
6602 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6603 "defined(@array) is deprecated");
6604 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6605 "\t(Maybe you should just omit the defined()?)\n");
6608 /* This is needed for
6609 if (defined %stash::)
6610 to work. Do not break Tk.
6612 break; /* Globals via GV can be undef */
6614 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6615 "defined(%%hash) is deprecated");
6616 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6617 "\t(Maybe you should just omit the defined()?)\n");
6628 Perl_ck_rfun(pTHX_ OP *o)
6630 const OPCODE type = o->op_type;
6631 return refkids(ck_fun(o), type);
6635 Perl_ck_listiob(pTHX_ OP *o)
6639 kid = cLISTOPo->op_first;
6642 kid = cLISTOPo->op_first;
6644 if (kid->op_type == OP_PUSHMARK)
6645 kid = kid->op_sibling;
6646 if (kid && o->op_flags & OPf_STACKED)
6647 kid = kid->op_sibling;
6648 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6649 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6650 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6651 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6652 cLISTOPo->op_first->op_sibling = kid;
6653 cLISTOPo->op_last = kid;
6654 kid = kid->op_sibling;
6659 append_elem(o->op_type, o, newDEFSVOP());
6665 Perl_ck_say(pTHX_ OP *o)
6668 o->op_type = OP_PRINT;
6669 cLISTOPo->op_last = cLISTOPo->op_last->op_sibling
6670 = newSVOP(OP_CONST, 0, newSVpvs("\n"));
6675 Perl_ck_smartmatch(pTHX_ OP *o)
6678 if (0 == (o->op_flags & OPf_SPECIAL)) {
6679 OP *first = cBINOPo->op_first;
6680 OP *second = first->op_sibling;
6682 /* Implicitly take a reference to an array or hash */
6683 first->op_sibling = NULL;
6684 first = cBINOPo->op_first = ref_array_or_hash(first);
6685 second = first->op_sibling = ref_array_or_hash(second);
6687 /* Implicitly take a reference to a regular expression */
6688 if (first->op_type == OP_MATCH) {
6689 first->op_type = OP_QR;
6690 first->op_ppaddr = PL_ppaddr[OP_QR];
6692 if (second->op_type == OP_MATCH) {
6693 second->op_type = OP_QR;
6694 second->op_ppaddr = PL_ppaddr[OP_QR];
6703 Perl_ck_sassign(pTHX_ OP *o)
6705 OP *kid = cLISTOPo->op_first;
6706 /* has a disposable target? */
6707 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6708 && !(kid->op_flags & OPf_STACKED)
6709 /* Cannot steal the second time! */
6710 && !(kid->op_private & OPpTARGET_MY))
6712 OP * const kkid = kid->op_sibling;
6714 /* Can just relocate the target. */
6715 if (kkid && kkid->op_type == OP_PADSV
6716 && !(kkid->op_private & OPpLVAL_INTRO))
6718 kid->op_targ = kkid->op_targ;
6720 /* Now we do not need PADSV and SASSIGN. */
6721 kid->op_sibling = o->op_sibling; /* NULL */
6722 cLISTOPo->op_first = NULL;
6724 op_getmad(o,kid,'O');
6725 op_getmad(kkid,kid,'M');
6730 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6738 Perl_ck_match(pTHX_ OP *o)
6741 if (o->op_type != OP_QR && PL_compcv) {
6742 const I32 offset = pad_findmy("$_");
6743 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
6744 o->op_targ = offset;
6745 o->op_private |= OPpTARGET_MY;
6748 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
6749 o->op_private |= OPpRUNTIME;
6754 Perl_ck_method(pTHX_ OP *o)
6756 OP * const kid = cUNOPo->op_first;
6757 if (kid->op_type == OP_CONST) {
6758 SV* sv = kSVOP->op_sv;
6759 const char * const method = SvPVX_const(sv);
6760 if (!(strchr(method, ':') || strchr(method, '\''))) {
6762 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6763 sv = newSVpvn_share(method, SvCUR(sv), 0);
6766 kSVOP->op_sv = NULL;
6768 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6770 op_getmad(o,cmop,'O');
6781 Perl_ck_null(pTHX_ OP *o)
6783 PERL_UNUSED_CONTEXT;
6788 Perl_ck_open(pTHX_ OP *o)
6791 HV * const table = GvHV(PL_hintgv);
6793 SV **svp = hv_fetchs(table, "open_IN", FALSE);
6795 const I32 mode = mode_from_discipline(*svp);
6796 if (mode & O_BINARY)
6797 o->op_private |= OPpOPEN_IN_RAW;
6798 else if (mode & O_TEXT)
6799 o->op_private |= OPpOPEN_IN_CRLF;
6802 svp = hv_fetchs(table, "open_OUT", FALSE);
6804 const I32 mode = mode_from_discipline(*svp);
6805 if (mode & O_BINARY)
6806 o->op_private |= OPpOPEN_OUT_RAW;
6807 else if (mode & O_TEXT)
6808 o->op_private |= OPpOPEN_OUT_CRLF;
6811 if (o->op_type == OP_BACKTICK)
6814 /* In case of three-arg dup open remove strictness
6815 * from the last arg if it is a bareword. */
6816 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
6817 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
6821 if ((last->op_type == OP_CONST) && /* The bareword. */
6822 (last->op_private & OPpCONST_BARE) &&
6823 (last->op_private & OPpCONST_STRICT) &&
6824 (oa = first->op_sibling) && /* The fh. */
6825 (oa = oa->op_sibling) && /* The mode. */
6826 (oa->op_type == OP_CONST) &&
6827 SvPOK(((SVOP*)oa)->op_sv) &&
6828 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
6829 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
6830 (last == oa->op_sibling)) /* The bareword. */
6831 last->op_private &= ~OPpCONST_STRICT;
6837 Perl_ck_repeat(pTHX_ OP *o)
6839 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6840 o->op_private |= OPpREPEAT_DOLIST;
6841 cBINOPo->op_first = force_list(cBINOPo->op_first);
6849 Perl_ck_require(pTHX_ OP *o)
6854 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6855 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6857 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6858 SV * const sv = kid->op_sv;
6859 U32 was_readonly = SvREADONLY(sv);
6864 sv_force_normal_flags(sv, 0);
6865 assert(!SvREADONLY(sv));
6872 for (s = SvPVX(sv); *s; s++) {
6873 if (*s == ':' && s[1] == ':') {
6874 const STRLEN len = strlen(s+2)+1;
6876 Move(s+2, s+1, len, char);
6877 SvCUR_set(sv, SvCUR(sv) - 1);
6880 sv_catpvs(sv, ".pm");
6881 SvFLAGS(sv) |= was_readonly;
6885 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
6886 /* handle override, if any */
6887 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
6888 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
6889 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
6890 gv = gvp ? *gvp : NULL;
6894 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6895 OP * const kid = cUNOPo->op_first;
6898 cUNOPo->op_first = 0;
6902 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
6903 append_elem(OP_LIST, kid,
6904 scalar(newUNOP(OP_RV2CV, 0,
6907 op_getmad(o,newop,'O');
6915 Perl_ck_return(pTHX_ OP *o)
6918 if (CvLVALUE(PL_compcv)) {
6920 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6921 mod(kid, OP_LEAVESUBLV);
6927 Perl_ck_select(pTHX_ OP *o)
6931 if (o->op_flags & OPf_KIDS) {
6932 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6933 if (kid && kid->op_sibling) {
6934 o->op_type = OP_SSELECT;
6935 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6937 return fold_constants(o);
6941 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6942 if (kid && kid->op_type == OP_RV2GV)
6943 kid->op_private &= ~HINT_STRICT_REFS;
6948 Perl_ck_shift(pTHX_ OP *o)
6951 const I32 type = o->op_type;
6953 if (!(o->op_flags & OPf_KIDS)) {
6955 /* FIXME - this can be refactored to reduce code in #ifdefs */
6957 OP * const oldo = o;
6961 argop = newUNOP(OP_RV2AV, 0,
6962 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
6964 o = newUNOP(type, 0, scalar(argop));
6965 op_getmad(oldo,o,'O');
6968 return newUNOP(type, 0, scalar(argop));
6971 return scalar(modkids(ck_fun(o), type));
6975 Perl_ck_sort(pTHX_ OP *o)
6980 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0)
6982 HV * const hinthv = GvHV(PL_hintgv);
6984 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
6986 const I32 sorthints = (I32)SvIV(*svp);
6987 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
6988 o->op_private |= OPpSORT_QSORT;
6989 if ((sorthints & HINT_SORT_STABLE) != 0)
6990 o->op_private |= OPpSORT_STABLE;
6995 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6997 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6998 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
7000 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
7002 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
7004 if (kid->op_type == OP_SCOPE) {
7008 else if (kid->op_type == OP_LEAVE) {
7009 if (o->op_type == OP_SORT) {
7010 op_null(kid); /* wipe out leave */
7013 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
7014 if (k->op_next == kid)
7016 /* don't descend into loops */
7017 else if (k->op_type == OP_ENTERLOOP
7018 || k->op_type == OP_ENTERITER)
7020 k = cLOOPx(k)->op_lastop;
7025 kid->op_next = 0; /* just disconnect the leave */
7026 k = kLISTOP->op_first;
7031 if (o->op_type == OP_SORT) {
7032 /* provide scalar context for comparison function/block */
7038 o->op_flags |= OPf_SPECIAL;
7040 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
7043 firstkid = firstkid->op_sibling;
7046 /* provide list context for arguments */
7047 if (o->op_type == OP_SORT)
7054 S_simplify_sort(pTHX_ OP *o)
7057 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7062 if (!(o->op_flags & OPf_STACKED))
7064 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7065 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
7066 kid = kUNOP->op_first; /* get past null */
7067 if (kid->op_type != OP_SCOPE)
7069 kid = kLISTOP->op_last; /* get past scope */
7070 switch(kid->op_type) {
7078 k = kid; /* remember this node*/
7079 if (kBINOP->op_first->op_type != OP_RV2SV)
7081 kid = kBINOP->op_first; /* get past cmp */
7082 if (kUNOP->op_first->op_type != OP_GV)
7084 kid = kUNOP->op_first; /* get past rv2sv */
7086 if (GvSTASH(gv) != PL_curstash)
7088 gvname = GvNAME(gv);
7089 if (*gvname == 'a' && gvname[1] == '\0')
7091 else if (*gvname == 'b' && gvname[1] == '\0')
7096 kid = k; /* back to cmp */
7097 if (kBINOP->op_last->op_type != OP_RV2SV)
7099 kid = kBINOP->op_last; /* down to 2nd arg */
7100 if (kUNOP->op_first->op_type != OP_GV)
7102 kid = kUNOP->op_first; /* get past rv2sv */
7104 if (GvSTASH(gv) != PL_curstash)
7106 gvname = GvNAME(gv);
7108 ? !(*gvname == 'a' && gvname[1] == '\0')
7109 : !(*gvname == 'b' && gvname[1] == '\0'))
7111 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
7113 o->op_private |= OPpSORT_DESCEND;
7114 if (k->op_type == OP_NCMP)
7115 o->op_private |= OPpSORT_NUMERIC;
7116 if (k->op_type == OP_I_NCMP)
7117 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
7118 kid = cLISTOPo->op_first->op_sibling;
7119 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
7121 op_getmad(kid,o,'S'); /* then delete it */
7123 op_free(kid); /* then delete it */
7128 Perl_ck_split(pTHX_ OP *o)
7133 if (o->op_flags & OPf_STACKED)
7134 return no_fh_allowed(o);
7136 kid = cLISTOPo->op_first;
7137 if (kid->op_type != OP_NULL)
7138 Perl_croak(aTHX_ "panic: ck_split");
7139 kid = kid->op_sibling;
7140 op_free(cLISTOPo->op_first);
7141 cLISTOPo->op_first = kid;
7143 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
7144 cLISTOPo->op_last = kid; /* There was only one element previously */
7147 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
7148 OP * const sibl = kid->op_sibling;
7149 kid->op_sibling = 0;
7150 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
7151 if (cLISTOPo->op_first == cLISTOPo->op_last)
7152 cLISTOPo->op_last = kid;
7153 cLISTOPo->op_first = kid;
7154 kid->op_sibling = sibl;
7157 kid->op_type = OP_PUSHRE;
7158 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
7160 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
7161 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
7162 "Use of /g modifier is meaningless in split");
7165 if (!kid->op_sibling)
7166 append_elem(OP_SPLIT, o, newDEFSVOP());
7168 kid = kid->op_sibling;
7171 if (!kid->op_sibling)
7172 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
7174 kid = kid->op_sibling;
7177 if (kid->op_sibling)
7178 return too_many_arguments(o,OP_DESC(o));
7184 Perl_ck_join(pTHX_ OP *o)
7186 const OP * const kid = cLISTOPo->op_first->op_sibling;
7187 if (kid && kid->op_type == OP_MATCH) {
7188 if (ckWARN(WARN_SYNTAX)) {
7189 const REGEXP *re = PM_GETRE(kPMOP);
7190 const char *pmstr = re ? re->precomp : "STRING";
7191 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7192 "/%s/ should probably be written as \"%s\"",
7200 Perl_ck_subr(pTHX_ OP *o)
7203 OP *prev = ((cUNOPo->op_first->op_sibling)
7204 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
7205 OP *o2 = prev->op_sibling;
7212 I32 contextclass = 0;
7216 o->op_private |= OPpENTERSUB_HASTARG;
7217 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
7218 if (cvop->op_type == OP_RV2CV) {
7220 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
7221 op_null(cvop); /* disable rv2cv */
7222 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
7223 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
7224 GV *gv = cGVOPx_gv(tmpop);
7227 tmpop->op_private |= OPpEARLY_CV;
7230 namegv = CvANON(cv) ? gv : CvGV(cv);
7231 proto = SvPV_nolen((SV*)cv);
7233 if (CvASSERTION(cv)) {
7234 if (PL_hints & HINT_ASSERTING) {
7235 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
7236 o->op_private |= OPpENTERSUB_DB;
7240 if (!(PL_hints & HINT_ASSERTIONSSEEN) && ckWARN(WARN_ASSERTIONS)) {
7241 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
7242 "Impossible to activate assertion call");
7249 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7250 if (o2->op_type == OP_CONST)
7251 o2->op_private &= ~OPpCONST_STRICT;
7252 else if (o2->op_type == OP_LIST) {
7253 OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
7254 if (sib && sib->op_type == OP_CONST)
7255 sib->op_private &= ~OPpCONST_STRICT;
7258 o->op_private |= (PL_hints & HINT_STRICT_REFS);
7259 if (PERLDB_SUB && PL_curstash != PL_debstash)
7260 o->op_private |= OPpENTERSUB_DB;
7261 while (o2 != cvop) {
7263 if (PL_madskills && o2->op_type == OP_NULL)
7264 o3 = ((UNOP*)o2)->op_first;
7270 return too_many_arguments(o, gv_ename(namegv));
7288 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
7290 arg == 1 ? "block or sub {}" : "sub {}",
7291 gv_ename(namegv), o3);
7294 /* '*' allows any scalar type, including bareword */
7297 if (o3->op_type == OP_RV2GV)
7298 goto wrapref; /* autoconvert GLOB -> GLOBref */
7299 else if (o3->op_type == OP_CONST)
7300 o3->op_private &= ~OPpCONST_STRICT;
7301 else if (o3->op_type == OP_ENTERSUB) {
7302 /* accidental subroutine, revert to bareword */
7303 OP *gvop = ((UNOP*)o3)->op_first;
7304 if (gvop && gvop->op_type == OP_NULL) {
7305 gvop = ((UNOP*)gvop)->op_first;
7307 for (; gvop->op_sibling; gvop = gvop->op_sibling)
7310 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
7311 (gvop = ((UNOP*)gvop)->op_first) &&
7312 gvop->op_type == OP_GV)
7314 GV * const gv = cGVOPx_gv(gvop);
7315 OP * const sibling = o2->op_sibling;
7316 SV * const n = newSVpvs("");
7318 OP * const oldo2 = o2;
7322 gv_fullname4(n, gv, "", FALSE);
7323 o2 = newSVOP(OP_CONST, 0, n);
7324 op_getmad(oldo2,o2,'O');
7325 prev->op_sibling = o2;
7326 o2->op_sibling = sibling;
7342 if (contextclass++ == 0) {
7343 e = strchr(proto, ']');
7344 if (!e || e == proto)
7353 /* XXX We shouldn't be modifying proto, so we can const proto */
7358 while (*--p != '[');
7359 bad_type(arg, Perl_form(aTHX_ "one of %s", p),
7360 gv_ename(namegv), o3);
7366 if (o3->op_type == OP_RV2GV)
7369 bad_type(arg, "symbol", gv_ename(namegv), o3);
7372 if (o3->op_type == OP_ENTERSUB)
7375 bad_type(arg, "subroutine entry", gv_ename(namegv),
7379 if (o3->op_type == OP_RV2SV ||
7380 o3->op_type == OP_PADSV ||
7381 o3->op_type == OP_HELEM ||
7382 o3->op_type == OP_AELEM ||
7383 o3->op_type == OP_THREADSV)
7386 bad_type(arg, "scalar", gv_ename(namegv), o3);
7389 if (o3->op_type == OP_RV2AV ||
7390 o3->op_type == OP_PADAV)
7393 bad_type(arg, "array", gv_ename(namegv), o3);
7396 if (o3->op_type == OP_RV2HV ||
7397 o3->op_type == OP_PADHV)
7400 bad_type(arg, "hash", gv_ename(namegv), o3);
7405 OP* const sib = kid->op_sibling;
7406 kid->op_sibling = 0;
7407 o2 = newUNOP(OP_REFGEN, 0, kid);
7408 o2->op_sibling = sib;
7409 prev->op_sibling = o2;
7411 if (contextclass && e) {
7426 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
7427 gv_ename(namegv), cv);
7432 mod(o2, OP_ENTERSUB);
7434 o2 = o2->op_sibling;
7436 if (proto && !optional &&
7437 (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
7438 return too_few_arguments(o, gv_ename(namegv));
7441 OP * const oldo = o;
7445 o=newSVOP(OP_CONST, 0, newSViv(0));
7446 op_getmad(oldo,o,'O');
7452 Perl_ck_svconst(pTHX_ OP *o)
7454 PERL_UNUSED_CONTEXT;
7455 SvREADONLY_on(cSVOPo->op_sv);
7460 Perl_ck_chdir(pTHX_ OP *o)
7462 if (o->op_flags & OPf_KIDS) {
7463 SVOP *kid = (SVOP*)cUNOPo->op_first;
7465 if (kid && kid->op_type == OP_CONST &&
7466 (kid->op_private & OPpCONST_BARE))
7468 o->op_flags |= OPf_SPECIAL;
7469 kid->op_private &= ~OPpCONST_STRICT;
7476 Perl_ck_trunc(pTHX_ OP *o)
7478 if (o->op_flags & OPf_KIDS) {
7479 SVOP *kid = (SVOP*)cUNOPo->op_first;
7481 if (kid->op_type == OP_NULL)
7482 kid = (SVOP*)kid->op_sibling;
7483 if (kid && kid->op_type == OP_CONST &&
7484 (kid->op_private & OPpCONST_BARE))
7486 o->op_flags |= OPf_SPECIAL;
7487 kid->op_private &= ~OPpCONST_STRICT;
7494 Perl_ck_unpack(pTHX_ OP *o)
7496 OP *kid = cLISTOPo->op_first;
7497 if (kid->op_sibling) {
7498 kid = kid->op_sibling;
7499 if (!kid->op_sibling)
7500 kid->op_sibling = newDEFSVOP();
7506 Perl_ck_substr(pTHX_ OP *o)
7509 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
7510 OP *kid = cLISTOPo->op_first;
7512 if (kid->op_type == OP_NULL)
7513 kid = kid->op_sibling;
7515 kid->op_flags |= OPf_MOD;
7521 /* A peephole optimizer. We visit the ops in the order they're to execute.
7522 * See the comments at the top of this file for more details about when
7523 * peep() is called */
7526 Perl_peep(pTHX_ register OP *o)
7529 register OP* oldop = NULL;
7531 if (!o || o->op_opt)
7535 SAVEVPTR(PL_curcop);
7536 for (; o; o = o->op_next) {
7540 switch (o->op_type) {
7544 PL_curcop = ((COP*)o); /* for warnings */
7549 if (cSVOPo->op_private & OPpCONST_STRICT)
7550 no_bareword_allowed(o);
7552 case OP_METHOD_NAMED:
7553 /* Relocate sv to the pad for thread safety.
7554 * Despite being a "constant", the SV is written to,
7555 * for reference counts, sv_upgrade() etc. */
7557 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
7558 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
7559 /* If op_sv is already a PADTMP then it is being used by
7560 * some pad, so make a copy. */
7561 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
7562 SvREADONLY_on(PAD_SVl(ix));
7563 SvREFCNT_dec(cSVOPo->op_sv);
7565 else if (o->op_type == OP_CONST
7566 && cSVOPo->op_sv == &PL_sv_undef) {
7567 /* PL_sv_undef is hack - it's unsafe to store it in the
7568 AV that is the pad, because av_fetch treats values of
7569 PL_sv_undef as a "free" AV entry and will merrily
7570 replace them with a new SV, causing pad_alloc to think
7571 that this pad slot is free. (When, clearly, it is not)
7573 SvOK_off(PAD_SVl(ix));
7574 SvPADTMP_on(PAD_SVl(ix));
7575 SvREADONLY_on(PAD_SVl(ix));
7578 SvREFCNT_dec(PAD_SVl(ix));
7579 SvPADTMP_on(cSVOPo->op_sv);
7580 PAD_SETSV(ix, cSVOPo->op_sv);
7581 /* XXX I don't know how this isn't readonly already. */
7582 SvREADONLY_on(PAD_SVl(ix));
7584 cSVOPo->op_sv = NULL;
7592 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
7593 if (o->op_next->op_private & OPpTARGET_MY) {
7594 if (o->op_flags & OPf_STACKED) /* chained concats */
7595 goto ignore_optimization;
7597 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
7598 o->op_targ = o->op_next->op_targ;
7599 o->op_next->op_targ = 0;
7600 o->op_private |= OPpTARGET_MY;
7603 op_null(o->op_next);
7605 ignore_optimization:
7609 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
7611 break; /* Scalar stub must produce undef. List stub is noop */
7615 if (o->op_targ == OP_NEXTSTATE
7616 || o->op_targ == OP_DBSTATE
7617 || o->op_targ == OP_SETSTATE)
7619 PL_curcop = ((COP*)o);
7621 /* XXX: We avoid setting op_seq here to prevent later calls
7622 to peep() from mistakenly concluding that optimisation
7623 has already occurred. This doesn't fix the real problem,
7624 though (See 20010220.007). AMS 20010719 */
7625 /* op_seq functionality is now replaced by op_opt */
7626 if (oldop && o->op_next) {
7627 oldop->op_next = o->op_next;
7635 if (oldop && o->op_next) {
7636 oldop->op_next = o->op_next;
7644 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
7645 OP* const pop = (o->op_type == OP_PADAV) ?
7646 o->op_next : o->op_next->op_next;
7648 if (pop && pop->op_type == OP_CONST &&
7649 ((PL_op = pop->op_next)) &&
7650 pop->op_next->op_type == OP_AELEM &&
7651 !(pop->op_next->op_private &
7652 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
7653 (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
7658 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
7659 no_bareword_allowed(pop);
7660 if (o->op_type == OP_GV)
7661 op_null(o->op_next);
7662 op_null(pop->op_next);
7664 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
7665 o->op_next = pop->op_next->op_next;
7666 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
7667 o->op_private = (U8)i;
7668 if (o->op_type == OP_GV) {
7673 o->op_flags |= OPf_SPECIAL;
7674 o->op_type = OP_AELEMFAST;
7680 if (o->op_next->op_type == OP_RV2SV) {
7681 if (!(o->op_next->op_private & OPpDEREF)) {
7682 op_null(o->op_next);
7683 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
7685 o->op_next = o->op_next->op_next;
7686 o->op_type = OP_GVSV;
7687 o->op_ppaddr = PL_ppaddr[OP_GVSV];
7690 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
7691 GV * const gv = cGVOPo_gv;
7692 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
7693 /* XXX could check prototype here instead of just carping */
7694 SV * const sv = sv_newmortal();
7695 gv_efullname3(sv, gv, NULL);
7696 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
7697 "%"SVf"() called too early to check prototype",
7701 else if (o->op_next->op_type == OP_READLINE
7702 && o->op_next->op_next->op_type == OP_CONCAT
7703 && (o->op_next->op_next->op_flags & OPf_STACKED))
7705 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
7706 o->op_type = OP_RCATLINE;
7707 o->op_flags |= OPf_STACKED;
7708 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
7709 op_null(o->op_next->op_next);
7710 op_null(o->op_next);
7727 while (cLOGOP->op_other->op_type == OP_NULL)
7728 cLOGOP->op_other = cLOGOP->op_other->op_next;
7729 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
7735 while (cLOOP->op_redoop->op_type == OP_NULL)
7736 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
7737 peep(cLOOP->op_redoop);
7738 while (cLOOP->op_nextop->op_type == OP_NULL)
7739 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
7740 peep(cLOOP->op_nextop);
7741 while (cLOOP->op_lastop->op_type == OP_NULL)
7742 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
7743 peep(cLOOP->op_lastop);
7750 while (cPMOP->op_pmreplstart &&
7751 cPMOP->op_pmreplstart->op_type == OP_NULL)
7752 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
7753 peep(cPMOP->op_pmreplstart);
7758 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
7759 && ckWARN(WARN_SYNTAX))
7761 if (o->op_next->op_sibling &&
7762 o->op_next->op_sibling->op_type != OP_EXIT &&
7763 o->op_next->op_sibling->op_type != OP_WARN &&
7764 o->op_next->op_sibling->op_type != OP_DIE) {
7765 const line_t oldline = CopLINE(PL_curcop);
7767 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
7768 Perl_warner(aTHX_ packWARN(WARN_EXEC),
7769 "Statement unlikely to be reached");
7770 Perl_warner(aTHX_ packWARN(WARN_EXEC),
7771 "\t(Maybe you meant system() when you said exec()?)\n");
7772 CopLINE_set(PL_curcop, oldline);
7782 const char *key = NULL;
7787 if (((BINOP*)o)->op_last->op_type != OP_CONST)
7790 /* Make the CONST have a shared SV */
7791 svp = cSVOPx_svp(((BINOP*)o)->op_last);
7792 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
7793 key = SvPV_const(sv, keylen);
7794 lexname = newSVpvn_share(key,
7795 SvUTF8(sv) ? -(I32)keylen : keylen,
7801 if ((o->op_private & (OPpLVAL_INTRO)))
7804 rop = (UNOP*)((BINOP*)o)->op_first;
7805 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7807 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7808 if (!SvPAD_TYPED(lexname))
7810 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
7811 if (!fields || !GvHV(*fields))
7813 key = SvPV_const(*svp, keylen);
7814 if (!hv_fetch(GvHV(*fields), key,
7815 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
7817 Perl_croak(aTHX_ "No such class field \"%s\" "
7818 "in variable %s of type %s",
7819 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
7832 SVOP *first_key_op, *key_op;
7834 if ((o->op_private & (OPpLVAL_INTRO))
7835 /* I bet there's always a pushmark... */
7836 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
7837 /* hmmm, no optimization if list contains only one key. */
7839 rop = (UNOP*)((LISTOP*)o)->op_last;
7840 if (rop->op_type != OP_RV2HV)
7842 if (rop->op_first->op_type == OP_PADSV)
7843 /* @$hash{qw(keys here)} */
7844 rop = (UNOP*)rop->op_first;
7846 /* @{$hash}{qw(keys here)} */
7847 if (rop->op_first->op_type == OP_SCOPE
7848 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
7850 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
7856 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
7857 if (!SvPAD_TYPED(lexname))
7859 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
7860 if (!fields || !GvHV(*fields))
7862 /* Again guessing that the pushmark can be jumped over.... */
7863 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
7864 ->op_first->op_sibling;
7865 for (key_op = first_key_op; key_op;
7866 key_op = (SVOP*)key_op->op_sibling) {
7867 if (key_op->op_type != OP_CONST)
7869 svp = cSVOPx_svp(key_op);
7870 key = SvPV_const(*svp, keylen);
7871 if (!hv_fetch(GvHV(*fields), key,
7872 SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE))
7874 Perl_croak(aTHX_ "No such class field \"%s\" "
7875 "in variable %s of type %s",
7876 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
7883 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
7887 /* check that RHS of sort is a single plain array */
7888 OP *oright = cUNOPo->op_first;
7889 if (!oright || oright->op_type != OP_PUSHMARK)
7892 /* reverse sort ... can be optimised. */
7893 if (!cUNOPo->op_sibling) {
7894 /* Nothing follows us on the list. */
7895 OP * const reverse = o->op_next;
7897 if (reverse->op_type == OP_REVERSE &&
7898 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
7899 OP * const pushmark = cUNOPx(reverse)->op_first;
7900 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
7901 && (cUNOPx(pushmark)->op_sibling == o)) {
7902 /* reverse -> pushmark -> sort */
7903 o->op_private |= OPpSORT_REVERSE;
7905 pushmark->op_next = oright->op_next;
7911 /* make @a = sort @a act in-place */
7915 oright = cUNOPx(oright)->op_sibling;
7918 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
7919 oright = cUNOPx(oright)->op_sibling;
7923 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
7924 || oright->op_next != o
7925 || (oright->op_private & OPpLVAL_INTRO)
7929 /* o2 follows the chain of op_nexts through the LHS of the
7930 * assign (if any) to the aassign op itself */
7932 if (!o2 || o2->op_type != OP_NULL)
7935 if (!o2 || o2->op_type != OP_PUSHMARK)
7938 if (o2 && o2->op_type == OP_GV)
7941 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
7942 || (o2->op_private & OPpLVAL_INTRO)
7947 if (!o2 || o2->op_type != OP_NULL)
7950 if (!o2 || o2->op_type != OP_AASSIGN
7951 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
7954 /* check that the sort is the first arg on RHS of assign */
7956 o2 = cUNOPx(o2)->op_first;
7957 if (!o2 || o2->op_type != OP_NULL)
7959 o2 = cUNOPx(o2)->op_first;
7960 if (!o2 || o2->op_type != OP_PUSHMARK)
7962 if (o2->op_sibling != o)
7965 /* check the array is the same on both sides */
7966 if (oleft->op_type == OP_RV2AV) {
7967 if (oright->op_type != OP_RV2AV
7968 || !cUNOPx(oright)->op_first
7969 || cUNOPx(oright)->op_first->op_type != OP_GV
7970 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
7971 cGVOPx_gv(cUNOPx(oright)->op_first)
7975 else if (oright->op_type != OP_PADAV
7976 || oright->op_targ != oleft->op_targ
7980 /* transfer MODishness etc from LHS arg to RHS arg */
7981 oright->op_flags = oleft->op_flags;
7982 o->op_private |= OPpSORT_INPLACE;
7984 /* excise push->gv->rv2av->null->aassign */
7985 o2 = o->op_next->op_next;
7986 op_null(o2); /* PUSHMARK */
7988 if (o2->op_type == OP_GV) {
7989 op_null(o2); /* GV */
7992 op_null(o2); /* RV2AV or PADAV */
7993 o2 = o2->op_next->op_next;
7994 op_null(o2); /* AASSIGN */
7996 o->op_next = o2->op_next;
8002 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
8004 LISTOP *enter, *exlist;
8007 enter = (LISTOP *) o->op_next;
8010 if (enter->op_type == OP_NULL) {
8011 enter = (LISTOP *) enter->op_next;
8015 /* for $a (...) will have OP_GV then OP_RV2GV here.
8016 for (...) just has an OP_GV. */
8017 if (enter->op_type == OP_GV) {
8018 gvop = (OP *) enter;
8019 enter = (LISTOP *) enter->op_next;
8022 if (enter->op_type == OP_RV2GV) {
8023 enter = (LISTOP *) enter->op_next;
8029 if (enter->op_type != OP_ENTERITER)
8032 iter = enter->op_next;
8033 if (!iter || iter->op_type != OP_ITER)
8036 expushmark = enter->op_first;
8037 if (!expushmark || expushmark->op_type != OP_NULL
8038 || expushmark->op_targ != OP_PUSHMARK)
8041 exlist = (LISTOP *) expushmark->op_sibling;
8042 if (!exlist || exlist->op_type != OP_NULL
8043 || exlist->op_targ != OP_LIST)
8046 if (exlist->op_last != o) {
8047 /* Mmm. Was expecting to point back to this op. */
8050 theirmark = exlist->op_first;
8051 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
8054 if (theirmark->op_sibling != o) {
8055 /* There's something between the mark and the reverse, eg
8056 for (1, reverse (...))
8061 ourmark = ((LISTOP *)o)->op_first;
8062 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
8065 ourlast = ((LISTOP *)o)->op_last;
8066 if (!ourlast || ourlast->op_next != o)
8069 rv2av = ourmark->op_sibling;
8070 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
8071 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
8072 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
8073 /* We're just reversing a single array. */
8074 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
8075 enter->op_flags |= OPf_STACKED;
8078 /* We don't have control over who points to theirmark, so sacrifice
8080 theirmark->op_next = ourmark->op_next;
8081 theirmark->op_flags = ourmark->op_flags;
8082 ourlast->op_next = gvop ? gvop : (OP *) enter;
8085 enter->op_private |= OPpITER_REVERSED;
8086 iter->op_private |= OPpITER_REVERSED;
8093 UNOP *refgen, *rv2cv;
8096 /* I do not understand this, but if o->op_opt isn't set to 1,
8097 various tests in ext/B/t/bytecode.t fail with no readily
8103 if ((o->op_flags && OPf_WANT) != OPf_WANT_VOID)
8106 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
8109 rv2gv = ((BINOP *)o)->op_last;
8110 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
8113 refgen = (UNOP *)((BINOP *)o)->op_first;
8115 if (!refgen || refgen->op_type != OP_REFGEN)
8118 exlist = (LISTOP *)refgen->op_first;
8119 if (!exlist || exlist->op_type != OP_NULL
8120 || exlist->op_targ != OP_LIST)
8123 if (exlist->op_first->op_type != OP_PUSHMARK)
8126 rv2cv = (UNOP*)exlist->op_last;
8128 if (rv2cv->op_type != OP_RV2CV)
8131 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
8132 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
8133 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
8135 o->op_private |= OPpASSIGN_CV_TO_GV;
8136 rv2gv->op_private |= OPpDONT_INIT_GV;
8137 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
8153 Perl_custom_op_name(pTHX_ const OP* o)
8156 const IV index = PTR2IV(o->op_ppaddr);
8160 if (!PL_custom_op_names) /* This probably shouldn't happen */
8161 return (char *)PL_op_name[OP_CUSTOM];
8163 keysv = sv_2mortal(newSViv(index));
8165 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
8167 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
8169 return SvPV_nolen(HeVAL(he));
8173 Perl_custom_op_desc(pTHX_ const OP* o)
8176 const IV index = PTR2IV(o->op_ppaddr);
8180 if (!PL_custom_op_descs)
8181 return (char *)PL_op_desc[OP_CUSTOM];
8183 keysv = sv_2mortal(newSViv(index));
8185 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
8187 return (char *)PL_op_desc[OP_CUSTOM];
8189 return SvPV_nolen(HeVAL(he));
8194 /* Efficient sub that returns a constant scalar value. */
8196 const_sv_xsub(pTHX_ CV* cv)
8203 Perl_croak(aTHX_ "usage: %s::%s()",
8204 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
8208 ST(0) = (SV*)XSANY.any_ptr;
8214 * c-indentation-style: bsd
8216 * indent-tabs-mode: t
8219 * ex: set ts=8 sts=4 sw=4 noet: