3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * "You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
13 * our Mr. Bilbo's first cousin on the mother's side (her mother being the
14 * youngest of the Old Took's daughters); and Mr. Drogo was his second
15 * cousin. So Mr. Frodo is his first *and* second cousin, once removed
16 * either way, as the saying is, if you follow me." --the Gaffer
19 /* This file contains the functions that create, manipulate and optimize
20 * the OP structures that hold a compiled perl program.
22 * A Perl program is compiled into a tree of OPs. Each op contains
23 * structural pointers (eg to its siblings and the next op in the
24 * execution sequence), a pointer to the function that would execute the
25 * op, plus any data specific to that op. For example, an OP_CONST op
26 * points to the pp_const() function and to an SV containing the constant
27 * value. When pp_const() is executed, its job is to push that SV onto the
30 * OPs are mainly created by the newFOO() functions, which are mainly
31 * called from the parser (in perly.y) as the code is parsed. For example
32 * the Perl code $a + $b * $c would cause the equivalent of the following
33 * to be called (oversimplifying a bit):
35 * newBINOP(OP_ADD, flags,
37 * newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
40 * Note that during the build of miniperl, a temporary copy of this file
41 * is made, called opmini.c.
45 Perl's compiler is essentially a 3-pass compiler with interleaved phases:
49 An execution-order pass
51 The bottom-up pass is represented by all the "newOP" routines and
52 the ck_ routines. The bottom-upness is actually driven by yacc.
53 So at the point that a ck_ routine fires, we have no idea what the
54 context is, either upward in the syntax tree, or either forward or
55 backward in the execution order. (The bottom-up parser builds that
56 part of the execution order it knows about, but if you follow the "next"
57 links around, you'll find it's actually a closed loop through the
60 Whenever the bottom-up parser gets to a node that supplies context to
61 its components, it invokes that portion of the top-down pass that applies
62 to that part of the subtree (and marks the top node as processed, so
63 if a node further up supplies context, it doesn't have to take the
64 plunge again). As a particular subcase of this, as the new node is
65 built, it takes all the closed execution loops of its subcomponents
66 and links them into a new closed loop for the higher level node. But
67 it's still not the real execution order.
69 The actual execution order is not known till we get a grammar reduction
70 to a top-level unit like a subroutine or file that will be called by
71 "name" rather than via a "next" pointer. At that point, we can call
72 into peep() to do that code's portion of the 3rd pass. It has to be
73 recursive, but it's recursive on basic blocks, not on tree nodes.
76 /* To implement user lexical pragmas, there needs to be a way at run time to
77 get the compile time state of %^H for that block. Storing %^H in every
78 block (or even COP) would be very expensive, so a different approach is
79 taken. The (running) state of %^H is serialised into a tree of HE-like
80 structs. Stores into %^H are chained onto the current leaf as a struct
81 refcounted_he * with the key and the value. Deletes from %^H are saved
82 with a value of PL_sv_placeholder. The state of %^H at any point can be
83 turned back into a regular HV by walking back up the tree from that point's
84 leaf, ignoring any key you've already seen (placeholder or not), storing
85 the rest into the HV structure, then removing the placeholders. Hence
86 memory is only used to store the %^H deltas from the enclosing COP, rather
87 than the entire %^H on each COP.
89 To cause actions on %^H to write out the serialisation records, it has
90 magic type 'H'. This magic (itself) does nothing, but its presence causes
91 the values to gain magic type 'h', which has entries for set and clear.
92 C<Perl_magic_sethint> updates C<PL_compiling.cop_hints_hash> with a store
93 record, with deletes written by C<Perl_magic_clearhint>. C<SAVE_HINTS>
94 saves the current C<PL_compiling.cop_hints_hash> on the save stack, so that
95 it will be correctly restored when any inner compiling scope is exited.
101 #include "keywords.h"
103 #define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
105 #if defined(PL_OP_SLAB_ALLOC)
107 #ifndef PERL_SLAB_SIZE
108 #define PERL_SLAB_SIZE 2048
112 Perl_Slab_Alloc(pTHX_ int m, size_t sz)
115 * To make incrementing use count easy PL_OpSlab is an I32 *
116 * To make inserting the link to slab PL_OpPtr is I32 **
117 * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
118 * Add an overhead for pointer to slab and round up as a number of pointers
120 sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
121 if ((PL_OpSpace -= sz) < 0) {
122 PL_OpPtr = (I32 **) PerlMemShared_malloc(PERL_SLAB_SIZE*sizeof(I32*));
126 Zero(PL_OpPtr,PERL_SLAB_SIZE,I32 **);
127 /* We reserve the 0'th I32 sized chunk as a use count */
128 PL_OpSlab = (I32 *) PL_OpPtr;
129 /* Reduce size by the use count word, and by the size we need.
130 * Latter is to mimic the '-=' in the if() above
132 PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
133 /* Allocation pointer starts at the top.
134 Theory: because we build leaves before trunk allocating at end
135 means that at run time access is cache friendly upward
137 PL_OpPtr += PERL_SLAB_SIZE;
139 assert( PL_OpSpace >= 0 );
140 /* Move the allocation pointer down */
142 assert( PL_OpPtr > (I32 **) PL_OpSlab );
143 *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */
144 (*PL_OpSlab)++; /* Increment use count of slab */
145 assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
146 assert( *PL_OpSlab > 0 );
147 return (void *)(PL_OpPtr + 1);
151 Perl_Slab_Free(pTHX_ void *op)
153 I32 * const * const ptr = (I32 **) op;
154 I32 * const slab = ptr[-1];
155 assert( ptr-1 > (I32 **) slab );
156 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
158 if (--(*slab) == 0) {
160 # define PerlMemShared PerlMem
163 PerlMemShared_free(slab);
164 if (slab == PL_OpSlab) {
171 * In the following definition, the ", (OP*)0" is just to make the compiler
172 * think the expression is of the right type: croak actually does a Siglongjmp.
174 #define CHECKOP(type,o) \
175 ((PL_op_mask && PL_op_mask[type]) \
176 ? ( op_free((OP*)o), \
177 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
179 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
181 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
184 S_gv_ename(pTHX_ GV *gv)
186 SV* const tmpsv = sv_newmortal();
187 gv_efullname3(tmpsv, gv, NULL);
188 return SvPV_nolen_const(tmpsv);
192 S_no_fh_allowed(pTHX_ OP *o)
194 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
200 S_too_few_arguments(pTHX_ OP *o, const char *name)
202 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
207 S_too_many_arguments(pTHX_ OP *o, const char *name)
209 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
214 S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid)
216 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
217 (int)n, name, t, OP_DESC(kid)));
221 S_no_bareword_allowed(pTHX_ const OP *o)
224 return; /* various ok barewords are hidden in extra OP_NULL */
225 qerror(Perl_mess(aTHX_
226 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
230 /* "register" allocation */
233 Perl_allocmy(pTHX_ const char *const name)
237 const bool is_our = (PL_in_my == KEY_our);
239 /* complain about "my $<special_var>" etc etc */
243 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
244 (name[1] == '_' && (*name == '$' || name[2]))))
246 /* name[2] is true if strlen(name) > 2 */
247 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
248 yyerror(Perl_form(aTHX_ "Can't use global %c^%c%s in \"my\"",
249 name[0], toCTRL(name[1]), name + 2));
251 yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
255 /* check for duplicate declaration */
256 pad_check_dup(name, is_our, (PL_curstash ? PL_curstash : PL_defstash));
258 if (PL_in_my_stash && *name != '$') {
259 yyerror(Perl_form(aTHX_
260 "Can't declare class for non-scalar %s in \"%s\"",
262 is_our ? "our" : PL_in_my == KEY_state ? "state" : "my"));
265 /* allocate a spare slot and store the name in that slot */
267 off = pad_add_name(name,
270 /* $_ is always in main::, even with our */
271 ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
275 PL_in_my == KEY_state
280 /* free the body of an op without examining its contents.
281 * Always use this rather than FreeOp directly */
284 S_op_destroy(pTHX_ OP *o)
286 if (o->op_latefree) {
297 Perl_op_free(pTHX_ OP *o)
302 if (!o || o->op_static)
304 if (o->op_latefreed) {
311 if (o->op_private & OPpREFCOUNTED) {
322 refcnt = OpREFCNT_dec(o);
333 if (o->op_flags & OPf_KIDS) {
334 register OP *kid, *nextkid;
335 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
336 nextkid = kid->op_sibling; /* Get before next freeing kid */
341 type = (OPCODE)o->op_targ;
343 /* COP* is not cleared by op_clear() so that we may track line
344 * numbers etc even after null() */
345 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
349 if (o->op_latefree) {
355 #ifdef DEBUG_LEAKING_SCALARS
362 Perl_op_clear(pTHX_ OP *o)
367 /* if (o->op_madprop && o->op_madprop->mad_next)
369 /* FIXME for MAD - if I uncomment these two lines t/op/pack.t fails with
370 "modification of a read only value" for a reason I can't fathom why.
371 It's the "" stringification of $_, where $_ was set to '' in a foreach
372 loop, but it defies simplification into a small test case.
373 However, commenting them out has caused ext/List/Util/t/weak.t to fail
376 mad_free(o->op_madprop);
382 switch (o->op_type) {
383 case OP_NULL: /* Was holding old type, if any. */
384 if (PL_madskills && o->op_targ != OP_NULL) {
385 o->op_type = o->op_targ;
389 case OP_ENTEREVAL: /* Was holding hints. */
393 if (!(o->op_flags & OPf_REF)
394 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
400 if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
401 /* not an OP_PADAV replacement */
403 if (cPADOPo->op_padix > 0) {
404 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
405 * may still exist on the pad */
406 pad_swipe(cPADOPo->op_padix, TRUE);
407 cPADOPo->op_padix = 0;
410 SvREFCNT_dec(cSVOPo->op_sv);
411 cSVOPo->op_sv = NULL;
415 case OP_METHOD_NAMED:
417 SvREFCNT_dec(cSVOPo->op_sv);
418 cSVOPo->op_sv = NULL;
421 Even if op_clear does a pad_free for the target of the op,
422 pad_free doesn't actually remove the sv that exists in the pad;
423 instead it lives on. This results in that it could be reused as
424 a target later on when the pad was reallocated.
427 pad_swipe(o->op_targ,1);
436 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
440 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
441 SvREFCNT_dec(cSVOPo->op_sv);
442 cSVOPo->op_sv = NULL;
445 Safefree(cPVOPo->op_pv);
446 cPVOPo->op_pv = NULL;
450 op_free(cPMOPo->op_pmreplroot);
454 if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) {
455 /* No GvIN_PAD_off here, because other references may still
456 * exist on the pad */
457 pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot), TRUE);
460 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
467 HV * const pmstash = PmopSTASH(cPMOPo);
468 if (pmstash && !SvIS_FREED(pmstash)) {
469 MAGIC * const mg = mg_find((SV*)pmstash, PERL_MAGIC_symtab);
471 PMOP *pmop = (PMOP*) mg->mg_obj;
472 PMOP *lastpmop = NULL;
474 if (cPMOPo == pmop) {
476 lastpmop->op_pmnext = pmop->op_pmnext;
478 mg->mg_obj = (SV*) pmop->op_pmnext;
482 pmop = pmop->op_pmnext;
486 PmopSTASH_free(cPMOPo);
488 cPMOPo->op_pmreplroot = NULL;
489 /* we use the "SAFE" version of the PM_ macros here
490 * since sv_clean_all might release some PMOPs
491 * after PL_regex_padav has been cleared
492 * and the clearing of PL_regex_padav needs to
493 * happen before sv_clean_all
495 ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
496 PM_SETRE_SAFE(cPMOPo, NULL);
498 if(PL_regex_pad) { /* We could be in destruction */
499 av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
500 SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
501 PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
508 if (o->op_targ > 0) {
509 pad_free(o->op_targ);
515 S_cop_free(pTHX_ COP* cop)
517 if (cop->cop_label) {
518 #ifdef PERL_TRACK_MEMPOOL
519 Malloc_t ptr = (Malloc_t)(cop->cop_label - sTHX);
520 struct perl_memory_debug_header *const header
521 = (struct perl_memory_debug_header *)ptr;
522 /* Only the thread that allocated us can free us. */
523 if (header->interpreter == aTHX)
526 Safefree(cop->cop_label);
527 cop->cop_label = NULL;
532 if (! specialWARN(cop->cop_warnings))
533 PerlMemShared_free(cop->cop_warnings);
534 Perl_refcounted_he_free(aTHX_ cop->cop_hints_hash);
538 Perl_op_null(pTHX_ OP *o)
541 if (o->op_type == OP_NULL)
545 o->op_targ = o->op_type;
546 o->op_type = OP_NULL;
547 o->op_ppaddr = PL_ppaddr[OP_NULL];
551 Perl_op_refcnt_lock(pTHX)
559 Perl_op_refcnt_unlock(pTHX)
566 /* Contextualizers */
568 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
571 Perl_linklist(pTHX_ OP *o)
578 /* establish postfix order */
579 first = cUNOPo->op_first;
582 o->op_next = LINKLIST(first);
585 if (kid->op_sibling) {
586 kid->op_next = LINKLIST(kid->op_sibling);
587 kid = kid->op_sibling;
601 Perl_scalarkids(pTHX_ OP *o)
603 if (o && o->op_flags & OPf_KIDS) {
605 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
612 S_scalarboolean(pTHX_ OP *o)
615 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
616 if (ckWARN(WARN_SYNTAX)) {
617 const line_t oldline = CopLINE(PL_curcop);
619 if (PL_copline != NOLINE)
620 CopLINE_set(PL_curcop, PL_copline);
621 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
622 CopLINE_set(PL_curcop, oldline);
629 Perl_scalar(pTHX_ OP *o)
634 /* assumes no premature commitment */
635 if (!o || PL_error_count || (o->op_flags & OPf_WANT)
636 || o->op_type == OP_RETURN)
641 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
643 switch (o->op_type) {
645 scalar(cBINOPo->op_first);
650 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
654 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
655 if (!kPMOP->op_pmreplroot)
656 deprecate_old("implicit split to @_");
664 if (o->op_flags & OPf_KIDS) {
665 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
671 kid = cLISTOPo->op_first;
673 while ((kid = kid->op_sibling)) {
679 PL_curcop = &PL_compiling;
684 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
690 PL_curcop = &PL_compiling;
693 if (ckWARN(WARN_VOID))
694 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
700 Perl_scalarvoid(pTHX_ OP *o)
704 const char* useless = NULL;
708 /* trailing mad null ops don't count as "there" for void processing */
710 o->op_type != OP_NULL &&
712 o->op_sibling->op_type == OP_NULL)
715 for (sib = o->op_sibling;
716 sib && sib->op_type == OP_NULL;
717 sib = sib->op_sibling) ;
723 if (o->op_type == OP_NEXTSTATE
724 || o->op_type == OP_SETSTATE
725 || o->op_type == OP_DBSTATE
726 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
727 || o->op_targ == OP_SETSTATE
728 || o->op_targ == OP_DBSTATE)))
729 PL_curcop = (COP*)o; /* for warning below */
731 /* assumes no premature commitment */
732 want = o->op_flags & OPf_WANT;
733 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
734 || o->op_type == OP_RETURN)
739 if ((o->op_private & OPpTARGET_MY)
740 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
742 return scalar(o); /* As if inside SASSIGN */
745 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
747 switch (o->op_type) {
749 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
753 if (o->op_flags & OPf_STACKED)
757 if (o->op_private == 4)
829 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
830 useless = OP_DESC(o);
834 kid = cUNOPo->op_first;
835 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
836 kid->op_type != OP_TRANS) {
839 useless = "negative pattern binding (!~)";
846 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
847 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
848 useless = "a variable";
853 if (cSVOPo->op_private & OPpCONST_STRICT)
854 no_bareword_allowed(o);
856 if (ckWARN(WARN_VOID)) {
857 useless = "a constant";
858 if (o->op_private & OPpCONST_ARYBASE)
860 /* don't warn on optimised away booleans, eg
861 * use constant Foo, 5; Foo || print; */
862 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
864 /* the constants 0 and 1 are permitted as they are
865 conventionally used as dummies in constructs like
866 1 while some_condition_with_side_effects; */
867 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
869 else if (SvPOK(sv)) {
870 /* perl4's way of mixing documentation and code
871 (before the invention of POD) was based on a
872 trick to mix nroff and perl code. The trick was
873 built upon these three nroff macros being used in
874 void context. The pink camel has the details in
875 the script wrapman near page 319. */
876 const char * const maybe_macro = SvPVX_const(sv);
877 if (strnEQ(maybe_macro, "di", 2) ||
878 strnEQ(maybe_macro, "ds", 2) ||
879 strnEQ(maybe_macro, "ig", 2))
884 op_null(o); /* don't execute or even remember it */
888 o->op_type = OP_PREINC; /* pre-increment is faster */
889 o->op_ppaddr = PL_ppaddr[OP_PREINC];
893 o->op_type = OP_PREDEC; /* pre-decrement is faster */
894 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
898 o->op_type = OP_I_PREINC; /* pre-increment is faster */
899 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
903 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
904 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
913 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
918 if (o->op_flags & OPf_STACKED)
925 if (!(o->op_flags & OPf_KIDS))
936 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
943 /* all requires must return a boolean value */
944 o->op_flags &= ~OPf_WANT;
949 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
950 if (!kPMOP->op_pmreplroot)
951 deprecate_old("implicit split to @_");
955 if (useless && ckWARN(WARN_VOID))
956 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
961 Perl_listkids(pTHX_ OP *o)
963 if (o && o->op_flags & OPf_KIDS) {
965 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
972 Perl_list(pTHX_ OP *o)
977 /* assumes no premature commitment */
978 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
979 || o->op_type == OP_RETURN)
984 if ((o->op_private & OPpTARGET_MY)
985 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
987 return o; /* As if inside SASSIGN */
990 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
992 switch (o->op_type) {
995 list(cBINOPo->op_first);
1000 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1008 if (!(o->op_flags & OPf_KIDS))
1010 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1011 list(cBINOPo->op_first);
1012 return gen_constant_list(o);
1019 kid = cLISTOPo->op_first;
1021 while ((kid = kid->op_sibling)) {
1022 if (kid->op_sibling)
1027 PL_curcop = &PL_compiling;
1031 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1032 if (kid->op_sibling)
1037 PL_curcop = &PL_compiling;
1040 /* all requires must return a boolean value */
1041 o->op_flags &= ~OPf_WANT;
1048 Perl_scalarseq(pTHX_ OP *o)
1052 const OPCODE type = o->op_type;
1054 if (type == OP_LINESEQ || type == OP_SCOPE ||
1055 type == OP_LEAVE || type == OP_LEAVETRY)
1058 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1059 if (kid->op_sibling) {
1063 PL_curcop = &PL_compiling;
1065 o->op_flags &= ~OPf_PARENS;
1066 if (PL_hints & HINT_BLOCK_SCOPE)
1067 o->op_flags |= OPf_PARENS;
1070 o = newOP(OP_STUB, 0);
1075 S_modkids(pTHX_ OP *o, I32 type)
1077 if (o && o->op_flags & OPf_KIDS) {
1079 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1085 /* Propagate lvalue ("modifiable") context to an op and its children.
1086 * 'type' represents the context type, roughly based on the type of op that
1087 * would do the modifying, although local() is represented by OP_NULL.
1088 * It's responsible for detecting things that can't be modified, flag
1089 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
1090 * might have to vivify a reference in $x), and so on.
1092 * For example, "$a+1 = 2" would cause mod() to be called with o being
1093 * OP_ADD and type being OP_SASSIGN, and would output an error.
1097 Perl_mod(pTHX_ OP *o, I32 type)
1101 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1104 if (!o || PL_error_count)
1107 if ((o->op_private & OPpTARGET_MY)
1108 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1113 switch (o->op_type) {
1119 if (!(o->op_private & OPpCONST_ARYBASE))
1122 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1123 CopARYBASE_set(&PL_compiling,
1124 (I32)SvIV(cSVOPx(PL_eval_start)->op_sv));
1128 SAVECOPARYBASE(&PL_compiling);
1129 CopARYBASE_set(&PL_compiling, 0);
1131 else if (type == OP_REFGEN)
1134 Perl_croak(aTHX_ "That use of $[ is unsupported");
1137 if (o->op_flags & OPf_PARENS || PL_madskills)
1141 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1142 !(o->op_flags & OPf_STACKED)) {
1143 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1144 /* The default is to set op_private to the number of children,
1145 which for a UNOP such as RV2CV is always 1. And w're using
1146 the bit for a flag in RV2CV, so we need it clear. */
1147 o->op_private &= ~1;
1148 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1149 assert(cUNOPo->op_first->op_type == OP_NULL);
1150 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1153 else if (o->op_private & OPpENTERSUB_NOMOD)
1155 else { /* lvalue subroutine call */
1156 o->op_private |= OPpLVAL_INTRO;
1157 PL_modcount = RETURN_UNLIMITED_NUMBER;
1158 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1159 /* Backward compatibility mode: */
1160 o->op_private |= OPpENTERSUB_INARGS;
1163 else { /* Compile-time error message: */
1164 OP *kid = cUNOPo->op_first;
1168 if (kid->op_type != OP_PUSHMARK) {
1169 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1171 "panic: unexpected lvalue entersub "
1172 "args: type/targ %ld:%"UVuf,
1173 (long)kid->op_type, (UV)kid->op_targ);
1174 kid = kLISTOP->op_first;
1176 while (kid->op_sibling)
1177 kid = kid->op_sibling;
1178 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1180 if (kid->op_type == OP_METHOD_NAMED
1181 || kid->op_type == OP_METHOD)
1185 NewOp(1101, newop, 1, UNOP);
1186 newop->op_type = OP_RV2CV;
1187 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1188 newop->op_first = NULL;
1189 newop->op_next = (OP*)newop;
1190 kid->op_sibling = (OP*)newop;
1191 newop->op_private |= OPpLVAL_INTRO;
1192 newop->op_private &= ~1;
1196 if (kid->op_type != OP_RV2CV)
1198 "panic: unexpected lvalue entersub "
1199 "entry via type/targ %ld:%"UVuf,
1200 (long)kid->op_type, (UV)kid->op_targ);
1201 kid->op_private |= OPpLVAL_INTRO;
1202 break; /* Postpone until runtime */
1206 kid = kUNOP->op_first;
1207 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1208 kid = kUNOP->op_first;
1209 if (kid->op_type == OP_NULL)
1211 "Unexpected constant lvalue entersub "
1212 "entry via type/targ %ld:%"UVuf,
1213 (long)kid->op_type, (UV)kid->op_targ);
1214 if (kid->op_type != OP_GV) {
1215 /* Restore RV2CV to check lvalueness */
1217 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1218 okid->op_next = kid->op_next;
1219 kid->op_next = okid;
1222 okid->op_next = NULL;
1223 okid->op_type = OP_RV2CV;
1225 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1226 okid->op_private |= OPpLVAL_INTRO;
1227 okid->op_private &= ~1;
1231 cv = GvCV(kGVOP_gv);
1241 /* grep, foreach, subcalls, refgen */
1242 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1244 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1245 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1247 : (o->op_type == OP_ENTERSUB
1248 ? "non-lvalue subroutine call"
1250 type ? PL_op_desc[type] : "local"));
1264 case OP_RIGHT_SHIFT:
1273 if (!(o->op_flags & OPf_STACKED))
1280 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1286 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1287 PL_modcount = RETURN_UNLIMITED_NUMBER;
1288 return o; /* Treat \(@foo) like ordinary list. */
1292 if (scalar_mod_type(o, type))
1294 ref(cUNOPo->op_first, o->op_type);
1298 if (type == OP_LEAVESUBLV)
1299 o->op_private |= OPpMAYBE_LVSUB;
1305 PL_modcount = RETURN_UNLIMITED_NUMBER;
1308 ref(cUNOPo->op_first, o->op_type);
1313 PL_hints |= HINT_BLOCK_SCOPE;
1328 PL_modcount = RETURN_UNLIMITED_NUMBER;
1329 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1330 return o; /* Treat \(@foo) like ordinary list. */
1331 if (scalar_mod_type(o, type))
1333 if (type == OP_LEAVESUBLV)
1334 o->op_private |= OPpMAYBE_LVSUB;
1338 if (!type) /* local() */
1339 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1340 PAD_COMPNAME_PV(o->op_targ));
1348 if (type != OP_SASSIGN)
1352 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1357 if (type == OP_LEAVESUBLV)
1358 o->op_private |= OPpMAYBE_LVSUB;
1360 pad_free(o->op_targ);
1361 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1362 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1363 if (o->op_flags & OPf_KIDS)
1364 mod(cBINOPo->op_first->op_sibling, type);
1369 ref(cBINOPo->op_first, o->op_type);
1370 if (type == OP_ENTERSUB &&
1371 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1372 o->op_private |= OPpLVAL_DEFER;
1373 if (type == OP_LEAVESUBLV)
1374 o->op_private |= OPpMAYBE_LVSUB;
1384 if (o->op_flags & OPf_KIDS)
1385 mod(cLISTOPo->op_last, type);
1390 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1392 else if (!(o->op_flags & OPf_KIDS))
1394 if (o->op_targ != OP_LIST) {
1395 mod(cBINOPo->op_first, type);
1401 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1406 if (type != OP_LEAVESUBLV)
1408 break; /* mod()ing was handled by ck_return() */
1411 /* [20011101.069] File test operators interpret OPf_REF to mean that
1412 their argument is a filehandle; thus \stat(".") should not set
1414 if (type == OP_REFGEN &&
1415 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1418 if (type != OP_LEAVESUBLV)
1419 o->op_flags |= OPf_MOD;
1421 if (type == OP_AASSIGN || type == OP_SASSIGN)
1422 o->op_flags |= OPf_SPECIAL|OPf_REF;
1423 else if (!type) { /* local() */
1426 o->op_private |= OPpLVAL_INTRO;
1427 o->op_flags &= ~OPf_SPECIAL;
1428 PL_hints |= HINT_BLOCK_SCOPE;
1433 if (ckWARN(WARN_SYNTAX)) {
1434 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1435 "Useless localization of %s", OP_DESC(o));
1439 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1440 && type != OP_LEAVESUBLV)
1441 o->op_flags |= OPf_REF;
1446 S_scalar_mod_type(const OP *o, I32 type)
1450 if (o->op_type == OP_RV2GV)
1474 case OP_RIGHT_SHIFT:
1493 S_is_handle_constructor(const OP *o, I32 numargs)
1495 switch (o->op_type) {
1503 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1516 Perl_refkids(pTHX_ OP *o, I32 type)
1518 if (o && o->op_flags & OPf_KIDS) {
1520 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1527 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
1532 if (!o || PL_error_count)
1535 switch (o->op_type) {
1537 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1538 !(o->op_flags & OPf_STACKED)) {
1539 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1540 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1541 assert(cUNOPo->op_first->op_type == OP_NULL);
1542 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1543 o->op_flags |= OPf_SPECIAL;
1544 o->op_private &= ~1;
1549 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1550 doref(kid, type, set_op_ref);
1553 if (type == OP_DEFINED)
1554 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1555 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1558 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1559 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1560 : type == OP_RV2HV ? OPpDEREF_HV
1562 o->op_flags |= OPf_MOD;
1567 o->op_flags |= OPf_MOD; /* XXX ??? */
1573 o->op_flags |= OPf_REF;
1576 if (type == OP_DEFINED)
1577 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1578 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1584 o->op_flags |= OPf_REF;
1589 if (!(o->op_flags & OPf_KIDS))
1591 doref(cBINOPo->op_first, type, set_op_ref);
1595 doref(cBINOPo->op_first, o->op_type, set_op_ref);
1596 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1597 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1598 : type == OP_RV2HV ? OPpDEREF_HV
1600 o->op_flags |= OPf_MOD;
1610 if (!(o->op_flags & OPf_KIDS))
1612 doref(cLISTOPo->op_last, type, set_op_ref);
1622 S_dup_attrlist(pTHX_ OP *o)
1627 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1628 * where the first kid is OP_PUSHMARK and the remaining ones
1629 * are OP_CONST. We need to push the OP_CONST values.
1631 if (o->op_type == OP_CONST)
1632 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
1634 else if (o->op_type == OP_NULL)
1638 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1640 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1641 if (o->op_type == OP_CONST)
1642 rop = append_elem(OP_LIST, rop,
1643 newSVOP(OP_CONST, o->op_flags,
1644 SvREFCNT_inc_NN(cSVOPo->op_sv)));
1651 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1656 /* fake up C<use attributes $pkg,$rv,@attrs> */
1657 ENTER; /* need to protect against side-effects of 'use' */
1659 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1661 #define ATTRSMODULE "attributes"
1662 #define ATTRSMODULE_PM "attributes.pm"
1665 /* Don't force the C<use> if we don't need it. */
1666 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
1667 if (svp && *svp != &PL_sv_undef)
1668 NOOP; /* already in %INC */
1670 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1671 newSVpvs(ATTRSMODULE), NULL);
1674 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1675 newSVpvs(ATTRSMODULE),
1677 prepend_elem(OP_LIST,
1678 newSVOP(OP_CONST, 0, stashsv),
1679 prepend_elem(OP_LIST,
1680 newSVOP(OP_CONST, 0,
1682 dup_attrlist(attrs))));
1688 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1691 OP *pack, *imop, *arg;
1697 assert(target->op_type == OP_PADSV ||
1698 target->op_type == OP_PADHV ||
1699 target->op_type == OP_PADAV);
1701 /* Ensure that attributes.pm is loaded. */
1702 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1704 /* Need package name for method call. */
1705 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
1707 /* Build up the real arg-list. */
1708 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1710 arg = newOP(OP_PADSV, 0);
1711 arg->op_targ = target->op_targ;
1712 arg = prepend_elem(OP_LIST,
1713 newSVOP(OP_CONST, 0, stashsv),
1714 prepend_elem(OP_LIST,
1715 newUNOP(OP_REFGEN, 0,
1716 mod(arg, OP_REFGEN)),
1717 dup_attrlist(attrs)));
1719 /* Fake up a method call to import */
1720 meth = newSVpvs_share("import");
1721 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1722 append_elem(OP_LIST,
1723 prepend_elem(OP_LIST, pack, list(arg)),
1724 newSVOP(OP_METHOD_NAMED, 0, meth)));
1725 imop->op_private |= OPpENTERSUB_NOMOD;
1727 /* Combine the ops. */
1728 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1732 =notfor apidoc apply_attrs_string
1734 Attempts to apply a list of attributes specified by the C<attrstr> and
1735 C<len> arguments to the subroutine identified by the C<cv> argument which
1736 is expected to be associated with the package identified by the C<stashpv>
1737 argument (see L<attributes>). It gets this wrong, though, in that it
1738 does not correctly identify the boundaries of the individual attribute
1739 specifications within C<attrstr>. This is not really intended for the
1740 public API, but has to be listed here for systems such as AIX which
1741 need an explicit export list for symbols. (It's called from XS code
1742 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1743 to respect attribute syntax properly would be welcome.
1749 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
1750 const char *attrstr, STRLEN len)
1755 len = strlen(attrstr);
1759 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1761 const char * const sstr = attrstr;
1762 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1763 attrs = append_elem(OP_LIST, attrs,
1764 newSVOP(OP_CONST, 0,
1765 newSVpvn(sstr, attrstr-sstr)));
1769 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1770 newSVpvs(ATTRSMODULE),
1771 NULL, prepend_elem(OP_LIST,
1772 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1773 prepend_elem(OP_LIST,
1774 newSVOP(OP_CONST, 0,
1780 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
1785 if (!o || PL_error_count)
1789 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
1790 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
1794 if (type == OP_LIST) {
1796 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1797 my_kid(kid, attrs, imopsp);
1798 } else if (type == OP_UNDEF
1804 } else if (type == OP_RV2SV || /* "our" declaration */
1806 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1807 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1808 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1810 PL_in_my == KEY_our ? "our" : PL_in_my == KEY_state ? "state" : "my"));
1812 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
1814 PL_in_my_stash = NULL;
1815 apply_attrs(GvSTASH(gv),
1816 (type == OP_RV2SV ? GvSV(gv) :
1817 type == OP_RV2AV ? (SV*)GvAV(gv) :
1818 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1821 o->op_private |= OPpOUR_INTRO;
1824 else if (type != OP_PADSV &&
1827 type != OP_PUSHMARK)
1829 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1831 PL_in_my == KEY_our ? "our" : PL_in_my == KEY_state ? "state" : "my"));
1834 else if (attrs && type != OP_PUSHMARK) {
1838 PL_in_my_stash = NULL;
1840 /* check for C<my Dog $spot> when deciding package */
1841 stash = PAD_COMPNAME_TYPE(o->op_targ);
1843 stash = PL_curstash;
1844 apply_attrs_my(stash, o, attrs, imopsp);
1846 o->op_flags |= OPf_MOD;
1847 o->op_private |= OPpLVAL_INTRO;
1848 if (PL_in_my == KEY_state)
1849 o->op_private |= OPpPAD_STATE;
1854 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1858 int maybe_scalar = 0;
1860 /* [perl #17376]: this appears to be premature, and results in code such as
1861 C< our(%x); > executing in list mode rather than void mode */
1863 if (o->op_flags & OPf_PARENS)
1873 o = my_kid(o, attrs, &rops);
1875 if (maybe_scalar && o->op_type == OP_PADSV) {
1876 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
1877 o->op_private |= OPpLVAL_INTRO;
1880 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
1883 PL_in_my_stash = NULL;
1888 Perl_my(pTHX_ OP *o)
1890 return my_attrs(o, NULL);
1894 Perl_sawparens(pTHX_ OP *o)
1896 PERL_UNUSED_CONTEXT;
1898 o->op_flags |= OPf_PARENS;
1903 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
1907 const OPCODE ltype = left->op_type;
1908 const OPCODE rtype = right->op_type;
1910 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
1911 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
1913 const char * const desc
1914 = PL_op_desc[(rtype == OP_SUBST || rtype == OP_TRANS)
1915 ? (int)rtype : OP_MATCH];
1916 const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV)
1917 ? "@array" : "%hash");
1918 Perl_warner(aTHX_ packWARN(WARN_MISC),
1919 "Applying %s to %s will act on scalar(%s)",
1920 desc, sample, sample);
1923 if (rtype == OP_CONST &&
1924 cSVOPx(right)->op_private & OPpCONST_BARE &&
1925 cSVOPx(right)->op_private & OPpCONST_STRICT)
1927 no_bareword_allowed(right);
1930 ismatchop = rtype == OP_MATCH ||
1931 rtype == OP_SUBST ||
1933 if (ismatchop && right->op_private & OPpTARGET_MY) {
1935 right->op_private &= ~OPpTARGET_MY;
1937 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
1940 right->op_flags |= OPf_STACKED;
1941 if (rtype != OP_MATCH &&
1942 ! (rtype == OP_TRANS &&
1943 right->op_private & OPpTRANS_IDENTICAL))
1944 newleft = mod(left, rtype);
1947 if (right->op_type == OP_TRANS)
1948 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
1950 o = prepend_elem(rtype, scalar(newleft), right);
1952 return newUNOP(OP_NOT, 0, scalar(o));
1956 return bind_match(type, left,
1957 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
1961 Perl_invert(pTHX_ OP *o)
1965 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
1969 Perl_scope(pTHX_ OP *o)
1973 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
1974 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
1975 o->op_type = OP_LEAVE;
1976 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
1978 else if (o->op_type == OP_LINESEQ) {
1980 o->op_type = OP_SCOPE;
1981 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
1982 kid = ((LISTOP*)o)->op_first;
1983 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
1986 /* The following deals with things like 'do {1 for 1}' */
1987 kid = kid->op_sibling;
1989 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
1994 o = newLISTOP(OP_SCOPE, 0, o, NULL);
2000 Perl_block_start(pTHX_ int full)
2003 const int retval = PL_savestack_ix;
2004 pad_block_start(full);
2006 PL_hints &= ~HINT_BLOCK_SCOPE;
2007 SAVECOMPILEWARNINGS();
2008 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
2013 Perl_block_end(pTHX_ I32 floor, OP *seq)
2016 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2017 OP* const retval = scalarseq(seq);
2019 CopHINTS_set(&PL_compiling, PL_hints);
2021 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2030 const PADOFFSET offset = pad_findmy("$_");
2031 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
2032 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2035 OP * const o = newOP(OP_PADSV, 0);
2036 o->op_targ = offset;
2042 Perl_newPROG(pTHX_ OP *o)
2048 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2049 ((PL_in_eval & EVAL_KEEPERR)
2050 ? OPf_SPECIAL : 0), o);
2051 PL_eval_start = linklist(PL_eval_root);
2052 PL_eval_root->op_private |= OPpREFCOUNTED;
2053 OpREFCNT_set(PL_eval_root, 1);
2054 PL_eval_root->op_next = 0;
2055 CALL_PEEP(PL_eval_start);
2058 if (o->op_type == OP_STUB) {
2059 PL_comppad_name = 0;
2061 S_op_destroy(aTHX_ o);
2064 PL_main_root = scope(sawparens(scalarvoid(o)));
2065 PL_curcop = &PL_compiling;
2066 PL_main_start = LINKLIST(PL_main_root);
2067 PL_main_root->op_private |= OPpREFCOUNTED;
2068 OpREFCNT_set(PL_main_root, 1);
2069 PL_main_root->op_next = 0;
2070 CALL_PEEP(PL_main_start);
2073 /* Register with debugger */
2075 CV * const cv = get_cv("DB::postponed", FALSE);
2079 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2081 call_sv((SV*)cv, G_DISCARD);
2088 Perl_localize(pTHX_ OP *o, I32 lex)
2091 if (o->op_flags & OPf_PARENS)
2092 /* [perl #17376]: this appears to be premature, and results in code such as
2093 C< our(%x); > executing in list mode rather than void mode */
2100 if ( PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ','
2101 && ckWARN(WARN_PARENTHESIS))
2103 char *s = PL_bufptr;
2106 /* some heuristics to detect a potential error */
2107 while (*s && (strchr(", \t\n", *s)))
2111 if (*s && strchr("@$%*", *s) && *++s
2112 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2115 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2117 while (*s && (strchr(", \t\n", *s)))
2123 if (sigil && (*s == ';' || *s == '=')) {
2124 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2125 "Parentheses missing around \"%s\" list",
2126 lex ? (PL_in_my == KEY_our ? "our" : PL_in_my == KEY_state ? "state" : "my")
2134 o = mod(o, OP_NULL); /* a bit kludgey */
2136 PL_in_my_stash = NULL;
2141 Perl_jmaybe(pTHX_ OP *o)
2143 if (o->op_type == OP_LIST) {
2145 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2146 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2152 Perl_fold_constants(pTHX_ register OP *o)
2157 VOL I32 type = o->op_type;
2162 SV * const oldwarnhook = PL_warnhook;
2163 SV * const olddiehook = PL_diehook;
2166 if (PL_opargs[type] & OA_RETSCALAR)
2168 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2169 o->op_targ = pad_alloc(type, SVs_PADTMP);
2171 /* integerize op, unless it happens to be C<-foo>.
2172 * XXX should pp_i_negate() do magic string negation instead? */
2173 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2174 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2175 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2177 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2180 if (!(PL_opargs[type] & OA_FOLDCONST))
2185 /* XXX might want a ck_negate() for this */
2186 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2197 /* XXX what about the numeric ops? */
2198 if (PL_hints & HINT_LOCALE)
2203 goto nope; /* Don't try to run w/ errors */
2205 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2206 const OPCODE type = curop->op_type;
2207 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2209 type != OP_SCALAR &&
2211 type != OP_PUSHMARK)
2217 curop = LINKLIST(o);
2218 old_next = o->op_next;
2222 oldscope = PL_scopestack_ix;
2223 create_eval_scope(G_FAKINGEVAL);
2225 PL_warnhook = PERL_WARNHOOK_FATAL;
2232 sv = *(PL_stack_sp--);
2233 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2234 pad_swipe(o->op_targ, FALSE);
2235 else if (SvTEMP(sv)) { /* grab mortal temp? */
2236 SvREFCNT_inc_simple_void(sv);
2241 /* Something tried to die. Abandon constant folding. */
2242 /* Pretend the error never happened. */
2243 sv_setpvn(ERRSV,"",0);
2244 o->op_next = old_next;
2248 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
2249 PL_warnhook = oldwarnhook;
2250 PL_diehook = olddiehook;
2251 /* XXX note that this croak may fail as we've already blown away
2252 * the stack - eg any nested evals */
2253 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
2256 PL_warnhook = oldwarnhook;
2257 PL_diehook = olddiehook;
2259 if (PL_scopestack_ix > oldscope)
2260 delete_eval_scope();
2269 if (type == OP_RV2GV)
2270 newop = newGVOP(OP_GV, 0, (GV*)sv);
2272 newop = newSVOP(OP_CONST, 0, (SV*)sv);
2273 op_getmad(o,newop,'f');
2281 Perl_gen_constant_list(pTHX_ register OP *o)
2285 const I32 oldtmps_floor = PL_tmps_floor;
2289 return o; /* Don't attempt to run with errors */
2291 PL_op = curop = LINKLIST(o);
2297 assert (!(curop->op_flags & OPf_SPECIAL));
2298 assert(curop->op_type == OP_RANGE);
2300 PL_tmps_floor = oldtmps_floor;
2302 o->op_type = OP_RV2AV;
2303 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2304 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2305 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2306 o->op_opt = 0; /* needs to be revisited in peep() */
2307 curop = ((UNOP*)o)->op_first;
2308 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
2310 op_getmad(curop,o,'O');
2319 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2322 if (!o || o->op_type != OP_LIST)
2323 o = newLISTOP(OP_LIST, 0, o, NULL);
2325 o->op_flags &= ~OPf_WANT;
2327 if (!(PL_opargs[type] & OA_MARK))
2328 op_null(cLISTOPo->op_first);
2330 o->op_type = (OPCODE)type;
2331 o->op_ppaddr = PL_ppaddr[type];
2332 o->op_flags |= flags;
2334 o = CHECKOP(type, o);
2335 if (o->op_type != (unsigned)type)
2338 return fold_constants(o);
2341 /* List constructors */
2344 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2352 if (first->op_type != (unsigned)type
2353 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2355 return newLISTOP(type, 0, first, last);
2358 if (first->op_flags & OPf_KIDS)
2359 ((LISTOP*)first)->op_last->op_sibling = last;
2361 first->op_flags |= OPf_KIDS;
2362 ((LISTOP*)first)->op_first = last;
2364 ((LISTOP*)first)->op_last = last;
2369 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2377 if (first->op_type != (unsigned)type)
2378 return prepend_elem(type, (OP*)first, (OP*)last);
2380 if (last->op_type != (unsigned)type)
2381 return append_elem(type, (OP*)first, (OP*)last);
2383 first->op_last->op_sibling = last->op_first;
2384 first->op_last = last->op_last;
2385 first->op_flags |= (last->op_flags & OPf_KIDS);
2388 if (last->op_first && first->op_madprop) {
2389 MADPROP *mp = last->op_first->op_madprop;
2391 while (mp->mad_next)
2393 mp->mad_next = first->op_madprop;
2396 last->op_first->op_madprop = first->op_madprop;
2399 first->op_madprop = last->op_madprop;
2400 last->op_madprop = 0;
2403 S_op_destroy(aTHX_ (OP*)last);
2409 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2417 if (last->op_type == (unsigned)type) {
2418 if (type == OP_LIST) { /* already a PUSHMARK there */
2419 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2420 ((LISTOP*)last)->op_first->op_sibling = first;
2421 if (!(first->op_flags & OPf_PARENS))
2422 last->op_flags &= ~OPf_PARENS;
2425 if (!(last->op_flags & OPf_KIDS)) {
2426 ((LISTOP*)last)->op_last = first;
2427 last->op_flags |= OPf_KIDS;
2429 first->op_sibling = ((LISTOP*)last)->op_first;
2430 ((LISTOP*)last)->op_first = first;
2432 last->op_flags |= OPf_KIDS;
2436 return newLISTOP(type, 0, first, last);
2444 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2447 Newxz(tk, 1, TOKEN);
2448 tk->tk_type = (OPCODE)optype;
2449 tk->tk_type = 12345;
2451 tk->tk_mad = madprop;
2456 Perl_token_free(pTHX_ TOKEN* tk)
2458 if (tk->tk_type != 12345)
2460 mad_free(tk->tk_mad);
2465 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2469 if (tk->tk_type != 12345) {
2470 Perl_warner(aTHX_ packWARN(WARN_MISC),
2471 "Invalid TOKEN object ignored");
2478 /* faked up qw list? */
2480 tm->mad_type == MAD_SV &&
2481 SvPVX((SV*)tm->mad_val)[0] == 'q')
2488 /* pretend constant fold didn't happen? */
2489 if (mp->mad_key == 'f' &&
2490 (o->op_type == OP_CONST ||
2491 o->op_type == OP_GV) )
2493 token_getmad(tk,(OP*)mp->mad_val,slot);
2507 if (mp->mad_key == 'X')
2508 mp->mad_key = slot; /* just change the first one */
2518 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
2527 /* pretend constant fold didn't happen? */
2528 if (mp->mad_key == 'f' &&
2529 (o->op_type == OP_CONST ||
2530 o->op_type == OP_GV) )
2532 op_getmad(from,(OP*)mp->mad_val,slot);
2539 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
2542 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
2548 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
2557 /* pretend constant fold didn't happen? */
2558 if (mp->mad_key == 'f' &&
2559 (o->op_type == OP_CONST ||
2560 o->op_type == OP_GV) )
2562 op_getmad(from,(OP*)mp->mad_val,slot);
2569 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
2572 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
2576 PerlIO_printf(PerlIO_stderr(),
2577 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
2583 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
2601 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
2605 addmad(tm, &(o->op_madprop), slot);
2609 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
2630 Perl_newMADsv(pTHX_ char key, SV* sv)
2632 return newMADPROP(key, MAD_SV, sv, 0);
2636 Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
2639 Newxz(mp, 1, MADPROP);
2642 mp->mad_vlen = vlen;
2643 mp->mad_type = type;
2645 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
2650 Perl_mad_free(pTHX_ MADPROP* mp)
2652 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
2656 mad_free(mp->mad_next);
2657 /* if (PL_lex_state != LEX_NOTPARSING && mp->mad_vlen)
2658 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
2659 switch (mp->mad_type) {
2663 Safefree((char*)mp->mad_val);
2666 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
2667 op_free((OP*)mp->mad_val);
2670 sv_free((SV*)mp->mad_val);
2673 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
2682 Perl_newNULLLIST(pTHX)
2684 return newOP(OP_STUB, 0);
2688 Perl_force_list(pTHX_ OP *o)
2690 if (!o || o->op_type != OP_LIST)
2691 o = newLISTOP(OP_LIST, 0, o, NULL);
2697 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2702 NewOp(1101, listop, 1, LISTOP);
2704 listop->op_type = (OPCODE)type;
2705 listop->op_ppaddr = PL_ppaddr[type];
2708 listop->op_flags = (U8)flags;
2712 else if (!first && last)
2715 first->op_sibling = last;
2716 listop->op_first = first;
2717 listop->op_last = last;
2718 if (type == OP_LIST) {
2719 OP* const pushop = newOP(OP_PUSHMARK, 0);
2720 pushop->op_sibling = first;
2721 listop->op_first = pushop;
2722 listop->op_flags |= OPf_KIDS;
2724 listop->op_last = pushop;
2727 return CHECKOP(type, listop);
2731 Perl_newOP(pTHX_ I32 type, I32 flags)
2735 NewOp(1101, o, 1, OP);
2736 o->op_type = (OPCODE)type;
2737 o->op_ppaddr = PL_ppaddr[type];
2738 o->op_flags = (U8)flags;
2740 o->op_latefreed = 0;
2743 o->op_private = (U8)(0 | (flags >> 8));
2744 if (PL_opargs[type] & OA_RETSCALAR)
2746 if (PL_opargs[type] & OA_TARGET)
2747 o->op_targ = pad_alloc(type, SVs_PADTMP);
2748 return CHECKOP(type, o);
2752 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2758 first = newOP(OP_STUB, 0);
2759 if (PL_opargs[type] & OA_MARK)
2760 first = force_list(first);
2762 NewOp(1101, unop, 1, UNOP);
2763 unop->op_type = (OPCODE)type;
2764 unop->op_ppaddr = PL_ppaddr[type];
2765 unop->op_first = first;
2766 unop->op_flags = (U8)(flags | OPf_KIDS);
2767 unop->op_private = (U8)(1 | (flags >> 8));
2768 unop = (UNOP*) CHECKOP(type, unop);
2772 return fold_constants((OP *) unop);
2776 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2780 NewOp(1101, binop, 1, BINOP);
2783 first = newOP(OP_NULL, 0);
2785 binop->op_type = (OPCODE)type;
2786 binop->op_ppaddr = PL_ppaddr[type];
2787 binop->op_first = first;
2788 binop->op_flags = (U8)(flags | OPf_KIDS);
2791 binop->op_private = (U8)(1 | (flags >> 8));
2794 binop->op_private = (U8)(2 | (flags >> 8));
2795 first->op_sibling = last;
2798 binop = (BINOP*)CHECKOP(type, binop);
2799 if (binop->op_next || binop->op_type != (OPCODE)type)
2802 binop->op_last = binop->op_first->op_sibling;
2804 return fold_constants((OP *)binop);
2807 static int uvcompare(const void *a, const void *b)
2808 __attribute__nonnull__(1)
2809 __attribute__nonnull__(2)
2810 __attribute__pure__;
2811 static int uvcompare(const void *a, const void *b)
2813 if (*((const UV *)a) < (*(const UV *)b))
2815 if (*((const UV *)a) > (*(const UV *)b))
2817 if (*((const UV *)a+1) < (*(const UV *)b+1))
2819 if (*((const UV *)a+1) > (*(const UV *)b+1))
2825 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2828 SV * const tstr = ((SVOP*)expr)->op_sv;
2831 (repl->op_type == OP_NULL)
2832 ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
2834 ((SVOP*)repl)->op_sv;
2837 const U8 *t = (U8*)SvPV_const(tstr, tlen);
2838 const U8 *r = (U8*)SvPV_const(rstr, rlen);
2842 register short *tbl;
2844 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
2845 const I32 squash = o->op_private & OPpTRANS_SQUASH;
2846 I32 del = o->op_private & OPpTRANS_DELETE;
2847 PL_hints |= HINT_BLOCK_SCOPE;
2850 o->op_private |= OPpTRANS_FROM_UTF;
2853 o->op_private |= OPpTRANS_TO_UTF;
2855 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2856 SV* const listsv = newSVpvs("# comment\n");
2858 const U8* tend = t + tlen;
2859 const U8* rend = r + rlen;
2873 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2874 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2877 const U32 flags = UTF8_ALLOW_DEFAULT;
2881 t = tsave = bytes_to_utf8(t, &len);
2884 if (!to_utf && rlen) {
2886 r = rsave = bytes_to_utf8(r, &len);
2890 /* There are several snags with this code on EBCDIC:
2891 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2892 2. scan_const() in toke.c has encoded chars in native encoding which makes
2893 ranges at least in EBCDIC 0..255 range the bottom odd.
2897 U8 tmpbuf[UTF8_MAXBYTES+1];
2900 Newx(cp, 2*tlen, UV);
2902 transv = newSVpvs("");
2904 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
2906 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2908 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
2912 cp[2*i+1] = cp[2*i];
2916 qsort(cp, i, 2*sizeof(UV), uvcompare);
2917 for (j = 0; j < i; j++) {
2919 diff = val - nextmin;
2921 t = uvuni_to_utf8(tmpbuf,nextmin);
2922 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2924 U8 range_mark = UTF_TO_NATIVE(0xff);
2925 t = uvuni_to_utf8(tmpbuf, val - 1);
2926 sv_catpvn(transv, (char *)&range_mark, 1);
2927 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2934 t = uvuni_to_utf8(tmpbuf,nextmin);
2935 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2937 U8 range_mark = UTF_TO_NATIVE(0xff);
2938 sv_catpvn(transv, (char *)&range_mark, 1);
2940 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2941 UNICODE_ALLOW_SUPER);
2942 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2943 t = (const U8*)SvPVX_const(transv);
2944 tlen = SvCUR(transv);
2948 else if (!rlen && !del) {
2949 r = t; rlen = tlen; rend = tend;
2952 if ((!rlen && !del) || t == r ||
2953 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2955 o->op_private |= OPpTRANS_IDENTICAL;
2959 while (t < tend || tfirst <= tlast) {
2960 /* see if we need more "t" chars */
2961 if (tfirst > tlast) {
2962 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
2964 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2966 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
2973 /* now see if we need more "r" chars */
2974 if (rfirst > rlast) {
2976 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
2978 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2980 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
2989 rfirst = rlast = 0xffffffff;
2993 /* now see which range will peter our first, if either. */
2994 tdiff = tlast - tfirst;
2995 rdiff = rlast - rfirst;
3002 if (rfirst == 0xffffffff) {
3003 diff = tdiff; /* oops, pretend rdiff is infinite */
3005 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
3006 (long)tfirst, (long)tlast);
3008 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
3012 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
3013 (long)tfirst, (long)(tfirst + diff),
3016 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3017 (long)tfirst, (long)rfirst);
3019 if (rfirst + diff > max)
3020 max = rfirst + diff;
3022 grows = (tfirst < rfirst &&
3023 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3035 else if (max > 0xff)
3040 Safefree(cPVOPo->op_pv);
3041 cPVOPo->op_pv = NULL;
3042 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
3043 SvREFCNT_dec(listsv);
3044 SvREFCNT_dec(transv);
3046 if (!del && havefinal && rlen)
3047 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
3048 newSVuv((UV)final), 0);
3051 o->op_private |= OPpTRANS_GROWS;
3057 op_getmad(expr,o,'e');
3058 op_getmad(repl,o,'r');
3066 tbl = (short*)cPVOPo->op_pv;
3068 Zero(tbl, 256, short);
3069 for (i = 0; i < (I32)tlen; i++)
3071 for (i = 0, j = 0; i < 256; i++) {
3073 if (j >= (I32)rlen) {
3082 if (i < 128 && r[j] >= 128)
3092 o->op_private |= OPpTRANS_IDENTICAL;
3094 else if (j >= (I32)rlen)
3097 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
3098 tbl[0x100] = (short)(rlen - j);
3099 for (i=0; i < (I32)rlen - j; i++)
3100 tbl[0x101+i] = r[j+i];
3104 if (!rlen && !del) {
3107 o->op_private |= OPpTRANS_IDENTICAL;
3109 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3110 o->op_private |= OPpTRANS_IDENTICAL;
3112 for (i = 0; i < 256; i++)
3114 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3115 if (j >= (I32)rlen) {
3117 if (tbl[t[i]] == -1)
3123 if (tbl[t[i]] == -1) {
3124 if (t[i] < 128 && r[j] >= 128)
3131 o->op_private |= OPpTRANS_GROWS;
3133 op_getmad(expr,o,'e');
3134 op_getmad(repl,o,'r');
3144 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3149 NewOp(1101, pmop, 1, PMOP);
3150 pmop->op_type = (OPCODE)type;
3151 pmop->op_ppaddr = PL_ppaddr[type];
3152 pmop->op_flags = (U8)flags;
3153 pmop->op_private = (U8)(0 | (flags >> 8));
3155 if (PL_hints & HINT_RE_TAINT)
3156 pmop->op_pmpermflags |= PMf_RETAINT;
3157 if (PL_hints & HINT_LOCALE)
3158 pmop->op_pmpermflags |= PMf_LOCALE;
3159 pmop->op_pmflags = pmop->op_pmpermflags;
3162 if (av_len((AV*) PL_regex_pad[0]) > -1) {
3163 SV * const repointer = av_pop((AV*)PL_regex_pad[0]);
3164 pmop->op_pmoffset = SvIV(repointer);
3165 SvREPADTMP_off(repointer);
3166 sv_setiv(repointer,0);
3168 SV * const repointer = newSViv(0);
3169 av_push(PL_regex_padav, SvREFCNT_inc_simple_NN(repointer));
3170 pmop->op_pmoffset = av_len(PL_regex_padav);
3171 PL_regex_pad = AvARRAY(PL_regex_padav);
3175 /* link into pm list */
3176 if (type != OP_TRANS && PL_curstash) {
3177 MAGIC *mg = mg_find((SV*)PL_curstash, PERL_MAGIC_symtab);
3180 mg = sv_magicext((SV*)PL_curstash, 0, PERL_MAGIC_symtab, 0, 0, 0);
3182 pmop->op_pmnext = (PMOP*)mg->mg_obj;
3183 mg->mg_obj = (SV*)pmop;
3184 PmopSTASH_set(pmop,PL_curstash);
3187 return CHECKOP(type, pmop);
3190 /* Given some sort of match op o, and an expression expr containing a
3191 * pattern, either compile expr into a regex and attach it to o (if it's
3192 * constant), or convert expr into a runtime regcomp op sequence (if it's
3195 * isreg indicates that the pattern is part of a regex construct, eg
3196 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3197 * split "pattern", which aren't. In the former case, expr will be a list
3198 * if the pattern contains more than one term (eg /a$b/) or if it contains
3199 * a replacement, ie s/// or tr///.
3203 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
3208 I32 repl_has_vars = 0;
3212 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
3213 /* last element in list is the replacement; pop it */
3215 repl = cLISTOPx(expr)->op_last;
3216 kid = cLISTOPx(expr)->op_first;
3217 while (kid->op_sibling != repl)
3218 kid = kid->op_sibling;
3219 kid->op_sibling = NULL;
3220 cLISTOPx(expr)->op_last = kid;
3223 if (isreg && expr->op_type == OP_LIST &&
3224 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3226 /* convert single element list to element */
3227 OP* const oe = expr;
3228 expr = cLISTOPx(oe)->op_first->op_sibling;
3229 cLISTOPx(oe)->op_first->op_sibling = NULL;
3230 cLISTOPx(oe)->op_last = NULL;
3234 if (o->op_type == OP_TRANS) {
3235 return pmtrans(o, expr, repl);
3238 reglist = isreg && expr->op_type == OP_LIST;
3242 PL_hints |= HINT_BLOCK_SCOPE;
3245 if (expr->op_type == OP_CONST) {
3247 SV * const pat = ((SVOP*)expr)->op_sv;
3248 const char *p = SvPV_const(pat, plen);
3249 if ((o->op_flags & OPf_SPECIAL) && (*p == ' ' && p[1] == '\0')) {
3250 U32 was_readonly = SvREADONLY(pat);
3254 sv_force_normal_flags(pat, 0);
3255 assert(!SvREADONLY(pat));
3258 SvREADONLY_off(pat);
3262 sv_setpvn(pat, "\\s+", 3);
3264 SvFLAGS(pat) |= was_readonly;
3266 p = SvPV_const(pat, plen);
3267 pm->op_pmflags |= PMf_SKIPWHITE;
3270 pm->op_pmdynflags |= PMdf_UTF8;
3271 /* FIXME - can we make this function take const char * args? */
3272 PM_SETRE(pm, CALLREGCOMP((char*)p, (char*)p + plen, pm));
3273 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
3274 pm->op_pmflags |= PMf_WHITE;
3276 op_getmad(expr,(OP*)pm,'e');
3282 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3283 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3285 : OP_REGCMAYBE),0,expr);
3287 NewOp(1101, rcop, 1, LOGOP);
3288 rcop->op_type = OP_REGCOMP;
3289 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3290 rcop->op_first = scalar(expr);
3291 rcop->op_flags |= OPf_KIDS
3292 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3293 | (reglist ? OPf_STACKED : 0);
3294 rcop->op_private = 1;
3297 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3299 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
3302 /* establish postfix order */
3303 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3305 rcop->op_next = expr;
3306 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3309 rcop->op_next = LINKLIST(expr);
3310 expr->op_next = (OP*)rcop;
3313 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3318 if (pm->op_pmflags & PMf_EVAL) {
3320 if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
3321 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
3323 else if (repl->op_type == OP_CONST)
3327 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3328 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3329 if (curop->op_type == OP_GV) {
3330 GV * const gv = cGVOPx_gv(curop);
3332 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3335 else if (curop->op_type == OP_RV2CV)
3337 else if (curop->op_type == OP_RV2SV ||
3338 curop->op_type == OP_RV2AV ||
3339 curop->op_type == OP_RV2HV ||
3340 curop->op_type == OP_RV2GV) {
3341 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3344 else if (curop->op_type == OP_PADSV ||
3345 curop->op_type == OP_PADAV ||
3346 curop->op_type == OP_PADHV ||
3347 curop->op_type == OP_PADANY) {
3350 else if (curop->op_type == OP_PUSHRE)
3351 NOOP; /* Okay here, dangerous in newASSIGNOP */
3361 || PM_GETRE(pm)->extflags & RXf_EVAL_SEEN))) {
3362 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3363 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
3364 prepend_elem(o->op_type, scalar(repl), o);
3367 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3368 pm->op_pmflags |= PMf_MAYBE_CONST;
3369 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3371 NewOp(1101, rcop, 1, LOGOP);
3372 rcop->op_type = OP_SUBSTCONT;
3373 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3374 rcop->op_first = scalar(repl);
3375 rcop->op_flags |= OPf_KIDS;
3376 rcop->op_private = 1;
3379 /* establish postfix order */
3380 rcop->op_next = LINKLIST(repl);
3381 repl->op_next = (OP*)rcop;
3383 pm->op_pmreplroot = scalar((OP*)rcop);
3384 pm->op_pmreplstart = LINKLIST(rcop);
3393 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3397 NewOp(1101, svop, 1, SVOP);
3398 svop->op_type = (OPCODE)type;
3399 svop->op_ppaddr = PL_ppaddr[type];
3401 svop->op_next = (OP*)svop;
3402 svop->op_flags = (U8)flags;
3403 if (PL_opargs[type] & OA_RETSCALAR)
3405 if (PL_opargs[type] & OA_TARGET)
3406 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3407 return CHECKOP(type, svop);
3411 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3415 NewOp(1101, padop, 1, PADOP);
3416 padop->op_type = (OPCODE)type;
3417 padop->op_ppaddr = PL_ppaddr[type];
3418 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3419 SvREFCNT_dec(PAD_SVl(padop->op_padix));
3420 PAD_SETSV(padop->op_padix, sv);
3423 padop->op_next = (OP*)padop;
3424 padop->op_flags = (U8)flags;
3425 if (PL_opargs[type] & OA_RETSCALAR)
3427 if (PL_opargs[type] & OA_TARGET)
3428 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3429 return CHECKOP(type, padop);
3433 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3439 return newPADOP(type, flags, SvREFCNT_inc_simple(gv));
3441 return newSVOP(type, flags, SvREFCNT_inc_simple(gv));
3446 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3450 NewOp(1101, pvop, 1, PVOP);
3451 pvop->op_type = (OPCODE)type;
3452 pvop->op_ppaddr = PL_ppaddr[type];
3454 pvop->op_next = (OP*)pvop;
3455 pvop->op_flags = (U8)flags;
3456 if (PL_opargs[type] & OA_RETSCALAR)
3458 if (PL_opargs[type] & OA_TARGET)
3459 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3460 return CHECKOP(type, pvop);
3468 Perl_package(pTHX_ OP *o)
3477 save_hptr(&PL_curstash);
3478 save_item(PL_curstname);
3480 name = SvPV_const(cSVOPo->op_sv, len);
3481 PL_curstash = gv_stashpvn(name, len, TRUE);
3482 sv_setpvn(PL_curstname, name, len);
3484 PL_hints |= HINT_BLOCK_SCOPE;
3485 PL_copline = NOLINE;
3491 if (!PL_madskills) {
3496 pegop = newOP(OP_NULL,0);
3497 op_getmad(o,pegop,'P');
3507 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3514 OP *pegop = newOP(OP_NULL,0);
3517 if (idop->op_type != OP_CONST)
3518 Perl_croak(aTHX_ "Module name must be constant");
3521 op_getmad(idop,pegop,'U');
3526 SV * const vesv = ((SVOP*)version)->op_sv;
3529 op_getmad(version,pegop,'V');
3530 if (!arg && !SvNIOKp(vesv)) {
3537 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3538 Perl_croak(aTHX_ "Version number must be constant number");
3540 /* Make copy of idop so we don't free it twice */
3541 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3543 /* Fake up a method call to VERSION */
3544 meth = newSVpvs_share("VERSION");
3545 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3546 append_elem(OP_LIST,
3547 prepend_elem(OP_LIST, pack, list(version)),
3548 newSVOP(OP_METHOD_NAMED, 0, meth)));
3552 /* Fake up an import/unimport */
3553 if (arg && arg->op_type == OP_STUB) {
3555 op_getmad(arg,pegop,'S');
3556 imop = arg; /* no import on explicit () */
3558 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3559 imop = NULL; /* use 5.0; */
3561 idop->op_private |= OPpCONST_NOVER;
3567 op_getmad(arg,pegop,'A');
3569 /* Make copy of idop so we don't free it twice */
3570 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3572 /* Fake up a method call to import/unimport */
3574 ? newSVpvs_share("import") : newSVpvs_share("unimport");
3575 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3576 append_elem(OP_LIST,
3577 prepend_elem(OP_LIST, pack, list(arg)),
3578 newSVOP(OP_METHOD_NAMED, 0, meth)));
3581 /* Fake up the BEGIN {}, which does its thing immediately. */
3583 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
3586 append_elem(OP_LINESEQ,
3587 append_elem(OP_LINESEQ,
3588 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
3589 newSTATEOP(0, NULL, veop)),
3590 newSTATEOP(0, NULL, imop) ));
3592 /* The "did you use incorrect case?" warning used to be here.
3593 * The problem is that on case-insensitive filesystems one
3594 * might get false positives for "use" (and "require"):
3595 * "use Strict" or "require CARP" will work. This causes
3596 * portability problems for the script: in case-strict
3597 * filesystems the script will stop working.
3599 * The "incorrect case" warning checked whether "use Foo"
3600 * imported "Foo" to your namespace, but that is wrong, too:
3601 * there is no requirement nor promise in the language that
3602 * a Foo.pm should or would contain anything in package "Foo".
3604 * There is very little Configure-wise that can be done, either:
3605 * the case-sensitivity of the build filesystem of Perl does not
3606 * help in guessing the case-sensitivity of the runtime environment.
3609 PL_hints |= HINT_BLOCK_SCOPE;
3610 PL_copline = NOLINE;
3612 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3615 if (!PL_madskills) {
3616 /* FIXME - don't allocate pegop if !PL_madskills */
3625 =head1 Embedding Functions
3627 =for apidoc load_module
3629 Loads the module whose name is pointed to by the string part of name.
3630 Note that the actual module name, not its filename, should be given.
3631 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3632 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3633 (or 0 for no flags). ver, if specified, provides version semantics
3634 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3635 arguments can be used to specify arguments to the module's import()
3636 method, similar to C<use Foo::Bar VERSION LIST>.
3641 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3644 va_start(args, ver);
3645 vload_module(flags, name, ver, &args);
3649 #ifdef PERL_IMPLICIT_CONTEXT
3651 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3655 va_start(args, ver);
3656 vload_module(flags, name, ver, &args);
3662 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3667 OP * const modname = newSVOP(OP_CONST, 0, name);
3668 modname->op_private |= OPpCONST_BARE;
3670 veop = newSVOP(OP_CONST, 0, ver);
3674 if (flags & PERL_LOADMOD_NOIMPORT) {
3675 imop = sawparens(newNULLLIST());
3677 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3678 imop = va_arg(*args, OP*);
3683 sv = va_arg(*args, SV*);
3685 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3686 sv = va_arg(*args, SV*);
3690 const line_t ocopline = PL_copline;
3691 COP * const ocurcop = PL_curcop;
3692 const int oexpect = PL_expect;
3694 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3695 veop, modname, imop);
3696 PL_expect = oexpect;
3697 PL_copline = ocopline;
3698 PL_curcop = ocurcop;
3703 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
3709 if (!force_builtin) {
3710 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
3711 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
3712 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
3713 gv = gvp ? *gvp : NULL;
3717 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3718 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3719 append_elem(OP_LIST, term,
3720 scalar(newUNOP(OP_RV2CV, 0,
3721 newGVOP(OP_GV, 0, gv))))));
3724 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3730 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3732 return newBINOP(OP_LSLICE, flags,
3733 list(force_list(subscript)),
3734 list(force_list(listval)) );
3738 S_is_list_assignment(pTHX_ register const OP *o)
3746 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
3747 o = cUNOPo->op_first;
3749 flags = o->op_flags;
3751 if (type == OP_COND_EXPR) {
3752 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
3753 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3758 yyerror("Assignment to both a list and a scalar");
3762 if (type == OP_LIST &&
3763 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
3764 o->op_private & OPpLVAL_INTRO)
3767 if (type == OP_LIST || flags & OPf_PARENS ||
3768 type == OP_RV2AV || type == OP_RV2HV ||
3769 type == OP_ASLICE || type == OP_HSLICE)
3772 if (type == OP_PADAV || type == OP_PADHV)
3775 if (type == OP_RV2SV)
3782 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3788 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3789 return newLOGOP(optype, 0,
3790 mod(scalar(left), optype),
3791 newUNOP(OP_SASSIGN, 0, scalar(right)));
3794 return newBINOP(optype, OPf_STACKED,
3795 mod(scalar(left), optype), scalar(right));
3799 if (is_list_assignment(left)) {
3803 /* Grandfathering $[ assignment here. Bletch.*/
3804 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
3805 PL_eval_start = (left->op_type == OP_CONST) ? right : 0;
3806 left = mod(left, OP_AASSIGN);
3809 else if (left->op_type == OP_CONST) {
3811 /* Result of assignment is always 1 (or we'd be dead already) */
3812 return newSVOP(OP_CONST, 0, newSViv(1));
3814 curop = list(force_list(left));
3815 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3816 o->op_private = (U8)(0 | (flags >> 8));
3818 /* PL_generation sorcery:
3819 * an assignment like ($a,$b) = ($c,$d) is easier than
3820 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3821 * To detect whether there are common vars, the global var
3822 * PL_generation is incremented for each assign op we compile.
3823 * Then, while compiling the assign op, we run through all the
3824 * variables on both sides of the assignment, setting a spare slot
3825 * in each of them to PL_generation. If any of them already have
3826 * that value, we know we've got commonality. We could use a
3827 * single bit marker, but then we'd have to make 2 passes, first
3828 * to clear the flag, then to test and set it. To find somewhere
3829 * to store these values, evil chicanery is done with SvCUR().
3835 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3836 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3837 if (curop->op_type == OP_GV) {
3838 GV *gv = cGVOPx_gv(curop);
3840 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
3842 GvASSIGN_GENERATION_set(gv, PL_generation);
3844 else if (curop->op_type == OP_PADSV ||
3845 curop->op_type == OP_PADAV ||
3846 curop->op_type == OP_PADHV ||
3847 curop->op_type == OP_PADANY)
3849 if (PAD_COMPNAME_GEN(curop->op_targ)
3850 == (STRLEN)PL_generation)
3852 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
3855 else if (curop->op_type == OP_RV2CV)
3857 else if (curop->op_type == OP_RV2SV ||
3858 curop->op_type == OP_RV2AV ||
3859 curop->op_type == OP_RV2HV ||
3860 curop->op_type == OP_RV2GV) {
3861 if (lastop->op_type != OP_GV) /* funny deref? */
3864 else if (curop->op_type == OP_PUSHRE) {
3865 if (((PMOP*)curop)->op_pmreplroot) {
3867 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3868 ((PMOP*)curop)->op_pmreplroot));
3870 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3873 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
3875 GvASSIGN_GENERATION_set(gv, PL_generation);
3876 GvASSIGN_GENERATION_set(gv, PL_generation);
3885 o->op_private |= OPpASSIGN_COMMON;
3888 if ( ((left->op_private & OPpLVAL_INTRO) || ckWARN(WARN_MISC))
3889 && (left->op_type == OP_LIST
3890 || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
3892 OP* lop = ((LISTOP*)left)->op_first;
3894 if (lop->op_type == OP_PADSV ||
3895 lop->op_type == OP_PADAV ||
3896 lop->op_type == OP_PADHV ||
3897 lop->op_type == OP_PADANY)
3899 if (lop->op_private & OPpPAD_STATE) {
3900 if (left->op_private & OPpLVAL_INTRO) {
3901 o->op_private |= OPpASSIGN_STATE;
3902 /* hijacking PADSTALE for uninitialized state variables */
3903 SvPADSTALE_on(PAD_SVl(lop->op_targ));
3905 else { /* we already checked for WARN_MISC before */
3906 Perl_warner(aTHX_ packWARN(WARN_MISC), "State variable %s will be reinitialized",
3907 PAD_COMPNAME_PV(lop->op_targ));
3911 lop = lop->op_sibling;
3915 if (right && right->op_type == OP_SPLIT) {
3916 OP* tmpop = ((LISTOP*)right)->op_first;
3917 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
3918 PMOP * const pm = (PMOP*)tmpop;
3919 if (left->op_type == OP_RV2AV &&
3920 !(left->op_private & OPpLVAL_INTRO) &&
3921 !(o->op_private & OPpASSIGN_COMMON) )
3923 tmpop = ((UNOP*)left)->op_first;
3924 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3926 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3927 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3929 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3930 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
3932 pm->op_pmflags |= PMf_ONCE;
3933 tmpop = cUNOPo->op_first; /* to list (nulled) */
3934 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3935 tmpop->op_sibling = NULL; /* don't free split */
3936 right->op_next = tmpop->op_next; /* fix starting loc */
3938 op_getmad(o,right,'R'); /* blow off assign */
3940 op_free(o); /* blow off assign */
3942 right->op_flags &= ~OPf_WANT;
3943 /* "I don't know and I don't care." */
3948 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3949 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3951 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3953 sv_setiv(sv, PL_modcount+1);
3961 right = newOP(OP_UNDEF, 0);
3962 if (right->op_type == OP_READLINE) {
3963 right->op_flags |= OPf_STACKED;
3964 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3967 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3968 o = newBINOP(OP_SASSIGN, flags,
3969 scalar(right), mod(scalar(left), OP_SASSIGN) );
3975 o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
3976 o->op_private |= OPpCONST_ARYBASE;
3983 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3986 const U32 seq = intro_my();
3989 NewOp(1101, cop, 1, COP);
3990 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3991 cop->op_type = OP_DBSTATE;
3992 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3995 cop->op_type = OP_NEXTSTATE;
3996 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3998 cop->op_flags = (U8)flags;
3999 CopHINTS_set(cop, PL_hints);
4001 cop->op_private |= NATIVE_HINTS;
4003 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
4004 cop->op_next = (OP*)cop;
4007 cop->cop_label = label;
4008 PL_hints |= HINT_BLOCK_SCOPE;
4011 /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
4012 CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
4014 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
4015 cop->cop_hints_hash = PL_curcop->cop_hints_hash;
4016 if (cop->cop_hints_hash) {
4018 cop->cop_hints_hash->refcounted_he_refcnt++;
4019 HINTS_REFCNT_UNLOCK;
4022 if (PL_copline == NOLINE)
4023 CopLINE_set(cop, CopLINE(PL_curcop));
4025 CopLINE_set(cop, PL_copline);
4026 PL_copline = NOLINE;
4029 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
4031 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
4033 CopSTASH_set(cop, PL_curstash);
4035 if (PERLDB_LINE && PL_curstash != PL_debstash) {
4036 AV *av = CopFILEAVx(PL_curcop);
4038 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
4039 if (svp && *svp != &PL_sv_undef ) {
4040 (void)SvIOK_on(*svp);
4041 SvIV_set(*svp, PTR2IV(cop));
4046 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
4051 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
4054 return new_logop(type, flags, &first, &other);
4058 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
4063 OP *first = *firstp;
4064 OP * const other = *otherp;
4066 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
4067 return newBINOP(type, flags, scalar(first), scalar(other));
4069 scalarboolean(first);
4070 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
4071 if (first->op_type == OP_NOT
4072 && (first->op_flags & OPf_SPECIAL)
4073 && (first->op_flags & OPf_KIDS)) {
4074 if (type == OP_AND || type == OP_OR) {
4080 first = *firstp = cUNOPo->op_first;
4082 first->op_next = o->op_next;
4083 cUNOPo->op_first = NULL;
4085 op_getmad(o,first,'O');
4091 if (first->op_type == OP_CONST) {
4092 if (first->op_private & OPpCONST_STRICT)
4093 no_bareword_allowed(first);
4094 else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
4095 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
4096 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
4097 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
4098 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
4100 if (other->op_type == OP_CONST)
4101 other->op_private |= OPpCONST_SHORTCIRCUIT;
4103 OP *newop = newUNOP(OP_NULL, 0, other);
4104 op_getmad(first, newop, '1');
4105 newop->op_targ = type; /* set "was" field */
4112 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
4113 const OP *o2 = other;
4114 if ( ! (o2->op_type == OP_LIST
4115 && (( o2 = cUNOPx(o2)->op_first))
4116 && o2->op_type == OP_PUSHMARK
4117 && (( o2 = o2->op_sibling)) )
4120 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
4121 || o2->op_type == OP_PADHV)
4122 && o2->op_private & OPpLVAL_INTRO
4123 && ckWARN(WARN_DEPRECATED))
4125 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4126 "Deprecated use of my() in false conditional");
4130 if (first->op_type == OP_CONST)
4131 first->op_private |= OPpCONST_SHORTCIRCUIT;
4133 first = newUNOP(OP_NULL, 0, first);
4134 op_getmad(other, first, '2');
4135 first->op_targ = type; /* set "was" field */
4142 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
4143 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
4145 const OP * const k1 = ((UNOP*)first)->op_first;
4146 const OP * const k2 = k1->op_sibling;
4148 switch (first->op_type)
4151 if (k2 && k2->op_type == OP_READLINE
4152 && (k2->op_flags & OPf_STACKED)
4153 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4155 warnop = k2->op_type;
4160 if (k1->op_type == OP_READDIR
4161 || k1->op_type == OP_GLOB
4162 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4163 || k1->op_type == OP_EACH)
4165 warnop = ((k1->op_type == OP_NULL)
4166 ? (OPCODE)k1->op_targ : k1->op_type);
4171 const line_t oldline = CopLINE(PL_curcop);
4172 CopLINE_set(PL_curcop, PL_copline);
4173 Perl_warner(aTHX_ packWARN(WARN_MISC),
4174 "Value of %s%s can be \"0\"; test with defined()",
4176 ((warnop == OP_READLINE || warnop == OP_GLOB)
4177 ? " construct" : "() operator"));
4178 CopLINE_set(PL_curcop, oldline);
4185 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
4186 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
4188 NewOp(1101, logop, 1, LOGOP);
4190 logop->op_type = (OPCODE)type;
4191 logop->op_ppaddr = PL_ppaddr[type];
4192 logop->op_first = first;
4193 logop->op_flags = (U8)(flags | OPf_KIDS);
4194 logop->op_other = LINKLIST(other);
4195 logop->op_private = (U8)(1 | (flags >> 8));
4197 /* establish postfix order */
4198 logop->op_next = LINKLIST(first);
4199 first->op_next = (OP*)logop;
4200 first->op_sibling = other;
4202 CHECKOP(type,logop);
4204 o = newUNOP(OP_NULL, 0, (OP*)logop);
4211 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
4219 return newLOGOP(OP_AND, 0, first, trueop);
4221 return newLOGOP(OP_OR, 0, first, falseop);
4223 scalarboolean(first);
4224 if (first->op_type == OP_CONST) {
4225 if (first->op_private & OPpCONST_BARE &&
4226 first->op_private & OPpCONST_STRICT) {
4227 no_bareword_allowed(first);
4229 if (SvTRUE(((SVOP*)first)->op_sv)) {
4232 trueop = newUNOP(OP_NULL, 0, trueop);
4233 op_getmad(first,trueop,'C');
4234 op_getmad(falseop,trueop,'e');
4236 /* FIXME for MAD - should there be an ELSE here? */
4246 falseop = newUNOP(OP_NULL, 0, falseop);
4247 op_getmad(first,falseop,'C');
4248 op_getmad(trueop,falseop,'t');
4250 /* FIXME for MAD - should there be an ELSE here? */
4258 NewOp(1101, logop, 1, LOGOP);
4259 logop->op_type = OP_COND_EXPR;
4260 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4261 logop->op_first = first;
4262 logop->op_flags = (U8)(flags | OPf_KIDS);
4263 logop->op_private = (U8)(1 | (flags >> 8));
4264 logop->op_other = LINKLIST(trueop);
4265 logop->op_next = LINKLIST(falseop);
4267 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
4270 /* establish postfix order */
4271 start = LINKLIST(first);
4272 first->op_next = (OP*)logop;
4274 first->op_sibling = trueop;
4275 trueop->op_sibling = falseop;
4276 o = newUNOP(OP_NULL, 0, (OP*)logop);
4278 trueop->op_next = falseop->op_next = o;
4285 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4294 NewOp(1101, range, 1, LOGOP);
4296 range->op_type = OP_RANGE;
4297 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4298 range->op_first = left;
4299 range->op_flags = OPf_KIDS;
4300 leftstart = LINKLIST(left);
4301 range->op_other = LINKLIST(right);
4302 range->op_private = (U8)(1 | (flags >> 8));
4304 left->op_sibling = right;
4306 range->op_next = (OP*)range;
4307 flip = newUNOP(OP_FLIP, flags, (OP*)range);
4308 flop = newUNOP(OP_FLOP, 0, flip);
4309 o = newUNOP(OP_NULL, 0, flop);
4311 range->op_next = leftstart;
4313 left->op_next = flip;
4314 right->op_next = flop;
4316 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4317 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4318 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4319 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4321 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4322 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4325 if (!flip->op_private || !flop->op_private)
4326 linklist(o); /* blow off optimizer unless constant */
4332 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4337 const bool once = block && block->op_flags & OPf_SPECIAL &&
4338 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4340 PERL_UNUSED_ARG(debuggable);
4343 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4344 return block; /* do {} while 0 does once */
4345 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4346 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4347 expr = newUNOP(OP_DEFINED, 0,
4348 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4349 } else if (expr->op_flags & OPf_KIDS) {
4350 const OP * const k1 = ((UNOP*)expr)->op_first;
4351 const OP * const k2 = k1 ? k1->op_sibling : NULL;
4352 switch (expr->op_type) {
4354 if (k2 && k2->op_type == OP_READLINE
4355 && (k2->op_flags & OPf_STACKED)
4356 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4357 expr = newUNOP(OP_DEFINED, 0, expr);
4361 if (k1 && (k1->op_type == OP_READDIR
4362 || k1->op_type == OP_GLOB
4363 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4364 || k1->op_type == OP_EACH))
4365 expr = newUNOP(OP_DEFINED, 0, expr);
4371 /* if block is null, the next append_elem() would put UNSTACK, a scalar
4372 * op, in listop. This is wrong. [perl #27024] */
4374 block = newOP(OP_NULL, 0);
4375 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4376 o = new_logop(OP_AND, 0, &expr, &listop);
4379 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4381 if (once && o != listop)
4382 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4385 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
4387 o->op_flags |= flags;
4389 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4394 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
4395 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
4404 PERL_UNUSED_ARG(debuggable);
4407 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4408 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4409 expr = newUNOP(OP_DEFINED, 0,
4410 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4411 } else if (expr->op_flags & OPf_KIDS) {
4412 const OP * const k1 = ((UNOP*)expr)->op_first;
4413 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
4414 switch (expr->op_type) {
4416 if (k2 && k2->op_type == OP_READLINE
4417 && (k2->op_flags & OPf_STACKED)
4418 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4419 expr = newUNOP(OP_DEFINED, 0, expr);
4423 if (k1 && (k1->op_type == OP_READDIR
4424 || k1->op_type == OP_GLOB
4425 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4426 || k1->op_type == OP_EACH))
4427 expr = newUNOP(OP_DEFINED, 0, expr);
4434 block = newOP(OP_NULL, 0);
4435 else if (cont || has_my) {
4436 block = scope(block);
4440 next = LINKLIST(cont);
4443 OP * const unstack = newOP(OP_UNSTACK, 0);
4446 cont = append_elem(OP_LINESEQ, cont, unstack);
4450 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4452 redo = LINKLIST(listop);
4455 PL_copline = (line_t)whileline;
4457 o = new_logop(OP_AND, 0, &expr, &listop);
4458 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4459 op_free(expr); /* oops, it's a while (0) */
4461 return NULL; /* listop already freed by new_logop */
4464 ((LISTOP*)listop)->op_last->op_next =
4465 (o == listop ? redo : LINKLIST(o));
4471 NewOp(1101,loop,1,LOOP);
4472 loop->op_type = OP_ENTERLOOP;
4473 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4474 loop->op_private = 0;
4475 loop->op_next = (OP*)loop;
4478 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4480 loop->op_redoop = redo;
4481 loop->op_lastop = o;
4482 o->op_private |= loopflags;
4485 loop->op_nextop = next;
4487 loop->op_nextop = o;
4489 o->op_flags |= flags;
4490 o->op_private |= (flags >> 8);
4495 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
4500 PADOFFSET padoff = 0;
4506 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4507 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
4508 sv->op_type = OP_RV2GV;
4509 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4510 if (cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
4511 iterpflags |= OPpITER_DEF;
4513 else if (sv->op_type == OP_PADSV) { /* private variable */
4514 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
4515 padoff = sv->op_targ;
4524 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4525 padoff = sv->op_targ;
4530 iterflags |= OPf_SPECIAL;
4536 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4537 if (padoff && strEQ(PAD_COMPNAME_PV(padoff), "$_"))
4538 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, savepv(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, (void*)name);
4897 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (void*)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, (void*)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, (void*)ERRSV);
5326 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5327 mod(scalarseq(block), OP_LEAVESUBLV));
5330 /* This makes sub {}; work as expected. */
5331 if (block->op_type == OP_STUB) {
5332 OP* const newblock = newSTATEOP(0, NULL, 0);
5334 op_getmad(block,newblock,'B');
5340 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5342 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5343 OpREFCNT_set(CvROOT(cv), 1);
5344 CvSTART(cv) = LINKLIST(CvROOT(cv));
5345 CvROOT(cv)->op_next = 0;
5346 CALL_PEEP(CvSTART(cv));
5348 /* now that optimizer has done its work, adjust pad values */
5350 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
5353 assert(!CvCONST(cv));
5354 if (ps && !*ps && op_const_sv(block, cv))
5358 if (name || aname) {
5360 const char * const tname = (name ? name : aname);
5362 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5363 SV * const sv = newSV(0);
5364 SV * const tmpstr = sv_newmortal();
5365 GV * const db_postponed = gv_fetchpvs("DB::postponed",
5366 GV_ADDMULTI, SVt_PVHV);
5369 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5371 (long)PL_subline, (long)CopLINE(PL_curcop));
5372 gv_efullname3(tmpstr, gv, NULL);
5373 hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0);
5374 hv = GvHVn(db_postponed);
5375 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
5376 CV * const pcv = GvCV(db_postponed);
5382 call_sv((SV*)pcv, G_DISCARD);
5387 if ((s = strrchr(tname,':')))
5392 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I' && *s != 'U')
5395 if (strEQ(s, "BEGIN") && !PL_error_count) {
5396 const I32 oldscope = PL_scopestack_ix;
5398 SAVECOPFILE(&PL_compiling);
5399 SAVECOPLINE(&PL_compiling);
5402 PL_beginav = newAV();
5403 DEBUG_x( dump_sub(gv) );
5404 av_push(PL_beginav, (SV*)cv);
5405 GvCV(gv) = 0; /* cv has been hijacked */
5406 call_list(oldscope, PL_beginav);
5408 PL_curcop = &PL_compiling;
5409 CopHINTS_set(&PL_compiling, PL_hints);
5412 else if (strEQ(s, "END") && !PL_error_count) {
5415 DEBUG_x( dump_sub(gv) );
5416 av_unshift(PL_endav, 1);
5417 av_store(PL_endav, 0, (SV*)cv);
5418 GvCV(gv) = 0; /* cv has been hijacked */
5420 else if (strEQ(s, "UNITCHECK") && !PL_error_count) {
5421 /* It's never too late to run a unitcheck block */
5422 if (!PL_unitcheckav)
5423 PL_unitcheckav = newAV();
5424 DEBUG_x( dump_sub(gv) );
5425 av_unshift(PL_unitcheckav, 1);
5426 av_store(PL_unitcheckav, 0, (SV*)cv);
5427 GvCV(gv) = 0; /* cv has been hijacked */
5429 else if (strEQ(s, "CHECK") && !PL_error_count) {
5431 PL_checkav = newAV();
5432 DEBUG_x( dump_sub(gv) );
5433 if (PL_main_start && ckWARN(WARN_VOID))
5434 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
5435 av_unshift(PL_checkav, 1);
5436 av_store(PL_checkav, 0, (SV*)cv);
5437 GvCV(gv) = 0; /* cv has been hijacked */
5439 else if (strEQ(s, "INIT") && !PL_error_count) {
5441 PL_initav = newAV();
5442 DEBUG_x( dump_sub(gv) );
5443 if (PL_main_start && ckWARN(WARN_VOID))
5444 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
5445 av_push(PL_initav, (SV*)cv);
5446 GvCV(gv) = 0; /* cv has been hijacked */
5451 PL_copline = NOLINE;
5456 /* XXX unsafe for threads if eval_owner isn't held */
5458 =for apidoc newCONSTSUB
5460 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5461 eligible for inlining at compile-time.
5467 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
5472 const char *const temp_p = CopFILE(PL_curcop);
5473 const STRLEN len = temp_p ? strlen(temp_p) : 0;
5475 SV *const temp_sv = CopFILESV(PL_curcop);
5477 const char *const temp_p = temp_sv ? SvPV_const(temp_sv, len) : NULL;
5479 char *const file = savepvn(temp_p, temp_p ? len : 0);
5483 SAVECOPLINE(PL_curcop);
5484 CopLINE_set(PL_curcop, PL_copline);
5487 PL_hints &= ~HINT_BLOCK_SCOPE;
5490 SAVESPTR(PL_curstash);
5491 SAVECOPSTASH(PL_curcop);
5492 PL_curstash = stash;
5493 CopSTASH_set(PL_curcop,stash);
5496 /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
5497 and so doesn't get free()d. (It's expected to be from the C pre-
5498 processor __FILE__ directive). But we need a dynamically allocated one,
5499 and we need it to get freed. */
5500 cv = newXS_flags(name, const_sv_xsub, file, "", XS_DYNAMIC_FILENAME);
5501 CvXSUBANY(cv).any_ptr = sv;
5507 CopSTASH_free(PL_curcop);
5515 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
5516 const char *const filename, const char *const proto,
5519 CV *cv = newXS(name, subaddr, filename);
5521 if (flags & XS_DYNAMIC_FILENAME) {
5522 /* We need to "make arrangements" (ie cheat) to ensure that the
5523 filename lasts as long as the PVCV we just created, but also doesn't
5525 STRLEN filename_len = strlen(filename);
5526 STRLEN proto_and_file_len = filename_len;
5527 char *proto_and_file;
5531 proto_len = strlen(proto);
5532 proto_and_file_len += proto_len;
5534 Newx(proto_and_file, proto_and_file_len + 1, char);
5535 Copy(proto, proto_and_file, proto_len, char);
5536 Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
5539 proto_and_file = savepvn(filename, filename_len);
5542 /* This gets free()d. :-) */
5543 sv_usepvn_flags((SV*)cv, proto_and_file, proto_and_file_len,
5544 SV_HAS_TRAILING_NUL);
5546 /* This gives us the correct prototype, rather than one with the
5547 file name appended. */
5548 SvCUR_set(cv, proto_len);
5552 CvFILE(cv) = proto_and_file + proto_len;
5554 sv_setpv((SV *)cv, proto);
5560 =for apidoc U||newXS
5562 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
5563 static storage, as it is used directly as CvFILE(), without a copy being made.
5569 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
5572 GV * const gv = gv_fetchpv(name ? name :
5573 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5574 GV_ADDMULTI, SVt_PVCV);
5578 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
5580 if ((cv = (name ? GvCV(gv) : NULL))) {
5582 /* just a cached method */
5586 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5587 /* already defined (or promised) */
5588 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
5589 if (ckWARN(WARN_REDEFINE)) {
5590 GV * const gvcv = CvGV(cv);
5592 HV * const stash = GvSTASH(gvcv);
5594 const char *redefined_name = HvNAME_get(stash);
5595 if ( strEQ(redefined_name,"autouse") ) {
5596 const line_t oldline = CopLINE(PL_curcop);
5597 if (PL_copline != NOLINE)
5598 CopLINE_set(PL_curcop, PL_copline);
5599 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5600 CvCONST(cv) ? "Constant subroutine %s redefined"
5601 : "Subroutine %s redefined"
5603 CopLINE_set(PL_curcop, oldline);
5613 if (cv) /* must reuse cv if autoloaded */
5617 sv_upgrade((SV *)cv, SVt_PVCV);
5621 PL_sub_generation++;
5625 (void)gv_fetchfile(filename);
5626 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
5627 an external constant string */
5629 CvXSUB(cv) = subaddr;
5632 const char *s = strrchr(name,':');
5638 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5641 if (strEQ(s, "BEGIN")) {
5643 PL_beginav = newAV();
5644 av_push(PL_beginav, (SV*)cv);
5645 GvCV(gv) = 0; /* cv has been hijacked */
5647 else if (strEQ(s, "END")) {
5650 av_unshift(PL_endav, 1);
5651 av_store(PL_endav, 0, (SV*)cv);
5652 GvCV(gv) = 0; /* cv has been hijacked */
5654 else if (strEQ(s, "CHECK")) {
5656 PL_checkav = newAV();
5657 if (PL_main_start && ckWARN(WARN_VOID))
5658 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
5659 av_unshift(PL_checkav, 1);
5660 av_store(PL_checkav, 0, (SV*)cv);
5661 GvCV(gv) = 0; /* cv has been hijacked */
5663 else if (strEQ(s, "INIT")) {
5665 PL_initav = newAV();
5666 if (PL_main_start && ckWARN(WARN_VOID))
5667 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
5668 av_push(PL_initav, (SV*)cv);
5669 GvCV(gv) = 0; /* cv has been hijacked */
5684 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5689 OP* pegop = newOP(OP_NULL, 0);
5693 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
5694 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
5696 #ifdef GV_UNIQUE_CHECK
5698 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5702 if ((cv = GvFORM(gv))) {
5703 if (ckWARN(WARN_REDEFINE)) {
5704 const line_t oldline = CopLINE(PL_curcop);
5705 if (PL_copline != NOLINE)
5706 CopLINE_set(PL_curcop, PL_copline);
5707 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5708 o ? "Format %"SVf" redefined"
5709 : "Format STDOUT redefined", (void*)cSVOPo->op_sv);
5710 CopLINE_set(PL_curcop, oldline);
5717 CvFILE_set_from_cop(cv, PL_curcop);
5720 pad_tidy(padtidy_FORMAT);
5721 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5722 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5723 OpREFCNT_set(CvROOT(cv), 1);
5724 CvSTART(cv) = LINKLIST(CvROOT(cv));
5725 CvROOT(cv)->op_next = 0;
5726 CALL_PEEP(CvSTART(cv));
5728 op_getmad(o,pegop,'n');
5729 op_getmad_weak(block, pegop, 'b');
5733 PL_copline = NOLINE;
5741 Perl_newANONLIST(pTHX_ OP *o)
5743 return convert(OP_ANONLIST, OPf_SPECIAL, o);
5747 Perl_newANONHASH(pTHX_ OP *o)
5749 return convert(OP_ANONHASH, OPf_SPECIAL, o);
5753 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5755 return newANONATTRSUB(floor, proto, NULL, block);
5759 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5761 return newUNOP(OP_REFGEN, 0,
5762 newSVOP(OP_ANONCODE, 0,
5763 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5767 Perl_oopsAV(pTHX_ OP *o)
5770 switch (o->op_type) {
5772 o->op_type = OP_PADAV;
5773 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5774 return ref(o, OP_RV2AV);
5777 o->op_type = OP_RV2AV;
5778 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5783 if (ckWARN_d(WARN_INTERNAL))
5784 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
5791 Perl_oopsHV(pTHX_ OP *o)
5794 switch (o->op_type) {
5797 o->op_type = OP_PADHV;
5798 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5799 return ref(o, OP_RV2HV);
5803 o->op_type = OP_RV2HV;
5804 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5809 if (ckWARN_d(WARN_INTERNAL))
5810 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
5817 Perl_newAVREF(pTHX_ OP *o)
5820 if (o->op_type == OP_PADANY) {
5821 o->op_type = OP_PADAV;
5822 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5825 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5826 && ckWARN(WARN_DEPRECATED)) {
5827 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5828 "Using an array as a reference is deprecated");
5830 return newUNOP(OP_RV2AV, 0, scalar(o));
5834 Perl_newGVREF(pTHX_ I32 type, OP *o)
5836 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5837 return newUNOP(OP_NULL, 0, o);
5838 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5842 Perl_newHVREF(pTHX_ OP *o)
5845 if (o->op_type == OP_PADANY) {
5846 o->op_type = OP_PADHV;
5847 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5850 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5851 && ckWARN(WARN_DEPRECATED)) {
5852 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5853 "Using a hash as a reference is deprecated");
5855 return newUNOP(OP_RV2HV, 0, scalar(o));
5859 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5861 return newUNOP(OP_RV2CV, flags, scalar(o));
5865 Perl_newSVREF(pTHX_ OP *o)
5868 if (o->op_type == OP_PADANY) {
5869 o->op_type = OP_PADSV;
5870 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5873 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5874 o->op_flags |= OPpDONE_SVREF;
5877 return newUNOP(OP_RV2SV, 0, scalar(o));
5880 /* Check routines. See the comments at the top of this file for details
5881 * on when these are called */
5884 Perl_ck_anoncode(pTHX_ OP *o)
5886 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
5888 cSVOPo->op_sv = NULL;
5893 Perl_ck_bitop(pTHX_ OP *o)
5896 #define OP_IS_NUMCOMPARE(op) \
5897 ((op) == OP_LT || (op) == OP_I_LT || \
5898 (op) == OP_GT || (op) == OP_I_GT || \
5899 (op) == OP_LE || (op) == OP_I_LE || \
5900 (op) == OP_GE || (op) == OP_I_GE || \
5901 (op) == OP_EQ || (op) == OP_I_EQ || \
5902 (op) == OP_NE || (op) == OP_I_NE || \
5903 (op) == OP_NCMP || (op) == OP_I_NCMP)
5904 o->op_private = (U8)(PL_hints & HINT_INTEGER);
5905 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
5906 && (o->op_type == OP_BIT_OR
5907 || o->op_type == OP_BIT_AND
5908 || o->op_type == OP_BIT_XOR))
5910 const OP * const left = cBINOPo->op_first;
5911 const OP * const right = left->op_sibling;
5912 if ((OP_IS_NUMCOMPARE(left->op_type) &&
5913 (left->op_flags & OPf_PARENS) == 0) ||
5914 (OP_IS_NUMCOMPARE(right->op_type) &&
5915 (right->op_flags & OPf_PARENS) == 0))
5916 if (ckWARN(WARN_PRECEDENCE))
5917 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
5918 "Possible precedence problem on bitwise %c operator",
5919 o->op_type == OP_BIT_OR ? '|'
5920 : o->op_type == OP_BIT_AND ? '&' : '^'
5927 Perl_ck_concat(pTHX_ OP *o)
5929 const OP * const kid = cUNOPo->op_first;
5930 PERL_UNUSED_CONTEXT;
5931 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
5932 !(kUNOP->op_first->op_flags & OPf_MOD))
5933 o->op_flags |= OPf_STACKED;
5938 Perl_ck_spair(pTHX_ OP *o)
5941 if (o->op_flags & OPf_KIDS) {
5944 const OPCODE type = o->op_type;
5945 o = modkids(ck_fun(o), type);
5946 kid = cUNOPo->op_first;
5947 newop = kUNOP->op_first->op_sibling;
5949 const OPCODE type = newop->op_type;
5950 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
5951 type == OP_PADAV || type == OP_PADHV ||
5952 type == OP_RV2AV || type == OP_RV2HV)
5956 op_getmad(kUNOP->op_first,newop,'K');
5958 op_free(kUNOP->op_first);
5960 kUNOP->op_first = newop;
5962 o->op_ppaddr = PL_ppaddr[++o->op_type];
5967 Perl_ck_delete(pTHX_ OP *o)
5971 if (o->op_flags & OPf_KIDS) {
5972 OP * const kid = cUNOPo->op_first;
5973 switch (kid->op_type) {
5975 o->op_flags |= OPf_SPECIAL;
5978 o->op_private |= OPpSLICE;
5981 o->op_flags |= OPf_SPECIAL;
5986 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5995 Perl_ck_die(pTHX_ OP *o)
5998 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6004 Perl_ck_eof(pTHX_ OP *o)
6008 if (o->op_flags & OPf_KIDS) {
6009 if (cLISTOPo->op_first->op_type == OP_STUB) {
6011 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
6013 op_getmad(o,newop,'O');
6025 Perl_ck_eval(pTHX_ OP *o)
6028 PL_hints |= HINT_BLOCK_SCOPE;
6029 if (o->op_flags & OPf_KIDS) {
6030 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6033 o->op_flags &= ~OPf_KIDS;
6036 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
6042 cUNOPo->op_first = 0;
6047 NewOp(1101, enter, 1, LOGOP);
6048 enter->op_type = OP_ENTERTRY;
6049 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
6050 enter->op_private = 0;
6052 /* establish postfix order */
6053 enter->op_next = (OP*)enter;
6055 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
6056 o->op_type = OP_LEAVETRY;
6057 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
6058 enter->op_other = o;
6059 op_getmad(oldo,o,'O');
6073 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
6074 op_getmad(oldo,o,'O');
6076 o->op_targ = (PADOFFSET)PL_hints;
6077 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
6078 /* Store a copy of %^H that pp_entereval can pick up */
6079 OP *hhop = newSVOP(OP_CONST, 0,
6080 (SV*)Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv)));
6081 cUNOPo->op_first->op_sibling = hhop;
6082 o->op_private |= OPpEVAL_HAS_HH;
6088 Perl_ck_exit(pTHX_ OP *o)
6091 HV * const table = GvHV(PL_hintgv);
6093 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
6094 if (svp && *svp && SvTRUE(*svp))
6095 o->op_private |= OPpEXIT_VMSISH;
6097 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6103 Perl_ck_exec(pTHX_ OP *o)
6105 if (o->op_flags & OPf_STACKED) {
6108 kid = cUNOPo->op_first->op_sibling;
6109 if (kid->op_type == OP_RV2GV)
6118 Perl_ck_exists(pTHX_ OP *o)
6122 if (o->op_flags & OPf_KIDS) {
6123 OP * const kid = cUNOPo->op_first;
6124 if (kid->op_type == OP_ENTERSUB) {
6125 (void) ref(kid, o->op_type);
6126 if (kid->op_type != OP_RV2CV && !PL_error_count)
6127 Perl_croak(aTHX_ "%s argument is not a subroutine name",
6129 o->op_private |= OPpEXISTS_SUB;
6131 else if (kid->op_type == OP_AELEM)
6132 o->op_flags |= OPf_SPECIAL;
6133 else if (kid->op_type != OP_HELEM)
6134 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
6142 Perl_ck_rvconst(pTHX_ register OP *o)
6145 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6147 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6148 if (o->op_type == OP_RV2CV)
6149 o->op_private &= ~1;
6151 if (kid->op_type == OP_CONST) {
6154 SV * const kidsv = kid->op_sv;
6156 /* Is it a constant from cv_const_sv()? */
6157 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
6158 SV * const rsv = SvRV(kidsv);
6159 const svtype type = SvTYPE(rsv);
6160 const char *badtype = NULL;
6162 switch (o->op_type) {
6164 if (type > SVt_PVMG)
6165 badtype = "a SCALAR";
6168 if (type != SVt_PVAV)
6169 badtype = "an ARRAY";
6172 if (type != SVt_PVHV)
6176 if (type != SVt_PVCV)
6181 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
6184 else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
6185 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
6186 /* If this is an access to a stash, disable "strict refs", because
6187 * stashes aren't auto-vivified at compile-time (unless we store
6188 * symbols in them), and we don't want to produce a run-time
6189 * stricture error when auto-vivifying the stash. */
6190 const char *s = SvPV_nolen(kidsv);
6191 const STRLEN l = SvCUR(kidsv);
6192 if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
6193 o->op_private &= ~HINT_STRICT_REFS;
6195 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
6196 const char *badthing;
6197 switch (o->op_type) {
6199 badthing = "a SCALAR";
6202 badthing = "an ARRAY";
6205 badthing = "a HASH";
6213 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
6214 (void*)kidsv, badthing);
6217 * This is a little tricky. We only want to add the symbol if we
6218 * didn't add it in the lexer. Otherwise we get duplicate strict
6219 * warnings. But if we didn't add it in the lexer, we must at
6220 * least pretend like we wanted to add it even if it existed before,
6221 * or we get possible typo warnings. OPpCONST_ENTERED says
6222 * whether the lexer already added THIS instance of this symbol.
6224 iscv = (o->op_type == OP_RV2CV) * 2;
6226 gv = gv_fetchsv(kidsv,
6227 iscv | !(kid->op_private & OPpCONST_ENTERED),
6230 : o->op_type == OP_RV2SV
6232 : o->op_type == OP_RV2AV
6234 : o->op_type == OP_RV2HV
6237 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
6239 kid->op_type = OP_GV;
6240 SvREFCNT_dec(kid->op_sv);
6242 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
6243 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
6244 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
6246 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc_simple_NN(gv));
6248 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
6250 kid->op_private = 0;
6251 kid->op_ppaddr = PL_ppaddr[OP_GV];
6258 Perl_ck_ftst(pTHX_ OP *o)
6261 const I32 type = o->op_type;
6263 if (o->op_flags & OPf_REF) {
6266 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
6267 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6268 const OPCODE kidtype = kid->op_type;
6270 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6271 OP * const newop = newGVOP(type, OPf_REF,
6272 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
6274 op_getmad(o,newop,'O');
6280 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o))
6281 o->op_private |= OPpFT_ACCESS;
6282 if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst)
6283 && kidtype != OP_STAT && kidtype != OP_LSTAT)
6284 o->op_private |= OPpFT_STACKED;
6292 if (type == OP_FTTTY)
6293 o = newGVOP(type, OPf_REF, PL_stdingv);
6295 o = newUNOP(type, 0, newDEFSVOP());
6296 op_getmad(oldo,o,'O');
6302 Perl_ck_fun(pTHX_ OP *o)
6305 const int type = o->op_type;
6306 register I32 oa = PL_opargs[type] >> OASHIFT;
6308 if (o->op_flags & OPf_STACKED) {
6309 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
6312 return no_fh_allowed(o);
6315 if (o->op_flags & OPf_KIDS) {
6316 OP **tokid = &cLISTOPo->op_first;
6317 register OP *kid = cLISTOPo->op_first;
6321 if (kid->op_type == OP_PUSHMARK ||
6322 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
6324 tokid = &kid->op_sibling;
6325 kid = kid->op_sibling;
6327 if (!kid && PL_opargs[type] & OA_DEFGV)
6328 *tokid = kid = newDEFSVOP();
6332 sibl = kid->op_sibling;
6334 if (!sibl && kid->op_type == OP_STUB) {
6341 /* list seen where single (scalar) arg expected? */
6342 if (numargs == 1 && !(oa >> 4)
6343 && kid->op_type == OP_LIST && type != OP_SCALAR)
6345 return too_many_arguments(o,PL_op_desc[type]);
6358 if ((type == OP_PUSH || type == OP_UNSHIFT)
6359 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
6360 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6361 "Useless use of %s with no values",
6364 if (kid->op_type == OP_CONST &&
6365 (kid->op_private & OPpCONST_BARE))
6367 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
6368 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
6369 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6370 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6371 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
6372 (void*)((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
6374 op_getmad(kid,newop,'K');
6379 kid->op_sibling = sibl;
6382 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
6383 bad_type(numargs, "array", PL_op_desc[type], kid);
6387 if (kid->op_type == OP_CONST &&
6388 (kid->op_private & OPpCONST_BARE))
6390 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
6391 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
6392 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6393 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6394 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
6395 (void*)((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
6397 op_getmad(kid,newop,'K');
6402 kid->op_sibling = sibl;
6405 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
6406 bad_type(numargs, "hash", PL_op_desc[type], kid);
6411 OP * const newop = newUNOP(OP_NULL, 0, kid);
6412 kid->op_sibling = 0;
6414 newop->op_next = newop;
6416 kid->op_sibling = sibl;
6421 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
6422 if (kid->op_type == OP_CONST &&
6423 (kid->op_private & OPpCONST_BARE))
6425 OP * const newop = newGVOP(OP_GV, 0,
6426 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
6427 if (!(o->op_private & 1) && /* if not unop */
6428 kid == cLISTOPo->op_last)
6429 cLISTOPo->op_last = newop;
6431 op_getmad(kid,newop,'K');
6437 else if (kid->op_type == OP_READLINE) {
6438 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
6439 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
6442 I32 flags = OPf_SPECIAL;
6446 /* is this op a FH constructor? */
6447 if (is_handle_constructor(o,numargs)) {
6448 const char *name = NULL;
6452 /* Set a flag to tell rv2gv to vivify
6453 * need to "prove" flag does not mean something
6454 * else already - NI-S 1999/05/07
6457 if (kid->op_type == OP_PADSV) {
6458 name = PAD_COMPNAME_PV(kid->op_targ);
6459 /* SvCUR of a pad namesv can't be trusted
6460 * (see PL_generation), so calc its length
6466 else if (kid->op_type == OP_RV2SV
6467 && kUNOP->op_first->op_type == OP_GV)
6469 GV * const gv = cGVOPx_gv(kUNOP->op_first);
6471 len = GvNAMELEN(gv);
6473 else if (kid->op_type == OP_AELEM
6474 || kid->op_type == OP_HELEM)
6477 OP *op = ((BINOP*)kid)->op_first;
6481 const char * const a =
6482 kid->op_type == OP_AELEM ?
6484 if (((op->op_type == OP_RV2AV) ||
6485 (op->op_type == OP_RV2HV)) &&
6486 (firstop = ((UNOP*)op)->op_first) &&
6487 (firstop->op_type == OP_GV)) {
6488 /* packagevar $a[] or $h{} */
6489 GV * const gv = cGVOPx_gv(firstop);
6497 else if (op->op_type == OP_PADAV
6498 || op->op_type == OP_PADHV) {
6499 /* lexicalvar $a[] or $h{} */
6500 const char * const padname =
6501 PAD_COMPNAME_PV(op->op_targ);
6510 name = SvPV_const(tmpstr, len);
6515 name = "__ANONIO__";
6522 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
6523 namesv = PAD_SVl(targ);
6524 SvUPGRADE(namesv, SVt_PV);
6526 sv_setpvn(namesv, "$", 1);
6527 sv_catpvn(namesv, name, len);
6530 kid->op_sibling = 0;
6531 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
6532 kid->op_targ = targ;
6533 kid->op_private |= priv;
6535 kid->op_sibling = sibl;
6541 mod(scalar(kid), type);
6545 tokid = &kid->op_sibling;
6546 kid = kid->op_sibling;
6549 if (kid && kid->op_type != OP_STUB)
6550 return too_many_arguments(o,OP_DESC(o));
6551 o->op_private |= numargs;
6553 /* FIXME - should the numargs move as for the PERL_MAD case? */
6554 o->op_private |= numargs;
6556 return too_many_arguments(o,OP_DESC(o));
6560 else if (PL_opargs[type] & OA_DEFGV) {
6562 OP *newop = newUNOP(type, 0, newDEFSVOP());
6563 op_getmad(o,newop,'O');
6566 /* Ordering of these two is important to keep f_map.t passing. */
6568 return newUNOP(type, 0, newDEFSVOP());
6573 while (oa & OA_OPTIONAL)
6575 if (oa && oa != OA_LIST)
6576 return too_few_arguments(o,OP_DESC(o));
6582 Perl_ck_glob(pTHX_ OP *o)
6588 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
6589 append_elem(OP_GLOB, o, newDEFSVOP());
6591 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
6592 && GvCVu(gv) && GvIMPORTED_CV(gv)))
6594 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6597 #if !defined(PERL_EXTERNAL_GLOB)
6598 /* XXX this can be tightened up and made more failsafe. */
6599 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
6602 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
6603 newSVpvs("File::Glob"), NULL, NULL, NULL);
6604 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6605 glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
6606 GvCV(gv) = GvCV(glob_gv);
6607 SvREFCNT_inc_void((SV*)GvCV(gv));
6608 GvIMPORTED_CV_on(gv);
6611 #endif /* PERL_EXTERNAL_GLOB */
6613 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6614 append_elem(OP_GLOB, o,
6615 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
6616 o->op_type = OP_LIST;
6617 o->op_ppaddr = PL_ppaddr[OP_LIST];
6618 cLISTOPo->op_first->op_type = OP_PUSHMARK;
6619 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
6620 cLISTOPo->op_first->op_targ = 0;
6621 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
6622 append_elem(OP_LIST, o,
6623 scalar(newUNOP(OP_RV2CV, 0,
6624 newGVOP(OP_GV, 0, gv)))));
6625 o = newUNOP(OP_NULL, 0, ck_subr(o));
6626 o->op_targ = OP_GLOB; /* hint at what it used to be */
6629 gv = newGVgen("main");
6631 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
6637 Perl_ck_grep(pTHX_ OP *o)
6642 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
6645 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
6646 /* don't allocate gwop here, as we may leak it if PL_error_count > 0 */
6648 if (o->op_flags & OPf_STACKED) {
6651 kid = cLISTOPo->op_first->op_sibling;
6652 if (!cUNOPx(kid)->op_next)
6653 Perl_croak(aTHX_ "panic: ck_grep");
6654 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
6657 NewOp(1101, gwop, 1, LOGOP);
6658 kid->op_next = (OP*)gwop;
6659 o->op_flags &= ~OPf_STACKED;
6661 kid = cLISTOPo->op_first->op_sibling;
6662 if (type == OP_MAPWHILE)
6669 kid = cLISTOPo->op_first->op_sibling;
6670 if (kid->op_type != OP_NULL)
6671 Perl_croak(aTHX_ "panic: ck_grep");
6672 kid = kUNOP->op_first;
6675 NewOp(1101, gwop, 1, LOGOP);
6676 gwop->op_type = type;
6677 gwop->op_ppaddr = PL_ppaddr[type];
6678 gwop->op_first = listkids(o);
6679 gwop->op_flags |= OPf_KIDS;
6680 gwop->op_other = LINKLIST(kid);
6681 kid->op_next = (OP*)gwop;
6682 offset = pad_findmy("$_");
6683 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
6684 o->op_private = gwop->op_private = 0;
6685 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
6688 o->op_private = gwop->op_private = OPpGREP_LEX;
6689 gwop->op_targ = o->op_targ = offset;
6692 kid = cLISTOPo->op_first->op_sibling;
6693 if (!kid || !kid->op_sibling)
6694 return too_few_arguments(o,OP_DESC(o));
6695 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
6696 mod(kid, OP_GREPSTART);
6702 Perl_ck_index(pTHX_ OP *o)
6704 if (o->op_flags & OPf_KIDS) {
6705 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6707 kid = kid->op_sibling; /* get past "big" */
6708 if (kid && kid->op_type == OP_CONST)
6709 fbm_compile(((SVOP*)kid)->op_sv, 0);
6715 Perl_ck_lengthconst(pTHX_ OP *o)
6717 /* XXX length optimization goes here */
6722 Perl_ck_lfun(pTHX_ OP *o)
6724 const OPCODE type = o->op_type;
6725 return modkids(ck_fun(o), type);
6729 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
6731 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
6732 switch (cUNOPo->op_first->op_type) {
6734 /* This is needed for
6735 if (defined %stash::)
6736 to work. Do not break Tk.
6738 break; /* Globals via GV can be undef */
6740 case OP_AASSIGN: /* Is this a good idea? */
6741 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6742 "defined(@array) is deprecated");
6743 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6744 "\t(Maybe you should just omit the defined()?)\n");
6747 /* This is needed for
6748 if (defined %stash::)
6749 to work. Do not break Tk.
6751 break; /* Globals via GV can be undef */
6753 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6754 "defined(%%hash) is deprecated");
6755 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6756 "\t(Maybe you should just omit the defined()?)\n");
6767 Perl_ck_rfun(pTHX_ OP *o)
6769 const OPCODE type = o->op_type;
6770 return refkids(ck_fun(o), type);
6774 Perl_ck_listiob(pTHX_ OP *o)
6778 kid = cLISTOPo->op_first;
6781 kid = cLISTOPo->op_first;
6783 if (kid->op_type == OP_PUSHMARK)
6784 kid = kid->op_sibling;
6785 if (kid && o->op_flags & OPf_STACKED)
6786 kid = kid->op_sibling;
6787 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6788 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6789 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6790 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6791 cLISTOPo->op_first->op_sibling = kid;
6792 cLISTOPo->op_last = kid;
6793 kid = kid->op_sibling;
6798 append_elem(o->op_type, o, newDEFSVOP());
6804 Perl_ck_smartmatch(pTHX_ OP *o)
6807 if (0 == (o->op_flags & OPf_SPECIAL)) {
6808 OP *first = cBINOPo->op_first;
6809 OP *second = first->op_sibling;
6811 /* Implicitly take a reference to an array or hash */
6812 first->op_sibling = NULL;
6813 first = cBINOPo->op_first = ref_array_or_hash(first);
6814 second = first->op_sibling = ref_array_or_hash(second);
6816 /* Implicitly take a reference to a regular expression */
6817 if (first->op_type == OP_MATCH) {
6818 first->op_type = OP_QR;
6819 first->op_ppaddr = PL_ppaddr[OP_QR];
6821 if (second->op_type == OP_MATCH) {
6822 second->op_type = OP_QR;
6823 second->op_ppaddr = PL_ppaddr[OP_QR];
6832 Perl_ck_sassign(pTHX_ OP *o)
6834 OP * const kid = cLISTOPo->op_first;
6835 /* has a disposable target? */
6836 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6837 && !(kid->op_flags & OPf_STACKED)
6838 /* Cannot steal the second time! */
6839 && !(kid->op_private & OPpTARGET_MY))
6841 OP * const kkid = kid->op_sibling;
6843 /* Can just relocate the target. */
6844 if (kkid && kkid->op_type == OP_PADSV
6845 && !(kkid->op_private & OPpLVAL_INTRO))
6847 kid->op_targ = kkid->op_targ;
6849 /* Now we do not need PADSV and SASSIGN. */
6850 kid->op_sibling = o->op_sibling; /* NULL */
6851 cLISTOPo->op_first = NULL;
6853 op_getmad(o,kid,'O');
6854 op_getmad(kkid,kid,'M');
6859 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6863 if (kid->op_sibling) {
6864 OP *kkid = kid->op_sibling;
6865 if (kkid->op_type == OP_PADSV
6866 && (kkid->op_private & OPpLVAL_INTRO)
6867 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
6868 o->op_private |= OPpASSIGN_STATE;
6869 /* hijacking PADSTALE for uninitialized state variables */
6870 SvPADSTALE_on(PAD_SVl(kkid->op_targ));
6877 Perl_ck_match(pTHX_ OP *o)
6880 if (o->op_type != OP_QR && PL_compcv) {
6881 const PADOFFSET offset = pad_findmy("$_");
6882 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
6883 o->op_targ = offset;
6884 o->op_private |= OPpTARGET_MY;
6887 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
6888 o->op_private |= OPpRUNTIME;
6893 Perl_ck_method(pTHX_ OP *o)
6895 OP * const kid = cUNOPo->op_first;
6896 if (kid->op_type == OP_CONST) {
6897 SV* sv = kSVOP->op_sv;
6898 const char * const method = SvPVX_const(sv);
6899 if (!(strchr(method, ':') || strchr(method, '\''))) {
6901 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6902 sv = newSVpvn_share(method, SvCUR(sv), 0);
6905 kSVOP->op_sv = NULL;
6907 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6909 op_getmad(o,cmop,'O');
6920 Perl_ck_null(pTHX_ OP *o)
6922 PERL_UNUSED_CONTEXT;
6927 Perl_ck_open(pTHX_ OP *o)
6930 HV * const table = GvHV(PL_hintgv);
6932 SV **svp = hv_fetchs(table, "open_IN", FALSE);
6934 const I32 mode = mode_from_discipline(*svp);
6935 if (mode & O_BINARY)
6936 o->op_private |= OPpOPEN_IN_RAW;
6937 else if (mode & O_TEXT)
6938 o->op_private |= OPpOPEN_IN_CRLF;
6941 svp = hv_fetchs(table, "open_OUT", FALSE);
6943 const I32 mode = mode_from_discipline(*svp);
6944 if (mode & O_BINARY)
6945 o->op_private |= OPpOPEN_OUT_RAW;
6946 else if (mode & O_TEXT)
6947 o->op_private |= OPpOPEN_OUT_CRLF;
6950 if (o->op_type == OP_BACKTICK)
6953 /* In case of three-arg dup open remove strictness
6954 * from the last arg if it is a bareword. */
6955 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
6956 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
6960 if ((last->op_type == OP_CONST) && /* The bareword. */
6961 (last->op_private & OPpCONST_BARE) &&
6962 (last->op_private & OPpCONST_STRICT) &&
6963 (oa = first->op_sibling) && /* The fh. */
6964 (oa = oa->op_sibling) && /* The mode. */
6965 (oa->op_type == OP_CONST) &&
6966 SvPOK(((SVOP*)oa)->op_sv) &&
6967 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
6968 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
6969 (last == oa->op_sibling)) /* The bareword. */
6970 last->op_private &= ~OPpCONST_STRICT;
6976 Perl_ck_repeat(pTHX_ OP *o)
6978 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6979 o->op_private |= OPpREPEAT_DOLIST;
6980 cBINOPo->op_first = force_list(cBINOPo->op_first);
6988 Perl_ck_require(pTHX_ OP *o)
6993 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6994 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6996 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6997 SV * const sv = kid->op_sv;
6998 U32 was_readonly = SvREADONLY(sv);
7003 sv_force_normal_flags(sv, 0);
7004 assert(!SvREADONLY(sv));
7011 for (s = SvPVX(sv); *s; s++) {
7012 if (*s == ':' && s[1] == ':') {
7013 const STRLEN len = strlen(s+2)+1;
7015 Move(s+2, s+1, len, char);
7016 SvCUR_set(sv, SvCUR(sv) - 1);
7019 sv_catpvs(sv, ".pm");
7020 SvFLAGS(sv) |= was_readonly;
7024 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
7025 /* handle override, if any */
7026 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
7027 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7028 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
7029 gv = gvp ? *gvp : NULL;
7033 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7034 OP * const kid = cUNOPo->op_first;
7037 cUNOPo->op_first = 0;
7041 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
7042 append_elem(OP_LIST, kid,
7043 scalar(newUNOP(OP_RV2CV, 0,
7046 op_getmad(o,newop,'O');
7054 Perl_ck_return(pTHX_ OP *o)
7057 if (CvLVALUE(PL_compcv)) {
7059 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
7060 mod(kid, OP_LEAVESUBLV);
7066 Perl_ck_select(pTHX_ OP *o)
7070 if (o->op_flags & OPf_KIDS) {
7071 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7072 if (kid && kid->op_sibling) {
7073 o->op_type = OP_SSELECT;
7074 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
7076 return fold_constants(o);
7080 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7081 if (kid && kid->op_type == OP_RV2GV)
7082 kid->op_private &= ~HINT_STRICT_REFS;
7087 Perl_ck_shift(pTHX_ OP *o)
7090 const I32 type = o->op_type;
7092 if (!(o->op_flags & OPf_KIDS)) {
7094 /* FIXME - this can be refactored to reduce code in #ifdefs */
7096 OP * const oldo = o;
7100 argop = newUNOP(OP_RV2AV, 0,
7101 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
7103 o = newUNOP(type, 0, scalar(argop));
7104 op_getmad(oldo,o,'O');
7107 return newUNOP(type, 0, scalar(argop));
7110 return scalar(modkids(ck_fun(o), type));
7114 Perl_ck_sort(pTHX_ OP *o)
7119 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
7120 HV * const hinthv = GvHV(PL_hintgv);
7122 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
7124 const I32 sorthints = (I32)SvIV(*svp);
7125 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
7126 o->op_private |= OPpSORT_QSORT;
7127 if ((sorthints & HINT_SORT_STABLE) != 0)
7128 o->op_private |= OPpSORT_STABLE;
7133 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
7135 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7136 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
7138 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
7140 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
7142 if (kid->op_type == OP_SCOPE) {
7146 else if (kid->op_type == OP_LEAVE) {
7147 if (o->op_type == OP_SORT) {
7148 op_null(kid); /* wipe out leave */
7151 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
7152 if (k->op_next == kid)
7154 /* don't descend into loops */
7155 else if (k->op_type == OP_ENTERLOOP
7156 || k->op_type == OP_ENTERITER)
7158 k = cLOOPx(k)->op_lastop;
7163 kid->op_next = 0; /* just disconnect the leave */
7164 k = kLISTOP->op_first;
7169 if (o->op_type == OP_SORT) {
7170 /* provide scalar context for comparison function/block */
7176 o->op_flags |= OPf_SPECIAL;
7178 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
7181 firstkid = firstkid->op_sibling;
7184 /* provide list context for arguments */
7185 if (o->op_type == OP_SORT)
7192 S_simplify_sort(pTHX_ OP *o)
7195 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7200 if (!(o->op_flags & OPf_STACKED))
7202 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7203 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
7204 kid = kUNOP->op_first; /* get past null */
7205 if (kid->op_type != OP_SCOPE)
7207 kid = kLISTOP->op_last; /* get past scope */
7208 switch(kid->op_type) {
7216 k = kid; /* remember this node*/
7217 if (kBINOP->op_first->op_type != OP_RV2SV)
7219 kid = kBINOP->op_first; /* get past cmp */
7220 if (kUNOP->op_first->op_type != OP_GV)
7222 kid = kUNOP->op_first; /* get past rv2sv */
7224 if (GvSTASH(gv) != PL_curstash)
7226 gvname = GvNAME(gv);
7227 if (*gvname == 'a' && gvname[1] == '\0')
7229 else if (*gvname == 'b' && gvname[1] == '\0')
7234 kid = k; /* back to cmp */
7235 if (kBINOP->op_last->op_type != OP_RV2SV)
7237 kid = kBINOP->op_last; /* down to 2nd arg */
7238 if (kUNOP->op_first->op_type != OP_GV)
7240 kid = kUNOP->op_first; /* get past rv2sv */
7242 if (GvSTASH(gv) != PL_curstash)
7244 gvname = GvNAME(gv);
7246 ? !(*gvname == 'a' && gvname[1] == '\0')
7247 : !(*gvname == 'b' && gvname[1] == '\0'))
7249 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
7251 o->op_private |= OPpSORT_DESCEND;
7252 if (k->op_type == OP_NCMP)
7253 o->op_private |= OPpSORT_NUMERIC;
7254 if (k->op_type == OP_I_NCMP)
7255 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
7256 kid = cLISTOPo->op_first->op_sibling;
7257 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
7259 op_getmad(kid,o,'S'); /* then delete it */
7261 op_free(kid); /* then delete it */
7266 Perl_ck_split(pTHX_ OP *o)
7271 if (o->op_flags & OPf_STACKED)
7272 return no_fh_allowed(o);
7274 kid = cLISTOPo->op_first;
7275 if (kid->op_type != OP_NULL)
7276 Perl_croak(aTHX_ "panic: ck_split");
7277 kid = kid->op_sibling;
7278 op_free(cLISTOPo->op_first);
7279 cLISTOPo->op_first = kid;
7281 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
7282 cLISTOPo->op_last = kid; /* There was only one element previously */
7285 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
7286 OP * const sibl = kid->op_sibling;
7287 kid->op_sibling = 0;
7288 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
7289 if (cLISTOPo->op_first == cLISTOPo->op_last)
7290 cLISTOPo->op_last = kid;
7291 cLISTOPo->op_first = kid;
7292 kid->op_sibling = sibl;
7295 kid->op_type = OP_PUSHRE;
7296 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
7298 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
7299 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
7300 "Use of /g modifier is meaningless in split");
7303 if (!kid->op_sibling)
7304 append_elem(OP_SPLIT, o, newDEFSVOP());
7306 kid = kid->op_sibling;
7309 if (!kid->op_sibling)
7310 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
7311 assert(kid->op_sibling);
7313 kid = kid->op_sibling;
7316 if (kid->op_sibling)
7317 return too_many_arguments(o,OP_DESC(o));
7323 Perl_ck_join(pTHX_ OP *o)
7325 const OP * const kid = cLISTOPo->op_first->op_sibling;
7326 if (kid && kid->op_type == OP_MATCH) {
7327 if (ckWARN(WARN_SYNTAX)) {
7328 const REGEXP *re = PM_GETRE(kPMOP);
7329 const char *pmstr = re ? re->precomp : "STRING";
7330 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7331 "/%s/ should probably be written as \"%s\"",
7339 Perl_ck_subr(pTHX_ OP *o)
7342 OP *prev = ((cUNOPo->op_first->op_sibling)
7343 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
7344 OP *o2 = prev->op_sibling;
7346 const char *proto = NULL;
7347 const char *proto_end = NULL;
7352 I32 contextclass = 0;
7353 const char *e = NULL;
7356 o->op_private |= OPpENTERSUB_HASTARG;
7357 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
7358 if (cvop->op_type == OP_RV2CV) {
7360 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
7361 op_null(cvop); /* disable rv2cv */
7362 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
7363 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
7364 GV *gv = cGVOPx_gv(tmpop);
7367 tmpop->op_private |= OPpEARLY_CV;
7371 namegv = CvANON(cv) ? gv : CvGV(cv);
7372 proto = SvPV((SV*)cv, len);
7373 proto_end = proto + len;
7375 if (CvASSERTION(cv)) {
7376 U32 asserthints = 0;
7377 HV *const hinthv = GvHV(PL_hintgv);
7379 SV **svp = hv_fetchs(hinthv, "assertions", FALSE);
7381 asserthints = SvUV(*svp);
7383 if (asserthints & HINT_ASSERTING) {
7384 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
7385 o->op_private |= OPpENTERSUB_DB;
7389 if (!(asserthints & HINT_ASSERTIONSSEEN) && ckWARN(WARN_ASSERTIONS)) {
7390 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
7391 "Impossible to activate assertion call");
7398 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7399 if (o2->op_type == OP_CONST)
7400 o2->op_private &= ~OPpCONST_STRICT;
7401 else if (o2->op_type == OP_LIST) {
7402 OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
7403 if (sib && sib->op_type == OP_CONST)
7404 sib->op_private &= ~OPpCONST_STRICT;
7407 o->op_private |= (PL_hints & HINT_STRICT_REFS);
7408 if (PERLDB_SUB && PL_curstash != PL_debstash)
7409 o->op_private |= OPpENTERSUB_DB;
7410 while (o2 != cvop) {
7412 if (PL_madskills && o2->op_type == OP_NULL)
7413 o3 = ((UNOP*)o2)->op_first;
7417 if (proto >= proto_end)
7418 return too_many_arguments(o, gv_ename(namegv));
7426 /* _ must be at the end */
7427 if (proto[1] && proto[1] != ';')
7442 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
7444 arg == 1 ? "block or sub {}" : "sub {}",
7445 gv_ename(namegv), o3);
7448 /* '*' allows any scalar type, including bareword */
7451 if (o3->op_type == OP_RV2GV)
7452 goto wrapref; /* autoconvert GLOB -> GLOBref */
7453 else if (o3->op_type == OP_CONST)
7454 o3->op_private &= ~OPpCONST_STRICT;
7455 else if (o3->op_type == OP_ENTERSUB) {
7456 /* accidental subroutine, revert to bareword */
7457 OP *gvop = ((UNOP*)o3)->op_first;
7458 if (gvop && gvop->op_type == OP_NULL) {
7459 gvop = ((UNOP*)gvop)->op_first;
7461 for (; gvop->op_sibling; gvop = gvop->op_sibling)
7464 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
7465 (gvop = ((UNOP*)gvop)->op_first) &&
7466 gvop->op_type == OP_GV)
7468 GV * const gv = cGVOPx_gv(gvop);
7469 OP * const sibling = o2->op_sibling;
7470 SV * const n = newSVpvs("");
7472 OP * const oldo2 = o2;
7476 gv_fullname4(n, gv, "", FALSE);
7477 o2 = newSVOP(OP_CONST, 0, n);
7478 op_getmad(oldo2,o2,'O');
7479 prev->op_sibling = o2;
7480 o2->op_sibling = sibling;
7496 if (contextclass++ == 0) {
7497 e = strchr(proto, ']');
7498 if (!e || e == proto)
7507 const char *p = proto;
7508 const char *const end = proto;
7510 while (*--p != '[');
7511 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
7513 gv_ename(namegv), o3);
7518 if (o3->op_type == OP_RV2GV)
7521 bad_type(arg, "symbol", gv_ename(namegv), o3);
7524 if (o3->op_type == OP_ENTERSUB)
7527 bad_type(arg, "subroutine entry", gv_ename(namegv),
7531 if (o3->op_type == OP_RV2SV ||
7532 o3->op_type == OP_PADSV ||
7533 o3->op_type == OP_HELEM ||
7534 o3->op_type == OP_AELEM ||
7535 o3->op_type == OP_THREADSV)
7538 bad_type(arg, "scalar", gv_ename(namegv), o3);
7541 if (o3->op_type == OP_RV2AV ||
7542 o3->op_type == OP_PADAV)
7545 bad_type(arg, "array", gv_ename(namegv), o3);
7548 if (o3->op_type == OP_RV2HV ||
7549 o3->op_type == OP_PADHV)
7552 bad_type(arg, "hash", gv_ename(namegv), o3);
7557 OP* const sib = kid->op_sibling;
7558 kid->op_sibling = 0;
7559 o2 = newUNOP(OP_REFGEN, 0, kid);
7560 o2->op_sibling = sib;
7561 prev->op_sibling = o2;
7563 if (contextclass && e) {
7578 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
7579 gv_ename(namegv), (void*)cv);
7584 mod(o2, OP_ENTERSUB);
7586 o2 = o2->op_sibling;
7588 if (o2 == cvop && proto && *proto == '_') {
7589 /* generate an access to $_ */
7591 o2->op_sibling = prev->op_sibling;
7592 prev->op_sibling = o2; /* instead of cvop */
7594 if (proto && !optional && proto_end > proto &&
7595 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
7596 return too_few_arguments(o, gv_ename(namegv));
7599 OP * const oldo = o;
7603 o=newSVOP(OP_CONST, 0, newSViv(0));
7604 op_getmad(oldo,o,'O');
7610 Perl_ck_svconst(pTHX_ OP *o)
7612 PERL_UNUSED_CONTEXT;
7613 SvREADONLY_on(cSVOPo->op_sv);
7618 Perl_ck_chdir(pTHX_ OP *o)
7620 if (o->op_flags & OPf_KIDS) {
7621 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7623 if (kid && kid->op_type == OP_CONST &&
7624 (kid->op_private & OPpCONST_BARE))
7626 o->op_flags |= OPf_SPECIAL;
7627 kid->op_private &= ~OPpCONST_STRICT;
7634 Perl_ck_trunc(pTHX_ OP *o)
7636 if (o->op_flags & OPf_KIDS) {
7637 SVOP *kid = (SVOP*)cUNOPo->op_first;
7639 if (kid->op_type == OP_NULL)
7640 kid = (SVOP*)kid->op_sibling;
7641 if (kid && kid->op_type == OP_CONST &&
7642 (kid->op_private & OPpCONST_BARE))
7644 o->op_flags |= OPf_SPECIAL;
7645 kid->op_private &= ~OPpCONST_STRICT;
7652 Perl_ck_unpack(pTHX_ OP *o)
7654 OP *kid = cLISTOPo->op_first;
7655 if (kid->op_sibling) {
7656 kid = kid->op_sibling;
7657 if (!kid->op_sibling)
7658 kid->op_sibling = newDEFSVOP();
7664 Perl_ck_substr(pTHX_ OP *o)
7667 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
7668 OP *kid = cLISTOPo->op_first;
7670 if (kid->op_type == OP_NULL)
7671 kid = kid->op_sibling;
7673 kid->op_flags |= OPf_MOD;
7679 /* A peephole optimizer. We visit the ops in the order they're to execute.
7680 * See the comments at the top of this file for more details about when
7681 * peep() is called */
7684 Perl_peep(pTHX_ register OP *o)
7687 register OP* oldop = NULL;
7689 if (!o || o->op_opt)
7693 SAVEVPTR(PL_curcop);
7694 for (; o; o = o->op_next) {
7698 switch (o->op_type) {
7702 PL_curcop = ((COP*)o); /* for warnings */
7707 if (cSVOPo->op_private & OPpCONST_STRICT)
7708 no_bareword_allowed(o);
7710 case OP_METHOD_NAMED:
7711 /* Relocate sv to the pad for thread safety.
7712 * Despite being a "constant", the SV is written to,
7713 * for reference counts, sv_upgrade() etc. */
7715 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
7716 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
7717 /* If op_sv is already a PADTMP then it is being used by
7718 * some pad, so make a copy. */
7719 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
7720 SvREADONLY_on(PAD_SVl(ix));
7721 SvREFCNT_dec(cSVOPo->op_sv);
7723 else if (o->op_type == OP_CONST
7724 && cSVOPo->op_sv == &PL_sv_undef) {
7725 /* PL_sv_undef is hack - it's unsafe to store it in the
7726 AV that is the pad, because av_fetch treats values of
7727 PL_sv_undef as a "free" AV entry and will merrily
7728 replace them with a new SV, causing pad_alloc to think
7729 that this pad slot is free. (When, clearly, it is not)
7731 SvOK_off(PAD_SVl(ix));
7732 SvPADTMP_on(PAD_SVl(ix));
7733 SvREADONLY_on(PAD_SVl(ix));
7736 SvREFCNT_dec(PAD_SVl(ix));
7737 SvPADTMP_on(cSVOPo->op_sv);
7738 PAD_SETSV(ix, cSVOPo->op_sv);
7739 /* XXX I don't know how this isn't readonly already. */
7740 SvREADONLY_on(PAD_SVl(ix));
7742 cSVOPo->op_sv = NULL;
7750 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
7751 if (o->op_next->op_private & OPpTARGET_MY) {
7752 if (o->op_flags & OPf_STACKED) /* chained concats */
7753 goto ignore_optimization;
7755 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
7756 o->op_targ = o->op_next->op_targ;
7757 o->op_next->op_targ = 0;
7758 o->op_private |= OPpTARGET_MY;
7761 op_null(o->op_next);
7763 ignore_optimization:
7767 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
7769 break; /* Scalar stub must produce undef. List stub is noop */
7773 if (o->op_targ == OP_NEXTSTATE
7774 || o->op_targ == OP_DBSTATE
7775 || o->op_targ == OP_SETSTATE)
7777 PL_curcop = ((COP*)o);
7779 /* XXX: We avoid setting op_seq here to prevent later calls
7780 to peep() from mistakenly concluding that optimisation
7781 has already occurred. This doesn't fix the real problem,
7782 though (See 20010220.007). AMS 20010719 */
7783 /* op_seq functionality is now replaced by op_opt */
7784 if (oldop && o->op_next) {
7785 oldop->op_next = o->op_next;
7793 if (oldop && o->op_next) {
7794 oldop->op_next = o->op_next;
7802 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
7803 OP* const pop = (o->op_type == OP_PADAV) ?
7804 o->op_next : o->op_next->op_next;
7806 if (pop && pop->op_type == OP_CONST &&
7807 ((PL_op = pop->op_next)) &&
7808 pop->op_next->op_type == OP_AELEM &&
7809 !(pop->op_next->op_private &
7810 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
7811 (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
7816 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
7817 no_bareword_allowed(pop);
7818 if (o->op_type == OP_GV)
7819 op_null(o->op_next);
7820 op_null(pop->op_next);
7822 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
7823 o->op_next = pop->op_next->op_next;
7824 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
7825 o->op_private = (U8)i;
7826 if (o->op_type == OP_GV) {
7831 o->op_flags |= OPf_SPECIAL;
7832 o->op_type = OP_AELEMFAST;
7838 if (o->op_next->op_type == OP_RV2SV) {
7839 if (!(o->op_next->op_private & OPpDEREF)) {
7840 op_null(o->op_next);
7841 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
7843 o->op_next = o->op_next->op_next;
7844 o->op_type = OP_GVSV;
7845 o->op_ppaddr = PL_ppaddr[OP_GVSV];
7848 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
7849 GV * const gv = cGVOPo_gv;
7850 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
7851 /* XXX could check prototype here instead of just carping */
7852 SV * const sv = sv_newmortal();
7853 gv_efullname3(sv, gv, NULL);
7854 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
7855 "%"SVf"() called too early to check prototype",
7859 else if (o->op_next->op_type == OP_READLINE
7860 && o->op_next->op_next->op_type == OP_CONCAT
7861 && (o->op_next->op_next->op_flags & OPf_STACKED))
7863 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
7864 o->op_type = OP_RCATLINE;
7865 o->op_flags |= OPf_STACKED;
7866 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
7867 op_null(o->op_next->op_next);
7868 op_null(o->op_next);
7885 while (cLOGOP->op_other->op_type == OP_NULL)
7886 cLOGOP->op_other = cLOGOP->op_other->op_next;
7887 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
7893 while (cLOOP->op_redoop->op_type == OP_NULL)
7894 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
7895 peep(cLOOP->op_redoop);
7896 while (cLOOP->op_nextop->op_type == OP_NULL)
7897 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
7898 peep(cLOOP->op_nextop);
7899 while (cLOOP->op_lastop->op_type == OP_NULL)
7900 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
7901 peep(cLOOP->op_lastop);
7908 while (cPMOP->op_pmreplstart &&
7909 cPMOP->op_pmreplstart->op_type == OP_NULL)
7910 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
7911 peep(cPMOP->op_pmreplstart);
7916 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
7917 && ckWARN(WARN_SYNTAX))
7919 if (o->op_next->op_sibling) {
7920 const OPCODE type = o->op_next->op_sibling->op_type;
7921 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
7922 const line_t oldline = CopLINE(PL_curcop);
7923 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
7924 Perl_warner(aTHX_ packWARN(WARN_EXEC),
7925 "Statement unlikely to be reached");
7926 Perl_warner(aTHX_ packWARN(WARN_EXEC),
7927 "\t(Maybe you meant system() when you said exec()?)\n");
7928 CopLINE_set(PL_curcop, oldline);
7939 const char *key = NULL;
7944 if (((BINOP*)o)->op_last->op_type != OP_CONST)
7947 /* Make the CONST have a shared SV */
7948 svp = cSVOPx_svp(((BINOP*)o)->op_last);
7949 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
7950 key = SvPV_const(sv, keylen);
7951 lexname = newSVpvn_share(key,
7952 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
7958 if ((o->op_private & (OPpLVAL_INTRO)))
7961 rop = (UNOP*)((BINOP*)o)->op_first;
7962 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7964 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7965 if (!SvPAD_TYPED(lexname))
7967 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
7968 if (!fields || !GvHV(*fields))
7970 key = SvPV_const(*svp, keylen);
7971 if (!hv_fetch(GvHV(*fields), key,
7972 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
7974 Perl_croak(aTHX_ "No such class field \"%s\" "
7975 "in variable %s of type %s",
7976 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
7989 SVOP *first_key_op, *key_op;
7991 if ((o->op_private & (OPpLVAL_INTRO))
7992 /* I bet there's always a pushmark... */
7993 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
7994 /* hmmm, no optimization if list contains only one key. */
7996 rop = (UNOP*)((LISTOP*)o)->op_last;
7997 if (rop->op_type != OP_RV2HV)
7999 if (rop->op_first->op_type == OP_PADSV)
8000 /* @$hash{qw(keys here)} */
8001 rop = (UNOP*)rop->op_first;
8003 /* @{$hash}{qw(keys here)} */
8004 if (rop->op_first->op_type == OP_SCOPE
8005 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
8007 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
8013 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
8014 if (!SvPAD_TYPED(lexname))
8016 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8017 if (!fields || !GvHV(*fields))
8019 /* Again guessing that the pushmark can be jumped over.... */
8020 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
8021 ->op_first->op_sibling;
8022 for (key_op = first_key_op; key_op;
8023 key_op = (SVOP*)key_op->op_sibling) {
8024 if (key_op->op_type != OP_CONST)
8026 svp = cSVOPx_svp(key_op);
8027 key = SvPV_const(*svp, keylen);
8028 if (!hv_fetch(GvHV(*fields), key,
8029 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8031 Perl_croak(aTHX_ "No such class field \"%s\" "
8032 "in variable %s of type %s",
8033 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
8040 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
8044 /* check that RHS of sort is a single plain array */
8045 OP *oright = cUNOPo->op_first;
8046 if (!oright || oright->op_type != OP_PUSHMARK)
8049 /* reverse sort ... can be optimised. */
8050 if (!cUNOPo->op_sibling) {
8051 /* Nothing follows us on the list. */
8052 OP * const reverse = o->op_next;
8054 if (reverse->op_type == OP_REVERSE &&
8055 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
8056 OP * const pushmark = cUNOPx(reverse)->op_first;
8057 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
8058 && (cUNOPx(pushmark)->op_sibling == o)) {
8059 /* reverse -> pushmark -> sort */
8060 o->op_private |= OPpSORT_REVERSE;
8062 pushmark->op_next = oright->op_next;
8068 /* make @a = sort @a act in-place */
8072 oright = cUNOPx(oright)->op_sibling;
8075 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
8076 oright = cUNOPx(oright)->op_sibling;
8080 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
8081 || oright->op_next != o
8082 || (oright->op_private & OPpLVAL_INTRO)
8086 /* o2 follows the chain of op_nexts through the LHS of the
8087 * assign (if any) to the aassign op itself */
8089 if (!o2 || o2->op_type != OP_NULL)
8092 if (!o2 || o2->op_type != OP_PUSHMARK)
8095 if (o2 && o2->op_type == OP_GV)
8098 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
8099 || (o2->op_private & OPpLVAL_INTRO)
8104 if (!o2 || o2->op_type != OP_NULL)
8107 if (!o2 || o2->op_type != OP_AASSIGN
8108 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
8111 /* check that the sort is the first arg on RHS of assign */
8113 o2 = cUNOPx(o2)->op_first;
8114 if (!o2 || o2->op_type != OP_NULL)
8116 o2 = cUNOPx(o2)->op_first;
8117 if (!o2 || o2->op_type != OP_PUSHMARK)
8119 if (o2->op_sibling != o)
8122 /* check the array is the same on both sides */
8123 if (oleft->op_type == OP_RV2AV) {
8124 if (oright->op_type != OP_RV2AV
8125 || !cUNOPx(oright)->op_first
8126 || cUNOPx(oright)->op_first->op_type != OP_GV
8127 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
8128 cGVOPx_gv(cUNOPx(oright)->op_first)
8132 else if (oright->op_type != OP_PADAV
8133 || oright->op_targ != oleft->op_targ
8137 /* transfer MODishness etc from LHS arg to RHS arg */
8138 oright->op_flags = oleft->op_flags;
8139 o->op_private |= OPpSORT_INPLACE;
8141 /* excise push->gv->rv2av->null->aassign */
8142 o2 = o->op_next->op_next;
8143 op_null(o2); /* PUSHMARK */
8145 if (o2->op_type == OP_GV) {
8146 op_null(o2); /* GV */
8149 op_null(o2); /* RV2AV or PADAV */
8150 o2 = o2->op_next->op_next;
8151 op_null(o2); /* AASSIGN */
8153 o->op_next = o2->op_next;
8159 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
8161 LISTOP *enter, *exlist;
8164 enter = (LISTOP *) o->op_next;
8167 if (enter->op_type == OP_NULL) {
8168 enter = (LISTOP *) enter->op_next;
8172 /* for $a (...) will have OP_GV then OP_RV2GV here.
8173 for (...) just has an OP_GV. */
8174 if (enter->op_type == OP_GV) {
8175 gvop = (OP *) enter;
8176 enter = (LISTOP *) enter->op_next;
8179 if (enter->op_type == OP_RV2GV) {
8180 enter = (LISTOP *) enter->op_next;
8186 if (enter->op_type != OP_ENTERITER)
8189 iter = enter->op_next;
8190 if (!iter || iter->op_type != OP_ITER)
8193 expushmark = enter->op_first;
8194 if (!expushmark || expushmark->op_type != OP_NULL
8195 || expushmark->op_targ != OP_PUSHMARK)
8198 exlist = (LISTOP *) expushmark->op_sibling;
8199 if (!exlist || exlist->op_type != OP_NULL
8200 || exlist->op_targ != OP_LIST)
8203 if (exlist->op_last != o) {
8204 /* Mmm. Was expecting to point back to this op. */
8207 theirmark = exlist->op_first;
8208 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
8211 if (theirmark->op_sibling != o) {
8212 /* There's something between the mark and the reverse, eg
8213 for (1, reverse (...))
8218 ourmark = ((LISTOP *)o)->op_first;
8219 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
8222 ourlast = ((LISTOP *)o)->op_last;
8223 if (!ourlast || ourlast->op_next != o)
8226 rv2av = ourmark->op_sibling;
8227 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
8228 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
8229 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
8230 /* We're just reversing a single array. */
8231 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
8232 enter->op_flags |= OPf_STACKED;
8235 /* We don't have control over who points to theirmark, so sacrifice
8237 theirmark->op_next = ourmark->op_next;
8238 theirmark->op_flags = ourmark->op_flags;
8239 ourlast->op_next = gvop ? gvop : (OP *) enter;
8242 enter->op_private |= OPpITER_REVERSED;
8243 iter->op_private |= OPpITER_REVERSED;
8250 UNOP *refgen, *rv2cv;
8253 /* I do not understand this, but if o->op_opt isn't set to 1,
8254 various tests in ext/B/t/bytecode.t fail with no readily
8260 if ((o->op_flags && OPf_WANT) != OPf_WANT_VOID)
8263 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
8266 rv2gv = ((BINOP *)o)->op_last;
8267 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
8270 refgen = (UNOP *)((BINOP *)o)->op_first;
8272 if (!refgen || refgen->op_type != OP_REFGEN)
8275 exlist = (LISTOP *)refgen->op_first;
8276 if (!exlist || exlist->op_type != OP_NULL
8277 || exlist->op_targ != OP_LIST)
8280 if (exlist->op_first->op_type != OP_PUSHMARK)
8283 rv2cv = (UNOP*)exlist->op_last;
8285 if (rv2cv->op_type != OP_RV2CV)
8288 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
8289 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
8290 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
8292 o->op_private |= OPpASSIGN_CV_TO_GV;
8293 rv2gv->op_private |= OPpDONT_INIT_GV;
8294 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
8310 Perl_custom_op_name(pTHX_ const OP* o)
8313 const IV index = PTR2IV(o->op_ppaddr);
8317 if (!PL_custom_op_names) /* This probably shouldn't happen */
8318 return (char *)PL_op_name[OP_CUSTOM];
8320 keysv = sv_2mortal(newSViv(index));
8322 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
8324 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
8326 return SvPV_nolen(HeVAL(he));
8330 Perl_custom_op_desc(pTHX_ const OP* o)
8333 const IV index = PTR2IV(o->op_ppaddr);
8337 if (!PL_custom_op_descs)
8338 return (char *)PL_op_desc[OP_CUSTOM];
8340 keysv = sv_2mortal(newSViv(index));
8342 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
8344 return (char *)PL_op_desc[OP_CUSTOM];
8346 return SvPV_nolen(HeVAL(he));
8351 /* Efficient sub that returns a constant scalar value. */
8353 const_sv_xsub(pTHX_ CV* cv)
8360 Perl_croak(aTHX_ "usage: %s::%s()",
8361 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
8365 ST(0) = (SV*)XSANY.any_ptr;
8371 * c-indentation-style: bsd
8373 * indent-tabs-mode: t
8376 * ex: set ts=8 sts=4 sw=4 noet: