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 (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3317 if (curop->op_type == OP_GV) {
3318 GV * const gv = cGVOPx_gv(curop);
3320 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3323 else if (curop->op_type == OP_RV2CV)
3325 else if (curop->op_type == OP_RV2SV ||
3326 curop->op_type == OP_RV2AV ||
3327 curop->op_type == OP_RV2HV ||
3328 curop->op_type == OP_RV2GV) {
3329 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3332 else if (curop->op_type == OP_PADSV ||
3333 curop->op_type == OP_PADAV ||
3334 curop->op_type == OP_PADHV ||
3335 curop->op_type == OP_PADANY) {
3338 else if (curop->op_type == OP_PUSHRE)
3339 NOOP; /* Okay here, dangerous in newASSIGNOP */
3349 || PM_GETRE(pm)->extflags & RXf_EVAL_SEEN))) {
3350 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3351 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
3352 prepend_elem(o->op_type, scalar(repl), o);
3355 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3356 pm->op_pmflags |= PMf_MAYBE_CONST;
3357 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3359 NewOp(1101, rcop, 1, LOGOP);
3360 rcop->op_type = OP_SUBSTCONT;
3361 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3362 rcop->op_first = scalar(repl);
3363 rcop->op_flags |= OPf_KIDS;
3364 rcop->op_private = 1;
3367 /* establish postfix order */
3368 rcop->op_next = LINKLIST(repl);
3369 repl->op_next = (OP*)rcop;
3371 pm->op_pmreplroot = scalar((OP*)rcop);
3372 pm->op_pmreplstart = LINKLIST(rcop);
3381 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3385 NewOp(1101, svop, 1, SVOP);
3386 svop->op_type = (OPCODE)type;
3387 svop->op_ppaddr = PL_ppaddr[type];
3389 svop->op_next = (OP*)svop;
3390 svop->op_flags = (U8)flags;
3391 if (PL_opargs[type] & OA_RETSCALAR)
3393 if (PL_opargs[type] & OA_TARGET)
3394 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3395 return CHECKOP(type, svop);
3399 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3403 NewOp(1101, padop, 1, PADOP);
3404 padop->op_type = (OPCODE)type;
3405 padop->op_ppaddr = PL_ppaddr[type];
3406 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3407 SvREFCNT_dec(PAD_SVl(padop->op_padix));
3408 PAD_SETSV(padop->op_padix, sv);
3411 padop->op_next = (OP*)padop;
3412 padop->op_flags = (U8)flags;
3413 if (PL_opargs[type] & OA_RETSCALAR)
3415 if (PL_opargs[type] & OA_TARGET)
3416 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3417 return CHECKOP(type, padop);
3421 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3427 return newPADOP(type, flags, SvREFCNT_inc_simple(gv));
3429 return newSVOP(type, flags, SvREFCNT_inc_simple(gv));
3434 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3438 NewOp(1101, pvop, 1, PVOP);
3439 pvop->op_type = (OPCODE)type;
3440 pvop->op_ppaddr = PL_ppaddr[type];
3442 pvop->op_next = (OP*)pvop;
3443 pvop->op_flags = (U8)flags;
3444 if (PL_opargs[type] & OA_RETSCALAR)
3446 if (PL_opargs[type] & OA_TARGET)
3447 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3448 return CHECKOP(type, pvop);
3456 Perl_package(pTHX_ OP *o)
3465 save_hptr(&PL_curstash);
3466 save_item(PL_curstname);
3468 name = SvPV_const(cSVOPo->op_sv, len);
3469 PL_curstash = gv_stashpvn(name, len, TRUE);
3470 sv_setpvn(PL_curstname, name, len);
3472 PL_hints |= HINT_BLOCK_SCOPE;
3473 PL_copline = NOLINE;
3479 if (!PL_madskills) {
3484 pegop = newOP(OP_NULL,0);
3485 op_getmad(o,pegop,'P');
3495 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3502 OP *pegop = newOP(OP_NULL,0);
3505 if (idop->op_type != OP_CONST)
3506 Perl_croak(aTHX_ "Module name must be constant");
3509 op_getmad(idop,pegop,'U');
3514 SV * const vesv = ((SVOP*)version)->op_sv;
3517 op_getmad(version,pegop,'V');
3518 if (!arg && !SvNIOKp(vesv)) {
3525 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3526 Perl_croak(aTHX_ "Version number must be constant number");
3528 /* Make copy of idop so we don't free it twice */
3529 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3531 /* Fake up a method call to VERSION */
3532 meth = newSVpvs_share("VERSION");
3533 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3534 append_elem(OP_LIST,
3535 prepend_elem(OP_LIST, pack, list(version)),
3536 newSVOP(OP_METHOD_NAMED, 0, meth)));
3540 /* Fake up an import/unimport */
3541 if (arg && arg->op_type == OP_STUB) {
3543 op_getmad(arg,pegop,'S');
3544 imop = arg; /* no import on explicit () */
3546 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3547 imop = NULL; /* use 5.0; */
3549 idop->op_private |= OPpCONST_NOVER;
3555 op_getmad(arg,pegop,'A');
3557 /* Make copy of idop so we don't free it twice */
3558 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3560 /* Fake up a method call to import/unimport */
3562 ? newSVpvs_share("import") : newSVpvs_share("unimport");
3563 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3564 append_elem(OP_LIST,
3565 prepend_elem(OP_LIST, pack, list(arg)),
3566 newSVOP(OP_METHOD_NAMED, 0, meth)));
3569 /* Fake up the BEGIN {}, which does its thing immediately. */
3571 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
3574 append_elem(OP_LINESEQ,
3575 append_elem(OP_LINESEQ,
3576 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
3577 newSTATEOP(0, NULL, veop)),
3578 newSTATEOP(0, NULL, imop) ));
3580 /* The "did you use incorrect case?" warning used to be here.
3581 * The problem is that on case-insensitive filesystems one
3582 * might get false positives for "use" (and "require"):
3583 * "use Strict" or "require CARP" will work. This causes
3584 * portability problems for the script: in case-strict
3585 * filesystems the script will stop working.
3587 * The "incorrect case" warning checked whether "use Foo"
3588 * imported "Foo" to your namespace, but that is wrong, too:
3589 * there is no requirement nor promise in the language that
3590 * a Foo.pm should or would contain anything in package "Foo".
3592 * There is very little Configure-wise that can be done, either:
3593 * the case-sensitivity of the build filesystem of Perl does not
3594 * help in guessing the case-sensitivity of the runtime environment.
3597 PL_hints |= HINT_BLOCK_SCOPE;
3598 PL_copline = NOLINE;
3600 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3603 if (!PL_madskills) {
3604 /* FIXME - don't allocate pegop if !PL_madskills */
3613 =head1 Embedding Functions
3615 =for apidoc load_module
3617 Loads the module whose name is pointed to by the string part of name.
3618 Note that the actual module name, not its filename, should be given.
3619 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3620 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3621 (or 0 for no flags). ver, if specified, provides version semantics
3622 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3623 arguments can be used to specify arguments to the module's import()
3624 method, similar to C<use Foo::Bar VERSION LIST>.
3629 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3632 va_start(args, ver);
3633 vload_module(flags, name, ver, &args);
3637 #ifdef PERL_IMPLICIT_CONTEXT
3639 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3643 va_start(args, ver);
3644 vload_module(flags, name, ver, &args);
3650 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3655 OP * const modname = newSVOP(OP_CONST, 0, name);
3656 modname->op_private |= OPpCONST_BARE;
3658 veop = newSVOP(OP_CONST, 0, ver);
3662 if (flags & PERL_LOADMOD_NOIMPORT) {
3663 imop = sawparens(newNULLLIST());
3665 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3666 imop = va_arg(*args, OP*);
3671 sv = va_arg(*args, SV*);
3673 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3674 sv = va_arg(*args, SV*);
3678 const line_t ocopline = PL_copline;
3679 COP * const ocurcop = PL_curcop;
3680 const int oexpect = PL_expect;
3682 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3683 veop, modname, imop);
3684 PL_expect = oexpect;
3685 PL_copline = ocopline;
3686 PL_curcop = ocurcop;
3691 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
3697 if (!force_builtin) {
3698 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
3699 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
3700 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
3701 gv = gvp ? *gvp : NULL;
3705 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3706 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3707 append_elem(OP_LIST, term,
3708 scalar(newUNOP(OP_RV2CV, 0,
3709 newGVOP(OP_GV, 0, gv))))));
3712 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3718 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3720 return newBINOP(OP_LSLICE, flags,
3721 list(force_list(subscript)),
3722 list(force_list(listval)) );
3726 S_is_list_assignment(pTHX_ register const OP *o)
3734 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
3735 o = cUNOPo->op_first;
3737 flags = o->op_flags;
3739 if (type == OP_COND_EXPR) {
3740 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
3741 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3746 yyerror("Assignment to both a list and a scalar");
3750 if (type == OP_LIST &&
3751 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
3752 o->op_private & OPpLVAL_INTRO)
3755 if (type == OP_LIST || flags & OPf_PARENS ||
3756 type == OP_RV2AV || type == OP_RV2HV ||
3757 type == OP_ASLICE || type == OP_HSLICE)
3760 if (type == OP_PADAV || type == OP_PADHV)
3763 if (type == OP_RV2SV)
3770 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3776 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3777 return newLOGOP(optype, 0,
3778 mod(scalar(left), optype),
3779 newUNOP(OP_SASSIGN, 0, scalar(right)));
3782 return newBINOP(optype, OPf_STACKED,
3783 mod(scalar(left), optype), scalar(right));
3787 if (is_list_assignment(left)) {
3791 /* Grandfathering $[ assignment here. Bletch.*/
3792 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
3793 PL_eval_start = (left->op_type == OP_CONST) ? right : 0;
3794 left = mod(left, OP_AASSIGN);
3797 else if (left->op_type == OP_CONST) {
3799 /* Result of assignment is always 1 (or we'd be dead already) */
3800 return newSVOP(OP_CONST, 0, newSViv(1));
3802 curop = list(force_list(left));
3803 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3804 o->op_private = (U8)(0 | (flags >> 8));
3806 /* PL_generation sorcery:
3807 * an assignment like ($a,$b) = ($c,$d) is easier than
3808 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3809 * To detect whether there are common vars, the global var
3810 * PL_generation is incremented for each assign op we compile.
3811 * Then, while compiling the assign op, we run through all the
3812 * variables on both sides of the assignment, setting a spare slot
3813 * in each of them to PL_generation. If any of them already have
3814 * that value, we know we've got commonality. We could use a
3815 * single bit marker, but then we'd have to make 2 passes, first
3816 * to clear the flag, then to test and set it. To find somewhere
3817 * to store these values, evil chicanery is done with SvCUR().
3823 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3824 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3825 if (curop->op_type == OP_GV) {
3826 GV *gv = cGVOPx_gv(curop);
3828 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
3830 GvASSIGN_GENERATION_set(gv, PL_generation);
3832 else if (curop->op_type == OP_PADSV ||
3833 curop->op_type == OP_PADAV ||
3834 curop->op_type == OP_PADHV ||
3835 curop->op_type == OP_PADANY)
3837 if (PAD_COMPNAME_GEN(curop->op_targ)
3838 == (STRLEN)PL_generation)
3840 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
3843 else if (curop->op_type == OP_RV2CV)
3845 else if (curop->op_type == OP_RV2SV ||
3846 curop->op_type == OP_RV2AV ||
3847 curop->op_type == OP_RV2HV ||
3848 curop->op_type == OP_RV2GV) {
3849 if (lastop->op_type != OP_GV) /* funny deref? */
3852 else if (curop->op_type == OP_PUSHRE) {
3853 if (((PMOP*)curop)->op_pmreplroot) {
3855 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3856 ((PMOP*)curop)->op_pmreplroot));
3858 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3861 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
3863 GvASSIGN_GENERATION_set(gv, PL_generation);
3864 GvASSIGN_GENERATION_set(gv, PL_generation);
3873 o->op_private |= OPpASSIGN_COMMON;
3876 if ( ((left->op_private & OPpLVAL_INTRO) || ckWARN(WARN_MISC))
3877 && (left->op_type == OP_LIST
3878 || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
3880 OP* lop = ((LISTOP*)left)->op_first;
3882 if (lop->op_type == OP_PADSV ||
3883 lop->op_type == OP_PADAV ||
3884 lop->op_type == OP_PADHV ||
3885 lop->op_type == OP_PADANY)
3887 if (lop->op_private & OPpPAD_STATE) {
3888 if (left->op_private & OPpLVAL_INTRO) {
3889 o->op_private |= OPpASSIGN_STATE;
3890 /* hijacking PADSTALE for uninitialized state variables */
3891 SvPADSTALE_on(PAD_SVl(lop->op_targ));
3893 else { /* we already checked for WARN_MISC before */
3894 Perl_warner(aTHX_ packWARN(WARN_MISC), "State variable %s will be reinitialized",
3895 PAD_COMPNAME_PV(lop->op_targ));
3899 lop = lop->op_sibling;
3903 if (right && right->op_type == OP_SPLIT) {
3904 OP* tmpop = ((LISTOP*)right)->op_first;
3905 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
3906 PMOP * const pm = (PMOP*)tmpop;
3907 if (left->op_type == OP_RV2AV &&
3908 !(left->op_private & OPpLVAL_INTRO) &&
3909 !(o->op_private & OPpASSIGN_COMMON) )
3911 tmpop = ((UNOP*)left)->op_first;
3912 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3914 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3915 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3917 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3918 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
3920 pm->op_pmflags |= PMf_ONCE;
3921 tmpop = cUNOPo->op_first; /* to list (nulled) */
3922 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3923 tmpop->op_sibling = NULL; /* don't free split */
3924 right->op_next = tmpop->op_next; /* fix starting loc */
3926 op_getmad(o,right,'R'); /* blow off assign */
3928 op_free(o); /* blow off assign */
3930 right->op_flags &= ~OPf_WANT;
3931 /* "I don't know and I don't care." */
3936 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3937 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3939 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3941 sv_setiv(sv, PL_modcount+1);
3949 right = newOP(OP_UNDEF, 0);
3950 if (right->op_type == OP_READLINE) {
3951 right->op_flags |= OPf_STACKED;
3952 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3955 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3956 o = newBINOP(OP_SASSIGN, flags,
3957 scalar(right), mod(scalar(left), OP_SASSIGN) );
3963 o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
3964 o->op_private |= OPpCONST_ARYBASE;
3971 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3974 const U32 seq = intro_my();
3977 NewOp(1101, cop, 1, COP);
3978 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3979 cop->op_type = OP_DBSTATE;
3980 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3983 cop->op_type = OP_NEXTSTATE;
3984 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3986 cop->op_flags = (U8)flags;
3987 CopHINTS_set(cop, PL_hints);
3989 cop->op_private |= NATIVE_HINTS;
3991 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
3992 cop->op_next = (OP*)cop;
3995 CopLABEL_set(cop, label);
3996 PL_hints |= HINT_BLOCK_SCOPE;
3999 /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
4000 CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
4002 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
4003 cop->cop_hints_hash = PL_curcop->cop_hints_hash;
4004 if (cop->cop_hints_hash) {
4006 cop->cop_hints_hash->refcounted_he_refcnt++;
4007 HINTS_REFCNT_UNLOCK;
4010 if (PL_copline == NOLINE)
4011 CopLINE_set(cop, CopLINE(PL_curcop));
4013 CopLINE_set(cop, PL_copline);
4014 PL_copline = NOLINE;
4017 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
4019 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
4021 CopSTASH_set(cop, PL_curstash);
4023 if (PERLDB_LINE && PL_curstash != PL_debstash) {
4024 AV *av = CopFILEAVx(PL_curcop);
4026 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
4027 if (svp && *svp != &PL_sv_undef ) {
4028 (void)SvIOK_on(*svp);
4029 SvIV_set(*svp, PTR2IV(cop));
4034 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
4039 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
4042 return new_logop(type, flags, &first, &other);
4046 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
4051 OP *first = *firstp;
4052 OP * const other = *otherp;
4054 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
4055 return newBINOP(type, flags, scalar(first), scalar(other));
4057 scalarboolean(first);
4058 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
4059 if (first->op_type == OP_NOT
4060 && (first->op_flags & OPf_SPECIAL)
4061 && (first->op_flags & OPf_KIDS)) {
4062 if (type == OP_AND || type == OP_OR) {
4068 first = *firstp = cUNOPo->op_first;
4070 first->op_next = o->op_next;
4071 cUNOPo->op_first = NULL;
4073 op_getmad(o,first,'O');
4079 if (first->op_type == OP_CONST) {
4080 if (first->op_private & OPpCONST_STRICT)
4081 no_bareword_allowed(first);
4082 else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
4083 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
4084 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
4085 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
4086 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
4088 if (other->op_type == OP_CONST)
4089 other->op_private |= OPpCONST_SHORTCIRCUIT;
4091 OP *newop = newUNOP(OP_NULL, 0, other);
4092 op_getmad(first, newop, '1');
4093 newop->op_targ = type; /* set "was" field */
4100 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
4101 const OP *o2 = other;
4102 if ( ! (o2->op_type == OP_LIST
4103 && (( o2 = cUNOPx(o2)->op_first))
4104 && o2->op_type == OP_PUSHMARK
4105 && (( o2 = o2->op_sibling)) )
4108 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
4109 || o2->op_type == OP_PADHV)
4110 && o2->op_private & OPpLVAL_INTRO
4111 && ckWARN(WARN_DEPRECATED))
4113 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4114 "Deprecated use of my() in false conditional");
4118 if (first->op_type == OP_CONST)
4119 first->op_private |= OPpCONST_SHORTCIRCUIT;
4121 first = newUNOP(OP_NULL, 0, first);
4122 op_getmad(other, first, '2');
4123 first->op_targ = type; /* set "was" field */
4130 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
4131 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
4133 const OP * const k1 = ((UNOP*)first)->op_first;
4134 const OP * const k2 = k1->op_sibling;
4136 switch (first->op_type)
4139 if (k2 && k2->op_type == OP_READLINE
4140 && (k2->op_flags & OPf_STACKED)
4141 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4143 warnop = k2->op_type;
4148 if (k1->op_type == OP_READDIR
4149 || k1->op_type == OP_GLOB
4150 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4151 || k1->op_type == OP_EACH)
4153 warnop = ((k1->op_type == OP_NULL)
4154 ? (OPCODE)k1->op_targ : k1->op_type);
4159 const line_t oldline = CopLINE(PL_curcop);
4160 CopLINE_set(PL_curcop, PL_copline);
4161 Perl_warner(aTHX_ packWARN(WARN_MISC),
4162 "Value of %s%s can be \"0\"; test with defined()",
4164 ((warnop == OP_READLINE || warnop == OP_GLOB)
4165 ? " construct" : "() operator"));
4166 CopLINE_set(PL_curcop, oldline);
4173 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
4174 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
4176 NewOp(1101, logop, 1, LOGOP);
4178 logop->op_type = (OPCODE)type;
4179 logop->op_ppaddr = PL_ppaddr[type];
4180 logop->op_first = first;
4181 logop->op_flags = (U8)(flags | OPf_KIDS);
4182 logop->op_other = LINKLIST(other);
4183 logop->op_private = (U8)(1 | (flags >> 8));
4185 /* establish postfix order */
4186 logop->op_next = LINKLIST(first);
4187 first->op_next = (OP*)logop;
4188 first->op_sibling = other;
4190 CHECKOP(type,logop);
4192 o = newUNOP(OP_NULL, 0, (OP*)logop);
4199 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
4207 return newLOGOP(OP_AND, 0, first, trueop);
4209 return newLOGOP(OP_OR, 0, first, falseop);
4211 scalarboolean(first);
4212 if (first->op_type == OP_CONST) {
4213 if (first->op_private & OPpCONST_BARE &&
4214 first->op_private & OPpCONST_STRICT) {
4215 no_bareword_allowed(first);
4217 if (SvTRUE(((SVOP*)first)->op_sv)) {
4220 trueop = newUNOP(OP_NULL, 0, trueop);
4221 op_getmad(first,trueop,'C');
4222 op_getmad(falseop,trueop,'e');
4224 /* FIXME for MAD - should there be an ELSE here? */
4234 falseop = newUNOP(OP_NULL, 0, falseop);
4235 op_getmad(first,falseop,'C');
4236 op_getmad(trueop,falseop,'t');
4238 /* FIXME for MAD - should there be an ELSE here? */
4246 NewOp(1101, logop, 1, LOGOP);
4247 logop->op_type = OP_COND_EXPR;
4248 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4249 logop->op_first = first;
4250 logop->op_flags = (U8)(flags | OPf_KIDS);
4251 logop->op_private = (U8)(1 | (flags >> 8));
4252 logop->op_other = LINKLIST(trueop);
4253 logop->op_next = LINKLIST(falseop);
4255 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
4258 /* establish postfix order */
4259 start = LINKLIST(first);
4260 first->op_next = (OP*)logop;
4262 first->op_sibling = trueop;
4263 trueop->op_sibling = falseop;
4264 o = newUNOP(OP_NULL, 0, (OP*)logop);
4266 trueop->op_next = falseop->op_next = o;
4273 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4282 NewOp(1101, range, 1, LOGOP);
4284 range->op_type = OP_RANGE;
4285 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4286 range->op_first = left;
4287 range->op_flags = OPf_KIDS;
4288 leftstart = LINKLIST(left);
4289 range->op_other = LINKLIST(right);
4290 range->op_private = (U8)(1 | (flags >> 8));
4292 left->op_sibling = right;
4294 range->op_next = (OP*)range;
4295 flip = newUNOP(OP_FLIP, flags, (OP*)range);
4296 flop = newUNOP(OP_FLOP, 0, flip);
4297 o = newUNOP(OP_NULL, 0, flop);
4299 range->op_next = leftstart;
4301 left->op_next = flip;
4302 right->op_next = flop;
4304 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4305 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4306 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4307 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4309 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4310 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4313 if (!flip->op_private || !flop->op_private)
4314 linklist(o); /* blow off optimizer unless constant */
4320 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4325 const bool once = block && block->op_flags & OPf_SPECIAL &&
4326 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4328 PERL_UNUSED_ARG(debuggable);
4331 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4332 return block; /* do {} while 0 does once */
4333 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4334 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4335 expr = newUNOP(OP_DEFINED, 0,
4336 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4337 } else if (expr->op_flags & OPf_KIDS) {
4338 const OP * const k1 = ((UNOP*)expr)->op_first;
4339 const OP * const k2 = k1 ? k1->op_sibling : NULL;
4340 switch (expr->op_type) {
4342 if (k2 && k2->op_type == OP_READLINE
4343 && (k2->op_flags & OPf_STACKED)
4344 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4345 expr = newUNOP(OP_DEFINED, 0, expr);
4349 if (k1 && (k1->op_type == OP_READDIR
4350 || k1->op_type == OP_GLOB
4351 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4352 || k1->op_type == OP_EACH))
4353 expr = newUNOP(OP_DEFINED, 0, expr);
4359 /* if block is null, the next append_elem() would put UNSTACK, a scalar
4360 * op, in listop. This is wrong. [perl #27024] */
4362 block = newOP(OP_NULL, 0);
4363 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4364 o = new_logop(OP_AND, 0, &expr, &listop);
4367 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4369 if (once && o != listop)
4370 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4373 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
4375 o->op_flags |= flags;
4377 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4382 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
4383 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
4392 PERL_UNUSED_ARG(debuggable);
4395 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4396 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4397 expr = newUNOP(OP_DEFINED, 0,
4398 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4399 } else if (expr->op_flags & OPf_KIDS) {
4400 const OP * const k1 = ((UNOP*)expr)->op_first;
4401 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
4402 switch (expr->op_type) {
4404 if (k2 && k2->op_type == OP_READLINE
4405 && (k2->op_flags & OPf_STACKED)
4406 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4407 expr = newUNOP(OP_DEFINED, 0, expr);
4411 if (k1 && (k1->op_type == OP_READDIR
4412 || k1->op_type == OP_GLOB
4413 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4414 || k1->op_type == OP_EACH))
4415 expr = newUNOP(OP_DEFINED, 0, expr);
4422 block = newOP(OP_NULL, 0);
4423 else if (cont || has_my) {
4424 block = scope(block);
4428 next = LINKLIST(cont);
4431 OP * const unstack = newOP(OP_UNSTACK, 0);
4434 cont = append_elem(OP_LINESEQ, cont, unstack);
4438 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4440 redo = LINKLIST(listop);
4443 PL_copline = (line_t)whileline;
4445 o = new_logop(OP_AND, 0, &expr, &listop);
4446 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4447 op_free(expr); /* oops, it's a while (0) */
4449 return NULL; /* listop already freed by new_logop */
4452 ((LISTOP*)listop)->op_last->op_next =
4453 (o == listop ? redo : LINKLIST(o));
4459 NewOp(1101,loop,1,LOOP);
4460 loop->op_type = OP_ENTERLOOP;
4461 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4462 loop->op_private = 0;
4463 loop->op_next = (OP*)loop;
4466 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4468 loop->op_redoop = redo;
4469 loop->op_lastop = o;
4470 o->op_private |= loopflags;
4473 loop->op_nextop = next;
4475 loop->op_nextop = o;
4477 o->op_flags |= flags;
4478 o->op_private |= (flags >> 8);
4483 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
4488 PADOFFSET padoff = 0;
4494 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4495 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
4496 sv->op_type = OP_RV2GV;
4497 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4498 if (cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
4499 iterpflags |= OPpITER_DEF;
4501 else if (sv->op_type == OP_PADSV) { /* private variable */
4502 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
4503 padoff = sv->op_targ;
4512 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4513 padoff = sv->op_targ;
4518 iterflags |= OPf_SPECIAL;
4524 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4525 if (padoff && strEQ(PAD_COMPNAME_PV(padoff), "$_"))
4526 iterpflags |= OPpITER_DEF;
4529 const PADOFFSET offset = pad_findmy("$_");
4530 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
4531 sv = newGVOP(OP_GV, 0, PL_defgv);
4536 iterpflags |= OPpITER_DEF;
4538 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4539 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4540 iterflags |= OPf_STACKED;
4542 else if (expr->op_type == OP_NULL &&
4543 (expr->op_flags & OPf_KIDS) &&
4544 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4546 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4547 * set the STACKED flag to indicate that these values are to be
4548 * treated as min/max values by 'pp_iterinit'.
4550 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4551 LOGOP* const range = (LOGOP*) flip->op_first;
4552 OP* const left = range->op_first;
4553 OP* const right = left->op_sibling;
4556 range->op_flags &= ~OPf_KIDS;
4557 range->op_first = NULL;
4559 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4560 listop->op_first->op_next = range->op_next;
4561 left->op_next = range->op_other;
4562 right->op_next = (OP*)listop;
4563 listop->op_next = listop->op_first;
4566 op_getmad(expr,(OP*)listop,'O');
4570 expr = (OP*)(listop);
4572 iterflags |= OPf_STACKED;
4575 expr = mod(force_list(expr), OP_GREPSTART);
4578 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4579 append_elem(OP_LIST, expr, scalar(sv))));
4580 assert(!loop->op_next);
4581 /* for my $x () sets OPpLVAL_INTRO;
4582 * for our $x () sets OPpOUR_INTRO */
4583 loop->op_private = (U8)iterpflags;
4584 #ifdef PL_OP_SLAB_ALLOC
4587 NewOp(1234,tmp,1,LOOP);
4588 Copy(loop,tmp,1,LISTOP);
4589 S_op_destroy(aTHX_ (OP*)loop);
4593 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
4595 loop->op_targ = padoff;
4596 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
4598 op_getmad(madsv, (OP*)loop, 'v');
4599 PL_copline = forline;
4600 return newSTATEOP(0, label, wop);
4604 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4609 if (type != OP_GOTO || label->op_type == OP_CONST) {
4610 /* "last()" means "last" */
4611 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4612 o = newOP(type, OPf_SPECIAL);
4614 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4615 ? SvPVx_nolen_const(((SVOP*)label)->op_sv)
4619 op_getmad(label,o,'L');
4625 /* Check whether it's going to be a goto &function */
4626 if (label->op_type == OP_ENTERSUB
4627 && !(label->op_flags & OPf_STACKED))
4628 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4629 o = newUNOP(type, OPf_STACKED, label);
4631 PL_hints |= HINT_BLOCK_SCOPE;
4635 /* if the condition is a literal array or hash
4636 (or @{ ... } etc), make a reference to it.
4639 S_ref_array_or_hash(pTHX_ OP *cond)
4642 && (cond->op_type == OP_RV2AV
4643 || cond->op_type == OP_PADAV
4644 || cond->op_type == OP_RV2HV
4645 || cond->op_type == OP_PADHV))
4647 return newUNOP(OP_REFGEN,
4648 0, mod(cond, OP_REFGEN));
4654 /* These construct the optree fragments representing given()
4657 entergiven and enterwhen are LOGOPs; the op_other pointer
4658 points up to the associated leave op. We need this so we
4659 can put it in the context and make break/continue work.
4660 (Also, of course, pp_enterwhen will jump straight to
4661 op_other if the match fails.)
4666 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
4667 I32 enter_opcode, I32 leave_opcode,
4668 PADOFFSET entertarg)
4674 NewOp(1101, enterop, 1, LOGOP);
4675 enterop->op_type = enter_opcode;
4676 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
4677 enterop->op_flags = (U8) OPf_KIDS;
4678 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
4679 enterop->op_private = 0;
4681 o = newUNOP(leave_opcode, 0, (OP *) enterop);
4684 enterop->op_first = scalar(cond);
4685 cond->op_sibling = block;
4687 o->op_next = LINKLIST(cond);
4688 cond->op_next = (OP *) enterop;
4691 /* This is a default {} block */
4692 enterop->op_first = block;
4693 enterop->op_flags |= OPf_SPECIAL;
4695 o->op_next = (OP *) enterop;
4698 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
4699 entergiven and enterwhen both
4702 enterop->op_next = LINKLIST(block);
4703 block->op_next = enterop->op_other = o;
4708 /* Does this look like a boolean operation? For these purposes
4709 a boolean operation is:
4710 - a subroutine call [*]
4711 - a logical connective
4712 - a comparison operator
4713 - a filetest operator, with the exception of -s -M -A -C
4714 - defined(), exists() or eof()
4715 - /$re/ or $foo =~ /$re/
4717 [*] possibly surprising
4721 S_looks_like_bool(pTHX_ const OP *o)
4724 switch(o->op_type) {
4726 return looks_like_bool(cLOGOPo->op_first);
4730 looks_like_bool(cLOGOPo->op_first)
4731 && looks_like_bool(cLOGOPo->op_first->op_sibling));
4735 case OP_NOT: case OP_XOR:
4736 /* Note that OP_DOR is not here */
4738 case OP_EQ: case OP_NE: case OP_LT:
4739 case OP_GT: case OP_LE: case OP_GE:
4741 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
4742 case OP_I_GT: case OP_I_LE: case OP_I_GE:
4744 case OP_SEQ: case OP_SNE: case OP_SLT:
4745 case OP_SGT: case OP_SLE: case OP_SGE:
4749 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
4750 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
4751 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
4752 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
4753 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
4754 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
4755 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
4756 case OP_FTTEXT: case OP_FTBINARY:
4758 case OP_DEFINED: case OP_EXISTS:
4759 case OP_MATCH: case OP_EOF:
4764 /* Detect comparisons that have been optimized away */
4765 if (cSVOPo->op_sv == &PL_sv_yes
4766 || cSVOPo->op_sv == &PL_sv_no)
4777 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
4781 return newGIVWHENOP(
4782 ref_array_or_hash(cond),
4784 OP_ENTERGIVEN, OP_LEAVEGIVEN,
4788 /* If cond is null, this is a default {} block */
4790 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
4792 const bool cond_llb = (!cond || looks_like_bool(cond));
4798 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
4800 scalar(ref_array_or_hash(cond)));
4803 return newGIVWHENOP(
4805 append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
4806 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
4810 =for apidoc cv_undef
4812 Clear out all the active components of a CV. This can happen either
4813 by an explicit C<undef &foo>, or by the reference count going to zero.
4814 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
4815 children can still follow the full lexical scope chain.
4821 Perl_cv_undef(pTHX_ CV *cv)
4825 if (CvFILE(cv) && !CvISXSUB(cv)) {
4826 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4827 Safefree(CvFILE(cv));
4832 if (!CvISXSUB(cv) && CvROOT(cv)) {
4833 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
4834 Perl_croak(aTHX_ "Can't undef active subroutine");
4837 PAD_SAVE_SETNULLPAD();
4839 op_free(CvROOT(cv));
4844 SvPOK_off((SV*)cv); /* forget prototype */
4849 /* remove CvOUTSIDE unless this is an undef rather than a free */
4850 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
4851 if (!CvWEAKOUTSIDE(cv))
4852 SvREFCNT_dec(CvOUTSIDE(cv));
4853 CvOUTSIDE(cv) = NULL;
4856 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4859 if (CvISXSUB(cv) && CvXSUB(cv)) {
4862 /* delete all flags except WEAKOUTSIDE */
4863 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
4867 Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
4870 /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
4871 relying on SvCUR, and doubling up the buffer to hold CvFILE(). */
4872 if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
4873 || (p && (len != SvCUR(cv) /* Not the same length. */
4874 || memNE(p, SvPVX_const(cv), len))))
4875 && ckWARN_d(WARN_PROTOTYPE)) {
4876 SV* const msg = sv_newmortal();
4880 gv_efullname3(name = sv_newmortal(), gv, NULL);
4881 sv_setpv(msg, "Prototype mismatch:");
4883 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, (void*)name);
4885 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (void*)cv);
4887 sv_catpvs(msg, ": none");
4888 sv_catpvs(msg, " vs ");
4890 Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
4892 sv_catpvs(msg, "none");
4893 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, (void*)msg);
4897 static void const_sv_xsub(pTHX_ CV* cv);
4901 =head1 Optree Manipulation Functions
4903 =for apidoc cv_const_sv
4905 If C<cv> is a constant sub eligible for inlining. returns the constant
4906 value returned by the sub. Otherwise, returns NULL.
4908 Constant subs can be created with C<newCONSTSUB> or as described in
4909 L<perlsub/"Constant Functions">.
4914 Perl_cv_const_sv(pTHX_ CV *cv)
4916 PERL_UNUSED_CONTEXT;
4919 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
4921 return CvCONST(cv) ? (SV*)CvXSUBANY(cv).any_ptr : NULL;
4924 /* op_const_sv: examine an optree to determine whether it's in-lineable.
4925 * Can be called in 3 ways:
4928 * look for a single OP_CONST with attached value: return the value
4930 * cv && CvCLONE(cv) && !CvCONST(cv)
4932 * examine the clone prototype, and if contains only a single
4933 * OP_CONST referencing a pad const, or a single PADSV referencing
4934 * an outer lexical, return a non-zero value to indicate the CV is
4935 * a candidate for "constizing" at clone time
4939 * We have just cloned an anon prototype that was marked as a const
4940 * candidiate. Try to grab the current value, and in the case of
4941 * PADSV, ignore it if it has multiple references. Return the value.
4945 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
4953 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4954 o = cLISTOPo->op_first->op_sibling;
4956 for (; o; o = o->op_next) {
4957 const OPCODE type = o->op_type;
4959 if (sv && o->op_next == o)
4961 if (o->op_next != o) {
4962 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4964 if (type == OP_DBSTATE)
4967 if (type == OP_LEAVESUB || type == OP_RETURN)
4971 if (type == OP_CONST && cSVOPo->op_sv)
4973 else if (cv && type == OP_CONST) {
4974 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4978 else if (cv && type == OP_PADSV) {
4979 if (CvCONST(cv)) { /* newly cloned anon */
4980 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4981 /* the candidate should have 1 ref from this pad and 1 ref
4982 * from the parent */
4983 if (!sv || SvREFCNT(sv) != 2)
4990 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
4991 sv = &PL_sv_undef; /* an arbitrary non-null value */
5006 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5009 /* This would be the return value, but the return cannot be reached. */
5010 OP* pegop = newOP(OP_NULL, 0);
5013 PERL_UNUSED_ARG(floor);
5023 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
5025 NORETURN_FUNCTION_END;
5030 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
5032 return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
5036 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5043 register CV *cv = NULL;
5045 /* If the subroutine has no body, no attributes, and no builtin attributes
5046 then it's just a sub declaration, and we may be able to get away with
5047 storing with a placeholder scalar in the symbol table, rather than a
5048 full GV and CV. If anything is present then it will take a full CV to
5050 const I32 gv_fetch_flags
5051 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5053 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
5054 const char * const name = o ? SvPVx_nolen_const(cSVOPo->op_sv) : NULL;
5057 assert(proto->op_type == OP_CONST);
5058 ps = SvPVx_const(((SVOP*)proto)->op_sv, ps_len);
5063 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
5064 SV * const sv = sv_newmortal();
5065 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
5066 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
5067 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
5068 aname = SvPVX_const(sv);
5073 gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
5074 : gv_fetchpv(aname ? aname
5075 : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5076 gv_fetch_flags, SVt_PVCV);
5078 if (!PL_madskills) {
5087 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
5088 maximum a prototype before. */
5089 if (SvTYPE(gv) > SVt_NULL) {
5090 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
5091 && ckWARN_d(WARN_PROTOTYPE))
5093 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
5095 cv_ckproto_len((CV*)gv, NULL, ps, ps_len);
5098 sv_setpvn((SV*)gv, ps, ps_len);
5100 sv_setiv((SV*)gv, -1);
5101 SvREFCNT_dec(PL_compcv);
5102 cv = PL_compcv = NULL;
5103 PL_sub_generation++;
5107 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
5109 #ifdef GV_UNIQUE_CHECK
5110 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
5111 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
5115 if (!block || !ps || *ps || attrs
5116 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5118 || block->op_type == OP_NULL
5123 const_sv = op_const_sv(block, NULL);
5126 const bool exists = CvROOT(cv) || CvXSUB(cv);
5128 #ifdef GV_UNIQUE_CHECK
5129 if (exists && GvUNIQUE(gv)) {
5130 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
5134 /* if the subroutine doesn't exist and wasn't pre-declared
5135 * with a prototype, assume it will be AUTOLOADed,
5136 * skipping the prototype check
5138 if (exists || SvPOK(cv))
5139 cv_ckproto_len(cv, gv, ps, ps_len);
5140 /* already defined (or promised)? */
5141 if (exists || GvASSUMECV(gv)) {
5144 || block->op_type == OP_NULL
5147 if (CvFLAGS(PL_compcv)) {
5148 /* might have had built-in attrs applied */
5149 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5151 /* just a "sub foo;" when &foo is already defined */
5152 SAVEFREESV(PL_compcv);
5157 && block->op_type != OP_NULL
5160 if (ckWARN(WARN_REDEFINE)
5162 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
5164 const line_t oldline = CopLINE(PL_curcop);
5165 if (PL_copline != NOLINE)
5166 CopLINE_set(PL_curcop, PL_copline);
5167 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5168 CvCONST(cv) ? "Constant subroutine %s redefined"
5169 : "Subroutine %s redefined", name);
5170 CopLINE_set(PL_curcop, oldline);
5173 if (!PL_minus_c) /* keep old one around for madskills */
5176 /* (PL_madskills unset in used file.) */
5184 SvREFCNT_inc_simple_void_NN(const_sv);
5186 assert(!CvROOT(cv) && !CvCONST(cv));
5187 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
5188 CvXSUBANY(cv).any_ptr = const_sv;
5189 CvXSUB(cv) = const_sv_xsub;
5195 cv = newCONSTSUB(NULL, name, const_sv);
5197 PL_sub_generation++;
5201 SvREFCNT_dec(PL_compcv);
5209 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
5210 * before we clobber PL_compcv.
5214 || block->op_type == OP_NULL
5218 /* Might have had built-in attributes applied -- propagate them. */
5219 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5220 if (CvGV(cv) && GvSTASH(CvGV(cv)))
5221 stash = GvSTASH(CvGV(cv));
5222 else if (CvSTASH(cv))
5223 stash = CvSTASH(cv);
5225 stash = PL_curstash;
5228 /* possibly about to re-define existing subr -- ignore old cv */
5229 rcv = (SV*)PL_compcv;
5230 if (name && GvSTASH(gv))
5231 stash = GvSTASH(gv);
5233 stash = PL_curstash;
5235 apply_attrs(stash, rcv, attrs, FALSE);
5237 if (cv) { /* must reuse cv if autoloaded */
5244 || block->op_type == OP_NULL) && !PL_madskills
5247 /* got here with just attrs -- work done, so bug out */
5248 SAVEFREESV(PL_compcv);
5251 /* transfer PL_compcv to cv */
5253 CvFLAGS(cv) = CvFLAGS(PL_compcv);
5254 if (!CvWEAKOUTSIDE(cv))
5255 SvREFCNT_dec(CvOUTSIDE(cv));
5256 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
5257 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
5258 CvOUTSIDE(PL_compcv) = 0;
5259 CvPADLIST(cv) = CvPADLIST(PL_compcv);
5260 CvPADLIST(PL_compcv) = 0;
5261 /* inner references to PL_compcv must be fixed up ... */
5262 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
5263 /* ... before we throw it away */
5264 SvREFCNT_dec(PL_compcv);
5266 if (PERLDB_INTER)/* Advice debugger on the new sub. */
5267 ++PL_sub_generation;
5274 if (strEQ(name, "import")) {
5275 PL_formfeed = (SV*)cv;
5276 Perl_warner(aTHX_ packWARN(WARN_VOID), "%lx\n", (long)cv);
5280 PL_sub_generation++;
5284 CvFILE_set_from_cop(cv, PL_curcop);
5285 CvSTASH(cv) = PL_curstash;
5288 sv_setpvn((SV*)cv, ps, ps_len);
5290 if (PL_error_count) {
5294 const char *s = strrchr(name, ':');
5296 if (strEQ(s, "BEGIN")) {
5297 const char not_safe[] =
5298 "BEGIN not safe after errors--compilation aborted";
5299 if (PL_in_eval & EVAL_KEEPERR)
5300 Perl_croak(aTHX_ not_safe);
5302 /* force display of errors found but not reported */
5303 sv_catpv(ERRSV, not_safe);
5304 Perl_croak(aTHX_ "%"SVf, (void*)ERRSV);
5314 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5315 mod(scalarseq(block), OP_LEAVESUBLV));
5318 /* This makes sub {}; work as expected. */
5319 if (block->op_type == OP_STUB) {
5320 OP* const newblock = newSTATEOP(0, NULL, 0);
5322 op_getmad(block,newblock,'B');
5328 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5330 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5331 OpREFCNT_set(CvROOT(cv), 1);
5332 CvSTART(cv) = LINKLIST(CvROOT(cv));
5333 CvROOT(cv)->op_next = 0;
5334 CALL_PEEP(CvSTART(cv));
5336 /* now that optimizer has done its work, adjust pad values */
5338 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
5341 assert(!CvCONST(cv));
5342 if (ps && !*ps && op_const_sv(block, cv))
5346 if (name || aname) {
5348 const char * const tname = (name ? name : aname);
5350 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5351 SV * const sv = newSV(0);
5352 SV * const tmpstr = sv_newmortal();
5353 GV * const db_postponed = gv_fetchpvs("DB::postponed",
5354 GV_ADDMULTI, SVt_PVHV);
5357 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5359 (long)PL_subline, (long)CopLINE(PL_curcop));
5360 gv_efullname3(tmpstr, gv, NULL);
5361 hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0);
5362 hv = GvHVn(db_postponed);
5363 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
5364 CV * const pcv = GvCV(db_postponed);
5370 call_sv((SV*)pcv, G_DISCARD);
5375 if ((s = strrchr(tname,':')))
5380 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I' && *s != 'U')
5383 if (strEQ(s, "BEGIN") && !PL_error_count) {
5384 const I32 oldscope = PL_scopestack_ix;
5386 SAVECOPFILE(&PL_compiling);
5387 SAVECOPLINE(&PL_compiling);
5390 PL_beginav = newAV();
5391 DEBUG_x( dump_sub(gv) );
5392 av_push(PL_beginav, (SV*)cv);
5393 GvCV(gv) = 0; /* cv has been hijacked */
5394 call_list(oldscope, PL_beginav);
5396 PL_curcop = &PL_compiling;
5397 CopHINTS_set(&PL_compiling, PL_hints);
5400 else if (strEQ(s, "END") && !PL_error_count) {
5403 DEBUG_x( dump_sub(gv) );
5404 av_unshift(PL_endav, 1);
5405 av_store(PL_endav, 0, (SV*)cv);
5406 GvCV(gv) = 0; /* cv has been hijacked */
5408 else if (strEQ(s, "UNITCHECK") && !PL_error_count) {
5409 /* It's never too late to run a unitcheck block */
5410 if (!PL_unitcheckav)
5411 PL_unitcheckav = newAV();
5412 DEBUG_x( dump_sub(gv) );
5413 av_unshift(PL_unitcheckav, 1);
5414 av_store(PL_unitcheckav, 0, (SV*)cv);
5415 GvCV(gv) = 0; /* cv has been hijacked */
5417 else if (strEQ(s, "CHECK") && !PL_error_count) {
5419 PL_checkav = newAV();
5420 DEBUG_x( dump_sub(gv) );
5421 if (PL_main_start && ckWARN(WARN_VOID))
5422 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
5423 av_unshift(PL_checkav, 1);
5424 av_store(PL_checkav, 0, (SV*)cv);
5425 GvCV(gv) = 0; /* cv has been hijacked */
5427 else if (strEQ(s, "INIT") && !PL_error_count) {
5429 PL_initav = newAV();
5430 DEBUG_x( dump_sub(gv) );
5431 if (PL_main_start && ckWARN(WARN_VOID))
5432 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
5433 av_push(PL_initav, (SV*)cv);
5434 GvCV(gv) = 0; /* cv has been hijacked */
5439 PL_copline = NOLINE;
5444 /* XXX unsafe for threads if eval_owner isn't held */
5446 =for apidoc newCONSTSUB
5448 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5449 eligible for inlining at compile-time.
5455 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
5460 const char *const temp_p = CopFILE(PL_curcop);
5461 const STRLEN len = temp_p ? strlen(temp_p) : 0;
5463 SV *const temp_sv = CopFILESV(PL_curcop);
5465 const char *const temp_p = temp_sv ? SvPV_const(temp_sv, len) : NULL;
5467 char *const file = savepvn(temp_p, temp_p ? len : 0);
5471 SAVECOPLINE(PL_curcop);
5472 CopLINE_set(PL_curcop, PL_copline);
5475 PL_hints &= ~HINT_BLOCK_SCOPE;
5478 SAVESPTR(PL_curstash);
5479 SAVECOPSTASH(PL_curcop);
5480 PL_curstash = stash;
5481 CopSTASH_set(PL_curcop,stash);
5484 /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
5485 and so doesn't get free()d. (It's expected to be from the C pre-
5486 processor __FILE__ directive). But we need a dynamically allocated one,
5487 and we need it to get freed. */
5488 cv = newXS_flags(name, const_sv_xsub, file, "", XS_DYNAMIC_FILENAME);
5489 CvXSUBANY(cv).any_ptr = sv;
5495 CopSTASH_free(PL_curcop);
5503 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
5504 const char *const filename, const char *const proto,
5507 CV *cv = newXS(name, subaddr, filename);
5509 if (flags & XS_DYNAMIC_FILENAME) {
5510 /* We need to "make arrangements" (ie cheat) to ensure that the
5511 filename lasts as long as the PVCV we just created, but also doesn't
5513 STRLEN filename_len = strlen(filename);
5514 STRLEN proto_and_file_len = filename_len;
5515 char *proto_and_file;
5519 proto_len = strlen(proto);
5520 proto_and_file_len += proto_len;
5522 Newx(proto_and_file, proto_and_file_len + 1, char);
5523 Copy(proto, proto_and_file, proto_len, char);
5524 Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
5527 proto_and_file = savepvn(filename, filename_len);
5530 /* This gets free()d. :-) */
5531 sv_usepvn_flags((SV*)cv, proto_and_file, proto_and_file_len,
5532 SV_HAS_TRAILING_NUL);
5534 /* This gives us the correct prototype, rather than one with the
5535 file name appended. */
5536 SvCUR_set(cv, proto_len);
5540 CvFILE(cv) = proto_and_file + proto_len;
5542 sv_setpv((SV *)cv, proto);
5548 =for apidoc U||newXS
5550 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
5551 static storage, as it is used directly as CvFILE(), without a copy being made.
5557 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
5560 GV * const gv = gv_fetchpv(name ? name :
5561 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5562 GV_ADDMULTI, SVt_PVCV);
5566 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
5568 if ((cv = (name ? GvCV(gv) : NULL))) {
5570 /* just a cached method */
5574 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5575 /* already defined (or promised) */
5576 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
5577 if (ckWARN(WARN_REDEFINE)) {
5578 GV * const gvcv = CvGV(cv);
5580 HV * const stash = GvSTASH(gvcv);
5582 const char *redefined_name = HvNAME_get(stash);
5583 if ( strEQ(redefined_name,"autouse") ) {
5584 const line_t oldline = CopLINE(PL_curcop);
5585 if (PL_copline != NOLINE)
5586 CopLINE_set(PL_curcop, PL_copline);
5587 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5588 CvCONST(cv) ? "Constant subroutine %s redefined"
5589 : "Subroutine %s redefined"
5591 CopLINE_set(PL_curcop, oldline);
5601 if (cv) /* must reuse cv if autoloaded */
5605 sv_upgrade((SV *)cv, SVt_PVCV);
5609 PL_sub_generation++;
5613 (void)gv_fetchfile(filename);
5614 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
5615 an external constant string */
5617 CvXSUB(cv) = subaddr;
5620 const char *s = strrchr(name,':');
5626 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5629 if (strEQ(s, "BEGIN")) {
5631 PL_beginav = newAV();
5632 av_push(PL_beginav, (SV*)cv);
5633 GvCV(gv) = 0; /* cv has been hijacked */
5635 else if (strEQ(s, "END")) {
5638 av_unshift(PL_endav, 1);
5639 av_store(PL_endav, 0, (SV*)cv);
5640 GvCV(gv) = 0; /* cv has been hijacked */
5642 else if (strEQ(s, "CHECK")) {
5644 PL_checkav = newAV();
5645 if (PL_main_start && ckWARN(WARN_VOID))
5646 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
5647 av_unshift(PL_checkav, 1);
5648 av_store(PL_checkav, 0, (SV*)cv);
5649 GvCV(gv) = 0; /* cv has been hijacked */
5651 else if (strEQ(s, "INIT")) {
5653 PL_initav = newAV();
5654 if (PL_main_start && ckWARN(WARN_VOID))
5655 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
5656 av_push(PL_initav, (SV*)cv);
5657 GvCV(gv) = 0; /* cv has been hijacked */
5672 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5677 OP* pegop = newOP(OP_NULL, 0);
5681 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
5682 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
5684 #ifdef GV_UNIQUE_CHECK
5686 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5690 if ((cv = GvFORM(gv))) {
5691 if (ckWARN(WARN_REDEFINE)) {
5692 const line_t oldline = CopLINE(PL_curcop);
5693 if (PL_copline != NOLINE)
5694 CopLINE_set(PL_curcop, PL_copline);
5695 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5696 o ? "Format %"SVf" redefined"
5697 : "Format STDOUT redefined", (void*)cSVOPo->op_sv);
5698 CopLINE_set(PL_curcop, oldline);
5705 CvFILE_set_from_cop(cv, PL_curcop);
5708 pad_tidy(padtidy_FORMAT);
5709 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5710 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5711 OpREFCNT_set(CvROOT(cv), 1);
5712 CvSTART(cv) = LINKLIST(CvROOT(cv));
5713 CvROOT(cv)->op_next = 0;
5714 CALL_PEEP(CvSTART(cv));
5716 op_getmad(o,pegop,'n');
5717 op_getmad_weak(block, pegop, 'b');
5721 PL_copline = NOLINE;
5729 Perl_newANONLIST(pTHX_ OP *o)
5731 return convert(OP_ANONLIST, OPf_SPECIAL, o);
5735 Perl_newANONHASH(pTHX_ OP *o)
5737 return convert(OP_ANONHASH, OPf_SPECIAL, o);
5741 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5743 return newANONATTRSUB(floor, proto, NULL, block);
5747 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5749 return newUNOP(OP_REFGEN, 0,
5750 newSVOP(OP_ANONCODE, 0,
5751 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5755 Perl_oopsAV(pTHX_ OP *o)
5758 switch (o->op_type) {
5760 o->op_type = OP_PADAV;
5761 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5762 return ref(o, OP_RV2AV);
5765 o->op_type = OP_RV2AV;
5766 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5771 if (ckWARN_d(WARN_INTERNAL))
5772 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
5779 Perl_oopsHV(pTHX_ OP *o)
5782 switch (o->op_type) {
5785 o->op_type = OP_PADHV;
5786 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5787 return ref(o, OP_RV2HV);
5791 o->op_type = OP_RV2HV;
5792 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5797 if (ckWARN_d(WARN_INTERNAL))
5798 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
5805 Perl_newAVREF(pTHX_ OP *o)
5808 if (o->op_type == OP_PADANY) {
5809 o->op_type = OP_PADAV;
5810 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5813 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5814 && ckWARN(WARN_DEPRECATED)) {
5815 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5816 "Using an array as a reference is deprecated");
5818 return newUNOP(OP_RV2AV, 0, scalar(o));
5822 Perl_newGVREF(pTHX_ I32 type, OP *o)
5824 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5825 return newUNOP(OP_NULL, 0, o);
5826 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5830 Perl_newHVREF(pTHX_ OP *o)
5833 if (o->op_type == OP_PADANY) {
5834 o->op_type = OP_PADHV;
5835 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5838 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5839 && ckWARN(WARN_DEPRECATED)) {
5840 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5841 "Using a hash as a reference is deprecated");
5843 return newUNOP(OP_RV2HV, 0, scalar(o));
5847 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5849 return newUNOP(OP_RV2CV, flags, scalar(o));
5853 Perl_newSVREF(pTHX_ OP *o)
5856 if (o->op_type == OP_PADANY) {
5857 o->op_type = OP_PADSV;
5858 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5861 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5862 o->op_flags |= OPpDONE_SVREF;
5865 return newUNOP(OP_RV2SV, 0, scalar(o));
5868 /* Check routines. See the comments at the top of this file for details
5869 * on when these are called */
5872 Perl_ck_anoncode(pTHX_ OP *o)
5874 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
5876 cSVOPo->op_sv = NULL;
5881 Perl_ck_bitop(pTHX_ OP *o)
5884 #define OP_IS_NUMCOMPARE(op) \
5885 ((op) == OP_LT || (op) == OP_I_LT || \
5886 (op) == OP_GT || (op) == OP_I_GT || \
5887 (op) == OP_LE || (op) == OP_I_LE || \
5888 (op) == OP_GE || (op) == OP_I_GE || \
5889 (op) == OP_EQ || (op) == OP_I_EQ || \
5890 (op) == OP_NE || (op) == OP_I_NE || \
5891 (op) == OP_NCMP || (op) == OP_I_NCMP)
5892 o->op_private = (U8)(PL_hints & HINT_INTEGER);
5893 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
5894 && (o->op_type == OP_BIT_OR
5895 || o->op_type == OP_BIT_AND
5896 || o->op_type == OP_BIT_XOR))
5898 const OP * const left = cBINOPo->op_first;
5899 const OP * const right = left->op_sibling;
5900 if ((OP_IS_NUMCOMPARE(left->op_type) &&
5901 (left->op_flags & OPf_PARENS) == 0) ||
5902 (OP_IS_NUMCOMPARE(right->op_type) &&
5903 (right->op_flags & OPf_PARENS) == 0))
5904 if (ckWARN(WARN_PRECEDENCE))
5905 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
5906 "Possible precedence problem on bitwise %c operator",
5907 o->op_type == OP_BIT_OR ? '|'
5908 : o->op_type == OP_BIT_AND ? '&' : '^'
5915 Perl_ck_concat(pTHX_ OP *o)
5917 const OP * const kid = cUNOPo->op_first;
5918 PERL_UNUSED_CONTEXT;
5919 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
5920 !(kUNOP->op_first->op_flags & OPf_MOD))
5921 o->op_flags |= OPf_STACKED;
5926 Perl_ck_spair(pTHX_ OP *o)
5929 if (o->op_flags & OPf_KIDS) {
5932 const OPCODE type = o->op_type;
5933 o = modkids(ck_fun(o), type);
5934 kid = cUNOPo->op_first;
5935 newop = kUNOP->op_first->op_sibling;
5937 const OPCODE type = newop->op_type;
5938 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
5939 type == OP_PADAV || type == OP_PADHV ||
5940 type == OP_RV2AV || type == OP_RV2HV)
5944 op_getmad(kUNOP->op_first,newop,'K');
5946 op_free(kUNOP->op_first);
5948 kUNOP->op_first = newop;
5950 o->op_ppaddr = PL_ppaddr[++o->op_type];
5955 Perl_ck_delete(pTHX_ OP *o)
5959 if (o->op_flags & OPf_KIDS) {
5960 OP * const kid = cUNOPo->op_first;
5961 switch (kid->op_type) {
5963 o->op_flags |= OPf_SPECIAL;
5966 o->op_private |= OPpSLICE;
5969 o->op_flags |= OPf_SPECIAL;
5974 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5983 Perl_ck_die(pTHX_ OP *o)
5986 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5992 Perl_ck_eof(pTHX_ OP *o)
5996 if (o->op_flags & OPf_KIDS) {
5997 if (cLISTOPo->op_first->op_type == OP_STUB) {
5999 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
6001 op_getmad(o,newop,'O');
6013 Perl_ck_eval(pTHX_ OP *o)
6016 PL_hints |= HINT_BLOCK_SCOPE;
6017 if (o->op_flags & OPf_KIDS) {
6018 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6021 o->op_flags &= ~OPf_KIDS;
6024 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
6030 cUNOPo->op_first = 0;
6035 NewOp(1101, enter, 1, LOGOP);
6036 enter->op_type = OP_ENTERTRY;
6037 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
6038 enter->op_private = 0;
6040 /* establish postfix order */
6041 enter->op_next = (OP*)enter;
6043 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
6044 o->op_type = OP_LEAVETRY;
6045 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
6046 enter->op_other = o;
6047 op_getmad(oldo,o,'O');
6061 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
6062 op_getmad(oldo,o,'O');
6064 o->op_targ = (PADOFFSET)PL_hints;
6065 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
6066 /* Store a copy of %^H that pp_entereval can pick up */
6067 OP *hhop = newSVOP(OP_CONST, 0,
6068 (SV*)Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv)));
6069 cUNOPo->op_first->op_sibling = hhop;
6070 o->op_private |= OPpEVAL_HAS_HH;
6076 Perl_ck_exit(pTHX_ OP *o)
6079 HV * const table = GvHV(PL_hintgv);
6081 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
6082 if (svp && *svp && SvTRUE(*svp))
6083 o->op_private |= OPpEXIT_VMSISH;
6085 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6091 Perl_ck_exec(pTHX_ OP *o)
6093 if (o->op_flags & OPf_STACKED) {
6096 kid = cUNOPo->op_first->op_sibling;
6097 if (kid->op_type == OP_RV2GV)
6106 Perl_ck_exists(pTHX_ OP *o)
6110 if (o->op_flags & OPf_KIDS) {
6111 OP * const kid = cUNOPo->op_first;
6112 if (kid->op_type == OP_ENTERSUB) {
6113 (void) ref(kid, o->op_type);
6114 if (kid->op_type != OP_RV2CV && !PL_error_count)
6115 Perl_croak(aTHX_ "%s argument is not a subroutine name",
6117 o->op_private |= OPpEXISTS_SUB;
6119 else if (kid->op_type == OP_AELEM)
6120 o->op_flags |= OPf_SPECIAL;
6121 else if (kid->op_type != OP_HELEM)
6122 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
6130 Perl_ck_rvconst(pTHX_ register OP *o)
6133 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6135 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6136 if (o->op_type == OP_RV2CV)
6137 o->op_private &= ~1;
6139 if (kid->op_type == OP_CONST) {
6142 SV * const kidsv = kid->op_sv;
6144 /* Is it a constant from cv_const_sv()? */
6145 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
6146 SV * const rsv = SvRV(kidsv);
6147 const svtype type = SvTYPE(rsv);
6148 const char *badtype = NULL;
6150 switch (o->op_type) {
6152 if (type > SVt_PVMG)
6153 badtype = "a SCALAR";
6156 if (type != SVt_PVAV)
6157 badtype = "an ARRAY";
6160 if (type != SVt_PVHV)
6164 if (type != SVt_PVCV)
6169 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
6172 else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
6173 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
6174 /* If this is an access to a stash, disable "strict refs", because
6175 * stashes aren't auto-vivified at compile-time (unless we store
6176 * symbols in them), and we don't want to produce a run-time
6177 * stricture error when auto-vivifying the stash. */
6178 const char *s = SvPV_nolen(kidsv);
6179 const STRLEN l = SvCUR(kidsv);
6180 if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
6181 o->op_private &= ~HINT_STRICT_REFS;
6183 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
6184 const char *badthing;
6185 switch (o->op_type) {
6187 badthing = "a SCALAR";
6190 badthing = "an ARRAY";
6193 badthing = "a HASH";
6201 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
6202 (void*)kidsv, badthing);
6205 * This is a little tricky. We only want to add the symbol if we
6206 * didn't add it in the lexer. Otherwise we get duplicate strict
6207 * warnings. But if we didn't add it in the lexer, we must at
6208 * least pretend like we wanted to add it even if it existed before,
6209 * or we get possible typo warnings. OPpCONST_ENTERED says
6210 * whether the lexer already added THIS instance of this symbol.
6212 iscv = (o->op_type == OP_RV2CV) * 2;
6214 gv = gv_fetchsv(kidsv,
6215 iscv | !(kid->op_private & OPpCONST_ENTERED),
6218 : o->op_type == OP_RV2SV
6220 : o->op_type == OP_RV2AV
6222 : o->op_type == OP_RV2HV
6225 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
6227 kid->op_type = OP_GV;
6228 SvREFCNT_dec(kid->op_sv);
6230 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
6231 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
6232 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
6234 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc_simple_NN(gv));
6236 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
6238 kid->op_private = 0;
6239 kid->op_ppaddr = PL_ppaddr[OP_GV];
6246 Perl_ck_ftst(pTHX_ OP *o)
6249 const I32 type = o->op_type;
6251 if (o->op_flags & OPf_REF) {
6254 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
6255 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6256 const OPCODE kidtype = kid->op_type;
6258 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6259 OP * const newop = newGVOP(type, OPf_REF,
6260 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
6262 op_getmad(o,newop,'O');
6268 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o))
6269 o->op_private |= OPpFT_ACCESS;
6270 if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst)
6271 && kidtype != OP_STAT && kidtype != OP_LSTAT)
6272 o->op_private |= OPpFT_STACKED;
6280 if (type == OP_FTTTY)
6281 o = newGVOP(type, OPf_REF, PL_stdingv);
6283 o = newUNOP(type, 0, newDEFSVOP());
6284 op_getmad(oldo,o,'O');
6290 Perl_ck_fun(pTHX_ OP *o)
6293 const int type = o->op_type;
6294 register I32 oa = PL_opargs[type] >> OASHIFT;
6296 if (o->op_flags & OPf_STACKED) {
6297 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
6300 return no_fh_allowed(o);
6303 if (o->op_flags & OPf_KIDS) {
6304 OP **tokid = &cLISTOPo->op_first;
6305 register OP *kid = cLISTOPo->op_first;
6309 if (kid->op_type == OP_PUSHMARK ||
6310 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
6312 tokid = &kid->op_sibling;
6313 kid = kid->op_sibling;
6315 if (!kid && PL_opargs[type] & OA_DEFGV)
6316 *tokid = kid = newDEFSVOP();
6320 sibl = kid->op_sibling;
6322 if (!sibl && kid->op_type == OP_STUB) {
6329 /* list seen where single (scalar) arg expected? */
6330 if (numargs == 1 && !(oa >> 4)
6331 && kid->op_type == OP_LIST && type != OP_SCALAR)
6333 return too_many_arguments(o,PL_op_desc[type]);
6346 if ((type == OP_PUSH || type == OP_UNSHIFT)
6347 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
6348 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6349 "Useless use of %s with no values",
6352 if (kid->op_type == OP_CONST &&
6353 (kid->op_private & OPpCONST_BARE))
6355 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
6356 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
6357 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6358 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6359 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
6360 (void*)((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
6362 op_getmad(kid,newop,'K');
6367 kid->op_sibling = sibl;
6370 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
6371 bad_type(numargs, "array", PL_op_desc[type], kid);
6375 if (kid->op_type == OP_CONST &&
6376 (kid->op_private & OPpCONST_BARE))
6378 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
6379 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
6380 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6381 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6382 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
6383 (void*)((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
6385 op_getmad(kid,newop,'K');
6390 kid->op_sibling = sibl;
6393 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
6394 bad_type(numargs, "hash", PL_op_desc[type], kid);
6399 OP * const newop = newUNOP(OP_NULL, 0, kid);
6400 kid->op_sibling = 0;
6402 newop->op_next = newop;
6404 kid->op_sibling = sibl;
6409 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
6410 if (kid->op_type == OP_CONST &&
6411 (kid->op_private & OPpCONST_BARE))
6413 OP * const newop = newGVOP(OP_GV, 0,
6414 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
6415 if (!(o->op_private & 1) && /* if not unop */
6416 kid == cLISTOPo->op_last)
6417 cLISTOPo->op_last = newop;
6419 op_getmad(kid,newop,'K');
6425 else if (kid->op_type == OP_READLINE) {
6426 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
6427 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
6430 I32 flags = OPf_SPECIAL;
6434 /* is this op a FH constructor? */
6435 if (is_handle_constructor(o,numargs)) {
6436 const char *name = NULL;
6440 /* Set a flag to tell rv2gv to vivify
6441 * need to "prove" flag does not mean something
6442 * else already - NI-S 1999/05/07
6445 if (kid->op_type == OP_PADSV) {
6446 name = PAD_COMPNAME_PV(kid->op_targ);
6447 /* SvCUR of a pad namesv can't be trusted
6448 * (see PL_generation), so calc its length
6454 else if (kid->op_type == OP_RV2SV
6455 && kUNOP->op_first->op_type == OP_GV)
6457 GV * const gv = cGVOPx_gv(kUNOP->op_first);
6459 len = GvNAMELEN(gv);
6461 else if (kid->op_type == OP_AELEM
6462 || kid->op_type == OP_HELEM)
6465 OP *op = ((BINOP*)kid)->op_first;
6469 const char * const a =
6470 kid->op_type == OP_AELEM ?
6472 if (((op->op_type == OP_RV2AV) ||
6473 (op->op_type == OP_RV2HV)) &&
6474 (firstop = ((UNOP*)op)->op_first) &&
6475 (firstop->op_type == OP_GV)) {
6476 /* packagevar $a[] or $h{} */
6477 GV * const gv = cGVOPx_gv(firstop);
6485 else if (op->op_type == OP_PADAV
6486 || op->op_type == OP_PADHV) {
6487 /* lexicalvar $a[] or $h{} */
6488 const char * const padname =
6489 PAD_COMPNAME_PV(op->op_targ);
6498 name = SvPV_const(tmpstr, len);
6503 name = "__ANONIO__";
6510 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
6511 namesv = PAD_SVl(targ);
6512 SvUPGRADE(namesv, SVt_PV);
6514 sv_setpvn(namesv, "$", 1);
6515 sv_catpvn(namesv, name, len);
6518 kid->op_sibling = 0;
6519 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
6520 kid->op_targ = targ;
6521 kid->op_private |= priv;
6523 kid->op_sibling = sibl;
6529 mod(scalar(kid), type);
6533 tokid = &kid->op_sibling;
6534 kid = kid->op_sibling;
6537 if (kid && kid->op_type != OP_STUB)
6538 return too_many_arguments(o,OP_DESC(o));
6539 o->op_private |= numargs;
6541 /* FIXME - should the numargs move as for the PERL_MAD case? */
6542 o->op_private |= numargs;
6544 return too_many_arguments(o,OP_DESC(o));
6548 else if (PL_opargs[type] & OA_DEFGV) {
6550 OP *newop = newUNOP(type, 0, newDEFSVOP());
6551 op_getmad(o,newop,'O');
6554 /* Ordering of these two is important to keep f_map.t passing. */
6556 return newUNOP(type, 0, newDEFSVOP());
6561 while (oa & OA_OPTIONAL)
6563 if (oa && oa != OA_LIST)
6564 return too_few_arguments(o,OP_DESC(o));
6570 Perl_ck_glob(pTHX_ OP *o)
6576 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
6577 append_elem(OP_GLOB, o, newDEFSVOP());
6579 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
6580 && GvCVu(gv) && GvIMPORTED_CV(gv)))
6582 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6585 #if !defined(PERL_EXTERNAL_GLOB)
6586 /* XXX this can be tightened up and made more failsafe. */
6587 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
6590 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
6591 newSVpvs("File::Glob"), NULL, NULL, NULL);
6592 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6593 glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
6594 GvCV(gv) = GvCV(glob_gv);
6595 SvREFCNT_inc_void((SV*)GvCV(gv));
6596 GvIMPORTED_CV_on(gv);
6599 #endif /* PERL_EXTERNAL_GLOB */
6601 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6602 append_elem(OP_GLOB, o,
6603 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
6604 o->op_type = OP_LIST;
6605 o->op_ppaddr = PL_ppaddr[OP_LIST];
6606 cLISTOPo->op_first->op_type = OP_PUSHMARK;
6607 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
6608 cLISTOPo->op_first->op_targ = 0;
6609 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
6610 append_elem(OP_LIST, o,
6611 scalar(newUNOP(OP_RV2CV, 0,
6612 newGVOP(OP_GV, 0, gv)))));
6613 o = newUNOP(OP_NULL, 0, ck_subr(o));
6614 o->op_targ = OP_GLOB; /* hint at what it used to be */
6617 gv = newGVgen("main");
6619 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
6625 Perl_ck_grep(pTHX_ OP *o)
6630 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
6633 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
6634 /* don't allocate gwop here, as we may leak it if PL_error_count > 0 */
6636 if (o->op_flags & OPf_STACKED) {
6639 kid = cLISTOPo->op_first->op_sibling;
6640 if (!cUNOPx(kid)->op_next)
6641 Perl_croak(aTHX_ "panic: ck_grep");
6642 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
6645 NewOp(1101, gwop, 1, LOGOP);
6646 kid->op_next = (OP*)gwop;
6647 o->op_flags &= ~OPf_STACKED;
6649 kid = cLISTOPo->op_first->op_sibling;
6650 if (type == OP_MAPWHILE)
6657 kid = cLISTOPo->op_first->op_sibling;
6658 if (kid->op_type != OP_NULL)
6659 Perl_croak(aTHX_ "panic: ck_grep");
6660 kid = kUNOP->op_first;
6663 NewOp(1101, gwop, 1, LOGOP);
6664 gwop->op_type = type;
6665 gwop->op_ppaddr = PL_ppaddr[type];
6666 gwop->op_first = listkids(o);
6667 gwop->op_flags |= OPf_KIDS;
6668 gwop->op_other = LINKLIST(kid);
6669 kid->op_next = (OP*)gwop;
6670 offset = pad_findmy("$_");
6671 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
6672 o->op_private = gwop->op_private = 0;
6673 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
6676 o->op_private = gwop->op_private = OPpGREP_LEX;
6677 gwop->op_targ = o->op_targ = offset;
6680 kid = cLISTOPo->op_first->op_sibling;
6681 if (!kid || !kid->op_sibling)
6682 return too_few_arguments(o,OP_DESC(o));
6683 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
6684 mod(kid, OP_GREPSTART);
6690 Perl_ck_index(pTHX_ OP *o)
6692 if (o->op_flags & OPf_KIDS) {
6693 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6695 kid = kid->op_sibling; /* get past "big" */
6696 if (kid && kid->op_type == OP_CONST)
6697 fbm_compile(((SVOP*)kid)->op_sv, 0);
6703 Perl_ck_lengthconst(pTHX_ OP *o)
6705 /* XXX length optimization goes here */
6710 Perl_ck_lfun(pTHX_ OP *o)
6712 const OPCODE type = o->op_type;
6713 return modkids(ck_fun(o), type);
6717 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
6719 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
6720 switch (cUNOPo->op_first->op_type) {
6722 /* This is needed for
6723 if (defined %stash::)
6724 to work. Do not break Tk.
6726 break; /* Globals via GV can be undef */
6728 case OP_AASSIGN: /* Is this a good idea? */
6729 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6730 "defined(@array) is deprecated");
6731 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6732 "\t(Maybe you should just omit the defined()?)\n");
6735 /* This is needed for
6736 if (defined %stash::)
6737 to work. Do not break Tk.
6739 break; /* Globals via GV can be undef */
6741 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6742 "defined(%%hash) is deprecated");
6743 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6744 "\t(Maybe you should just omit the defined()?)\n");
6755 Perl_ck_rfun(pTHX_ OP *o)
6757 const OPCODE type = o->op_type;
6758 return refkids(ck_fun(o), type);
6762 Perl_ck_listiob(pTHX_ OP *o)
6766 kid = cLISTOPo->op_first;
6769 kid = cLISTOPo->op_first;
6771 if (kid->op_type == OP_PUSHMARK)
6772 kid = kid->op_sibling;
6773 if (kid && o->op_flags & OPf_STACKED)
6774 kid = kid->op_sibling;
6775 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6776 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6777 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6778 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6779 cLISTOPo->op_first->op_sibling = kid;
6780 cLISTOPo->op_last = kid;
6781 kid = kid->op_sibling;
6786 append_elem(o->op_type, o, newDEFSVOP());
6792 Perl_ck_smartmatch(pTHX_ OP *o)
6795 if (0 == (o->op_flags & OPf_SPECIAL)) {
6796 OP *first = cBINOPo->op_first;
6797 OP *second = first->op_sibling;
6799 /* Implicitly take a reference to an array or hash */
6800 first->op_sibling = NULL;
6801 first = cBINOPo->op_first = ref_array_or_hash(first);
6802 second = first->op_sibling = ref_array_or_hash(second);
6804 /* Implicitly take a reference to a regular expression */
6805 if (first->op_type == OP_MATCH) {
6806 first->op_type = OP_QR;
6807 first->op_ppaddr = PL_ppaddr[OP_QR];
6809 if (second->op_type == OP_MATCH) {
6810 second->op_type = OP_QR;
6811 second->op_ppaddr = PL_ppaddr[OP_QR];
6820 Perl_ck_sassign(pTHX_ OP *o)
6822 OP * const kid = cLISTOPo->op_first;
6823 /* has a disposable target? */
6824 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6825 && !(kid->op_flags & OPf_STACKED)
6826 /* Cannot steal the second time! */
6827 && !(kid->op_private & OPpTARGET_MY))
6829 OP * const kkid = kid->op_sibling;
6831 /* Can just relocate the target. */
6832 if (kkid && kkid->op_type == OP_PADSV
6833 && !(kkid->op_private & OPpLVAL_INTRO))
6835 kid->op_targ = kkid->op_targ;
6837 /* Now we do not need PADSV and SASSIGN. */
6838 kid->op_sibling = o->op_sibling; /* NULL */
6839 cLISTOPo->op_first = NULL;
6841 op_getmad(o,kid,'O');
6842 op_getmad(kkid,kid,'M');
6847 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6851 if (kid->op_sibling) {
6852 OP *kkid = kid->op_sibling;
6853 if (kkid->op_type == OP_PADSV
6854 && (kkid->op_private & OPpLVAL_INTRO)
6855 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
6856 o->op_private |= OPpASSIGN_STATE;
6857 /* hijacking PADSTALE for uninitialized state variables */
6858 SvPADSTALE_on(PAD_SVl(kkid->op_targ));
6865 Perl_ck_match(pTHX_ OP *o)
6868 if (o->op_type != OP_QR && PL_compcv) {
6869 const PADOFFSET offset = pad_findmy("$_");
6870 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
6871 o->op_targ = offset;
6872 o->op_private |= OPpTARGET_MY;
6875 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
6876 o->op_private |= OPpRUNTIME;
6881 Perl_ck_method(pTHX_ OP *o)
6883 OP * const kid = cUNOPo->op_first;
6884 if (kid->op_type == OP_CONST) {
6885 SV* sv = kSVOP->op_sv;
6886 const char * const method = SvPVX_const(sv);
6887 if (!(strchr(method, ':') || strchr(method, '\''))) {
6889 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6890 sv = newSVpvn_share(method, SvCUR(sv), 0);
6893 kSVOP->op_sv = NULL;
6895 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6897 op_getmad(o,cmop,'O');
6908 Perl_ck_null(pTHX_ OP *o)
6910 PERL_UNUSED_CONTEXT;
6915 Perl_ck_open(pTHX_ OP *o)
6918 HV * const table = GvHV(PL_hintgv);
6920 SV **svp = hv_fetchs(table, "open_IN", FALSE);
6922 const I32 mode = mode_from_discipline(*svp);
6923 if (mode & O_BINARY)
6924 o->op_private |= OPpOPEN_IN_RAW;
6925 else if (mode & O_TEXT)
6926 o->op_private |= OPpOPEN_IN_CRLF;
6929 svp = hv_fetchs(table, "open_OUT", FALSE);
6931 const I32 mode = mode_from_discipline(*svp);
6932 if (mode & O_BINARY)
6933 o->op_private |= OPpOPEN_OUT_RAW;
6934 else if (mode & O_TEXT)
6935 o->op_private |= OPpOPEN_OUT_CRLF;
6938 if (o->op_type == OP_BACKTICK)
6941 /* In case of three-arg dup open remove strictness
6942 * from the last arg if it is a bareword. */
6943 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
6944 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
6948 if ((last->op_type == OP_CONST) && /* The bareword. */
6949 (last->op_private & OPpCONST_BARE) &&
6950 (last->op_private & OPpCONST_STRICT) &&
6951 (oa = first->op_sibling) && /* The fh. */
6952 (oa = oa->op_sibling) && /* The mode. */
6953 (oa->op_type == OP_CONST) &&
6954 SvPOK(((SVOP*)oa)->op_sv) &&
6955 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
6956 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
6957 (last == oa->op_sibling)) /* The bareword. */
6958 last->op_private &= ~OPpCONST_STRICT;
6964 Perl_ck_repeat(pTHX_ OP *o)
6966 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6967 o->op_private |= OPpREPEAT_DOLIST;
6968 cBINOPo->op_first = force_list(cBINOPo->op_first);
6976 Perl_ck_require(pTHX_ OP *o)
6981 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6982 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6984 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6985 SV * const sv = kid->op_sv;
6986 U32 was_readonly = SvREADONLY(sv);
6991 sv_force_normal_flags(sv, 0);
6992 assert(!SvREADONLY(sv));
6999 for (s = SvPVX(sv); *s; s++) {
7000 if (*s == ':' && s[1] == ':') {
7001 const STRLEN len = strlen(s+2)+1;
7003 Move(s+2, s+1, len, char);
7004 SvCUR_set(sv, SvCUR(sv) - 1);
7007 sv_catpvs(sv, ".pm");
7008 SvFLAGS(sv) |= was_readonly;
7012 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
7013 /* handle override, if any */
7014 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
7015 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7016 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
7017 gv = gvp ? *gvp : NULL;
7021 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7022 OP * const kid = cUNOPo->op_first;
7025 cUNOPo->op_first = 0;
7029 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
7030 append_elem(OP_LIST, kid,
7031 scalar(newUNOP(OP_RV2CV, 0,
7034 op_getmad(o,newop,'O');
7042 Perl_ck_return(pTHX_ OP *o)
7045 if (CvLVALUE(PL_compcv)) {
7047 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
7048 mod(kid, OP_LEAVESUBLV);
7054 Perl_ck_select(pTHX_ OP *o)
7058 if (o->op_flags & OPf_KIDS) {
7059 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7060 if (kid && kid->op_sibling) {
7061 o->op_type = OP_SSELECT;
7062 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
7064 return fold_constants(o);
7068 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7069 if (kid && kid->op_type == OP_RV2GV)
7070 kid->op_private &= ~HINT_STRICT_REFS;
7075 Perl_ck_shift(pTHX_ OP *o)
7078 const I32 type = o->op_type;
7080 if (!(o->op_flags & OPf_KIDS)) {
7082 /* FIXME - this can be refactored to reduce code in #ifdefs */
7084 OP * const oldo = o;
7088 argop = newUNOP(OP_RV2AV, 0,
7089 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
7091 o = newUNOP(type, 0, scalar(argop));
7092 op_getmad(oldo,o,'O');
7095 return newUNOP(type, 0, scalar(argop));
7098 return scalar(modkids(ck_fun(o), type));
7102 Perl_ck_sort(pTHX_ OP *o)
7107 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
7108 HV * const hinthv = GvHV(PL_hintgv);
7110 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
7112 const I32 sorthints = (I32)SvIV(*svp);
7113 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
7114 o->op_private |= OPpSORT_QSORT;
7115 if ((sorthints & HINT_SORT_STABLE) != 0)
7116 o->op_private |= OPpSORT_STABLE;
7121 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
7123 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7124 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
7126 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
7128 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
7130 if (kid->op_type == OP_SCOPE) {
7134 else if (kid->op_type == OP_LEAVE) {
7135 if (o->op_type == OP_SORT) {
7136 op_null(kid); /* wipe out leave */
7139 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
7140 if (k->op_next == kid)
7142 /* don't descend into loops */
7143 else if (k->op_type == OP_ENTERLOOP
7144 || k->op_type == OP_ENTERITER)
7146 k = cLOOPx(k)->op_lastop;
7151 kid->op_next = 0; /* just disconnect the leave */
7152 k = kLISTOP->op_first;
7157 if (o->op_type == OP_SORT) {
7158 /* provide scalar context for comparison function/block */
7164 o->op_flags |= OPf_SPECIAL;
7166 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
7169 firstkid = firstkid->op_sibling;
7172 /* provide list context for arguments */
7173 if (o->op_type == OP_SORT)
7180 S_simplify_sort(pTHX_ OP *o)
7183 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7188 if (!(o->op_flags & OPf_STACKED))
7190 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7191 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
7192 kid = kUNOP->op_first; /* get past null */
7193 if (kid->op_type != OP_SCOPE)
7195 kid = kLISTOP->op_last; /* get past scope */
7196 switch(kid->op_type) {
7204 k = kid; /* remember this node*/
7205 if (kBINOP->op_first->op_type != OP_RV2SV)
7207 kid = kBINOP->op_first; /* get past cmp */
7208 if (kUNOP->op_first->op_type != OP_GV)
7210 kid = kUNOP->op_first; /* get past rv2sv */
7212 if (GvSTASH(gv) != PL_curstash)
7214 gvname = GvNAME(gv);
7215 if (*gvname == 'a' && gvname[1] == '\0')
7217 else if (*gvname == 'b' && gvname[1] == '\0')
7222 kid = k; /* back to cmp */
7223 if (kBINOP->op_last->op_type != OP_RV2SV)
7225 kid = kBINOP->op_last; /* down to 2nd arg */
7226 if (kUNOP->op_first->op_type != OP_GV)
7228 kid = kUNOP->op_first; /* get past rv2sv */
7230 if (GvSTASH(gv) != PL_curstash)
7232 gvname = GvNAME(gv);
7234 ? !(*gvname == 'a' && gvname[1] == '\0')
7235 : !(*gvname == 'b' && gvname[1] == '\0'))
7237 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
7239 o->op_private |= OPpSORT_DESCEND;
7240 if (k->op_type == OP_NCMP)
7241 o->op_private |= OPpSORT_NUMERIC;
7242 if (k->op_type == OP_I_NCMP)
7243 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
7244 kid = cLISTOPo->op_first->op_sibling;
7245 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
7247 op_getmad(kid,o,'S'); /* then delete it */
7249 op_free(kid); /* then delete it */
7254 Perl_ck_split(pTHX_ OP *o)
7259 if (o->op_flags & OPf_STACKED)
7260 return no_fh_allowed(o);
7262 kid = cLISTOPo->op_first;
7263 if (kid->op_type != OP_NULL)
7264 Perl_croak(aTHX_ "panic: ck_split");
7265 kid = kid->op_sibling;
7266 op_free(cLISTOPo->op_first);
7267 cLISTOPo->op_first = kid;
7269 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
7270 cLISTOPo->op_last = kid; /* There was only one element previously */
7273 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
7274 OP * const sibl = kid->op_sibling;
7275 kid->op_sibling = 0;
7276 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
7277 if (cLISTOPo->op_first == cLISTOPo->op_last)
7278 cLISTOPo->op_last = kid;
7279 cLISTOPo->op_first = kid;
7280 kid->op_sibling = sibl;
7283 kid->op_type = OP_PUSHRE;
7284 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
7286 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
7287 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
7288 "Use of /g modifier is meaningless in split");
7291 if (!kid->op_sibling)
7292 append_elem(OP_SPLIT, o, newDEFSVOP());
7294 kid = kid->op_sibling;
7297 if (!kid->op_sibling)
7298 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
7299 assert(kid->op_sibling);
7301 kid = kid->op_sibling;
7304 if (kid->op_sibling)
7305 return too_many_arguments(o,OP_DESC(o));
7311 Perl_ck_join(pTHX_ OP *o)
7313 const OP * const kid = cLISTOPo->op_first->op_sibling;
7314 if (kid && kid->op_type == OP_MATCH) {
7315 if (ckWARN(WARN_SYNTAX)) {
7316 const REGEXP *re = PM_GETRE(kPMOP);
7317 const char *pmstr = re ? re->precomp : "STRING";
7318 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7319 "/%s/ should probably be written as \"%s\"",
7327 Perl_ck_subr(pTHX_ OP *o)
7330 OP *prev = ((cUNOPo->op_first->op_sibling)
7331 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
7332 OP *o2 = prev->op_sibling;
7334 const char *proto = NULL;
7335 const char *proto_end = NULL;
7340 I32 contextclass = 0;
7341 const char *e = NULL;
7344 o->op_private |= OPpENTERSUB_HASTARG;
7345 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
7346 if (cvop->op_type == OP_RV2CV) {
7348 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
7349 op_null(cvop); /* disable rv2cv */
7350 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
7351 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
7352 GV *gv = cGVOPx_gv(tmpop);
7355 tmpop->op_private |= OPpEARLY_CV;
7359 namegv = CvANON(cv) ? gv : CvGV(cv);
7360 proto = SvPV((SV*)cv, len);
7361 proto_end = proto + len;
7363 if (CvASSERTION(cv)) {
7364 U32 asserthints = 0;
7365 HV *const hinthv = GvHV(PL_hintgv);
7367 SV **svp = hv_fetchs(hinthv, "assertions", FALSE);
7369 asserthints = SvUV(*svp);
7371 if (asserthints & HINT_ASSERTING) {
7372 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
7373 o->op_private |= OPpENTERSUB_DB;
7377 if (!(asserthints & HINT_ASSERTIONSSEEN) && ckWARN(WARN_ASSERTIONS)) {
7378 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
7379 "Impossible to activate assertion call");
7386 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7387 if (o2->op_type == OP_CONST)
7388 o2->op_private &= ~OPpCONST_STRICT;
7389 else if (o2->op_type == OP_LIST) {
7390 OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
7391 if (sib && sib->op_type == OP_CONST)
7392 sib->op_private &= ~OPpCONST_STRICT;
7395 o->op_private |= (PL_hints & HINT_STRICT_REFS);
7396 if (PERLDB_SUB && PL_curstash != PL_debstash)
7397 o->op_private |= OPpENTERSUB_DB;
7398 while (o2 != cvop) {
7400 if (PL_madskills && o2->op_type == OP_NULL)
7401 o3 = ((UNOP*)o2)->op_first;
7405 if (proto >= proto_end)
7406 return too_many_arguments(o, gv_ename(namegv));
7414 /* _ must be at the end */
7415 if (proto[1] && proto[1] != ';')
7430 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
7432 arg == 1 ? "block or sub {}" : "sub {}",
7433 gv_ename(namegv), o3);
7436 /* '*' allows any scalar type, including bareword */
7439 if (o3->op_type == OP_RV2GV)
7440 goto wrapref; /* autoconvert GLOB -> GLOBref */
7441 else if (o3->op_type == OP_CONST)
7442 o3->op_private &= ~OPpCONST_STRICT;
7443 else if (o3->op_type == OP_ENTERSUB) {
7444 /* accidental subroutine, revert to bareword */
7445 OP *gvop = ((UNOP*)o3)->op_first;
7446 if (gvop && gvop->op_type == OP_NULL) {
7447 gvop = ((UNOP*)gvop)->op_first;
7449 for (; gvop->op_sibling; gvop = gvop->op_sibling)
7452 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
7453 (gvop = ((UNOP*)gvop)->op_first) &&
7454 gvop->op_type == OP_GV)
7456 GV * const gv = cGVOPx_gv(gvop);
7457 OP * const sibling = o2->op_sibling;
7458 SV * const n = newSVpvs("");
7460 OP * const oldo2 = o2;
7464 gv_fullname4(n, gv, "", FALSE);
7465 o2 = newSVOP(OP_CONST, 0, n);
7466 op_getmad(oldo2,o2,'O');
7467 prev->op_sibling = o2;
7468 o2->op_sibling = sibling;
7484 if (contextclass++ == 0) {
7485 e = strchr(proto, ']');
7486 if (!e || e == proto)
7495 const char *p = proto;
7496 const char *const end = proto;
7498 while (*--p != '[');
7499 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
7501 gv_ename(namegv), o3);
7506 if (o3->op_type == OP_RV2GV)
7509 bad_type(arg, "symbol", gv_ename(namegv), o3);
7512 if (o3->op_type == OP_ENTERSUB)
7515 bad_type(arg, "subroutine entry", gv_ename(namegv),
7519 if (o3->op_type == OP_RV2SV ||
7520 o3->op_type == OP_PADSV ||
7521 o3->op_type == OP_HELEM ||
7522 o3->op_type == OP_AELEM ||
7523 o3->op_type == OP_THREADSV)
7526 bad_type(arg, "scalar", gv_ename(namegv), o3);
7529 if (o3->op_type == OP_RV2AV ||
7530 o3->op_type == OP_PADAV)
7533 bad_type(arg, "array", gv_ename(namegv), o3);
7536 if (o3->op_type == OP_RV2HV ||
7537 o3->op_type == OP_PADHV)
7540 bad_type(arg, "hash", gv_ename(namegv), o3);
7545 OP* const sib = kid->op_sibling;
7546 kid->op_sibling = 0;
7547 o2 = newUNOP(OP_REFGEN, 0, kid);
7548 o2->op_sibling = sib;
7549 prev->op_sibling = o2;
7551 if (contextclass && e) {
7566 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
7567 gv_ename(namegv), (void*)cv);
7572 mod(o2, OP_ENTERSUB);
7574 o2 = o2->op_sibling;
7576 if (o2 == cvop && proto && *proto == '_') {
7577 /* generate an access to $_ */
7579 o2->op_sibling = prev->op_sibling;
7580 prev->op_sibling = o2; /* instead of cvop */
7582 if (proto && !optional && proto_end > proto &&
7583 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
7584 return too_few_arguments(o, gv_ename(namegv));
7587 OP * const oldo = o;
7591 o=newSVOP(OP_CONST, 0, newSViv(0));
7592 op_getmad(oldo,o,'O');
7598 Perl_ck_svconst(pTHX_ OP *o)
7600 PERL_UNUSED_CONTEXT;
7601 SvREADONLY_on(cSVOPo->op_sv);
7606 Perl_ck_chdir(pTHX_ OP *o)
7608 if (o->op_flags & OPf_KIDS) {
7609 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7611 if (kid && kid->op_type == OP_CONST &&
7612 (kid->op_private & OPpCONST_BARE))
7614 o->op_flags |= OPf_SPECIAL;
7615 kid->op_private &= ~OPpCONST_STRICT;
7622 Perl_ck_trunc(pTHX_ OP *o)
7624 if (o->op_flags & OPf_KIDS) {
7625 SVOP *kid = (SVOP*)cUNOPo->op_first;
7627 if (kid->op_type == OP_NULL)
7628 kid = (SVOP*)kid->op_sibling;
7629 if (kid && kid->op_type == OP_CONST &&
7630 (kid->op_private & OPpCONST_BARE))
7632 o->op_flags |= OPf_SPECIAL;
7633 kid->op_private &= ~OPpCONST_STRICT;
7640 Perl_ck_unpack(pTHX_ OP *o)
7642 OP *kid = cLISTOPo->op_first;
7643 if (kid->op_sibling) {
7644 kid = kid->op_sibling;
7645 if (!kid->op_sibling)
7646 kid->op_sibling = newDEFSVOP();
7652 Perl_ck_substr(pTHX_ OP *o)
7655 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
7656 OP *kid = cLISTOPo->op_first;
7658 if (kid->op_type == OP_NULL)
7659 kid = kid->op_sibling;
7661 kid->op_flags |= OPf_MOD;
7667 /* A peephole optimizer. We visit the ops in the order they're to execute.
7668 * See the comments at the top of this file for more details about when
7669 * peep() is called */
7672 Perl_peep(pTHX_ register OP *o)
7675 register OP* oldop = NULL;
7677 if (!o || o->op_opt)
7681 SAVEVPTR(PL_curcop);
7682 for (; o; o = o->op_next) {
7686 switch (o->op_type) {
7690 PL_curcop = ((COP*)o); /* for warnings */
7695 if (cSVOPo->op_private & OPpCONST_STRICT)
7696 no_bareword_allowed(o);
7698 case OP_METHOD_NAMED:
7699 /* Relocate sv to the pad for thread safety.
7700 * Despite being a "constant", the SV is written to,
7701 * for reference counts, sv_upgrade() etc. */
7703 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
7704 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
7705 /* If op_sv is already a PADTMP then it is being used by
7706 * some pad, so make a copy. */
7707 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
7708 SvREADONLY_on(PAD_SVl(ix));
7709 SvREFCNT_dec(cSVOPo->op_sv);
7711 else if (o->op_type == OP_CONST
7712 && cSVOPo->op_sv == &PL_sv_undef) {
7713 /* PL_sv_undef is hack - it's unsafe to store it in the
7714 AV that is the pad, because av_fetch treats values of
7715 PL_sv_undef as a "free" AV entry and will merrily
7716 replace them with a new SV, causing pad_alloc to think
7717 that this pad slot is free. (When, clearly, it is not)
7719 SvOK_off(PAD_SVl(ix));
7720 SvPADTMP_on(PAD_SVl(ix));
7721 SvREADONLY_on(PAD_SVl(ix));
7724 SvREFCNT_dec(PAD_SVl(ix));
7725 SvPADTMP_on(cSVOPo->op_sv);
7726 PAD_SETSV(ix, cSVOPo->op_sv);
7727 /* XXX I don't know how this isn't readonly already. */
7728 SvREADONLY_on(PAD_SVl(ix));
7730 cSVOPo->op_sv = NULL;
7738 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
7739 if (o->op_next->op_private & OPpTARGET_MY) {
7740 if (o->op_flags & OPf_STACKED) /* chained concats */
7741 goto ignore_optimization;
7743 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
7744 o->op_targ = o->op_next->op_targ;
7745 o->op_next->op_targ = 0;
7746 o->op_private |= OPpTARGET_MY;
7749 op_null(o->op_next);
7751 ignore_optimization:
7755 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
7757 break; /* Scalar stub must produce undef. List stub is noop */
7761 if (o->op_targ == OP_NEXTSTATE
7762 || o->op_targ == OP_DBSTATE
7763 || o->op_targ == OP_SETSTATE)
7765 PL_curcop = ((COP*)o);
7767 /* XXX: We avoid setting op_seq here to prevent later calls
7768 to peep() from mistakenly concluding that optimisation
7769 has already occurred. This doesn't fix the real problem,
7770 though (See 20010220.007). AMS 20010719 */
7771 /* op_seq functionality is now replaced by op_opt */
7772 if (oldop && o->op_next) {
7773 oldop->op_next = o->op_next;
7781 if (oldop && o->op_next) {
7782 oldop->op_next = o->op_next;
7790 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
7791 OP* const pop = (o->op_type == OP_PADAV) ?
7792 o->op_next : o->op_next->op_next;
7794 if (pop && pop->op_type == OP_CONST &&
7795 ((PL_op = pop->op_next)) &&
7796 pop->op_next->op_type == OP_AELEM &&
7797 !(pop->op_next->op_private &
7798 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
7799 (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
7804 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
7805 no_bareword_allowed(pop);
7806 if (o->op_type == OP_GV)
7807 op_null(o->op_next);
7808 op_null(pop->op_next);
7810 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
7811 o->op_next = pop->op_next->op_next;
7812 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
7813 o->op_private = (U8)i;
7814 if (o->op_type == OP_GV) {
7819 o->op_flags |= OPf_SPECIAL;
7820 o->op_type = OP_AELEMFAST;
7826 if (o->op_next->op_type == OP_RV2SV) {
7827 if (!(o->op_next->op_private & OPpDEREF)) {
7828 op_null(o->op_next);
7829 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
7831 o->op_next = o->op_next->op_next;
7832 o->op_type = OP_GVSV;
7833 o->op_ppaddr = PL_ppaddr[OP_GVSV];
7836 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
7837 GV * const gv = cGVOPo_gv;
7838 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
7839 /* XXX could check prototype here instead of just carping */
7840 SV * const sv = sv_newmortal();
7841 gv_efullname3(sv, gv, NULL);
7842 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
7843 "%"SVf"() called too early to check prototype",
7847 else if (o->op_next->op_type == OP_READLINE
7848 && o->op_next->op_next->op_type == OP_CONCAT
7849 && (o->op_next->op_next->op_flags & OPf_STACKED))
7851 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
7852 o->op_type = OP_RCATLINE;
7853 o->op_flags |= OPf_STACKED;
7854 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
7855 op_null(o->op_next->op_next);
7856 op_null(o->op_next);
7873 while (cLOGOP->op_other->op_type == OP_NULL)
7874 cLOGOP->op_other = cLOGOP->op_other->op_next;
7875 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
7881 while (cLOOP->op_redoop->op_type == OP_NULL)
7882 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
7883 peep(cLOOP->op_redoop);
7884 while (cLOOP->op_nextop->op_type == OP_NULL)
7885 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
7886 peep(cLOOP->op_nextop);
7887 while (cLOOP->op_lastop->op_type == OP_NULL)
7888 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
7889 peep(cLOOP->op_lastop);
7896 while (cPMOP->op_pmreplstart &&
7897 cPMOP->op_pmreplstart->op_type == OP_NULL)
7898 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
7899 peep(cPMOP->op_pmreplstart);
7904 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
7905 && ckWARN(WARN_SYNTAX))
7907 if (o->op_next->op_sibling) {
7908 const OPCODE type = o->op_next->op_sibling->op_type;
7909 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
7910 const line_t oldline = CopLINE(PL_curcop);
7911 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
7912 Perl_warner(aTHX_ packWARN(WARN_EXEC),
7913 "Statement unlikely to be reached");
7914 Perl_warner(aTHX_ packWARN(WARN_EXEC),
7915 "\t(Maybe you meant system() when you said exec()?)\n");
7916 CopLINE_set(PL_curcop, oldline);
7927 const char *key = NULL;
7932 if (((BINOP*)o)->op_last->op_type != OP_CONST)
7935 /* Make the CONST have a shared SV */
7936 svp = cSVOPx_svp(((BINOP*)o)->op_last);
7937 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
7938 key = SvPV_const(sv, keylen);
7939 lexname = newSVpvn_share(key,
7940 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
7946 if ((o->op_private & (OPpLVAL_INTRO)))
7949 rop = (UNOP*)((BINOP*)o)->op_first;
7950 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7952 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7953 if (!SvPAD_TYPED(lexname))
7955 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
7956 if (!fields || !GvHV(*fields))
7958 key = SvPV_const(*svp, keylen);
7959 if (!hv_fetch(GvHV(*fields), key,
7960 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
7962 Perl_croak(aTHX_ "No such class field \"%s\" "
7963 "in variable %s of type %s",
7964 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
7977 SVOP *first_key_op, *key_op;
7979 if ((o->op_private & (OPpLVAL_INTRO))
7980 /* I bet there's always a pushmark... */
7981 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
7982 /* hmmm, no optimization if list contains only one key. */
7984 rop = (UNOP*)((LISTOP*)o)->op_last;
7985 if (rop->op_type != OP_RV2HV)
7987 if (rop->op_first->op_type == OP_PADSV)
7988 /* @$hash{qw(keys here)} */
7989 rop = (UNOP*)rop->op_first;
7991 /* @{$hash}{qw(keys here)} */
7992 if (rop->op_first->op_type == OP_SCOPE
7993 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
7995 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
8001 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
8002 if (!SvPAD_TYPED(lexname))
8004 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8005 if (!fields || !GvHV(*fields))
8007 /* Again guessing that the pushmark can be jumped over.... */
8008 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
8009 ->op_first->op_sibling;
8010 for (key_op = first_key_op; key_op;
8011 key_op = (SVOP*)key_op->op_sibling) {
8012 if (key_op->op_type != OP_CONST)
8014 svp = cSVOPx_svp(key_op);
8015 key = SvPV_const(*svp, keylen);
8016 if (!hv_fetch(GvHV(*fields), key,
8017 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8019 Perl_croak(aTHX_ "No such class field \"%s\" "
8020 "in variable %s of type %s",
8021 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
8028 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
8032 /* check that RHS of sort is a single plain array */
8033 OP *oright = cUNOPo->op_first;
8034 if (!oright || oright->op_type != OP_PUSHMARK)
8037 /* reverse sort ... can be optimised. */
8038 if (!cUNOPo->op_sibling) {
8039 /* Nothing follows us on the list. */
8040 OP * const reverse = o->op_next;
8042 if (reverse->op_type == OP_REVERSE &&
8043 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
8044 OP * const pushmark = cUNOPx(reverse)->op_first;
8045 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
8046 && (cUNOPx(pushmark)->op_sibling == o)) {
8047 /* reverse -> pushmark -> sort */
8048 o->op_private |= OPpSORT_REVERSE;
8050 pushmark->op_next = oright->op_next;
8056 /* make @a = sort @a act in-place */
8060 oright = cUNOPx(oright)->op_sibling;
8063 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
8064 oright = cUNOPx(oright)->op_sibling;
8068 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
8069 || oright->op_next != o
8070 || (oright->op_private & OPpLVAL_INTRO)
8074 /* o2 follows the chain of op_nexts through the LHS of the
8075 * assign (if any) to the aassign op itself */
8077 if (!o2 || o2->op_type != OP_NULL)
8080 if (!o2 || o2->op_type != OP_PUSHMARK)
8083 if (o2 && o2->op_type == OP_GV)
8086 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
8087 || (o2->op_private & OPpLVAL_INTRO)
8092 if (!o2 || o2->op_type != OP_NULL)
8095 if (!o2 || o2->op_type != OP_AASSIGN
8096 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
8099 /* check that the sort is the first arg on RHS of assign */
8101 o2 = cUNOPx(o2)->op_first;
8102 if (!o2 || o2->op_type != OP_NULL)
8104 o2 = cUNOPx(o2)->op_first;
8105 if (!o2 || o2->op_type != OP_PUSHMARK)
8107 if (o2->op_sibling != o)
8110 /* check the array is the same on both sides */
8111 if (oleft->op_type == OP_RV2AV) {
8112 if (oright->op_type != OP_RV2AV
8113 || !cUNOPx(oright)->op_first
8114 || cUNOPx(oright)->op_first->op_type != OP_GV
8115 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
8116 cGVOPx_gv(cUNOPx(oright)->op_first)
8120 else if (oright->op_type != OP_PADAV
8121 || oright->op_targ != oleft->op_targ
8125 /* transfer MODishness etc from LHS arg to RHS arg */
8126 oright->op_flags = oleft->op_flags;
8127 o->op_private |= OPpSORT_INPLACE;
8129 /* excise push->gv->rv2av->null->aassign */
8130 o2 = o->op_next->op_next;
8131 op_null(o2); /* PUSHMARK */
8133 if (o2->op_type == OP_GV) {
8134 op_null(o2); /* GV */
8137 op_null(o2); /* RV2AV or PADAV */
8138 o2 = o2->op_next->op_next;
8139 op_null(o2); /* AASSIGN */
8141 o->op_next = o2->op_next;
8147 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
8149 LISTOP *enter, *exlist;
8152 enter = (LISTOP *) o->op_next;
8155 if (enter->op_type == OP_NULL) {
8156 enter = (LISTOP *) enter->op_next;
8160 /* for $a (...) will have OP_GV then OP_RV2GV here.
8161 for (...) just has an OP_GV. */
8162 if (enter->op_type == OP_GV) {
8163 gvop = (OP *) enter;
8164 enter = (LISTOP *) enter->op_next;
8167 if (enter->op_type == OP_RV2GV) {
8168 enter = (LISTOP *) enter->op_next;
8174 if (enter->op_type != OP_ENTERITER)
8177 iter = enter->op_next;
8178 if (!iter || iter->op_type != OP_ITER)
8181 expushmark = enter->op_first;
8182 if (!expushmark || expushmark->op_type != OP_NULL
8183 || expushmark->op_targ != OP_PUSHMARK)
8186 exlist = (LISTOP *) expushmark->op_sibling;
8187 if (!exlist || exlist->op_type != OP_NULL
8188 || exlist->op_targ != OP_LIST)
8191 if (exlist->op_last != o) {
8192 /* Mmm. Was expecting to point back to this op. */
8195 theirmark = exlist->op_first;
8196 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
8199 if (theirmark->op_sibling != o) {
8200 /* There's something between the mark and the reverse, eg
8201 for (1, reverse (...))
8206 ourmark = ((LISTOP *)o)->op_first;
8207 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
8210 ourlast = ((LISTOP *)o)->op_last;
8211 if (!ourlast || ourlast->op_next != o)
8214 rv2av = ourmark->op_sibling;
8215 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
8216 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
8217 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
8218 /* We're just reversing a single array. */
8219 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
8220 enter->op_flags |= OPf_STACKED;
8223 /* We don't have control over who points to theirmark, so sacrifice
8225 theirmark->op_next = ourmark->op_next;
8226 theirmark->op_flags = ourmark->op_flags;
8227 ourlast->op_next = gvop ? gvop : (OP *) enter;
8230 enter->op_private |= OPpITER_REVERSED;
8231 iter->op_private |= OPpITER_REVERSED;
8238 UNOP *refgen, *rv2cv;
8241 /* I do not understand this, but if o->op_opt isn't set to 1,
8242 various tests in ext/B/t/bytecode.t fail with no readily
8248 if ((o->op_flags && OPf_WANT) != OPf_WANT_VOID)
8251 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
8254 rv2gv = ((BINOP *)o)->op_last;
8255 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
8258 refgen = (UNOP *)((BINOP *)o)->op_first;
8260 if (!refgen || refgen->op_type != OP_REFGEN)
8263 exlist = (LISTOP *)refgen->op_first;
8264 if (!exlist || exlist->op_type != OP_NULL
8265 || exlist->op_targ != OP_LIST)
8268 if (exlist->op_first->op_type != OP_PUSHMARK)
8271 rv2cv = (UNOP*)exlist->op_last;
8273 if (rv2cv->op_type != OP_RV2CV)
8276 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
8277 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
8278 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
8280 o->op_private |= OPpASSIGN_CV_TO_GV;
8281 rv2gv->op_private |= OPpDONT_INIT_GV;
8282 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
8298 Perl_custom_op_name(pTHX_ const OP* o)
8301 const IV index = PTR2IV(o->op_ppaddr);
8305 if (!PL_custom_op_names) /* This probably shouldn't happen */
8306 return (char *)PL_op_name[OP_CUSTOM];
8308 keysv = sv_2mortal(newSViv(index));
8310 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
8312 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
8314 return SvPV_nolen(HeVAL(he));
8318 Perl_custom_op_desc(pTHX_ const OP* o)
8321 const IV index = PTR2IV(o->op_ppaddr);
8325 if (!PL_custom_op_descs)
8326 return (char *)PL_op_desc[OP_CUSTOM];
8328 keysv = sv_2mortal(newSViv(index));
8330 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
8332 return (char *)PL_op_desc[OP_CUSTOM];
8334 return SvPV_nolen(HeVAL(he));
8339 /* Efficient sub that returns a constant scalar value. */
8341 const_sv_xsub(pTHX_ CV* cv)
8348 Perl_croak(aTHX_ "usage: %s::%s()",
8349 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
8353 ST(0) = (SV*)XSANY.any_ptr;
8359 * c-indentation-style: bsd
8361 * indent-tabs-mode: t
8364 * ex: set ts=8 sts=4 sw=4 noet: