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
283 Perl_op_free(pTHX_ OP *o)
288 if (!o || o->op_static)
292 if (o->op_private & OPpREFCOUNTED) {
303 refcnt = OpREFCNT_dec(o);
314 if (o->op_flags & OPf_KIDS) {
315 register OP *kid, *nextkid;
316 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
317 nextkid = kid->op_sibling; /* Get before next freeing kid */
322 type = (OPCODE)o->op_targ;
324 /* COP* is not cleared by op_clear() so that we may track line
325 * numbers etc even after null() */
326 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
331 #ifdef DEBUG_LEAKING_SCALARS
338 Perl_op_clear(pTHX_ OP *o)
343 /* if (o->op_madprop && o->op_madprop->mad_next)
345 /* FIXME for MAD - if I uncomment these two lines t/op/pack.t fails with
346 "modification of a read only value" for a reason I can't fathom why.
347 It's the "" stringification of $_, where $_ was set to '' in a foreach
348 loop, but it defies simplification into a small test case.
349 However, commenting them out has caused ext/List/Util/t/weak.t to fail
352 mad_free(o->op_madprop);
358 switch (o->op_type) {
359 case OP_NULL: /* Was holding old type, if any. */
360 if (PL_madskills && o->op_targ != OP_NULL) {
361 o->op_type = o->op_targ;
365 case OP_ENTEREVAL: /* Was holding hints. */
369 if (!(o->op_flags & OPf_REF)
370 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
376 if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
377 /* not an OP_PADAV replacement */
379 if (cPADOPo->op_padix > 0) {
380 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
381 * may still exist on the pad */
382 pad_swipe(cPADOPo->op_padix, TRUE);
383 cPADOPo->op_padix = 0;
386 SvREFCNT_dec(cSVOPo->op_sv);
387 cSVOPo->op_sv = NULL;
391 case OP_METHOD_NAMED:
393 SvREFCNT_dec(cSVOPo->op_sv);
394 cSVOPo->op_sv = NULL;
397 Even if op_clear does a pad_free for the target of the op,
398 pad_free doesn't actually remove the sv that exists in the pad;
399 instead it lives on. This results in that it could be reused as
400 a target later on when the pad was reallocated.
403 pad_swipe(o->op_targ,1);
412 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
416 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
417 SvREFCNT_dec(cSVOPo->op_sv);
418 cSVOPo->op_sv = NULL;
421 Safefree(cPVOPo->op_pv);
422 cPVOPo->op_pv = NULL;
426 op_free(cPMOPo->op_pmreplroot);
430 if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) {
431 /* No GvIN_PAD_off here, because other references may still
432 * exist on the pad */
433 pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot), TRUE);
436 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
443 HV * const pmstash = PmopSTASH(cPMOPo);
444 if (pmstash && !SvIS_FREED(pmstash)) {
445 MAGIC * const mg = mg_find((SV*)pmstash, PERL_MAGIC_symtab);
447 PMOP *pmop = (PMOP*) mg->mg_obj;
448 PMOP *lastpmop = NULL;
450 if (cPMOPo == pmop) {
452 lastpmop->op_pmnext = pmop->op_pmnext;
454 mg->mg_obj = (SV*) pmop->op_pmnext;
458 pmop = pmop->op_pmnext;
462 PmopSTASH_free(cPMOPo);
464 cPMOPo->op_pmreplroot = NULL;
465 /* we use the "SAFE" version of the PM_ macros here
466 * since sv_clean_all might release some PMOPs
467 * after PL_regex_padav has been cleared
468 * and the clearing of PL_regex_padav needs to
469 * happen before sv_clean_all
471 ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
472 PM_SETRE_SAFE(cPMOPo, NULL);
474 if(PL_regex_pad) { /* We could be in destruction */
475 av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
476 SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
477 PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
484 if (o->op_targ > 0) {
485 pad_free(o->op_targ);
491 S_cop_free(pTHX_ COP* cop)
493 if (cop->cop_label) {
494 #ifdef PERL_TRACK_MEMPOOL
495 Malloc_t ptr = (Malloc_t)(cop->cop_label - sTHX);
496 struct perl_memory_debug_header *const header
497 = (struct perl_memory_debug_header *)ptr;
498 /* Only the thread that allocated us can free us. */
499 if (header->interpreter == aTHX)
502 Safefree(cop->cop_label);
503 cop->cop_label = NULL;
508 if (! specialWARN(cop->cop_warnings))
509 PerlMemShared_free(cop->cop_warnings);
510 Perl_refcounted_he_free(aTHX_ cop->cop_hints_hash);
514 Perl_op_null(pTHX_ OP *o)
517 if (o->op_type == OP_NULL)
521 o->op_targ = o->op_type;
522 o->op_type = OP_NULL;
523 o->op_ppaddr = PL_ppaddr[OP_NULL];
527 Perl_op_refcnt_lock(pTHX)
535 Perl_op_refcnt_unlock(pTHX)
542 /* Contextualizers */
544 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
547 Perl_linklist(pTHX_ OP *o)
554 /* establish postfix order */
555 first = cUNOPo->op_first;
558 o->op_next = LINKLIST(first);
561 if (kid->op_sibling) {
562 kid->op_next = LINKLIST(kid->op_sibling);
563 kid = kid->op_sibling;
577 Perl_scalarkids(pTHX_ OP *o)
579 if (o && o->op_flags & OPf_KIDS) {
581 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
588 S_scalarboolean(pTHX_ OP *o)
591 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
592 if (ckWARN(WARN_SYNTAX)) {
593 const line_t oldline = CopLINE(PL_curcop);
595 if (PL_copline != NOLINE)
596 CopLINE_set(PL_curcop, PL_copline);
597 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
598 CopLINE_set(PL_curcop, oldline);
605 Perl_scalar(pTHX_ OP *o)
610 /* assumes no premature commitment */
611 if (!o || PL_error_count || (o->op_flags & OPf_WANT)
612 || o->op_type == OP_RETURN)
617 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
619 switch (o->op_type) {
621 scalar(cBINOPo->op_first);
626 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
630 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
631 if (!kPMOP->op_pmreplroot)
632 deprecate_old("implicit split to @_");
640 if (o->op_flags & OPf_KIDS) {
641 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
647 kid = cLISTOPo->op_first;
649 while ((kid = kid->op_sibling)) {
655 PL_curcop = &PL_compiling;
660 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
666 PL_curcop = &PL_compiling;
669 if (ckWARN(WARN_VOID))
670 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
676 Perl_scalarvoid(pTHX_ OP *o)
680 const char* useless = NULL;
684 /* trailing mad null ops don't count as "there" for void processing */
686 o->op_type != OP_NULL &&
688 o->op_sibling->op_type == OP_NULL)
691 for (sib = o->op_sibling;
692 sib && sib->op_type == OP_NULL;
693 sib = sib->op_sibling) ;
699 if (o->op_type == OP_NEXTSTATE
700 || o->op_type == OP_SETSTATE
701 || o->op_type == OP_DBSTATE
702 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
703 || o->op_targ == OP_SETSTATE
704 || o->op_targ == OP_DBSTATE)))
705 PL_curcop = (COP*)o; /* for warning below */
707 /* assumes no premature commitment */
708 want = o->op_flags & OPf_WANT;
709 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
710 || o->op_type == OP_RETURN)
715 if ((o->op_private & OPpTARGET_MY)
716 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
718 return scalar(o); /* As if inside SASSIGN */
721 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
723 switch (o->op_type) {
725 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
729 if (o->op_flags & OPf_STACKED)
733 if (o->op_private == 4)
805 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
806 useless = OP_DESC(o);
810 kid = cUNOPo->op_first;
811 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
812 kid->op_type != OP_TRANS) {
815 useless = "negative pattern binding (!~)";
822 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
823 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
824 useless = "a variable";
829 if (cSVOPo->op_private & OPpCONST_STRICT)
830 no_bareword_allowed(o);
832 if (ckWARN(WARN_VOID)) {
833 useless = "a constant";
834 if (o->op_private & OPpCONST_ARYBASE)
836 /* don't warn on optimised away booleans, eg
837 * use constant Foo, 5; Foo || print; */
838 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
840 /* the constants 0 and 1 are permitted as they are
841 conventionally used as dummies in constructs like
842 1 while some_condition_with_side_effects; */
843 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
845 else if (SvPOK(sv)) {
846 /* perl4's way of mixing documentation and code
847 (before the invention of POD) was based on a
848 trick to mix nroff and perl code. The trick was
849 built upon these three nroff macros being used in
850 void context. The pink camel has the details in
851 the script wrapman near page 319. */
852 const char * const maybe_macro = SvPVX_const(sv);
853 if (strnEQ(maybe_macro, "di", 2) ||
854 strnEQ(maybe_macro, "ds", 2) ||
855 strnEQ(maybe_macro, "ig", 2))
860 op_null(o); /* don't execute or even remember it */
864 o->op_type = OP_PREINC; /* pre-increment is faster */
865 o->op_ppaddr = PL_ppaddr[OP_PREINC];
869 o->op_type = OP_PREDEC; /* pre-decrement is faster */
870 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
874 o->op_type = OP_I_PREINC; /* pre-increment is faster */
875 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
879 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
880 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
889 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
894 if (o->op_flags & OPf_STACKED)
901 if (!(o->op_flags & OPf_KIDS))
912 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
919 /* all requires must return a boolean value */
920 o->op_flags &= ~OPf_WANT;
925 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
926 if (!kPMOP->op_pmreplroot)
927 deprecate_old("implicit split to @_");
931 if (useless && ckWARN(WARN_VOID))
932 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
937 Perl_listkids(pTHX_ OP *o)
939 if (o && o->op_flags & OPf_KIDS) {
941 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
948 Perl_list(pTHX_ OP *o)
953 /* assumes no premature commitment */
954 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
955 || o->op_type == OP_RETURN)
960 if ((o->op_private & OPpTARGET_MY)
961 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
963 return o; /* As if inside SASSIGN */
966 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
968 switch (o->op_type) {
971 list(cBINOPo->op_first);
976 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
984 if (!(o->op_flags & OPf_KIDS))
986 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
987 list(cBINOPo->op_first);
988 return gen_constant_list(o);
995 kid = cLISTOPo->op_first;
997 while ((kid = kid->op_sibling)) {
1003 PL_curcop = &PL_compiling;
1007 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1008 if (kid->op_sibling)
1013 PL_curcop = &PL_compiling;
1016 /* all requires must return a boolean value */
1017 o->op_flags &= ~OPf_WANT;
1024 Perl_scalarseq(pTHX_ OP *o)
1028 const OPCODE type = o->op_type;
1030 if (type == OP_LINESEQ || type == OP_SCOPE ||
1031 type == OP_LEAVE || type == OP_LEAVETRY)
1034 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1035 if (kid->op_sibling) {
1039 PL_curcop = &PL_compiling;
1041 o->op_flags &= ~OPf_PARENS;
1042 if (PL_hints & HINT_BLOCK_SCOPE)
1043 o->op_flags |= OPf_PARENS;
1046 o = newOP(OP_STUB, 0);
1051 S_modkids(pTHX_ OP *o, I32 type)
1053 if (o && o->op_flags & OPf_KIDS) {
1055 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1061 /* Propagate lvalue ("modifiable") context to an op and its children.
1062 * 'type' represents the context type, roughly based on the type of op that
1063 * would do the modifying, although local() is represented by OP_NULL.
1064 * It's responsible for detecting things that can't be modified, flag
1065 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
1066 * might have to vivify a reference in $x), and so on.
1068 * For example, "$a+1 = 2" would cause mod() to be called with o being
1069 * OP_ADD and type being OP_SASSIGN, and would output an error.
1073 Perl_mod(pTHX_ OP *o, I32 type)
1077 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1080 if (!o || PL_error_count)
1083 if ((o->op_private & OPpTARGET_MY)
1084 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1089 switch (o->op_type) {
1095 if (!(o->op_private & OPpCONST_ARYBASE))
1098 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1099 CopARYBASE_set(&PL_compiling,
1100 (I32)SvIV(cSVOPx(PL_eval_start)->op_sv));
1104 SAVECOPARYBASE(&PL_compiling);
1105 CopARYBASE_set(&PL_compiling, 0);
1107 else if (type == OP_REFGEN)
1110 Perl_croak(aTHX_ "That use of $[ is unsupported");
1113 if (o->op_flags & OPf_PARENS || PL_madskills)
1117 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1118 !(o->op_flags & OPf_STACKED)) {
1119 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1120 /* The default is to set op_private to the number of children,
1121 which for a UNOP such as RV2CV is always 1. And w're using
1122 the bit for a flag in RV2CV, so we need it clear. */
1123 o->op_private &= ~1;
1124 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1125 assert(cUNOPo->op_first->op_type == OP_NULL);
1126 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1129 else if (o->op_private & OPpENTERSUB_NOMOD)
1131 else { /* lvalue subroutine call */
1132 o->op_private |= OPpLVAL_INTRO;
1133 PL_modcount = RETURN_UNLIMITED_NUMBER;
1134 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1135 /* Backward compatibility mode: */
1136 o->op_private |= OPpENTERSUB_INARGS;
1139 else { /* Compile-time error message: */
1140 OP *kid = cUNOPo->op_first;
1144 if (kid->op_type != OP_PUSHMARK) {
1145 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1147 "panic: unexpected lvalue entersub "
1148 "args: type/targ %ld:%"UVuf,
1149 (long)kid->op_type, (UV)kid->op_targ);
1150 kid = kLISTOP->op_first;
1152 while (kid->op_sibling)
1153 kid = kid->op_sibling;
1154 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1156 if (kid->op_type == OP_METHOD_NAMED
1157 || kid->op_type == OP_METHOD)
1161 NewOp(1101, newop, 1, UNOP);
1162 newop->op_type = OP_RV2CV;
1163 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1164 newop->op_first = NULL;
1165 newop->op_next = (OP*)newop;
1166 kid->op_sibling = (OP*)newop;
1167 newop->op_private |= OPpLVAL_INTRO;
1168 newop->op_private &= ~1;
1172 if (kid->op_type != OP_RV2CV)
1174 "panic: unexpected lvalue entersub "
1175 "entry via type/targ %ld:%"UVuf,
1176 (long)kid->op_type, (UV)kid->op_targ);
1177 kid->op_private |= OPpLVAL_INTRO;
1178 break; /* Postpone until runtime */
1182 kid = kUNOP->op_first;
1183 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1184 kid = kUNOP->op_first;
1185 if (kid->op_type == OP_NULL)
1187 "Unexpected constant lvalue entersub "
1188 "entry via type/targ %ld:%"UVuf,
1189 (long)kid->op_type, (UV)kid->op_targ);
1190 if (kid->op_type != OP_GV) {
1191 /* Restore RV2CV to check lvalueness */
1193 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1194 okid->op_next = kid->op_next;
1195 kid->op_next = okid;
1198 okid->op_next = NULL;
1199 okid->op_type = OP_RV2CV;
1201 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1202 okid->op_private |= OPpLVAL_INTRO;
1203 okid->op_private &= ~1;
1207 cv = GvCV(kGVOP_gv);
1217 /* grep, foreach, subcalls, refgen */
1218 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1220 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1221 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1223 : (o->op_type == OP_ENTERSUB
1224 ? "non-lvalue subroutine call"
1226 type ? PL_op_desc[type] : "local"));
1240 case OP_RIGHT_SHIFT:
1249 if (!(o->op_flags & OPf_STACKED))
1256 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1262 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1263 PL_modcount = RETURN_UNLIMITED_NUMBER;
1264 return o; /* Treat \(@foo) like ordinary list. */
1268 if (scalar_mod_type(o, type))
1270 ref(cUNOPo->op_first, o->op_type);
1274 if (type == OP_LEAVESUBLV)
1275 o->op_private |= OPpMAYBE_LVSUB;
1281 PL_modcount = RETURN_UNLIMITED_NUMBER;
1284 ref(cUNOPo->op_first, o->op_type);
1289 PL_hints |= HINT_BLOCK_SCOPE;
1304 PL_modcount = RETURN_UNLIMITED_NUMBER;
1305 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1306 return o; /* Treat \(@foo) like ordinary list. */
1307 if (scalar_mod_type(o, type))
1309 if (type == OP_LEAVESUBLV)
1310 o->op_private |= OPpMAYBE_LVSUB;
1314 if (!type) /* local() */
1315 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1316 PAD_COMPNAME_PV(o->op_targ));
1324 if (type != OP_SASSIGN)
1328 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1333 if (type == OP_LEAVESUBLV)
1334 o->op_private |= OPpMAYBE_LVSUB;
1336 pad_free(o->op_targ);
1337 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1338 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1339 if (o->op_flags & OPf_KIDS)
1340 mod(cBINOPo->op_first->op_sibling, type);
1345 ref(cBINOPo->op_first, o->op_type);
1346 if (type == OP_ENTERSUB &&
1347 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1348 o->op_private |= OPpLVAL_DEFER;
1349 if (type == OP_LEAVESUBLV)
1350 o->op_private |= OPpMAYBE_LVSUB;
1360 if (o->op_flags & OPf_KIDS)
1361 mod(cLISTOPo->op_last, type);
1366 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1368 else if (!(o->op_flags & OPf_KIDS))
1370 if (o->op_targ != OP_LIST) {
1371 mod(cBINOPo->op_first, type);
1377 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1382 if (type != OP_LEAVESUBLV)
1384 break; /* mod()ing was handled by ck_return() */
1387 /* [20011101.069] File test operators interpret OPf_REF to mean that
1388 their argument is a filehandle; thus \stat(".") should not set
1390 if (type == OP_REFGEN &&
1391 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1394 if (type != OP_LEAVESUBLV)
1395 o->op_flags |= OPf_MOD;
1397 if (type == OP_AASSIGN || type == OP_SASSIGN)
1398 o->op_flags |= OPf_SPECIAL|OPf_REF;
1399 else if (!type) { /* local() */
1402 o->op_private |= OPpLVAL_INTRO;
1403 o->op_flags &= ~OPf_SPECIAL;
1404 PL_hints |= HINT_BLOCK_SCOPE;
1409 if (ckWARN(WARN_SYNTAX)) {
1410 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1411 "Useless localization of %s", OP_DESC(o));
1415 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1416 && type != OP_LEAVESUBLV)
1417 o->op_flags |= OPf_REF;
1422 S_scalar_mod_type(const OP *o, I32 type)
1426 if (o->op_type == OP_RV2GV)
1450 case OP_RIGHT_SHIFT:
1469 S_is_handle_constructor(const OP *o, I32 numargs)
1471 switch (o->op_type) {
1479 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1492 Perl_refkids(pTHX_ OP *o, I32 type)
1494 if (o && o->op_flags & OPf_KIDS) {
1496 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1503 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
1508 if (!o || PL_error_count)
1511 switch (o->op_type) {
1513 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1514 !(o->op_flags & OPf_STACKED)) {
1515 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1516 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1517 assert(cUNOPo->op_first->op_type == OP_NULL);
1518 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1519 o->op_flags |= OPf_SPECIAL;
1520 o->op_private &= ~1;
1525 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1526 doref(kid, type, set_op_ref);
1529 if (type == OP_DEFINED)
1530 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1531 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1534 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1535 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1536 : type == OP_RV2HV ? OPpDEREF_HV
1538 o->op_flags |= OPf_MOD;
1543 o->op_flags |= OPf_MOD; /* XXX ??? */
1549 o->op_flags |= OPf_REF;
1552 if (type == OP_DEFINED)
1553 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1554 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1560 o->op_flags |= OPf_REF;
1565 if (!(o->op_flags & OPf_KIDS))
1567 doref(cBINOPo->op_first, type, set_op_ref);
1571 doref(cBINOPo->op_first, o->op_type, set_op_ref);
1572 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1573 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1574 : type == OP_RV2HV ? OPpDEREF_HV
1576 o->op_flags |= OPf_MOD;
1586 if (!(o->op_flags & OPf_KIDS))
1588 doref(cLISTOPo->op_last, type, set_op_ref);
1598 S_dup_attrlist(pTHX_ OP *o)
1603 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1604 * where the first kid is OP_PUSHMARK and the remaining ones
1605 * are OP_CONST. We need to push the OP_CONST values.
1607 if (o->op_type == OP_CONST)
1608 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
1610 else if (o->op_type == OP_NULL)
1614 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1616 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1617 if (o->op_type == OP_CONST)
1618 rop = append_elem(OP_LIST, rop,
1619 newSVOP(OP_CONST, o->op_flags,
1620 SvREFCNT_inc_NN(cSVOPo->op_sv)));
1627 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1632 /* fake up C<use attributes $pkg,$rv,@attrs> */
1633 ENTER; /* need to protect against side-effects of 'use' */
1635 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1637 #define ATTRSMODULE "attributes"
1638 #define ATTRSMODULE_PM "attributes.pm"
1641 /* Don't force the C<use> if we don't need it. */
1642 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
1643 if (svp && *svp != &PL_sv_undef)
1644 NOOP; /* already in %INC */
1646 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1647 newSVpvs(ATTRSMODULE), NULL);
1650 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1651 newSVpvs(ATTRSMODULE),
1653 prepend_elem(OP_LIST,
1654 newSVOP(OP_CONST, 0, stashsv),
1655 prepend_elem(OP_LIST,
1656 newSVOP(OP_CONST, 0,
1658 dup_attrlist(attrs))));
1664 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1667 OP *pack, *imop, *arg;
1673 assert(target->op_type == OP_PADSV ||
1674 target->op_type == OP_PADHV ||
1675 target->op_type == OP_PADAV);
1677 /* Ensure that attributes.pm is loaded. */
1678 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1680 /* Need package name for method call. */
1681 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
1683 /* Build up the real arg-list. */
1684 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1686 arg = newOP(OP_PADSV, 0);
1687 arg->op_targ = target->op_targ;
1688 arg = prepend_elem(OP_LIST,
1689 newSVOP(OP_CONST, 0, stashsv),
1690 prepend_elem(OP_LIST,
1691 newUNOP(OP_REFGEN, 0,
1692 mod(arg, OP_REFGEN)),
1693 dup_attrlist(attrs)));
1695 /* Fake up a method call to import */
1696 meth = newSVpvs_share("import");
1697 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1698 append_elem(OP_LIST,
1699 prepend_elem(OP_LIST, pack, list(arg)),
1700 newSVOP(OP_METHOD_NAMED, 0, meth)));
1701 imop->op_private |= OPpENTERSUB_NOMOD;
1703 /* Combine the ops. */
1704 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1708 =notfor apidoc apply_attrs_string
1710 Attempts to apply a list of attributes specified by the C<attrstr> and
1711 C<len> arguments to the subroutine identified by the C<cv> argument which
1712 is expected to be associated with the package identified by the C<stashpv>
1713 argument (see L<attributes>). It gets this wrong, though, in that it
1714 does not correctly identify the boundaries of the individual attribute
1715 specifications within C<attrstr>. This is not really intended for the
1716 public API, but has to be listed here for systems such as AIX which
1717 need an explicit export list for symbols. (It's called from XS code
1718 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1719 to respect attribute syntax properly would be welcome.
1725 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
1726 const char *attrstr, STRLEN len)
1731 len = strlen(attrstr);
1735 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1737 const char * const sstr = attrstr;
1738 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1739 attrs = append_elem(OP_LIST, attrs,
1740 newSVOP(OP_CONST, 0,
1741 newSVpvn(sstr, attrstr-sstr)));
1745 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1746 newSVpvs(ATTRSMODULE),
1747 NULL, prepend_elem(OP_LIST,
1748 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1749 prepend_elem(OP_LIST,
1750 newSVOP(OP_CONST, 0,
1756 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
1761 if (!o || PL_error_count)
1765 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
1766 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
1770 if (type == OP_LIST) {
1772 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1773 my_kid(kid, attrs, imopsp);
1774 } else if (type == OP_UNDEF
1780 } else if (type == OP_RV2SV || /* "our" declaration */
1782 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1783 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1784 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1786 PL_in_my == KEY_our ? "our" : PL_in_my == KEY_state ? "state" : "my"));
1788 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
1790 PL_in_my_stash = NULL;
1791 apply_attrs(GvSTASH(gv),
1792 (type == OP_RV2SV ? GvSV(gv) :
1793 type == OP_RV2AV ? (SV*)GvAV(gv) :
1794 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1797 o->op_private |= OPpOUR_INTRO;
1800 else if (type != OP_PADSV &&
1803 type != OP_PUSHMARK)
1805 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1807 PL_in_my == KEY_our ? "our" : PL_in_my == KEY_state ? "state" : "my"));
1810 else if (attrs && type != OP_PUSHMARK) {
1814 PL_in_my_stash = NULL;
1816 /* check for C<my Dog $spot> when deciding package */
1817 stash = PAD_COMPNAME_TYPE(o->op_targ);
1819 stash = PL_curstash;
1820 apply_attrs_my(stash, o, attrs, imopsp);
1822 o->op_flags |= OPf_MOD;
1823 o->op_private |= OPpLVAL_INTRO;
1824 if (PL_in_my == KEY_state)
1825 o->op_private |= OPpPAD_STATE;
1830 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1834 int maybe_scalar = 0;
1836 /* [perl #17376]: this appears to be premature, and results in code such as
1837 C< our(%x); > executing in list mode rather than void mode */
1839 if (o->op_flags & OPf_PARENS)
1849 o = my_kid(o, attrs, &rops);
1851 if (maybe_scalar && o->op_type == OP_PADSV) {
1852 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
1853 o->op_private |= OPpLVAL_INTRO;
1856 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
1859 PL_in_my_stash = NULL;
1864 Perl_my(pTHX_ OP *o)
1866 return my_attrs(o, NULL);
1870 Perl_sawparens(pTHX_ OP *o)
1872 PERL_UNUSED_CONTEXT;
1874 o->op_flags |= OPf_PARENS;
1879 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
1883 const OPCODE ltype = left->op_type;
1884 const OPCODE rtype = right->op_type;
1886 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
1887 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
1889 const char * const desc
1890 = PL_op_desc[(rtype == OP_SUBST || rtype == OP_TRANS)
1891 ? (int)rtype : OP_MATCH];
1892 const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV)
1893 ? "@array" : "%hash");
1894 Perl_warner(aTHX_ packWARN(WARN_MISC),
1895 "Applying %s to %s will act on scalar(%s)",
1896 desc, sample, sample);
1899 if (rtype == OP_CONST &&
1900 cSVOPx(right)->op_private & OPpCONST_BARE &&
1901 cSVOPx(right)->op_private & OPpCONST_STRICT)
1903 no_bareword_allowed(right);
1906 ismatchop = rtype == OP_MATCH ||
1907 rtype == OP_SUBST ||
1909 if (ismatchop && right->op_private & OPpTARGET_MY) {
1911 right->op_private &= ~OPpTARGET_MY;
1913 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
1916 right->op_flags |= OPf_STACKED;
1917 if (rtype != OP_MATCH &&
1918 ! (rtype == OP_TRANS &&
1919 right->op_private & OPpTRANS_IDENTICAL))
1920 newleft = mod(left, rtype);
1923 if (right->op_type == OP_TRANS)
1924 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
1926 o = prepend_elem(rtype, scalar(newleft), right);
1928 return newUNOP(OP_NOT, 0, scalar(o));
1932 return bind_match(type, left,
1933 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
1937 Perl_invert(pTHX_ OP *o)
1941 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
1945 Perl_scope(pTHX_ OP *o)
1949 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
1950 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
1951 o->op_type = OP_LEAVE;
1952 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
1954 else if (o->op_type == OP_LINESEQ) {
1956 o->op_type = OP_SCOPE;
1957 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
1958 kid = ((LISTOP*)o)->op_first;
1959 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
1962 /* The following deals with things like 'do {1 for 1}' */
1963 kid = kid->op_sibling;
1965 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
1970 o = newLISTOP(OP_SCOPE, 0, o, NULL);
1976 Perl_block_start(pTHX_ int full)
1979 const int retval = PL_savestack_ix;
1980 pad_block_start(full);
1982 PL_hints &= ~HINT_BLOCK_SCOPE;
1983 SAVECOMPILEWARNINGS();
1984 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
1989 Perl_block_end(pTHX_ I32 floor, OP *seq)
1992 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
1993 OP* const retval = scalarseq(seq);
1995 CopHINTS_set(&PL_compiling, PL_hints);
1997 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2006 const PADOFFSET offset = pad_findmy("$_");
2007 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
2008 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2011 OP * const o = newOP(OP_PADSV, 0);
2012 o->op_targ = offset;
2018 Perl_newPROG(pTHX_ OP *o)
2024 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2025 ((PL_in_eval & EVAL_KEEPERR)
2026 ? OPf_SPECIAL : 0), o);
2027 PL_eval_start = linklist(PL_eval_root);
2028 PL_eval_root->op_private |= OPpREFCOUNTED;
2029 OpREFCNT_set(PL_eval_root, 1);
2030 PL_eval_root->op_next = 0;
2031 CALL_PEEP(PL_eval_start);
2034 if (o->op_type == OP_STUB) {
2035 PL_comppad_name = 0;
2040 PL_main_root = scope(sawparens(scalarvoid(o)));
2041 PL_curcop = &PL_compiling;
2042 PL_main_start = LINKLIST(PL_main_root);
2043 PL_main_root->op_private |= OPpREFCOUNTED;
2044 OpREFCNT_set(PL_main_root, 1);
2045 PL_main_root->op_next = 0;
2046 CALL_PEEP(PL_main_start);
2049 /* Register with debugger */
2051 CV * const cv = get_cv("DB::postponed", FALSE);
2055 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2057 call_sv((SV*)cv, G_DISCARD);
2064 Perl_localize(pTHX_ OP *o, I32 lex)
2067 if (o->op_flags & OPf_PARENS)
2068 /* [perl #17376]: this appears to be premature, and results in code such as
2069 C< our(%x); > executing in list mode rather than void mode */
2076 if ( PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ','
2077 && ckWARN(WARN_PARENTHESIS))
2079 char *s = PL_bufptr;
2082 /* some heuristics to detect a potential error */
2083 while (*s && (strchr(", \t\n", *s)))
2087 if (*s && strchr("@$%*", *s) && *++s
2088 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2091 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2093 while (*s && (strchr(", \t\n", *s)))
2099 if (sigil && (*s == ';' || *s == '=')) {
2100 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2101 "Parentheses missing around \"%s\" list",
2102 lex ? (PL_in_my == KEY_our ? "our" : PL_in_my == KEY_state ? "state" : "my")
2110 o = mod(o, OP_NULL); /* a bit kludgey */
2112 PL_in_my_stash = NULL;
2117 Perl_jmaybe(pTHX_ OP *o)
2119 if (o->op_type == OP_LIST) {
2121 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2122 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2128 Perl_fold_constants(pTHX_ register OP *o)
2133 VOL I32 type = o->op_type;
2138 SV * const oldwarnhook = PL_warnhook;
2139 SV * const olddiehook = PL_diehook;
2142 if (PL_opargs[type] & OA_RETSCALAR)
2144 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2145 o->op_targ = pad_alloc(type, SVs_PADTMP);
2147 /* integerize op, unless it happens to be C<-foo>.
2148 * XXX should pp_i_negate() do magic string negation instead? */
2149 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2150 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2151 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2153 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2156 if (!(PL_opargs[type] & OA_FOLDCONST))
2161 /* XXX might want a ck_negate() for this */
2162 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2173 /* XXX what about the numeric ops? */
2174 if (PL_hints & HINT_LOCALE)
2179 goto nope; /* Don't try to run w/ errors */
2181 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2182 const OPCODE type = curop->op_type;
2183 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2185 type != OP_SCALAR &&
2187 type != OP_PUSHMARK)
2193 curop = LINKLIST(o);
2194 old_next = o->op_next;
2198 oldscope = PL_scopestack_ix;
2199 create_eval_scope(G_FAKINGEVAL);
2201 PL_warnhook = PERL_WARNHOOK_FATAL;
2208 sv = *(PL_stack_sp--);
2209 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2210 pad_swipe(o->op_targ, FALSE);
2211 else if (SvTEMP(sv)) { /* grab mortal temp? */
2212 SvREFCNT_inc_simple_void(sv);
2217 /* Something tried to die. Abandon constant folding. */
2218 /* Pretend the error never happened. */
2219 sv_setpvn(ERRSV,"",0);
2220 o->op_next = old_next;
2224 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
2225 PL_warnhook = oldwarnhook;
2226 PL_diehook = olddiehook;
2227 /* XXX note that this croak may fail as we've already blown away
2228 * the stack - eg any nested evals */
2229 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
2232 PL_warnhook = oldwarnhook;
2233 PL_diehook = olddiehook;
2235 if (PL_scopestack_ix > oldscope)
2236 delete_eval_scope();
2245 if (type == OP_RV2GV)
2246 newop = newGVOP(OP_GV, 0, (GV*)sv);
2248 newop = newSVOP(OP_CONST, 0, (SV*)sv);
2249 op_getmad(o,newop,'f');
2257 Perl_gen_constant_list(pTHX_ register OP *o)
2261 const I32 oldtmps_floor = PL_tmps_floor;
2265 return o; /* Don't attempt to run with errors */
2267 PL_op = curop = LINKLIST(o);
2273 assert (!(curop->op_flags & OPf_SPECIAL));
2274 assert(curop->op_type == OP_RANGE);
2276 PL_tmps_floor = oldtmps_floor;
2278 o->op_type = OP_RV2AV;
2279 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2280 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2281 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2282 o->op_opt = 0; /* needs to be revisited in peep() */
2283 curop = ((UNOP*)o)->op_first;
2284 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
2286 op_getmad(curop,o,'O');
2295 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2298 if (!o || o->op_type != OP_LIST)
2299 o = newLISTOP(OP_LIST, 0, o, NULL);
2301 o->op_flags &= ~OPf_WANT;
2303 if (!(PL_opargs[type] & OA_MARK))
2304 op_null(cLISTOPo->op_first);
2306 o->op_type = (OPCODE)type;
2307 o->op_ppaddr = PL_ppaddr[type];
2308 o->op_flags |= flags;
2310 o = CHECKOP(type, o);
2311 if (o->op_type != (unsigned)type)
2314 return fold_constants(o);
2317 /* List constructors */
2320 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2328 if (first->op_type != (unsigned)type
2329 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2331 return newLISTOP(type, 0, first, last);
2334 if (first->op_flags & OPf_KIDS)
2335 ((LISTOP*)first)->op_last->op_sibling = last;
2337 first->op_flags |= OPf_KIDS;
2338 ((LISTOP*)first)->op_first = last;
2340 ((LISTOP*)first)->op_last = last;
2345 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2353 if (first->op_type != (unsigned)type)
2354 return prepend_elem(type, (OP*)first, (OP*)last);
2356 if (last->op_type != (unsigned)type)
2357 return append_elem(type, (OP*)first, (OP*)last);
2359 first->op_last->op_sibling = last->op_first;
2360 first->op_last = last->op_last;
2361 first->op_flags |= (last->op_flags & OPf_KIDS);
2364 if (last->op_first && first->op_madprop) {
2365 MADPROP *mp = last->op_first->op_madprop;
2367 while (mp->mad_next)
2369 mp->mad_next = first->op_madprop;
2372 last->op_first->op_madprop = first->op_madprop;
2375 first->op_madprop = last->op_madprop;
2376 last->op_madprop = 0;
2385 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2393 if (last->op_type == (unsigned)type) {
2394 if (type == OP_LIST) { /* already a PUSHMARK there */
2395 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2396 ((LISTOP*)last)->op_first->op_sibling = first;
2397 if (!(first->op_flags & OPf_PARENS))
2398 last->op_flags &= ~OPf_PARENS;
2401 if (!(last->op_flags & OPf_KIDS)) {
2402 ((LISTOP*)last)->op_last = first;
2403 last->op_flags |= OPf_KIDS;
2405 first->op_sibling = ((LISTOP*)last)->op_first;
2406 ((LISTOP*)last)->op_first = first;
2408 last->op_flags |= OPf_KIDS;
2412 return newLISTOP(type, 0, first, last);
2420 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2423 Newxz(tk, 1, TOKEN);
2424 tk->tk_type = (OPCODE)optype;
2425 tk->tk_type = 12345;
2427 tk->tk_mad = madprop;
2432 Perl_token_free(pTHX_ TOKEN* tk)
2434 if (tk->tk_type != 12345)
2436 mad_free(tk->tk_mad);
2441 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2445 if (tk->tk_type != 12345) {
2446 Perl_warner(aTHX_ packWARN(WARN_MISC),
2447 "Invalid TOKEN object ignored");
2454 /* faked up qw list? */
2456 tm->mad_type == MAD_SV &&
2457 SvPVX((SV*)tm->mad_val)[0] == 'q')
2464 /* pretend constant fold didn't happen? */
2465 if (mp->mad_key == 'f' &&
2466 (o->op_type == OP_CONST ||
2467 o->op_type == OP_GV) )
2469 token_getmad(tk,(OP*)mp->mad_val,slot);
2483 if (mp->mad_key == 'X')
2484 mp->mad_key = slot; /* just change the first one */
2494 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
2503 /* pretend constant fold didn't happen? */
2504 if (mp->mad_key == 'f' &&
2505 (o->op_type == OP_CONST ||
2506 o->op_type == OP_GV) )
2508 op_getmad(from,(OP*)mp->mad_val,slot);
2515 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
2518 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
2524 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
2533 /* pretend constant fold didn't happen? */
2534 if (mp->mad_key == 'f' &&
2535 (o->op_type == OP_CONST ||
2536 o->op_type == OP_GV) )
2538 op_getmad(from,(OP*)mp->mad_val,slot);
2545 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
2548 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
2552 PerlIO_printf(PerlIO_stderr(),
2553 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
2559 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
2577 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
2581 addmad(tm, &(o->op_madprop), slot);
2585 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
2606 Perl_newMADsv(pTHX_ char key, SV* sv)
2608 return newMADPROP(key, MAD_SV, sv, 0);
2612 Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
2615 Newxz(mp, 1, MADPROP);
2618 mp->mad_vlen = vlen;
2619 mp->mad_type = type;
2621 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
2626 Perl_mad_free(pTHX_ MADPROP* mp)
2628 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
2632 mad_free(mp->mad_next);
2633 /* if (PL_lex_state != LEX_NOTPARSING && mp->mad_vlen)
2634 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
2635 switch (mp->mad_type) {
2639 Safefree((char*)mp->mad_val);
2642 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
2643 op_free((OP*)mp->mad_val);
2646 sv_free((SV*)mp->mad_val);
2649 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
2658 Perl_newNULLLIST(pTHX)
2660 return newOP(OP_STUB, 0);
2664 Perl_force_list(pTHX_ OP *o)
2666 if (!o || o->op_type != OP_LIST)
2667 o = newLISTOP(OP_LIST, 0, o, NULL);
2673 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2678 NewOp(1101, listop, 1, LISTOP);
2680 listop->op_type = (OPCODE)type;
2681 listop->op_ppaddr = PL_ppaddr[type];
2684 listop->op_flags = (U8)flags;
2688 else if (!first && last)
2691 first->op_sibling = last;
2692 listop->op_first = first;
2693 listop->op_last = last;
2694 if (type == OP_LIST) {
2695 OP* const pushop = newOP(OP_PUSHMARK, 0);
2696 pushop->op_sibling = first;
2697 listop->op_first = pushop;
2698 listop->op_flags |= OPf_KIDS;
2700 listop->op_last = pushop;
2703 return CHECKOP(type, listop);
2707 Perl_newOP(pTHX_ I32 type, I32 flags)
2711 NewOp(1101, o, 1, OP);
2712 o->op_type = (OPCODE)type;
2713 o->op_ppaddr = PL_ppaddr[type];
2714 o->op_flags = (U8)flags;
2717 o->op_private = (U8)(0 | (flags >> 8));
2718 if (PL_opargs[type] & OA_RETSCALAR)
2720 if (PL_opargs[type] & OA_TARGET)
2721 o->op_targ = pad_alloc(type, SVs_PADTMP);
2722 return CHECKOP(type, o);
2726 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2732 first = newOP(OP_STUB, 0);
2733 if (PL_opargs[type] & OA_MARK)
2734 first = force_list(first);
2736 NewOp(1101, unop, 1, UNOP);
2737 unop->op_type = (OPCODE)type;
2738 unop->op_ppaddr = PL_ppaddr[type];
2739 unop->op_first = first;
2740 unop->op_flags = (U8)(flags | OPf_KIDS);
2741 unop->op_private = (U8)(1 | (flags >> 8));
2742 unop = (UNOP*) CHECKOP(type, unop);
2746 return fold_constants((OP *) unop);
2750 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2754 NewOp(1101, binop, 1, BINOP);
2757 first = newOP(OP_NULL, 0);
2759 binop->op_type = (OPCODE)type;
2760 binop->op_ppaddr = PL_ppaddr[type];
2761 binop->op_first = first;
2762 binop->op_flags = (U8)(flags | OPf_KIDS);
2765 binop->op_private = (U8)(1 | (flags >> 8));
2768 binop->op_private = (U8)(2 | (flags >> 8));
2769 first->op_sibling = last;
2772 binop = (BINOP*)CHECKOP(type, binop);
2773 if (binop->op_next || binop->op_type != (OPCODE)type)
2776 binop->op_last = binop->op_first->op_sibling;
2778 return fold_constants((OP *)binop);
2781 static int uvcompare(const void *a, const void *b)
2782 __attribute__nonnull__(1)
2783 __attribute__nonnull__(2)
2784 __attribute__pure__;
2785 static int uvcompare(const void *a, const void *b)
2787 if (*((const UV *)a) < (*(const UV *)b))
2789 if (*((const UV *)a) > (*(const UV *)b))
2791 if (*((const UV *)a+1) < (*(const UV *)b+1))
2793 if (*((const UV *)a+1) > (*(const UV *)b+1))
2799 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2802 SV * const tstr = ((SVOP*)expr)->op_sv;
2803 SV * const rstr = ((SVOP*)repl)->op_sv;
2806 const U8 *t = (U8*)SvPV_const(tstr, tlen);
2807 const U8 *r = (U8*)SvPV_const(rstr, rlen);
2811 register short *tbl;
2813 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
2814 const I32 squash = o->op_private & OPpTRANS_SQUASH;
2815 I32 del = o->op_private & OPpTRANS_DELETE;
2816 PL_hints |= HINT_BLOCK_SCOPE;
2819 o->op_private |= OPpTRANS_FROM_UTF;
2822 o->op_private |= OPpTRANS_TO_UTF;
2824 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2825 SV* const listsv = newSVpvs("# comment\n");
2827 const U8* tend = t + tlen;
2828 const U8* rend = r + rlen;
2842 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2843 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2846 const U32 flags = UTF8_ALLOW_DEFAULT;
2850 t = tsave = bytes_to_utf8(t, &len);
2853 if (!to_utf && rlen) {
2855 r = rsave = bytes_to_utf8(r, &len);
2859 /* There are several snags with this code on EBCDIC:
2860 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2861 2. scan_const() in toke.c has encoded chars in native encoding which makes
2862 ranges at least in EBCDIC 0..255 range the bottom odd.
2866 U8 tmpbuf[UTF8_MAXBYTES+1];
2869 Newx(cp, 2*tlen, UV);
2871 transv = newSVpvs("");
2873 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
2875 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2877 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
2881 cp[2*i+1] = cp[2*i];
2885 qsort(cp, i, 2*sizeof(UV), uvcompare);
2886 for (j = 0; j < i; j++) {
2888 diff = val - nextmin;
2890 t = uvuni_to_utf8(tmpbuf,nextmin);
2891 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2893 U8 range_mark = UTF_TO_NATIVE(0xff);
2894 t = uvuni_to_utf8(tmpbuf, val - 1);
2895 sv_catpvn(transv, (char *)&range_mark, 1);
2896 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2903 t = uvuni_to_utf8(tmpbuf,nextmin);
2904 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2906 U8 range_mark = UTF_TO_NATIVE(0xff);
2907 sv_catpvn(transv, (char *)&range_mark, 1);
2909 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2910 UNICODE_ALLOW_SUPER);
2911 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2912 t = (const U8*)SvPVX_const(transv);
2913 tlen = SvCUR(transv);
2917 else if (!rlen && !del) {
2918 r = t; rlen = tlen; rend = tend;
2921 if ((!rlen && !del) || t == r ||
2922 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2924 o->op_private |= OPpTRANS_IDENTICAL;
2928 while (t < tend || tfirst <= tlast) {
2929 /* see if we need more "t" chars */
2930 if (tfirst > tlast) {
2931 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
2933 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2935 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
2942 /* now see if we need more "r" chars */
2943 if (rfirst > rlast) {
2945 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
2947 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2949 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
2958 rfirst = rlast = 0xffffffff;
2962 /* now see which range will peter our first, if either. */
2963 tdiff = tlast - tfirst;
2964 rdiff = rlast - rfirst;
2971 if (rfirst == 0xffffffff) {
2972 diff = tdiff; /* oops, pretend rdiff is infinite */
2974 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2975 (long)tfirst, (long)tlast);
2977 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2981 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2982 (long)tfirst, (long)(tfirst + diff),
2985 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2986 (long)tfirst, (long)rfirst);
2988 if (rfirst + diff > max)
2989 max = rfirst + diff;
2991 grows = (tfirst < rfirst &&
2992 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3004 else if (max > 0xff)
3009 Safefree(cPVOPo->op_pv);
3010 cPVOPo->op_pv = NULL;
3011 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
3012 SvREFCNT_dec(listsv);
3013 SvREFCNT_dec(transv);
3015 if (!del && havefinal && rlen)
3016 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
3017 newSVuv((UV)final), 0);
3020 o->op_private |= OPpTRANS_GROWS;
3026 op_getmad(expr,o,'e');
3027 op_getmad(repl,o,'r');
3035 tbl = (short*)cPVOPo->op_pv;
3037 Zero(tbl, 256, short);
3038 for (i = 0; i < (I32)tlen; i++)
3040 for (i = 0, j = 0; i < 256; i++) {
3042 if (j >= (I32)rlen) {
3051 if (i < 128 && r[j] >= 128)
3061 o->op_private |= OPpTRANS_IDENTICAL;
3063 else if (j >= (I32)rlen)
3066 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
3067 tbl[0x100] = (short)(rlen - j);
3068 for (i=0; i < (I32)rlen - j; i++)
3069 tbl[0x101+i] = r[j+i];
3073 if (!rlen && !del) {
3076 o->op_private |= OPpTRANS_IDENTICAL;
3078 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3079 o->op_private |= OPpTRANS_IDENTICAL;
3081 for (i = 0; i < 256; i++)
3083 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3084 if (j >= (I32)rlen) {
3086 if (tbl[t[i]] == -1)
3092 if (tbl[t[i]] == -1) {
3093 if (t[i] < 128 && r[j] >= 128)
3100 o->op_private |= OPpTRANS_GROWS;
3102 op_getmad(expr,o,'e');
3103 op_getmad(repl,o,'r');
3113 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3118 NewOp(1101, pmop, 1, PMOP);
3119 pmop->op_type = (OPCODE)type;
3120 pmop->op_ppaddr = PL_ppaddr[type];
3121 pmop->op_flags = (U8)flags;
3122 pmop->op_private = (U8)(0 | (flags >> 8));
3124 if (PL_hints & HINT_RE_TAINT)
3125 pmop->op_pmpermflags |= PMf_RETAINT;
3126 if (PL_hints & HINT_LOCALE)
3127 pmop->op_pmpermflags |= PMf_LOCALE;
3128 pmop->op_pmflags = pmop->op_pmpermflags;
3131 if (av_len((AV*) PL_regex_pad[0]) > -1) {
3132 SV * const repointer = av_pop((AV*)PL_regex_pad[0]);
3133 pmop->op_pmoffset = SvIV(repointer);
3134 SvREPADTMP_off(repointer);
3135 sv_setiv(repointer,0);
3137 SV * const repointer = newSViv(0);
3138 av_push(PL_regex_padav, SvREFCNT_inc_simple_NN(repointer));
3139 pmop->op_pmoffset = av_len(PL_regex_padav);
3140 PL_regex_pad = AvARRAY(PL_regex_padav);
3144 /* link into pm list */
3145 if (type != OP_TRANS && PL_curstash) {
3146 MAGIC *mg = mg_find((SV*)PL_curstash, PERL_MAGIC_symtab);
3149 mg = sv_magicext((SV*)PL_curstash, 0, PERL_MAGIC_symtab, 0, 0, 0);
3151 pmop->op_pmnext = (PMOP*)mg->mg_obj;
3152 mg->mg_obj = (SV*)pmop;
3153 PmopSTASH_set(pmop,PL_curstash);
3156 return CHECKOP(type, pmop);
3159 /* Given some sort of match op o, and an expression expr containing a
3160 * pattern, either compile expr into a regex and attach it to o (if it's
3161 * constant), or convert expr into a runtime regcomp op sequence (if it's
3164 * isreg indicates that the pattern is part of a regex construct, eg
3165 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3166 * split "pattern", which aren't. In the former case, expr will be a list
3167 * if the pattern contains more than one term (eg /a$b/) or if it contains
3168 * a replacement, ie s/// or tr///.
3172 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
3177 I32 repl_has_vars = 0;
3181 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
3182 /* last element in list is the replacement; pop it */
3184 repl = cLISTOPx(expr)->op_last;
3185 kid = cLISTOPx(expr)->op_first;
3186 while (kid->op_sibling != repl)
3187 kid = kid->op_sibling;
3188 kid->op_sibling = NULL;
3189 cLISTOPx(expr)->op_last = kid;
3192 if (isreg && expr->op_type == OP_LIST &&
3193 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3195 /* convert single element list to element */
3196 OP* const oe = expr;
3197 expr = cLISTOPx(oe)->op_first->op_sibling;
3198 cLISTOPx(oe)->op_first->op_sibling = NULL;
3199 cLISTOPx(oe)->op_last = NULL;
3203 if (o->op_type == OP_TRANS) {
3204 return pmtrans(o, expr, repl);
3207 reglist = isreg && expr->op_type == OP_LIST;
3211 PL_hints |= HINT_BLOCK_SCOPE;
3214 if (expr->op_type == OP_CONST) {
3216 SV * const pat = ((SVOP*)expr)->op_sv;
3217 const char *p = SvPV_const(pat, plen);
3218 if ((o->op_flags & OPf_SPECIAL) && (*p == ' ' && p[1] == '\0')) {
3219 U32 was_readonly = SvREADONLY(pat);
3223 sv_force_normal_flags(pat, 0);
3224 assert(!SvREADONLY(pat));
3227 SvREADONLY_off(pat);
3231 sv_setpvn(pat, "\\s+", 3);
3233 SvFLAGS(pat) |= was_readonly;
3235 p = SvPV_const(pat, plen);
3236 pm->op_pmflags |= PMf_SKIPWHITE;
3239 pm->op_pmdynflags |= PMdf_UTF8;
3240 /* FIXME - can we make this function take const char * args? */
3241 PM_SETRE(pm, CALLREGCOMP((char*)p, (char*)p + plen, pm));
3242 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
3243 pm->op_pmflags |= PMf_WHITE;
3245 op_getmad(expr,(OP*)pm,'e');
3251 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3252 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3254 : OP_REGCMAYBE),0,expr);
3256 NewOp(1101, rcop, 1, LOGOP);
3257 rcop->op_type = OP_REGCOMP;
3258 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3259 rcop->op_first = scalar(expr);
3260 rcop->op_flags |= OPf_KIDS
3261 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3262 | (reglist ? OPf_STACKED : 0);
3263 rcop->op_private = 1;
3266 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3268 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
3271 /* establish postfix order */
3272 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3274 rcop->op_next = expr;
3275 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3278 rcop->op_next = LINKLIST(expr);
3279 expr->op_next = (OP*)rcop;
3282 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3287 if (pm->op_pmflags & PMf_EVAL) {
3289 if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
3290 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
3292 else if (repl->op_type == OP_CONST)
3296 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3297 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3298 if (curop->op_type == OP_GV) {
3299 GV * const gv = cGVOPx_gv(curop);
3301 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3304 else if (curop->op_type == OP_RV2CV)
3306 else if (curop->op_type == OP_RV2SV ||
3307 curop->op_type == OP_RV2AV ||
3308 curop->op_type == OP_RV2HV ||
3309 curop->op_type == OP_RV2GV) {
3310 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3313 else if (curop->op_type == OP_PADSV ||
3314 curop->op_type == OP_PADAV ||
3315 curop->op_type == OP_PADHV ||
3316 curop->op_type == OP_PADANY) {
3319 else if (curop->op_type == OP_PUSHRE)
3320 NOOP; /* Okay here, dangerous in newASSIGNOP */
3330 || PM_GETRE(pm)->extflags & RXf_EVAL_SEEN))) {
3331 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3332 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
3333 prepend_elem(o->op_type, scalar(repl), o);
3336 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3337 pm->op_pmflags |= PMf_MAYBE_CONST;
3338 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3340 NewOp(1101, rcop, 1, LOGOP);
3341 rcop->op_type = OP_SUBSTCONT;
3342 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3343 rcop->op_first = scalar(repl);
3344 rcop->op_flags |= OPf_KIDS;
3345 rcop->op_private = 1;
3348 /* establish postfix order */
3349 rcop->op_next = LINKLIST(repl);
3350 repl->op_next = (OP*)rcop;
3352 pm->op_pmreplroot = scalar((OP*)rcop);
3353 pm->op_pmreplstart = LINKLIST(rcop);
3362 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3366 NewOp(1101, svop, 1, SVOP);
3367 svop->op_type = (OPCODE)type;
3368 svop->op_ppaddr = PL_ppaddr[type];
3370 svop->op_next = (OP*)svop;
3371 svop->op_flags = (U8)flags;
3372 if (PL_opargs[type] & OA_RETSCALAR)
3374 if (PL_opargs[type] & OA_TARGET)
3375 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3376 return CHECKOP(type, svop);
3380 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3384 NewOp(1101, padop, 1, PADOP);
3385 padop->op_type = (OPCODE)type;
3386 padop->op_ppaddr = PL_ppaddr[type];
3387 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3388 SvREFCNT_dec(PAD_SVl(padop->op_padix));
3389 PAD_SETSV(padop->op_padix, sv);
3392 padop->op_next = (OP*)padop;
3393 padop->op_flags = (U8)flags;
3394 if (PL_opargs[type] & OA_RETSCALAR)
3396 if (PL_opargs[type] & OA_TARGET)
3397 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3398 return CHECKOP(type, padop);
3402 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3408 return newPADOP(type, flags, SvREFCNT_inc_simple(gv));
3410 return newSVOP(type, flags, SvREFCNT_inc_simple(gv));
3415 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3419 NewOp(1101, pvop, 1, PVOP);
3420 pvop->op_type = (OPCODE)type;
3421 pvop->op_ppaddr = PL_ppaddr[type];
3423 pvop->op_next = (OP*)pvop;
3424 pvop->op_flags = (U8)flags;
3425 if (PL_opargs[type] & OA_RETSCALAR)
3427 if (PL_opargs[type] & OA_TARGET)
3428 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3429 return CHECKOP(type, pvop);
3437 Perl_package(pTHX_ OP *o)
3446 save_hptr(&PL_curstash);
3447 save_item(PL_curstname);
3449 name = SvPV_const(cSVOPo->op_sv, len);
3450 PL_curstash = gv_stashpvn(name, len, TRUE);
3451 sv_setpvn(PL_curstname, name, len);
3453 PL_hints |= HINT_BLOCK_SCOPE;
3454 PL_copline = NOLINE;
3460 if (!PL_madskills) {
3465 pegop = newOP(OP_NULL,0);
3466 op_getmad(o,pegop,'P');
3476 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3483 OP *pegop = newOP(OP_NULL,0);
3486 if (idop->op_type != OP_CONST)
3487 Perl_croak(aTHX_ "Module name must be constant");
3490 op_getmad(idop,pegop,'U');
3495 SV * const vesv = ((SVOP*)version)->op_sv;
3498 op_getmad(version,pegop,'V');
3499 if (!arg && !SvNIOKp(vesv)) {
3506 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3507 Perl_croak(aTHX_ "Version number must be constant number");
3509 /* Make copy of idop so we don't free it twice */
3510 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3512 /* Fake up a method call to VERSION */
3513 meth = newSVpvs_share("VERSION");
3514 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3515 append_elem(OP_LIST,
3516 prepend_elem(OP_LIST, pack, list(version)),
3517 newSVOP(OP_METHOD_NAMED, 0, meth)));
3521 /* Fake up an import/unimport */
3522 if (arg && arg->op_type == OP_STUB) {
3524 op_getmad(arg,pegop,'S');
3525 imop = arg; /* no import on explicit () */
3527 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3528 imop = NULL; /* use 5.0; */
3530 idop->op_private |= OPpCONST_NOVER;
3536 op_getmad(arg,pegop,'A');
3538 /* Make copy of idop so we don't free it twice */
3539 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3541 /* Fake up a method call to import/unimport */
3543 ? newSVpvs_share("import") : newSVpvs_share("unimport");
3544 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3545 append_elem(OP_LIST,
3546 prepend_elem(OP_LIST, pack, list(arg)),
3547 newSVOP(OP_METHOD_NAMED, 0, meth)));
3550 /* Fake up the BEGIN {}, which does its thing immediately. */
3552 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
3555 append_elem(OP_LINESEQ,
3556 append_elem(OP_LINESEQ,
3557 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
3558 newSTATEOP(0, NULL, veop)),
3559 newSTATEOP(0, NULL, imop) ));
3561 /* The "did you use incorrect case?" warning used to be here.
3562 * The problem is that on case-insensitive filesystems one
3563 * might get false positives for "use" (and "require"):
3564 * "use Strict" or "require CARP" will work. This causes
3565 * portability problems for the script: in case-strict
3566 * filesystems the script will stop working.
3568 * The "incorrect case" warning checked whether "use Foo"
3569 * imported "Foo" to your namespace, but that is wrong, too:
3570 * there is no requirement nor promise in the language that
3571 * a Foo.pm should or would contain anything in package "Foo".
3573 * There is very little Configure-wise that can be done, either:
3574 * the case-sensitivity of the build filesystem of Perl does not
3575 * help in guessing the case-sensitivity of the runtime environment.
3578 PL_hints |= HINT_BLOCK_SCOPE;
3579 PL_copline = NOLINE;
3581 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3584 if (!PL_madskills) {
3585 /* FIXME - don't allocate pegop if !PL_madskills */
3594 =head1 Embedding Functions
3596 =for apidoc load_module
3598 Loads the module whose name is pointed to by the string part of name.
3599 Note that the actual module name, not its filename, should be given.
3600 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3601 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3602 (or 0 for no flags). ver, if specified, provides version semantics
3603 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3604 arguments can be used to specify arguments to the module's import()
3605 method, similar to C<use Foo::Bar VERSION LIST>.
3610 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3613 va_start(args, ver);
3614 vload_module(flags, name, ver, &args);
3618 #ifdef PERL_IMPLICIT_CONTEXT
3620 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3624 va_start(args, ver);
3625 vload_module(flags, name, ver, &args);
3631 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3636 OP * const modname = newSVOP(OP_CONST, 0, name);
3637 modname->op_private |= OPpCONST_BARE;
3639 veop = newSVOP(OP_CONST, 0, ver);
3643 if (flags & PERL_LOADMOD_NOIMPORT) {
3644 imop = sawparens(newNULLLIST());
3646 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3647 imop = va_arg(*args, OP*);
3652 sv = va_arg(*args, SV*);
3654 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3655 sv = va_arg(*args, SV*);
3659 const line_t ocopline = PL_copline;
3660 COP * const ocurcop = PL_curcop;
3661 const int oexpect = PL_expect;
3663 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3664 veop, modname, imop);
3665 PL_expect = oexpect;
3666 PL_copline = ocopline;
3667 PL_curcop = ocurcop;
3672 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
3678 if (!force_builtin) {
3679 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
3680 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
3681 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
3682 gv = gvp ? *gvp : NULL;
3686 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3687 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3688 append_elem(OP_LIST, term,
3689 scalar(newUNOP(OP_RV2CV, 0,
3690 newGVOP(OP_GV, 0, gv))))));
3693 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3699 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3701 return newBINOP(OP_LSLICE, flags,
3702 list(force_list(subscript)),
3703 list(force_list(listval)) );
3707 S_is_list_assignment(pTHX_ register const OP *o)
3715 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
3716 o = cUNOPo->op_first;
3718 flags = o->op_flags;
3720 if (type == OP_COND_EXPR) {
3721 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
3722 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3727 yyerror("Assignment to both a list and a scalar");
3731 if (type == OP_LIST &&
3732 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
3733 o->op_private & OPpLVAL_INTRO)
3736 if (type == OP_LIST || flags & OPf_PARENS ||
3737 type == OP_RV2AV || type == OP_RV2HV ||
3738 type == OP_ASLICE || type == OP_HSLICE)
3741 if (type == OP_PADAV || type == OP_PADHV)
3744 if (type == OP_RV2SV)
3751 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3757 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3758 return newLOGOP(optype, 0,
3759 mod(scalar(left), optype),
3760 newUNOP(OP_SASSIGN, 0, scalar(right)));
3763 return newBINOP(optype, OPf_STACKED,
3764 mod(scalar(left), optype), scalar(right));
3768 if (is_list_assignment(left)) {
3772 /* Grandfathering $[ assignment here. Bletch.*/
3773 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
3774 PL_eval_start = (left->op_type == OP_CONST) ? right : 0;
3775 left = mod(left, OP_AASSIGN);
3778 else if (left->op_type == OP_CONST) {
3780 /* Result of assignment is always 1 (or we'd be dead already) */
3781 return newSVOP(OP_CONST, 0, newSViv(1));
3783 curop = list(force_list(left));
3784 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3785 o->op_private = (U8)(0 | (flags >> 8));
3787 /* PL_generation sorcery:
3788 * an assignment like ($a,$b) = ($c,$d) is easier than
3789 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3790 * To detect whether there are common vars, the global var
3791 * PL_generation is incremented for each assign op we compile.
3792 * Then, while compiling the assign op, we run through all the
3793 * variables on both sides of the assignment, setting a spare slot
3794 * in each of them to PL_generation. If any of them already have
3795 * that value, we know we've got commonality. We could use a
3796 * single bit marker, but then we'd have to make 2 passes, first
3797 * to clear the flag, then to test and set it. To find somewhere
3798 * to store these values, evil chicanery is done with SvCUR().
3804 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3805 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3806 if (curop->op_type == OP_GV) {
3807 GV *gv = cGVOPx_gv(curop);
3809 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
3811 GvASSIGN_GENERATION_set(gv, PL_generation);
3813 else if (curop->op_type == OP_PADSV ||
3814 curop->op_type == OP_PADAV ||
3815 curop->op_type == OP_PADHV ||
3816 curop->op_type == OP_PADANY)
3818 if (PAD_COMPNAME_GEN(curop->op_targ)
3819 == (STRLEN)PL_generation)
3821 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
3824 else if (curop->op_type == OP_RV2CV)
3826 else if (curop->op_type == OP_RV2SV ||
3827 curop->op_type == OP_RV2AV ||
3828 curop->op_type == OP_RV2HV ||
3829 curop->op_type == OP_RV2GV) {
3830 if (lastop->op_type != OP_GV) /* funny deref? */
3833 else if (curop->op_type == OP_PUSHRE) {
3834 if (((PMOP*)curop)->op_pmreplroot) {
3836 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3837 ((PMOP*)curop)->op_pmreplroot));
3839 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3842 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
3844 GvASSIGN_GENERATION_set(gv, PL_generation);
3845 GvASSIGN_GENERATION_set(gv, PL_generation);
3854 o->op_private |= OPpASSIGN_COMMON;
3857 if ( ((left->op_private & OPpLVAL_INTRO) || ckWARN(WARN_MISC))
3858 && (left->op_type == OP_LIST
3859 || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
3861 OP* lop = ((LISTOP*)left)->op_first;
3863 if (lop->op_type == OP_PADSV ||
3864 lop->op_type == OP_PADAV ||
3865 lop->op_type == OP_PADHV ||
3866 lop->op_type == OP_PADANY)
3868 if (lop->op_private & OPpPAD_STATE) {
3869 if (left->op_private & OPpLVAL_INTRO) {
3870 o->op_private |= OPpASSIGN_STATE;
3871 /* hijacking PADSTALE for uninitialized state variables */
3872 SvPADSTALE_on(PAD_SVl(lop->op_targ));
3874 else { /* we already checked for WARN_MISC before */
3875 Perl_warner(aTHX_ packWARN(WARN_MISC), "State variable %s will be reinitialized",
3876 PAD_COMPNAME_PV(lop->op_targ));
3880 lop = lop->op_sibling;
3884 if (right && right->op_type == OP_SPLIT) {
3885 OP* tmpop = ((LISTOP*)right)->op_first;
3886 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
3887 PMOP * const pm = (PMOP*)tmpop;
3888 if (left->op_type == OP_RV2AV &&
3889 !(left->op_private & OPpLVAL_INTRO) &&
3890 !(o->op_private & OPpASSIGN_COMMON) )
3892 tmpop = ((UNOP*)left)->op_first;
3893 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3895 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3896 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3898 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3899 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
3901 pm->op_pmflags |= PMf_ONCE;
3902 tmpop = cUNOPo->op_first; /* to list (nulled) */
3903 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3904 tmpop->op_sibling = NULL; /* don't free split */
3905 right->op_next = tmpop->op_next; /* fix starting loc */
3907 op_getmad(o,right,'R'); /* blow off assign */
3909 op_free(o); /* blow off assign */
3911 right->op_flags &= ~OPf_WANT;
3912 /* "I don't know and I don't care." */
3917 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3918 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3920 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3922 sv_setiv(sv, PL_modcount+1);
3930 right = newOP(OP_UNDEF, 0);
3931 if (right->op_type == OP_READLINE) {
3932 right->op_flags |= OPf_STACKED;
3933 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3936 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3937 o = newBINOP(OP_SASSIGN, flags,
3938 scalar(right), mod(scalar(left), OP_SASSIGN) );
3944 o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
3945 o->op_private |= OPpCONST_ARYBASE;
3952 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3955 const U32 seq = intro_my();
3958 NewOp(1101, cop, 1, COP);
3959 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3960 cop->op_type = OP_DBSTATE;
3961 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3964 cop->op_type = OP_NEXTSTATE;
3965 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3967 cop->op_flags = (U8)flags;
3968 CopHINTS_set(cop, PL_hints);
3970 cop->op_private |= NATIVE_HINTS;
3972 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
3973 cop->op_next = (OP*)cop;
3976 cop->cop_label = label;
3977 PL_hints |= HINT_BLOCK_SCOPE;
3980 /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
3981 CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
3983 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
3984 cop->cop_hints_hash = PL_curcop->cop_hints_hash;
3985 if (cop->cop_hints_hash) {
3987 cop->cop_hints_hash->refcounted_he_refcnt++;
3988 HINTS_REFCNT_UNLOCK;
3991 if (PL_copline == NOLINE)
3992 CopLINE_set(cop, CopLINE(PL_curcop));
3994 CopLINE_set(cop, PL_copline);
3995 PL_copline = NOLINE;
3998 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
4000 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
4002 CopSTASH_set(cop, PL_curstash);
4004 if (PERLDB_LINE && PL_curstash != PL_debstash) {
4005 AV *av = CopFILEAVx(PL_curcop);
4007 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
4008 if (svp && *svp != &PL_sv_undef ) {
4009 (void)SvIOK_on(*svp);
4010 SvIV_set(*svp, PTR2IV(cop));
4015 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
4020 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
4023 return new_logop(type, flags, &first, &other);
4027 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
4032 OP *first = *firstp;
4033 OP * const other = *otherp;
4035 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
4036 return newBINOP(type, flags, scalar(first), scalar(other));
4038 scalarboolean(first);
4039 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
4040 if (first->op_type == OP_NOT
4041 && (first->op_flags & OPf_SPECIAL)
4042 && (first->op_flags & OPf_KIDS)) {
4043 if (type == OP_AND || type == OP_OR) {
4049 first = *firstp = cUNOPo->op_first;
4051 first->op_next = o->op_next;
4052 cUNOPo->op_first = NULL;
4054 op_getmad(o,first,'O');
4060 if (first->op_type == OP_CONST) {
4061 if (first->op_private & OPpCONST_STRICT)
4062 no_bareword_allowed(first);
4063 else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
4064 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
4065 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
4066 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
4067 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
4069 if (other->op_type == OP_CONST)
4070 other->op_private |= OPpCONST_SHORTCIRCUIT;
4072 OP *newop = newUNOP(OP_NULL, 0, other);
4073 op_getmad(first, newop, '1');
4074 newop->op_targ = type; /* set "was" field */
4081 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
4082 const OP *o2 = other;
4083 if ( ! (o2->op_type == OP_LIST
4084 && (( o2 = cUNOPx(o2)->op_first))
4085 && o2->op_type == OP_PUSHMARK
4086 && (( o2 = o2->op_sibling)) )
4089 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
4090 || o2->op_type == OP_PADHV)
4091 && o2->op_private & OPpLVAL_INTRO
4092 && ckWARN(WARN_DEPRECATED))
4094 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4095 "Deprecated use of my() in false conditional");
4099 if (first->op_type == OP_CONST)
4100 first->op_private |= OPpCONST_SHORTCIRCUIT;
4102 first = newUNOP(OP_NULL, 0, first);
4103 op_getmad(other, first, '2');
4104 first->op_targ = type; /* set "was" field */
4111 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
4112 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
4114 const OP * const k1 = ((UNOP*)first)->op_first;
4115 const OP * const k2 = k1->op_sibling;
4117 switch (first->op_type)
4120 if (k2 && k2->op_type == OP_READLINE
4121 && (k2->op_flags & OPf_STACKED)
4122 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4124 warnop = k2->op_type;
4129 if (k1->op_type == OP_READDIR
4130 || k1->op_type == OP_GLOB
4131 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4132 || k1->op_type == OP_EACH)
4134 warnop = ((k1->op_type == OP_NULL)
4135 ? (OPCODE)k1->op_targ : k1->op_type);
4140 const line_t oldline = CopLINE(PL_curcop);
4141 CopLINE_set(PL_curcop, PL_copline);
4142 Perl_warner(aTHX_ packWARN(WARN_MISC),
4143 "Value of %s%s can be \"0\"; test with defined()",
4145 ((warnop == OP_READLINE || warnop == OP_GLOB)
4146 ? " construct" : "() operator"));
4147 CopLINE_set(PL_curcop, oldline);
4154 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
4155 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
4157 NewOp(1101, logop, 1, LOGOP);
4159 logop->op_type = (OPCODE)type;
4160 logop->op_ppaddr = PL_ppaddr[type];
4161 logop->op_first = first;
4162 logop->op_flags = (U8)(flags | OPf_KIDS);
4163 logop->op_other = LINKLIST(other);
4164 logop->op_private = (U8)(1 | (flags >> 8));
4166 /* establish postfix order */
4167 logop->op_next = LINKLIST(first);
4168 first->op_next = (OP*)logop;
4169 first->op_sibling = other;
4171 CHECKOP(type,logop);
4173 o = newUNOP(OP_NULL, 0, (OP*)logop);
4180 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
4188 return newLOGOP(OP_AND, 0, first, trueop);
4190 return newLOGOP(OP_OR, 0, first, falseop);
4192 scalarboolean(first);
4193 if (first->op_type == OP_CONST) {
4194 if (first->op_private & OPpCONST_BARE &&
4195 first->op_private & OPpCONST_STRICT) {
4196 no_bareword_allowed(first);
4198 if (SvTRUE(((SVOP*)first)->op_sv)) {
4201 trueop = newUNOP(OP_NULL, 0, trueop);
4202 op_getmad(first,trueop,'C');
4203 op_getmad(falseop,trueop,'e');
4205 /* FIXME for MAD - should there be an ELSE here? */
4215 falseop = newUNOP(OP_NULL, 0, falseop);
4216 op_getmad(first,falseop,'C');
4217 op_getmad(trueop,falseop,'t');
4219 /* FIXME for MAD - should there be an ELSE here? */
4227 NewOp(1101, logop, 1, LOGOP);
4228 logop->op_type = OP_COND_EXPR;
4229 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4230 logop->op_first = first;
4231 logop->op_flags = (U8)(flags | OPf_KIDS);
4232 logop->op_private = (U8)(1 | (flags >> 8));
4233 logop->op_other = LINKLIST(trueop);
4234 logop->op_next = LINKLIST(falseop);
4236 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
4239 /* establish postfix order */
4240 start = LINKLIST(first);
4241 first->op_next = (OP*)logop;
4243 first->op_sibling = trueop;
4244 trueop->op_sibling = falseop;
4245 o = newUNOP(OP_NULL, 0, (OP*)logop);
4247 trueop->op_next = falseop->op_next = o;
4254 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4263 NewOp(1101, range, 1, LOGOP);
4265 range->op_type = OP_RANGE;
4266 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4267 range->op_first = left;
4268 range->op_flags = OPf_KIDS;
4269 leftstart = LINKLIST(left);
4270 range->op_other = LINKLIST(right);
4271 range->op_private = (U8)(1 | (flags >> 8));
4273 left->op_sibling = right;
4275 range->op_next = (OP*)range;
4276 flip = newUNOP(OP_FLIP, flags, (OP*)range);
4277 flop = newUNOP(OP_FLOP, 0, flip);
4278 o = newUNOP(OP_NULL, 0, flop);
4280 range->op_next = leftstart;
4282 left->op_next = flip;
4283 right->op_next = flop;
4285 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4286 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4287 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4288 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4290 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4291 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4294 if (!flip->op_private || !flop->op_private)
4295 linklist(o); /* blow off optimizer unless constant */
4301 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4306 const bool once = block && block->op_flags & OPf_SPECIAL &&
4307 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4309 PERL_UNUSED_ARG(debuggable);
4312 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4313 return block; /* do {} while 0 does once */
4314 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4315 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4316 expr = newUNOP(OP_DEFINED, 0,
4317 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4318 } else if (expr->op_flags & OPf_KIDS) {
4319 const OP * const k1 = ((UNOP*)expr)->op_first;
4320 const OP * const k2 = k1 ? k1->op_sibling : NULL;
4321 switch (expr->op_type) {
4323 if (k2 && k2->op_type == OP_READLINE
4324 && (k2->op_flags & OPf_STACKED)
4325 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4326 expr = newUNOP(OP_DEFINED, 0, expr);
4330 if (k1 && (k1->op_type == OP_READDIR
4331 || k1->op_type == OP_GLOB
4332 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4333 || k1->op_type == OP_EACH))
4334 expr = newUNOP(OP_DEFINED, 0, expr);
4340 /* if block is null, the next append_elem() would put UNSTACK, a scalar
4341 * op, in listop. This is wrong. [perl #27024] */
4343 block = newOP(OP_NULL, 0);
4344 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4345 o = new_logop(OP_AND, 0, &expr, &listop);
4348 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4350 if (once && o != listop)
4351 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4354 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
4356 o->op_flags |= flags;
4358 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4363 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
4364 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
4373 PERL_UNUSED_ARG(debuggable);
4376 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4377 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4378 expr = newUNOP(OP_DEFINED, 0,
4379 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4380 } else if (expr->op_flags & OPf_KIDS) {
4381 const OP * const k1 = ((UNOP*)expr)->op_first;
4382 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
4383 switch (expr->op_type) {
4385 if (k2 && k2->op_type == OP_READLINE
4386 && (k2->op_flags & OPf_STACKED)
4387 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4388 expr = newUNOP(OP_DEFINED, 0, expr);
4392 if (k1 && (k1->op_type == OP_READDIR
4393 || k1->op_type == OP_GLOB
4394 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4395 || k1->op_type == OP_EACH))
4396 expr = newUNOP(OP_DEFINED, 0, expr);
4403 block = newOP(OP_NULL, 0);
4404 else if (cont || has_my) {
4405 block = scope(block);
4409 next = LINKLIST(cont);
4412 OP * const unstack = newOP(OP_UNSTACK, 0);
4415 cont = append_elem(OP_LINESEQ, cont, unstack);
4419 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4421 redo = LINKLIST(listop);
4424 PL_copline = (line_t)whileline;
4426 o = new_logop(OP_AND, 0, &expr, &listop);
4427 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4428 op_free(expr); /* oops, it's a while (0) */
4430 return NULL; /* listop already freed by new_logop */
4433 ((LISTOP*)listop)->op_last->op_next =
4434 (o == listop ? redo : LINKLIST(o));
4440 NewOp(1101,loop,1,LOOP);
4441 loop->op_type = OP_ENTERLOOP;
4442 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4443 loop->op_private = 0;
4444 loop->op_next = (OP*)loop;
4447 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4449 loop->op_redoop = redo;
4450 loop->op_lastop = o;
4451 o->op_private |= loopflags;
4454 loop->op_nextop = next;
4456 loop->op_nextop = o;
4458 o->op_flags |= flags;
4459 o->op_private |= (flags >> 8);
4464 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
4469 PADOFFSET padoff = 0;
4475 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4476 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
4477 sv->op_type = OP_RV2GV;
4478 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4479 if (cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
4480 iterpflags |= OPpITER_DEF;
4482 else if (sv->op_type == OP_PADSV) { /* private variable */
4483 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
4484 padoff = sv->op_targ;
4493 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4494 padoff = sv->op_targ;
4499 iterflags |= OPf_SPECIAL;
4505 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4506 if (padoff && strEQ(PAD_COMPNAME_PV(padoff), "$_"))
4507 iterpflags |= OPpITER_DEF;
4510 const PADOFFSET offset = pad_findmy("$_");
4511 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
4512 sv = newGVOP(OP_GV, 0, PL_defgv);
4517 iterpflags |= OPpITER_DEF;
4519 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4520 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4521 iterflags |= OPf_STACKED;
4523 else if (expr->op_type == OP_NULL &&
4524 (expr->op_flags & OPf_KIDS) &&
4525 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4527 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4528 * set the STACKED flag to indicate that these values are to be
4529 * treated as min/max values by 'pp_iterinit'.
4531 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4532 LOGOP* const range = (LOGOP*) flip->op_first;
4533 OP* const left = range->op_first;
4534 OP* const right = left->op_sibling;
4537 range->op_flags &= ~OPf_KIDS;
4538 range->op_first = NULL;
4540 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4541 listop->op_first->op_next = range->op_next;
4542 left->op_next = range->op_other;
4543 right->op_next = (OP*)listop;
4544 listop->op_next = listop->op_first;
4547 op_getmad(expr,(OP*)listop,'O');
4551 expr = (OP*)(listop);
4553 iterflags |= OPf_STACKED;
4556 expr = mod(force_list(expr), OP_GREPSTART);
4559 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4560 append_elem(OP_LIST, expr, scalar(sv))));
4561 assert(!loop->op_next);
4562 /* for my $x () sets OPpLVAL_INTRO;
4563 * for our $x () sets OPpOUR_INTRO */
4564 loop->op_private = (U8)iterpflags;
4565 #ifdef PL_OP_SLAB_ALLOC
4568 NewOp(1234,tmp,1,LOOP);
4569 Copy(loop,tmp,1,LISTOP);
4574 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
4576 loop->op_targ = padoff;
4577 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
4579 op_getmad(madsv, (OP*)loop, 'v');
4580 PL_copline = forline;
4581 return newSTATEOP(0, label, wop);
4585 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4590 if (type != OP_GOTO || label->op_type == OP_CONST) {
4591 /* "last()" means "last" */
4592 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4593 o = newOP(type, OPf_SPECIAL);
4595 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4596 ? SvPVx_nolen_const(((SVOP*)label)->op_sv)
4600 op_getmad(label,o,'L');
4606 /* Check whether it's going to be a goto &function */
4607 if (label->op_type == OP_ENTERSUB
4608 && !(label->op_flags & OPf_STACKED))
4609 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4610 o = newUNOP(type, OPf_STACKED, label);
4612 PL_hints |= HINT_BLOCK_SCOPE;
4616 /* if the condition is a literal array or hash
4617 (or @{ ... } etc), make a reference to it.
4620 S_ref_array_or_hash(pTHX_ OP *cond)
4623 && (cond->op_type == OP_RV2AV
4624 || cond->op_type == OP_PADAV
4625 || cond->op_type == OP_RV2HV
4626 || cond->op_type == OP_PADHV))
4628 return newUNOP(OP_REFGEN,
4629 0, mod(cond, OP_REFGEN));
4635 /* These construct the optree fragments representing given()
4638 entergiven and enterwhen are LOGOPs; the op_other pointer
4639 points up to the associated leave op. We need this so we
4640 can put it in the context and make break/continue work.
4641 (Also, of course, pp_enterwhen will jump straight to
4642 op_other if the match fails.)
4647 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
4648 I32 enter_opcode, I32 leave_opcode,
4649 PADOFFSET entertarg)
4655 NewOp(1101, enterop, 1, LOGOP);
4656 enterop->op_type = enter_opcode;
4657 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
4658 enterop->op_flags = (U8) OPf_KIDS;
4659 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
4660 enterop->op_private = 0;
4662 o = newUNOP(leave_opcode, 0, (OP *) enterop);
4665 enterop->op_first = scalar(cond);
4666 cond->op_sibling = block;
4668 o->op_next = LINKLIST(cond);
4669 cond->op_next = (OP *) enterop;
4672 /* This is a default {} block */
4673 enterop->op_first = block;
4674 enterop->op_flags |= OPf_SPECIAL;
4676 o->op_next = (OP *) enterop;
4679 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
4680 entergiven and enterwhen both
4683 enterop->op_next = LINKLIST(block);
4684 block->op_next = enterop->op_other = o;
4689 /* Does this look like a boolean operation? For these purposes
4690 a boolean operation is:
4691 - a subroutine call [*]
4692 - a logical connective
4693 - a comparison operator
4694 - a filetest operator, with the exception of -s -M -A -C
4695 - defined(), exists() or eof()
4696 - /$re/ or $foo =~ /$re/
4698 [*] possibly surprising
4702 S_looks_like_bool(pTHX_ const OP *o)
4705 switch(o->op_type) {
4707 return looks_like_bool(cLOGOPo->op_first);
4711 looks_like_bool(cLOGOPo->op_first)
4712 && looks_like_bool(cLOGOPo->op_first->op_sibling));
4716 case OP_NOT: case OP_XOR:
4717 /* Note that OP_DOR is not here */
4719 case OP_EQ: case OP_NE: case OP_LT:
4720 case OP_GT: case OP_LE: case OP_GE:
4722 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
4723 case OP_I_GT: case OP_I_LE: case OP_I_GE:
4725 case OP_SEQ: case OP_SNE: case OP_SLT:
4726 case OP_SGT: case OP_SLE: case OP_SGE:
4730 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
4731 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
4732 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
4733 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
4734 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
4735 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
4736 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
4737 case OP_FTTEXT: case OP_FTBINARY:
4739 case OP_DEFINED: case OP_EXISTS:
4740 case OP_MATCH: case OP_EOF:
4745 /* Detect comparisons that have been optimized away */
4746 if (cSVOPo->op_sv == &PL_sv_yes
4747 || cSVOPo->op_sv == &PL_sv_no)
4758 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
4762 return newGIVWHENOP(
4763 ref_array_or_hash(cond),
4765 OP_ENTERGIVEN, OP_LEAVEGIVEN,
4769 /* If cond is null, this is a default {} block */
4771 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
4773 const bool cond_llb = (!cond || looks_like_bool(cond));
4779 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
4781 scalar(ref_array_or_hash(cond)));
4784 return newGIVWHENOP(
4786 append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
4787 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
4791 =for apidoc cv_undef
4793 Clear out all the active components of a CV. This can happen either
4794 by an explicit C<undef &foo>, or by the reference count going to zero.
4795 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
4796 children can still follow the full lexical scope chain.
4802 Perl_cv_undef(pTHX_ CV *cv)
4806 if (CvFILE(cv) && !CvISXSUB(cv)) {
4807 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4808 Safefree(CvFILE(cv));
4813 if (!CvISXSUB(cv) && CvROOT(cv)) {
4814 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
4815 Perl_croak(aTHX_ "Can't undef active subroutine");
4818 PAD_SAVE_SETNULLPAD();
4820 op_free(CvROOT(cv));
4825 SvPOK_off((SV*)cv); /* forget prototype */
4830 /* remove CvOUTSIDE unless this is an undef rather than a free */
4831 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
4832 if (!CvWEAKOUTSIDE(cv))
4833 SvREFCNT_dec(CvOUTSIDE(cv));
4834 CvOUTSIDE(cv) = NULL;
4837 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4840 if (CvISXSUB(cv) && CvXSUB(cv)) {
4843 /* delete all flags except WEAKOUTSIDE */
4844 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
4848 Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
4851 /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
4852 relying on SvCUR, and doubling up the buffer to hold CvFILE(). */
4853 if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
4854 || (p && (len != SvCUR(cv) /* Not the same length. */
4855 || memNE(p, SvPVX_const(cv), len))))
4856 && ckWARN_d(WARN_PROTOTYPE)) {
4857 SV* const msg = sv_newmortal();
4861 gv_efullname3(name = sv_newmortal(), gv, NULL);
4862 sv_setpv(msg, "Prototype mismatch:");
4864 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, (void*)name);
4866 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (void*)cv);
4868 sv_catpvs(msg, ": none");
4869 sv_catpvs(msg, " vs ");
4871 Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
4873 sv_catpvs(msg, "none");
4874 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, (void*)msg);
4878 static void const_sv_xsub(pTHX_ CV* cv);
4882 =head1 Optree Manipulation Functions
4884 =for apidoc cv_const_sv
4886 If C<cv> is a constant sub eligible for inlining. returns the constant
4887 value returned by the sub. Otherwise, returns NULL.
4889 Constant subs can be created with C<newCONSTSUB> or as described in
4890 L<perlsub/"Constant Functions">.
4895 Perl_cv_const_sv(pTHX_ CV *cv)
4897 PERL_UNUSED_CONTEXT;
4900 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
4902 return CvCONST(cv) ? (SV*)CvXSUBANY(cv).any_ptr : NULL;
4905 /* op_const_sv: examine an optree to determine whether it's in-lineable.
4906 * Can be called in 3 ways:
4909 * look for a single OP_CONST with attached value: return the value
4911 * cv && CvCLONE(cv) && !CvCONST(cv)
4913 * examine the clone prototype, and if contains only a single
4914 * OP_CONST referencing a pad const, or a single PADSV referencing
4915 * an outer lexical, return a non-zero value to indicate the CV is
4916 * a candidate for "constizing" at clone time
4920 * We have just cloned an anon prototype that was marked as a const
4921 * candidiate. Try to grab the current value, and in the case of
4922 * PADSV, ignore it if it has multiple references. Return the value.
4926 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
4934 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4935 o = cLISTOPo->op_first->op_sibling;
4937 for (; o; o = o->op_next) {
4938 const OPCODE type = o->op_type;
4940 if (sv && o->op_next == o)
4942 if (o->op_next != o) {
4943 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4945 if (type == OP_DBSTATE)
4948 if (type == OP_LEAVESUB || type == OP_RETURN)
4952 if (type == OP_CONST && cSVOPo->op_sv)
4954 else if (cv && type == OP_CONST) {
4955 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4959 else if (cv && type == OP_PADSV) {
4960 if (CvCONST(cv)) { /* newly cloned anon */
4961 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4962 /* the candidate should have 1 ref from this pad and 1 ref
4963 * from the parent */
4964 if (!sv || SvREFCNT(sv) != 2)
4971 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
4972 sv = &PL_sv_undef; /* an arbitrary non-null value */
4987 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4990 /* This would be the return value, but the return cannot be reached. */
4991 OP* pegop = newOP(OP_NULL, 0);
4994 PERL_UNUSED_ARG(floor);
5004 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
5006 NORETURN_FUNCTION_END;
5011 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
5013 return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
5017 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5024 register CV *cv = NULL;
5026 /* If the subroutine has no body, no attributes, and no builtin attributes
5027 then it's just a sub declaration, and we may be able to get away with
5028 storing with a placeholder scalar in the symbol table, rather than a
5029 full GV and CV. If anything is present then it will take a full CV to
5031 const I32 gv_fetch_flags
5032 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5034 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
5035 const char * const name = o ? SvPVx_nolen_const(cSVOPo->op_sv) : NULL;
5038 assert(proto->op_type == OP_CONST);
5039 ps = SvPVx_const(((SVOP*)proto)->op_sv, ps_len);
5044 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
5045 SV * const sv = sv_newmortal();
5046 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
5047 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
5048 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
5049 aname = SvPVX_const(sv);
5054 gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
5055 : gv_fetchpv(aname ? aname
5056 : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5057 gv_fetch_flags, SVt_PVCV);
5059 if (!PL_madskills) {
5068 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
5069 maximum a prototype before. */
5070 if (SvTYPE(gv) > SVt_NULL) {
5071 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
5072 && ckWARN_d(WARN_PROTOTYPE))
5074 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
5076 cv_ckproto_len((CV*)gv, NULL, ps, ps_len);
5079 sv_setpvn((SV*)gv, ps, ps_len);
5081 sv_setiv((SV*)gv, -1);
5082 SvREFCNT_dec(PL_compcv);
5083 cv = PL_compcv = NULL;
5084 PL_sub_generation++;
5088 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
5090 #ifdef GV_UNIQUE_CHECK
5091 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
5092 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
5096 if (!block || !ps || *ps || attrs
5097 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5099 || block->op_type == OP_NULL
5104 const_sv = op_const_sv(block, NULL);
5107 const bool exists = CvROOT(cv) || CvXSUB(cv);
5109 #ifdef GV_UNIQUE_CHECK
5110 if (exists && GvUNIQUE(gv)) {
5111 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
5115 /* if the subroutine doesn't exist and wasn't pre-declared
5116 * with a prototype, assume it will be AUTOLOADed,
5117 * skipping the prototype check
5119 if (exists || SvPOK(cv))
5120 cv_ckproto_len(cv, gv, ps, ps_len);
5121 /* already defined (or promised)? */
5122 if (exists || GvASSUMECV(gv)) {
5125 || block->op_type == OP_NULL
5128 if (CvFLAGS(PL_compcv)) {
5129 /* might have had built-in attrs applied */
5130 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5132 /* just a "sub foo;" when &foo is already defined */
5133 SAVEFREESV(PL_compcv);
5138 && block->op_type != OP_NULL
5141 if (ckWARN(WARN_REDEFINE)
5143 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
5145 const line_t oldline = CopLINE(PL_curcop);
5146 if (PL_copline != NOLINE)
5147 CopLINE_set(PL_curcop, PL_copline);
5148 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5149 CvCONST(cv) ? "Constant subroutine %s redefined"
5150 : "Subroutine %s redefined", name);
5151 CopLINE_set(PL_curcop, oldline);
5154 if (!PL_minus_c) /* keep old one around for madskills */
5157 /* (PL_madskills unset in used file.) */
5165 SvREFCNT_inc_simple_void_NN(const_sv);
5167 assert(!CvROOT(cv) && !CvCONST(cv));
5168 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
5169 CvXSUBANY(cv).any_ptr = const_sv;
5170 CvXSUB(cv) = const_sv_xsub;
5176 cv = newCONSTSUB(NULL, name, const_sv);
5178 PL_sub_generation++;
5182 SvREFCNT_dec(PL_compcv);
5190 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
5191 * before we clobber PL_compcv.
5195 || block->op_type == OP_NULL
5199 /* Might have had built-in attributes applied -- propagate them. */
5200 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5201 if (CvGV(cv) && GvSTASH(CvGV(cv)))
5202 stash = GvSTASH(CvGV(cv));
5203 else if (CvSTASH(cv))
5204 stash = CvSTASH(cv);
5206 stash = PL_curstash;
5209 /* possibly about to re-define existing subr -- ignore old cv */
5210 rcv = (SV*)PL_compcv;
5211 if (name && GvSTASH(gv))
5212 stash = GvSTASH(gv);
5214 stash = PL_curstash;
5216 apply_attrs(stash, rcv, attrs, FALSE);
5218 if (cv) { /* must reuse cv if autoloaded */
5225 || block->op_type == OP_NULL) && !PL_madskills
5228 /* got here with just attrs -- work done, so bug out */
5229 SAVEFREESV(PL_compcv);
5232 /* transfer PL_compcv to cv */
5234 CvFLAGS(cv) = CvFLAGS(PL_compcv);
5235 if (!CvWEAKOUTSIDE(cv))
5236 SvREFCNT_dec(CvOUTSIDE(cv));
5237 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
5238 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
5239 CvOUTSIDE(PL_compcv) = 0;
5240 CvPADLIST(cv) = CvPADLIST(PL_compcv);
5241 CvPADLIST(PL_compcv) = 0;
5242 /* inner references to PL_compcv must be fixed up ... */
5243 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
5244 /* ... before we throw it away */
5245 SvREFCNT_dec(PL_compcv);
5247 if (PERLDB_INTER)/* Advice debugger on the new sub. */
5248 ++PL_sub_generation;
5255 if (strEQ(name, "import")) {
5256 PL_formfeed = (SV*)cv;
5257 Perl_warner(aTHX_ packWARN(WARN_VOID), "%lx\n", (long)cv);
5261 PL_sub_generation++;
5265 CvFILE_set_from_cop(cv, PL_curcop);
5266 CvSTASH(cv) = PL_curstash;
5269 sv_setpvn((SV*)cv, ps, ps_len);
5271 if (PL_error_count) {
5275 const char *s = strrchr(name, ':');
5277 if (strEQ(s, "BEGIN")) {
5278 const char not_safe[] =
5279 "BEGIN not safe after errors--compilation aborted";
5280 if (PL_in_eval & EVAL_KEEPERR)
5281 Perl_croak(aTHX_ not_safe);
5283 /* force display of errors found but not reported */
5284 sv_catpv(ERRSV, not_safe);
5285 Perl_croak(aTHX_ "%"SVf, (void*)ERRSV);
5295 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5296 mod(scalarseq(block), OP_LEAVESUBLV));
5299 /* This makes sub {}; work as expected. */
5300 if (block->op_type == OP_STUB) {
5301 OP* const newblock = newSTATEOP(0, NULL, 0);
5303 op_getmad(block,newblock,'B');
5309 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5311 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5312 OpREFCNT_set(CvROOT(cv), 1);
5313 CvSTART(cv) = LINKLIST(CvROOT(cv));
5314 CvROOT(cv)->op_next = 0;
5315 CALL_PEEP(CvSTART(cv));
5317 /* now that optimizer has done its work, adjust pad values */
5319 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
5322 assert(!CvCONST(cv));
5323 if (ps && !*ps && op_const_sv(block, cv))
5327 if (name || aname) {
5329 const char * const tname = (name ? name : aname);
5331 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5332 SV * const sv = newSV(0);
5333 SV * const tmpstr = sv_newmortal();
5334 GV * const db_postponed = gv_fetchpvs("DB::postponed",
5335 GV_ADDMULTI, SVt_PVHV);
5338 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5340 (long)PL_subline, (long)CopLINE(PL_curcop));
5341 gv_efullname3(tmpstr, gv, NULL);
5342 hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0);
5343 hv = GvHVn(db_postponed);
5344 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
5345 CV * const pcv = GvCV(db_postponed);
5351 call_sv((SV*)pcv, G_DISCARD);
5356 if ((s = strrchr(tname,':')))
5361 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I' && *s != 'U')
5364 if (strEQ(s, "BEGIN") && !PL_error_count) {
5365 const I32 oldscope = PL_scopestack_ix;
5367 SAVECOPFILE(&PL_compiling);
5368 SAVECOPLINE(&PL_compiling);
5371 PL_beginav = newAV();
5372 DEBUG_x( dump_sub(gv) );
5373 av_push(PL_beginav, (SV*)cv);
5374 GvCV(gv) = 0; /* cv has been hijacked */
5375 call_list(oldscope, PL_beginav);
5377 PL_curcop = &PL_compiling;
5378 CopHINTS_set(&PL_compiling, PL_hints);
5381 else if (strEQ(s, "END") && !PL_error_count) {
5384 DEBUG_x( dump_sub(gv) );
5385 av_unshift(PL_endav, 1);
5386 av_store(PL_endav, 0, (SV*)cv);
5387 GvCV(gv) = 0; /* cv has been hijacked */
5389 else if (strEQ(s, "UNITCHECK") && !PL_error_count) {
5390 /* It's never too late to run a unitcheck block */
5391 if (!PL_unitcheckav)
5392 PL_unitcheckav = newAV();
5393 DEBUG_x( dump_sub(gv) );
5394 av_unshift(PL_unitcheckav, 1);
5395 av_store(PL_unitcheckav, 0, (SV*)cv);
5396 GvCV(gv) = 0; /* cv has been hijacked */
5398 else if (strEQ(s, "CHECK") && !PL_error_count) {
5400 PL_checkav = newAV();
5401 DEBUG_x( dump_sub(gv) );
5402 if (PL_main_start && ckWARN(WARN_VOID))
5403 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
5404 av_unshift(PL_checkav, 1);
5405 av_store(PL_checkav, 0, (SV*)cv);
5406 GvCV(gv) = 0; /* cv has been hijacked */
5408 else if (strEQ(s, "INIT") && !PL_error_count) {
5410 PL_initav = newAV();
5411 DEBUG_x( dump_sub(gv) );
5412 if (PL_main_start && ckWARN(WARN_VOID))
5413 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
5414 av_push(PL_initav, (SV*)cv);
5415 GvCV(gv) = 0; /* cv has been hijacked */
5420 PL_copline = NOLINE;
5425 /* XXX unsafe for threads if eval_owner isn't held */
5427 =for apidoc newCONSTSUB
5429 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5430 eligible for inlining at compile-time.
5436 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
5441 const char *const temp_p = CopFILE(PL_curcop);
5442 const STRLEN len = temp_p ? strlen(temp_p) : 0;
5444 SV *const temp_sv = CopFILESV(PL_curcop);
5446 const char *const temp_p = temp_sv ? SvPV_const(temp_sv, len) : NULL;
5448 char *const file = savepvn(temp_p, temp_p ? len : 0);
5452 SAVECOPLINE(PL_curcop);
5453 CopLINE_set(PL_curcop, PL_copline);
5456 PL_hints &= ~HINT_BLOCK_SCOPE;
5459 SAVESPTR(PL_curstash);
5460 SAVECOPSTASH(PL_curcop);
5461 PL_curstash = stash;
5462 CopSTASH_set(PL_curcop,stash);
5465 /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
5466 and so doesn't get free()d. (It's expected to be from the C pre-
5467 processor __FILE__ directive). But we need a dynamically allocated one,
5468 and we need it to get freed. */
5469 cv = newXS_flags(name, const_sv_xsub, file, "", XS_DYNAMIC_FILENAME);
5470 CvXSUBANY(cv).any_ptr = sv;
5476 CopSTASH_free(PL_curcop);
5484 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
5485 const char *const filename, const char *const proto,
5488 CV *cv = newXS(name, subaddr, filename);
5490 if (flags & XS_DYNAMIC_FILENAME) {
5491 /* We need to "make arrangements" (ie cheat) to ensure that the
5492 filename lasts as long as the PVCV we just created, but also doesn't
5494 STRLEN filename_len = strlen(filename);
5495 STRLEN proto_and_file_len = filename_len;
5496 char *proto_and_file;
5500 proto_len = strlen(proto);
5501 proto_and_file_len += proto_len;
5503 Newx(proto_and_file, proto_and_file_len + 1, char);
5504 Copy(proto, proto_and_file, proto_len, char);
5505 Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
5508 proto_and_file = savepvn(filename, filename_len);
5511 /* This gets free()d. :-) */
5512 sv_usepvn_flags((SV*)cv, proto_and_file, proto_and_file_len,
5513 SV_HAS_TRAILING_NUL);
5515 /* This gives us the correct prototype, rather than one with the
5516 file name appended. */
5517 SvCUR_set(cv, proto_len);
5521 CvFILE(cv) = proto_and_file + proto_len;
5523 sv_setpv((SV *)cv, proto);
5529 =for apidoc U||newXS
5531 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
5532 static storage, as it is used directly as CvFILE(), without a copy being made.
5538 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
5541 GV * const gv = gv_fetchpv(name ? name :
5542 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5543 GV_ADDMULTI, SVt_PVCV);
5547 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
5549 if ((cv = (name ? GvCV(gv) : NULL))) {
5551 /* just a cached method */
5555 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5556 /* already defined (or promised) */
5557 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
5558 if (ckWARN(WARN_REDEFINE)) {
5559 GV * const gvcv = CvGV(cv);
5561 HV * const stash = GvSTASH(gvcv);
5563 const char *redefined_name = HvNAME_get(stash);
5564 if ( strEQ(redefined_name,"autouse") ) {
5565 const line_t oldline = CopLINE(PL_curcop);
5566 if (PL_copline != NOLINE)
5567 CopLINE_set(PL_curcop, PL_copline);
5568 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5569 CvCONST(cv) ? "Constant subroutine %s redefined"
5570 : "Subroutine %s redefined"
5572 CopLINE_set(PL_curcop, oldline);
5582 if (cv) /* must reuse cv if autoloaded */
5586 sv_upgrade((SV *)cv, SVt_PVCV);
5590 PL_sub_generation++;
5594 (void)gv_fetchfile(filename);
5595 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
5596 an external constant string */
5598 CvXSUB(cv) = subaddr;
5601 const char *s = strrchr(name,':');
5607 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5610 if (strEQ(s, "BEGIN")) {
5612 PL_beginav = newAV();
5613 av_push(PL_beginav, (SV*)cv);
5614 GvCV(gv) = 0; /* cv has been hijacked */
5616 else if (strEQ(s, "END")) {
5619 av_unshift(PL_endav, 1);
5620 av_store(PL_endav, 0, (SV*)cv);
5621 GvCV(gv) = 0; /* cv has been hijacked */
5623 else if (strEQ(s, "CHECK")) {
5625 PL_checkav = newAV();
5626 if (PL_main_start && ckWARN(WARN_VOID))
5627 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
5628 av_unshift(PL_checkav, 1);
5629 av_store(PL_checkav, 0, (SV*)cv);
5630 GvCV(gv) = 0; /* cv has been hijacked */
5632 else if (strEQ(s, "INIT")) {
5634 PL_initav = newAV();
5635 if (PL_main_start && ckWARN(WARN_VOID))
5636 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
5637 av_push(PL_initav, (SV*)cv);
5638 GvCV(gv) = 0; /* cv has been hijacked */
5653 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5658 OP* pegop = newOP(OP_NULL, 0);
5662 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
5663 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
5665 #ifdef GV_UNIQUE_CHECK
5667 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5671 if ((cv = GvFORM(gv))) {
5672 if (ckWARN(WARN_REDEFINE)) {
5673 const line_t oldline = CopLINE(PL_curcop);
5674 if (PL_copline != NOLINE)
5675 CopLINE_set(PL_curcop, PL_copline);
5676 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5677 o ? "Format %"SVf" redefined"
5678 : "Format STDOUT redefined", (void*)cSVOPo->op_sv);
5679 CopLINE_set(PL_curcop, oldline);
5686 CvFILE_set_from_cop(cv, PL_curcop);
5689 pad_tidy(padtidy_FORMAT);
5690 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5691 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5692 OpREFCNT_set(CvROOT(cv), 1);
5693 CvSTART(cv) = LINKLIST(CvROOT(cv));
5694 CvROOT(cv)->op_next = 0;
5695 CALL_PEEP(CvSTART(cv));
5697 op_getmad(o,pegop,'n');
5698 op_getmad_weak(block, pegop, 'b');
5702 PL_copline = NOLINE;
5710 Perl_newANONLIST(pTHX_ OP *o)
5712 return convert(OP_ANONLIST, OPf_SPECIAL, o);
5716 Perl_newANONHASH(pTHX_ OP *o)
5718 return convert(OP_ANONHASH, OPf_SPECIAL, o);
5722 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5724 return newANONATTRSUB(floor, proto, NULL, block);
5728 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5730 return newUNOP(OP_REFGEN, 0,
5731 newSVOP(OP_ANONCODE, 0,
5732 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5736 Perl_oopsAV(pTHX_ OP *o)
5739 switch (o->op_type) {
5741 o->op_type = OP_PADAV;
5742 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5743 return ref(o, OP_RV2AV);
5746 o->op_type = OP_RV2AV;
5747 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5752 if (ckWARN_d(WARN_INTERNAL))
5753 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
5760 Perl_oopsHV(pTHX_ OP *o)
5763 switch (o->op_type) {
5766 o->op_type = OP_PADHV;
5767 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5768 return ref(o, OP_RV2HV);
5772 o->op_type = OP_RV2HV;
5773 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5778 if (ckWARN_d(WARN_INTERNAL))
5779 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
5786 Perl_newAVREF(pTHX_ OP *o)
5789 if (o->op_type == OP_PADANY) {
5790 o->op_type = OP_PADAV;
5791 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5794 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5795 && ckWARN(WARN_DEPRECATED)) {
5796 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5797 "Using an array as a reference is deprecated");
5799 return newUNOP(OP_RV2AV, 0, scalar(o));
5803 Perl_newGVREF(pTHX_ I32 type, OP *o)
5805 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5806 return newUNOP(OP_NULL, 0, o);
5807 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5811 Perl_newHVREF(pTHX_ OP *o)
5814 if (o->op_type == OP_PADANY) {
5815 o->op_type = OP_PADHV;
5816 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5819 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5820 && ckWARN(WARN_DEPRECATED)) {
5821 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5822 "Using a hash as a reference is deprecated");
5824 return newUNOP(OP_RV2HV, 0, scalar(o));
5828 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5830 return newUNOP(OP_RV2CV, flags, scalar(o));
5834 Perl_newSVREF(pTHX_ OP *o)
5837 if (o->op_type == OP_PADANY) {
5838 o->op_type = OP_PADSV;
5839 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5842 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5843 o->op_flags |= OPpDONE_SVREF;
5846 return newUNOP(OP_RV2SV, 0, scalar(o));
5849 /* Check routines. See the comments at the top of this file for details
5850 * on when these are called */
5853 Perl_ck_anoncode(pTHX_ OP *o)
5855 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
5857 cSVOPo->op_sv = NULL;
5862 Perl_ck_bitop(pTHX_ OP *o)
5865 #define OP_IS_NUMCOMPARE(op) \
5866 ((op) == OP_LT || (op) == OP_I_LT || \
5867 (op) == OP_GT || (op) == OP_I_GT || \
5868 (op) == OP_LE || (op) == OP_I_LE || \
5869 (op) == OP_GE || (op) == OP_I_GE || \
5870 (op) == OP_EQ || (op) == OP_I_EQ || \
5871 (op) == OP_NE || (op) == OP_I_NE || \
5872 (op) == OP_NCMP || (op) == OP_I_NCMP)
5873 o->op_private = (U8)(PL_hints & HINT_INTEGER);
5874 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
5875 && (o->op_type == OP_BIT_OR
5876 || o->op_type == OP_BIT_AND
5877 || o->op_type == OP_BIT_XOR))
5879 const OP * const left = cBINOPo->op_first;
5880 const OP * const right = left->op_sibling;
5881 if ((OP_IS_NUMCOMPARE(left->op_type) &&
5882 (left->op_flags & OPf_PARENS) == 0) ||
5883 (OP_IS_NUMCOMPARE(right->op_type) &&
5884 (right->op_flags & OPf_PARENS) == 0))
5885 if (ckWARN(WARN_PRECEDENCE))
5886 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
5887 "Possible precedence problem on bitwise %c operator",
5888 o->op_type == OP_BIT_OR ? '|'
5889 : o->op_type == OP_BIT_AND ? '&' : '^'
5896 Perl_ck_concat(pTHX_ OP *o)
5898 const OP * const kid = cUNOPo->op_first;
5899 PERL_UNUSED_CONTEXT;
5900 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
5901 !(kUNOP->op_first->op_flags & OPf_MOD))
5902 o->op_flags |= OPf_STACKED;
5907 Perl_ck_spair(pTHX_ OP *o)
5910 if (o->op_flags & OPf_KIDS) {
5913 const OPCODE type = o->op_type;
5914 o = modkids(ck_fun(o), type);
5915 kid = cUNOPo->op_first;
5916 newop = kUNOP->op_first->op_sibling;
5918 const OPCODE type = newop->op_type;
5919 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
5920 type == OP_PADAV || type == OP_PADHV ||
5921 type == OP_RV2AV || type == OP_RV2HV)
5925 op_getmad(kUNOP->op_first,newop,'K');
5927 op_free(kUNOP->op_first);
5929 kUNOP->op_first = newop;
5931 o->op_ppaddr = PL_ppaddr[++o->op_type];
5936 Perl_ck_delete(pTHX_ OP *o)
5940 if (o->op_flags & OPf_KIDS) {
5941 OP * const kid = cUNOPo->op_first;
5942 switch (kid->op_type) {
5944 o->op_flags |= OPf_SPECIAL;
5947 o->op_private |= OPpSLICE;
5950 o->op_flags |= OPf_SPECIAL;
5955 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5964 Perl_ck_die(pTHX_ OP *o)
5967 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5973 Perl_ck_eof(pTHX_ OP *o)
5977 if (o->op_flags & OPf_KIDS) {
5978 if (cLISTOPo->op_first->op_type == OP_STUB) {
5980 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
5982 op_getmad(o,newop,'O');
5994 Perl_ck_eval(pTHX_ OP *o)
5997 PL_hints |= HINT_BLOCK_SCOPE;
5998 if (o->op_flags & OPf_KIDS) {
5999 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6002 o->op_flags &= ~OPf_KIDS;
6005 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
6011 cUNOPo->op_first = 0;
6016 NewOp(1101, enter, 1, LOGOP);
6017 enter->op_type = OP_ENTERTRY;
6018 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
6019 enter->op_private = 0;
6021 /* establish postfix order */
6022 enter->op_next = (OP*)enter;
6024 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
6025 o->op_type = OP_LEAVETRY;
6026 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
6027 enter->op_other = o;
6028 op_getmad(oldo,o,'O');
6042 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
6043 op_getmad(oldo,o,'O');
6045 o->op_targ = (PADOFFSET)PL_hints;
6046 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
6047 /* Store a copy of %^H that pp_entereval can pick up */
6048 OP *hhop = newSVOP(OP_CONST, 0,
6049 (SV*)Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv)));
6050 cUNOPo->op_first->op_sibling = hhop;
6051 o->op_private |= OPpEVAL_HAS_HH;
6057 Perl_ck_exit(pTHX_ OP *o)
6060 HV * const table = GvHV(PL_hintgv);
6062 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
6063 if (svp && *svp && SvTRUE(*svp))
6064 o->op_private |= OPpEXIT_VMSISH;
6066 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6072 Perl_ck_exec(pTHX_ OP *o)
6074 if (o->op_flags & OPf_STACKED) {
6077 kid = cUNOPo->op_first->op_sibling;
6078 if (kid->op_type == OP_RV2GV)
6087 Perl_ck_exists(pTHX_ OP *o)
6091 if (o->op_flags & OPf_KIDS) {
6092 OP * const kid = cUNOPo->op_first;
6093 if (kid->op_type == OP_ENTERSUB) {
6094 (void) ref(kid, o->op_type);
6095 if (kid->op_type != OP_RV2CV && !PL_error_count)
6096 Perl_croak(aTHX_ "%s argument is not a subroutine name",
6098 o->op_private |= OPpEXISTS_SUB;
6100 else if (kid->op_type == OP_AELEM)
6101 o->op_flags |= OPf_SPECIAL;
6102 else if (kid->op_type != OP_HELEM)
6103 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
6111 Perl_ck_rvconst(pTHX_ register OP *o)
6114 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6116 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6117 if (o->op_type == OP_RV2CV)
6118 o->op_private &= ~1;
6120 if (kid->op_type == OP_CONST) {
6123 SV * const kidsv = kid->op_sv;
6125 /* Is it a constant from cv_const_sv()? */
6126 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
6127 SV * const rsv = SvRV(kidsv);
6128 const svtype type = SvTYPE(rsv);
6129 const char *badtype = NULL;
6131 switch (o->op_type) {
6133 if (type > SVt_PVMG)
6134 badtype = "a SCALAR";
6137 if (type != SVt_PVAV)
6138 badtype = "an ARRAY";
6141 if (type != SVt_PVHV)
6145 if (type != SVt_PVCV)
6150 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
6153 else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
6154 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
6155 /* If this is an access to a stash, disable "strict refs", because
6156 * stashes aren't auto-vivified at compile-time (unless we store
6157 * symbols in them), and we don't want to produce a run-time
6158 * stricture error when auto-vivifying the stash. */
6159 const char *s = SvPV_nolen(kidsv);
6160 const STRLEN l = SvCUR(kidsv);
6161 if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
6162 o->op_private &= ~HINT_STRICT_REFS;
6164 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
6165 const char *badthing;
6166 switch (o->op_type) {
6168 badthing = "a SCALAR";
6171 badthing = "an ARRAY";
6174 badthing = "a HASH";
6182 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
6183 (void*)kidsv, badthing);
6186 * This is a little tricky. We only want to add the symbol if we
6187 * didn't add it in the lexer. Otherwise we get duplicate strict
6188 * warnings. But if we didn't add it in the lexer, we must at
6189 * least pretend like we wanted to add it even if it existed before,
6190 * or we get possible typo warnings. OPpCONST_ENTERED says
6191 * whether the lexer already added THIS instance of this symbol.
6193 iscv = (o->op_type == OP_RV2CV) * 2;
6195 gv = gv_fetchsv(kidsv,
6196 iscv | !(kid->op_private & OPpCONST_ENTERED),
6199 : o->op_type == OP_RV2SV
6201 : o->op_type == OP_RV2AV
6203 : o->op_type == OP_RV2HV
6206 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
6208 kid->op_type = OP_GV;
6209 SvREFCNT_dec(kid->op_sv);
6211 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
6212 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
6213 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
6215 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc_simple_NN(gv));
6217 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
6219 kid->op_private = 0;
6220 kid->op_ppaddr = PL_ppaddr[OP_GV];
6227 Perl_ck_ftst(pTHX_ OP *o)
6230 const I32 type = o->op_type;
6232 if (o->op_flags & OPf_REF) {
6235 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
6236 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6237 const OPCODE kidtype = kid->op_type;
6239 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6240 OP * const newop = newGVOP(type, OPf_REF,
6241 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
6243 op_getmad(o,newop,'O');
6249 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o))
6250 o->op_private |= OPpFT_ACCESS;
6251 if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst)
6252 && kidtype != OP_STAT && kidtype != OP_LSTAT)
6253 o->op_private |= OPpFT_STACKED;
6261 if (type == OP_FTTTY)
6262 o = newGVOP(type, OPf_REF, PL_stdingv);
6264 o = newUNOP(type, 0, newDEFSVOP());
6265 op_getmad(oldo,o,'O');
6271 Perl_ck_fun(pTHX_ OP *o)
6274 const int type = o->op_type;
6275 register I32 oa = PL_opargs[type] >> OASHIFT;
6277 if (o->op_flags & OPf_STACKED) {
6278 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
6281 return no_fh_allowed(o);
6284 if (o->op_flags & OPf_KIDS) {
6285 OP **tokid = &cLISTOPo->op_first;
6286 register OP *kid = cLISTOPo->op_first;
6290 if (kid->op_type == OP_PUSHMARK ||
6291 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
6293 tokid = &kid->op_sibling;
6294 kid = kid->op_sibling;
6296 if (!kid && PL_opargs[type] & OA_DEFGV)
6297 *tokid = kid = newDEFSVOP();
6301 sibl = kid->op_sibling;
6303 if (!sibl && kid->op_type == OP_STUB) {
6310 /* list seen where single (scalar) arg expected? */
6311 if (numargs == 1 && !(oa >> 4)
6312 && kid->op_type == OP_LIST && type != OP_SCALAR)
6314 return too_many_arguments(o,PL_op_desc[type]);
6327 if ((type == OP_PUSH || type == OP_UNSHIFT)
6328 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
6329 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6330 "Useless use of %s with no values",
6333 if (kid->op_type == OP_CONST &&
6334 (kid->op_private & OPpCONST_BARE))
6336 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
6337 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
6338 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6339 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6340 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
6341 (void*)((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
6343 op_getmad(kid,newop,'K');
6348 kid->op_sibling = sibl;
6351 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
6352 bad_type(numargs, "array", PL_op_desc[type], kid);
6356 if (kid->op_type == OP_CONST &&
6357 (kid->op_private & OPpCONST_BARE))
6359 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
6360 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
6361 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6362 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6363 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
6364 (void*)((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
6366 op_getmad(kid,newop,'K');
6371 kid->op_sibling = sibl;
6374 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
6375 bad_type(numargs, "hash", PL_op_desc[type], kid);
6380 OP * const newop = newUNOP(OP_NULL, 0, kid);
6381 kid->op_sibling = 0;
6383 newop->op_next = newop;
6385 kid->op_sibling = sibl;
6390 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
6391 if (kid->op_type == OP_CONST &&
6392 (kid->op_private & OPpCONST_BARE))
6394 OP * const newop = newGVOP(OP_GV, 0,
6395 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
6396 if (!(o->op_private & 1) && /* if not unop */
6397 kid == cLISTOPo->op_last)
6398 cLISTOPo->op_last = newop;
6400 op_getmad(kid,newop,'K');
6406 else if (kid->op_type == OP_READLINE) {
6407 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
6408 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
6411 I32 flags = OPf_SPECIAL;
6415 /* is this op a FH constructor? */
6416 if (is_handle_constructor(o,numargs)) {
6417 const char *name = NULL;
6421 /* Set a flag to tell rv2gv to vivify
6422 * need to "prove" flag does not mean something
6423 * else already - NI-S 1999/05/07
6426 if (kid->op_type == OP_PADSV) {
6427 name = PAD_COMPNAME_PV(kid->op_targ);
6428 /* SvCUR of a pad namesv can't be trusted
6429 * (see PL_generation), so calc its length
6435 else if (kid->op_type == OP_RV2SV
6436 && kUNOP->op_first->op_type == OP_GV)
6438 GV * const gv = cGVOPx_gv(kUNOP->op_first);
6440 len = GvNAMELEN(gv);
6442 else if (kid->op_type == OP_AELEM
6443 || kid->op_type == OP_HELEM)
6446 OP *op = ((BINOP*)kid)->op_first;
6450 const char * const a =
6451 kid->op_type == OP_AELEM ?
6453 if (((op->op_type == OP_RV2AV) ||
6454 (op->op_type == OP_RV2HV)) &&
6455 (firstop = ((UNOP*)op)->op_first) &&
6456 (firstop->op_type == OP_GV)) {
6457 /* packagevar $a[] or $h{} */
6458 GV * const gv = cGVOPx_gv(firstop);
6466 else if (op->op_type == OP_PADAV
6467 || op->op_type == OP_PADHV) {
6468 /* lexicalvar $a[] or $h{} */
6469 const char * const padname =
6470 PAD_COMPNAME_PV(op->op_targ);
6479 name = SvPV_const(tmpstr, len);
6484 name = "__ANONIO__";
6491 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
6492 namesv = PAD_SVl(targ);
6493 SvUPGRADE(namesv, SVt_PV);
6495 sv_setpvn(namesv, "$", 1);
6496 sv_catpvn(namesv, name, len);
6499 kid->op_sibling = 0;
6500 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
6501 kid->op_targ = targ;
6502 kid->op_private |= priv;
6504 kid->op_sibling = sibl;
6510 mod(scalar(kid), type);
6514 tokid = &kid->op_sibling;
6515 kid = kid->op_sibling;
6518 if (kid && kid->op_type != OP_STUB)
6519 return too_many_arguments(o,OP_DESC(o));
6520 o->op_private |= numargs;
6522 /* FIXME - should the numargs move as for the PERL_MAD case? */
6523 o->op_private |= numargs;
6525 return too_many_arguments(o,OP_DESC(o));
6529 else if (PL_opargs[type] & OA_DEFGV) {
6531 OP *newop = newUNOP(type, 0, newDEFSVOP());
6532 op_getmad(o,newop,'O');
6535 /* Ordering of these two is important to keep f_map.t passing. */
6537 return newUNOP(type, 0, newDEFSVOP());
6542 while (oa & OA_OPTIONAL)
6544 if (oa && oa != OA_LIST)
6545 return too_few_arguments(o,OP_DESC(o));
6551 Perl_ck_glob(pTHX_ OP *o)
6557 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
6558 append_elem(OP_GLOB, o, newDEFSVOP());
6560 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
6561 && GvCVu(gv) && GvIMPORTED_CV(gv)))
6563 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6566 #if !defined(PERL_EXTERNAL_GLOB)
6567 /* XXX this can be tightened up and made more failsafe. */
6568 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
6571 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
6572 newSVpvs("File::Glob"), NULL, NULL, NULL);
6573 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6574 glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
6575 GvCV(gv) = GvCV(glob_gv);
6576 SvREFCNT_inc_void((SV*)GvCV(gv));
6577 GvIMPORTED_CV_on(gv);
6580 #endif /* PERL_EXTERNAL_GLOB */
6582 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6583 append_elem(OP_GLOB, o,
6584 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
6585 o->op_type = OP_LIST;
6586 o->op_ppaddr = PL_ppaddr[OP_LIST];
6587 cLISTOPo->op_first->op_type = OP_PUSHMARK;
6588 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
6589 cLISTOPo->op_first->op_targ = 0;
6590 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
6591 append_elem(OP_LIST, o,
6592 scalar(newUNOP(OP_RV2CV, 0,
6593 newGVOP(OP_GV, 0, gv)))));
6594 o = newUNOP(OP_NULL, 0, ck_subr(o));
6595 o->op_targ = OP_GLOB; /* hint at what it used to be */
6598 gv = newGVgen("main");
6600 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
6606 Perl_ck_grep(pTHX_ OP *o)
6611 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
6614 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
6615 /* don't allocate gwop here, as we may leak it if PL_error_count > 0 */
6617 if (o->op_flags & OPf_STACKED) {
6620 kid = cLISTOPo->op_first->op_sibling;
6621 if (!cUNOPx(kid)->op_next)
6622 Perl_croak(aTHX_ "panic: ck_grep");
6623 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
6626 NewOp(1101, gwop, 1, LOGOP);
6627 kid->op_next = (OP*)gwop;
6628 o->op_flags &= ~OPf_STACKED;
6630 kid = cLISTOPo->op_first->op_sibling;
6631 if (type == OP_MAPWHILE)
6638 kid = cLISTOPo->op_first->op_sibling;
6639 if (kid->op_type != OP_NULL)
6640 Perl_croak(aTHX_ "panic: ck_grep");
6641 kid = kUNOP->op_first;
6644 NewOp(1101, gwop, 1, LOGOP);
6645 gwop->op_type = type;
6646 gwop->op_ppaddr = PL_ppaddr[type];
6647 gwop->op_first = listkids(o);
6648 gwop->op_flags |= OPf_KIDS;
6649 gwop->op_other = LINKLIST(kid);
6650 kid->op_next = (OP*)gwop;
6651 offset = pad_findmy("$_");
6652 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
6653 o->op_private = gwop->op_private = 0;
6654 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
6657 o->op_private = gwop->op_private = OPpGREP_LEX;
6658 gwop->op_targ = o->op_targ = offset;
6661 kid = cLISTOPo->op_first->op_sibling;
6662 if (!kid || !kid->op_sibling)
6663 return too_few_arguments(o,OP_DESC(o));
6664 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
6665 mod(kid, OP_GREPSTART);
6671 Perl_ck_index(pTHX_ OP *o)
6673 if (o->op_flags & OPf_KIDS) {
6674 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6676 kid = kid->op_sibling; /* get past "big" */
6677 if (kid && kid->op_type == OP_CONST)
6678 fbm_compile(((SVOP*)kid)->op_sv, 0);
6684 Perl_ck_lengthconst(pTHX_ OP *o)
6686 /* XXX length optimization goes here */
6691 Perl_ck_lfun(pTHX_ OP *o)
6693 const OPCODE type = o->op_type;
6694 return modkids(ck_fun(o), type);
6698 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
6700 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
6701 switch (cUNOPo->op_first->op_type) {
6703 /* This is needed for
6704 if (defined %stash::)
6705 to work. Do not break Tk.
6707 break; /* Globals via GV can be undef */
6709 case OP_AASSIGN: /* Is this a good idea? */
6710 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6711 "defined(@array) is deprecated");
6712 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6713 "\t(Maybe you should just omit the defined()?)\n");
6716 /* This is needed for
6717 if (defined %stash::)
6718 to work. Do not break Tk.
6720 break; /* Globals via GV can be undef */
6722 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6723 "defined(%%hash) is deprecated");
6724 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6725 "\t(Maybe you should just omit the defined()?)\n");
6736 Perl_ck_rfun(pTHX_ OP *o)
6738 const OPCODE type = o->op_type;
6739 return refkids(ck_fun(o), type);
6743 Perl_ck_listiob(pTHX_ OP *o)
6747 kid = cLISTOPo->op_first;
6750 kid = cLISTOPo->op_first;
6752 if (kid->op_type == OP_PUSHMARK)
6753 kid = kid->op_sibling;
6754 if (kid && o->op_flags & OPf_STACKED)
6755 kid = kid->op_sibling;
6756 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6757 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6758 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6759 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6760 cLISTOPo->op_first->op_sibling = kid;
6761 cLISTOPo->op_last = kid;
6762 kid = kid->op_sibling;
6767 append_elem(o->op_type, o, newDEFSVOP());
6773 Perl_ck_smartmatch(pTHX_ OP *o)
6776 if (0 == (o->op_flags & OPf_SPECIAL)) {
6777 OP *first = cBINOPo->op_first;
6778 OP *second = first->op_sibling;
6780 /* Implicitly take a reference to an array or hash */
6781 first->op_sibling = NULL;
6782 first = cBINOPo->op_first = ref_array_or_hash(first);
6783 second = first->op_sibling = ref_array_or_hash(second);
6785 /* Implicitly take a reference to a regular expression */
6786 if (first->op_type == OP_MATCH) {
6787 first->op_type = OP_QR;
6788 first->op_ppaddr = PL_ppaddr[OP_QR];
6790 if (second->op_type == OP_MATCH) {
6791 second->op_type = OP_QR;
6792 second->op_ppaddr = PL_ppaddr[OP_QR];
6801 Perl_ck_sassign(pTHX_ OP *o)
6803 OP * const kid = cLISTOPo->op_first;
6804 /* has a disposable target? */
6805 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6806 && !(kid->op_flags & OPf_STACKED)
6807 /* Cannot steal the second time! */
6808 && !(kid->op_private & OPpTARGET_MY))
6810 OP * const kkid = kid->op_sibling;
6812 /* Can just relocate the target. */
6813 if (kkid && kkid->op_type == OP_PADSV
6814 && !(kkid->op_private & OPpLVAL_INTRO))
6816 kid->op_targ = kkid->op_targ;
6818 /* Now we do not need PADSV and SASSIGN. */
6819 kid->op_sibling = o->op_sibling; /* NULL */
6820 cLISTOPo->op_first = NULL;
6822 op_getmad(o,kid,'O');
6823 op_getmad(kkid,kid,'M');
6828 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6832 if (kid->op_sibling) {
6833 OP *kkid = kid->op_sibling;
6834 if (kkid->op_type == OP_PADSV
6835 && (kkid->op_private & OPpLVAL_INTRO)
6836 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
6837 o->op_private |= OPpASSIGN_STATE;
6838 /* hijacking PADSTALE for uninitialized state variables */
6839 SvPADSTALE_on(PAD_SVl(kkid->op_targ));
6846 Perl_ck_match(pTHX_ OP *o)
6849 if (o->op_type != OP_QR && PL_compcv) {
6850 const PADOFFSET offset = pad_findmy("$_");
6851 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
6852 o->op_targ = offset;
6853 o->op_private |= OPpTARGET_MY;
6856 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
6857 o->op_private |= OPpRUNTIME;
6862 Perl_ck_method(pTHX_ OP *o)
6864 OP * const kid = cUNOPo->op_first;
6865 if (kid->op_type == OP_CONST) {
6866 SV* sv = kSVOP->op_sv;
6867 const char * const method = SvPVX_const(sv);
6868 if (!(strchr(method, ':') || strchr(method, '\''))) {
6870 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6871 sv = newSVpvn_share(method, SvCUR(sv), 0);
6874 kSVOP->op_sv = NULL;
6876 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6878 op_getmad(o,cmop,'O');
6889 Perl_ck_null(pTHX_ OP *o)
6891 PERL_UNUSED_CONTEXT;
6896 Perl_ck_open(pTHX_ OP *o)
6899 HV * const table = GvHV(PL_hintgv);
6901 SV **svp = hv_fetchs(table, "open_IN", FALSE);
6903 const I32 mode = mode_from_discipline(*svp);
6904 if (mode & O_BINARY)
6905 o->op_private |= OPpOPEN_IN_RAW;
6906 else if (mode & O_TEXT)
6907 o->op_private |= OPpOPEN_IN_CRLF;
6910 svp = hv_fetchs(table, "open_OUT", FALSE);
6912 const I32 mode = mode_from_discipline(*svp);
6913 if (mode & O_BINARY)
6914 o->op_private |= OPpOPEN_OUT_RAW;
6915 else if (mode & O_TEXT)
6916 o->op_private |= OPpOPEN_OUT_CRLF;
6919 if (o->op_type == OP_BACKTICK)
6922 /* In case of three-arg dup open remove strictness
6923 * from the last arg if it is a bareword. */
6924 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
6925 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
6929 if ((last->op_type == OP_CONST) && /* The bareword. */
6930 (last->op_private & OPpCONST_BARE) &&
6931 (last->op_private & OPpCONST_STRICT) &&
6932 (oa = first->op_sibling) && /* The fh. */
6933 (oa = oa->op_sibling) && /* The mode. */
6934 (oa->op_type == OP_CONST) &&
6935 SvPOK(((SVOP*)oa)->op_sv) &&
6936 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
6937 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
6938 (last == oa->op_sibling)) /* The bareword. */
6939 last->op_private &= ~OPpCONST_STRICT;
6945 Perl_ck_repeat(pTHX_ OP *o)
6947 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6948 o->op_private |= OPpREPEAT_DOLIST;
6949 cBINOPo->op_first = force_list(cBINOPo->op_first);
6957 Perl_ck_require(pTHX_ OP *o)
6962 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6963 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6965 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6966 SV * const sv = kid->op_sv;
6967 U32 was_readonly = SvREADONLY(sv);
6972 sv_force_normal_flags(sv, 0);
6973 assert(!SvREADONLY(sv));
6980 for (s = SvPVX(sv); *s; s++) {
6981 if (*s == ':' && s[1] == ':') {
6982 const STRLEN len = strlen(s+2)+1;
6984 Move(s+2, s+1, len, char);
6985 SvCUR_set(sv, SvCUR(sv) - 1);
6988 sv_catpvs(sv, ".pm");
6989 SvFLAGS(sv) |= was_readonly;
6993 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
6994 /* handle override, if any */
6995 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
6996 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
6997 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
6998 gv = gvp ? *gvp : NULL;
7002 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7003 OP * const kid = cUNOPo->op_first;
7006 cUNOPo->op_first = 0;
7010 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
7011 append_elem(OP_LIST, kid,
7012 scalar(newUNOP(OP_RV2CV, 0,
7015 op_getmad(o,newop,'O');
7023 Perl_ck_return(pTHX_ OP *o)
7026 if (CvLVALUE(PL_compcv)) {
7028 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
7029 mod(kid, OP_LEAVESUBLV);
7035 Perl_ck_select(pTHX_ OP *o)
7039 if (o->op_flags & OPf_KIDS) {
7040 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7041 if (kid && kid->op_sibling) {
7042 o->op_type = OP_SSELECT;
7043 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
7045 return fold_constants(o);
7049 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7050 if (kid && kid->op_type == OP_RV2GV)
7051 kid->op_private &= ~HINT_STRICT_REFS;
7056 Perl_ck_shift(pTHX_ OP *o)
7059 const I32 type = o->op_type;
7061 if (!(o->op_flags & OPf_KIDS)) {
7063 /* FIXME - this can be refactored to reduce code in #ifdefs */
7065 OP * const oldo = o;
7069 argop = newUNOP(OP_RV2AV, 0,
7070 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
7072 o = newUNOP(type, 0, scalar(argop));
7073 op_getmad(oldo,o,'O');
7076 return newUNOP(type, 0, scalar(argop));
7079 return scalar(modkids(ck_fun(o), type));
7083 Perl_ck_sort(pTHX_ OP *o)
7088 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
7089 HV * const hinthv = GvHV(PL_hintgv);
7091 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
7093 const I32 sorthints = (I32)SvIV(*svp);
7094 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
7095 o->op_private |= OPpSORT_QSORT;
7096 if ((sorthints & HINT_SORT_STABLE) != 0)
7097 o->op_private |= OPpSORT_STABLE;
7102 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
7104 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7105 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
7107 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
7109 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
7111 if (kid->op_type == OP_SCOPE) {
7115 else if (kid->op_type == OP_LEAVE) {
7116 if (o->op_type == OP_SORT) {
7117 op_null(kid); /* wipe out leave */
7120 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
7121 if (k->op_next == kid)
7123 /* don't descend into loops */
7124 else if (k->op_type == OP_ENTERLOOP
7125 || k->op_type == OP_ENTERITER)
7127 k = cLOOPx(k)->op_lastop;
7132 kid->op_next = 0; /* just disconnect the leave */
7133 k = kLISTOP->op_first;
7138 if (o->op_type == OP_SORT) {
7139 /* provide scalar context for comparison function/block */
7145 o->op_flags |= OPf_SPECIAL;
7147 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
7150 firstkid = firstkid->op_sibling;
7153 /* provide list context for arguments */
7154 if (o->op_type == OP_SORT)
7161 S_simplify_sort(pTHX_ OP *o)
7164 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7169 if (!(o->op_flags & OPf_STACKED))
7171 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7172 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
7173 kid = kUNOP->op_first; /* get past null */
7174 if (kid->op_type != OP_SCOPE)
7176 kid = kLISTOP->op_last; /* get past scope */
7177 switch(kid->op_type) {
7185 k = kid; /* remember this node*/
7186 if (kBINOP->op_first->op_type != OP_RV2SV)
7188 kid = kBINOP->op_first; /* get past cmp */
7189 if (kUNOP->op_first->op_type != OP_GV)
7191 kid = kUNOP->op_first; /* get past rv2sv */
7193 if (GvSTASH(gv) != PL_curstash)
7195 gvname = GvNAME(gv);
7196 if (*gvname == 'a' && gvname[1] == '\0')
7198 else if (*gvname == 'b' && gvname[1] == '\0')
7203 kid = k; /* back to cmp */
7204 if (kBINOP->op_last->op_type != OP_RV2SV)
7206 kid = kBINOP->op_last; /* down to 2nd arg */
7207 if (kUNOP->op_first->op_type != OP_GV)
7209 kid = kUNOP->op_first; /* get past rv2sv */
7211 if (GvSTASH(gv) != PL_curstash)
7213 gvname = GvNAME(gv);
7215 ? !(*gvname == 'a' && gvname[1] == '\0')
7216 : !(*gvname == 'b' && gvname[1] == '\0'))
7218 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
7220 o->op_private |= OPpSORT_DESCEND;
7221 if (k->op_type == OP_NCMP)
7222 o->op_private |= OPpSORT_NUMERIC;
7223 if (k->op_type == OP_I_NCMP)
7224 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
7225 kid = cLISTOPo->op_first->op_sibling;
7226 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
7228 op_getmad(kid,o,'S'); /* then delete it */
7230 op_free(kid); /* then delete it */
7235 Perl_ck_split(pTHX_ OP *o)
7240 if (o->op_flags & OPf_STACKED)
7241 return no_fh_allowed(o);
7243 kid = cLISTOPo->op_first;
7244 if (kid->op_type != OP_NULL)
7245 Perl_croak(aTHX_ "panic: ck_split");
7246 kid = kid->op_sibling;
7247 op_free(cLISTOPo->op_first);
7248 cLISTOPo->op_first = kid;
7250 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
7251 cLISTOPo->op_last = kid; /* There was only one element previously */
7254 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
7255 OP * const sibl = kid->op_sibling;
7256 kid->op_sibling = 0;
7257 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
7258 if (cLISTOPo->op_first == cLISTOPo->op_last)
7259 cLISTOPo->op_last = kid;
7260 cLISTOPo->op_first = kid;
7261 kid->op_sibling = sibl;
7264 kid->op_type = OP_PUSHRE;
7265 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
7267 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
7268 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
7269 "Use of /g modifier is meaningless in split");
7272 if (!kid->op_sibling)
7273 append_elem(OP_SPLIT, o, newDEFSVOP());
7275 kid = kid->op_sibling;
7278 if (!kid->op_sibling)
7279 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
7280 assert(kid->op_sibling);
7282 kid = kid->op_sibling;
7285 if (kid->op_sibling)
7286 return too_many_arguments(o,OP_DESC(o));
7292 Perl_ck_join(pTHX_ OP *o)
7294 const OP * const kid = cLISTOPo->op_first->op_sibling;
7295 if (kid && kid->op_type == OP_MATCH) {
7296 if (ckWARN(WARN_SYNTAX)) {
7297 const REGEXP *re = PM_GETRE(kPMOP);
7298 const char *pmstr = re ? re->precomp : "STRING";
7299 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7300 "/%s/ should probably be written as \"%s\"",
7308 Perl_ck_subr(pTHX_ OP *o)
7311 OP *prev = ((cUNOPo->op_first->op_sibling)
7312 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
7313 OP *o2 = prev->op_sibling;
7315 const char *proto = NULL;
7316 const char *proto_end = NULL;
7321 I32 contextclass = 0;
7322 const char *e = NULL;
7325 o->op_private |= OPpENTERSUB_HASTARG;
7326 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
7327 if (cvop->op_type == OP_RV2CV) {
7329 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
7330 op_null(cvop); /* disable rv2cv */
7331 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
7332 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
7333 GV *gv = cGVOPx_gv(tmpop);
7336 tmpop->op_private |= OPpEARLY_CV;
7340 namegv = CvANON(cv) ? gv : CvGV(cv);
7341 proto = SvPV((SV*)cv, len);
7342 proto_end = proto + len;
7344 if (CvASSERTION(cv)) {
7345 U32 asserthints = 0;
7346 HV *const hinthv = GvHV(PL_hintgv);
7348 SV **svp = hv_fetchs(hinthv, "assertions", FALSE);
7350 asserthints = SvUV(*svp);
7352 if (asserthints & HINT_ASSERTING) {
7353 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
7354 o->op_private |= OPpENTERSUB_DB;
7358 if (!(asserthints & HINT_ASSERTIONSSEEN) && ckWARN(WARN_ASSERTIONS)) {
7359 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
7360 "Impossible to activate assertion call");
7367 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7368 if (o2->op_type == OP_CONST)
7369 o2->op_private &= ~OPpCONST_STRICT;
7370 else if (o2->op_type == OP_LIST) {
7371 OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
7372 if (sib && sib->op_type == OP_CONST)
7373 sib->op_private &= ~OPpCONST_STRICT;
7376 o->op_private |= (PL_hints & HINT_STRICT_REFS);
7377 if (PERLDB_SUB && PL_curstash != PL_debstash)
7378 o->op_private |= OPpENTERSUB_DB;
7379 while (o2 != cvop) {
7381 if (PL_madskills && o2->op_type == OP_NULL)
7382 o3 = ((UNOP*)o2)->op_first;
7386 if (proto >= proto_end)
7387 return too_many_arguments(o, gv_ename(namegv));
7395 /* _ must be at the end */
7396 if (proto[1] && proto[1] != ';')
7411 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
7413 arg == 1 ? "block or sub {}" : "sub {}",
7414 gv_ename(namegv), o3);
7417 /* '*' allows any scalar type, including bareword */
7420 if (o3->op_type == OP_RV2GV)
7421 goto wrapref; /* autoconvert GLOB -> GLOBref */
7422 else if (o3->op_type == OP_CONST)
7423 o3->op_private &= ~OPpCONST_STRICT;
7424 else if (o3->op_type == OP_ENTERSUB) {
7425 /* accidental subroutine, revert to bareword */
7426 OP *gvop = ((UNOP*)o3)->op_first;
7427 if (gvop && gvop->op_type == OP_NULL) {
7428 gvop = ((UNOP*)gvop)->op_first;
7430 for (; gvop->op_sibling; gvop = gvop->op_sibling)
7433 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
7434 (gvop = ((UNOP*)gvop)->op_first) &&
7435 gvop->op_type == OP_GV)
7437 GV * const gv = cGVOPx_gv(gvop);
7438 OP * const sibling = o2->op_sibling;
7439 SV * const n = newSVpvs("");
7441 OP * const oldo2 = o2;
7445 gv_fullname4(n, gv, "", FALSE);
7446 o2 = newSVOP(OP_CONST, 0, n);
7447 op_getmad(oldo2,o2,'O');
7448 prev->op_sibling = o2;
7449 o2->op_sibling = sibling;
7465 if (contextclass++ == 0) {
7466 e = strchr(proto, ']');
7467 if (!e || e == proto)
7476 const char *p = proto;
7477 const char *const end = proto;
7479 while (*--p != '[');
7480 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
7482 gv_ename(namegv), o3);
7487 if (o3->op_type == OP_RV2GV)
7490 bad_type(arg, "symbol", gv_ename(namegv), o3);
7493 if (o3->op_type == OP_ENTERSUB)
7496 bad_type(arg, "subroutine entry", gv_ename(namegv),
7500 if (o3->op_type == OP_RV2SV ||
7501 o3->op_type == OP_PADSV ||
7502 o3->op_type == OP_HELEM ||
7503 o3->op_type == OP_AELEM ||
7504 o3->op_type == OP_THREADSV)
7507 bad_type(arg, "scalar", gv_ename(namegv), o3);
7510 if (o3->op_type == OP_RV2AV ||
7511 o3->op_type == OP_PADAV)
7514 bad_type(arg, "array", gv_ename(namegv), o3);
7517 if (o3->op_type == OP_RV2HV ||
7518 o3->op_type == OP_PADHV)
7521 bad_type(arg, "hash", gv_ename(namegv), o3);
7526 OP* const sib = kid->op_sibling;
7527 kid->op_sibling = 0;
7528 o2 = newUNOP(OP_REFGEN, 0, kid);
7529 o2->op_sibling = sib;
7530 prev->op_sibling = o2;
7532 if (contextclass && e) {
7547 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
7548 gv_ename(namegv), (void*)cv);
7553 mod(o2, OP_ENTERSUB);
7555 o2 = o2->op_sibling;
7557 if (o2 == cvop && proto && *proto == '_') {
7558 /* generate an access to $_ */
7560 o2->op_sibling = prev->op_sibling;
7561 prev->op_sibling = o2; /* instead of cvop */
7563 if (proto && !optional && proto_end > proto &&
7564 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
7565 return too_few_arguments(o, gv_ename(namegv));
7568 OP * const oldo = o;
7572 o=newSVOP(OP_CONST, 0, newSViv(0));
7573 op_getmad(oldo,o,'O');
7579 Perl_ck_svconst(pTHX_ OP *o)
7581 PERL_UNUSED_CONTEXT;
7582 SvREADONLY_on(cSVOPo->op_sv);
7587 Perl_ck_chdir(pTHX_ OP *o)
7589 if (o->op_flags & OPf_KIDS) {
7590 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7592 if (kid && kid->op_type == OP_CONST &&
7593 (kid->op_private & OPpCONST_BARE))
7595 o->op_flags |= OPf_SPECIAL;
7596 kid->op_private &= ~OPpCONST_STRICT;
7603 Perl_ck_trunc(pTHX_ OP *o)
7605 if (o->op_flags & OPf_KIDS) {
7606 SVOP *kid = (SVOP*)cUNOPo->op_first;
7608 if (kid->op_type == OP_NULL)
7609 kid = (SVOP*)kid->op_sibling;
7610 if (kid && kid->op_type == OP_CONST &&
7611 (kid->op_private & OPpCONST_BARE))
7613 o->op_flags |= OPf_SPECIAL;
7614 kid->op_private &= ~OPpCONST_STRICT;
7621 Perl_ck_unpack(pTHX_ OP *o)
7623 OP *kid = cLISTOPo->op_first;
7624 if (kid->op_sibling) {
7625 kid = kid->op_sibling;
7626 if (!kid->op_sibling)
7627 kid->op_sibling = newDEFSVOP();
7633 Perl_ck_substr(pTHX_ OP *o)
7636 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
7637 OP *kid = cLISTOPo->op_first;
7639 if (kid->op_type == OP_NULL)
7640 kid = kid->op_sibling;
7642 kid->op_flags |= OPf_MOD;
7648 /* A peephole optimizer. We visit the ops in the order they're to execute.
7649 * See the comments at the top of this file for more details about when
7650 * peep() is called */
7653 Perl_peep(pTHX_ register OP *o)
7656 register OP* oldop = NULL;
7658 if (!o || o->op_opt)
7662 SAVEVPTR(PL_curcop);
7663 for (; o; o = o->op_next) {
7667 switch (o->op_type) {
7671 PL_curcop = ((COP*)o); /* for warnings */
7676 if (cSVOPo->op_private & OPpCONST_STRICT)
7677 no_bareword_allowed(o);
7679 case OP_METHOD_NAMED:
7680 /* Relocate sv to the pad for thread safety.
7681 * Despite being a "constant", the SV is written to,
7682 * for reference counts, sv_upgrade() etc. */
7684 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
7685 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
7686 /* If op_sv is already a PADTMP then it is being used by
7687 * some pad, so make a copy. */
7688 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
7689 SvREADONLY_on(PAD_SVl(ix));
7690 SvREFCNT_dec(cSVOPo->op_sv);
7692 else if (o->op_type == OP_CONST
7693 && cSVOPo->op_sv == &PL_sv_undef) {
7694 /* PL_sv_undef is hack - it's unsafe to store it in the
7695 AV that is the pad, because av_fetch treats values of
7696 PL_sv_undef as a "free" AV entry and will merrily
7697 replace them with a new SV, causing pad_alloc to think
7698 that this pad slot is free. (When, clearly, it is not)
7700 SvOK_off(PAD_SVl(ix));
7701 SvPADTMP_on(PAD_SVl(ix));
7702 SvREADONLY_on(PAD_SVl(ix));
7705 SvREFCNT_dec(PAD_SVl(ix));
7706 SvPADTMP_on(cSVOPo->op_sv);
7707 PAD_SETSV(ix, cSVOPo->op_sv);
7708 /* XXX I don't know how this isn't readonly already. */
7709 SvREADONLY_on(PAD_SVl(ix));
7711 cSVOPo->op_sv = NULL;
7719 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
7720 if (o->op_next->op_private & OPpTARGET_MY) {
7721 if (o->op_flags & OPf_STACKED) /* chained concats */
7722 goto ignore_optimization;
7724 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
7725 o->op_targ = o->op_next->op_targ;
7726 o->op_next->op_targ = 0;
7727 o->op_private |= OPpTARGET_MY;
7730 op_null(o->op_next);
7732 ignore_optimization:
7736 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
7738 break; /* Scalar stub must produce undef. List stub is noop */
7742 if (o->op_targ == OP_NEXTSTATE
7743 || o->op_targ == OP_DBSTATE
7744 || o->op_targ == OP_SETSTATE)
7746 PL_curcop = ((COP*)o);
7748 /* XXX: We avoid setting op_seq here to prevent later calls
7749 to peep() from mistakenly concluding that optimisation
7750 has already occurred. This doesn't fix the real problem,
7751 though (See 20010220.007). AMS 20010719 */
7752 /* op_seq functionality is now replaced by op_opt */
7753 if (oldop && o->op_next) {
7754 oldop->op_next = o->op_next;
7762 if (oldop && o->op_next) {
7763 oldop->op_next = o->op_next;
7771 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
7772 OP* const pop = (o->op_type == OP_PADAV) ?
7773 o->op_next : o->op_next->op_next;
7775 if (pop && pop->op_type == OP_CONST &&
7776 ((PL_op = pop->op_next)) &&
7777 pop->op_next->op_type == OP_AELEM &&
7778 !(pop->op_next->op_private &
7779 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
7780 (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
7785 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
7786 no_bareword_allowed(pop);
7787 if (o->op_type == OP_GV)
7788 op_null(o->op_next);
7789 op_null(pop->op_next);
7791 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
7792 o->op_next = pop->op_next->op_next;
7793 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
7794 o->op_private = (U8)i;
7795 if (o->op_type == OP_GV) {
7800 o->op_flags |= OPf_SPECIAL;
7801 o->op_type = OP_AELEMFAST;
7807 if (o->op_next->op_type == OP_RV2SV) {
7808 if (!(o->op_next->op_private & OPpDEREF)) {
7809 op_null(o->op_next);
7810 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
7812 o->op_next = o->op_next->op_next;
7813 o->op_type = OP_GVSV;
7814 o->op_ppaddr = PL_ppaddr[OP_GVSV];
7817 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
7818 GV * const gv = cGVOPo_gv;
7819 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
7820 /* XXX could check prototype here instead of just carping */
7821 SV * const sv = sv_newmortal();
7822 gv_efullname3(sv, gv, NULL);
7823 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
7824 "%"SVf"() called too early to check prototype",
7828 else if (o->op_next->op_type == OP_READLINE
7829 && o->op_next->op_next->op_type == OP_CONCAT
7830 && (o->op_next->op_next->op_flags & OPf_STACKED))
7832 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
7833 o->op_type = OP_RCATLINE;
7834 o->op_flags |= OPf_STACKED;
7835 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
7836 op_null(o->op_next->op_next);
7837 op_null(o->op_next);
7854 while (cLOGOP->op_other->op_type == OP_NULL)
7855 cLOGOP->op_other = cLOGOP->op_other->op_next;
7856 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
7862 while (cLOOP->op_redoop->op_type == OP_NULL)
7863 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
7864 peep(cLOOP->op_redoop);
7865 while (cLOOP->op_nextop->op_type == OP_NULL)
7866 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
7867 peep(cLOOP->op_nextop);
7868 while (cLOOP->op_lastop->op_type == OP_NULL)
7869 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
7870 peep(cLOOP->op_lastop);
7877 while (cPMOP->op_pmreplstart &&
7878 cPMOP->op_pmreplstart->op_type == OP_NULL)
7879 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
7880 peep(cPMOP->op_pmreplstart);
7885 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
7886 && ckWARN(WARN_SYNTAX))
7888 if (o->op_next->op_sibling) {
7889 const OPCODE type = o->op_next->op_sibling->op_type;
7890 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
7891 const line_t oldline = CopLINE(PL_curcop);
7892 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
7893 Perl_warner(aTHX_ packWARN(WARN_EXEC),
7894 "Statement unlikely to be reached");
7895 Perl_warner(aTHX_ packWARN(WARN_EXEC),
7896 "\t(Maybe you meant system() when you said exec()?)\n");
7897 CopLINE_set(PL_curcop, oldline);
7908 const char *key = NULL;
7913 if (((BINOP*)o)->op_last->op_type != OP_CONST)
7916 /* Make the CONST have a shared SV */
7917 svp = cSVOPx_svp(((BINOP*)o)->op_last);
7918 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
7919 key = SvPV_const(sv, keylen);
7920 lexname = newSVpvn_share(key,
7921 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
7927 if ((o->op_private & (OPpLVAL_INTRO)))
7930 rop = (UNOP*)((BINOP*)o)->op_first;
7931 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7933 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7934 if (!SvPAD_TYPED(lexname))
7936 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
7937 if (!fields || !GvHV(*fields))
7939 key = SvPV_const(*svp, keylen);
7940 if (!hv_fetch(GvHV(*fields), key,
7941 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
7943 Perl_croak(aTHX_ "No such class field \"%s\" "
7944 "in variable %s of type %s",
7945 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
7958 SVOP *first_key_op, *key_op;
7960 if ((o->op_private & (OPpLVAL_INTRO))
7961 /* I bet there's always a pushmark... */
7962 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
7963 /* hmmm, no optimization if list contains only one key. */
7965 rop = (UNOP*)((LISTOP*)o)->op_last;
7966 if (rop->op_type != OP_RV2HV)
7968 if (rop->op_first->op_type == OP_PADSV)
7969 /* @$hash{qw(keys here)} */
7970 rop = (UNOP*)rop->op_first;
7972 /* @{$hash}{qw(keys here)} */
7973 if (rop->op_first->op_type == OP_SCOPE
7974 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
7976 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
7982 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
7983 if (!SvPAD_TYPED(lexname))
7985 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
7986 if (!fields || !GvHV(*fields))
7988 /* Again guessing that the pushmark can be jumped over.... */
7989 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
7990 ->op_first->op_sibling;
7991 for (key_op = first_key_op; key_op;
7992 key_op = (SVOP*)key_op->op_sibling) {
7993 if (key_op->op_type != OP_CONST)
7995 svp = cSVOPx_svp(key_op);
7996 key = SvPV_const(*svp, keylen);
7997 if (!hv_fetch(GvHV(*fields), key,
7998 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8000 Perl_croak(aTHX_ "No such class field \"%s\" "
8001 "in variable %s of type %s",
8002 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
8009 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
8013 /* check that RHS of sort is a single plain array */
8014 OP *oright = cUNOPo->op_first;
8015 if (!oright || oright->op_type != OP_PUSHMARK)
8018 /* reverse sort ... can be optimised. */
8019 if (!cUNOPo->op_sibling) {
8020 /* Nothing follows us on the list. */
8021 OP * const reverse = o->op_next;
8023 if (reverse->op_type == OP_REVERSE &&
8024 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
8025 OP * const pushmark = cUNOPx(reverse)->op_first;
8026 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
8027 && (cUNOPx(pushmark)->op_sibling == o)) {
8028 /* reverse -> pushmark -> sort */
8029 o->op_private |= OPpSORT_REVERSE;
8031 pushmark->op_next = oright->op_next;
8037 /* make @a = sort @a act in-place */
8041 oright = cUNOPx(oright)->op_sibling;
8044 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
8045 oright = cUNOPx(oright)->op_sibling;
8049 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
8050 || oright->op_next != o
8051 || (oright->op_private & OPpLVAL_INTRO)
8055 /* o2 follows the chain of op_nexts through the LHS of the
8056 * assign (if any) to the aassign op itself */
8058 if (!o2 || o2->op_type != OP_NULL)
8061 if (!o2 || o2->op_type != OP_PUSHMARK)
8064 if (o2 && o2->op_type == OP_GV)
8067 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
8068 || (o2->op_private & OPpLVAL_INTRO)
8073 if (!o2 || o2->op_type != OP_NULL)
8076 if (!o2 || o2->op_type != OP_AASSIGN
8077 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
8080 /* check that the sort is the first arg on RHS of assign */
8082 o2 = cUNOPx(o2)->op_first;
8083 if (!o2 || o2->op_type != OP_NULL)
8085 o2 = cUNOPx(o2)->op_first;
8086 if (!o2 || o2->op_type != OP_PUSHMARK)
8088 if (o2->op_sibling != o)
8091 /* check the array is the same on both sides */
8092 if (oleft->op_type == OP_RV2AV) {
8093 if (oright->op_type != OP_RV2AV
8094 || !cUNOPx(oright)->op_first
8095 || cUNOPx(oright)->op_first->op_type != OP_GV
8096 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
8097 cGVOPx_gv(cUNOPx(oright)->op_first)
8101 else if (oright->op_type != OP_PADAV
8102 || oright->op_targ != oleft->op_targ
8106 /* transfer MODishness etc from LHS arg to RHS arg */
8107 oright->op_flags = oleft->op_flags;
8108 o->op_private |= OPpSORT_INPLACE;
8110 /* excise push->gv->rv2av->null->aassign */
8111 o2 = o->op_next->op_next;
8112 op_null(o2); /* PUSHMARK */
8114 if (o2->op_type == OP_GV) {
8115 op_null(o2); /* GV */
8118 op_null(o2); /* RV2AV or PADAV */
8119 o2 = o2->op_next->op_next;
8120 op_null(o2); /* AASSIGN */
8122 o->op_next = o2->op_next;
8128 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
8130 LISTOP *enter, *exlist;
8133 enter = (LISTOP *) o->op_next;
8136 if (enter->op_type == OP_NULL) {
8137 enter = (LISTOP *) enter->op_next;
8141 /* for $a (...) will have OP_GV then OP_RV2GV here.
8142 for (...) just has an OP_GV. */
8143 if (enter->op_type == OP_GV) {
8144 gvop = (OP *) enter;
8145 enter = (LISTOP *) enter->op_next;
8148 if (enter->op_type == OP_RV2GV) {
8149 enter = (LISTOP *) enter->op_next;
8155 if (enter->op_type != OP_ENTERITER)
8158 iter = enter->op_next;
8159 if (!iter || iter->op_type != OP_ITER)
8162 expushmark = enter->op_first;
8163 if (!expushmark || expushmark->op_type != OP_NULL
8164 || expushmark->op_targ != OP_PUSHMARK)
8167 exlist = (LISTOP *) expushmark->op_sibling;
8168 if (!exlist || exlist->op_type != OP_NULL
8169 || exlist->op_targ != OP_LIST)
8172 if (exlist->op_last != o) {
8173 /* Mmm. Was expecting to point back to this op. */
8176 theirmark = exlist->op_first;
8177 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
8180 if (theirmark->op_sibling != o) {
8181 /* There's something between the mark and the reverse, eg
8182 for (1, reverse (...))
8187 ourmark = ((LISTOP *)o)->op_first;
8188 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
8191 ourlast = ((LISTOP *)o)->op_last;
8192 if (!ourlast || ourlast->op_next != o)
8195 rv2av = ourmark->op_sibling;
8196 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
8197 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
8198 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
8199 /* We're just reversing a single array. */
8200 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
8201 enter->op_flags |= OPf_STACKED;
8204 /* We don't have control over who points to theirmark, so sacrifice
8206 theirmark->op_next = ourmark->op_next;
8207 theirmark->op_flags = ourmark->op_flags;
8208 ourlast->op_next = gvop ? gvop : (OP *) enter;
8211 enter->op_private |= OPpITER_REVERSED;
8212 iter->op_private |= OPpITER_REVERSED;
8219 UNOP *refgen, *rv2cv;
8222 /* I do not understand this, but if o->op_opt isn't set to 1,
8223 various tests in ext/B/t/bytecode.t fail with no readily
8229 if ((o->op_flags && OPf_WANT) != OPf_WANT_VOID)
8232 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
8235 rv2gv = ((BINOP *)o)->op_last;
8236 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
8239 refgen = (UNOP *)((BINOP *)o)->op_first;
8241 if (!refgen || refgen->op_type != OP_REFGEN)
8244 exlist = (LISTOP *)refgen->op_first;
8245 if (!exlist || exlist->op_type != OP_NULL
8246 || exlist->op_targ != OP_LIST)
8249 if (exlist->op_first->op_type != OP_PUSHMARK)
8252 rv2cv = (UNOP*)exlist->op_last;
8254 if (rv2cv->op_type != OP_RV2CV)
8257 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
8258 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
8259 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
8261 o->op_private |= OPpASSIGN_CV_TO_GV;
8262 rv2gv->op_private |= OPpDONT_INIT_GV;
8263 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
8279 Perl_custom_op_name(pTHX_ const OP* o)
8282 const IV index = PTR2IV(o->op_ppaddr);
8286 if (!PL_custom_op_names) /* This probably shouldn't happen */
8287 return (char *)PL_op_name[OP_CUSTOM];
8289 keysv = sv_2mortal(newSViv(index));
8291 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
8293 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
8295 return SvPV_nolen(HeVAL(he));
8299 Perl_custom_op_desc(pTHX_ const OP* o)
8302 const IV index = PTR2IV(o->op_ppaddr);
8306 if (!PL_custom_op_descs)
8307 return (char *)PL_op_desc[OP_CUSTOM];
8309 keysv = sv_2mortal(newSViv(index));
8311 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
8313 return (char *)PL_op_desc[OP_CUSTOM];
8315 return SvPV_nolen(HeVAL(he));
8320 /* Efficient sub that returns a constant scalar value. */
8322 const_sv_xsub(pTHX_ CV* cv)
8329 Perl_croak(aTHX_ "usage: %s::%s()",
8330 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
8334 ST(0) = (SV*)XSANY.any_ptr;
8340 * c-indentation-style: bsd
8342 * indent-tabs-mode: t
8345 * ex: set ts=8 sts=4 sw=4 noet: