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.
76 /* To implement user lexical pragmas, there needs to be a way at run time to
77 get the compile time state of %^H for that block. Storing %^H in every
78 block (or even COP) would be very expensive, so a different approach is
79 taken. The (running) state of %^H is serialised into a tree of HE-like
80 structs. Stores into %^H are chained onto the current leaf as a struct
81 refcounted_he * with the key and the value. Deletes from %^H are saved
82 with a value of PL_sv_placeholder. The state of %^H at any point can be
83 turned back into a regular HV by walking back up the tree from that point's
84 leaf, ignoring any key you've already seen (placeholder or not), storing
85 the rest into the HV structure, then removing the placeholders. Hence
86 memory is only used to store the %^H deltas from the enclosing COP, rather
87 than the entire %^H on each COP.
89 To cause actions on %^H to write out the serialisation records, it has
90 magic type 'H'. This magic (itself) does nothing, but its presence causes
91 the values to gain magic type 'h', which has entries for set and clear.
92 C<Perl_magic_sethint> updates C<PL_compiling.cop_hints_hash> with a store
93 record, with deletes written by C<Perl_magic_clearhint>. C<SAVE_HINTS>
94 saves the current C<PL_compiling.cop_hints_hash> on the save stack, so that
95 it will be correctly restored when any inner compiling scope is exited.
101 #include "keywords.h"
103 #define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
105 #if defined(PL_OP_SLAB_ALLOC)
107 #ifndef PERL_SLAB_SIZE
108 #define PERL_SLAB_SIZE 2048
112 Perl_Slab_Alloc(pTHX_ int m, size_t sz)
115 * To make incrementing use count easy PL_OpSlab is an I32 *
116 * To make inserting the link to slab PL_OpPtr is I32 **
117 * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
118 * Add an overhead for pointer to slab and round up as a number of pointers
120 sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
121 if ((PL_OpSpace -= sz) < 0) {
122 PL_OpPtr = (I32 **) PerlMemShared_malloc(PERL_SLAB_SIZE*sizeof(I32*));
126 Zero(PL_OpPtr,PERL_SLAB_SIZE,I32 **);
127 /* We reserve the 0'th I32 sized chunk as a use count */
128 PL_OpSlab = (I32 *) PL_OpPtr;
129 /* Reduce size by the use count word, and by the size we need.
130 * Latter is to mimic the '-=' in the if() above
132 PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
133 /* Allocation pointer starts at the top.
134 Theory: because we build leaves before trunk allocating at end
135 means that at run time access is cache friendly upward
137 PL_OpPtr += PERL_SLAB_SIZE;
139 assert( PL_OpSpace >= 0 );
140 /* Move the allocation pointer down */
142 assert( PL_OpPtr > (I32 **) PL_OpSlab );
143 *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */
144 (*PL_OpSlab)++; /* Increment use count of slab */
145 assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
146 assert( *PL_OpSlab > 0 );
147 return (void *)(PL_OpPtr + 1);
151 Perl_Slab_Free(pTHX_ void *op)
153 I32 * const * const ptr = (I32 **) op;
154 I32 * const slab = ptr[-1];
155 assert( ptr-1 > (I32 **) slab );
156 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
158 if (--(*slab) == 0) {
160 # define PerlMemShared PerlMem
163 PerlMemShared_free(slab);
164 if (slab == PL_OpSlab) {
171 * In the following definition, the ", (OP*)0" is just to make the compiler
172 * think the expression is of the right type: croak actually does a Siglongjmp.
174 #define CHECKOP(type,o) \
175 ((PL_op_mask && PL_op_mask[type]) \
176 ? ( op_free((OP*)o), \
177 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
179 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
181 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
184 S_gv_ename(pTHX_ GV *gv)
186 SV* const tmpsv = sv_newmortal();
187 gv_efullname3(tmpsv, gv, NULL);
188 return SvPV_nolen_const(tmpsv);
192 S_no_fh_allowed(pTHX_ OP *o)
194 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
200 S_too_few_arguments(pTHX_ OP *o, const char *name)
202 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
207 S_too_many_arguments(pTHX_ OP *o, const char *name)
209 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
214 S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid)
216 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
217 (int)n, name, t, OP_DESC(kid)));
221 S_no_bareword_allowed(pTHX_ const OP *o)
224 return; /* various ok barewords are hidden in extra OP_NULL */
225 qerror(Perl_mess(aTHX_
226 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
230 /* "register" allocation */
233 Perl_allocmy(pTHX_ const char *const name)
237 const bool is_our = (PL_in_my == KEY_our);
239 /* complain about "my $<special_var>" etc etc */
243 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
244 (name[1] == '_' && (*name == '$' || name[2]))))
246 /* name[2] is true if strlen(name) > 2 */
247 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
248 yyerror(Perl_form(aTHX_ "Can't use global %c^%c%s in \"my\"",
249 name[0], toCTRL(name[1]), name + 2));
251 yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
255 /* check for duplicate declaration */
256 pad_check_dup(name, is_our, (PL_curstash ? PL_curstash : PL_defstash));
258 if (PL_in_my_stash && *name != '$') {
259 yyerror(Perl_form(aTHX_
260 "Can't declare class for non-scalar %s in \"%s\"",
262 is_our ? "our" : PL_in_my == KEY_state ? "state" : "my"));
265 /* allocate a spare slot and store the name in that slot */
267 off = pad_add_name(name,
270 /* $_ is always in main::, even with our */
271 ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
275 PL_in_my == KEY_state
283 Perl_op_free(pTHX_ OP *o)
288 if (!o || o->op_static)
292 if (o->op_private & OPpREFCOUNTED) {
303 refcnt = OpREFCNT_dec(o);
314 if (o->op_flags & OPf_KIDS) {
315 register OP *kid, *nextkid;
316 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
317 nextkid = kid->op_sibling; /* Get before next freeing kid */
322 type = (OPCODE)o->op_targ;
324 /* COP* is not cleared by op_clear() so that we may track line
325 * numbers etc even after null() */
326 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
331 #ifdef DEBUG_LEAKING_SCALARS
338 Perl_op_clear(pTHX_ OP *o)
343 /* if (o->op_madprop && o->op_madprop->mad_next)
345 /* FIXME for MAD - if I uncomment these two lines t/op/pack.t fails with
346 "modification of a read only value" for a reason I can't fathom why.
347 It's the "" stringification of $_, where $_ was set to '' in a foreach
348 loop, but it defies simplification into a small test case.
349 However, commenting them out has caused ext/List/Util/t/weak.t to fail
352 mad_free(o->op_madprop);
358 switch (o->op_type) {
359 case OP_NULL: /* Was holding old type, if any. */
360 if (PL_madskills && o->op_targ != OP_NULL) {
361 o->op_type = o->op_targ;
365 case OP_ENTEREVAL: /* Was holding hints. */
369 if (!(o->op_flags & OPf_REF)
370 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
376 if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
377 /* not an OP_PADAV replacement */
379 if (cPADOPo->op_padix > 0) {
380 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
381 * may still exist on the pad */
382 pad_swipe(cPADOPo->op_padix, TRUE);
383 cPADOPo->op_padix = 0;
386 SvREFCNT_dec(cSVOPo->op_sv);
387 cSVOPo->op_sv = NULL;
391 case OP_METHOD_NAMED:
393 SvREFCNT_dec(cSVOPo->op_sv);
394 cSVOPo->op_sv = NULL;
397 Even if op_clear does a pad_free for the target of the op,
398 pad_free doesn't actually remove the sv that exists in the pad;
399 instead it lives on. This results in that it could be reused as
400 a target later on when the pad was reallocated.
403 pad_swipe(o->op_targ,1);
412 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
416 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
417 SvREFCNT_dec(cSVOPo->op_sv);
418 cSVOPo->op_sv = NULL;
421 Safefree(cPVOPo->op_pv);
422 cPVOPo->op_pv = NULL;
426 op_free(cPMOPo->op_pmreplroot);
430 if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) {
431 /* No GvIN_PAD_off here, because other references may still
432 * exist on the pad */
433 pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot), TRUE);
436 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
443 HV * const pmstash = PmopSTASH(cPMOPo);
444 if (pmstash && !SvIS_FREED(pmstash)) {
445 MAGIC * const mg = mg_find((SV*)pmstash, PERL_MAGIC_symtab);
447 PMOP *pmop = (PMOP*) mg->mg_obj;
448 PMOP *lastpmop = NULL;
450 if (cPMOPo == pmop) {
452 lastpmop->op_pmnext = pmop->op_pmnext;
454 mg->mg_obj = (SV*) pmop->op_pmnext;
458 pmop = pmop->op_pmnext;
462 PmopSTASH_free(cPMOPo);
464 cPMOPo->op_pmreplroot = NULL;
465 /* we use the "SAFE" version of the PM_ macros here
466 * since sv_clean_all might release some PMOPs
467 * after PL_regex_padav has been cleared
468 * and the clearing of PL_regex_padav needs to
469 * happen before sv_clean_all
471 ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
472 PM_SETRE_SAFE(cPMOPo, NULL);
474 if(PL_regex_pad) { /* We could be in destruction */
475 av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
476 SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
477 PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
484 if (o->op_targ > 0) {
485 pad_free(o->op_targ);
491 S_cop_free(pTHX_ COP* cop)
493 Safefree(cop->cop_label); /* FIXME: treaddead ??? */
496 if (! specialWARN(cop->cop_warnings))
497 PerlMemShared_free(cop->cop_warnings);
498 Perl_refcounted_he_free(aTHX_ cop->cop_hints_hash);
502 Perl_op_null(pTHX_ OP *o)
505 if (o->op_type == OP_NULL)
509 o->op_targ = o->op_type;
510 o->op_type = OP_NULL;
511 o->op_ppaddr = PL_ppaddr[OP_NULL];
515 Perl_op_refcnt_lock(pTHX)
523 Perl_op_refcnt_unlock(pTHX)
530 /* Contextualizers */
532 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
535 Perl_linklist(pTHX_ OP *o)
542 /* establish postfix order */
543 first = cUNOPo->op_first;
546 o->op_next = LINKLIST(first);
549 if (kid->op_sibling) {
550 kid->op_next = LINKLIST(kid->op_sibling);
551 kid = kid->op_sibling;
565 Perl_scalarkids(pTHX_ OP *o)
567 if (o && o->op_flags & OPf_KIDS) {
569 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
576 S_scalarboolean(pTHX_ OP *o)
579 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
580 if (ckWARN(WARN_SYNTAX)) {
581 const line_t oldline = CopLINE(PL_curcop);
583 if (PL_copline != NOLINE)
584 CopLINE_set(PL_curcop, PL_copline);
585 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
586 CopLINE_set(PL_curcop, oldline);
593 Perl_scalar(pTHX_ OP *o)
598 /* assumes no premature commitment */
599 if (!o || PL_error_count || (o->op_flags & OPf_WANT)
600 || o->op_type == OP_RETURN)
605 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
607 switch (o->op_type) {
609 scalar(cBINOPo->op_first);
614 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
618 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
619 if (!kPMOP->op_pmreplroot)
620 deprecate_old("implicit split to @_");
628 if (o->op_flags & OPf_KIDS) {
629 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
635 kid = cLISTOPo->op_first;
637 while ((kid = kid->op_sibling)) {
643 PL_curcop = &PL_compiling;
648 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
654 PL_curcop = &PL_compiling;
657 if (ckWARN(WARN_VOID))
658 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
664 Perl_scalarvoid(pTHX_ OP *o)
668 const char* useless = NULL;
672 /* trailing mad null ops don't count as "there" for void processing */
674 o->op_type != OP_NULL &&
676 o->op_sibling->op_type == OP_NULL)
679 for (sib = o->op_sibling;
680 sib && sib->op_type == OP_NULL;
681 sib = sib->op_sibling) ;
687 if (o->op_type == OP_NEXTSTATE
688 || o->op_type == OP_SETSTATE
689 || o->op_type == OP_DBSTATE
690 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
691 || o->op_targ == OP_SETSTATE
692 || o->op_targ == OP_DBSTATE)))
693 PL_curcop = (COP*)o; /* for warning below */
695 /* assumes no premature commitment */
696 want = o->op_flags & OPf_WANT;
697 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
698 || o->op_type == OP_RETURN)
703 if ((o->op_private & OPpTARGET_MY)
704 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
706 return scalar(o); /* As if inside SASSIGN */
709 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
711 switch (o->op_type) {
713 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
717 if (o->op_flags & OPf_STACKED)
721 if (o->op_private == 4)
793 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
794 useless = OP_DESC(o);
798 kid = cUNOPo->op_first;
799 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
800 kid->op_type != OP_TRANS) {
803 useless = "negative pattern binding (!~)";
810 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
811 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
812 useless = "a variable";
817 if (cSVOPo->op_private & OPpCONST_STRICT)
818 no_bareword_allowed(o);
820 if (ckWARN(WARN_VOID)) {
821 useless = "a constant";
822 if (o->op_private & OPpCONST_ARYBASE)
824 /* don't warn on optimised away booleans, eg
825 * use constant Foo, 5; Foo || print; */
826 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
828 /* the constants 0 and 1 are permitted as they are
829 conventionally used as dummies in constructs like
830 1 while some_condition_with_side_effects; */
831 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
833 else if (SvPOK(sv)) {
834 /* perl4's way of mixing documentation and code
835 (before the invention of POD) was based on a
836 trick to mix nroff and perl code. The trick was
837 built upon these three nroff macros being used in
838 void context. The pink camel has the details in
839 the script wrapman near page 319. */
840 const char * const maybe_macro = SvPVX_const(sv);
841 if (strnEQ(maybe_macro, "di", 2) ||
842 strnEQ(maybe_macro, "ds", 2) ||
843 strnEQ(maybe_macro, "ig", 2))
848 op_null(o); /* don't execute or even remember it */
852 o->op_type = OP_PREINC; /* pre-increment is faster */
853 o->op_ppaddr = PL_ppaddr[OP_PREINC];
857 o->op_type = OP_PREDEC; /* pre-decrement is faster */
858 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
862 o->op_type = OP_I_PREINC; /* pre-increment is faster */
863 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
867 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
868 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
877 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
882 if (o->op_flags & OPf_STACKED)
889 if (!(o->op_flags & OPf_KIDS))
900 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
907 /* all requires must return a boolean value */
908 o->op_flags &= ~OPf_WANT;
913 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
914 if (!kPMOP->op_pmreplroot)
915 deprecate_old("implicit split to @_");
919 if (useless && ckWARN(WARN_VOID))
920 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
925 Perl_listkids(pTHX_ OP *o)
927 if (o && o->op_flags & OPf_KIDS) {
929 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
936 Perl_list(pTHX_ OP *o)
941 /* assumes no premature commitment */
942 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
943 || o->op_type == OP_RETURN)
948 if ((o->op_private & OPpTARGET_MY)
949 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
951 return o; /* As if inside SASSIGN */
954 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
956 switch (o->op_type) {
959 list(cBINOPo->op_first);
964 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
972 if (!(o->op_flags & OPf_KIDS))
974 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
975 list(cBINOPo->op_first);
976 return gen_constant_list(o);
983 kid = cLISTOPo->op_first;
985 while ((kid = kid->op_sibling)) {
991 PL_curcop = &PL_compiling;
995 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1001 PL_curcop = &PL_compiling;
1004 /* all requires must return a boolean value */
1005 o->op_flags &= ~OPf_WANT;
1012 Perl_scalarseq(pTHX_ OP *o)
1016 const OPCODE type = o->op_type;
1018 if (type == OP_LINESEQ || type == OP_SCOPE ||
1019 type == OP_LEAVE || type == OP_LEAVETRY)
1022 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1023 if (kid->op_sibling) {
1027 PL_curcop = &PL_compiling;
1029 o->op_flags &= ~OPf_PARENS;
1030 if (PL_hints & HINT_BLOCK_SCOPE)
1031 o->op_flags |= OPf_PARENS;
1034 o = newOP(OP_STUB, 0);
1039 S_modkids(pTHX_ OP *o, I32 type)
1041 if (o && o->op_flags & OPf_KIDS) {
1043 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1049 /* Propagate lvalue ("modifiable") context to an op and its children.
1050 * 'type' represents the context type, roughly based on the type of op that
1051 * would do the modifying, although local() is represented by OP_NULL.
1052 * It's responsible for detecting things that can't be modified, flag
1053 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
1054 * might have to vivify a reference in $x), and so on.
1056 * For example, "$a+1 = 2" would cause mod() to be called with o being
1057 * OP_ADD and type being OP_SASSIGN, and would output an error.
1061 Perl_mod(pTHX_ OP *o, I32 type)
1065 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1068 if (!o || PL_error_count)
1071 if ((o->op_private & OPpTARGET_MY)
1072 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1077 switch (o->op_type) {
1083 if (!(o->op_private & OPpCONST_ARYBASE))
1086 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1087 CopARYBASE_set(&PL_compiling,
1088 (I32)SvIV(cSVOPx(PL_eval_start)->op_sv));
1092 SAVECOPARYBASE(&PL_compiling);
1093 CopARYBASE_set(&PL_compiling, 0);
1095 else if (type == OP_REFGEN)
1098 Perl_croak(aTHX_ "That use of $[ is unsupported");
1101 if (o->op_flags & OPf_PARENS || PL_madskills)
1105 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1106 !(o->op_flags & OPf_STACKED)) {
1107 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1108 /* The default is to set op_private to the number of children,
1109 which for a UNOP such as RV2CV is always 1. And w're using
1110 the bit for a flag in RV2CV, so we need it clear. */
1111 o->op_private &= ~1;
1112 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1113 assert(cUNOPo->op_first->op_type == OP_NULL);
1114 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1117 else if (o->op_private & OPpENTERSUB_NOMOD)
1119 else { /* lvalue subroutine call */
1120 o->op_private |= OPpLVAL_INTRO;
1121 PL_modcount = RETURN_UNLIMITED_NUMBER;
1122 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1123 /* Backward compatibility mode: */
1124 o->op_private |= OPpENTERSUB_INARGS;
1127 else { /* Compile-time error message: */
1128 OP *kid = cUNOPo->op_first;
1132 if (kid->op_type != OP_PUSHMARK) {
1133 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1135 "panic: unexpected lvalue entersub "
1136 "args: type/targ %ld:%"UVuf,
1137 (long)kid->op_type, (UV)kid->op_targ);
1138 kid = kLISTOP->op_first;
1140 while (kid->op_sibling)
1141 kid = kid->op_sibling;
1142 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1144 if (kid->op_type == OP_METHOD_NAMED
1145 || kid->op_type == OP_METHOD)
1149 NewOp(1101, newop, 1, UNOP);
1150 newop->op_type = OP_RV2CV;
1151 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1152 newop->op_first = NULL;
1153 newop->op_next = (OP*)newop;
1154 kid->op_sibling = (OP*)newop;
1155 newop->op_private |= OPpLVAL_INTRO;
1156 newop->op_private &= ~1;
1160 if (kid->op_type != OP_RV2CV)
1162 "panic: unexpected lvalue entersub "
1163 "entry via type/targ %ld:%"UVuf,
1164 (long)kid->op_type, (UV)kid->op_targ);
1165 kid->op_private |= OPpLVAL_INTRO;
1166 break; /* Postpone until runtime */
1170 kid = kUNOP->op_first;
1171 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1172 kid = kUNOP->op_first;
1173 if (kid->op_type == OP_NULL)
1175 "Unexpected constant lvalue entersub "
1176 "entry via type/targ %ld:%"UVuf,
1177 (long)kid->op_type, (UV)kid->op_targ);
1178 if (kid->op_type != OP_GV) {
1179 /* Restore RV2CV to check lvalueness */
1181 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1182 okid->op_next = kid->op_next;
1183 kid->op_next = okid;
1186 okid->op_next = NULL;
1187 okid->op_type = OP_RV2CV;
1189 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1190 okid->op_private |= OPpLVAL_INTRO;
1191 okid->op_private &= ~1;
1195 cv = GvCV(kGVOP_gv);
1205 /* grep, foreach, subcalls, refgen */
1206 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1208 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1209 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1211 : (o->op_type == OP_ENTERSUB
1212 ? "non-lvalue subroutine call"
1214 type ? PL_op_desc[type] : "local"));
1228 case OP_RIGHT_SHIFT:
1237 if (!(o->op_flags & OPf_STACKED))
1244 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1250 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1251 PL_modcount = RETURN_UNLIMITED_NUMBER;
1252 return o; /* Treat \(@foo) like ordinary list. */
1256 if (scalar_mod_type(o, type))
1258 ref(cUNOPo->op_first, o->op_type);
1262 if (type == OP_LEAVESUBLV)
1263 o->op_private |= OPpMAYBE_LVSUB;
1269 PL_modcount = RETURN_UNLIMITED_NUMBER;
1272 ref(cUNOPo->op_first, o->op_type);
1277 PL_hints |= HINT_BLOCK_SCOPE;
1292 PL_modcount = RETURN_UNLIMITED_NUMBER;
1293 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1294 return o; /* Treat \(@foo) like ordinary list. */
1295 if (scalar_mod_type(o, type))
1297 if (type == OP_LEAVESUBLV)
1298 o->op_private |= OPpMAYBE_LVSUB;
1302 if (!type) /* local() */
1303 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1304 PAD_COMPNAME_PV(o->op_targ));
1312 if (type != OP_SASSIGN)
1316 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1321 if (type == OP_LEAVESUBLV)
1322 o->op_private |= OPpMAYBE_LVSUB;
1324 pad_free(o->op_targ);
1325 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1326 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1327 if (o->op_flags & OPf_KIDS)
1328 mod(cBINOPo->op_first->op_sibling, type);
1333 ref(cBINOPo->op_first, o->op_type);
1334 if (type == OP_ENTERSUB &&
1335 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1336 o->op_private |= OPpLVAL_DEFER;
1337 if (type == OP_LEAVESUBLV)
1338 o->op_private |= OPpMAYBE_LVSUB;
1348 if (o->op_flags & OPf_KIDS)
1349 mod(cLISTOPo->op_last, type);
1354 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1356 else if (!(o->op_flags & OPf_KIDS))
1358 if (o->op_targ != OP_LIST) {
1359 mod(cBINOPo->op_first, type);
1365 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1370 if (type != OP_LEAVESUBLV)
1372 break; /* mod()ing was handled by ck_return() */
1375 /* [20011101.069] File test operators interpret OPf_REF to mean that
1376 their argument is a filehandle; thus \stat(".") should not set
1378 if (type == OP_REFGEN &&
1379 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1382 if (type != OP_LEAVESUBLV)
1383 o->op_flags |= OPf_MOD;
1385 if (type == OP_AASSIGN || type == OP_SASSIGN)
1386 o->op_flags |= OPf_SPECIAL|OPf_REF;
1387 else if (!type) { /* local() */
1390 o->op_private |= OPpLVAL_INTRO;
1391 o->op_flags &= ~OPf_SPECIAL;
1392 PL_hints |= HINT_BLOCK_SCOPE;
1397 if (ckWARN(WARN_SYNTAX)) {
1398 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1399 "Useless localization of %s", OP_DESC(o));
1403 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1404 && type != OP_LEAVESUBLV)
1405 o->op_flags |= OPf_REF;
1410 S_scalar_mod_type(const OP *o, I32 type)
1414 if (o->op_type == OP_RV2GV)
1438 case OP_RIGHT_SHIFT:
1457 S_is_handle_constructor(const OP *o, I32 numargs)
1459 switch (o->op_type) {
1467 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1480 Perl_refkids(pTHX_ OP *o, I32 type)
1482 if (o && o->op_flags & OPf_KIDS) {
1484 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1491 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
1496 if (!o || PL_error_count)
1499 switch (o->op_type) {
1501 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1502 !(o->op_flags & OPf_STACKED)) {
1503 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1504 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1505 assert(cUNOPo->op_first->op_type == OP_NULL);
1506 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1507 o->op_flags |= OPf_SPECIAL;
1508 o->op_private &= ~1;
1513 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1514 doref(kid, type, set_op_ref);
1517 if (type == OP_DEFINED)
1518 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1519 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1522 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1523 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1524 : type == OP_RV2HV ? OPpDEREF_HV
1526 o->op_flags |= OPf_MOD;
1531 o->op_flags |= OPf_MOD; /* XXX ??? */
1537 o->op_flags |= OPf_REF;
1540 if (type == OP_DEFINED)
1541 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1542 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1548 o->op_flags |= OPf_REF;
1553 if (!(o->op_flags & OPf_KIDS))
1555 doref(cBINOPo->op_first, type, set_op_ref);
1559 doref(cBINOPo->op_first, o->op_type, set_op_ref);
1560 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1561 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1562 : type == OP_RV2HV ? OPpDEREF_HV
1564 o->op_flags |= OPf_MOD;
1574 if (!(o->op_flags & OPf_KIDS))
1576 doref(cLISTOPo->op_last, type, set_op_ref);
1586 S_dup_attrlist(pTHX_ OP *o)
1591 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1592 * where the first kid is OP_PUSHMARK and the remaining ones
1593 * are OP_CONST. We need to push the OP_CONST values.
1595 if (o->op_type == OP_CONST)
1596 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
1598 else if (o->op_type == OP_NULL)
1602 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1604 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1605 if (o->op_type == OP_CONST)
1606 rop = append_elem(OP_LIST, rop,
1607 newSVOP(OP_CONST, o->op_flags,
1608 SvREFCNT_inc_NN(cSVOPo->op_sv)));
1615 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1620 /* fake up C<use attributes $pkg,$rv,@attrs> */
1621 ENTER; /* need to protect against side-effects of 'use' */
1623 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1625 #define ATTRSMODULE "attributes"
1626 #define ATTRSMODULE_PM "attributes.pm"
1629 /* Don't force the C<use> if we don't need it. */
1630 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
1631 if (svp && *svp != &PL_sv_undef)
1632 NOOP; /* already in %INC */
1634 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1635 newSVpvs(ATTRSMODULE), NULL);
1638 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1639 newSVpvs(ATTRSMODULE),
1641 prepend_elem(OP_LIST,
1642 newSVOP(OP_CONST, 0, stashsv),
1643 prepend_elem(OP_LIST,
1644 newSVOP(OP_CONST, 0,
1646 dup_attrlist(attrs))));
1652 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1655 OP *pack, *imop, *arg;
1661 assert(target->op_type == OP_PADSV ||
1662 target->op_type == OP_PADHV ||
1663 target->op_type == OP_PADAV);
1665 /* Ensure that attributes.pm is loaded. */
1666 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1668 /* Need package name for method call. */
1669 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
1671 /* Build up the real arg-list. */
1672 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1674 arg = newOP(OP_PADSV, 0);
1675 arg->op_targ = target->op_targ;
1676 arg = prepend_elem(OP_LIST,
1677 newSVOP(OP_CONST, 0, stashsv),
1678 prepend_elem(OP_LIST,
1679 newUNOP(OP_REFGEN, 0,
1680 mod(arg, OP_REFGEN)),
1681 dup_attrlist(attrs)));
1683 /* Fake up a method call to import */
1684 meth = newSVpvs_share("import");
1685 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1686 append_elem(OP_LIST,
1687 prepend_elem(OP_LIST, pack, list(arg)),
1688 newSVOP(OP_METHOD_NAMED, 0, meth)));
1689 imop->op_private |= OPpENTERSUB_NOMOD;
1691 /* Combine the ops. */
1692 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1696 =notfor apidoc apply_attrs_string
1698 Attempts to apply a list of attributes specified by the C<attrstr> and
1699 C<len> arguments to the subroutine identified by the C<cv> argument which
1700 is expected to be associated with the package identified by the C<stashpv>
1701 argument (see L<attributes>). It gets this wrong, though, in that it
1702 does not correctly identify the boundaries of the individual attribute
1703 specifications within C<attrstr>. This is not really intended for the
1704 public API, but has to be listed here for systems such as AIX which
1705 need an explicit export list for symbols. (It's called from XS code
1706 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1707 to respect attribute syntax properly would be welcome.
1713 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
1714 const char *attrstr, STRLEN len)
1719 len = strlen(attrstr);
1723 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1725 const char * const sstr = attrstr;
1726 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1727 attrs = append_elem(OP_LIST, attrs,
1728 newSVOP(OP_CONST, 0,
1729 newSVpvn(sstr, attrstr-sstr)));
1733 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1734 newSVpvs(ATTRSMODULE),
1735 NULL, prepend_elem(OP_LIST,
1736 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1737 prepend_elem(OP_LIST,
1738 newSVOP(OP_CONST, 0,
1744 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
1749 if (!o || PL_error_count)
1753 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
1754 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
1758 if (type == OP_LIST) {
1760 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1761 my_kid(kid, attrs, imopsp);
1762 } else if (type == OP_UNDEF
1768 } else if (type == OP_RV2SV || /* "our" declaration */
1770 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1771 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1772 yyerror(Perl_form(aTHX_ "Can't declare %s in %s",
1774 PL_in_my == KEY_our ? "our" : PL_in_my == KEY_state ? "state" : "my"));
1776 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
1778 PL_in_my_stash = NULL;
1779 apply_attrs(GvSTASH(gv),
1780 (type == OP_RV2SV ? GvSV(gv) :
1781 type == OP_RV2AV ? (SV*)GvAV(gv) :
1782 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1785 o->op_private |= OPpOUR_INTRO;
1788 else if (type != OP_PADSV &&
1791 type != OP_PUSHMARK)
1793 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1795 PL_in_my == KEY_our ? "our" : PL_in_my == KEY_state ? "state" : "my"));
1798 else if (attrs && type != OP_PUSHMARK) {
1802 PL_in_my_stash = NULL;
1804 /* check for C<my Dog $spot> when deciding package */
1805 stash = PAD_COMPNAME_TYPE(o->op_targ);
1807 stash = PL_curstash;
1808 apply_attrs_my(stash, o, attrs, imopsp);
1810 o->op_flags |= OPf_MOD;
1811 o->op_private |= OPpLVAL_INTRO;
1812 if (PL_in_my == KEY_state)
1813 o->op_private |= OPpPAD_STATE;
1818 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1822 int maybe_scalar = 0;
1824 /* [perl #17376]: this appears to be premature, and results in code such as
1825 C< our(%x); > executing in list mode rather than void mode */
1827 if (o->op_flags & OPf_PARENS)
1837 o = my_kid(o, attrs, &rops);
1839 if (maybe_scalar && o->op_type == OP_PADSV) {
1840 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
1841 o->op_private |= OPpLVAL_INTRO;
1844 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
1847 PL_in_my_stash = NULL;
1852 Perl_my(pTHX_ OP *o)
1854 return my_attrs(o, NULL);
1858 Perl_sawparens(pTHX_ OP *o)
1860 PERL_UNUSED_CONTEXT;
1862 o->op_flags |= OPf_PARENS;
1867 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
1871 const OPCODE ltype = left->op_type;
1872 const OPCODE rtype = right->op_type;
1874 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
1875 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
1877 const char * const desc
1878 = PL_op_desc[(rtype == OP_SUBST || rtype == OP_TRANS)
1879 ? rtype : OP_MATCH];
1880 const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV)
1881 ? "@array" : "%hash");
1882 Perl_warner(aTHX_ packWARN(WARN_MISC),
1883 "Applying %s to %s will act on scalar(%s)",
1884 desc, sample, sample);
1887 if (rtype == OP_CONST &&
1888 cSVOPx(right)->op_private & OPpCONST_BARE &&
1889 cSVOPx(right)->op_private & OPpCONST_STRICT)
1891 no_bareword_allowed(right);
1894 ismatchop = rtype == OP_MATCH ||
1895 rtype == OP_SUBST ||
1897 if (ismatchop && right->op_private & OPpTARGET_MY) {
1899 right->op_private &= ~OPpTARGET_MY;
1901 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
1904 right->op_flags |= OPf_STACKED;
1905 if (rtype != OP_MATCH &&
1906 ! (rtype == OP_TRANS &&
1907 right->op_private & OPpTRANS_IDENTICAL))
1908 newleft = mod(left, rtype);
1911 if (right->op_type == OP_TRANS)
1912 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
1914 o = prepend_elem(rtype, scalar(newleft), right);
1916 return newUNOP(OP_NOT, 0, scalar(o));
1920 return bind_match(type, left,
1921 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
1925 Perl_invert(pTHX_ OP *o)
1929 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
1933 Perl_scope(pTHX_ OP *o)
1937 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
1938 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
1939 o->op_type = OP_LEAVE;
1940 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
1942 else if (o->op_type == OP_LINESEQ) {
1944 o->op_type = OP_SCOPE;
1945 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
1946 kid = ((LISTOP*)o)->op_first;
1947 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
1950 /* The following deals with things like 'do {1 for 1}' */
1951 kid = kid->op_sibling;
1953 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
1958 o = newLISTOP(OP_SCOPE, 0, o, NULL);
1964 Perl_block_start(pTHX_ int full)
1967 const int retval = PL_savestack_ix;
1968 pad_block_start(full);
1970 PL_hints &= ~HINT_BLOCK_SCOPE;
1971 SAVECOMPILEWARNINGS();
1972 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
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 CopHINTS_set(&PL_compiling, PL_hints);
1985 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
1994 const PADOFFSET 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" : PL_in_my == KEY_state ? "state" : "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, SVt_PV)));
2110 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2116 Perl_fold_constants(pTHX_ register OP *o)
2121 I32 type = o->op_type;
2126 SV * const oldwarnhook = PL_warnhook;
2127 SV * const olddiehook = PL_diehook;
2130 if (PL_opargs[type] & OA_RETSCALAR)
2132 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2133 o->op_targ = pad_alloc(type, SVs_PADTMP);
2135 /* integerize op, unless it happens to be C<-foo>.
2136 * XXX should pp_i_negate() do magic string negation instead? */
2137 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2138 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2139 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2141 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2144 if (!(PL_opargs[type] & OA_FOLDCONST))
2149 /* XXX might want a ck_negate() for this */
2150 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2161 /* XXX what about the numeric ops? */
2162 if (PL_hints & HINT_LOCALE)
2167 goto nope; /* Don't try to run w/ errors */
2169 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2170 const OPCODE type = curop->op_type;
2171 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2173 type != OP_SCALAR &&
2175 type != OP_PUSHMARK)
2181 curop = LINKLIST(o);
2182 old_next = o->op_next;
2186 oldscope = PL_scopestack_ix;
2187 create_eval_scope(G_FAKINGEVAL);
2189 PL_warnhook = PERL_WARNHOOK_FATAL;
2196 sv = *(PL_stack_sp--);
2197 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2198 pad_swipe(o->op_targ, FALSE);
2199 else if (SvTEMP(sv)) { /* grab mortal temp? */
2200 SvREFCNT_inc_simple_void(sv);
2205 /* Something tried to die. Abandon constant folding. */
2206 /* Pretend the error never happened. */
2207 sv_setpvn(ERRSV,"",0);
2208 o->op_next = old_next;
2212 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
2213 PL_warnhook = oldwarnhook;
2214 PL_diehook = olddiehook;
2215 /* XXX note that this croak may fail as we've already blown away
2216 * the stack - eg any nested evals */
2217 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
2220 PL_warnhook = oldwarnhook;
2221 PL_diehook = olddiehook;
2223 if (PL_scopestack_ix > oldscope)
2224 delete_eval_scope();
2233 if (type == OP_RV2GV)
2234 newop = newGVOP(OP_GV, 0, (GV*)sv);
2236 newop = newSVOP(OP_CONST, 0, sv);
2237 op_getmad(o,newop,'f');
2245 Perl_gen_constant_list(pTHX_ register OP *o)
2249 const I32 oldtmps_floor = PL_tmps_floor;
2253 return o; /* Don't attempt to run with errors */
2255 PL_op = curop = LINKLIST(o);
2262 PL_tmps_floor = oldtmps_floor;
2264 o->op_type = OP_RV2AV;
2265 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2266 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2267 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2268 o->op_opt = 0; /* needs to be revisited in peep() */
2269 curop = ((UNOP*)o)->op_first;
2270 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
2272 op_getmad(curop,o,'O');
2281 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2284 if (!o || o->op_type != OP_LIST)
2285 o = newLISTOP(OP_LIST, 0, o, NULL);
2287 o->op_flags &= ~OPf_WANT;
2289 if (!(PL_opargs[type] & OA_MARK))
2290 op_null(cLISTOPo->op_first);
2292 o->op_type = (OPCODE)type;
2293 o->op_ppaddr = PL_ppaddr[type];
2294 o->op_flags |= flags;
2296 o = CHECKOP(type, o);
2297 if (o->op_type != (unsigned)type)
2300 return fold_constants(o);
2303 /* List constructors */
2306 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2314 if (first->op_type != (unsigned)type
2315 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2317 return newLISTOP(type, 0, first, last);
2320 if (first->op_flags & OPf_KIDS)
2321 ((LISTOP*)first)->op_last->op_sibling = last;
2323 first->op_flags |= OPf_KIDS;
2324 ((LISTOP*)first)->op_first = last;
2326 ((LISTOP*)first)->op_last = last;
2331 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2339 if (first->op_type != (unsigned)type)
2340 return prepend_elem(type, (OP*)first, (OP*)last);
2342 if (last->op_type != (unsigned)type)
2343 return append_elem(type, (OP*)first, (OP*)last);
2345 first->op_last->op_sibling = last->op_first;
2346 first->op_last = last->op_last;
2347 first->op_flags |= (last->op_flags & OPf_KIDS);
2350 if (last->op_first && first->op_madprop) {
2351 MADPROP *mp = last->op_first->op_madprop;
2353 while (mp->mad_next)
2355 mp->mad_next = first->op_madprop;
2358 last->op_first->op_madprop = first->op_madprop;
2361 first->op_madprop = last->op_madprop;
2362 last->op_madprop = 0;
2371 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2379 if (last->op_type == (unsigned)type) {
2380 if (type == OP_LIST) { /* already a PUSHMARK there */
2381 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2382 ((LISTOP*)last)->op_first->op_sibling = first;
2383 if (!(first->op_flags & OPf_PARENS))
2384 last->op_flags &= ~OPf_PARENS;
2387 if (!(last->op_flags & OPf_KIDS)) {
2388 ((LISTOP*)last)->op_last = first;
2389 last->op_flags |= OPf_KIDS;
2391 first->op_sibling = ((LISTOP*)last)->op_first;
2392 ((LISTOP*)last)->op_first = first;
2394 last->op_flags |= OPf_KIDS;
2398 return newLISTOP(type, 0, first, last);
2406 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2409 Newxz(tk, 1, TOKEN);
2410 tk->tk_type = (OPCODE)optype;
2411 tk->tk_type = 12345;
2413 tk->tk_mad = madprop;
2418 Perl_token_free(pTHX_ TOKEN* tk)
2420 if (tk->tk_type != 12345)
2422 mad_free(tk->tk_mad);
2427 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2431 if (tk->tk_type != 12345) {
2432 Perl_warner(aTHX_ packWARN(WARN_MISC),
2433 "Invalid TOKEN object ignored");
2440 /* faked up qw list? */
2442 tm->mad_type == MAD_SV &&
2443 SvPVX((SV*)tm->mad_val)[0] == 'q')
2450 /* pretend constant fold didn't happen? */
2451 if (mp->mad_key == 'f' &&
2452 (o->op_type == OP_CONST ||
2453 o->op_type == OP_GV) )
2455 token_getmad(tk,(OP*)mp->mad_val,slot);
2469 if (mp->mad_key == 'X')
2470 mp->mad_key = slot; /* just change the first one */
2480 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
2489 /* pretend constant fold didn't happen? */
2490 if (mp->mad_key == 'f' &&
2491 (o->op_type == OP_CONST ||
2492 o->op_type == OP_GV) )
2494 op_getmad(from,(OP*)mp->mad_val,slot);
2501 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
2504 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
2510 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
2519 /* pretend constant fold didn't happen? */
2520 if (mp->mad_key == 'f' &&
2521 (o->op_type == OP_CONST ||
2522 o->op_type == OP_GV) )
2524 op_getmad(from,(OP*)mp->mad_val,slot);
2531 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
2534 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
2538 PerlIO_printf(PerlIO_stderr(),
2539 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
2545 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
2563 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
2567 addmad(tm, &(o->op_madprop), slot);
2571 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
2592 Perl_newMADsv(pTHX_ char key, SV* sv)
2594 return newMADPROP(key, MAD_SV, sv, 0);
2598 Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
2601 Newxz(mp, 1, MADPROP);
2604 mp->mad_vlen = vlen;
2605 mp->mad_type = type;
2607 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
2612 Perl_mad_free(pTHX_ MADPROP* mp)
2614 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
2618 mad_free(mp->mad_next);
2619 /* if (PL_lex_state != LEX_NOTPARSING && mp->mad_vlen)
2620 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
2621 switch (mp->mad_type) {
2625 Safefree((char*)mp->mad_val);
2628 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
2629 op_free((OP*)mp->mad_val);
2632 sv_free((SV*)mp->mad_val);
2635 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
2644 Perl_newNULLLIST(pTHX)
2646 return newOP(OP_STUB, 0);
2650 Perl_force_list(pTHX_ OP *o)
2652 if (!o || o->op_type != OP_LIST)
2653 o = newLISTOP(OP_LIST, 0, o, NULL);
2659 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2664 NewOp(1101, listop, 1, LISTOP);
2666 listop->op_type = (OPCODE)type;
2667 listop->op_ppaddr = PL_ppaddr[type];
2670 listop->op_flags = (U8)flags;
2674 else if (!first && last)
2677 first->op_sibling = last;
2678 listop->op_first = first;
2679 listop->op_last = last;
2680 if (type == OP_LIST) {
2681 OP* const pushop = newOP(OP_PUSHMARK, 0);
2682 pushop->op_sibling = first;
2683 listop->op_first = pushop;
2684 listop->op_flags |= OPf_KIDS;
2686 listop->op_last = pushop;
2689 return CHECKOP(type, listop);
2693 Perl_newOP(pTHX_ I32 type, I32 flags)
2697 NewOp(1101, o, 1, OP);
2698 o->op_type = (OPCODE)type;
2699 o->op_ppaddr = PL_ppaddr[type];
2700 o->op_flags = (U8)flags;
2703 o->op_private = (U8)(0 | (flags >> 8));
2704 if (PL_opargs[type] & OA_RETSCALAR)
2706 if (PL_opargs[type] & OA_TARGET)
2707 o->op_targ = pad_alloc(type, SVs_PADTMP);
2708 return CHECKOP(type, o);
2712 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2718 first = newOP(OP_STUB, 0);
2719 if (PL_opargs[type] & OA_MARK)
2720 first = force_list(first);
2722 NewOp(1101, unop, 1, UNOP);
2723 unop->op_type = (OPCODE)type;
2724 unop->op_ppaddr = PL_ppaddr[type];
2725 unop->op_first = first;
2726 unop->op_flags = (U8)(flags | OPf_KIDS);
2727 unop->op_private = (U8)(1 | (flags >> 8));
2728 unop = (UNOP*) CHECKOP(type, unop);
2732 return fold_constants((OP *) unop);
2736 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2740 NewOp(1101, binop, 1, BINOP);
2743 first = newOP(OP_NULL, 0);
2745 binop->op_type = (OPCODE)type;
2746 binop->op_ppaddr = PL_ppaddr[type];
2747 binop->op_first = first;
2748 binop->op_flags = (U8)(flags | OPf_KIDS);
2751 binop->op_private = (U8)(1 | (flags >> 8));
2754 binop->op_private = (U8)(2 | (flags >> 8));
2755 first->op_sibling = last;
2758 binop = (BINOP*)CHECKOP(type, binop);
2759 if (binop->op_next || binop->op_type != (OPCODE)type)
2762 binop->op_last = binop->op_first->op_sibling;
2764 return fold_constants((OP *)binop);
2767 static int uvcompare(const void *a, const void *b)
2768 __attribute__nonnull__(1)
2769 __attribute__nonnull__(2)
2770 __attribute__pure__;
2771 static int uvcompare(const void *a, const void *b)
2773 if (*((const UV *)a) < (*(const UV *)b))
2775 if (*((const UV *)a) > (*(const UV *)b))
2777 if (*((const UV *)a+1) < (*(const UV *)b+1))
2779 if (*((const UV *)a+1) > (*(const UV *)b+1))
2785 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2788 SV * const tstr = ((SVOP*)expr)->op_sv;
2789 SV * const rstr = ((SVOP*)repl)->op_sv;
2792 const U8 *t = (U8*)SvPV_const(tstr, tlen);
2793 const U8 *r = (U8*)SvPV_const(rstr, rlen);
2797 register short *tbl;
2799 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
2800 const I32 squash = o->op_private & OPpTRANS_SQUASH;
2801 I32 del = o->op_private & OPpTRANS_DELETE;
2802 PL_hints |= HINT_BLOCK_SCOPE;
2805 o->op_private |= OPpTRANS_FROM_UTF;
2808 o->op_private |= OPpTRANS_TO_UTF;
2810 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2811 SV* const listsv = newSVpvs("# comment\n");
2813 const U8* tend = t + tlen;
2814 const U8* rend = r + rlen;
2828 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2829 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2832 const U32 flags = UTF8_ALLOW_DEFAULT;
2836 t = tsave = bytes_to_utf8(t, &len);
2839 if (!to_utf && rlen) {
2841 r = rsave = bytes_to_utf8(r, &len);
2845 /* There are several snags with this code on EBCDIC:
2846 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2847 2. scan_const() in toke.c has encoded chars in native encoding which makes
2848 ranges at least in EBCDIC 0..255 range the bottom odd.
2852 U8 tmpbuf[UTF8_MAXBYTES+1];
2855 Newx(cp, 2*tlen, UV);
2857 transv = newSVpvs("");
2859 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
2861 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2863 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
2867 cp[2*i+1] = cp[2*i];
2871 qsort(cp, i, 2*sizeof(UV), uvcompare);
2872 for (j = 0; j < i; j++) {
2874 diff = val - nextmin;
2876 t = uvuni_to_utf8(tmpbuf,nextmin);
2877 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2879 U8 range_mark = UTF_TO_NATIVE(0xff);
2880 t = uvuni_to_utf8(tmpbuf, val - 1);
2881 sv_catpvn(transv, (char *)&range_mark, 1);
2882 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2889 t = uvuni_to_utf8(tmpbuf,nextmin);
2890 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2892 U8 range_mark = UTF_TO_NATIVE(0xff);
2893 sv_catpvn(transv, (char *)&range_mark, 1);
2895 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2896 UNICODE_ALLOW_SUPER);
2897 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2898 t = (const U8*)SvPVX_const(transv);
2899 tlen = SvCUR(transv);
2903 else if (!rlen && !del) {
2904 r = t; rlen = tlen; rend = tend;
2907 if ((!rlen && !del) || t == r ||
2908 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2910 o->op_private |= OPpTRANS_IDENTICAL;
2914 while (t < tend || tfirst <= tlast) {
2915 /* see if we need more "t" chars */
2916 if (tfirst > tlast) {
2917 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
2919 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2921 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
2928 /* now see if we need more "r" chars */
2929 if (rfirst > rlast) {
2931 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
2933 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2935 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
2944 rfirst = rlast = 0xffffffff;
2948 /* now see which range will peter our first, if either. */
2949 tdiff = tlast - tfirst;
2950 rdiff = rlast - rfirst;
2957 if (rfirst == 0xffffffff) {
2958 diff = tdiff; /* oops, pretend rdiff is infinite */
2960 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2961 (long)tfirst, (long)tlast);
2963 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2967 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2968 (long)tfirst, (long)(tfirst + diff),
2971 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2972 (long)tfirst, (long)rfirst);
2974 if (rfirst + diff > max)
2975 max = rfirst + diff;
2977 grows = (tfirst < rfirst &&
2978 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2990 else if (max > 0xff)
2995 Safefree(cPVOPo->op_pv);
2996 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2997 SvREFCNT_dec(listsv);
2998 SvREFCNT_dec(transv);
3000 if (!del && havefinal && rlen)
3001 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
3002 newSVuv((UV)final), 0);
3005 o->op_private |= OPpTRANS_GROWS;
3011 op_getmad(expr,o,'e');
3012 op_getmad(repl,o,'r');
3020 tbl = (short*)cPVOPo->op_pv;
3022 Zero(tbl, 256, short);
3023 for (i = 0; i < (I32)tlen; i++)
3025 for (i = 0, j = 0; i < 256; i++) {
3027 if (j >= (I32)rlen) {
3036 if (i < 128 && r[j] >= 128)
3046 o->op_private |= OPpTRANS_IDENTICAL;
3048 else if (j >= (I32)rlen)
3051 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
3052 tbl[0x100] = (short)(rlen - j);
3053 for (i=0; i < (I32)rlen - j; i++)
3054 tbl[0x101+i] = r[j+i];
3058 if (!rlen && !del) {
3061 o->op_private |= OPpTRANS_IDENTICAL;
3063 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3064 o->op_private |= OPpTRANS_IDENTICAL;
3066 for (i = 0; i < 256; i++)
3068 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3069 if (j >= (I32)rlen) {
3071 if (tbl[t[i]] == -1)
3077 if (tbl[t[i]] == -1) {
3078 if (t[i] < 128 && r[j] >= 128)
3085 o->op_private |= OPpTRANS_GROWS;
3087 op_getmad(expr,o,'e');
3088 op_getmad(repl,o,'r');
3098 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3103 NewOp(1101, pmop, 1, PMOP);
3104 pmop->op_type = (OPCODE)type;
3105 pmop->op_ppaddr = PL_ppaddr[type];
3106 pmop->op_flags = (U8)flags;
3107 pmop->op_private = (U8)(0 | (flags >> 8));
3109 if (PL_hints & HINT_RE_TAINT)
3110 pmop->op_pmpermflags |= PMf_RETAINT;
3111 if (PL_hints & HINT_LOCALE)
3112 pmop->op_pmpermflags |= PMf_LOCALE;
3113 pmop->op_pmflags = pmop->op_pmpermflags;
3116 if (av_len((AV*) PL_regex_pad[0]) > -1) {
3117 SV * const repointer = av_pop((AV*)PL_regex_pad[0]);
3118 pmop->op_pmoffset = SvIV(repointer);
3119 SvREPADTMP_off(repointer);
3120 sv_setiv(repointer,0);
3122 SV * const repointer = newSViv(0);
3123 av_push(PL_regex_padav, SvREFCNT_inc_simple_NN(repointer));
3124 pmop->op_pmoffset = av_len(PL_regex_padav);
3125 PL_regex_pad = AvARRAY(PL_regex_padav);
3129 /* link into pm list */
3130 if (type != OP_TRANS && PL_curstash) {
3131 MAGIC *mg = mg_find((SV*)PL_curstash, PERL_MAGIC_symtab);
3134 mg = sv_magicext((SV*)PL_curstash, 0, PERL_MAGIC_symtab, 0, 0, 0);
3136 pmop->op_pmnext = (PMOP*)mg->mg_obj;
3137 mg->mg_obj = (SV*)pmop;
3138 PmopSTASH_set(pmop,PL_curstash);
3141 return CHECKOP(type, pmop);
3144 /* Given some sort of match op o, and an expression expr containing a
3145 * pattern, either compile expr into a regex and attach it to o (if it's
3146 * constant), or convert expr into a runtime regcomp op sequence (if it's
3149 * isreg indicates that the pattern is part of a regex construct, eg
3150 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3151 * split "pattern", which aren't. In the former case, expr will be a list
3152 * if the pattern contains more than one term (eg /a$b/) or if it contains
3153 * a replacement, ie s/// or tr///.
3157 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
3162 I32 repl_has_vars = 0;
3166 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
3167 /* last element in list is the replacement; pop it */
3169 repl = cLISTOPx(expr)->op_last;
3170 kid = cLISTOPx(expr)->op_first;
3171 while (kid->op_sibling != repl)
3172 kid = kid->op_sibling;
3173 kid->op_sibling = NULL;
3174 cLISTOPx(expr)->op_last = kid;
3177 if (isreg && expr->op_type == OP_LIST &&
3178 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3180 /* convert single element list to element */
3181 OP* const oe = expr;
3182 expr = cLISTOPx(oe)->op_first->op_sibling;
3183 cLISTOPx(oe)->op_first->op_sibling = NULL;
3184 cLISTOPx(oe)->op_last = NULL;
3188 if (o->op_type == OP_TRANS) {
3189 return pmtrans(o, expr, repl);
3192 reglist = isreg && expr->op_type == OP_LIST;
3196 PL_hints |= HINT_BLOCK_SCOPE;
3199 if (expr->op_type == OP_CONST) {
3201 SV * const pat = ((SVOP*)expr)->op_sv;
3202 const char *p = SvPV_const(pat, plen);
3203 if ((o->op_flags & OPf_SPECIAL) && (*p == ' ' && p[1] == '\0')) {
3204 U32 was_readonly = SvREADONLY(pat);
3208 sv_force_normal_flags(pat, 0);
3209 assert(!SvREADONLY(pat));
3212 SvREADONLY_off(pat);
3216 sv_setpvn(pat, "\\s+", 3);
3218 SvFLAGS(pat) |= was_readonly;
3220 p = SvPV_const(pat, plen);
3221 pm->op_pmflags |= PMf_SKIPWHITE;
3224 pm->op_pmdynflags |= PMdf_UTF8;
3225 /* FIXME - can we make this function take const char * args? */
3226 PM_SETRE(pm, CALLREGCOMP(aTHX_ (char*)p, (char*)p + plen, pm));
3227 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
3228 pm->op_pmflags |= PMf_WHITE;
3230 op_getmad(expr,(OP*)pm,'e');
3236 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3237 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3239 : OP_REGCMAYBE),0,expr);
3241 NewOp(1101, rcop, 1, LOGOP);
3242 rcop->op_type = OP_REGCOMP;
3243 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3244 rcop->op_first = scalar(expr);
3245 rcop->op_flags |= OPf_KIDS
3246 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3247 | (reglist ? OPf_STACKED : 0);
3248 rcop->op_private = 1;
3251 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3253 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
3256 /* establish postfix order */
3257 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3259 rcop->op_next = expr;
3260 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3263 rcop->op_next = LINKLIST(expr);
3264 expr->op_next = (OP*)rcop;
3267 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3272 if (pm->op_pmflags & PMf_EVAL) {
3274 if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
3275 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
3277 else if (repl->op_type == OP_CONST)
3281 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3282 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3283 if (curop->op_type == OP_GV) {
3284 GV * const gv = cGVOPx_gv(curop);
3286 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3289 else if (curop->op_type == OP_RV2CV)
3291 else if (curop->op_type == OP_RV2SV ||
3292 curop->op_type == OP_RV2AV ||
3293 curop->op_type == OP_RV2HV ||
3294 curop->op_type == OP_RV2GV) {
3295 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3298 else if (curop->op_type == OP_PADSV ||
3299 curop->op_type == OP_PADAV ||
3300 curop->op_type == OP_PADHV ||
3301 curop->op_type == OP_PADANY) {
3304 else if (curop->op_type == OP_PUSHRE)
3305 NOOP; /* Okay here, dangerous in newASSIGNOP */
3315 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
3316 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3317 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
3318 prepend_elem(o->op_type, scalar(repl), o);
3321 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3322 pm->op_pmflags |= PMf_MAYBE_CONST;
3323 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3325 NewOp(1101, rcop, 1, LOGOP);
3326 rcop->op_type = OP_SUBSTCONT;
3327 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3328 rcop->op_first = scalar(repl);
3329 rcop->op_flags |= OPf_KIDS;
3330 rcop->op_private = 1;
3333 /* establish postfix order */
3334 rcop->op_next = LINKLIST(repl);
3335 repl->op_next = (OP*)rcop;
3337 pm->op_pmreplroot = scalar((OP*)rcop);
3338 pm->op_pmreplstart = LINKLIST(rcop);
3347 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3351 NewOp(1101, svop, 1, SVOP);
3352 svop->op_type = (OPCODE)type;
3353 svop->op_ppaddr = PL_ppaddr[type];
3355 svop->op_next = (OP*)svop;
3356 svop->op_flags = (U8)flags;
3357 if (PL_opargs[type] & OA_RETSCALAR)
3359 if (PL_opargs[type] & OA_TARGET)
3360 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3361 return CHECKOP(type, svop);
3365 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3369 NewOp(1101, padop, 1, PADOP);
3370 padop->op_type = (OPCODE)type;
3371 padop->op_ppaddr = PL_ppaddr[type];
3372 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3373 SvREFCNT_dec(PAD_SVl(padop->op_padix));
3374 PAD_SETSV(padop->op_padix, sv);
3377 padop->op_next = (OP*)padop;
3378 padop->op_flags = (U8)flags;
3379 if (PL_opargs[type] & OA_RETSCALAR)
3381 if (PL_opargs[type] & OA_TARGET)
3382 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3383 return CHECKOP(type, padop);
3387 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3393 return newPADOP(type, flags, SvREFCNT_inc_simple(gv));
3395 return newSVOP(type, flags, SvREFCNT_inc_simple(gv));
3400 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3404 NewOp(1101, pvop, 1, PVOP);
3405 pvop->op_type = (OPCODE)type;
3406 pvop->op_ppaddr = PL_ppaddr[type];
3408 pvop->op_next = (OP*)pvop;
3409 pvop->op_flags = (U8)flags;
3410 if (PL_opargs[type] & OA_RETSCALAR)
3412 if (PL_opargs[type] & OA_TARGET)
3413 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3414 return CHECKOP(type, pvop);
3422 Perl_package(pTHX_ OP *o)
3431 save_hptr(&PL_curstash);
3432 save_item(PL_curstname);
3434 name = SvPV_const(cSVOPo->op_sv, len);
3435 PL_curstash = gv_stashpvn(name, len, TRUE);
3436 sv_setpvn(PL_curstname, name, len);
3438 PL_hints |= HINT_BLOCK_SCOPE;
3439 PL_copline = NOLINE;
3445 if (!PL_madskills) {
3450 pegop = newOP(OP_NULL,0);
3451 op_getmad(o,pegop,'P');
3461 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3468 OP *pegop = newOP(OP_NULL,0);
3471 if (idop->op_type != OP_CONST)
3472 Perl_croak(aTHX_ "Module name must be constant");
3475 op_getmad(idop,pegop,'U');
3480 SV * const vesv = ((SVOP*)version)->op_sv;
3483 op_getmad(version,pegop,'V');
3484 if (!arg && !SvNIOKp(vesv)) {
3491 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3492 Perl_croak(aTHX_ "Version number must be constant number");
3494 /* Make copy of idop so we don't free it twice */
3495 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3497 /* Fake up a method call to VERSION */
3498 meth = newSVpvs_share("VERSION");
3499 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3500 append_elem(OP_LIST,
3501 prepend_elem(OP_LIST, pack, list(version)),
3502 newSVOP(OP_METHOD_NAMED, 0, meth)));
3506 /* Fake up an import/unimport */
3507 if (arg && arg->op_type == OP_STUB) {
3509 op_getmad(arg,pegop,'S');
3510 imop = arg; /* no import on explicit () */
3512 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3513 imop = NULL; /* use 5.0; */
3515 idop->op_private |= OPpCONST_NOVER;
3521 op_getmad(arg,pegop,'A');
3523 /* Make copy of idop so we don't free it twice */
3524 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3526 /* Fake up a method call to import/unimport */
3528 ? newSVpvs_share("import") : newSVpvs_share("unimport");
3529 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3530 append_elem(OP_LIST,
3531 prepend_elem(OP_LIST, pack, list(arg)),
3532 newSVOP(OP_METHOD_NAMED, 0, meth)));
3535 /* Fake up the BEGIN {}, which does its thing immediately. */
3537 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
3540 append_elem(OP_LINESEQ,
3541 append_elem(OP_LINESEQ,
3542 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
3543 newSTATEOP(0, NULL, veop)),
3544 newSTATEOP(0, NULL, imop) ));
3546 /* The "did you use incorrect case?" warning used to be here.
3547 * The problem is that on case-insensitive filesystems one
3548 * might get false positives for "use" (and "require"):
3549 * "use Strict" or "require CARP" will work. This causes
3550 * portability problems for the script: in case-strict
3551 * filesystems the script will stop working.
3553 * The "incorrect case" warning checked whether "use Foo"
3554 * imported "Foo" to your namespace, but that is wrong, too:
3555 * there is no requirement nor promise in the language that
3556 * a Foo.pm should or would contain anything in package "Foo".
3558 * There is very little Configure-wise that can be done, either:
3559 * the case-sensitivity of the build filesystem of Perl does not
3560 * help in guessing the case-sensitivity of the runtime environment.
3563 PL_hints |= HINT_BLOCK_SCOPE;
3564 PL_copline = NOLINE;
3566 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3569 if (!PL_madskills) {
3570 /* FIXME - don't allocate pegop if !PL_madskills */
3579 =head1 Embedding Functions
3581 =for apidoc load_module
3583 Loads the module whose name is pointed to by the string part of name.
3584 Note that the actual module name, not its filename, should be given.
3585 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3586 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3587 (or 0 for no flags). ver, if specified, provides version semantics
3588 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3589 arguments can be used to specify arguments to the module's import()
3590 method, similar to C<use Foo::Bar VERSION LIST>.
3595 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3598 va_start(args, ver);
3599 vload_module(flags, name, ver, &args);
3603 #ifdef PERL_IMPLICIT_CONTEXT
3605 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3609 va_start(args, ver);
3610 vload_module(flags, name, ver, &args);
3616 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3621 OP * const modname = newSVOP(OP_CONST, 0, name);
3622 modname->op_private |= OPpCONST_BARE;
3624 veop = newSVOP(OP_CONST, 0, ver);
3628 if (flags & PERL_LOADMOD_NOIMPORT) {
3629 imop = sawparens(newNULLLIST());
3631 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3632 imop = va_arg(*args, OP*);
3637 sv = va_arg(*args, SV*);
3639 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3640 sv = va_arg(*args, SV*);
3644 const line_t ocopline = PL_copline;
3645 COP * const ocurcop = PL_curcop;
3646 const int oexpect = PL_expect;
3648 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3649 veop, modname, imop);
3650 PL_expect = oexpect;
3651 PL_copline = ocopline;
3652 PL_curcop = ocurcop;
3657 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
3663 if (!force_builtin) {
3664 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
3665 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
3666 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
3667 gv = gvp ? *gvp : NULL;
3671 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3672 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3673 append_elem(OP_LIST, term,
3674 scalar(newUNOP(OP_RV2CV, 0,
3675 newGVOP(OP_GV, 0, gv))))));
3678 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3684 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3686 return newBINOP(OP_LSLICE, flags,
3687 list(force_list(subscript)),
3688 list(force_list(listval)) );
3692 S_is_list_assignment(pTHX_ register const OP *o)
3700 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
3701 o = cUNOPo->op_first;
3703 flags = o->op_flags;
3705 if (type == OP_COND_EXPR) {
3706 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
3707 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3712 yyerror("Assignment to both a list and a scalar");
3716 if (type == OP_LIST &&
3717 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
3718 o->op_private & OPpLVAL_INTRO)
3721 if (type == OP_LIST || flags & OPf_PARENS ||
3722 type == OP_RV2AV || type == OP_RV2HV ||
3723 type == OP_ASLICE || type == OP_HSLICE)
3726 if (type == OP_PADAV || type == OP_PADHV)
3729 if (type == OP_RV2SV)
3736 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3742 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3743 return newLOGOP(optype, 0,
3744 mod(scalar(left), optype),
3745 newUNOP(OP_SASSIGN, 0, scalar(right)));
3748 return newBINOP(optype, OPf_STACKED,
3749 mod(scalar(left), optype), scalar(right));
3753 if (is_list_assignment(left)) {
3757 /* Grandfathering $[ assignment here. Bletch.*/
3758 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
3759 PL_eval_start = (left->op_type == OP_CONST) ? right : 0;
3760 left = mod(left, OP_AASSIGN);
3763 else if (left->op_type == OP_CONST) {
3765 /* Result of assignment is always 1 (or we'd be dead already) */
3766 return newSVOP(OP_CONST, 0, newSViv(1));
3768 curop = list(force_list(left));
3769 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3770 o->op_private = (U8)(0 | (flags >> 8));
3772 /* PL_generation sorcery:
3773 * an assignment like ($a,$b) = ($c,$d) is easier than
3774 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3775 * To detect whether there are common vars, the global var
3776 * PL_generation is incremented for each assign op we compile.
3777 * Then, while compiling the assign op, we run through all the
3778 * variables on both sides of the assignment, setting a spare slot
3779 * in each of them to PL_generation. If any of them already have
3780 * that value, we know we've got commonality. We could use a
3781 * single bit marker, but then we'd have to make 2 passes, first
3782 * to clear the flag, then to test and set it. To find somewhere
3783 * to store these values, evil chicanery is done with SvCUR().
3789 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3790 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3791 if (curop->op_type == OP_GV) {
3792 GV *gv = cGVOPx_gv(curop);
3794 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
3796 GvASSIGN_GENERATION_set(gv, PL_generation);
3798 else if (curop->op_type == OP_PADSV ||
3799 curop->op_type == OP_PADAV ||
3800 curop->op_type == OP_PADHV ||
3801 curop->op_type == OP_PADANY)
3803 if ((left->op_private & OPpLVAL_INTRO) && (curop->op_private & OPpPAD_STATE)) {
3804 o->op_private |= OPpASSIGN_STATE;
3805 /* hijacking PADSTALE for uninitialized state variables */
3806 SvPADSTALE_on(PAD_SVl(curop->op_targ));
3808 if (PAD_COMPNAME_GEN(curop->op_targ)
3809 == (STRLEN)PL_generation)
3811 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
3814 else if (curop->op_type == OP_RV2CV)
3816 else if (curop->op_type == OP_RV2SV ||
3817 curop->op_type == OP_RV2AV ||
3818 curop->op_type == OP_RV2HV ||
3819 curop->op_type == OP_RV2GV) {
3820 if (lastop->op_type != OP_GV) /* funny deref? */
3823 else if (curop->op_type == OP_PUSHRE) {
3824 if (((PMOP*)curop)->op_pmreplroot) {
3826 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3827 ((PMOP*)curop)->op_pmreplroot));
3829 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3832 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
3834 GvASSIGN_GENERATION_set(gv, PL_generation);
3835 GvASSIGN_GENERATION_set(gv, PL_generation);
3844 o->op_private |= OPpASSIGN_COMMON;
3846 if (right && right->op_type == OP_SPLIT) {
3847 OP* tmpop = ((LISTOP*)right)->op_first;
3848 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
3849 PMOP * const pm = (PMOP*)tmpop;
3850 if (left->op_type == OP_RV2AV &&
3851 !(left->op_private & OPpLVAL_INTRO) &&
3852 !(o->op_private & OPpASSIGN_COMMON) )
3854 tmpop = ((UNOP*)left)->op_first;
3855 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3857 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3858 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3860 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3861 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
3863 pm->op_pmflags |= PMf_ONCE;
3864 tmpop = cUNOPo->op_first; /* to list (nulled) */
3865 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3866 tmpop->op_sibling = NULL; /* don't free split */
3867 right->op_next = tmpop->op_next; /* fix starting loc */
3869 op_getmad(o,right,'R'); /* blow off assign */
3871 op_free(o); /* blow off assign */
3873 right->op_flags &= ~OPf_WANT;
3874 /* "I don't know and I don't care." */
3879 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3880 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3882 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3884 sv_setiv(sv, PL_modcount+1);
3892 right = newOP(OP_UNDEF, 0);
3893 if (right->op_type == OP_READLINE) {
3894 right->op_flags |= OPf_STACKED;
3895 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3898 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3899 o = newBINOP(OP_SASSIGN, flags,
3900 scalar(right), mod(scalar(left), OP_SASSIGN) );
3906 o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
3907 o->op_private |= OPpCONST_ARYBASE;
3914 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3917 const U32 seq = intro_my();
3920 NewOp(1101, cop, 1, COP);
3921 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3922 cop->op_type = OP_DBSTATE;
3923 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3926 cop->op_type = OP_NEXTSTATE;
3927 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3929 cop->op_flags = (U8)flags;
3930 CopHINTS_set(cop, PL_hints);
3932 cop->op_private |= NATIVE_HINTS;
3934 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
3935 cop->op_next = (OP*)cop;
3938 cop->cop_label = label;
3939 PL_hints |= HINT_BLOCK_SCOPE;
3942 /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
3943 CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
3945 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
3946 cop->cop_hints_hash = PL_curcop->cop_hints_hash;
3947 if (cop->cop_hints_hash) {
3949 cop->cop_hints_hash->refcounted_he_refcnt++;
3950 HINTS_REFCNT_UNLOCK;
3953 if (PL_copline == NOLINE)
3954 CopLINE_set(cop, CopLINE(PL_curcop));
3956 CopLINE_set(cop, PL_copline);
3957 PL_copline = NOLINE;
3960 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3962 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3964 CopSTASH_set(cop, PL_curstash);
3966 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3967 SV * const * const svp = av_fetch(CopFILEAVx(PL_curcop), (I32)CopLINE(cop), FALSE);
3968 if (svp && *svp != &PL_sv_undef ) {
3969 (void)SvIOK_on(*svp);
3970 SvIV_set(*svp, PTR2IV(cop));
3974 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3979 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3982 return new_logop(type, flags, &first, &other);
3986 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3991 OP *first = *firstp;
3992 OP * const other = *otherp;
3994 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
3995 return newBINOP(type, flags, scalar(first), scalar(other));
3997 scalarboolean(first);
3998 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3999 if (first->op_type == OP_NOT
4000 && (first->op_flags & OPf_SPECIAL)
4001 && (first->op_flags & OPf_KIDS)) {
4002 if (type == OP_AND || type == OP_OR) {
4008 first = *firstp = cUNOPo->op_first;
4010 first->op_next = o->op_next;
4011 cUNOPo->op_first = NULL;
4013 op_getmad(o,first,'O');
4019 if (first->op_type == OP_CONST) {
4020 if (first->op_private & OPpCONST_STRICT)
4021 no_bareword_allowed(first);
4022 else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
4023 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
4024 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
4025 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
4026 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
4028 if (other->op_type == OP_CONST)
4029 other->op_private |= OPpCONST_SHORTCIRCUIT;
4031 OP *newop = newUNOP(OP_NULL, 0, other);
4032 op_getmad(first, newop, '1');
4033 newop->op_targ = type; /* set "was" field */
4040 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
4041 const OP *o2 = other;
4042 if ( ! (o2->op_type == OP_LIST
4043 && (( o2 = cUNOPx(o2)->op_first))
4044 && o2->op_type == OP_PUSHMARK
4045 && (( o2 = o2->op_sibling)) )
4048 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
4049 || o2->op_type == OP_PADHV)
4050 && o2->op_private & OPpLVAL_INTRO
4051 && ckWARN(WARN_DEPRECATED))
4053 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4054 "Deprecated use of my() in false conditional");
4058 if (first->op_type == OP_CONST)
4059 first->op_private |= OPpCONST_SHORTCIRCUIT;
4061 first = newUNOP(OP_NULL, 0, first);
4062 op_getmad(other, first, '2');
4063 first->op_targ = type; /* set "was" field */
4070 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
4071 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
4073 const OP * const k1 = ((UNOP*)first)->op_first;
4074 const OP * const k2 = k1->op_sibling;
4076 switch (first->op_type)
4079 if (k2 && k2->op_type == OP_READLINE
4080 && (k2->op_flags & OPf_STACKED)
4081 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4083 warnop = k2->op_type;
4088 if (k1->op_type == OP_READDIR
4089 || k1->op_type == OP_GLOB
4090 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4091 || k1->op_type == OP_EACH)
4093 warnop = ((k1->op_type == OP_NULL)
4094 ? (OPCODE)k1->op_targ : k1->op_type);
4099 const line_t oldline = CopLINE(PL_curcop);
4100 CopLINE_set(PL_curcop, PL_copline);
4101 Perl_warner(aTHX_ packWARN(WARN_MISC),
4102 "Value of %s%s can be \"0\"; test with defined()",
4104 ((warnop == OP_READLINE || warnop == OP_GLOB)
4105 ? " construct" : "() operator"));
4106 CopLINE_set(PL_curcop, oldline);
4113 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
4114 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
4116 NewOp(1101, logop, 1, LOGOP);
4118 logop->op_type = (OPCODE)type;
4119 logop->op_ppaddr = PL_ppaddr[type];
4120 logop->op_first = first;
4121 logop->op_flags = (U8)(flags | OPf_KIDS);
4122 logop->op_other = LINKLIST(other);
4123 logop->op_private = (U8)(1 | (flags >> 8));
4125 /* establish postfix order */
4126 logop->op_next = LINKLIST(first);
4127 first->op_next = (OP*)logop;
4128 first->op_sibling = other;
4130 CHECKOP(type,logop);
4132 o = newUNOP(OP_NULL, 0, (OP*)logop);
4139 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
4147 return newLOGOP(OP_AND, 0, first, trueop);
4149 return newLOGOP(OP_OR, 0, first, falseop);
4151 scalarboolean(first);
4152 if (first->op_type == OP_CONST) {
4153 if (first->op_private & OPpCONST_BARE &&
4154 first->op_private & OPpCONST_STRICT) {
4155 no_bareword_allowed(first);
4157 if (SvTRUE(((SVOP*)first)->op_sv)) {
4160 trueop = newUNOP(OP_NULL, 0, trueop);
4161 op_getmad(first,trueop,'C');
4162 op_getmad(falseop,trueop,'e');
4164 /* FIXME for MAD - should there be an ELSE here? */
4174 falseop = newUNOP(OP_NULL, 0, falseop);
4175 op_getmad(first,falseop,'C');
4176 op_getmad(trueop,falseop,'t');
4178 /* FIXME for MAD - should there be an ELSE here? */
4186 NewOp(1101, logop, 1, LOGOP);
4187 logop->op_type = OP_COND_EXPR;
4188 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4189 logop->op_first = first;
4190 logop->op_flags = (U8)(flags | OPf_KIDS);
4191 logop->op_private = (U8)(1 | (flags >> 8));
4192 logop->op_other = LINKLIST(trueop);
4193 logop->op_next = LINKLIST(falseop);
4195 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
4198 /* establish postfix order */
4199 start = LINKLIST(first);
4200 first->op_next = (OP*)logop;
4202 first->op_sibling = trueop;
4203 trueop->op_sibling = falseop;
4204 o = newUNOP(OP_NULL, 0, (OP*)logop);
4206 trueop->op_next = falseop->op_next = o;
4213 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4222 NewOp(1101, range, 1, LOGOP);
4224 range->op_type = OP_RANGE;
4225 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4226 range->op_first = left;
4227 range->op_flags = OPf_KIDS;
4228 leftstart = LINKLIST(left);
4229 range->op_other = LINKLIST(right);
4230 range->op_private = (U8)(1 | (flags >> 8));
4232 left->op_sibling = right;
4234 range->op_next = (OP*)range;
4235 flip = newUNOP(OP_FLIP, flags, (OP*)range);
4236 flop = newUNOP(OP_FLOP, 0, flip);
4237 o = newUNOP(OP_NULL, 0, flop);
4239 range->op_next = leftstart;
4241 left->op_next = flip;
4242 right->op_next = flop;
4244 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4245 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4246 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4247 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4249 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4250 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4253 if (!flip->op_private || !flop->op_private)
4254 linklist(o); /* blow off optimizer unless constant */
4260 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4265 const bool once = block && block->op_flags & OPf_SPECIAL &&
4266 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4268 PERL_UNUSED_ARG(debuggable);
4271 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4272 return block; /* do {} while 0 does once */
4273 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4274 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4275 expr = newUNOP(OP_DEFINED, 0,
4276 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4277 } else if (expr->op_flags & OPf_KIDS) {
4278 const OP * const k1 = ((UNOP*)expr)->op_first;
4279 const OP * const k2 = k1 ? k1->op_sibling : NULL;
4280 switch (expr->op_type) {
4282 if (k2 && k2->op_type == OP_READLINE
4283 && (k2->op_flags & OPf_STACKED)
4284 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4285 expr = newUNOP(OP_DEFINED, 0, expr);
4289 if (k1 && (k1->op_type == OP_READDIR
4290 || k1->op_type == OP_GLOB
4291 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4292 || k1->op_type == OP_EACH))
4293 expr = newUNOP(OP_DEFINED, 0, expr);
4299 /* if block is null, the next append_elem() would put UNSTACK, a scalar
4300 * op, in listop. This is wrong. [perl #27024] */
4302 block = newOP(OP_NULL, 0);
4303 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4304 o = new_logop(OP_AND, 0, &expr, &listop);
4307 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4309 if (once && o != listop)
4310 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4313 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
4315 o->op_flags |= flags;
4317 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4322 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
4323 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
4332 PERL_UNUSED_ARG(debuggable);
4335 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4336 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4337 expr = newUNOP(OP_DEFINED, 0,
4338 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4339 } else if (expr->op_flags & OPf_KIDS) {
4340 const OP * const k1 = ((UNOP*)expr)->op_first;
4341 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
4342 switch (expr->op_type) {
4344 if (k2 && k2->op_type == OP_READLINE
4345 && (k2->op_flags & OPf_STACKED)
4346 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4347 expr = newUNOP(OP_DEFINED, 0, expr);
4351 if (k1 && (k1->op_type == OP_READDIR
4352 || k1->op_type == OP_GLOB
4353 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4354 || k1->op_type == OP_EACH))
4355 expr = newUNOP(OP_DEFINED, 0, expr);
4362 block = newOP(OP_NULL, 0);
4363 else if (cont || has_my) {
4364 block = scope(block);
4368 next = LINKLIST(cont);
4371 OP * const unstack = newOP(OP_UNSTACK, 0);
4374 cont = append_elem(OP_LINESEQ, cont, unstack);
4378 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4380 redo = LINKLIST(listop);
4383 PL_copline = (line_t)whileline;
4385 o = new_logop(OP_AND, 0, &expr, &listop);
4386 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4387 op_free(expr); /* oops, it's a while (0) */
4389 return NULL; /* listop already freed by new_logop */
4392 ((LISTOP*)listop)->op_last->op_next =
4393 (o == listop ? redo : LINKLIST(o));
4399 NewOp(1101,loop,1,LOOP);
4400 loop->op_type = OP_ENTERLOOP;
4401 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4402 loop->op_private = 0;
4403 loop->op_next = (OP*)loop;
4406 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4408 loop->op_redoop = redo;
4409 loop->op_lastop = o;
4410 o->op_private |= loopflags;
4413 loop->op_nextop = next;
4415 loop->op_nextop = o;
4417 o->op_flags |= flags;
4418 o->op_private |= (flags >> 8);
4423 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
4428 PADOFFSET padoff = 0;
4434 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4435 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
4436 sv->op_type = OP_RV2GV;
4437 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4438 if (cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
4439 iterpflags |= OPpITER_DEF;
4441 else if (sv->op_type == OP_PADSV) { /* private variable */
4442 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
4443 padoff = sv->op_targ;
4452 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4453 padoff = sv->op_targ;
4458 iterflags |= OPf_SPECIAL;
4464 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4465 if (padoff && strEQ(PAD_COMPNAME_PV(padoff), "$_"))
4466 iterpflags |= OPpITER_DEF;
4469 const PADOFFSET offset = pad_findmy("$_");
4470 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
4471 sv = newGVOP(OP_GV, 0, PL_defgv);
4476 iterpflags |= OPpITER_DEF;
4478 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4479 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4480 iterflags |= OPf_STACKED;
4482 else if (expr->op_type == OP_NULL &&
4483 (expr->op_flags & OPf_KIDS) &&
4484 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4486 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4487 * set the STACKED flag to indicate that these values are to be
4488 * treated as min/max values by 'pp_iterinit'.
4490 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4491 LOGOP* const range = (LOGOP*) flip->op_first;
4492 OP* const left = range->op_first;
4493 OP* const right = left->op_sibling;
4496 range->op_flags &= ~OPf_KIDS;
4497 range->op_first = NULL;
4499 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4500 listop->op_first->op_next = range->op_next;
4501 left->op_next = range->op_other;
4502 right->op_next = (OP*)listop;
4503 listop->op_next = listop->op_first;
4506 op_getmad(expr,(OP*)listop,'O');
4510 expr = (OP*)(listop);
4512 iterflags |= OPf_STACKED;
4515 expr = mod(force_list(expr), OP_GREPSTART);
4518 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4519 append_elem(OP_LIST, expr, scalar(sv))));
4520 assert(!loop->op_next);
4521 /* for my $x () sets OPpLVAL_INTRO;
4522 * for our $x () sets OPpOUR_INTRO */
4523 loop->op_private = (U8)iterpflags;
4524 #ifdef PL_OP_SLAB_ALLOC
4527 NewOp(1234,tmp,1,LOOP);
4528 Copy(loop,tmp,1,LISTOP);
4533 loop = PerlMemShared_realloc(loop, sizeof(LOOP));
4535 loop->op_targ = padoff;
4536 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
4538 op_getmad(madsv, (OP*)loop, 'v');
4539 PL_copline = forline;
4540 return newSTATEOP(0, label, wop);
4544 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4549 if (type != OP_GOTO || label->op_type == OP_CONST) {
4550 /* "last()" means "last" */
4551 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4552 o = newOP(type, OPf_SPECIAL);
4554 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4555 ? SvPVx_nolen_const(((SVOP*)label)->op_sv)
4559 op_getmad(label,o,'L');
4565 /* Check whether it's going to be a goto &function */
4566 if (label->op_type == OP_ENTERSUB
4567 && !(label->op_flags & OPf_STACKED))
4568 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4569 o = newUNOP(type, OPf_STACKED, label);
4571 PL_hints |= HINT_BLOCK_SCOPE;
4575 /* if the condition is a literal array or hash
4576 (or @{ ... } etc), make a reference to it.
4579 S_ref_array_or_hash(pTHX_ OP *cond)
4582 && (cond->op_type == OP_RV2AV
4583 || cond->op_type == OP_PADAV
4584 || cond->op_type == OP_RV2HV
4585 || cond->op_type == OP_PADHV))
4587 return newUNOP(OP_REFGEN,
4588 0, mod(cond, OP_REFGEN));
4594 /* These construct the optree fragments representing given()
4597 entergiven and enterwhen are LOGOPs; the op_other pointer
4598 points up to the associated leave op. We need this so we
4599 can put it in the context and make break/continue work.
4600 (Also, of course, pp_enterwhen will jump straight to
4601 op_other if the match fails.)
4606 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
4607 I32 enter_opcode, I32 leave_opcode,
4608 PADOFFSET entertarg)
4614 NewOp(1101, enterop, 1, LOGOP);
4615 enterop->op_type = enter_opcode;
4616 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
4617 enterop->op_flags = (U8) OPf_KIDS;
4618 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
4619 enterop->op_private = 0;
4621 o = newUNOP(leave_opcode, 0, (OP *) enterop);
4624 enterop->op_first = scalar(cond);
4625 cond->op_sibling = block;
4627 o->op_next = LINKLIST(cond);
4628 cond->op_next = (OP *) enterop;
4631 /* This is a default {} block */
4632 enterop->op_first = block;
4633 enterop->op_flags |= OPf_SPECIAL;
4635 o->op_next = (OP *) enterop;
4638 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
4639 entergiven and enterwhen both
4642 enterop->op_next = LINKLIST(block);
4643 block->op_next = enterop->op_other = o;
4648 /* Does this look like a boolean operation? For these purposes
4649 a boolean operation is:
4650 - a subroutine call [*]
4651 - a logical connective
4652 - a comparison operator
4653 - a filetest operator, with the exception of -s -M -A -C
4654 - defined(), exists() or eof()
4655 - /$re/ or $foo =~ /$re/
4657 [*] possibly surprising
4661 S_looks_like_bool(pTHX_ const OP *o)
4664 switch(o->op_type) {
4666 return looks_like_bool(cLOGOPo->op_first);
4670 looks_like_bool(cLOGOPo->op_first)
4671 && looks_like_bool(cLOGOPo->op_first->op_sibling));
4675 case OP_NOT: case OP_XOR:
4676 /* Note that OP_DOR is not here */
4678 case OP_EQ: case OP_NE: case OP_LT:
4679 case OP_GT: case OP_LE: case OP_GE:
4681 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
4682 case OP_I_GT: case OP_I_LE: case OP_I_GE:
4684 case OP_SEQ: case OP_SNE: case OP_SLT:
4685 case OP_SGT: case OP_SLE: case OP_SGE:
4689 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
4690 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
4691 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
4692 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
4693 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
4694 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
4695 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
4696 case OP_FTTEXT: case OP_FTBINARY:
4698 case OP_DEFINED: case OP_EXISTS:
4699 case OP_MATCH: case OP_EOF:
4704 /* Detect comparisons that have been optimized away */
4705 if (cSVOPo->op_sv == &PL_sv_yes
4706 || cSVOPo->op_sv == &PL_sv_no)
4717 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
4721 return newGIVWHENOP(
4722 ref_array_or_hash(cond),
4724 OP_ENTERGIVEN, OP_LEAVEGIVEN,
4728 /* If cond is null, this is a default {} block */
4730 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
4732 const bool cond_llb = (!cond || looks_like_bool(cond));
4738 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
4740 scalar(ref_array_or_hash(cond)));
4743 return newGIVWHENOP(
4745 append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
4746 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
4750 =for apidoc cv_undef
4752 Clear out all the active components of a CV. This can happen either
4753 by an explicit C<undef &foo>, or by the reference count going to zero.
4754 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
4755 children can still follow the full lexical scope chain.
4761 Perl_cv_undef(pTHX_ CV *cv)
4765 if (CvFILE(cv) && !CvISXSUB(cv)) {
4766 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4767 Safefree(CvFILE(cv));
4772 if (!CvISXSUB(cv) && CvROOT(cv)) {
4773 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
4774 Perl_croak(aTHX_ "Can't undef active subroutine");
4777 PAD_SAVE_SETNULLPAD();
4779 op_free(CvROOT(cv));
4784 SvPOK_off((SV*)cv); /* forget prototype */
4789 /* remove CvOUTSIDE unless this is an undef rather than a free */
4790 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
4791 if (!CvWEAKOUTSIDE(cv))
4792 SvREFCNT_dec(CvOUTSIDE(cv));
4793 CvOUTSIDE(cv) = NULL;
4796 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4799 if (CvISXSUB(cv) && CvXSUB(cv)) {
4802 /* delete all flags except WEAKOUTSIDE */
4803 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
4807 Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
4810 /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
4811 relying on SvCUR, and doubling up the buffer to hold CvFILE(). */
4812 if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
4813 || (p && (len != SvCUR(cv) /* Not the same length. */
4814 || memNE(p, SvPVX_const(cv), len))))
4815 && ckWARN_d(WARN_PROTOTYPE)) {
4816 SV* const msg = sv_newmortal();
4820 gv_efullname3(name = sv_newmortal(), gv, NULL);
4821 sv_setpv(msg, "Prototype mismatch:");
4823 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, (void*)name);
4825 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (void*)cv);
4827 sv_catpvs(msg, ": none");
4828 sv_catpvs(msg, " vs ");
4830 Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
4832 sv_catpvs(msg, "none");
4833 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, (void*)msg);
4837 static void const_sv_xsub(pTHX_ CV* cv);
4841 =head1 Optree Manipulation Functions
4843 =for apidoc cv_const_sv
4845 If C<cv> is a constant sub eligible for inlining. returns the constant
4846 value returned by the sub. Otherwise, returns NULL.
4848 Constant subs can be created with C<newCONSTSUB> or as described in
4849 L<perlsub/"Constant Functions">.
4854 Perl_cv_const_sv(pTHX_ CV *cv)
4856 PERL_UNUSED_CONTEXT;
4859 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
4861 return CvCONST(cv) ? (SV*)CvXSUBANY(cv).any_ptr : NULL;
4864 /* op_const_sv: examine an optree to determine whether it's in-lineable.
4865 * Can be called in 3 ways:
4868 * look for a single OP_CONST with attached value: return the value
4870 * cv && CvCLONE(cv) && !CvCONST(cv)
4872 * examine the clone prototype, and if contains only a single
4873 * OP_CONST referencing a pad const, or a single PADSV referencing
4874 * an outer lexical, return a non-zero value to indicate the CV is
4875 * a candidate for "constizing" at clone time
4879 * We have just cloned an anon prototype that was marked as a const
4880 * candidiate. Try to grab the current value, and in the case of
4881 * PADSV, ignore it if it has multiple references. Return the value.
4885 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
4893 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4894 o = cLISTOPo->op_first->op_sibling;
4896 for (; o; o = o->op_next) {
4897 const OPCODE type = o->op_type;
4899 if (sv && o->op_next == o)
4901 if (o->op_next != o) {
4902 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4904 if (type == OP_DBSTATE)
4907 if (type == OP_LEAVESUB || type == OP_RETURN)
4911 if (type == OP_CONST && cSVOPo->op_sv)
4913 else if (cv && type == OP_CONST) {
4914 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4918 else if (cv && type == OP_PADSV) {
4919 if (CvCONST(cv)) { /* newly cloned anon */
4920 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4921 /* the candidate should have 1 ref from this pad and 1 ref
4922 * from the parent */
4923 if (!sv || SvREFCNT(sv) != 2)
4930 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
4931 sv = &PL_sv_undef; /* an arbitrary non-null value */
4946 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4949 /* This would be the return value, but the return cannot be reached. */
4950 OP* pegop = newOP(OP_NULL, 0);
4953 PERL_UNUSED_ARG(floor);
4963 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4965 NORETURN_FUNCTION_END;
4970 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4972 return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
4976 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4983 register CV *cv = NULL;
4985 /* If the subroutine has no body, no attributes, and no builtin attributes
4986 then it's just a sub declaration, and we may be able to get away with
4987 storing with a placeholder scalar in the symbol table, rather than a
4988 full GV and CV. If anything is present then it will take a full CV to
4990 const I32 gv_fetch_flags
4991 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
4993 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
4994 const char * const name = o ? SvPVx_nolen_const(cSVOPo->op_sv) : NULL;
4997 assert(proto->op_type == OP_CONST);
4998 ps = SvPVx_const(((SVOP*)proto)->op_sv, ps_len);
5003 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
5004 SV * const sv = sv_newmortal();
5005 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
5006 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
5007 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
5008 aname = SvPVX_const(sv);
5013 gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
5014 : gv_fetchpv(aname ? aname
5015 : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5016 gv_fetch_flags, SVt_PVCV);
5018 if (!PL_madskills) {
5027 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
5028 maximum a prototype before. */
5029 if (SvTYPE(gv) > SVt_NULL) {
5030 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
5031 && ckWARN_d(WARN_PROTOTYPE))
5033 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
5035 cv_ckproto_len((CV*)gv, NULL, ps, ps_len);
5038 sv_setpvn((SV*)gv, ps, ps_len);
5040 sv_setiv((SV*)gv, -1);
5041 SvREFCNT_dec(PL_compcv);
5042 cv = PL_compcv = NULL;
5043 PL_sub_generation++;
5047 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
5049 #ifdef GV_UNIQUE_CHECK
5050 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
5051 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
5055 if (!block || !ps || *ps || attrs
5056 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5058 || block->op_type == OP_NULL
5063 const_sv = op_const_sv(block, NULL);
5066 const bool exists = CvROOT(cv) || CvXSUB(cv);
5068 #ifdef GV_UNIQUE_CHECK
5069 if (exists && GvUNIQUE(gv)) {
5070 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
5074 /* if the subroutine doesn't exist and wasn't pre-declared
5075 * with a prototype, assume it will be AUTOLOADed,
5076 * skipping the prototype check
5078 if (exists || SvPOK(cv))
5079 cv_ckproto_len(cv, gv, ps, ps_len);
5080 /* already defined (or promised)? */
5081 if (exists || GvASSUMECV(gv)) {
5084 || block->op_type == OP_NULL
5087 if (CvFLAGS(PL_compcv)) {
5088 /* might have had built-in attrs applied */
5089 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5091 /* just a "sub foo;" when &foo is already defined */
5092 SAVEFREESV(PL_compcv);
5097 && block->op_type != OP_NULL
5100 if (ckWARN(WARN_REDEFINE)
5102 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
5104 const line_t oldline = CopLINE(PL_curcop);
5105 if (PL_copline != NOLINE)
5106 CopLINE_set(PL_curcop, PL_copline);
5107 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5108 CvCONST(cv) ? "Constant subroutine %s redefined"
5109 : "Subroutine %s redefined", name);
5110 CopLINE_set(PL_curcop, oldline);
5113 if (!PL_minus_c) /* keep old one around for madskills */
5116 /* (PL_madskills unset in used file.) */
5124 SvREFCNT_inc_simple_void_NN(const_sv);
5126 assert(!CvROOT(cv) && !CvCONST(cv));
5127 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
5128 CvXSUBANY(cv).any_ptr = const_sv;
5129 CvXSUB(cv) = const_sv_xsub;
5135 cv = newCONSTSUB(NULL, name, const_sv);
5137 PL_sub_generation++;
5141 SvREFCNT_dec(PL_compcv);
5149 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
5150 * before we clobber PL_compcv.
5154 || block->op_type == OP_NULL
5158 /* Might have had built-in attributes applied -- propagate them. */
5159 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5160 if (CvGV(cv) && GvSTASH(CvGV(cv)))
5161 stash = GvSTASH(CvGV(cv));
5162 else if (CvSTASH(cv))
5163 stash = CvSTASH(cv);
5165 stash = PL_curstash;
5168 /* possibly about to re-define existing subr -- ignore old cv */
5169 rcv = (SV*)PL_compcv;
5170 if (name && GvSTASH(gv))
5171 stash = GvSTASH(gv);
5173 stash = PL_curstash;
5175 apply_attrs(stash, rcv, attrs, FALSE);
5177 if (cv) { /* must reuse cv if autoloaded */
5184 || block->op_type == OP_NULL) && !PL_madskills
5187 /* got here with just attrs -- work done, so bug out */
5188 SAVEFREESV(PL_compcv);
5191 /* transfer PL_compcv to cv */
5193 CvFLAGS(cv) = CvFLAGS(PL_compcv);
5194 if (!CvWEAKOUTSIDE(cv))
5195 SvREFCNT_dec(CvOUTSIDE(cv));
5196 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
5197 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
5198 CvOUTSIDE(PL_compcv) = 0;
5199 CvPADLIST(cv) = CvPADLIST(PL_compcv);
5200 CvPADLIST(PL_compcv) = 0;
5201 /* inner references to PL_compcv must be fixed up ... */
5202 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
5203 /* ... before we throw it away */
5204 SvREFCNT_dec(PL_compcv);
5206 if (PERLDB_INTER)/* Advice debugger on the new sub. */
5207 ++PL_sub_generation;
5214 if (strEQ(name, "import")) {
5215 PL_formfeed = (SV*)cv;
5216 Perl_warner(aTHX_ packWARN(WARN_VOID), "%lx\n", (long)cv);
5220 PL_sub_generation++;
5224 CvFILE_set_from_cop(cv, PL_curcop);
5225 CvSTASH(cv) = PL_curstash;
5228 sv_setpvn((SV*)cv, ps, ps_len);
5230 if (PL_error_count) {
5234 const char *s = strrchr(name, ':');
5236 if (strEQ(s, "BEGIN")) {
5237 const char not_safe[] =
5238 "BEGIN not safe after errors--compilation aborted";
5239 if (PL_in_eval & EVAL_KEEPERR)
5240 Perl_croak(aTHX_ not_safe);
5242 /* force display of errors found but not reported */
5243 sv_catpv(ERRSV, not_safe);
5244 Perl_croak(aTHX_ "%"SVf, (void*)ERRSV);
5254 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5255 mod(scalarseq(block), OP_LEAVESUBLV));
5258 /* This makes sub {}; work as expected. */
5259 if (block->op_type == OP_STUB) {
5260 OP* const newblock = newSTATEOP(0, NULL, 0);
5262 op_getmad(block,newblock,'B');
5268 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5270 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5271 OpREFCNT_set(CvROOT(cv), 1);
5272 CvSTART(cv) = LINKLIST(CvROOT(cv));
5273 CvROOT(cv)->op_next = 0;
5274 CALL_PEEP(CvSTART(cv));
5276 /* now that optimizer has done its work, adjust pad values */
5278 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
5281 assert(!CvCONST(cv));
5282 if (ps && !*ps && op_const_sv(block, cv))
5286 if (name || aname) {
5288 const char * const tname = (name ? name : aname);
5290 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5291 SV * const sv = newSV(0);
5292 SV * const tmpstr = sv_newmortal();
5293 GV * const db_postponed = gv_fetchpvs("DB::postponed",
5294 GV_ADDMULTI, SVt_PVHV);
5297 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5299 (long)PL_subline, (long)CopLINE(PL_curcop));
5300 gv_efullname3(tmpstr, gv, NULL);
5301 hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0);
5302 hv = GvHVn(db_postponed);
5303 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
5304 CV * const pcv = GvCV(db_postponed);
5310 call_sv((SV*)pcv, G_DISCARD);
5315 if ((s = strrchr(tname,':')))
5320 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5323 if (strEQ(s, "BEGIN") && !PL_error_count) {
5324 const I32 oldscope = PL_scopestack_ix;
5326 SAVECOPFILE(&PL_compiling);
5327 SAVECOPLINE(&PL_compiling);
5330 PL_beginav = newAV();
5331 DEBUG_x( dump_sub(gv) );
5332 av_push(PL_beginav, (SV*)cv);
5333 GvCV(gv) = 0; /* cv has been hijacked */
5334 call_list(oldscope, PL_beginav);
5336 PL_curcop = &PL_compiling;
5337 CopHINTS_set(&PL_compiling, PL_hints);
5340 else if (strEQ(s, "END") && !PL_error_count) {
5343 DEBUG_x( dump_sub(gv) );
5344 av_unshift(PL_endav, 1);
5345 av_store(PL_endav, 0, (SV*)cv);
5346 GvCV(gv) = 0; /* cv has been hijacked */
5348 else if (strEQ(s, "CHECK") && !PL_error_count) {
5350 PL_checkav = newAV();
5351 DEBUG_x( dump_sub(gv) );
5352 if (PL_main_start && ckWARN(WARN_VOID))
5353 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
5354 av_unshift(PL_checkav, 1);
5355 av_store(PL_checkav, 0, (SV*)cv);
5356 GvCV(gv) = 0; /* cv has been hijacked */
5358 else if (strEQ(s, "INIT") && !PL_error_count) {
5360 PL_initav = newAV();
5361 DEBUG_x( dump_sub(gv) );
5362 if (PL_main_start && ckWARN(WARN_VOID))
5363 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
5364 av_push(PL_initav, (SV*)cv);
5365 GvCV(gv) = 0; /* cv has been hijacked */
5370 PL_copline = NOLINE;
5375 /* XXX unsafe for threads if eval_owner isn't held */
5377 =for apidoc newCONSTSUB
5379 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5380 eligible for inlining at compile-time.
5386 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
5391 const char *const temp_p = CopFILE(PL_curcop);
5392 const STRLEN len = temp_p ? strlen(temp_p) : 0;
5394 SV *const temp_sv = CopFILESV(PL_curcop);
5396 const char *const temp_p = temp_sv ? SvPV_const(temp_sv, len) : NULL;
5398 char *const file = savepvn(temp_p, temp_p ? len : 0);
5402 SAVECOPLINE(PL_curcop);
5403 CopLINE_set(PL_curcop, PL_copline);
5406 PL_hints &= ~HINT_BLOCK_SCOPE;
5409 SAVESPTR(PL_curstash);
5410 SAVECOPSTASH(PL_curcop);
5411 PL_curstash = stash;
5412 CopSTASH_set(PL_curcop,stash);
5415 /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
5416 and so doesn't get free()d. (It's expected to be from the C pre-
5417 processor __FILE__ directive). But we need a dynamically allocated one,
5418 and we need it to get freed. */
5419 cv = newXS_flags(name, const_sv_xsub, file, "", XS_DYNAMIC_FILENAME);
5420 CvXSUBANY(cv).any_ptr = sv;
5425 CopSTASH_free(PL_curcop);
5433 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
5434 const char *const filename, const char *const proto,
5437 CV *cv = newXS(name, subaddr, filename);
5439 if (flags & XS_DYNAMIC_FILENAME) {
5440 /* We need to "make arrangements" (ie cheat) to ensure that the
5441 filename lasts as long as the PVCV we just created, but also doesn't
5443 STRLEN filename_len = strlen(filename);
5444 STRLEN proto_and_file_len = filename_len;
5445 char *proto_and_file;
5449 proto_len = strlen(proto);
5450 proto_and_file_len += proto_len;
5452 Newx(proto_and_file, proto_and_file_len + 1, char);
5453 Copy(proto, proto_and_file, proto_len, char);
5454 Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
5457 proto_and_file = savepvn(filename, filename_len);
5460 /* This gets free()d. :-) */
5461 sv_usepvn_flags((SV*)cv, proto_and_file, proto_and_file_len,
5462 SV_HAS_TRAILING_NUL);
5464 /* This gives us the correct prototype, rather than one with the
5465 file name appended. */
5466 SvCUR_set(cv, proto_len);
5470 CvFILE(cv) = proto_and_file + proto_len;
5472 sv_setpv((SV *)cv, proto);
5478 =for apidoc U||newXS
5480 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
5481 static storage, as it is used directly as CvFILE(), without a copy being made.
5487 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
5490 GV * const gv = gv_fetchpv(name ? name :
5491 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5492 GV_ADDMULTI, SVt_PVCV);
5496 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
5498 if ((cv = (name ? GvCV(gv) : NULL))) {
5500 /* just a cached method */
5504 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5505 /* already defined (or promised) */
5506 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
5507 if (ckWARN(WARN_REDEFINE)) {
5508 GV * const gvcv = CvGV(cv);
5510 HV * const stash = GvSTASH(gvcv);
5512 const char *redefined_name = HvNAME_get(stash);
5513 if ( strEQ(redefined_name,"autouse") ) {
5514 const line_t oldline = CopLINE(PL_curcop);
5515 if (PL_copline != NOLINE)
5516 CopLINE_set(PL_curcop, PL_copline);
5517 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5518 CvCONST(cv) ? "Constant subroutine %s redefined"
5519 : "Subroutine %s redefined"
5521 CopLINE_set(PL_curcop, oldline);
5531 if (cv) /* must reuse cv if autoloaded */
5535 sv_upgrade((SV *)cv, SVt_PVCV);
5539 PL_sub_generation++;
5543 (void)gv_fetchfile(filename);
5544 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
5545 an external constant string */
5547 CvXSUB(cv) = subaddr;
5550 const char *s = strrchr(name,':');
5556 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5559 if (strEQ(s, "BEGIN")) {
5561 PL_beginav = newAV();
5562 av_push(PL_beginav, (SV*)cv);
5563 GvCV(gv) = 0; /* cv has been hijacked */
5565 else if (strEQ(s, "END")) {
5568 av_unshift(PL_endav, 1);
5569 av_store(PL_endav, 0, (SV*)cv);
5570 GvCV(gv) = 0; /* cv has been hijacked */
5572 else if (strEQ(s, "CHECK")) {
5574 PL_checkav = newAV();
5575 if (PL_main_start && ckWARN(WARN_VOID))
5576 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
5577 av_unshift(PL_checkav, 1);
5578 av_store(PL_checkav, 0, (SV*)cv);
5579 GvCV(gv) = 0; /* cv has been hijacked */
5581 else if (strEQ(s, "INIT")) {
5583 PL_initav = newAV();
5584 if (PL_main_start && ckWARN(WARN_VOID))
5585 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
5586 av_push(PL_initav, (SV*)cv);
5587 GvCV(gv) = 0; /* cv has been hijacked */
5602 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5607 OP* pegop = newOP(OP_NULL, 0);
5611 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
5612 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
5614 #ifdef GV_UNIQUE_CHECK
5616 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5620 if ((cv = GvFORM(gv))) {
5621 if (ckWARN(WARN_REDEFINE)) {
5622 const line_t oldline = CopLINE(PL_curcop);
5623 if (PL_copline != NOLINE)
5624 CopLINE_set(PL_curcop, PL_copline);
5625 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5626 o ? "Format %"SVf" redefined"
5627 : "Format STDOUT redefined", (void*)cSVOPo->op_sv);
5628 CopLINE_set(PL_curcop, oldline);
5635 CvFILE_set_from_cop(cv, PL_curcop);
5638 pad_tidy(padtidy_FORMAT);
5639 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5640 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5641 OpREFCNT_set(CvROOT(cv), 1);
5642 CvSTART(cv) = LINKLIST(CvROOT(cv));
5643 CvROOT(cv)->op_next = 0;
5644 CALL_PEEP(CvSTART(cv));
5646 op_getmad(o,pegop,'n');
5647 op_getmad_weak(block, pegop, 'b');
5651 PL_copline = NOLINE;
5659 Perl_newANONLIST(pTHX_ OP *o)
5661 return newUNOP(OP_REFGEN, 0,
5662 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5666 Perl_newANONHASH(pTHX_ OP *o)
5668 return newUNOP(OP_REFGEN, 0,
5669 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5673 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5675 return newANONATTRSUB(floor, proto, NULL, block);
5679 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5681 return newUNOP(OP_REFGEN, 0,
5682 newSVOP(OP_ANONCODE, 0,
5683 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5687 Perl_oopsAV(pTHX_ OP *o)
5690 switch (o->op_type) {
5692 o->op_type = OP_PADAV;
5693 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5694 return ref(o, OP_RV2AV);
5697 o->op_type = OP_RV2AV;
5698 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5703 if (ckWARN_d(WARN_INTERNAL))
5704 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
5711 Perl_oopsHV(pTHX_ OP *o)
5714 switch (o->op_type) {
5717 o->op_type = OP_PADHV;
5718 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5719 return ref(o, OP_RV2HV);
5723 o->op_type = OP_RV2HV;
5724 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5729 if (ckWARN_d(WARN_INTERNAL))
5730 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
5737 Perl_newAVREF(pTHX_ OP *o)
5740 if (o->op_type == OP_PADANY) {
5741 o->op_type = OP_PADAV;
5742 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5745 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5746 && ckWARN(WARN_DEPRECATED)) {
5747 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5748 "Using an array as a reference is deprecated");
5750 return newUNOP(OP_RV2AV, 0, scalar(o));
5754 Perl_newGVREF(pTHX_ I32 type, OP *o)
5756 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5757 return newUNOP(OP_NULL, 0, o);
5758 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5762 Perl_newHVREF(pTHX_ OP *o)
5765 if (o->op_type == OP_PADANY) {
5766 o->op_type = OP_PADHV;
5767 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5770 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5771 && ckWARN(WARN_DEPRECATED)) {
5772 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5773 "Using a hash as a reference is deprecated");
5775 return newUNOP(OP_RV2HV, 0, scalar(o));
5779 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5781 return newUNOP(OP_RV2CV, flags, scalar(o));
5785 Perl_newSVREF(pTHX_ OP *o)
5788 if (o->op_type == OP_PADANY) {
5789 o->op_type = OP_PADSV;
5790 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5793 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5794 o->op_flags |= OPpDONE_SVREF;
5797 return newUNOP(OP_RV2SV, 0, scalar(o));
5800 /* Check routines. See the comments at the top of this file for details
5801 * on when these are called */
5804 Perl_ck_anoncode(pTHX_ OP *o)
5806 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
5808 cSVOPo->op_sv = NULL;
5813 Perl_ck_bitop(pTHX_ OP *o)
5816 #define OP_IS_NUMCOMPARE(op) \
5817 ((op) == OP_LT || (op) == OP_I_LT || \
5818 (op) == OP_GT || (op) == OP_I_GT || \
5819 (op) == OP_LE || (op) == OP_I_LE || \
5820 (op) == OP_GE || (op) == OP_I_GE || \
5821 (op) == OP_EQ || (op) == OP_I_EQ || \
5822 (op) == OP_NE || (op) == OP_I_NE || \
5823 (op) == OP_NCMP || (op) == OP_I_NCMP)
5824 o->op_private = (U8)(PL_hints & HINT_INTEGER);
5825 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
5826 && (o->op_type == OP_BIT_OR
5827 || o->op_type == OP_BIT_AND
5828 || o->op_type == OP_BIT_XOR))
5830 const OP * const left = cBINOPo->op_first;
5831 const OP * const right = left->op_sibling;
5832 if ((OP_IS_NUMCOMPARE(left->op_type) &&
5833 (left->op_flags & OPf_PARENS) == 0) ||
5834 (OP_IS_NUMCOMPARE(right->op_type) &&
5835 (right->op_flags & OPf_PARENS) == 0))
5836 if (ckWARN(WARN_PRECEDENCE))
5837 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
5838 "Possible precedence problem on bitwise %c operator",
5839 o->op_type == OP_BIT_OR ? '|'
5840 : o->op_type == OP_BIT_AND ? '&' : '^'
5847 Perl_ck_concat(pTHX_ OP *o)
5849 const OP * const kid = cUNOPo->op_first;
5850 PERL_UNUSED_CONTEXT;
5851 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
5852 !(kUNOP->op_first->op_flags & OPf_MOD))
5853 o->op_flags |= OPf_STACKED;
5858 Perl_ck_spair(pTHX_ OP *o)
5861 if (o->op_flags & OPf_KIDS) {
5864 const OPCODE type = o->op_type;
5865 o = modkids(ck_fun(o), type);
5866 kid = cUNOPo->op_first;
5867 newop = kUNOP->op_first->op_sibling;
5869 const OPCODE type = newop->op_type;
5870 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
5871 type == OP_PADAV || type == OP_PADHV ||
5872 type == OP_RV2AV || type == OP_RV2HV)
5876 op_getmad(kUNOP->op_first,newop,'K');
5878 op_free(kUNOP->op_first);
5880 kUNOP->op_first = newop;
5882 o->op_ppaddr = PL_ppaddr[++o->op_type];
5887 Perl_ck_delete(pTHX_ OP *o)
5891 if (o->op_flags & OPf_KIDS) {
5892 OP * const kid = cUNOPo->op_first;
5893 switch (kid->op_type) {
5895 o->op_flags |= OPf_SPECIAL;
5898 o->op_private |= OPpSLICE;
5901 o->op_flags |= OPf_SPECIAL;
5906 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5915 Perl_ck_die(pTHX_ OP *o)
5918 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5924 Perl_ck_eof(pTHX_ OP *o)
5928 if (o->op_flags & OPf_KIDS) {
5929 if (cLISTOPo->op_first->op_type == OP_STUB) {
5931 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
5933 op_getmad(o,newop,'O');
5945 Perl_ck_eval(pTHX_ OP *o)
5948 PL_hints |= HINT_BLOCK_SCOPE;
5949 if (o->op_flags & OPf_KIDS) {
5950 SVOP * const kid = (SVOP*)cUNOPo->op_first;
5953 o->op_flags &= ~OPf_KIDS;
5956 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
5962 cUNOPo->op_first = 0;
5967 NewOp(1101, enter, 1, LOGOP);
5968 enter->op_type = OP_ENTERTRY;
5969 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5970 enter->op_private = 0;
5972 /* establish postfix order */
5973 enter->op_next = (OP*)enter;
5975 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5976 o->op_type = OP_LEAVETRY;
5977 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5978 enter->op_other = o;
5979 op_getmad(oldo,o,'O');
5993 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5994 op_getmad(oldo,o,'O');
5996 o->op_targ = (PADOFFSET)PL_hints;
5997 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
5998 /* Store a copy of %^H that pp_entereval can pick up */
5999 OP *hhop = newSVOP(OP_CONST, 0,
6000 (SV*)Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv)));
6001 cUNOPo->op_first->op_sibling = hhop;
6002 o->op_private |= OPpEVAL_HAS_HH;
6008 Perl_ck_exit(pTHX_ OP *o)
6011 HV * const table = GvHV(PL_hintgv);
6013 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
6014 if (svp && *svp && SvTRUE(*svp))
6015 o->op_private |= OPpEXIT_VMSISH;
6017 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6023 Perl_ck_exec(pTHX_ OP *o)
6025 if (o->op_flags & OPf_STACKED) {
6028 kid = cUNOPo->op_first->op_sibling;
6029 if (kid->op_type == OP_RV2GV)
6038 Perl_ck_exists(pTHX_ OP *o)
6042 if (o->op_flags & OPf_KIDS) {
6043 OP * const kid = cUNOPo->op_first;
6044 if (kid->op_type == OP_ENTERSUB) {
6045 (void) ref(kid, o->op_type);
6046 if (kid->op_type != OP_RV2CV && !PL_error_count)
6047 Perl_croak(aTHX_ "%s argument is not a subroutine name",
6049 o->op_private |= OPpEXISTS_SUB;
6051 else if (kid->op_type == OP_AELEM)
6052 o->op_flags |= OPf_SPECIAL;
6053 else if (kid->op_type != OP_HELEM)
6054 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
6062 Perl_ck_rvconst(pTHX_ register OP *o)
6065 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6067 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6068 if (o->op_type == OP_RV2CV)
6069 o->op_private &= ~1;
6071 if (kid->op_type == OP_CONST) {
6074 SV * const kidsv = kid->op_sv;
6076 /* Is it a constant from cv_const_sv()? */
6077 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
6078 SV * const rsv = SvRV(kidsv);
6079 const svtype type = SvTYPE(rsv);
6080 const char *badtype = NULL;
6082 switch (o->op_type) {
6084 if (type > SVt_PVMG)
6085 badtype = "a SCALAR";
6088 if (type != SVt_PVAV)
6089 badtype = "an ARRAY";
6092 if (type != SVt_PVHV)
6096 if (type != SVt_PVCV)
6101 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
6104 else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
6105 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
6106 /* If this is an access to a stash, disable "strict refs", because
6107 * stashes aren't auto-vivified at compile-time (unless we store
6108 * symbols in them), and we don't want to produce a run-time
6109 * stricture error when auto-vivifying the stash. */
6110 const char *s = SvPV_nolen(kidsv);
6111 const STRLEN l = SvCUR(kidsv);
6112 if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
6113 o->op_private &= ~HINT_STRICT_REFS;
6115 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
6116 const char *badthing;
6117 switch (o->op_type) {
6119 badthing = "a SCALAR";
6122 badthing = "an ARRAY";
6125 badthing = "a HASH";
6133 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
6134 (void*)kidsv, badthing);
6137 * This is a little tricky. We only want to add the symbol if we
6138 * didn't add it in the lexer. Otherwise we get duplicate strict
6139 * warnings. But if we didn't add it in the lexer, we must at
6140 * least pretend like we wanted to add it even if it existed before,
6141 * or we get possible typo warnings. OPpCONST_ENTERED says
6142 * whether the lexer already added THIS instance of this symbol.
6144 iscv = (o->op_type == OP_RV2CV) * 2;
6146 gv = gv_fetchsv(kidsv,
6147 iscv | !(kid->op_private & OPpCONST_ENTERED),
6150 : o->op_type == OP_RV2SV
6152 : o->op_type == OP_RV2AV
6154 : o->op_type == OP_RV2HV
6157 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
6159 kid->op_type = OP_GV;
6160 SvREFCNT_dec(kid->op_sv);
6162 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
6163 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
6164 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
6166 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc_simple_NN(gv));
6168 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
6170 kid->op_private = 0;
6171 kid->op_ppaddr = PL_ppaddr[OP_GV];
6178 Perl_ck_ftst(pTHX_ OP *o)
6181 const I32 type = o->op_type;
6183 if (o->op_flags & OPf_REF) {
6186 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
6187 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6188 const OPCODE kidtype = kid->op_type;
6190 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6191 OP * const newop = newGVOP(type, OPf_REF,
6192 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
6194 op_getmad(o,newop,'O');
6200 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o))
6201 o->op_private |= OPpFT_ACCESS;
6202 if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst)
6203 && kidtype != OP_STAT && kidtype != OP_LSTAT)
6204 o->op_private |= OPpFT_STACKED;
6212 if (type == OP_FTTTY)
6213 o = newGVOP(type, OPf_REF, PL_stdingv);
6215 o = newUNOP(type, 0, newDEFSVOP());
6216 op_getmad(oldo,o,'O');
6222 Perl_ck_fun(pTHX_ OP *o)
6225 const int type = o->op_type;
6226 register I32 oa = PL_opargs[type] >> OASHIFT;
6228 if (o->op_flags & OPf_STACKED) {
6229 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
6232 return no_fh_allowed(o);
6235 if (o->op_flags & OPf_KIDS) {
6236 OP **tokid = &cLISTOPo->op_first;
6237 register OP *kid = cLISTOPo->op_first;
6241 if (kid->op_type == OP_PUSHMARK ||
6242 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
6244 tokid = &kid->op_sibling;
6245 kid = kid->op_sibling;
6247 if (!kid && PL_opargs[type] & OA_DEFGV)
6248 *tokid = kid = newDEFSVOP();
6252 sibl = kid->op_sibling;
6254 if (!sibl && kid->op_type == OP_STUB) {
6261 /* list seen where single (scalar) arg expected? */
6262 if (numargs == 1 && !(oa >> 4)
6263 && kid->op_type == OP_LIST && type != OP_SCALAR)
6265 return too_many_arguments(o,PL_op_desc[type]);
6278 if ((type == OP_PUSH || type == OP_UNSHIFT)
6279 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
6280 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6281 "Useless use of %s with no values",
6284 if (kid->op_type == OP_CONST &&
6285 (kid->op_private & OPpCONST_BARE))
6287 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
6288 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
6289 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6290 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6291 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
6292 (void*)((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
6294 op_getmad(kid,newop,'K');
6299 kid->op_sibling = sibl;
6302 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
6303 bad_type(numargs, "array", PL_op_desc[type], kid);
6307 if (kid->op_type == OP_CONST &&
6308 (kid->op_private & OPpCONST_BARE))
6310 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
6311 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
6312 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6313 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6314 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
6315 (void*)((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
6317 op_getmad(kid,newop,'K');
6322 kid->op_sibling = sibl;
6325 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
6326 bad_type(numargs, "hash", PL_op_desc[type], kid);
6331 OP * const newop = newUNOP(OP_NULL, 0, kid);
6332 kid->op_sibling = 0;
6334 newop->op_next = newop;
6336 kid->op_sibling = sibl;
6341 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
6342 if (kid->op_type == OP_CONST &&
6343 (kid->op_private & OPpCONST_BARE))
6345 OP * const newop = newGVOP(OP_GV, 0,
6346 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
6347 if (!(o->op_private & 1) && /* if not unop */
6348 kid == cLISTOPo->op_last)
6349 cLISTOPo->op_last = newop;
6351 op_getmad(kid,newop,'K');
6357 else if (kid->op_type == OP_READLINE) {
6358 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
6359 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
6362 I32 flags = OPf_SPECIAL;
6366 /* is this op a FH constructor? */
6367 if (is_handle_constructor(o,numargs)) {
6368 const char *name = NULL;
6372 /* Set a flag to tell rv2gv to vivify
6373 * need to "prove" flag does not mean something
6374 * else already - NI-S 1999/05/07
6377 if (kid->op_type == OP_PADSV) {
6378 name = PAD_COMPNAME_PV(kid->op_targ);
6379 /* SvCUR of a pad namesv can't be trusted
6380 * (see PL_generation), so calc its length
6386 else if (kid->op_type == OP_RV2SV
6387 && kUNOP->op_first->op_type == OP_GV)
6389 GV * const gv = cGVOPx_gv(kUNOP->op_first);
6391 len = GvNAMELEN(gv);
6393 else if (kid->op_type == OP_AELEM
6394 || kid->op_type == OP_HELEM)
6397 OP *op = ((BINOP*)kid)->op_first;
6401 const char * const a =
6402 kid->op_type == OP_AELEM ?
6404 if (((op->op_type == OP_RV2AV) ||
6405 (op->op_type == OP_RV2HV)) &&
6406 (firstop = ((UNOP*)op)->op_first) &&
6407 (firstop->op_type == OP_GV)) {
6408 /* packagevar $a[] or $h{} */
6409 GV * const gv = cGVOPx_gv(firstop);
6417 else if (op->op_type == OP_PADAV
6418 || op->op_type == OP_PADHV) {
6419 /* lexicalvar $a[] or $h{} */
6420 const char * const padname =
6421 PAD_COMPNAME_PV(op->op_targ);
6430 name = SvPV_const(tmpstr, len);
6435 name = "__ANONIO__";
6442 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
6443 namesv = PAD_SVl(targ);
6444 SvUPGRADE(namesv, SVt_PV);
6446 sv_setpvn(namesv, "$", 1);
6447 sv_catpvn(namesv, name, len);
6450 kid->op_sibling = 0;
6451 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
6452 kid->op_targ = targ;
6453 kid->op_private |= priv;
6455 kid->op_sibling = sibl;
6461 mod(scalar(kid), type);
6465 tokid = &kid->op_sibling;
6466 kid = kid->op_sibling;
6469 if (kid && kid->op_type != OP_STUB)
6470 return too_many_arguments(o,OP_DESC(o));
6471 o->op_private |= numargs;
6473 /* FIXME - should the numargs move as for the PERL_MAD case? */
6474 o->op_private |= numargs;
6476 return too_many_arguments(o,OP_DESC(o));
6480 else if (PL_opargs[type] & OA_DEFGV) {
6482 OP *newop = newUNOP(type, 0, newDEFSVOP());
6483 op_getmad(o,newop,'O');
6486 /* Ordering of these two is important to keep f_map.t passing. */
6488 return newUNOP(type, 0, newDEFSVOP());
6493 while (oa & OA_OPTIONAL)
6495 if (oa && oa != OA_LIST)
6496 return too_few_arguments(o,OP_DESC(o));
6502 Perl_ck_glob(pTHX_ OP *o)
6508 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
6509 append_elem(OP_GLOB, o, newDEFSVOP());
6511 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
6512 && GvCVu(gv) && GvIMPORTED_CV(gv)))
6514 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6517 #if !defined(PERL_EXTERNAL_GLOB)
6518 /* XXX this can be tightened up and made more failsafe. */
6519 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
6522 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
6523 newSVpvs("File::Glob"), NULL, NULL, NULL);
6524 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6525 glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
6526 GvCV(gv) = GvCV(glob_gv);
6527 SvREFCNT_inc_void((SV*)GvCV(gv));
6528 GvIMPORTED_CV_on(gv);
6531 #endif /* PERL_EXTERNAL_GLOB */
6533 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6534 append_elem(OP_GLOB, o,
6535 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
6536 o->op_type = OP_LIST;
6537 o->op_ppaddr = PL_ppaddr[OP_LIST];
6538 cLISTOPo->op_first->op_type = OP_PUSHMARK;
6539 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
6540 cLISTOPo->op_first->op_targ = 0;
6541 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
6542 append_elem(OP_LIST, o,
6543 scalar(newUNOP(OP_RV2CV, 0,
6544 newGVOP(OP_GV, 0, gv)))));
6545 o = newUNOP(OP_NULL, 0, ck_subr(o));
6546 o->op_targ = OP_GLOB; /* hint at what it used to be */
6549 gv = newGVgen("main");
6551 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
6557 Perl_ck_grep(pTHX_ OP *o)
6562 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
6565 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
6566 /* don't allocate gwop here, as we may leak it if PL_error_count > 0 */
6568 if (o->op_flags & OPf_STACKED) {
6571 kid = cLISTOPo->op_first->op_sibling;
6572 if (!cUNOPx(kid)->op_next)
6573 Perl_croak(aTHX_ "panic: ck_grep");
6574 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
6577 NewOp(1101, gwop, 1, LOGOP);
6578 kid->op_next = (OP*)gwop;
6579 o->op_flags &= ~OPf_STACKED;
6581 kid = cLISTOPo->op_first->op_sibling;
6582 if (type == OP_MAPWHILE)
6589 kid = cLISTOPo->op_first->op_sibling;
6590 if (kid->op_type != OP_NULL)
6591 Perl_croak(aTHX_ "panic: ck_grep");
6592 kid = kUNOP->op_first;
6595 NewOp(1101, gwop, 1, LOGOP);
6596 gwop->op_type = type;
6597 gwop->op_ppaddr = PL_ppaddr[type];
6598 gwop->op_first = listkids(o);
6599 gwop->op_flags |= OPf_KIDS;
6600 gwop->op_other = LINKLIST(kid);
6601 kid->op_next = (OP*)gwop;
6602 offset = pad_findmy("$_");
6603 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
6604 o->op_private = gwop->op_private = 0;
6605 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
6608 o->op_private = gwop->op_private = OPpGREP_LEX;
6609 gwop->op_targ = o->op_targ = offset;
6612 kid = cLISTOPo->op_first->op_sibling;
6613 if (!kid || !kid->op_sibling)
6614 return too_few_arguments(o,OP_DESC(o));
6615 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
6616 mod(kid, OP_GREPSTART);
6622 Perl_ck_index(pTHX_ OP *o)
6624 if (o->op_flags & OPf_KIDS) {
6625 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6627 kid = kid->op_sibling; /* get past "big" */
6628 if (kid && kid->op_type == OP_CONST)
6629 fbm_compile(((SVOP*)kid)->op_sv, 0);
6635 Perl_ck_lengthconst(pTHX_ OP *o)
6637 /* XXX length optimization goes here */
6642 Perl_ck_lfun(pTHX_ OP *o)
6644 const OPCODE type = o->op_type;
6645 return modkids(ck_fun(o), type);
6649 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
6651 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
6652 switch (cUNOPo->op_first->op_type) {
6654 /* This is needed for
6655 if (defined %stash::)
6656 to work. Do not break Tk.
6658 break; /* Globals via GV can be undef */
6660 case OP_AASSIGN: /* Is this a good idea? */
6661 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6662 "defined(@array) is deprecated");
6663 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6664 "\t(Maybe you should just omit the defined()?)\n");
6667 /* This is needed for
6668 if (defined %stash::)
6669 to work. Do not break Tk.
6671 break; /* Globals via GV can be undef */
6673 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6674 "defined(%%hash) is deprecated");
6675 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6676 "\t(Maybe you should just omit the defined()?)\n");
6687 Perl_ck_rfun(pTHX_ OP *o)
6689 const OPCODE type = o->op_type;
6690 return refkids(ck_fun(o), type);
6694 Perl_ck_listiob(pTHX_ OP *o)
6698 kid = cLISTOPo->op_first;
6701 kid = cLISTOPo->op_first;
6703 if (kid->op_type == OP_PUSHMARK)
6704 kid = kid->op_sibling;
6705 if (kid && o->op_flags & OPf_STACKED)
6706 kid = kid->op_sibling;
6707 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6708 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6709 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6710 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6711 cLISTOPo->op_first->op_sibling = kid;
6712 cLISTOPo->op_last = kid;
6713 kid = kid->op_sibling;
6718 append_elem(o->op_type, o, newDEFSVOP());
6724 Perl_ck_say(pTHX_ OP *o)
6727 o->op_type = OP_PRINT;
6728 cLISTOPo->op_last = cLISTOPo->op_last->op_sibling
6729 = newSVOP(OP_CONST, 0, newSVpvs("\n"));
6734 Perl_ck_smartmatch(pTHX_ OP *o)
6737 if (0 == (o->op_flags & OPf_SPECIAL)) {
6738 OP *first = cBINOPo->op_first;
6739 OP *second = first->op_sibling;
6741 /* Implicitly take a reference to an array or hash */
6742 first->op_sibling = NULL;
6743 first = cBINOPo->op_first = ref_array_or_hash(first);
6744 second = first->op_sibling = ref_array_or_hash(second);
6746 /* Implicitly take a reference to a regular expression */
6747 if (first->op_type == OP_MATCH) {
6748 first->op_type = OP_QR;
6749 first->op_ppaddr = PL_ppaddr[OP_QR];
6751 if (second->op_type == OP_MATCH) {
6752 second->op_type = OP_QR;
6753 second->op_ppaddr = PL_ppaddr[OP_QR];
6762 Perl_ck_sassign(pTHX_ OP *o)
6764 OP * const kid = cLISTOPo->op_first;
6765 /* has a disposable target? */
6766 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6767 && !(kid->op_flags & OPf_STACKED)
6768 /* Cannot steal the second time! */
6769 && !(kid->op_private & OPpTARGET_MY))
6771 OP * const kkid = kid->op_sibling;
6773 /* Can just relocate the target. */
6774 if (kkid && kkid->op_type == OP_PADSV
6775 && !(kkid->op_private & OPpLVAL_INTRO))
6777 kid->op_targ = kkid->op_targ;
6779 /* Now we do not need PADSV and SASSIGN. */
6780 kid->op_sibling = o->op_sibling; /* NULL */
6781 cLISTOPo->op_first = NULL;
6783 op_getmad(o,kid,'O');
6784 op_getmad(kkid,kid,'M');
6789 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6793 if (kid->op_sibling) {
6794 OP *kkid = kid->op_sibling;
6795 if (kkid->op_type == OP_PADSV
6796 && (kkid->op_private & OPpLVAL_INTRO)
6797 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
6798 o->op_private |= OPpASSIGN_STATE;
6799 /* hijacking PADSTALE for uninitialized state variables */
6800 SvPADSTALE_on(PAD_SVl(kkid->op_targ));
6807 Perl_ck_match(pTHX_ OP *o)
6810 if (o->op_type != OP_QR && PL_compcv) {
6811 const PADOFFSET offset = pad_findmy("$_");
6812 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
6813 o->op_targ = offset;
6814 o->op_private |= OPpTARGET_MY;
6817 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
6818 o->op_private |= OPpRUNTIME;
6823 Perl_ck_method(pTHX_ OP *o)
6825 OP * const kid = cUNOPo->op_first;
6826 if (kid->op_type == OP_CONST) {
6827 SV* sv = kSVOP->op_sv;
6828 const char * const method = SvPVX_const(sv);
6829 if (!(strchr(method, ':') || strchr(method, '\''))) {
6831 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6832 sv = newSVpvn_share(method, SvCUR(sv), 0);
6835 kSVOP->op_sv = NULL;
6837 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6839 op_getmad(o,cmop,'O');
6850 Perl_ck_null(pTHX_ OP *o)
6852 PERL_UNUSED_CONTEXT;
6857 Perl_ck_open(pTHX_ OP *o)
6860 HV * const table = GvHV(PL_hintgv);
6862 SV **svp = hv_fetchs(table, "open_IN", FALSE);
6864 const I32 mode = mode_from_discipline(*svp);
6865 if (mode & O_BINARY)
6866 o->op_private |= OPpOPEN_IN_RAW;
6867 else if (mode & O_TEXT)
6868 o->op_private |= OPpOPEN_IN_CRLF;
6871 svp = hv_fetchs(table, "open_OUT", FALSE);
6873 const I32 mode = mode_from_discipline(*svp);
6874 if (mode & O_BINARY)
6875 o->op_private |= OPpOPEN_OUT_RAW;
6876 else if (mode & O_TEXT)
6877 o->op_private |= OPpOPEN_OUT_CRLF;
6880 if (o->op_type == OP_BACKTICK)
6883 /* In case of three-arg dup open remove strictness
6884 * from the last arg if it is a bareword. */
6885 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
6886 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
6890 if ((last->op_type == OP_CONST) && /* The bareword. */
6891 (last->op_private & OPpCONST_BARE) &&
6892 (last->op_private & OPpCONST_STRICT) &&
6893 (oa = first->op_sibling) && /* The fh. */
6894 (oa = oa->op_sibling) && /* The mode. */
6895 (oa->op_type == OP_CONST) &&
6896 SvPOK(((SVOP*)oa)->op_sv) &&
6897 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
6898 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
6899 (last == oa->op_sibling)) /* The bareword. */
6900 last->op_private &= ~OPpCONST_STRICT;
6906 Perl_ck_repeat(pTHX_ OP *o)
6908 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6909 o->op_private |= OPpREPEAT_DOLIST;
6910 cBINOPo->op_first = force_list(cBINOPo->op_first);
6918 Perl_ck_require(pTHX_ OP *o)
6923 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6924 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6926 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6927 SV * const sv = kid->op_sv;
6928 U32 was_readonly = SvREADONLY(sv);
6933 sv_force_normal_flags(sv, 0);
6934 assert(!SvREADONLY(sv));
6941 for (s = SvPVX(sv); *s; s++) {
6942 if (*s == ':' && s[1] == ':') {
6943 const STRLEN len = strlen(s+2)+1;
6945 Move(s+2, s+1, len, char);
6946 SvCUR_set(sv, SvCUR(sv) - 1);
6949 sv_catpvs(sv, ".pm");
6950 SvFLAGS(sv) |= was_readonly;
6954 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
6955 /* handle override, if any */
6956 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
6957 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
6958 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
6959 gv = gvp ? *gvp : NULL;
6963 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6964 OP * const kid = cUNOPo->op_first;
6967 cUNOPo->op_first = 0;
6971 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
6972 append_elem(OP_LIST, kid,
6973 scalar(newUNOP(OP_RV2CV, 0,
6976 op_getmad(o,newop,'O');
6984 Perl_ck_return(pTHX_ OP *o)
6987 if (CvLVALUE(PL_compcv)) {
6989 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6990 mod(kid, OP_LEAVESUBLV);
6996 Perl_ck_select(pTHX_ OP *o)
7000 if (o->op_flags & OPf_KIDS) {
7001 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7002 if (kid && kid->op_sibling) {
7003 o->op_type = OP_SSELECT;
7004 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
7006 return fold_constants(o);
7010 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7011 if (kid && kid->op_type == OP_RV2GV)
7012 kid->op_private &= ~HINT_STRICT_REFS;
7017 Perl_ck_shift(pTHX_ OP *o)
7020 const I32 type = o->op_type;
7022 if (!(o->op_flags & OPf_KIDS)) {
7024 /* FIXME - this can be refactored to reduce code in #ifdefs */
7026 OP * const oldo = o;
7030 argop = newUNOP(OP_RV2AV, 0,
7031 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
7033 o = newUNOP(type, 0, scalar(argop));
7034 op_getmad(oldo,o,'O');
7037 return newUNOP(type, 0, scalar(argop));
7040 return scalar(modkids(ck_fun(o), type));
7044 Perl_ck_sort(pTHX_ OP *o)
7049 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
7050 HV * const hinthv = GvHV(PL_hintgv);
7052 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
7054 const I32 sorthints = (I32)SvIV(*svp);
7055 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
7056 o->op_private |= OPpSORT_QSORT;
7057 if ((sorthints & HINT_SORT_STABLE) != 0)
7058 o->op_private |= OPpSORT_STABLE;
7063 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
7065 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7066 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
7068 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
7070 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
7072 if (kid->op_type == OP_SCOPE) {
7076 else if (kid->op_type == OP_LEAVE) {
7077 if (o->op_type == OP_SORT) {
7078 op_null(kid); /* wipe out leave */
7081 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
7082 if (k->op_next == kid)
7084 /* don't descend into loops */
7085 else if (k->op_type == OP_ENTERLOOP
7086 || k->op_type == OP_ENTERITER)
7088 k = cLOOPx(k)->op_lastop;
7093 kid->op_next = 0; /* just disconnect the leave */
7094 k = kLISTOP->op_first;
7099 if (o->op_type == OP_SORT) {
7100 /* provide scalar context for comparison function/block */
7106 o->op_flags |= OPf_SPECIAL;
7108 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
7111 firstkid = firstkid->op_sibling;
7114 /* provide list context for arguments */
7115 if (o->op_type == OP_SORT)
7122 S_simplify_sort(pTHX_ OP *o)
7125 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7130 if (!(o->op_flags & OPf_STACKED))
7132 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7133 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
7134 kid = kUNOP->op_first; /* get past null */
7135 if (kid->op_type != OP_SCOPE)
7137 kid = kLISTOP->op_last; /* get past scope */
7138 switch(kid->op_type) {
7146 k = kid; /* remember this node*/
7147 if (kBINOP->op_first->op_type != OP_RV2SV)
7149 kid = kBINOP->op_first; /* get past cmp */
7150 if (kUNOP->op_first->op_type != OP_GV)
7152 kid = kUNOP->op_first; /* get past rv2sv */
7154 if (GvSTASH(gv) != PL_curstash)
7156 gvname = GvNAME(gv);
7157 if (*gvname == 'a' && gvname[1] == '\0')
7159 else if (*gvname == 'b' && gvname[1] == '\0')
7164 kid = k; /* back to cmp */
7165 if (kBINOP->op_last->op_type != OP_RV2SV)
7167 kid = kBINOP->op_last; /* down to 2nd arg */
7168 if (kUNOP->op_first->op_type != OP_GV)
7170 kid = kUNOP->op_first; /* get past rv2sv */
7172 if (GvSTASH(gv) != PL_curstash)
7174 gvname = GvNAME(gv);
7176 ? !(*gvname == 'a' && gvname[1] == '\0')
7177 : !(*gvname == 'b' && gvname[1] == '\0'))
7179 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
7181 o->op_private |= OPpSORT_DESCEND;
7182 if (k->op_type == OP_NCMP)
7183 o->op_private |= OPpSORT_NUMERIC;
7184 if (k->op_type == OP_I_NCMP)
7185 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
7186 kid = cLISTOPo->op_first->op_sibling;
7187 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
7189 op_getmad(kid,o,'S'); /* then delete it */
7191 op_free(kid); /* then delete it */
7196 Perl_ck_split(pTHX_ OP *o)
7201 if (o->op_flags & OPf_STACKED)
7202 return no_fh_allowed(o);
7204 kid = cLISTOPo->op_first;
7205 if (kid->op_type != OP_NULL)
7206 Perl_croak(aTHX_ "panic: ck_split");
7207 kid = kid->op_sibling;
7208 op_free(cLISTOPo->op_first);
7209 cLISTOPo->op_first = kid;
7211 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
7212 cLISTOPo->op_last = kid; /* There was only one element previously */
7215 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
7216 OP * const sibl = kid->op_sibling;
7217 kid->op_sibling = 0;
7218 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
7219 if (cLISTOPo->op_first == cLISTOPo->op_last)
7220 cLISTOPo->op_last = kid;
7221 cLISTOPo->op_first = kid;
7222 kid->op_sibling = sibl;
7225 kid->op_type = OP_PUSHRE;
7226 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
7228 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
7229 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
7230 "Use of /g modifier is meaningless in split");
7233 if (!kid->op_sibling)
7234 append_elem(OP_SPLIT, o, newDEFSVOP());
7236 kid = kid->op_sibling;
7239 if (!kid->op_sibling)
7240 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
7241 assert(kid->op_sibling);
7243 kid = kid->op_sibling;
7246 if (kid->op_sibling)
7247 return too_many_arguments(o,OP_DESC(o));
7253 Perl_ck_join(pTHX_ OP *o)
7255 const OP * const kid = cLISTOPo->op_first->op_sibling;
7256 if (kid && kid->op_type == OP_MATCH) {
7257 if (ckWARN(WARN_SYNTAX)) {
7258 const REGEXP *re = PM_GETRE(kPMOP);
7259 const char *pmstr = re ? re->precomp : "STRING";
7260 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7261 "/%s/ should probably be written as \"%s\"",
7269 Perl_ck_subr(pTHX_ OP *o)
7272 OP *prev = ((cUNOPo->op_first->op_sibling)
7273 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
7274 OP *o2 = prev->op_sibling;
7276 const char *proto = NULL;
7277 const char *proto_end = NULL;
7282 I32 contextclass = 0;
7286 o->op_private |= OPpENTERSUB_HASTARG;
7287 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
7288 if (cvop->op_type == OP_RV2CV) {
7290 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
7291 op_null(cvop); /* disable rv2cv */
7292 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
7293 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
7294 GV *gv = cGVOPx_gv(tmpop);
7297 tmpop->op_private |= OPpEARLY_CV;
7301 namegv = CvANON(cv) ? gv : CvGV(cv);
7302 proto = SvPV((SV*)cv, len);
7303 proto_end = proto + len;
7305 if (CvASSERTION(cv)) {
7306 if (PL_hints & HINT_ASSERTING) {
7307 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
7308 o->op_private |= OPpENTERSUB_DB;
7312 if (!(PL_hints & HINT_ASSERTIONSSEEN) && ckWARN(WARN_ASSERTIONS)) {
7313 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
7314 "Impossible to activate assertion call");
7321 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7322 if (o2->op_type == OP_CONST)
7323 o2->op_private &= ~OPpCONST_STRICT;
7324 else if (o2->op_type == OP_LIST) {
7325 OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
7326 if (sib && sib->op_type == OP_CONST)
7327 sib->op_private &= ~OPpCONST_STRICT;
7330 o->op_private |= (PL_hints & HINT_STRICT_REFS);
7331 if (PERLDB_SUB && PL_curstash != PL_debstash)
7332 o->op_private |= OPpENTERSUB_DB;
7333 while (o2 != cvop) {
7335 if (PL_madskills && o2->op_type == OP_NULL)
7336 o3 = ((UNOP*)o2)->op_first;
7340 if (proto >= proto_end)
7341 return too_many_arguments(o, gv_ename(namegv));
7361 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
7363 arg == 1 ? "block or sub {}" : "sub {}",
7364 gv_ename(namegv), o3);
7367 /* '*' allows any scalar type, including bareword */
7370 if (o3->op_type == OP_RV2GV)
7371 goto wrapref; /* autoconvert GLOB -> GLOBref */
7372 else if (o3->op_type == OP_CONST)
7373 o3->op_private &= ~OPpCONST_STRICT;
7374 else if (o3->op_type == OP_ENTERSUB) {
7375 /* accidental subroutine, revert to bareword */
7376 OP *gvop = ((UNOP*)o3)->op_first;
7377 if (gvop && gvop->op_type == OP_NULL) {
7378 gvop = ((UNOP*)gvop)->op_first;
7380 for (; gvop->op_sibling; gvop = gvop->op_sibling)
7383 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
7384 (gvop = ((UNOP*)gvop)->op_first) &&
7385 gvop->op_type == OP_GV)
7387 GV * const gv = cGVOPx_gv(gvop);
7388 OP * const sibling = o2->op_sibling;
7389 SV * const n = newSVpvs("");
7391 OP * const oldo2 = o2;
7395 gv_fullname4(n, gv, "", FALSE);
7396 o2 = newSVOP(OP_CONST, 0, n);
7397 op_getmad(oldo2,o2,'O');
7398 prev->op_sibling = o2;
7399 o2->op_sibling = sibling;
7415 if (contextclass++ == 0) {
7416 e = strchr(proto, ']');
7417 if (!e || e == proto)
7426 const char *p = proto;
7427 const char *const end = proto;
7429 while (*--p != '[');
7430 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
7432 gv_ename(namegv), o3);
7437 if (o3->op_type == OP_RV2GV)
7440 bad_type(arg, "symbol", gv_ename(namegv), o3);
7443 if (o3->op_type == OP_ENTERSUB)
7446 bad_type(arg, "subroutine entry", gv_ename(namegv),
7450 if (o3->op_type == OP_RV2SV ||
7451 o3->op_type == OP_PADSV ||
7452 o3->op_type == OP_HELEM ||
7453 o3->op_type == OP_AELEM ||
7454 o3->op_type == OP_THREADSV)
7457 bad_type(arg, "scalar", gv_ename(namegv), o3);
7460 if (o3->op_type == OP_RV2AV ||
7461 o3->op_type == OP_PADAV)
7464 bad_type(arg, "array", gv_ename(namegv), o3);
7467 if (o3->op_type == OP_RV2HV ||
7468 o3->op_type == OP_PADHV)
7471 bad_type(arg, "hash", gv_ename(namegv), o3);
7476 OP* const sib = kid->op_sibling;
7477 kid->op_sibling = 0;
7478 o2 = newUNOP(OP_REFGEN, 0, kid);
7479 o2->op_sibling = sib;
7480 prev->op_sibling = o2;
7482 if (contextclass && e) {
7497 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
7498 gv_ename(namegv), (void*)cv);
7503 mod(o2, OP_ENTERSUB);
7505 o2 = o2->op_sibling;
7507 if (proto && !optional && proto_end > proto &&
7508 (*proto != '@' && *proto != '%' && *proto != ';'))
7509 return too_few_arguments(o, gv_ename(namegv));
7512 OP * const oldo = o;
7516 o=newSVOP(OP_CONST, 0, newSViv(0));
7517 op_getmad(oldo,o,'O');
7523 Perl_ck_svconst(pTHX_ OP *o)
7525 PERL_UNUSED_CONTEXT;
7526 SvREADONLY_on(cSVOPo->op_sv);
7531 Perl_ck_chdir(pTHX_ OP *o)
7533 if (o->op_flags & OPf_KIDS) {
7534 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7536 if (kid && kid->op_type == OP_CONST &&
7537 (kid->op_private & OPpCONST_BARE))
7539 o->op_flags |= OPf_SPECIAL;
7540 kid->op_private &= ~OPpCONST_STRICT;
7547 Perl_ck_trunc(pTHX_ OP *o)
7549 if (o->op_flags & OPf_KIDS) {
7550 SVOP *kid = (SVOP*)cUNOPo->op_first;
7552 if (kid->op_type == OP_NULL)
7553 kid = (SVOP*)kid->op_sibling;
7554 if (kid && kid->op_type == OP_CONST &&
7555 (kid->op_private & OPpCONST_BARE))
7557 o->op_flags |= OPf_SPECIAL;
7558 kid->op_private &= ~OPpCONST_STRICT;
7565 Perl_ck_unpack(pTHX_ OP *o)
7567 OP *kid = cLISTOPo->op_first;
7568 if (kid->op_sibling) {
7569 kid = kid->op_sibling;
7570 if (!kid->op_sibling)
7571 kid->op_sibling = newDEFSVOP();
7577 Perl_ck_substr(pTHX_ OP *o)
7580 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
7581 OP *kid = cLISTOPo->op_first;
7583 if (kid->op_type == OP_NULL)
7584 kid = kid->op_sibling;
7586 kid->op_flags |= OPf_MOD;
7592 /* A peephole optimizer. We visit the ops in the order they're to execute.
7593 * See the comments at the top of this file for more details about when
7594 * peep() is called */
7597 Perl_peep(pTHX_ register OP *o)
7600 register OP* oldop = NULL;
7602 if (!o || o->op_opt)
7606 SAVEVPTR(PL_curcop);
7607 for (; o; o = o->op_next) {
7611 switch (o->op_type) {
7615 PL_curcop = ((COP*)o); /* for warnings */
7620 if (cSVOPo->op_private & OPpCONST_STRICT)
7621 no_bareword_allowed(o);
7623 case OP_METHOD_NAMED:
7624 /* Relocate sv to the pad for thread safety.
7625 * Despite being a "constant", the SV is written to,
7626 * for reference counts, sv_upgrade() etc. */
7628 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
7629 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
7630 /* If op_sv is already a PADTMP then it is being used by
7631 * some pad, so make a copy. */
7632 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
7633 SvREADONLY_on(PAD_SVl(ix));
7634 SvREFCNT_dec(cSVOPo->op_sv);
7636 else if (o->op_type == OP_CONST
7637 && cSVOPo->op_sv == &PL_sv_undef) {
7638 /* PL_sv_undef is hack - it's unsafe to store it in the
7639 AV that is the pad, because av_fetch treats values of
7640 PL_sv_undef as a "free" AV entry and will merrily
7641 replace them with a new SV, causing pad_alloc to think
7642 that this pad slot is free. (When, clearly, it is not)
7644 SvOK_off(PAD_SVl(ix));
7645 SvPADTMP_on(PAD_SVl(ix));
7646 SvREADONLY_on(PAD_SVl(ix));
7649 SvREFCNT_dec(PAD_SVl(ix));
7650 SvPADTMP_on(cSVOPo->op_sv);
7651 PAD_SETSV(ix, cSVOPo->op_sv);
7652 /* XXX I don't know how this isn't readonly already. */
7653 SvREADONLY_on(PAD_SVl(ix));
7655 cSVOPo->op_sv = NULL;
7663 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
7664 if (o->op_next->op_private & OPpTARGET_MY) {
7665 if (o->op_flags & OPf_STACKED) /* chained concats */
7666 goto ignore_optimization;
7668 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
7669 o->op_targ = o->op_next->op_targ;
7670 o->op_next->op_targ = 0;
7671 o->op_private |= OPpTARGET_MY;
7674 op_null(o->op_next);
7676 ignore_optimization:
7680 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
7682 break; /* Scalar stub must produce undef. List stub is noop */
7686 if (o->op_targ == OP_NEXTSTATE
7687 || o->op_targ == OP_DBSTATE
7688 || o->op_targ == OP_SETSTATE)
7690 PL_curcop = ((COP*)o);
7692 /* XXX: We avoid setting op_seq here to prevent later calls
7693 to peep() from mistakenly concluding that optimisation
7694 has already occurred. This doesn't fix the real problem,
7695 though (See 20010220.007). AMS 20010719 */
7696 /* op_seq functionality is now replaced by op_opt */
7697 if (oldop && o->op_next) {
7698 oldop->op_next = o->op_next;
7706 if (oldop && o->op_next) {
7707 oldop->op_next = o->op_next;
7715 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
7716 OP* const pop = (o->op_type == OP_PADAV) ?
7717 o->op_next : o->op_next->op_next;
7719 if (pop && pop->op_type == OP_CONST &&
7720 ((PL_op = pop->op_next)) &&
7721 pop->op_next->op_type == OP_AELEM &&
7722 !(pop->op_next->op_private &
7723 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
7724 (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
7729 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
7730 no_bareword_allowed(pop);
7731 if (o->op_type == OP_GV)
7732 op_null(o->op_next);
7733 op_null(pop->op_next);
7735 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
7736 o->op_next = pop->op_next->op_next;
7737 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
7738 o->op_private = (U8)i;
7739 if (o->op_type == OP_GV) {
7744 o->op_flags |= OPf_SPECIAL;
7745 o->op_type = OP_AELEMFAST;
7751 if (o->op_next->op_type == OP_RV2SV) {
7752 if (!(o->op_next->op_private & OPpDEREF)) {
7753 op_null(o->op_next);
7754 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
7756 o->op_next = o->op_next->op_next;
7757 o->op_type = OP_GVSV;
7758 o->op_ppaddr = PL_ppaddr[OP_GVSV];
7761 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
7762 GV * const gv = cGVOPo_gv;
7763 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
7764 /* XXX could check prototype here instead of just carping */
7765 SV * const sv = sv_newmortal();
7766 gv_efullname3(sv, gv, NULL);
7767 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
7768 "%"SVf"() called too early to check prototype",
7772 else if (o->op_next->op_type == OP_READLINE
7773 && o->op_next->op_next->op_type == OP_CONCAT
7774 && (o->op_next->op_next->op_flags & OPf_STACKED))
7776 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
7777 o->op_type = OP_RCATLINE;
7778 o->op_flags |= OPf_STACKED;
7779 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
7780 op_null(o->op_next->op_next);
7781 op_null(o->op_next);
7798 while (cLOGOP->op_other->op_type == OP_NULL)
7799 cLOGOP->op_other = cLOGOP->op_other->op_next;
7800 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
7806 while (cLOOP->op_redoop->op_type == OP_NULL)
7807 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
7808 peep(cLOOP->op_redoop);
7809 while (cLOOP->op_nextop->op_type == OP_NULL)
7810 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
7811 peep(cLOOP->op_nextop);
7812 while (cLOOP->op_lastop->op_type == OP_NULL)
7813 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
7814 peep(cLOOP->op_lastop);
7821 while (cPMOP->op_pmreplstart &&
7822 cPMOP->op_pmreplstart->op_type == OP_NULL)
7823 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
7824 peep(cPMOP->op_pmreplstart);
7829 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
7830 && ckWARN(WARN_SYNTAX))
7832 if (o->op_next->op_sibling) {
7833 const OPCODE type = o->op_next->op_sibling->op_type;
7834 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
7835 const line_t oldline = CopLINE(PL_curcop);
7836 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
7837 Perl_warner(aTHX_ packWARN(WARN_EXEC),
7838 "Statement unlikely to be reached");
7839 Perl_warner(aTHX_ packWARN(WARN_EXEC),
7840 "\t(Maybe you meant system() when you said exec()?)\n");
7841 CopLINE_set(PL_curcop, oldline);
7852 const char *key = NULL;
7857 if (((BINOP*)o)->op_last->op_type != OP_CONST)
7860 /* Make the CONST have a shared SV */
7861 svp = cSVOPx_svp(((BINOP*)o)->op_last);
7862 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
7863 key = SvPV_const(sv, keylen);
7864 lexname = newSVpvn_share(key,
7865 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
7871 if ((o->op_private & (OPpLVAL_INTRO)))
7874 rop = (UNOP*)((BINOP*)o)->op_first;
7875 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7877 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7878 if (!SvPAD_TYPED(lexname))
7880 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
7881 if (!fields || !GvHV(*fields))
7883 key = SvPV_const(*svp, keylen);
7884 if (!hv_fetch(GvHV(*fields), key,
7885 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
7887 Perl_croak(aTHX_ "No such class field \"%s\" "
7888 "in variable %s of type %s",
7889 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
7902 SVOP *first_key_op, *key_op;
7904 if ((o->op_private & (OPpLVAL_INTRO))
7905 /* I bet there's always a pushmark... */
7906 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
7907 /* hmmm, no optimization if list contains only one key. */
7909 rop = (UNOP*)((LISTOP*)o)->op_last;
7910 if (rop->op_type != OP_RV2HV)
7912 if (rop->op_first->op_type == OP_PADSV)
7913 /* @$hash{qw(keys here)} */
7914 rop = (UNOP*)rop->op_first;
7916 /* @{$hash}{qw(keys here)} */
7917 if (rop->op_first->op_type == OP_SCOPE
7918 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
7920 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
7926 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
7927 if (!SvPAD_TYPED(lexname))
7929 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
7930 if (!fields || !GvHV(*fields))
7932 /* Again guessing that the pushmark can be jumped over.... */
7933 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
7934 ->op_first->op_sibling;
7935 for (key_op = first_key_op; key_op;
7936 key_op = (SVOP*)key_op->op_sibling) {
7937 if (key_op->op_type != OP_CONST)
7939 svp = cSVOPx_svp(key_op);
7940 key = SvPV_const(*svp, keylen);
7941 if (!hv_fetch(GvHV(*fields), key,
7942 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
7944 Perl_croak(aTHX_ "No such class field \"%s\" "
7945 "in variable %s of type %s",
7946 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
7953 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
7957 /* check that RHS of sort is a single plain array */
7958 OP *oright = cUNOPo->op_first;
7959 if (!oright || oright->op_type != OP_PUSHMARK)
7962 /* reverse sort ... can be optimised. */
7963 if (!cUNOPo->op_sibling) {
7964 /* Nothing follows us on the list. */
7965 OP * const reverse = o->op_next;
7967 if (reverse->op_type == OP_REVERSE &&
7968 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
7969 OP * const pushmark = cUNOPx(reverse)->op_first;
7970 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
7971 && (cUNOPx(pushmark)->op_sibling == o)) {
7972 /* reverse -> pushmark -> sort */
7973 o->op_private |= OPpSORT_REVERSE;
7975 pushmark->op_next = oright->op_next;
7981 /* make @a = sort @a act in-place */
7985 oright = cUNOPx(oright)->op_sibling;
7988 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
7989 oright = cUNOPx(oright)->op_sibling;
7993 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
7994 || oright->op_next != o
7995 || (oright->op_private & OPpLVAL_INTRO)
7999 /* o2 follows the chain of op_nexts through the LHS of the
8000 * assign (if any) to the aassign op itself */
8002 if (!o2 || o2->op_type != OP_NULL)
8005 if (!o2 || o2->op_type != OP_PUSHMARK)
8008 if (o2 && o2->op_type == OP_GV)
8011 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
8012 || (o2->op_private & OPpLVAL_INTRO)
8017 if (!o2 || o2->op_type != OP_NULL)
8020 if (!o2 || o2->op_type != OP_AASSIGN
8021 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
8024 /* check that the sort is the first arg on RHS of assign */
8026 o2 = cUNOPx(o2)->op_first;
8027 if (!o2 || o2->op_type != OP_NULL)
8029 o2 = cUNOPx(o2)->op_first;
8030 if (!o2 || o2->op_type != OP_PUSHMARK)
8032 if (o2->op_sibling != o)
8035 /* check the array is the same on both sides */
8036 if (oleft->op_type == OP_RV2AV) {
8037 if (oright->op_type != OP_RV2AV
8038 || !cUNOPx(oright)->op_first
8039 || cUNOPx(oright)->op_first->op_type != OP_GV
8040 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
8041 cGVOPx_gv(cUNOPx(oright)->op_first)
8045 else if (oright->op_type != OP_PADAV
8046 || oright->op_targ != oleft->op_targ
8050 /* transfer MODishness etc from LHS arg to RHS arg */
8051 oright->op_flags = oleft->op_flags;
8052 o->op_private |= OPpSORT_INPLACE;
8054 /* excise push->gv->rv2av->null->aassign */
8055 o2 = o->op_next->op_next;
8056 op_null(o2); /* PUSHMARK */
8058 if (o2->op_type == OP_GV) {
8059 op_null(o2); /* GV */
8062 op_null(o2); /* RV2AV or PADAV */
8063 o2 = o2->op_next->op_next;
8064 op_null(o2); /* AASSIGN */
8066 o->op_next = o2->op_next;
8072 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
8074 LISTOP *enter, *exlist;
8077 enter = (LISTOP *) o->op_next;
8080 if (enter->op_type == OP_NULL) {
8081 enter = (LISTOP *) enter->op_next;
8085 /* for $a (...) will have OP_GV then OP_RV2GV here.
8086 for (...) just has an OP_GV. */
8087 if (enter->op_type == OP_GV) {
8088 gvop = (OP *) enter;
8089 enter = (LISTOP *) enter->op_next;
8092 if (enter->op_type == OP_RV2GV) {
8093 enter = (LISTOP *) enter->op_next;
8099 if (enter->op_type != OP_ENTERITER)
8102 iter = enter->op_next;
8103 if (!iter || iter->op_type != OP_ITER)
8106 expushmark = enter->op_first;
8107 if (!expushmark || expushmark->op_type != OP_NULL
8108 || expushmark->op_targ != OP_PUSHMARK)
8111 exlist = (LISTOP *) expushmark->op_sibling;
8112 if (!exlist || exlist->op_type != OP_NULL
8113 || exlist->op_targ != OP_LIST)
8116 if (exlist->op_last != o) {
8117 /* Mmm. Was expecting to point back to this op. */
8120 theirmark = exlist->op_first;
8121 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
8124 if (theirmark->op_sibling != o) {
8125 /* There's something between the mark and the reverse, eg
8126 for (1, reverse (...))
8131 ourmark = ((LISTOP *)o)->op_first;
8132 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
8135 ourlast = ((LISTOP *)o)->op_last;
8136 if (!ourlast || ourlast->op_next != o)
8139 rv2av = ourmark->op_sibling;
8140 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
8141 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
8142 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
8143 /* We're just reversing a single array. */
8144 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
8145 enter->op_flags |= OPf_STACKED;
8148 /* We don't have control over who points to theirmark, so sacrifice
8150 theirmark->op_next = ourmark->op_next;
8151 theirmark->op_flags = ourmark->op_flags;
8152 ourlast->op_next = gvop ? gvop : (OP *) enter;
8155 enter->op_private |= OPpITER_REVERSED;
8156 iter->op_private |= OPpITER_REVERSED;
8163 UNOP *refgen, *rv2cv;
8166 /* I do not understand this, but if o->op_opt isn't set to 1,
8167 various tests in ext/B/t/bytecode.t fail with no readily
8173 if ((o->op_flags && OPf_WANT) != OPf_WANT_VOID)
8176 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
8179 rv2gv = ((BINOP *)o)->op_last;
8180 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
8183 refgen = (UNOP *)((BINOP *)o)->op_first;
8185 if (!refgen || refgen->op_type != OP_REFGEN)
8188 exlist = (LISTOP *)refgen->op_first;
8189 if (!exlist || exlist->op_type != OP_NULL
8190 || exlist->op_targ != OP_LIST)
8193 if (exlist->op_first->op_type != OP_PUSHMARK)
8196 rv2cv = (UNOP*)exlist->op_last;
8198 if (rv2cv->op_type != OP_RV2CV)
8201 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
8202 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
8203 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
8205 o->op_private |= OPpASSIGN_CV_TO_GV;
8206 rv2gv->op_private |= OPpDONT_INIT_GV;
8207 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
8223 Perl_custom_op_name(pTHX_ const OP* o)
8226 const IV index = PTR2IV(o->op_ppaddr);
8230 if (!PL_custom_op_names) /* This probably shouldn't happen */
8231 return (char *)PL_op_name[OP_CUSTOM];
8233 keysv = sv_2mortal(newSViv(index));
8235 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
8237 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
8239 return SvPV_nolen(HeVAL(he));
8243 Perl_custom_op_desc(pTHX_ const OP* o)
8246 const IV index = PTR2IV(o->op_ppaddr);
8250 if (!PL_custom_op_descs)
8251 return (char *)PL_op_desc[OP_CUSTOM];
8253 keysv = sv_2mortal(newSViv(index));
8255 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
8257 return (char *)PL_op_desc[OP_CUSTOM];
8259 return SvPV_nolen(HeVAL(he));
8264 /* Efficient sub that returns a constant scalar value. */
8266 const_sv_xsub(pTHX_ CV* cv)
8273 Perl_croak(aTHX_ "usage: %s::%s()",
8274 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
8278 ST(0) = (SV*)XSANY.any_ptr;
8284 * c-indentation-style: bsd
8286 * indent-tabs-mode: t
8289 * ex: set ts=8 sts=4 sw=4 noet: