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;
2829 SV * const rstr = (repl->op_type == OP_NULL)
2830 ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv
2831 : ((SVOP*)repl)->op_sv;
2834 const U8 *t = (U8*)SvPV_const(tstr, tlen);
2835 const U8 *r = (U8*)SvPV_const(rstr, rlen);
2839 register short *tbl;
2841 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
2842 const I32 squash = o->op_private & OPpTRANS_SQUASH;
2843 I32 del = o->op_private & OPpTRANS_DELETE;
2844 PL_hints |= HINT_BLOCK_SCOPE;
2847 o->op_private |= OPpTRANS_FROM_UTF;
2850 o->op_private |= OPpTRANS_TO_UTF;
2852 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2853 SV* const listsv = newSVpvs("# comment\n");
2855 const U8* tend = t + tlen;
2856 const U8* rend = r + rlen;
2870 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2871 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2874 const U32 flags = UTF8_ALLOW_DEFAULT;
2878 t = tsave = bytes_to_utf8(t, &len);
2881 if (!to_utf && rlen) {
2883 r = rsave = bytes_to_utf8(r, &len);
2887 /* There are several snags with this code on EBCDIC:
2888 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2889 2. scan_const() in toke.c has encoded chars in native encoding which makes
2890 ranges at least in EBCDIC 0..255 range the bottom odd.
2894 U8 tmpbuf[UTF8_MAXBYTES+1];
2897 Newx(cp, 2*tlen, UV);
2899 transv = newSVpvs("");
2901 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
2903 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2905 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
2909 cp[2*i+1] = cp[2*i];
2913 qsort(cp, i, 2*sizeof(UV), uvcompare);
2914 for (j = 0; j < i; j++) {
2916 diff = val - nextmin;
2918 t = uvuni_to_utf8(tmpbuf,nextmin);
2919 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2921 U8 range_mark = UTF_TO_NATIVE(0xff);
2922 t = uvuni_to_utf8(tmpbuf, val - 1);
2923 sv_catpvn(transv, (char *)&range_mark, 1);
2924 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2931 t = uvuni_to_utf8(tmpbuf,nextmin);
2932 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2934 U8 range_mark = UTF_TO_NATIVE(0xff);
2935 sv_catpvn(transv, (char *)&range_mark, 1);
2937 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2938 UNICODE_ALLOW_SUPER);
2939 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2940 t = (const U8*)SvPVX_const(transv);
2941 tlen = SvCUR(transv);
2945 else if (!rlen && !del) {
2946 r = t; rlen = tlen; rend = tend;
2949 if ((!rlen && !del) || t == r ||
2950 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2952 o->op_private |= OPpTRANS_IDENTICAL;
2956 while (t < tend || tfirst <= tlast) {
2957 /* see if we need more "t" chars */
2958 if (tfirst > tlast) {
2959 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
2961 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2963 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
2970 /* now see if we need more "r" chars */
2971 if (rfirst > rlast) {
2973 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
2975 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2977 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
2986 rfirst = rlast = 0xffffffff;
2990 /* now see which range will peter our first, if either. */
2991 tdiff = tlast - tfirst;
2992 rdiff = rlast - rfirst;
2999 if (rfirst == 0xffffffff) {
3000 diff = tdiff; /* oops, pretend rdiff is infinite */
3002 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
3003 (long)tfirst, (long)tlast);
3005 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
3009 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
3010 (long)tfirst, (long)(tfirst + diff),
3013 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3014 (long)tfirst, (long)rfirst);
3016 if (rfirst + diff > max)
3017 max = rfirst + diff;
3019 grows = (tfirst < rfirst &&
3020 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3032 else if (max > 0xff)
3037 Safefree(cPVOPo->op_pv);
3038 cPVOPo->op_pv = NULL;
3039 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
3040 SvREFCNT_dec(listsv);
3041 SvREFCNT_dec(transv);
3043 if (!del && havefinal && rlen)
3044 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
3045 newSVuv((UV)final), 0);
3048 o->op_private |= OPpTRANS_GROWS;
3054 op_getmad(expr,o,'e');
3055 op_getmad(repl,o,'r');
3063 tbl = (short*)cPVOPo->op_pv;
3065 Zero(tbl, 256, short);
3066 for (i = 0; i < (I32)tlen; i++)
3068 for (i = 0, j = 0; i < 256; i++) {
3070 if (j >= (I32)rlen) {
3079 if (i < 128 && r[j] >= 128)
3089 o->op_private |= OPpTRANS_IDENTICAL;
3091 else if (j >= (I32)rlen)
3094 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
3095 tbl[0x100] = (short)(rlen - j);
3096 for (i=0; i < (I32)rlen - j; i++)
3097 tbl[0x101+i] = r[j+i];
3101 if (!rlen && !del) {
3104 o->op_private |= OPpTRANS_IDENTICAL;
3106 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3107 o->op_private |= OPpTRANS_IDENTICAL;
3109 for (i = 0; i < 256; i++)
3111 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3112 if (j >= (I32)rlen) {
3114 if (tbl[t[i]] == -1)
3120 if (tbl[t[i]] == -1) {
3121 if (t[i] < 128 && r[j] >= 128)
3128 o->op_private |= OPpTRANS_GROWS;
3130 op_getmad(expr,o,'e');
3131 op_getmad(repl,o,'r');
3141 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3146 NewOp(1101, pmop, 1, PMOP);
3147 pmop->op_type = (OPCODE)type;
3148 pmop->op_ppaddr = PL_ppaddr[type];
3149 pmop->op_flags = (U8)flags;
3150 pmop->op_private = (U8)(0 | (flags >> 8));
3152 if (PL_hints & HINT_RE_TAINT)
3153 pmop->op_pmpermflags |= PMf_RETAINT;
3154 if (PL_hints & HINT_LOCALE)
3155 pmop->op_pmpermflags |= PMf_LOCALE;
3156 pmop->op_pmflags = pmop->op_pmpermflags;
3159 if (av_len((AV*) PL_regex_pad[0]) > -1) {
3160 SV * const repointer = av_pop((AV*)PL_regex_pad[0]);
3161 pmop->op_pmoffset = SvIV(repointer);
3162 SvREPADTMP_off(repointer);
3163 sv_setiv(repointer,0);
3165 SV * const repointer = newSViv(0);
3166 av_push(PL_regex_padav, SvREFCNT_inc_simple_NN(repointer));
3167 pmop->op_pmoffset = av_len(PL_regex_padav);
3168 PL_regex_pad = AvARRAY(PL_regex_padav);
3172 /* link into pm list */
3173 if (type != OP_TRANS && PL_curstash) {
3174 MAGIC *mg = mg_find((SV*)PL_curstash, PERL_MAGIC_symtab);
3177 mg = sv_magicext((SV*)PL_curstash, 0, PERL_MAGIC_symtab, 0, 0, 0);
3179 pmop->op_pmnext = (PMOP*)mg->mg_obj;
3180 mg->mg_obj = (SV*)pmop;
3181 PmopSTASH_set(pmop,PL_curstash);
3184 return CHECKOP(type, pmop);
3187 /* Given some sort of match op o, and an expression expr containing a
3188 * pattern, either compile expr into a regex and attach it to o (if it's
3189 * constant), or convert expr into a runtime regcomp op sequence (if it's
3192 * isreg indicates that the pattern is part of a regex construct, eg
3193 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3194 * split "pattern", which aren't. In the former case, expr will be a list
3195 * if the pattern contains more than one term (eg /a$b/) or if it contains
3196 * a replacement, ie s/// or tr///.
3200 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
3205 I32 repl_has_vars = 0;
3209 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
3210 /* last element in list is the replacement; pop it */
3212 repl = cLISTOPx(expr)->op_last;
3213 kid = cLISTOPx(expr)->op_first;
3214 while (kid->op_sibling != repl)
3215 kid = kid->op_sibling;
3216 kid->op_sibling = NULL;
3217 cLISTOPx(expr)->op_last = kid;
3220 if (isreg && expr->op_type == OP_LIST &&
3221 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3223 /* convert single element list to element */
3224 OP* const oe = expr;
3225 expr = cLISTOPx(oe)->op_first->op_sibling;
3226 cLISTOPx(oe)->op_first->op_sibling = NULL;
3227 cLISTOPx(oe)->op_last = NULL;
3231 if (o->op_type == OP_TRANS) {
3232 return pmtrans(o, expr, repl);
3235 reglist = isreg && expr->op_type == OP_LIST;
3239 PL_hints |= HINT_BLOCK_SCOPE;
3242 if (expr->op_type == OP_CONST) {
3244 SV * const pat = ((SVOP*)expr)->op_sv;
3245 const char *p = SvPV_const(pat, plen);
3246 if ((o->op_flags & OPf_SPECIAL) && (*p == ' ' && p[1] == '\0')) {
3247 U32 was_readonly = SvREADONLY(pat);
3251 sv_force_normal_flags(pat, 0);
3252 assert(!SvREADONLY(pat));
3255 SvREADONLY_off(pat);
3259 sv_setpvn(pat, "\\s+", 3);
3261 SvFLAGS(pat) |= was_readonly;
3263 p = SvPV_const(pat, plen);
3264 pm->op_pmflags |= PMf_SKIPWHITE;
3267 pm->op_pmdynflags |= PMdf_UTF8;
3268 /* FIXME - can we make this function take const char * args? */
3269 PM_SETRE(pm, CALLREGCOMP((char*)p, (char*)p + plen, pm));
3270 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
3271 pm->op_pmflags |= PMf_WHITE;
3273 op_getmad(expr,(OP*)pm,'e');
3279 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3280 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3282 : OP_REGCMAYBE),0,expr);
3284 NewOp(1101, rcop, 1, LOGOP);
3285 rcop->op_type = OP_REGCOMP;
3286 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3287 rcop->op_first = scalar(expr);
3288 rcop->op_flags |= OPf_KIDS
3289 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3290 | (reglist ? OPf_STACKED : 0);
3291 rcop->op_private = 1;
3294 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3296 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
3299 /* establish postfix order */
3300 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3302 rcop->op_next = expr;
3303 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3306 rcop->op_next = LINKLIST(expr);
3307 expr->op_next = (OP*)rcop;
3310 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3315 if (pm->op_pmflags & PMf_EVAL) {
3317 if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
3318 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
3320 else if (repl->op_type == OP_CONST)
3324 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3325 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3326 if (curop->op_type == OP_GV) {
3327 GV * const gv = cGVOPx_gv(curop);
3329 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3332 else if (curop->op_type == OP_RV2CV)
3334 else if (curop->op_type == OP_RV2SV ||
3335 curop->op_type == OP_RV2AV ||
3336 curop->op_type == OP_RV2HV ||
3337 curop->op_type == OP_RV2GV) {
3338 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3341 else if (curop->op_type == OP_PADSV ||
3342 curop->op_type == OP_PADAV ||
3343 curop->op_type == OP_PADHV ||
3344 curop->op_type == OP_PADANY) {
3347 else if (curop->op_type == OP_PUSHRE)
3348 NOOP; /* Okay here, dangerous in newASSIGNOP */
3358 || PM_GETRE(pm)->extflags & RXf_EVAL_SEEN))) {
3359 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3360 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
3361 prepend_elem(o->op_type, scalar(repl), o);
3364 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3365 pm->op_pmflags |= PMf_MAYBE_CONST;
3366 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3368 NewOp(1101, rcop, 1, LOGOP);
3369 rcop->op_type = OP_SUBSTCONT;
3370 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3371 rcop->op_first = scalar(repl);
3372 rcop->op_flags |= OPf_KIDS;
3373 rcop->op_private = 1;
3376 /* establish postfix order */
3377 rcop->op_next = LINKLIST(repl);
3378 repl->op_next = (OP*)rcop;
3380 pm->op_pmreplroot = scalar((OP*)rcop);
3381 pm->op_pmreplstart = LINKLIST(rcop);
3390 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3394 NewOp(1101, svop, 1, SVOP);
3395 svop->op_type = (OPCODE)type;
3396 svop->op_ppaddr = PL_ppaddr[type];
3398 svop->op_next = (OP*)svop;
3399 svop->op_flags = (U8)flags;
3400 if (PL_opargs[type] & OA_RETSCALAR)
3402 if (PL_opargs[type] & OA_TARGET)
3403 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3404 return CHECKOP(type, svop);
3408 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3412 NewOp(1101, padop, 1, PADOP);
3413 padop->op_type = (OPCODE)type;
3414 padop->op_ppaddr = PL_ppaddr[type];
3415 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3416 SvREFCNT_dec(PAD_SVl(padop->op_padix));
3417 PAD_SETSV(padop->op_padix, sv);
3420 padop->op_next = (OP*)padop;
3421 padop->op_flags = (U8)flags;
3422 if (PL_opargs[type] & OA_RETSCALAR)
3424 if (PL_opargs[type] & OA_TARGET)
3425 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3426 return CHECKOP(type, padop);
3430 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3436 return newPADOP(type, flags, SvREFCNT_inc_simple(gv));
3438 return newSVOP(type, flags, SvREFCNT_inc_simple(gv));
3443 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3447 NewOp(1101, pvop, 1, PVOP);
3448 pvop->op_type = (OPCODE)type;
3449 pvop->op_ppaddr = PL_ppaddr[type];
3451 pvop->op_next = (OP*)pvop;
3452 pvop->op_flags = (U8)flags;
3453 if (PL_opargs[type] & OA_RETSCALAR)
3455 if (PL_opargs[type] & OA_TARGET)
3456 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3457 return CHECKOP(type, pvop);
3465 Perl_package(pTHX_ OP *o)
3474 save_hptr(&PL_curstash);
3475 save_item(PL_curstname);
3477 name = SvPV_const(cSVOPo->op_sv, len);
3478 PL_curstash = gv_stashpvn(name, len, TRUE);
3479 sv_setpvn(PL_curstname, name, len);
3481 PL_hints |= HINT_BLOCK_SCOPE;
3482 PL_copline = NOLINE;
3488 if (!PL_madskills) {
3493 pegop = newOP(OP_NULL,0);
3494 op_getmad(o,pegop,'P');
3504 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3511 OP *pegop = newOP(OP_NULL,0);
3514 if (idop->op_type != OP_CONST)
3515 Perl_croak(aTHX_ "Module name must be constant");
3518 op_getmad(idop,pegop,'U');
3523 SV * const vesv = ((SVOP*)version)->op_sv;
3526 op_getmad(version,pegop,'V');
3527 if (!arg && !SvNIOKp(vesv)) {
3534 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3535 Perl_croak(aTHX_ "Version number must be constant number");
3537 /* Make copy of idop so we don't free it twice */
3538 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3540 /* Fake up a method call to VERSION */
3541 meth = newSVpvs_share("VERSION");
3542 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3543 append_elem(OP_LIST,
3544 prepend_elem(OP_LIST, pack, list(version)),
3545 newSVOP(OP_METHOD_NAMED, 0, meth)));
3549 /* Fake up an import/unimport */
3550 if (arg && arg->op_type == OP_STUB) {
3552 op_getmad(arg,pegop,'S');
3553 imop = arg; /* no import on explicit () */
3555 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3556 imop = NULL; /* use 5.0; */
3558 idop->op_private |= OPpCONST_NOVER;
3564 op_getmad(arg,pegop,'A');
3566 /* Make copy of idop so we don't free it twice */
3567 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3569 /* Fake up a method call to import/unimport */
3571 ? newSVpvs_share("import") : newSVpvs_share("unimport");
3572 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3573 append_elem(OP_LIST,
3574 prepend_elem(OP_LIST, pack, list(arg)),
3575 newSVOP(OP_METHOD_NAMED, 0, meth)));
3578 /* Fake up the BEGIN {}, which does its thing immediately. */
3580 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
3583 append_elem(OP_LINESEQ,
3584 append_elem(OP_LINESEQ,
3585 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
3586 newSTATEOP(0, NULL, veop)),
3587 newSTATEOP(0, NULL, imop) ));
3589 /* The "did you use incorrect case?" warning used to be here.
3590 * The problem is that on case-insensitive filesystems one
3591 * might get false positives for "use" (and "require"):
3592 * "use Strict" or "require CARP" will work. This causes
3593 * portability problems for the script: in case-strict
3594 * filesystems the script will stop working.
3596 * The "incorrect case" warning checked whether "use Foo"
3597 * imported "Foo" to your namespace, but that is wrong, too:
3598 * there is no requirement nor promise in the language that
3599 * a Foo.pm should or would contain anything in package "Foo".
3601 * There is very little Configure-wise that can be done, either:
3602 * the case-sensitivity of the build filesystem of Perl does not
3603 * help in guessing the case-sensitivity of the runtime environment.
3606 PL_hints |= HINT_BLOCK_SCOPE;
3607 PL_copline = NOLINE;
3609 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3612 if (!PL_madskills) {
3613 /* FIXME - don't allocate pegop if !PL_madskills */
3622 =head1 Embedding Functions
3624 =for apidoc load_module
3626 Loads the module whose name is pointed to by the string part of name.
3627 Note that the actual module name, not its filename, should be given.
3628 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3629 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3630 (or 0 for no flags). ver, if specified, provides version semantics
3631 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3632 arguments can be used to specify arguments to the module's import()
3633 method, similar to C<use Foo::Bar VERSION LIST>.
3638 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3641 va_start(args, ver);
3642 vload_module(flags, name, ver, &args);
3646 #ifdef PERL_IMPLICIT_CONTEXT
3648 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3652 va_start(args, ver);
3653 vload_module(flags, name, ver, &args);
3659 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3664 OP * const modname = newSVOP(OP_CONST, 0, name);
3665 modname->op_private |= OPpCONST_BARE;
3667 veop = newSVOP(OP_CONST, 0, ver);
3671 if (flags & PERL_LOADMOD_NOIMPORT) {
3672 imop = sawparens(newNULLLIST());
3674 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3675 imop = va_arg(*args, OP*);
3680 sv = va_arg(*args, SV*);
3682 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3683 sv = va_arg(*args, SV*);
3687 const line_t ocopline = PL_copline;
3688 COP * const ocurcop = PL_curcop;
3689 const int oexpect = PL_expect;
3691 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3692 veop, modname, imop);
3693 PL_expect = oexpect;
3694 PL_copline = ocopline;
3695 PL_curcop = ocurcop;
3700 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
3706 if (!force_builtin) {
3707 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
3708 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
3709 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
3710 gv = gvp ? *gvp : NULL;
3714 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3715 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3716 append_elem(OP_LIST, term,
3717 scalar(newUNOP(OP_RV2CV, 0,
3718 newGVOP(OP_GV, 0, gv))))));
3721 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3727 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3729 return newBINOP(OP_LSLICE, flags,
3730 list(force_list(subscript)),
3731 list(force_list(listval)) );
3735 S_is_list_assignment(pTHX_ register const OP *o)
3743 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
3744 o = cUNOPo->op_first;
3746 flags = o->op_flags;
3748 if (type == OP_COND_EXPR) {
3749 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
3750 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3755 yyerror("Assignment to both a list and a scalar");
3759 if (type == OP_LIST &&
3760 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
3761 o->op_private & OPpLVAL_INTRO)
3764 if (type == OP_LIST || flags & OPf_PARENS ||
3765 type == OP_RV2AV || type == OP_RV2HV ||
3766 type == OP_ASLICE || type == OP_HSLICE)
3769 if (type == OP_PADAV || type == OP_PADHV)
3772 if (type == OP_RV2SV)
3779 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3785 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3786 return newLOGOP(optype, 0,
3787 mod(scalar(left), optype),
3788 newUNOP(OP_SASSIGN, 0, scalar(right)));
3791 return newBINOP(optype, OPf_STACKED,
3792 mod(scalar(left), optype), scalar(right));
3796 if (is_list_assignment(left)) {
3800 /* Grandfathering $[ assignment here. Bletch.*/
3801 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
3802 PL_eval_start = (left->op_type == OP_CONST) ? right : 0;
3803 left = mod(left, OP_AASSIGN);
3806 else if (left->op_type == OP_CONST) {
3808 /* Result of assignment is always 1 (or we'd be dead already) */
3809 return newSVOP(OP_CONST, 0, newSViv(1));
3811 curop = list(force_list(left));
3812 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3813 o->op_private = (U8)(0 | (flags >> 8));
3815 /* PL_generation sorcery:
3816 * an assignment like ($a,$b) = ($c,$d) is easier than
3817 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3818 * To detect whether there are common vars, the global var
3819 * PL_generation is incremented for each assign op we compile.
3820 * Then, while compiling the assign op, we run through all the
3821 * variables on both sides of the assignment, setting a spare slot
3822 * in each of them to PL_generation. If any of them already have
3823 * that value, we know we've got commonality. We could use a
3824 * single bit marker, but then we'd have to make 2 passes, first
3825 * to clear the flag, then to test and set it. To find somewhere
3826 * to store these values, evil chicanery is done with SvCUR().
3832 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3833 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3834 if (curop->op_type == OP_GV) {
3835 GV *gv = cGVOPx_gv(curop);
3837 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
3839 GvASSIGN_GENERATION_set(gv, PL_generation);
3841 else if (curop->op_type == OP_PADSV ||
3842 curop->op_type == OP_PADAV ||
3843 curop->op_type == OP_PADHV ||
3844 curop->op_type == OP_PADANY)
3846 if (PAD_COMPNAME_GEN(curop->op_targ)
3847 == (STRLEN)PL_generation)
3849 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
3852 else if (curop->op_type == OP_RV2CV)
3854 else if (curop->op_type == OP_RV2SV ||
3855 curop->op_type == OP_RV2AV ||
3856 curop->op_type == OP_RV2HV ||
3857 curop->op_type == OP_RV2GV) {
3858 if (lastop->op_type != OP_GV) /* funny deref? */
3861 else if (curop->op_type == OP_PUSHRE) {
3862 if (((PMOP*)curop)->op_pmreplroot) {
3864 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3865 ((PMOP*)curop)->op_pmreplroot));
3867 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3870 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
3872 GvASSIGN_GENERATION_set(gv, PL_generation);
3873 GvASSIGN_GENERATION_set(gv, PL_generation);
3882 o->op_private |= OPpASSIGN_COMMON;
3885 if ( ((left->op_private & OPpLVAL_INTRO) || ckWARN(WARN_MISC))
3886 && (left->op_type == OP_LIST
3887 || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
3889 OP* lop = ((LISTOP*)left)->op_first;
3891 if (lop->op_type == OP_PADSV ||
3892 lop->op_type == OP_PADAV ||
3893 lop->op_type == OP_PADHV ||
3894 lop->op_type == OP_PADANY)
3896 if (lop->op_private & OPpPAD_STATE) {
3897 if (left->op_private & OPpLVAL_INTRO) {
3898 o->op_private |= OPpASSIGN_STATE;
3899 /* hijacking PADSTALE for uninitialized state variables */
3900 SvPADSTALE_on(PAD_SVl(lop->op_targ));
3902 else { /* we already checked for WARN_MISC before */
3903 Perl_warner(aTHX_ packWARN(WARN_MISC), "State variable %s will be reinitialized",
3904 PAD_COMPNAME_PV(lop->op_targ));
3908 lop = lop->op_sibling;
3912 if (right && right->op_type == OP_SPLIT) {
3913 OP* tmpop = ((LISTOP*)right)->op_first;
3914 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
3915 PMOP * const pm = (PMOP*)tmpop;
3916 if (left->op_type == OP_RV2AV &&
3917 !(left->op_private & OPpLVAL_INTRO) &&
3918 !(o->op_private & OPpASSIGN_COMMON) )
3920 tmpop = ((UNOP*)left)->op_first;
3921 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3923 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3924 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3926 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3927 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
3929 pm->op_pmflags |= PMf_ONCE;
3930 tmpop = cUNOPo->op_first; /* to list (nulled) */
3931 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3932 tmpop->op_sibling = NULL; /* don't free split */
3933 right->op_next = tmpop->op_next; /* fix starting loc */
3935 op_getmad(o,right,'R'); /* blow off assign */
3937 op_free(o); /* blow off assign */
3939 right->op_flags &= ~OPf_WANT;
3940 /* "I don't know and I don't care." */
3945 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3946 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3948 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3950 sv_setiv(sv, PL_modcount+1);
3958 right = newOP(OP_UNDEF, 0);
3959 if (right->op_type == OP_READLINE) {
3960 right->op_flags |= OPf_STACKED;
3961 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3964 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3965 o = newBINOP(OP_SASSIGN, flags,
3966 scalar(right), mod(scalar(left), OP_SASSIGN) );
3972 o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
3973 o->op_private |= OPpCONST_ARYBASE;
3980 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3983 const U32 seq = intro_my();
3986 NewOp(1101, cop, 1, COP);
3987 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3988 cop->op_type = OP_DBSTATE;
3989 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3992 cop->op_type = OP_NEXTSTATE;
3993 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3995 cop->op_flags = (U8)flags;
3996 CopHINTS_set(cop, PL_hints);
3998 cop->op_private |= NATIVE_HINTS;
4000 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
4001 cop->op_next = (OP*)cop;
4004 cop->cop_label = label;
4005 PL_hints |= HINT_BLOCK_SCOPE;
4008 /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
4009 CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
4011 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
4012 cop->cop_hints_hash = PL_curcop->cop_hints_hash;
4013 if (cop->cop_hints_hash) {
4015 cop->cop_hints_hash->refcounted_he_refcnt++;
4016 HINTS_REFCNT_UNLOCK;
4019 if (PL_copline == NOLINE)
4020 CopLINE_set(cop, CopLINE(PL_curcop));
4022 CopLINE_set(cop, PL_copline);
4023 PL_copline = NOLINE;
4026 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
4028 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
4030 CopSTASH_set(cop, PL_curstash);
4032 if (PERLDB_LINE && PL_curstash != PL_debstash) {
4033 AV *av = CopFILEAVx(PL_curcop);
4035 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
4036 if (svp && *svp != &PL_sv_undef ) {
4037 (void)SvIOK_on(*svp);
4038 SvIV_set(*svp, PTR2IV(cop));
4043 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
4048 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
4051 return new_logop(type, flags, &first, &other);
4055 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
4060 OP *first = *firstp;
4061 OP * const other = *otherp;
4063 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
4064 return newBINOP(type, flags, scalar(first), scalar(other));
4066 scalarboolean(first);
4067 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
4068 if (first->op_type == OP_NOT
4069 && (first->op_flags & OPf_SPECIAL)
4070 && (first->op_flags & OPf_KIDS)) {
4071 if (type == OP_AND || type == OP_OR) {
4077 first = *firstp = cUNOPo->op_first;
4079 first->op_next = o->op_next;
4080 cUNOPo->op_first = NULL;
4082 op_getmad(o,first,'O');
4088 if (first->op_type == OP_CONST) {
4089 if (first->op_private & OPpCONST_STRICT)
4090 no_bareword_allowed(first);
4091 else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
4092 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
4093 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
4094 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
4095 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
4097 if (other->op_type == OP_CONST)
4098 other->op_private |= OPpCONST_SHORTCIRCUIT;
4100 OP *newop = newUNOP(OP_NULL, 0, other);
4101 op_getmad(first, newop, '1');
4102 newop->op_targ = type; /* set "was" field */
4109 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
4110 const OP *o2 = other;
4111 if ( ! (o2->op_type == OP_LIST
4112 && (( o2 = cUNOPx(o2)->op_first))
4113 && o2->op_type == OP_PUSHMARK
4114 && (( o2 = o2->op_sibling)) )
4117 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
4118 || o2->op_type == OP_PADHV)
4119 && o2->op_private & OPpLVAL_INTRO
4120 && ckWARN(WARN_DEPRECATED))
4122 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4123 "Deprecated use of my() in false conditional");
4127 if (first->op_type == OP_CONST)
4128 first->op_private |= OPpCONST_SHORTCIRCUIT;
4130 first = newUNOP(OP_NULL, 0, first);
4131 op_getmad(other, first, '2');
4132 first->op_targ = type; /* set "was" field */
4139 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
4140 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
4142 const OP * const k1 = ((UNOP*)first)->op_first;
4143 const OP * const k2 = k1->op_sibling;
4145 switch (first->op_type)
4148 if (k2 && k2->op_type == OP_READLINE
4149 && (k2->op_flags & OPf_STACKED)
4150 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4152 warnop = k2->op_type;
4157 if (k1->op_type == OP_READDIR
4158 || k1->op_type == OP_GLOB
4159 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4160 || k1->op_type == OP_EACH)
4162 warnop = ((k1->op_type == OP_NULL)
4163 ? (OPCODE)k1->op_targ : k1->op_type);
4168 const line_t oldline = CopLINE(PL_curcop);
4169 CopLINE_set(PL_curcop, PL_copline);
4170 Perl_warner(aTHX_ packWARN(WARN_MISC),
4171 "Value of %s%s can be \"0\"; test with defined()",
4173 ((warnop == OP_READLINE || warnop == OP_GLOB)
4174 ? " construct" : "() operator"));
4175 CopLINE_set(PL_curcop, oldline);
4182 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
4183 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
4185 NewOp(1101, logop, 1, LOGOP);
4187 logop->op_type = (OPCODE)type;
4188 logop->op_ppaddr = PL_ppaddr[type];
4189 logop->op_first = first;
4190 logop->op_flags = (U8)(flags | OPf_KIDS);
4191 logop->op_other = LINKLIST(other);
4192 logop->op_private = (U8)(1 | (flags >> 8));
4194 /* establish postfix order */
4195 logop->op_next = LINKLIST(first);
4196 first->op_next = (OP*)logop;
4197 first->op_sibling = other;
4199 CHECKOP(type,logop);
4201 o = newUNOP(OP_NULL, 0, (OP*)logop);
4208 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
4216 return newLOGOP(OP_AND, 0, first, trueop);
4218 return newLOGOP(OP_OR, 0, first, falseop);
4220 scalarboolean(first);
4221 if (first->op_type == OP_CONST) {
4222 if (first->op_private & OPpCONST_BARE &&
4223 first->op_private & OPpCONST_STRICT) {
4224 no_bareword_allowed(first);
4226 if (SvTRUE(((SVOP*)first)->op_sv)) {
4229 trueop = newUNOP(OP_NULL, 0, trueop);
4230 op_getmad(first,trueop,'C');
4231 op_getmad(falseop,trueop,'e');
4233 /* FIXME for MAD - should there be an ELSE here? */
4243 falseop = newUNOP(OP_NULL, 0, falseop);
4244 op_getmad(first,falseop,'C');
4245 op_getmad(trueop,falseop,'t');
4247 /* FIXME for MAD - should there be an ELSE here? */
4255 NewOp(1101, logop, 1, LOGOP);
4256 logop->op_type = OP_COND_EXPR;
4257 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4258 logop->op_first = first;
4259 logop->op_flags = (U8)(flags | OPf_KIDS);
4260 logop->op_private = (U8)(1 | (flags >> 8));
4261 logop->op_other = LINKLIST(trueop);
4262 logop->op_next = LINKLIST(falseop);
4264 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
4267 /* establish postfix order */
4268 start = LINKLIST(first);
4269 first->op_next = (OP*)logop;
4271 first->op_sibling = trueop;
4272 trueop->op_sibling = falseop;
4273 o = newUNOP(OP_NULL, 0, (OP*)logop);
4275 trueop->op_next = falseop->op_next = o;
4282 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4291 NewOp(1101, range, 1, LOGOP);
4293 range->op_type = OP_RANGE;
4294 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4295 range->op_first = left;
4296 range->op_flags = OPf_KIDS;
4297 leftstart = LINKLIST(left);
4298 range->op_other = LINKLIST(right);
4299 range->op_private = (U8)(1 | (flags >> 8));
4301 left->op_sibling = right;
4303 range->op_next = (OP*)range;
4304 flip = newUNOP(OP_FLIP, flags, (OP*)range);
4305 flop = newUNOP(OP_FLOP, 0, flip);
4306 o = newUNOP(OP_NULL, 0, flop);
4308 range->op_next = leftstart;
4310 left->op_next = flip;
4311 right->op_next = flop;
4313 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4314 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4315 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4316 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4318 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4319 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4322 if (!flip->op_private || !flop->op_private)
4323 linklist(o); /* blow off optimizer unless constant */
4329 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4334 const bool once = block && block->op_flags & OPf_SPECIAL &&
4335 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4337 PERL_UNUSED_ARG(debuggable);
4340 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4341 return block; /* do {} while 0 does once */
4342 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4343 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4344 expr = newUNOP(OP_DEFINED, 0,
4345 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4346 } else if (expr->op_flags & OPf_KIDS) {
4347 const OP * const k1 = ((UNOP*)expr)->op_first;
4348 const OP * const k2 = k1 ? k1->op_sibling : NULL;
4349 switch (expr->op_type) {
4351 if (k2 && k2->op_type == OP_READLINE
4352 && (k2->op_flags & OPf_STACKED)
4353 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4354 expr = newUNOP(OP_DEFINED, 0, expr);
4358 if (k1 && (k1->op_type == OP_READDIR
4359 || k1->op_type == OP_GLOB
4360 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4361 || k1->op_type == OP_EACH))
4362 expr = newUNOP(OP_DEFINED, 0, expr);
4368 /* if block is null, the next append_elem() would put UNSTACK, a scalar
4369 * op, in listop. This is wrong. [perl #27024] */
4371 block = newOP(OP_NULL, 0);
4372 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4373 o = new_logop(OP_AND, 0, &expr, &listop);
4376 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4378 if (once && o != listop)
4379 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4382 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
4384 o->op_flags |= flags;
4386 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4391 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
4392 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
4401 PERL_UNUSED_ARG(debuggable);
4404 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4405 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4406 expr = newUNOP(OP_DEFINED, 0,
4407 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4408 } else if (expr->op_flags & OPf_KIDS) {
4409 const OP * const k1 = ((UNOP*)expr)->op_first;
4410 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
4411 switch (expr->op_type) {
4413 if (k2 && k2->op_type == OP_READLINE
4414 && (k2->op_flags & OPf_STACKED)
4415 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4416 expr = newUNOP(OP_DEFINED, 0, expr);
4420 if (k1 && (k1->op_type == OP_READDIR
4421 || k1->op_type == OP_GLOB
4422 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4423 || k1->op_type == OP_EACH))
4424 expr = newUNOP(OP_DEFINED, 0, expr);
4431 block = newOP(OP_NULL, 0);
4432 else if (cont || has_my) {
4433 block = scope(block);
4437 next = LINKLIST(cont);
4440 OP * const unstack = newOP(OP_UNSTACK, 0);
4443 cont = append_elem(OP_LINESEQ, cont, unstack);
4447 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4449 redo = LINKLIST(listop);
4452 PL_copline = (line_t)whileline;
4454 o = new_logop(OP_AND, 0, &expr, &listop);
4455 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4456 op_free(expr); /* oops, it's a while (0) */
4458 return NULL; /* listop already freed by new_logop */
4461 ((LISTOP*)listop)->op_last->op_next =
4462 (o == listop ? redo : LINKLIST(o));
4468 NewOp(1101,loop,1,LOOP);
4469 loop->op_type = OP_ENTERLOOP;
4470 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4471 loop->op_private = 0;
4472 loop->op_next = (OP*)loop;
4475 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4477 loop->op_redoop = redo;
4478 loop->op_lastop = o;
4479 o->op_private |= loopflags;
4482 loop->op_nextop = next;
4484 loop->op_nextop = o;
4486 o->op_flags |= flags;
4487 o->op_private |= (flags >> 8);
4492 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
4497 PADOFFSET padoff = 0;
4503 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4504 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
4505 sv->op_type = OP_RV2GV;
4506 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4507 if (cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
4508 iterpflags |= OPpITER_DEF;
4510 else if (sv->op_type == OP_PADSV) { /* private variable */
4511 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
4512 padoff = sv->op_targ;
4521 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4522 padoff = sv->op_targ;
4527 iterflags |= OPf_SPECIAL;
4533 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4534 if (padoff && strEQ(PAD_COMPNAME_PV(padoff), "$_"))
4535 iterpflags |= OPpITER_DEF;
4538 const PADOFFSET offset = pad_findmy("$_");
4539 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
4540 sv = newGVOP(OP_GV, 0, PL_defgv);
4545 iterpflags |= OPpITER_DEF;
4547 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4548 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4549 iterflags |= OPf_STACKED;
4551 else if (expr->op_type == OP_NULL &&
4552 (expr->op_flags & OPf_KIDS) &&
4553 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4555 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4556 * set the STACKED flag to indicate that these values are to be
4557 * treated as min/max values by 'pp_iterinit'.
4559 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4560 LOGOP* const range = (LOGOP*) flip->op_first;
4561 OP* const left = range->op_first;
4562 OP* const right = left->op_sibling;
4565 range->op_flags &= ~OPf_KIDS;
4566 range->op_first = NULL;
4568 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4569 listop->op_first->op_next = range->op_next;
4570 left->op_next = range->op_other;
4571 right->op_next = (OP*)listop;
4572 listop->op_next = listop->op_first;
4575 op_getmad(expr,(OP*)listop,'O');
4579 expr = (OP*)(listop);
4581 iterflags |= OPf_STACKED;
4584 expr = mod(force_list(expr), OP_GREPSTART);
4587 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4588 append_elem(OP_LIST, expr, scalar(sv))));
4589 assert(!loop->op_next);
4590 /* for my $x () sets OPpLVAL_INTRO;
4591 * for our $x () sets OPpOUR_INTRO */
4592 loop->op_private = (U8)iterpflags;
4593 #ifdef PL_OP_SLAB_ALLOC
4596 NewOp(1234,tmp,1,LOOP);
4597 Copy(loop,tmp,1,LISTOP);
4598 S_op_destroy(aTHX_ (OP*)loop);
4602 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
4604 loop->op_targ = padoff;
4605 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
4607 op_getmad(madsv, (OP*)loop, 'v');
4608 PL_copline = forline;
4609 return newSTATEOP(0, label, wop);
4613 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4618 if (type != OP_GOTO || label->op_type == OP_CONST) {
4619 /* "last()" means "last" */
4620 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4621 o = newOP(type, OPf_SPECIAL);
4623 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4624 ? SvPVx_nolen_const(((SVOP*)label)->op_sv)
4628 op_getmad(label,o,'L');
4634 /* Check whether it's going to be a goto &function */
4635 if (label->op_type == OP_ENTERSUB
4636 && !(label->op_flags & OPf_STACKED))
4637 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4638 o = newUNOP(type, OPf_STACKED, label);
4640 PL_hints |= HINT_BLOCK_SCOPE;
4644 /* if the condition is a literal array or hash
4645 (or @{ ... } etc), make a reference to it.
4648 S_ref_array_or_hash(pTHX_ OP *cond)
4651 && (cond->op_type == OP_RV2AV
4652 || cond->op_type == OP_PADAV
4653 || cond->op_type == OP_RV2HV
4654 || cond->op_type == OP_PADHV))
4656 return newUNOP(OP_REFGEN,
4657 0, mod(cond, OP_REFGEN));
4663 /* These construct the optree fragments representing given()
4666 entergiven and enterwhen are LOGOPs; the op_other pointer
4667 points up to the associated leave op. We need this so we
4668 can put it in the context and make break/continue work.
4669 (Also, of course, pp_enterwhen will jump straight to
4670 op_other if the match fails.)
4675 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
4676 I32 enter_opcode, I32 leave_opcode,
4677 PADOFFSET entertarg)
4683 NewOp(1101, enterop, 1, LOGOP);
4684 enterop->op_type = enter_opcode;
4685 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
4686 enterop->op_flags = (U8) OPf_KIDS;
4687 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
4688 enterop->op_private = 0;
4690 o = newUNOP(leave_opcode, 0, (OP *) enterop);
4693 enterop->op_first = scalar(cond);
4694 cond->op_sibling = block;
4696 o->op_next = LINKLIST(cond);
4697 cond->op_next = (OP *) enterop;
4700 /* This is a default {} block */
4701 enterop->op_first = block;
4702 enterop->op_flags |= OPf_SPECIAL;
4704 o->op_next = (OP *) enterop;
4707 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
4708 entergiven and enterwhen both
4711 enterop->op_next = LINKLIST(block);
4712 block->op_next = enterop->op_other = o;
4717 /* Does this look like a boolean operation? For these purposes
4718 a boolean operation is:
4719 - a subroutine call [*]
4720 - a logical connective
4721 - a comparison operator
4722 - a filetest operator, with the exception of -s -M -A -C
4723 - defined(), exists() or eof()
4724 - /$re/ or $foo =~ /$re/
4726 [*] possibly surprising
4730 S_looks_like_bool(pTHX_ const OP *o)
4733 switch(o->op_type) {
4735 return looks_like_bool(cLOGOPo->op_first);
4739 looks_like_bool(cLOGOPo->op_first)
4740 && looks_like_bool(cLOGOPo->op_first->op_sibling));
4744 case OP_NOT: case OP_XOR:
4745 /* Note that OP_DOR is not here */
4747 case OP_EQ: case OP_NE: case OP_LT:
4748 case OP_GT: case OP_LE: case OP_GE:
4750 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
4751 case OP_I_GT: case OP_I_LE: case OP_I_GE:
4753 case OP_SEQ: case OP_SNE: case OP_SLT:
4754 case OP_SGT: case OP_SLE: case OP_SGE:
4758 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
4759 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
4760 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
4761 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
4762 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
4763 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
4764 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
4765 case OP_FTTEXT: case OP_FTBINARY:
4767 case OP_DEFINED: case OP_EXISTS:
4768 case OP_MATCH: case OP_EOF:
4773 /* Detect comparisons that have been optimized away */
4774 if (cSVOPo->op_sv == &PL_sv_yes
4775 || cSVOPo->op_sv == &PL_sv_no)
4786 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
4790 return newGIVWHENOP(
4791 ref_array_or_hash(cond),
4793 OP_ENTERGIVEN, OP_LEAVEGIVEN,
4797 /* If cond is null, this is a default {} block */
4799 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
4801 const bool cond_llb = (!cond || looks_like_bool(cond));
4807 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
4809 scalar(ref_array_or_hash(cond)));
4812 return newGIVWHENOP(
4814 append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
4815 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
4819 =for apidoc cv_undef
4821 Clear out all the active components of a CV. This can happen either
4822 by an explicit C<undef &foo>, or by the reference count going to zero.
4823 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
4824 children can still follow the full lexical scope chain.
4830 Perl_cv_undef(pTHX_ CV *cv)
4834 if (CvFILE(cv) && !CvISXSUB(cv)) {
4835 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4836 Safefree(CvFILE(cv));
4841 if (!CvISXSUB(cv) && CvROOT(cv)) {
4842 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
4843 Perl_croak(aTHX_ "Can't undef active subroutine");
4846 PAD_SAVE_SETNULLPAD();
4848 op_free(CvROOT(cv));
4853 SvPOK_off((SV*)cv); /* forget prototype */
4858 /* remove CvOUTSIDE unless this is an undef rather than a free */
4859 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
4860 if (!CvWEAKOUTSIDE(cv))
4861 SvREFCNT_dec(CvOUTSIDE(cv));
4862 CvOUTSIDE(cv) = NULL;
4865 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4868 if (CvISXSUB(cv) && CvXSUB(cv)) {
4871 /* delete all flags except WEAKOUTSIDE */
4872 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
4876 Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
4879 /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
4880 relying on SvCUR, and doubling up the buffer to hold CvFILE(). */
4881 if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
4882 || (p && (len != SvCUR(cv) /* Not the same length. */
4883 || memNE(p, SvPVX_const(cv), len))))
4884 && ckWARN_d(WARN_PROTOTYPE)) {
4885 SV* const msg = sv_newmortal();
4889 gv_efullname3(name = sv_newmortal(), gv, NULL);
4890 sv_setpv(msg, "Prototype mismatch:");
4892 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, (void*)name);
4894 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (void*)cv);
4896 sv_catpvs(msg, ": none");
4897 sv_catpvs(msg, " vs ");
4899 Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
4901 sv_catpvs(msg, "none");
4902 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, (void*)msg);
4906 static void const_sv_xsub(pTHX_ CV* cv);
4910 =head1 Optree Manipulation Functions
4912 =for apidoc cv_const_sv
4914 If C<cv> is a constant sub eligible for inlining. returns the constant
4915 value returned by the sub. Otherwise, returns NULL.
4917 Constant subs can be created with C<newCONSTSUB> or as described in
4918 L<perlsub/"Constant Functions">.
4923 Perl_cv_const_sv(pTHX_ CV *cv)
4925 PERL_UNUSED_CONTEXT;
4928 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
4930 return CvCONST(cv) ? (SV*)CvXSUBANY(cv).any_ptr : NULL;
4933 /* op_const_sv: examine an optree to determine whether it's in-lineable.
4934 * Can be called in 3 ways:
4937 * look for a single OP_CONST with attached value: return the value
4939 * cv && CvCLONE(cv) && !CvCONST(cv)
4941 * examine the clone prototype, and if contains only a single
4942 * OP_CONST referencing a pad const, or a single PADSV referencing
4943 * an outer lexical, return a non-zero value to indicate the CV is
4944 * a candidate for "constizing" at clone time
4948 * We have just cloned an anon prototype that was marked as a const
4949 * candidiate. Try to grab the current value, and in the case of
4950 * PADSV, ignore it if it has multiple references. Return the value.
4954 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
4962 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4963 o = cLISTOPo->op_first->op_sibling;
4965 for (; o; o = o->op_next) {
4966 const OPCODE type = o->op_type;
4968 if (sv && o->op_next == o)
4970 if (o->op_next != o) {
4971 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4973 if (type == OP_DBSTATE)
4976 if (type == OP_LEAVESUB || type == OP_RETURN)
4980 if (type == OP_CONST && cSVOPo->op_sv)
4982 else if (cv && type == OP_CONST) {
4983 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4987 else if (cv && type == OP_PADSV) {
4988 if (CvCONST(cv)) { /* newly cloned anon */
4989 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4990 /* the candidate should have 1 ref from this pad and 1 ref
4991 * from the parent */
4992 if (!sv || SvREFCNT(sv) != 2)
4999 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
5000 sv = &PL_sv_undef; /* an arbitrary non-null value */
5015 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5018 /* This would be the return value, but the return cannot be reached. */
5019 OP* pegop = newOP(OP_NULL, 0);
5022 PERL_UNUSED_ARG(floor);
5032 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
5034 NORETURN_FUNCTION_END;
5039 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
5041 return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
5045 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5052 register CV *cv = NULL;
5054 /* If the subroutine has no body, no attributes, and no builtin attributes
5055 then it's just a sub declaration, and we may be able to get away with
5056 storing with a placeholder scalar in the symbol table, rather than a
5057 full GV and CV. If anything is present then it will take a full CV to
5059 const I32 gv_fetch_flags
5060 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5062 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
5063 const char * const name = o ? SvPVx_nolen_const(cSVOPo->op_sv) : NULL;
5066 assert(proto->op_type == OP_CONST);
5067 ps = SvPVx_const(((SVOP*)proto)->op_sv, ps_len);
5072 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
5073 SV * const sv = sv_newmortal();
5074 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
5075 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
5076 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
5077 aname = SvPVX_const(sv);
5082 gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
5083 : gv_fetchpv(aname ? aname
5084 : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5085 gv_fetch_flags, SVt_PVCV);
5087 if (!PL_madskills) {
5096 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
5097 maximum a prototype before. */
5098 if (SvTYPE(gv) > SVt_NULL) {
5099 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
5100 && ckWARN_d(WARN_PROTOTYPE))
5102 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
5104 cv_ckproto_len((CV*)gv, NULL, ps, ps_len);
5107 sv_setpvn((SV*)gv, ps, ps_len);
5109 sv_setiv((SV*)gv, -1);
5110 SvREFCNT_dec(PL_compcv);
5111 cv = PL_compcv = NULL;
5112 PL_sub_generation++;
5116 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
5118 #ifdef GV_UNIQUE_CHECK
5119 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
5120 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
5124 if (!block || !ps || *ps || attrs
5125 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5127 || block->op_type == OP_NULL
5132 const_sv = op_const_sv(block, NULL);
5135 const bool exists = CvROOT(cv) || CvXSUB(cv);
5137 #ifdef GV_UNIQUE_CHECK
5138 if (exists && GvUNIQUE(gv)) {
5139 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
5143 /* if the subroutine doesn't exist and wasn't pre-declared
5144 * with a prototype, assume it will be AUTOLOADed,
5145 * skipping the prototype check
5147 if (exists || SvPOK(cv))
5148 cv_ckproto_len(cv, gv, ps, ps_len);
5149 /* already defined (or promised)? */
5150 if (exists || GvASSUMECV(gv)) {
5153 || block->op_type == OP_NULL
5156 if (CvFLAGS(PL_compcv)) {
5157 /* might have had built-in attrs applied */
5158 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5160 /* just a "sub foo;" when &foo is already defined */
5161 SAVEFREESV(PL_compcv);
5166 && block->op_type != OP_NULL
5169 if (ckWARN(WARN_REDEFINE)
5171 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
5173 const line_t oldline = CopLINE(PL_curcop);
5174 if (PL_copline != NOLINE)
5175 CopLINE_set(PL_curcop, PL_copline);
5176 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5177 CvCONST(cv) ? "Constant subroutine %s redefined"
5178 : "Subroutine %s redefined", name);
5179 CopLINE_set(PL_curcop, oldline);
5182 if (!PL_minus_c) /* keep old one around for madskills */
5185 /* (PL_madskills unset in used file.) */
5193 SvREFCNT_inc_simple_void_NN(const_sv);
5195 assert(!CvROOT(cv) && !CvCONST(cv));
5196 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
5197 CvXSUBANY(cv).any_ptr = const_sv;
5198 CvXSUB(cv) = const_sv_xsub;
5204 cv = newCONSTSUB(NULL, name, const_sv);
5206 PL_sub_generation++;
5210 SvREFCNT_dec(PL_compcv);
5218 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
5219 * before we clobber PL_compcv.
5223 || block->op_type == OP_NULL
5227 /* Might have had built-in attributes applied -- propagate them. */
5228 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5229 if (CvGV(cv) && GvSTASH(CvGV(cv)))
5230 stash = GvSTASH(CvGV(cv));
5231 else if (CvSTASH(cv))
5232 stash = CvSTASH(cv);
5234 stash = PL_curstash;
5237 /* possibly about to re-define existing subr -- ignore old cv */
5238 rcv = (SV*)PL_compcv;
5239 if (name && GvSTASH(gv))
5240 stash = GvSTASH(gv);
5242 stash = PL_curstash;
5244 apply_attrs(stash, rcv, attrs, FALSE);
5246 if (cv) { /* must reuse cv if autoloaded */
5253 || block->op_type == OP_NULL) && !PL_madskills
5256 /* got here with just attrs -- work done, so bug out */
5257 SAVEFREESV(PL_compcv);
5260 /* transfer PL_compcv to cv */
5262 CvFLAGS(cv) = CvFLAGS(PL_compcv);
5263 if (!CvWEAKOUTSIDE(cv))
5264 SvREFCNT_dec(CvOUTSIDE(cv));
5265 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
5266 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
5267 CvOUTSIDE(PL_compcv) = 0;
5268 CvPADLIST(cv) = CvPADLIST(PL_compcv);
5269 CvPADLIST(PL_compcv) = 0;
5270 /* inner references to PL_compcv must be fixed up ... */
5271 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
5272 /* ... before we throw it away */
5273 SvREFCNT_dec(PL_compcv);
5275 if (PERLDB_INTER)/* Advice debugger on the new sub. */
5276 ++PL_sub_generation;
5283 if (strEQ(name, "import")) {
5284 PL_formfeed = (SV*)cv;
5285 Perl_warner(aTHX_ packWARN(WARN_VOID), "%lx\n", (long)cv);
5289 PL_sub_generation++;
5293 CvFILE_set_from_cop(cv, PL_curcop);
5294 CvSTASH(cv) = PL_curstash;
5297 sv_setpvn((SV*)cv, ps, ps_len);
5299 if (PL_error_count) {
5303 const char *s = strrchr(name, ':');
5305 if (strEQ(s, "BEGIN")) {
5306 const char not_safe[] =
5307 "BEGIN not safe after errors--compilation aborted";
5308 if (PL_in_eval & EVAL_KEEPERR)
5309 Perl_croak(aTHX_ not_safe);
5311 /* force display of errors found but not reported */
5312 sv_catpv(ERRSV, not_safe);
5313 Perl_croak(aTHX_ "%"SVf, (void*)ERRSV);
5323 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5324 mod(scalarseq(block), OP_LEAVESUBLV));
5327 /* This makes sub {}; work as expected. */
5328 if (block->op_type == OP_STUB) {
5329 OP* const newblock = newSTATEOP(0, NULL, 0);
5331 op_getmad(block,newblock,'B');
5337 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5339 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5340 OpREFCNT_set(CvROOT(cv), 1);
5341 CvSTART(cv) = LINKLIST(CvROOT(cv));
5342 CvROOT(cv)->op_next = 0;
5343 CALL_PEEP(CvSTART(cv));
5345 /* now that optimizer has done its work, adjust pad values */
5347 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
5350 assert(!CvCONST(cv));
5351 if (ps && !*ps && op_const_sv(block, cv))
5355 if (name || aname) {
5357 const char * const tname = (name ? name : aname);
5359 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5360 SV * const sv = newSV(0);
5361 SV * const tmpstr = sv_newmortal();
5362 GV * const db_postponed = gv_fetchpvs("DB::postponed",
5363 GV_ADDMULTI, SVt_PVHV);
5366 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5368 (long)PL_subline, (long)CopLINE(PL_curcop));
5369 gv_efullname3(tmpstr, gv, NULL);
5370 hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0);
5371 hv = GvHVn(db_postponed);
5372 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
5373 CV * const pcv = GvCV(db_postponed);
5379 call_sv((SV*)pcv, G_DISCARD);
5384 if ((s = strrchr(tname,':')))
5389 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I' && *s != 'U')
5392 if (strEQ(s, "BEGIN") && !PL_error_count) {
5393 const I32 oldscope = PL_scopestack_ix;
5395 SAVECOPFILE(&PL_compiling);
5396 SAVECOPLINE(&PL_compiling);
5399 PL_beginav = newAV();
5400 DEBUG_x( dump_sub(gv) );
5401 av_push(PL_beginav, (SV*)cv);
5402 GvCV(gv) = 0; /* cv has been hijacked */
5403 call_list(oldscope, PL_beginav);
5405 PL_curcop = &PL_compiling;
5406 CopHINTS_set(&PL_compiling, PL_hints);
5409 else if (strEQ(s, "END") && !PL_error_count) {
5412 DEBUG_x( dump_sub(gv) );
5413 av_unshift(PL_endav, 1);
5414 av_store(PL_endav, 0, (SV*)cv);
5415 GvCV(gv) = 0; /* cv has been hijacked */
5417 else if (strEQ(s, "UNITCHECK") && !PL_error_count) {
5418 /* It's never too late to run a unitcheck block */
5419 if (!PL_unitcheckav)
5420 PL_unitcheckav = newAV();
5421 DEBUG_x( dump_sub(gv) );
5422 av_unshift(PL_unitcheckav, 1);
5423 av_store(PL_unitcheckav, 0, (SV*)cv);
5424 GvCV(gv) = 0; /* cv has been hijacked */
5426 else if (strEQ(s, "CHECK") && !PL_error_count) {
5428 PL_checkav = newAV();
5429 DEBUG_x( dump_sub(gv) );
5430 if (PL_main_start && ckWARN(WARN_VOID))
5431 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
5432 av_unshift(PL_checkav, 1);
5433 av_store(PL_checkav, 0, (SV*)cv);
5434 GvCV(gv) = 0; /* cv has been hijacked */
5436 else if (strEQ(s, "INIT") && !PL_error_count) {
5438 PL_initav = newAV();
5439 DEBUG_x( dump_sub(gv) );
5440 if (PL_main_start && ckWARN(WARN_VOID))
5441 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
5442 av_push(PL_initav, (SV*)cv);
5443 GvCV(gv) = 0; /* cv has been hijacked */
5448 PL_copline = NOLINE;
5453 /* XXX unsafe for threads if eval_owner isn't held */
5455 =for apidoc newCONSTSUB
5457 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5458 eligible for inlining at compile-time.
5464 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
5469 const char *const temp_p = CopFILE(PL_curcop);
5470 const STRLEN len = temp_p ? strlen(temp_p) : 0;
5472 SV *const temp_sv = CopFILESV(PL_curcop);
5474 const char *const temp_p = temp_sv ? SvPV_const(temp_sv, len) : NULL;
5476 char *const file = savepvn(temp_p, temp_p ? len : 0);
5480 SAVECOPLINE(PL_curcop);
5481 CopLINE_set(PL_curcop, PL_copline);
5484 PL_hints &= ~HINT_BLOCK_SCOPE;
5487 SAVESPTR(PL_curstash);
5488 SAVECOPSTASH(PL_curcop);
5489 PL_curstash = stash;
5490 CopSTASH_set(PL_curcop,stash);
5493 /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
5494 and so doesn't get free()d. (It's expected to be from the C pre-
5495 processor __FILE__ directive). But we need a dynamically allocated one,
5496 and we need it to get freed. */
5497 cv = newXS_flags(name, const_sv_xsub, file, "", XS_DYNAMIC_FILENAME);
5498 CvXSUBANY(cv).any_ptr = sv;
5504 CopSTASH_free(PL_curcop);
5512 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
5513 const char *const filename, const char *const proto,
5516 CV *cv = newXS(name, subaddr, filename);
5518 if (flags & XS_DYNAMIC_FILENAME) {
5519 /* We need to "make arrangements" (ie cheat) to ensure that the
5520 filename lasts as long as the PVCV we just created, but also doesn't
5522 STRLEN filename_len = strlen(filename);
5523 STRLEN proto_and_file_len = filename_len;
5524 char *proto_and_file;
5528 proto_len = strlen(proto);
5529 proto_and_file_len += proto_len;
5531 Newx(proto_and_file, proto_and_file_len + 1, char);
5532 Copy(proto, proto_and_file, proto_len, char);
5533 Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
5536 proto_and_file = savepvn(filename, filename_len);
5539 /* This gets free()d. :-) */
5540 sv_usepvn_flags((SV*)cv, proto_and_file, proto_and_file_len,
5541 SV_HAS_TRAILING_NUL);
5543 /* This gives us the correct prototype, rather than one with the
5544 file name appended. */
5545 SvCUR_set(cv, proto_len);
5549 CvFILE(cv) = proto_and_file + proto_len;
5551 sv_setpv((SV *)cv, proto);
5557 =for apidoc U||newXS
5559 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
5560 static storage, as it is used directly as CvFILE(), without a copy being made.
5566 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
5569 GV * const gv = gv_fetchpv(name ? name :
5570 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5571 GV_ADDMULTI, SVt_PVCV);
5575 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
5577 if ((cv = (name ? GvCV(gv) : NULL))) {
5579 /* just a cached method */
5583 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5584 /* already defined (or promised) */
5585 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
5586 if (ckWARN(WARN_REDEFINE)) {
5587 GV * const gvcv = CvGV(cv);
5589 HV * const stash = GvSTASH(gvcv);
5591 const char *redefined_name = HvNAME_get(stash);
5592 if ( strEQ(redefined_name,"autouse") ) {
5593 const line_t oldline = CopLINE(PL_curcop);
5594 if (PL_copline != NOLINE)
5595 CopLINE_set(PL_curcop, PL_copline);
5596 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5597 CvCONST(cv) ? "Constant subroutine %s redefined"
5598 : "Subroutine %s redefined"
5600 CopLINE_set(PL_curcop, oldline);
5610 if (cv) /* must reuse cv if autoloaded */
5614 sv_upgrade((SV *)cv, SVt_PVCV);
5618 PL_sub_generation++;
5622 (void)gv_fetchfile(filename);
5623 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
5624 an external constant string */
5626 CvXSUB(cv) = subaddr;
5629 const char *s = strrchr(name,':');
5635 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5638 if (strEQ(s, "BEGIN")) {
5640 PL_beginav = newAV();
5641 av_push(PL_beginav, (SV*)cv);
5642 GvCV(gv) = 0; /* cv has been hijacked */
5644 else if (strEQ(s, "END")) {
5647 av_unshift(PL_endav, 1);
5648 av_store(PL_endav, 0, (SV*)cv);
5649 GvCV(gv) = 0; /* cv has been hijacked */
5651 else if (strEQ(s, "CHECK")) {
5653 PL_checkav = newAV();
5654 if (PL_main_start && ckWARN(WARN_VOID))
5655 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
5656 av_unshift(PL_checkav, 1);
5657 av_store(PL_checkav, 0, (SV*)cv);
5658 GvCV(gv) = 0; /* cv has been hijacked */
5660 else if (strEQ(s, "INIT")) {
5662 PL_initav = newAV();
5663 if (PL_main_start && ckWARN(WARN_VOID))
5664 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
5665 av_push(PL_initav, (SV*)cv);
5666 GvCV(gv) = 0; /* cv has been hijacked */
5681 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5686 OP* pegop = newOP(OP_NULL, 0);
5690 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
5691 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
5693 #ifdef GV_UNIQUE_CHECK
5695 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5699 if ((cv = GvFORM(gv))) {
5700 if (ckWARN(WARN_REDEFINE)) {
5701 const line_t oldline = CopLINE(PL_curcop);
5702 if (PL_copline != NOLINE)
5703 CopLINE_set(PL_curcop, PL_copline);
5704 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5705 o ? "Format %"SVf" redefined"
5706 : "Format STDOUT redefined", (void*)cSVOPo->op_sv);
5707 CopLINE_set(PL_curcop, oldline);
5714 CvFILE_set_from_cop(cv, PL_curcop);
5717 pad_tidy(padtidy_FORMAT);
5718 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5719 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5720 OpREFCNT_set(CvROOT(cv), 1);
5721 CvSTART(cv) = LINKLIST(CvROOT(cv));
5722 CvROOT(cv)->op_next = 0;
5723 CALL_PEEP(CvSTART(cv));
5725 op_getmad(o,pegop,'n');
5726 op_getmad_weak(block, pegop, 'b');
5730 PL_copline = NOLINE;
5738 Perl_newANONLIST(pTHX_ OP *o)
5740 return convert(OP_ANONLIST, OPf_SPECIAL, o);
5744 Perl_newANONHASH(pTHX_ OP *o)
5746 return convert(OP_ANONHASH, OPf_SPECIAL, o);
5750 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5752 return newANONATTRSUB(floor, proto, NULL, block);
5756 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5758 return newUNOP(OP_REFGEN, 0,
5759 newSVOP(OP_ANONCODE, 0,
5760 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5764 Perl_oopsAV(pTHX_ OP *o)
5767 switch (o->op_type) {
5769 o->op_type = OP_PADAV;
5770 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5771 return ref(o, OP_RV2AV);
5774 o->op_type = OP_RV2AV;
5775 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5780 if (ckWARN_d(WARN_INTERNAL))
5781 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
5788 Perl_oopsHV(pTHX_ OP *o)
5791 switch (o->op_type) {
5794 o->op_type = OP_PADHV;
5795 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5796 return ref(o, OP_RV2HV);
5800 o->op_type = OP_RV2HV;
5801 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5806 if (ckWARN_d(WARN_INTERNAL))
5807 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
5814 Perl_newAVREF(pTHX_ OP *o)
5817 if (o->op_type == OP_PADANY) {
5818 o->op_type = OP_PADAV;
5819 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5822 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5823 && ckWARN(WARN_DEPRECATED)) {
5824 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5825 "Using an array as a reference is deprecated");
5827 return newUNOP(OP_RV2AV, 0, scalar(o));
5831 Perl_newGVREF(pTHX_ I32 type, OP *o)
5833 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5834 return newUNOP(OP_NULL, 0, o);
5835 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5839 Perl_newHVREF(pTHX_ OP *o)
5842 if (o->op_type == OP_PADANY) {
5843 o->op_type = OP_PADHV;
5844 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5847 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5848 && ckWARN(WARN_DEPRECATED)) {
5849 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5850 "Using a hash as a reference is deprecated");
5852 return newUNOP(OP_RV2HV, 0, scalar(o));
5856 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5858 return newUNOP(OP_RV2CV, flags, scalar(o));
5862 Perl_newSVREF(pTHX_ OP *o)
5865 if (o->op_type == OP_PADANY) {
5866 o->op_type = OP_PADSV;
5867 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5870 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5871 o->op_flags |= OPpDONE_SVREF;
5874 return newUNOP(OP_RV2SV, 0, scalar(o));
5877 /* Check routines. See the comments at the top of this file for details
5878 * on when these are called */
5881 Perl_ck_anoncode(pTHX_ OP *o)
5883 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
5885 cSVOPo->op_sv = NULL;
5890 Perl_ck_bitop(pTHX_ OP *o)
5893 #define OP_IS_NUMCOMPARE(op) \
5894 ((op) == OP_LT || (op) == OP_I_LT || \
5895 (op) == OP_GT || (op) == OP_I_GT || \
5896 (op) == OP_LE || (op) == OP_I_LE || \
5897 (op) == OP_GE || (op) == OP_I_GE || \
5898 (op) == OP_EQ || (op) == OP_I_EQ || \
5899 (op) == OP_NE || (op) == OP_I_NE || \
5900 (op) == OP_NCMP || (op) == OP_I_NCMP)
5901 o->op_private = (U8)(PL_hints & HINT_INTEGER);
5902 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
5903 && (o->op_type == OP_BIT_OR
5904 || o->op_type == OP_BIT_AND
5905 || o->op_type == OP_BIT_XOR))
5907 const OP * const left = cBINOPo->op_first;
5908 const OP * const right = left->op_sibling;
5909 if ((OP_IS_NUMCOMPARE(left->op_type) &&
5910 (left->op_flags & OPf_PARENS) == 0) ||
5911 (OP_IS_NUMCOMPARE(right->op_type) &&
5912 (right->op_flags & OPf_PARENS) == 0))
5913 if (ckWARN(WARN_PRECEDENCE))
5914 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
5915 "Possible precedence problem on bitwise %c operator",
5916 o->op_type == OP_BIT_OR ? '|'
5917 : o->op_type == OP_BIT_AND ? '&' : '^'
5924 Perl_ck_concat(pTHX_ OP *o)
5926 const OP * const kid = cUNOPo->op_first;
5927 PERL_UNUSED_CONTEXT;
5928 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
5929 !(kUNOP->op_first->op_flags & OPf_MOD))
5930 o->op_flags |= OPf_STACKED;
5935 Perl_ck_spair(pTHX_ OP *o)
5938 if (o->op_flags & OPf_KIDS) {
5941 const OPCODE type = o->op_type;
5942 o = modkids(ck_fun(o), type);
5943 kid = cUNOPo->op_first;
5944 newop = kUNOP->op_first->op_sibling;
5946 const OPCODE type = newop->op_type;
5947 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
5948 type == OP_PADAV || type == OP_PADHV ||
5949 type == OP_RV2AV || type == OP_RV2HV)
5953 op_getmad(kUNOP->op_first,newop,'K');
5955 op_free(kUNOP->op_first);
5957 kUNOP->op_first = newop;
5959 o->op_ppaddr = PL_ppaddr[++o->op_type];
5964 Perl_ck_delete(pTHX_ OP *o)
5968 if (o->op_flags & OPf_KIDS) {
5969 OP * const kid = cUNOPo->op_first;
5970 switch (kid->op_type) {
5972 o->op_flags |= OPf_SPECIAL;
5975 o->op_private |= OPpSLICE;
5978 o->op_flags |= OPf_SPECIAL;
5983 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5992 Perl_ck_die(pTHX_ OP *o)
5995 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6001 Perl_ck_eof(pTHX_ OP *o)
6005 if (o->op_flags & OPf_KIDS) {
6006 if (cLISTOPo->op_first->op_type == OP_STUB) {
6008 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
6010 op_getmad(o,newop,'O');
6022 Perl_ck_eval(pTHX_ OP *o)
6025 PL_hints |= HINT_BLOCK_SCOPE;
6026 if (o->op_flags & OPf_KIDS) {
6027 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6030 o->op_flags &= ~OPf_KIDS;
6033 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
6039 cUNOPo->op_first = 0;
6044 NewOp(1101, enter, 1, LOGOP);
6045 enter->op_type = OP_ENTERTRY;
6046 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
6047 enter->op_private = 0;
6049 /* establish postfix order */
6050 enter->op_next = (OP*)enter;
6052 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
6053 o->op_type = OP_LEAVETRY;
6054 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
6055 enter->op_other = o;
6056 op_getmad(oldo,o,'O');
6070 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
6071 op_getmad(oldo,o,'O');
6073 o->op_targ = (PADOFFSET)PL_hints;
6074 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
6075 /* Store a copy of %^H that pp_entereval can pick up */
6076 OP *hhop = newSVOP(OP_CONST, 0,
6077 (SV*)Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv)));
6078 cUNOPo->op_first->op_sibling = hhop;
6079 o->op_private |= OPpEVAL_HAS_HH;
6085 Perl_ck_exit(pTHX_ OP *o)
6088 HV * const table = GvHV(PL_hintgv);
6090 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
6091 if (svp && *svp && SvTRUE(*svp))
6092 o->op_private |= OPpEXIT_VMSISH;
6094 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6100 Perl_ck_exec(pTHX_ OP *o)
6102 if (o->op_flags & OPf_STACKED) {
6105 kid = cUNOPo->op_first->op_sibling;
6106 if (kid->op_type == OP_RV2GV)
6115 Perl_ck_exists(pTHX_ OP *o)
6119 if (o->op_flags & OPf_KIDS) {
6120 OP * const kid = cUNOPo->op_first;
6121 if (kid->op_type == OP_ENTERSUB) {
6122 (void) ref(kid, o->op_type);
6123 if (kid->op_type != OP_RV2CV && !PL_error_count)
6124 Perl_croak(aTHX_ "%s argument is not a subroutine name",
6126 o->op_private |= OPpEXISTS_SUB;
6128 else if (kid->op_type == OP_AELEM)
6129 o->op_flags |= OPf_SPECIAL;
6130 else if (kid->op_type != OP_HELEM)
6131 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
6139 Perl_ck_rvconst(pTHX_ register OP *o)
6142 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6144 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6145 if (o->op_type == OP_RV2CV)
6146 o->op_private &= ~1;
6148 if (kid->op_type == OP_CONST) {
6151 SV * const kidsv = kid->op_sv;
6153 /* Is it a constant from cv_const_sv()? */
6154 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
6155 SV * const rsv = SvRV(kidsv);
6156 const svtype type = SvTYPE(rsv);
6157 const char *badtype = NULL;
6159 switch (o->op_type) {
6161 if (type > SVt_PVMG)
6162 badtype = "a SCALAR";
6165 if (type != SVt_PVAV)
6166 badtype = "an ARRAY";
6169 if (type != SVt_PVHV)
6173 if (type != SVt_PVCV)
6178 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
6181 else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
6182 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
6183 /* If this is an access to a stash, disable "strict refs", because
6184 * stashes aren't auto-vivified at compile-time (unless we store
6185 * symbols in them), and we don't want to produce a run-time
6186 * stricture error when auto-vivifying the stash. */
6187 const char *s = SvPV_nolen(kidsv);
6188 const STRLEN l = SvCUR(kidsv);
6189 if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
6190 o->op_private &= ~HINT_STRICT_REFS;
6192 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
6193 const char *badthing;
6194 switch (o->op_type) {
6196 badthing = "a SCALAR";
6199 badthing = "an ARRAY";
6202 badthing = "a HASH";
6210 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
6211 (void*)kidsv, badthing);
6214 * This is a little tricky. We only want to add the symbol if we
6215 * didn't add it in the lexer. Otherwise we get duplicate strict
6216 * warnings. But if we didn't add it in the lexer, we must at
6217 * least pretend like we wanted to add it even if it existed before,
6218 * or we get possible typo warnings. OPpCONST_ENTERED says
6219 * whether the lexer already added THIS instance of this symbol.
6221 iscv = (o->op_type == OP_RV2CV) * 2;
6223 gv = gv_fetchsv(kidsv,
6224 iscv | !(kid->op_private & OPpCONST_ENTERED),
6227 : o->op_type == OP_RV2SV
6229 : o->op_type == OP_RV2AV
6231 : o->op_type == OP_RV2HV
6234 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
6236 kid->op_type = OP_GV;
6237 SvREFCNT_dec(kid->op_sv);
6239 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
6240 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
6241 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
6243 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc_simple_NN(gv));
6245 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
6247 kid->op_private = 0;
6248 kid->op_ppaddr = PL_ppaddr[OP_GV];
6255 Perl_ck_ftst(pTHX_ OP *o)
6258 const I32 type = o->op_type;
6260 if (o->op_flags & OPf_REF) {
6263 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
6264 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6265 const OPCODE kidtype = kid->op_type;
6267 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6268 OP * const newop = newGVOP(type, OPf_REF,
6269 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
6271 op_getmad(o,newop,'O');
6277 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o))
6278 o->op_private |= OPpFT_ACCESS;
6279 if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst)
6280 && kidtype != OP_STAT && kidtype != OP_LSTAT)
6281 o->op_private |= OPpFT_STACKED;
6289 if (type == OP_FTTTY)
6290 o = newGVOP(type, OPf_REF, PL_stdingv);
6292 o = newUNOP(type, 0, newDEFSVOP());
6293 op_getmad(oldo,o,'O');
6299 Perl_ck_fun(pTHX_ OP *o)
6302 const int type = o->op_type;
6303 register I32 oa = PL_opargs[type] >> OASHIFT;
6305 if (o->op_flags & OPf_STACKED) {
6306 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
6309 return no_fh_allowed(o);
6312 if (o->op_flags & OPf_KIDS) {
6313 OP **tokid = &cLISTOPo->op_first;
6314 register OP *kid = cLISTOPo->op_first;
6318 if (kid->op_type == OP_PUSHMARK ||
6319 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
6321 tokid = &kid->op_sibling;
6322 kid = kid->op_sibling;
6324 if (!kid && PL_opargs[type] & OA_DEFGV)
6325 *tokid = kid = newDEFSVOP();
6329 sibl = kid->op_sibling;
6331 if (!sibl && kid->op_type == OP_STUB) {
6338 /* list seen where single (scalar) arg expected? */
6339 if (numargs == 1 && !(oa >> 4)
6340 && kid->op_type == OP_LIST && type != OP_SCALAR)
6342 return too_many_arguments(o,PL_op_desc[type]);
6355 if ((type == OP_PUSH || type == OP_UNSHIFT)
6356 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
6357 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6358 "Useless use of %s with no values",
6361 if (kid->op_type == OP_CONST &&
6362 (kid->op_private & OPpCONST_BARE))
6364 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
6365 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
6366 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6367 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6368 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
6369 (void*)((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
6371 op_getmad(kid,newop,'K');
6376 kid->op_sibling = sibl;
6379 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
6380 bad_type(numargs, "array", PL_op_desc[type], kid);
6384 if (kid->op_type == OP_CONST &&
6385 (kid->op_private & OPpCONST_BARE))
6387 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
6388 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
6389 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6390 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6391 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
6392 (void*)((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
6394 op_getmad(kid,newop,'K');
6399 kid->op_sibling = sibl;
6402 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
6403 bad_type(numargs, "hash", PL_op_desc[type], kid);
6408 OP * const newop = newUNOP(OP_NULL, 0, kid);
6409 kid->op_sibling = 0;
6411 newop->op_next = newop;
6413 kid->op_sibling = sibl;
6418 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
6419 if (kid->op_type == OP_CONST &&
6420 (kid->op_private & OPpCONST_BARE))
6422 OP * const newop = newGVOP(OP_GV, 0,
6423 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
6424 if (!(o->op_private & 1) && /* if not unop */
6425 kid == cLISTOPo->op_last)
6426 cLISTOPo->op_last = newop;
6428 op_getmad(kid,newop,'K');
6434 else if (kid->op_type == OP_READLINE) {
6435 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
6436 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
6439 I32 flags = OPf_SPECIAL;
6443 /* is this op a FH constructor? */
6444 if (is_handle_constructor(o,numargs)) {
6445 const char *name = NULL;
6449 /* Set a flag to tell rv2gv to vivify
6450 * need to "prove" flag does not mean something
6451 * else already - NI-S 1999/05/07
6454 if (kid->op_type == OP_PADSV) {
6455 name = PAD_COMPNAME_PV(kid->op_targ);
6456 /* SvCUR of a pad namesv can't be trusted
6457 * (see PL_generation), so calc its length
6463 else if (kid->op_type == OP_RV2SV
6464 && kUNOP->op_first->op_type == OP_GV)
6466 GV * const gv = cGVOPx_gv(kUNOP->op_first);
6468 len = GvNAMELEN(gv);
6470 else if (kid->op_type == OP_AELEM
6471 || kid->op_type == OP_HELEM)
6474 OP *op = ((BINOP*)kid)->op_first;
6478 const char * const a =
6479 kid->op_type == OP_AELEM ?
6481 if (((op->op_type == OP_RV2AV) ||
6482 (op->op_type == OP_RV2HV)) &&
6483 (firstop = ((UNOP*)op)->op_first) &&
6484 (firstop->op_type == OP_GV)) {
6485 /* packagevar $a[] or $h{} */
6486 GV * const gv = cGVOPx_gv(firstop);
6494 else if (op->op_type == OP_PADAV
6495 || op->op_type == OP_PADHV) {
6496 /* lexicalvar $a[] or $h{} */
6497 const char * const padname =
6498 PAD_COMPNAME_PV(op->op_targ);
6507 name = SvPV_const(tmpstr, len);
6512 name = "__ANONIO__";
6519 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
6520 namesv = PAD_SVl(targ);
6521 SvUPGRADE(namesv, SVt_PV);
6523 sv_setpvn(namesv, "$", 1);
6524 sv_catpvn(namesv, name, len);
6527 kid->op_sibling = 0;
6528 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
6529 kid->op_targ = targ;
6530 kid->op_private |= priv;
6532 kid->op_sibling = sibl;
6538 mod(scalar(kid), type);
6542 tokid = &kid->op_sibling;
6543 kid = kid->op_sibling;
6546 if (kid && kid->op_type != OP_STUB)
6547 return too_many_arguments(o,OP_DESC(o));
6548 o->op_private |= numargs;
6550 /* FIXME - should the numargs move as for the PERL_MAD case? */
6551 o->op_private |= numargs;
6553 return too_many_arguments(o,OP_DESC(o));
6557 else if (PL_opargs[type] & OA_DEFGV) {
6559 OP *newop = newUNOP(type, 0, newDEFSVOP());
6560 op_getmad(o,newop,'O');
6563 /* Ordering of these two is important to keep f_map.t passing. */
6565 return newUNOP(type, 0, newDEFSVOP());
6570 while (oa & OA_OPTIONAL)
6572 if (oa && oa != OA_LIST)
6573 return too_few_arguments(o,OP_DESC(o));
6579 Perl_ck_glob(pTHX_ OP *o)
6585 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
6586 append_elem(OP_GLOB, o, newDEFSVOP());
6588 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
6589 && GvCVu(gv) && GvIMPORTED_CV(gv)))
6591 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6594 #if !defined(PERL_EXTERNAL_GLOB)
6595 /* XXX this can be tightened up and made more failsafe. */
6596 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
6599 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
6600 newSVpvs("File::Glob"), NULL, NULL, NULL);
6601 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6602 glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
6603 GvCV(gv) = GvCV(glob_gv);
6604 SvREFCNT_inc_void((SV*)GvCV(gv));
6605 GvIMPORTED_CV_on(gv);
6608 #endif /* PERL_EXTERNAL_GLOB */
6610 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6611 append_elem(OP_GLOB, o,
6612 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
6613 o->op_type = OP_LIST;
6614 o->op_ppaddr = PL_ppaddr[OP_LIST];
6615 cLISTOPo->op_first->op_type = OP_PUSHMARK;
6616 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
6617 cLISTOPo->op_first->op_targ = 0;
6618 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
6619 append_elem(OP_LIST, o,
6620 scalar(newUNOP(OP_RV2CV, 0,
6621 newGVOP(OP_GV, 0, gv)))));
6622 o = newUNOP(OP_NULL, 0, ck_subr(o));
6623 o->op_targ = OP_GLOB; /* hint at what it used to be */
6626 gv = newGVgen("main");
6628 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
6634 Perl_ck_grep(pTHX_ OP *o)
6639 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
6642 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
6643 /* don't allocate gwop here, as we may leak it if PL_error_count > 0 */
6645 if (o->op_flags & OPf_STACKED) {
6648 kid = cLISTOPo->op_first->op_sibling;
6649 if (!cUNOPx(kid)->op_next)
6650 Perl_croak(aTHX_ "panic: ck_grep");
6651 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
6654 NewOp(1101, gwop, 1, LOGOP);
6655 kid->op_next = (OP*)gwop;
6656 o->op_flags &= ~OPf_STACKED;
6658 kid = cLISTOPo->op_first->op_sibling;
6659 if (type == OP_MAPWHILE)
6666 kid = cLISTOPo->op_first->op_sibling;
6667 if (kid->op_type != OP_NULL)
6668 Perl_croak(aTHX_ "panic: ck_grep");
6669 kid = kUNOP->op_first;
6672 NewOp(1101, gwop, 1, LOGOP);
6673 gwop->op_type = type;
6674 gwop->op_ppaddr = PL_ppaddr[type];
6675 gwop->op_first = listkids(o);
6676 gwop->op_flags |= OPf_KIDS;
6677 gwop->op_other = LINKLIST(kid);
6678 kid->op_next = (OP*)gwop;
6679 offset = pad_findmy("$_");
6680 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
6681 o->op_private = gwop->op_private = 0;
6682 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
6685 o->op_private = gwop->op_private = OPpGREP_LEX;
6686 gwop->op_targ = o->op_targ = offset;
6689 kid = cLISTOPo->op_first->op_sibling;
6690 if (!kid || !kid->op_sibling)
6691 return too_few_arguments(o,OP_DESC(o));
6692 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
6693 mod(kid, OP_GREPSTART);
6699 Perl_ck_index(pTHX_ OP *o)
6701 if (o->op_flags & OPf_KIDS) {
6702 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6704 kid = kid->op_sibling; /* get past "big" */
6705 if (kid && kid->op_type == OP_CONST)
6706 fbm_compile(((SVOP*)kid)->op_sv, 0);
6712 Perl_ck_lengthconst(pTHX_ OP *o)
6714 /* XXX length optimization goes here */
6719 Perl_ck_lfun(pTHX_ OP *o)
6721 const OPCODE type = o->op_type;
6722 return modkids(ck_fun(o), type);
6726 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
6728 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
6729 switch (cUNOPo->op_first->op_type) {
6731 /* This is needed for
6732 if (defined %stash::)
6733 to work. Do not break Tk.
6735 break; /* Globals via GV can be undef */
6737 case OP_AASSIGN: /* Is this a good idea? */
6738 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6739 "defined(@array) is deprecated");
6740 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6741 "\t(Maybe you should just omit the defined()?)\n");
6744 /* This is needed for
6745 if (defined %stash::)
6746 to work. Do not break Tk.
6748 break; /* Globals via GV can be undef */
6750 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6751 "defined(%%hash) is deprecated");
6752 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6753 "\t(Maybe you should just omit the defined()?)\n");
6764 Perl_ck_rfun(pTHX_ OP *o)
6766 const OPCODE type = o->op_type;
6767 return refkids(ck_fun(o), type);
6771 Perl_ck_listiob(pTHX_ OP *o)
6775 kid = cLISTOPo->op_first;
6778 kid = cLISTOPo->op_first;
6780 if (kid->op_type == OP_PUSHMARK)
6781 kid = kid->op_sibling;
6782 if (kid && o->op_flags & OPf_STACKED)
6783 kid = kid->op_sibling;
6784 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6785 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6786 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6787 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6788 cLISTOPo->op_first->op_sibling = kid;
6789 cLISTOPo->op_last = kid;
6790 kid = kid->op_sibling;
6795 append_elem(o->op_type, o, newDEFSVOP());
6801 Perl_ck_smartmatch(pTHX_ OP *o)
6804 if (0 == (o->op_flags & OPf_SPECIAL)) {
6805 OP *first = cBINOPo->op_first;
6806 OP *second = first->op_sibling;
6808 /* Implicitly take a reference to an array or hash */
6809 first->op_sibling = NULL;
6810 first = cBINOPo->op_first = ref_array_or_hash(first);
6811 second = first->op_sibling = ref_array_or_hash(second);
6813 /* Implicitly take a reference to a regular expression */
6814 if (first->op_type == OP_MATCH) {
6815 first->op_type = OP_QR;
6816 first->op_ppaddr = PL_ppaddr[OP_QR];
6818 if (second->op_type == OP_MATCH) {
6819 second->op_type = OP_QR;
6820 second->op_ppaddr = PL_ppaddr[OP_QR];
6829 Perl_ck_sassign(pTHX_ OP *o)
6831 OP * const kid = cLISTOPo->op_first;
6832 /* has a disposable target? */
6833 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6834 && !(kid->op_flags & OPf_STACKED)
6835 /* Cannot steal the second time! */
6836 && !(kid->op_private & OPpTARGET_MY))
6838 OP * const kkid = kid->op_sibling;
6840 /* Can just relocate the target. */
6841 if (kkid && kkid->op_type == OP_PADSV
6842 && !(kkid->op_private & OPpLVAL_INTRO))
6844 kid->op_targ = kkid->op_targ;
6846 /* Now we do not need PADSV and SASSIGN. */
6847 kid->op_sibling = o->op_sibling; /* NULL */
6848 cLISTOPo->op_first = NULL;
6850 op_getmad(o,kid,'O');
6851 op_getmad(kkid,kid,'M');
6856 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6860 if (kid->op_sibling) {
6861 OP *kkid = kid->op_sibling;
6862 if (kkid->op_type == OP_PADSV
6863 && (kkid->op_private & OPpLVAL_INTRO)
6864 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
6865 o->op_private |= OPpASSIGN_STATE;
6866 /* hijacking PADSTALE for uninitialized state variables */
6867 SvPADSTALE_on(PAD_SVl(kkid->op_targ));
6874 Perl_ck_match(pTHX_ OP *o)
6877 if (o->op_type != OP_QR && PL_compcv) {
6878 const PADOFFSET offset = pad_findmy("$_");
6879 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
6880 o->op_targ = offset;
6881 o->op_private |= OPpTARGET_MY;
6884 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
6885 o->op_private |= OPpRUNTIME;
6890 Perl_ck_method(pTHX_ OP *o)
6892 OP * const kid = cUNOPo->op_first;
6893 if (kid->op_type == OP_CONST) {
6894 SV* sv = kSVOP->op_sv;
6895 const char * const method = SvPVX_const(sv);
6896 if (!(strchr(method, ':') || strchr(method, '\''))) {
6898 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6899 sv = newSVpvn_share(method, SvCUR(sv), 0);
6902 kSVOP->op_sv = NULL;
6904 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6906 op_getmad(o,cmop,'O');
6917 Perl_ck_null(pTHX_ OP *o)
6919 PERL_UNUSED_CONTEXT;
6924 Perl_ck_open(pTHX_ OP *o)
6927 HV * const table = GvHV(PL_hintgv);
6929 SV **svp = hv_fetchs(table, "open_IN", FALSE);
6931 const I32 mode = mode_from_discipline(*svp);
6932 if (mode & O_BINARY)
6933 o->op_private |= OPpOPEN_IN_RAW;
6934 else if (mode & O_TEXT)
6935 o->op_private |= OPpOPEN_IN_CRLF;
6938 svp = hv_fetchs(table, "open_OUT", FALSE);
6940 const I32 mode = mode_from_discipline(*svp);
6941 if (mode & O_BINARY)
6942 o->op_private |= OPpOPEN_OUT_RAW;
6943 else if (mode & O_TEXT)
6944 o->op_private |= OPpOPEN_OUT_CRLF;
6947 if (o->op_type == OP_BACKTICK)
6950 /* In case of three-arg dup open remove strictness
6951 * from the last arg if it is a bareword. */
6952 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
6953 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
6957 if ((last->op_type == OP_CONST) && /* The bareword. */
6958 (last->op_private & OPpCONST_BARE) &&
6959 (last->op_private & OPpCONST_STRICT) &&
6960 (oa = first->op_sibling) && /* The fh. */
6961 (oa = oa->op_sibling) && /* The mode. */
6962 (oa->op_type == OP_CONST) &&
6963 SvPOK(((SVOP*)oa)->op_sv) &&
6964 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
6965 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
6966 (last == oa->op_sibling)) /* The bareword. */
6967 last->op_private &= ~OPpCONST_STRICT;
6973 Perl_ck_repeat(pTHX_ OP *o)
6975 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6976 o->op_private |= OPpREPEAT_DOLIST;
6977 cBINOPo->op_first = force_list(cBINOPo->op_first);
6985 Perl_ck_require(pTHX_ OP *o)
6990 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6991 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6993 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6994 SV * const sv = kid->op_sv;
6995 U32 was_readonly = SvREADONLY(sv);
7000 sv_force_normal_flags(sv, 0);
7001 assert(!SvREADONLY(sv));
7008 for (s = SvPVX(sv); *s; s++) {
7009 if (*s == ':' && s[1] == ':') {
7010 const STRLEN len = strlen(s+2)+1;
7012 Move(s+2, s+1, len, char);
7013 SvCUR_set(sv, SvCUR(sv) - 1);
7016 sv_catpvs(sv, ".pm");
7017 SvFLAGS(sv) |= was_readonly;
7021 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
7022 /* handle override, if any */
7023 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
7024 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7025 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
7026 gv = gvp ? *gvp : NULL;
7030 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7031 OP * const kid = cUNOPo->op_first;
7034 cUNOPo->op_first = 0;
7038 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
7039 append_elem(OP_LIST, kid,
7040 scalar(newUNOP(OP_RV2CV, 0,
7043 op_getmad(o,newop,'O');
7051 Perl_ck_return(pTHX_ OP *o)
7054 if (CvLVALUE(PL_compcv)) {
7056 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
7057 mod(kid, OP_LEAVESUBLV);
7063 Perl_ck_select(pTHX_ OP *o)
7067 if (o->op_flags & OPf_KIDS) {
7068 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7069 if (kid && kid->op_sibling) {
7070 o->op_type = OP_SSELECT;
7071 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
7073 return fold_constants(o);
7077 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7078 if (kid && kid->op_type == OP_RV2GV)
7079 kid->op_private &= ~HINT_STRICT_REFS;
7084 Perl_ck_shift(pTHX_ OP *o)
7087 const I32 type = o->op_type;
7089 if (!(o->op_flags & OPf_KIDS)) {
7091 /* FIXME - this can be refactored to reduce code in #ifdefs */
7093 OP * const oldo = o;
7097 argop = newUNOP(OP_RV2AV, 0,
7098 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
7100 o = newUNOP(type, 0, scalar(argop));
7101 op_getmad(oldo,o,'O');
7104 return newUNOP(type, 0, scalar(argop));
7107 return scalar(modkids(ck_fun(o), type));
7111 Perl_ck_sort(pTHX_ OP *o)
7116 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
7117 HV * const hinthv = GvHV(PL_hintgv);
7119 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
7121 const I32 sorthints = (I32)SvIV(*svp);
7122 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
7123 o->op_private |= OPpSORT_QSORT;
7124 if ((sorthints & HINT_SORT_STABLE) != 0)
7125 o->op_private |= OPpSORT_STABLE;
7130 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
7132 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7133 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
7135 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
7137 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
7139 if (kid->op_type == OP_SCOPE) {
7143 else if (kid->op_type == OP_LEAVE) {
7144 if (o->op_type == OP_SORT) {
7145 op_null(kid); /* wipe out leave */
7148 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
7149 if (k->op_next == kid)
7151 /* don't descend into loops */
7152 else if (k->op_type == OP_ENTERLOOP
7153 || k->op_type == OP_ENTERITER)
7155 k = cLOOPx(k)->op_lastop;
7160 kid->op_next = 0; /* just disconnect the leave */
7161 k = kLISTOP->op_first;
7166 if (o->op_type == OP_SORT) {
7167 /* provide scalar context for comparison function/block */
7173 o->op_flags |= OPf_SPECIAL;
7175 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
7178 firstkid = firstkid->op_sibling;
7181 /* provide list context for arguments */
7182 if (o->op_type == OP_SORT)
7189 S_simplify_sort(pTHX_ OP *o)
7192 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7197 if (!(o->op_flags & OPf_STACKED))
7199 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7200 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
7201 kid = kUNOP->op_first; /* get past null */
7202 if (kid->op_type != OP_SCOPE)
7204 kid = kLISTOP->op_last; /* get past scope */
7205 switch(kid->op_type) {
7213 k = kid; /* remember this node*/
7214 if (kBINOP->op_first->op_type != OP_RV2SV)
7216 kid = kBINOP->op_first; /* get past cmp */
7217 if (kUNOP->op_first->op_type != OP_GV)
7219 kid = kUNOP->op_first; /* get past rv2sv */
7221 if (GvSTASH(gv) != PL_curstash)
7223 gvname = GvNAME(gv);
7224 if (*gvname == 'a' && gvname[1] == '\0')
7226 else if (*gvname == 'b' && gvname[1] == '\0')
7231 kid = k; /* back to cmp */
7232 if (kBINOP->op_last->op_type != OP_RV2SV)
7234 kid = kBINOP->op_last; /* down to 2nd arg */
7235 if (kUNOP->op_first->op_type != OP_GV)
7237 kid = kUNOP->op_first; /* get past rv2sv */
7239 if (GvSTASH(gv) != PL_curstash)
7241 gvname = GvNAME(gv);
7243 ? !(*gvname == 'a' && gvname[1] == '\0')
7244 : !(*gvname == 'b' && gvname[1] == '\0'))
7246 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
7248 o->op_private |= OPpSORT_DESCEND;
7249 if (k->op_type == OP_NCMP)
7250 o->op_private |= OPpSORT_NUMERIC;
7251 if (k->op_type == OP_I_NCMP)
7252 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
7253 kid = cLISTOPo->op_first->op_sibling;
7254 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
7256 op_getmad(kid,o,'S'); /* then delete it */
7258 op_free(kid); /* then delete it */
7263 Perl_ck_split(pTHX_ OP *o)
7268 if (o->op_flags & OPf_STACKED)
7269 return no_fh_allowed(o);
7271 kid = cLISTOPo->op_first;
7272 if (kid->op_type != OP_NULL)
7273 Perl_croak(aTHX_ "panic: ck_split");
7274 kid = kid->op_sibling;
7275 op_free(cLISTOPo->op_first);
7276 cLISTOPo->op_first = kid;
7278 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
7279 cLISTOPo->op_last = kid; /* There was only one element previously */
7282 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
7283 OP * const sibl = kid->op_sibling;
7284 kid->op_sibling = 0;
7285 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
7286 if (cLISTOPo->op_first == cLISTOPo->op_last)
7287 cLISTOPo->op_last = kid;
7288 cLISTOPo->op_first = kid;
7289 kid->op_sibling = sibl;
7292 kid->op_type = OP_PUSHRE;
7293 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
7295 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
7296 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
7297 "Use of /g modifier is meaningless in split");
7300 if (!kid->op_sibling)
7301 append_elem(OP_SPLIT, o, newDEFSVOP());
7303 kid = kid->op_sibling;
7306 if (!kid->op_sibling)
7307 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
7308 assert(kid->op_sibling);
7310 kid = kid->op_sibling;
7313 if (kid->op_sibling)
7314 return too_many_arguments(o,OP_DESC(o));
7320 Perl_ck_join(pTHX_ OP *o)
7322 const OP * const kid = cLISTOPo->op_first->op_sibling;
7323 if (kid && kid->op_type == OP_MATCH) {
7324 if (ckWARN(WARN_SYNTAX)) {
7325 const REGEXP *re = PM_GETRE(kPMOP);
7326 const char *pmstr = re ? re->precomp : "STRING";
7327 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7328 "/%s/ should probably be written as \"%s\"",
7336 Perl_ck_subr(pTHX_ OP *o)
7339 OP *prev = ((cUNOPo->op_first->op_sibling)
7340 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
7341 OP *o2 = prev->op_sibling;
7343 const char *proto = NULL;
7344 const char *proto_end = NULL;
7349 I32 contextclass = 0;
7350 const char *e = NULL;
7353 o->op_private |= OPpENTERSUB_HASTARG;
7354 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
7355 if (cvop->op_type == OP_RV2CV) {
7357 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
7358 op_null(cvop); /* disable rv2cv */
7359 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
7360 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
7361 GV *gv = cGVOPx_gv(tmpop);
7364 tmpop->op_private |= OPpEARLY_CV;
7368 namegv = CvANON(cv) ? gv : CvGV(cv);
7369 proto = SvPV((SV*)cv, len);
7370 proto_end = proto + len;
7372 if (CvASSERTION(cv)) {
7373 U32 asserthints = 0;
7374 HV *const hinthv = GvHV(PL_hintgv);
7376 SV **svp = hv_fetchs(hinthv, "assertions", FALSE);
7378 asserthints = SvUV(*svp);
7380 if (asserthints & HINT_ASSERTING) {
7381 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
7382 o->op_private |= OPpENTERSUB_DB;
7386 if (!(asserthints & HINT_ASSERTIONSSEEN) && ckWARN(WARN_ASSERTIONS)) {
7387 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
7388 "Impossible to activate assertion call");
7395 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7396 if (o2->op_type == OP_CONST)
7397 o2->op_private &= ~OPpCONST_STRICT;
7398 else if (o2->op_type == OP_LIST) {
7399 OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
7400 if (sib && sib->op_type == OP_CONST)
7401 sib->op_private &= ~OPpCONST_STRICT;
7404 o->op_private |= (PL_hints & HINT_STRICT_REFS);
7405 if (PERLDB_SUB && PL_curstash != PL_debstash)
7406 o->op_private |= OPpENTERSUB_DB;
7407 while (o2 != cvop) {
7409 if (PL_madskills && o2->op_type == OP_NULL)
7410 o3 = ((UNOP*)o2)->op_first;
7414 if (proto >= proto_end)
7415 return too_many_arguments(o, gv_ename(namegv));
7423 /* _ must be at the end */
7424 if (proto[1] && proto[1] != ';')
7439 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
7441 arg == 1 ? "block or sub {}" : "sub {}",
7442 gv_ename(namegv), o3);
7445 /* '*' allows any scalar type, including bareword */
7448 if (o3->op_type == OP_RV2GV)
7449 goto wrapref; /* autoconvert GLOB -> GLOBref */
7450 else if (o3->op_type == OP_CONST)
7451 o3->op_private &= ~OPpCONST_STRICT;
7452 else if (o3->op_type == OP_ENTERSUB) {
7453 /* accidental subroutine, revert to bareword */
7454 OP *gvop = ((UNOP*)o3)->op_first;
7455 if (gvop && gvop->op_type == OP_NULL) {
7456 gvop = ((UNOP*)gvop)->op_first;
7458 for (; gvop->op_sibling; gvop = gvop->op_sibling)
7461 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
7462 (gvop = ((UNOP*)gvop)->op_first) &&
7463 gvop->op_type == OP_GV)
7465 GV * const gv = cGVOPx_gv(gvop);
7466 OP * const sibling = o2->op_sibling;
7467 SV * const n = newSVpvs("");
7469 OP * const oldo2 = o2;
7473 gv_fullname4(n, gv, "", FALSE);
7474 o2 = newSVOP(OP_CONST, 0, n);
7475 op_getmad(oldo2,o2,'O');
7476 prev->op_sibling = o2;
7477 o2->op_sibling = sibling;
7493 if (contextclass++ == 0) {
7494 e = strchr(proto, ']');
7495 if (!e || e == proto)
7504 const char *p = proto;
7505 const char *const end = proto;
7507 while (*--p != '[');
7508 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
7510 gv_ename(namegv), o3);
7515 if (o3->op_type == OP_RV2GV)
7518 bad_type(arg, "symbol", gv_ename(namegv), o3);
7521 if (o3->op_type == OP_ENTERSUB)
7524 bad_type(arg, "subroutine entry", gv_ename(namegv),
7528 if (o3->op_type == OP_RV2SV ||
7529 o3->op_type == OP_PADSV ||
7530 o3->op_type == OP_HELEM ||
7531 o3->op_type == OP_AELEM ||
7532 o3->op_type == OP_THREADSV)
7535 bad_type(arg, "scalar", gv_ename(namegv), o3);
7538 if (o3->op_type == OP_RV2AV ||
7539 o3->op_type == OP_PADAV)
7542 bad_type(arg, "array", gv_ename(namegv), o3);
7545 if (o3->op_type == OP_RV2HV ||
7546 o3->op_type == OP_PADHV)
7549 bad_type(arg, "hash", gv_ename(namegv), o3);
7554 OP* const sib = kid->op_sibling;
7555 kid->op_sibling = 0;
7556 o2 = newUNOP(OP_REFGEN, 0, kid);
7557 o2->op_sibling = sib;
7558 prev->op_sibling = o2;
7560 if (contextclass && e) {
7575 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
7576 gv_ename(namegv), (void*)cv);
7581 mod(o2, OP_ENTERSUB);
7583 o2 = o2->op_sibling;
7585 if (o2 == cvop && proto && *proto == '_') {
7586 /* generate an access to $_ */
7588 o2->op_sibling = prev->op_sibling;
7589 prev->op_sibling = o2; /* instead of cvop */
7591 if (proto && !optional && proto_end > proto &&
7592 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
7593 return too_few_arguments(o, gv_ename(namegv));
7596 OP * const oldo = o;
7600 o=newSVOP(OP_CONST, 0, newSViv(0));
7601 op_getmad(oldo,o,'O');
7607 Perl_ck_svconst(pTHX_ OP *o)
7609 PERL_UNUSED_CONTEXT;
7610 SvREADONLY_on(cSVOPo->op_sv);
7615 Perl_ck_chdir(pTHX_ OP *o)
7617 if (o->op_flags & OPf_KIDS) {
7618 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7620 if (kid && kid->op_type == OP_CONST &&
7621 (kid->op_private & OPpCONST_BARE))
7623 o->op_flags |= OPf_SPECIAL;
7624 kid->op_private &= ~OPpCONST_STRICT;
7631 Perl_ck_trunc(pTHX_ OP *o)
7633 if (o->op_flags & OPf_KIDS) {
7634 SVOP *kid = (SVOP*)cUNOPo->op_first;
7636 if (kid->op_type == OP_NULL)
7637 kid = (SVOP*)kid->op_sibling;
7638 if (kid && kid->op_type == OP_CONST &&
7639 (kid->op_private & OPpCONST_BARE))
7641 o->op_flags |= OPf_SPECIAL;
7642 kid->op_private &= ~OPpCONST_STRICT;
7649 Perl_ck_unpack(pTHX_ OP *o)
7651 OP *kid = cLISTOPo->op_first;
7652 if (kid->op_sibling) {
7653 kid = kid->op_sibling;
7654 if (!kid->op_sibling)
7655 kid->op_sibling = newDEFSVOP();
7661 Perl_ck_substr(pTHX_ OP *o)
7664 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
7665 OP *kid = cLISTOPo->op_first;
7667 if (kid->op_type == OP_NULL)
7668 kid = kid->op_sibling;
7670 kid->op_flags |= OPf_MOD;
7676 /* A peephole optimizer. We visit the ops in the order they're to execute.
7677 * See the comments at the top of this file for more details about when
7678 * peep() is called */
7681 Perl_peep(pTHX_ register OP *o)
7684 register OP* oldop = NULL;
7686 if (!o || o->op_opt)
7690 SAVEVPTR(PL_curcop);
7691 for (; o; o = o->op_next) {
7695 switch (o->op_type) {
7699 PL_curcop = ((COP*)o); /* for warnings */
7704 if (cSVOPo->op_private & OPpCONST_STRICT)
7705 no_bareword_allowed(o);
7707 case OP_METHOD_NAMED:
7708 /* Relocate sv to the pad for thread safety.
7709 * Despite being a "constant", the SV is written to,
7710 * for reference counts, sv_upgrade() etc. */
7712 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
7713 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
7714 /* If op_sv is already a PADTMP then it is being used by
7715 * some pad, so make a copy. */
7716 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
7717 SvREADONLY_on(PAD_SVl(ix));
7718 SvREFCNT_dec(cSVOPo->op_sv);
7720 else if (o->op_type == OP_CONST
7721 && cSVOPo->op_sv == &PL_sv_undef) {
7722 /* PL_sv_undef is hack - it's unsafe to store it in the
7723 AV that is the pad, because av_fetch treats values of
7724 PL_sv_undef as a "free" AV entry and will merrily
7725 replace them with a new SV, causing pad_alloc to think
7726 that this pad slot is free. (When, clearly, it is not)
7728 SvOK_off(PAD_SVl(ix));
7729 SvPADTMP_on(PAD_SVl(ix));
7730 SvREADONLY_on(PAD_SVl(ix));
7733 SvREFCNT_dec(PAD_SVl(ix));
7734 SvPADTMP_on(cSVOPo->op_sv);
7735 PAD_SETSV(ix, cSVOPo->op_sv);
7736 /* XXX I don't know how this isn't readonly already. */
7737 SvREADONLY_on(PAD_SVl(ix));
7739 cSVOPo->op_sv = NULL;
7747 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
7748 if (o->op_next->op_private & OPpTARGET_MY) {
7749 if (o->op_flags & OPf_STACKED) /* chained concats */
7750 goto ignore_optimization;
7752 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
7753 o->op_targ = o->op_next->op_targ;
7754 o->op_next->op_targ = 0;
7755 o->op_private |= OPpTARGET_MY;
7758 op_null(o->op_next);
7760 ignore_optimization:
7764 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
7766 break; /* Scalar stub must produce undef. List stub is noop */
7770 if (o->op_targ == OP_NEXTSTATE
7771 || o->op_targ == OP_DBSTATE
7772 || o->op_targ == OP_SETSTATE)
7774 PL_curcop = ((COP*)o);
7776 /* XXX: We avoid setting op_seq here to prevent later calls
7777 to peep() from mistakenly concluding that optimisation
7778 has already occurred. This doesn't fix the real problem,
7779 though (See 20010220.007). AMS 20010719 */
7780 /* op_seq functionality is now replaced by op_opt */
7781 if (oldop && o->op_next) {
7782 oldop->op_next = o->op_next;
7790 if (oldop && o->op_next) {
7791 oldop->op_next = o->op_next;
7799 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
7800 OP* const pop = (o->op_type == OP_PADAV) ?
7801 o->op_next : o->op_next->op_next;
7803 if (pop && pop->op_type == OP_CONST &&
7804 ((PL_op = pop->op_next)) &&
7805 pop->op_next->op_type == OP_AELEM &&
7806 !(pop->op_next->op_private &
7807 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
7808 (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
7813 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
7814 no_bareword_allowed(pop);
7815 if (o->op_type == OP_GV)
7816 op_null(o->op_next);
7817 op_null(pop->op_next);
7819 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
7820 o->op_next = pop->op_next->op_next;
7821 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
7822 o->op_private = (U8)i;
7823 if (o->op_type == OP_GV) {
7828 o->op_flags |= OPf_SPECIAL;
7829 o->op_type = OP_AELEMFAST;
7835 if (o->op_next->op_type == OP_RV2SV) {
7836 if (!(o->op_next->op_private & OPpDEREF)) {
7837 op_null(o->op_next);
7838 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
7840 o->op_next = o->op_next->op_next;
7841 o->op_type = OP_GVSV;
7842 o->op_ppaddr = PL_ppaddr[OP_GVSV];
7845 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
7846 GV * const gv = cGVOPo_gv;
7847 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
7848 /* XXX could check prototype here instead of just carping */
7849 SV * const sv = sv_newmortal();
7850 gv_efullname3(sv, gv, NULL);
7851 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
7852 "%"SVf"() called too early to check prototype",
7856 else if (o->op_next->op_type == OP_READLINE
7857 && o->op_next->op_next->op_type == OP_CONCAT
7858 && (o->op_next->op_next->op_flags & OPf_STACKED))
7860 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
7861 o->op_type = OP_RCATLINE;
7862 o->op_flags |= OPf_STACKED;
7863 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
7864 op_null(o->op_next->op_next);
7865 op_null(o->op_next);
7882 while (cLOGOP->op_other->op_type == OP_NULL)
7883 cLOGOP->op_other = cLOGOP->op_other->op_next;
7884 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
7890 while (cLOOP->op_redoop->op_type == OP_NULL)
7891 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
7892 peep(cLOOP->op_redoop);
7893 while (cLOOP->op_nextop->op_type == OP_NULL)
7894 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
7895 peep(cLOOP->op_nextop);
7896 while (cLOOP->op_lastop->op_type == OP_NULL)
7897 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
7898 peep(cLOOP->op_lastop);
7905 while (cPMOP->op_pmreplstart &&
7906 cPMOP->op_pmreplstart->op_type == OP_NULL)
7907 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
7908 peep(cPMOP->op_pmreplstart);
7913 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
7914 && ckWARN(WARN_SYNTAX))
7916 if (o->op_next->op_sibling) {
7917 const OPCODE type = o->op_next->op_sibling->op_type;
7918 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
7919 const line_t oldline = CopLINE(PL_curcop);
7920 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
7921 Perl_warner(aTHX_ packWARN(WARN_EXEC),
7922 "Statement unlikely to be reached");
7923 Perl_warner(aTHX_ packWARN(WARN_EXEC),
7924 "\t(Maybe you meant system() when you said exec()?)\n");
7925 CopLINE_set(PL_curcop, oldline);
7936 const char *key = NULL;
7941 if (((BINOP*)o)->op_last->op_type != OP_CONST)
7944 /* Make the CONST have a shared SV */
7945 svp = cSVOPx_svp(((BINOP*)o)->op_last);
7946 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
7947 key = SvPV_const(sv, keylen);
7948 lexname = newSVpvn_share(key,
7949 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
7955 if ((o->op_private & (OPpLVAL_INTRO)))
7958 rop = (UNOP*)((BINOP*)o)->op_first;
7959 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7961 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7962 if (!SvPAD_TYPED(lexname))
7964 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
7965 if (!fields || !GvHV(*fields))
7967 key = SvPV_const(*svp, keylen);
7968 if (!hv_fetch(GvHV(*fields), key,
7969 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
7971 Perl_croak(aTHX_ "No such class field \"%s\" "
7972 "in variable %s of type %s",
7973 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
7986 SVOP *first_key_op, *key_op;
7988 if ((o->op_private & (OPpLVAL_INTRO))
7989 /* I bet there's always a pushmark... */
7990 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
7991 /* hmmm, no optimization if list contains only one key. */
7993 rop = (UNOP*)((LISTOP*)o)->op_last;
7994 if (rop->op_type != OP_RV2HV)
7996 if (rop->op_first->op_type == OP_PADSV)
7997 /* @$hash{qw(keys here)} */
7998 rop = (UNOP*)rop->op_first;
8000 /* @{$hash}{qw(keys here)} */
8001 if (rop->op_first->op_type == OP_SCOPE
8002 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
8004 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
8010 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
8011 if (!SvPAD_TYPED(lexname))
8013 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8014 if (!fields || !GvHV(*fields))
8016 /* Again guessing that the pushmark can be jumped over.... */
8017 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
8018 ->op_first->op_sibling;
8019 for (key_op = first_key_op; key_op;
8020 key_op = (SVOP*)key_op->op_sibling) {
8021 if (key_op->op_type != OP_CONST)
8023 svp = cSVOPx_svp(key_op);
8024 key = SvPV_const(*svp, keylen);
8025 if (!hv_fetch(GvHV(*fields), key,
8026 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8028 Perl_croak(aTHX_ "No such class field \"%s\" "
8029 "in variable %s of type %s",
8030 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
8037 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
8041 /* check that RHS of sort is a single plain array */
8042 OP *oright = cUNOPo->op_first;
8043 if (!oright || oright->op_type != OP_PUSHMARK)
8046 /* reverse sort ... can be optimised. */
8047 if (!cUNOPo->op_sibling) {
8048 /* Nothing follows us on the list. */
8049 OP * const reverse = o->op_next;
8051 if (reverse->op_type == OP_REVERSE &&
8052 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
8053 OP * const pushmark = cUNOPx(reverse)->op_first;
8054 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
8055 && (cUNOPx(pushmark)->op_sibling == o)) {
8056 /* reverse -> pushmark -> sort */
8057 o->op_private |= OPpSORT_REVERSE;
8059 pushmark->op_next = oright->op_next;
8065 /* make @a = sort @a act in-place */
8069 oright = cUNOPx(oright)->op_sibling;
8072 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
8073 oright = cUNOPx(oright)->op_sibling;
8077 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
8078 || oright->op_next != o
8079 || (oright->op_private & OPpLVAL_INTRO)
8083 /* o2 follows the chain of op_nexts through the LHS of the
8084 * assign (if any) to the aassign op itself */
8086 if (!o2 || o2->op_type != OP_NULL)
8089 if (!o2 || o2->op_type != OP_PUSHMARK)
8092 if (o2 && o2->op_type == OP_GV)
8095 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
8096 || (o2->op_private & OPpLVAL_INTRO)
8101 if (!o2 || o2->op_type != OP_NULL)
8104 if (!o2 || o2->op_type != OP_AASSIGN
8105 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
8108 /* check that the sort is the first arg on RHS of assign */
8110 o2 = cUNOPx(o2)->op_first;
8111 if (!o2 || o2->op_type != OP_NULL)
8113 o2 = cUNOPx(o2)->op_first;
8114 if (!o2 || o2->op_type != OP_PUSHMARK)
8116 if (o2->op_sibling != o)
8119 /* check the array is the same on both sides */
8120 if (oleft->op_type == OP_RV2AV) {
8121 if (oright->op_type != OP_RV2AV
8122 || !cUNOPx(oright)->op_first
8123 || cUNOPx(oright)->op_first->op_type != OP_GV
8124 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
8125 cGVOPx_gv(cUNOPx(oright)->op_first)
8129 else if (oright->op_type != OP_PADAV
8130 || oright->op_targ != oleft->op_targ
8134 /* transfer MODishness etc from LHS arg to RHS arg */
8135 oright->op_flags = oleft->op_flags;
8136 o->op_private |= OPpSORT_INPLACE;
8138 /* excise push->gv->rv2av->null->aassign */
8139 o2 = o->op_next->op_next;
8140 op_null(o2); /* PUSHMARK */
8142 if (o2->op_type == OP_GV) {
8143 op_null(o2); /* GV */
8146 op_null(o2); /* RV2AV or PADAV */
8147 o2 = o2->op_next->op_next;
8148 op_null(o2); /* AASSIGN */
8150 o->op_next = o2->op_next;
8156 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
8158 LISTOP *enter, *exlist;
8161 enter = (LISTOP *) o->op_next;
8164 if (enter->op_type == OP_NULL) {
8165 enter = (LISTOP *) enter->op_next;
8169 /* for $a (...) will have OP_GV then OP_RV2GV here.
8170 for (...) just has an OP_GV. */
8171 if (enter->op_type == OP_GV) {
8172 gvop = (OP *) enter;
8173 enter = (LISTOP *) enter->op_next;
8176 if (enter->op_type == OP_RV2GV) {
8177 enter = (LISTOP *) enter->op_next;
8183 if (enter->op_type != OP_ENTERITER)
8186 iter = enter->op_next;
8187 if (!iter || iter->op_type != OP_ITER)
8190 expushmark = enter->op_first;
8191 if (!expushmark || expushmark->op_type != OP_NULL
8192 || expushmark->op_targ != OP_PUSHMARK)
8195 exlist = (LISTOP *) expushmark->op_sibling;
8196 if (!exlist || exlist->op_type != OP_NULL
8197 || exlist->op_targ != OP_LIST)
8200 if (exlist->op_last != o) {
8201 /* Mmm. Was expecting to point back to this op. */
8204 theirmark = exlist->op_first;
8205 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
8208 if (theirmark->op_sibling != o) {
8209 /* There's something between the mark and the reverse, eg
8210 for (1, reverse (...))
8215 ourmark = ((LISTOP *)o)->op_first;
8216 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
8219 ourlast = ((LISTOP *)o)->op_last;
8220 if (!ourlast || ourlast->op_next != o)
8223 rv2av = ourmark->op_sibling;
8224 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
8225 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
8226 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
8227 /* We're just reversing a single array. */
8228 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
8229 enter->op_flags |= OPf_STACKED;
8232 /* We don't have control over who points to theirmark, so sacrifice
8234 theirmark->op_next = ourmark->op_next;
8235 theirmark->op_flags = ourmark->op_flags;
8236 ourlast->op_next = gvop ? gvop : (OP *) enter;
8239 enter->op_private |= OPpITER_REVERSED;
8240 iter->op_private |= OPpITER_REVERSED;
8247 UNOP *refgen, *rv2cv;
8250 /* I do not understand this, but if o->op_opt isn't set to 1,
8251 various tests in ext/B/t/bytecode.t fail with no readily
8257 if ((o->op_flags && OPf_WANT) != OPf_WANT_VOID)
8260 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
8263 rv2gv = ((BINOP *)o)->op_last;
8264 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
8267 refgen = (UNOP *)((BINOP *)o)->op_first;
8269 if (!refgen || refgen->op_type != OP_REFGEN)
8272 exlist = (LISTOP *)refgen->op_first;
8273 if (!exlist || exlist->op_type != OP_NULL
8274 || exlist->op_targ != OP_LIST)
8277 if (exlist->op_first->op_type != OP_PUSHMARK)
8280 rv2cv = (UNOP*)exlist->op_last;
8282 if (rv2cv->op_type != OP_RV2CV)
8285 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
8286 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
8287 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
8289 o->op_private |= OPpASSIGN_CV_TO_GV;
8290 rv2gv->op_private |= OPpDONT_INIT_GV;
8291 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
8307 Perl_custom_op_name(pTHX_ const OP* o)
8310 const IV index = PTR2IV(o->op_ppaddr);
8314 if (!PL_custom_op_names) /* This probably shouldn't happen */
8315 return (char *)PL_op_name[OP_CUSTOM];
8317 keysv = sv_2mortal(newSViv(index));
8319 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
8321 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
8323 return SvPV_nolen(HeVAL(he));
8327 Perl_custom_op_desc(pTHX_ const OP* o)
8330 const IV index = PTR2IV(o->op_ppaddr);
8334 if (!PL_custom_op_descs)
8335 return (char *)PL_op_desc[OP_CUSTOM];
8337 keysv = sv_2mortal(newSViv(index));
8339 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
8341 return (char *)PL_op_desc[OP_CUSTOM];
8343 return SvPV_nolen(HeVAL(he));
8348 /* Efficient sub that returns a constant scalar value. */
8350 const_sv_xsub(pTHX_ CV* cv)
8357 Perl_croak(aTHX_ "usage: %s::%s()",
8358 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
8362 ST(0) = (SV*)XSANY.any_ptr;
8368 * c-indentation-style: bsd
8370 * indent-tabs-mode: t
8373 * ex: set ts=8 sts=4 sw=4 noet: