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
280 /* free the body of an op without examining its contents.
281 * Always use this rather than FreeOp directly */
284 S_op_destroy(pTHX_ OP *o)
286 if (o->op_latefree) {
297 Perl_op_free(pTHX_ OP *o)
302 if (!o || o->op_static)
304 if (o->op_latefreed) {
311 if (o->op_private & OPpREFCOUNTED) {
322 refcnt = OpREFCNT_dec(o);
333 if (o->op_flags & OPf_KIDS) {
334 register OP *kid, *nextkid;
335 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
336 nextkid = kid->op_sibling; /* Get before next freeing kid */
341 type = (OPCODE)o->op_targ;
343 /* COP* is not cleared by op_clear() so that we may track line
344 * numbers etc even after null() */
345 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
349 if (o->op_latefree) {
355 #ifdef DEBUG_LEAKING_SCALARS
362 Perl_op_clear(pTHX_ OP *o)
367 /* if (o->op_madprop && o->op_madprop->mad_next)
369 /* FIXME for MAD - if I uncomment these two lines t/op/pack.t fails with
370 "modification of a read only value" for a reason I can't fathom why.
371 It's the "" stringification of $_, where $_ was set to '' in a foreach
372 loop, but it defies simplification into a small test case.
373 However, commenting them out has caused ext/List/Util/t/weak.t to fail
376 mad_free(o->op_madprop);
382 switch (o->op_type) {
383 case OP_NULL: /* Was holding old type, if any. */
384 if (PL_madskills && o->op_targ != OP_NULL) {
385 o->op_type = o->op_targ;
389 case OP_ENTEREVAL: /* Was holding hints. */
393 if (!(o->op_flags & OPf_REF)
394 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
400 if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
401 /* not an OP_PADAV replacement */
403 if (cPADOPo->op_padix > 0) {
404 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
405 * may still exist on the pad */
406 pad_swipe(cPADOPo->op_padix, TRUE);
407 cPADOPo->op_padix = 0;
410 SvREFCNT_dec(cSVOPo->op_sv);
411 cSVOPo->op_sv = NULL;
415 case OP_METHOD_NAMED:
417 SvREFCNT_dec(cSVOPo->op_sv);
418 cSVOPo->op_sv = NULL;
421 Even if op_clear does a pad_free for the target of the op,
422 pad_free doesn't actually remove the sv that exists in the pad;
423 instead it lives on. This results in that it could be reused as
424 a target later on when the pad was reallocated.
427 pad_swipe(o->op_targ,1);
436 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
440 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
441 SvREFCNT_dec(cSVOPo->op_sv);
442 cSVOPo->op_sv = NULL;
445 Safefree(cPVOPo->op_pv);
446 cPVOPo->op_pv = NULL;
450 op_free(cPMOPo->op_pmreplroot);
454 if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) {
455 /* No GvIN_PAD_off here, because other references may still
456 * exist on the pad */
457 pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot), TRUE);
460 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
467 HV * const pmstash = PmopSTASH(cPMOPo);
468 if (pmstash && !SvIS_FREED(pmstash)) {
469 MAGIC * const mg = mg_find((SV*)pmstash, PERL_MAGIC_symtab);
471 PMOP *pmop = (PMOP*) mg->mg_obj;
472 PMOP *lastpmop = NULL;
474 if (cPMOPo == pmop) {
476 lastpmop->op_pmnext = pmop->op_pmnext;
478 mg->mg_obj = (SV*) pmop->op_pmnext;
482 pmop = pmop->op_pmnext;
486 PmopSTASH_free(cPMOPo);
488 cPMOPo->op_pmreplroot = NULL;
489 /* we use the "SAFE" version of the PM_ macros here
490 * since sv_clean_all might release some PMOPs
491 * after PL_regex_padav has been cleared
492 * and the clearing of PL_regex_padav needs to
493 * happen before sv_clean_all
495 ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
496 PM_SETRE_SAFE(cPMOPo, NULL);
498 if(PL_regex_pad) { /* We could be in destruction */
499 av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
500 SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
501 PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
508 if (o->op_targ > 0) {
509 pad_free(o->op_targ);
515 S_cop_free(pTHX_ COP* cop)
520 if (! specialWARN(cop->cop_warnings))
521 PerlMemShared_free(cop->cop_warnings);
522 Perl_refcounted_he_free(aTHX_ cop->cop_hints_hash);
526 Perl_op_null(pTHX_ OP *o)
529 if (o->op_type == OP_NULL)
533 o->op_targ = o->op_type;
534 o->op_type = OP_NULL;
535 o->op_ppaddr = PL_ppaddr[OP_NULL];
539 Perl_op_refcnt_lock(pTHX)
547 Perl_op_refcnt_unlock(pTHX)
554 /* Contextualizers */
556 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
559 Perl_linklist(pTHX_ OP *o)
566 /* establish postfix order */
567 first = cUNOPo->op_first;
570 o->op_next = LINKLIST(first);
573 if (kid->op_sibling) {
574 kid->op_next = LINKLIST(kid->op_sibling);
575 kid = kid->op_sibling;
589 Perl_scalarkids(pTHX_ OP *o)
591 if (o && o->op_flags & OPf_KIDS) {
593 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
600 S_scalarboolean(pTHX_ OP *o)
603 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
604 if (ckWARN(WARN_SYNTAX)) {
605 const line_t oldline = CopLINE(PL_curcop);
607 if (PL_copline != NOLINE)
608 CopLINE_set(PL_curcop, PL_copline);
609 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
610 CopLINE_set(PL_curcop, oldline);
617 Perl_scalar(pTHX_ OP *o)
622 /* assumes no premature commitment */
623 if (!o || PL_error_count || (o->op_flags & OPf_WANT)
624 || o->op_type == OP_RETURN)
629 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
631 switch (o->op_type) {
633 scalar(cBINOPo->op_first);
638 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
642 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
643 if (!kPMOP->op_pmreplroot)
644 deprecate_old("implicit split to @_");
652 if (o->op_flags & OPf_KIDS) {
653 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
659 kid = cLISTOPo->op_first;
661 while ((kid = kid->op_sibling)) {
667 PL_curcop = &PL_compiling;
672 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
678 PL_curcop = &PL_compiling;
681 if (ckWARN(WARN_VOID))
682 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
688 Perl_scalarvoid(pTHX_ OP *o)
692 const char* useless = NULL;
696 /* trailing mad null ops don't count as "there" for void processing */
698 o->op_type != OP_NULL &&
700 o->op_sibling->op_type == OP_NULL)
703 for (sib = o->op_sibling;
704 sib && sib->op_type == OP_NULL;
705 sib = sib->op_sibling) ;
711 if (o->op_type == OP_NEXTSTATE
712 || o->op_type == OP_SETSTATE
713 || o->op_type == OP_DBSTATE
714 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
715 || o->op_targ == OP_SETSTATE
716 || o->op_targ == OP_DBSTATE)))
717 PL_curcop = (COP*)o; /* for warning below */
719 /* assumes no premature commitment */
720 want = o->op_flags & OPf_WANT;
721 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
722 || o->op_type == OP_RETURN)
727 if ((o->op_private & OPpTARGET_MY)
728 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
730 return scalar(o); /* As if inside SASSIGN */
733 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
735 switch (o->op_type) {
737 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
741 if (o->op_flags & OPf_STACKED)
745 if (o->op_private == 4)
817 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
818 useless = OP_DESC(o);
822 kid = cUNOPo->op_first;
823 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
824 kid->op_type != OP_TRANS) {
827 useless = "negative pattern binding (!~)";
834 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
835 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
836 useless = "a variable";
841 if (cSVOPo->op_private & OPpCONST_STRICT)
842 no_bareword_allowed(o);
844 if (ckWARN(WARN_VOID)) {
845 useless = "a constant";
846 if (o->op_private & OPpCONST_ARYBASE)
848 /* don't warn on optimised away booleans, eg
849 * use constant Foo, 5; Foo || print; */
850 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
852 /* the constants 0 and 1 are permitted as they are
853 conventionally used as dummies in constructs like
854 1 while some_condition_with_side_effects; */
855 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
857 else if (SvPOK(sv)) {
858 /* perl4's way of mixing documentation and code
859 (before the invention of POD) was based on a
860 trick to mix nroff and perl code. The trick was
861 built upon these three nroff macros being used in
862 void context. The pink camel has the details in
863 the script wrapman near page 319. */
864 const char * const maybe_macro = SvPVX_const(sv);
865 if (strnEQ(maybe_macro, "di", 2) ||
866 strnEQ(maybe_macro, "ds", 2) ||
867 strnEQ(maybe_macro, "ig", 2))
872 op_null(o); /* don't execute or even remember it */
876 o->op_type = OP_PREINC; /* pre-increment is faster */
877 o->op_ppaddr = PL_ppaddr[OP_PREINC];
881 o->op_type = OP_PREDEC; /* pre-decrement is faster */
882 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
886 o->op_type = OP_I_PREINC; /* pre-increment is faster */
887 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
891 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
892 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
901 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
906 if (o->op_flags & OPf_STACKED)
913 if (!(o->op_flags & OPf_KIDS))
924 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
931 /* all requires must return a boolean value */
932 o->op_flags &= ~OPf_WANT;
937 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
938 if (!kPMOP->op_pmreplroot)
939 deprecate_old("implicit split to @_");
943 if (useless && ckWARN(WARN_VOID))
944 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
949 Perl_listkids(pTHX_ OP *o)
951 if (o && o->op_flags & OPf_KIDS) {
953 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
960 Perl_list(pTHX_ OP *o)
965 /* assumes no premature commitment */
966 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
967 || o->op_type == OP_RETURN)
972 if ((o->op_private & OPpTARGET_MY)
973 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
975 return o; /* As if inside SASSIGN */
978 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
980 switch (o->op_type) {
983 list(cBINOPo->op_first);
988 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
996 if (!(o->op_flags & OPf_KIDS))
998 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
999 list(cBINOPo->op_first);
1000 return gen_constant_list(o);
1007 kid = cLISTOPo->op_first;
1009 while ((kid = kid->op_sibling)) {
1010 if (kid->op_sibling)
1015 PL_curcop = &PL_compiling;
1019 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1020 if (kid->op_sibling)
1025 PL_curcop = &PL_compiling;
1028 /* all requires must return a boolean value */
1029 o->op_flags &= ~OPf_WANT;
1036 Perl_scalarseq(pTHX_ OP *o)
1040 const OPCODE type = o->op_type;
1042 if (type == OP_LINESEQ || type == OP_SCOPE ||
1043 type == OP_LEAVE || type == OP_LEAVETRY)
1046 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1047 if (kid->op_sibling) {
1051 PL_curcop = &PL_compiling;
1053 o->op_flags &= ~OPf_PARENS;
1054 if (PL_hints & HINT_BLOCK_SCOPE)
1055 o->op_flags |= OPf_PARENS;
1058 o = newOP(OP_STUB, 0);
1063 S_modkids(pTHX_ OP *o, I32 type)
1065 if (o && o->op_flags & OPf_KIDS) {
1067 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1073 /* Propagate lvalue ("modifiable") context to an op and its children.
1074 * 'type' represents the context type, roughly based on the type of op that
1075 * would do the modifying, although local() is represented by OP_NULL.
1076 * It's responsible for detecting things that can't be modified, flag
1077 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
1078 * might have to vivify a reference in $x), and so on.
1080 * For example, "$a+1 = 2" would cause mod() to be called with o being
1081 * OP_ADD and type being OP_SASSIGN, and would output an error.
1085 Perl_mod(pTHX_ OP *o, I32 type)
1089 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1092 if (!o || PL_error_count)
1095 if ((o->op_private & OPpTARGET_MY)
1096 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1101 switch (o->op_type) {
1107 if (!(o->op_private & OPpCONST_ARYBASE))
1110 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1111 CopARYBASE_set(&PL_compiling,
1112 (I32)SvIV(cSVOPx(PL_eval_start)->op_sv));
1116 SAVECOPARYBASE(&PL_compiling);
1117 CopARYBASE_set(&PL_compiling, 0);
1119 else if (type == OP_REFGEN)
1122 Perl_croak(aTHX_ "That use of $[ is unsupported");
1125 if (o->op_flags & OPf_PARENS || PL_madskills)
1129 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1130 !(o->op_flags & OPf_STACKED)) {
1131 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1132 /* The default is to set op_private to the number of children,
1133 which for a UNOP such as RV2CV is always 1. And w're using
1134 the bit for a flag in RV2CV, so we need it clear. */
1135 o->op_private &= ~1;
1136 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1137 assert(cUNOPo->op_first->op_type == OP_NULL);
1138 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1141 else if (o->op_private & OPpENTERSUB_NOMOD)
1143 else { /* lvalue subroutine call */
1144 o->op_private |= OPpLVAL_INTRO;
1145 PL_modcount = RETURN_UNLIMITED_NUMBER;
1146 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1147 /* Backward compatibility mode: */
1148 o->op_private |= OPpENTERSUB_INARGS;
1151 else { /* Compile-time error message: */
1152 OP *kid = cUNOPo->op_first;
1156 if (kid->op_type != OP_PUSHMARK) {
1157 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1159 "panic: unexpected lvalue entersub "
1160 "args: type/targ %ld:%"UVuf,
1161 (long)kid->op_type, (UV)kid->op_targ);
1162 kid = kLISTOP->op_first;
1164 while (kid->op_sibling)
1165 kid = kid->op_sibling;
1166 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1168 if (kid->op_type == OP_METHOD_NAMED
1169 || kid->op_type == OP_METHOD)
1173 NewOp(1101, newop, 1, UNOP);
1174 newop->op_type = OP_RV2CV;
1175 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1176 newop->op_first = NULL;
1177 newop->op_next = (OP*)newop;
1178 kid->op_sibling = (OP*)newop;
1179 newop->op_private |= OPpLVAL_INTRO;
1180 newop->op_private &= ~1;
1184 if (kid->op_type != OP_RV2CV)
1186 "panic: unexpected lvalue entersub "
1187 "entry via type/targ %ld:%"UVuf,
1188 (long)kid->op_type, (UV)kid->op_targ);
1189 kid->op_private |= OPpLVAL_INTRO;
1190 break; /* Postpone until runtime */
1194 kid = kUNOP->op_first;
1195 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1196 kid = kUNOP->op_first;
1197 if (kid->op_type == OP_NULL)
1199 "Unexpected constant lvalue entersub "
1200 "entry via type/targ %ld:%"UVuf,
1201 (long)kid->op_type, (UV)kid->op_targ);
1202 if (kid->op_type != OP_GV) {
1203 /* Restore RV2CV to check lvalueness */
1205 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1206 okid->op_next = kid->op_next;
1207 kid->op_next = okid;
1210 okid->op_next = NULL;
1211 okid->op_type = OP_RV2CV;
1213 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1214 okid->op_private |= OPpLVAL_INTRO;
1215 okid->op_private &= ~1;
1219 cv = GvCV(kGVOP_gv);
1229 /* grep, foreach, subcalls, refgen */
1230 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1232 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1233 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1235 : (o->op_type == OP_ENTERSUB
1236 ? "non-lvalue subroutine call"
1238 type ? PL_op_desc[type] : "local"));
1252 case OP_RIGHT_SHIFT:
1261 if (!(o->op_flags & OPf_STACKED))
1268 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1274 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1275 PL_modcount = RETURN_UNLIMITED_NUMBER;
1276 return o; /* Treat \(@foo) like ordinary list. */
1280 if (scalar_mod_type(o, type))
1282 ref(cUNOPo->op_first, o->op_type);
1286 if (type == OP_LEAVESUBLV)
1287 o->op_private |= OPpMAYBE_LVSUB;
1293 PL_modcount = RETURN_UNLIMITED_NUMBER;
1296 ref(cUNOPo->op_first, o->op_type);
1301 PL_hints |= HINT_BLOCK_SCOPE;
1316 PL_modcount = RETURN_UNLIMITED_NUMBER;
1317 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1318 return o; /* Treat \(@foo) like ordinary list. */
1319 if (scalar_mod_type(o, type))
1321 if (type == OP_LEAVESUBLV)
1322 o->op_private |= OPpMAYBE_LVSUB;
1326 if (!type) /* local() */
1327 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1328 PAD_COMPNAME_PV(o->op_targ));
1336 if (type != OP_SASSIGN)
1340 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1345 if (type == OP_LEAVESUBLV)
1346 o->op_private |= OPpMAYBE_LVSUB;
1348 pad_free(o->op_targ);
1349 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1350 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1351 if (o->op_flags & OPf_KIDS)
1352 mod(cBINOPo->op_first->op_sibling, type);
1357 ref(cBINOPo->op_first, o->op_type);
1358 if (type == OP_ENTERSUB &&
1359 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1360 o->op_private |= OPpLVAL_DEFER;
1361 if (type == OP_LEAVESUBLV)
1362 o->op_private |= OPpMAYBE_LVSUB;
1372 if (o->op_flags & OPf_KIDS)
1373 mod(cLISTOPo->op_last, type);
1378 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1380 else if (!(o->op_flags & OPf_KIDS))
1382 if (o->op_targ != OP_LIST) {
1383 mod(cBINOPo->op_first, type);
1389 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1394 if (type != OP_LEAVESUBLV)
1396 break; /* mod()ing was handled by ck_return() */
1399 /* [20011101.069] File test operators interpret OPf_REF to mean that
1400 their argument is a filehandle; thus \stat(".") should not set
1402 if (type == OP_REFGEN &&
1403 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1406 if (type != OP_LEAVESUBLV)
1407 o->op_flags |= OPf_MOD;
1409 if (type == OP_AASSIGN || type == OP_SASSIGN)
1410 o->op_flags |= OPf_SPECIAL|OPf_REF;
1411 else if (!type) { /* local() */
1414 o->op_private |= OPpLVAL_INTRO;
1415 o->op_flags &= ~OPf_SPECIAL;
1416 PL_hints |= HINT_BLOCK_SCOPE;
1421 if (ckWARN(WARN_SYNTAX)) {
1422 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1423 "Useless localization of %s", OP_DESC(o));
1427 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1428 && type != OP_LEAVESUBLV)
1429 o->op_flags |= OPf_REF;
1434 S_scalar_mod_type(const OP *o, I32 type)
1438 if (o->op_type == OP_RV2GV)
1462 case OP_RIGHT_SHIFT:
1481 S_is_handle_constructor(const OP *o, I32 numargs)
1483 switch (o->op_type) {
1491 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1504 Perl_refkids(pTHX_ OP *o, I32 type)
1506 if (o && o->op_flags & OPf_KIDS) {
1508 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1515 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
1520 if (!o || PL_error_count)
1523 switch (o->op_type) {
1525 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1526 !(o->op_flags & OPf_STACKED)) {
1527 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1528 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1529 assert(cUNOPo->op_first->op_type == OP_NULL);
1530 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1531 o->op_flags |= OPf_SPECIAL;
1532 o->op_private &= ~1;
1537 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1538 doref(kid, type, set_op_ref);
1541 if (type == OP_DEFINED)
1542 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1543 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1546 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1547 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1548 : type == OP_RV2HV ? OPpDEREF_HV
1550 o->op_flags |= OPf_MOD;
1555 o->op_flags |= OPf_MOD; /* XXX ??? */
1561 o->op_flags |= OPf_REF;
1564 if (type == OP_DEFINED)
1565 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1566 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1572 o->op_flags |= OPf_REF;
1577 if (!(o->op_flags & OPf_KIDS))
1579 doref(cBINOPo->op_first, type, set_op_ref);
1583 doref(cBINOPo->op_first, o->op_type, set_op_ref);
1584 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1585 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1586 : type == OP_RV2HV ? OPpDEREF_HV
1588 o->op_flags |= OPf_MOD;
1598 if (!(o->op_flags & OPf_KIDS))
1600 doref(cLISTOPo->op_last, type, set_op_ref);
1610 S_dup_attrlist(pTHX_ OP *o)
1615 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1616 * where the first kid is OP_PUSHMARK and the remaining ones
1617 * are OP_CONST. We need to push the OP_CONST values.
1619 if (o->op_type == OP_CONST)
1620 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
1622 else if (o->op_type == OP_NULL)
1626 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1628 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1629 if (o->op_type == OP_CONST)
1630 rop = append_elem(OP_LIST, rop,
1631 newSVOP(OP_CONST, o->op_flags,
1632 SvREFCNT_inc_NN(cSVOPo->op_sv)));
1639 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1644 /* fake up C<use attributes $pkg,$rv,@attrs> */
1645 ENTER; /* need to protect against side-effects of 'use' */
1647 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1649 #define ATTRSMODULE "attributes"
1650 #define ATTRSMODULE_PM "attributes.pm"
1653 /* Don't force the C<use> if we don't need it. */
1654 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
1655 if (svp && *svp != &PL_sv_undef)
1656 NOOP; /* already in %INC */
1658 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1659 newSVpvs(ATTRSMODULE), NULL);
1662 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1663 newSVpvs(ATTRSMODULE),
1665 prepend_elem(OP_LIST,
1666 newSVOP(OP_CONST, 0, stashsv),
1667 prepend_elem(OP_LIST,
1668 newSVOP(OP_CONST, 0,
1670 dup_attrlist(attrs))));
1676 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1679 OP *pack, *imop, *arg;
1685 assert(target->op_type == OP_PADSV ||
1686 target->op_type == OP_PADHV ||
1687 target->op_type == OP_PADAV);
1689 /* Ensure that attributes.pm is loaded. */
1690 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1692 /* Need package name for method call. */
1693 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
1695 /* Build up the real arg-list. */
1696 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1698 arg = newOP(OP_PADSV, 0);
1699 arg->op_targ = target->op_targ;
1700 arg = prepend_elem(OP_LIST,
1701 newSVOP(OP_CONST, 0, stashsv),
1702 prepend_elem(OP_LIST,
1703 newUNOP(OP_REFGEN, 0,
1704 mod(arg, OP_REFGEN)),
1705 dup_attrlist(attrs)));
1707 /* Fake up a method call to import */
1708 meth = newSVpvs_share("import");
1709 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1710 append_elem(OP_LIST,
1711 prepend_elem(OP_LIST, pack, list(arg)),
1712 newSVOP(OP_METHOD_NAMED, 0, meth)));
1713 imop->op_private |= OPpENTERSUB_NOMOD;
1715 /* Combine the ops. */
1716 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1720 =notfor apidoc apply_attrs_string
1722 Attempts to apply a list of attributes specified by the C<attrstr> and
1723 C<len> arguments to the subroutine identified by the C<cv> argument which
1724 is expected to be associated with the package identified by the C<stashpv>
1725 argument (see L<attributes>). It gets this wrong, though, in that it
1726 does not correctly identify the boundaries of the individual attribute
1727 specifications within C<attrstr>. This is not really intended for the
1728 public API, but has to be listed here for systems such as AIX which
1729 need an explicit export list for symbols. (It's called from XS code
1730 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1731 to respect attribute syntax properly would be welcome.
1737 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
1738 const char *attrstr, STRLEN len)
1743 len = strlen(attrstr);
1747 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1749 const char * const sstr = attrstr;
1750 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1751 attrs = append_elem(OP_LIST, attrs,
1752 newSVOP(OP_CONST, 0,
1753 newSVpvn(sstr, attrstr-sstr)));
1757 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1758 newSVpvs(ATTRSMODULE),
1759 NULL, prepend_elem(OP_LIST,
1760 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1761 prepend_elem(OP_LIST,
1762 newSVOP(OP_CONST, 0,
1768 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
1773 if (!o || PL_error_count)
1777 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
1778 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
1782 if (type == OP_LIST) {
1784 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1785 my_kid(kid, attrs, imopsp);
1786 } else if (type == OP_UNDEF
1792 } else if (type == OP_RV2SV || /* "our" declaration */
1794 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1795 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1796 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1798 PL_in_my == KEY_our ? "our" : PL_in_my == KEY_state ? "state" : "my"));
1800 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
1802 PL_in_my_stash = NULL;
1803 apply_attrs(GvSTASH(gv),
1804 (type == OP_RV2SV ? GvSV(gv) :
1805 type == OP_RV2AV ? (SV*)GvAV(gv) :
1806 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1809 o->op_private |= OPpOUR_INTRO;
1812 else if (type != OP_PADSV &&
1815 type != OP_PUSHMARK)
1817 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1819 PL_in_my == KEY_our ? "our" : PL_in_my == KEY_state ? "state" : "my"));
1822 else if (attrs && type != OP_PUSHMARK) {
1826 PL_in_my_stash = NULL;
1828 /* check for C<my Dog $spot> when deciding package */
1829 stash = PAD_COMPNAME_TYPE(o->op_targ);
1831 stash = PL_curstash;
1832 apply_attrs_my(stash, o, attrs, imopsp);
1834 o->op_flags |= OPf_MOD;
1835 o->op_private |= OPpLVAL_INTRO;
1836 if (PL_in_my == KEY_state)
1837 o->op_private |= OPpPAD_STATE;
1842 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1846 int maybe_scalar = 0;
1848 /* [perl #17376]: this appears to be premature, and results in code such as
1849 C< our(%x); > executing in list mode rather than void mode */
1851 if (o->op_flags & OPf_PARENS)
1861 o = my_kid(o, attrs, &rops);
1863 if (maybe_scalar && o->op_type == OP_PADSV) {
1864 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
1865 o->op_private |= OPpLVAL_INTRO;
1868 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
1871 PL_in_my_stash = NULL;
1876 Perl_my(pTHX_ OP *o)
1878 return my_attrs(o, NULL);
1882 Perl_sawparens(pTHX_ OP *o)
1884 PERL_UNUSED_CONTEXT;
1886 o->op_flags |= OPf_PARENS;
1891 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
1895 const OPCODE ltype = left->op_type;
1896 const OPCODE rtype = right->op_type;
1898 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
1899 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
1901 const char * const desc
1902 = PL_op_desc[(rtype == OP_SUBST || rtype == OP_TRANS)
1903 ? (int)rtype : OP_MATCH];
1904 const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV)
1905 ? "@array" : "%hash");
1906 Perl_warner(aTHX_ packWARN(WARN_MISC),
1907 "Applying %s to %s will act on scalar(%s)",
1908 desc, sample, sample);
1911 if (rtype == OP_CONST &&
1912 cSVOPx(right)->op_private & OPpCONST_BARE &&
1913 cSVOPx(right)->op_private & OPpCONST_STRICT)
1915 no_bareword_allowed(right);
1918 ismatchop = rtype == OP_MATCH ||
1919 rtype == OP_SUBST ||
1921 if (ismatchop && right->op_private & OPpTARGET_MY) {
1923 right->op_private &= ~OPpTARGET_MY;
1925 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
1928 right->op_flags |= OPf_STACKED;
1929 if (rtype != OP_MATCH &&
1930 ! (rtype == OP_TRANS &&
1931 right->op_private & OPpTRANS_IDENTICAL))
1932 newleft = mod(left, rtype);
1935 if (right->op_type == OP_TRANS)
1936 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
1938 o = prepend_elem(rtype, scalar(newleft), right);
1940 return newUNOP(OP_NOT, 0, scalar(o));
1944 return bind_match(type, left,
1945 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
1949 Perl_invert(pTHX_ OP *o)
1953 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
1957 Perl_scope(pTHX_ OP *o)
1961 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
1962 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
1963 o->op_type = OP_LEAVE;
1964 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
1966 else if (o->op_type == OP_LINESEQ) {
1968 o->op_type = OP_SCOPE;
1969 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
1970 kid = ((LISTOP*)o)->op_first;
1971 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
1974 /* The following deals with things like 'do {1 for 1}' */
1975 kid = kid->op_sibling;
1977 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
1982 o = newLISTOP(OP_SCOPE, 0, o, NULL);
1988 Perl_block_start(pTHX_ int full)
1991 const int retval = PL_savestack_ix;
1992 pad_block_start(full);
1994 PL_hints &= ~HINT_BLOCK_SCOPE;
1995 SAVECOMPILEWARNINGS();
1996 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
2001 Perl_block_end(pTHX_ I32 floor, OP *seq)
2004 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2005 OP* const retval = scalarseq(seq);
2007 CopHINTS_set(&PL_compiling, PL_hints);
2009 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2018 const PADOFFSET offset = pad_findmy("$_");
2019 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
2020 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2023 OP * const o = newOP(OP_PADSV, 0);
2024 o->op_targ = offset;
2030 Perl_newPROG(pTHX_ OP *o)
2036 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2037 ((PL_in_eval & EVAL_KEEPERR)
2038 ? OPf_SPECIAL : 0), o);
2039 PL_eval_start = linklist(PL_eval_root);
2040 PL_eval_root->op_private |= OPpREFCOUNTED;
2041 OpREFCNT_set(PL_eval_root, 1);
2042 PL_eval_root->op_next = 0;
2043 CALL_PEEP(PL_eval_start);
2046 if (o->op_type == OP_STUB) {
2047 PL_comppad_name = 0;
2049 S_op_destroy(aTHX_ o);
2052 PL_main_root = scope(sawparens(scalarvoid(o)));
2053 PL_curcop = &PL_compiling;
2054 PL_main_start = LINKLIST(PL_main_root);
2055 PL_main_root->op_private |= OPpREFCOUNTED;
2056 OpREFCNT_set(PL_main_root, 1);
2057 PL_main_root->op_next = 0;
2058 CALL_PEEP(PL_main_start);
2061 /* Register with debugger */
2063 CV * const cv = get_cv("DB::postponed", FALSE);
2067 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2069 call_sv((SV*)cv, G_DISCARD);
2076 Perl_localize(pTHX_ OP *o, I32 lex)
2079 if (o->op_flags & OPf_PARENS)
2080 /* [perl #17376]: this appears to be premature, and results in code such as
2081 C< our(%x); > executing in list mode rather than void mode */
2088 if ( PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ','
2089 && ckWARN(WARN_PARENTHESIS))
2091 char *s = PL_bufptr;
2094 /* some heuristics to detect a potential error */
2095 while (*s && (strchr(", \t\n", *s)))
2099 if (*s && strchr("@$%*", *s) && *++s
2100 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2103 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2105 while (*s && (strchr(", \t\n", *s)))
2111 if (sigil && (*s == ';' || *s == '=')) {
2112 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2113 "Parentheses missing around \"%s\" list",
2114 lex ? (PL_in_my == KEY_our ? "our" : PL_in_my == KEY_state ? "state" : "my")
2122 o = mod(o, OP_NULL); /* a bit kludgey */
2124 PL_in_my_stash = NULL;
2129 Perl_jmaybe(pTHX_ OP *o)
2131 if (o->op_type == OP_LIST) {
2133 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2134 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2140 Perl_fold_constants(pTHX_ register OP *o)
2145 VOL I32 type = o->op_type;
2150 SV * const oldwarnhook = PL_warnhook;
2151 SV * const olddiehook = PL_diehook;
2154 if (PL_opargs[type] & OA_RETSCALAR)
2156 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2157 o->op_targ = pad_alloc(type, SVs_PADTMP);
2159 /* integerize op, unless it happens to be C<-foo>.
2160 * XXX should pp_i_negate() do magic string negation instead? */
2161 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2162 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2163 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2165 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2168 if (!(PL_opargs[type] & OA_FOLDCONST))
2173 /* XXX might want a ck_negate() for this */
2174 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2185 /* XXX what about the numeric ops? */
2186 if (PL_hints & HINT_LOCALE)
2191 goto nope; /* Don't try to run w/ errors */
2193 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2194 const OPCODE type = curop->op_type;
2195 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2197 type != OP_SCALAR &&
2199 type != OP_PUSHMARK)
2205 curop = LINKLIST(o);
2206 old_next = o->op_next;
2210 oldscope = PL_scopestack_ix;
2211 create_eval_scope(G_FAKINGEVAL);
2213 PL_warnhook = PERL_WARNHOOK_FATAL;
2220 sv = *(PL_stack_sp--);
2221 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2222 pad_swipe(o->op_targ, FALSE);
2223 else if (SvTEMP(sv)) { /* grab mortal temp? */
2224 SvREFCNT_inc_simple_void(sv);
2229 /* Something tried to die. Abandon constant folding. */
2230 /* Pretend the error never happened. */
2231 sv_setpvn(ERRSV,"",0);
2232 o->op_next = old_next;
2236 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
2237 PL_warnhook = oldwarnhook;
2238 PL_diehook = olddiehook;
2239 /* XXX note that this croak may fail as we've already blown away
2240 * the stack - eg any nested evals */
2241 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
2244 PL_warnhook = oldwarnhook;
2245 PL_diehook = olddiehook;
2247 if (PL_scopestack_ix > oldscope)
2248 delete_eval_scope();
2257 if (type == OP_RV2GV)
2258 newop = newGVOP(OP_GV, 0, (GV*)sv);
2260 newop = newSVOP(OP_CONST, 0, (SV*)sv);
2261 op_getmad(o,newop,'f');
2269 Perl_gen_constant_list(pTHX_ register OP *o)
2273 const I32 oldtmps_floor = PL_tmps_floor;
2277 return o; /* Don't attempt to run with errors */
2279 PL_op = curop = LINKLIST(o);
2285 assert (!(curop->op_flags & OPf_SPECIAL));
2286 assert(curop->op_type == OP_RANGE);
2288 PL_tmps_floor = oldtmps_floor;
2290 o->op_type = OP_RV2AV;
2291 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2292 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2293 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2294 o->op_opt = 0; /* needs to be revisited in peep() */
2295 curop = ((UNOP*)o)->op_first;
2296 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
2298 op_getmad(curop,o,'O');
2307 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2310 if (!o || o->op_type != OP_LIST)
2311 o = newLISTOP(OP_LIST, 0, o, NULL);
2313 o->op_flags &= ~OPf_WANT;
2315 if (!(PL_opargs[type] & OA_MARK))
2316 op_null(cLISTOPo->op_first);
2318 o->op_type = (OPCODE)type;
2319 o->op_ppaddr = PL_ppaddr[type];
2320 o->op_flags |= flags;
2322 o = CHECKOP(type, o);
2323 if (o->op_type != (unsigned)type)
2326 return fold_constants(o);
2329 /* List constructors */
2332 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2340 if (first->op_type != (unsigned)type
2341 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2343 return newLISTOP(type, 0, first, last);
2346 if (first->op_flags & OPf_KIDS)
2347 ((LISTOP*)first)->op_last->op_sibling = last;
2349 first->op_flags |= OPf_KIDS;
2350 ((LISTOP*)first)->op_first = last;
2352 ((LISTOP*)first)->op_last = last;
2357 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2365 if (first->op_type != (unsigned)type)
2366 return prepend_elem(type, (OP*)first, (OP*)last);
2368 if (last->op_type != (unsigned)type)
2369 return append_elem(type, (OP*)first, (OP*)last);
2371 first->op_last->op_sibling = last->op_first;
2372 first->op_last = last->op_last;
2373 first->op_flags |= (last->op_flags & OPf_KIDS);
2376 if (last->op_first && first->op_madprop) {
2377 MADPROP *mp = last->op_first->op_madprop;
2379 while (mp->mad_next)
2381 mp->mad_next = first->op_madprop;
2384 last->op_first->op_madprop = first->op_madprop;
2387 first->op_madprop = last->op_madprop;
2388 last->op_madprop = 0;
2391 S_op_destroy(aTHX_ (OP*)last);
2397 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2405 if (last->op_type == (unsigned)type) {
2406 if (type == OP_LIST) { /* already a PUSHMARK there */
2407 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2408 ((LISTOP*)last)->op_first->op_sibling = first;
2409 if (!(first->op_flags & OPf_PARENS))
2410 last->op_flags &= ~OPf_PARENS;
2413 if (!(last->op_flags & OPf_KIDS)) {
2414 ((LISTOP*)last)->op_last = first;
2415 last->op_flags |= OPf_KIDS;
2417 first->op_sibling = ((LISTOP*)last)->op_first;
2418 ((LISTOP*)last)->op_first = first;
2420 last->op_flags |= OPf_KIDS;
2424 return newLISTOP(type, 0, first, last);
2432 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2435 Newxz(tk, 1, TOKEN);
2436 tk->tk_type = (OPCODE)optype;
2437 tk->tk_type = 12345;
2439 tk->tk_mad = madprop;
2444 Perl_token_free(pTHX_ TOKEN* tk)
2446 if (tk->tk_type != 12345)
2448 mad_free(tk->tk_mad);
2453 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2457 if (tk->tk_type != 12345) {
2458 Perl_warner(aTHX_ packWARN(WARN_MISC),
2459 "Invalid TOKEN object ignored");
2466 /* faked up qw list? */
2468 tm->mad_type == MAD_SV &&
2469 SvPVX((SV*)tm->mad_val)[0] == 'q')
2476 /* pretend constant fold didn't happen? */
2477 if (mp->mad_key == 'f' &&
2478 (o->op_type == OP_CONST ||
2479 o->op_type == OP_GV) )
2481 token_getmad(tk,(OP*)mp->mad_val,slot);
2495 if (mp->mad_key == 'X')
2496 mp->mad_key = slot; /* just change the first one */
2506 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
2515 /* pretend constant fold didn't happen? */
2516 if (mp->mad_key == 'f' &&
2517 (o->op_type == OP_CONST ||
2518 o->op_type == OP_GV) )
2520 op_getmad(from,(OP*)mp->mad_val,slot);
2527 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
2530 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
2536 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
2545 /* pretend constant fold didn't happen? */
2546 if (mp->mad_key == 'f' &&
2547 (o->op_type == OP_CONST ||
2548 o->op_type == OP_GV) )
2550 op_getmad(from,(OP*)mp->mad_val,slot);
2557 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
2560 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
2564 PerlIO_printf(PerlIO_stderr(),
2565 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
2571 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
2589 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
2593 addmad(tm, &(o->op_madprop), slot);
2597 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
2618 Perl_newMADsv(pTHX_ char key, SV* sv)
2620 return newMADPROP(key, MAD_SV, sv, 0);
2624 Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
2627 Newxz(mp, 1, MADPROP);
2630 mp->mad_vlen = vlen;
2631 mp->mad_type = type;
2633 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
2638 Perl_mad_free(pTHX_ MADPROP* mp)
2640 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
2644 mad_free(mp->mad_next);
2645 /* if (PL_lex_state != LEX_NOTPARSING && mp->mad_vlen)
2646 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
2647 switch (mp->mad_type) {
2651 Safefree((char*)mp->mad_val);
2654 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
2655 op_free((OP*)mp->mad_val);
2658 sv_free((SV*)mp->mad_val);
2661 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
2670 Perl_newNULLLIST(pTHX)
2672 return newOP(OP_STUB, 0);
2676 Perl_force_list(pTHX_ OP *o)
2678 if (!o || o->op_type != OP_LIST)
2679 o = newLISTOP(OP_LIST, 0, o, NULL);
2685 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2690 NewOp(1101, listop, 1, LISTOP);
2692 listop->op_type = (OPCODE)type;
2693 listop->op_ppaddr = PL_ppaddr[type];
2696 listop->op_flags = (U8)flags;
2700 else if (!first && last)
2703 first->op_sibling = last;
2704 listop->op_first = first;
2705 listop->op_last = last;
2706 if (type == OP_LIST) {
2707 OP* const pushop = newOP(OP_PUSHMARK, 0);
2708 pushop->op_sibling = first;
2709 listop->op_first = pushop;
2710 listop->op_flags |= OPf_KIDS;
2712 listop->op_last = pushop;
2715 return CHECKOP(type, listop);
2719 Perl_newOP(pTHX_ I32 type, I32 flags)
2723 NewOp(1101, o, 1, OP);
2724 o->op_type = (OPCODE)type;
2725 o->op_ppaddr = PL_ppaddr[type];
2726 o->op_flags = (U8)flags;
2728 o->op_latefreed = 0;
2731 o->op_private = (U8)(0 | (flags >> 8));
2732 if (PL_opargs[type] & OA_RETSCALAR)
2734 if (PL_opargs[type] & OA_TARGET)
2735 o->op_targ = pad_alloc(type, SVs_PADTMP);
2736 return CHECKOP(type, o);
2740 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2746 first = newOP(OP_STUB, 0);
2747 if (PL_opargs[type] & OA_MARK)
2748 first = force_list(first);
2750 NewOp(1101, unop, 1, UNOP);
2751 unop->op_type = (OPCODE)type;
2752 unop->op_ppaddr = PL_ppaddr[type];
2753 unop->op_first = first;
2754 unop->op_flags = (U8)(flags | OPf_KIDS);
2755 unop->op_private = (U8)(1 | (flags >> 8));
2756 unop = (UNOP*) CHECKOP(type, unop);
2760 return fold_constants((OP *) unop);
2764 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2768 NewOp(1101, binop, 1, BINOP);
2771 first = newOP(OP_NULL, 0);
2773 binop->op_type = (OPCODE)type;
2774 binop->op_ppaddr = PL_ppaddr[type];
2775 binop->op_first = first;
2776 binop->op_flags = (U8)(flags | OPf_KIDS);
2779 binop->op_private = (U8)(1 | (flags >> 8));
2782 binop->op_private = (U8)(2 | (flags >> 8));
2783 first->op_sibling = last;
2786 binop = (BINOP*)CHECKOP(type, binop);
2787 if (binop->op_next || binop->op_type != (OPCODE)type)
2790 binop->op_last = binop->op_first->op_sibling;
2792 return fold_constants((OP *)binop);
2795 static int uvcompare(const void *a, const void *b)
2796 __attribute__nonnull__(1)
2797 __attribute__nonnull__(2)
2798 __attribute__pure__;
2799 static int uvcompare(const void *a, const void *b)
2801 if (*((const UV *)a) < (*(const UV *)b))
2803 if (*((const UV *)a) > (*(const UV *)b))
2805 if (*((const UV *)a+1) < (*(const UV *)b+1))
2807 if (*((const UV *)a+1) > (*(const UV *)b+1))
2813 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2816 SV * const tstr = ((SVOP*)expr)->op_sv;
2819 (repl->op_type == OP_NULL)
2820 ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
2822 ((SVOP*)repl)->op_sv;
2825 const U8 *t = (U8*)SvPV_const(tstr, tlen);
2826 const U8 *r = (U8*)SvPV_const(rstr, rlen);
2830 register short *tbl;
2832 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
2833 const I32 squash = o->op_private & OPpTRANS_SQUASH;
2834 I32 del = o->op_private & OPpTRANS_DELETE;
2835 PL_hints |= HINT_BLOCK_SCOPE;
2838 o->op_private |= OPpTRANS_FROM_UTF;
2841 o->op_private |= OPpTRANS_TO_UTF;
2843 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2844 SV* const listsv = newSVpvs("# comment\n");
2846 const U8* tend = t + tlen;
2847 const U8* rend = r + rlen;
2861 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2862 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2865 const U32 flags = UTF8_ALLOW_DEFAULT;
2869 t = tsave = bytes_to_utf8(t, &len);
2872 if (!to_utf && rlen) {
2874 r = rsave = bytes_to_utf8(r, &len);
2878 /* There are several snags with this code on EBCDIC:
2879 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2880 2. scan_const() in toke.c has encoded chars in native encoding which makes
2881 ranges at least in EBCDIC 0..255 range the bottom odd.
2885 U8 tmpbuf[UTF8_MAXBYTES+1];
2888 Newx(cp, 2*tlen, UV);
2890 transv = newSVpvs("");
2892 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
2894 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2896 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
2900 cp[2*i+1] = cp[2*i];
2904 qsort(cp, i, 2*sizeof(UV), uvcompare);
2905 for (j = 0; j < i; j++) {
2907 diff = val - nextmin;
2909 t = uvuni_to_utf8(tmpbuf,nextmin);
2910 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2912 U8 range_mark = UTF_TO_NATIVE(0xff);
2913 t = uvuni_to_utf8(tmpbuf, val - 1);
2914 sv_catpvn(transv, (char *)&range_mark, 1);
2915 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2922 t = uvuni_to_utf8(tmpbuf,nextmin);
2923 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2925 U8 range_mark = UTF_TO_NATIVE(0xff);
2926 sv_catpvn(transv, (char *)&range_mark, 1);
2928 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2929 UNICODE_ALLOW_SUPER);
2930 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2931 t = (const U8*)SvPVX_const(transv);
2932 tlen = SvCUR(transv);
2936 else if (!rlen && !del) {
2937 r = t; rlen = tlen; rend = tend;
2940 if ((!rlen && !del) || t == r ||
2941 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2943 o->op_private |= OPpTRANS_IDENTICAL;
2947 while (t < tend || tfirst <= tlast) {
2948 /* see if we need more "t" chars */
2949 if (tfirst > tlast) {
2950 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
2952 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2954 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
2961 /* now see if we need more "r" chars */
2962 if (rfirst > rlast) {
2964 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
2966 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2968 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
2977 rfirst = rlast = 0xffffffff;
2981 /* now see which range will peter our first, if either. */
2982 tdiff = tlast - tfirst;
2983 rdiff = rlast - rfirst;
2990 if (rfirst == 0xffffffff) {
2991 diff = tdiff; /* oops, pretend rdiff is infinite */
2993 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2994 (long)tfirst, (long)tlast);
2996 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
3000 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
3001 (long)tfirst, (long)(tfirst + diff),
3004 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3005 (long)tfirst, (long)rfirst);
3007 if (rfirst + diff > max)
3008 max = rfirst + diff;
3010 grows = (tfirst < rfirst &&
3011 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3023 else if (max > 0xff)
3028 Safefree(cPVOPo->op_pv);
3029 cPVOPo->op_pv = NULL;
3030 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
3031 SvREFCNT_dec(listsv);
3032 SvREFCNT_dec(transv);
3034 if (!del && havefinal && rlen)
3035 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
3036 newSVuv((UV)final), 0);
3039 o->op_private |= OPpTRANS_GROWS;
3045 op_getmad(expr,o,'e');
3046 op_getmad(repl,o,'r');
3054 tbl = (short*)cPVOPo->op_pv;
3056 Zero(tbl, 256, short);
3057 for (i = 0; i < (I32)tlen; i++)
3059 for (i = 0, j = 0; i < 256; i++) {
3061 if (j >= (I32)rlen) {
3070 if (i < 128 && r[j] >= 128)
3080 o->op_private |= OPpTRANS_IDENTICAL;
3082 else if (j >= (I32)rlen)
3085 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
3086 tbl[0x100] = (short)(rlen - j);
3087 for (i=0; i < (I32)rlen - j; i++)
3088 tbl[0x101+i] = r[j+i];
3092 if (!rlen && !del) {
3095 o->op_private |= OPpTRANS_IDENTICAL;
3097 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3098 o->op_private |= OPpTRANS_IDENTICAL;
3100 for (i = 0; i < 256; i++)
3102 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3103 if (j >= (I32)rlen) {
3105 if (tbl[t[i]] == -1)
3111 if (tbl[t[i]] == -1) {
3112 if (t[i] < 128 && r[j] >= 128)
3119 o->op_private |= OPpTRANS_GROWS;
3121 op_getmad(expr,o,'e');
3122 op_getmad(repl,o,'r');
3132 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3137 NewOp(1101, pmop, 1, PMOP);
3138 pmop->op_type = (OPCODE)type;
3139 pmop->op_ppaddr = PL_ppaddr[type];
3140 pmop->op_flags = (U8)flags;
3141 pmop->op_private = (U8)(0 | (flags >> 8));
3143 if (PL_hints & HINT_RE_TAINT)
3144 pmop->op_pmpermflags |= PMf_RETAINT;
3145 if (PL_hints & HINT_LOCALE)
3146 pmop->op_pmpermflags |= PMf_LOCALE;
3147 pmop->op_pmflags = pmop->op_pmpermflags;
3150 if (av_len((AV*) PL_regex_pad[0]) > -1) {
3151 SV * const repointer = av_pop((AV*)PL_regex_pad[0]);
3152 pmop->op_pmoffset = SvIV(repointer);
3153 SvREPADTMP_off(repointer);
3154 sv_setiv(repointer,0);
3156 SV * const repointer = newSViv(0);
3157 av_push(PL_regex_padav, SvREFCNT_inc_simple_NN(repointer));
3158 pmop->op_pmoffset = av_len(PL_regex_padav);
3159 PL_regex_pad = AvARRAY(PL_regex_padav);
3163 /* link into pm list */
3164 if (type != OP_TRANS && PL_curstash) {
3165 MAGIC *mg = mg_find((SV*)PL_curstash, PERL_MAGIC_symtab);
3168 mg = sv_magicext((SV*)PL_curstash, 0, PERL_MAGIC_symtab, 0, 0, 0);
3170 pmop->op_pmnext = (PMOP*)mg->mg_obj;
3171 mg->mg_obj = (SV*)pmop;
3172 PmopSTASH_set(pmop,PL_curstash);
3175 return CHECKOP(type, pmop);
3178 /* Given some sort of match op o, and an expression expr containing a
3179 * pattern, either compile expr into a regex and attach it to o (if it's
3180 * constant), or convert expr into a runtime regcomp op sequence (if it's
3183 * isreg indicates that the pattern is part of a regex construct, eg
3184 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3185 * split "pattern", which aren't. In the former case, expr will be a list
3186 * if the pattern contains more than one term (eg /a$b/) or if it contains
3187 * a replacement, ie s/// or tr///.
3191 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
3196 I32 repl_has_vars = 0;
3200 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
3201 /* last element in list is the replacement; pop it */
3203 repl = cLISTOPx(expr)->op_last;
3204 kid = cLISTOPx(expr)->op_first;
3205 while (kid->op_sibling != repl)
3206 kid = kid->op_sibling;
3207 kid->op_sibling = NULL;
3208 cLISTOPx(expr)->op_last = kid;
3211 if (isreg && expr->op_type == OP_LIST &&
3212 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3214 /* convert single element list to element */
3215 OP* const oe = expr;
3216 expr = cLISTOPx(oe)->op_first->op_sibling;
3217 cLISTOPx(oe)->op_first->op_sibling = NULL;
3218 cLISTOPx(oe)->op_last = NULL;
3222 if (o->op_type == OP_TRANS) {
3223 return pmtrans(o, expr, repl);
3226 reglist = isreg && expr->op_type == OP_LIST;
3230 PL_hints |= HINT_BLOCK_SCOPE;
3233 if (expr->op_type == OP_CONST) {
3235 SV * const pat = ((SVOP*)expr)->op_sv;
3236 const char *p = SvPV_const(pat, plen);
3237 if ((o->op_flags & OPf_SPECIAL) && (*p == ' ' && p[1] == '\0')) {
3238 U32 was_readonly = SvREADONLY(pat);
3242 sv_force_normal_flags(pat, 0);
3243 assert(!SvREADONLY(pat));
3246 SvREADONLY_off(pat);
3250 sv_setpvn(pat, "\\s+", 3);
3252 SvFLAGS(pat) |= was_readonly;
3254 p = SvPV_const(pat, plen);
3255 pm->op_pmflags |= PMf_SKIPWHITE;
3258 pm->op_pmdynflags |= PMdf_UTF8;
3259 /* FIXME - can we make this function take const char * args? */
3260 PM_SETRE(pm, CALLREGCOMP((char*)p, (char*)p + plen, pm));
3261 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
3262 pm->op_pmflags |= PMf_WHITE;
3264 op_getmad(expr,(OP*)pm,'e');
3270 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3271 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3273 : OP_REGCMAYBE),0,expr);
3275 NewOp(1101, rcop, 1, LOGOP);
3276 rcop->op_type = OP_REGCOMP;
3277 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3278 rcop->op_first = scalar(expr);
3279 rcop->op_flags |= OPf_KIDS
3280 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3281 | (reglist ? OPf_STACKED : 0);
3282 rcop->op_private = 1;
3285 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3287 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
3290 /* establish postfix order */
3291 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3293 rcop->op_next = expr;
3294 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3297 rcop->op_next = LINKLIST(expr);
3298 expr->op_next = (OP*)rcop;
3301 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3306 if (pm->op_pmflags & PMf_EVAL) {
3308 if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
3309 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
3311 else if (repl->op_type == OP_CONST)
3315 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3316 if (curop->op_type == OP_SCOPE
3317 || curop->op_type == OP_LEAVE
3318 || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
3319 if (curop->op_type == OP_GV) {
3320 GV * const gv = cGVOPx_gv(curop);
3322 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3325 else if (curop->op_type == OP_RV2CV)
3327 else if (curop->op_type == OP_RV2SV ||
3328 curop->op_type == OP_RV2AV ||
3329 curop->op_type == OP_RV2HV ||
3330 curop->op_type == OP_RV2GV) {
3331 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3334 else if (curop->op_type == OP_PADSV ||
3335 curop->op_type == OP_PADAV ||
3336 curop->op_type == OP_PADHV ||
3337 curop->op_type == OP_PADANY)
3341 else if (curop->op_type == OP_PUSHRE)
3342 NOOP; /* Okay here, dangerous in newASSIGNOP */
3352 || PM_GETRE(pm)->extflags & RXf_EVAL_SEEN)))
3354 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3355 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
3356 prepend_elem(o->op_type, scalar(repl), o);
3359 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3360 pm->op_pmflags |= PMf_MAYBE_CONST;
3361 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3363 NewOp(1101, rcop, 1, LOGOP);
3364 rcop->op_type = OP_SUBSTCONT;
3365 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3366 rcop->op_first = scalar(repl);
3367 rcop->op_flags |= OPf_KIDS;
3368 rcop->op_private = 1;
3371 /* establish postfix order */
3372 rcop->op_next = LINKLIST(repl);
3373 repl->op_next = (OP*)rcop;
3375 pm->op_pmreplroot = scalar((OP*)rcop);
3376 pm->op_pmreplstart = LINKLIST(rcop);
3385 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3389 NewOp(1101, svop, 1, SVOP);
3390 svop->op_type = (OPCODE)type;
3391 svop->op_ppaddr = PL_ppaddr[type];
3393 svop->op_next = (OP*)svop;
3394 svop->op_flags = (U8)flags;
3395 if (PL_opargs[type] & OA_RETSCALAR)
3397 if (PL_opargs[type] & OA_TARGET)
3398 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3399 return CHECKOP(type, svop);
3403 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3407 NewOp(1101, padop, 1, PADOP);
3408 padop->op_type = (OPCODE)type;
3409 padop->op_ppaddr = PL_ppaddr[type];
3410 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3411 SvREFCNT_dec(PAD_SVl(padop->op_padix));
3412 PAD_SETSV(padop->op_padix, sv);
3415 padop->op_next = (OP*)padop;
3416 padop->op_flags = (U8)flags;
3417 if (PL_opargs[type] & OA_RETSCALAR)
3419 if (PL_opargs[type] & OA_TARGET)
3420 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3421 return CHECKOP(type, padop);
3425 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3431 return newPADOP(type, flags, SvREFCNT_inc_simple(gv));
3433 return newSVOP(type, flags, SvREFCNT_inc_simple(gv));
3438 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3442 NewOp(1101, pvop, 1, PVOP);
3443 pvop->op_type = (OPCODE)type;
3444 pvop->op_ppaddr = PL_ppaddr[type];
3446 pvop->op_next = (OP*)pvop;
3447 pvop->op_flags = (U8)flags;
3448 if (PL_opargs[type] & OA_RETSCALAR)
3450 if (PL_opargs[type] & OA_TARGET)
3451 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3452 return CHECKOP(type, pvop);
3460 Perl_package(pTHX_ OP *o)
3469 save_hptr(&PL_curstash);
3470 save_item(PL_curstname);
3472 name = SvPV_const(cSVOPo->op_sv, len);
3473 PL_curstash = gv_stashpvn(name, len, TRUE);
3474 sv_setpvn(PL_curstname, name, len);
3476 PL_hints |= HINT_BLOCK_SCOPE;
3477 PL_copline = NOLINE;
3483 if (!PL_madskills) {
3488 pegop = newOP(OP_NULL,0);
3489 op_getmad(o,pegop,'P');
3499 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3506 OP *pegop = newOP(OP_NULL,0);
3509 if (idop->op_type != OP_CONST)
3510 Perl_croak(aTHX_ "Module name must be constant");
3513 op_getmad(idop,pegop,'U');
3518 SV * const vesv = ((SVOP*)version)->op_sv;
3521 op_getmad(version,pegop,'V');
3522 if (!arg && !SvNIOKp(vesv)) {
3529 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3530 Perl_croak(aTHX_ "Version number must be constant number");
3532 /* Make copy of idop so we don't free it twice */
3533 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3535 /* Fake up a method call to VERSION */
3536 meth = newSVpvs_share("VERSION");
3537 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3538 append_elem(OP_LIST,
3539 prepend_elem(OP_LIST, pack, list(version)),
3540 newSVOP(OP_METHOD_NAMED, 0, meth)));
3544 /* Fake up an import/unimport */
3545 if (arg && arg->op_type == OP_STUB) {
3547 op_getmad(arg,pegop,'S');
3548 imop = arg; /* no import on explicit () */
3550 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3551 imop = NULL; /* use 5.0; */
3553 idop->op_private |= OPpCONST_NOVER;
3559 op_getmad(arg,pegop,'A');
3561 /* Make copy of idop so we don't free it twice */
3562 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3564 /* Fake up a method call to import/unimport */
3566 ? newSVpvs_share("import") : newSVpvs_share("unimport");
3567 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3568 append_elem(OP_LIST,
3569 prepend_elem(OP_LIST, pack, list(arg)),
3570 newSVOP(OP_METHOD_NAMED, 0, meth)));
3573 /* Fake up the BEGIN {}, which does its thing immediately. */
3575 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
3578 append_elem(OP_LINESEQ,
3579 append_elem(OP_LINESEQ,
3580 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
3581 newSTATEOP(0, NULL, veop)),
3582 newSTATEOP(0, NULL, imop) ));
3584 /* The "did you use incorrect case?" warning used to be here.
3585 * The problem is that on case-insensitive filesystems one
3586 * might get false positives for "use" (and "require"):
3587 * "use Strict" or "require CARP" will work. This causes
3588 * portability problems for the script: in case-strict
3589 * filesystems the script will stop working.
3591 * The "incorrect case" warning checked whether "use Foo"
3592 * imported "Foo" to your namespace, but that is wrong, too:
3593 * there is no requirement nor promise in the language that
3594 * a Foo.pm should or would contain anything in package "Foo".
3596 * There is very little Configure-wise that can be done, either:
3597 * the case-sensitivity of the build filesystem of Perl does not
3598 * help in guessing the case-sensitivity of the runtime environment.
3601 PL_hints |= HINT_BLOCK_SCOPE;
3602 PL_copline = NOLINE;
3604 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3607 if (!PL_madskills) {
3608 /* FIXME - don't allocate pegop if !PL_madskills */
3617 =head1 Embedding Functions
3619 =for apidoc load_module
3621 Loads the module whose name is pointed to by the string part of name.
3622 Note that the actual module name, not its filename, should be given.
3623 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3624 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3625 (or 0 for no flags). ver, if specified, provides version semantics
3626 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3627 arguments can be used to specify arguments to the module's import()
3628 method, similar to C<use Foo::Bar VERSION LIST>.
3633 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3636 va_start(args, ver);
3637 vload_module(flags, name, ver, &args);
3641 #ifdef PERL_IMPLICIT_CONTEXT
3643 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3647 va_start(args, ver);
3648 vload_module(flags, name, ver, &args);
3654 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3659 OP * const modname = newSVOP(OP_CONST, 0, name);
3660 modname->op_private |= OPpCONST_BARE;
3662 veop = newSVOP(OP_CONST, 0, ver);
3666 if (flags & PERL_LOADMOD_NOIMPORT) {
3667 imop = sawparens(newNULLLIST());
3669 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3670 imop = va_arg(*args, OP*);
3675 sv = va_arg(*args, SV*);
3677 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3678 sv = va_arg(*args, SV*);
3682 const line_t ocopline = PL_copline;
3683 COP * const ocurcop = PL_curcop;
3684 const int oexpect = PL_expect;
3686 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3687 veop, modname, imop);
3688 PL_expect = oexpect;
3689 PL_copline = ocopline;
3690 PL_curcop = ocurcop;
3695 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
3701 if (!force_builtin) {
3702 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
3703 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
3704 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
3705 gv = gvp ? *gvp : NULL;
3709 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3710 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3711 append_elem(OP_LIST, term,
3712 scalar(newUNOP(OP_RV2CV, 0,
3713 newGVOP(OP_GV, 0, gv))))));
3716 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3722 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3724 return newBINOP(OP_LSLICE, flags,
3725 list(force_list(subscript)),
3726 list(force_list(listval)) );
3730 S_is_list_assignment(pTHX_ register const OP *o)
3738 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
3739 o = cUNOPo->op_first;
3741 flags = o->op_flags;
3743 if (type == OP_COND_EXPR) {
3744 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
3745 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3750 yyerror("Assignment to both a list and a scalar");
3754 if (type == OP_LIST &&
3755 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
3756 o->op_private & OPpLVAL_INTRO)
3759 if (type == OP_LIST || flags & OPf_PARENS ||
3760 type == OP_RV2AV || type == OP_RV2HV ||
3761 type == OP_ASLICE || type == OP_HSLICE)
3764 if (type == OP_PADAV || type == OP_PADHV)
3767 if (type == OP_RV2SV)
3774 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3780 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3781 return newLOGOP(optype, 0,
3782 mod(scalar(left), optype),
3783 newUNOP(OP_SASSIGN, 0, scalar(right)));
3786 return newBINOP(optype, OPf_STACKED,
3787 mod(scalar(left), optype), scalar(right));
3791 if (is_list_assignment(left)) {
3795 /* Grandfathering $[ assignment here. Bletch.*/
3796 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
3797 PL_eval_start = (left->op_type == OP_CONST) ? right : 0;
3798 left = mod(left, OP_AASSIGN);
3801 else if (left->op_type == OP_CONST) {
3803 /* Result of assignment is always 1 (or we'd be dead already) */
3804 return newSVOP(OP_CONST, 0, newSViv(1));
3806 curop = list(force_list(left));
3807 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3808 o->op_private = (U8)(0 | (flags >> 8));
3810 /* PL_generation sorcery:
3811 * an assignment like ($a,$b) = ($c,$d) is easier than
3812 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3813 * To detect whether there are common vars, the global var
3814 * PL_generation is incremented for each assign op we compile.
3815 * Then, while compiling the assign op, we run through all the
3816 * variables on both sides of the assignment, setting a spare slot
3817 * in each of them to PL_generation. If any of them already have
3818 * that value, we know we've got commonality. We could use a
3819 * single bit marker, but then we'd have to make 2 passes, first
3820 * to clear the flag, then to test and set it. To find somewhere
3821 * to store these values, evil chicanery is done with SvCUR().
3827 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3828 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3829 if (curop->op_type == OP_GV) {
3830 GV *gv = cGVOPx_gv(curop);
3832 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
3834 GvASSIGN_GENERATION_set(gv, PL_generation);
3836 else if (curop->op_type == OP_PADSV ||
3837 curop->op_type == OP_PADAV ||
3838 curop->op_type == OP_PADHV ||
3839 curop->op_type == OP_PADANY)
3841 if (PAD_COMPNAME_GEN(curop->op_targ)
3842 == (STRLEN)PL_generation)
3844 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
3847 else if (curop->op_type == OP_RV2CV)
3849 else if (curop->op_type == OP_RV2SV ||
3850 curop->op_type == OP_RV2AV ||
3851 curop->op_type == OP_RV2HV ||
3852 curop->op_type == OP_RV2GV) {
3853 if (lastop->op_type != OP_GV) /* funny deref? */
3856 else if (curop->op_type == OP_PUSHRE) {
3857 if (((PMOP*)curop)->op_pmreplroot) {
3859 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3860 ((PMOP*)curop)->op_pmreplroot));
3862 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3865 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
3867 GvASSIGN_GENERATION_set(gv, PL_generation);
3868 GvASSIGN_GENERATION_set(gv, PL_generation);
3877 o->op_private |= OPpASSIGN_COMMON;
3880 if ( ((left->op_private & OPpLVAL_INTRO) || ckWARN(WARN_MISC))
3881 && (left->op_type == OP_LIST
3882 || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
3884 OP* lop = ((LISTOP*)left)->op_first;
3886 if (lop->op_type == OP_PADSV ||
3887 lop->op_type == OP_PADAV ||
3888 lop->op_type == OP_PADHV ||
3889 lop->op_type == OP_PADANY)
3891 if (lop->op_private & OPpPAD_STATE) {
3892 if (left->op_private & OPpLVAL_INTRO) {
3893 o->op_private |= OPpASSIGN_STATE;
3894 /* hijacking PADSTALE for uninitialized state variables */
3895 SvPADSTALE_on(PAD_SVl(lop->op_targ));
3897 else { /* we already checked for WARN_MISC before */
3898 Perl_warner(aTHX_ packWARN(WARN_MISC), "State variable %s will be reinitialized",
3899 PAD_COMPNAME_PV(lop->op_targ));
3903 lop = lop->op_sibling;
3907 if (right && right->op_type == OP_SPLIT) {
3908 OP* tmpop = ((LISTOP*)right)->op_first;
3909 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
3910 PMOP * const pm = (PMOP*)tmpop;
3911 if (left->op_type == OP_RV2AV &&
3912 !(left->op_private & OPpLVAL_INTRO) &&
3913 !(o->op_private & OPpASSIGN_COMMON) )
3915 tmpop = ((UNOP*)left)->op_first;
3916 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3918 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3919 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3921 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3922 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
3924 pm->op_pmflags |= PMf_ONCE;
3925 tmpop = cUNOPo->op_first; /* to list (nulled) */
3926 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3927 tmpop->op_sibling = NULL; /* don't free split */
3928 right->op_next = tmpop->op_next; /* fix starting loc */
3930 op_getmad(o,right,'R'); /* blow off assign */
3932 op_free(o); /* blow off assign */
3934 right->op_flags &= ~OPf_WANT;
3935 /* "I don't know and I don't care." */
3940 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3941 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3943 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3945 sv_setiv(sv, PL_modcount+1);
3953 right = newOP(OP_UNDEF, 0);
3954 if (right->op_type == OP_READLINE) {
3955 right->op_flags |= OPf_STACKED;
3956 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3959 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3960 o = newBINOP(OP_SASSIGN, flags,
3961 scalar(right), mod(scalar(left), OP_SASSIGN) );
3967 o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
3968 o->op_private |= OPpCONST_ARYBASE;
3975 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3978 const U32 seq = intro_my();
3981 NewOp(1101, cop, 1, COP);
3982 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3983 cop->op_type = OP_DBSTATE;
3984 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3987 cop->op_type = OP_NEXTSTATE;
3988 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3990 cop->op_flags = (U8)flags;
3991 CopHINTS_set(cop, PL_hints);
3993 cop->op_private |= NATIVE_HINTS;
3995 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
3996 cop->op_next = (OP*)cop;
3999 CopLABEL_set(cop, label);
4000 PL_hints |= HINT_BLOCK_SCOPE;
4003 /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
4004 CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
4006 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
4007 cop->cop_hints_hash = PL_curcop->cop_hints_hash;
4008 if (cop->cop_hints_hash) {
4010 cop->cop_hints_hash->refcounted_he_refcnt++;
4011 HINTS_REFCNT_UNLOCK;
4014 if (PL_copline == NOLINE)
4015 CopLINE_set(cop, CopLINE(PL_curcop));
4017 CopLINE_set(cop, PL_copline);
4018 PL_copline = NOLINE;
4021 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
4023 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
4025 CopSTASH_set(cop, PL_curstash);
4027 if (PERLDB_LINE && PL_curstash != PL_debstash) {
4028 AV *av = CopFILEAVx(PL_curcop);
4030 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
4031 if (svp && *svp != &PL_sv_undef ) {
4032 (void)SvIOK_on(*svp);
4033 SvIV_set(*svp, PTR2IV(cop));
4038 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
4043 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
4046 return new_logop(type, flags, &first, &other);
4050 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
4055 OP *first = *firstp;
4056 OP * const other = *otherp;
4058 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
4059 return newBINOP(type, flags, scalar(first), scalar(other));
4061 scalarboolean(first);
4062 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
4063 if (first->op_type == OP_NOT
4064 && (first->op_flags & OPf_SPECIAL)
4065 && (first->op_flags & OPf_KIDS)) {
4066 if (type == OP_AND || type == OP_OR) {
4072 first = *firstp = cUNOPo->op_first;
4074 first->op_next = o->op_next;
4075 cUNOPo->op_first = NULL;
4077 op_getmad(o,first,'O');
4083 if (first->op_type == OP_CONST) {
4084 if (first->op_private & OPpCONST_STRICT)
4085 no_bareword_allowed(first);
4086 else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
4087 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
4088 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
4089 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
4090 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
4092 if (other->op_type == OP_CONST)
4093 other->op_private |= OPpCONST_SHORTCIRCUIT;
4095 OP *newop = newUNOP(OP_NULL, 0, other);
4096 op_getmad(first, newop, '1');
4097 newop->op_targ = type; /* set "was" field */
4104 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
4105 const OP *o2 = other;
4106 if ( ! (o2->op_type == OP_LIST
4107 && (( o2 = cUNOPx(o2)->op_first))
4108 && o2->op_type == OP_PUSHMARK
4109 && (( o2 = o2->op_sibling)) )
4112 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
4113 || o2->op_type == OP_PADHV)
4114 && o2->op_private & OPpLVAL_INTRO
4115 && ckWARN(WARN_DEPRECATED))
4117 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4118 "Deprecated use of my() in false conditional");
4122 if (first->op_type == OP_CONST)
4123 first->op_private |= OPpCONST_SHORTCIRCUIT;
4125 first = newUNOP(OP_NULL, 0, first);
4126 op_getmad(other, first, '2');
4127 first->op_targ = type; /* set "was" field */
4134 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
4135 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
4137 const OP * const k1 = ((UNOP*)first)->op_first;
4138 const OP * const k2 = k1->op_sibling;
4140 switch (first->op_type)
4143 if (k2 && k2->op_type == OP_READLINE
4144 && (k2->op_flags & OPf_STACKED)
4145 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4147 warnop = k2->op_type;
4152 if (k1->op_type == OP_READDIR
4153 || k1->op_type == OP_GLOB
4154 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4155 || k1->op_type == OP_EACH)
4157 warnop = ((k1->op_type == OP_NULL)
4158 ? (OPCODE)k1->op_targ : k1->op_type);
4163 const line_t oldline = CopLINE(PL_curcop);
4164 CopLINE_set(PL_curcop, PL_copline);
4165 Perl_warner(aTHX_ packWARN(WARN_MISC),
4166 "Value of %s%s can be \"0\"; test with defined()",
4168 ((warnop == OP_READLINE || warnop == OP_GLOB)
4169 ? " construct" : "() operator"));
4170 CopLINE_set(PL_curcop, oldline);
4177 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
4178 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
4180 NewOp(1101, logop, 1, LOGOP);
4182 logop->op_type = (OPCODE)type;
4183 logop->op_ppaddr = PL_ppaddr[type];
4184 logop->op_first = first;
4185 logop->op_flags = (U8)(flags | OPf_KIDS);
4186 logop->op_other = LINKLIST(other);
4187 logop->op_private = (U8)(1 | (flags >> 8));
4189 /* establish postfix order */
4190 logop->op_next = LINKLIST(first);
4191 first->op_next = (OP*)logop;
4192 first->op_sibling = other;
4194 CHECKOP(type,logop);
4196 o = newUNOP(OP_NULL, 0, (OP*)logop);
4203 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
4211 return newLOGOP(OP_AND, 0, first, trueop);
4213 return newLOGOP(OP_OR, 0, first, falseop);
4215 scalarboolean(first);
4216 if (first->op_type == OP_CONST) {
4217 if (first->op_private & OPpCONST_BARE &&
4218 first->op_private & OPpCONST_STRICT) {
4219 no_bareword_allowed(first);
4221 if (SvTRUE(((SVOP*)first)->op_sv)) {
4224 trueop = newUNOP(OP_NULL, 0, trueop);
4225 op_getmad(first,trueop,'C');
4226 op_getmad(falseop,trueop,'e');
4228 /* FIXME for MAD - should there be an ELSE here? */
4238 falseop = newUNOP(OP_NULL, 0, falseop);
4239 op_getmad(first,falseop,'C');
4240 op_getmad(trueop,falseop,'t');
4242 /* FIXME for MAD - should there be an ELSE here? */
4250 NewOp(1101, logop, 1, LOGOP);
4251 logop->op_type = OP_COND_EXPR;
4252 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4253 logop->op_first = first;
4254 logop->op_flags = (U8)(flags | OPf_KIDS);
4255 logop->op_private = (U8)(1 | (flags >> 8));
4256 logop->op_other = LINKLIST(trueop);
4257 logop->op_next = LINKLIST(falseop);
4259 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
4262 /* establish postfix order */
4263 start = LINKLIST(first);
4264 first->op_next = (OP*)logop;
4266 first->op_sibling = trueop;
4267 trueop->op_sibling = falseop;
4268 o = newUNOP(OP_NULL, 0, (OP*)logop);
4270 trueop->op_next = falseop->op_next = o;
4277 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4286 NewOp(1101, range, 1, LOGOP);
4288 range->op_type = OP_RANGE;
4289 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4290 range->op_first = left;
4291 range->op_flags = OPf_KIDS;
4292 leftstart = LINKLIST(left);
4293 range->op_other = LINKLIST(right);
4294 range->op_private = (U8)(1 | (flags >> 8));
4296 left->op_sibling = right;
4298 range->op_next = (OP*)range;
4299 flip = newUNOP(OP_FLIP, flags, (OP*)range);
4300 flop = newUNOP(OP_FLOP, 0, flip);
4301 o = newUNOP(OP_NULL, 0, flop);
4303 range->op_next = leftstart;
4305 left->op_next = flip;
4306 right->op_next = flop;
4308 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4309 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4310 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4311 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4313 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4314 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4317 if (!flip->op_private || !flop->op_private)
4318 linklist(o); /* blow off optimizer unless constant */
4324 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4329 const bool once = block && block->op_flags & OPf_SPECIAL &&
4330 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4332 PERL_UNUSED_ARG(debuggable);
4335 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4336 return block; /* do {} while 0 does once */
4337 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4338 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4339 expr = newUNOP(OP_DEFINED, 0,
4340 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4341 } else if (expr->op_flags & OPf_KIDS) {
4342 const OP * const k1 = ((UNOP*)expr)->op_first;
4343 const OP * const k2 = k1 ? k1->op_sibling : NULL;
4344 switch (expr->op_type) {
4346 if (k2 && k2->op_type == OP_READLINE
4347 && (k2->op_flags & OPf_STACKED)
4348 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4349 expr = newUNOP(OP_DEFINED, 0, expr);
4353 if (k1 && (k1->op_type == OP_READDIR
4354 || k1->op_type == OP_GLOB
4355 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4356 || k1->op_type == OP_EACH))
4357 expr = newUNOP(OP_DEFINED, 0, expr);
4363 /* if block is null, the next append_elem() would put UNSTACK, a scalar
4364 * op, in listop. This is wrong. [perl #27024] */
4366 block = newOP(OP_NULL, 0);
4367 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4368 o = new_logop(OP_AND, 0, &expr, &listop);
4371 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4373 if (once && o != listop)
4374 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4377 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
4379 o->op_flags |= flags;
4381 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4386 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
4387 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
4396 PERL_UNUSED_ARG(debuggable);
4399 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4400 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4401 expr = newUNOP(OP_DEFINED, 0,
4402 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4403 } else if (expr->op_flags & OPf_KIDS) {
4404 const OP * const k1 = ((UNOP*)expr)->op_first;
4405 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
4406 switch (expr->op_type) {
4408 if (k2 && k2->op_type == OP_READLINE
4409 && (k2->op_flags & OPf_STACKED)
4410 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4411 expr = newUNOP(OP_DEFINED, 0, expr);
4415 if (k1 && (k1->op_type == OP_READDIR
4416 || k1->op_type == OP_GLOB
4417 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4418 || k1->op_type == OP_EACH))
4419 expr = newUNOP(OP_DEFINED, 0, expr);
4426 block = newOP(OP_NULL, 0);
4427 else if (cont || has_my) {
4428 block = scope(block);
4432 next = LINKLIST(cont);
4435 OP * const unstack = newOP(OP_UNSTACK, 0);
4438 cont = append_elem(OP_LINESEQ, cont, unstack);
4442 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4444 redo = LINKLIST(listop);
4447 PL_copline = (line_t)whileline;
4449 o = new_logop(OP_AND, 0, &expr, &listop);
4450 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4451 op_free(expr); /* oops, it's a while (0) */
4453 return NULL; /* listop already freed by new_logop */
4456 ((LISTOP*)listop)->op_last->op_next =
4457 (o == listop ? redo : LINKLIST(o));
4463 NewOp(1101,loop,1,LOOP);
4464 loop->op_type = OP_ENTERLOOP;
4465 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4466 loop->op_private = 0;
4467 loop->op_next = (OP*)loop;
4470 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4472 loop->op_redoop = redo;
4473 loop->op_lastop = o;
4474 o->op_private |= loopflags;
4477 loop->op_nextop = next;
4479 loop->op_nextop = o;
4481 o->op_flags |= flags;
4482 o->op_private |= (flags >> 8);
4487 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
4492 PADOFFSET padoff = 0;
4498 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4499 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
4500 sv->op_type = OP_RV2GV;
4501 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4502 if (cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
4503 iterpflags |= OPpITER_DEF;
4505 else if (sv->op_type == OP_PADSV) { /* private variable */
4506 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
4507 padoff = sv->op_targ;
4516 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4517 padoff = sv->op_targ;
4522 iterflags |= OPf_SPECIAL;
4528 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4529 if (padoff && strEQ(PAD_COMPNAME_PV(padoff), "$_"))
4530 iterpflags |= OPpITER_DEF;
4533 const PADOFFSET offset = pad_findmy("$_");
4534 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
4535 sv = newGVOP(OP_GV, 0, PL_defgv);
4540 iterpflags |= OPpITER_DEF;
4542 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4543 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4544 iterflags |= OPf_STACKED;
4546 else if (expr->op_type == OP_NULL &&
4547 (expr->op_flags & OPf_KIDS) &&
4548 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4550 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4551 * set the STACKED flag to indicate that these values are to be
4552 * treated as min/max values by 'pp_iterinit'.
4554 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4555 LOGOP* const range = (LOGOP*) flip->op_first;
4556 OP* const left = range->op_first;
4557 OP* const right = left->op_sibling;
4560 range->op_flags &= ~OPf_KIDS;
4561 range->op_first = NULL;
4563 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4564 listop->op_first->op_next = range->op_next;
4565 left->op_next = range->op_other;
4566 right->op_next = (OP*)listop;
4567 listop->op_next = listop->op_first;
4570 op_getmad(expr,(OP*)listop,'O');
4574 expr = (OP*)(listop);
4576 iterflags |= OPf_STACKED;
4579 expr = mod(force_list(expr), OP_GREPSTART);
4582 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4583 append_elem(OP_LIST, expr, scalar(sv))));
4584 assert(!loop->op_next);
4585 /* for my $x () sets OPpLVAL_INTRO;
4586 * for our $x () sets OPpOUR_INTRO */
4587 loop->op_private = (U8)iterpflags;
4588 #ifdef PL_OP_SLAB_ALLOC
4591 NewOp(1234,tmp,1,LOOP);
4592 Copy(loop,tmp,1,LISTOP);
4593 S_op_destroy(aTHX_ (OP*)loop);
4597 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
4599 loop->op_targ = padoff;
4600 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
4602 op_getmad(madsv, (OP*)loop, 'v');
4603 PL_copline = forline;
4604 return newSTATEOP(0, label, wop);
4608 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4613 if (type != OP_GOTO || label->op_type == OP_CONST) {
4614 /* "last()" means "last" */
4615 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4616 o = newOP(type, OPf_SPECIAL);
4618 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4619 ? SvPVx_nolen_const(((SVOP*)label)->op_sv)
4623 op_getmad(label,o,'L');
4629 /* Check whether it's going to be a goto &function */
4630 if (label->op_type == OP_ENTERSUB
4631 && !(label->op_flags & OPf_STACKED))
4632 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4633 o = newUNOP(type, OPf_STACKED, label);
4635 PL_hints |= HINT_BLOCK_SCOPE;
4639 /* if the condition is a literal array or hash
4640 (or @{ ... } etc), make a reference to it.
4643 S_ref_array_or_hash(pTHX_ OP *cond)
4646 && (cond->op_type == OP_RV2AV
4647 || cond->op_type == OP_PADAV
4648 || cond->op_type == OP_RV2HV
4649 || cond->op_type == OP_PADHV))
4651 return newUNOP(OP_REFGEN,
4652 0, mod(cond, OP_REFGEN));
4658 /* These construct the optree fragments representing given()
4661 entergiven and enterwhen are LOGOPs; the op_other pointer
4662 points up to the associated leave op. We need this so we
4663 can put it in the context and make break/continue work.
4664 (Also, of course, pp_enterwhen will jump straight to
4665 op_other if the match fails.)
4670 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
4671 I32 enter_opcode, I32 leave_opcode,
4672 PADOFFSET entertarg)
4678 NewOp(1101, enterop, 1, LOGOP);
4679 enterop->op_type = enter_opcode;
4680 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
4681 enterop->op_flags = (U8) OPf_KIDS;
4682 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
4683 enterop->op_private = 0;
4685 o = newUNOP(leave_opcode, 0, (OP *) enterop);
4688 enterop->op_first = scalar(cond);
4689 cond->op_sibling = block;
4691 o->op_next = LINKLIST(cond);
4692 cond->op_next = (OP *) enterop;
4695 /* This is a default {} block */
4696 enterop->op_first = block;
4697 enterop->op_flags |= OPf_SPECIAL;
4699 o->op_next = (OP *) enterop;
4702 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
4703 entergiven and enterwhen both
4706 enterop->op_next = LINKLIST(block);
4707 block->op_next = enterop->op_other = o;
4712 /* Does this look like a boolean operation? For these purposes
4713 a boolean operation is:
4714 - a subroutine call [*]
4715 - a logical connective
4716 - a comparison operator
4717 - a filetest operator, with the exception of -s -M -A -C
4718 - defined(), exists() or eof()
4719 - /$re/ or $foo =~ /$re/
4721 [*] possibly surprising
4725 S_looks_like_bool(pTHX_ const OP *o)
4728 switch(o->op_type) {
4730 return looks_like_bool(cLOGOPo->op_first);
4734 looks_like_bool(cLOGOPo->op_first)
4735 && looks_like_bool(cLOGOPo->op_first->op_sibling));
4739 case OP_NOT: case OP_XOR:
4740 /* Note that OP_DOR is not here */
4742 case OP_EQ: case OP_NE: case OP_LT:
4743 case OP_GT: case OP_LE: case OP_GE:
4745 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
4746 case OP_I_GT: case OP_I_LE: case OP_I_GE:
4748 case OP_SEQ: case OP_SNE: case OP_SLT:
4749 case OP_SGT: case OP_SLE: case OP_SGE:
4753 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
4754 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
4755 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
4756 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
4757 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
4758 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
4759 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
4760 case OP_FTTEXT: case OP_FTBINARY:
4762 case OP_DEFINED: case OP_EXISTS:
4763 case OP_MATCH: case OP_EOF:
4768 /* Detect comparisons that have been optimized away */
4769 if (cSVOPo->op_sv == &PL_sv_yes
4770 || cSVOPo->op_sv == &PL_sv_no)
4781 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
4785 return newGIVWHENOP(
4786 ref_array_or_hash(cond),
4788 OP_ENTERGIVEN, OP_LEAVEGIVEN,
4792 /* If cond is null, this is a default {} block */
4794 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
4796 const bool cond_llb = (!cond || looks_like_bool(cond));
4802 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
4804 scalar(ref_array_or_hash(cond)));
4807 return newGIVWHENOP(
4809 append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
4810 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
4814 =for apidoc cv_undef
4816 Clear out all the active components of a CV. This can happen either
4817 by an explicit C<undef &foo>, or by the reference count going to zero.
4818 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
4819 children can still follow the full lexical scope chain.
4825 Perl_cv_undef(pTHX_ CV *cv)
4829 if (CvFILE(cv) && !CvISXSUB(cv)) {
4830 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4831 Safefree(CvFILE(cv));
4836 if (!CvISXSUB(cv) && CvROOT(cv)) {
4837 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
4838 Perl_croak(aTHX_ "Can't undef active subroutine");
4841 PAD_SAVE_SETNULLPAD();
4843 op_free(CvROOT(cv));
4848 SvPOK_off((SV*)cv); /* forget prototype */
4853 /* remove CvOUTSIDE unless this is an undef rather than a free */
4854 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
4855 if (!CvWEAKOUTSIDE(cv))
4856 SvREFCNT_dec(CvOUTSIDE(cv));
4857 CvOUTSIDE(cv) = NULL;
4860 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4863 if (CvISXSUB(cv) && CvXSUB(cv)) {
4866 /* delete all flags except WEAKOUTSIDE */
4867 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
4871 Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
4874 /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
4875 relying on SvCUR, and doubling up the buffer to hold CvFILE(). */
4876 if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
4877 || (p && (len != SvCUR(cv) /* Not the same length. */
4878 || memNE(p, SvPVX_const(cv), len))))
4879 && ckWARN_d(WARN_PROTOTYPE)) {
4880 SV* const msg = sv_newmortal();
4884 gv_efullname3(name = sv_newmortal(), gv, NULL);
4885 sv_setpv(msg, "Prototype mismatch:");
4887 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, (void*)name);
4889 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (void*)cv);
4891 sv_catpvs(msg, ": none");
4892 sv_catpvs(msg, " vs ");
4894 Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
4896 sv_catpvs(msg, "none");
4897 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, (void*)msg);
4901 static void const_sv_xsub(pTHX_ CV* cv);
4905 =head1 Optree Manipulation Functions
4907 =for apidoc cv_const_sv
4909 If C<cv> is a constant sub eligible for inlining. returns the constant
4910 value returned by the sub. Otherwise, returns NULL.
4912 Constant subs can be created with C<newCONSTSUB> or as described in
4913 L<perlsub/"Constant Functions">.
4918 Perl_cv_const_sv(pTHX_ CV *cv)
4920 PERL_UNUSED_CONTEXT;
4923 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
4925 return CvCONST(cv) ? (SV*)CvXSUBANY(cv).any_ptr : NULL;
4928 /* op_const_sv: examine an optree to determine whether it's in-lineable.
4929 * Can be called in 3 ways:
4932 * look for a single OP_CONST with attached value: return the value
4934 * cv && CvCLONE(cv) && !CvCONST(cv)
4936 * examine the clone prototype, and if contains only a single
4937 * OP_CONST referencing a pad const, or a single PADSV referencing
4938 * an outer lexical, return a non-zero value to indicate the CV is
4939 * a candidate for "constizing" at clone time
4943 * We have just cloned an anon prototype that was marked as a const
4944 * candidiate. Try to grab the current value, and in the case of
4945 * PADSV, ignore it if it has multiple references. Return the value.
4949 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
4957 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4958 o = cLISTOPo->op_first->op_sibling;
4960 for (; o; o = o->op_next) {
4961 const OPCODE type = o->op_type;
4963 if (sv && o->op_next == o)
4965 if (o->op_next != o) {
4966 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4968 if (type == OP_DBSTATE)
4971 if (type == OP_LEAVESUB || type == OP_RETURN)
4975 if (type == OP_CONST && cSVOPo->op_sv)
4977 else if (cv && type == OP_CONST) {
4978 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4982 else if (cv && type == OP_PADSV) {
4983 if (CvCONST(cv)) { /* newly cloned anon */
4984 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4985 /* the candidate should have 1 ref from this pad and 1 ref
4986 * from the parent */
4987 if (!sv || SvREFCNT(sv) != 2)
4994 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
4995 sv = &PL_sv_undef; /* an arbitrary non-null value */
5010 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5013 /* This would be the return value, but the return cannot be reached. */
5014 OP* pegop = newOP(OP_NULL, 0);
5017 PERL_UNUSED_ARG(floor);
5027 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
5029 NORETURN_FUNCTION_END;
5034 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
5036 return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
5040 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5047 register CV *cv = NULL;
5049 /* If the subroutine has no body, no attributes, and no builtin attributes
5050 then it's just a sub declaration, and we may be able to get away with
5051 storing with a placeholder scalar in the symbol table, rather than a
5052 full GV and CV. If anything is present then it will take a full CV to
5054 const I32 gv_fetch_flags
5055 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5057 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
5058 const char * const name = o ? SvPVx_nolen_const(cSVOPo->op_sv) : NULL;
5061 assert(proto->op_type == OP_CONST);
5062 ps = SvPVx_const(((SVOP*)proto)->op_sv, ps_len);
5067 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
5068 SV * const sv = sv_newmortal();
5069 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
5070 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
5071 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
5072 aname = SvPVX_const(sv);
5077 gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
5078 : gv_fetchpv(aname ? aname
5079 : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5080 gv_fetch_flags, SVt_PVCV);
5082 if (!PL_madskills) {
5091 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
5092 maximum a prototype before. */
5093 if (SvTYPE(gv) > SVt_NULL) {
5094 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
5095 && ckWARN_d(WARN_PROTOTYPE))
5097 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
5099 cv_ckproto_len((CV*)gv, NULL, ps, ps_len);
5102 sv_setpvn((SV*)gv, ps, ps_len);
5104 sv_setiv((SV*)gv, -1);
5105 SvREFCNT_dec(PL_compcv);
5106 cv = PL_compcv = NULL;
5107 PL_sub_generation++;
5111 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
5113 #ifdef GV_UNIQUE_CHECK
5114 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
5115 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
5119 if (!block || !ps || *ps || attrs
5120 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5122 || block->op_type == OP_NULL
5127 const_sv = op_const_sv(block, NULL);
5130 const bool exists = CvROOT(cv) || CvXSUB(cv);
5132 #ifdef GV_UNIQUE_CHECK
5133 if (exists && GvUNIQUE(gv)) {
5134 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
5138 /* if the subroutine doesn't exist and wasn't pre-declared
5139 * with a prototype, assume it will be AUTOLOADed,
5140 * skipping the prototype check
5142 if (exists || SvPOK(cv))
5143 cv_ckproto_len(cv, gv, ps, ps_len);
5144 /* already defined (or promised)? */
5145 if (exists || GvASSUMECV(gv)) {
5148 || block->op_type == OP_NULL
5151 if (CvFLAGS(PL_compcv)) {
5152 /* might have had built-in attrs applied */
5153 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5155 /* just a "sub foo;" when &foo is already defined */
5156 SAVEFREESV(PL_compcv);
5161 && block->op_type != OP_NULL
5164 if (ckWARN(WARN_REDEFINE)
5166 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
5168 const line_t oldline = CopLINE(PL_curcop);
5169 if (PL_copline != NOLINE)
5170 CopLINE_set(PL_curcop, PL_copline);
5171 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5172 CvCONST(cv) ? "Constant subroutine %s redefined"
5173 : "Subroutine %s redefined", name);
5174 CopLINE_set(PL_curcop, oldline);
5177 if (!PL_minus_c) /* keep old one around for madskills */
5180 /* (PL_madskills unset in used file.) */
5188 SvREFCNT_inc_simple_void_NN(const_sv);
5190 assert(!CvROOT(cv) && !CvCONST(cv));
5191 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
5192 CvXSUBANY(cv).any_ptr = const_sv;
5193 CvXSUB(cv) = const_sv_xsub;
5199 cv = newCONSTSUB(NULL, name, const_sv);
5201 PL_sub_generation++;
5205 SvREFCNT_dec(PL_compcv);
5213 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
5214 * before we clobber PL_compcv.
5218 || block->op_type == OP_NULL
5222 /* Might have had built-in attributes applied -- propagate them. */
5223 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5224 if (CvGV(cv) && GvSTASH(CvGV(cv)))
5225 stash = GvSTASH(CvGV(cv));
5226 else if (CvSTASH(cv))
5227 stash = CvSTASH(cv);
5229 stash = PL_curstash;
5232 /* possibly about to re-define existing subr -- ignore old cv */
5233 rcv = (SV*)PL_compcv;
5234 if (name && GvSTASH(gv))
5235 stash = GvSTASH(gv);
5237 stash = PL_curstash;
5239 apply_attrs(stash, rcv, attrs, FALSE);
5241 if (cv) { /* must reuse cv if autoloaded */
5248 || block->op_type == OP_NULL) && !PL_madskills
5251 /* got here with just attrs -- work done, so bug out */
5252 SAVEFREESV(PL_compcv);
5255 /* transfer PL_compcv to cv */
5257 CvFLAGS(cv) = CvFLAGS(PL_compcv);
5258 if (!CvWEAKOUTSIDE(cv))
5259 SvREFCNT_dec(CvOUTSIDE(cv));
5260 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
5261 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
5262 CvOUTSIDE(PL_compcv) = 0;
5263 CvPADLIST(cv) = CvPADLIST(PL_compcv);
5264 CvPADLIST(PL_compcv) = 0;
5265 /* inner references to PL_compcv must be fixed up ... */
5266 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
5267 /* ... before we throw it away */
5268 SvREFCNT_dec(PL_compcv);
5270 if (PERLDB_INTER)/* Advice debugger on the new sub. */
5271 ++PL_sub_generation;
5278 if (strEQ(name, "import")) {
5279 PL_formfeed = (SV*)cv;
5280 Perl_warner(aTHX_ packWARN(WARN_VOID), "%lx\n", (long)cv);
5284 PL_sub_generation++;
5288 CvFILE_set_from_cop(cv, PL_curcop);
5289 CvSTASH(cv) = PL_curstash;
5292 sv_setpvn((SV*)cv, ps, ps_len);
5294 if (PL_error_count) {
5298 const char *s = strrchr(name, ':');
5300 if (strEQ(s, "BEGIN")) {
5301 const char not_safe[] =
5302 "BEGIN not safe after errors--compilation aborted";
5303 if (PL_in_eval & EVAL_KEEPERR)
5304 Perl_croak(aTHX_ not_safe);
5306 /* force display of errors found but not reported */
5307 sv_catpv(ERRSV, not_safe);
5308 Perl_croak(aTHX_ "%"SVf, (void*)ERRSV);
5318 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5319 mod(scalarseq(block), OP_LEAVESUBLV));
5322 /* This makes sub {}; work as expected. */
5323 if (block->op_type == OP_STUB) {
5324 OP* const newblock = newSTATEOP(0, NULL, 0);
5326 op_getmad(block,newblock,'B');
5332 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5334 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5335 OpREFCNT_set(CvROOT(cv), 1);
5336 CvSTART(cv) = LINKLIST(CvROOT(cv));
5337 CvROOT(cv)->op_next = 0;
5338 CALL_PEEP(CvSTART(cv));
5340 /* now that optimizer has done its work, adjust pad values */
5342 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
5345 assert(!CvCONST(cv));
5346 if (ps && !*ps && op_const_sv(block, cv))
5350 if (name || aname) {
5352 const char * const tname = (name ? name : aname);
5354 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5355 SV * const sv = newSV(0);
5356 SV * const tmpstr = sv_newmortal();
5357 GV * const db_postponed = gv_fetchpvs("DB::postponed",
5358 GV_ADDMULTI, SVt_PVHV);
5361 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5363 (long)PL_subline, (long)CopLINE(PL_curcop));
5364 gv_efullname3(tmpstr, gv, NULL);
5365 hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0);
5366 hv = GvHVn(db_postponed);
5367 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
5368 CV * const pcv = GvCV(db_postponed);
5374 call_sv((SV*)pcv, G_DISCARD);
5379 if ((s = strrchr(tname,':')))
5384 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I' && *s != 'U')
5387 if (strEQ(s, "BEGIN") && !PL_error_count) {
5388 const I32 oldscope = PL_scopestack_ix;
5390 SAVECOPFILE(&PL_compiling);
5391 SAVECOPLINE(&PL_compiling);
5394 PL_beginav = newAV();
5395 DEBUG_x( dump_sub(gv) );
5396 av_push(PL_beginav, (SV*)cv);
5397 GvCV(gv) = 0; /* cv has been hijacked */
5398 call_list(oldscope, PL_beginav);
5400 PL_curcop = &PL_compiling;
5401 CopHINTS_set(&PL_compiling, PL_hints);
5404 else if (strEQ(s, "END") && !PL_error_count) {
5407 DEBUG_x( dump_sub(gv) );
5408 av_unshift(PL_endav, 1);
5409 av_store(PL_endav, 0, (SV*)cv);
5410 GvCV(gv) = 0; /* cv has been hijacked */
5412 else if (strEQ(s, "UNITCHECK") && !PL_error_count) {
5413 /* It's never too late to run a unitcheck block */
5414 if (!PL_unitcheckav)
5415 PL_unitcheckav = newAV();
5416 DEBUG_x( dump_sub(gv) );
5417 av_unshift(PL_unitcheckav, 1);
5418 av_store(PL_unitcheckav, 0, (SV*)cv);
5419 GvCV(gv) = 0; /* cv has been hijacked */
5421 else if (strEQ(s, "CHECK") && !PL_error_count) {
5423 PL_checkav = newAV();
5424 DEBUG_x( dump_sub(gv) );
5425 if (PL_main_start && ckWARN(WARN_VOID))
5426 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
5427 av_unshift(PL_checkav, 1);
5428 av_store(PL_checkav, 0, (SV*)cv);
5429 GvCV(gv) = 0; /* cv has been hijacked */
5431 else if (strEQ(s, "INIT") && !PL_error_count) {
5433 PL_initav = newAV();
5434 DEBUG_x( dump_sub(gv) );
5435 if (PL_main_start && ckWARN(WARN_VOID))
5436 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
5437 av_push(PL_initav, (SV*)cv);
5438 GvCV(gv) = 0; /* cv has been hijacked */
5443 PL_copline = NOLINE;
5448 /* XXX unsafe for threads if eval_owner isn't held */
5450 =for apidoc newCONSTSUB
5452 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5453 eligible for inlining at compile-time.
5459 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
5464 const char *const temp_p = CopFILE(PL_curcop);
5465 const STRLEN len = temp_p ? strlen(temp_p) : 0;
5467 SV *const temp_sv = CopFILESV(PL_curcop);
5469 const char *const temp_p = temp_sv ? SvPV_const(temp_sv, len) : NULL;
5471 char *const file = savepvn(temp_p, temp_p ? len : 0);
5475 SAVECOPLINE(PL_curcop);
5476 CopLINE_set(PL_curcop, PL_copline);
5479 PL_hints &= ~HINT_BLOCK_SCOPE;
5482 SAVESPTR(PL_curstash);
5483 SAVECOPSTASH(PL_curcop);
5484 PL_curstash = stash;
5485 CopSTASH_set(PL_curcop,stash);
5488 /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
5489 and so doesn't get free()d. (It's expected to be from the C pre-
5490 processor __FILE__ directive). But we need a dynamically allocated one,
5491 and we need it to get freed. */
5492 cv = newXS_flags(name, const_sv_xsub, file, "", XS_DYNAMIC_FILENAME);
5493 CvXSUBANY(cv).any_ptr = sv;
5499 CopSTASH_free(PL_curcop);
5507 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
5508 const char *const filename, const char *const proto,
5511 CV *cv = newXS(name, subaddr, filename);
5513 if (flags & XS_DYNAMIC_FILENAME) {
5514 /* We need to "make arrangements" (ie cheat) to ensure that the
5515 filename lasts as long as the PVCV we just created, but also doesn't
5517 STRLEN filename_len = strlen(filename);
5518 STRLEN proto_and_file_len = filename_len;
5519 char *proto_and_file;
5523 proto_len = strlen(proto);
5524 proto_and_file_len += proto_len;
5526 Newx(proto_and_file, proto_and_file_len + 1, char);
5527 Copy(proto, proto_and_file, proto_len, char);
5528 Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
5531 proto_and_file = savepvn(filename, filename_len);
5534 /* This gets free()d. :-) */
5535 sv_usepvn_flags((SV*)cv, proto_and_file, proto_and_file_len,
5536 SV_HAS_TRAILING_NUL);
5538 /* This gives us the correct prototype, rather than one with the
5539 file name appended. */
5540 SvCUR_set(cv, proto_len);
5544 CvFILE(cv) = proto_and_file + proto_len;
5546 sv_setpv((SV *)cv, proto);
5552 =for apidoc U||newXS
5554 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
5555 static storage, as it is used directly as CvFILE(), without a copy being made.
5561 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
5564 GV * const gv = gv_fetchpv(name ? name :
5565 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5566 GV_ADDMULTI, SVt_PVCV);
5570 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
5572 if ((cv = (name ? GvCV(gv) : NULL))) {
5574 /* just a cached method */
5578 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5579 /* already defined (or promised) */
5580 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
5581 if (ckWARN(WARN_REDEFINE)) {
5582 GV * const gvcv = CvGV(cv);
5584 HV * const stash = GvSTASH(gvcv);
5586 const char *redefined_name = HvNAME_get(stash);
5587 if ( strEQ(redefined_name,"autouse") ) {
5588 const line_t oldline = CopLINE(PL_curcop);
5589 if (PL_copline != NOLINE)
5590 CopLINE_set(PL_curcop, PL_copline);
5591 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5592 CvCONST(cv) ? "Constant subroutine %s redefined"
5593 : "Subroutine %s redefined"
5595 CopLINE_set(PL_curcop, oldline);
5605 if (cv) /* must reuse cv if autoloaded */
5609 sv_upgrade((SV *)cv, SVt_PVCV);
5613 PL_sub_generation++;
5617 (void)gv_fetchfile(filename);
5618 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
5619 an external constant string */
5621 CvXSUB(cv) = subaddr;
5624 const char *s = strrchr(name,':');
5630 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5633 if (strEQ(s, "BEGIN")) {
5635 PL_beginav = newAV();
5636 av_push(PL_beginav, (SV*)cv);
5637 GvCV(gv) = 0; /* cv has been hijacked */
5639 else if (strEQ(s, "END")) {
5642 av_unshift(PL_endav, 1);
5643 av_store(PL_endav, 0, (SV*)cv);
5644 GvCV(gv) = 0; /* cv has been hijacked */
5646 else if (strEQ(s, "CHECK")) {
5648 PL_checkav = newAV();
5649 if (PL_main_start && ckWARN(WARN_VOID))
5650 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
5651 av_unshift(PL_checkav, 1);
5652 av_store(PL_checkav, 0, (SV*)cv);
5653 GvCV(gv) = 0; /* cv has been hijacked */
5655 else if (strEQ(s, "INIT")) {
5657 PL_initav = newAV();
5658 if (PL_main_start && ckWARN(WARN_VOID))
5659 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
5660 av_push(PL_initav, (SV*)cv);
5661 GvCV(gv) = 0; /* cv has been hijacked */
5676 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5681 OP* pegop = newOP(OP_NULL, 0);
5685 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
5686 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
5688 #ifdef GV_UNIQUE_CHECK
5690 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5694 if ((cv = GvFORM(gv))) {
5695 if (ckWARN(WARN_REDEFINE)) {
5696 const line_t oldline = CopLINE(PL_curcop);
5697 if (PL_copline != NOLINE)
5698 CopLINE_set(PL_curcop, PL_copline);
5699 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5700 o ? "Format %"SVf" redefined"
5701 : "Format STDOUT redefined", (void*)cSVOPo->op_sv);
5702 CopLINE_set(PL_curcop, oldline);
5709 CvFILE_set_from_cop(cv, PL_curcop);
5712 pad_tidy(padtidy_FORMAT);
5713 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5714 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5715 OpREFCNT_set(CvROOT(cv), 1);
5716 CvSTART(cv) = LINKLIST(CvROOT(cv));
5717 CvROOT(cv)->op_next = 0;
5718 CALL_PEEP(CvSTART(cv));
5720 op_getmad(o,pegop,'n');
5721 op_getmad_weak(block, pegop, 'b');
5725 PL_copline = NOLINE;
5733 Perl_newANONLIST(pTHX_ OP *o)
5735 return convert(OP_ANONLIST, OPf_SPECIAL, o);
5739 Perl_newANONHASH(pTHX_ OP *o)
5741 return convert(OP_ANONHASH, OPf_SPECIAL, o);
5745 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5747 return newANONATTRSUB(floor, proto, NULL, block);
5751 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5753 return newUNOP(OP_REFGEN, 0,
5754 newSVOP(OP_ANONCODE, 0,
5755 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5759 Perl_oopsAV(pTHX_ OP *o)
5762 switch (o->op_type) {
5764 o->op_type = OP_PADAV;
5765 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5766 return ref(o, OP_RV2AV);
5769 o->op_type = OP_RV2AV;
5770 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5775 if (ckWARN_d(WARN_INTERNAL))
5776 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
5783 Perl_oopsHV(pTHX_ OP *o)
5786 switch (o->op_type) {
5789 o->op_type = OP_PADHV;
5790 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5791 return ref(o, OP_RV2HV);
5795 o->op_type = OP_RV2HV;
5796 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5801 if (ckWARN_d(WARN_INTERNAL))
5802 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
5809 Perl_newAVREF(pTHX_ OP *o)
5812 if (o->op_type == OP_PADANY) {
5813 o->op_type = OP_PADAV;
5814 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5817 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5818 && ckWARN(WARN_DEPRECATED)) {
5819 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5820 "Using an array as a reference is deprecated");
5822 return newUNOP(OP_RV2AV, 0, scalar(o));
5826 Perl_newGVREF(pTHX_ I32 type, OP *o)
5828 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5829 return newUNOP(OP_NULL, 0, o);
5830 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5834 Perl_newHVREF(pTHX_ OP *o)
5837 if (o->op_type == OP_PADANY) {
5838 o->op_type = OP_PADHV;
5839 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5842 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5843 && ckWARN(WARN_DEPRECATED)) {
5844 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5845 "Using a hash as a reference is deprecated");
5847 return newUNOP(OP_RV2HV, 0, scalar(o));
5851 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5853 return newUNOP(OP_RV2CV, flags, scalar(o));
5857 Perl_newSVREF(pTHX_ OP *o)
5860 if (o->op_type == OP_PADANY) {
5861 o->op_type = OP_PADSV;
5862 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5865 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5866 o->op_flags |= OPpDONE_SVREF;
5869 return newUNOP(OP_RV2SV, 0, scalar(o));
5872 /* Check routines. See the comments at the top of this file for details
5873 * on when these are called */
5876 Perl_ck_anoncode(pTHX_ OP *o)
5878 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
5880 cSVOPo->op_sv = NULL;
5885 Perl_ck_bitop(pTHX_ OP *o)
5888 #define OP_IS_NUMCOMPARE(op) \
5889 ((op) == OP_LT || (op) == OP_I_LT || \
5890 (op) == OP_GT || (op) == OP_I_GT || \
5891 (op) == OP_LE || (op) == OP_I_LE || \
5892 (op) == OP_GE || (op) == OP_I_GE || \
5893 (op) == OP_EQ || (op) == OP_I_EQ || \
5894 (op) == OP_NE || (op) == OP_I_NE || \
5895 (op) == OP_NCMP || (op) == OP_I_NCMP)
5896 o->op_private = (U8)(PL_hints & HINT_INTEGER);
5897 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
5898 && (o->op_type == OP_BIT_OR
5899 || o->op_type == OP_BIT_AND
5900 || o->op_type == OP_BIT_XOR))
5902 const OP * const left = cBINOPo->op_first;
5903 const OP * const right = left->op_sibling;
5904 if ((OP_IS_NUMCOMPARE(left->op_type) &&
5905 (left->op_flags & OPf_PARENS) == 0) ||
5906 (OP_IS_NUMCOMPARE(right->op_type) &&
5907 (right->op_flags & OPf_PARENS) == 0))
5908 if (ckWARN(WARN_PRECEDENCE))
5909 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
5910 "Possible precedence problem on bitwise %c operator",
5911 o->op_type == OP_BIT_OR ? '|'
5912 : o->op_type == OP_BIT_AND ? '&' : '^'
5919 Perl_ck_concat(pTHX_ OP *o)
5921 const OP * const kid = cUNOPo->op_first;
5922 PERL_UNUSED_CONTEXT;
5923 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
5924 !(kUNOP->op_first->op_flags & OPf_MOD))
5925 o->op_flags |= OPf_STACKED;
5930 Perl_ck_spair(pTHX_ OP *o)
5933 if (o->op_flags & OPf_KIDS) {
5936 const OPCODE type = o->op_type;
5937 o = modkids(ck_fun(o), type);
5938 kid = cUNOPo->op_first;
5939 newop = kUNOP->op_first->op_sibling;
5941 const OPCODE type = newop->op_type;
5942 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
5943 type == OP_PADAV || type == OP_PADHV ||
5944 type == OP_RV2AV || type == OP_RV2HV)
5948 op_getmad(kUNOP->op_first,newop,'K');
5950 op_free(kUNOP->op_first);
5952 kUNOP->op_first = newop;
5954 o->op_ppaddr = PL_ppaddr[++o->op_type];
5959 Perl_ck_delete(pTHX_ OP *o)
5963 if (o->op_flags & OPf_KIDS) {
5964 OP * const kid = cUNOPo->op_first;
5965 switch (kid->op_type) {
5967 o->op_flags |= OPf_SPECIAL;
5970 o->op_private |= OPpSLICE;
5973 o->op_flags |= OPf_SPECIAL;
5978 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5987 Perl_ck_die(pTHX_ OP *o)
5990 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5996 Perl_ck_eof(pTHX_ OP *o)
6000 if (o->op_flags & OPf_KIDS) {
6001 if (cLISTOPo->op_first->op_type == OP_STUB) {
6003 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
6005 op_getmad(o,newop,'O');
6017 Perl_ck_eval(pTHX_ OP *o)
6020 PL_hints |= HINT_BLOCK_SCOPE;
6021 if (o->op_flags & OPf_KIDS) {
6022 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6025 o->op_flags &= ~OPf_KIDS;
6028 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
6034 cUNOPo->op_first = 0;
6039 NewOp(1101, enter, 1, LOGOP);
6040 enter->op_type = OP_ENTERTRY;
6041 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
6042 enter->op_private = 0;
6044 /* establish postfix order */
6045 enter->op_next = (OP*)enter;
6047 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
6048 o->op_type = OP_LEAVETRY;
6049 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
6050 enter->op_other = o;
6051 op_getmad(oldo,o,'O');
6065 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
6066 op_getmad(oldo,o,'O');
6068 o->op_targ = (PADOFFSET)PL_hints;
6069 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
6070 /* Store a copy of %^H that pp_entereval can pick up */
6071 OP *hhop = newSVOP(OP_CONST, 0,
6072 (SV*)Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv)));
6073 cUNOPo->op_first->op_sibling = hhop;
6074 o->op_private |= OPpEVAL_HAS_HH;
6080 Perl_ck_exit(pTHX_ OP *o)
6083 HV * const table = GvHV(PL_hintgv);
6085 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
6086 if (svp && *svp && SvTRUE(*svp))
6087 o->op_private |= OPpEXIT_VMSISH;
6089 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6095 Perl_ck_exec(pTHX_ OP *o)
6097 if (o->op_flags & OPf_STACKED) {
6100 kid = cUNOPo->op_first->op_sibling;
6101 if (kid->op_type == OP_RV2GV)
6110 Perl_ck_exists(pTHX_ OP *o)
6114 if (o->op_flags & OPf_KIDS) {
6115 OP * const kid = cUNOPo->op_first;
6116 if (kid->op_type == OP_ENTERSUB) {
6117 (void) ref(kid, o->op_type);
6118 if (kid->op_type != OP_RV2CV && !PL_error_count)
6119 Perl_croak(aTHX_ "%s argument is not a subroutine name",
6121 o->op_private |= OPpEXISTS_SUB;
6123 else if (kid->op_type == OP_AELEM)
6124 o->op_flags |= OPf_SPECIAL;
6125 else if (kid->op_type != OP_HELEM)
6126 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
6134 Perl_ck_rvconst(pTHX_ register OP *o)
6137 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6139 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6140 if (o->op_type == OP_RV2CV)
6141 o->op_private &= ~1;
6143 if (kid->op_type == OP_CONST) {
6146 SV * const kidsv = kid->op_sv;
6148 /* Is it a constant from cv_const_sv()? */
6149 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
6150 SV * const rsv = SvRV(kidsv);
6151 const svtype type = SvTYPE(rsv);
6152 const char *badtype = NULL;
6154 switch (o->op_type) {
6156 if (type > SVt_PVMG)
6157 badtype = "a SCALAR";
6160 if (type != SVt_PVAV)
6161 badtype = "an ARRAY";
6164 if (type != SVt_PVHV)
6168 if (type != SVt_PVCV)
6173 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
6176 else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
6177 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
6178 /* If this is an access to a stash, disable "strict refs", because
6179 * stashes aren't auto-vivified at compile-time (unless we store
6180 * symbols in them), and we don't want to produce a run-time
6181 * stricture error when auto-vivifying the stash. */
6182 const char *s = SvPV_nolen(kidsv);
6183 const STRLEN l = SvCUR(kidsv);
6184 if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
6185 o->op_private &= ~HINT_STRICT_REFS;
6187 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
6188 const char *badthing;
6189 switch (o->op_type) {
6191 badthing = "a SCALAR";
6194 badthing = "an ARRAY";
6197 badthing = "a HASH";
6205 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
6206 (void*)kidsv, badthing);
6209 * This is a little tricky. We only want to add the symbol if we
6210 * didn't add it in the lexer. Otherwise we get duplicate strict
6211 * warnings. But if we didn't add it in the lexer, we must at
6212 * least pretend like we wanted to add it even if it existed before,
6213 * or we get possible typo warnings. OPpCONST_ENTERED says
6214 * whether the lexer already added THIS instance of this symbol.
6216 iscv = (o->op_type == OP_RV2CV) * 2;
6218 gv = gv_fetchsv(kidsv,
6219 iscv | !(kid->op_private & OPpCONST_ENTERED),
6222 : o->op_type == OP_RV2SV
6224 : o->op_type == OP_RV2AV
6226 : o->op_type == OP_RV2HV
6229 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
6231 kid->op_type = OP_GV;
6232 SvREFCNT_dec(kid->op_sv);
6234 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
6235 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
6236 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
6238 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc_simple_NN(gv));
6240 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
6242 kid->op_private = 0;
6243 kid->op_ppaddr = PL_ppaddr[OP_GV];
6250 Perl_ck_ftst(pTHX_ OP *o)
6253 const I32 type = o->op_type;
6255 if (o->op_flags & OPf_REF) {
6258 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
6259 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6260 const OPCODE kidtype = kid->op_type;
6262 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6263 OP * const newop = newGVOP(type, OPf_REF,
6264 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
6266 op_getmad(o,newop,'O');
6272 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o))
6273 o->op_private |= OPpFT_ACCESS;
6274 if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst)
6275 && kidtype != OP_STAT && kidtype != OP_LSTAT)
6276 o->op_private |= OPpFT_STACKED;
6284 if (type == OP_FTTTY)
6285 o = newGVOP(type, OPf_REF, PL_stdingv);
6287 o = newUNOP(type, 0, newDEFSVOP());
6288 op_getmad(oldo,o,'O');
6294 Perl_ck_fun(pTHX_ OP *o)
6297 const int type = o->op_type;
6298 register I32 oa = PL_opargs[type] >> OASHIFT;
6300 if (o->op_flags & OPf_STACKED) {
6301 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
6304 return no_fh_allowed(o);
6307 if (o->op_flags & OPf_KIDS) {
6308 OP **tokid = &cLISTOPo->op_first;
6309 register OP *kid = cLISTOPo->op_first;
6313 if (kid->op_type == OP_PUSHMARK ||
6314 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
6316 tokid = &kid->op_sibling;
6317 kid = kid->op_sibling;
6319 if (!kid && PL_opargs[type] & OA_DEFGV)
6320 *tokid = kid = newDEFSVOP();
6324 sibl = kid->op_sibling;
6326 if (!sibl && kid->op_type == OP_STUB) {
6333 /* list seen where single (scalar) arg expected? */
6334 if (numargs == 1 && !(oa >> 4)
6335 && kid->op_type == OP_LIST && type != OP_SCALAR)
6337 return too_many_arguments(o,PL_op_desc[type]);
6350 if ((type == OP_PUSH || type == OP_UNSHIFT)
6351 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
6352 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6353 "Useless use of %s with no values",
6356 if (kid->op_type == OP_CONST &&
6357 (kid->op_private & OPpCONST_BARE))
6359 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
6360 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
6361 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6362 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6363 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
6364 (void*)((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
6366 op_getmad(kid,newop,'K');
6371 kid->op_sibling = sibl;
6374 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
6375 bad_type(numargs, "array", PL_op_desc[type], kid);
6379 if (kid->op_type == OP_CONST &&
6380 (kid->op_private & OPpCONST_BARE))
6382 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
6383 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
6384 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6385 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6386 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
6387 (void*)((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
6389 op_getmad(kid,newop,'K');
6394 kid->op_sibling = sibl;
6397 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
6398 bad_type(numargs, "hash", PL_op_desc[type], kid);
6403 OP * const newop = newUNOP(OP_NULL, 0, kid);
6404 kid->op_sibling = 0;
6406 newop->op_next = newop;
6408 kid->op_sibling = sibl;
6413 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
6414 if (kid->op_type == OP_CONST &&
6415 (kid->op_private & OPpCONST_BARE))
6417 OP * const newop = newGVOP(OP_GV, 0,
6418 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
6419 if (!(o->op_private & 1) && /* if not unop */
6420 kid == cLISTOPo->op_last)
6421 cLISTOPo->op_last = newop;
6423 op_getmad(kid,newop,'K');
6429 else if (kid->op_type == OP_READLINE) {
6430 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
6431 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
6434 I32 flags = OPf_SPECIAL;
6438 /* is this op a FH constructor? */
6439 if (is_handle_constructor(o,numargs)) {
6440 const char *name = NULL;
6444 /* Set a flag to tell rv2gv to vivify
6445 * need to "prove" flag does not mean something
6446 * else already - NI-S 1999/05/07
6449 if (kid->op_type == OP_PADSV) {
6450 name = PAD_COMPNAME_PV(kid->op_targ);
6451 /* SvCUR of a pad namesv can't be trusted
6452 * (see PL_generation), so calc its length
6458 else if (kid->op_type == OP_RV2SV
6459 && kUNOP->op_first->op_type == OP_GV)
6461 GV * const gv = cGVOPx_gv(kUNOP->op_first);
6463 len = GvNAMELEN(gv);
6465 else if (kid->op_type == OP_AELEM
6466 || kid->op_type == OP_HELEM)
6469 OP *op = ((BINOP*)kid)->op_first;
6473 const char * const a =
6474 kid->op_type == OP_AELEM ?
6476 if (((op->op_type == OP_RV2AV) ||
6477 (op->op_type == OP_RV2HV)) &&
6478 (firstop = ((UNOP*)op)->op_first) &&
6479 (firstop->op_type == OP_GV)) {
6480 /* packagevar $a[] or $h{} */
6481 GV * const gv = cGVOPx_gv(firstop);
6489 else if (op->op_type == OP_PADAV
6490 || op->op_type == OP_PADHV) {
6491 /* lexicalvar $a[] or $h{} */
6492 const char * const padname =
6493 PAD_COMPNAME_PV(op->op_targ);
6502 name = SvPV_const(tmpstr, len);
6507 name = "__ANONIO__";
6514 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
6515 namesv = PAD_SVl(targ);
6516 SvUPGRADE(namesv, SVt_PV);
6518 sv_setpvn(namesv, "$", 1);
6519 sv_catpvn(namesv, name, len);
6522 kid->op_sibling = 0;
6523 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
6524 kid->op_targ = targ;
6525 kid->op_private |= priv;
6527 kid->op_sibling = sibl;
6533 mod(scalar(kid), type);
6537 tokid = &kid->op_sibling;
6538 kid = kid->op_sibling;
6541 if (kid && kid->op_type != OP_STUB)
6542 return too_many_arguments(o,OP_DESC(o));
6543 o->op_private |= numargs;
6545 /* FIXME - should the numargs move as for the PERL_MAD case? */
6546 o->op_private |= numargs;
6548 return too_many_arguments(o,OP_DESC(o));
6552 else if (PL_opargs[type] & OA_DEFGV) {
6554 OP *newop = newUNOP(type, 0, newDEFSVOP());
6555 op_getmad(o,newop,'O');
6558 /* Ordering of these two is important to keep f_map.t passing. */
6560 return newUNOP(type, 0, newDEFSVOP());
6565 while (oa & OA_OPTIONAL)
6567 if (oa && oa != OA_LIST)
6568 return too_few_arguments(o,OP_DESC(o));
6574 Perl_ck_glob(pTHX_ OP *o)
6580 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
6581 append_elem(OP_GLOB, o, newDEFSVOP());
6583 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
6584 && GvCVu(gv) && GvIMPORTED_CV(gv)))
6586 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6589 #if !defined(PERL_EXTERNAL_GLOB)
6590 /* XXX this can be tightened up and made more failsafe. */
6591 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
6594 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
6595 newSVpvs("File::Glob"), NULL, NULL, NULL);
6596 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6597 glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
6598 GvCV(gv) = GvCV(glob_gv);
6599 SvREFCNT_inc_void((SV*)GvCV(gv));
6600 GvIMPORTED_CV_on(gv);
6603 #endif /* PERL_EXTERNAL_GLOB */
6605 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6606 append_elem(OP_GLOB, o,
6607 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
6608 o->op_type = OP_LIST;
6609 o->op_ppaddr = PL_ppaddr[OP_LIST];
6610 cLISTOPo->op_first->op_type = OP_PUSHMARK;
6611 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
6612 cLISTOPo->op_first->op_targ = 0;
6613 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
6614 append_elem(OP_LIST, o,
6615 scalar(newUNOP(OP_RV2CV, 0,
6616 newGVOP(OP_GV, 0, gv)))));
6617 o = newUNOP(OP_NULL, 0, ck_subr(o));
6618 o->op_targ = OP_GLOB; /* hint at what it used to be */
6621 gv = newGVgen("main");
6623 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
6629 Perl_ck_grep(pTHX_ OP *o)
6634 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
6637 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
6638 /* don't allocate gwop here, as we may leak it if PL_error_count > 0 */
6640 if (o->op_flags & OPf_STACKED) {
6643 kid = cLISTOPo->op_first->op_sibling;
6644 if (!cUNOPx(kid)->op_next)
6645 Perl_croak(aTHX_ "panic: ck_grep");
6646 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
6649 NewOp(1101, gwop, 1, LOGOP);
6650 kid->op_next = (OP*)gwop;
6651 o->op_flags &= ~OPf_STACKED;
6653 kid = cLISTOPo->op_first->op_sibling;
6654 if (type == OP_MAPWHILE)
6661 kid = cLISTOPo->op_first->op_sibling;
6662 if (kid->op_type != OP_NULL)
6663 Perl_croak(aTHX_ "panic: ck_grep");
6664 kid = kUNOP->op_first;
6667 NewOp(1101, gwop, 1, LOGOP);
6668 gwop->op_type = type;
6669 gwop->op_ppaddr = PL_ppaddr[type];
6670 gwop->op_first = listkids(o);
6671 gwop->op_flags |= OPf_KIDS;
6672 gwop->op_other = LINKLIST(kid);
6673 kid->op_next = (OP*)gwop;
6674 offset = pad_findmy("$_");
6675 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
6676 o->op_private = gwop->op_private = 0;
6677 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
6680 o->op_private = gwop->op_private = OPpGREP_LEX;
6681 gwop->op_targ = o->op_targ = offset;
6684 kid = cLISTOPo->op_first->op_sibling;
6685 if (!kid || !kid->op_sibling)
6686 return too_few_arguments(o,OP_DESC(o));
6687 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
6688 mod(kid, OP_GREPSTART);
6694 Perl_ck_index(pTHX_ OP *o)
6696 if (o->op_flags & OPf_KIDS) {
6697 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6699 kid = kid->op_sibling; /* get past "big" */
6700 if (kid && kid->op_type == OP_CONST)
6701 fbm_compile(((SVOP*)kid)->op_sv, 0);
6707 Perl_ck_lengthconst(pTHX_ OP *o)
6709 /* XXX length optimization goes here */
6714 Perl_ck_lfun(pTHX_ OP *o)
6716 const OPCODE type = o->op_type;
6717 return modkids(ck_fun(o), type);
6721 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
6723 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
6724 switch (cUNOPo->op_first->op_type) {
6726 /* This is needed for
6727 if (defined %stash::)
6728 to work. Do not break Tk.
6730 break; /* Globals via GV can be undef */
6732 case OP_AASSIGN: /* Is this a good idea? */
6733 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6734 "defined(@array) is deprecated");
6735 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6736 "\t(Maybe you should just omit the defined()?)\n");
6739 /* This is needed for
6740 if (defined %stash::)
6741 to work. Do not break Tk.
6743 break; /* Globals via GV can be undef */
6745 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6746 "defined(%%hash) is deprecated");
6747 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6748 "\t(Maybe you should just omit the defined()?)\n");
6759 Perl_ck_rfun(pTHX_ OP *o)
6761 const OPCODE type = o->op_type;
6762 return refkids(ck_fun(o), type);
6766 Perl_ck_listiob(pTHX_ OP *o)
6770 kid = cLISTOPo->op_first;
6773 kid = cLISTOPo->op_first;
6775 if (kid->op_type == OP_PUSHMARK)
6776 kid = kid->op_sibling;
6777 if (kid && o->op_flags & OPf_STACKED)
6778 kid = kid->op_sibling;
6779 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6780 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6781 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6782 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6783 cLISTOPo->op_first->op_sibling = kid;
6784 cLISTOPo->op_last = kid;
6785 kid = kid->op_sibling;
6790 append_elem(o->op_type, o, newDEFSVOP());
6796 Perl_ck_smartmatch(pTHX_ OP *o)
6799 if (0 == (o->op_flags & OPf_SPECIAL)) {
6800 OP *first = cBINOPo->op_first;
6801 OP *second = first->op_sibling;
6803 /* Implicitly take a reference to an array or hash */
6804 first->op_sibling = NULL;
6805 first = cBINOPo->op_first = ref_array_or_hash(first);
6806 second = first->op_sibling = ref_array_or_hash(second);
6808 /* Implicitly take a reference to a regular expression */
6809 if (first->op_type == OP_MATCH) {
6810 first->op_type = OP_QR;
6811 first->op_ppaddr = PL_ppaddr[OP_QR];
6813 if (second->op_type == OP_MATCH) {
6814 second->op_type = OP_QR;
6815 second->op_ppaddr = PL_ppaddr[OP_QR];
6824 Perl_ck_sassign(pTHX_ OP *o)
6826 OP * const kid = cLISTOPo->op_first;
6827 /* has a disposable target? */
6828 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6829 && !(kid->op_flags & OPf_STACKED)
6830 /* Cannot steal the second time! */
6831 && !(kid->op_private & OPpTARGET_MY))
6833 OP * const kkid = kid->op_sibling;
6835 /* Can just relocate the target. */
6836 if (kkid && kkid->op_type == OP_PADSV
6837 && !(kkid->op_private & OPpLVAL_INTRO))
6839 kid->op_targ = kkid->op_targ;
6841 /* Now we do not need PADSV and SASSIGN. */
6842 kid->op_sibling = o->op_sibling; /* NULL */
6843 cLISTOPo->op_first = NULL;
6845 op_getmad(o,kid,'O');
6846 op_getmad(kkid,kid,'M');
6851 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6855 if (kid->op_sibling) {
6856 OP *kkid = kid->op_sibling;
6857 if (kkid->op_type == OP_PADSV
6858 && (kkid->op_private & OPpLVAL_INTRO)
6859 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
6860 o->op_private |= OPpASSIGN_STATE;
6861 /* hijacking PADSTALE for uninitialized state variables */
6862 SvPADSTALE_on(PAD_SVl(kkid->op_targ));
6869 Perl_ck_match(pTHX_ OP *o)
6872 if (o->op_type != OP_QR && PL_compcv) {
6873 const PADOFFSET offset = pad_findmy("$_");
6874 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
6875 o->op_targ = offset;
6876 o->op_private |= OPpTARGET_MY;
6879 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
6880 o->op_private |= OPpRUNTIME;
6885 Perl_ck_method(pTHX_ OP *o)
6887 OP * const kid = cUNOPo->op_first;
6888 if (kid->op_type == OP_CONST) {
6889 SV* sv = kSVOP->op_sv;
6890 const char * const method = SvPVX_const(sv);
6891 if (!(strchr(method, ':') || strchr(method, '\''))) {
6893 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6894 sv = newSVpvn_share(method, SvCUR(sv), 0);
6897 kSVOP->op_sv = NULL;
6899 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6901 op_getmad(o,cmop,'O');
6912 Perl_ck_null(pTHX_ OP *o)
6914 PERL_UNUSED_CONTEXT;
6919 Perl_ck_open(pTHX_ OP *o)
6922 HV * const table = GvHV(PL_hintgv);
6924 SV **svp = hv_fetchs(table, "open_IN", FALSE);
6926 const I32 mode = mode_from_discipline(*svp);
6927 if (mode & O_BINARY)
6928 o->op_private |= OPpOPEN_IN_RAW;
6929 else if (mode & O_TEXT)
6930 o->op_private |= OPpOPEN_IN_CRLF;
6933 svp = hv_fetchs(table, "open_OUT", FALSE);
6935 const I32 mode = mode_from_discipline(*svp);
6936 if (mode & O_BINARY)
6937 o->op_private |= OPpOPEN_OUT_RAW;
6938 else if (mode & O_TEXT)
6939 o->op_private |= OPpOPEN_OUT_CRLF;
6942 if (o->op_type == OP_BACKTICK)
6945 /* In case of three-arg dup open remove strictness
6946 * from the last arg if it is a bareword. */
6947 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
6948 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
6952 if ((last->op_type == OP_CONST) && /* The bareword. */
6953 (last->op_private & OPpCONST_BARE) &&
6954 (last->op_private & OPpCONST_STRICT) &&
6955 (oa = first->op_sibling) && /* The fh. */
6956 (oa = oa->op_sibling) && /* The mode. */
6957 (oa->op_type == OP_CONST) &&
6958 SvPOK(((SVOP*)oa)->op_sv) &&
6959 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
6960 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
6961 (last == oa->op_sibling)) /* The bareword. */
6962 last->op_private &= ~OPpCONST_STRICT;
6968 Perl_ck_repeat(pTHX_ OP *o)
6970 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6971 o->op_private |= OPpREPEAT_DOLIST;
6972 cBINOPo->op_first = force_list(cBINOPo->op_first);
6980 Perl_ck_require(pTHX_ OP *o)
6985 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6986 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6988 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6989 SV * const sv = kid->op_sv;
6990 U32 was_readonly = SvREADONLY(sv);
6995 sv_force_normal_flags(sv, 0);
6996 assert(!SvREADONLY(sv));
7003 for (s = SvPVX(sv); *s; s++) {
7004 if (*s == ':' && s[1] == ':') {
7005 const STRLEN len = strlen(s+2)+1;
7007 Move(s+2, s+1, len, char);
7008 SvCUR_set(sv, SvCUR(sv) - 1);
7011 sv_catpvs(sv, ".pm");
7012 SvFLAGS(sv) |= was_readonly;
7016 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
7017 /* handle override, if any */
7018 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
7019 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7020 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
7021 gv = gvp ? *gvp : NULL;
7025 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7026 OP * const kid = cUNOPo->op_first;
7029 cUNOPo->op_first = 0;
7033 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
7034 append_elem(OP_LIST, kid,
7035 scalar(newUNOP(OP_RV2CV, 0,
7038 op_getmad(o,newop,'O');
7046 Perl_ck_return(pTHX_ OP *o)
7049 if (CvLVALUE(PL_compcv)) {
7051 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
7052 mod(kid, OP_LEAVESUBLV);
7058 Perl_ck_select(pTHX_ OP *o)
7062 if (o->op_flags & OPf_KIDS) {
7063 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7064 if (kid && kid->op_sibling) {
7065 o->op_type = OP_SSELECT;
7066 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
7068 return fold_constants(o);
7072 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7073 if (kid && kid->op_type == OP_RV2GV)
7074 kid->op_private &= ~HINT_STRICT_REFS;
7079 Perl_ck_shift(pTHX_ OP *o)
7082 const I32 type = o->op_type;
7084 if (!(o->op_flags & OPf_KIDS)) {
7086 /* FIXME - this can be refactored to reduce code in #ifdefs */
7088 OP * const oldo = o;
7092 argop = newUNOP(OP_RV2AV, 0,
7093 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
7095 o = newUNOP(type, 0, scalar(argop));
7096 op_getmad(oldo,o,'O');
7099 return newUNOP(type, 0, scalar(argop));
7102 return scalar(modkids(ck_fun(o), type));
7106 Perl_ck_sort(pTHX_ OP *o)
7111 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
7112 HV * const hinthv = GvHV(PL_hintgv);
7114 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
7116 const I32 sorthints = (I32)SvIV(*svp);
7117 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
7118 o->op_private |= OPpSORT_QSORT;
7119 if ((sorthints & HINT_SORT_STABLE) != 0)
7120 o->op_private |= OPpSORT_STABLE;
7125 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
7127 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7128 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
7130 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
7132 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
7134 if (kid->op_type == OP_SCOPE) {
7138 else if (kid->op_type == OP_LEAVE) {
7139 if (o->op_type == OP_SORT) {
7140 op_null(kid); /* wipe out leave */
7143 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
7144 if (k->op_next == kid)
7146 /* don't descend into loops */
7147 else if (k->op_type == OP_ENTERLOOP
7148 || k->op_type == OP_ENTERITER)
7150 k = cLOOPx(k)->op_lastop;
7155 kid->op_next = 0; /* just disconnect the leave */
7156 k = kLISTOP->op_first;
7161 if (o->op_type == OP_SORT) {
7162 /* provide scalar context for comparison function/block */
7168 o->op_flags |= OPf_SPECIAL;
7170 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
7173 firstkid = firstkid->op_sibling;
7176 /* provide list context for arguments */
7177 if (o->op_type == OP_SORT)
7184 S_simplify_sort(pTHX_ OP *o)
7187 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7192 if (!(o->op_flags & OPf_STACKED))
7194 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7195 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
7196 kid = kUNOP->op_first; /* get past null */
7197 if (kid->op_type != OP_SCOPE)
7199 kid = kLISTOP->op_last; /* get past scope */
7200 switch(kid->op_type) {
7208 k = kid; /* remember this node*/
7209 if (kBINOP->op_first->op_type != OP_RV2SV)
7211 kid = kBINOP->op_first; /* get past cmp */
7212 if (kUNOP->op_first->op_type != OP_GV)
7214 kid = kUNOP->op_first; /* get past rv2sv */
7216 if (GvSTASH(gv) != PL_curstash)
7218 gvname = GvNAME(gv);
7219 if (*gvname == 'a' && gvname[1] == '\0')
7221 else if (*gvname == 'b' && gvname[1] == '\0')
7226 kid = k; /* back to cmp */
7227 if (kBINOP->op_last->op_type != OP_RV2SV)
7229 kid = kBINOP->op_last; /* down to 2nd arg */
7230 if (kUNOP->op_first->op_type != OP_GV)
7232 kid = kUNOP->op_first; /* get past rv2sv */
7234 if (GvSTASH(gv) != PL_curstash)
7236 gvname = GvNAME(gv);
7238 ? !(*gvname == 'a' && gvname[1] == '\0')
7239 : !(*gvname == 'b' && gvname[1] == '\0'))
7241 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
7243 o->op_private |= OPpSORT_DESCEND;
7244 if (k->op_type == OP_NCMP)
7245 o->op_private |= OPpSORT_NUMERIC;
7246 if (k->op_type == OP_I_NCMP)
7247 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
7248 kid = cLISTOPo->op_first->op_sibling;
7249 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
7251 op_getmad(kid,o,'S'); /* then delete it */
7253 op_free(kid); /* then delete it */
7258 Perl_ck_split(pTHX_ OP *o)
7263 if (o->op_flags & OPf_STACKED)
7264 return no_fh_allowed(o);
7266 kid = cLISTOPo->op_first;
7267 if (kid->op_type != OP_NULL)
7268 Perl_croak(aTHX_ "panic: ck_split");
7269 kid = kid->op_sibling;
7270 op_free(cLISTOPo->op_first);
7271 cLISTOPo->op_first = kid;
7273 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
7274 cLISTOPo->op_last = kid; /* There was only one element previously */
7277 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
7278 OP * const sibl = kid->op_sibling;
7279 kid->op_sibling = 0;
7280 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
7281 if (cLISTOPo->op_first == cLISTOPo->op_last)
7282 cLISTOPo->op_last = kid;
7283 cLISTOPo->op_first = kid;
7284 kid->op_sibling = sibl;
7287 kid->op_type = OP_PUSHRE;
7288 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
7290 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
7291 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
7292 "Use of /g modifier is meaningless in split");
7295 if (!kid->op_sibling)
7296 append_elem(OP_SPLIT, o, newDEFSVOP());
7298 kid = kid->op_sibling;
7301 if (!kid->op_sibling)
7302 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
7303 assert(kid->op_sibling);
7305 kid = kid->op_sibling;
7308 if (kid->op_sibling)
7309 return too_many_arguments(o,OP_DESC(o));
7315 Perl_ck_join(pTHX_ OP *o)
7317 const OP * const kid = cLISTOPo->op_first->op_sibling;
7318 if (kid && kid->op_type == OP_MATCH) {
7319 if (ckWARN(WARN_SYNTAX)) {
7320 const REGEXP *re = PM_GETRE(kPMOP);
7321 const char *pmstr = re ? re->precomp : "STRING";
7322 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7323 "/%s/ should probably be written as \"%s\"",
7331 Perl_ck_subr(pTHX_ OP *o)
7334 OP *prev = ((cUNOPo->op_first->op_sibling)
7335 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
7336 OP *o2 = prev->op_sibling;
7338 const char *proto = NULL;
7339 const char *proto_end = NULL;
7344 I32 contextclass = 0;
7345 const char *e = NULL;
7348 o->op_private |= OPpENTERSUB_HASTARG;
7349 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
7350 if (cvop->op_type == OP_RV2CV) {
7352 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
7353 op_null(cvop); /* disable rv2cv */
7354 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
7355 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
7356 GV *gv = cGVOPx_gv(tmpop);
7359 tmpop->op_private |= OPpEARLY_CV;
7363 namegv = CvANON(cv) ? gv : CvGV(cv);
7364 proto = SvPV((SV*)cv, len);
7365 proto_end = proto + len;
7367 if (CvASSERTION(cv)) {
7368 U32 asserthints = 0;
7369 HV *const hinthv = GvHV(PL_hintgv);
7371 SV **svp = hv_fetchs(hinthv, "assertions", FALSE);
7373 asserthints = SvUV(*svp);
7375 if (asserthints & HINT_ASSERTING) {
7376 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
7377 o->op_private |= OPpENTERSUB_DB;
7381 if (!(asserthints & HINT_ASSERTIONSSEEN) && ckWARN(WARN_ASSERTIONS)) {
7382 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
7383 "Impossible to activate assertion call");
7390 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7391 if (o2->op_type == OP_CONST)
7392 o2->op_private &= ~OPpCONST_STRICT;
7393 else if (o2->op_type == OP_LIST) {
7394 OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
7395 if (sib && sib->op_type == OP_CONST)
7396 sib->op_private &= ~OPpCONST_STRICT;
7399 o->op_private |= (PL_hints & HINT_STRICT_REFS);
7400 if (PERLDB_SUB && PL_curstash != PL_debstash)
7401 o->op_private |= OPpENTERSUB_DB;
7402 while (o2 != cvop) {
7404 if (PL_madskills && o2->op_type == OP_NULL)
7405 o3 = ((UNOP*)o2)->op_first;
7409 if (proto >= proto_end)
7410 return too_many_arguments(o, gv_ename(namegv));
7418 /* _ must be at the end */
7419 if (proto[1] && proto[1] != ';')
7434 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
7436 arg == 1 ? "block or sub {}" : "sub {}",
7437 gv_ename(namegv), o3);
7440 /* '*' allows any scalar type, including bareword */
7443 if (o3->op_type == OP_RV2GV)
7444 goto wrapref; /* autoconvert GLOB -> GLOBref */
7445 else if (o3->op_type == OP_CONST)
7446 o3->op_private &= ~OPpCONST_STRICT;
7447 else if (o3->op_type == OP_ENTERSUB) {
7448 /* accidental subroutine, revert to bareword */
7449 OP *gvop = ((UNOP*)o3)->op_first;
7450 if (gvop && gvop->op_type == OP_NULL) {
7451 gvop = ((UNOP*)gvop)->op_first;
7453 for (; gvop->op_sibling; gvop = gvop->op_sibling)
7456 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
7457 (gvop = ((UNOP*)gvop)->op_first) &&
7458 gvop->op_type == OP_GV)
7460 GV * const gv = cGVOPx_gv(gvop);
7461 OP * const sibling = o2->op_sibling;
7462 SV * const n = newSVpvs("");
7464 OP * const oldo2 = o2;
7468 gv_fullname4(n, gv, "", FALSE);
7469 o2 = newSVOP(OP_CONST, 0, n);
7470 op_getmad(oldo2,o2,'O');
7471 prev->op_sibling = o2;
7472 o2->op_sibling = sibling;
7488 if (contextclass++ == 0) {
7489 e = strchr(proto, ']');
7490 if (!e || e == proto)
7499 const char *p = proto;
7500 const char *const end = proto;
7502 while (*--p != '[');
7503 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
7505 gv_ename(namegv), o3);
7510 if (o3->op_type == OP_RV2GV)
7513 bad_type(arg, "symbol", gv_ename(namegv), o3);
7516 if (o3->op_type == OP_ENTERSUB)
7519 bad_type(arg, "subroutine entry", gv_ename(namegv),
7523 if (o3->op_type == OP_RV2SV ||
7524 o3->op_type == OP_PADSV ||
7525 o3->op_type == OP_HELEM ||
7526 o3->op_type == OP_AELEM ||
7527 o3->op_type == OP_THREADSV)
7530 bad_type(arg, "scalar", gv_ename(namegv), o3);
7533 if (o3->op_type == OP_RV2AV ||
7534 o3->op_type == OP_PADAV)
7537 bad_type(arg, "array", gv_ename(namegv), o3);
7540 if (o3->op_type == OP_RV2HV ||
7541 o3->op_type == OP_PADHV)
7544 bad_type(arg, "hash", gv_ename(namegv), o3);
7549 OP* const sib = kid->op_sibling;
7550 kid->op_sibling = 0;
7551 o2 = newUNOP(OP_REFGEN, 0, kid);
7552 o2->op_sibling = sib;
7553 prev->op_sibling = o2;
7555 if (contextclass && e) {
7570 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
7571 gv_ename(namegv), (void*)cv);
7576 mod(o2, OP_ENTERSUB);
7578 o2 = o2->op_sibling;
7580 if (o2 == cvop && proto && *proto == '_') {
7581 /* generate an access to $_ */
7583 o2->op_sibling = prev->op_sibling;
7584 prev->op_sibling = o2; /* instead of cvop */
7586 if (proto && !optional && proto_end > proto &&
7587 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
7588 return too_few_arguments(o, gv_ename(namegv));
7591 OP * const oldo = o;
7595 o=newSVOP(OP_CONST, 0, newSViv(0));
7596 op_getmad(oldo,o,'O');
7602 Perl_ck_svconst(pTHX_ OP *o)
7604 PERL_UNUSED_CONTEXT;
7605 SvREADONLY_on(cSVOPo->op_sv);
7610 Perl_ck_chdir(pTHX_ OP *o)
7612 if (o->op_flags & OPf_KIDS) {
7613 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7615 if (kid && kid->op_type == OP_CONST &&
7616 (kid->op_private & OPpCONST_BARE))
7618 o->op_flags |= OPf_SPECIAL;
7619 kid->op_private &= ~OPpCONST_STRICT;
7626 Perl_ck_trunc(pTHX_ OP *o)
7628 if (o->op_flags & OPf_KIDS) {
7629 SVOP *kid = (SVOP*)cUNOPo->op_first;
7631 if (kid->op_type == OP_NULL)
7632 kid = (SVOP*)kid->op_sibling;
7633 if (kid && kid->op_type == OP_CONST &&
7634 (kid->op_private & OPpCONST_BARE))
7636 o->op_flags |= OPf_SPECIAL;
7637 kid->op_private &= ~OPpCONST_STRICT;
7644 Perl_ck_unpack(pTHX_ OP *o)
7646 OP *kid = cLISTOPo->op_first;
7647 if (kid->op_sibling) {
7648 kid = kid->op_sibling;
7649 if (!kid->op_sibling)
7650 kid->op_sibling = newDEFSVOP();
7656 Perl_ck_substr(pTHX_ OP *o)
7659 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
7660 OP *kid = cLISTOPo->op_first;
7662 if (kid->op_type == OP_NULL)
7663 kid = kid->op_sibling;
7665 kid->op_flags |= OPf_MOD;
7671 /* A peephole optimizer. We visit the ops in the order they're to execute.
7672 * See the comments at the top of this file for more details about when
7673 * peep() is called */
7676 Perl_peep(pTHX_ register OP *o)
7679 register OP* oldop = NULL;
7681 if (!o || o->op_opt)
7685 SAVEVPTR(PL_curcop);
7686 for (; o; o = o->op_next) {
7690 switch (o->op_type) {
7694 PL_curcop = ((COP*)o); /* for warnings */
7699 if (cSVOPo->op_private & OPpCONST_STRICT)
7700 no_bareword_allowed(o);
7702 case OP_METHOD_NAMED:
7703 /* Relocate sv to the pad for thread safety.
7704 * Despite being a "constant", the SV is written to,
7705 * for reference counts, sv_upgrade() etc. */
7707 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
7708 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
7709 /* If op_sv is already a PADTMP then it is being used by
7710 * some pad, so make a copy. */
7711 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
7712 SvREADONLY_on(PAD_SVl(ix));
7713 SvREFCNT_dec(cSVOPo->op_sv);
7715 else if (o->op_type == OP_CONST
7716 && cSVOPo->op_sv == &PL_sv_undef) {
7717 /* PL_sv_undef is hack - it's unsafe to store it in the
7718 AV that is the pad, because av_fetch treats values of
7719 PL_sv_undef as a "free" AV entry and will merrily
7720 replace them with a new SV, causing pad_alloc to think
7721 that this pad slot is free. (When, clearly, it is not)
7723 SvOK_off(PAD_SVl(ix));
7724 SvPADTMP_on(PAD_SVl(ix));
7725 SvREADONLY_on(PAD_SVl(ix));
7728 SvREFCNT_dec(PAD_SVl(ix));
7729 SvPADTMP_on(cSVOPo->op_sv);
7730 PAD_SETSV(ix, cSVOPo->op_sv);
7731 /* XXX I don't know how this isn't readonly already. */
7732 SvREADONLY_on(PAD_SVl(ix));
7734 cSVOPo->op_sv = NULL;
7742 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
7743 if (o->op_next->op_private & OPpTARGET_MY) {
7744 if (o->op_flags & OPf_STACKED) /* chained concats */
7745 goto ignore_optimization;
7747 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
7748 o->op_targ = o->op_next->op_targ;
7749 o->op_next->op_targ = 0;
7750 o->op_private |= OPpTARGET_MY;
7753 op_null(o->op_next);
7755 ignore_optimization:
7759 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
7761 break; /* Scalar stub must produce undef. List stub is noop */
7765 if (o->op_targ == OP_NEXTSTATE
7766 || o->op_targ == OP_DBSTATE
7767 || o->op_targ == OP_SETSTATE)
7769 PL_curcop = ((COP*)o);
7771 /* XXX: We avoid setting op_seq here to prevent later calls
7772 to peep() from mistakenly concluding that optimisation
7773 has already occurred. This doesn't fix the real problem,
7774 though (See 20010220.007). AMS 20010719 */
7775 /* op_seq functionality is now replaced by op_opt */
7776 if (oldop && o->op_next) {
7777 oldop->op_next = o->op_next;
7785 if (oldop && o->op_next) {
7786 oldop->op_next = o->op_next;
7794 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
7795 OP* const pop = (o->op_type == OP_PADAV) ?
7796 o->op_next : o->op_next->op_next;
7798 if (pop && pop->op_type == OP_CONST &&
7799 ((PL_op = pop->op_next)) &&
7800 pop->op_next->op_type == OP_AELEM &&
7801 !(pop->op_next->op_private &
7802 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
7803 (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
7808 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
7809 no_bareword_allowed(pop);
7810 if (o->op_type == OP_GV)
7811 op_null(o->op_next);
7812 op_null(pop->op_next);
7814 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
7815 o->op_next = pop->op_next->op_next;
7816 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
7817 o->op_private = (U8)i;
7818 if (o->op_type == OP_GV) {
7823 o->op_flags |= OPf_SPECIAL;
7824 o->op_type = OP_AELEMFAST;
7830 if (o->op_next->op_type == OP_RV2SV) {
7831 if (!(o->op_next->op_private & OPpDEREF)) {
7832 op_null(o->op_next);
7833 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
7835 o->op_next = o->op_next->op_next;
7836 o->op_type = OP_GVSV;
7837 o->op_ppaddr = PL_ppaddr[OP_GVSV];
7840 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
7841 GV * const gv = cGVOPo_gv;
7842 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
7843 /* XXX could check prototype here instead of just carping */
7844 SV * const sv = sv_newmortal();
7845 gv_efullname3(sv, gv, NULL);
7846 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
7847 "%"SVf"() called too early to check prototype",
7851 else if (o->op_next->op_type == OP_READLINE
7852 && o->op_next->op_next->op_type == OP_CONCAT
7853 && (o->op_next->op_next->op_flags & OPf_STACKED))
7855 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
7856 o->op_type = OP_RCATLINE;
7857 o->op_flags |= OPf_STACKED;
7858 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
7859 op_null(o->op_next->op_next);
7860 op_null(o->op_next);
7877 while (cLOGOP->op_other->op_type == OP_NULL)
7878 cLOGOP->op_other = cLOGOP->op_other->op_next;
7879 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
7885 while (cLOOP->op_redoop->op_type == OP_NULL)
7886 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
7887 peep(cLOOP->op_redoop);
7888 while (cLOOP->op_nextop->op_type == OP_NULL)
7889 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
7890 peep(cLOOP->op_nextop);
7891 while (cLOOP->op_lastop->op_type == OP_NULL)
7892 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
7893 peep(cLOOP->op_lastop);
7900 while (cPMOP->op_pmreplstart &&
7901 cPMOP->op_pmreplstart->op_type == OP_NULL)
7902 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
7903 peep(cPMOP->op_pmreplstart);
7908 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
7909 && ckWARN(WARN_SYNTAX))
7911 if (o->op_next->op_sibling) {
7912 const OPCODE type = o->op_next->op_sibling->op_type;
7913 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
7914 const line_t oldline = CopLINE(PL_curcop);
7915 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
7916 Perl_warner(aTHX_ packWARN(WARN_EXEC),
7917 "Statement unlikely to be reached");
7918 Perl_warner(aTHX_ packWARN(WARN_EXEC),
7919 "\t(Maybe you meant system() when you said exec()?)\n");
7920 CopLINE_set(PL_curcop, oldline);
7931 const char *key = NULL;
7936 if (((BINOP*)o)->op_last->op_type != OP_CONST)
7939 /* Make the CONST have a shared SV */
7940 svp = cSVOPx_svp(((BINOP*)o)->op_last);
7941 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
7942 key = SvPV_const(sv, keylen);
7943 lexname = newSVpvn_share(key,
7944 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
7950 if ((o->op_private & (OPpLVAL_INTRO)))
7953 rop = (UNOP*)((BINOP*)o)->op_first;
7954 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7956 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7957 if (!SvPAD_TYPED(lexname))
7959 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
7960 if (!fields || !GvHV(*fields))
7962 key = SvPV_const(*svp, keylen);
7963 if (!hv_fetch(GvHV(*fields), key,
7964 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
7966 Perl_croak(aTHX_ "No such class field \"%s\" "
7967 "in variable %s of type %s",
7968 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
7981 SVOP *first_key_op, *key_op;
7983 if ((o->op_private & (OPpLVAL_INTRO))
7984 /* I bet there's always a pushmark... */
7985 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
7986 /* hmmm, no optimization if list contains only one key. */
7988 rop = (UNOP*)((LISTOP*)o)->op_last;
7989 if (rop->op_type != OP_RV2HV)
7991 if (rop->op_first->op_type == OP_PADSV)
7992 /* @$hash{qw(keys here)} */
7993 rop = (UNOP*)rop->op_first;
7995 /* @{$hash}{qw(keys here)} */
7996 if (rop->op_first->op_type == OP_SCOPE
7997 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
7999 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
8005 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
8006 if (!SvPAD_TYPED(lexname))
8008 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8009 if (!fields || !GvHV(*fields))
8011 /* Again guessing that the pushmark can be jumped over.... */
8012 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
8013 ->op_first->op_sibling;
8014 for (key_op = first_key_op; key_op;
8015 key_op = (SVOP*)key_op->op_sibling) {
8016 if (key_op->op_type != OP_CONST)
8018 svp = cSVOPx_svp(key_op);
8019 key = SvPV_const(*svp, keylen);
8020 if (!hv_fetch(GvHV(*fields), key,
8021 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8023 Perl_croak(aTHX_ "No such class field \"%s\" "
8024 "in variable %s of type %s",
8025 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
8032 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
8036 /* check that RHS of sort is a single plain array */
8037 OP *oright = cUNOPo->op_first;
8038 if (!oright || oright->op_type != OP_PUSHMARK)
8041 /* reverse sort ... can be optimised. */
8042 if (!cUNOPo->op_sibling) {
8043 /* Nothing follows us on the list. */
8044 OP * const reverse = o->op_next;
8046 if (reverse->op_type == OP_REVERSE &&
8047 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
8048 OP * const pushmark = cUNOPx(reverse)->op_first;
8049 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
8050 && (cUNOPx(pushmark)->op_sibling == o)) {
8051 /* reverse -> pushmark -> sort */
8052 o->op_private |= OPpSORT_REVERSE;
8054 pushmark->op_next = oright->op_next;
8060 /* make @a = sort @a act in-place */
8064 oright = cUNOPx(oright)->op_sibling;
8067 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
8068 oright = cUNOPx(oright)->op_sibling;
8072 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
8073 || oright->op_next != o
8074 || (oright->op_private & OPpLVAL_INTRO)
8078 /* o2 follows the chain of op_nexts through the LHS of the
8079 * assign (if any) to the aassign op itself */
8081 if (!o2 || o2->op_type != OP_NULL)
8084 if (!o2 || o2->op_type != OP_PUSHMARK)
8087 if (o2 && o2->op_type == OP_GV)
8090 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
8091 || (o2->op_private & OPpLVAL_INTRO)
8096 if (!o2 || o2->op_type != OP_NULL)
8099 if (!o2 || o2->op_type != OP_AASSIGN
8100 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
8103 /* check that the sort is the first arg on RHS of assign */
8105 o2 = cUNOPx(o2)->op_first;
8106 if (!o2 || o2->op_type != OP_NULL)
8108 o2 = cUNOPx(o2)->op_first;
8109 if (!o2 || o2->op_type != OP_PUSHMARK)
8111 if (o2->op_sibling != o)
8114 /* check the array is the same on both sides */
8115 if (oleft->op_type == OP_RV2AV) {
8116 if (oright->op_type != OP_RV2AV
8117 || !cUNOPx(oright)->op_first
8118 || cUNOPx(oright)->op_first->op_type != OP_GV
8119 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
8120 cGVOPx_gv(cUNOPx(oright)->op_first)
8124 else if (oright->op_type != OP_PADAV
8125 || oright->op_targ != oleft->op_targ
8129 /* transfer MODishness etc from LHS arg to RHS arg */
8130 oright->op_flags = oleft->op_flags;
8131 o->op_private |= OPpSORT_INPLACE;
8133 /* excise push->gv->rv2av->null->aassign */
8134 o2 = o->op_next->op_next;
8135 op_null(o2); /* PUSHMARK */
8137 if (o2->op_type == OP_GV) {
8138 op_null(o2); /* GV */
8141 op_null(o2); /* RV2AV or PADAV */
8142 o2 = o2->op_next->op_next;
8143 op_null(o2); /* AASSIGN */
8145 o->op_next = o2->op_next;
8151 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
8153 LISTOP *enter, *exlist;
8156 enter = (LISTOP *) o->op_next;
8159 if (enter->op_type == OP_NULL) {
8160 enter = (LISTOP *) enter->op_next;
8164 /* for $a (...) will have OP_GV then OP_RV2GV here.
8165 for (...) just has an OP_GV. */
8166 if (enter->op_type == OP_GV) {
8167 gvop = (OP *) enter;
8168 enter = (LISTOP *) enter->op_next;
8171 if (enter->op_type == OP_RV2GV) {
8172 enter = (LISTOP *) enter->op_next;
8178 if (enter->op_type != OP_ENTERITER)
8181 iter = enter->op_next;
8182 if (!iter || iter->op_type != OP_ITER)
8185 expushmark = enter->op_first;
8186 if (!expushmark || expushmark->op_type != OP_NULL
8187 || expushmark->op_targ != OP_PUSHMARK)
8190 exlist = (LISTOP *) expushmark->op_sibling;
8191 if (!exlist || exlist->op_type != OP_NULL
8192 || exlist->op_targ != OP_LIST)
8195 if (exlist->op_last != o) {
8196 /* Mmm. Was expecting to point back to this op. */
8199 theirmark = exlist->op_first;
8200 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
8203 if (theirmark->op_sibling != o) {
8204 /* There's something between the mark and the reverse, eg
8205 for (1, reverse (...))
8210 ourmark = ((LISTOP *)o)->op_first;
8211 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
8214 ourlast = ((LISTOP *)o)->op_last;
8215 if (!ourlast || ourlast->op_next != o)
8218 rv2av = ourmark->op_sibling;
8219 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
8220 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
8221 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
8222 /* We're just reversing a single array. */
8223 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
8224 enter->op_flags |= OPf_STACKED;
8227 /* We don't have control over who points to theirmark, so sacrifice
8229 theirmark->op_next = ourmark->op_next;
8230 theirmark->op_flags = ourmark->op_flags;
8231 ourlast->op_next = gvop ? gvop : (OP *) enter;
8234 enter->op_private |= OPpITER_REVERSED;
8235 iter->op_private |= OPpITER_REVERSED;
8242 UNOP *refgen, *rv2cv;
8245 /* I do not understand this, but if o->op_opt isn't set to 1,
8246 various tests in ext/B/t/bytecode.t fail with no readily
8252 if ((o->op_flags && OPf_WANT) != OPf_WANT_VOID)
8255 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
8258 rv2gv = ((BINOP *)o)->op_last;
8259 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
8262 refgen = (UNOP *)((BINOP *)o)->op_first;
8264 if (!refgen || refgen->op_type != OP_REFGEN)
8267 exlist = (LISTOP *)refgen->op_first;
8268 if (!exlist || exlist->op_type != OP_NULL
8269 || exlist->op_targ != OP_LIST)
8272 if (exlist->op_first->op_type != OP_PUSHMARK)
8275 rv2cv = (UNOP*)exlist->op_last;
8277 if (rv2cv->op_type != OP_RV2CV)
8280 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
8281 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
8282 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
8284 o->op_private |= OPpASSIGN_CV_TO_GV;
8285 rv2gv->op_private |= OPpDONT_INIT_GV;
8286 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
8302 Perl_custom_op_name(pTHX_ const OP* o)
8305 const IV index = PTR2IV(o->op_ppaddr);
8309 if (!PL_custom_op_names) /* This probably shouldn't happen */
8310 return (char *)PL_op_name[OP_CUSTOM];
8312 keysv = sv_2mortal(newSViv(index));
8314 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
8316 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
8318 return SvPV_nolen(HeVAL(he));
8322 Perl_custom_op_desc(pTHX_ const OP* o)
8325 const IV index = PTR2IV(o->op_ppaddr);
8329 if (!PL_custom_op_descs)
8330 return (char *)PL_op_desc[OP_CUSTOM];
8332 keysv = sv_2mortal(newSViv(index));
8334 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
8336 return (char *)PL_op_desc[OP_CUSTOM];
8338 return SvPV_nolen(HeVAL(he));
8343 /* Efficient sub that returns a constant scalar value. */
8345 const_sv_xsub(pTHX_ CV* cv)
8352 Perl_croak(aTHX_ "usage: %s::%s()",
8353 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
8357 ST(0) = (SV*)XSANY.any_ptr;
8363 * c-indentation-style: bsd
8365 * indent-tabs-mode: t
8368 * ex: set ts=8 sts=4 sw=4 noet: