3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 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 PerlMemShared_free(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;
1557 o->op_flags |= OPf_REF;
1560 if (type == OP_DEFINED)
1561 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1562 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1568 o->op_flags |= OPf_REF;
1573 if (!(o->op_flags & OPf_KIDS))
1575 doref(cBINOPo->op_first, type, set_op_ref);
1579 doref(cBINOPo->op_first, o->op_type, set_op_ref);
1580 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1581 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1582 : type == OP_RV2HV ? OPpDEREF_HV
1584 o->op_flags |= OPf_MOD;
1594 if (!(o->op_flags & OPf_KIDS))
1596 doref(cLISTOPo->op_last, type, set_op_ref);
1606 S_dup_attrlist(pTHX_ OP *o)
1611 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1612 * where the first kid is OP_PUSHMARK and the remaining ones
1613 * are OP_CONST. We need to push the OP_CONST values.
1615 if (o->op_type == OP_CONST)
1616 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
1618 else if (o->op_type == OP_NULL)
1622 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1624 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1625 if (o->op_type == OP_CONST)
1626 rop = append_elem(OP_LIST, rop,
1627 newSVOP(OP_CONST, o->op_flags,
1628 SvREFCNT_inc_NN(cSVOPo->op_sv)));
1635 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1640 /* fake up C<use attributes $pkg,$rv,@attrs> */
1641 ENTER; /* need to protect against side-effects of 'use' */
1643 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1645 #define ATTRSMODULE "attributes"
1646 #define ATTRSMODULE_PM "attributes.pm"
1649 /* Don't force the C<use> if we don't need it. */
1650 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
1651 if (svp && *svp != &PL_sv_undef)
1652 NOOP; /* already in %INC */
1654 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1655 newSVpvs(ATTRSMODULE), NULL);
1658 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1659 newSVpvs(ATTRSMODULE),
1661 prepend_elem(OP_LIST,
1662 newSVOP(OP_CONST, 0, stashsv),
1663 prepend_elem(OP_LIST,
1664 newSVOP(OP_CONST, 0,
1666 dup_attrlist(attrs))));
1672 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1675 OP *pack, *imop, *arg;
1681 assert(target->op_type == OP_PADSV ||
1682 target->op_type == OP_PADHV ||
1683 target->op_type == OP_PADAV);
1685 /* Ensure that attributes.pm is loaded. */
1686 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1688 /* Need package name for method call. */
1689 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
1691 /* Build up the real arg-list. */
1692 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1694 arg = newOP(OP_PADSV, 0);
1695 arg->op_targ = target->op_targ;
1696 arg = prepend_elem(OP_LIST,
1697 newSVOP(OP_CONST, 0, stashsv),
1698 prepend_elem(OP_LIST,
1699 newUNOP(OP_REFGEN, 0,
1700 mod(arg, OP_REFGEN)),
1701 dup_attrlist(attrs)));
1703 /* Fake up a method call to import */
1704 meth = newSVpvs_share("import");
1705 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1706 append_elem(OP_LIST,
1707 prepend_elem(OP_LIST, pack, list(arg)),
1708 newSVOP(OP_METHOD_NAMED, 0, meth)));
1709 imop->op_private |= OPpENTERSUB_NOMOD;
1711 /* Combine the ops. */
1712 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1716 =notfor apidoc apply_attrs_string
1718 Attempts to apply a list of attributes specified by the C<attrstr> and
1719 C<len> arguments to the subroutine identified by the C<cv> argument which
1720 is expected to be associated with the package identified by the C<stashpv>
1721 argument (see L<attributes>). It gets this wrong, though, in that it
1722 does not correctly identify the boundaries of the individual attribute
1723 specifications within C<attrstr>. This is not really intended for the
1724 public API, but has to be listed here for systems such as AIX which
1725 need an explicit export list for symbols. (It's called from XS code
1726 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1727 to respect attribute syntax properly would be welcome.
1733 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
1734 const char *attrstr, STRLEN len)
1739 len = strlen(attrstr);
1743 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1745 const char * const sstr = attrstr;
1746 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1747 attrs = append_elem(OP_LIST, attrs,
1748 newSVOP(OP_CONST, 0,
1749 newSVpvn(sstr, attrstr-sstr)));
1753 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1754 newSVpvs(ATTRSMODULE),
1755 NULL, prepend_elem(OP_LIST,
1756 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1757 prepend_elem(OP_LIST,
1758 newSVOP(OP_CONST, 0,
1764 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
1769 if (!o || PL_error_count)
1773 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
1774 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
1778 if (type == OP_LIST) {
1780 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1781 my_kid(kid, attrs, imopsp);
1782 } else if (type == OP_UNDEF
1788 } else if (type == OP_RV2SV || /* "our" declaration */
1790 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1791 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1792 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1794 PL_in_my == KEY_our ? "our" : PL_in_my == KEY_state ? "state" : "my"));
1796 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
1798 PL_in_my_stash = NULL;
1799 apply_attrs(GvSTASH(gv),
1800 (type == OP_RV2SV ? GvSV(gv) :
1801 type == OP_RV2AV ? (SV*)GvAV(gv) :
1802 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1805 o->op_private |= OPpOUR_INTRO;
1808 else if (type != OP_PADSV &&
1811 type != OP_PUSHMARK)
1813 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1815 PL_in_my == KEY_our ? "our" : PL_in_my == KEY_state ? "state" : "my"));
1818 else if (attrs && type != OP_PUSHMARK) {
1822 PL_in_my_stash = NULL;
1824 /* check for C<my Dog $spot> when deciding package */
1825 stash = PAD_COMPNAME_TYPE(o->op_targ);
1827 stash = PL_curstash;
1828 apply_attrs_my(stash, o, attrs, imopsp);
1830 o->op_flags |= OPf_MOD;
1831 o->op_private |= OPpLVAL_INTRO;
1832 if (PL_in_my == KEY_state)
1833 o->op_private |= OPpPAD_STATE;
1838 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1842 int maybe_scalar = 0;
1844 /* [perl #17376]: this appears to be premature, and results in code such as
1845 C< our(%x); > executing in list mode rather than void mode */
1847 if (o->op_flags & OPf_PARENS)
1857 o = my_kid(o, attrs, &rops);
1859 if (maybe_scalar && o->op_type == OP_PADSV) {
1860 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
1861 o->op_private |= OPpLVAL_INTRO;
1864 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
1867 PL_in_my_stash = NULL;
1872 Perl_my(pTHX_ OP *o)
1874 return my_attrs(o, NULL);
1878 Perl_sawparens(pTHX_ OP *o)
1880 PERL_UNUSED_CONTEXT;
1882 o->op_flags |= OPf_PARENS;
1887 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
1891 const OPCODE ltype = left->op_type;
1892 const OPCODE rtype = right->op_type;
1894 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
1895 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
1897 const char * const desc
1898 = PL_op_desc[(rtype == OP_SUBST || rtype == OP_TRANS)
1899 ? (int)rtype : OP_MATCH];
1900 const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV)
1901 ? "@array" : "%hash");
1902 Perl_warner(aTHX_ packWARN(WARN_MISC),
1903 "Applying %s to %s will act on scalar(%s)",
1904 desc, sample, sample);
1907 if (rtype == OP_CONST &&
1908 cSVOPx(right)->op_private & OPpCONST_BARE &&
1909 cSVOPx(right)->op_private & OPpCONST_STRICT)
1911 no_bareword_allowed(right);
1914 ismatchop = rtype == OP_MATCH ||
1915 rtype == OP_SUBST ||
1917 if (ismatchop && right->op_private & OPpTARGET_MY) {
1919 right->op_private &= ~OPpTARGET_MY;
1921 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
1924 right->op_flags |= OPf_STACKED;
1925 if (rtype != OP_MATCH &&
1926 ! (rtype == OP_TRANS &&
1927 right->op_private & OPpTRANS_IDENTICAL))
1928 newleft = mod(left, rtype);
1931 if (right->op_type == OP_TRANS)
1932 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
1934 o = prepend_elem(rtype, scalar(newleft), right);
1936 return newUNOP(OP_NOT, 0, scalar(o));
1940 return bind_match(type, left,
1941 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
1945 Perl_invert(pTHX_ OP *o)
1949 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
1953 Perl_scope(pTHX_ OP *o)
1957 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
1958 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
1959 o->op_type = OP_LEAVE;
1960 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
1962 else if (o->op_type == OP_LINESEQ) {
1964 o->op_type = OP_SCOPE;
1965 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
1966 kid = ((LISTOP*)o)->op_first;
1967 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
1970 /* The following deals with things like 'do {1 for 1}' */
1971 kid = kid->op_sibling;
1973 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
1978 o = newLISTOP(OP_SCOPE, 0, o, NULL);
1984 Perl_block_start(pTHX_ int full)
1987 const int retval = PL_savestack_ix;
1988 pad_block_start(full);
1990 PL_hints &= ~HINT_BLOCK_SCOPE;
1991 SAVECOMPILEWARNINGS();
1992 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
1997 Perl_block_end(pTHX_ I32 floor, OP *seq)
2000 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2001 OP* const retval = scalarseq(seq);
2003 CopHINTS_set(&PL_compiling, PL_hints);
2005 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2014 const PADOFFSET offset = pad_findmy("$_");
2015 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
2016 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2019 OP * const o = newOP(OP_PADSV, 0);
2020 o->op_targ = offset;
2026 Perl_newPROG(pTHX_ OP *o)
2032 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2033 ((PL_in_eval & EVAL_KEEPERR)
2034 ? OPf_SPECIAL : 0), o);
2035 PL_eval_start = linklist(PL_eval_root);
2036 PL_eval_root->op_private |= OPpREFCOUNTED;
2037 OpREFCNT_set(PL_eval_root, 1);
2038 PL_eval_root->op_next = 0;
2039 CALL_PEEP(PL_eval_start);
2042 if (o->op_type == OP_STUB) {
2043 PL_comppad_name = 0;
2045 S_op_destroy(aTHX_ o);
2048 PL_main_root = scope(sawparens(scalarvoid(o)));
2049 PL_curcop = &PL_compiling;
2050 PL_main_start = LINKLIST(PL_main_root);
2051 PL_main_root->op_private |= OPpREFCOUNTED;
2052 OpREFCNT_set(PL_main_root, 1);
2053 PL_main_root->op_next = 0;
2054 CALL_PEEP(PL_main_start);
2057 /* Register with debugger */
2059 CV * const cv = get_cv("DB::postponed", FALSE);
2063 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2065 call_sv((SV*)cv, G_DISCARD);
2072 Perl_localize(pTHX_ OP *o, I32 lex)
2075 if (o->op_flags & OPf_PARENS)
2076 /* [perl #17376]: this appears to be premature, and results in code such as
2077 C< our(%x); > executing in list mode rather than void mode */
2084 if ( PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ','
2085 && ckWARN(WARN_PARENTHESIS))
2087 char *s = PL_bufptr;
2090 /* some heuristics to detect a potential error */
2091 while (*s && (strchr(", \t\n", *s)))
2095 if (*s && strchr("@$%*", *s) && *++s
2096 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2099 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2101 while (*s && (strchr(", \t\n", *s)))
2107 if (sigil && (*s == ';' || *s == '=')) {
2108 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2109 "Parentheses missing around \"%s\" list",
2110 lex ? (PL_in_my == KEY_our ? "our" : PL_in_my == KEY_state ? "state" : "my")
2118 o = mod(o, OP_NULL); /* a bit kludgey */
2120 PL_in_my_stash = NULL;
2125 Perl_jmaybe(pTHX_ OP *o)
2127 if (o->op_type == OP_LIST) {
2129 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2130 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2136 Perl_fold_constants(pTHX_ register OP *o)
2141 VOL I32 type = o->op_type;
2146 SV * const oldwarnhook = PL_warnhook;
2147 SV * const olddiehook = PL_diehook;
2150 if (PL_opargs[type] & OA_RETSCALAR)
2152 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2153 o->op_targ = pad_alloc(type, SVs_PADTMP);
2155 /* integerize op, unless it happens to be C<-foo>.
2156 * XXX should pp_i_negate() do magic string negation instead? */
2157 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2158 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2159 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2161 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2164 if (!(PL_opargs[type] & OA_FOLDCONST))
2169 /* XXX might want a ck_negate() for this */
2170 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2181 /* XXX what about the numeric ops? */
2182 if (PL_hints & HINT_LOCALE)
2187 goto nope; /* Don't try to run w/ errors */
2189 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2190 const OPCODE type = curop->op_type;
2191 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2193 type != OP_SCALAR &&
2195 type != OP_PUSHMARK)
2201 curop = LINKLIST(o);
2202 old_next = o->op_next;
2206 oldscope = PL_scopestack_ix;
2207 create_eval_scope(G_FAKINGEVAL);
2209 PL_warnhook = PERL_WARNHOOK_FATAL;
2216 sv = *(PL_stack_sp--);
2217 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2218 pad_swipe(o->op_targ, FALSE);
2219 else if (SvTEMP(sv)) { /* grab mortal temp? */
2220 SvREFCNT_inc_simple_void(sv);
2225 /* Something tried to die. Abandon constant folding. */
2226 /* Pretend the error never happened. */
2227 sv_setpvn(ERRSV,"",0);
2228 o->op_next = old_next;
2232 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
2233 PL_warnhook = oldwarnhook;
2234 PL_diehook = olddiehook;
2235 /* XXX note that this croak may fail as we've already blown away
2236 * the stack - eg any nested evals */
2237 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
2240 PL_warnhook = oldwarnhook;
2241 PL_diehook = olddiehook;
2243 if (PL_scopestack_ix > oldscope)
2244 delete_eval_scope();
2253 if (type == OP_RV2GV)
2254 newop = newGVOP(OP_GV, 0, (GV*)sv);
2256 newop = newSVOP(OP_CONST, 0, (SV*)sv);
2257 op_getmad(o,newop,'f');
2265 Perl_gen_constant_list(pTHX_ register OP *o)
2269 const I32 oldtmps_floor = PL_tmps_floor;
2273 return o; /* Don't attempt to run with errors */
2275 PL_op = curop = LINKLIST(o);
2281 assert (!(curop->op_flags & OPf_SPECIAL));
2282 assert(curop->op_type == OP_RANGE);
2284 PL_tmps_floor = oldtmps_floor;
2286 o->op_type = OP_RV2AV;
2287 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2288 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2289 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2290 o->op_opt = 0; /* needs to be revisited in peep() */
2291 curop = ((UNOP*)o)->op_first;
2292 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
2294 op_getmad(curop,o,'O');
2303 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2306 if (!o || o->op_type != OP_LIST)
2307 o = newLISTOP(OP_LIST, 0, o, NULL);
2309 o->op_flags &= ~OPf_WANT;
2311 if (!(PL_opargs[type] & OA_MARK))
2312 op_null(cLISTOPo->op_first);
2314 o->op_type = (OPCODE)type;
2315 o->op_ppaddr = PL_ppaddr[type];
2316 o->op_flags |= flags;
2318 o = CHECKOP(type, o);
2319 if (o->op_type != (unsigned)type)
2322 return fold_constants(o);
2325 /* List constructors */
2328 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2336 if (first->op_type != (unsigned)type
2337 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2339 return newLISTOP(type, 0, first, last);
2342 if (first->op_flags & OPf_KIDS)
2343 ((LISTOP*)first)->op_last->op_sibling = last;
2345 first->op_flags |= OPf_KIDS;
2346 ((LISTOP*)first)->op_first = last;
2348 ((LISTOP*)first)->op_last = last;
2353 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2361 if (first->op_type != (unsigned)type)
2362 return prepend_elem(type, (OP*)first, (OP*)last);
2364 if (last->op_type != (unsigned)type)
2365 return append_elem(type, (OP*)first, (OP*)last);
2367 first->op_last->op_sibling = last->op_first;
2368 first->op_last = last->op_last;
2369 first->op_flags |= (last->op_flags & OPf_KIDS);
2372 if (last->op_first && first->op_madprop) {
2373 MADPROP *mp = last->op_first->op_madprop;
2375 while (mp->mad_next)
2377 mp->mad_next = first->op_madprop;
2380 last->op_first->op_madprop = first->op_madprop;
2383 first->op_madprop = last->op_madprop;
2384 last->op_madprop = 0;
2387 S_op_destroy(aTHX_ (OP*)last);
2393 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2401 if (last->op_type == (unsigned)type) {
2402 if (type == OP_LIST) { /* already a PUSHMARK there */
2403 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2404 ((LISTOP*)last)->op_first->op_sibling = first;
2405 if (!(first->op_flags & OPf_PARENS))
2406 last->op_flags &= ~OPf_PARENS;
2409 if (!(last->op_flags & OPf_KIDS)) {
2410 ((LISTOP*)last)->op_last = first;
2411 last->op_flags |= OPf_KIDS;
2413 first->op_sibling = ((LISTOP*)last)->op_first;
2414 ((LISTOP*)last)->op_first = first;
2416 last->op_flags |= OPf_KIDS;
2420 return newLISTOP(type, 0, first, last);
2428 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2431 Newxz(tk, 1, TOKEN);
2432 tk->tk_type = (OPCODE)optype;
2433 tk->tk_type = 12345;
2435 tk->tk_mad = madprop;
2440 Perl_token_free(pTHX_ TOKEN* tk)
2442 if (tk->tk_type != 12345)
2444 mad_free(tk->tk_mad);
2449 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2453 if (tk->tk_type != 12345) {
2454 Perl_warner(aTHX_ packWARN(WARN_MISC),
2455 "Invalid TOKEN object ignored");
2462 /* faked up qw list? */
2464 tm->mad_type == MAD_SV &&
2465 SvPVX((SV*)tm->mad_val)[0] == 'q')
2472 /* pretend constant fold didn't happen? */
2473 if (mp->mad_key == 'f' &&
2474 (o->op_type == OP_CONST ||
2475 o->op_type == OP_GV) )
2477 token_getmad(tk,(OP*)mp->mad_val,slot);
2491 if (mp->mad_key == 'X')
2492 mp->mad_key = slot; /* just change the first one */
2502 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
2511 /* pretend constant fold didn't happen? */
2512 if (mp->mad_key == 'f' &&
2513 (o->op_type == OP_CONST ||
2514 o->op_type == OP_GV) )
2516 op_getmad(from,(OP*)mp->mad_val,slot);
2523 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
2526 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
2532 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
2541 /* pretend constant fold didn't happen? */
2542 if (mp->mad_key == 'f' &&
2543 (o->op_type == OP_CONST ||
2544 o->op_type == OP_GV) )
2546 op_getmad(from,(OP*)mp->mad_val,slot);
2553 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
2556 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
2560 PerlIO_printf(PerlIO_stderr(),
2561 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
2567 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
2585 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
2589 addmad(tm, &(o->op_madprop), slot);
2593 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
2614 Perl_newMADsv(pTHX_ char key, SV* sv)
2616 return newMADPROP(key, MAD_SV, sv, 0);
2620 Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
2623 Newxz(mp, 1, MADPROP);
2626 mp->mad_vlen = vlen;
2627 mp->mad_type = type;
2629 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
2634 Perl_mad_free(pTHX_ MADPROP* mp)
2636 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
2640 mad_free(mp->mad_next);
2641 /* if (PL_lex_state != LEX_NOTPARSING && mp->mad_vlen)
2642 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
2643 switch (mp->mad_type) {
2647 Safefree((char*)mp->mad_val);
2650 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
2651 op_free((OP*)mp->mad_val);
2654 sv_free((SV*)mp->mad_val);
2657 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
2666 Perl_newNULLLIST(pTHX)
2668 return newOP(OP_STUB, 0);
2672 Perl_force_list(pTHX_ OP *o)
2674 if (!o || o->op_type != OP_LIST)
2675 o = newLISTOP(OP_LIST, 0, o, NULL);
2681 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2686 NewOp(1101, listop, 1, LISTOP);
2688 listop->op_type = (OPCODE)type;
2689 listop->op_ppaddr = PL_ppaddr[type];
2692 listop->op_flags = (U8)flags;
2696 else if (!first && last)
2699 first->op_sibling = last;
2700 listop->op_first = first;
2701 listop->op_last = last;
2702 if (type == OP_LIST) {
2703 OP* const pushop = newOP(OP_PUSHMARK, 0);
2704 pushop->op_sibling = first;
2705 listop->op_first = pushop;
2706 listop->op_flags |= OPf_KIDS;
2708 listop->op_last = pushop;
2711 return CHECKOP(type, listop);
2715 Perl_newOP(pTHX_ I32 type, I32 flags)
2719 NewOp(1101, o, 1, OP);
2720 o->op_type = (OPCODE)type;
2721 o->op_ppaddr = PL_ppaddr[type];
2722 o->op_flags = (U8)flags;
2724 o->op_latefreed = 0;
2728 o->op_private = (U8)(0 | (flags >> 8));
2729 if (PL_opargs[type] & OA_RETSCALAR)
2731 if (PL_opargs[type] & OA_TARGET)
2732 o->op_targ = pad_alloc(type, SVs_PADTMP);
2733 return CHECKOP(type, o);
2737 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2743 first = newOP(OP_STUB, 0);
2744 if (PL_opargs[type] & OA_MARK)
2745 first = force_list(first);
2747 NewOp(1101, unop, 1, UNOP);
2748 unop->op_type = (OPCODE)type;
2749 unop->op_ppaddr = PL_ppaddr[type];
2750 unop->op_first = first;
2751 unop->op_flags = (U8)(flags | OPf_KIDS);
2752 unop->op_private = (U8)(1 | (flags >> 8));
2753 unop = (UNOP*) CHECKOP(type, unop);
2757 return fold_constants((OP *) unop);
2761 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2765 NewOp(1101, binop, 1, BINOP);
2768 first = newOP(OP_NULL, 0);
2770 binop->op_type = (OPCODE)type;
2771 binop->op_ppaddr = PL_ppaddr[type];
2772 binop->op_first = first;
2773 binop->op_flags = (U8)(flags | OPf_KIDS);
2776 binop->op_private = (U8)(1 | (flags >> 8));
2779 binop->op_private = (U8)(2 | (flags >> 8));
2780 first->op_sibling = last;
2783 binop = (BINOP*)CHECKOP(type, binop);
2784 if (binop->op_next || binop->op_type != (OPCODE)type)
2787 binop->op_last = binop->op_first->op_sibling;
2789 return fold_constants((OP *)binop);
2792 static int uvcompare(const void *a, const void *b)
2793 __attribute__nonnull__(1)
2794 __attribute__nonnull__(2)
2795 __attribute__pure__;
2796 static int uvcompare(const void *a, const void *b)
2798 if (*((const UV *)a) < (*(const UV *)b))
2800 if (*((const UV *)a) > (*(const UV *)b))
2802 if (*((const UV *)a+1) < (*(const UV *)b+1))
2804 if (*((const UV *)a+1) > (*(const UV *)b+1))
2810 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2813 SV * const tstr = ((SVOP*)expr)->op_sv;
2816 (repl->op_type == OP_NULL)
2817 ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
2819 ((SVOP*)repl)->op_sv;
2822 const U8 *t = (U8*)SvPV_const(tstr, tlen);
2823 const U8 *r = (U8*)SvPV_const(rstr, rlen);
2827 register short *tbl;
2829 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
2830 const I32 squash = o->op_private & OPpTRANS_SQUASH;
2831 I32 del = o->op_private & OPpTRANS_DELETE;
2832 PL_hints |= HINT_BLOCK_SCOPE;
2835 o->op_private |= OPpTRANS_FROM_UTF;
2838 o->op_private |= OPpTRANS_TO_UTF;
2840 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2841 SV* const listsv = newSVpvs("# comment\n");
2843 const U8* tend = t + tlen;
2844 const U8* rend = r + rlen;
2858 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2859 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2862 const U32 flags = UTF8_ALLOW_DEFAULT;
2866 t = tsave = bytes_to_utf8(t, &len);
2869 if (!to_utf && rlen) {
2871 r = rsave = bytes_to_utf8(r, &len);
2875 /* There are several snags with this code on EBCDIC:
2876 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2877 2. scan_const() in toke.c has encoded chars in native encoding which makes
2878 ranges at least in EBCDIC 0..255 range the bottom odd.
2882 U8 tmpbuf[UTF8_MAXBYTES+1];
2885 Newx(cp, 2*tlen, UV);
2887 transv = newSVpvs("");
2889 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
2891 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2893 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
2897 cp[2*i+1] = cp[2*i];
2901 qsort(cp, i, 2*sizeof(UV), uvcompare);
2902 for (j = 0; j < i; j++) {
2904 diff = val - nextmin;
2906 t = uvuni_to_utf8(tmpbuf,nextmin);
2907 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2909 U8 range_mark = UTF_TO_NATIVE(0xff);
2910 t = uvuni_to_utf8(tmpbuf, val - 1);
2911 sv_catpvn(transv, (char *)&range_mark, 1);
2912 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2919 t = uvuni_to_utf8(tmpbuf,nextmin);
2920 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2922 U8 range_mark = UTF_TO_NATIVE(0xff);
2923 sv_catpvn(transv, (char *)&range_mark, 1);
2925 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2926 UNICODE_ALLOW_SUPER);
2927 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2928 t = (const U8*)SvPVX_const(transv);
2929 tlen = SvCUR(transv);
2933 else if (!rlen && !del) {
2934 r = t; rlen = tlen; rend = tend;
2937 if ((!rlen && !del) || t == r ||
2938 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2940 o->op_private |= OPpTRANS_IDENTICAL;
2944 while (t < tend || tfirst <= tlast) {
2945 /* see if we need more "t" chars */
2946 if (tfirst > tlast) {
2947 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
2949 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2951 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
2958 /* now see if we need more "r" chars */
2959 if (rfirst > rlast) {
2961 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
2963 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2965 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
2974 rfirst = rlast = 0xffffffff;
2978 /* now see which range will peter our first, if either. */
2979 tdiff = tlast - tfirst;
2980 rdiff = rlast - rfirst;
2987 if (rfirst == 0xffffffff) {
2988 diff = tdiff; /* oops, pretend rdiff is infinite */
2990 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2991 (long)tfirst, (long)tlast);
2993 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2997 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2998 (long)tfirst, (long)(tfirst + diff),
3001 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3002 (long)tfirst, (long)rfirst);
3004 if (rfirst + diff > max)
3005 max = rfirst + diff;
3007 grows = (tfirst < rfirst &&
3008 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3020 else if (max > 0xff)
3025 PerlMemShared_free(cPVOPo->op_pv);
3026 cPVOPo->op_pv = NULL;
3027 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
3028 SvREFCNT_dec(listsv);
3029 SvREFCNT_dec(transv);
3031 if (!del && havefinal && rlen)
3032 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
3033 newSVuv((UV)final), 0);
3036 o->op_private |= OPpTRANS_GROWS;
3042 op_getmad(expr,o,'e');
3043 op_getmad(repl,o,'r');
3051 tbl = (short*)cPVOPo->op_pv;
3053 Zero(tbl, 256, short);
3054 for (i = 0; i < (I32)tlen; i++)
3056 for (i = 0, j = 0; i < 256; i++) {
3058 if (j >= (I32)rlen) {
3067 if (i < 128 && r[j] >= 128)
3077 o->op_private |= OPpTRANS_IDENTICAL;
3079 else if (j >= (I32)rlen)
3082 cPVOPo->op_pv = (char*)PerlMemShared_realloc(tbl,
3083 (0x101+rlen-j) * sizeof(short));
3084 tbl[0x100] = (short)(rlen - j);
3085 for (i=0; i < (I32)rlen - j; i++)
3086 tbl[0x101+i] = r[j+i];
3090 if (!rlen && !del) {
3093 o->op_private |= OPpTRANS_IDENTICAL;
3095 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3096 o->op_private |= OPpTRANS_IDENTICAL;
3098 for (i = 0; i < 256; i++)
3100 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3101 if (j >= (I32)rlen) {
3103 if (tbl[t[i]] == -1)
3109 if (tbl[t[i]] == -1) {
3110 if (t[i] < 128 && r[j] >= 128)
3117 o->op_private |= OPpTRANS_GROWS;
3119 op_getmad(expr,o,'e');
3120 op_getmad(repl,o,'r');
3130 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3135 NewOp(1101, pmop, 1, PMOP);
3136 pmop->op_type = (OPCODE)type;
3137 pmop->op_ppaddr = PL_ppaddr[type];
3138 pmop->op_flags = (U8)flags;
3139 pmop->op_private = (U8)(0 | (flags >> 8));
3141 if (PL_hints & HINT_RE_TAINT)
3142 pmop->op_pmpermflags |= PMf_RETAINT;
3143 if (PL_hints & HINT_LOCALE)
3144 pmop->op_pmpermflags |= PMf_LOCALE;
3145 pmop->op_pmflags = pmop->op_pmpermflags;
3148 if (av_len((AV*) PL_regex_pad[0]) > -1) {
3149 SV * const repointer = av_pop((AV*)PL_regex_pad[0]);
3150 pmop->op_pmoffset = SvIV(repointer);
3151 SvREPADTMP_off(repointer);
3152 sv_setiv(repointer,0);
3154 SV * const repointer = newSViv(0);
3155 av_push(PL_regex_padav, SvREFCNT_inc_simple_NN(repointer));
3156 pmop->op_pmoffset = av_len(PL_regex_padav);
3157 PL_regex_pad = AvARRAY(PL_regex_padav);
3161 /* link into pm list */
3162 if (type != OP_TRANS && PL_curstash) {
3163 MAGIC *mg = mg_find((SV*)PL_curstash, PERL_MAGIC_symtab);
3166 mg = sv_magicext((SV*)PL_curstash, 0, PERL_MAGIC_symtab, 0, 0, 0);
3168 pmop->op_pmnext = (PMOP*)mg->mg_obj;
3169 mg->mg_obj = (SV*)pmop;
3170 PmopSTASH_set(pmop,PL_curstash);
3173 return CHECKOP(type, pmop);
3176 /* Given some sort of match op o, and an expression expr containing a
3177 * pattern, either compile expr into a regex and attach it to o (if it's
3178 * constant), or convert expr into a runtime regcomp op sequence (if it's
3181 * isreg indicates that the pattern is part of a regex construct, eg
3182 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3183 * split "pattern", which aren't. In the former case, expr will be a list
3184 * if the pattern contains more than one term (eg /a$b/) or if it contains
3185 * a replacement, ie s/// or tr///.
3189 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
3194 I32 repl_has_vars = 0;
3198 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
3199 /* last element in list is the replacement; pop it */
3201 repl = cLISTOPx(expr)->op_last;
3202 kid = cLISTOPx(expr)->op_first;
3203 while (kid->op_sibling != repl)
3204 kid = kid->op_sibling;
3205 kid->op_sibling = NULL;
3206 cLISTOPx(expr)->op_last = kid;
3209 if (isreg && expr->op_type == OP_LIST &&
3210 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3212 /* convert single element list to element */
3213 OP* const oe = expr;
3214 expr = cLISTOPx(oe)->op_first->op_sibling;
3215 cLISTOPx(oe)->op_first->op_sibling = NULL;
3216 cLISTOPx(oe)->op_last = NULL;
3220 if (o->op_type == OP_TRANS) {
3221 return pmtrans(o, expr, repl);
3224 reglist = isreg && expr->op_type == OP_LIST;
3228 PL_hints |= HINT_BLOCK_SCOPE;
3231 if (expr->op_type == OP_CONST) {
3233 SV * const pat = ((SVOP*)expr)->op_sv;
3234 const char *p = SvPV_const(pat, plen);
3235 if ((o->op_flags & OPf_SPECIAL) && (*p == ' ' && p[1] == '\0')) {
3236 U32 was_readonly = SvREADONLY(pat);
3240 sv_force_normal_flags(pat, 0);
3241 assert(!SvREADONLY(pat));
3244 SvREADONLY_off(pat);
3248 sv_setpvn(pat, "\\s+", 3);
3250 SvFLAGS(pat) |= was_readonly;
3252 p = SvPV_const(pat, plen);
3253 pm->op_pmflags |= PMf_SKIPWHITE;
3256 pm->op_pmdynflags |= PMdf_UTF8;
3257 /* FIXME - can we make this function take const char * args? */
3258 PM_SETRE(pm, CALLREGCOMP((char*)p, (char*)p + plen, pm));
3259 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
3260 pm->op_pmflags |= PMf_WHITE;
3262 op_getmad(expr,(OP*)pm,'e');
3268 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3269 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3271 : OP_REGCMAYBE),0,expr);
3273 NewOp(1101, rcop, 1, LOGOP);
3274 rcop->op_type = OP_REGCOMP;
3275 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3276 rcop->op_first = scalar(expr);
3277 rcop->op_flags |= OPf_KIDS
3278 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3279 | (reglist ? OPf_STACKED : 0);
3280 rcop->op_private = 1;
3283 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3285 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
3288 /* establish postfix order */
3289 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3291 rcop->op_next = expr;
3292 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3295 rcop->op_next = LINKLIST(expr);
3296 expr->op_next = (OP*)rcop;
3299 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3304 if (pm->op_pmflags & PMf_EVAL) {
3306 if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
3307 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
3309 else if (repl->op_type == OP_CONST)
3313 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3314 if (curop->op_type == OP_SCOPE
3315 || curop->op_type == OP_LEAVE
3316 || (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)
3339 else if (curop->op_type == OP_PUSHRE)
3340 NOOP; /* Okay here, dangerous in newASSIGNOP */
3350 || PM_GETRE(pm)->extflags & RXf_EVAL_SEEN)))
3352 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3353 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
3354 prepend_elem(o->op_type, scalar(repl), o);
3357 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3358 pm->op_pmflags |= PMf_MAYBE_CONST;
3359 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3361 NewOp(1101, rcop, 1, LOGOP);
3362 rcop->op_type = OP_SUBSTCONT;
3363 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3364 rcop->op_first = scalar(repl);
3365 rcop->op_flags |= OPf_KIDS;
3366 rcop->op_private = 1;
3369 /* establish postfix order */
3370 rcop->op_next = LINKLIST(repl);
3371 repl->op_next = (OP*)rcop;
3373 pm->op_pmreplroot = scalar((OP*)rcop);
3374 pm->op_pmreplstart = LINKLIST(rcop);
3383 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3387 NewOp(1101, svop, 1, SVOP);
3388 svop->op_type = (OPCODE)type;
3389 svop->op_ppaddr = PL_ppaddr[type];
3391 svop->op_next = (OP*)svop;
3392 svop->op_flags = (U8)flags;
3393 if (PL_opargs[type] & OA_RETSCALAR)
3395 if (PL_opargs[type] & OA_TARGET)
3396 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3397 return CHECKOP(type, svop);
3401 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3405 NewOp(1101, padop, 1, PADOP);
3406 padop->op_type = (OPCODE)type;
3407 padop->op_ppaddr = PL_ppaddr[type];
3408 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3409 SvREFCNT_dec(PAD_SVl(padop->op_padix));
3410 PAD_SETSV(padop->op_padix, sv);
3413 padop->op_next = (OP*)padop;
3414 padop->op_flags = (U8)flags;
3415 if (PL_opargs[type] & OA_RETSCALAR)
3417 if (PL_opargs[type] & OA_TARGET)
3418 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3419 return CHECKOP(type, padop);
3423 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3429 return newPADOP(type, flags, SvREFCNT_inc_simple(gv));
3431 return newSVOP(type, flags, SvREFCNT_inc_simple(gv));
3436 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3440 NewOp(1101, pvop, 1, PVOP);
3441 pvop->op_type = (OPCODE)type;
3442 pvop->op_ppaddr = PL_ppaddr[type];
3444 pvop->op_next = (OP*)pvop;
3445 pvop->op_flags = (U8)flags;
3446 if (PL_opargs[type] & OA_RETSCALAR)
3448 if (PL_opargs[type] & OA_TARGET)
3449 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3450 return CHECKOP(type, pvop);
3458 Perl_package(pTHX_ OP *o)
3467 save_hptr(&PL_curstash);
3468 save_item(PL_curstname);
3470 name = SvPV_const(cSVOPo->op_sv, len);
3471 PL_curstash = gv_stashpvn(name, len, TRUE);
3472 sv_setpvn(PL_curstname, name, len);
3474 PL_hints |= HINT_BLOCK_SCOPE;
3475 PL_copline = NOLINE;
3481 if (!PL_madskills) {
3486 pegop = newOP(OP_NULL,0);
3487 op_getmad(o,pegop,'P');
3497 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3504 OP *pegop = newOP(OP_NULL,0);
3507 if (idop->op_type != OP_CONST)
3508 Perl_croak(aTHX_ "Module name must be constant");
3511 op_getmad(idop,pegop,'U');
3516 SV * const vesv = ((SVOP*)version)->op_sv;
3519 op_getmad(version,pegop,'V');
3520 if (!arg && !SvNIOKp(vesv)) {
3527 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3528 Perl_croak(aTHX_ "Version number must be constant number");
3530 /* Make copy of idop so we don't free it twice */
3531 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3533 /* Fake up a method call to VERSION */
3534 meth = newSVpvs_share("VERSION");
3535 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3536 append_elem(OP_LIST,
3537 prepend_elem(OP_LIST, pack, list(version)),
3538 newSVOP(OP_METHOD_NAMED, 0, meth)));
3542 /* Fake up an import/unimport */
3543 if (arg && arg->op_type == OP_STUB) {
3545 op_getmad(arg,pegop,'S');
3546 imop = arg; /* no import on explicit () */
3548 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3549 imop = NULL; /* use 5.0; */
3551 idop->op_private |= OPpCONST_NOVER;
3557 op_getmad(arg,pegop,'A');
3559 /* Make copy of idop so we don't free it twice */
3560 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3562 /* Fake up a method call to import/unimport */
3564 ? newSVpvs_share("import") : newSVpvs_share("unimport");
3565 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3566 append_elem(OP_LIST,
3567 prepend_elem(OP_LIST, pack, list(arg)),
3568 newSVOP(OP_METHOD_NAMED, 0, meth)));
3571 /* Fake up the BEGIN {}, which does its thing immediately. */
3573 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
3576 append_elem(OP_LINESEQ,
3577 append_elem(OP_LINESEQ,
3578 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
3579 newSTATEOP(0, NULL, veop)),
3580 newSTATEOP(0, NULL, imop) ));
3582 /* The "did you use incorrect case?" warning used to be here.
3583 * The problem is that on case-insensitive filesystems one
3584 * might get false positives for "use" (and "require"):
3585 * "use Strict" or "require CARP" will work. This causes
3586 * portability problems for the script: in case-strict
3587 * filesystems the script will stop working.
3589 * The "incorrect case" warning checked whether "use Foo"
3590 * imported "Foo" to your namespace, but that is wrong, too:
3591 * there is no requirement nor promise in the language that
3592 * a Foo.pm should or would contain anything in package "Foo".
3594 * There is very little Configure-wise that can be done, either:
3595 * the case-sensitivity of the build filesystem of Perl does not
3596 * help in guessing the case-sensitivity of the runtime environment.
3599 PL_hints |= HINT_BLOCK_SCOPE;
3600 PL_copline = NOLINE;
3602 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3605 if (!PL_madskills) {
3606 /* FIXME - don't allocate pegop if !PL_madskills */
3615 =head1 Embedding Functions
3617 =for apidoc load_module
3619 Loads the module whose name is pointed to by the string part of name.
3620 Note that the actual module name, not its filename, should be given.
3621 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3622 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3623 (or 0 for no flags). ver, if specified, provides version semantics
3624 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3625 arguments can be used to specify arguments to the module's import()
3626 method, similar to C<use Foo::Bar VERSION LIST>.
3631 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3634 va_start(args, ver);
3635 vload_module(flags, name, ver, &args);
3639 #ifdef PERL_IMPLICIT_CONTEXT
3641 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3645 va_start(args, ver);
3646 vload_module(flags, name, ver, &args);
3652 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3657 OP * const modname = newSVOP(OP_CONST, 0, name);
3658 modname->op_private |= OPpCONST_BARE;
3660 veop = newSVOP(OP_CONST, 0, ver);
3664 if (flags & PERL_LOADMOD_NOIMPORT) {
3665 imop = sawparens(newNULLLIST());
3667 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3668 imop = va_arg(*args, OP*);
3673 sv = va_arg(*args, SV*);
3675 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3676 sv = va_arg(*args, SV*);
3680 const line_t ocopline = PL_copline;
3681 COP * const ocurcop = PL_curcop;
3682 const int oexpect = PL_expect;
3684 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3685 veop, modname, imop);
3686 PL_expect = oexpect;
3687 PL_copline = ocopline;
3688 PL_curcop = ocurcop;
3693 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
3699 if (!force_builtin) {
3700 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
3701 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
3702 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
3703 gv = gvp ? *gvp : NULL;
3707 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3708 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3709 append_elem(OP_LIST, term,
3710 scalar(newUNOP(OP_RV2CV, 0,
3711 newGVOP(OP_GV, 0, gv))))));
3714 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3720 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3722 return newBINOP(OP_LSLICE, flags,
3723 list(force_list(subscript)),
3724 list(force_list(listval)) );
3728 S_is_list_assignment(pTHX_ register const OP *o)
3736 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
3737 o = cUNOPo->op_first;
3739 flags = o->op_flags;
3741 if (type == OP_COND_EXPR) {
3742 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
3743 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3748 yyerror("Assignment to both a list and a scalar");
3752 if (type == OP_LIST &&
3753 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
3754 o->op_private & OPpLVAL_INTRO)
3757 if (type == OP_LIST || flags & OPf_PARENS ||
3758 type == OP_RV2AV || type == OP_RV2HV ||
3759 type == OP_ASLICE || type == OP_HSLICE)
3762 if (type == OP_PADAV || type == OP_PADHV)
3765 if (type == OP_RV2SV)
3772 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3778 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3779 return newLOGOP(optype, 0,
3780 mod(scalar(left), optype),
3781 newUNOP(OP_SASSIGN, 0, scalar(right)));
3784 return newBINOP(optype, OPf_STACKED,
3785 mod(scalar(left), optype), scalar(right));
3789 if (is_list_assignment(left)) {
3793 /* Grandfathering $[ assignment here. Bletch.*/
3794 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
3795 PL_eval_start = (left->op_type == OP_CONST) ? right : 0;
3796 left = mod(left, OP_AASSIGN);
3799 else if (left->op_type == OP_CONST) {
3801 /* Result of assignment is always 1 (or we'd be dead already) */
3802 return newSVOP(OP_CONST, 0, newSViv(1));
3804 curop = list(force_list(left));
3805 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3806 o->op_private = (U8)(0 | (flags >> 8));
3808 /* PL_generation sorcery:
3809 * an assignment like ($a,$b) = ($c,$d) is easier than
3810 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3811 * To detect whether there are common vars, the global var
3812 * PL_generation is incremented for each assign op we compile.
3813 * Then, while compiling the assign op, we run through all the
3814 * variables on both sides of the assignment, setting a spare slot
3815 * in each of them to PL_generation. If any of them already have
3816 * that value, we know we've got commonality. We could use a
3817 * single bit marker, but then we'd have to make 2 passes, first
3818 * to clear the flag, then to test and set it. To find somewhere
3819 * to store these values, evil chicanery is done with SvUVX().
3825 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3826 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3827 if (curop->op_type == OP_GV) {
3828 GV *gv = cGVOPx_gv(curop);
3830 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
3832 GvASSIGN_GENERATION_set(gv, PL_generation);
3834 else if (curop->op_type == OP_PADSV ||
3835 curop->op_type == OP_PADAV ||
3836 curop->op_type == OP_PADHV ||
3837 curop->op_type == OP_PADANY)
3839 if (PAD_COMPNAME_GEN(curop->op_targ)
3840 == (STRLEN)PL_generation)
3842 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
3845 else if (curop->op_type == OP_RV2CV)
3847 else if (curop->op_type == OP_RV2SV ||
3848 curop->op_type == OP_RV2AV ||
3849 curop->op_type == OP_RV2HV ||
3850 curop->op_type == OP_RV2GV) {
3851 if (lastop->op_type != OP_GV) /* funny deref? */
3854 else if (curop->op_type == OP_PUSHRE) {
3855 if (((PMOP*)curop)->op_pmreplroot) {
3857 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3858 ((PMOP*)curop)->op_pmreplroot));
3860 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3863 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
3865 GvASSIGN_GENERATION_set(gv, PL_generation);
3866 GvASSIGN_GENERATION_set(gv, PL_generation);
3875 o->op_private |= OPpASSIGN_COMMON;
3878 if ( ((left->op_private & OPpLVAL_INTRO) || ckWARN(WARN_MISC))
3879 && (left->op_type == OP_LIST
3880 || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
3882 OP* lop = ((LISTOP*)left)->op_first;
3884 if (lop->op_type == OP_PADSV ||
3885 lop->op_type == OP_PADAV ||
3886 lop->op_type == OP_PADHV ||
3887 lop->op_type == OP_PADANY)
3889 if (lop->op_private & OPpPAD_STATE) {
3890 if (left->op_private & OPpLVAL_INTRO) {
3891 o->op_private |= OPpASSIGN_STATE;
3892 /* hijacking PADSTALE for uninitialized state variables */
3893 SvPADSTALE_on(PAD_SVl(lop->op_targ));
3895 else { /* we already checked for WARN_MISC before */
3896 Perl_warner(aTHX_ packWARN(WARN_MISC), "State variable %s will be reinitialized",
3897 PAD_COMPNAME_PV(lop->op_targ));
3901 lop = lop->op_sibling;
3905 if (right && right->op_type == OP_SPLIT) {
3906 OP* tmpop = ((LISTOP*)right)->op_first;
3907 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
3908 PMOP * const pm = (PMOP*)tmpop;
3909 if (left->op_type == OP_RV2AV &&
3910 !(left->op_private & OPpLVAL_INTRO) &&
3911 !(o->op_private & OPpASSIGN_COMMON) )
3913 tmpop = ((UNOP*)left)->op_first;
3914 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3916 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3917 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3919 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3920 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
3922 pm->op_pmflags |= PMf_ONCE;
3923 tmpop = cUNOPo->op_first; /* to list (nulled) */
3924 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3925 tmpop->op_sibling = NULL; /* don't free split */
3926 right->op_next = tmpop->op_next; /* fix starting loc */
3928 op_getmad(o,right,'R'); /* blow off assign */
3930 op_free(o); /* blow off assign */
3932 right->op_flags &= ~OPf_WANT;
3933 /* "I don't know and I don't care." */
3938 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3939 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3941 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3943 sv_setiv(sv, PL_modcount+1);
3951 right = newOP(OP_UNDEF, 0);
3952 if (right->op_type == OP_READLINE) {
3953 right->op_flags |= OPf_STACKED;
3954 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3957 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3958 o = newBINOP(OP_SASSIGN, flags,
3959 scalar(right), mod(scalar(left), OP_SASSIGN) );
3965 o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
3966 o->op_private |= OPpCONST_ARYBASE;
3973 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3976 const U32 seq = intro_my();
3979 NewOp(1101, cop, 1, COP);
3980 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3981 cop->op_type = OP_DBSTATE;
3982 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3985 cop->op_type = OP_NEXTSTATE;
3986 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3988 cop->op_flags = (U8)flags;
3989 CopHINTS_set(cop, PL_hints);
3991 cop->op_private |= NATIVE_HINTS;
3993 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
3994 cop->op_next = (OP*)cop;
3997 CopLABEL_set(cop, label);
3998 PL_hints |= HINT_BLOCK_SCOPE;
4001 /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
4002 CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
4004 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
4005 cop->cop_hints_hash = PL_curcop->cop_hints_hash;
4006 if (cop->cop_hints_hash) {
4008 cop->cop_hints_hash->refcounted_he_refcnt++;
4009 HINTS_REFCNT_UNLOCK;
4012 if (PL_copline == NOLINE)
4013 CopLINE_set(cop, CopLINE(PL_curcop));
4015 CopLINE_set(cop, PL_copline);
4016 PL_copline = NOLINE;
4019 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
4021 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
4023 CopSTASH_set(cop, PL_curstash);
4025 if (PERLDB_LINE && PL_curstash != PL_debstash) {
4026 AV *av = CopFILEAVx(PL_curcop);
4028 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
4029 if (svp && *svp != &PL_sv_undef ) {
4030 (void)SvIOK_on(*svp);
4031 SvIV_set(*svp, PTR2IV(cop));
4036 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
4041 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
4044 return new_logop(type, flags, &first, &other);
4048 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
4053 OP *first = *firstp;
4054 OP * const other = *otherp;
4056 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
4057 return newBINOP(type, flags, scalar(first), scalar(other));
4059 scalarboolean(first);
4060 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
4061 if (first->op_type == OP_NOT
4062 && (first->op_flags & OPf_SPECIAL)
4063 && (first->op_flags & OPf_KIDS)) {
4064 if (type == OP_AND || type == OP_OR) {
4070 first = *firstp = cUNOPo->op_first;
4072 first->op_next = o->op_next;
4073 cUNOPo->op_first = NULL;
4075 op_getmad(o,first,'O');
4081 if (first->op_type == OP_CONST) {
4082 if (first->op_private & OPpCONST_STRICT)
4083 no_bareword_allowed(first);
4084 else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
4085 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
4086 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
4087 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
4088 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
4090 if (other->op_type == OP_CONST)
4091 other->op_private |= OPpCONST_SHORTCIRCUIT;
4093 OP *newop = newUNOP(OP_NULL, 0, other);
4094 op_getmad(first, newop, '1');
4095 newop->op_targ = type; /* set "was" field */
4102 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
4103 const OP *o2 = other;
4104 if ( ! (o2->op_type == OP_LIST
4105 && (( o2 = cUNOPx(o2)->op_first))
4106 && o2->op_type == OP_PUSHMARK
4107 && (( o2 = o2->op_sibling)) )
4110 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
4111 || o2->op_type == OP_PADHV)
4112 && o2->op_private & OPpLVAL_INTRO
4113 && ckWARN(WARN_DEPRECATED))
4115 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4116 "Deprecated use of my() in false conditional");
4120 if (first->op_type == OP_CONST)
4121 first->op_private |= OPpCONST_SHORTCIRCUIT;
4123 first = newUNOP(OP_NULL, 0, first);
4124 op_getmad(other, first, '2');
4125 first->op_targ = type; /* set "was" field */
4132 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
4133 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
4135 const OP * const k1 = ((UNOP*)first)->op_first;
4136 const OP * const k2 = k1->op_sibling;
4138 switch (first->op_type)
4141 if (k2 && k2->op_type == OP_READLINE
4142 && (k2->op_flags & OPf_STACKED)
4143 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4145 warnop = k2->op_type;
4150 if (k1->op_type == OP_READDIR
4151 || k1->op_type == OP_GLOB
4152 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4153 || k1->op_type == OP_EACH)
4155 warnop = ((k1->op_type == OP_NULL)
4156 ? (OPCODE)k1->op_targ : k1->op_type);
4161 const line_t oldline = CopLINE(PL_curcop);
4162 CopLINE_set(PL_curcop, PL_copline);
4163 Perl_warner(aTHX_ packWARN(WARN_MISC),
4164 "Value of %s%s can be \"0\"; test with defined()",
4166 ((warnop == OP_READLINE || warnop == OP_GLOB)
4167 ? " construct" : "() operator"));
4168 CopLINE_set(PL_curcop, oldline);
4175 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
4176 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
4178 NewOp(1101, logop, 1, LOGOP);
4180 logop->op_type = (OPCODE)type;
4181 logop->op_ppaddr = PL_ppaddr[type];
4182 logop->op_first = first;
4183 logop->op_flags = (U8)(flags | OPf_KIDS);
4184 logop->op_other = LINKLIST(other);
4185 logop->op_private = (U8)(1 | (flags >> 8));
4187 /* establish postfix order */
4188 logop->op_next = LINKLIST(first);
4189 first->op_next = (OP*)logop;
4190 first->op_sibling = other;
4192 CHECKOP(type,logop);
4194 o = newUNOP(OP_NULL, 0, (OP*)logop);
4201 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
4209 return newLOGOP(OP_AND, 0, first, trueop);
4211 return newLOGOP(OP_OR, 0, first, falseop);
4213 scalarboolean(first);
4214 if (first->op_type == OP_CONST) {
4215 if (first->op_private & OPpCONST_BARE &&
4216 first->op_private & OPpCONST_STRICT) {
4217 no_bareword_allowed(first);
4219 if (SvTRUE(((SVOP*)first)->op_sv)) {
4222 trueop = newUNOP(OP_NULL, 0, trueop);
4223 op_getmad(first,trueop,'C');
4224 op_getmad(falseop,trueop,'e');
4226 /* FIXME for MAD - should there be an ELSE here? */
4236 falseop = newUNOP(OP_NULL, 0, falseop);
4237 op_getmad(first,falseop,'C');
4238 op_getmad(trueop,falseop,'t');
4240 /* FIXME for MAD - should there be an ELSE here? */
4248 NewOp(1101, logop, 1, LOGOP);
4249 logop->op_type = OP_COND_EXPR;
4250 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4251 logop->op_first = first;
4252 logop->op_flags = (U8)(flags | OPf_KIDS);
4253 logop->op_private = (U8)(1 | (flags >> 8));
4254 logop->op_other = LINKLIST(trueop);
4255 logop->op_next = LINKLIST(falseop);
4257 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
4260 /* establish postfix order */
4261 start = LINKLIST(first);
4262 first->op_next = (OP*)logop;
4264 first->op_sibling = trueop;
4265 trueop->op_sibling = falseop;
4266 o = newUNOP(OP_NULL, 0, (OP*)logop);
4268 trueop->op_next = falseop->op_next = o;
4275 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4284 NewOp(1101, range, 1, LOGOP);
4286 range->op_type = OP_RANGE;
4287 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4288 range->op_first = left;
4289 range->op_flags = OPf_KIDS;
4290 leftstart = LINKLIST(left);
4291 range->op_other = LINKLIST(right);
4292 range->op_private = (U8)(1 | (flags >> 8));
4294 left->op_sibling = right;
4296 range->op_next = (OP*)range;
4297 flip = newUNOP(OP_FLIP, flags, (OP*)range);
4298 flop = newUNOP(OP_FLOP, 0, flip);
4299 o = newUNOP(OP_NULL, 0, flop);
4301 range->op_next = leftstart;
4303 left->op_next = flip;
4304 right->op_next = flop;
4306 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4307 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4308 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4309 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4311 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4312 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4315 if (!flip->op_private || !flop->op_private)
4316 linklist(o); /* blow off optimizer unless constant */
4322 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4327 const bool once = block && block->op_flags & OPf_SPECIAL &&
4328 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4330 PERL_UNUSED_ARG(debuggable);
4333 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4334 return block; /* do {} while 0 does once */
4335 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4336 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4337 expr = newUNOP(OP_DEFINED, 0,
4338 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4339 } else if (expr->op_flags & OPf_KIDS) {
4340 const OP * const k1 = ((UNOP*)expr)->op_first;
4341 const OP * const k2 = k1 ? k1->op_sibling : NULL;
4342 switch (expr->op_type) {
4344 if (k2 && k2->op_type == OP_READLINE
4345 && (k2->op_flags & OPf_STACKED)
4346 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4347 expr = newUNOP(OP_DEFINED, 0, expr);
4351 if (k1 && (k1->op_type == OP_READDIR
4352 || k1->op_type == OP_GLOB
4353 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4354 || k1->op_type == OP_EACH))
4355 expr = newUNOP(OP_DEFINED, 0, expr);
4361 /* if block is null, the next append_elem() would put UNSTACK, a scalar
4362 * op, in listop. This is wrong. [perl #27024] */
4364 block = newOP(OP_NULL, 0);
4365 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4366 o = new_logop(OP_AND, 0, &expr, &listop);
4369 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4371 if (once && o != listop)
4372 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4375 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
4377 o->op_flags |= flags;
4379 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4384 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
4385 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
4394 PERL_UNUSED_ARG(debuggable);
4397 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4398 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4399 expr = newUNOP(OP_DEFINED, 0,
4400 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4401 } else if (expr->op_flags & OPf_KIDS) {
4402 const OP * const k1 = ((UNOP*)expr)->op_first;
4403 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
4404 switch (expr->op_type) {
4406 if (k2 && k2->op_type == OP_READLINE
4407 && (k2->op_flags & OPf_STACKED)
4408 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4409 expr = newUNOP(OP_DEFINED, 0, expr);
4413 if (k1 && (k1->op_type == OP_READDIR
4414 || k1->op_type == OP_GLOB
4415 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4416 || k1->op_type == OP_EACH))
4417 expr = newUNOP(OP_DEFINED, 0, expr);
4424 block = newOP(OP_NULL, 0);
4425 else if (cont || has_my) {
4426 block = scope(block);
4430 next = LINKLIST(cont);
4433 OP * const unstack = newOP(OP_UNSTACK, 0);
4436 cont = append_elem(OP_LINESEQ, cont, unstack);
4440 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4442 redo = LINKLIST(listop);
4445 PL_copline = (line_t)whileline;
4447 o = new_logop(OP_AND, 0, &expr, &listop);
4448 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4449 op_free(expr); /* oops, it's a while (0) */
4451 return NULL; /* listop already freed by new_logop */
4454 ((LISTOP*)listop)->op_last->op_next =
4455 (o == listop ? redo : LINKLIST(o));
4461 NewOp(1101,loop,1,LOOP);
4462 loop->op_type = OP_ENTERLOOP;
4463 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4464 loop->op_private = 0;
4465 loop->op_next = (OP*)loop;
4468 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4470 loop->op_redoop = redo;
4471 loop->op_lastop = o;
4472 o->op_private |= loopflags;
4475 loop->op_nextop = next;
4477 loop->op_nextop = o;
4479 o->op_flags |= flags;
4480 o->op_private |= (flags >> 8);
4485 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
4490 PADOFFSET padoff = 0;
4496 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4497 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
4498 sv->op_type = OP_RV2GV;
4499 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4500 if (cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
4501 iterpflags |= OPpITER_DEF;
4503 else if (sv->op_type == OP_PADSV) { /* private variable */
4504 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
4505 padoff = sv->op_targ;
4515 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4517 SV *const namesv = PAD_COMPNAME_SV(padoff);
4519 const char *const name = SvPV_const(namesv, len);
4521 if (len == 2 && name[0] == '$' && name[1] == '_')
4522 iterpflags |= OPpITER_DEF;
4526 const PADOFFSET offset = pad_findmy("$_");
4527 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
4528 sv = newGVOP(OP_GV, 0, PL_defgv);
4533 iterpflags |= OPpITER_DEF;
4535 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4536 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4537 iterflags |= OPf_STACKED;
4539 else if (expr->op_type == OP_NULL &&
4540 (expr->op_flags & OPf_KIDS) &&
4541 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4543 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4544 * set the STACKED flag to indicate that these values are to be
4545 * treated as min/max values by 'pp_iterinit'.
4547 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4548 LOGOP* const range = (LOGOP*) flip->op_first;
4549 OP* const left = range->op_first;
4550 OP* const right = left->op_sibling;
4553 range->op_flags &= ~OPf_KIDS;
4554 range->op_first = NULL;
4556 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4557 listop->op_first->op_next = range->op_next;
4558 left->op_next = range->op_other;
4559 right->op_next = (OP*)listop;
4560 listop->op_next = listop->op_first;
4563 op_getmad(expr,(OP*)listop,'O');
4567 expr = (OP*)(listop);
4569 iterflags |= OPf_STACKED;
4572 expr = mod(force_list(expr), OP_GREPSTART);
4575 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4576 append_elem(OP_LIST, expr, scalar(sv))));
4577 assert(!loop->op_next);
4578 /* for my $x () sets OPpLVAL_INTRO;
4579 * for our $x () sets OPpOUR_INTRO */
4580 loop->op_private = (U8)iterpflags;
4581 #ifdef PL_OP_SLAB_ALLOC
4584 NewOp(1234,tmp,1,LOOP);
4585 Copy(loop,tmp,1,LISTOP);
4586 S_op_destroy(aTHX_ (OP*)loop);
4590 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
4592 loop->op_targ = padoff;
4593 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
4595 op_getmad(madsv, (OP*)loop, 'v');
4596 PL_copline = forline;
4597 return newSTATEOP(0, label, wop);
4601 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4606 if (type != OP_GOTO || label->op_type == OP_CONST) {
4607 /* "last()" means "last" */
4608 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4609 o = newOP(type, OPf_SPECIAL);
4611 o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
4612 ? SvPVx_nolen_const(((SVOP*)label)->op_sv)
4616 op_getmad(label,o,'L');
4622 /* Check whether it's going to be a goto &function */
4623 if (label->op_type == OP_ENTERSUB
4624 && !(label->op_flags & OPf_STACKED))
4625 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4626 o = newUNOP(type, OPf_STACKED, label);
4628 PL_hints |= HINT_BLOCK_SCOPE;
4632 /* if the condition is a literal array or hash
4633 (or @{ ... } etc), make a reference to it.
4636 S_ref_array_or_hash(pTHX_ OP *cond)
4639 && (cond->op_type == OP_RV2AV
4640 || cond->op_type == OP_PADAV
4641 || cond->op_type == OP_RV2HV
4642 || cond->op_type == OP_PADHV))
4644 return newUNOP(OP_REFGEN,
4645 0, mod(cond, OP_REFGEN));
4651 /* These construct the optree fragments representing given()
4654 entergiven and enterwhen are LOGOPs; the op_other pointer
4655 points up to the associated leave op. We need this so we
4656 can put it in the context and make break/continue work.
4657 (Also, of course, pp_enterwhen will jump straight to
4658 op_other if the match fails.)
4663 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
4664 I32 enter_opcode, I32 leave_opcode,
4665 PADOFFSET entertarg)
4671 NewOp(1101, enterop, 1, LOGOP);
4672 enterop->op_type = enter_opcode;
4673 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
4674 enterop->op_flags = (U8) OPf_KIDS;
4675 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
4676 enterop->op_private = 0;
4678 o = newUNOP(leave_opcode, 0, (OP *) enterop);
4681 enterop->op_first = scalar(cond);
4682 cond->op_sibling = block;
4684 o->op_next = LINKLIST(cond);
4685 cond->op_next = (OP *) enterop;
4688 /* This is a default {} block */
4689 enterop->op_first = block;
4690 enterop->op_flags |= OPf_SPECIAL;
4692 o->op_next = (OP *) enterop;
4695 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
4696 entergiven and enterwhen both
4699 enterop->op_next = LINKLIST(block);
4700 block->op_next = enterop->op_other = o;
4705 /* Does this look like a boolean operation? For these purposes
4706 a boolean operation is:
4707 - a subroutine call [*]
4708 - a logical connective
4709 - a comparison operator
4710 - a filetest operator, with the exception of -s -M -A -C
4711 - defined(), exists() or eof()
4712 - /$re/ or $foo =~ /$re/
4714 [*] possibly surprising
4718 S_looks_like_bool(pTHX_ const OP *o)
4721 switch(o->op_type) {
4723 return looks_like_bool(cLOGOPo->op_first);
4727 looks_like_bool(cLOGOPo->op_first)
4728 && looks_like_bool(cLOGOPo->op_first->op_sibling));
4732 case OP_NOT: case OP_XOR:
4733 /* Note that OP_DOR is not here */
4735 case OP_EQ: case OP_NE: case OP_LT:
4736 case OP_GT: case OP_LE: case OP_GE:
4738 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
4739 case OP_I_GT: case OP_I_LE: case OP_I_GE:
4741 case OP_SEQ: case OP_SNE: case OP_SLT:
4742 case OP_SGT: case OP_SLE: case OP_SGE:
4746 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
4747 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
4748 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
4749 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
4750 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
4751 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
4752 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
4753 case OP_FTTEXT: case OP_FTBINARY:
4755 case OP_DEFINED: case OP_EXISTS:
4756 case OP_MATCH: case OP_EOF:
4761 /* Detect comparisons that have been optimized away */
4762 if (cSVOPo->op_sv == &PL_sv_yes
4763 || cSVOPo->op_sv == &PL_sv_no)
4774 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
4778 return newGIVWHENOP(
4779 ref_array_or_hash(cond),
4781 OP_ENTERGIVEN, OP_LEAVEGIVEN,
4785 /* If cond is null, this is a default {} block */
4787 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
4789 const bool cond_llb = (!cond || looks_like_bool(cond));
4795 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
4797 scalar(ref_array_or_hash(cond)));
4800 return newGIVWHENOP(
4802 append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
4803 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
4807 =for apidoc cv_undef
4809 Clear out all the active components of a CV. This can happen either
4810 by an explicit C<undef &foo>, or by the reference count going to zero.
4811 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
4812 children can still follow the full lexical scope chain.
4818 Perl_cv_undef(pTHX_ CV *cv)
4822 if (CvFILE(cv) && !CvISXSUB(cv)) {
4823 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4824 Safefree(CvFILE(cv));
4829 if (!CvISXSUB(cv) && CvROOT(cv)) {
4830 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
4831 Perl_croak(aTHX_ "Can't undef active subroutine");
4834 PAD_SAVE_SETNULLPAD();
4836 op_free(CvROOT(cv));
4841 SvPOK_off((SV*)cv); /* forget prototype */
4846 /* remove CvOUTSIDE unless this is an undef rather than a free */
4847 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
4848 if (!CvWEAKOUTSIDE(cv))
4849 SvREFCNT_dec(CvOUTSIDE(cv));
4850 CvOUTSIDE(cv) = NULL;
4853 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4856 if (CvISXSUB(cv) && CvXSUB(cv)) {
4859 /* delete all flags except WEAKOUTSIDE */
4860 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
4864 Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
4867 /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
4868 relying on SvCUR, and doubling up the buffer to hold CvFILE(). */
4869 if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
4870 || (p && (len != SvCUR(cv) /* Not the same length. */
4871 || memNE(p, SvPVX_const(cv), len))))
4872 && ckWARN_d(WARN_PROTOTYPE)) {
4873 SV* const msg = sv_newmortal();
4877 gv_efullname3(name = sv_newmortal(), gv, NULL);
4878 sv_setpv(msg, "Prototype mismatch:");
4880 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
4882 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv));
4884 sv_catpvs(msg, ": none");
4885 sv_catpvs(msg, " vs ");
4887 Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
4889 sv_catpvs(msg, "none");
4890 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
4894 static void const_sv_xsub(pTHX_ CV* cv);
4898 =head1 Optree Manipulation Functions
4900 =for apidoc cv_const_sv
4902 If C<cv> is a constant sub eligible for inlining. returns the constant
4903 value returned by the sub. Otherwise, returns NULL.
4905 Constant subs can be created with C<newCONSTSUB> or as described in
4906 L<perlsub/"Constant Functions">.
4911 Perl_cv_const_sv(pTHX_ CV *cv)
4913 PERL_UNUSED_CONTEXT;
4916 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
4918 return CvCONST(cv) ? (SV*)CvXSUBANY(cv).any_ptr : NULL;
4921 /* op_const_sv: examine an optree to determine whether it's in-lineable.
4922 * Can be called in 3 ways:
4925 * look for a single OP_CONST with attached value: return the value
4927 * cv && CvCLONE(cv) && !CvCONST(cv)
4929 * examine the clone prototype, and if contains only a single
4930 * OP_CONST referencing a pad const, or a single PADSV referencing
4931 * an outer lexical, return a non-zero value to indicate the CV is
4932 * a candidate for "constizing" at clone time
4936 * We have just cloned an anon prototype that was marked as a const
4937 * candidiate. Try to grab the current value, and in the case of
4938 * PADSV, ignore it if it has multiple references. Return the value.
4942 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
4950 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4951 o = cLISTOPo->op_first->op_sibling;
4953 for (; o; o = o->op_next) {
4954 const OPCODE type = o->op_type;
4956 if (sv && o->op_next == o)
4958 if (o->op_next != o) {
4959 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4961 if (type == OP_DBSTATE)
4964 if (type == OP_LEAVESUB || type == OP_RETURN)
4968 if (type == OP_CONST && cSVOPo->op_sv)
4970 else if (cv && type == OP_CONST) {
4971 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4975 else if (cv && type == OP_PADSV) {
4976 if (CvCONST(cv)) { /* newly cloned anon */
4977 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4978 /* the candidate should have 1 ref from this pad and 1 ref
4979 * from the parent */
4980 if (!sv || SvREFCNT(sv) != 2)
4987 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
4988 sv = &PL_sv_undef; /* an arbitrary non-null value */
5003 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5006 /* This would be the return value, but the return cannot be reached. */
5007 OP* pegop = newOP(OP_NULL, 0);
5010 PERL_UNUSED_ARG(floor);
5020 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
5022 NORETURN_FUNCTION_END;
5027 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
5029 return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
5033 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5040 register CV *cv = NULL;
5042 /* If the subroutine has no body, no attributes, and no builtin attributes
5043 then it's just a sub declaration, and we may be able to get away with
5044 storing with a placeholder scalar in the symbol table, rather than a
5045 full GV and CV. If anything is present then it will take a full CV to
5047 const I32 gv_fetch_flags
5048 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5050 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
5051 const char * const name = o ? SvPVx_nolen_const(cSVOPo->op_sv) : NULL;
5054 assert(proto->op_type == OP_CONST);
5055 ps = SvPVx_const(((SVOP*)proto)->op_sv, ps_len);
5060 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
5061 SV * const sv = sv_newmortal();
5062 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
5063 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
5064 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
5065 aname = SvPVX_const(sv);
5070 gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
5071 : gv_fetchpv(aname ? aname
5072 : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5073 gv_fetch_flags, SVt_PVCV);
5075 if (!PL_madskills) {
5084 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
5085 maximum a prototype before. */
5086 if (SvTYPE(gv) > SVt_NULL) {
5087 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
5088 && ckWARN_d(WARN_PROTOTYPE))
5090 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
5092 cv_ckproto_len((CV*)gv, NULL, ps, ps_len);
5095 sv_setpvn((SV*)gv, ps, ps_len);
5097 sv_setiv((SV*)gv, -1);
5098 SvREFCNT_dec(PL_compcv);
5099 cv = PL_compcv = NULL;
5100 PL_sub_generation++;
5104 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
5106 #ifdef GV_UNIQUE_CHECK
5107 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
5108 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
5112 if (!block || !ps || *ps || attrs
5113 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5115 || block->op_type == OP_NULL
5120 const_sv = op_const_sv(block, NULL);
5123 const bool exists = CvROOT(cv) || CvXSUB(cv);
5125 #ifdef GV_UNIQUE_CHECK
5126 if (exists && GvUNIQUE(gv)) {
5127 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
5131 /* if the subroutine doesn't exist and wasn't pre-declared
5132 * with a prototype, assume it will be AUTOLOADed,
5133 * skipping the prototype check
5135 if (exists || SvPOK(cv))
5136 cv_ckproto_len(cv, gv, ps, ps_len);
5137 /* already defined (or promised)? */
5138 if (exists || GvASSUMECV(gv)) {
5141 || block->op_type == OP_NULL
5144 if (CvFLAGS(PL_compcv)) {
5145 /* might have had built-in attrs applied */
5146 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5148 /* just a "sub foo;" when &foo is already defined */
5149 SAVEFREESV(PL_compcv);
5154 && block->op_type != OP_NULL
5157 if (ckWARN(WARN_REDEFINE)
5159 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
5161 const line_t oldline = CopLINE(PL_curcop);
5162 if (PL_copline != NOLINE)
5163 CopLINE_set(PL_curcop, PL_copline);
5164 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5165 CvCONST(cv) ? "Constant subroutine %s redefined"
5166 : "Subroutine %s redefined", name);
5167 CopLINE_set(PL_curcop, oldline);
5170 if (!PL_minus_c) /* keep old one around for madskills */
5173 /* (PL_madskills unset in used file.) */
5181 SvREFCNT_inc_simple_void_NN(const_sv);
5183 assert(!CvROOT(cv) && !CvCONST(cv));
5184 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
5185 CvXSUBANY(cv).any_ptr = const_sv;
5186 CvXSUB(cv) = const_sv_xsub;
5192 cv = newCONSTSUB(NULL, name, const_sv);
5194 PL_sub_generation++;
5198 SvREFCNT_dec(PL_compcv);
5206 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
5207 * before we clobber PL_compcv.
5211 || block->op_type == OP_NULL
5215 /* Might have had built-in attributes applied -- propagate them. */
5216 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5217 if (CvGV(cv) && GvSTASH(CvGV(cv)))
5218 stash = GvSTASH(CvGV(cv));
5219 else if (CvSTASH(cv))
5220 stash = CvSTASH(cv);
5222 stash = PL_curstash;
5225 /* possibly about to re-define existing subr -- ignore old cv */
5226 rcv = (SV*)PL_compcv;
5227 if (name && GvSTASH(gv))
5228 stash = GvSTASH(gv);
5230 stash = PL_curstash;
5232 apply_attrs(stash, rcv, attrs, FALSE);
5234 if (cv) { /* must reuse cv if autoloaded */
5241 || block->op_type == OP_NULL) && !PL_madskills
5244 /* got here with just attrs -- work done, so bug out */
5245 SAVEFREESV(PL_compcv);
5248 /* transfer PL_compcv to cv */
5250 CvFLAGS(cv) = CvFLAGS(PL_compcv);
5251 if (!CvWEAKOUTSIDE(cv))
5252 SvREFCNT_dec(CvOUTSIDE(cv));
5253 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
5254 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
5255 CvOUTSIDE(PL_compcv) = 0;
5256 CvPADLIST(cv) = CvPADLIST(PL_compcv);
5257 CvPADLIST(PL_compcv) = 0;
5258 /* inner references to PL_compcv must be fixed up ... */
5259 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
5260 /* ... before we throw it away */
5261 SvREFCNT_dec(PL_compcv);
5263 if (PERLDB_INTER)/* Advice debugger on the new sub. */
5264 ++PL_sub_generation;
5271 if (strEQ(name, "import")) {
5272 PL_formfeed = (SV*)cv;
5273 Perl_warner(aTHX_ packWARN(WARN_VOID), "%lx\n", (long)cv);
5277 PL_sub_generation++;
5281 CvFILE_set_from_cop(cv, PL_curcop);
5282 CvSTASH(cv) = PL_curstash;
5285 sv_setpvn((SV*)cv, ps, ps_len);
5287 if (PL_error_count) {
5291 const char *s = strrchr(name, ':');
5293 if (strEQ(s, "BEGIN")) {
5294 const char not_safe[] =
5295 "BEGIN not safe after errors--compilation aborted";
5296 if (PL_in_eval & EVAL_KEEPERR)
5297 Perl_croak(aTHX_ not_safe);
5299 /* force display of errors found but not reported */
5300 sv_catpv(ERRSV, not_safe);
5301 Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
5311 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5312 mod(scalarseq(block), OP_LEAVESUBLV));
5313 block->op_attached = 1;
5316 /* This makes sub {}; work as expected. */
5317 if (block->op_type == OP_STUB) {
5318 OP* const newblock = newSTATEOP(0, NULL, 0);
5320 op_getmad(block,newblock,'B');
5327 block->op_attached = 1;
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", SVfARG(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 return newUNOP(OP_RV2SV, 0, scalar(o));
5864 /* Check routines. See the comments at the top of this file for details
5865 * on when these are called */
5868 Perl_ck_anoncode(pTHX_ OP *o)
5870 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
5872 cSVOPo->op_sv = NULL;
5877 Perl_ck_bitop(pTHX_ OP *o)
5880 #define OP_IS_NUMCOMPARE(op) \
5881 ((op) == OP_LT || (op) == OP_I_LT || \
5882 (op) == OP_GT || (op) == OP_I_GT || \
5883 (op) == OP_LE || (op) == OP_I_LE || \
5884 (op) == OP_GE || (op) == OP_I_GE || \
5885 (op) == OP_EQ || (op) == OP_I_EQ || \
5886 (op) == OP_NE || (op) == OP_I_NE || \
5887 (op) == OP_NCMP || (op) == OP_I_NCMP)
5888 o->op_private = (U8)(PL_hints & HINT_INTEGER);
5889 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
5890 && (o->op_type == OP_BIT_OR
5891 || o->op_type == OP_BIT_AND
5892 || o->op_type == OP_BIT_XOR))
5894 const OP * const left = cBINOPo->op_first;
5895 const OP * const right = left->op_sibling;
5896 if ((OP_IS_NUMCOMPARE(left->op_type) &&
5897 (left->op_flags & OPf_PARENS) == 0) ||
5898 (OP_IS_NUMCOMPARE(right->op_type) &&
5899 (right->op_flags & OPf_PARENS) == 0))
5900 if (ckWARN(WARN_PRECEDENCE))
5901 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
5902 "Possible precedence problem on bitwise %c operator",
5903 o->op_type == OP_BIT_OR ? '|'
5904 : o->op_type == OP_BIT_AND ? '&' : '^'
5911 Perl_ck_concat(pTHX_ OP *o)
5913 const OP * const kid = cUNOPo->op_first;
5914 PERL_UNUSED_CONTEXT;
5915 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
5916 !(kUNOP->op_first->op_flags & OPf_MOD))
5917 o->op_flags |= OPf_STACKED;
5922 Perl_ck_spair(pTHX_ OP *o)
5925 if (o->op_flags & OPf_KIDS) {
5928 const OPCODE type = o->op_type;
5929 o = modkids(ck_fun(o), type);
5930 kid = cUNOPo->op_first;
5931 newop = kUNOP->op_first->op_sibling;
5933 const OPCODE type = newop->op_type;
5934 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
5935 type == OP_PADAV || type == OP_PADHV ||
5936 type == OP_RV2AV || type == OP_RV2HV)
5940 op_getmad(kUNOP->op_first,newop,'K');
5942 op_free(kUNOP->op_first);
5944 kUNOP->op_first = newop;
5946 o->op_ppaddr = PL_ppaddr[++o->op_type];
5951 Perl_ck_delete(pTHX_ OP *o)
5955 if (o->op_flags & OPf_KIDS) {
5956 OP * const kid = cUNOPo->op_first;
5957 switch (kid->op_type) {
5959 o->op_flags |= OPf_SPECIAL;
5962 o->op_private |= OPpSLICE;
5965 o->op_flags |= OPf_SPECIAL;
5970 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5979 Perl_ck_die(pTHX_ OP *o)
5982 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5988 Perl_ck_eof(pTHX_ OP *o)
5992 if (o->op_flags & OPf_KIDS) {
5993 if (cLISTOPo->op_first->op_type == OP_STUB) {
5995 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
5997 op_getmad(o,newop,'O');
6009 Perl_ck_eval(pTHX_ OP *o)
6012 PL_hints |= HINT_BLOCK_SCOPE;
6013 if (o->op_flags & OPf_KIDS) {
6014 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6017 o->op_flags &= ~OPf_KIDS;
6020 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
6026 cUNOPo->op_first = 0;
6031 NewOp(1101, enter, 1, LOGOP);
6032 enter->op_type = OP_ENTERTRY;
6033 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
6034 enter->op_private = 0;
6036 /* establish postfix order */
6037 enter->op_next = (OP*)enter;
6039 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
6040 o->op_type = OP_LEAVETRY;
6041 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
6042 enter->op_other = o;
6043 op_getmad(oldo,o,'O');
6057 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
6058 op_getmad(oldo,o,'O');
6060 o->op_targ = (PADOFFSET)PL_hints;
6061 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
6062 /* Store a copy of %^H that pp_entereval can pick up */
6063 OP *hhop = newSVOP(OP_CONST, 0,
6064 (SV*)Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv)));
6065 cUNOPo->op_first->op_sibling = hhop;
6066 o->op_private |= OPpEVAL_HAS_HH;
6072 Perl_ck_exit(pTHX_ OP *o)
6075 HV * const table = GvHV(PL_hintgv);
6077 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
6078 if (svp && *svp && SvTRUE(*svp))
6079 o->op_private |= OPpEXIT_VMSISH;
6081 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6087 Perl_ck_exec(pTHX_ OP *o)
6089 if (o->op_flags & OPf_STACKED) {
6092 kid = cUNOPo->op_first->op_sibling;
6093 if (kid->op_type == OP_RV2GV)
6102 Perl_ck_exists(pTHX_ OP *o)
6106 if (o->op_flags & OPf_KIDS) {
6107 OP * const kid = cUNOPo->op_first;
6108 if (kid->op_type == OP_ENTERSUB) {
6109 (void) ref(kid, o->op_type);
6110 if (kid->op_type != OP_RV2CV && !PL_error_count)
6111 Perl_croak(aTHX_ "%s argument is not a subroutine name",
6113 o->op_private |= OPpEXISTS_SUB;
6115 else if (kid->op_type == OP_AELEM)
6116 o->op_flags |= OPf_SPECIAL;
6117 else if (kid->op_type != OP_HELEM)
6118 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
6126 Perl_ck_rvconst(pTHX_ register OP *o)
6129 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6131 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6132 if (o->op_type == OP_RV2CV)
6133 o->op_private &= ~1;
6135 if (kid->op_type == OP_CONST) {
6138 SV * const kidsv = kid->op_sv;
6140 /* Is it a constant from cv_const_sv()? */
6141 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
6142 SV * const rsv = SvRV(kidsv);
6143 const svtype type = SvTYPE(rsv);
6144 const char *badtype = NULL;
6146 switch (o->op_type) {
6148 if (type > SVt_PVMG)
6149 badtype = "a SCALAR";
6152 if (type != SVt_PVAV)
6153 badtype = "an ARRAY";
6156 if (type != SVt_PVHV)
6160 if (type != SVt_PVCV)
6165 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
6168 else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
6169 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
6170 /* If this is an access to a stash, disable "strict refs", because
6171 * stashes aren't auto-vivified at compile-time (unless we store
6172 * symbols in them), and we don't want to produce a run-time
6173 * stricture error when auto-vivifying the stash. */
6174 const char *s = SvPV_nolen(kidsv);
6175 const STRLEN l = SvCUR(kidsv);
6176 if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
6177 o->op_private &= ~HINT_STRICT_REFS;
6179 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
6180 const char *badthing;
6181 switch (o->op_type) {
6183 badthing = "a SCALAR";
6186 badthing = "an ARRAY";
6189 badthing = "a HASH";
6197 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
6198 SVfARG(kidsv), badthing);
6201 * This is a little tricky. We only want to add the symbol if we
6202 * didn't add it in the lexer. Otherwise we get duplicate strict
6203 * warnings. But if we didn't add it in the lexer, we must at
6204 * least pretend like we wanted to add it even if it existed before,
6205 * or we get possible typo warnings. OPpCONST_ENTERED says
6206 * whether the lexer already added THIS instance of this symbol.
6208 iscv = (o->op_type == OP_RV2CV) * 2;
6210 gv = gv_fetchsv(kidsv,
6211 iscv | !(kid->op_private & OPpCONST_ENTERED),
6214 : o->op_type == OP_RV2SV
6216 : o->op_type == OP_RV2AV
6218 : o->op_type == OP_RV2HV
6221 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
6223 kid->op_type = OP_GV;
6224 SvREFCNT_dec(kid->op_sv);
6226 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
6227 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
6228 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
6230 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc_simple_NN(gv));
6232 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
6234 kid->op_private = 0;
6235 kid->op_ppaddr = PL_ppaddr[OP_GV];
6242 Perl_ck_ftst(pTHX_ OP *o)
6245 const I32 type = o->op_type;
6247 if (o->op_flags & OPf_REF) {
6250 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
6251 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6252 const OPCODE kidtype = kid->op_type;
6254 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6255 OP * const newop = newGVOP(type, OPf_REF,
6256 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
6258 op_getmad(o,newop,'O');
6264 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o))
6265 o->op_private |= OPpFT_ACCESS;
6266 if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst)
6267 && kidtype != OP_STAT && kidtype != OP_LSTAT)
6268 o->op_private |= OPpFT_STACKED;
6276 if (type == OP_FTTTY)
6277 o = newGVOP(type, OPf_REF, PL_stdingv);
6279 o = newUNOP(type, 0, newDEFSVOP());
6280 op_getmad(oldo,o,'O');
6286 Perl_ck_fun(pTHX_ OP *o)
6289 const int type = o->op_type;
6290 register I32 oa = PL_opargs[type] >> OASHIFT;
6292 if (o->op_flags & OPf_STACKED) {
6293 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
6296 return no_fh_allowed(o);
6299 if (o->op_flags & OPf_KIDS) {
6300 OP **tokid = &cLISTOPo->op_first;
6301 register OP *kid = cLISTOPo->op_first;
6305 if (kid->op_type == OP_PUSHMARK ||
6306 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
6308 tokid = &kid->op_sibling;
6309 kid = kid->op_sibling;
6311 if (!kid && PL_opargs[type] & OA_DEFGV)
6312 *tokid = kid = newDEFSVOP();
6316 sibl = kid->op_sibling;
6318 if (!sibl && kid->op_type == OP_STUB) {
6325 /* list seen where single (scalar) arg expected? */
6326 if (numargs == 1 && !(oa >> 4)
6327 && kid->op_type == OP_LIST && type != OP_SCALAR)
6329 return too_many_arguments(o,PL_op_desc[type]);
6342 if ((type == OP_PUSH || type == OP_UNSHIFT)
6343 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
6344 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6345 "Useless use of %s with no values",
6348 if (kid->op_type == OP_CONST &&
6349 (kid->op_private & OPpCONST_BARE))
6351 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
6352 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
6353 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6354 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6355 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
6356 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6358 op_getmad(kid,newop,'K');
6363 kid->op_sibling = sibl;
6366 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
6367 bad_type(numargs, "array", PL_op_desc[type], kid);
6371 if (kid->op_type == OP_CONST &&
6372 (kid->op_private & OPpCONST_BARE))
6374 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
6375 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
6376 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6377 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6378 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
6379 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6381 op_getmad(kid,newop,'K');
6386 kid->op_sibling = sibl;
6389 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
6390 bad_type(numargs, "hash", PL_op_desc[type], kid);
6395 OP * const newop = newUNOP(OP_NULL, 0, kid);
6396 kid->op_sibling = 0;
6398 newop->op_next = newop;
6400 kid->op_sibling = sibl;
6405 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
6406 if (kid->op_type == OP_CONST &&
6407 (kid->op_private & OPpCONST_BARE))
6409 OP * const newop = newGVOP(OP_GV, 0,
6410 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
6411 if (!(o->op_private & 1) && /* if not unop */
6412 kid == cLISTOPo->op_last)
6413 cLISTOPo->op_last = newop;
6415 op_getmad(kid,newop,'K');
6421 else if (kid->op_type == OP_READLINE) {
6422 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
6423 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
6426 I32 flags = OPf_SPECIAL;
6430 /* is this op a FH constructor? */
6431 if (is_handle_constructor(o,numargs)) {
6432 const char *name = NULL;
6436 /* Set a flag to tell rv2gv to vivify
6437 * need to "prove" flag does not mean something
6438 * else already - NI-S 1999/05/07
6441 if (kid->op_type == OP_PADSV) {
6443 = PAD_COMPNAME_SV(kid->op_targ);
6444 name = SvPV_const(namesv, len);
6446 else if (kid->op_type == OP_RV2SV
6447 && kUNOP->op_first->op_type == OP_GV)
6449 GV * const gv = cGVOPx_gv(kUNOP->op_first);
6451 len = GvNAMELEN(gv);
6453 else if (kid->op_type == OP_AELEM
6454 || kid->op_type == OP_HELEM)
6457 OP *op = ((BINOP*)kid)->op_first;
6461 const char * const a =
6462 kid->op_type == OP_AELEM ?
6464 if (((op->op_type == OP_RV2AV) ||
6465 (op->op_type == OP_RV2HV)) &&
6466 (firstop = ((UNOP*)op)->op_first) &&
6467 (firstop->op_type == OP_GV)) {
6468 /* packagevar $a[] or $h{} */
6469 GV * const gv = cGVOPx_gv(firstop);
6477 else if (op->op_type == OP_PADAV
6478 || op->op_type == OP_PADHV) {
6479 /* lexicalvar $a[] or $h{} */
6480 const char * const padname =
6481 PAD_COMPNAME_PV(op->op_targ);
6490 name = SvPV_const(tmpstr, len);
6495 name = "__ANONIO__";
6502 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
6503 namesv = PAD_SVl(targ);
6504 SvUPGRADE(namesv, SVt_PV);
6506 sv_setpvn(namesv, "$", 1);
6507 sv_catpvn(namesv, name, len);
6510 kid->op_sibling = 0;
6511 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
6512 kid->op_targ = targ;
6513 kid->op_private |= priv;
6515 kid->op_sibling = sibl;
6521 mod(scalar(kid), type);
6525 tokid = &kid->op_sibling;
6526 kid = kid->op_sibling;
6529 if (kid && kid->op_type != OP_STUB)
6530 return too_many_arguments(o,OP_DESC(o));
6531 o->op_private |= numargs;
6533 /* FIXME - should the numargs move as for the PERL_MAD case? */
6534 o->op_private |= numargs;
6536 return too_many_arguments(o,OP_DESC(o));
6540 else if (PL_opargs[type] & OA_DEFGV) {
6542 OP *newop = newUNOP(type, 0, newDEFSVOP());
6543 op_getmad(o,newop,'O');
6546 /* Ordering of these two is important to keep f_map.t passing. */
6548 return newUNOP(type, 0, newDEFSVOP());
6553 while (oa & OA_OPTIONAL)
6555 if (oa && oa != OA_LIST)
6556 return too_few_arguments(o,OP_DESC(o));
6562 Perl_ck_glob(pTHX_ OP *o)
6568 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
6569 append_elem(OP_GLOB, o, newDEFSVOP());
6571 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
6572 && GvCVu(gv) && GvIMPORTED_CV(gv)))
6574 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6577 #if !defined(PERL_EXTERNAL_GLOB)
6578 /* XXX this can be tightened up and made more failsafe. */
6579 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
6582 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
6583 newSVpvs("File::Glob"), NULL, NULL, NULL);
6584 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6585 glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
6586 GvCV(gv) = GvCV(glob_gv);
6587 SvREFCNT_inc_void((SV*)GvCV(gv));
6588 GvIMPORTED_CV_on(gv);
6591 #endif /* PERL_EXTERNAL_GLOB */
6593 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6594 append_elem(OP_GLOB, o,
6595 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
6596 o->op_type = OP_LIST;
6597 o->op_ppaddr = PL_ppaddr[OP_LIST];
6598 cLISTOPo->op_first->op_type = OP_PUSHMARK;
6599 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
6600 cLISTOPo->op_first->op_targ = 0;
6601 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
6602 append_elem(OP_LIST, o,
6603 scalar(newUNOP(OP_RV2CV, 0,
6604 newGVOP(OP_GV, 0, gv)))));
6605 o = newUNOP(OP_NULL, 0, ck_subr(o));
6606 o->op_targ = OP_GLOB; /* hint at what it used to be */
6609 gv = newGVgen("main");
6611 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
6617 Perl_ck_grep(pTHX_ OP *o)
6622 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
6625 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
6626 /* don't allocate gwop here, as we may leak it if PL_error_count > 0 */
6628 if (o->op_flags & OPf_STACKED) {
6631 kid = cLISTOPo->op_first->op_sibling;
6632 if (!cUNOPx(kid)->op_next)
6633 Perl_croak(aTHX_ "panic: ck_grep");
6634 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
6637 NewOp(1101, gwop, 1, LOGOP);
6638 kid->op_next = (OP*)gwop;
6639 o->op_flags &= ~OPf_STACKED;
6641 kid = cLISTOPo->op_first->op_sibling;
6642 if (type == OP_MAPWHILE)
6649 kid = cLISTOPo->op_first->op_sibling;
6650 if (kid->op_type != OP_NULL)
6651 Perl_croak(aTHX_ "panic: ck_grep");
6652 kid = kUNOP->op_first;
6655 NewOp(1101, gwop, 1, LOGOP);
6656 gwop->op_type = type;
6657 gwop->op_ppaddr = PL_ppaddr[type];
6658 gwop->op_first = listkids(o);
6659 gwop->op_flags |= OPf_KIDS;
6660 gwop->op_other = LINKLIST(kid);
6661 kid->op_next = (OP*)gwop;
6662 offset = pad_findmy("$_");
6663 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
6664 o->op_private = gwop->op_private = 0;
6665 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
6668 o->op_private = gwop->op_private = OPpGREP_LEX;
6669 gwop->op_targ = o->op_targ = offset;
6672 kid = cLISTOPo->op_first->op_sibling;
6673 if (!kid || !kid->op_sibling)
6674 return too_few_arguments(o,OP_DESC(o));
6675 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
6676 mod(kid, OP_GREPSTART);
6682 Perl_ck_index(pTHX_ OP *o)
6684 if (o->op_flags & OPf_KIDS) {
6685 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6687 kid = kid->op_sibling; /* get past "big" */
6688 if (kid && kid->op_type == OP_CONST)
6689 fbm_compile(((SVOP*)kid)->op_sv, 0);
6695 Perl_ck_lengthconst(pTHX_ OP *o)
6697 /* XXX length optimization goes here */
6702 Perl_ck_lfun(pTHX_ OP *o)
6704 const OPCODE type = o->op_type;
6705 return modkids(ck_fun(o), type);
6709 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
6711 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
6712 switch (cUNOPo->op_first->op_type) {
6714 /* This is needed for
6715 if (defined %stash::)
6716 to work. Do not break Tk.
6718 break; /* Globals via GV can be undef */
6720 case OP_AASSIGN: /* Is this a good idea? */
6721 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6722 "defined(@array) is deprecated");
6723 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6724 "\t(Maybe you should just omit the defined()?)\n");
6727 /* This is needed for
6728 if (defined %stash::)
6729 to work. Do not break Tk.
6731 break; /* Globals via GV can be undef */
6733 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6734 "defined(%%hash) is deprecated");
6735 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6736 "\t(Maybe you should just omit the defined()?)\n");
6747 Perl_ck_rfun(pTHX_ OP *o)
6749 const OPCODE type = o->op_type;
6750 return refkids(ck_fun(o), type);
6754 Perl_ck_listiob(pTHX_ OP *o)
6758 kid = cLISTOPo->op_first;
6761 kid = cLISTOPo->op_first;
6763 if (kid->op_type == OP_PUSHMARK)
6764 kid = kid->op_sibling;
6765 if (kid && o->op_flags & OPf_STACKED)
6766 kid = kid->op_sibling;
6767 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6768 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6769 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6770 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6771 cLISTOPo->op_first->op_sibling = kid;
6772 cLISTOPo->op_last = kid;
6773 kid = kid->op_sibling;
6778 append_elem(o->op_type, o, newDEFSVOP());
6784 Perl_ck_smartmatch(pTHX_ OP *o)
6787 if (0 == (o->op_flags & OPf_SPECIAL)) {
6788 OP *first = cBINOPo->op_first;
6789 OP *second = first->op_sibling;
6791 /* Implicitly take a reference to an array or hash */
6792 first->op_sibling = NULL;
6793 first = cBINOPo->op_first = ref_array_or_hash(first);
6794 second = first->op_sibling = ref_array_or_hash(second);
6796 /* Implicitly take a reference to a regular expression */
6797 if (first->op_type == OP_MATCH) {
6798 first->op_type = OP_QR;
6799 first->op_ppaddr = PL_ppaddr[OP_QR];
6801 if (second->op_type == OP_MATCH) {
6802 second->op_type = OP_QR;
6803 second->op_ppaddr = PL_ppaddr[OP_QR];
6812 Perl_ck_sassign(pTHX_ OP *o)
6814 OP * const kid = cLISTOPo->op_first;
6815 /* has a disposable target? */
6816 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6817 && !(kid->op_flags & OPf_STACKED)
6818 /* Cannot steal the second time! */
6819 && !(kid->op_private & OPpTARGET_MY))
6821 OP * const kkid = kid->op_sibling;
6823 /* Can just relocate the target. */
6824 if (kkid && kkid->op_type == OP_PADSV
6825 && !(kkid->op_private & OPpLVAL_INTRO))
6827 kid->op_targ = kkid->op_targ;
6829 /* Now we do not need PADSV and SASSIGN. */
6830 kid->op_sibling = o->op_sibling; /* NULL */
6831 cLISTOPo->op_first = NULL;
6833 op_getmad(o,kid,'O');
6834 op_getmad(kkid,kid,'M');
6839 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6843 if (kid->op_sibling) {
6844 OP *kkid = kid->op_sibling;
6845 if (kkid->op_type == OP_PADSV
6846 && (kkid->op_private & OPpLVAL_INTRO)
6847 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
6848 o->op_private |= OPpASSIGN_STATE;
6849 /* hijacking PADSTALE for uninitialized state variables */
6850 SvPADSTALE_on(PAD_SVl(kkid->op_targ));
6857 Perl_ck_match(pTHX_ OP *o)
6860 if (o->op_type != OP_QR && PL_compcv) {
6861 const PADOFFSET offset = pad_findmy("$_");
6862 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
6863 o->op_targ = offset;
6864 o->op_private |= OPpTARGET_MY;
6867 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
6868 o->op_private |= OPpRUNTIME;
6873 Perl_ck_method(pTHX_ OP *o)
6875 OP * const kid = cUNOPo->op_first;
6876 if (kid->op_type == OP_CONST) {
6877 SV* sv = kSVOP->op_sv;
6878 const char * const method = SvPVX_const(sv);
6879 if (!(strchr(method, ':') || strchr(method, '\''))) {
6881 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6882 sv = newSVpvn_share(method, SvCUR(sv), 0);
6885 kSVOP->op_sv = NULL;
6887 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6889 op_getmad(o,cmop,'O');
6900 Perl_ck_null(pTHX_ OP *o)
6902 PERL_UNUSED_CONTEXT;
6907 Perl_ck_open(pTHX_ OP *o)
6910 HV * const table = GvHV(PL_hintgv);
6912 SV **svp = hv_fetchs(table, "open_IN", FALSE);
6914 const I32 mode = mode_from_discipline(*svp);
6915 if (mode & O_BINARY)
6916 o->op_private |= OPpOPEN_IN_RAW;
6917 else if (mode & O_TEXT)
6918 o->op_private |= OPpOPEN_IN_CRLF;
6921 svp = hv_fetchs(table, "open_OUT", FALSE);
6923 const I32 mode = mode_from_discipline(*svp);
6924 if (mode & O_BINARY)
6925 o->op_private |= OPpOPEN_OUT_RAW;
6926 else if (mode & O_TEXT)
6927 o->op_private |= OPpOPEN_OUT_CRLF;
6930 if (o->op_type == OP_BACKTICK)
6933 /* In case of three-arg dup open remove strictness
6934 * from the last arg if it is a bareword. */
6935 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
6936 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
6940 if ((last->op_type == OP_CONST) && /* The bareword. */
6941 (last->op_private & OPpCONST_BARE) &&
6942 (last->op_private & OPpCONST_STRICT) &&
6943 (oa = first->op_sibling) && /* The fh. */
6944 (oa = oa->op_sibling) && /* The mode. */
6945 (oa->op_type == OP_CONST) &&
6946 SvPOK(((SVOP*)oa)->op_sv) &&
6947 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
6948 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
6949 (last == oa->op_sibling)) /* The bareword. */
6950 last->op_private &= ~OPpCONST_STRICT;
6956 Perl_ck_repeat(pTHX_ OP *o)
6958 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6959 o->op_private |= OPpREPEAT_DOLIST;
6960 cBINOPo->op_first = force_list(cBINOPo->op_first);
6968 Perl_ck_require(pTHX_ OP *o)
6973 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6974 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6976 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6977 SV * const sv = kid->op_sv;
6978 U32 was_readonly = SvREADONLY(sv);
6983 sv_force_normal_flags(sv, 0);
6984 assert(!SvREADONLY(sv));
6991 for (s = SvPVX(sv); *s; s++) {
6992 if (*s == ':' && s[1] == ':') {
6993 const STRLEN len = strlen(s+2)+1;
6995 Move(s+2, s+1, len, char);
6996 SvCUR_set(sv, SvCUR(sv) - 1);
6999 sv_catpvs(sv, ".pm");
7000 SvFLAGS(sv) |= was_readonly;
7004 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
7005 /* handle override, if any */
7006 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
7007 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7008 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
7009 gv = gvp ? *gvp : NULL;
7013 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7014 OP * const kid = cUNOPo->op_first;
7017 cUNOPo->op_first = 0;
7021 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
7022 append_elem(OP_LIST, kid,
7023 scalar(newUNOP(OP_RV2CV, 0,
7026 op_getmad(o,newop,'O');
7034 Perl_ck_return(pTHX_ OP *o)
7037 if (CvLVALUE(PL_compcv)) {
7039 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
7040 mod(kid, OP_LEAVESUBLV);
7046 Perl_ck_select(pTHX_ OP *o)
7050 if (o->op_flags & OPf_KIDS) {
7051 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7052 if (kid && kid->op_sibling) {
7053 o->op_type = OP_SSELECT;
7054 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
7056 return fold_constants(o);
7060 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7061 if (kid && kid->op_type == OP_RV2GV)
7062 kid->op_private &= ~HINT_STRICT_REFS;
7067 Perl_ck_shift(pTHX_ OP *o)
7070 const I32 type = o->op_type;
7072 if (!(o->op_flags & OPf_KIDS)) {
7074 /* FIXME - this can be refactored to reduce code in #ifdefs */
7076 OP * const oldo = o;
7080 argop = newUNOP(OP_RV2AV, 0,
7081 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
7083 o = newUNOP(type, 0, scalar(argop));
7084 op_getmad(oldo,o,'O');
7087 return newUNOP(type, 0, scalar(argop));
7090 return scalar(modkids(ck_fun(o), type));
7094 Perl_ck_sort(pTHX_ OP *o)
7099 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
7100 HV * const hinthv = GvHV(PL_hintgv);
7102 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
7104 const I32 sorthints = (I32)SvIV(*svp);
7105 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
7106 o->op_private |= OPpSORT_QSORT;
7107 if ((sorthints & HINT_SORT_STABLE) != 0)
7108 o->op_private |= OPpSORT_STABLE;
7113 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
7115 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7116 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
7118 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
7120 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
7122 if (kid->op_type == OP_SCOPE) {
7126 else if (kid->op_type == OP_LEAVE) {
7127 if (o->op_type == OP_SORT) {
7128 op_null(kid); /* wipe out leave */
7131 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
7132 if (k->op_next == kid)
7134 /* don't descend into loops */
7135 else if (k->op_type == OP_ENTERLOOP
7136 || k->op_type == OP_ENTERITER)
7138 k = cLOOPx(k)->op_lastop;
7143 kid->op_next = 0; /* just disconnect the leave */
7144 k = kLISTOP->op_first;
7149 if (o->op_type == OP_SORT) {
7150 /* provide scalar context for comparison function/block */
7156 o->op_flags |= OPf_SPECIAL;
7158 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
7161 firstkid = firstkid->op_sibling;
7164 /* provide list context for arguments */
7165 if (o->op_type == OP_SORT)
7172 S_simplify_sort(pTHX_ OP *o)
7175 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7180 if (!(o->op_flags & OPf_STACKED))
7182 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7183 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
7184 kid = kUNOP->op_first; /* get past null */
7185 if (kid->op_type != OP_SCOPE)
7187 kid = kLISTOP->op_last; /* get past scope */
7188 switch(kid->op_type) {
7196 k = kid; /* remember this node*/
7197 if (kBINOP->op_first->op_type != OP_RV2SV)
7199 kid = kBINOP->op_first; /* get past cmp */
7200 if (kUNOP->op_first->op_type != OP_GV)
7202 kid = kUNOP->op_first; /* get past rv2sv */
7204 if (GvSTASH(gv) != PL_curstash)
7206 gvname = GvNAME(gv);
7207 if (*gvname == 'a' && gvname[1] == '\0')
7209 else if (*gvname == 'b' && gvname[1] == '\0')
7214 kid = k; /* back to cmp */
7215 if (kBINOP->op_last->op_type != OP_RV2SV)
7217 kid = kBINOP->op_last; /* down to 2nd arg */
7218 if (kUNOP->op_first->op_type != OP_GV)
7220 kid = kUNOP->op_first; /* get past rv2sv */
7222 if (GvSTASH(gv) != PL_curstash)
7224 gvname = GvNAME(gv);
7226 ? !(*gvname == 'a' && gvname[1] == '\0')
7227 : !(*gvname == 'b' && gvname[1] == '\0'))
7229 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
7231 o->op_private |= OPpSORT_DESCEND;
7232 if (k->op_type == OP_NCMP)
7233 o->op_private |= OPpSORT_NUMERIC;
7234 if (k->op_type == OP_I_NCMP)
7235 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
7236 kid = cLISTOPo->op_first->op_sibling;
7237 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
7239 op_getmad(kid,o,'S'); /* then delete it */
7241 op_free(kid); /* then delete it */
7246 Perl_ck_split(pTHX_ OP *o)
7251 if (o->op_flags & OPf_STACKED)
7252 return no_fh_allowed(o);
7254 kid = cLISTOPo->op_first;
7255 if (kid->op_type != OP_NULL)
7256 Perl_croak(aTHX_ "panic: ck_split");
7257 kid = kid->op_sibling;
7258 op_free(cLISTOPo->op_first);
7259 cLISTOPo->op_first = kid;
7261 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
7262 cLISTOPo->op_last = kid; /* There was only one element previously */
7265 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
7266 OP * const sibl = kid->op_sibling;
7267 kid->op_sibling = 0;
7268 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
7269 if (cLISTOPo->op_first == cLISTOPo->op_last)
7270 cLISTOPo->op_last = kid;
7271 cLISTOPo->op_first = kid;
7272 kid->op_sibling = sibl;
7275 kid->op_type = OP_PUSHRE;
7276 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
7278 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
7279 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
7280 "Use of /g modifier is meaningless in split");
7283 if (!kid->op_sibling)
7284 append_elem(OP_SPLIT, o, newDEFSVOP());
7286 kid = kid->op_sibling;
7289 if (!kid->op_sibling)
7290 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
7291 assert(kid->op_sibling);
7293 kid = kid->op_sibling;
7296 if (kid->op_sibling)
7297 return too_many_arguments(o,OP_DESC(o));
7303 Perl_ck_join(pTHX_ OP *o)
7305 const OP * const kid = cLISTOPo->op_first->op_sibling;
7306 if (kid && kid->op_type == OP_MATCH) {
7307 if (ckWARN(WARN_SYNTAX)) {
7308 const REGEXP *re = PM_GETRE(kPMOP);
7309 const char *pmstr = re ? re->precomp : "STRING";
7310 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7311 "/%s/ should probably be written as \"%s\"",
7319 Perl_ck_subr(pTHX_ OP *o)
7322 OP *prev = ((cUNOPo->op_first->op_sibling)
7323 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
7324 OP *o2 = prev->op_sibling;
7326 const char *proto = NULL;
7327 const char *proto_end = NULL;
7332 I32 contextclass = 0;
7333 const char *e = NULL;
7336 o->op_private |= OPpENTERSUB_HASTARG;
7337 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
7338 if (cvop->op_type == OP_RV2CV) {
7340 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
7341 op_null(cvop); /* disable rv2cv */
7342 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
7343 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
7344 GV *gv = cGVOPx_gv(tmpop);
7347 tmpop->op_private |= OPpEARLY_CV;
7351 namegv = CvANON(cv) ? gv : CvGV(cv);
7352 proto = SvPV((SV*)cv, len);
7353 proto_end = proto + len;
7355 if (CvASSERTION(cv)) {
7356 U32 asserthints = 0;
7357 HV *const hinthv = GvHV(PL_hintgv);
7359 SV **svp = hv_fetchs(hinthv, "assertions", FALSE);
7361 asserthints = SvUV(*svp);
7363 if (asserthints & HINT_ASSERTING) {
7364 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
7365 o->op_private |= OPpENTERSUB_DB;
7369 if (!(asserthints & HINT_ASSERTIONSSEEN) && ckWARN(WARN_ASSERTIONS)) {
7370 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
7371 "Impossible to activate assertion call");
7378 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7379 if (o2->op_type == OP_CONST)
7380 o2->op_private &= ~OPpCONST_STRICT;
7381 else if (o2->op_type == OP_LIST) {
7382 OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
7383 if (sib && sib->op_type == OP_CONST)
7384 sib->op_private &= ~OPpCONST_STRICT;
7387 o->op_private |= (PL_hints & HINT_STRICT_REFS);
7388 if (PERLDB_SUB && PL_curstash != PL_debstash)
7389 o->op_private |= OPpENTERSUB_DB;
7390 while (o2 != cvop) {
7392 if (PL_madskills && o2->op_type == OP_NULL)
7393 o3 = ((UNOP*)o2)->op_first;
7397 if (proto >= proto_end)
7398 return too_many_arguments(o, gv_ename(namegv));
7406 /* _ must be at the end */
7407 if (proto[1] && proto[1] != ';')
7422 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
7424 arg == 1 ? "block or sub {}" : "sub {}",
7425 gv_ename(namegv), o3);
7428 /* '*' allows any scalar type, including bareword */
7431 if (o3->op_type == OP_RV2GV)
7432 goto wrapref; /* autoconvert GLOB -> GLOBref */
7433 else if (o3->op_type == OP_CONST)
7434 o3->op_private &= ~OPpCONST_STRICT;
7435 else if (o3->op_type == OP_ENTERSUB) {
7436 /* accidental subroutine, revert to bareword */
7437 OP *gvop = ((UNOP*)o3)->op_first;
7438 if (gvop && gvop->op_type == OP_NULL) {
7439 gvop = ((UNOP*)gvop)->op_first;
7441 for (; gvop->op_sibling; gvop = gvop->op_sibling)
7444 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
7445 (gvop = ((UNOP*)gvop)->op_first) &&
7446 gvop->op_type == OP_GV)
7448 GV * const gv = cGVOPx_gv(gvop);
7449 OP * const sibling = o2->op_sibling;
7450 SV * const n = newSVpvs("");
7452 OP * const oldo2 = o2;
7456 gv_fullname4(n, gv, "", FALSE);
7457 o2 = newSVOP(OP_CONST, 0, n);
7458 op_getmad(oldo2,o2,'O');
7459 prev->op_sibling = o2;
7460 o2->op_sibling = sibling;
7476 if (contextclass++ == 0) {
7477 e = strchr(proto, ']');
7478 if (!e || e == proto)
7487 const char *p = proto;
7488 const char *const end = proto;
7490 while (*--p != '[');
7491 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
7493 gv_ename(namegv), o3);
7498 if (o3->op_type == OP_RV2GV)
7501 bad_type(arg, "symbol", gv_ename(namegv), o3);
7504 if (o3->op_type == OP_ENTERSUB)
7507 bad_type(arg, "subroutine entry", gv_ename(namegv),
7511 if (o3->op_type == OP_RV2SV ||
7512 o3->op_type == OP_PADSV ||
7513 o3->op_type == OP_HELEM ||
7514 o3->op_type == OP_AELEM)
7517 bad_type(arg, "scalar", gv_ename(namegv), o3);
7520 if (o3->op_type == OP_RV2AV ||
7521 o3->op_type == OP_PADAV)
7524 bad_type(arg, "array", gv_ename(namegv), o3);
7527 if (o3->op_type == OP_RV2HV ||
7528 o3->op_type == OP_PADHV)
7531 bad_type(arg, "hash", gv_ename(namegv), o3);
7536 OP* const sib = kid->op_sibling;
7537 kid->op_sibling = 0;
7538 o2 = newUNOP(OP_REFGEN, 0, kid);
7539 o2->op_sibling = sib;
7540 prev->op_sibling = o2;
7542 if (contextclass && e) {
7557 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
7558 gv_ename(namegv), SVfARG(cv));
7563 mod(o2, OP_ENTERSUB);
7565 o2 = o2->op_sibling;
7567 if (o2 == cvop && proto && *proto == '_') {
7568 /* generate an access to $_ */
7570 o2->op_sibling = prev->op_sibling;
7571 prev->op_sibling = o2; /* instead of cvop */
7573 if (proto && !optional && proto_end > proto &&
7574 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
7575 return too_few_arguments(o, gv_ename(namegv));
7578 OP * const oldo = o;
7582 o=newSVOP(OP_CONST, 0, newSViv(0));
7583 op_getmad(oldo,o,'O');
7589 Perl_ck_svconst(pTHX_ OP *o)
7591 PERL_UNUSED_CONTEXT;
7592 SvREADONLY_on(cSVOPo->op_sv);
7597 Perl_ck_chdir(pTHX_ OP *o)
7599 if (o->op_flags & OPf_KIDS) {
7600 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7602 if (kid && kid->op_type == OP_CONST &&
7603 (kid->op_private & OPpCONST_BARE))
7605 o->op_flags |= OPf_SPECIAL;
7606 kid->op_private &= ~OPpCONST_STRICT;
7613 Perl_ck_trunc(pTHX_ OP *o)
7615 if (o->op_flags & OPf_KIDS) {
7616 SVOP *kid = (SVOP*)cUNOPo->op_first;
7618 if (kid->op_type == OP_NULL)
7619 kid = (SVOP*)kid->op_sibling;
7620 if (kid && kid->op_type == OP_CONST &&
7621 (kid->op_private & OPpCONST_BARE))
7623 o->op_flags |= OPf_SPECIAL;
7624 kid->op_private &= ~OPpCONST_STRICT;
7631 Perl_ck_unpack(pTHX_ OP *o)
7633 OP *kid = cLISTOPo->op_first;
7634 if (kid->op_sibling) {
7635 kid = kid->op_sibling;
7636 if (!kid->op_sibling)
7637 kid->op_sibling = newDEFSVOP();
7643 Perl_ck_substr(pTHX_ OP *o)
7646 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
7647 OP *kid = cLISTOPo->op_first;
7649 if (kid->op_type == OP_NULL)
7650 kid = kid->op_sibling;
7652 kid->op_flags |= OPf_MOD;
7658 /* A peephole optimizer. We visit the ops in the order they're to execute.
7659 * See the comments at the top of this file for more details about when
7660 * peep() is called */
7663 Perl_peep(pTHX_ register OP *o)
7666 register OP* oldop = NULL;
7668 if (!o || o->op_opt)
7672 SAVEVPTR(PL_curcop);
7673 for (; o; o = o->op_next) {
7677 switch (o->op_type) {
7681 PL_curcop = ((COP*)o); /* for warnings */
7686 if (cSVOPo->op_private & OPpCONST_STRICT)
7687 no_bareword_allowed(o);
7689 case OP_METHOD_NAMED:
7690 /* Relocate sv to the pad for thread safety.
7691 * Despite being a "constant", the SV is written to,
7692 * for reference counts, sv_upgrade() etc. */
7694 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
7695 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
7696 /* If op_sv is already a PADTMP then it is being used by
7697 * some pad, so make a copy. */
7698 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
7699 SvREADONLY_on(PAD_SVl(ix));
7700 SvREFCNT_dec(cSVOPo->op_sv);
7702 else if (o->op_type == OP_CONST
7703 && cSVOPo->op_sv == &PL_sv_undef) {
7704 /* PL_sv_undef is hack - it's unsafe to store it in the
7705 AV that is the pad, because av_fetch treats values of
7706 PL_sv_undef as a "free" AV entry and will merrily
7707 replace them with a new SV, causing pad_alloc to think
7708 that this pad slot is free. (When, clearly, it is not)
7710 SvOK_off(PAD_SVl(ix));
7711 SvPADTMP_on(PAD_SVl(ix));
7712 SvREADONLY_on(PAD_SVl(ix));
7715 SvREFCNT_dec(PAD_SVl(ix));
7716 SvPADTMP_on(cSVOPo->op_sv);
7717 PAD_SETSV(ix, cSVOPo->op_sv);
7718 /* XXX I don't know how this isn't readonly already. */
7719 SvREADONLY_on(PAD_SVl(ix));
7721 cSVOPo->op_sv = NULL;
7729 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
7730 if (o->op_next->op_private & OPpTARGET_MY) {
7731 if (o->op_flags & OPf_STACKED) /* chained concats */
7732 goto ignore_optimization;
7734 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
7735 o->op_targ = o->op_next->op_targ;
7736 o->op_next->op_targ = 0;
7737 o->op_private |= OPpTARGET_MY;
7740 op_null(o->op_next);
7742 ignore_optimization:
7746 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
7748 break; /* Scalar stub must produce undef. List stub is noop */
7752 if (o->op_targ == OP_NEXTSTATE
7753 || o->op_targ == OP_DBSTATE
7754 || o->op_targ == OP_SETSTATE)
7756 PL_curcop = ((COP*)o);
7758 /* XXX: We avoid setting op_seq here to prevent later calls
7759 to peep() from mistakenly concluding that optimisation
7760 has already occurred. This doesn't fix the real problem,
7761 though (See 20010220.007). AMS 20010719 */
7762 /* op_seq functionality is now replaced by op_opt */
7763 if (oldop && o->op_next) {
7764 oldop->op_next = o->op_next;
7772 if (oldop && o->op_next) {
7773 oldop->op_next = o->op_next;
7781 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
7782 OP* const pop = (o->op_type == OP_PADAV) ?
7783 o->op_next : o->op_next->op_next;
7785 if (pop && pop->op_type == OP_CONST &&
7786 ((PL_op = pop->op_next)) &&
7787 pop->op_next->op_type == OP_AELEM &&
7788 !(pop->op_next->op_private &
7789 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
7790 (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
7795 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
7796 no_bareword_allowed(pop);
7797 if (o->op_type == OP_GV)
7798 op_null(o->op_next);
7799 op_null(pop->op_next);
7801 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
7802 o->op_next = pop->op_next->op_next;
7803 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
7804 o->op_private = (U8)i;
7805 if (o->op_type == OP_GV) {
7810 o->op_flags |= OPf_SPECIAL;
7811 o->op_type = OP_AELEMFAST;
7817 if (o->op_next->op_type == OP_RV2SV) {
7818 if (!(o->op_next->op_private & OPpDEREF)) {
7819 op_null(o->op_next);
7820 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
7822 o->op_next = o->op_next->op_next;
7823 o->op_type = OP_GVSV;
7824 o->op_ppaddr = PL_ppaddr[OP_GVSV];
7827 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
7828 GV * const gv = cGVOPo_gv;
7829 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
7830 /* XXX could check prototype here instead of just carping */
7831 SV * const sv = sv_newmortal();
7832 gv_efullname3(sv, gv, NULL);
7833 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
7834 "%"SVf"() called too early to check prototype",
7838 else if (o->op_next->op_type == OP_READLINE
7839 && o->op_next->op_next->op_type == OP_CONCAT
7840 && (o->op_next->op_next->op_flags & OPf_STACKED))
7842 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
7843 o->op_type = OP_RCATLINE;
7844 o->op_flags |= OPf_STACKED;
7845 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
7846 op_null(o->op_next->op_next);
7847 op_null(o->op_next);
7864 while (cLOGOP->op_other->op_type == OP_NULL)
7865 cLOGOP->op_other = cLOGOP->op_other->op_next;
7866 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
7872 while (cLOOP->op_redoop->op_type == OP_NULL)
7873 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
7874 peep(cLOOP->op_redoop);
7875 while (cLOOP->op_nextop->op_type == OP_NULL)
7876 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
7877 peep(cLOOP->op_nextop);
7878 while (cLOOP->op_lastop->op_type == OP_NULL)
7879 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
7880 peep(cLOOP->op_lastop);
7887 while (cPMOP->op_pmreplstart &&
7888 cPMOP->op_pmreplstart->op_type == OP_NULL)
7889 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
7890 peep(cPMOP->op_pmreplstart);
7895 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
7896 && ckWARN(WARN_SYNTAX))
7898 if (o->op_next->op_sibling) {
7899 const OPCODE type = o->op_next->op_sibling->op_type;
7900 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
7901 const line_t oldline = CopLINE(PL_curcop);
7902 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
7903 Perl_warner(aTHX_ packWARN(WARN_EXEC),
7904 "Statement unlikely to be reached");
7905 Perl_warner(aTHX_ packWARN(WARN_EXEC),
7906 "\t(Maybe you meant system() when you said exec()?)\n");
7907 CopLINE_set(PL_curcop, oldline);
7918 const char *key = NULL;
7923 if (((BINOP*)o)->op_last->op_type != OP_CONST)
7926 /* Make the CONST have a shared SV */
7927 svp = cSVOPx_svp(((BINOP*)o)->op_last);
7928 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
7929 key = SvPV_const(sv, keylen);
7930 lexname = newSVpvn_share(key,
7931 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
7937 if ((o->op_private & (OPpLVAL_INTRO)))
7940 rop = (UNOP*)((BINOP*)o)->op_first;
7941 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7943 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7944 if (!SvPAD_TYPED(lexname))
7946 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
7947 if (!fields || !GvHV(*fields))
7949 key = SvPV_const(*svp, keylen);
7950 if (!hv_fetch(GvHV(*fields), key,
7951 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
7953 Perl_croak(aTHX_ "No such class field \"%s\" "
7954 "in variable %s of type %s",
7955 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
7968 SVOP *first_key_op, *key_op;
7970 if ((o->op_private & (OPpLVAL_INTRO))
7971 /* I bet there's always a pushmark... */
7972 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
7973 /* hmmm, no optimization if list contains only one key. */
7975 rop = (UNOP*)((LISTOP*)o)->op_last;
7976 if (rop->op_type != OP_RV2HV)
7978 if (rop->op_first->op_type == OP_PADSV)
7979 /* @$hash{qw(keys here)} */
7980 rop = (UNOP*)rop->op_first;
7982 /* @{$hash}{qw(keys here)} */
7983 if (rop->op_first->op_type == OP_SCOPE
7984 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
7986 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
7992 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
7993 if (!SvPAD_TYPED(lexname))
7995 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
7996 if (!fields || !GvHV(*fields))
7998 /* Again guessing that the pushmark can be jumped over.... */
7999 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
8000 ->op_first->op_sibling;
8001 for (key_op = first_key_op; key_op;
8002 key_op = (SVOP*)key_op->op_sibling) {
8003 if (key_op->op_type != OP_CONST)
8005 svp = cSVOPx_svp(key_op);
8006 key = SvPV_const(*svp, keylen);
8007 if (!hv_fetch(GvHV(*fields), key,
8008 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8010 Perl_croak(aTHX_ "No such class field \"%s\" "
8011 "in variable %s of type %s",
8012 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
8019 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
8023 /* check that RHS of sort is a single plain array */
8024 OP *oright = cUNOPo->op_first;
8025 if (!oright || oright->op_type != OP_PUSHMARK)
8028 /* reverse sort ... can be optimised. */
8029 if (!cUNOPo->op_sibling) {
8030 /* Nothing follows us on the list. */
8031 OP * const reverse = o->op_next;
8033 if (reverse->op_type == OP_REVERSE &&
8034 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
8035 OP * const pushmark = cUNOPx(reverse)->op_first;
8036 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
8037 && (cUNOPx(pushmark)->op_sibling == o)) {
8038 /* reverse -> pushmark -> sort */
8039 o->op_private |= OPpSORT_REVERSE;
8041 pushmark->op_next = oright->op_next;
8047 /* make @a = sort @a act in-place */
8051 oright = cUNOPx(oright)->op_sibling;
8054 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
8055 oright = cUNOPx(oright)->op_sibling;
8059 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
8060 || oright->op_next != o
8061 || (oright->op_private & OPpLVAL_INTRO)
8065 /* o2 follows the chain of op_nexts through the LHS of the
8066 * assign (if any) to the aassign op itself */
8068 if (!o2 || o2->op_type != OP_NULL)
8071 if (!o2 || o2->op_type != OP_PUSHMARK)
8074 if (o2 && o2->op_type == OP_GV)
8077 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
8078 || (o2->op_private & OPpLVAL_INTRO)
8083 if (!o2 || o2->op_type != OP_NULL)
8086 if (!o2 || o2->op_type != OP_AASSIGN
8087 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
8090 /* check that the sort is the first arg on RHS of assign */
8092 o2 = cUNOPx(o2)->op_first;
8093 if (!o2 || o2->op_type != OP_NULL)
8095 o2 = cUNOPx(o2)->op_first;
8096 if (!o2 || o2->op_type != OP_PUSHMARK)
8098 if (o2->op_sibling != o)
8101 /* check the array is the same on both sides */
8102 if (oleft->op_type == OP_RV2AV) {
8103 if (oright->op_type != OP_RV2AV
8104 || !cUNOPx(oright)->op_first
8105 || cUNOPx(oright)->op_first->op_type != OP_GV
8106 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
8107 cGVOPx_gv(cUNOPx(oright)->op_first)
8111 else if (oright->op_type != OP_PADAV
8112 || oright->op_targ != oleft->op_targ
8116 /* transfer MODishness etc from LHS arg to RHS arg */
8117 oright->op_flags = oleft->op_flags;
8118 o->op_private |= OPpSORT_INPLACE;
8120 /* excise push->gv->rv2av->null->aassign */
8121 o2 = o->op_next->op_next;
8122 op_null(o2); /* PUSHMARK */
8124 if (o2->op_type == OP_GV) {
8125 op_null(o2); /* GV */
8128 op_null(o2); /* RV2AV or PADAV */
8129 o2 = o2->op_next->op_next;
8130 op_null(o2); /* AASSIGN */
8132 o->op_next = o2->op_next;
8138 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
8140 LISTOP *enter, *exlist;
8143 enter = (LISTOP *) o->op_next;
8146 if (enter->op_type == OP_NULL) {
8147 enter = (LISTOP *) enter->op_next;
8151 /* for $a (...) will have OP_GV then OP_RV2GV here.
8152 for (...) just has an OP_GV. */
8153 if (enter->op_type == OP_GV) {
8154 gvop = (OP *) enter;
8155 enter = (LISTOP *) enter->op_next;
8158 if (enter->op_type == OP_RV2GV) {
8159 enter = (LISTOP *) enter->op_next;
8165 if (enter->op_type != OP_ENTERITER)
8168 iter = enter->op_next;
8169 if (!iter || iter->op_type != OP_ITER)
8172 expushmark = enter->op_first;
8173 if (!expushmark || expushmark->op_type != OP_NULL
8174 || expushmark->op_targ != OP_PUSHMARK)
8177 exlist = (LISTOP *) expushmark->op_sibling;
8178 if (!exlist || exlist->op_type != OP_NULL
8179 || exlist->op_targ != OP_LIST)
8182 if (exlist->op_last != o) {
8183 /* Mmm. Was expecting to point back to this op. */
8186 theirmark = exlist->op_first;
8187 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
8190 if (theirmark->op_sibling != o) {
8191 /* There's something between the mark and the reverse, eg
8192 for (1, reverse (...))
8197 ourmark = ((LISTOP *)o)->op_first;
8198 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
8201 ourlast = ((LISTOP *)o)->op_last;
8202 if (!ourlast || ourlast->op_next != o)
8205 rv2av = ourmark->op_sibling;
8206 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
8207 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
8208 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
8209 /* We're just reversing a single array. */
8210 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
8211 enter->op_flags |= OPf_STACKED;
8214 /* We don't have control over who points to theirmark, so sacrifice
8216 theirmark->op_next = ourmark->op_next;
8217 theirmark->op_flags = ourmark->op_flags;
8218 ourlast->op_next = gvop ? gvop : (OP *) enter;
8221 enter->op_private |= OPpITER_REVERSED;
8222 iter->op_private |= OPpITER_REVERSED;
8229 UNOP *refgen, *rv2cv;
8232 /* I do not understand this, but if o->op_opt isn't set to 1,
8233 various tests in ext/B/t/bytecode.t fail with no readily
8239 if ((o->op_flags && OPf_WANT) != OPf_WANT_VOID)
8242 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
8245 rv2gv = ((BINOP *)o)->op_last;
8246 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
8249 refgen = (UNOP *)((BINOP *)o)->op_first;
8251 if (!refgen || refgen->op_type != OP_REFGEN)
8254 exlist = (LISTOP *)refgen->op_first;
8255 if (!exlist || exlist->op_type != OP_NULL
8256 || exlist->op_targ != OP_LIST)
8259 if (exlist->op_first->op_type != OP_PUSHMARK)
8262 rv2cv = (UNOP*)exlist->op_last;
8264 if (rv2cv->op_type != OP_RV2CV)
8267 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
8268 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
8269 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
8271 o->op_private |= OPpASSIGN_CV_TO_GV;
8272 rv2gv->op_private |= OPpDONT_INIT_GV;
8273 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
8289 Perl_custom_op_name(pTHX_ const OP* o)
8292 const IV index = PTR2IV(o->op_ppaddr);
8296 if (!PL_custom_op_names) /* This probably shouldn't happen */
8297 return (char *)PL_op_name[OP_CUSTOM];
8299 keysv = sv_2mortal(newSViv(index));
8301 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
8303 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
8305 return SvPV_nolen(HeVAL(he));
8309 Perl_custom_op_desc(pTHX_ const OP* o)
8312 const IV index = PTR2IV(o->op_ppaddr);
8316 if (!PL_custom_op_descs)
8317 return (char *)PL_op_desc[OP_CUSTOM];
8319 keysv = sv_2mortal(newSViv(index));
8321 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
8323 return (char *)PL_op_desc[OP_CUSTOM];
8325 return SvPV_nolen(HeVAL(he));
8330 /* Efficient sub that returns a constant scalar value. */
8332 const_sv_xsub(pTHX_ CV* cv)
8339 Perl_croak(aTHX_ "usage: %s::%s()",
8340 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
8344 ST(0) = (SV*)XSANY.any_ptr;
8350 * c-indentation-style: bsd
8352 * indent-tabs-mode: t
8355 * ex: set ts=8 sts=4 sw=4 noet: