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 ? (int)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 volatile I32 type = o->op_type;
2122 volatile SV *sv = NULL;
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*)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);
2261 assert (!(curop->op_flags & OPf_SPECIAL));
2262 assert(curop->op_type == OP_RANGE);
2264 PL_tmps_floor = oldtmps_floor;
2266 o->op_type = OP_RV2AV;
2267 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2268 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2269 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2270 o->op_opt = 0; /* needs to be revisited in peep() */
2271 curop = ((UNOP*)o)->op_first;
2272 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
2274 op_getmad(curop,o,'O');
2283 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2286 if (!o || o->op_type != OP_LIST)
2287 o = newLISTOP(OP_LIST, 0, o, NULL);
2289 o->op_flags &= ~OPf_WANT;
2291 if (!(PL_opargs[type] & OA_MARK))
2292 op_null(cLISTOPo->op_first);
2294 o->op_type = (OPCODE)type;
2295 o->op_ppaddr = PL_ppaddr[type];
2296 o->op_flags |= flags;
2298 o = CHECKOP(type, o);
2299 if (o->op_type != (unsigned)type)
2302 return fold_constants(o);
2305 /* List constructors */
2308 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2316 if (first->op_type != (unsigned)type
2317 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2319 return newLISTOP(type, 0, first, last);
2322 if (first->op_flags & OPf_KIDS)
2323 ((LISTOP*)first)->op_last->op_sibling = last;
2325 first->op_flags |= OPf_KIDS;
2326 ((LISTOP*)first)->op_first = last;
2328 ((LISTOP*)first)->op_last = last;
2333 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2341 if (first->op_type != (unsigned)type)
2342 return prepend_elem(type, (OP*)first, (OP*)last);
2344 if (last->op_type != (unsigned)type)
2345 return append_elem(type, (OP*)first, (OP*)last);
2347 first->op_last->op_sibling = last->op_first;
2348 first->op_last = last->op_last;
2349 first->op_flags |= (last->op_flags & OPf_KIDS);
2352 if (last->op_first && first->op_madprop) {
2353 MADPROP *mp = last->op_first->op_madprop;
2355 while (mp->mad_next)
2357 mp->mad_next = first->op_madprop;
2360 last->op_first->op_madprop = first->op_madprop;
2363 first->op_madprop = last->op_madprop;
2364 last->op_madprop = 0;
2373 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2381 if (last->op_type == (unsigned)type) {
2382 if (type == OP_LIST) { /* already a PUSHMARK there */
2383 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2384 ((LISTOP*)last)->op_first->op_sibling = first;
2385 if (!(first->op_flags & OPf_PARENS))
2386 last->op_flags &= ~OPf_PARENS;
2389 if (!(last->op_flags & OPf_KIDS)) {
2390 ((LISTOP*)last)->op_last = first;
2391 last->op_flags |= OPf_KIDS;
2393 first->op_sibling = ((LISTOP*)last)->op_first;
2394 ((LISTOP*)last)->op_first = first;
2396 last->op_flags |= OPf_KIDS;
2400 return newLISTOP(type, 0, first, last);
2408 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2411 Newxz(tk, 1, TOKEN);
2412 tk->tk_type = (OPCODE)optype;
2413 tk->tk_type = 12345;
2415 tk->tk_mad = madprop;
2420 Perl_token_free(pTHX_ TOKEN* tk)
2422 if (tk->tk_type != 12345)
2424 mad_free(tk->tk_mad);
2429 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2433 if (tk->tk_type != 12345) {
2434 Perl_warner(aTHX_ packWARN(WARN_MISC),
2435 "Invalid TOKEN object ignored");
2442 /* faked up qw list? */
2444 tm->mad_type == MAD_SV &&
2445 SvPVX((SV*)tm->mad_val)[0] == 'q')
2452 /* pretend constant fold didn't happen? */
2453 if (mp->mad_key == 'f' &&
2454 (o->op_type == OP_CONST ||
2455 o->op_type == OP_GV) )
2457 token_getmad(tk,(OP*)mp->mad_val,slot);
2471 if (mp->mad_key == 'X')
2472 mp->mad_key = slot; /* just change the first one */
2482 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
2491 /* pretend constant fold didn't happen? */
2492 if (mp->mad_key == 'f' &&
2493 (o->op_type == OP_CONST ||
2494 o->op_type == OP_GV) )
2496 op_getmad(from,(OP*)mp->mad_val,slot);
2503 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
2506 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
2512 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
2521 /* pretend constant fold didn't happen? */
2522 if (mp->mad_key == 'f' &&
2523 (o->op_type == OP_CONST ||
2524 o->op_type == OP_GV) )
2526 op_getmad(from,(OP*)mp->mad_val,slot);
2533 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
2536 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
2540 PerlIO_printf(PerlIO_stderr(),
2541 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
2547 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
2565 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
2569 addmad(tm, &(o->op_madprop), slot);
2573 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
2594 Perl_newMADsv(pTHX_ char key, SV* sv)
2596 return newMADPROP(key, MAD_SV, sv, 0);
2600 Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
2603 Newxz(mp, 1, MADPROP);
2606 mp->mad_vlen = vlen;
2607 mp->mad_type = type;
2609 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
2614 Perl_mad_free(pTHX_ MADPROP* mp)
2616 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
2620 mad_free(mp->mad_next);
2621 /* if (PL_lex_state != LEX_NOTPARSING && mp->mad_vlen)
2622 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
2623 switch (mp->mad_type) {
2627 Safefree((char*)mp->mad_val);
2630 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
2631 op_free((OP*)mp->mad_val);
2634 sv_free((SV*)mp->mad_val);
2637 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
2646 Perl_newNULLLIST(pTHX)
2648 return newOP(OP_STUB, 0);
2652 Perl_force_list(pTHX_ OP *o)
2654 if (!o || o->op_type != OP_LIST)
2655 o = newLISTOP(OP_LIST, 0, o, NULL);
2661 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2666 NewOp(1101, listop, 1, LISTOP);
2668 listop->op_type = (OPCODE)type;
2669 listop->op_ppaddr = PL_ppaddr[type];
2672 listop->op_flags = (U8)flags;
2676 else if (!first && last)
2679 first->op_sibling = last;
2680 listop->op_first = first;
2681 listop->op_last = last;
2682 if (type == OP_LIST) {
2683 OP* const pushop = newOP(OP_PUSHMARK, 0);
2684 pushop->op_sibling = first;
2685 listop->op_first = pushop;
2686 listop->op_flags |= OPf_KIDS;
2688 listop->op_last = pushop;
2691 return CHECKOP(type, listop);
2695 Perl_newOP(pTHX_ I32 type, I32 flags)
2699 NewOp(1101, o, 1, OP);
2700 o->op_type = (OPCODE)type;
2701 o->op_ppaddr = PL_ppaddr[type];
2702 o->op_flags = (U8)flags;
2705 o->op_private = (U8)(0 | (flags >> 8));
2706 if (PL_opargs[type] & OA_RETSCALAR)
2708 if (PL_opargs[type] & OA_TARGET)
2709 o->op_targ = pad_alloc(type, SVs_PADTMP);
2710 return CHECKOP(type, o);
2714 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2720 first = newOP(OP_STUB, 0);
2721 if (PL_opargs[type] & OA_MARK)
2722 first = force_list(first);
2724 NewOp(1101, unop, 1, UNOP);
2725 unop->op_type = (OPCODE)type;
2726 unop->op_ppaddr = PL_ppaddr[type];
2727 unop->op_first = first;
2728 unop->op_flags = (U8)(flags | OPf_KIDS);
2729 unop->op_private = (U8)(1 | (flags >> 8));
2730 unop = (UNOP*) CHECKOP(type, unop);
2734 return fold_constants((OP *) unop);
2738 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2742 NewOp(1101, binop, 1, BINOP);
2745 first = newOP(OP_NULL, 0);
2747 binop->op_type = (OPCODE)type;
2748 binop->op_ppaddr = PL_ppaddr[type];
2749 binop->op_first = first;
2750 binop->op_flags = (U8)(flags | OPf_KIDS);
2753 binop->op_private = (U8)(1 | (flags >> 8));
2756 binop->op_private = (U8)(2 | (flags >> 8));
2757 first->op_sibling = last;
2760 binop = (BINOP*)CHECKOP(type, binop);
2761 if (binop->op_next || binop->op_type != (OPCODE)type)
2764 binop->op_last = binop->op_first->op_sibling;
2766 return fold_constants((OP *)binop);
2769 static int uvcompare(const void *a, const void *b)
2770 __attribute__nonnull__(1)
2771 __attribute__nonnull__(2)
2772 __attribute__pure__;
2773 static int uvcompare(const void *a, const void *b)
2775 if (*((const UV *)a) < (*(const UV *)b))
2777 if (*((const UV *)a) > (*(const UV *)b))
2779 if (*((const UV *)a+1) < (*(const UV *)b+1))
2781 if (*((const UV *)a+1) > (*(const UV *)b+1))
2787 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2790 SV * const tstr = ((SVOP*)expr)->op_sv;
2791 SV * const rstr = ((SVOP*)repl)->op_sv;
2794 const U8 *t = (U8*)SvPV_const(tstr, tlen);
2795 const U8 *r = (U8*)SvPV_const(rstr, rlen);
2799 register short *tbl;
2801 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
2802 const I32 squash = o->op_private & OPpTRANS_SQUASH;
2803 I32 del = o->op_private & OPpTRANS_DELETE;
2804 PL_hints |= HINT_BLOCK_SCOPE;
2807 o->op_private |= OPpTRANS_FROM_UTF;
2810 o->op_private |= OPpTRANS_TO_UTF;
2812 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2813 SV* const listsv = newSVpvs("# comment\n");
2815 const U8* tend = t + tlen;
2816 const U8* rend = r + rlen;
2830 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2831 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2834 const U32 flags = UTF8_ALLOW_DEFAULT;
2838 t = tsave = bytes_to_utf8(t, &len);
2841 if (!to_utf && rlen) {
2843 r = rsave = bytes_to_utf8(r, &len);
2847 /* There are several snags with this code on EBCDIC:
2848 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2849 2. scan_const() in toke.c has encoded chars in native encoding which makes
2850 ranges at least in EBCDIC 0..255 range the bottom odd.
2854 U8 tmpbuf[UTF8_MAXBYTES+1];
2857 Newx(cp, 2*tlen, UV);
2859 transv = newSVpvs("");
2861 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
2863 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2865 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
2869 cp[2*i+1] = cp[2*i];
2873 qsort(cp, i, 2*sizeof(UV), uvcompare);
2874 for (j = 0; j < i; j++) {
2876 diff = val - nextmin;
2878 t = uvuni_to_utf8(tmpbuf,nextmin);
2879 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2881 U8 range_mark = UTF_TO_NATIVE(0xff);
2882 t = uvuni_to_utf8(tmpbuf, val - 1);
2883 sv_catpvn(transv, (char *)&range_mark, 1);
2884 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2891 t = uvuni_to_utf8(tmpbuf,nextmin);
2892 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2894 U8 range_mark = UTF_TO_NATIVE(0xff);
2895 sv_catpvn(transv, (char *)&range_mark, 1);
2897 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2898 UNICODE_ALLOW_SUPER);
2899 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2900 t = (const U8*)SvPVX_const(transv);
2901 tlen = SvCUR(transv);
2905 else if (!rlen && !del) {
2906 r = t; rlen = tlen; rend = tend;
2909 if ((!rlen && !del) || t == r ||
2910 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2912 o->op_private |= OPpTRANS_IDENTICAL;
2916 while (t < tend || tfirst <= tlast) {
2917 /* see if we need more "t" chars */
2918 if (tfirst > tlast) {
2919 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
2921 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2923 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
2930 /* now see if we need more "r" chars */
2931 if (rfirst > rlast) {
2933 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
2935 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2937 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
2946 rfirst = rlast = 0xffffffff;
2950 /* now see which range will peter our first, if either. */
2951 tdiff = tlast - tfirst;
2952 rdiff = rlast - rfirst;
2959 if (rfirst == 0xffffffff) {
2960 diff = tdiff; /* oops, pretend rdiff is infinite */
2962 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2963 (long)tfirst, (long)tlast);
2965 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2969 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2970 (long)tfirst, (long)(tfirst + diff),
2973 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2974 (long)tfirst, (long)rfirst);
2976 if (rfirst + diff > max)
2977 max = rfirst + diff;
2979 grows = (tfirst < rfirst &&
2980 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2992 else if (max > 0xff)
2997 Safefree(cPVOPo->op_pv);
2998 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2999 SvREFCNT_dec(listsv);
3000 SvREFCNT_dec(transv);
3002 if (!del && havefinal && rlen)
3003 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
3004 newSVuv((UV)final), 0);
3007 o->op_private |= OPpTRANS_GROWS;
3013 op_getmad(expr,o,'e');
3014 op_getmad(repl,o,'r');
3022 tbl = (short*)cPVOPo->op_pv;
3024 Zero(tbl, 256, short);
3025 for (i = 0; i < (I32)tlen; i++)
3027 for (i = 0, j = 0; i < 256; i++) {
3029 if (j >= (I32)rlen) {
3038 if (i < 128 && r[j] >= 128)
3048 o->op_private |= OPpTRANS_IDENTICAL;
3050 else if (j >= (I32)rlen)
3053 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
3054 tbl[0x100] = (short)(rlen - j);
3055 for (i=0; i < (I32)rlen - j; i++)
3056 tbl[0x101+i] = r[j+i];
3060 if (!rlen && !del) {
3063 o->op_private |= OPpTRANS_IDENTICAL;
3065 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3066 o->op_private |= OPpTRANS_IDENTICAL;
3068 for (i = 0; i < 256; i++)
3070 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3071 if (j >= (I32)rlen) {
3073 if (tbl[t[i]] == -1)
3079 if (tbl[t[i]] == -1) {
3080 if (t[i] < 128 && r[j] >= 128)
3087 o->op_private |= OPpTRANS_GROWS;
3089 op_getmad(expr,o,'e');
3090 op_getmad(repl,o,'r');
3100 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3105 NewOp(1101, pmop, 1, PMOP);
3106 pmop->op_type = (OPCODE)type;
3107 pmop->op_ppaddr = PL_ppaddr[type];
3108 pmop->op_flags = (U8)flags;
3109 pmop->op_private = (U8)(0 | (flags >> 8));
3111 if (PL_hints & HINT_RE_TAINT)
3112 pmop->op_pmpermflags |= PMf_RETAINT;
3113 if (PL_hints & HINT_LOCALE)
3114 pmop->op_pmpermflags |= PMf_LOCALE;
3115 pmop->op_pmflags = pmop->op_pmpermflags;
3118 if (av_len((AV*) PL_regex_pad[0]) > -1) {
3119 SV * const repointer = av_pop((AV*)PL_regex_pad[0]);
3120 pmop->op_pmoffset = SvIV(repointer);
3121 SvREPADTMP_off(repointer);
3122 sv_setiv(repointer,0);
3124 SV * const repointer = newSViv(0);
3125 av_push(PL_regex_padav, SvREFCNT_inc_simple_NN(repointer));
3126 pmop->op_pmoffset = av_len(PL_regex_padav);
3127 PL_regex_pad = AvARRAY(PL_regex_padav);
3131 /* link into pm list */
3132 if (type != OP_TRANS && PL_curstash) {
3133 MAGIC *mg = mg_find((SV*)PL_curstash, PERL_MAGIC_symtab);
3136 mg = sv_magicext((SV*)PL_curstash, 0, PERL_MAGIC_symtab, 0, 0, 0);
3138 pmop->op_pmnext = (PMOP*)mg->mg_obj;
3139 mg->mg_obj = (SV*)pmop;
3140 PmopSTASH_set(pmop,PL_curstash);
3143 return CHECKOP(type, pmop);
3146 /* Given some sort of match op o, and an expression expr containing a
3147 * pattern, either compile expr into a regex and attach it to o (if it's
3148 * constant), or convert expr into a runtime regcomp op sequence (if it's
3151 * isreg indicates that the pattern is part of a regex construct, eg
3152 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3153 * split "pattern", which aren't. In the former case, expr will be a list
3154 * if the pattern contains more than one term (eg /a$b/) or if it contains
3155 * a replacement, ie s/// or tr///.
3159 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
3164 I32 repl_has_vars = 0;
3168 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
3169 /* last element in list is the replacement; pop it */
3171 repl = cLISTOPx(expr)->op_last;
3172 kid = cLISTOPx(expr)->op_first;
3173 while (kid->op_sibling != repl)
3174 kid = kid->op_sibling;
3175 kid->op_sibling = NULL;
3176 cLISTOPx(expr)->op_last = kid;
3179 if (isreg && expr->op_type == OP_LIST &&
3180 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3182 /* convert single element list to element */
3183 OP* const oe = expr;
3184 expr = cLISTOPx(oe)->op_first->op_sibling;
3185 cLISTOPx(oe)->op_first->op_sibling = NULL;
3186 cLISTOPx(oe)->op_last = NULL;
3190 if (o->op_type == OP_TRANS) {
3191 return pmtrans(o, expr, repl);
3194 reglist = isreg && expr->op_type == OP_LIST;
3198 PL_hints |= HINT_BLOCK_SCOPE;
3201 if (expr->op_type == OP_CONST) {
3203 SV * const pat = ((SVOP*)expr)->op_sv;
3204 const char *p = SvPV_const(pat, plen);
3205 if ((o->op_flags & OPf_SPECIAL) && (*p == ' ' && p[1] == '\0')) {
3206 U32 was_readonly = SvREADONLY(pat);
3210 sv_force_normal_flags(pat, 0);
3211 assert(!SvREADONLY(pat));
3214 SvREADONLY_off(pat);
3218 sv_setpvn(pat, "\\s+", 3);
3220 SvFLAGS(pat) |= was_readonly;
3222 p = SvPV_const(pat, plen);
3223 pm->op_pmflags |= PMf_SKIPWHITE;
3226 pm->op_pmdynflags |= PMdf_UTF8;
3227 /* FIXME - can we make this function take const char * args? */
3228 PM_SETRE(pm, CALLREGCOMP((char*)p, (char*)p + plen, pm));
3229 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
3230 pm->op_pmflags |= PMf_WHITE;
3232 op_getmad(expr,(OP*)pm,'e');
3238 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3239 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3241 : OP_REGCMAYBE),0,expr);
3243 NewOp(1101, rcop, 1, LOGOP);
3244 rcop->op_type = OP_REGCOMP;
3245 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3246 rcop->op_first = scalar(expr);
3247 rcop->op_flags |= OPf_KIDS
3248 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3249 | (reglist ? OPf_STACKED : 0);
3250 rcop->op_private = 1;
3253 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3255 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
3258 /* establish postfix order */
3259 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3261 rcop->op_next = expr;
3262 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3265 rcop->op_next = LINKLIST(expr);
3266 expr->op_next = (OP*)rcop;
3269 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3274 if (pm->op_pmflags & PMf_EVAL) {
3276 if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
3277 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
3279 else if (repl->op_type == OP_CONST)
3283 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3284 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3285 if (curop->op_type == OP_GV) {
3286 GV * const gv = cGVOPx_gv(curop);
3288 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3291 else if (curop->op_type == OP_RV2CV)
3293 else if (curop->op_type == OP_RV2SV ||
3294 curop->op_type == OP_RV2AV ||
3295 curop->op_type == OP_RV2HV ||
3296 curop->op_type == OP_RV2GV) {
3297 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3300 else if (curop->op_type == OP_PADSV ||
3301 curop->op_type == OP_PADAV ||
3302 curop->op_type == OP_PADHV ||
3303 curop->op_type == OP_PADANY) {
3306 else if (curop->op_type == OP_PUSHRE)
3307 NOOP; /* Okay here, dangerous in newASSIGNOP */
3317 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
3318 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3319 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
3320 prepend_elem(o->op_type, scalar(repl), o);
3323 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3324 pm->op_pmflags |= PMf_MAYBE_CONST;
3325 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3327 NewOp(1101, rcop, 1, LOGOP);
3328 rcop->op_type = OP_SUBSTCONT;
3329 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3330 rcop->op_first = scalar(repl);
3331 rcop->op_flags |= OPf_KIDS;
3332 rcop->op_private = 1;
3335 /* establish postfix order */
3336 rcop->op_next = LINKLIST(repl);
3337 repl->op_next = (OP*)rcop;
3339 pm->op_pmreplroot = scalar((OP*)rcop);
3340 pm->op_pmreplstart = LINKLIST(rcop);
3349 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3353 NewOp(1101, svop, 1, SVOP);
3354 svop->op_type = (OPCODE)type;
3355 svop->op_ppaddr = PL_ppaddr[type];
3357 svop->op_next = (OP*)svop;
3358 svop->op_flags = (U8)flags;
3359 if (PL_opargs[type] & OA_RETSCALAR)
3361 if (PL_opargs[type] & OA_TARGET)
3362 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3363 return CHECKOP(type, svop);
3367 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3371 NewOp(1101, padop, 1, PADOP);
3372 padop->op_type = (OPCODE)type;
3373 padop->op_ppaddr = PL_ppaddr[type];
3374 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3375 SvREFCNT_dec(PAD_SVl(padop->op_padix));
3376 PAD_SETSV(padop->op_padix, sv);
3379 padop->op_next = (OP*)padop;
3380 padop->op_flags = (U8)flags;
3381 if (PL_opargs[type] & OA_RETSCALAR)
3383 if (PL_opargs[type] & OA_TARGET)
3384 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3385 return CHECKOP(type, padop);
3389 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3395 return newPADOP(type, flags, SvREFCNT_inc_simple(gv));
3397 return newSVOP(type, flags, SvREFCNT_inc_simple(gv));
3402 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3406 NewOp(1101, pvop, 1, PVOP);
3407 pvop->op_type = (OPCODE)type;
3408 pvop->op_ppaddr = PL_ppaddr[type];
3410 pvop->op_next = (OP*)pvop;
3411 pvop->op_flags = (U8)flags;
3412 if (PL_opargs[type] & OA_RETSCALAR)
3414 if (PL_opargs[type] & OA_TARGET)
3415 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3416 return CHECKOP(type, pvop);
3424 Perl_package(pTHX_ OP *o)
3433 save_hptr(&PL_curstash);
3434 save_item(PL_curstname);
3436 name = SvPV_const(cSVOPo->op_sv, len);
3437 PL_curstash = gv_stashpvn(name, len, TRUE);
3438 sv_setpvn(PL_curstname, name, len);
3440 PL_hints |= HINT_BLOCK_SCOPE;
3441 PL_copline = NOLINE;
3447 if (!PL_madskills) {
3452 pegop = newOP(OP_NULL,0);
3453 op_getmad(o,pegop,'P');
3463 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3470 OP *pegop = newOP(OP_NULL,0);
3473 if (idop->op_type != OP_CONST)
3474 Perl_croak(aTHX_ "Module name must be constant");
3477 op_getmad(idop,pegop,'U');
3482 SV * const vesv = ((SVOP*)version)->op_sv;
3485 op_getmad(version,pegop,'V');
3486 if (!arg && !SvNIOKp(vesv)) {
3493 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3494 Perl_croak(aTHX_ "Version number must be constant number");
3496 /* Make copy of idop so we don't free it twice */
3497 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3499 /* Fake up a method call to VERSION */
3500 meth = newSVpvs_share("VERSION");
3501 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3502 append_elem(OP_LIST,
3503 prepend_elem(OP_LIST, pack, list(version)),
3504 newSVOP(OP_METHOD_NAMED, 0, meth)));
3508 /* Fake up an import/unimport */
3509 if (arg && arg->op_type == OP_STUB) {
3511 op_getmad(arg,pegop,'S');
3512 imop = arg; /* no import on explicit () */
3514 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3515 imop = NULL; /* use 5.0; */
3517 idop->op_private |= OPpCONST_NOVER;
3523 op_getmad(arg,pegop,'A');
3525 /* Make copy of idop so we don't free it twice */
3526 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3528 /* Fake up a method call to import/unimport */
3530 ? newSVpvs_share("import") : newSVpvs_share("unimport");
3531 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3532 append_elem(OP_LIST,
3533 prepend_elem(OP_LIST, pack, list(arg)),
3534 newSVOP(OP_METHOD_NAMED, 0, meth)));
3537 /* Fake up the BEGIN {}, which does its thing immediately. */
3539 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
3542 append_elem(OP_LINESEQ,
3543 append_elem(OP_LINESEQ,
3544 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
3545 newSTATEOP(0, NULL, veop)),
3546 newSTATEOP(0, NULL, imop) ));
3548 /* The "did you use incorrect case?" warning used to be here.
3549 * The problem is that on case-insensitive filesystems one
3550 * might get false positives for "use" (and "require"):
3551 * "use Strict" or "require CARP" will work. This causes
3552 * portability problems for the script: in case-strict
3553 * filesystems the script will stop working.
3555 * The "incorrect case" warning checked whether "use Foo"
3556 * imported "Foo" to your namespace, but that is wrong, too:
3557 * there is no requirement nor promise in the language that
3558 * a Foo.pm should or would contain anything in package "Foo".
3560 * There is very little Configure-wise that can be done, either:
3561 * the case-sensitivity of the build filesystem of Perl does not
3562 * help in guessing the case-sensitivity of the runtime environment.
3565 PL_hints |= HINT_BLOCK_SCOPE;
3566 PL_copline = NOLINE;
3568 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3571 if (!PL_madskills) {
3572 /* FIXME - don't allocate pegop if !PL_madskills */
3581 =head1 Embedding Functions
3583 =for apidoc load_module
3585 Loads the module whose name is pointed to by the string part of name.
3586 Note that the actual module name, not its filename, should be given.
3587 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3588 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3589 (or 0 for no flags). ver, if specified, provides version semantics
3590 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3591 arguments can be used to specify arguments to the module's import()
3592 method, similar to C<use Foo::Bar VERSION LIST>.
3597 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3600 va_start(args, ver);
3601 vload_module(flags, name, ver, &args);
3605 #ifdef PERL_IMPLICIT_CONTEXT
3607 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3611 va_start(args, ver);
3612 vload_module(flags, name, ver, &args);
3618 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3623 OP * const modname = newSVOP(OP_CONST, 0, name);
3624 modname->op_private |= OPpCONST_BARE;
3626 veop = newSVOP(OP_CONST, 0, ver);
3630 if (flags & PERL_LOADMOD_NOIMPORT) {
3631 imop = sawparens(newNULLLIST());
3633 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3634 imop = va_arg(*args, OP*);
3639 sv = va_arg(*args, SV*);
3641 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3642 sv = va_arg(*args, SV*);
3646 const line_t ocopline = PL_copline;
3647 COP * const ocurcop = PL_curcop;
3648 const int oexpect = PL_expect;
3650 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3651 veop, modname, imop);
3652 PL_expect = oexpect;
3653 PL_copline = ocopline;
3654 PL_curcop = ocurcop;
3659 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
3665 if (!force_builtin) {
3666 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
3667 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
3668 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
3669 gv = gvp ? *gvp : NULL;
3673 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3674 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3675 append_elem(OP_LIST, term,
3676 scalar(newUNOP(OP_RV2CV, 0,
3677 newGVOP(OP_GV, 0, gv))))));
3680 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3686 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3688 return newBINOP(OP_LSLICE, flags,
3689 list(force_list(subscript)),
3690 list(force_list(listval)) );
3694 S_is_list_assignment(pTHX_ register const OP *o)
3702 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
3703 o = cUNOPo->op_first;
3705 flags = o->op_flags;
3707 if (type == OP_COND_EXPR) {
3708 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
3709 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3714 yyerror("Assignment to both a list and a scalar");
3718 if (type == OP_LIST &&
3719 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
3720 o->op_private & OPpLVAL_INTRO)
3723 if (type == OP_LIST || flags & OPf_PARENS ||
3724 type == OP_RV2AV || type == OP_RV2HV ||
3725 type == OP_ASLICE || type == OP_HSLICE)
3728 if (type == OP_PADAV || type == OP_PADHV)
3731 if (type == OP_RV2SV)
3738 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3744 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3745 return newLOGOP(optype, 0,
3746 mod(scalar(left), optype),
3747 newUNOP(OP_SASSIGN, 0, scalar(right)));
3750 return newBINOP(optype, OPf_STACKED,
3751 mod(scalar(left), optype), scalar(right));
3755 if (is_list_assignment(left)) {
3759 /* Grandfathering $[ assignment here. Bletch.*/
3760 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
3761 PL_eval_start = (left->op_type == OP_CONST) ? right : 0;
3762 left = mod(left, OP_AASSIGN);
3765 else if (left->op_type == OP_CONST) {
3767 /* Result of assignment is always 1 (or we'd be dead already) */
3768 return newSVOP(OP_CONST, 0, newSViv(1));
3770 curop = list(force_list(left));
3771 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3772 o->op_private = (U8)(0 | (flags >> 8));
3774 /* PL_generation sorcery:
3775 * an assignment like ($a,$b) = ($c,$d) is easier than
3776 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3777 * To detect whether there are common vars, the global var
3778 * PL_generation is incremented for each assign op we compile.
3779 * Then, while compiling the assign op, we run through all the
3780 * variables on both sides of the assignment, setting a spare slot
3781 * in each of them to PL_generation. If any of them already have
3782 * that value, we know we've got commonality. We could use a
3783 * single bit marker, but then we'd have to make 2 passes, first
3784 * to clear the flag, then to test and set it. To find somewhere
3785 * to store these values, evil chicanery is done with SvCUR().
3791 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3792 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3793 if (curop->op_type == OP_GV) {
3794 GV *gv = cGVOPx_gv(curop);
3796 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
3798 GvASSIGN_GENERATION_set(gv, PL_generation);
3800 else if (curop->op_type == OP_PADSV ||
3801 curop->op_type == OP_PADAV ||
3802 curop->op_type == OP_PADHV ||
3803 curop->op_type == OP_PADANY)
3805 if (PAD_COMPNAME_GEN(curop->op_targ)
3806 == (STRLEN)PL_generation)
3808 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
3811 else if (curop->op_type == OP_RV2CV)
3813 else if (curop->op_type == OP_RV2SV ||
3814 curop->op_type == OP_RV2AV ||
3815 curop->op_type == OP_RV2HV ||
3816 curop->op_type == OP_RV2GV) {
3817 if (lastop->op_type != OP_GV) /* funny deref? */
3820 else if (curop->op_type == OP_PUSHRE) {
3821 if (((PMOP*)curop)->op_pmreplroot) {
3823 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3824 ((PMOP*)curop)->op_pmreplroot));
3826 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3829 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
3831 GvASSIGN_GENERATION_set(gv, PL_generation);
3832 GvASSIGN_GENERATION_set(gv, PL_generation);
3841 o->op_private |= OPpASSIGN_COMMON;
3844 if ( ((left->op_private & OPpLVAL_INTRO) || ckWARN(WARN_MISC))
3845 && (left->op_type == OP_LIST
3846 || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
3848 OP* lop = ((LISTOP*)left)->op_first;
3850 if (lop->op_type == OP_PADSV ||
3851 lop->op_type == OP_PADAV ||
3852 lop->op_type == OP_PADHV ||
3853 lop->op_type == OP_PADANY)
3855 if (lop->op_private & OPpPAD_STATE) {
3856 if (left->op_private & OPpLVAL_INTRO) {
3857 o->op_private |= OPpASSIGN_STATE;
3858 /* hijacking PADSTALE for uninitialized state variables */
3859 SvPADSTALE_on(PAD_SVl(lop->op_targ));
3861 else { /* we already checked for WARN_MISC before */
3862 Perl_warner(aTHX_ packWARN(WARN_MISC), "State variable %s will be reinitialized",
3863 PAD_COMPNAME_PV(lop->op_targ));
3867 lop = lop->op_sibling;
3871 if (right && right->op_type == OP_SPLIT) {
3872 OP* tmpop = ((LISTOP*)right)->op_first;
3873 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
3874 PMOP * const pm = (PMOP*)tmpop;
3875 if (left->op_type == OP_RV2AV &&
3876 !(left->op_private & OPpLVAL_INTRO) &&
3877 !(o->op_private & OPpASSIGN_COMMON) )
3879 tmpop = ((UNOP*)left)->op_first;
3880 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3882 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3883 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3885 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3886 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
3888 pm->op_pmflags |= PMf_ONCE;
3889 tmpop = cUNOPo->op_first; /* to list (nulled) */
3890 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3891 tmpop->op_sibling = NULL; /* don't free split */
3892 right->op_next = tmpop->op_next; /* fix starting loc */
3894 op_getmad(o,right,'R'); /* blow off assign */
3896 op_free(o); /* blow off assign */
3898 right->op_flags &= ~OPf_WANT;
3899 /* "I don't know and I don't care." */
3904 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3905 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3907 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3909 sv_setiv(sv, PL_modcount+1);
3917 right = newOP(OP_UNDEF, 0);
3918 if (right->op_type == OP_READLINE) {
3919 right->op_flags |= OPf_STACKED;
3920 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3923 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3924 o = newBINOP(OP_SASSIGN, flags,
3925 scalar(right), mod(scalar(left), OP_SASSIGN) );
3931 o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
3932 o->op_private |= OPpCONST_ARYBASE;
3939 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3942 const U32 seq = intro_my();
3945 NewOp(1101, cop, 1, COP);
3946 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3947 cop->op_type = OP_DBSTATE;
3948 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3951 cop->op_type = OP_NEXTSTATE;
3952 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3954 cop->op_flags = (U8)flags;
3955 CopHINTS_set(cop, PL_hints);
3957 cop->op_private |= NATIVE_HINTS;
3959 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
3960 cop->op_next = (OP*)cop;
3963 cop->cop_label = label;
3964 PL_hints |= HINT_BLOCK_SCOPE;
3967 /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
3968 CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
3970 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
3971 cop->cop_hints_hash = PL_curcop->cop_hints_hash;
3972 if (cop->cop_hints_hash) {
3974 cop->cop_hints_hash->refcounted_he_refcnt++;
3975 HINTS_REFCNT_UNLOCK;
3978 if (PL_copline == NOLINE)
3979 CopLINE_set(cop, CopLINE(PL_curcop));
3981 CopLINE_set(cop, PL_copline);
3982 PL_copline = NOLINE;
3985 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3987 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3989 CopSTASH_set(cop, PL_curstash);
3991 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3992 SV * const * const svp = av_fetch(CopFILEAVx(PL_curcop), (I32)CopLINE(cop), FALSE);
3993 if (svp && *svp != &PL_sv_undef ) {
3994 (void)SvIOK_on(*svp);
3995 SvIV_set(*svp, PTR2IV(cop));
3999 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
4004 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
4007 return new_logop(type, flags, &first, &other);
4011 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
4016 OP *first = *firstp;
4017 OP * const other = *otherp;
4019 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
4020 return newBINOP(type, flags, scalar(first), scalar(other));
4022 scalarboolean(first);
4023 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
4024 if (first->op_type == OP_NOT
4025 && (first->op_flags & OPf_SPECIAL)
4026 && (first->op_flags & OPf_KIDS)) {
4027 if (type == OP_AND || type == OP_OR) {
4033 first = *firstp = cUNOPo->op_first;
4035 first->op_next = o->op_next;
4036 cUNOPo->op_first = NULL;
4038 op_getmad(o,first,'O');
4044 if (first->op_type == OP_CONST) {
4045 if (first->op_private & OPpCONST_STRICT)
4046 no_bareword_allowed(first);
4047 else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
4048 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
4049 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
4050 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
4051 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
4053 if (other->op_type == OP_CONST)
4054 other->op_private |= OPpCONST_SHORTCIRCUIT;
4056 OP *newop = newUNOP(OP_NULL, 0, other);
4057 op_getmad(first, newop, '1');
4058 newop->op_targ = type; /* set "was" field */
4065 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
4066 const OP *o2 = other;
4067 if ( ! (o2->op_type == OP_LIST
4068 && (( o2 = cUNOPx(o2)->op_first))
4069 && o2->op_type == OP_PUSHMARK
4070 && (( o2 = o2->op_sibling)) )
4073 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
4074 || o2->op_type == OP_PADHV)
4075 && o2->op_private & OPpLVAL_INTRO
4076 && ckWARN(WARN_DEPRECATED))
4078 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4079 "Deprecated use of my() in false conditional");
4083 if (first->op_type == OP_CONST)
4084 first->op_private |= OPpCONST_SHORTCIRCUIT;
4086 first = newUNOP(OP_NULL, 0, first);
4087 op_getmad(other, first, '2');
4088 first->op_targ = type; /* set "was" field */
4095 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
4096 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
4098 const OP * const k1 = ((UNOP*)first)->op_first;
4099 const OP * const k2 = k1->op_sibling;
4101 switch (first->op_type)
4104 if (k2 && k2->op_type == OP_READLINE
4105 && (k2->op_flags & OPf_STACKED)
4106 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4108 warnop = k2->op_type;
4113 if (k1->op_type == OP_READDIR
4114 || k1->op_type == OP_GLOB
4115 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4116 || k1->op_type == OP_EACH)
4118 warnop = ((k1->op_type == OP_NULL)
4119 ? (OPCODE)k1->op_targ : k1->op_type);
4124 const line_t oldline = CopLINE(PL_curcop);
4125 CopLINE_set(PL_curcop, PL_copline);
4126 Perl_warner(aTHX_ packWARN(WARN_MISC),
4127 "Value of %s%s can be \"0\"; test with defined()",
4129 ((warnop == OP_READLINE || warnop == OP_GLOB)
4130 ? " construct" : "() operator"));
4131 CopLINE_set(PL_curcop, oldline);
4138 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
4139 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
4141 NewOp(1101, logop, 1, LOGOP);
4143 logop->op_type = (OPCODE)type;
4144 logop->op_ppaddr = PL_ppaddr[type];
4145 logop->op_first = first;
4146 logop->op_flags = (U8)(flags | OPf_KIDS);
4147 logop->op_other = LINKLIST(other);
4148 logop->op_private = (U8)(1 | (flags >> 8));
4150 /* establish postfix order */
4151 logop->op_next = LINKLIST(first);
4152 first->op_next = (OP*)logop;
4153 first->op_sibling = other;
4155 CHECKOP(type,logop);
4157 o = newUNOP(OP_NULL, 0, (OP*)logop);
4164 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
4172 return newLOGOP(OP_AND, 0, first, trueop);
4174 return newLOGOP(OP_OR, 0, first, falseop);
4176 scalarboolean(first);
4177 if (first->op_type == OP_CONST) {
4178 if (first->op_private & OPpCONST_BARE &&
4179 first->op_private & OPpCONST_STRICT) {
4180 no_bareword_allowed(first);
4182 if (SvTRUE(((SVOP*)first)->op_sv)) {
4185 trueop = newUNOP(OP_NULL, 0, trueop);
4186 op_getmad(first,trueop,'C');
4187 op_getmad(falseop,trueop,'e');
4189 /* FIXME for MAD - should there be an ELSE here? */
4199 falseop = newUNOP(OP_NULL, 0, falseop);
4200 op_getmad(first,falseop,'C');
4201 op_getmad(trueop,falseop,'t');
4203 /* FIXME for MAD - should there be an ELSE here? */
4211 NewOp(1101, logop, 1, LOGOP);
4212 logop->op_type = OP_COND_EXPR;
4213 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4214 logop->op_first = first;
4215 logop->op_flags = (U8)(flags | OPf_KIDS);
4216 logop->op_private = (U8)(1 | (flags >> 8));
4217 logop->op_other = LINKLIST(trueop);
4218 logop->op_next = LINKLIST(falseop);
4220 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
4223 /* establish postfix order */
4224 start = LINKLIST(first);
4225 first->op_next = (OP*)logop;
4227 first->op_sibling = trueop;
4228 trueop->op_sibling = falseop;
4229 o = newUNOP(OP_NULL, 0, (OP*)logop);
4231 trueop->op_next = falseop->op_next = o;
4238 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4247 NewOp(1101, range, 1, LOGOP);
4249 range->op_type = OP_RANGE;
4250 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4251 range->op_first = left;
4252 range->op_flags = OPf_KIDS;
4253 leftstart = LINKLIST(left);
4254 range->op_other = LINKLIST(right);
4255 range->op_private = (U8)(1 | (flags >> 8));
4257 left->op_sibling = right;
4259 range->op_next = (OP*)range;
4260 flip = newUNOP(OP_FLIP, flags, (OP*)range);
4261 flop = newUNOP(OP_FLOP, 0, flip);
4262 o = newUNOP(OP_NULL, 0, flop);
4264 range->op_next = leftstart;
4266 left->op_next = flip;
4267 right->op_next = flop;
4269 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4270 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4271 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4272 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4274 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4275 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4278 if (!flip->op_private || !flop->op_private)
4279 linklist(o); /* blow off optimizer unless constant */
4285 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4290 const bool once = block && block->op_flags & OPf_SPECIAL &&
4291 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4293 PERL_UNUSED_ARG(debuggable);
4296 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4297 return block; /* do {} while 0 does once */
4298 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4299 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4300 expr = newUNOP(OP_DEFINED, 0,
4301 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4302 } else if (expr->op_flags & OPf_KIDS) {
4303 const OP * const k1 = ((UNOP*)expr)->op_first;
4304 const OP * const k2 = k1 ? k1->op_sibling : NULL;
4305 switch (expr->op_type) {
4307 if (k2 && k2->op_type == OP_READLINE
4308 && (k2->op_flags & OPf_STACKED)
4309 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4310 expr = newUNOP(OP_DEFINED, 0, expr);
4314 if (k1 && (k1->op_type == OP_READDIR
4315 || k1->op_type == OP_GLOB
4316 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4317 || k1->op_type == OP_EACH))
4318 expr = newUNOP(OP_DEFINED, 0, expr);
4324 /* if block is null, the next append_elem() would put UNSTACK, a scalar
4325 * op, in listop. This is wrong. [perl #27024] */
4327 block = newOP(OP_NULL, 0);
4328 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4329 o = new_logop(OP_AND, 0, &expr, &listop);
4332 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4334 if (once && o != listop)
4335 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4338 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
4340 o->op_flags |= flags;
4342 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4347 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
4348 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
4357 PERL_UNUSED_ARG(debuggable);
4360 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4361 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4362 expr = newUNOP(OP_DEFINED, 0,
4363 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4364 } else if (expr->op_flags & OPf_KIDS) {
4365 const OP * const k1 = ((UNOP*)expr)->op_first;
4366 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
4367 switch (expr->op_type) {
4369 if (k2 && k2->op_type == OP_READLINE
4370 && (k2->op_flags & OPf_STACKED)
4371 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4372 expr = newUNOP(OP_DEFINED, 0, expr);
4376 if (k1 && (k1->op_type == OP_READDIR
4377 || k1->op_type == OP_GLOB
4378 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4379 || k1->op_type == OP_EACH))
4380 expr = newUNOP(OP_DEFINED, 0, expr);
4387 block = newOP(OP_NULL, 0);
4388 else if (cont || has_my) {
4389 block = scope(block);
4393 next = LINKLIST(cont);
4396 OP * const unstack = newOP(OP_UNSTACK, 0);
4399 cont = append_elem(OP_LINESEQ, cont, unstack);
4403 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4405 redo = LINKLIST(listop);
4408 PL_copline = (line_t)whileline;
4410 o = new_logop(OP_AND, 0, &expr, &listop);
4411 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4412 op_free(expr); /* oops, it's a while (0) */
4414 return NULL; /* listop already freed by new_logop */
4417 ((LISTOP*)listop)->op_last->op_next =
4418 (o == listop ? redo : LINKLIST(o));
4424 NewOp(1101,loop,1,LOOP);
4425 loop->op_type = OP_ENTERLOOP;
4426 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4427 loop->op_private = 0;
4428 loop->op_next = (OP*)loop;
4431 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4433 loop->op_redoop = redo;
4434 loop->op_lastop = o;
4435 o->op_private |= loopflags;
4438 loop->op_nextop = next;
4440 loop->op_nextop = o;
4442 o->op_flags |= flags;
4443 o->op_private |= (flags >> 8);
4448 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
4453 PADOFFSET padoff = 0;
4459 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4460 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
4461 sv->op_type = OP_RV2GV;
4462 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4463 if (cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
4464 iterpflags |= OPpITER_DEF;
4466 else if (sv->op_type == OP_PADSV) { /* private variable */
4467 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
4468 padoff = sv->op_targ;
4477 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4478 padoff = sv->op_targ;
4483 iterflags |= OPf_SPECIAL;
4489 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4490 if (padoff && strEQ(PAD_COMPNAME_PV(padoff), "$_"))
4491 iterpflags |= OPpITER_DEF;
4494 const PADOFFSET offset = pad_findmy("$_");
4495 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
4496 sv = newGVOP(OP_GV, 0, PL_defgv);
4501 iterpflags |= OPpITER_DEF;
4503 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4504 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4505 iterflags |= OPf_STACKED;
4507 else if (expr->op_type == OP_NULL &&
4508 (expr->op_flags & OPf_KIDS) &&
4509 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4511 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4512 * set the STACKED flag to indicate that these values are to be
4513 * treated as min/max values by 'pp_iterinit'.
4515 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4516 LOGOP* const range = (LOGOP*) flip->op_first;
4517 OP* const left = range->op_first;
4518 OP* const right = left->op_sibling;
4521 range->op_flags &= ~OPf_KIDS;
4522 range->op_first = NULL;
4524 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4525 listop->op_first->op_next = range->op_next;
4526 left->op_next = range->op_other;
4527 right->op_next = (OP*)listop;
4528 listop->op_next = listop->op_first;
4531 op_getmad(expr,(OP*)listop,'O');
4535 expr = (OP*)(listop);
4537 iterflags |= OPf_STACKED;
4540 expr = mod(force_list(expr), OP_GREPSTART);
4543 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4544 append_elem(OP_LIST, expr, scalar(sv))));
4545 assert(!loop->op_next);
4546 /* for my $x () sets OPpLVAL_INTRO;
4547 * for our $x () sets OPpOUR_INTRO */
4548 loop->op_private = (U8)iterpflags;
4549 #ifdef PL_OP_SLAB_ALLOC
4552 NewOp(1234,tmp,1,LOOP);
4553 Copy(loop,tmp,1,LISTOP);
4558 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
4560 loop->op_targ = padoff;
4561 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
4563 op_getmad(madsv, (OP*)loop, 'v');
4564 PL_copline = forline;
4565 return newSTATEOP(0, label, wop);
4569 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4574 if (type != OP_GOTO || label->op_type == OP_CONST) {
4575 /* "last()" means "last" */
4576 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4577 o = newOP(type, OPf_SPECIAL);
4579 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4580 ? SvPVx_nolen_const(((SVOP*)label)->op_sv)
4584 op_getmad(label,o,'L');
4590 /* Check whether it's going to be a goto &function */
4591 if (label->op_type == OP_ENTERSUB
4592 && !(label->op_flags & OPf_STACKED))
4593 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4594 o = newUNOP(type, OPf_STACKED, label);
4596 PL_hints |= HINT_BLOCK_SCOPE;
4600 /* if the condition is a literal array or hash
4601 (or @{ ... } etc), make a reference to it.
4604 S_ref_array_or_hash(pTHX_ OP *cond)
4607 && (cond->op_type == OP_RV2AV
4608 || cond->op_type == OP_PADAV
4609 || cond->op_type == OP_RV2HV
4610 || cond->op_type == OP_PADHV))
4612 return newUNOP(OP_REFGEN,
4613 0, mod(cond, OP_REFGEN));
4619 /* These construct the optree fragments representing given()
4622 entergiven and enterwhen are LOGOPs; the op_other pointer
4623 points up to the associated leave op. We need this so we
4624 can put it in the context and make break/continue work.
4625 (Also, of course, pp_enterwhen will jump straight to
4626 op_other if the match fails.)
4631 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
4632 I32 enter_opcode, I32 leave_opcode,
4633 PADOFFSET entertarg)
4639 NewOp(1101, enterop, 1, LOGOP);
4640 enterop->op_type = enter_opcode;
4641 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
4642 enterop->op_flags = (U8) OPf_KIDS;
4643 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
4644 enterop->op_private = 0;
4646 o = newUNOP(leave_opcode, 0, (OP *) enterop);
4649 enterop->op_first = scalar(cond);
4650 cond->op_sibling = block;
4652 o->op_next = LINKLIST(cond);
4653 cond->op_next = (OP *) enterop;
4656 /* This is a default {} block */
4657 enterop->op_first = block;
4658 enterop->op_flags |= OPf_SPECIAL;
4660 o->op_next = (OP *) enterop;
4663 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
4664 entergiven and enterwhen both
4667 enterop->op_next = LINKLIST(block);
4668 block->op_next = enterop->op_other = o;
4673 /* Does this look like a boolean operation? For these purposes
4674 a boolean operation is:
4675 - a subroutine call [*]
4676 - a logical connective
4677 - a comparison operator
4678 - a filetest operator, with the exception of -s -M -A -C
4679 - defined(), exists() or eof()
4680 - /$re/ or $foo =~ /$re/
4682 [*] possibly surprising
4686 S_looks_like_bool(pTHX_ const OP *o)
4689 switch(o->op_type) {
4691 return looks_like_bool(cLOGOPo->op_first);
4695 looks_like_bool(cLOGOPo->op_first)
4696 && looks_like_bool(cLOGOPo->op_first->op_sibling));
4700 case OP_NOT: case OP_XOR:
4701 /* Note that OP_DOR is not here */
4703 case OP_EQ: case OP_NE: case OP_LT:
4704 case OP_GT: case OP_LE: case OP_GE:
4706 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
4707 case OP_I_GT: case OP_I_LE: case OP_I_GE:
4709 case OP_SEQ: case OP_SNE: case OP_SLT:
4710 case OP_SGT: case OP_SLE: case OP_SGE:
4714 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
4715 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
4716 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
4717 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
4718 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
4719 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
4720 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
4721 case OP_FTTEXT: case OP_FTBINARY:
4723 case OP_DEFINED: case OP_EXISTS:
4724 case OP_MATCH: case OP_EOF:
4729 /* Detect comparisons that have been optimized away */
4730 if (cSVOPo->op_sv == &PL_sv_yes
4731 || cSVOPo->op_sv == &PL_sv_no)
4742 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
4746 return newGIVWHENOP(
4747 ref_array_or_hash(cond),
4749 OP_ENTERGIVEN, OP_LEAVEGIVEN,
4753 /* If cond is null, this is a default {} block */
4755 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
4757 const bool cond_llb = (!cond || looks_like_bool(cond));
4763 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
4765 scalar(ref_array_or_hash(cond)));
4768 return newGIVWHENOP(
4770 append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
4771 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
4775 =for apidoc cv_undef
4777 Clear out all the active components of a CV. This can happen either
4778 by an explicit C<undef &foo>, or by the reference count going to zero.
4779 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
4780 children can still follow the full lexical scope chain.
4786 Perl_cv_undef(pTHX_ CV *cv)
4790 if (CvFILE(cv) && !CvISXSUB(cv)) {
4791 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4792 Safefree(CvFILE(cv));
4797 if (!CvISXSUB(cv) && CvROOT(cv)) {
4798 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
4799 Perl_croak(aTHX_ "Can't undef active subroutine");
4802 PAD_SAVE_SETNULLPAD();
4804 op_free(CvROOT(cv));
4809 SvPOK_off((SV*)cv); /* forget prototype */
4814 /* remove CvOUTSIDE unless this is an undef rather than a free */
4815 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
4816 if (!CvWEAKOUTSIDE(cv))
4817 SvREFCNT_dec(CvOUTSIDE(cv));
4818 CvOUTSIDE(cv) = NULL;
4821 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4824 if (CvISXSUB(cv) && CvXSUB(cv)) {
4827 /* delete all flags except WEAKOUTSIDE */
4828 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
4832 Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
4835 /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
4836 relying on SvCUR, and doubling up the buffer to hold CvFILE(). */
4837 if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
4838 || (p && (len != SvCUR(cv) /* Not the same length. */
4839 || memNE(p, SvPVX_const(cv), len))))
4840 && ckWARN_d(WARN_PROTOTYPE)) {
4841 SV* const msg = sv_newmortal();
4845 gv_efullname3(name = sv_newmortal(), gv, NULL);
4846 sv_setpv(msg, "Prototype mismatch:");
4848 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, (void*)name);
4850 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (void*)cv);
4852 sv_catpvs(msg, ": none");
4853 sv_catpvs(msg, " vs ");
4855 Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
4857 sv_catpvs(msg, "none");
4858 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, (void*)msg);
4862 static void const_sv_xsub(pTHX_ CV* cv);
4866 =head1 Optree Manipulation Functions
4868 =for apidoc cv_const_sv
4870 If C<cv> is a constant sub eligible for inlining. returns the constant
4871 value returned by the sub. Otherwise, returns NULL.
4873 Constant subs can be created with C<newCONSTSUB> or as described in
4874 L<perlsub/"Constant Functions">.
4879 Perl_cv_const_sv(pTHX_ CV *cv)
4881 PERL_UNUSED_CONTEXT;
4884 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
4886 return CvCONST(cv) ? (SV*)CvXSUBANY(cv).any_ptr : NULL;
4889 /* op_const_sv: examine an optree to determine whether it's in-lineable.
4890 * Can be called in 3 ways:
4893 * look for a single OP_CONST with attached value: return the value
4895 * cv && CvCLONE(cv) && !CvCONST(cv)
4897 * examine the clone prototype, and if contains only a single
4898 * OP_CONST referencing a pad const, or a single PADSV referencing
4899 * an outer lexical, return a non-zero value to indicate the CV is
4900 * a candidate for "constizing" at clone time
4904 * We have just cloned an anon prototype that was marked as a const
4905 * candidiate. Try to grab the current value, and in the case of
4906 * PADSV, ignore it if it has multiple references. Return the value.
4910 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
4918 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4919 o = cLISTOPo->op_first->op_sibling;
4921 for (; o; o = o->op_next) {
4922 const OPCODE type = o->op_type;
4924 if (sv && o->op_next == o)
4926 if (o->op_next != o) {
4927 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4929 if (type == OP_DBSTATE)
4932 if (type == OP_LEAVESUB || type == OP_RETURN)
4936 if (type == OP_CONST && cSVOPo->op_sv)
4938 else if (cv && type == OP_CONST) {
4939 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4943 else if (cv && type == OP_PADSV) {
4944 if (CvCONST(cv)) { /* newly cloned anon */
4945 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4946 /* the candidate should have 1 ref from this pad and 1 ref
4947 * from the parent */
4948 if (!sv || SvREFCNT(sv) != 2)
4955 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
4956 sv = &PL_sv_undef; /* an arbitrary non-null value */
4971 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4974 /* This would be the return value, but the return cannot be reached. */
4975 OP* pegop = newOP(OP_NULL, 0);
4978 PERL_UNUSED_ARG(floor);
4988 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4990 NORETURN_FUNCTION_END;
4995 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4997 return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
5001 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5008 register CV *cv = NULL;
5010 /* If the subroutine has no body, no attributes, and no builtin attributes
5011 then it's just a sub declaration, and we may be able to get away with
5012 storing with a placeholder scalar in the symbol table, rather than a
5013 full GV and CV. If anything is present then it will take a full CV to
5015 const I32 gv_fetch_flags
5016 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5018 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
5019 const char * const name = o ? SvPVx_nolen_const(cSVOPo->op_sv) : NULL;
5022 assert(proto->op_type == OP_CONST);
5023 ps = SvPVx_const(((SVOP*)proto)->op_sv, ps_len);
5028 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
5029 SV * const sv = sv_newmortal();
5030 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
5031 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
5032 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
5033 aname = SvPVX_const(sv);
5038 gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
5039 : gv_fetchpv(aname ? aname
5040 : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5041 gv_fetch_flags, SVt_PVCV);
5043 if (!PL_madskills) {
5052 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
5053 maximum a prototype before. */
5054 if (SvTYPE(gv) > SVt_NULL) {
5055 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
5056 && ckWARN_d(WARN_PROTOTYPE))
5058 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
5060 cv_ckproto_len((CV*)gv, NULL, ps, ps_len);
5063 sv_setpvn((SV*)gv, ps, ps_len);
5065 sv_setiv((SV*)gv, -1);
5066 SvREFCNT_dec(PL_compcv);
5067 cv = PL_compcv = NULL;
5068 PL_sub_generation++;
5072 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
5074 #ifdef GV_UNIQUE_CHECK
5075 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
5076 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
5080 if (!block || !ps || *ps || attrs
5081 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5083 || block->op_type == OP_NULL
5088 const_sv = op_const_sv(block, NULL);
5091 const bool exists = CvROOT(cv) || CvXSUB(cv);
5093 #ifdef GV_UNIQUE_CHECK
5094 if (exists && GvUNIQUE(gv)) {
5095 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
5099 /* if the subroutine doesn't exist and wasn't pre-declared
5100 * with a prototype, assume it will be AUTOLOADed,
5101 * skipping the prototype check
5103 if (exists || SvPOK(cv))
5104 cv_ckproto_len(cv, gv, ps, ps_len);
5105 /* already defined (or promised)? */
5106 if (exists || GvASSUMECV(gv)) {
5109 || block->op_type == OP_NULL
5112 if (CvFLAGS(PL_compcv)) {
5113 /* might have had built-in attrs applied */
5114 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5116 /* just a "sub foo;" when &foo is already defined */
5117 SAVEFREESV(PL_compcv);
5122 && block->op_type != OP_NULL
5125 if (ckWARN(WARN_REDEFINE)
5127 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
5129 const line_t oldline = CopLINE(PL_curcop);
5130 if (PL_copline != NOLINE)
5131 CopLINE_set(PL_curcop, PL_copline);
5132 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5133 CvCONST(cv) ? "Constant subroutine %s redefined"
5134 : "Subroutine %s redefined", name);
5135 CopLINE_set(PL_curcop, oldline);
5138 if (!PL_minus_c) /* keep old one around for madskills */
5141 /* (PL_madskills unset in used file.) */
5149 SvREFCNT_inc_simple_void_NN(const_sv);
5151 assert(!CvROOT(cv) && !CvCONST(cv));
5152 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
5153 CvXSUBANY(cv).any_ptr = const_sv;
5154 CvXSUB(cv) = const_sv_xsub;
5160 cv = newCONSTSUB(NULL, name, const_sv);
5162 PL_sub_generation++;
5166 SvREFCNT_dec(PL_compcv);
5174 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
5175 * before we clobber PL_compcv.
5179 || block->op_type == OP_NULL
5183 /* Might have had built-in attributes applied -- propagate them. */
5184 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5185 if (CvGV(cv) && GvSTASH(CvGV(cv)))
5186 stash = GvSTASH(CvGV(cv));
5187 else if (CvSTASH(cv))
5188 stash = CvSTASH(cv);
5190 stash = PL_curstash;
5193 /* possibly about to re-define existing subr -- ignore old cv */
5194 rcv = (SV*)PL_compcv;
5195 if (name && GvSTASH(gv))
5196 stash = GvSTASH(gv);
5198 stash = PL_curstash;
5200 apply_attrs(stash, rcv, attrs, FALSE);
5202 if (cv) { /* must reuse cv if autoloaded */
5209 || block->op_type == OP_NULL) && !PL_madskills
5212 /* got here with just attrs -- work done, so bug out */
5213 SAVEFREESV(PL_compcv);
5216 /* transfer PL_compcv to cv */
5218 CvFLAGS(cv) = CvFLAGS(PL_compcv);
5219 if (!CvWEAKOUTSIDE(cv))
5220 SvREFCNT_dec(CvOUTSIDE(cv));
5221 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
5222 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
5223 CvOUTSIDE(PL_compcv) = 0;
5224 CvPADLIST(cv) = CvPADLIST(PL_compcv);
5225 CvPADLIST(PL_compcv) = 0;
5226 /* inner references to PL_compcv must be fixed up ... */
5227 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
5228 /* ... before we throw it away */
5229 SvREFCNT_dec(PL_compcv);
5231 if (PERLDB_INTER)/* Advice debugger on the new sub. */
5232 ++PL_sub_generation;
5239 if (strEQ(name, "import")) {
5240 PL_formfeed = (SV*)cv;
5241 Perl_warner(aTHX_ packWARN(WARN_VOID), "%lx\n", (long)cv);
5245 PL_sub_generation++;
5249 CvFILE_set_from_cop(cv, PL_curcop);
5250 CvSTASH(cv) = PL_curstash;
5253 sv_setpvn((SV*)cv, ps, ps_len);
5255 if (PL_error_count) {
5259 const char *s = strrchr(name, ':');
5261 if (strEQ(s, "BEGIN")) {
5262 const char not_safe[] =
5263 "BEGIN not safe after errors--compilation aborted";
5264 if (PL_in_eval & EVAL_KEEPERR)
5265 Perl_croak(aTHX_ not_safe);
5267 /* force display of errors found but not reported */
5268 sv_catpv(ERRSV, not_safe);
5269 Perl_croak(aTHX_ "%"SVf, (void*)ERRSV);
5279 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5280 mod(scalarseq(block), OP_LEAVESUBLV));
5283 /* This makes sub {}; work as expected. */
5284 if (block->op_type == OP_STUB) {
5285 OP* const newblock = newSTATEOP(0, NULL, 0);
5287 op_getmad(block,newblock,'B');
5293 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5295 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5296 OpREFCNT_set(CvROOT(cv), 1);
5297 CvSTART(cv) = LINKLIST(CvROOT(cv));
5298 CvROOT(cv)->op_next = 0;
5299 CALL_PEEP(CvSTART(cv));
5301 /* now that optimizer has done its work, adjust pad values */
5303 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
5306 assert(!CvCONST(cv));
5307 if (ps && !*ps && op_const_sv(block, cv))
5311 if (name || aname) {
5313 const char * const tname = (name ? name : aname);
5315 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5316 SV * const sv = newSV(0);
5317 SV * const tmpstr = sv_newmortal();
5318 GV * const db_postponed = gv_fetchpvs("DB::postponed",
5319 GV_ADDMULTI, SVt_PVHV);
5322 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5324 (long)PL_subline, (long)CopLINE(PL_curcop));
5325 gv_efullname3(tmpstr, gv, NULL);
5326 hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0);
5327 hv = GvHVn(db_postponed);
5328 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
5329 CV * const pcv = GvCV(db_postponed);
5335 call_sv((SV*)pcv, G_DISCARD);
5340 if ((s = strrchr(tname,':')))
5345 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I' && *s != 'U')
5348 if (strEQ(s, "BEGIN") && !PL_error_count) {
5349 const I32 oldscope = PL_scopestack_ix;
5351 SAVECOPFILE(&PL_compiling);
5352 SAVECOPLINE(&PL_compiling);
5355 PL_beginav = newAV();
5356 DEBUG_x( dump_sub(gv) );
5357 av_push(PL_beginav, (SV*)cv);
5358 GvCV(gv) = 0; /* cv has been hijacked */
5359 call_list(oldscope, PL_beginav);
5361 PL_curcop = &PL_compiling;
5362 CopHINTS_set(&PL_compiling, PL_hints);
5365 else if (strEQ(s, "END") && !PL_error_count) {
5368 DEBUG_x( dump_sub(gv) );
5369 av_unshift(PL_endav, 1);
5370 av_store(PL_endav, 0, (SV*)cv);
5371 GvCV(gv) = 0; /* cv has been hijacked */
5373 else if (strEQ(s, "UNITCHECK") && !PL_error_count) {
5374 /* It's never too late to run a unitcheck block */
5375 if (!PL_unitcheckav)
5376 PL_unitcheckav = newAV();
5377 DEBUG_x( dump_sub(gv) );
5378 av_unshift(PL_unitcheckav, 1);
5379 av_store(PL_unitcheckav, 0, (SV*)cv);
5380 GvCV(gv) = 0; /* cv has been hijacked */
5382 else if (strEQ(s, "CHECK") && !PL_error_count) {
5384 PL_checkav = newAV();
5385 DEBUG_x( dump_sub(gv) );
5386 if (PL_main_start && ckWARN(WARN_VOID))
5387 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
5388 av_unshift(PL_checkav, 1);
5389 av_store(PL_checkav, 0, (SV*)cv);
5390 GvCV(gv) = 0; /* cv has been hijacked */
5392 else if (strEQ(s, "INIT") && !PL_error_count) {
5394 PL_initav = newAV();
5395 DEBUG_x( dump_sub(gv) );
5396 if (PL_main_start && ckWARN(WARN_VOID))
5397 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
5398 av_push(PL_initav, (SV*)cv);
5399 GvCV(gv) = 0; /* cv has been hijacked */
5404 PL_copline = NOLINE;
5409 /* XXX unsafe for threads if eval_owner isn't held */
5411 =for apidoc newCONSTSUB
5413 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5414 eligible for inlining at compile-time.
5420 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
5425 const char *const temp_p = CopFILE(PL_curcop);
5426 const STRLEN len = temp_p ? strlen(temp_p) : 0;
5428 SV *const temp_sv = CopFILESV(PL_curcop);
5430 const char *const temp_p = temp_sv ? SvPV_const(temp_sv, len) : NULL;
5432 char *const file = savepvn(temp_p, temp_p ? len : 0);
5436 SAVECOPLINE(PL_curcop);
5437 CopLINE_set(PL_curcop, PL_copline);
5440 PL_hints &= ~HINT_BLOCK_SCOPE;
5443 SAVESPTR(PL_curstash);
5444 SAVECOPSTASH(PL_curcop);
5445 PL_curstash = stash;
5446 CopSTASH_set(PL_curcop,stash);
5449 /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
5450 and so doesn't get free()d. (It's expected to be from the C pre-
5451 processor __FILE__ directive). But we need a dynamically allocated one,
5452 and we need it to get freed. */
5453 cv = newXS_flags(name, const_sv_xsub, file, "", XS_DYNAMIC_FILENAME);
5454 CvXSUBANY(cv).any_ptr = sv;
5459 CopSTASH_free(PL_curcop);
5467 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
5468 const char *const filename, const char *const proto,
5471 CV *cv = newXS(name, subaddr, filename);
5473 if (flags & XS_DYNAMIC_FILENAME) {
5474 /* We need to "make arrangements" (ie cheat) to ensure that the
5475 filename lasts as long as the PVCV we just created, but also doesn't
5477 STRLEN filename_len = strlen(filename);
5478 STRLEN proto_and_file_len = filename_len;
5479 char *proto_and_file;
5483 proto_len = strlen(proto);
5484 proto_and_file_len += proto_len;
5486 Newx(proto_and_file, proto_and_file_len + 1, char);
5487 Copy(proto, proto_and_file, proto_len, char);
5488 Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
5491 proto_and_file = savepvn(filename, filename_len);
5494 /* This gets free()d. :-) */
5495 sv_usepvn_flags((SV*)cv, proto_and_file, proto_and_file_len,
5496 SV_HAS_TRAILING_NUL);
5498 /* This gives us the correct prototype, rather than one with the
5499 file name appended. */
5500 SvCUR_set(cv, proto_len);
5504 CvFILE(cv) = proto_and_file + proto_len;
5506 sv_setpv((SV *)cv, proto);
5512 =for apidoc U||newXS
5514 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
5515 static storage, as it is used directly as CvFILE(), without a copy being made.
5521 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
5524 GV * const gv = gv_fetchpv(name ? name :
5525 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5526 GV_ADDMULTI, SVt_PVCV);
5530 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
5532 if ((cv = (name ? GvCV(gv) : NULL))) {
5534 /* just a cached method */
5538 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5539 /* already defined (or promised) */
5540 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
5541 if (ckWARN(WARN_REDEFINE)) {
5542 GV * const gvcv = CvGV(cv);
5544 HV * const stash = GvSTASH(gvcv);
5546 const char *redefined_name = HvNAME_get(stash);
5547 if ( strEQ(redefined_name,"autouse") ) {
5548 const line_t oldline = CopLINE(PL_curcop);
5549 if (PL_copline != NOLINE)
5550 CopLINE_set(PL_curcop, PL_copline);
5551 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5552 CvCONST(cv) ? "Constant subroutine %s redefined"
5553 : "Subroutine %s redefined"
5555 CopLINE_set(PL_curcop, oldline);
5565 if (cv) /* must reuse cv if autoloaded */
5569 sv_upgrade((SV *)cv, SVt_PVCV);
5573 PL_sub_generation++;
5577 (void)gv_fetchfile(filename);
5578 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
5579 an external constant string */
5581 CvXSUB(cv) = subaddr;
5584 const char *s = strrchr(name,':');
5590 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5593 if (strEQ(s, "BEGIN")) {
5595 PL_beginav = newAV();
5596 av_push(PL_beginav, (SV*)cv);
5597 GvCV(gv) = 0; /* cv has been hijacked */
5599 else if (strEQ(s, "END")) {
5602 av_unshift(PL_endav, 1);
5603 av_store(PL_endav, 0, (SV*)cv);
5604 GvCV(gv) = 0; /* cv has been hijacked */
5606 else if (strEQ(s, "CHECK")) {
5608 PL_checkav = newAV();
5609 if (PL_main_start && ckWARN(WARN_VOID))
5610 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
5611 av_unshift(PL_checkav, 1);
5612 av_store(PL_checkav, 0, (SV*)cv);
5613 GvCV(gv) = 0; /* cv has been hijacked */
5615 else if (strEQ(s, "INIT")) {
5617 PL_initav = newAV();
5618 if (PL_main_start && ckWARN(WARN_VOID))
5619 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
5620 av_push(PL_initav, (SV*)cv);
5621 GvCV(gv) = 0; /* cv has been hijacked */
5636 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5641 OP* pegop = newOP(OP_NULL, 0);
5645 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
5646 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
5648 #ifdef GV_UNIQUE_CHECK
5650 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5654 if ((cv = GvFORM(gv))) {
5655 if (ckWARN(WARN_REDEFINE)) {
5656 const line_t oldline = CopLINE(PL_curcop);
5657 if (PL_copline != NOLINE)
5658 CopLINE_set(PL_curcop, PL_copline);
5659 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5660 o ? "Format %"SVf" redefined"
5661 : "Format STDOUT redefined", (void*)cSVOPo->op_sv);
5662 CopLINE_set(PL_curcop, oldline);
5669 CvFILE_set_from_cop(cv, PL_curcop);
5672 pad_tidy(padtidy_FORMAT);
5673 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5674 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5675 OpREFCNT_set(CvROOT(cv), 1);
5676 CvSTART(cv) = LINKLIST(CvROOT(cv));
5677 CvROOT(cv)->op_next = 0;
5678 CALL_PEEP(CvSTART(cv));
5680 op_getmad(o,pegop,'n');
5681 op_getmad_weak(block, pegop, 'b');
5685 PL_copline = NOLINE;
5693 Perl_newANONLIST(pTHX_ OP *o)
5695 return convert(OP_ANONLIST, OPf_SPECIAL, o);
5699 Perl_newANONHASH(pTHX_ OP *o)
5701 return convert(OP_ANONHASH, OPf_SPECIAL, o);
5705 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5707 return newANONATTRSUB(floor, proto, NULL, block);
5711 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5713 return newUNOP(OP_REFGEN, 0,
5714 newSVOP(OP_ANONCODE, 0,
5715 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5719 Perl_oopsAV(pTHX_ OP *o)
5722 switch (o->op_type) {
5724 o->op_type = OP_PADAV;
5725 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5726 return ref(o, OP_RV2AV);
5729 o->op_type = OP_RV2AV;
5730 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5735 if (ckWARN_d(WARN_INTERNAL))
5736 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
5743 Perl_oopsHV(pTHX_ OP *o)
5746 switch (o->op_type) {
5749 o->op_type = OP_PADHV;
5750 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5751 return ref(o, OP_RV2HV);
5755 o->op_type = OP_RV2HV;
5756 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5761 if (ckWARN_d(WARN_INTERNAL))
5762 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
5769 Perl_newAVREF(pTHX_ OP *o)
5772 if (o->op_type == OP_PADANY) {
5773 o->op_type = OP_PADAV;
5774 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5777 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5778 && ckWARN(WARN_DEPRECATED)) {
5779 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5780 "Using an array as a reference is deprecated");
5782 return newUNOP(OP_RV2AV, 0, scalar(o));
5786 Perl_newGVREF(pTHX_ I32 type, OP *o)
5788 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5789 return newUNOP(OP_NULL, 0, o);
5790 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5794 Perl_newHVREF(pTHX_ OP *o)
5797 if (o->op_type == OP_PADANY) {
5798 o->op_type = OP_PADHV;
5799 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5802 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5803 && ckWARN(WARN_DEPRECATED)) {
5804 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5805 "Using a hash as a reference is deprecated");
5807 return newUNOP(OP_RV2HV, 0, scalar(o));
5811 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5813 return newUNOP(OP_RV2CV, flags, scalar(o));
5817 Perl_newSVREF(pTHX_ OP *o)
5820 if (o->op_type == OP_PADANY) {
5821 o->op_type = OP_PADSV;
5822 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5825 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5826 o->op_flags |= OPpDONE_SVREF;
5829 return newUNOP(OP_RV2SV, 0, scalar(o));
5832 /* Check routines. See the comments at the top of this file for details
5833 * on when these are called */
5836 Perl_ck_anoncode(pTHX_ OP *o)
5838 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
5840 cSVOPo->op_sv = NULL;
5845 Perl_ck_bitop(pTHX_ OP *o)
5848 #define OP_IS_NUMCOMPARE(op) \
5849 ((op) == OP_LT || (op) == OP_I_LT || \
5850 (op) == OP_GT || (op) == OP_I_GT || \
5851 (op) == OP_LE || (op) == OP_I_LE || \
5852 (op) == OP_GE || (op) == OP_I_GE || \
5853 (op) == OP_EQ || (op) == OP_I_EQ || \
5854 (op) == OP_NE || (op) == OP_I_NE || \
5855 (op) == OP_NCMP || (op) == OP_I_NCMP)
5856 o->op_private = (U8)(PL_hints & HINT_INTEGER);
5857 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
5858 && (o->op_type == OP_BIT_OR
5859 || o->op_type == OP_BIT_AND
5860 || o->op_type == OP_BIT_XOR))
5862 const OP * const left = cBINOPo->op_first;
5863 const OP * const right = left->op_sibling;
5864 if ((OP_IS_NUMCOMPARE(left->op_type) &&
5865 (left->op_flags & OPf_PARENS) == 0) ||
5866 (OP_IS_NUMCOMPARE(right->op_type) &&
5867 (right->op_flags & OPf_PARENS) == 0))
5868 if (ckWARN(WARN_PRECEDENCE))
5869 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
5870 "Possible precedence problem on bitwise %c operator",
5871 o->op_type == OP_BIT_OR ? '|'
5872 : o->op_type == OP_BIT_AND ? '&' : '^'
5879 Perl_ck_concat(pTHX_ OP *o)
5881 const OP * const kid = cUNOPo->op_first;
5882 PERL_UNUSED_CONTEXT;
5883 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
5884 !(kUNOP->op_first->op_flags & OPf_MOD))
5885 o->op_flags |= OPf_STACKED;
5890 Perl_ck_spair(pTHX_ OP *o)
5893 if (o->op_flags & OPf_KIDS) {
5896 const OPCODE type = o->op_type;
5897 o = modkids(ck_fun(o), type);
5898 kid = cUNOPo->op_first;
5899 newop = kUNOP->op_first->op_sibling;
5901 const OPCODE type = newop->op_type;
5902 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
5903 type == OP_PADAV || type == OP_PADHV ||
5904 type == OP_RV2AV || type == OP_RV2HV)
5908 op_getmad(kUNOP->op_first,newop,'K');
5910 op_free(kUNOP->op_first);
5912 kUNOP->op_first = newop;
5914 o->op_ppaddr = PL_ppaddr[++o->op_type];
5919 Perl_ck_delete(pTHX_ OP *o)
5923 if (o->op_flags & OPf_KIDS) {
5924 OP * const kid = cUNOPo->op_first;
5925 switch (kid->op_type) {
5927 o->op_flags |= OPf_SPECIAL;
5930 o->op_private |= OPpSLICE;
5933 o->op_flags |= OPf_SPECIAL;
5938 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5947 Perl_ck_die(pTHX_ OP *o)
5950 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5956 Perl_ck_eof(pTHX_ OP *o)
5960 if (o->op_flags & OPf_KIDS) {
5961 if (cLISTOPo->op_first->op_type == OP_STUB) {
5963 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
5965 op_getmad(o,newop,'O');
5977 Perl_ck_eval(pTHX_ OP *o)
5980 PL_hints |= HINT_BLOCK_SCOPE;
5981 if (o->op_flags & OPf_KIDS) {
5982 SVOP * const kid = (SVOP*)cUNOPo->op_first;
5985 o->op_flags &= ~OPf_KIDS;
5988 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
5994 cUNOPo->op_first = 0;
5999 NewOp(1101, enter, 1, LOGOP);
6000 enter->op_type = OP_ENTERTRY;
6001 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
6002 enter->op_private = 0;
6004 /* establish postfix order */
6005 enter->op_next = (OP*)enter;
6007 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
6008 o->op_type = OP_LEAVETRY;
6009 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
6010 enter->op_other = o;
6011 op_getmad(oldo,o,'O');
6025 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
6026 op_getmad(oldo,o,'O');
6028 o->op_targ = (PADOFFSET)PL_hints;
6029 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
6030 /* Store a copy of %^H that pp_entereval can pick up */
6031 OP *hhop = newSVOP(OP_CONST, 0,
6032 (SV*)Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv)));
6033 cUNOPo->op_first->op_sibling = hhop;
6034 o->op_private |= OPpEVAL_HAS_HH;
6040 Perl_ck_exit(pTHX_ OP *o)
6043 HV * const table = GvHV(PL_hintgv);
6045 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
6046 if (svp && *svp && SvTRUE(*svp))
6047 o->op_private |= OPpEXIT_VMSISH;
6049 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6055 Perl_ck_exec(pTHX_ OP *o)
6057 if (o->op_flags & OPf_STACKED) {
6060 kid = cUNOPo->op_first->op_sibling;
6061 if (kid->op_type == OP_RV2GV)
6070 Perl_ck_exists(pTHX_ OP *o)
6074 if (o->op_flags & OPf_KIDS) {
6075 OP * const kid = cUNOPo->op_first;
6076 if (kid->op_type == OP_ENTERSUB) {
6077 (void) ref(kid, o->op_type);
6078 if (kid->op_type != OP_RV2CV && !PL_error_count)
6079 Perl_croak(aTHX_ "%s argument is not a subroutine name",
6081 o->op_private |= OPpEXISTS_SUB;
6083 else if (kid->op_type == OP_AELEM)
6084 o->op_flags |= OPf_SPECIAL;
6085 else if (kid->op_type != OP_HELEM)
6086 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
6094 Perl_ck_rvconst(pTHX_ register OP *o)
6097 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6099 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6100 if (o->op_type == OP_RV2CV)
6101 o->op_private &= ~1;
6103 if (kid->op_type == OP_CONST) {
6106 SV * const kidsv = kid->op_sv;
6108 /* Is it a constant from cv_const_sv()? */
6109 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
6110 SV * const rsv = SvRV(kidsv);
6111 const svtype type = SvTYPE(rsv);
6112 const char *badtype = NULL;
6114 switch (o->op_type) {
6116 if (type > SVt_PVMG)
6117 badtype = "a SCALAR";
6120 if (type != SVt_PVAV)
6121 badtype = "an ARRAY";
6124 if (type != SVt_PVHV)
6128 if (type != SVt_PVCV)
6133 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
6136 else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
6137 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
6138 /* If this is an access to a stash, disable "strict refs", because
6139 * stashes aren't auto-vivified at compile-time (unless we store
6140 * symbols in them), and we don't want to produce a run-time
6141 * stricture error when auto-vivifying the stash. */
6142 const char *s = SvPV_nolen(kidsv);
6143 const STRLEN l = SvCUR(kidsv);
6144 if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
6145 o->op_private &= ~HINT_STRICT_REFS;
6147 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
6148 const char *badthing;
6149 switch (o->op_type) {
6151 badthing = "a SCALAR";
6154 badthing = "an ARRAY";
6157 badthing = "a HASH";
6165 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
6166 (void*)kidsv, badthing);
6169 * This is a little tricky. We only want to add the symbol if we
6170 * didn't add it in the lexer. Otherwise we get duplicate strict
6171 * warnings. But if we didn't add it in the lexer, we must at
6172 * least pretend like we wanted to add it even if it existed before,
6173 * or we get possible typo warnings. OPpCONST_ENTERED says
6174 * whether the lexer already added THIS instance of this symbol.
6176 iscv = (o->op_type == OP_RV2CV) * 2;
6178 gv = gv_fetchsv(kidsv,
6179 iscv | !(kid->op_private & OPpCONST_ENTERED),
6182 : o->op_type == OP_RV2SV
6184 : o->op_type == OP_RV2AV
6186 : o->op_type == OP_RV2HV
6189 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
6191 kid->op_type = OP_GV;
6192 SvREFCNT_dec(kid->op_sv);
6194 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
6195 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
6196 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
6198 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc_simple_NN(gv));
6200 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
6202 kid->op_private = 0;
6203 kid->op_ppaddr = PL_ppaddr[OP_GV];
6210 Perl_ck_ftst(pTHX_ OP *o)
6213 const I32 type = o->op_type;
6215 if (o->op_flags & OPf_REF) {
6218 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
6219 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6220 const OPCODE kidtype = kid->op_type;
6222 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6223 OP * const newop = newGVOP(type, OPf_REF,
6224 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
6226 op_getmad(o,newop,'O');
6232 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o))
6233 o->op_private |= OPpFT_ACCESS;
6234 if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst)
6235 && kidtype != OP_STAT && kidtype != OP_LSTAT)
6236 o->op_private |= OPpFT_STACKED;
6244 if (type == OP_FTTTY)
6245 o = newGVOP(type, OPf_REF, PL_stdingv);
6247 o = newUNOP(type, 0, newDEFSVOP());
6248 op_getmad(oldo,o,'O');
6254 Perl_ck_fun(pTHX_ OP *o)
6257 const int type = o->op_type;
6258 register I32 oa = PL_opargs[type] >> OASHIFT;
6260 if (o->op_flags & OPf_STACKED) {
6261 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
6264 return no_fh_allowed(o);
6267 if (o->op_flags & OPf_KIDS) {
6268 OP **tokid = &cLISTOPo->op_first;
6269 register OP *kid = cLISTOPo->op_first;
6273 if (kid->op_type == OP_PUSHMARK ||
6274 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
6276 tokid = &kid->op_sibling;
6277 kid = kid->op_sibling;
6279 if (!kid && PL_opargs[type] & OA_DEFGV)
6280 *tokid = kid = newDEFSVOP();
6284 sibl = kid->op_sibling;
6286 if (!sibl && kid->op_type == OP_STUB) {
6293 /* list seen where single (scalar) arg expected? */
6294 if (numargs == 1 && !(oa >> 4)
6295 && kid->op_type == OP_LIST && type != OP_SCALAR)
6297 return too_many_arguments(o,PL_op_desc[type]);
6310 if ((type == OP_PUSH || type == OP_UNSHIFT)
6311 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
6312 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6313 "Useless use of %s with no values",
6316 if (kid->op_type == OP_CONST &&
6317 (kid->op_private & OPpCONST_BARE))
6319 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
6320 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
6321 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6322 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6323 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
6324 (void*)((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
6326 op_getmad(kid,newop,'K');
6331 kid->op_sibling = sibl;
6334 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
6335 bad_type(numargs, "array", PL_op_desc[type], kid);
6339 if (kid->op_type == OP_CONST &&
6340 (kid->op_private & OPpCONST_BARE))
6342 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
6343 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
6344 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6345 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6346 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
6347 (void*)((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
6349 op_getmad(kid,newop,'K');
6354 kid->op_sibling = sibl;
6357 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
6358 bad_type(numargs, "hash", PL_op_desc[type], kid);
6363 OP * const newop = newUNOP(OP_NULL, 0, kid);
6364 kid->op_sibling = 0;
6366 newop->op_next = newop;
6368 kid->op_sibling = sibl;
6373 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
6374 if (kid->op_type == OP_CONST &&
6375 (kid->op_private & OPpCONST_BARE))
6377 OP * const newop = newGVOP(OP_GV, 0,
6378 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
6379 if (!(o->op_private & 1) && /* if not unop */
6380 kid == cLISTOPo->op_last)
6381 cLISTOPo->op_last = newop;
6383 op_getmad(kid,newop,'K');
6389 else if (kid->op_type == OP_READLINE) {
6390 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
6391 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
6394 I32 flags = OPf_SPECIAL;
6398 /* is this op a FH constructor? */
6399 if (is_handle_constructor(o,numargs)) {
6400 const char *name = NULL;
6404 /* Set a flag to tell rv2gv to vivify
6405 * need to "prove" flag does not mean something
6406 * else already - NI-S 1999/05/07
6409 if (kid->op_type == OP_PADSV) {
6410 name = PAD_COMPNAME_PV(kid->op_targ);
6411 /* SvCUR of a pad namesv can't be trusted
6412 * (see PL_generation), so calc its length
6418 else if (kid->op_type == OP_RV2SV
6419 && kUNOP->op_first->op_type == OP_GV)
6421 GV * const gv = cGVOPx_gv(kUNOP->op_first);
6423 len = GvNAMELEN(gv);
6425 else if (kid->op_type == OP_AELEM
6426 || kid->op_type == OP_HELEM)
6429 OP *op = ((BINOP*)kid)->op_first;
6433 const char * const a =
6434 kid->op_type == OP_AELEM ?
6436 if (((op->op_type == OP_RV2AV) ||
6437 (op->op_type == OP_RV2HV)) &&
6438 (firstop = ((UNOP*)op)->op_first) &&
6439 (firstop->op_type == OP_GV)) {
6440 /* packagevar $a[] or $h{} */
6441 GV * const gv = cGVOPx_gv(firstop);
6449 else if (op->op_type == OP_PADAV
6450 || op->op_type == OP_PADHV) {
6451 /* lexicalvar $a[] or $h{} */
6452 const char * const padname =
6453 PAD_COMPNAME_PV(op->op_targ);
6462 name = SvPV_const(tmpstr, len);
6467 name = "__ANONIO__";
6474 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
6475 namesv = PAD_SVl(targ);
6476 SvUPGRADE(namesv, SVt_PV);
6478 sv_setpvn(namesv, "$", 1);
6479 sv_catpvn(namesv, name, len);
6482 kid->op_sibling = 0;
6483 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
6484 kid->op_targ = targ;
6485 kid->op_private |= priv;
6487 kid->op_sibling = sibl;
6493 mod(scalar(kid), type);
6497 tokid = &kid->op_sibling;
6498 kid = kid->op_sibling;
6501 if (kid && kid->op_type != OP_STUB)
6502 return too_many_arguments(o,OP_DESC(o));
6503 o->op_private |= numargs;
6505 /* FIXME - should the numargs move as for the PERL_MAD case? */
6506 o->op_private |= numargs;
6508 return too_many_arguments(o,OP_DESC(o));
6512 else if (PL_opargs[type] & OA_DEFGV) {
6514 OP *newop = newUNOP(type, 0, newDEFSVOP());
6515 op_getmad(o,newop,'O');
6518 /* Ordering of these two is important to keep f_map.t passing. */
6520 return newUNOP(type, 0, newDEFSVOP());
6525 while (oa & OA_OPTIONAL)
6527 if (oa && oa != OA_LIST)
6528 return too_few_arguments(o,OP_DESC(o));
6534 Perl_ck_glob(pTHX_ OP *o)
6540 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
6541 append_elem(OP_GLOB, o, newDEFSVOP());
6543 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
6544 && GvCVu(gv) && GvIMPORTED_CV(gv)))
6546 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6549 #if !defined(PERL_EXTERNAL_GLOB)
6550 /* XXX this can be tightened up and made more failsafe. */
6551 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
6554 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
6555 newSVpvs("File::Glob"), NULL, NULL, NULL);
6556 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6557 glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
6558 GvCV(gv) = GvCV(glob_gv);
6559 SvREFCNT_inc_void((SV*)GvCV(gv));
6560 GvIMPORTED_CV_on(gv);
6563 #endif /* PERL_EXTERNAL_GLOB */
6565 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6566 append_elem(OP_GLOB, o,
6567 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
6568 o->op_type = OP_LIST;
6569 o->op_ppaddr = PL_ppaddr[OP_LIST];
6570 cLISTOPo->op_first->op_type = OP_PUSHMARK;
6571 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
6572 cLISTOPo->op_first->op_targ = 0;
6573 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
6574 append_elem(OP_LIST, o,
6575 scalar(newUNOP(OP_RV2CV, 0,
6576 newGVOP(OP_GV, 0, gv)))));
6577 o = newUNOP(OP_NULL, 0, ck_subr(o));
6578 o->op_targ = OP_GLOB; /* hint at what it used to be */
6581 gv = newGVgen("main");
6583 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
6589 Perl_ck_grep(pTHX_ OP *o)
6594 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
6597 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
6598 /* don't allocate gwop here, as we may leak it if PL_error_count > 0 */
6600 if (o->op_flags & OPf_STACKED) {
6603 kid = cLISTOPo->op_first->op_sibling;
6604 if (!cUNOPx(kid)->op_next)
6605 Perl_croak(aTHX_ "panic: ck_grep");
6606 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
6609 NewOp(1101, gwop, 1, LOGOP);
6610 kid->op_next = (OP*)gwop;
6611 o->op_flags &= ~OPf_STACKED;
6613 kid = cLISTOPo->op_first->op_sibling;
6614 if (type == OP_MAPWHILE)
6621 kid = cLISTOPo->op_first->op_sibling;
6622 if (kid->op_type != OP_NULL)
6623 Perl_croak(aTHX_ "panic: ck_grep");
6624 kid = kUNOP->op_first;
6627 NewOp(1101, gwop, 1, LOGOP);
6628 gwop->op_type = type;
6629 gwop->op_ppaddr = PL_ppaddr[type];
6630 gwop->op_first = listkids(o);
6631 gwop->op_flags |= OPf_KIDS;
6632 gwop->op_other = LINKLIST(kid);
6633 kid->op_next = (OP*)gwop;
6634 offset = pad_findmy("$_");
6635 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
6636 o->op_private = gwop->op_private = 0;
6637 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
6640 o->op_private = gwop->op_private = OPpGREP_LEX;
6641 gwop->op_targ = o->op_targ = offset;
6644 kid = cLISTOPo->op_first->op_sibling;
6645 if (!kid || !kid->op_sibling)
6646 return too_few_arguments(o,OP_DESC(o));
6647 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
6648 mod(kid, OP_GREPSTART);
6654 Perl_ck_index(pTHX_ OP *o)
6656 if (o->op_flags & OPf_KIDS) {
6657 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6659 kid = kid->op_sibling; /* get past "big" */
6660 if (kid && kid->op_type == OP_CONST)
6661 fbm_compile(((SVOP*)kid)->op_sv, 0);
6667 Perl_ck_lengthconst(pTHX_ OP *o)
6669 /* XXX length optimization goes here */
6674 Perl_ck_lfun(pTHX_ OP *o)
6676 const OPCODE type = o->op_type;
6677 return modkids(ck_fun(o), type);
6681 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
6683 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
6684 switch (cUNOPo->op_first->op_type) {
6686 /* This is needed for
6687 if (defined %stash::)
6688 to work. Do not break Tk.
6690 break; /* Globals via GV can be undef */
6692 case OP_AASSIGN: /* Is this a good idea? */
6693 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6694 "defined(@array) is deprecated");
6695 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6696 "\t(Maybe you should just omit the defined()?)\n");
6699 /* This is needed for
6700 if (defined %stash::)
6701 to work. Do not break Tk.
6703 break; /* Globals via GV can be undef */
6705 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6706 "defined(%%hash) is deprecated");
6707 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6708 "\t(Maybe you should just omit the defined()?)\n");
6719 Perl_ck_rfun(pTHX_ OP *o)
6721 const OPCODE type = o->op_type;
6722 return refkids(ck_fun(o), type);
6726 Perl_ck_listiob(pTHX_ OP *o)
6730 kid = cLISTOPo->op_first;
6733 kid = cLISTOPo->op_first;
6735 if (kid->op_type == OP_PUSHMARK)
6736 kid = kid->op_sibling;
6737 if (kid && o->op_flags & OPf_STACKED)
6738 kid = kid->op_sibling;
6739 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6740 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6741 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6742 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6743 cLISTOPo->op_first->op_sibling = kid;
6744 cLISTOPo->op_last = kid;
6745 kid = kid->op_sibling;
6750 append_elem(o->op_type, o, newDEFSVOP());
6756 Perl_ck_say(pTHX_ OP *o)
6759 o->op_type = OP_PRINT;
6760 cLISTOPo->op_last = cLISTOPo->op_last->op_sibling
6761 = newSVOP(OP_CONST, 0, newSVpvs("\n"));
6766 Perl_ck_smartmatch(pTHX_ OP *o)
6769 if (0 == (o->op_flags & OPf_SPECIAL)) {
6770 OP *first = cBINOPo->op_first;
6771 OP *second = first->op_sibling;
6773 /* Implicitly take a reference to an array or hash */
6774 first->op_sibling = NULL;
6775 first = cBINOPo->op_first = ref_array_or_hash(first);
6776 second = first->op_sibling = ref_array_or_hash(second);
6778 /* Implicitly take a reference to a regular expression */
6779 if (first->op_type == OP_MATCH) {
6780 first->op_type = OP_QR;
6781 first->op_ppaddr = PL_ppaddr[OP_QR];
6783 if (second->op_type == OP_MATCH) {
6784 second->op_type = OP_QR;
6785 second->op_ppaddr = PL_ppaddr[OP_QR];
6794 Perl_ck_sassign(pTHX_ OP *o)
6796 OP * const kid = cLISTOPo->op_first;
6797 /* has a disposable target? */
6798 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6799 && !(kid->op_flags & OPf_STACKED)
6800 /* Cannot steal the second time! */
6801 && !(kid->op_private & OPpTARGET_MY))
6803 OP * const kkid = kid->op_sibling;
6805 /* Can just relocate the target. */
6806 if (kkid && kkid->op_type == OP_PADSV
6807 && !(kkid->op_private & OPpLVAL_INTRO))
6809 kid->op_targ = kkid->op_targ;
6811 /* Now we do not need PADSV and SASSIGN. */
6812 kid->op_sibling = o->op_sibling; /* NULL */
6813 cLISTOPo->op_first = NULL;
6815 op_getmad(o,kid,'O');
6816 op_getmad(kkid,kid,'M');
6821 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6825 if (kid->op_sibling) {
6826 OP *kkid = kid->op_sibling;
6827 if (kkid->op_type == OP_PADSV
6828 && (kkid->op_private & OPpLVAL_INTRO)
6829 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
6830 o->op_private |= OPpASSIGN_STATE;
6831 /* hijacking PADSTALE for uninitialized state variables */
6832 SvPADSTALE_on(PAD_SVl(kkid->op_targ));
6839 Perl_ck_match(pTHX_ OP *o)
6842 if (o->op_type != OP_QR && PL_compcv) {
6843 const PADOFFSET offset = pad_findmy("$_");
6844 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
6845 o->op_targ = offset;
6846 o->op_private |= OPpTARGET_MY;
6849 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
6850 o->op_private |= OPpRUNTIME;
6855 Perl_ck_method(pTHX_ OP *o)
6857 OP * const kid = cUNOPo->op_first;
6858 if (kid->op_type == OP_CONST) {
6859 SV* sv = kSVOP->op_sv;
6860 const char * const method = SvPVX_const(sv);
6861 if (!(strchr(method, ':') || strchr(method, '\''))) {
6863 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6864 sv = newSVpvn_share(method, SvCUR(sv), 0);
6867 kSVOP->op_sv = NULL;
6869 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6871 op_getmad(o,cmop,'O');
6882 Perl_ck_null(pTHX_ OP *o)
6884 PERL_UNUSED_CONTEXT;
6889 Perl_ck_open(pTHX_ OP *o)
6892 HV * const table = GvHV(PL_hintgv);
6894 SV **svp = hv_fetchs(table, "open_IN", FALSE);
6896 const I32 mode = mode_from_discipline(*svp);
6897 if (mode & O_BINARY)
6898 o->op_private |= OPpOPEN_IN_RAW;
6899 else if (mode & O_TEXT)
6900 o->op_private |= OPpOPEN_IN_CRLF;
6903 svp = hv_fetchs(table, "open_OUT", FALSE);
6905 const I32 mode = mode_from_discipline(*svp);
6906 if (mode & O_BINARY)
6907 o->op_private |= OPpOPEN_OUT_RAW;
6908 else if (mode & O_TEXT)
6909 o->op_private |= OPpOPEN_OUT_CRLF;
6912 if (o->op_type == OP_BACKTICK)
6915 /* In case of three-arg dup open remove strictness
6916 * from the last arg if it is a bareword. */
6917 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
6918 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
6922 if ((last->op_type == OP_CONST) && /* The bareword. */
6923 (last->op_private & OPpCONST_BARE) &&
6924 (last->op_private & OPpCONST_STRICT) &&
6925 (oa = first->op_sibling) && /* The fh. */
6926 (oa = oa->op_sibling) && /* The mode. */
6927 (oa->op_type == OP_CONST) &&
6928 SvPOK(((SVOP*)oa)->op_sv) &&
6929 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
6930 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
6931 (last == oa->op_sibling)) /* The bareword. */
6932 last->op_private &= ~OPpCONST_STRICT;
6938 Perl_ck_repeat(pTHX_ OP *o)
6940 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6941 o->op_private |= OPpREPEAT_DOLIST;
6942 cBINOPo->op_first = force_list(cBINOPo->op_first);
6950 Perl_ck_require(pTHX_ OP *o)
6955 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6956 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6958 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6959 SV * const sv = kid->op_sv;
6960 U32 was_readonly = SvREADONLY(sv);
6965 sv_force_normal_flags(sv, 0);
6966 assert(!SvREADONLY(sv));
6973 for (s = SvPVX(sv); *s; s++) {
6974 if (*s == ':' && s[1] == ':') {
6975 const STRLEN len = strlen(s+2)+1;
6977 Move(s+2, s+1, len, char);
6978 SvCUR_set(sv, SvCUR(sv) - 1);
6981 sv_catpvs(sv, ".pm");
6982 SvFLAGS(sv) |= was_readonly;
6986 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
6987 /* handle override, if any */
6988 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
6989 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
6990 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
6991 gv = gvp ? *gvp : NULL;
6995 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6996 OP * const kid = cUNOPo->op_first;
6999 cUNOPo->op_first = 0;
7003 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
7004 append_elem(OP_LIST, kid,
7005 scalar(newUNOP(OP_RV2CV, 0,
7008 op_getmad(o,newop,'O');
7016 Perl_ck_return(pTHX_ OP *o)
7019 if (CvLVALUE(PL_compcv)) {
7021 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
7022 mod(kid, OP_LEAVESUBLV);
7028 Perl_ck_select(pTHX_ OP *o)
7032 if (o->op_flags & OPf_KIDS) {
7033 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7034 if (kid && kid->op_sibling) {
7035 o->op_type = OP_SSELECT;
7036 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
7038 return fold_constants(o);
7042 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7043 if (kid && kid->op_type == OP_RV2GV)
7044 kid->op_private &= ~HINT_STRICT_REFS;
7049 Perl_ck_shift(pTHX_ OP *o)
7052 const I32 type = o->op_type;
7054 if (!(o->op_flags & OPf_KIDS)) {
7056 /* FIXME - this can be refactored to reduce code in #ifdefs */
7058 OP * const oldo = o;
7062 argop = newUNOP(OP_RV2AV, 0,
7063 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
7065 o = newUNOP(type, 0, scalar(argop));
7066 op_getmad(oldo,o,'O');
7069 return newUNOP(type, 0, scalar(argop));
7072 return scalar(modkids(ck_fun(o), type));
7076 Perl_ck_sort(pTHX_ OP *o)
7081 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
7082 HV * const hinthv = GvHV(PL_hintgv);
7084 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
7086 const I32 sorthints = (I32)SvIV(*svp);
7087 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
7088 o->op_private |= OPpSORT_QSORT;
7089 if ((sorthints & HINT_SORT_STABLE) != 0)
7090 o->op_private |= OPpSORT_STABLE;
7095 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
7097 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7098 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
7100 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
7102 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
7104 if (kid->op_type == OP_SCOPE) {
7108 else if (kid->op_type == OP_LEAVE) {
7109 if (o->op_type == OP_SORT) {
7110 op_null(kid); /* wipe out leave */
7113 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
7114 if (k->op_next == kid)
7116 /* don't descend into loops */
7117 else if (k->op_type == OP_ENTERLOOP
7118 || k->op_type == OP_ENTERITER)
7120 k = cLOOPx(k)->op_lastop;
7125 kid->op_next = 0; /* just disconnect the leave */
7126 k = kLISTOP->op_first;
7131 if (o->op_type == OP_SORT) {
7132 /* provide scalar context for comparison function/block */
7138 o->op_flags |= OPf_SPECIAL;
7140 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
7143 firstkid = firstkid->op_sibling;
7146 /* provide list context for arguments */
7147 if (o->op_type == OP_SORT)
7154 S_simplify_sort(pTHX_ OP *o)
7157 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7162 if (!(o->op_flags & OPf_STACKED))
7164 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7165 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
7166 kid = kUNOP->op_first; /* get past null */
7167 if (kid->op_type != OP_SCOPE)
7169 kid = kLISTOP->op_last; /* get past scope */
7170 switch(kid->op_type) {
7178 k = kid; /* remember this node*/
7179 if (kBINOP->op_first->op_type != OP_RV2SV)
7181 kid = kBINOP->op_first; /* get past cmp */
7182 if (kUNOP->op_first->op_type != OP_GV)
7184 kid = kUNOP->op_first; /* get past rv2sv */
7186 if (GvSTASH(gv) != PL_curstash)
7188 gvname = GvNAME(gv);
7189 if (*gvname == 'a' && gvname[1] == '\0')
7191 else if (*gvname == 'b' && gvname[1] == '\0')
7196 kid = k; /* back to cmp */
7197 if (kBINOP->op_last->op_type != OP_RV2SV)
7199 kid = kBINOP->op_last; /* down to 2nd arg */
7200 if (kUNOP->op_first->op_type != OP_GV)
7202 kid = kUNOP->op_first; /* get past rv2sv */
7204 if (GvSTASH(gv) != PL_curstash)
7206 gvname = GvNAME(gv);
7208 ? !(*gvname == 'a' && gvname[1] == '\0')
7209 : !(*gvname == 'b' && gvname[1] == '\0'))
7211 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
7213 o->op_private |= OPpSORT_DESCEND;
7214 if (k->op_type == OP_NCMP)
7215 o->op_private |= OPpSORT_NUMERIC;
7216 if (k->op_type == OP_I_NCMP)
7217 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
7218 kid = cLISTOPo->op_first->op_sibling;
7219 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
7221 op_getmad(kid,o,'S'); /* then delete it */
7223 op_free(kid); /* then delete it */
7228 Perl_ck_split(pTHX_ OP *o)
7233 if (o->op_flags & OPf_STACKED)
7234 return no_fh_allowed(o);
7236 kid = cLISTOPo->op_first;
7237 if (kid->op_type != OP_NULL)
7238 Perl_croak(aTHX_ "panic: ck_split");
7239 kid = kid->op_sibling;
7240 op_free(cLISTOPo->op_first);
7241 cLISTOPo->op_first = kid;
7243 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
7244 cLISTOPo->op_last = kid; /* There was only one element previously */
7247 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
7248 OP * const sibl = kid->op_sibling;
7249 kid->op_sibling = 0;
7250 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
7251 if (cLISTOPo->op_first == cLISTOPo->op_last)
7252 cLISTOPo->op_last = kid;
7253 cLISTOPo->op_first = kid;
7254 kid->op_sibling = sibl;
7257 kid->op_type = OP_PUSHRE;
7258 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
7260 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
7261 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
7262 "Use of /g modifier is meaningless in split");
7265 if (!kid->op_sibling)
7266 append_elem(OP_SPLIT, o, newDEFSVOP());
7268 kid = kid->op_sibling;
7271 if (!kid->op_sibling)
7272 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
7273 assert(kid->op_sibling);
7275 kid = kid->op_sibling;
7278 if (kid->op_sibling)
7279 return too_many_arguments(o,OP_DESC(o));
7285 Perl_ck_join(pTHX_ OP *o)
7287 const OP * const kid = cLISTOPo->op_first->op_sibling;
7288 if (kid && kid->op_type == OP_MATCH) {
7289 if (ckWARN(WARN_SYNTAX)) {
7290 const REGEXP *re = PM_GETRE(kPMOP);
7291 const char *pmstr = re ? re->precomp : "STRING";
7292 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7293 "/%s/ should probably be written as \"%s\"",
7301 Perl_ck_subr(pTHX_ OP *o)
7304 OP *prev = ((cUNOPo->op_first->op_sibling)
7305 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
7306 OP *o2 = prev->op_sibling;
7308 const char *proto = NULL;
7309 const char *proto_end = NULL;
7314 I32 contextclass = 0;
7315 const char *e = NULL;
7318 o->op_private |= OPpENTERSUB_HASTARG;
7319 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
7320 if (cvop->op_type == OP_RV2CV) {
7322 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
7323 op_null(cvop); /* disable rv2cv */
7324 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
7325 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
7326 GV *gv = cGVOPx_gv(tmpop);
7329 tmpop->op_private |= OPpEARLY_CV;
7333 namegv = CvANON(cv) ? gv : CvGV(cv);
7334 proto = SvPV((SV*)cv, len);
7335 proto_end = proto + len;
7337 if (CvASSERTION(cv)) {
7338 U32 asserthints = 0;
7339 HV *const hinthv = GvHV(PL_hintgv);
7341 SV **svp = hv_fetchs(hinthv, "assertions", FALSE);
7343 asserthints = SvUV(*svp);
7345 if (asserthints & HINT_ASSERTING) {
7346 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
7347 o->op_private |= OPpENTERSUB_DB;
7351 if (!(asserthints & HINT_ASSERTIONSSEEN) && ckWARN(WARN_ASSERTIONS)) {
7352 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
7353 "Impossible to activate assertion call");
7360 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7361 if (o2->op_type == OP_CONST)
7362 o2->op_private &= ~OPpCONST_STRICT;
7363 else if (o2->op_type == OP_LIST) {
7364 OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
7365 if (sib && sib->op_type == OP_CONST)
7366 sib->op_private &= ~OPpCONST_STRICT;
7369 o->op_private |= (PL_hints & HINT_STRICT_REFS);
7370 if (PERLDB_SUB && PL_curstash != PL_debstash)
7371 o->op_private |= OPpENTERSUB_DB;
7372 while (o2 != cvop) {
7374 if (PL_madskills && o2->op_type == OP_NULL)
7375 o3 = ((UNOP*)o2)->op_first;
7379 if (proto >= proto_end)
7380 return too_many_arguments(o, gv_ename(namegv));
7388 /* _ must be at the end */
7389 if (proto[1] && proto[1] != ';')
7404 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
7406 arg == 1 ? "block or sub {}" : "sub {}",
7407 gv_ename(namegv), o3);
7410 /* '*' allows any scalar type, including bareword */
7413 if (o3->op_type == OP_RV2GV)
7414 goto wrapref; /* autoconvert GLOB -> GLOBref */
7415 else if (o3->op_type == OP_CONST)
7416 o3->op_private &= ~OPpCONST_STRICT;
7417 else if (o3->op_type == OP_ENTERSUB) {
7418 /* accidental subroutine, revert to bareword */
7419 OP *gvop = ((UNOP*)o3)->op_first;
7420 if (gvop && gvop->op_type == OP_NULL) {
7421 gvop = ((UNOP*)gvop)->op_first;
7423 for (; gvop->op_sibling; gvop = gvop->op_sibling)
7426 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
7427 (gvop = ((UNOP*)gvop)->op_first) &&
7428 gvop->op_type == OP_GV)
7430 GV * const gv = cGVOPx_gv(gvop);
7431 OP * const sibling = o2->op_sibling;
7432 SV * const n = newSVpvs("");
7434 OP * const oldo2 = o2;
7438 gv_fullname4(n, gv, "", FALSE);
7439 o2 = newSVOP(OP_CONST, 0, n);
7440 op_getmad(oldo2,o2,'O');
7441 prev->op_sibling = o2;
7442 o2->op_sibling = sibling;
7458 if (contextclass++ == 0) {
7459 e = strchr(proto, ']');
7460 if (!e || e == proto)
7469 const char *p = proto;
7470 const char *const end = proto;
7472 while (*--p != '[');
7473 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
7475 gv_ename(namegv), o3);
7480 if (o3->op_type == OP_RV2GV)
7483 bad_type(arg, "symbol", gv_ename(namegv), o3);
7486 if (o3->op_type == OP_ENTERSUB)
7489 bad_type(arg, "subroutine entry", gv_ename(namegv),
7493 if (o3->op_type == OP_RV2SV ||
7494 o3->op_type == OP_PADSV ||
7495 o3->op_type == OP_HELEM ||
7496 o3->op_type == OP_AELEM ||
7497 o3->op_type == OP_THREADSV)
7500 bad_type(arg, "scalar", gv_ename(namegv), o3);
7503 if (o3->op_type == OP_RV2AV ||
7504 o3->op_type == OP_PADAV)
7507 bad_type(arg, "array", gv_ename(namegv), o3);
7510 if (o3->op_type == OP_RV2HV ||
7511 o3->op_type == OP_PADHV)
7514 bad_type(arg, "hash", gv_ename(namegv), o3);
7519 OP* const sib = kid->op_sibling;
7520 kid->op_sibling = 0;
7521 o2 = newUNOP(OP_REFGEN, 0, kid);
7522 o2->op_sibling = sib;
7523 prev->op_sibling = o2;
7525 if (contextclass && e) {
7540 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
7541 gv_ename(namegv), (void*)cv);
7546 mod(o2, OP_ENTERSUB);
7548 o2 = o2->op_sibling;
7550 if (o2 == cvop && proto && *proto == '_') {
7551 /* generate an access to $_ */
7553 o2->op_sibling = prev->op_sibling;
7554 prev->op_sibling = o2; /* instead of cvop */
7556 if (proto && !optional && proto_end > proto &&
7557 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
7558 return too_few_arguments(o, gv_ename(namegv));
7561 OP * const oldo = o;
7565 o=newSVOP(OP_CONST, 0, newSViv(0));
7566 op_getmad(oldo,o,'O');
7572 Perl_ck_svconst(pTHX_ OP *o)
7574 PERL_UNUSED_CONTEXT;
7575 SvREADONLY_on(cSVOPo->op_sv);
7580 Perl_ck_chdir(pTHX_ OP *o)
7582 if (o->op_flags & OPf_KIDS) {
7583 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7585 if (kid && kid->op_type == OP_CONST &&
7586 (kid->op_private & OPpCONST_BARE))
7588 o->op_flags |= OPf_SPECIAL;
7589 kid->op_private &= ~OPpCONST_STRICT;
7596 Perl_ck_trunc(pTHX_ OP *o)
7598 if (o->op_flags & OPf_KIDS) {
7599 SVOP *kid = (SVOP*)cUNOPo->op_first;
7601 if (kid->op_type == OP_NULL)
7602 kid = (SVOP*)kid->op_sibling;
7603 if (kid && kid->op_type == OP_CONST &&
7604 (kid->op_private & OPpCONST_BARE))
7606 o->op_flags |= OPf_SPECIAL;
7607 kid->op_private &= ~OPpCONST_STRICT;
7614 Perl_ck_unpack(pTHX_ OP *o)
7616 OP *kid = cLISTOPo->op_first;
7617 if (kid->op_sibling) {
7618 kid = kid->op_sibling;
7619 if (!kid->op_sibling)
7620 kid->op_sibling = newDEFSVOP();
7626 Perl_ck_substr(pTHX_ OP *o)
7629 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
7630 OP *kid = cLISTOPo->op_first;
7632 if (kid->op_type == OP_NULL)
7633 kid = kid->op_sibling;
7635 kid->op_flags |= OPf_MOD;
7641 /* A peephole optimizer. We visit the ops in the order they're to execute.
7642 * See the comments at the top of this file for more details about when
7643 * peep() is called */
7646 Perl_peep(pTHX_ register OP *o)
7649 register OP* oldop = NULL;
7651 if (!o || o->op_opt)
7655 SAVEVPTR(PL_curcop);
7656 for (; o; o = o->op_next) {
7660 switch (o->op_type) {
7664 PL_curcop = ((COP*)o); /* for warnings */
7669 if (cSVOPo->op_private & OPpCONST_STRICT)
7670 no_bareword_allowed(o);
7672 case OP_METHOD_NAMED:
7673 /* Relocate sv to the pad for thread safety.
7674 * Despite being a "constant", the SV is written to,
7675 * for reference counts, sv_upgrade() etc. */
7677 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
7678 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
7679 /* If op_sv is already a PADTMP then it is being used by
7680 * some pad, so make a copy. */
7681 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
7682 SvREADONLY_on(PAD_SVl(ix));
7683 SvREFCNT_dec(cSVOPo->op_sv);
7685 else if (o->op_type == OP_CONST
7686 && cSVOPo->op_sv == &PL_sv_undef) {
7687 /* PL_sv_undef is hack - it's unsafe to store it in the
7688 AV that is the pad, because av_fetch treats values of
7689 PL_sv_undef as a "free" AV entry and will merrily
7690 replace them with a new SV, causing pad_alloc to think
7691 that this pad slot is free. (When, clearly, it is not)
7693 SvOK_off(PAD_SVl(ix));
7694 SvPADTMP_on(PAD_SVl(ix));
7695 SvREADONLY_on(PAD_SVl(ix));
7698 SvREFCNT_dec(PAD_SVl(ix));
7699 SvPADTMP_on(cSVOPo->op_sv);
7700 PAD_SETSV(ix, cSVOPo->op_sv);
7701 /* XXX I don't know how this isn't readonly already. */
7702 SvREADONLY_on(PAD_SVl(ix));
7704 cSVOPo->op_sv = NULL;
7712 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
7713 if (o->op_next->op_private & OPpTARGET_MY) {
7714 if (o->op_flags & OPf_STACKED) /* chained concats */
7715 goto ignore_optimization;
7717 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
7718 o->op_targ = o->op_next->op_targ;
7719 o->op_next->op_targ = 0;
7720 o->op_private |= OPpTARGET_MY;
7723 op_null(o->op_next);
7725 ignore_optimization:
7729 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
7731 break; /* Scalar stub must produce undef. List stub is noop */
7735 if (o->op_targ == OP_NEXTSTATE
7736 || o->op_targ == OP_DBSTATE
7737 || o->op_targ == OP_SETSTATE)
7739 PL_curcop = ((COP*)o);
7741 /* XXX: We avoid setting op_seq here to prevent later calls
7742 to peep() from mistakenly concluding that optimisation
7743 has already occurred. This doesn't fix the real problem,
7744 though (See 20010220.007). AMS 20010719 */
7745 /* op_seq functionality is now replaced by op_opt */
7746 if (oldop && o->op_next) {
7747 oldop->op_next = o->op_next;
7755 if (oldop && o->op_next) {
7756 oldop->op_next = o->op_next;
7764 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
7765 OP* const pop = (o->op_type == OP_PADAV) ?
7766 o->op_next : o->op_next->op_next;
7768 if (pop && pop->op_type == OP_CONST &&
7769 ((PL_op = pop->op_next)) &&
7770 pop->op_next->op_type == OP_AELEM &&
7771 !(pop->op_next->op_private &
7772 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
7773 (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
7778 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
7779 no_bareword_allowed(pop);
7780 if (o->op_type == OP_GV)
7781 op_null(o->op_next);
7782 op_null(pop->op_next);
7784 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
7785 o->op_next = pop->op_next->op_next;
7786 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
7787 o->op_private = (U8)i;
7788 if (o->op_type == OP_GV) {
7793 o->op_flags |= OPf_SPECIAL;
7794 o->op_type = OP_AELEMFAST;
7800 if (o->op_next->op_type == OP_RV2SV) {
7801 if (!(o->op_next->op_private & OPpDEREF)) {
7802 op_null(o->op_next);
7803 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
7805 o->op_next = o->op_next->op_next;
7806 o->op_type = OP_GVSV;
7807 o->op_ppaddr = PL_ppaddr[OP_GVSV];
7810 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
7811 GV * const gv = cGVOPo_gv;
7812 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
7813 /* XXX could check prototype here instead of just carping */
7814 SV * const sv = sv_newmortal();
7815 gv_efullname3(sv, gv, NULL);
7816 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
7817 "%"SVf"() called too early to check prototype",
7821 else if (o->op_next->op_type == OP_READLINE
7822 && o->op_next->op_next->op_type == OP_CONCAT
7823 && (o->op_next->op_next->op_flags & OPf_STACKED))
7825 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
7826 o->op_type = OP_RCATLINE;
7827 o->op_flags |= OPf_STACKED;
7828 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
7829 op_null(o->op_next->op_next);
7830 op_null(o->op_next);
7847 while (cLOGOP->op_other->op_type == OP_NULL)
7848 cLOGOP->op_other = cLOGOP->op_other->op_next;
7849 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
7855 while (cLOOP->op_redoop->op_type == OP_NULL)
7856 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
7857 peep(cLOOP->op_redoop);
7858 while (cLOOP->op_nextop->op_type == OP_NULL)
7859 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
7860 peep(cLOOP->op_nextop);
7861 while (cLOOP->op_lastop->op_type == OP_NULL)
7862 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
7863 peep(cLOOP->op_lastop);
7870 while (cPMOP->op_pmreplstart &&
7871 cPMOP->op_pmreplstart->op_type == OP_NULL)
7872 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
7873 peep(cPMOP->op_pmreplstart);
7878 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
7879 && ckWARN(WARN_SYNTAX))
7881 if (o->op_next->op_sibling) {
7882 const OPCODE type = o->op_next->op_sibling->op_type;
7883 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
7884 const line_t oldline = CopLINE(PL_curcop);
7885 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
7886 Perl_warner(aTHX_ packWARN(WARN_EXEC),
7887 "Statement unlikely to be reached");
7888 Perl_warner(aTHX_ packWARN(WARN_EXEC),
7889 "\t(Maybe you meant system() when you said exec()?)\n");
7890 CopLINE_set(PL_curcop, oldline);
7901 const char *key = NULL;
7906 if (((BINOP*)o)->op_last->op_type != OP_CONST)
7909 /* Make the CONST have a shared SV */
7910 svp = cSVOPx_svp(((BINOP*)o)->op_last);
7911 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
7912 key = SvPV_const(sv, keylen);
7913 lexname = newSVpvn_share(key,
7914 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
7920 if ((o->op_private & (OPpLVAL_INTRO)))
7923 rop = (UNOP*)((BINOP*)o)->op_first;
7924 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7926 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7927 if (!SvPAD_TYPED(lexname))
7929 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
7930 if (!fields || !GvHV(*fields))
7932 key = SvPV_const(*svp, keylen);
7933 if (!hv_fetch(GvHV(*fields), key,
7934 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
7936 Perl_croak(aTHX_ "No such class field \"%s\" "
7937 "in variable %s of type %s",
7938 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
7951 SVOP *first_key_op, *key_op;
7953 if ((o->op_private & (OPpLVAL_INTRO))
7954 /* I bet there's always a pushmark... */
7955 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
7956 /* hmmm, no optimization if list contains only one key. */
7958 rop = (UNOP*)((LISTOP*)o)->op_last;
7959 if (rop->op_type != OP_RV2HV)
7961 if (rop->op_first->op_type == OP_PADSV)
7962 /* @$hash{qw(keys here)} */
7963 rop = (UNOP*)rop->op_first;
7965 /* @{$hash}{qw(keys here)} */
7966 if (rop->op_first->op_type == OP_SCOPE
7967 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
7969 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
7975 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
7976 if (!SvPAD_TYPED(lexname))
7978 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
7979 if (!fields || !GvHV(*fields))
7981 /* Again guessing that the pushmark can be jumped over.... */
7982 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
7983 ->op_first->op_sibling;
7984 for (key_op = first_key_op; key_op;
7985 key_op = (SVOP*)key_op->op_sibling) {
7986 if (key_op->op_type != OP_CONST)
7988 svp = cSVOPx_svp(key_op);
7989 key = SvPV_const(*svp, keylen);
7990 if (!hv_fetch(GvHV(*fields), key,
7991 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
7993 Perl_croak(aTHX_ "No such class field \"%s\" "
7994 "in variable %s of type %s",
7995 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
8002 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
8006 /* check that RHS of sort is a single plain array */
8007 OP *oright = cUNOPo->op_first;
8008 if (!oright || oright->op_type != OP_PUSHMARK)
8011 /* reverse sort ... can be optimised. */
8012 if (!cUNOPo->op_sibling) {
8013 /* Nothing follows us on the list. */
8014 OP * const reverse = o->op_next;
8016 if (reverse->op_type == OP_REVERSE &&
8017 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
8018 OP * const pushmark = cUNOPx(reverse)->op_first;
8019 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
8020 && (cUNOPx(pushmark)->op_sibling == o)) {
8021 /* reverse -> pushmark -> sort */
8022 o->op_private |= OPpSORT_REVERSE;
8024 pushmark->op_next = oright->op_next;
8030 /* make @a = sort @a act in-place */
8034 oright = cUNOPx(oright)->op_sibling;
8037 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
8038 oright = cUNOPx(oright)->op_sibling;
8042 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
8043 || oright->op_next != o
8044 || (oright->op_private & OPpLVAL_INTRO)
8048 /* o2 follows the chain of op_nexts through the LHS of the
8049 * assign (if any) to the aassign op itself */
8051 if (!o2 || o2->op_type != OP_NULL)
8054 if (!o2 || o2->op_type != OP_PUSHMARK)
8057 if (o2 && o2->op_type == OP_GV)
8060 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
8061 || (o2->op_private & OPpLVAL_INTRO)
8066 if (!o2 || o2->op_type != OP_NULL)
8069 if (!o2 || o2->op_type != OP_AASSIGN
8070 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
8073 /* check that the sort is the first arg on RHS of assign */
8075 o2 = cUNOPx(o2)->op_first;
8076 if (!o2 || o2->op_type != OP_NULL)
8078 o2 = cUNOPx(o2)->op_first;
8079 if (!o2 || o2->op_type != OP_PUSHMARK)
8081 if (o2->op_sibling != o)
8084 /* check the array is the same on both sides */
8085 if (oleft->op_type == OP_RV2AV) {
8086 if (oright->op_type != OP_RV2AV
8087 || !cUNOPx(oright)->op_first
8088 || cUNOPx(oright)->op_first->op_type != OP_GV
8089 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
8090 cGVOPx_gv(cUNOPx(oright)->op_first)
8094 else if (oright->op_type != OP_PADAV
8095 || oright->op_targ != oleft->op_targ
8099 /* transfer MODishness etc from LHS arg to RHS arg */
8100 oright->op_flags = oleft->op_flags;
8101 o->op_private |= OPpSORT_INPLACE;
8103 /* excise push->gv->rv2av->null->aassign */
8104 o2 = o->op_next->op_next;
8105 op_null(o2); /* PUSHMARK */
8107 if (o2->op_type == OP_GV) {
8108 op_null(o2); /* GV */
8111 op_null(o2); /* RV2AV or PADAV */
8112 o2 = o2->op_next->op_next;
8113 op_null(o2); /* AASSIGN */
8115 o->op_next = o2->op_next;
8121 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
8123 LISTOP *enter, *exlist;
8126 enter = (LISTOP *) o->op_next;
8129 if (enter->op_type == OP_NULL) {
8130 enter = (LISTOP *) enter->op_next;
8134 /* for $a (...) will have OP_GV then OP_RV2GV here.
8135 for (...) just has an OP_GV. */
8136 if (enter->op_type == OP_GV) {
8137 gvop = (OP *) enter;
8138 enter = (LISTOP *) enter->op_next;
8141 if (enter->op_type == OP_RV2GV) {
8142 enter = (LISTOP *) enter->op_next;
8148 if (enter->op_type != OP_ENTERITER)
8151 iter = enter->op_next;
8152 if (!iter || iter->op_type != OP_ITER)
8155 expushmark = enter->op_first;
8156 if (!expushmark || expushmark->op_type != OP_NULL
8157 || expushmark->op_targ != OP_PUSHMARK)
8160 exlist = (LISTOP *) expushmark->op_sibling;
8161 if (!exlist || exlist->op_type != OP_NULL
8162 || exlist->op_targ != OP_LIST)
8165 if (exlist->op_last != o) {
8166 /* Mmm. Was expecting to point back to this op. */
8169 theirmark = exlist->op_first;
8170 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
8173 if (theirmark->op_sibling != o) {
8174 /* There's something between the mark and the reverse, eg
8175 for (1, reverse (...))
8180 ourmark = ((LISTOP *)o)->op_first;
8181 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
8184 ourlast = ((LISTOP *)o)->op_last;
8185 if (!ourlast || ourlast->op_next != o)
8188 rv2av = ourmark->op_sibling;
8189 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
8190 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
8191 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
8192 /* We're just reversing a single array. */
8193 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
8194 enter->op_flags |= OPf_STACKED;
8197 /* We don't have control over who points to theirmark, so sacrifice
8199 theirmark->op_next = ourmark->op_next;
8200 theirmark->op_flags = ourmark->op_flags;
8201 ourlast->op_next = gvop ? gvop : (OP *) enter;
8204 enter->op_private |= OPpITER_REVERSED;
8205 iter->op_private |= OPpITER_REVERSED;
8212 UNOP *refgen, *rv2cv;
8215 /* I do not understand this, but if o->op_opt isn't set to 1,
8216 various tests in ext/B/t/bytecode.t fail with no readily
8222 if ((o->op_flags && OPf_WANT) != OPf_WANT_VOID)
8225 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
8228 rv2gv = ((BINOP *)o)->op_last;
8229 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
8232 refgen = (UNOP *)((BINOP *)o)->op_first;
8234 if (!refgen || refgen->op_type != OP_REFGEN)
8237 exlist = (LISTOP *)refgen->op_first;
8238 if (!exlist || exlist->op_type != OP_NULL
8239 || exlist->op_targ != OP_LIST)
8242 if (exlist->op_first->op_type != OP_PUSHMARK)
8245 rv2cv = (UNOP*)exlist->op_last;
8247 if (rv2cv->op_type != OP_RV2CV)
8250 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
8251 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
8252 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
8254 o->op_private |= OPpASSIGN_CV_TO_GV;
8255 rv2gv->op_private |= OPpDONT_INIT_GV;
8256 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
8272 Perl_custom_op_name(pTHX_ const OP* o)
8275 const IV index = PTR2IV(o->op_ppaddr);
8279 if (!PL_custom_op_names) /* This probably shouldn't happen */
8280 return (char *)PL_op_name[OP_CUSTOM];
8282 keysv = sv_2mortal(newSViv(index));
8284 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
8286 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
8288 return SvPV_nolen(HeVAL(he));
8292 Perl_custom_op_desc(pTHX_ const OP* o)
8295 const IV index = PTR2IV(o->op_ppaddr);
8299 if (!PL_custom_op_descs)
8300 return (char *)PL_op_desc[OP_CUSTOM];
8302 keysv = sv_2mortal(newSViv(index));
8304 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
8306 return (char *)PL_op_desc[OP_CUSTOM];
8308 return SvPV_nolen(HeVAL(he));
8313 /* Efficient sub that returns a constant scalar value. */
8315 const_sv_xsub(pTHX_ CV* cv)
8322 Perl_croak(aTHX_ "usage: %s::%s()",
8323 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
8327 ST(0) = (SV*)XSANY.any_ptr;
8333 * c-indentation-style: bsd
8335 * indent-tabs-mode: t
8338 * ex: set ts=8 sts=4 sw=4 noet: