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;
1555 o->op_flags |= OPf_MOD; /* XXX ??? */
1561 o->op_flags |= OPf_REF;
1564 if (type == OP_DEFINED)
1565 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1566 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1572 o->op_flags |= OPf_REF;
1577 if (!(o->op_flags & OPf_KIDS))
1579 doref(cBINOPo->op_first, type, set_op_ref);
1583 doref(cBINOPo->op_first, o->op_type, set_op_ref);
1584 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1585 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1586 : type == OP_RV2HV ? OPpDEREF_HV
1588 o->op_flags |= OPf_MOD;
1598 if (!(o->op_flags & OPf_KIDS))
1600 doref(cLISTOPo->op_last, type, set_op_ref);
1610 S_dup_attrlist(pTHX_ OP *o)
1615 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1616 * where the first kid is OP_PUSHMARK and the remaining ones
1617 * are OP_CONST. We need to push the OP_CONST values.
1619 if (o->op_type == OP_CONST)
1620 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
1622 else if (o->op_type == OP_NULL)
1626 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1628 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1629 if (o->op_type == OP_CONST)
1630 rop = append_elem(OP_LIST, rop,
1631 newSVOP(OP_CONST, o->op_flags,
1632 SvREFCNT_inc_NN(cSVOPo->op_sv)));
1639 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1644 /* fake up C<use attributes $pkg,$rv,@attrs> */
1645 ENTER; /* need to protect against side-effects of 'use' */
1647 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1649 #define ATTRSMODULE "attributes"
1650 #define ATTRSMODULE_PM "attributes.pm"
1653 /* Don't force the C<use> if we don't need it. */
1654 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
1655 if (svp && *svp != &PL_sv_undef)
1656 NOOP; /* already in %INC */
1658 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1659 newSVpvs(ATTRSMODULE), NULL);
1662 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1663 newSVpvs(ATTRSMODULE),
1665 prepend_elem(OP_LIST,
1666 newSVOP(OP_CONST, 0, stashsv),
1667 prepend_elem(OP_LIST,
1668 newSVOP(OP_CONST, 0,
1670 dup_attrlist(attrs))));
1676 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1679 OP *pack, *imop, *arg;
1685 assert(target->op_type == OP_PADSV ||
1686 target->op_type == OP_PADHV ||
1687 target->op_type == OP_PADAV);
1689 /* Ensure that attributes.pm is loaded. */
1690 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1692 /* Need package name for method call. */
1693 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
1695 /* Build up the real arg-list. */
1696 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1698 arg = newOP(OP_PADSV, 0);
1699 arg->op_targ = target->op_targ;
1700 arg = prepend_elem(OP_LIST,
1701 newSVOP(OP_CONST, 0, stashsv),
1702 prepend_elem(OP_LIST,
1703 newUNOP(OP_REFGEN, 0,
1704 mod(arg, OP_REFGEN)),
1705 dup_attrlist(attrs)));
1707 /* Fake up a method call to import */
1708 meth = newSVpvs_share("import");
1709 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1710 append_elem(OP_LIST,
1711 prepend_elem(OP_LIST, pack, list(arg)),
1712 newSVOP(OP_METHOD_NAMED, 0, meth)));
1713 imop->op_private |= OPpENTERSUB_NOMOD;
1715 /* Combine the ops. */
1716 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1720 =notfor apidoc apply_attrs_string
1722 Attempts to apply a list of attributes specified by the C<attrstr> and
1723 C<len> arguments to the subroutine identified by the C<cv> argument which
1724 is expected to be associated with the package identified by the C<stashpv>
1725 argument (see L<attributes>). It gets this wrong, though, in that it
1726 does not correctly identify the boundaries of the individual attribute
1727 specifications within C<attrstr>. This is not really intended for the
1728 public API, but has to be listed here for systems such as AIX which
1729 need an explicit export list for symbols. (It's called from XS code
1730 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1731 to respect attribute syntax properly would be welcome.
1737 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
1738 const char *attrstr, STRLEN len)
1743 len = strlen(attrstr);
1747 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1749 const char * const sstr = attrstr;
1750 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1751 attrs = append_elem(OP_LIST, attrs,
1752 newSVOP(OP_CONST, 0,
1753 newSVpvn(sstr, attrstr-sstr)));
1757 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1758 newSVpvs(ATTRSMODULE),
1759 NULL, prepend_elem(OP_LIST,
1760 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1761 prepend_elem(OP_LIST,
1762 newSVOP(OP_CONST, 0,
1768 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
1773 if (!o || PL_error_count)
1777 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
1778 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
1782 if (type == OP_LIST) {
1784 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1785 my_kid(kid, attrs, imopsp);
1786 } else if (type == OP_UNDEF
1792 } else if (type == OP_RV2SV || /* "our" declaration */
1794 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1795 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1796 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1798 PL_in_my == KEY_our ? "our" : PL_in_my == KEY_state ? "state" : "my"));
1800 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
1802 PL_in_my_stash = NULL;
1803 apply_attrs(GvSTASH(gv),
1804 (type == OP_RV2SV ? GvSV(gv) :
1805 type == OP_RV2AV ? (SV*)GvAV(gv) :
1806 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1809 o->op_private |= OPpOUR_INTRO;
1812 else if (type != OP_PADSV &&
1815 type != OP_PUSHMARK)
1817 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1819 PL_in_my == KEY_our ? "our" : PL_in_my == KEY_state ? "state" : "my"));
1822 else if (attrs && type != OP_PUSHMARK) {
1826 PL_in_my_stash = NULL;
1828 /* check for C<my Dog $spot> when deciding package */
1829 stash = PAD_COMPNAME_TYPE(o->op_targ);
1831 stash = PL_curstash;
1832 apply_attrs_my(stash, o, attrs, imopsp);
1834 o->op_flags |= OPf_MOD;
1835 o->op_private |= OPpLVAL_INTRO;
1836 if (PL_in_my == KEY_state)
1837 o->op_private |= OPpPAD_STATE;
1842 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1846 int maybe_scalar = 0;
1848 /* [perl #17376]: this appears to be premature, and results in code such as
1849 C< our(%x); > executing in list mode rather than void mode */
1851 if (o->op_flags & OPf_PARENS)
1861 o = my_kid(o, attrs, &rops);
1863 if (maybe_scalar && o->op_type == OP_PADSV) {
1864 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
1865 o->op_private |= OPpLVAL_INTRO;
1868 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
1871 PL_in_my_stash = NULL;
1876 Perl_my(pTHX_ OP *o)
1878 return my_attrs(o, NULL);
1882 Perl_sawparens(pTHX_ OP *o)
1884 PERL_UNUSED_CONTEXT;
1886 o->op_flags |= OPf_PARENS;
1891 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
1895 const OPCODE ltype = left->op_type;
1896 const OPCODE rtype = right->op_type;
1898 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
1899 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
1901 const char * const desc
1902 = PL_op_desc[(rtype == OP_SUBST || rtype == OP_TRANS)
1903 ? (int)rtype : OP_MATCH];
1904 const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV)
1905 ? "@array" : "%hash");
1906 Perl_warner(aTHX_ packWARN(WARN_MISC),
1907 "Applying %s to %s will act on scalar(%s)",
1908 desc, sample, sample);
1911 if (rtype == OP_CONST &&
1912 cSVOPx(right)->op_private & OPpCONST_BARE &&
1913 cSVOPx(right)->op_private & OPpCONST_STRICT)
1915 no_bareword_allowed(right);
1918 ismatchop = rtype == OP_MATCH ||
1919 rtype == OP_SUBST ||
1921 if (ismatchop && right->op_private & OPpTARGET_MY) {
1923 right->op_private &= ~OPpTARGET_MY;
1925 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
1928 right->op_flags |= OPf_STACKED;
1929 if (rtype != OP_MATCH &&
1930 ! (rtype == OP_TRANS &&
1931 right->op_private & OPpTRANS_IDENTICAL))
1932 newleft = mod(left, rtype);
1935 if (right->op_type == OP_TRANS)
1936 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
1938 o = prepend_elem(rtype, scalar(newleft), right);
1940 return newUNOP(OP_NOT, 0, scalar(o));
1944 return bind_match(type, left,
1945 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
1949 Perl_invert(pTHX_ OP *o)
1953 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
1957 Perl_scope(pTHX_ OP *o)
1961 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
1962 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
1963 o->op_type = OP_LEAVE;
1964 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
1966 else if (o->op_type == OP_LINESEQ) {
1968 o->op_type = OP_SCOPE;
1969 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
1970 kid = ((LISTOP*)o)->op_first;
1971 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
1974 /* The following deals with things like 'do {1 for 1}' */
1975 kid = kid->op_sibling;
1977 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
1982 o = newLISTOP(OP_SCOPE, 0, o, NULL);
1988 Perl_block_start(pTHX_ int full)
1991 const int retval = PL_savestack_ix;
1992 pad_block_start(full);
1994 PL_hints &= ~HINT_BLOCK_SCOPE;
1995 SAVECOMPILEWARNINGS();
1996 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
2001 Perl_block_end(pTHX_ I32 floor, OP *seq)
2004 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2005 OP* const retval = scalarseq(seq);
2007 CopHINTS_set(&PL_compiling, PL_hints);
2009 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2018 const PADOFFSET offset = pad_findmy("$_");
2019 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
2020 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2023 OP * const o = newOP(OP_PADSV, 0);
2024 o->op_targ = offset;
2030 Perl_newPROG(pTHX_ OP *o)
2036 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2037 ((PL_in_eval & EVAL_KEEPERR)
2038 ? OPf_SPECIAL : 0), o);
2039 PL_eval_start = linklist(PL_eval_root);
2040 PL_eval_root->op_private |= OPpREFCOUNTED;
2041 OpREFCNT_set(PL_eval_root, 1);
2042 PL_eval_root->op_next = 0;
2043 CALL_PEEP(PL_eval_start);
2046 if (o->op_type == OP_STUB) {
2047 PL_comppad_name = 0;
2049 S_op_destroy(aTHX_ o);
2052 PL_main_root = scope(sawparens(scalarvoid(o)));
2053 PL_curcop = &PL_compiling;
2054 PL_main_start = LINKLIST(PL_main_root);
2055 PL_main_root->op_private |= OPpREFCOUNTED;
2056 OpREFCNT_set(PL_main_root, 1);
2057 PL_main_root->op_next = 0;
2058 CALL_PEEP(PL_main_start);
2061 /* Register with debugger */
2063 CV * const cv = get_cv("DB::postponed", FALSE);
2067 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2069 call_sv((SV*)cv, G_DISCARD);
2076 Perl_localize(pTHX_ OP *o, I32 lex)
2079 if (o->op_flags & OPf_PARENS)
2080 /* [perl #17376]: this appears to be premature, and results in code such as
2081 C< our(%x); > executing in list mode rather than void mode */
2088 if ( PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ','
2089 && ckWARN(WARN_PARENTHESIS))
2091 char *s = PL_bufptr;
2094 /* some heuristics to detect a potential error */
2095 while (*s && (strchr(", \t\n", *s)))
2099 if (*s && strchr("@$%*", *s) && *++s
2100 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2103 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2105 while (*s && (strchr(", \t\n", *s)))
2111 if (sigil && (*s == ';' || *s == '=')) {
2112 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2113 "Parentheses missing around \"%s\" list",
2114 lex ? (PL_in_my == KEY_our ? "our" : PL_in_my == KEY_state ? "state" : "my")
2122 o = mod(o, OP_NULL); /* a bit kludgey */
2124 PL_in_my_stash = NULL;
2129 Perl_jmaybe(pTHX_ OP *o)
2131 if (o->op_type == OP_LIST) {
2133 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2134 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2140 Perl_fold_constants(pTHX_ register OP *o)
2145 VOL I32 type = o->op_type;
2150 SV * const oldwarnhook = PL_warnhook;
2151 SV * const olddiehook = PL_diehook;
2154 if (PL_opargs[type] & OA_RETSCALAR)
2156 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2157 o->op_targ = pad_alloc(type, SVs_PADTMP);
2159 /* integerize op, unless it happens to be C<-foo>.
2160 * XXX should pp_i_negate() do magic string negation instead? */
2161 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2162 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2163 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2165 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2168 if (!(PL_opargs[type] & OA_FOLDCONST))
2173 /* XXX might want a ck_negate() for this */
2174 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2185 /* XXX what about the numeric ops? */
2186 if (PL_hints & HINT_LOCALE)
2191 goto nope; /* Don't try to run w/ errors */
2193 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2194 const OPCODE type = curop->op_type;
2195 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2197 type != OP_SCALAR &&
2199 type != OP_PUSHMARK)
2205 curop = LINKLIST(o);
2206 old_next = o->op_next;
2210 oldscope = PL_scopestack_ix;
2211 create_eval_scope(G_FAKINGEVAL);
2213 PL_warnhook = PERL_WARNHOOK_FATAL;
2220 sv = *(PL_stack_sp--);
2221 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2222 pad_swipe(o->op_targ, FALSE);
2223 else if (SvTEMP(sv)) { /* grab mortal temp? */
2224 SvREFCNT_inc_simple_void(sv);
2229 /* Something tried to die. Abandon constant folding. */
2230 /* Pretend the error never happened. */
2231 sv_setpvn(ERRSV,"",0);
2232 o->op_next = old_next;
2236 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
2237 PL_warnhook = oldwarnhook;
2238 PL_diehook = olddiehook;
2239 /* XXX note that this croak may fail as we've already blown away
2240 * the stack - eg any nested evals */
2241 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
2244 PL_warnhook = oldwarnhook;
2245 PL_diehook = olddiehook;
2247 if (PL_scopestack_ix > oldscope)
2248 delete_eval_scope();
2257 if (type == OP_RV2GV)
2258 newop = newGVOP(OP_GV, 0, (GV*)sv);
2260 newop = newSVOP(OP_CONST, 0, (SV*)sv);
2261 op_getmad(o,newop,'f');
2269 Perl_gen_constant_list(pTHX_ register OP *o)
2273 const I32 oldtmps_floor = PL_tmps_floor;
2277 return o; /* Don't attempt to run with errors */
2279 PL_op = curop = LINKLIST(o);
2285 assert (!(curop->op_flags & OPf_SPECIAL));
2286 assert(curop->op_type == OP_RANGE);
2288 PL_tmps_floor = oldtmps_floor;
2290 o->op_type = OP_RV2AV;
2291 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2292 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2293 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2294 o->op_opt = 0; /* needs to be revisited in peep() */
2295 curop = ((UNOP*)o)->op_first;
2296 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
2298 op_getmad(curop,o,'O');
2307 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2310 if (!o || o->op_type != OP_LIST)
2311 o = newLISTOP(OP_LIST, 0, o, NULL);
2313 o->op_flags &= ~OPf_WANT;
2315 if (!(PL_opargs[type] & OA_MARK))
2316 op_null(cLISTOPo->op_first);
2318 o->op_type = (OPCODE)type;
2319 o->op_ppaddr = PL_ppaddr[type];
2320 o->op_flags |= flags;
2322 o = CHECKOP(type, o);
2323 if (o->op_type != (unsigned)type)
2326 return fold_constants(o);
2329 /* List constructors */
2332 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2340 if (first->op_type != (unsigned)type
2341 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2343 return newLISTOP(type, 0, first, last);
2346 if (first->op_flags & OPf_KIDS)
2347 ((LISTOP*)first)->op_last->op_sibling = last;
2349 first->op_flags |= OPf_KIDS;
2350 ((LISTOP*)first)->op_first = last;
2352 ((LISTOP*)first)->op_last = last;
2357 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2365 if (first->op_type != (unsigned)type)
2366 return prepend_elem(type, (OP*)first, (OP*)last);
2368 if (last->op_type != (unsigned)type)
2369 return append_elem(type, (OP*)first, (OP*)last);
2371 first->op_last->op_sibling = last->op_first;
2372 first->op_last = last->op_last;
2373 first->op_flags |= (last->op_flags & OPf_KIDS);
2376 if (last->op_first && first->op_madprop) {
2377 MADPROP *mp = last->op_first->op_madprop;
2379 while (mp->mad_next)
2381 mp->mad_next = first->op_madprop;
2384 last->op_first->op_madprop = first->op_madprop;
2387 first->op_madprop = last->op_madprop;
2388 last->op_madprop = 0;
2391 S_op_destroy(aTHX_ (OP*)last);
2397 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2405 if (last->op_type == (unsigned)type) {
2406 if (type == OP_LIST) { /* already a PUSHMARK there */
2407 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2408 ((LISTOP*)last)->op_first->op_sibling = first;
2409 if (!(first->op_flags & OPf_PARENS))
2410 last->op_flags &= ~OPf_PARENS;
2413 if (!(last->op_flags & OPf_KIDS)) {
2414 ((LISTOP*)last)->op_last = first;
2415 last->op_flags |= OPf_KIDS;
2417 first->op_sibling = ((LISTOP*)last)->op_first;
2418 ((LISTOP*)last)->op_first = first;
2420 last->op_flags |= OPf_KIDS;
2424 return newLISTOP(type, 0, first, last);
2432 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2435 Newxz(tk, 1, TOKEN);
2436 tk->tk_type = (OPCODE)optype;
2437 tk->tk_type = 12345;
2439 tk->tk_mad = madprop;
2444 Perl_token_free(pTHX_ TOKEN* tk)
2446 if (tk->tk_type != 12345)
2448 mad_free(tk->tk_mad);
2453 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2457 if (tk->tk_type != 12345) {
2458 Perl_warner(aTHX_ packWARN(WARN_MISC),
2459 "Invalid TOKEN object ignored");
2466 /* faked up qw list? */
2468 tm->mad_type == MAD_SV &&
2469 SvPVX((SV*)tm->mad_val)[0] == 'q')
2476 /* pretend constant fold didn't happen? */
2477 if (mp->mad_key == 'f' &&
2478 (o->op_type == OP_CONST ||
2479 o->op_type == OP_GV) )
2481 token_getmad(tk,(OP*)mp->mad_val,slot);
2495 if (mp->mad_key == 'X')
2496 mp->mad_key = slot; /* just change the first one */
2506 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
2515 /* pretend constant fold didn't happen? */
2516 if (mp->mad_key == 'f' &&
2517 (o->op_type == OP_CONST ||
2518 o->op_type == OP_GV) )
2520 op_getmad(from,(OP*)mp->mad_val,slot);
2527 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
2530 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
2536 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
2545 /* pretend constant fold didn't happen? */
2546 if (mp->mad_key == 'f' &&
2547 (o->op_type == OP_CONST ||
2548 o->op_type == OP_GV) )
2550 op_getmad(from,(OP*)mp->mad_val,slot);
2557 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
2560 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
2564 PerlIO_printf(PerlIO_stderr(),
2565 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
2571 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
2589 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
2593 addmad(tm, &(o->op_madprop), slot);
2597 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
2618 Perl_newMADsv(pTHX_ char key, SV* sv)
2620 return newMADPROP(key, MAD_SV, sv, 0);
2624 Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
2627 Newxz(mp, 1, MADPROP);
2630 mp->mad_vlen = vlen;
2631 mp->mad_type = type;
2633 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
2638 Perl_mad_free(pTHX_ MADPROP* mp)
2640 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
2644 mad_free(mp->mad_next);
2645 /* if (PL_lex_state != LEX_NOTPARSING && mp->mad_vlen)
2646 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
2647 switch (mp->mad_type) {
2651 Safefree((char*)mp->mad_val);
2654 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
2655 op_free((OP*)mp->mad_val);
2658 sv_free((SV*)mp->mad_val);
2661 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
2670 Perl_newNULLLIST(pTHX)
2672 return newOP(OP_STUB, 0);
2676 Perl_force_list(pTHX_ OP *o)
2678 if (!o || o->op_type != OP_LIST)
2679 o = newLISTOP(OP_LIST, 0, o, NULL);
2685 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2690 NewOp(1101, listop, 1, LISTOP);
2692 listop->op_type = (OPCODE)type;
2693 listop->op_ppaddr = PL_ppaddr[type];
2696 listop->op_flags = (U8)flags;
2700 else if (!first && last)
2703 first->op_sibling = last;
2704 listop->op_first = first;
2705 listop->op_last = last;
2706 if (type == OP_LIST) {
2707 OP* const pushop = newOP(OP_PUSHMARK, 0);
2708 pushop->op_sibling = first;
2709 listop->op_first = pushop;
2710 listop->op_flags |= OPf_KIDS;
2712 listop->op_last = pushop;
2715 return CHECKOP(type, listop);
2719 Perl_newOP(pTHX_ I32 type, I32 flags)
2723 NewOp(1101, o, 1, OP);
2724 o->op_type = (OPCODE)type;
2725 o->op_ppaddr = PL_ppaddr[type];
2726 o->op_flags = (U8)flags;
2728 o->op_latefreed = 0;
2732 o->op_private = (U8)(0 | (flags >> 8));
2733 if (PL_opargs[type] & OA_RETSCALAR)
2735 if (PL_opargs[type] & OA_TARGET)
2736 o->op_targ = pad_alloc(type, SVs_PADTMP);
2737 return CHECKOP(type, o);
2741 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2747 first = newOP(OP_STUB, 0);
2748 if (PL_opargs[type] & OA_MARK)
2749 first = force_list(first);
2751 NewOp(1101, unop, 1, UNOP);
2752 unop->op_type = (OPCODE)type;
2753 unop->op_ppaddr = PL_ppaddr[type];
2754 unop->op_first = first;
2755 unop->op_flags = (U8)(flags | OPf_KIDS);
2756 unop->op_private = (U8)(1 | (flags >> 8));
2757 unop = (UNOP*) CHECKOP(type, unop);
2761 return fold_constants((OP *) unop);
2765 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2769 NewOp(1101, binop, 1, BINOP);
2772 first = newOP(OP_NULL, 0);
2774 binop->op_type = (OPCODE)type;
2775 binop->op_ppaddr = PL_ppaddr[type];
2776 binop->op_first = first;
2777 binop->op_flags = (U8)(flags | OPf_KIDS);
2780 binop->op_private = (U8)(1 | (flags >> 8));
2783 binop->op_private = (U8)(2 | (flags >> 8));
2784 first->op_sibling = last;
2787 binop = (BINOP*)CHECKOP(type, binop);
2788 if (binop->op_next || binop->op_type != (OPCODE)type)
2791 binop->op_last = binop->op_first->op_sibling;
2793 return fold_constants((OP *)binop);
2796 static int uvcompare(const void *a, const void *b)
2797 __attribute__nonnull__(1)
2798 __attribute__nonnull__(2)
2799 __attribute__pure__;
2800 static int uvcompare(const void *a, const void *b)
2802 if (*((const UV *)a) < (*(const UV *)b))
2804 if (*((const UV *)a) > (*(const UV *)b))
2806 if (*((const UV *)a+1) < (*(const UV *)b+1))
2808 if (*((const UV *)a+1) > (*(const UV *)b+1))
2814 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2817 SV * const tstr = ((SVOP*)expr)->op_sv;
2820 (repl->op_type == OP_NULL)
2821 ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
2823 ((SVOP*)repl)->op_sv;
2826 const U8 *t = (U8*)SvPV_const(tstr, tlen);
2827 const U8 *r = (U8*)SvPV_const(rstr, rlen);
2831 register short *tbl;
2833 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
2834 const I32 squash = o->op_private & OPpTRANS_SQUASH;
2835 I32 del = o->op_private & OPpTRANS_DELETE;
2836 PL_hints |= HINT_BLOCK_SCOPE;
2839 o->op_private |= OPpTRANS_FROM_UTF;
2842 o->op_private |= OPpTRANS_TO_UTF;
2844 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2845 SV* const listsv = newSVpvs("# comment\n");
2847 const U8* tend = t + tlen;
2848 const U8* rend = r + rlen;
2862 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2863 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2866 const U32 flags = UTF8_ALLOW_DEFAULT;
2870 t = tsave = bytes_to_utf8(t, &len);
2873 if (!to_utf && rlen) {
2875 r = rsave = bytes_to_utf8(r, &len);
2879 /* There are several snags with this code on EBCDIC:
2880 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2881 2. scan_const() in toke.c has encoded chars in native encoding which makes
2882 ranges at least in EBCDIC 0..255 range the bottom odd.
2886 U8 tmpbuf[UTF8_MAXBYTES+1];
2889 Newx(cp, 2*tlen, UV);
2891 transv = newSVpvs("");
2893 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
2895 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2897 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
2901 cp[2*i+1] = cp[2*i];
2905 qsort(cp, i, 2*sizeof(UV), uvcompare);
2906 for (j = 0; j < i; j++) {
2908 diff = val - nextmin;
2910 t = uvuni_to_utf8(tmpbuf,nextmin);
2911 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2913 U8 range_mark = UTF_TO_NATIVE(0xff);
2914 t = uvuni_to_utf8(tmpbuf, val - 1);
2915 sv_catpvn(transv, (char *)&range_mark, 1);
2916 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2923 t = uvuni_to_utf8(tmpbuf,nextmin);
2924 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2926 U8 range_mark = UTF_TO_NATIVE(0xff);
2927 sv_catpvn(transv, (char *)&range_mark, 1);
2929 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2930 UNICODE_ALLOW_SUPER);
2931 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2932 t = (const U8*)SvPVX_const(transv);
2933 tlen = SvCUR(transv);
2937 else if (!rlen && !del) {
2938 r = t; rlen = tlen; rend = tend;
2941 if ((!rlen && !del) || t == r ||
2942 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2944 o->op_private |= OPpTRANS_IDENTICAL;
2948 while (t < tend || tfirst <= tlast) {
2949 /* see if we need more "t" chars */
2950 if (tfirst > tlast) {
2951 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
2953 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2955 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
2962 /* now see if we need more "r" chars */
2963 if (rfirst > rlast) {
2965 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
2967 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2969 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
2978 rfirst = rlast = 0xffffffff;
2982 /* now see which range will peter our first, if either. */
2983 tdiff = tlast - tfirst;
2984 rdiff = rlast - rfirst;
2991 if (rfirst == 0xffffffff) {
2992 diff = tdiff; /* oops, pretend rdiff is infinite */
2994 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2995 (long)tfirst, (long)tlast);
2997 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
3001 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
3002 (long)tfirst, (long)(tfirst + diff),
3005 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3006 (long)tfirst, (long)rfirst);
3008 if (rfirst + diff > max)
3009 max = rfirst + diff;
3011 grows = (tfirst < rfirst &&
3012 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3024 else if (max > 0xff)
3029 PerlMemShared_free(cPVOPo->op_pv);
3030 cPVOPo->op_pv = NULL;
3031 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
3032 SvREFCNT_dec(listsv);
3033 SvREFCNT_dec(transv);
3035 if (!del && havefinal && rlen)
3036 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
3037 newSVuv((UV)final), 0);
3040 o->op_private |= OPpTRANS_GROWS;
3046 op_getmad(expr,o,'e');
3047 op_getmad(repl,o,'r');
3055 tbl = (short*)cPVOPo->op_pv;
3057 Zero(tbl, 256, short);
3058 for (i = 0; i < (I32)tlen; i++)
3060 for (i = 0, j = 0; i < 256; i++) {
3062 if (j >= (I32)rlen) {
3071 if (i < 128 && r[j] >= 128)
3081 o->op_private |= OPpTRANS_IDENTICAL;
3083 else if (j >= (I32)rlen)
3086 cPVOPo->op_pv = (char*)PerlMemShared_realloc(tbl,
3087 (0x101+rlen-j) * sizeof(short));
3088 tbl[0x100] = (short)(rlen - j);
3089 for (i=0; i < (I32)rlen - j; i++)
3090 tbl[0x101+i] = r[j+i];
3094 if (!rlen && !del) {
3097 o->op_private |= OPpTRANS_IDENTICAL;
3099 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3100 o->op_private |= OPpTRANS_IDENTICAL;
3102 for (i = 0; i < 256; i++)
3104 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3105 if (j >= (I32)rlen) {
3107 if (tbl[t[i]] == -1)
3113 if (tbl[t[i]] == -1) {
3114 if (t[i] < 128 && r[j] >= 128)
3121 o->op_private |= OPpTRANS_GROWS;
3123 op_getmad(expr,o,'e');
3124 op_getmad(repl,o,'r');
3134 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3139 NewOp(1101, pmop, 1, PMOP);
3140 pmop->op_type = (OPCODE)type;
3141 pmop->op_ppaddr = PL_ppaddr[type];
3142 pmop->op_flags = (U8)flags;
3143 pmop->op_private = (U8)(0 | (flags >> 8));
3145 if (PL_hints & HINT_RE_TAINT)
3146 pmop->op_pmpermflags |= PMf_RETAINT;
3147 if (PL_hints & HINT_LOCALE)
3148 pmop->op_pmpermflags |= PMf_LOCALE;
3149 pmop->op_pmflags = pmop->op_pmpermflags;
3152 if (av_len((AV*) PL_regex_pad[0]) > -1) {
3153 SV * const repointer = av_pop((AV*)PL_regex_pad[0]);
3154 pmop->op_pmoffset = SvIV(repointer);
3155 SvREPADTMP_off(repointer);
3156 sv_setiv(repointer,0);
3158 SV * const repointer = newSViv(0);
3159 av_push(PL_regex_padav, SvREFCNT_inc_simple_NN(repointer));
3160 pmop->op_pmoffset = av_len(PL_regex_padav);
3161 PL_regex_pad = AvARRAY(PL_regex_padav);
3165 /* link into pm list */
3166 if (type != OP_TRANS && PL_curstash) {
3167 MAGIC *mg = mg_find((SV*)PL_curstash, PERL_MAGIC_symtab);
3170 mg = sv_magicext((SV*)PL_curstash, 0, PERL_MAGIC_symtab, 0, 0, 0);
3172 pmop->op_pmnext = (PMOP*)mg->mg_obj;
3173 mg->mg_obj = (SV*)pmop;
3174 PmopSTASH_set(pmop,PL_curstash);
3177 return CHECKOP(type, pmop);
3180 /* Given some sort of match op o, and an expression expr containing a
3181 * pattern, either compile expr into a regex and attach it to o (if it's
3182 * constant), or convert expr into a runtime regcomp op sequence (if it's
3185 * isreg indicates that the pattern is part of a regex construct, eg
3186 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3187 * split "pattern", which aren't. In the former case, expr will be a list
3188 * if the pattern contains more than one term (eg /a$b/) or if it contains
3189 * a replacement, ie s/// or tr///.
3193 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
3198 I32 repl_has_vars = 0;
3202 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
3203 /* last element in list is the replacement; pop it */
3205 repl = cLISTOPx(expr)->op_last;
3206 kid = cLISTOPx(expr)->op_first;
3207 while (kid->op_sibling != repl)
3208 kid = kid->op_sibling;
3209 kid->op_sibling = NULL;
3210 cLISTOPx(expr)->op_last = kid;
3213 if (isreg && expr->op_type == OP_LIST &&
3214 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3216 /* convert single element list to element */
3217 OP* const oe = expr;
3218 expr = cLISTOPx(oe)->op_first->op_sibling;
3219 cLISTOPx(oe)->op_first->op_sibling = NULL;
3220 cLISTOPx(oe)->op_last = NULL;
3224 if (o->op_type == OP_TRANS) {
3225 return pmtrans(o, expr, repl);
3228 reglist = isreg && expr->op_type == OP_LIST;
3232 PL_hints |= HINT_BLOCK_SCOPE;
3235 if (expr->op_type == OP_CONST) {
3237 SV * const pat = ((SVOP*)expr)->op_sv;
3238 const char *p = SvPV_const(pat, plen);
3239 if ((o->op_flags & OPf_SPECIAL) && (*p == ' ' && p[1] == '\0')) {
3240 U32 was_readonly = SvREADONLY(pat);
3244 sv_force_normal_flags(pat, 0);
3245 assert(!SvREADONLY(pat));
3248 SvREADONLY_off(pat);
3252 sv_setpvn(pat, "\\s+", 3);
3254 SvFLAGS(pat) |= was_readonly;
3256 p = SvPV_const(pat, plen);
3257 pm->op_pmflags |= PMf_SKIPWHITE;
3260 pm->op_pmdynflags |= PMdf_UTF8;
3261 /* FIXME - can we make this function take const char * args? */
3262 PM_SETRE(pm, CALLREGCOMP((char*)p, (char*)p + plen, pm));
3263 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
3264 pm->op_pmflags |= PMf_WHITE;
3266 op_getmad(expr,(OP*)pm,'e');
3272 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3273 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3275 : OP_REGCMAYBE),0,expr);
3277 NewOp(1101, rcop, 1, LOGOP);
3278 rcop->op_type = OP_REGCOMP;
3279 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3280 rcop->op_first = scalar(expr);
3281 rcop->op_flags |= OPf_KIDS
3282 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3283 | (reglist ? OPf_STACKED : 0);
3284 rcop->op_private = 1;
3287 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3289 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
3292 /* establish postfix order */
3293 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3295 rcop->op_next = expr;
3296 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3299 rcop->op_next = LINKLIST(expr);
3300 expr->op_next = (OP*)rcop;
3303 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3308 if (pm->op_pmflags & PMf_EVAL) {
3310 if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
3311 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
3313 else if (repl->op_type == OP_CONST)
3317 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3318 if (curop->op_type == OP_SCOPE
3319 || curop->op_type == OP_LEAVE
3320 || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
3321 if (curop->op_type == OP_GV) {
3322 GV * const gv = cGVOPx_gv(curop);
3324 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3327 else if (curop->op_type == OP_RV2CV)
3329 else if (curop->op_type == OP_RV2SV ||
3330 curop->op_type == OP_RV2AV ||
3331 curop->op_type == OP_RV2HV ||
3332 curop->op_type == OP_RV2GV) {
3333 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3336 else if (curop->op_type == OP_PADSV ||
3337 curop->op_type == OP_PADAV ||
3338 curop->op_type == OP_PADHV ||
3339 curop->op_type == OP_PADANY)
3343 else if (curop->op_type == OP_PUSHRE)
3344 NOOP; /* Okay here, dangerous in newASSIGNOP */
3354 || PM_GETRE(pm)->extflags & RXf_EVAL_SEEN)))
3356 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3357 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
3358 prepend_elem(o->op_type, scalar(repl), o);
3361 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3362 pm->op_pmflags |= PMf_MAYBE_CONST;
3363 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3365 NewOp(1101, rcop, 1, LOGOP);
3366 rcop->op_type = OP_SUBSTCONT;
3367 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3368 rcop->op_first = scalar(repl);
3369 rcop->op_flags |= OPf_KIDS;
3370 rcop->op_private = 1;
3373 /* establish postfix order */
3374 rcop->op_next = LINKLIST(repl);
3375 repl->op_next = (OP*)rcop;
3377 pm->op_pmreplroot = scalar((OP*)rcop);
3378 pm->op_pmreplstart = LINKLIST(rcop);
3387 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3391 NewOp(1101, svop, 1, SVOP);
3392 svop->op_type = (OPCODE)type;
3393 svop->op_ppaddr = PL_ppaddr[type];
3395 svop->op_next = (OP*)svop;
3396 svop->op_flags = (U8)flags;
3397 if (PL_opargs[type] & OA_RETSCALAR)
3399 if (PL_opargs[type] & OA_TARGET)
3400 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3401 return CHECKOP(type, svop);
3405 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3409 NewOp(1101, padop, 1, PADOP);
3410 padop->op_type = (OPCODE)type;
3411 padop->op_ppaddr = PL_ppaddr[type];
3412 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3413 SvREFCNT_dec(PAD_SVl(padop->op_padix));
3414 PAD_SETSV(padop->op_padix, sv);
3417 padop->op_next = (OP*)padop;
3418 padop->op_flags = (U8)flags;
3419 if (PL_opargs[type] & OA_RETSCALAR)
3421 if (PL_opargs[type] & OA_TARGET)
3422 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3423 return CHECKOP(type, padop);
3427 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3433 return newPADOP(type, flags, SvREFCNT_inc_simple(gv));
3435 return newSVOP(type, flags, SvREFCNT_inc_simple(gv));
3440 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3444 NewOp(1101, pvop, 1, PVOP);
3445 pvop->op_type = (OPCODE)type;
3446 pvop->op_ppaddr = PL_ppaddr[type];
3448 pvop->op_next = (OP*)pvop;
3449 pvop->op_flags = (U8)flags;
3450 if (PL_opargs[type] & OA_RETSCALAR)
3452 if (PL_opargs[type] & OA_TARGET)
3453 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3454 return CHECKOP(type, pvop);
3462 Perl_package(pTHX_ OP *o)
3471 save_hptr(&PL_curstash);
3472 save_item(PL_curstname);
3474 name = SvPV_const(cSVOPo->op_sv, len);
3475 PL_curstash = gv_stashpvn(name, len, TRUE);
3476 sv_setpvn(PL_curstname, name, len);
3478 PL_hints |= HINT_BLOCK_SCOPE;
3479 PL_copline = NOLINE;
3485 if (!PL_madskills) {
3490 pegop = newOP(OP_NULL,0);
3491 op_getmad(o,pegop,'P');
3501 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3508 OP *pegop = newOP(OP_NULL,0);
3511 if (idop->op_type != OP_CONST)
3512 Perl_croak(aTHX_ "Module name must be constant");
3515 op_getmad(idop,pegop,'U');
3520 SV * const vesv = ((SVOP*)version)->op_sv;
3523 op_getmad(version,pegop,'V');
3524 if (!arg && !SvNIOKp(vesv)) {
3531 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3532 Perl_croak(aTHX_ "Version number must be constant number");
3534 /* Make copy of idop so we don't free it twice */
3535 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3537 /* Fake up a method call to VERSION */
3538 meth = newSVpvs_share("VERSION");
3539 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3540 append_elem(OP_LIST,
3541 prepend_elem(OP_LIST, pack, list(version)),
3542 newSVOP(OP_METHOD_NAMED, 0, meth)));
3546 /* Fake up an import/unimport */
3547 if (arg && arg->op_type == OP_STUB) {
3549 op_getmad(arg,pegop,'S');
3550 imop = arg; /* no import on explicit () */
3552 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3553 imop = NULL; /* use 5.0; */
3555 idop->op_private |= OPpCONST_NOVER;
3561 op_getmad(arg,pegop,'A');
3563 /* Make copy of idop so we don't free it twice */
3564 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3566 /* Fake up a method call to import/unimport */
3568 ? newSVpvs_share("import") : newSVpvs_share("unimport");
3569 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3570 append_elem(OP_LIST,
3571 prepend_elem(OP_LIST, pack, list(arg)),
3572 newSVOP(OP_METHOD_NAMED, 0, meth)));
3575 /* Fake up the BEGIN {}, which does its thing immediately. */
3577 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
3580 append_elem(OP_LINESEQ,
3581 append_elem(OP_LINESEQ,
3582 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
3583 newSTATEOP(0, NULL, veop)),
3584 newSTATEOP(0, NULL, imop) ));
3586 /* The "did you use incorrect case?" warning used to be here.
3587 * The problem is that on case-insensitive filesystems one
3588 * might get false positives for "use" (and "require"):
3589 * "use Strict" or "require CARP" will work. This causes
3590 * portability problems for the script: in case-strict
3591 * filesystems the script will stop working.
3593 * The "incorrect case" warning checked whether "use Foo"
3594 * imported "Foo" to your namespace, but that is wrong, too:
3595 * there is no requirement nor promise in the language that
3596 * a Foo.pm should or would contain anything in package "Foo".
3598 * There is very little Configure-wise that can be done, either:
3599 * the case-sensitivity of the build filesystem of Perl does not
3600 * help in guessing the case-sensitivity of the runtime environment.
3603 PL_hints |= HINT_BLOCK_SCOPE;
3604 PL_copline = NOLINE;
3606 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3609 if (!PL_madskills) {
3610 /* FIXME - don't allocate pegop if !PL_madskills */
3619 =head1 Embedding Functions
3621 =for apidoc load_module
3623 Loads the module whose name is pointed to by the string part of name.
3624 Note that the actual module name, not its filename, should be given.
3625 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3626 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3627 (or 0 for no flags). ver, if specified, provides version semantics
3628 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3629 arguments can be used to specify arguments to the module's import()
3630 method, similar to C<use Foo::Bar VERSION LIST>.
3635 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3638 va_start(args, ver);
3639 vload_module(flags, name, ver, &args);
3643 #ifdef PERL_IMPLICIT_CONTEXT
3645 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3649 va_start(args, ver);
3650 vload_module(flags, name, ver, &args);
3656 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3661 OP * const modname = newSVOP(OP_CONST, 0, name);
3662 modname->op_private |= OPpCONST_BARE;
3664 veop = newSVOP(OP_CONST, 0, ver);
3668 if (flags & PERL_LOADMOD_NOIMPORT) {
3669 imop = sawparens(newNULLLIST());
3671 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3672 imop = va_arg(*args, OP*);
3677 sv = va_arg(*args, SV*);
3679 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3680 sv = va_arg(*args, SV*);
3684 const line_t ocopline = PL_copline;
3685 COP * const ocurcop = PL_curcop;
3686 const int oexpect = PL_expect;
3688 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3689 veop, modname, imop);
3690 PL_expect = oexpect;
3691 PL_copline = ocopline;
3692 PL_curcop = ocurcop;
3697 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
3703 if (!force_builtin) {
3704 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
3705 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
3706 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
3707 gv = gvp ? *gvp : NULL;
3711 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3712 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3713 append_elem(OP_LIST, term,
3714 scalar(newUNOP(OP_RV2CV, 0,
3715 newGVOP(OP_GV, 0, gv))))));
3718 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3724 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3726 return newBINOP(OP_LSLICE, flags,
3727 list(force_list(subscript)),
3728 list(force_list(listval)) );
3732 S_is_list_assignment(pTHX_ register const OP *o)
3740 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
3741 o = cUNOPo->op_first;
3743 flags = o->op_flags;
3745 if (type == OP_COND_EXPR) {
3746 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
3747 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3752 yyerror("Assignment to both a list and a scalar");
3756 if (type == OP_LIST &&
3757 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
3758 o->op_private & OPpLVAL_INTRO)
3761 if (type == OP_LIST || flags & OPf_PARENS ||
3762 type == OP_RV2AV || type == OP_RV2HV ||
3763 type == OP_ASLICE || type == OP_HSLICE)
3766 if (type == OP_PADAV || type == OP_PADHV)
3769 if (type == OP_RV2SV)
3776 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3782 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3783 return newLOGOP(optype, 0,
3784 mod(scalar(left), optype),
3785 newUNOP(OP_SASSIGN, 0, scalar(right)));
3788 return newBINOP(optype, OPf_STACKED,
3789 mod(scalar(left), optype), scalar(right));
3793 if (is_list_assignment(left)) {
3797 /* Grandfathering $[ assignment here. Bletch.*/
3798 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
3799 PL_eval_start = (left->op_type == OP_CONST) ? right : 0;
3800 left = mod(left, OP_AASSIGN);
3803 else if (left->op_type == OP_CONST) {
3805 /* Result of assignment is always 1 (or we'd be dead already) */
3806 return newSVOP(OP_CONST, 0, newSViv(1));
3808 curop = list(force_list(left));
3809 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3810 o->op_private = (U8)(0 | (flags >> 8));
3812 /* PL_generation sorcery:
3813 * an assignment like ($a,$b) = ($c,$d) is easier than
3814 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3815 * To detect whether there are common vars, the global var
3816 * PL_generation is incremented for each assign op we compile.
3817 * Then, while compiling the assign op, we run through all the
3818 * variables on both sides of the assignment, setting a spare slot
3819 * in each of them to PL_generation. If any of them already have
3820 * that value, we know we've got commonality. We could use a
3821 * single bit marker, but then we'd have to make 2 passes, first
3822 * to clear the flag, then to test and set it. To find somewhere
3823 * to store these values, evil chicanery is done with SvUVX().
3829 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3830 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3831 if (curop->op_type == OP_GV) {
3832 GV *gv = cGVOPx_gv(curop);
3834 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
3836 GvASSIGN_GENERATION_set(gv, PL_generation);
3838 else if (curop->op_type == OP_PADSV ||
3839 curop->op_type == OP_PADAV ||
3840 curop->op_type == OP_PADHV ||
3841 curop->op_type == OP_PADANY)
3843 if (PAD_COMPNAME_GEN(curop->op_targ)
3844 == (STRLEN)PL_generation)
3846 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
3849 else if (curop->op_type == OP_RV2CV)
3851 else if (curop->op_type == OP_RV2SV ||
3852 curop->op_type == OP_RV2AV ||
3853 curop->op_type == OP_RV2HV ||
3854 curop->op_type == OP_RV2GV) {
3855 if (lastop->op_type != OP_GV) /* funny deref? */
3858 else if (curop->op_type == OP_PUSHRE) {
3859 if (((PMOP*)curop)->op_pmreplroot) {
3861 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3862 ((PMOP*)curop)->op_pmreplroot));
3864 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3867 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
3869 GvASSIGN_GENERATION_set(gv, PL_generation);
3870 GvASSIGN_GENERATION_set(gv, PL_generation);
3879 o->op_private |= OPpASSIGN_COMMON;
3882 if ( ((left->op_private & OPpLVAL_INTRO) || ckWARN(WARN_MISC))
3883 && (left->op_type == OP_LIST
3884 || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
3886 OP* lop = ((LISTOP*)left)->op_first;
3888 if (lop->op_type == OP_PADSV ||
3889 lop->op_type == OP_PADAV ||
3890 lop->op_type == OP_PADHV ||
3891 lop->op_type == OP_PADANY)
3893 if (lop->op_private & OPpPAD_STATE) {
3894 if (left->op_private & OPpLVAL_INTRO) {
3895 o->op_private |= OPpASSIGN_STATE;
3896 /* hijacking PADSTALE for uninitialized state variables */
3897 SvPADSTALE_on(PAD_SVl(lop->op_targ));
3899 else { /* we already checked for WARN_MISC before */
3900 Perl_warner(aTHX_ packWARN(WARN_MISC), "State variable %s will be reinitialized",
3901 PAD_COMPNAME_PV(lop->op_targ));
3905 lop = lop->op_sibling;
3909 if (right && right->op_type == OP_SPLIT) {
3910 OP* tmpop = ((LISTOP*)right)->op_first;
3911 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
3912 PMOP * const pm = (PMOP*)tmpop;
3913 if (left->op_type == OP_RV2AV &&
3914 !(left->op_private & OPpLVAL_INTRO) &&
3915 !(o->op_private & OPpASSIGN_COMMON) )
3917 tmpop = ((UNOP*)left)->op_first;
3918 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3920 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3921 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3923 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3924 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
3926 pm->op_pmflags |= PMf_ONCE;
3927 tmpop = cUNOPo->op_first; /* to list (nulled) */
3928 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3929 tmpop->op_sibling = NULL; /* don't free split */
3930 right->op_next = tmpop->op_next; /* fix starting loc */
3932 op_getmad(o,right,'R'); /* blow off assign */
3934 op_free(o); /* blow off assign */
3936 right->op_flags &= ~OPf_WANT;
3937 /* "I don't know and I don't care." */
3942 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3943 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3945 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3947 sv_setiv(sv, PL_modcount+1);
3955 right = newOP(OP_UNDEF, 0);
3956 if (right->op_type == OP_READLINE) {
3957 right->op_flags |= OPf_STACKED;
3958 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3961 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3962 o = newBINOP(OP_SASSIGN, flags,
3963 scalar(right), mod(scalar(left), OP_SASSIGN) );
3969 o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
3970 o->op_private |= OPpCONST_ARYBASE;
3977 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3980 const U32 seq = intro_my();
3983 NewOp(1101, cop, 1, COP);
3984 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3985 cop->op_type = OP_DBSTATE;
3986 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3989 cop->op_type = OP_NEXTSTATE;
3990 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3992 cop->op_flags = (U8)flags;
3993 CopHINTS_set(cop, PL_hints);
3995 cop->op_private |= NATIVE_HINTS;
3997 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
3998 cop->op_next = (OP*)cop;
4001 CopLABEL_set(cop, label);
4002 PL_hints |= HINT_BLOCK_SCOPE;
4005 /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
4006 CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
4008 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
4009 cop->cop_hints_hash = PL_curcop->cop_hints_hash;
4010 if (cop->cop_hints_hash) {
4012 cop->cop_hints_hash->refcounted_he_refcnt++;
4013 HINTS_REFCNT_UNLOCK;
4016 if (PL_copline == NOLINE)
4017 CopLINE_set(cop, CopLINE(PL_curcop));
4019 CopLINE_set(cop, PL_copline);
4020 PL_copline = NOLINE;
4023 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
4025 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
4027 CopSTASH_set(cop, PL_curstash);
4029 if (PERLDB_LINE && PL_curstash != PL_debstash) {
4030 AV *av = CopFILEAVx(PL_curcop);
4032 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
4033 if (svp && *svp != &PL_sv_undef ) {
4034 (void)SvIOK_on(*svp);
4035 SvIV_set(*svp, PTR2IV(cop));
4040 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
4045 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
4048 return new_logop(type, flags, &first, &other);
4052 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
4057 OP *first = *firstp;
4058 OP * const other = *otherp;
4060 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
4061 return newBINOP(type, flags, scalar(first), scalar(other));
4063 scalarboolean(first);
4064 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
4065 if (first->op_type == OP_NOT
4066 && (first->op_flags & OPf_SPECIAL)
4067 && (first->op_flags & OPf_KIDS)) {
4068 if (type == OP_AND || type == OP_OR) {
4074 first = *firstp = cUNOPo->op_first;
4076 first->op_next = o->op_next;
4077 cUNOPo->op_first = NULL;
4079 op_getmad(o,first,'O');
4085 if (first->op_type == OP_CONST) {
4086 if (first->op_private & OPpCONST_STRICT)
4087 no_bareword_allowed(first);
4088 else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
4089 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
4090 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
4091 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
4092 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
4094 if (other->op_type == OP_CONST)
4095 other->op_private |= OPpCONST_SHORTCIRCUIT;
4097 OP *newop = newUNOP(OP_NULL, 0, other);
4098 op_getmad(first, newop, '1');
4099 newop->op_targ = type; /* set "was" field */
4106 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
4107 const OP *o2 = other;
4108 if ( ! (o2->op_type == OP_LIST
4109 && (( o2 = cUNOPx(o2)->op_first))
4110 && o2->op_type == OP_PUSHMARK
4111 && (( o2 = o2->op_sibling)) )
4114 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
4115 || o2->op_type == OP_PADHV)
4116 && o2->op_private & OPpLVAL_INTRO
4117 && ckWARN(WARN_DEPRECATED))
4119 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4120 "Deprecated use of my() in false conditional");
4124 if (first->op_type == OP_CONST)
4125 first->op_private |= OPpCONST_SHORTCIRCUIT;
4127 first = newUNOP(OP_NULL, 0, first);
4128 op_getmad(other, first, '2');
4129 first->op_targ = type; /* set "was" field */
4136 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
4137 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
4139 const OP * const k1 = ((UNOP*)first)->op_first;
4140 const OP * const k2 = k1->op_sibling;
4142 switch (first->op_type)
4145 if (k2 && k2->op_type == OP_READLINE
4146 && (k2->op_flags & OPf_STACKED)
4147 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4149 warnop = k2->op_type;
4154 if (k1->op_type == OP_READDIR
4155 || k1->op_type == OP_GLOB
4156 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4157 || k1->op_type == OP_EACH)
4159 warnop = ((k1->op_type == OP_NULL)
4160 ? (OPCODE)k1->op_targ : k1->op_type);
4165 const line_t oldline = CopLINE(PL_curcop);
4166 CopLINE_set(PL_curcop, PL_copline);
4167 Perl_warner(aTHX_ packWARN(WARN_MISC),
4168 "Value of %s%s can be \"0\"; test with defined()",
4170 ((warnop == OP_READLINE || warnop == OP_GLOB)
4171 ? " construct" : "() operator"));
4172 CopLINE_set(PL_curcop, oldline);
4179 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
4180 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
4182 NewOp(1101, logop, 1, LOGOP);
4184 logop->op_type = (OPCODE)type;
4185 logop->op_ppaddr = PL_ppaddr[type];
4186 logop->op_first = first;
4187 logop->op_flags = (U8)(flags | OPf_KIDS);
4188 logop->op_other = LINKLIST(other);
4189 logop->op_private = (U8)(1 | (flags >> 8));
4191 /* establish postfix order */
4192 logop->op_next = LINKLIST(first);
4193 first->op_next = (OP*)logop;
4194 first->op_sibling = other;
4196 CHECKOP(type,logop);
4198 o = newUNOP(OP_NULL, 0, (OP*)logop);
4205 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
4213 return newLOGOP(OP_AND, 0, first, trueop);
4215 return newLOGOP(OP_OR, 0, first, falseop);
4217 scalarboolean(first);
4218 if (first->op_type == OP_CONST) {
4219 if (first->op_private & OPpCONST_BARE &&
4220 first->op_private & OPpCONST_STRICT) {
4221 no_bareword_allowed(first);
4223 if (SvTRUE(((SVOP*)first)->op_sv)) {
4226 trueop = newUNOP(OP_NULL, 0, trueop);
4227 op_getmad(first,trueop,'C');
4228 op_getmad(falseop,trueop,'e');
4230 /* FIXME for MAD - should there be an ELSE here? */
4240 falseop = newUNOP(OP_NULL, 0, falseop);
4241 op_getmad(first,falseop,'C');
4242 op_getmad(trueop,falseop,'t');
4244 /* FIXME for MAD - should there be an ELSE here? */
4252 NewOp(1101, logop, 1, LOGOP);
4253 logop->op_type = OP_COND_EXPR;
4254 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4255 logop->op_first = first;
4256 logop->op_flags = (U8)(flags | OPf_KIDS);
4257 logop->op_private = (U8)(1 | (flags >> 8));
4258 logop->op_other = LINKLIST(trueop);
4259 logop->op_next = LINKLIST(falseop);
4261 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
4264 /* establish postfix order */
4265 start = LINKLIST(first);
4266 first->op_next = (OP*)logop;
4268 first->op_sibling = trueop;
4269 trueop->op_sibling = falseop;
4270 o = newUNOP(OP_NULL, 0, (OP*)logop);
4272 trueop->op_next = falseop->op_next = o;
4279 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4288 NewOp(1101, range, 1, LOGOP);
4290 range->op_type = OP_RANGE;
4291 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4292 range->op_first = left;
4293 range->op_flags = OPf_KIDS;
4294 leftstart = LINKLIST(left);
4295 range->op_other = LINKLIST(right);
4296 range->op_private = (U8)(1 | (flags >> 8));
4298 left->op_sibling = right;
4300 range->op_next = (OP*)range;
4301 flip = newUNOP(OP_FLIP, flags, (OP*)range);
4302 flop = newUNOP(OP_FLOP, 0, flip);
4303 o = newUNOP(OP_NULL, 0, flop);
4305 range->op_next = leftstart;
4307 left->op_next = flip;
4308 right->op_next = flop;
4310 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4311 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4312 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4313 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4315 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4316 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4319 if (!flip->op_private || !flop->op_private)
4320 linklist(o); /* blow off optimizer unless constant */
4326 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4331 const bool once = block && block->op_flags & OPf_SPECIAL &&
4332 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4334 PERL_UNUSED_ARG(debuggable);
4337 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4338 return block; /* do {} while 0 does once */
4339 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4340 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4341 expr = newUNOP(OP_DEFINED, 0,
4342 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4343 } else if (expr->op_flags & OPf_KIDS) {
4344 const OP * const k1 = ((UNOP*)expr)->op_first;
4345 const OP * const k2 = k1 ? k1->op_sibling : NULL;
4346 switch (expr->op_type) {
4348 if (k2 && k2->op_type == OP_READLINE
4349 && (k2->op_flags & OPf_STACKED)
4350 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4351 expr = newUNOP(OP_DEFINED, 0, expr);
4355 if (k1 && (k1->op_type == OP_READDIR
4356 || k1->op_type == OP_GLOB
4357 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4358 || k1->op_type == OP_EACH))
4359 expr = newUNOP(OP_DEFINED, 0, expr);
4365 /* if block is null, the next append_elem() would put UNSTACK, a scalar
4366 * op, in listop. This is wrong. [perl #27024] */
4368 block = newOP(OP_NULL, 0);
4369 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4370 o = new_logop(OP_AND, 0, &expr, &listop);
4373 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4375 if (once && o != listop)
4376 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4379 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
4381 o->op_flags |= flags;
4383 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4388 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
4389 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
4398 PERL_UNUSED_ARG(debuggable);
4401 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4402 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4403 expr = newUNOP(OP_DEFINED, 0,
4404 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4405 } else if (expr->op_flags & OPf_KIDS) {
4406 const OP * const k1 = ((UNOP*)expr)->op_first;
4407 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
4408 switch (expr->op_type) {
4410 if (k2 && k2->op_type == OP_READLINE
4411 && (k2->op_flags & OPf_STACKED)
4412 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4413 expr = newUNOP(OP_DEFINED, 0, expr);
4417 if (k1 && (k1->op_type == OP_READDIR
4418 || k1->op_type == OP_GLOB
4419 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4420 || k1->op_type == OP_EACH))
4421 expr = newUNOP(OP_DEFINED, 0, expr);
4428 block = newOP(OP_NULL, 0);
4429 else if (cont || has_my) {
4430 block = scope(block);
4434 next = LINKLIST(cont);
4437 OP * const unstack = newOP(OP_UNSTACK, 0);
4440 cont = append_elem(OP_LINESEQ, cont, unstack);
4444 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4446 redo = LINKLIST(listop);
4449 PL_copline = (line_t)whileline;
4451 o = new_logop(OP_AND, 0, &expr, &listop);
4452 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4453 op_free(expr); /* oops, it's a while (0) */
4455 return NULL; /* listop already freed by new_logop */
4458 ((LISTOP*)listop)->op_last->op_next =
4459 (o == listop ? redo : LINKLIST(o));
4465 NewOp(1101,loop,1,LOOP);
4466 loop->op_type = OP_ENTERLOOP;
4467 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4468 loop->op_private = 0;
4469 loop->op_next = (OP*)loop;
4472 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4474 loop->op_redoop = redo;
4475 loop->op_lastop = o;
4476 o->op_private |= loopflags;
4479 loop->op_nextop = next;
4481 loop->op_nextop = o;
4483 o->op_flags |= flags;
4484 o->op_private |= (flags >> 8);
4489 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
4494 PADOFFSET padoff = 0;
4500 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4501 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
4502 sv->op_type = OP_RV2GV;
4503 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4504 if (cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
4505 iterpflags |= OPpITER_DEF;
4507 else if (sv->op_type == OP_PADSV) { /* private variable */
4508 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
4509 padoff = sv->op_targ;
4518 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4519 padoff = sv->op_targ;
4524 iterflags |= OPf_SPECIAL;
4530 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4532 SV *const namesv = PAD_COMPNAME_SV(padoff);
4534 const char *const name = SvPV_const(namesv, len);
4536 if (len == 2 && name[0] == '$' && name[1] == '_')
4537 iterpflags |= OPpITER_DEF;
4541 const PADOFFSET offset = pad_findmy("$_");
4542 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
4543 sv = newGVOP(OP_GV, 0, PL_defgv);
4548 iterpflags |= OPpITER_DEF;
4550 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4551 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4552 iterflags |= OPf_STACKED;
4554 else if (expr->op_type == OP_NULL &&
4555 (expr->op_flags & OPf_KIDS) &&
4556 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4558 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4559 * set the STACKED flag to indicate that these values are to be
4560 * treated as min/max values by 'pp_iterinit'.
4562 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4563 LOGOP* const range = (LOGOP*) flip->op_first;
4564 OP* const left = range->op_first;
4565 OP* const right = left->op_sibling;
4568 range->op_flags &= ~OPf_KIDS;
4569 range->op_first = NULL;
4571 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4572 listop->op_first->op_next = range->op_next;
4573 left->op_next = range->op_other;
4574 right->op_next = (OP*)listop;
4575 listop->op_next = listop->op_first;
4578 op_getmad(expr,(OP*)listop,'O');
4582 expr = (OP*)(listop);
4584 iterflags |= OPf_STACKED;
4587 expr = mod(force_list(expr), OP_GREPSTART);
4590 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4591 append_elem(OP_LIST, expr, scalar(sv))));
4592 assert(!loop->op_next);
4593 /* for my $x () sets OPpLVAL_INTRO;
4594 * for our $x () sets OPpOUR_INTRO */
4595 loop->op_private = (U8)iterpflags;
4596 #ifdef PL_OP_SLAB_ALLOC
4599 NewOp(1234,tmp,1,LOOP);
4600 Copy(loop,tmp,1,LISTOP);
4601 S_op_destroy(aTHX_ (OP*)loop);
4605 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
4607 loop->op_targ = padoff;
4608 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
4610 op_getmad(madsv, (OP*)loop, 'v');
4611 PL_copline = forline;
4612 return newSTATEOP(0, label, wop);
4616 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4621 if (type != OP_GOTO || label->op_type == OP_CONST) {
4622 /* "last()" means "last" */
4623 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4624 o = newOP(type, OPf_SPECIAL);
4626 o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
4627 ? SvPVx_nolen_const(((SVOP*)label)->op_sv)
4631 op_getmad(label,o,'L');
4637 /* Check whether it's going to be a goto &function */
4638 if (label->op_type == OP_ENTERSUB
4639 && !(label->op_flags & OPf_STACKED))
4640 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4641 o = newUNOP(type, OPf_STACKED, label);
4643 PL_hints |= HINT_BLOCK_SCOPE;
4647 /* if the condition is a literal array or hash
4648 (or @{ ... } etc), make a reference to it.
4651 S_ref_array_or_hash(pTHX_ OP *cond)
4654 && (cond->op_type == OP_RV2AV
4655 || cond->op_type == OP_PADAV
4656 || cond->op_type == OP_RV2HV
4657 || cond->op_type == OP_PADHV))
4659 return newUNOP(OP_REFGEN,
4660 0, mod(cond, OP_REFGEN));
4666 /* These construct the optree fragments representing given()
4669 entergiven and enterwhen are LOGOPs; the op_other pointer
4670 points up to the associated leave op. We need this so we
4671 can put it in the context and make break/continue work.
4672 (Also, of course, pp_enterwhen will jump straight to
4673 op_other if the match fails.)
4678 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
4679 I32 enter_opcode, I32 leave_opcode,
4680 PADOFFSET entertarg)
4686 NewOp(1101, enterop, 1, LOGOP);
4687 enterop->op_type = enter_opcode;
4688 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
4689 enterop->op_flags = (U8) OPf_KIDS;
4690 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
4691 enterop->op_private = 0;
4693 o = newUNOP(leave_opcode, 0, (OP *) enterop);
4696 enterop->op_first = scalar(cond);
4697 cond->op_sibling = block;
4699 o->op_next = LINKLIST(cond);
4700 cond->op_next = (OP *) enterop;
4703 /* This is a default {} block */
4704 enterop->op_first = block;
4705 enterop->op_flags |= OPf_SPECIAL;
4707 o->op_next = (OP *) enterop;
4710 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
4711 entergiven and enterwhen both
4714 enterop->op_next = LINKLIST(block);
4715 block->op_next = enterop->op_other = o;
4720 /* Does this look like a boolean operation? For these purposes
4721 a boolean operation is:
4722 - a subroutine call [*]
4723 - a logical connective
4724 - a comparison operator
4725 - a filetest operator, with the exception of -s -M -A -C
4726 - defined(), exists() or eof()
4727 - /$re/ or $foo =~ /$re/
4729 [*] possibly surprising
4733 S_looks_like_bool(pTHX_ const OP *o)
4736 switch(o->op_type) {
4738 return looks_like_bool(cLOGOPo->op_first);
4742 looks_like_bool(cLOGOPo->op_first)
4743 && looks_like_bool(cLOGOPo->op_first->op_sibling));
4747 case OP_NOT: case OP_XOR:
4748 /* Note that OP_DOR is not here */
4750 case OP_EQ: case OP_NE: case OP_LT:
4751 case OP_GT: case OP_LE: case OP_GE:
4753 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
4754 case OP_I_GT: case OP_I_LE: case OP_I_GE:
4756 case OP_SEQ: case OP_SNE: case OP_SLT:
4757 case OP_SGT: case OP_SLE: case OP_SGE:
4761 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
4762 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
4763 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
4764 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
4765 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
4766 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
4767 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
4768 case OP_FTTEXT: case OP_FTBINARY:
4770 case OP_DEFINED: case OP_EXISTS:
4771 case OP_MATCH: case OP_EOF:
4776 /* Detect comparisons that have been optimized away */
4777 if (cSVOPo->op_sv == &PL_sv_yes
4778 || cSVOPo->op_sv == &PL_sv_no)
4789 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
4793 return newGIVWHENOP(
4794 ref_array_or_hash(cond),
4796 OP_ENTERGIVEN, OP_LEAVEGIVEN,
4800 /* If cond is null, this is a default {} block */
4802 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
4804 const bool cond_llb = (!cond || looks_like_bool(cond));
4810 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
4812 scalar(ref_array_or_hash(cond)));
4815 return newGIVWHENOP(
4817 append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
4818 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
4822 =for apidoc cv_undef
4824 Clear out all the active components of a CV. This can happen either
4825 by an explicit C<undef &foo>, or by the reference count going to zero.
4826 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
4827 children can still follow the full lexical scope chain.
4833 Perl_cv_undef(pTHX_ CV *cv)
4837 if (CvFILE(cv) && !CvISXSUB(cv)) {
4838 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4839 Safefree(CvFILE(cv));
4844 if (!CvISXSUB(cv) && CvROOT(cv)) {
4845 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
4846 Perl_croak(aTHX_ "Can't undef active subroutine");
4849 PAD_SAVE_SETNULLPAD();
4851 op_free(CvROOT(cv));
4856 SvPOK_off((SV*)cv); /* forget prototype */
4861 /* remove CvOUTSIDE unless this is an undef rather than a free */
4862 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
4863 if (!CvWEAKOUTSIDE(cv))
4864 SvREFCNT_dec(CvOUTSIDE(cv));
4865 CvOUTSIDE(cv) = NULL;
4868 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4871 if (CvISXSUB(cv) && CvXSUB(cv)) {
4874 /* delete all flags except WEAKOUTSIDE */
4875 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
4879 Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
4882 /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
4883 relying on SvCUR, and doubling up the buffer to hold CvFILE(). */
4884 if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
4885 || (p && (len != SvCUR(cv) /* Not the same length. */
4886 || memNE(p, SvPVX_const(cv), len))))
4887 && ckWARN_d(WARN_PROTOTYPE)) {
4888 SV* const msg = sv_newmortal();
4892 gv_efullname3(name = sv_newmortal(), gv, NULL);
4893 sv_setpv(msg, "Prototype mismatch:");
4895 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
4897 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv));
4899 sv_catpvs(msg, ": none");
4900 sv_catpvs(msg, " vs ");
4902 Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
4904 sv_catpvs(msg, "none");
4905 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
4909 static void const_sv_xsub(pTHX_ CV* cv);
4913 =head1 Optree Manipulation Functions
4915 =for apidoc cv_const_sv
4917 If C<cv> is a constant sub eligible for inlining. returns the constant
4918 value returned by the sub. Otherwise, returns NULL.
4920 Constant subs can be created with C<newCONSTSUB> or as described in
4921 L<perlsub/"Constant Functions">.
4926 Perl_cv_const_sv(pTHX_ CV *cv)
4928 PERL_UNUSED_CONTEXT;
4931 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
4933 return CvCONST(cv) ? (SV*)CvXSUBANY(cv).any_ptr : NULL;
4936 /* op_const_sv: examine an optree to determine whether it's in-lineable.
4937 * Can be called in 3 ways:
4940 * look for a single OP_CONST with attached value: return the value
4942 * cv && CvCLONE(cv) && !CvCONST(cv)
4944 * examine the clone prototype, and if contains only a single
4945 * OP_CONST referencing a pad const, or a single PADSV referencing
4946 * an outer lexical, return a non-zero value to indicate the CV is
4947 * a candidate for "constizing" at clone time
4951 * We have just cloned an anon prototype that was marked as a const
4952 * candidiate. Try to grab the current value, and in the case of
4953 * PADSV, ignore it if it has multiple references. Return the value.
4957 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
4965 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4966 o = cLISTOPo->op_first->op_sibling;
4968 for (; o; o = o->op_next) {
4969 const OPCODE type = o->op_type;
4971 if (sv && o->op_next == o)
4973 if (o->op_next != o) {
4974 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4976 if (type == OP_DBSTATE)
4979 if (type == OP_LEAVESUB || type == OP_RETURN)
4983 if (type == OP_CONST && cSVOPo->op_sv)
4985 else if (cv && type == OP_CONST) {
4986 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4990 else if (cv && type == OP_PADSV) {
4991 if (CvCONST(cv)) { /* newly cloned anon */
4992 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4993 /* the candidate should have 1 ref from this pad and 1 ref
4994 * from the parent */
4995 if (!sv || SvREFCNT(sv) != 2)
5002 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
5003 sv = &PL_sv_undef; /* an arbitrary non-null value */
5018 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5021 /* This would be the return value, but the return cannot be reached. */
5022 OP* pegop = newOP(OP_NULL, 0);
5025 PERL_UNUSED_ARG(floor);
5035 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
5037 NORETURN_FUNCTION_END;
5042 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
5044 return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
5048 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5055 register CV *cv = NULL;
5057 /* If the subroutine has no body, no attributes, and no builtin attributes
5058 then it's just a sub declaration, and we may be able to get away with
5059 storing with a placeholder scalar in the symbol table, rather than a
5060 full GV and CV. If anything is present then it will take a full CV to
5062 const I32 gv_fetch_flags
5063 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5065 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
5066 const char * const name = o ? SvPVx_nolen_const(cSVOPo->op_sv) : NULL;
5069 assert(proto->op_type == OP_CONST);
5070 ps = SvPVx_const(((SVOP*)proto)->op_sv, ps_len);
5075 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
5076 SV * const sv = sv_newmortal();
5077 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
5078 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
5079 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
5080 aname = SvPVX_const(sv);
5085 gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
5086 : gv_fetchpv(aname ? aname
5087 : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5088 gv_fetch_flags, SVt_PVCV);
5090 if (!PL_madskills) {
5099 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
5100 maximum a prototype before. */
5101 if (SvTYPE(gv) > SVt_NULL) {
5102 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
5103 && ckWARN_d(WARN_PROTOTYPE))
5105 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
5107 cv_ckproto_len((CV*)gv, NULL, ps, ps_len);
5110 sv_setpvn((SV*)gv, ps, ps_len);
5112 sv_setiv((SV*)gv, -1);
5113 SvREFCNT_dec(PL_compcv);
5114 cv = PL_compcv = NULL;
5115 PL_sub_generation++;
5119 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
5121 #ifdef GV_UNIQUE_CHECK
5122 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
5123 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
5127 if (!block || !ps || *ps || attrs
5128 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5130 || block->op_type == OP_NULL
5135 const_sv = op_const_sv(block, NULL);
5138 const bool exists = CvROOT(cv) || CvXSUB(cv);
5140 #ifdef GV_UNIQUE_CHECK
5141 if (exists && GvUNIQUE(gv)) {
5142 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
5146 /* if the subroutine doesn't exist and wasn't pre-declared
5147 * with a prototype, assume it will be AUTOLOADed,
5148 * skipping the prototype check
5150 if (exists || SvPOK(cv))
5151 cv_ckproto_len(cv, gv, ps, ps_len);
5152 /* already defined (or promised)? */
5153 if (exists || GvASSUMECV(gv)) {
5156 || block->op_type == OP_NULL
5159 if (CvFLAGS(PL_compcv)) {
5160 /* might have had built-in attrs applied */
5161 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5163 /* just a "sub foo;" when &foo is already defined */
5164 SAVEFREESV(PL_compcv);
5169 && block->op_type != OP_NULL
5172 if (ckWARN(WARN_REDEFINE)
5174 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
5176 const line_t oldline = CopLINE(PL_curcop);
5177 if (PL_copline != NOLINE)
5178 CopLINE_set(PL_curcop, PL_copline);
5179 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5180 CvCONST(cv) ? "Constant subroutine %s redefined"
5181 : "Subroutine %s redefined", name);
5182 CopLINE_set(PL_curcop, oldline);
5185 if (!PL_minus_c) /* keep old one around for madskills */
5188 /* (PL_madskills unset in used file.) */
5196 SvREFCNT_inc_simple_void_NN(const_sv);
5198 assert(!CvROOT(cv) && !CvCONST(cv));
5199 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
5200 CvXSUBANY(cv).any_ptr = const_sv;
5201 CvXSUB(cv) = const_sv_xsub;
5207 cv = newCONSTSUB(NULL, name, const_sv);
5209 PL_sub_generation++;
5213 SvREFCNT_dec(PL_compcv);
5221 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
5222 * before we clobber PL_compcv.
5226 || block->op_type == OP_NULL
5230 /* Might have had built-in attributes applied -- propagate them. */
5231 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5232 if (CvGV(cv) && GvSTASH(CvGV(cv)))
5233 stash = GvSTASH(CvGV(cv));
5234 else if (CvSTASH(cv))
5235 stash = CvSTASH(cv);
5237 stash = PL_curstash;
5240 /* possibly about to re-define existing subr -- ignore old cv */
5241 rcv = (SV*)PL_compcv;
5242 if (name && GvSTASH(gv))
5243 stash = GvSTASH(gv);
5245 stash = PL_curstash;
5247 apply_attrs(stash, rcv, attrs, FALSE);
5249 if (cv) { /* must reuse cv if autoloaded */
5256 || block->op_type == OP_NULL) && !PL_madskills
5259 /* got here with just attrs -- work done, so bug out */
5260 SAVEFREESV(PL_compcv);
5263 /* transfer PL_compcv to cv */
5265 CvFLAGS(cv) = CvFLAGS(PL_compcv);
5266 if (!CvWEAKOUTSIDE(cv))
5267 SvREFCNT_dec(CvOUTSIDE(cv));
5268 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
5269 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
5270 CvOUTSIDE(PL_compcv) = 0;
5271 CvPADLIST(cv) = CvPADLIST(PL_compcv);
5272 CvPADLIST(PL_compcv) = 0;
5273 /* inner references to PL_compcv must be fixed up ... */
5274 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
5275 /* ... before we throw it away */
5276 SvREFCNT_dec(PL_compcv);
5278 if (PERLDB_INTER)/* Advice debugger on the new sub. */
5279 ++PL_sub_generation;
5286 if (strEQ(name, "import")) {
5287 PL_formfeed = (SV*)cv;
5288 Perl_warner(aTHX_ packWARN(WARN_VOID), "%lx\n", (long)cv);
5292 PL_sub_generation++;
5296 CvFILE_set_from_cop(cv, PL_curcop);
5297 CvSTASH(cv) = PL_curstash;
5300 sv_setpvn((SV*)cv, ps, ps_len);
5302 if (PL_error_count) {
5306 const char *s = strrchr(name, ':');
5308 if (strEQ(s, "BEGIN")) {
5309 const char not_safe[] =
5310 "BEGIN not safe after errors--compilation aborted";
5311 if (PL_in_eval & EVAL_KEEPERR)
5312 Perl_croak(aTHX_ not_safe);
5314 /* force display of errors found but not reported */
5315 sv_catpv(ERRSV, not_safe);
5316 Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
5326 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5327 mod(scalarseq(block), OP_LEAVESUBLV));
5328 block->op_attached = 1;
5331 /* This makes sub {}; work as expected. */
5332 if (block->op_type == OP_STUB) {
5333 OP* const newblock = newSTATEOP(0, NULL, 0);
5335 op_getmad(block,newblock,'B');
5342 block->op_attached = 1;
5343 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5345 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5346 OpREFCNT_set(CvROOT(cv), 1);
5347 CvSTART(cv) = LINKLIST(CvROOT(cv));
5348 CvROOT(cv)->op_next = 0;
5349 CALL_PEEP(CvSTART(cv));
5351 /* now that optimizer has done its work, adjust pad values */
5353 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
5356 assert(!CvCONST(cv));
5357 if (ps && !*ps && op_const_sv(block, cv))
5361 if (name || aname) {
5363 const char * const tname = (name ? name : aname);
5365 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5366 SV * const sv = newSV(0);
5367 SV * const tmpstr = sv_newmortal();
5368 GV * const db_postponed = gv_fetchpvs("DB::postponed",
5369 GV_ADDMULTI, SVt_PVHV);
5372 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5374 (long)PL_subline, (long)CopLINE(PL_curcop));
5375 gv_efullname3(tmpstr, gv, NULL);
5376 hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0);
5377 hv = GvHVn(db_postponed);
5378 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
5379 CV * const pcv = GvCV(db_postponed);
5385 call_sv((SV*)pcv, G_DISCARD);
5390 if ((s = strrchr(tname,':')))
5395 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I' && *s != 'U')
5398 if (strEQ(s, "BEGIN") && !PL_error_count) {
5399 const I32 oldscope = PL_scopestack_ix;
5401 SAVECOPFILE(&PL_compiling);
5402 SAVECOPLINE(&PL_compiling);
5405 PL_beginav = newAV();
5406 DEBUG_x( dump_sub(gv) );
5407 av_push(PL_beginav, (SV*)cv);
5408 GvCV(gv) = 0; /* cv has been hijacked */
5409 call_list(oldscope, PL_beginav);
5411 PL_curcop = &PL_compiling;
5412 CopHINTS_set(&PL_compiling, PL_hints);
5415 else if (strEQ(s, "END") && !PL_error_count) {
5418 DEBUG_x( dump_sub(gv) );
5419 av_unshift(PL_endav, 1);
5420 av_store(PL_endav, 0, (SV*)cv);
5421 GvCV(gv) = 0; /* cv has been hijacked */
5423 else if (strEQ(s, "UNITCHECK") && !PL_error_count) {
5424 /* It's never too late to run a unitcheck block */
5425 if (!PL_unitcheckav)
5426 PL_unitcheckav = newAV();
5427 DEBUG_x( dump_sub(gv) );
5428 av_unshift(PL_unitcheckav, 1);
5429 av_store(PL_unitcheckav, 0, (SV*)cv);
5430 GvCV(gv) = 0; /* cv has been hijacked */
5432 else if (strEQ(s, "CHECK") && !PL_error_count) {
5434 PL_checkav = newAV();
5435 DEBUG_x( dump_sub(gv) );
5436 if (PL_main_start && ckWARN(WARN_VOID))
5437 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
5438 av_unshift(PL_checkav, 1);
5439 av_store(PL_checkav, 0, (SV*)cv);
5440 GvCV(gv) = 0; /* cv has been hijacked */
5442 else if (strEQ(s, "INIT") && !PL_error_count) {
5444 PL_initav = newAV();
5445 DEBUG_x( dump_sub(gv) );
5446 if (PL_main_start && ckWARN(WARN_VOID))
5447 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
5448 av_push(PL_initav, (SV*)cv);
5449 GvCV(gv) = 0; /* cv has been hijacked */
5454 PL_copline = NOLINE;
5459 /* XXX unsafe for threads if eval_owner isn't held */
5461 =for apidoc newCONSTSUB
5463 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5464 eligible for inlining at compile-time.
5470 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
5475 const char *const temp_p = CopFILE(PL_curcop);
5476 const STRLEN len = temp_p ? strlen(temp_p) : 0;
5478 SV *const temp_sv = CopFILESV(PL_curcop);
5480 const char *const temp_p = temp_sv ? SvPV_const(temp_sv, len) : NULL;
5482 char *const file = savepvn(temp_p, temp_p ? len : 0);
5486 SAVECOPLINE(PL_curcop);
5487 CopLINE_set(PL_curcop, PL_copline);
5490 PL_hints &= ~HINT_BLOCK_SCOPE;
5493 SAVESPTR(PL_curstash);
5494 SAVECOPSTASH(PL_curcop);
5495 PL_curstash = stash;
5496 CopSTASH_set(PL_curcop,stash);
5499 /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
5500 and so doesn't get free()d. (It's expected to be from the C pre-
5501 processor __FILE__ directive). But we need a dynamically allocated one,
5502 and we need it to get freed. */
5503 cv = newXS_flags(name, const_sv_xsub, file, "", XS_DYNAMIC_FILENAME);
5504 CvXSUBANY(cv).any_ptr = sv;
5510 CopSTASH_free(PL_curcop);
5518 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
5519 const char *const filename, const char *const proto,
5522 CV *cv = newXS(name, subaddr, filename);
5524 if (flags & XS_DYNAMIC_FILENAME) {
5525 /* We need to "make arrangements" (ie cheat) to ensure that the
5526 filename lasts as long as the PVCV we just created, but also doesn't
5528 STRLEN filename_len = strlen(filename);
5529 STRLEN proto_and_file_len = filename_len;
5530 char *proto_and_file;
5534 proto_len = strlen(proto);
5535 proto_and_file_len += proto_len;
5537 Newx(proto_and_file, proto_and_file_len + 1, char);
5538 Copy(proto, proto_and_file, proto_len, char);
5539 Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
5542 proto_and_file = savepvn(filename, filename_len);
5545 /* This gets free()d. :-) */
5546 sv_usepvn_flags((SV*)cv, proto_and_file, proto_and_file_len,
5547 SV_HAS_TRAILING_NUL);
5549 /* This gives us the correct prototype, rather than one with the
5550 file name appended. */
5551 SvCUR_set(cv, proto_len);
5555 CvFILE(cv) = proto_and_file + proto_len;
5557 sv_setpv((SV *)cv, proto);
5563 =for apidoc U||newXS
5565 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
5566 static storage, as it is used directly as CvFILE(), without a copy being made.
5572 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
5575 GV * const gv = gv_fetchpv(name ? name :
5576 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5577 GV_ADDMULTI, SVt_PVCV);
5581 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
5583 if ((cv = (name ? GvCV(gv) : NULL))) {
5585 /* just a cached method */
5589 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5590 /* already defined (or promised) */
5591 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
5592 if (ckWARN(WARN_REDEFINE)) {
5593 GV * const gvcv = CvGV(cv);
5595 HV * const stash = GvSTASH(gvcv);
5597 const char *redefined_name = HvNAME_get(stash);
5598 if ( strEQ(redefined_name,"autouse") ) {
5599 const line_t oldline = CopLINE(PL_curcop);
5600 if (PL_copline != NOLINE)
5601 CopLINE_set(PL_curcop, PL_copline);
5602 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5603 CvCONST(cv) ? "Constant subroutine %s redefined"
5604 : "Subroutine %s redefined"
5606 CopLINE_set(PL_curcop, oldline);
5616 if (cv) /* must reuse cv if autoloaded */
5620 sv_upgrade((SV *)cv, SVt_PVCV);
5624 PL_sub_generation++;
5628 (void)gv_fetchfile(filename);
5629 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
5630 an external constant string */
5632 CvXSUB(cv) = subaddr;
5635 const char *s = strrchr(name,':');
5641 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5644 if (strEQ(s, "BEGIN")) {
5646 PL_beginav = newAV();
5647 av_push(PL_beginav, (SV*)cv);
5648 GvCV(gv) = 0; /* cv has been hijacked */
5650 else if (strEQ(s, "END")) {
5653 av_unshift(PL_endav, 1);
5654 av_store(PL_endav, 0, (SV*)cv);
5655 GvCV(gv) = 0; /* cv has been hijacked */
5657 else if (strEQ(s, "CHECK")) {
5659 PL_checkav = newAV();
5660 if (PL_main_start && ckWARN(WARN_VOID))
5661 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
5662 av_unshift(PL_checkav, 1);
5663 av_store(PL_checkav, 0, (SV*)cv);
5664 GvCV(gv) = 0; /* cv has been hijacked */
5666 else if (strEQ(s, "INIT")) {
5668 PL_initav = newAV();
5669 if (PL_main_start && ckWARN(WARN_VOID))
5670 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
5671 av_push(PL_initav, (SV*)cv);
5672 GvCV(gv) = 0; /* cv has been hijacked */
5687 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5692 OP* pegop = newOP(OP_NULL, 0);
5696 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
5697 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
5699 #ifdef GV_UNIQUE_CHECK
5701 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5705 if ((cv = GvFORM(gv))) {
5706 if (ckWARN(WARN_REDEFINE)) {
5707 const line_t oldline = CopLINE(PL_curcop);
5708 if (PL_copline != NOLINE)
5709 CopLINE_set(PL_curcop, PL_copline);
5710 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5711 o ? "Format %"SVf" redefined"
5712 : "Format STDOUT redefined", SVfARG(cSVOPo->op_sv));
5713 CopLINE_set(PL_curcop, oldline);
5720 CvFILE_set_from_cop(cv, PL_curcop);
5723 pad_tidy(padtidy_FORMAT);
5724 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5725 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5726 OpREFCNT_set(CvROOT(cv), 1);
5727 CvSTART(cv) = LINKLIST(CvROOT(cv));
5728 CvROOT(cv)->op_next = 0;
5729 CALL_PEEP(CvSTART(cv));
5731 op_getmad(o,pegop,'n');
5732 op_getmad_weak(block, pegop, 'b');
5736 PL_copline = NOLINE;
5744 Perl_newANONLIST(pTHX_ OP *o)
5746 return convert(OP_ANONLIST, OPf_SPECIAL, o);
5750 Perl_newANONHASH(pTHX_ OP *o)
5752 return convert(OP_ANONHASH, OPf_SPECIAL, o);
5756 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5758 return newANONATTRSUB(floor, proto, NULL, block);
5762 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5764 return newUNOP(OP_REFGEN, 0,
5765 newSVOP(OP_ANONCODE, 0,
5766 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5770 Perl_oopsAV(pTHX_ OP *o)
5773 switch (o->op_type) {
5775 o->op_type = OP_PADAV;
5776 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5777 return ref(o, OP_RV2AV);
5780 o->op_type = OP_RV2AV;
5781 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5786 if (ckWARN_d(WARN_INTERNAL))
5787 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
5794 Perl_oopsHV(pTHX_ OP *o)
5797 switch (o->op_type) {
5800 o->op_type = OP_PADHV;
5801 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5802 return ref(o, OP_RV2HV);
5806 o->op_type = OP_RV2HV;
5807 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5812 if (ckWARN_d(WARN_INTERNAL))
5813 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
5820 Perl_newAVREF(pTHX_ OP *o)
5823 if (o->op_type == OP_PADANY) {
5824 o->op_type = OP_PADAV;
5825 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5828 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5829 && ckWARN(WARN_DEPRECATED)) {
5830 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5831 "Using an array as a reference is deprecated");
5833 return newUNOP(OP_RV2AV, 0, scalar(o));
5837 Perl_newGVREF(pTHX_ I32 type, OP *o)
5839 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5840 return newUNOP(OP_NULL, 0, o);
5841 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5845 Perl_newHVREF(pTHX_ OP *o)
5848 if (o->op_type == OP_PADANY) {
5849 o->op_type = OP_PADHV;
5850 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5853 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5854 && ckWARN(WARN_DEPRECATED)) {
5855 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5856 "Using a hash as a reference is deprecated");
5858 return newUNOP(OP_RV2HV, 0, scalar(o));
5862 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5864 return newUNOP(OP_RV2CV, flags, scalar(o));
5868 Perl_newSVREF(pTHX_ OP *o)
5871 if (o->op_type == OP_PADANY) {
5872 o->op_type = OP_PADSV;
5873 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5876 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5877 o->op_flags |= OPpDONE_SVREF;
5880 return newUNOP(OP_RV2SV, 0, scalar(o));
5883 /* Check routines. See the comments at the top of this file for details
5884 * on when these are called */
5887 Perl_ck_anoncode(pTHX_ OP *o)
5889 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
5891 cSVOPo->op_sv = NULL;
5896 Perl_ck_bitop(pTHX_ OP *o)
5899 #define OP_IS_NUMCOMPARE(op) \
5900 ((op) == OP_LT || (op) == OP_I_LT || \
5901 (op) == OP_GT || (op) == OP_I_GT || \
5902 (op) == OP_LE || (op) == OP_I_LE || \
5903 (op) == OP_GE || (op) == OP_I_GE || \
5904 (op) == OP_EQ || (op) == OP_I_EQ || \
5905 (op) == OP_NE || (op) == OP_I_NE || \
5906 (op) == OP_NCMP || (op) == OP_I_NCMP)
5907 o->op_private = (U8)(PL_hints & HINT_INTEGER);
5908 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
5909 && (o->op_type == OP_BIT_OR
5910 || o->op_type == OP_BIT_AND
5911 || o->op_type == OP_BIT_XOR))
5913 const OP * const left = cBINOPo->op_first;
5914 const OP * const right = left->op_sibling;
5915 if ((OP_IS_NUMCOMPARE(left->op_type) &&
5916 (left->op_flags & OPf_PARENS) == 0) ||
5917 (OP_IS_NUMCOMPARE(right->op_type) &&
5918 (right->op_flags & OPf_PARENS) == 0))
5919 if (ckWARN(WARN_PRECEDENCE))
5920 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
5921 "Possible precedence problem on bitwise %c operator",
5922 o->op_type == OP_BIT_OR ? '|'
5923 : o->op_type == OP_BIT_AND ? '&' : '^'
5930 Perl_ck_concat(pTHX_ OP *o)
5932 const OP * const kid = cUNOPo->op_first;
5933 PERL_UNUSED_CONTEXT;
5934 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
5935 !(kUNOP->op_first->op_flags & OPf_MOD))
5936 o->op_flags |= OPf_STACKED;
5941 Perl_ck_spair(pTHX_ OP *o)
5944 if (o->op_flags & OPf_KIDS) {
5947 const OPCODE type = o->op_type;
5948 o = modkids(ck_fun(o), type);
5949 kid = cUNOPo->op_first;
5950 newop = kUNOP->op_first->op_sibling;
5952 const OPCODE type = newop->op_type;
5953 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
5954 type == OP_PADAV || type == OP_PADHV ||
5955 type == OP_RV2AV || type == OP_RV2HV)
5959 op_getmad(kUNOP->op_first,newop,'K');
5961 op_free(kUNOP->op_first);
5963 kUNOP->op_first = newop;
5965 o->op_ppaddr = PL_ppaddr[++o->op_type];
5970 Perl_ck_delete(pTHX_ OP *o)
5974 if (o->op_flags & OPf_KIDS) {
5975 OP * const kid = cUNOPo->op_first;
5976 switch (kid->op_type) {
5978 o->op_flags |= OPf_SPECIAL;
5981 o->op_private |= OPpSLICE;
5984 o->op_flags |= OPf_SPECIAL;
5989 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5998 Perl_ck_die(pTHX_ OP *o)
6001 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6007 Perl_ck_eof(pTHX_ OP *o)
6011 if (o->op_flags & OPf_KIDS) {
6012 if (cLISTOPo->op_first->op_type == OP_STUB) {
6014 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
6016 op_getmad(o,newop,'O');
6028 Perl_ck_eval(pTHX_ OP *o)
6031 PL_hints |= HINT_BLOCK_SCOPE;
6032 if (o->op_flags & OPf_KIDS) {
6033 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6036 o->op_flags &= ~OPf_KIDS;
6039 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
6045 cUNOPo->op_first = 0;
6050 NewOp(1101, enter, 1, LOGOP);
6051 enter->op_type = OP_ENTERTRY;
6052 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
6053 enter->op_private = 0;
6055 /* establish postfix order */
6056 enter->op_next = (OP*)enter;
6058 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
6059 o->op_type = OP_LEAVETRY;
6060 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
6061 enter->op_other = o;
6062 op_getmad(oldo,o,'O');
6076 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
6077 op_getmad(oldo,o,'O');
6079 o->op_targ = (PADOFFSET)PL_hints;
6080 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
6081 /* Store a copy of %^H that pp_entereval can pick up */
6082 OP *hhop = newSVOP(OP_CONST, 0,
6083 (SV*)Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv)));
6084 cUNOPo->op_first->op_sibling = hhop;
6085 o->op_private |= OPpEVAL_HAS_HH;
6091 Perl_ck_exit(pTHX_ OP *o)
6094 HV * const table = GvHV(PL_hintgv);
6096 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
6097 if (svp && *svp && SvTRUE(*svp))
6098 o->op_private |= OPpEXIT_VMSISH;
6100 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6106 Perl_ck_exec(pTHX_ OP *o)
6108 if (o->op_flags & OPf_STACKED) {
6111 kid = cUNOPo->op_first->op_sibling;
6112 if (kid->op_type == OP_RV2GV)
6121 Perl_ck_exists(pTHX_ OP *o)
6125 if (o->op_flags & OPf_KIDS) {
6126 OP * const kid = cUNOPo->op_first;
6127 if (kid->op_type == OP_ENTERSUB) {
6128 (void) ref(kid, o->op_type);
6129 if (kid->op_type != OP_RV2CV && !PL_error_count)
6130 Perl_croak(aTHX_ "%s argument is not a subroutine name",
6132 o->op_private |= OPpEXISTS_SUB;
6134 else if (kid->op_type == OP_AELEM)
6135 o->op_flags |= OPf_SPECIAL;
6136 else if (kid->op_type != OP_HELEM)
6137 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
6145 Perl_ck_rvconst(pTHX_ register OP *o)
6148 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6150 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6151 if (o->op_type == OP_RV2CV)
6152 o->op_private &= ~1;
6154 if (kid->op_type == OP_CONST) {
6157 SV * const kidsv = kid->op_sv;
6159 /* Is it a constant from cv_const_sv()? */
6160 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
6161 SV * const rsv = SvRV(kidsv);
6162 const svtype type = SvTYPE(rsv);
6163 const char *badtype = NULL;
6165 switch (o->op_type) {
6167 if (type > SVt_PVMG)
6168 badtype = "a SCALAR";
6171 if (type != SVt_PVAV)
6172 badtype = "an ARRAY";
6175 if (type != SVt_PVHV)
6179 if (type != SVt_PVCV)
6184 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
6187 else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
6188 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
6189 /* If this is an access to a stash, disable "strict refs", because
6190 * stashes aren't auto-vivified at compile-time (unless we store
6191 * symbols in them), and we don't want to produce a run-time
6192 * stricture error when auto-vivifying the stash. */
6193 const char *s = SvPV_nolen(kidsv);
6194 const STRLEN l = SvCUR(kidsv);
6195 if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
6196 o->op_private &= ~HINT_STRICT_REFS;
6198 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
6199 const char *badthing;
6200 switch (o->op_type) {
6202 badthing = "a SCALAR";
6205 badthing = "an ARRAY";
6208 badthing = "a HASH";
6216 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
6217 SVfARG(kidsv), badthing);
6220 * This is a little tricky. We only want to add the symbol if we
6221 * didn't add it in the lexer. Otherwise we get duplicate strict
6222 * warnings. But if we didn't add it in the lexer, we must at
6223 * least pretend like we wanted to add it even if it existed before,
6224 * or we get possible typo warnings. OPpCONST_ENTERED says
6225 * whether the lexer already added THIS instance of this symbol.
6227 iscv = (o->op_type == OP_RV2CV) * 2;
6229 gv = gv_fetchsv(kidsv,
6230 iscv | !(kid->op_private & OPpCONST_ENTERED),
6233 : o->op_type == OP_RV2SV
6235 : o->op_type == OP_RV2AV
6237 : o->op_type == OP_RV2HV
6240 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
6242 kid->op_type = OP_GV;
6243 SvREFCNT_dec(kid->op_sv);
6245 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
6246 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
6247 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
6249 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc_simple_NN(gv));
6251 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
6253 kid->op_private = 0;
6254 kid->op_ppaddr = PL_ppaddr[OP_GV];
6261 Perl_ck_ftst(pTHX_ OP *o)
6264 const I32 type = o->op_type;
6266 if (o->op_flags & OPf_REF) {
6269 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
6270 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6271 const OPCODE kidtype = kid->op_type;
6273 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6274 OP * const newop = newGVOP(type, OPf_REF,
6275 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
6277 op_getmad(o,newop,'O');
6283 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o))
6284 o->op_private |= OPpFT_ACCESS;
6285 if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst)
6286 && kidtype != OP_STAT && kidtype != OP_LSTAT)
6287 o->op_private |= OPpFT_STACKED;
6295 if (type == OP_FTTTY)
6296 o = newGVOP(type, OPf_REF, PL_stdingv);
6298 o = newUNOP(type, 0, newDEFSVOP());
6299 op_getmad(oldo,o,'O');
6305 Perl_ck_fun(pTHX_ OP *o)
6308 const int type = o->op_type;
6309 register I32 oa = PL_opargs[type] >> OASHIFT;
6311 if (o->op_flags & OPf_STACKED) {
6312 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
6315 return no_fh_allowed(o);
6318 if (o->op_flags & OPf_KIDS) {
6319 OP **tokid = &cLISTOPo->op_first;
6320 register OP *kid = cLISTOPo->op_first;
6324 if (kid->op_type == OP_PUSHMARK ||
6325 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
6327 tokid = &kid->op_sibling;
6328 kid = kid->op_sibling;
6330 if (!kid && PL_opargs[type] & OA_DEFGV)
6331 *tokid = kid = newDEFSVOP();
6335 sibl = kid->op_sibling;
6337 if (!sibl && kid->op_type == OP_STUB) {
6344 /* list seen where single (scalar) arg expected? */
6345 if (numargs == 1 && !(oa >> 4)
6346 && kid->op_type == OP_LIST && type != OP_SCALAR)
6348 return too_many_arguments(o,PL_op_desc[type]);
6361 if ((type == OP_PUSH || type == OP_UNSHIFT)
6362 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
6363 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6364 "Useless use of %s with no values",
6367 if (kid->op_type == OP_CONST &&
6368 (kid->op_private & OPpCONST_BARE))
6370 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
6371 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
6372 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6373 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6374 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
6375 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6377 op_getmad(kid,newop,'K');
6382 kid->op_sibling = sibl;
6385 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
6386 bad_type(numargs, "array", PL_op_desc[type], kid);
6390 if (kid->op_type == OP_CONST &&
6391 (kid->op_private & OPpCONST_BARE))
6393 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
6394 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
6395 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6396 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6397 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
6398 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6400 op_getmad(kid,newop,'K');
6405 kid->op_sibling = sibl;
6408 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
6409 bad_type(numargs, "hash", PL_op_desc[type], kid);
6414 OP * const newop = newUNOP(OP_NULL, 0, kid);
6415 kid->op_sibling = 0;
6417 newop->op_next = newop;
6419 kid->op_sibling = sibl;
6424 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
6425 if (kid->op_type == OP_CONST &&
6426 (kid->op_private & OPpCONST_BARE))
6428 OP * const newop = newGVOP(OP_GV, 0,
6429 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
6430 if (!(o->op_private & 1) && /* if not unop */
6431 kid == cLISTOPo->op_last)
6432 cLISTOPo->op_last = newop;
6434 op_getmad(kid,newop,'K');
6440 else if (kid->op_type == OP_READLINE) {
6441 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
6442 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
6445 I32 flags = OPf_SPECIAL;
6449 /* is this op a FH constructor? */
6450 if (is_handle_constructor(o,numargs)) {
6451 const char *name = NULL;
6455 /* Set a flag to tell rv2gv to vivify
6456 * need to "prove" flag does not mean something
6457 * else already - NI-S 1999/05/07
6460 if (kid->op_type == OP_PADSV) {
6462 = PAD_COMPNAME_SV(kid->op_targ);
6463 name = SvPV_const(namesv, len);
6465 else if (kid->op_type == OP_RV2SV
6466 && kUNOP->op_first->op_type == OP_GV)
6468 GV * const gv = cGVOPx_gv(kUNOP->op_first);
6470 len = GvNAMELEN(gv);
6472 else if (kid->op_type == OP_AELEM
6473 || kid->op_type == OP_HELEM)
6476 OP *op = ((BINOP*)kid)->op_first;
6480 const char * const a =
6481 kid->op_type == OP_AELEM ?
6483 if (((op->op_type == OP_RV2AV) ||
6484 (op->op_type == OP_RV2HV)) &&
6485 (firstop = ((UNOP*)op)->op_first) &&
6486 (firstop->op_type == OP_GV)) {
6487 /* packagevar $a[] or $h{} */
6488 GV * const gv = cGVOPx_gv(firstop);
6496 else if (op->op_type == OP_PADAV
6497 || op->op_type == OP_PADHV) {
6498 /* lexicalvar $a[] or $h{} */
6499 const char * const padname =
6500 PAD_COMPNAME_PV(op->op_targ);
6509 name = SvPV_const(tmpstr, len);
6514 name = "__ANONIO__";
6521 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
6522 namesv = PAD_SVl(targ);
6523 SvUPGRADE(namesv, SVt_PV);
6525 sv_setpvn(namesv, "$", 1);
6526 sv_catpvn(namesv, name, len);
6529 kid->op_sibling = 0;
6530 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
6531 kid->op_targ = targ;
6532 kid->op_private |= priv;
6534 kid->op_sibling = sibl;
6540 mod(scalar(kid), type);
6544 tokid = &kid->op_sibling;
6545 kid = kid->op_sibling;
6548 if (kid && kid->op_type != OP_STUB)
6549 return too_many_arguments(o,OP_DESC(o));
6550 o->op_private |= numargs;
6552 /* FIXME - should the numargs move as for the PERL_MAD case? */
6553 o->op_private |= numargs;
6555 return too_many_arguments(o,OP_DESC(o));
6559 else if (PL_opargs[type] & OA_DEFGV) {
6561 OP *newop = newUNOP(type, 0, newDEFSVOP());
6562 op_getmad(o,newop,'O');
6565 /* Ordering of these two is important to keep f_map.t passing. */
6567 return newUNOP(type, 0, newDEFSVOP());
6572 while (oa & OA_OPTIONAL)
6574 if (oa && oa != OA_LIST)
6575 return too_few_arguments(o,OP_DESC(o));
6581 Perl_ck_glob(pTHX_ OP *o)
6587 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
6588 append_elem(OP_GLOB, o, newDEFSVOP());
6590 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
6591 && GvCVu(gv) && GvIMPORTED_CV(gv)))
6593 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6596 #if !defined(PERL_EXTERNAL_GLOB)
6597 /* XXX this can be tightened up and made more failsafe. */
6598 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
6601 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
6602 newSVpvs("File::Glob"), NULL, NULL, NULL);
6603 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6604 glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
6605 GvCV(gv) = GvCV(glob_gv);
6606 SvREFCNT_inc_void((SV*)GvCV(gv));
6607 GvIMPORTED_CV_on(gv);
6610 #endif /* PERL_EXTERNAL_GLOB */
6612 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6613 append_elem(OP_GLOB, o,
6614 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
6615 o->op_type = OP_LIST;
6616 o->op_ppaddr = PL_ppaddr[OP_LIST];
6617 cLISTOPo->op_first->op_type = OP_PUSHMARK;
6618 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
6619 cLISTOPo->op_first->op_targ = 0;
6620 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
6621 append_elem(OP_LIST, o,
6622 scalar(newUNOP(OP_RV2CV, 0,
6623 newGVOP(OP_GV, 0, gv)))));
6624 o = newUNOP(OP_NULL, 0, ck_subr(o));
6625 o->op_targ = OP_GLOB; /* hint at what it used to be */
6628 gv = newGVgen("main");
6630 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
6636 Perl_ck_grep(pTHX_ OP *o)
6641 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
6644 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
6645 /* don't allocate gwop here, as we may leak it if PL_error_count > 0 */
6647 if (o->op_flags & OPf_STACKED) {
6650 kid = cLISTOPo->op_first->op_sibling;
6651 if (!cUNOPx(kid)->op_next)
6652 Perl_croak(aTHX_ "panic: ck_grep");
6653 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
6656 NewOp(1101, gwop, 1, LOGOP);
6657 kid->op_next = (OP*)gwop;
6658 o->op_flags &= ~OPf_STACKED;
6660 kid = cLISTOPo->op_first->op_sibling;
6661 if (type == OP_MAPWHILE)
6668 kid = cLISTOPo->op_first->op_sibling;
6669 if (kid->op_type != OP_NULL)
6670 Perl_croak(aTHX_ "panic: ck_grep");
6671 kid = kUNOP->op_first;
6674 NewOp(1101, gwop, 1, LOGOP);
6675 gwop->op_type = type;
6676 gwop->op_ppaddr = PL_ppaddr[type];
6677 gwop->op_first = listkids(o);
6678 gwop->op_flags |= OPf_KIDS;
6679 gwop->op_other = LINKLIST(kid);
6680 kid->op_next = (OP*)gwop;
6681 offset = pad_findmy("$_");
6682 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
6683 o->op_private = gwop->op_private = 0;
6684 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
6687 o->op_private = gwop->op_private = OPpGREP_LEX;
6688 gwop->op_targ = o->op_targ = offset;
6691 kid = cLISTOPo->op_first->op_sibling;
6692 if (!kid || !kid->op_sibling)
6693 return too_few_arguments(o,OP_DESC(o));
6694 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
6695 mod(kid, OP_GREPSTART);
6701 Perl_ck_index(pTHX_ OP *o)
6703 if (o->op_flags & OPf_KIDS) {
6704 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6706 kid = kid->op_sibling; /* get past "big" */
6707 if (kid && kid->op_type == OP_CONST)
6708 fbm_compile(((SVOP*)kid)->op_sv, 0);
6714 Perl_ck_lengthconst(pTHX_ OP *o)
6716 /* XXX length optimization goes here */
6721 Perl_ck_lfun(pTHX_ OP *o)
6723 const OPCODE type = o->op_type;
6724 return modkids(ck_fun(o), type);
6728 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
6730 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
6731 switch (cUNOPo->op_first->op_type) {
6733 /* This is needed for
6734 if (defined %stash::)
6735 to work. Do not break Tk.
6737 break; /* Globals via GV can be undef */
6739 case OP_AASSIGN: /* Is this a good idea? */
6740 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6741 "defined(@array) is deprecated");
6742 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6743 "\t(Maybe you should just omit the defined()?)\n");
6746 /* This is needed for
6747 if (defined %stash::)
6748 to work. Do not break Tk.
6750 break; /* Globals via GV can be undef */
6752 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6753 "defined(%%hash) is deprecated");
6754 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6755 "\t(Maybe you should just omit the defined()?)\n");
6766 Perl_ck_rfun(pTHX_ OP *o)
6768 const OPCODE type = o->op_type;
6769 return refkids(ck_fun(o), type);
6773 Perl_ck_listiob(pTHX_ OP *o)
6777 kid = cLISTOPo->op_first;
6780 kid = cLISTOPo->op_first;
6782 if (kid->op_type == OP_PUSHMARK)
6783 kid = kid->op_sibling;
6784 if (kid && o->op_flags & OPf_STACKED)
6785 kid = kid->op_sibling;
6786 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6787 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6788 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6789 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6790 cLISTOPo->op_first->op_sibling = kid;
6791 cLISTOPo->op_last = kid;
6792 kid = kid->op_sibling;
6797 append_elem(o->op_type, o, newDEFSVOP());
6803 Perl_ck_smartmatch(pTHX_ OP *o)
6806 if (0 == (o->op_flags & OPf_SPECIAL)) {
6807 OP *first = cBINOPo->op_first;
6808 OP *second = first->op_sibling;
6810 /* Implicitly take a reference to an array or hash */
6811 first->op_sibling = NULL;
6812 first = cBINOPo->op_first = ref_array_or_hash(first);
6813 second = first->op_sibling = ref_array_or_hash(second);
6815 /* Implicitly take a reference to a regular expression */
6816 if (first->op_type == OP_MATCH) {
6817 first->op_type = OP_QR;
6818 first->op_ppaddr = PL_ppaddr[OP_QR];
6820 if (second->op_type == OP_MATCH) {
6821 second->op_type = OP_QR;
6822 second->op_ppaddr = PL_ppaddr[OP_QR];
6831 Perl_ck_sassign(pTHX_ OP *o)
6833 OP * const kid = cLISTOPo->op_first;
6834 /* has a disposable target? */
6835 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6836 && !(kid->op_flags & OPf_STACKED)
6837 /* Cannot steal the second time! */
6838 && !(kid->op_private & OPpTARGET_MY))
6840 OP * const kkid = kid->op_sibling;
6842 /* Can just relocate the target. */
6843 if (kkid && kkid->op_type == OP_PADSV
6844 && !(kkid->op_private & OPpLVAL_INTRO))
6846 kid->op_targ = kkid->op_targ;
6848 /* Now we do not need PADSV and SASSIGN. */
6849 kid->op_sibling = o->op_sibling; /* NULL */
6850 cLISTOPo->op_first = NULL;
6852 op_getmad(o,kid,'O');
6853 op_getmad(kkid,kid,'M');
6858 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6862 if (kid->op_sibling) {
6863 OP *kkid = kid->op_sibling;
6864 if (kkid->op_type == OP_PADSV
6865 && (kkid->op_private & OPpLVAL_INTRO)
6866 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
6867 o->op_private |= OPpASSIGN_STATE;
6868 /* hijacking PADSTALE for uninitialized state variables */
6869 SvPADSTALE_on(PAD_SVl(kkid->op_targ));
6876 Perl_ck_match(pTHX_ OP *o)
6879 if (o->op_type != OP_QR && PL_compcv) {
6880 const PADOFFSET offset = pad_findmy("$_");
6881 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
6882 o->op_targ = offset;
6883 o->op_private |= OPpTARGET_MY;
6886 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
6887 o->op_private |= OPpRUNTIME;
6892 Perl_ck_method(pTHX_ OP *o)
6894 OP * const kid = cUNOPo->op_first;
6895 if (kid->op_type == OP_CONST) {
6896 SV* sv = kSVOP->op_sv;
6897 const char * const method = SvPVX_const(sv);
6898 if (!(strchr(method, ':') || strchr(method, '\''))) {
6900 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6901 sv = newSVpvn_share(method, SvCUR(sv), 0);
6904 kSVOP->op_sv = NULL;
6906 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6908 op_getmad(o,cmop,'O');
6919 Perl_ck_null(pTHX_ OP *o)
6921 PERL_UNUSED_CONTEXT;
6926 Perl_ck_open(pTHX_ OP *o)
6929 HV * const table = GvHV(PL_hintgv);
6931 SV **svp = hv_fetchs(table, "open_IN", FALSE);
6933 const I32 mode = mode_from_discipline(*svp);
6934 if (mode & O_BINARY)
6935 o->op_private |= OPpOPEN_IN_RAW;
6936 else if (mode & O_TEXT)
6937 o->op_private |= OPpOPEN_IN_CRLF;
6940 svp = hv_fetchs(table, "open_OUT", FALSE);
6942 const I32 mode = mode_from_discipline(*svp);
6943 if (mode & O_BINARY)
6944 o->op_private |= OPpOPEN_OUT_RAW;
6945 else if (mode & O_TEXT)
6946 o->op_private |= OPpOPEN_OUT_CRLF;
6949 if (o->op_type == OP_BACKTICK)
6952 /* In case of three-arg dup open remove strictness
6953 * from the last arg if it is a bareword. */
6954 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
6955 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
6959 if ((last->op_type == OP_CONST) && /* The bareword. */
6960 (last->op_private & OPpCONST_BARE) &&
6961 (last->op_private & OPpCONST_STRICT) &&
6962 (oa = first->op_sibling) && /* The fh. */
6963 (oa = oa->op_sibling) && /* The mode. */
6964 (oa->op_type == OP_CONST) &&
6965 SvPOK(((SVOP*)oa)->op_sv) &&
6966 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
6967 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
6968 (last == oa->op_sibling)) /* The bareword. */
6969 last->op_private &= ~OPpCONST_STRICT;
6975 Perl_ck_repeat(pTHX_ OP *o)
6977 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6978 o->op_private |= OPpREPEAT_DOLIST;
6979 cBINOPo->op_first = force_list(cBINOPo->op_first);
6987 Perl_ck_require(pTHX_ OP *o)
6992 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6993 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6995 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6996 SV * const sv = kid->op_sv;
6997 U32 was_readonly = SvREADONLY(sv);
7002 sv_force_normal_flags(sv, 0);
7003 assert(!SvREADONLY(sv));
7010 for (s = SvPVX(sv); *s; s++) {
7011 if (*s == ':' && s[1] == ':') {
7012 const STRLEN len = strlen(s+2)+1;
7014 Move(s+2, s+1, len, char);
7015 SvCUR_set(sv, SvCUR(sv) - 1);
7018 sv_catpvs(sv, ".pm");
7019 SvFLAGS(sv) |= was_readonly;
7023 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
7024 /* handle override, if any */
7025 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
7026 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7027 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
7028 gv = gvp ? *gvp : NULL;
7032 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7033 OP * const kid = cUNOPo->op_first;
7036 cUNOPo->op_first = 0;
7040 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
7041 append_elem(OP_LIST, kid,
7042 scalar(newUNOP(OP_RV2CV, 0,
7045 op_getmad(o,newop,'O');
7053 Perl_ck_return(pTHX_ OP *o)
7056 if (CvLVALUE(PL_compcv)) {
7058 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
7059 mod(kid, OP_LEAVESUBLV);
7065 Perl_ck_select(pTHX_ OP *o)
7069 if (o->op_flags & OPf_KIDS) {
7070 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7071 if (kid && kid->op_sibling) {
7072 o->op_type = OP_SSELECT;
7073 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
7075 return fold_constants(o);
7079 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7080 if (kid && kid->op_type == OP_RV2GV)
7081 kid->op_private &= ~HINT_STRICT_REFS;
7086 Perl_ck_shift(pTHX_ OP *o)
7089 const I32 type = o->op_type;
7091 if (!(o->op_flags & OPf_KIDS)) {
7093 /* FIXME - this can be refactored to reduce code in #ifdefs */
7095 OP * const oldo = o;
7099 argop = newUNOP(OP_RV2AV, 0,
7100 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
7102 o = newUNOP(type, 0, scalar(argop));
7103 op_getmad(oldo,o,'O');
7106 return newUNOP(type, 0, scalar(argop));
7109 return scalar(modkids(ck_fun(o), type));
7113 Perl_ck_sort(pTHX_ OP *o)
7118 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
7119 HV * const hinthv = GvHV(PL_hintgv);
7121 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
7123 const I32 sorthints = (I32)SvIV(*svp);
7124 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
7125 o->op_private |= OPpSORT_QSORT;
7126 if ((sorthints & HINT_SORT_STABLE) != 0)
7127 o->op_private |= OPpSORT_STABLE;
7132 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
7134 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7135 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
7137 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
7139 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
7141 if (kid->op_type == OP_SCOPE) {
7145 else if (kid->op_type == OP_LEAVE) {
7146 if (o->op_type == OP_SORT) {
7147 op_null(kid); /* wipe out leave */
7150 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
7151 if (k->op_next == kid)
7153 /* don't descend into loops */
7154 else if (k->op_type == OP_ENTERLOOP
7155 || k->op_type == OP_ENTERITER)
7157 k = cLOOPx(k)->op_lastop;
7162 kid->op_next = 0; /* just disconnect the leave */
7163 k = kLISTOP->op_first;
7168 if (o->op_type == OP_SORT) {
7169 /* provide scalar context for comparison function/block */
7175 o->op_flags |= OPf_SPECIAL;
7177 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
7180 firstkid = firstkid->op_sibling;
7183 /* provide list context for arguments */
7184 if (o->op_type == OP_SORT)
7191 S_simplify_sort(pTHX_ OP *o)
7194 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7199 if (!(o->op_flags & OPf_STACKED))
7201 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7202 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
7203 kid = kUNOP->op_first; /* get past null */
7204 if (kid->op_type != OP_SCOPE)
7206 kid = kLISTOP->op_last; /* get past scope */
7207 switch(kid->op_type) {
7215 k = kid; /* remember this node*/
7216 if (kBINOP->op_first->op_type != OP_RV2SV)
7218 kid = kBINOP->op_first; /* get past cmp */
7219 if (kUNOP->op_first->op_type != OP_GV)
7221 kid = kUNOP->op_first; /* get past rv2sv */
7223 if (GvSTASH(gv) != PL_curstash)
7225 gvname = GvNAME(gv);
7226 if (*gvname == 'a' && gvname[1] == '\0')
7228 else if (*gvname == 'b' && gvname[1] == '\0')
7233 kid = k; /* back to cmp */
7234 if (kBINOP->op_last->op_type != OP_RV2SV)
7236 kid = kBINOP->op_last; /* down to 2nd arg */
7237 if (kUNOP->op_first->op_type != OP_GV)
7239 kid = kUNOP->op_first; /* get past rv2sv */
7241 if (GvSTASH(gv) != PL_curstash)
7243 gvname = GvNAME(gv);
7245 ? !(*gvname == 'a' && gvname[1] == '\0')
7246 : !(*gvname == 'b' && gvname[1] == '\0'))
7248 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
7250 o->op_private |= OPpSORT_DESCEND;
7251 if (k->op_type == OP_NCMP)
7252 o->op_private |= OPpSORT_NUMERIC;
7253 if (k->op_type == OP_I_NCMP)
7254 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
7255 kid = cLISTOPo->op_first->op_sibling;
7256 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
7258 op_getmad(kid,o,'S'); /* then delete it */
7260 op_free(kid); /* then delete it */
7265 Perl_ck_split(pTHX_ OP *o)
7270 if (o->op_flags & OPf_STACKED)
7271 return no_fh_allowed(o);
7273 kid = cLISTOPo->op_first;
7274 if (kid->op_type != OP_NULL)
7275 Perl_croak(aTHX_ "panic: ck_split");
7276 kid = kid->op_sibling;
7277 op_free(cLISTOPo->op_first);
7278 cLISTOPo->op_first = kid;
7280 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
7281 cLISTOPo->op_last = kid; /* There was only one element previously */
7284 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
7285 OP * const sibl = kid->op_sibling;
7286 kid->op_sibling = 0;
7287 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
7288 if (cLISTOPo->op_first == cLISTOPo->op_last)
7289 cLISTOPo->op_last = kid;
7290 cLISTOPo->op_first = kid;
7291 kid->op_sibling = sibl;
7294 kid->op_type = OP_PUSHRE;
7295 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
7297 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
7298 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
7299 "Use of /g modifier is meaningless in split");
7302 if (!kid->op_sibling)
7303 append_elem(OP_SPLIT, o, newDEFSVOP());
7305 kid = kid->op_sibling;
7308 if (!kid->op_sibling)
7309 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
7310 assert(kid->op_sibling);
7312 kid = kid->op_sibling;
7315 if (kid->op_sibling)
7316 return too_many_arguments(o,OP_DESC(o));
7322 Perl_ck_join(pTHX_ OP *o)
7324 const OP * const kid = cLISTOPo->op_first->op_sibling;
7325 if (kid && kid->op_type == OP_MATCH) {
7326 if (ckWARN(WARN_SYNTAX)) {
7327 const REGEXP *re = PM_GETRE(kPMOP);
7328 const char *pmstr = re ? re->precomp : "STRING";
7329 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7330 "/%s/ should probably be written as \"%s\"",
7338 Perl_ck_subr(pTHX_ OP *o)
7341 OP *prev = ((cUNOPo->op_first->op_sibling)
7342 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
7343 OP *o2 = prev->op_sibling;
7345 const char *proto = NULL;
7346 const char *proto_end = NULL;
7351 I32 contextclass = 0;
7352 const char *e = NULL;
7355 o->op_private |= OPpENTERSUB_HASTARG;
7356 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
7357 if (cvop->op_type == OP_RV2CV) {
7359 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
7360 op_null(cvop); /* disable rv2cv */
7361 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
7362 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
7363 GV *gv = cGVOPx_gv(tmpop);
7366 tmpop->op_private |= OPpEARLY_CV;
7370 namegv = CvANON(cv) ? gv : CvGV(cv);
7371 proto = SvPV((SV*)cv, len);
7372 proto_end = proto + len;
7374 if (CvASSERTION(cv)) {
7375 U32 asserthints = 0;
7376 HV *const hinthv = GvHV(PL_hintgv);
7378 SV **svp = hv_fetchs(hinthv, "assertions", FALSE);
7380 asserthints = SvUV(*svp);
7382 if (asserthints & HINT_ASSERTING) {
7383 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
7384 o->op_private |= OPpENTERSUB_DB;
7388 if (!(asserthints & HINT_ASSERTIONSSEEN) && ckWARN(WARN_ASSERTIONS)) {
7389 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
7390 "Impossible to activate assertion call");
7397 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7398 if (o2->op_type == OP_CONST)
7399 o2->op_private &= ~OPpCONST_STRICT;
7400 else if (o2->op_type == OP_LIST) {
7401 OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
7402 if (sib && sib->op_type == OP_CONST)
7403 sib->op_private &= ~OPpCONST_STRICT;
7406 o->op_private |= (PL_hints & HINT_STRICT_REFS);
7407 if (PERLDB_SUB && PL_curstash != PL_debstash)
7408 o->op_private |= OPpENTERSUB_DB;
7409 while (o2 != cvop) {
7411 if (PL_madskills && o2->op_type == OP_NULL)
7412 o3 = ((UNOP*)o2)->op_first;
7416 if (proto >= proto_end)
7417 return too_many_arguments(o, gv_ename(namegv));
7425 /* _ must be at the end */
7426 if (proto[1] && proto[1] != ';')
7441 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
7443 arg == 1 ? "block or sub {}" : "sub {}",
7444 gv_ename(namegv), o3);
7447 /* '*' allows any scalar type, including bareword */
7450 if (o3->op_type == OP_RV2GV)
7451 goto wrapref; /* autoconvert GLOB -> GLOBref */
7452 else if (o3->op_type == OP_CONST)
7453 o3->op_private &= ~OPpCONST_STRICT;
7454 else if (o3->op_type == OP_ENTERSUB) {
7455 /* accidental subroutine, revert to bareword */
7456 OP *gvop = ((UNOP*)o3)->op_first;
7457 if (gvop && gvop->op_type == OP_NULL) {
7458 gvop = ((UNOP*)gvop)->op_first;
7460 for (; gvop->op_sibling; gvop = gvop->op_sibling)
7463 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
7464 (gvop = ((UNOP*)gvop)->op_first) &&
7465 gvop->op_type == OP_GV)
7467 GV * const gv = cGVOPx_gv(gvop);
7468 OP * const sibling = o2->op_sibling;
7469 SV * const n = newSVpvs("");
7471 OP * const oldo2 = o2;
7475 gv_fullname4(n, gv, "", FALSE);
7476 o2 = newSVOP(OP_CONST, 0, n);
7477 op_getmad(oldo2,o2,'O');
7478 prev->op_sibling = o2;
7479 o2->op_sibling = sibling;
7495 if (contextclass++ == 0) {
7496 e = strchr(proto, ']');
7497 if (!e || e == proto)
7506 const char *p = proto;
7507 const char *const end = proto;
7509 while (*--p != '[');
7510 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
7512 gv_ename(namegv), o3);
7517 if (o3->op_type == OP_RV2GV)
7520 bad_type(arg, "symbol", gv_ename(namegv), o3);
7523 if (o3->op_type == OP_ENTERSUB)
7526 bad_type(arg, "subroutine entry", gv_ename(namegv),
7530 if (o3->op_type == OP_RV2SV ||
7531 o3->op_type == OP_PADSV ||
7532 o3->op_type == OP_HELEM ||
7533 o3->op_type == OP_AELEM ||
7534 o3->op_type == OP_THREADSV)
7537 bad_type(arg, "scalar", gv_ename(namegv), o3);
7540 if (o3->op_type == OP_RV2AV ||
7541 o3->op_type == OP_PADAV)
7544 bad_type(arg, "array", gv_ename(namegv), o3);
7547 if (o3->op_type == OP_RV2HV ||
7548 o3->op_type == OP_PADHV)
7551 bad_type(arg, "hash", gv_ename(namegv), o3);
7556 OP* const sib = kid->op_sibling;
7557 kid->op_sibling = 0;
7558 o2 = newUNOP(OP_REFGEN, 0, kid);
7559 o2->op_sibling = sib;
7560 prev->op_sibling = o2;
7562 if (contextclass && e) {
7577 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
7578 gv_ename(namegv), SVfARG(cv));
7583 mod(o2, OP_ENTERSUB);
7585 o2 = o2->op_sibling;
7587 if (o2 == cvop && proto && *proto == '_') {
7588 /* generate an access to $_ */
7590 o2->op_sibling = prev->op_sibling;
7591 prev->op_sibling = o2; /* instead of cvop */
7593 if (proto && !optional && proto_end > proto &&
7594 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
7595 return too_few_arguments(o, gv_ename(namegv));
7598 OP * const oldo = o;
7602 o=newSVOP(OP_CONST, 0, newSViv(0));
7603 op_getmad(oldo,o,'O');
7609 Perl_ck_svconst(pTHX_ OP *o)
7611 PERL_UNUSED_CONTEXT;
7612 SvREADONLY_on(cSVOPo->op_sv);
7617 Perl_ck_chdir(pTHX_ OP *o)
7619 if (o->op_flags & OPf_KIDS) {
7620 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7622 if (kid && kid->op_type == OP_CONST &&
7623 (kid->op_private & OPpCONST_BARE))
7625 o->op_flags |= OPf_SPECIAL;
7626 kid->op_private &= ~OPpCONST_STRICT;
7633 Perl_ck_trunc(pTHX_ OP *o)
7635 if (o->op_flags & OPf_KIDS) {
7636 SVOP *kid = (SVOP*)cUNOPo->op_first;
7638 if (kid->op_type == OP_NULL)
7639 kid = (SVOP*)kid->op_sibling;
7640 if (kid && kid->op_type == OP_CONST &&
7641 (kid->op_private & OPpCONST_BARE))
7643 o->op_flags |= OPf_SPECIAL;
7644 kid->op_private &= ~OPpCONST_STRICT;
7651 Perl_ck_unpack(pTHX_ OP *o)
7653 OP *kid = cLISTOPo->op_first;
7654 if (kid->op_sibling) {
7655 kid = kid->op_sibling;
7656 if (!kid->op_sibling)
7657 kid->op_sibling = newDEFSVOP();
7663 Perl_ck_substr(pTHX_ OP *o)
7666 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
7667 OP *kid = cLISTOPo->op_first;
7669 if (kid->op_type == OP_NULL)
7670 kid = kid->op_sibling;
7672 kid->op_flags |= OPf_MOD;
7678 /* A peephole optimizer. We visit the ops in the order they're to execute.
7679 * See the comments at the top of this file for more details about when
7680 * peep() is called */
7683 Perl_peep(pTHX_ register OP *o)
7686 register OP* oldop = NULL;
7688 if (!o || o->op_opt)
7692 SAVEVPTR(PL_curcop);
7693 for (; o; o = o->op_next) {
7697 switch (o->op_type) {
7701 PL_curcop = ((COP*)o); /* for warnings */
7706 if (cSVOPo->op_private & OPpCONST_STRICT)
7707 no_bareword_allowed(o);
7709 case OP_METHOD_NAMED:
7710 /* Relocate sv to the pad for thread safety.
7711 * Despite being a "constant", the SV is written to,
7712 * for reference counts, sv_upgrade() etc. */
7714 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
7715 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
7716 /* If op_sv is already a PADTMP then it is being used by
7717 * some pad, so make a copy. */
7718 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
7719 SvREADONLY_on(PAD_SVl(ix));
7720 SvREFCNT_dec(cSVOPo->op_sv);
7722 else if (o->op_type == OP_CONST
7723 && cSVOPo->op_sv == &PL_sv_undef) {
7724 /* PL_sv_undef is hack - it's unsafe to store it in the
7725 AV that is the pad, because av_fetch treats values of
7726 PL_sv_undef as a "free" AV entry and will merrily
7727 replace them with a new SV, causing pad_alloc to think
7728 that this pad slot is free. (When, clearly, it is not)
7730 SvOK_off(PAD_SVl(ix));
7731 SvPADTMP_on(PAD_SVl(ix));
7732 SvREADONLY_on(PAD_SVl(ix));
7735 SvREFCNT_dec(PAD_SVl(ix));
7736 SvPADTMP_on(cSVOPo->op_sv);
7737 PAD_SETSV(ix, cSVOPo->op_sv);
7738 /* XXX I don't know how this isn't readonly already. */
7739 SvREADONLY_on(PAD_SVl(ix));
7741 cSVOPo->op_sv = NULL;
7749 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
7750 if (o->op_next->op_private & OPpTARGET_MY) {
7751 if (o->op_flags & OPf_STACKED) /* chained concats */
7752 goto ignore_optimization;
7754 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
7755 o->op_targ = o->op_next->op_targ;
7756 o->op_next->op_targ = 0;
7757 o->op_private |= OPpTARGET_MY;
7760 op_null(o->op_next);
7762 ignore_optimization:
7766 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
7768 break; /* Scalar stub must produce undef. List stub is noop */
7772 if (o->op_targ == OP_NEXTSTATE
7773 || o->op_targ == OP_DBSTATE
7774 || o->op_targ == OP_SETSTATE)
7776 PL_curcop = ((COP*)o);
7778 /* XXX: We avoid setting op_seq here to prevent later calls
7779 to peep() from mistakenly concluding that optimisation
7780 has already occurred. This doesn't fix the real problem,
7781 though (See 20010220.007). AMS 20010719 */
7782 /* op_seq functionality is now replaced by op_opt */
7783 if (oldop && o->op_next) {
7784 oldop->op_next = o->op_next;
7792 if (oldop && o->op_next) {
7793 oldop->op_next = o->op_next;
7801 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
7802 OP* const pop = (o->op_type == OP_PADAV) ?
7803 o->op_next : o->op_next->op_next;
7805 if (pop && pop->op_type == OP_CONST &&
7806 ((PL_op = pop->op_next)) &&
7807 pop->op_next->op_type == OP_AELEM &&
7808 !(pop->op_next->op_private &
7809 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
7810 (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
7815 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
7816 no_bareword_allowed(pop);
7817 if (o->op_type == OP_GV)
7818 op_null(o->op_next);
7819 op_null(pop->op_next);
7821 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
7822 o->op_next = pop->op_next->op_next;
7823 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
7824 o->op_private = (U8)i;
7825 if (o->op_type == OP_GV) {
7830 o->op_flags |= OPf_SPECIAL;
7831 o->op_type = OP_AELEMFAST;
7837 if (o->op_next->op_type == OP_RV2SV) {
7838 if (!(o->op_next->op_private & OPpDEREF)) {
7839 op_null(o->op_next);
7840 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
7842 o->op_next = o->op_next->op_next;
7843 o->op_type = OP_GVSV;
7844 o->op_ppaddr = PL_ppaddr[OP_GVSV];
7847 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
7848 GV * const gv = cGVOPo_gv;
7849 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
7850 /* XXX could check prototype here instead of just carping */
7851 SV * const sv = sv_newmortal();
7852 gv_efullname3(sv, gv, NULL);
7853 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
7854 "%"SVf"() called too early to check prototype",
7858 else if (o->op_next->op_type == OP_READLINE
7859 && o->op_next->op_next->op_type == OP_CONCAT
7860 && (o->op_next->op_next->op_flags & OPf_STACKED))
7862 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
7863 o->op_type = OP_RCATLINE;
7864 o->op_flags |= OPf_STACKED;
7865 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
7866 op_null(o->op_next->op_next);
7867 op_null(o->op_next);
7884 while (cLOGOP->op_other->op_type == OP_NULL)
7885 cLOGOP->op_other = cLOGOP->op_other->op_next;
7886 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
7892 while (cLOOP->op_redoop->op_type == OP_NULL)
7893 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
7894 peep(cLOOP->op_redoop);
7895 while (cLOOP->op_nextop->op_type == OP_NULL)
7896 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
7897 peep(cLOOP->op_nextop);
7898 while (cLOOP->op_lastop->op_type == OP_NULL)
7899 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
7900 peep(cLOOP->op_lastop);
7907 while (cPMOP->op_pmreplstart &&
7908 cPMOP->op_pmreplstart->op_type == OP_NULL)
7909 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
7910 peep(cPMOP->op_pmreplstart);
7915 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
7916 && ckWARN(WARN_SYNTAX))
7918 if (o->op_next->op_sibling) {
7919 const OPCODE type = o->op_next->op_sibling->op_type;
7920 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
7921 const line_t oldline = CopLINE(PL_curcop);
7922 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
7923 Perl_warner(aTHX_ packWARN(WARN_EXEC),
7924 "Statement unlikely to be reached");
7925 Perl_warner(aTHX_ packWARN(WARN_EXEC),
7926 "\t(Maybe you meant system() when you said exec()?)\n");
7927 CopLINE_set(PL_curcop, oldline);
7938 const char *key = NULL;
7943 if (((BINOP*)o)->op_last->op_type != OP_CONST)
7946 /* Make the CONST have a shared SV */
7947 svp = cSVOPx_svp(((BINOP*)o)->op_last);
7948 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
7949 key = SvPV_const(sv, keylen);
7950 lexname = newSVpvn_share(key,
7951 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
7957 if ((o->op_private & (OPpLVAL_INTRO)))
7960 rop = (UNOP*)((BINOP*)o)->op_first;
7961 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7963 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7964 if (!SvPAD_TYPED(lexname))
7966 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
7967 if (!fields || !GvHV(*fields))
7969 key = SvPV_const(*svp, keylen);
7970 if (!hv_fetch(GvHV(*fields), key,
7971 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
7973 Perl_croak(aTHX_ "No such class field \"%s\" "
7974 "in variable %s of type %s",
7975 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
7988 SVOP *first_key_op, *key_op;
7990 if ((o->op_private & (OPpLVAL_INTRO))
7991 /* I bet there's always a pushmark... */
7992 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
7993 /* hmmm, no optimization if list contains only one key. */
7995 rop = (UNOP*)((LISTOP*)o)->op_last;
7996 if (rop->op_type != OP_RV2HV)
7998 if (rop->op_first->op_type == OP_PADSV)
7999 /* @$hash{qw(keys here)} */
8000 rop = (UNOP*)rop->op_first;
8002 /* @{$hash}{qw(keys here)} */
8003 if (rop->op_first->op_type == OP_SCOPE
8004 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
8006 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
8012 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
8013 if (!SvPAD_TYPED(lexname))
8015 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8016 if (!fields || !GvHV(*fields))
8018 /* Again guessing that the pushmark can be jumped over.... */
8019 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
8020 ->op_first->op_sibling;
8021 for (key_op = first_key_op; key_op;
8022 key_op = (SVOP*)key_op->op_sibling) {
8023 if (key_op->op_type != OP_CONST)
8025 svp = cSVOPx_svp(key_op);
8026 key = SvPV_const(*svp, keylen);
8027 if (!hv_fetch(GvHV(*fields), key,
8028 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8030 Perl_croak(aTHX_ "No such class field \"%s\" "
8031 "in variable %s of type %s",
8032 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
8039 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
8043 /* check that RHS of sort is a single plain array */
8044 OP *oright = cUNOPo->op_first;
8045 if (!oright || oright->op_type != OP_PUSHMARK)
8048 /* reverse sort ... can be optimised. */
8049 if (!cUNOPo->op_sibling) {
8050 /* Nothing follows us on the list. */
8051 OP * const reverse = o->op_next;
8053 if (reverse->op_type == OP_REVERSE &&
8054 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
8055 OP * const pushmark = cUNOPx(reverse)->op_first;
8056 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
8057 && (cUNOPx(pushmark)->op_sibling == o)) {
8058 /* reverse -> pushmark -> sort */
8059 o->op_private |= OPpSORT_REVERSE;
8061 pushmark->op_next = oright->op_next;
8067 /* make @a = sort @a act in-place */
8071 oright = cUNOPx(oright)->op_sibling;
8074 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
8075 oright = cUNOPx(oright)->op_sibling;
8079 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
8080 || oright->op_next != o
8081 || (oright->op_private & OPpLVAL_INTRO)
8085 /* o2 follows the chain of op_nexts through the LHS of the
8086 * assign (if any) to the aassign op itself */
8088 if (!o2 || o2->op_type != OP_NULL)
8091 if (!o2 || o2->op_type != OP_PUSHMARK)
8094 if (o2 && o2->op_type == OP_GV)
8097 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
8098 || (o2->op_private & OPpLVAL_INTRO)
8103 if (!o2 || o2->op_type != OP_NULL)
8106 if (!o2 || o2->op_type != OP_AASSIGN
8107 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
8110 /* check that the sort is the first arg on RHS of assign */
8112 o2 = cUNOPx(o2)->op_first;
8113 if (!o2 || o2->op_type != OP_NULL)
8115 o2 = cUNOPx(o2)->op_first;
8116 if (!o2 || o2->op_type != OP_PUSHMARK)
8118 if (o2->op_sibling != o)
8121 /* check the array is the same on both sides */
8122 if (oleft->op_type == OP_RV2AV) {
8123 if (oright->op_type != OP_RV2AV
8124 || !cUNOPx(oright)->op_first
8125 || cUNOPx(oright)->op_first->op_type != OP_GV
8126 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
8127 cGVOPx_gv(cUNOPx(oright)->op_first)
8131 else if (oright->op_type != OP_PADAV
8132 || oright->op_targ != oleft->op_targ
8136 /* transfer MODishness etc from LHS arg to RHS arg */
8137 oright->op_flags = oleft->op_flags;
8138 o->op_private |= OPpSORT_INPLACE;
8140 /* excise push->gv->rv2av->null->aassign */
8141 o2 = o->op_next->op_next;
8142 op_null(o2); /* PUSHMARK */
8144 if (o2->op_type == OP_GV) {
8145 op_null(o2); /* GV */
8148 op_null(o2); /* RV2AV or PADAV */
8149 o2 = o2->op_next->op_next;
8150 op_null(o2); /* AASSIGN */
8152 o->op_next = o2->op_next;
8158 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
8160 LISTOP *enter, *exlist;
8163 enter = (LISTOP *) o->op_next;
8166 if (enter->op_type == OP_NULL) {
8167 enter = (LISTOP *) enter->op_next;
8171 /* for $a (...) will have OP_GV then OP_RV2GV here.
8172 for (...) just has an OP_GV. */
8173 if (enter->op_type == OP_GV) {
8174 gvop = (OP *) enter;
8175 enter = (LISTOP *) enter->op_next;
8178 if (enter->op_type == OP_RV2GV) {
8179 enter = (LISTOP *) enter->op_next;
8185 if (enter->op_type != OP_ENTERITER)
8188 iter = enter->op_next;
8189 if (!iter || iter->op_type != OP_ITER)
8192 expushmark = enter->op_first;
8193 if (!expushmark || expushmark->op_type != OP_NULL
8194 || expushmark->op_targ != OP_PUSHMARK)
8197 exlist = (LISTOP *) expushmark->op_sibling;
8198 if (!exlist || exlist->op_type != OP_NULL
8199 || exlist->op_targ != OP_LIST)
8202 if (exlist->op_last != o) {
8203 /* Mmm. Was expecting to point back to this op. */
8206 theirmark = exlist->op_first;
8207 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
8210 if (theirmark->op_sibling != o) {
8211 /* There's something between the mark and the reverse, eg
8212 for (1, reverse (...))
8217 ourmark = ((LISTOP *)o)->op_first;
8218 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
8221 ourlast = ((LISTOP *)o)->op_last;
8222 if (!ourlast || ourlast->op_next != o)
8225 rv2av = ourmark->op_sibling;
8226 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
8227 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
8228 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
8229 /* We're just reversing a single array. */
8230 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
8231 enter->op_flags |= OPf_STACKED;
8234 /* We don't have control over who points to theirmark, so sacrifice
8236 theirmark->op_next = ourmark->op_next;
8237 theirmark->op_flags = ourmark->op_flags;
8238 ourlast->op_next = gvop ? gvop : (OP *) enter;
8241 enter->op_private |= OPpITER_REVERSED;
8242 iter->op_private |= OPpITER_REVERSED;
8249 UNOP *refgen, *rv2cv;
8252 /* I do not understand this, but if o->op_opt isn't set to 1,
8253 various tests in ext/B/t/bytecode.t fail with no readily
8259 if ((o->op_flags && OPf_WANT) != OPf_WANT_VOID)
8262 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
8265 rv2gv = ((BINOP *)o)->op_last;
8266 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
8269 refgen = (UNOP *)((BINOP *)o)->op_first;
8271 if (!refgen || refgen->op_type != OP_REFGEN)
8274 exlist = (LISTOP *)refgen->op_first;
8275 if (!exlist || exlist->op_type != OP_NULL
8276 || exlist->op_targ != OP_LIST)
8279 if (exlist->op_first->op_type != OP_PUSHMARK)
8282 rv2cv = (UNOP*)exlist->op_last;
8284 if (rv2cv->op_type != OP_RV2CV)
8287 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
8288 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
8289 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
8291 o->op_private |= OPpASSIGN_CV_TO_GV;
8292 rv2gv->op_private |= OPpDONT_INIT_GV;
8293 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
8309 Perl_custom_op_name(pTHX_ const OP* o)
8312 const IV index = PTR2IV(o->op_ppaddr);
8316 if (!PL_custom_op_names) /* This probably shouldn't happen */
8317 return (char *)PL_op_name[OP_CUSTOM];
8319 keysv = sv_2mortal(newSViv(index));
8321 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
8323 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
8325 return SvPV_nolen(HeVAL(he));
8329 Perl_custom_op_desc(pTHX_ const OP* o)
8332 const IV index = PTR2IV(o->op_ppaddr);
8336 if (!PL_custom_op_descs)
8337 return (char *)PL_op_desc[OP_CUSTOM];
8339 keysv = sv_2mortal(newSViv(index));
8341 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
8343 return (char *)PL_op_desc[OP_CUSTOM];
8345 return SvPV_nolen(HeVAL(he));
8350 /* Efficient sub that returns a constant scalar value. */
8352 const_sv_xsub(pTHX_ CV* cv)
8359 Perl_croak(aTHX_ "usage: %s::%s()",
8360 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
8364 ST(0) = (SV*)XSANY.any_ptr;
8370 * c-indentation-style: bsd
8372 * indent-tabs-mode: t
8375 * ex: set ts=8 sts=4 sw=4 noet: