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)
501 Safefree(cop->cop_label);
505 if (! specialWARN(cop->cop_warnings))
506 PerlMemShared_free(cop->cop_warnings);
507 Perl_refcounted_he_free(aTHX_ cop->cop_hints_hash);
511 Perl_op_null(pTHX_ OP *o)
514 if (o->op_type == OP_NULL)
518 o->op_targ = o->op_type;
519 o->op_type = OP_NULL;
520 o->op_ppaddr = PL_ppaddr[OP_NULL];
524 Perl_op_refcnt_lock(pTHX)
532 Perl_op_refcnt_unlock(pTHX)
539 /* Contextualizers */
541 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
544 Perl_linklist(pTHX_ OP *o)
551 /* establish postfix order */
552 first = cUNOPo->op_first;
555 o->op_next = LINKLIST(first);
558 if (kid->op_sibling) {
559 kid->op_next = LINKLIST(kid->op_sibling);
560 kid = kid->op_sibling;
574 Perl_scalarkids(pTHX_ OP *o)
576 if (o && o->op_flags & OPf_KIDS) {
578 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
585 S_scalarboolean(pTHX_ OP *o)
588 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
589 if (ckWARN(WARN_SYNTAX)) {
590 const line_t oldline = CopLINE(PL_curcop);
592 if (PL_copline != NOLINE)
593 CopLINE_set(PL_curcop, PL_copline);
594 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
595 CopLINE_set(PL_curcop, oldline);
602 Perl_scalar(pTHX_ OP *o)
607 /* assumes no premature commitment */
608 if (!o || PL_error_count || (o->op_flags & OPf_WANT)
609 || o->op_type == OP_RETURN)
614 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
616 switch (o->op_type) {
618 scalar(cBINOPo->op_first);
623 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
627 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
628 if (!kPMOP->op_pmreplroot)
629 deprecate_old("implicit split to @_");
637 if (o->op_flags & OPf_KIDS) {
638 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
644 kid = cLISTOPo->op_first;
646 while ((kid = kid->op_sibling)) {
652 PL_curcop = &PL_compiling;
657 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
663 PL_curcop = &PL_compiling;
666 if (ckWARN(WARN_VOID))
667 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
673 Perl_scalarvoid(pTHX_ OP *o)
677 const char* useless = NULL;
681 /* trailing mad null ops don't count as "there" for void processing */
683 o->op_type != OP_NULL &&
685 o->op_sibling->op_type == OP_NULL)
688 for (sib = o->op_sibling;
689 sib && sib->op_type == OP_NULL;
690 sib = sib->op_sibling) ;
696 if (o->op_type == OP_NEXTSTATE
697 || o->op_type == OP_SETSTATE
698 || o->op_type == OP_DBSTATE
699 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
700 || o->op_targ == OP_SETSTATE
701 || o->op_targ == OP_DBSTATE)))
702 PL_curcop = (COP*)o; /* for warning below */
704 /* assumes no premature commitment */
705 want = o->op_flags & OPf_WANT;
706 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
707 || o->op_type == OP_RETURN)
712 if ((o->op_private & OPpTARGET_MY)
713 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
715 return scalar(o); /* As if inside SASSIGN */
718 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
720 switch (o->op_type) {
722 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
726 if (o->op_flags & OPf_STACKED)
730 if (o->op_private == 4)
802 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
803 useless = OP_DESC(o);
807 kid = cUNOPo->op_first;
808 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
809 kid->op_type != OP_TRANS) {
812 useless = "negative pattern binding (!~)";
819 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
820 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
821 useless = "a variable";
826 if (cSVOPo->op_private & OPpCONST_STRICT)
827 no_bareword_allowed(o);
829 if (ckWARN(WARN_VOID)) {
830 useless = "a constant";
831 if (o->op_private & OPpCONST_ARYBASE)
833 /* don't warn on optimised away booleans, eg
834 * use constant Foo, 5; Foo || print; */
835 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
837 /* the constants 0 and 1 are permitted as they are
838 conventionally used as dummies in constructs like
839 1 while some_condition_with_side_effects; */
840 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
842 else if (SvPOK(sv)) {
843 /* perl4's way of mixing documentation and code
844 (before the invention of POD) was based on a
845 trick to mix nroff and perl code. The trick was
846 built upon these three nroff macros being used in
847 void context. The pink camel has the details in
848 the script wrapman near page 319. */
849 const char * const maybe_macro = SvPVX_const(sv);
850 if (strnEQ(maybe_macro, "di", 2) ||
851 strnEQ(maybe_macro, "ds", 2) ||
852 strnEQ(maybe_macro, "ig", 2))
857 op_null(o); /* don't execute or even remember it */
861 o->op_type = OP_PREINC; /* pre-increment is faster */
862 o->op_ppaddr = PL_ppaddr[OP_PREINC];
866 o->op_type = OP_PREDEC; /* pre-decrement is faster */
867 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
871 o->op_type = OP_I_PREINC; /* pre-increment is faster */
872 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
876 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
877 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
886 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
891 if (o->op_flags & OPf_STACKED)
898 if (!(o->op_flags & OPf_KIDS))
909 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
916 /* all requires must return a boolean value */
917 o->op_flags &= ~OPf_WANT;
922 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
923 if (!kPMOP->op_pmreplroot)
924 deprecate_old("implicit split to @_");
928 if (useless && ckWARN(WARN_VOID))
929 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
934 Perl_listkids(pTHX_ OP *o)
936 if (o && o->op_flags & OPf_KIDS) {
938 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
945 Perl_list(pTHX_ OP *o)
950 /* assumes no premature commitment */
951 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
952 || o->op_type == OP_RETURN)
957 if ((o->op_private & OPpTARGET_MY)
958 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
960 return o; /* As if inside SASSIGN */
963 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
965 switch (o->op_type) {
968 list(cBINOPo->op_first);
973 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
981 if (!(o->op_flags & OPf_KIDS))
983 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
984 list(cBINOPo->op_first);
985 return gen_constant_list(o);
992 kid = cLISTOPo->op_first;
994 while ((kid = kid->op_sibling)) {
1000 PL_curcop = &PL_compiling;
1004 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1005 if (kid->op_sibling)
1010 PL_curcop = &PL_compiling;
1013 /* all requires must return a boolean value */
1014 o->op_flags &= ~OPf_WANT;
1021 Perl_scalarseq(pTHX_ OP *o)
1025 const OPCODE type = o->op_type;
1027 if (type == OP_LINESEQ || type == OP_SCOPE ||
1028 type == OP_LEAVE || type == OP_LEAVETRY)
1031 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1032 if (kid->op_sibling) {
1036 PL_curcop = &PL_compiling;
1038 o->op_flags &= ~OPf_PARENS;
1039 if (PL_hints & HINT_BLOCK_SCOPE)
1040 o->op_flags |= OPf_PARENS;
1043 o = newOP(OP_STUB, 0);
1048 S_modkids(pTHX_ OP *o, I32 type)
1050 if (o && o->op_flags & OPf_KIDS) {
1052 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1058 /* Propagate lvalue ("modifiable") context to an op and its children.
1059 * 'type' represents the context type, roughly based on the type of op that
1060 * would do the modifying, although local() is represented by OP_NULL.
1061 * It's responsible for detecting things that can't be modified, flag
1062 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
1063 * might have to vivify a reference in $x), and so on.
1065 * For example, "$a+1 = 2" would cause mod() to be called with o being
1066 * OP_ADD and type being OP_SASSIGN, and would output an error.
1070 Perl_mod(pTHX_ OP *o, I32 type)
1074 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1077 if (!o || PL_error_count)
1080 if ((o->op_private & OPpTARGET_MY)
1081 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1086 switch (o->op_type) {
1092 if (!(o->op_private & OPpCONST_ARYBASE))
1095 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1096 CopARYBASE_set(&PL_compiling,
1097 (I32)SvIV(cSVOPx(PL_eval_start)->op_sv));
1101 SAVECOPARYBASE(&PL_compiling);
1102 CopARYBASE_set(&PL_compiling, 0);
1104 else if (type == OP_REFGEN)
1107 Perl_croak(aTHX_ "That use of $[ is unsupported");
1110 if (o->op_flags & OPf_PARENS || PL_madskills)
1114 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1115 !(o->op_flags & OPf_STACKED)) {
1116 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1117 /* The default is to set op_private to the number of children,
1118 which for a UNOP such as RV2CV is always 1. And w're using
1119 the bit for a flag in RV2CV, so we need it clear. */
1120 o->op_private &= ~1;
1121 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1122 assert(cUNOPo->op_first->op_type == OP_NULL);
1123 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1126 else if (o->op_private & OPpENTERSUB_NOMOD)
1128 else { /* lvalue subroutine call */
1129 o->op_private |= OPpLVAL_INTRO;
1130 PL_modcount = RETURN_UNLIMITED_NUMBER;
1131 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1132 /* Backward compatibility mode: */
1133 o->op_private |= OPpENTERSUB_INARGS;
1136 else { /* Compile-time error message: */
1137 OP *kid = cUNOPo->op_first;
1141 if (kid->op_type != OP_PUSHMARK) {
1142 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1144 "panic: unexpected lvalue entersub "
1145 "args: type/targ %ld:%"UVuf,
1146 (long)kid->op_type, (UV)kid->op_targ);
1147 kid = kLISTOP->op_first;
1149 while (kid->op_sibling)
1150 kid = kid->op_sibling;
1151 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1153 if (kid->op_type == OP_METHOD_NAMED
1154 || kid->op_type == OP_METHOD)
1158 NewOp(1101, newop, 1, UNOP);
1159 newop->op_type = OP_RV2CV;
1160 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1161 newop->op_first = NULL;
1162 newop->op_next = (OP*)newop;
1163 kid->op_sibling = (OP*)newop;
1164 newop->op_private |= OPpLVAL_INTRO;
1165 newop->op_private &= ~1;
1169 if (kid->op_type != OP_RV2CV)
1171 "panic: unexpected lvalue entersub "
1172 "entry via type/targ %ld:%"UVuf,
1173 (long)kid->op_type, (UV)kid->op_targ);
1174 kid->op_private |= OPpLVAL_INTRO;
1175 break; /* Postpone until runtime */
1179 kid = kUNOP->op_first;
1180 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1181 kid = kUNOP->op_first;
1182 if (kid->op_type == OP_NULL)
1184 "Unexpected constant lvalue entersub "
1185 "entry via type/targ %ld:%"UVuf,
1186 (long)kid->op_type, (UV)kid->op_targ);
1187 if (kid->op_type != OP_GV) {
1188 /* Restore RV2CV to check lvalueness */
1190 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1191 okid->op_next = kid->op_next;
1192 kid->op_next = okid;
1195 okid->op_next = NULL;
1196 okid->op_type = OP_RV2CV;
1198 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1199 okid->op_private |= OPpLVAL_INTRO;
1200 okid->op_private &= ~1;
1204 cv = GvCV(kGVOP_gv);
1214 /* grep, foreach, subcalls, refgen */
1215 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1217 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1218 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1220 : (o->op_type == OP_ENTERSUB
1221 ? "non-lvalue subroutine call"
1223 type ? PL_op_desc[type] : "local"));
1237 case OP_RIGHT_SHIFT:
1246 if (!(o->op_flags & OPf_STACKED))
1253 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1259 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1260 PL_modcount = RETURN_UNLIMITED_NUMBER;
1261 return o; /* Treat \(@foo) like ordinary list. */
1265 if (scalar_mod_type(o, type))
1267 ref(cUNOPo->op_first, o->op_type);
1271 if (type == OP_LEAVESUBLV)
1272 o->op_private |= OPpMAYBE_LVSUB;
1278 PL_modcount = RETURN_UNLIMITED_NUMBER;
1281 ref(cUNOPo->op_first, o->op_type);
1286 PL_hints |= HINT_BLOCK_SCOPE;
1301 PL_modcount = RETURN_UNLIMITED_NUMBER;
1302 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1303 return o; /* Treat \(@foo) like ordinary list. */
1304 if (scalar_mod_type(o, type))
1306 if (type == OP_LEAVESUBLV)
1307 o->op_private |= OPpMAYBE_LVSUB;
1311 if (!type) /* local() */
1312 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1313 PAD_COMPNAME_PV(o->op_targ));
1321 if (type != OP_SASSIGN)
1325 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1330 if (type == OP_LEAVESUBLV)
1331 o->op_private |= OPpMAYBE_LVSUB;
1333 pad_free(o->op_targ);
1334 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1335 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1336 if (o->op_flags & OPf_KIDS)
1337 mod(cBINOPo->op_first->op_sibling, type);
1342 ref(cBINOPo->op_first, o->op_type);
1343 if (type == OP_ENTERSUB &&
1344 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1345 o->op_private |= OPpLVAL_DEFER;
1346 if (type == OP_LEAVESUBLV)
1347 o->op_private |= OPpMAYBE_LVSUB;
1357 if (o->op_flags & OPf_KIDS)
1358 mod(cLISTOPo->op_last, type);
1363 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1365 else if (!(o->op_flags & OPf_KIDS))
1367 if (o->op_targ != OP_LIST) {
1368 mod(cBINOPo->op_first, type);
1374 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1379 if (type != OP_LEAVESUBLV)
1381 break; /* mod()ing was handled by ck_return() */
1384 /* [20011101.069] File test operators interpret OPf_REF to mean that
1385 their argument is a filehandle; thus \stat(".") should not set
1387 if (type == OP_REFGEN &&
1388 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1391 if (type != OP_LEAVESUBLV)
1392 o->op_flags |= OPf_MOD;
1394 if (type == OP_AASSIGN || type == OP_SASSIGN)
1395 o->op_flags |= OPf_SPECIAL|OPf_REF;
1396 else if (!type) { /* local() */
1399 o->op_private |= OPpLVAL_INTRO;
1400 o->op_flags &= ~OPf_SPECIAL;
1401 PL_hints |= HINT_BLOCK_SCOPE;
1406 if (ckWARN(WARN_SYNTAX)) {
1407 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1408 "Useless localization of %s", OP_DESC(o));
1412 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1413 && type != OP_LEAVESUBLV)
1414 o->op_flags |= OPf_REF;
1419 S_scalar_mod_type(const OP *o, I32 type)
1423 if (o->op_type == OP_RV2GV)
1447 case OP_RIGHT_SHIFT:
1466 S_is_handle_constructor(const OP *o, I32 numargs)
1468 switch (o->op_type) {
1476 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1489 Perl_refkids(pTHX_ OP *o, I32 type)
1491 if (o && o->op_flags & OPf_KIDS) {
1493 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1500 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
1505 if (!o || PL_error_count)
1508 switch (o->op_type) {
1510 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1511 !(o->op_flags & OPf_STACKED)) {
1512 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1513 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1514 assert(cUNOPo->op_first->op_type == OP_NULL);
1515 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1516 o->op_flags |= OPf_SPECIAL;
1517 o->op_private &= ~1;
1522 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1523 doref(kid, type, set_op_ref);
1526 if (type == OP_DEFINED)
1527 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1528 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1531 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1532 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1533 : type == OP_RV2HV ? OPpDEREF_HV
1535 o->op_flags |= OPf_MOD;
1540 o->op_flags |= OPf_MOD; /* XXX ??? */
1546 o->op_flags |= OPf_REF;
1549 if (type == OP_DEFINED)
1550 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1551 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1557 o->op_flags |= OPf_REF;
1562 if (!(o->op_flags & OPf_KIDS))
1564 doref(cBINOPo->op_first, type, set_op_ref);
1568 doref(cBINOPo->op_first, o->op_type, set_op_ref);
1569 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1570 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1571 : type == OP_RV2HV ? OPpDEREF_HV
1573 o->op_flags |= OPf_MOD;
1583 if (!(o->op_flags & OPf_KIDS))
1585 doref(cLISTOPo->op_last, type, set_op_ref);
1595 S_dup_attrlist(pTHX_ OP *o)
1600 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1601 * where the first kid is OP_PUSHMARK and the remaining ones
1602 * are OP_CONST. We need to push the OP_CONST values.
1604 if (o->op_type == OP_CONST)
1605 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
1607 else if (o->op_type == OP_NULL)
1611 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1613 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1614 if (o->op_type == OP_CONST)
1615 rop = append_elem(OP_LIST, rop,
1616 newSVOP(OP_CONST, o->op_flags,
1617 SvREFCNT_inc_NN(cSVOPo->op_sv)));
1624 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1629 /* fake up C<use attributes $pkg,$rv,@attrs> */
1630 ENTER; /* need to protect against side-effects of 'use' */
1632 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1634 #define ATTRSMODULE "attributes"
1635 #define ATTRSMODULE_PM "attributes.pm"
1638 /* Don't force the C<use> if we don't need it. */
1639 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
1640 if (svp && *svp != &PL_sv_undef)
1641 NOOP; /* already in %INC */
1643 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1644 newSVpvs(ATTRSMODULE), NULL);
1647 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1648 newSVpvs(ATTRSMODULE),
1650 prepend_elem(OP_LIST,
1651 newSVOP(OP_CONST, 0, stashsv),
1652 prepend_elem(OP_LIST,
1653 newSVOP(OP_CONST, 0,
1655 dup_attrlist(attrs))));
1661 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1664 OP *pack, *imop, *arg;
1670 assert(target->op_type == OP_PADSV ||
1671 target->op_type == OP_PADHV ||
1672 target->op_type == OP_PADAV);
1674 /* Ensure that attributes.pm is loaded. */
1675 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1677 /* Need package name for method call. */
1678 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
1680 /* Build up the real arg-list. */
1681 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1683 arg = newOP(OP_PADSV, 0);
1684 arg->op_targ = target->op_targ;
1685 arg = prepend_elem(OP_LIST,
1686 newSVOP(OP_CONST, 0, stashsv),
1687 prepend_elem(OP_LIST,
1688 newUNOP(OP_REFGEN, 0,
1689 mod(arg, OP_REFGEN)),
1690 dup_attrlist(attrs)));
1692 /* Fake up a method call to import */
1693 meth = newSVpvs_share("import");
1694 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1695 append_elem(OP_LIST,
1696 prepend_elem(OP_LIST, pack, list(arg)),
1697 newSVOP(OP_METHOD_NAMED, 0, meth)));
1698 imop->op_private |= OPpENTERSUB_NOMOD;
1700 /* Combine the ops. */
1701 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1705 =notfor apidoc apply_attrs_string
1707 Attempts to apply a list of attributes specified by the C<attrstr> and
1708 C<len> arguments to the subroutine identified by the C<cv> argument which
1709 is expected to be associated with the package identified by the C<stashpv>
1710 argument (see L<attributes>). It gets this wrong, though, in that it
1711 does not correctly identify the boundaries of the individual attribute
1712 specifications within C<attrstr>. This is not really intended for the
1713 public API, but has to be listed here for systems such as AIX which
1714 need an explicit export list for symbols. (It's called from XS code
1715 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1716 to respect attribute syntax properly would be welcome.
1722 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
1723 const char *attrstr, STRLEN len)
1728 len = strlen(attrstr);
1732 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1734 const char * const sstr = attrstr;
1735 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1736 attrs = append_elem(OP_LIST, attrs,
1737 newSVOP(OP_CONST, 0,
1738 newSVpvn(sstr, attrstr-sstr)));
1742 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1743 newSVpvs(ATTRSMODULE),
1744 NULL, prepend_elem(OP_LIST,
1745 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1746 prepend_elem(OP_LIST,
1747 newSVOP(OP_CONST, 0,
1753 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
1758 if (!o || PL_error_count)
1762 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
1763 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
1767 if (type == OP_LIST) {
1769 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1770 my_kid(kid, attrs, imopsp);
1771 } else if (type == OP_UNDEF
1777 } else if (type == OP_RV2SV || /* "our" declaration */
1779 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1780 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1781 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1783 PL_in_my == KEY_our ? "our" : PL_in_my == KEY_state ? "state" : "my"));
1785 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
1787 PL_in_my_stash = NULL;
1788 apply_attrs(GvSTASH(gv),
1789 (type == OP_RV2SV ? GvSV(gv) :
1790 type == OP_RV2AV ? (SV*)GvAV(gv) :
1791 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1794 o->op_private |= OPpOUR_INTRO;
1797 else if (type != OP_PADSV &&
1800 type != OP_PUSHMARK)
1802 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1804 PL_in_my == KEY_our ? "our" : PL_in_my == KEY_state ? "state" : "my"));
1807 else if (attrs && type != OP_PUSHMARK) {
1811 PL_in_my_stash = NULL;
1813 /* check for C<my Dog $spot> when deciding package */
1814 stash = PAD_COMPNAME_TYPE(o->op_targ);
1816 stash = PL_curstash;
1817 apply_attrs_my(stash, o, attrs, imopsp);
1819 o->op_flags |= OPf_MOD;
1820 o->op_private |= OPpLVAL_INTRO;
1821 if (PL_in_my == KEY_state)
1822 o->op_private |= OPpPAD_STATE;
1827 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1831 int maybe_scalar = 0;
1833 /* [perl #17376]: this appears to be premature, and results in code such as
1834 C< our(%x); > executing in list mode rather than void mode */
1836 if (o->op_flags & OPf_PARENS)
1846 o = my_kid(o, attrs, &rops);
1848 if (maybe_scalar && o->op_type == OP_PADSV) {
1849 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
1850 o->op_private |= OPpLVAL_INTRO;
1853 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
1856 PL_in_my_stash = NULL;
1861 Perl_my(pTHX_ OP *o)
1863 return my_attrs(o, NULL);
1867 Perl_sawparens(pTHX_ OP *o)
1869 PERL_UNUSED_CONTEXT;
1871 o->op_flags |= OPf_PARENS;
1876 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
1880 const OPCODE ltype = left->op_type;
1881 const OPCODE rtype = right->op_type;
1883 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
1884 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
1886 const char * const desc
1887 = PL_op_desc[(rtype == OP_SUBST || rtype == OP_TRANS)
1888 ? (int)rtype : OP_MATCH];
1889 const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV)
1890 ? "@array" : "%hash");
1891 Perl_warner(aTHX_ packWARN(WARN_MISC),
1892 "Applying %s to %s will act on scalar(%s)",
1893 desc, sample, sample);
1896 if (rtype == OP_CONST &&
1897 cSVOPx(right)->op_private & OPpCONST_BARE &&
1898 cSVOPx(right)->op_private & OPpCONST_STRICT)
1900 no_bareword_allowed(right);
1903 ismatchop = rtype == OP_MATCH ||
1904 rtype == OP_SUBST ||
1906 if (ismatchop && right->op_private & OPpTARGET_MY) {
1908 right->op_private &= ~OPpTARGET_MY;
1910 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
1913 right->op_flags |= OPf_STACKED;
1914 if (rtype != OP_MATCH &&
1915 ! (rtype == OP_TRANS &&
1916 right->op_private & OPpTRANS_IDENTICAL))
1917 newleft = mod(left, rtype);
1920 if (right->op_type == OP_TRANS)
1921 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
1923 o = prepend_elem(rtype, scalar(newleft), right);
1925 return newUNOP(OP_NOT, 0, scalar(o));
1929 return bind_match(type, left,
1930 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
1934 Perl_invert(pTHX_ OP *o)
1938 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
1942 Perl_scope(pTHX_ OP *o)
1946 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
1947 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
1948 o->op_type = OP_LEAVE;
1949 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
1951 else if (o->op_type == OP_LINESEQ) {
1953 o->op_type = OP_SCOPE;
1954 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
1955 kid = ((LISTOP*)o)->op_first;
1956 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
1959 /* The following deals with things like 'do {1 for 1}' */
1960 kid = kid->op_sibling;
1962 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
1967 o = newLISTOP(OP_SCOPE, 0, o, NULL);
1973 Perl_block_start(pTHX_ int full)
1976 const int retval = PL_savestack_ix;
1977 pad_block_start(full);
1979 PL_hints &= ~HINT_BLOCK_SCOPE;
1980 SAVECOMPILEWARNINGS();
1981 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
1986 Perl_block_end(pTHX_ I32 floor, OP *seq)
1989 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
1990 OP* const retval = scalarseq(seq);
1992 CopHINTS_set(&PL_compiling, PL_hints);
1994 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2003 const PADOFFSET offset = pad_findmy("$_");
2004 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
2005 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2008 OP * const o = newOP(OP_PADSV, 0);
2009 o->op_targ = offset;
2015 Perl_newPROG(pTHX_ OP *o)
2021 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2022 ((PL_in_eval & EVAL_KEEPERR)
2023 ? OPf_SPECIAL : 0), o);
2024 PL_eval_start = linklist(PL_eval_root);
2025 PL_eval_root->op_private |= OPpREFCOUNTED;
2026 OpREFCNT_set(PL_eval_root, 1);
2027 PL_eval_root->op_next = 0;
2028 CALL_PEEP(PL_eval_start);
2031 if (o->op_type == OP_STUB) {
2032 PL_comppad_name = 0;
2037 PL_main_root = scope(sawparens(scalarvoid(o)));
2038 PL_curcop = &PL_compiling;
2039 PL_main_start = LINKLIST(PL_main_root);
2040 PL_main_root->op_private |= OPpREFCOUNTED;
2041 OpREFCNT_set(PL_main_root, 1);
2042 PL_main_root->op_next = 0;
2043 CALL_PEEP(PL_main_start);
2046 /* Register with debugger */
2048 CV * const cv = get_cv("DB::postponed", FALSE);
2052 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2054 call_sv((SV*)cv, G_DISCARD);
2061 Perl_localize(pTHX_ OP *o, I32 lex)
2064 if (o->op_flags & OPf_PARENS)
2065 /* [perl #17376]: this appears to be premature, and results in code such as
2066 C< our(%x); > executing in list mode rather than void mode */
2073 if ( PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ','
2074 && ckWARN(WARN_PARENTHESIS))
2076 char *s = PL_bufptr;
2079 /* some heuristics to detect a potential error */
2080 while (*s && (strchr(", \t\n", *s)))
2084 if (*s && strchr("@$%*", *s) && *++s
2085 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2088 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2090 while (*s && (strchr(", \t\n", *s)))
2096 if (sigil && (*s == ';' || *s == '=')) {
2097 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2098 "Parentheses missing around \"%s\" list",
2099 lex ? (PL_in_my == KEY_our ? "our" : PL_in_my == KEY_state ? "state" : "my")
2107 o = mod(o, OP_NULL); /* a bit kludgey */
2109 PL_in_my_stash = NULL;
2114 Perl_jmaybe(pTHX_ OP *o)
2116 if (o->op_type == OP_LIST) {
2118 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2119 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2125 Perl_fold_constants(pTHX_ register OP *o)
2130 VOL I32 type = o->op_type;
2135 SV * const oldwarnhook = PL_warnhook;
2136 SV * const olddiehook = PL_diehook;
2139 if (PL_opargs[type] & OA_RETSCALAR)
2141 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2142 o->op_targ = pad_alloc(type, SVs_PADTMP);
2144 /* integerize op, unless it happens to be C<-foo>.
2145 * XXX should pp_i_negate() do magic string negation instead? */
2146 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2147 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2148 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2150 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2153 if (!(PL_opargs[type] & OA_FOLDCONST))
2158 /* XXX might want a ck_negate() for this */
2159 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2170 /* XXX what about the numeric ops? */
2171 if (PL_hints & HINT_LOCALE)
2176 goto nope; /* Don't try to run w/ errors */
2178 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2179 const OPCODE type = curop->op_type;
2180 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2182 type != OP_SCALAR &&
2184 type != OP_PUSHMARK)
2190 curop = LINKLIST(o);
2191 old_next = o->op_next;
2195 oldscope = PL_scopestack_ix;
2196 create_eval_scope(G_FAKINGEVAL);
2198 PL_warnhook = PERL_WARNHOOK_FATAL;
2205 sv = *(PL_stack_sp--);
2206 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2207 pad_swipe(o->op_targ, FALSE);
2208 else if (SvTEMP(sv)) { /* grab mortal temp? */
2209 SvREFCNT_inc_simple_void(sv);
2214 /* Something tried to die. Abandon constant folding. */
2215 /* Pretend the error never happened. */
2216 sv_setpvn(ERRSV,"",0);
2217 o->op_next = old_next;
2221 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
2222 PL_warnhook = oldwarnhook;
2223 PL_diehook = olddiehook;
2224 /* XXX note that this croak may fail as we've already blown away
2225 * the stack - eg any nested evals */
2226 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
2229 PL_warnhook = oldwarnhook;
2230 PL_diehook = olddiehook;
2232 if (PL_scopestack_ix > oldscope)
2233 delete_eval_scope();
2242 if (type == OP_RV2GV)
2243 newop = newGVOP(OP_GV, 0, (GV*)sv);
2245 newop = newSVOP(OP_CONST, 0, (SV*)sv);
2246 op_getmad(o,newop,'f');
2254 Perl_gen_constant_list(pTHX_ register OP *o)
2258 const I32 oldtmps_floor = PL_tmps_floor;
2262 return o; /* Don't attempt to run with errors */
2264 PL_op = curop = LINKLIST(o);
2270 assert (!(curop->op_flags & OPf_SPECIAL));
2271 assert(curop->op_type == OP_RANGE);
2273 PL_tmps_floor = oldtmps_floor;
2275 o->op_type = OP_RV2AV;
2276 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2277 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2278 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2279 o->op_opt = 0; /* needs to be revisited in peep() */
2280 curop = ((UNOP*)o)->op_first;
2281 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
2283 op_getmad(curop,o,'O');
2292 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2295 if (!o || o->op_type != OP_LIST)
2296 o = newLISTOP(OP_LIST, 0, o, NULL);
2298 o->op_flags &= ~OPf_WANT;
2300 if (!(PL_opargs[type] & OA_MARK))
2301 op_null(cLISTOPo->op_first);
2303 o->op_type = (OPCODE)type;
2304 o->op_ppaddr = PL_ppaddr[type];
2305 o->op_flags |= flags;
2307 o = CHECKOP(type, o);
2308 if (o->op_type != (unsigned)type)
2311 return fold_constants(o);
2314 /* List constructors */
2317 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2325 if (first->op_type != (unsigned)type
2326 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2328 return newLISTOP(type, 0, first, last);
2331 if (first->op_flags & OPf_KIDS)
2332 ((LISTOP*)first)->op_last->op_sibling = last;
2334 first->op_flags |= OPf_KIDS;
2335 ((LISTOP*)first)->op_first = last;
2337 ((LISTOP*)first)->op_last = last;
2342 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2350 if (first->op_type != (unsigned)type)
2351 return prepend_elem(type, (OP*)first, (OP*)last);
2353 if (last->op_type != (unsigned)type)
2354 return append_elem(type, (OP*)first, (OP*)last);
2356 first->op_last->op_sibling = last->op_first;
2357 first->op_last = last->op_last;
2358 first->op_flags |= (last->op_flags & OPf_KIDS);
2361 if (last->op_first && first->op_madprop) {
2362 MADPROP *mp = last->op_first->op_madprop;
2364 while (mp->mad_next)
2366 mp->mad_next = first->op_madprop;
2369 last->op_first->op_madprop = first->op_madprop;
2372 first->op_madprop = last->op_madprop;
2373 last->op_madprop = 0;
2382 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2390 if (last->op_type == (unsigned)type) {
2391 if (type == OP_LIST) { /* already a PUSHMARK there */
2392 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2393 ((LISTOP*)last)->op_first->op_sibling = first;
2394 if (!(first->op_flags & OPf_PARENS))
2395 last->op_flags &= ~OPf_PARENS;
2398 if (!(last->op_flags & OPf_KIDS)) {
2399 ((LISTOP*)last)->op_last = first;
2400 last->op_flags |= OPf_KIDS;
2402 first->op_sibling = ((LISTOP*)last)->op_first;
2403 ((LISTOP*)last)->op_first = first;
2405 last->op_flags |= OPf_KIDS;
2409 return newLISTOP(type, 0, first, last);
2417 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2420 Newxz(tk, 1, TOKEN);
2421 tk->tk_type = (OPCODE)optype;
2422 tk->tk_type = 12345;
2424 tk->tk_mad = madprop;
2429 Perl_token_free(pTHX_ TOKEN* tk)
2431 if (tk->tk_type != 12345)
2433 mad_free(tk->tk_mad);
2438 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2442 if (tk->tk_type != 12345) {
2443 Perl_warner(aTHX_ packWARN(WARN_MISC),
2444 "Invalid TOKEN object ignored");
2451 /* faked up qw list? */
2453 tm->mad_type == MAD_SV &&
2454 SvPVX((SV*)tm->mad_val)[0] == 'q')
2461 /* pretend constant fold didn't happen? */
2462 if (mp->mad_key == 'f' &&
2463 (o->op_type == OP_CONST ||
2464 o->op_type == OP_GV) )
2466 token_getmad(tk,(OP*)mp->mad_val,slot);
2480 if (mp->mad_key == 'X')
2481 mp->mad_key = slot; /* just change the first one */
2491 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
2500 /* pretend constant fold didn't happen? */
2501 if (mp->mad_key == 'f' &&
2502 (o->op_type == OP_CONST ||
2503 o->op_type == OP_GV) )
2505 op_getmad(from,(OP*)mp->mad_val,slot);
2512 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
2515 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
2521 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
2530 /* pretend constant fold didn't happen? */
2531 if (mp->mad_key == 'f' &&
2532 (o->op_type == OP_CONST ||
2533 o->op_type == OP_GV) )
2535 op_getmad(from,(OP*)mp->mad_val,slot);
2542 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
2545 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
2549 PerlIO_printf(PerlIO_stderr(),
2550 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
2556 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
2574 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
2578 addmad(tm, &(o->op_madprop), slot);
2582 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
2603 Perl_newMADsv(pTHX_ char key, SV* sv)
2605 return newMADPROP(key, MAD_SV, sv, 0);
2609 Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
2612 Newxz(mp, 1, MADPROP);
2615 mp->mad_vlen = vlen;
2616 mp->mad_type = type;
2618 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
2623 Perl_mad_free(pTHX_ MADPROP* mp)
2625 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
2629 mad_free(mp->mad_next);
2630 /* if (PL_lex_state != LEX_NOTPARSING && mp->mad_vlen)
2631 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
2632 switch (mp->mad_type) {
2636 Safefree((char*)mp->mad_val);
2639 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
2640 op_free((OP*)mp->mad_val);
2643 sv_free((SV*)mp->mad_val);
2646 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
2655 Perl_newNULLLIST(pTHX)
2657 return newOP(OP_STUB, 0);
2661 Perl_force_list(pTHX_ OP *o)
2663 if (!o || o->op_type != OP_LIST)
2664 o = newLISTOP(OP_LIST, 0, o, NULL);
2670 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2675 NewOp(1101, listop, 1, LISTOP);
2677 listop->op_type = (OPCODE)type;
2678 listop->op_ppaddr = PL_ppaddr[type];
2681 listop->op_flags = (U8)flags;
2685 else if (!first && last)
2688 first->op_sibling = last;
2689 listop->op_first = first;
2690 listop->op_last = last;
2691 if (type == OP_LIST) {
2692 OP* const pushop = newOP(OP_PUSHMARK, 0);
2693 pushop->op_sibling = first;
2694 listop->op_first = pushop;
2695 listop->op_flags |= OPf_KIDS;
2697 listop->op_last = pushop;
2700 return CHECKOP(type, listop);
2704 Perl_newOP(pTHX_ I32 type, I32 flags)
2708 NewOp(1101, o, 1, OP);
2709 o->op_type = (OPCODE)type;
2710 o->op_ppaddr = PL_ppaddr[type];
2711 o->op_flags = (U8)flags;
2714 o->op_private = (U8)(0 | (flags >> 8));
2715 if (PL_opargs[type] & OA_RETSCALAR)
2717 if (PL_opargs[type] & OA_TARGET)
2718 o->op_targ = pad_alloc(type, SVs_PADTMP);
2719 return CHECKOP(type, o);
2723 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2729 first = newOP(OP_STUB, 0);
2730 if (PL_opargs[type] & OA_MARK)
2731 first = force_list(first);
2733 NewOp(1101, unop, 1, UNOP);
2734 unop->op_type = (OPCODE)type;
2735 unop->op_ppaddr = PL_ppaddr[type];
2736 unop->op_first = first;
2737 unop->op_flags = (U8)(flags | OPf_KIDS);
2738 unop->op_private = (U8)(1 | (flags >> 8));
2739 unop = (UNOP*) CHECKOP(type, unop);
2743 return fold_constants((OP *) unop);
2747 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2751 NewOp(1101, binop, 1, BINOP);
2754 first = newOP(OP_NULL, 0);
2756 binop->op_type = (OPCODE)type;
2757 binop->op_ppaddr = PL_ppaddr[type];
2758 binop->op_first = first;
2759 binop->op_flags = (U8)(flags | OPf_KIDS);
2762 binop->op_private = (U8)(1 | (flags >> 8));
2765 binop->op_private = (U8)(2 | (flags >> 8));
2766 first->op_sibling = last;
2769 binop = (BINOP*)CHECKOP(type, binop);
2770 if (binop->op_next || binop->op_type != (OPCODE)type)
2773 binop->op_last = binop->op_first->op_sibling;
2775 return fold_constants((OP *)binop);
2778 static int uvcompare(const void *a, const void *b)
2779 __attribute__nonnull__(1)
2780 __attribute__nonnull__(2)
2781 __attribute__pure__;
2782 static int uvcompare(const void *a, const void *b)
2784 if (*((const UV *)a) < (*(const UV *)b))
2786 if (*((const UV *)a) > (*(const UV *)b))
2788 if (*((const UV *)a+1) < (*(const UV *)b+1))
2790 if (*((const UV *)a+1) > (*(const UV *)b+1))
2796 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2799 SV * const tstr = ((SVOP*)expr)->op_sv;
2800 SV * const rstr = ((SVOP*)repl)->op_sv;
2803 const U8 *t = (U8*)SvPV_const(tstr, tlen);
2804 const U8 *r = (U8*)SvPV_const(rstr, rlen);
2808 register short *tbl;
2810 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
2811 const I32 squash = o->op_private & OPpTRANS_SQUASH;
2812 I32 del = o->op_private & OPpTRANS_DELETE;
2813 PL_hints |= HINT_BLOCK_SCOPE;
2816 o->op_private |= OPpTRANS_FROM_UTF;
2819 o->op_private |= OPpTRANS_TO_UTF;
2821 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2822 SV* const listsv = newSVpvs("# comment\n");
2824 const U8* tend = t + tlen;
2825 const U8* rend = r + rlen;
2839 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2840 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2843 const U32 flags = UTF8_ALLOW_DEFAULT;
2847 t = tsave = bytes_to_utf8(t, &len);
2850 if (!to_utf && rlen) {
2852 r = rsave = bytes_to_utf8(r, &len);
2856 /* There are several snags with this code on EBCDIC:
2857 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2858 2. scan_const() in toke.c has encoded chars in native encoding which makes
2859 ranges at least in EBCDIC 0..255 range the bottom odd.
2863 U8 tmpbuf[UTF8_MAXBYTES+1];
2866 Newx(cp, 2*tlen, UV);
2868 transv = newSVpvs("");
2870 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
2872 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2874 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
2878 cp[2*i+1] = cp[2*i];
2882 qsort(cp, i, 2*sizeof(UV), uvcompare);
2883 for (j = 0; j < i; j++) {
2885 diff = val - nextmin;
2887 t = uvuni_to_utf8(tmpbuf,nextmin);
2888 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2890 U8 range_mark = UTF_TO_NATIVE(0xff);
2891 t = uvuni_to_utf8(tmpbuf, val - 1);
2892 sv_catpvn(transv, (char *)&range_mark, 1);
2893 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2900 t = uvuni_to_utf8(tmpbuf,nextmin);
2901 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2903 U8 range_mark = UTF_TO_NATIVE(0xff);
2904 sv_catpvn(transv, (char *)&range_mark, 1);
2906 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2907 UNICODE_ALLOW_SUPER);
2908 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2909 t = (const U8*)SvPVX_const(transv);
2910 tlen = SvCUR(transv);
2914 else if (!rlen && !del) {
2915 r = t; rlen = tlen; rend = tend;
2918 if ((!rlen && !del) || t == r ||
2919 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2921 o->op_private |= OPpTRANS_IDENTICAL;
2925 while (t < tend || tfirst <= tlast) {
2926 /* see if we need more "t" chars */
2927 if (tfirst > tlast) {
2928 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
2930 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2932 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
2939 /* now see if we need more "r" chars */
2940 if (rfirst > rlast) {
2942 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
2944 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2946 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
2955 rfirst = rlast = 0xffffffff;
2959 /* now see which range will peter our first, if either. */
2960 tdiff = tlast - tfirst;
2961 rdiff = rlast - rfirst;
2968 if (rfirst == 0xffffffff) {
2969 diff = tdiff; /* oops, pretend rdiff is infinite */
2971 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2972 (long)tfirst, (long)tlast);
2974 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2978 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2979 (long)tfirst, (long)(tfirst + diff),
2982 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2983 (long)tfirst, (long)rfirst);
2985 if (rfirst + diff > max)
2986 max = rfirst + diff;
2988 grows = (tfirst < rfirst &&
2989 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3001 else if (max > 0xff)
3006 Safefree(cPVOPo->op_pv);
3007 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
3008 SvREFCNT_dec(listsv);
3009 SvREFCNT_dec(transv);
3011 if (!del && havefinal && rlen)
3012 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
3013 newSVuv((UV)final), 0);
3016 o->op_private |= OPpTRANS_GROWS;
3022 op_getmad(expr,o,'e');
3023 op_getmad(repl,o,'r');
3031 tbl = (short*)cPVOPo->op_pv;
3033 Zero(tbl, 256, short);
3034 for (i = 0; i < (I32)tlen; i++)
3036 for (i = 0, j = 0; i < 256; i++) {
3038 if (j >= (I32)rlen) {
3047 if (i < 128 && r[j] >= 128)
3057 o->op_private |= OPpTRANS_IDENTICAL;
3059 else if (j >= (I32)rlen)
3062 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
3063 tbl[0x100] = (short)(rlen - j);
3064 for (i=0; i < (I32)rlen - j; i++)
3065 tbl[0x101+i] = r[j+i];
3069 if (!rlen && !del) {
3072 o->op_private |= OPpTRANS_IDENTICAL;
3074 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3075 o->op_private |= OPpTRANS_IDENTICAL;
3077 for (i = 0; i < 256; i++)
3079 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3080 if (j >= (I32)rlen) {
3082 if (tbl[t[i]] == -1)
3088 if (tbl[t[i]] == -1) {
3089 if (t[i] < 128 && r[j] >= 128)
3096 o->op_private |= OPpTRANS_GROWS;
3098 op_getmad(expr,o,'e');
3099 op_getmad(repl,o,'r');
3109 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3114 NewOp(1101, pmop, 1, PMOP);
3115 pmop->op_type = (OPCODE)type;
3116 pmop->op_ppaddr = PL_ppaddr[type];
3117 pmop->op_flags = (U8)flags;
3118 pmop->op_private = (U8)(0 | (flags >> 8));
3120 if (PL_hints & HINT_RE_TAINT)
3121 pmop->op_pmpermflags |= PMf_RETAINT;
3122 if (PL_hints & HINT_LOCALE)
3123 pmop->op_pmpermflags |= PMf_LOCALE;
3124 pmop->op_pmflags = pmop->op_pmpermflags;
3127 if (av_len((AV*) PL_regex_pad[0]) > -1) {
3128 SV * const repointer = av_pop((AV*)PL_regex_pad[0]);
3129 pmop->op_pmoffset = SvIV(repointer);
3130 SvREPADTMP_off(repointer);
3131 sv_setiv(repointer,0);
3133 SV * const repointer = newSViv(0);
3134 av_push(PL_regex_padav, SvREFCNT_inc_simple_NN(repointer));
3135 pmop->op_pmoffset = av_len(PL_regex_padav);
3136 PL_regex_pad = AvARRAY(PL_regex_padav);
3140 /* link into pm list */
3141 if (type != OP_TRANS && PL_curstash) {
3142 MAGIC *mg = mg_find((SV*)PL_curstash, PERL_MAGIC_symtab);
3145 mg = sv_magicext((SV*)PL_curstash, 0, PERL_MAGIC_symtab, 0, 0, 0);
3147 pmop->op_pmnext = (PMOP*)mg->mg_obj;
3148 mg->mg_obj = (SV*)pmop;
3149 PmopSTASH_set(pmop,PL_curstash);
3152 return CHECKOP(type, pmop);
3155 /* Given some sort of match op o, and an expression expr containing a
3156 * pattern, either compile expr into a regex and attach it to o (if it's
3157 * constant), or convert expr into a runtime regcomp op sequence (if it's
3160 * isreg indicates that the pattern is part of a regex construct, eg
3161 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3162 * split "pattern", which aren't. In the former case, expr will be a list
3163 * if the pattern contains more than one term (eg /a$b/) or if it contains
3164 * a replacement, ie s/// or tr///.
3168 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
3173 I32 repl_has_vars = 0;
3177 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
3178 /* last element in list is the replacement; pop it */
3180 repl = cLISTOPx(expr)->op_last;
3181 kid = cLISTOPx(expr)->op_first;
3182 while (kid->op_sibling != repl)
3183 kid = kid->op_sibling;
3184 kid->op_sibling = NULL;
3185 cLISTOPx(expr)->op_last = kid;
3188 if (isreg && expr->op_type == OP_LIST &&
3189 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3191 /* convert single element list to element */
3192 OP* const oe = expr;
3193 expr = cLISTOPx(oe)->op_first->op_sibling;
3194 cLISTOPx(oe)->op_first->op_sibling = NULL;
3195 cLISTOPx(oe)->op_last = NULL;
3199 if (o->op_type == OP_TRANS) {
3200 return pmtrans(o, expr, repl);
3203 reglist = isreg && expr->op_type == OP_LIST;
3207 PL_hints |= HINT_BLOCK_SCOPE;
3210 if (expr->op_type == OP_CONST) {
3212 SV * const pat = ((SVOP*)expr)->op_sv;
3213 const char *p = SvPV_const(pat, plen);
3214 if ((o->op_flags & OPf_SPECIAL) && (*p == ' ' && p[1] == '\0')) {
3215 U32 was_readonly = SvREADONLY(pat);
3219 sv_force_normal_flags(pat, 0);
3220 assert(!SvREADONLY(pat));
3223 SvREADONLY_off(pat);
3227 sv_setpvn(pat, "\\s+", 3);
3229 SvFLAGS(pat) |= was_readonly;
3231 p = SvPV_const(pat, plen);
3232 pm->op_pmflags |= PMf_SKIPWHITE;
3235 pm->op_pmdynflags |= PMdf_UTF8;
3236 /* FIXME - can we make this function take const char * args? */
3237 PM_SETRE(pm, CALLREGCOMP((char*)p, (char*)p + plen, pm));
3238 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
3239 pm->op_pmflags |= PMf_WHITE;
3241 op_getmad(expr,(OP*)pm,'e');
3247 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3248 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3250 : OP_REGCMAYBE),0,expr);
3252 NewOp(1101, rcop, 1, LOGOP);
3253 rcop->op_type = OP_REGCOMP;
3254 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3255 rcop->op_first = scalar(expr);
3256 rcop->op_flags |= OPf_KIDS
3257 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3258 | (reglist ? OPf_STACKED : 0);
3259 rcop->op_private = 1;
3262 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3264 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
3267 /* establish postfix order */
3268 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3270 rcop->op_next = expr;
3271 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3274 rcop->op_next = LINKLIST(expr);
3275 expr->op_next = (OP*)rcop;
3278 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3283 if (pm->op_pmflags & PMf_EVAL) {
3285 if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
3286 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
3288 else if (repl->op_type == OP_CONST)
3292 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3293 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3294 if (curop->op_type == OP_GV) {
3295 GV * const gv = cGVOPx_gv(curop);
3297 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3300 else if (curop->op_type == OP_RV2CV)
3302 else if (curop->op_type == OP_RV2SV ||
3303 curop->op_type == OP_RV2AV ||
3304 curop->op_type == OP_RV2HV ||
3305 curop->op_type == OP_RV2GV) {
3306 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3309 else if (curop->op_type == OP_PADSV ||
3310 curop->op_type == OP_PADAV ||
3311 curop->op_type == OP_PADHV ||
3312 curop->op_type == OP_PADANY) {
3315 else if (curop->op_type == OP_PUSHRE)
3316 NOOP; /* Okay here, dangerous in newASSIGNOP */
3326 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
3327 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3328 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
3329 prepend_elem(o->op_type, scalar(repl), o);
3332 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3333 pm->op_pmflags |= PMf_MAYBE_CONST;
3334 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3336 NewOp(1101, rcop, 1, LOGOP);
3337 rcop->op_type = OP_SUBSTCONT;
3338 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3339 rcop->op_first = scalar(repl);
3340 rcop->op_flags |= OPf_KIDS;
3341 rcop->op_private = 1;
3344 /* establish postfix order */
3345 rcop->op_next = LINKLIST(repl);
3346 repl->op_next = (OP*)rcop;
3348 pm->op_pmreplroot = scalar((OP*)rcop);
3349 pm->op_pmreplstart = LINKLIST(rcop);
3358 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3362 NewOp(1101, svop, 1, SVOP);
3363 svop->op_type = (OPCODE)type;
3364 svop->op_ppaddr = PL_ppaddr[type];
3366 svop->op_next = (OP*)svop;
3367 svop->op_flags = (U8)flags;
3368 if (PL_opargs[type] & OA_RETSCALAR)
3370 if (PL_opargs[type] & OA_TARGET)
3371 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3372 return CHECKOP(type, svop);
3376 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3380 NewOp(1101, padop, 1, PADOP);
3381 padop->op_type = (OPCODE)type;
3382 padop->op_ppaddr = PL_ppaddr[type];
3383 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3384 SvREFCNT_dec(PAD_SVl(padop->op_padix));
3385 PAD_SETSV(padop->op_padix, sv);
3388 padop->op_next = (OP*)padop;
3389 padop->op_flags = (U8)flags;
3390 if (PL_opargs[type] & OA_RETSCALAR)
3392 if (PL_opargs[type] & OA_TARGET)
3393 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3394 return CHECKOP(type, padop);
3398 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3404 return newPADOP(type, flags, SvREFCNT_inc_simple(gv));
3406 return newSVOP(type, flags, SvREFCNT_inc_simple(gv));
3411 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3415 NewOp(1101, pvop, 1, PVOP);
3416 pvop->op_type = (OPCODE)type;
3417 pvop->op_ppaddr = PL_ppaddr[type];
3419 pvop->op_next = (OP*)pvop;
3420 pvop->op_flags = (U8)flags;
3421 if (PL_opargs[type] & OA_RETSCALAR)
3423 if (PL_opargs[type] & OA_TARGET)
3424 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3425 return CHECKOP(type, pvop);
3433 Perl_package(pTHX_ OP *o)
3442 save_hptr(&PL_curstash);
3443 save_item(PL_curstname);
3445 name = SvPV_const(cSVOPo->op_sv, len);
3446 PL_curstash = gv_stashpvn(name, len, TRUE);
3447 sv_setpvn(PL_curstname, name, len);
3449 PL_hints |= HINT_BLOCK_SCOPE;
3450 PL_copline = NOLINE;
3456 if (!PL_madskills) {
3461 pegop = newOP(OP_NULL,0);
3462 op_getmad(o,pegop,'P');
3472 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3479 OP *pegop = newOP(OP_NULL,0);
3482 if (idop->op_type != OP_CONST)
3483 Perl_croak(aTHX_ "Module name must be constant");
3486 op_getmad(idop,pegop,'U');
3491 SV * const vesv = ((SVOP*)version)->op_sv;
3494 op_getmad(version,pegop,'V');
3495 if (!arg && !SvNIOKp(vesv)) {
3502 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3503 Perl_croak(aTHX_ "Version number must be constant number");
3505 /* Make copy of idop so we don't free it twice */
3506 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3508 /* Fake up a method call to VERSION */
3509 meth = newSVpvs_share("VERSION");
3510 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3511 append_elem(OP_LIST,
3512 prepend_elem(OP_LIST, pack, list(version)),
3513 newSVOP(OP_METHOD_NAMED, 0, meth)));
3517 /* Fake up an import/unimport */
3518 if (arg && arg->op_type == OP_STUB) {
3520 op_getmad(arg,pegop,'S');
3521 imop = arg; /* no import on explicit () */
3523 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3524 imop = NULL; /* use 5.0; */
3526 idop->op_private |= OPpCONST_NOVER;
3532 op_getmad(arg,pegop,'A');
3534 /* Make copy of idop so we don't free it twice */
3535 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3537 /* Fake up a method call to import/unimport */
3539 ? newSVpvs_share("import") : newSVpvs_share("unimport");
3540 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3541 append_elem(OP_LIST,
3542 prepend_elem(OP_LIST, pack, list(arg)),
3543 newSVOP(OP_METHOD_NAMED, 0, meth)));
3546 /* Fake up the BEGIN {}, which does its thing immediately. */
3548 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
3551 append_elem(OP_LINESEQ,
3552 append_elem(OP_LINESEQ,
3553 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
3554 newSTATEOP(0, NULL, veop)),
3555 newSTATEOP(0, NULL, imop) ));
3557 /* The "did you use incorrect case?" warning used to be here.
3558 * The problem is that on case-insensitive filesystems one
3559 * might get false positives for "use" (and "require"):
3560 * "use Strict" or "require CARP" will work. This causes
3561 * portability problems for the script: in case-strict
3562 * filesystems the script will stop working.
3564 * The "incorrect case" warning checked whether "use Foo"
3565 * imported "Foo" to your namespace, but that is wrong, too:
3566 * there is no requirement nor promise in the language that
3567 * a Foo.pm should or would contain anything in package "Foo".
3569 * There is very little Configure-wise that can be done, either:
3570 * the case-sensitivity of the build filesystem of Perl does not
3571 * help in guessing the case-sensitivity of the runtime environment.
3574 PL_hints |= HINT_BLOCK_SCOPE;
3575 PL_copline = NOLINE;
3577 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3580 if (!PL_madskills) {
3581 /* FIXME - don't allocate pegop if !PL_madskills */
3590 =head1 Embedding Functions
3592 =for apidoc load_module
3594 Loads the module whose name is pointed to by the string part of name.
3595 Note that the actual module name, not its filename, should be given.
3596 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3597 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3598 (or 0 for no flags). ver, if specified, provides version semantics
3599 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3600 arguments can be used to specify arguments to the module's import()
3601 method, similar to C<use Foo::Bar VERSION LIST>.
3606 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3609 va_start(args, ver);
3610 vload_module(flags, name, ver, &args);
3614 #ifdef PERL_IMPLICIT_CONTEXT
3616 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3620 va_start(args, ver);
3621 vload_module(flags, name, ver, &args);
3627 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3632 OP * const modname = newSVOP(OP_CONST, 0, name);
3633 modname->op_private |= OPpCONST_BARE;
3635 veop = newSVOP(OP_CONST, 0, ver);
3639 if (flags & PERL_LOADMOD_NOIMPORT) {
3640 imop = sawparens(newNULLLIST());
3642 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3643 imop = va_arg(*args, OP*);
3648 sv = va_arg(*args, SV*);
3650 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3651 sv = va_arg(*args, SV*);
3655 const line_t ocopline = PL_copline;
3656 COP * const ocurcop = PL_curcop;
3657 const int oexpect = PL_expect;
3659 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3660 veop, modname, imop);
3661 PL_expect = oexpect;
3662 PL_copline = ocopline;
3663 PL_curcop = ocurcop;
3668 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
3674 if (!force_builtin) {
3675 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
3676 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
3677 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
3678 gv = gvp ? *gvp : NULL;
3682 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3683 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3684 append_elem(OP_LIST, term,
3685 scalar(newUNOP(OP_RV2CV, 0,
3686 newGVOP(OP_GV, 0, gv))))));
3689 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3695 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3697 return newBINOP(OP_LSLICE, flags,
3698 list(force_list(subscript)),
3699 list(force_list(listval)) );
3703 S_is_list_assignment(pTHX_ register const OP *o)
3711 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
3712 o = cUNOPo->op_first;
3714 flags = o->op_flags;
3716 if (type == OP_COND_EXPR) {
3717 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
3718 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3723 yyerror("Assignment to both a list and a scalar");
3727 if (type == OP_LIST &&
3728 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
3729 o->op_private & OPpLVAL_INTRO)
3732 if (type == OP_LIST || flags & OPf_PARENS ||
3733 type == OP_RV2AV || type == OP_RV2HV ||
3734 type == OP_ASLICE || type == OP_HSLICE)
3737 if (type == OP_PADAV || type == OP_PADHV)
3740 if (type == OP_RV2SV)
3747 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3753 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3754 return newLOGOP(optype, 0,
3755 mod(scalar(left), optype),
3756 newUNOP(OP_SASSIGN, 0, scalar(right)));
3759 return newBINOP(optype, OPf_STACKED,
3760 mod(scalar(left), optype), scalar(right));
3764 if (is_list_assignment(left)) {
3768 /* Grandfathering $[ assignment here. Bletch.*/
3769 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
3770 PL_eval_start = (left->op_type == OP_CONST) ? right : 0;
3771 left = mod(left, OP_AASSIGN);
3774 else if (left->op_type == OP_CONST) {
3776 /* Result of assignment is always 1 (or we'd be dead already) */
3777 return newSVOP(OP_CONST, 0, newSViv(1));
3779 curop = list(force_list(left));
3780 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3781 o->op_private = (U8)(0 | (flags >> 8));
3783 /* PL_generation sorcery:
3784 * an assignment like ($a,$b) = ($c,$d) is easier than
3785 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3786 * To detect whether there are common vars, the global var
3787 * PL_generation is incremented for each assign op we compile.
3788 * Then, while compiling the assign op, we run through all the
3789 * variables on both sides of the assignment, setting a spare slot
3790 * in each of them to PL_generation. If any of them already have
3791 * that value, we know we've got commonality. We could use a
3792 * single bit marker, but then we'd have to make 2 passes, first
3793 * to clear the flag, then to test and set it. To find somewhere
3794 * to store these values, evil chicanery is done with SvCUR().
3800 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3801 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3802 if (curop->op_type == OP_GV) {
3803 GV *gv = cGVOPx_gv(curop);
3805 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
3807 GvASSIGN_GENERATION_set(gv, PL_generation);
3809 else if (curop->op_type == OP_PADSV ||
3810 curop->op_type == OP_PADAV ||
3811 curop->op_type == OP_PADHV ||
3812 curop->op_type == OP_PADANY)
3814 if (PAD_COMPNAME_GEN(curop->op_targ)
3815 == (STRLEN)PL_generation)
3817 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
3820 else if (curop->op_type == OP_RV2CV)
3822 else if (curop->op_type == OP_RV2SV ||
3823 curop->op_type == OP_RV2AV ||
3824 curop->op_type == OP_RV2HV ||
3825 curop->op_type == OP_RV2GV) {
3826 if (lastop->op_type != OP_GV) /* funny deref? */
3829 else if (curop->op_type == OP_PUSHRE) {
3830 if (((PMOP*)curop)->op_pmreplroot) {
3832 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3833 ((PMOP*)curop)->op_pmreplroot));
3835 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3838 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
3840 GvASSIGN_GENERATION_set(gv, PL_generation);
3841 GvASSIGN_GENERATION_set(gv, PL_generation);
3850 o->op_private |= OPpASSIGN_COMMON;
3853 if ( ((left->op_private & OPpLVAL_INTRO) || ckWARN(WARN_MISC))
3854 && (left->op_type == OP_LIST
3855 || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
3857 OP* lop = ((LISTOP*)left)->op_first;
3859 if (lop->op_type == OP_PADSV ||
3860 lop->op_type == OP_PADAV ||
3861 lop->op_type == OP_PADHV ||
3862 lop->op_type == OP_PADANY)
3864 if (lop->op_private & OPpPAD_STATE) {
3865 if (left->op_private & OPpLVAL_INTRO) {
3866 o->op_private |= OPpASSIGN_STATE;
3867 /* hijacking PADSTALE for uninitialized state variables */
3868 SvPADSTALE_on(PAD_SVl(lop->op_targ));
3870 else { /* we already checked for WARN_MISC before */
3871 Perl_warner(aTHX_ packWARN(WARN_MISC), "State variable %s will be reinitialized",
3872 PAD_COMPNAME_PV(lop->op_targ));
3876 lop = lop->op_sibling;
3880 if (right && right->op_type == OP_SPLIT) {
3881 OP* tmpop = ((LISTOP*)right)->op_first;
3882 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
3883 PMOP * const pm = (PMOP*)tmpop;
3884 if (left->op_type == OP_RV2AV &&
3885 !(left->op_private & OPpLVAL_INTRO) &&
3886 !(o->op_private & OPpASSIGN_COMMON) )
3888 tmpop = ((UNOP*)left)->op_first;
3889 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3891 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3892 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3894 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3895 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
3897 pm->op_pmflags |= PMf_ONCE;
3898 tmpop = cUNOPo->op_first; /* to list (nulled) */
3899 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3900 tmpop->op_sibling = NULL; /* don't free split */
3901 right->op_next = tmpop->op_next; /* fix starting loc */
3903 op_getmad(o,right,'R'); /* blow off assign */
3905 op_free(o); /* blow off assign */
3907 right->op_flags &= ~OPf_WANT;
3908 /* "I don't know and I don't care." */
3913 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3914 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3916 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3918 sv_setiv(sv, PL_modcount+1);
3926 right = newOP(OP_UNDEF, 0);
3927 if (right->op_type == OP_READLINE) {
3928 right->op_flags |= OPf_STACKED;
3929 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3932 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3933 o = newBINOP(OP_SASSIGN, flags,
3934 scalar(right), mod(scalar(left), OP_SASSIGN) );
3940 o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
3941 o->op_private |= OPpCONST_ARYBASE;
3948 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3951 const U32 seq = intro_my();
3954 NewOp(1101, cop, 1, COP);
3955 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3956 cop->op_type = OP_DBSTATE;
3957 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3960 cop->op_type = OP_NEXTSTATE;
3961 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3963 cop->op_flags = (U8)flags;
3964 CopHINTS_set(cop, PL_hints);
3966 cop->op_private |= NATIVE_HINTS;
3968 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
3969 cop->op_next = (OP*)cop;
3972 cop->cop_label = label;
3973 PL_hints |= HINT_BLOCK_SCOPE;
3976 /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
3977 CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
3979 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
3980 cop->cop_hints_hash = PL_curcop->cop_hints_hash;
3981 if (cop->cop_hints_hash) {
3983 cop->cop_hints_hash->refcounted_he_refcnt++;
3984 HINTS_REFCNT_UNLOCK;
3987 if (PL_copline == NOLINE)
3988 CopLINE_set(cop, CopLINE(PL_curcop));
3990 CopLINE_set(cop, PL_copline);
3991 PL_copline = NOLINE;
3994 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3996 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3998 CopSTASH_set(cop, PL_curstash);
4000 if (PERLDB_LINE && PL_curstash != PL_debstash) {
4001 SV * const * const svp = av_fetch(CopFILEAVx(PL_curcop), (I32)CopLINE(cop), FALSE);
4002 if (svp && *svp != &PL_sv_undef ) {
4003 (void)SvIOK_on(*svp);
4004 SvIV_set(*svp, PTR2IV(cop));
4008 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
4013 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
4016 return new_logop(type, flags, &first, &other);
4020 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
4025 OP *first = *firstp;
4026 OP * const other = *otherp;
4028 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
4029 return newBINOP(type, flags, scalar(first), scalar(other));
4031 scalarboolean(first);
4032 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
4033 if (first->op_type == OP_NOT
4034 && (first->op_flags & OPf_SPECIAL)
4035 && (first->op_flags & OPf_KIDS)) {
4036 if (type == OP_AND || type == OP_OR) {
4042 first = *firstp = cUNOPo->op_first;
4044 first->op_next = o->op_next;
4045 cUNOPo->op_first = NULL;
4047 op_getmad(o,first,'O');
4053 if (first->op_type == OP_CONST) {
4054 if (first->op_private & OPpCONST_STRICT)
4055 no_bareword_allowed(first);
4056 else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
4057 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
4058 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
4059 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
4060 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
4062 if (other->op_type == OP_CONST)
4063 other->op_private |= OPpCONST_SHORTCIRCUIT;
4065 OP *newop = newUNOP(OP_NULL, 0, other);
4066 op_getmad(first, newop, '1');
4067 newop->op_targ = type; /* set "was" field */
4074 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
4075 const OP *o2 = other;
4076 if ( ! (o2->op_type == OP_LIST
4077 && (( o2 = cUNOPx(o2)->op_first))
4078 && o2->op_type == OP_PUSHMARK
4079 && (( o2 = o2->op_sibling)) )
4082 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
4083 || o2->op_type == OP_PADHV)
4084 && o2->op_private & OPpLVAL_INTRO
4085 && ckWARN(WARN_DEPRECATED))
4087 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4088 "Deprecated use of my() in false conditional");
4092 if (first->op_type == OP_CONST)
4093 first->op_private |= OPpCONST_SHORTCIRCUIT;
4095 first = newUNOP(OP_NULL, 0, first);
4096 op_getmad(other, first, '2');
4097 first->op_targ = type; /* set "was" field */
4104 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
4105 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
4107 const OP * const k1 = ((UNOP*)first)->op_first;
4108 const OP * const k2 = k1->op_sibling;
4110 switch (first->op_type)
4113 if (k2 && k2->op_type == OP_READLINE
4114 && (k2->op_flags & OPf_STACKED)
4115 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4117 warnop = k2->op_type;
4122 if (k1->op_type == OP_READDIR
4123 || k1->op_type == OP_GLOB
4124 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4125 || k1->op_type == OP_EACH)
4127 warnop = ((k1->op_type == OP_NULL)
4128 ? (OPCODE)k1->op_targ : k1->op_type);
4133 const line_t oldline = CopLINE(PL_curcop);
4134 CopLINE_set(PL_curcop, PL_copline);
4135 Perl_warner(aTHX_ packWARN(WARN_MISC),
4136 "Value of %s%s can be \"0\"; test with defined()",
4138 ((warnop == OP_READLINE || warnop == OP_GLOB)
4139 ? " construct" : "() operator"));
4140 CopLINE_set(PL_curcop, oldline);
4147 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
4148 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
4150 NewOp(1101, logop, 1, LOGOP);
4152 logop->op_type = (OPCODE)type;
4153 logop->op_ppaddr = PL_ppaddr[type];
4154 logop->op_first = first;
4155 logop->op_flags = (U8)(flags | OPf_KIDS);
4156 logop->op_other = LINKLIST(other);
4157 logop->op_private = (U8)(1 | (flags >> 8));
4159 /* establish postfix order */
4160 logop->op_next = LINKLIST(first);
4161 first->op_next = (OP*)logop;
4162 first->op_sibling = other;
4164 CHECKOP(type,logop);
4166 o = newUNOP(OP_NULL, 0, (OP*)logop);
4173 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
4181 return newLOGOP(OP_AND, 0, first, trueop);
4183 return newLOGOP(OP_OR, 0, first, falseop);
4185 scalarboolean(first);
4186 if (first->op_type == OP_CONST) {
4187 if (first->op_private & OPpCONST_BARE &&
4188 first->op_private & OPpCONST_STRICT) {
4189 no_bareword_allowed(first);
4191 if (SvTRUE(((SVOP*)first)->op_sv)) {
4194 trueop = newUNOP(OP_NULL, 0, trueop);
4195 op_getmad(first,trueop,'C');
4196 op_getmad(falseop,trueop,'e');
4198 /* FIXME for MAD - should there be an ELSE here? */
4208 falseop = newUNOP(OP_NULL, 0, falseop);
4209 op_getmad(first,falseop,'C');
4210 op_getmad(trueop,falseop,'t');
4212 /* FIXME for MAD - should there be an ELSE here? */
4220 NewOp(1101, logop, 1, LOGOP);
4221 logop->op_type = OP_COND_EXPR;
4222 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4223 logop->op_first = first;
4224 logop->op_flags = (U8)(flags | OPf_KIDS);
4225 logop->op_private = (U8)(1 | (flags >> 8));
4226 logop->op_other = LINKLIST(trueop);
4227 logop->op_next = LINKLIST(falseop);
4229 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
4232 /* establish postfix order */
4233 start = LINKLIST(first);
4234 first->op_next = (OP*)logop;
4236 first->op_sibling = trueop;
4237 trueop->op_sibling = falseop;
4238 o = newUNOP(OP_NULL, 0, (OP*)logop);
4240 trueop->op_next = falseop->op_next = o;
4247 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4256 NewOp(1101, range, 1, LOGOP);
4258 range->op_type = OP_RANGE;
4259 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4260 range->op_first = left;
4261 range->op_flags = OPf_KIDS;
4262 leftstart = LINKLIST(left);
4263 range->op_other = LINKLIST(right);
4264 range->op_private = (U8)(1 | (flags >> 8));
4266 left->op_sibling = right;
4268 range->op_next = (OP*)range;
4269 flip = newUNOP(OP_FLIP, flags, (OP*)range);
4270 flop = newUNOP(OP_FLOP, 0, flip);
4271 o = newUNOP(OP_NULL, 0, flop);
4273 range->op_next = leftstart;
4275 left->op_next = flip;
4276 right->op_next = flop;
4278 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4279 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4280 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4281 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4283 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4284 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4287 if (!flip->op_private || !flop->op_private)
4288 linklist(o); /* blow off optimizer unless constant */
4294 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4299 const bool once = block && block->op_flags & OPf_SPECIAL &&
4300 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4302 PERL_UNUSED_ARG(debuggable);
4305 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4306 return block; /* do {} while 0 does once */
4307 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4308 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4309 expr = newUNOP(OP_DEFINED, 0,
4310 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4311 } else if (expr->op_flags & OPf_KIDS) {
4312 const OP * const k1 = ((UNOP*)expr)->op_first;
4313 const OP * const k2 = k1 ? k1->op_sibling : NULL;
4314 switch (expr->op_type) {
4316 if (k2 && k2->op_type == OP_READLINE
4317 && (k2->op_flags & OPf_STACKED)
4318 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4319 expr = newUNOP(OP_DEFINED, 0, expr);
4323 if (k1 && (k1->op_type == OP_READDIR
4324 || k1->op_type == OP_GLOB
4325 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4326 || k1->op_type == OP_EACH))
4327 expr = newUNOP(OP_DEFINED, 0, expr);
4333 /* if block is null, the next append_elem() would put UNSTACK, a scalar
4334 * op, in listop. This is wrong. [perl #27024] */
4336 block = newOP(OP_NULL, 0);
4337 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4338 o = new_logop(OP_AND, 0, &expr, &listop);
4341 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4343 if (once && o != listop)
4344 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4347 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
4349 o->op_flags |= flags;
4351 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4356 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
4357 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
4366 PERL_UNUSED_ARG(debuggable);
4369 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4370 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4371 expr = newUNOP(OP_DEFINED, 0,
4372 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4373 } else if (expr->op_flags & OPf_KIDS) {
4374 const OP * const k1 = ((UNOP*)expr)->op_first;
4375 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
4376 switch (expr->op_type) {
4378 if (k2 && k2->op_type == OP_READLINE
4379 && (k2->op_flags & OPf_STACKED)
4380 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4381 expr = newUNOP(OP_DEFINED, 0, expr);
4385 if (k1 && (k1->op_type == OP_READDIR
4386 || k1->op_type == OP_GLOB
4387 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4388 || k1->op_type == OP_EACH))
4389 expr = newUNOP(OP_DEFINED, 0, expr);
4396 block = newOP(OP_NULL, 0);
4397 else if (cont || has_my) {
4398 block = scope(block);
4402 next = LINKLIST(cont);
4405 OP * const unstack = newOP(OP_UNSTACK, 0);
4408 cont = append_elem(OP_LINESEQ, cont, unstack);
4412 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4414 redo = LINKLIST(listop);
4417 PL_copline = (line_t)whileline;
4419 o = new_logop(OP_AND, 0, &expr, &listop);
4420 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4421 op_free(expr); /* oops, it's a while (0) */
4423 return NULL; /* listop already freed by new_logop */
4426 ((LISTOP*)listop)->op_last->op_next =
4427 (o == listop ? redo : LINKLIST(o));
4433 NewOp(1101,loop,1,LOOP);
4434 loop->op_type = OP_ENTERLOOP;
4435 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4436 loop->op_private = 0;
4437 loop->op_next = (OP*)loop;
4440 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4442 loop->op_redoop = redo;
4443 loop->op_lastop = o;
4444 o->op_private |= loopflags;
4447 loop->op_nextop = next;
4449 loop->op_nextop = o;
4451 o->op_flags |= flags;
4452 o->op_private |= (flags >> 8);
4457 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
4462 PADOFFSET padoff = 0;
4468 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4469 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
4470 sv->op_type = OP_RV2GV;
4471 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4472 if (cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
4473 iterpflags |= OPpITER_DEF;
4475 else if (sv->op_type == OP_PADSV) { /* private variable */
4476 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
4477 padoff = sv->op_targ;
4486 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4487 padoff = sv->op_targ;
4492 iterflags |= OPf_SPECIAL;
4498 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4499 if (padoff && strEQ(PAD_COMPNAME_PV(padoff), "$_"))
4500 iterpflags |= OPpITER_DEF;
4503 const PADOFFSET offset = pad_findmy("$_");
4504 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
4505 sv = newGVOP(OP_GV, 0, PL_defgv);
4510 iterpflags |= OPpITER_DEF;
4512 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4513 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4514 iterflags |= OPf_STACKED;
4516 else if (expr->op_type == OP_NULL &&
4517 (expr->op_flags & OPf_KIDS) &&
4518 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4520 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4521 * set the STACKED flag to indicate that these values are to be
4522 * treated as min/max values by 'pp_iterinit'.
4524 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4525 LOGOP* const range = (LOGOP*) flip->op_first;
4526 OP* const left = range->op_first;
4527 OP* const right = left->op_sibling;
4530 range->op_flags &= ~OPf_KIDS;
4531 range->op_first = NULL;
4533 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4534 listop->op_first->op_next = range->op_next;
4535 left->op_next = range->op_other;
4536 right->op_next = (OP*)listop;
4537 listop->op_next = listop->op_first;
4540 op_getmad(expr,(OP*)listop,'O');
4544 expr = (OP*)(listop);
4546 iterflags |= OPf_STACKED;
4549 expr = mod(force_list(expr), OP_GREPSTART);
4552 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4553 append_elem(OP_LIST, expr, scalar(sv))));
4554 assert(!loop->op_next);
4555 /* for my $x () sets OPpLVAL_INTRO;
4556 * for our $x () sets OPpOUR_INTRO */
4557 loop->op_private = (U8)iterpflags;
4558 #ifdef PL_OP_SLAB_ALLOC
4561 NewOp(1234,tmp,1,LOOP);
4562 Copy(loop,tmp,1,LISTOP);
4567 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
4569 loop->op_targ = padoff;
4570 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
4572 op_getmad(madsv, (OP*)loop, 'v');
4573 PL_copline = forline;
4574 return newSTATEOP(0, label, wop);
4578 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4583 if (type != OP_GOTO || label->op_type == OP_CONST) {
4584 /* "last()" means "last" */
4585 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4586 o = newOP(type, OPf_SPECIAL);
4588 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4589 ? SvPVx_nolen_const(((SVOP*)label)->op_sv)
4593 op_getmad(label,o,'L');
4599 /* Check whether it's going to be a goto &function */
4600 if (label->op_type == OP_ENTERSUB
4601 && !(label->op_flags & OPf_STACKED))
4602 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4603 o = newUNOP(type, OPf_STACKED, label);
4605 PL_hints |= HINT_BLOCK_SCOPE;
4609 /* if the condition is a literal array or hash
4610 (or @{ ... } etc), make a reference to it.
4613 S_ref_array_or_hash(pTHX_ OP *cond)
4616 && (cond->op_type == OP_RV2AV
4617 || cond->op_type == OP_PADAV
4618 || cond->op_type == OP_RV2HV
4619 || cond->op_type == OP_PADHV))
4621 return newUNOP(OP_REFGEN,
4622 0, mod(cond, OP_REFGEN));
4628 /* These construct the optree fragments representing given()
4631 entergiven and enterwhen are LOGOPs; the op_other pointer
4632 points up to the associated leave op. We need this so we
4633 can put it in the context and make break/continue work.
4634 (Also, of course, pp_enterwhen will jump straight to
4635 op_other if the match fails.)
4640 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
4641 I32 enter_opcode, I32 leave_opcode,
4642 PADOFFSET entertarg)
4648 NewOp(1101, enterop, 1, LOGOP);
4649 enterop->op_type = enter_opcode;
4650 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
4651 enterop->op_flags = (U8) OPf_KIDS;
4652 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
4653 enterop->op_private = 0;
4655 o = newUNOP(leave_opcode, 0, (OP *) enterop);
4658 enterop->op_first = scalar(cond);
4659 cond->op_sibling = block;
4661 o->op_next = LINKLIST(cond);
4662 cond->op_next = (OP *) enterop;
4665 /* This is a default {} block */
4666 enterop->op_first = block;
4667 enterop->op_flags |= OPf_SPECIAL;
4669 o->op_next = (OP *) enterop;
4672 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
4673 entergiven and enterwhen both
4676 enterop->op_next = LINKLIST(block);
4677 block->op_next = enterop->op_other = o;
4682 /* Does this look like a boolean operation? For these purposes
4683 a boolean operation is:
4684 - a subroutine call [*]
4685 - a logical connective
4686 - a comparison operator
4687 - a filetest operator, with the exception of -s -M -A -C
4688 - defined(), exists() or eof()
4689 - /$re/ or $foo =~ /$re/
4691 [*] possibly surprising
4695 S_looks_like_bool(pTHX_ const OP *o)
4698 switch(o->op_type) {
4700 return looks_like_bool(cLOGOPo->op_first);
4704 looks_like_bool(cLOGOPo->op_first)
4705 && looks_like_bool(cLOGOPo->op_first->op_sibling));
4709 case OP_NOT: case OP_XOR:
4710 /* Note that OP_DOR is not here */
4712 case OP_EQ: case OP_NE: case OP_LT:
4713 case OP_GT: case OP_LE: case OP_GE:
4715 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
4716 case OP_I_GT: case OP_I_LE: case OP_I_GE:
4718 case OP_SEQ: case OP_SNE: case OP_SLT:
4719 case OP_SGT: case OP_SLE: case OP_SGE:
4723 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
4724 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
4725 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
4726 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
4727 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
4728 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
4729 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
4730 case OP_FTTEXT: case OP_FTBINARY:
4732 case OP_DEFINED: case OP_EXISTS:
4733 case OP_MATCH: case OP_EOF:
4738 /* Detect comparisons that have been optimized away */
4739 if (cSVOPo->op_sv == &PL_sv_yes
4740 || cSVOPo->op_sv == &PL_sv_no)
4751 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
4755 return newGIVWHENOP(
4756 ref_array_or_hash(cond),
4758 OP_ENTERGIVEN, OP_LEAVEGIVEN,
4762 /* If cond is null, this is a default {} block */
4764 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
4766 const bool cond_llb = (!cond || looks_like_bool(cond));
4772 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
4774 scalar(ref_array_or_hash(cond)));
4777 return newGIVWHENOP(
4779 append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
4780 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
4784 =for apidoc cv_undef
4786 Clear out all the active components of a CV. This can happen either
4787 by an explicit C<undef &foo>, or by the reference count going to zero.
4788 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
4789 children can still follow the full lexical scope chain.
4795 Perl_cv_undef(pTHX_ CV *cv)
4799 if (CvFILE(cv) && !CvISXSUB(cv)) {
4800 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4801 Safefree(CvFILE(cv));
4806 if (!CvISXSUB(cv) && CvROOT(cv)) {
4807 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
4808 Perl_croak(aTHX_ "Can't undef active subroutine");
4811 PAD_SAVE_SETNULLPAD();
4813 op_free(CvROOT(cv));
4818 SvPOK_off((SV*)cv); /* forget prototype */
4823 /* remove CvOUTSIDE unless this is an undef rather than a free */
4824 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
4825 if (!CvWEAKOUTSIDE(cv))
4826 SvREFCNT_dec(CvOUTSIDE(cv));
4827 CvOUTSIDE(cv) = NULL;
4830 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4833 if (CvISXSUB(cv) && CvXSUB(cv)) {
4836 /* delete all flags except WEAKOUTSIDE */
4837 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
4841 Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
4844 /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
4845 relying on SvCUR, and doubling up the buffer to hold CvFILE(). */
4846 if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
4847 || (p && (len != SvCUR(cv) /* Not the same length. */
4848 || memNE(p, SvPVX_const(cv), len))))
4849 && ckWARN_d(WARN_PROTOTYPE)) {
4850 SV* const msg = sv_newmortal();
4854 gv_efullname3(name = sv_newmortal(), gv, NULL);
4855 sv_setpv(msg, "Prototype mismatch:");
4857 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, (void*)name);
4859 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (void*)cv);
4861 sv_catpvs(msg, ": none");
4862 sv_catpvs(msg, " vs ");
4864 Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
4866 sv_catpvs(msg, "none");
4867 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, (void*)msg);
4871 static void const_sv_xsub(pTHX_ CV* cv);
4875 =head1 Optree Manipulation Functions
4877 =for apidoc cv_const_sv
4879 If C<cv> is a constant sub eligible for inlining. returns the constant
4880 value returned by the sub. Otherwise, returns NULL.
4882 Constant subs can be created with C<newCONSTSUB> or as described in
4883 L<perlsub/"Constant Functions">.
4888 Perl_cv_const_sv(pTHX_ CV *cv)
4890 PERL_UNUSED_CONTEXT;
4893 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
4895 return CvCONST(cv) ? (SV*)CvXSUBANY(cv).any_ptr : NULL;
4898 /* op_const_sv: examine an optree to determine whether it's in-lineable.
4899 * Can be called in 3 ways:
4902 * look for a single OP_CONST with attached value: return the value
4904 * cv && CvCLONE(cv) && !CvCONST(cv)
4906 * examine the clone prototype, and if contains only a single
4907 * OP_CONST referencing a pad const, or a single PADSV referencing
4908 * an outer lexical, return a non-zero value to indicate the CV is
4909 * a candidate for "constizing" at clone time
4913 * We have just cloned an anon prototype that was marked as a const
4914 * candidiate. Try to grab the current value, and in the case of
4915 * PADSV, ignore it if it has multiple references. Return the value.
4919 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
4927 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4928 o = cLISTOPo->op_first->op_sibling;
4930 for (; o; o = o->op_next) {
4931 const OPCODE type = o->op_type;
4933 if (sv && o->op_next == o)
4935 if (o->op_next != o) {
4936 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4938 if (type == OP_DBSTATE)
4941 if (type == OP_LEAVESUB || type == OP_RETURN)
4945 if (type == OP_CONST && cSVOPo->op_sv)
4947 else if (cv && type == OP_CONST) {
4948 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4952 else if (cv && type == OP_PADSV) {
4953 if (CvCONST(cv)) { /* newly cloned anon */
4954 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4955 /* the candidate should have 1 ref from this pad and 1 ref
4956 * from the parent */
4957 if (!sv || SvREFCNT(sv) != 2)
4964 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
4965 sv = &PL_sv_undef; /* an arbitrary non-null value */
4980 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4983 /* This would be the return value, but the return cannot be reached. */
4984 OP* pegop = newOP(OP_NULL, 0);
4987 PERL_UNUSED_ARG(floor);
4997 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4999 NORETURN_FUNCTION_END;
5004 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
5006 return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
5010 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5017 register CV *cv = NULL;
5019 /* If the subroutine has no body, no attributes, and no builtin attributes
5020 then it's just a sub declaration, and we may be able to get away with
5021 storing with a placeholder scalar in the symbol table, rather than a
5022 full GV and CV. If anything is present then it will take a full CV to
5024 const I32 gv_fetch_flags
5025 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5027 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
5028 const char * const name = o ? SvPVx_nolen_const(cSVOPo->op_sv) : NULL;
5031 assert(proto->op_type == OP_CONST);
5032 ps = SvPVx_const(((SVOP*)proto)->op_sv, ps_len);
5037 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
5038 SV * const sv = sv_newmortal();
5039 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
5040 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
5041 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
5042 aname = SvPVX_const(sv);
5047 gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
5048 : gv_fetchpv(aname ? aname
5049 : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5050 gv_fetch_flags, SVt_PVCV);
5052 if (!PL_madskills) {
5061 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
5062 maximum a prototype before. */
5063 if (SvTYPE(gv) > SVt_NULL) {
5064 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
5065 && ckWARN_d(WARN_PROTOTYPE))
5067 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
5069 cv_ckproto_len((CV*)gv, NULL, ps, ps_len);
5072 sv_setpvn((SV*)gv, ps, ps_len);
5074 sv_setiv((SV*)gv, -1);
5075 SvREFCNT_dec(PL_compcv);
5076 cv = PL_compcv = NULL;
5077 PL_sub_generation++;
5081 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
5083 #ifdef GV_UNIQUE_CHECK
5084 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
5085 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
5089 if (!block || !ps || *ps || attrs
5090 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5092 || block->op_type == OP_NULL
5097 const_sv = op_const_sv(block, NULL);
5100 const bool exists = CvROOT(cv) || CvXSUB(cv);
5102 #ifdef GV_UNIQUE_CHECK
5103 if (exists && GvUNIQUE(gv)) {
5104 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
5108 /* if the subroutine doesn't exist and wasn't pre-declared
5109 * with a prototype, assume it will be AUTOLOADed,
5110 * skipping the prototype check
5112 if (exists || SvPOK(cv))
5113 cv_ckproto_len(cv, gv, ps, ps_len);
5114 /* already defined (or promised)? */
5115 if (exists || GvASSUMECV(gv)) {
5118 || block->op_type == OP_NULL
5121 if (CvFLAGS(PL_compcv)) {
5122 /* might have had built-in attrs applied */
5123 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5125 /* just a "sub foo;" when &foo is already defined */
5126 SAVEFREESV(PL_compcv);
5131 && block->op_type != OP_NULL
5134 if (ckWARN(WARN_REDEFINE)
5136 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
5138 const line_t oldline = CopLINE(PL_curcop);
5139 if (PL_copline != NOLINE)
5140 CopLINE_set(PL_curcop, PL_copline);
5141 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5142 CvCONST(cv) ? "Constant subroutine %s redefined"
5143 : "Subroutine %s redefined", name);
5144 CopLINE_set(PL_curcop, oldline);
5147 if (!PL_minus_c) /* keep old one around for madskills */
5150 /* (PL_madskills unset in used file.) */
5158 SvREFCNT_inc_simple_void_NN(const_sv);
5160 assert(!CvROOT(cv) && !CvCONST(cv));
5161 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
5162 CvXSUBANY(cv).any_ptr = const_sv;
5163 CvXSUB(cv) = const_sv_xsub;
5169 cv = newCONSTSUB(NULL, name, const_sv);
5171 PL_sub_generation++;
5175 SvREFCNT_dec(PL_compcv);
5183 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
5184 * before we clobber PL_compcv.
5188 || block->op_type == OP_NULL
5192 /* Might have had built-in attributes applied -- propagate them. */
5193 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5194 if (CvGV(cv) && GvSTASH(CvGV(cv)))
5195 stash = GvSTASH(CvGV(cv));
5196 else if (CvSTASH(cv))
5197 stash = CvSTASH(cv);
5199 stash = PL_curstash;
5202 /* possibly about to re-define existing subr -- ignore old cv */
5203 rcv = (SV*)PL_compcv;
5204 if (name && GvSTASH(gv))
5205 stash = GvSTASH(gv);
5207 stash = PL_curstash;
5209 apply_attrs(stash, rcv, attrs, FALSE);
5211 if (cv) { /* must reuse cv if autoloaded */
5218 || block->op_type == OP_NULL) && !PL_madskills
5221 /* got here with just attrs -- work done, so bug out */
5222 SAVEFREESV(PL_compcv);
5225 /* transfer PL_compcv to cv */
5227 CvFLAGS(cv) = CvFLAGS(PL_compcv);
5228 if (!CvWEAKOUTSIDE(cv))
5229 SvREFCNT_dec(CvOUTSIDE(cv));
5230 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
5231 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
5232 CvOUTSIDE(PL_compcv) = 0;
5233 CvPADLIST(cv) = CvPADLIST(PL_compcv);
5234 CvPADLIST(PL_compcv) = 0;
5235 /* inner references to PL_compcv must be fixed up ... */
5236 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
5237 /* ... before we throw it away */
5238 SvREFCNT_dec(PL_compcv);
5240 if (PERLDB_INTER)/* Advice debugger on the new sub. */
5241 ++PL_sub_generation;
5248 if (strEQ(name, "import")) {
5249 PL_formfeed = (SV*)cv;
5250 Perl_warner(aTHX_ packWARN(WARN_VOID), "%lx\n", (long)cv);
5254 PL_sub_generation++;
5258 CvFILE_set_from_cop(cv, PL_curcop);
5259 CvSTASH(cv) = PL_curstash;
5262 sv_setpvn((SV*)cv, ps, ps_len);
5264 if (PL_error_count) {
5268 const char *s = strrchr(name, ':');
5270 if (strEQ(s, "BEGIN")) {
5271 const char not_safe[] =
5272 "BEGIN not safe after errors--compilation aborted";
5273 if (PL_in_eval & EVAL_KEEPERR)
5274 Perl_croak(aTHX_ not_safe);
5276 /* force display of errors found but not reported */
5277 sv_catpv(ERRSV, not_safe);
5278 Perl_croak(aTHX_ "%"SVf, (void*)ERRSV);
5288 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5289 mod(scalarseq(block), OP_LEAVESUBLV));
5292 /* This makes sub {}; work as expected. */
5293 if (block->op_type == OP_STUB) {
5294 OP* const newblock = newSTATEOP(0, NULL, 0);
5296 op_getmad(block,newblock,'B');
5302 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5304 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5305 OpREFCNT_set(CvROOT(cv), 1);
5306 CvSTART(cv) = LINKLIST(CvROOT(cv));
5307 CvROOT(cv)->op_next = 0;
5308 CALL_PEEP(CvSTART(cv));
5310 /* now that optimizer has done its work, adjust pad values */
5312 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
5315 assert(!CvCONST(cv));
5316 if (ps && !*ps && op_const_sv(block, cv))
5320 if (name || aname) {
5322 const char * const tname = (name ? name : aname);
5324 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5325 SV * const sv = newSV(0);
5326 SV * const tmpstr = sv_newmortal();
5327 GV * const db_postponed = gv_fetchpvs("DB::postponed",
5328 GV_ADDMULTI, SVt_PVHV);
5331 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5333 (long)PL_subline, (long)CopLINE(PL_curcop));
5334 gv_efullname3(tmpstr, gv, NULL);
5335 hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0);
5336 hv = GvHVn(db_postponed);
5337 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
5338 CV * const pcv = GvCV(db_postponed);
5344 call_sv((SV*)pcv, G_DISCARD);
5349 if ((s = strrchr(tname,':')))
5354 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I' && *s != 'U')
5357 if (strEQ(s, "BEGIN") && !PL_error_count) {
5358 const I32 oldscope = PL_scopestack_ix;
5360 SAVECOPFILE(&PL_compiling);
5361 SAVECOPLINE(&PL_compiling);
5364 PL_beginav = newAV();
5365 DEBUG_x( dump_sub(gv) );
5366 av_push(PL_beginav, (SV*)cv);
5367 GvCV(gv) = 0; /* cv has been hijacked */
5368 call_list(oldscope, PL_beginav);
5370 PL_curcop = &PL_compiling;
5371 CopHINTS_set(&PL_compiling, PL_hints);
5374 else if (strEQ(s, "END") && !PL_error_count) {
5377 DEBUG_x( dump_sub(gv) );
5378 av_unshift(PL_endav, 1);
5379 av_store(PL_endav, 0, (SV*)cv);
5380 GvCV(gv) = 0; /* cv has been hijacked */
5382 else if (strEQ(s, "UNITCHECK") && !PL_error_count) {
5383 /* It's never too late to run a unitcheck block */
5384 if (!PL_unitcheckav)
5385 PL_unitcheckav = newAV();
5386 DEBUG_x( dump_sub(gv) );
5387 av_unshift(PL_unitcheckav, 1);
5388 av_store(PL_unitcheckav, 0, (SV*)cv);
5389 GvCV(gv) = 0; /* cv has been hijacked */
5391 else if (strEQ(s, "CHECK") && !PL_error_count) {
5393 PL_checkav = newAV();
5394 DEBUG_x( dump_sub(gv) );
5395 if (PL_main_start && ckWARN(WARN_VOID))
5396 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
5397 av_unshift(PL_checkav, 1);
5398 av_store(PL_checkav, 0, (SV*)cv);
5399 GvCV(gv) = 0; /* cv has been hijacked */
5401 else if (strEQ(s, "INIT") && !PL_error_count) {
5403 PL_initav = newAV();
5404 DEBUG_x( dump_sub(gv) );
5405 if (PL_main_start && ckWARN(WARN_VOID))
5406 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
5407 av_push(PL_initav, (SV*)cv);
5408 GvCV(gv) = 0; /* cv has been hijacked */
5413 PL_copline = NOLINE;
5418 /* XXX unsafe for threads if eval_owner isn't held */
5420 =for apidoc newCONSTSUB
5422 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5423 eligible for inlining at compile-time.
5429 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
5434 const char *const temp_p = CopFILE(PL_curcop);
5435 const STRLEN len = temp_p ? strlen(temp_p) : 0;
5437 SV *const temp_sv = CopFILESV(PL_curcop);
5439 const char *const temp_p = temp_sv ? SvPV_const(temp_sv, len) : NULL;
5441 char *const file = savepvn(temp_p, temp_p ? len : 0);
5445 SAVECOPLINE(PL_curcop);
5446 CopLINE_set(PL_curcop, PL_copline);
5449 PL_hints &= ~HINT_BLOCK_SCOPE;
5452 SAVESPTR(PL_curstash);
5453 SAVECOPSTASH(PL_curcop);
5454 PL_curstash = stash;
5455 CopSTASH_set(PL_curcop,stash);
5458 /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
5459 and so doesn't get free()d. (It's expected to be from the C pre-
5460 processor __FILE__ directive). But we need a dynamically allocated one,
5461 and we need it to get freed. */
5462 cv = newXS_flags(name, const_sv_xsub, file, "", XS_DYNAMIC_FILENAME);
5463 CvXSUBANY(cv).any_ptr = sv;
5469 CopSTASH_free(PL_curcop);
5477 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
5478 const char *const filename, const char *const proto,
5481 CV *cv = newXS(name, subaddr, filename);
5483 if (flags & XS_DYNAMIC_FILENAME) {
5484 /* We need to "make arrangements" (ie cheat) to ensure that the
5485 filename lasts as long as the PVCV we just created, but also doesn't
5487 STRLEN filename_len = strlen(filename);
5488 STRLEN proto_and_file_len = filename_len;
5489 char *proto_and_file;
5493 proto_len = strlen(proto);
5494 proto_and_file_len += proto_len;
5496 Newx(proto_and_file, proto_and_file_len + 1, char);
5497 Copy(proto, proto_and_file, proto_len, char);
5498 Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
5501 proto_and_file = savepvn(filename, filename_len);
5504 /* This gets free()d. :-) */
5505 sv_usepvn_flags((SV*)cv, proto_and_file, proto_and_file_len,
5506 SV_HAS_TRAILING_NUL);
5508 /* This gives us the correct prototype, rather than one with the
5509 file name appended. */
5510 SvCUR_set(cv, proto_len);
5514 CvFILE(cv) = proto_and_file + proto_len;
5516 sv_setpv((SV *)cv, proto);
5522 =for apidoc U||newXS
5524 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
5525 static storage, as it is used directly as CvFILE(), without a copy being made.
5531 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
5534 GV * const gv = gv_fetchpv(name ? name :
5535 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5536 GV_ADDMULTI, SVt_PVCV);
5540 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
5542 if ((cv = (name ? GvCV(gv) : NULL))) {
5544 /* just a cached method */
5548 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5549 /* already defined (or promised) */
5550 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
5551 if (ckWARN(WARN_REDEFINE)) {
5552 GV * const gvcv = CvGV(cv);
5554 HV * const stash = GvSTASH(gvcv);
5556 const char *redefined_name = HvNAME_get(stash);
5557 if ( strEQ(redefined_name,"autouse") ) {
5558 const line_t oldline = CopLINE(PL_curcop);
5559 if (PL_copline != NOLINE)
5560 CopLINE_set(PL_curcop, PL_copline);
5561 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5562 CvCONST(cv) ? "Constant subroutine %s redefined"
5563 : "Subroutine %s redefined"
5565 CopLINE_set(PL_curcop, oldline);
5575 if (cv) /* must reuse cv if autoloaded */
5579 sv_upgrade((SV *)cv, SVt_PVCV);
5583 PL_sub_generation++;
5587 (void)gv_fetchfile(filename);
5588 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
5589 an external constant string */
5591 CvXSUB(cv) = subaddr;
5594 const char *s = strrchr(name,':');
5600 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5603 if (strEQ(s, "BEGIN")) {
5605 PL_beginav = newAV();
5606 av_push(PL_beginav, (SV*)cv);
5607 GvCV(gv) = 0; /* cv has been hijacked */
5609 else if (strEQ(s, "END")) {
5612 av_unshift(PL_endav, 1);
5613 av_store(PL_endav, 0, (SV*)cv);
5614 GvCV(gv) = 0; /* cv has been hijacked */
5616 else if (strEQ(s, "CHECK")) {
5618 PL_checkav = newAV();
5619 if (PL_main_start && ckWARN(WARN_VOID))
5620 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
5621 av_unshift(PL_checkav, 1);
5622 av_store(PL_checkav, 0, (SV*)cv);
5623 GvCV(gv) = 0; /* cv has been hijacked */
5625 else if (strEQ(s, "INIT")) {
5627 PL_initav = newAV();
5628 if (PL_main_start && ckWARN(WARN_VOID))
5629 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
5630 av_push(PL_initav, (SV*)cv);
5631 GvCV(gv) = 0; /* cv has been hijacked */
5646 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5651 OP* pegop = newOP(OP_NULL, 0);
5655 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
5656 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
5658 #ifdef GV_UNIQUE_CHECK
5660 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5664 if ((cv = GvFORM(gv))) {
5665 if (ckWARN(WARN_REDEFINE)) {
5666 const line_t oldline = CopLINE(PL_curcop);
5667 if (PL_copline != NOLINE)
5668 CopLINE_set(PL_curcop, PL_copline);
5669 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5670 o ? "Format %"SVf" redefined"
5671 : "Format STDOUT redefined", (void*)cSVOPo->op_sv);
5672 CopLINE_set(PL_curcop, oldline);
5679 CvFILE_set_from_cop(cv, PL_curcop);
5682 pad_tidy(padtidy_FORMAT);
5683 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5684 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5685 OpREFCNT_set(CvROOT(cv), 1);
5686 CvSTART(cv) = LINKLIST(CvROOT(cv));
5687 CvROOT(cv)->op_next = 0;
5688 CALL_PEEP(CvSTART(cv));
5690 op_getmad(o,pegop,'n');
5691 op_getmad_weak(block, pegop, 'b');
5695 PL_copline = NOLINE;
5703 Perl_newANONLIST(pTHX_ OP *o)
5705 return convert(OP_ANONLIST, OPf_SPECIAL, o);
5709 Perl_newANONHASH(pTHX_ OP *o)
5711 return convert(OP_ANONHASH, OPf_SPECIAL, o);
5715 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5717 return newANONATTRSUB(floor, proto, NULL, block);
5721 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5723 return newUNOP(OP_REFGEN, 0,
5724 newSVOP(OP_ANONCODE, 0,
5725 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5729 Perl_oopsAV(pTHX_ OP *o)
5732 switch (o->op_type) {
5734 o->op_type = OP_PADAV;
5735 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5736 return ref(o, OP_RV2AV);
5739 o->op_type = OP_RV2AV;
5740 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5745 if (ckWARN_d(WARN_INTERNAL))
5746 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
5753 Perl_oopsHV(pTHX_ OP *o)
5756 switch (o->op_type) {
5759 o->op_type = OP_PADHV;
5760 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5761 return ref(o, OP_RV2HV);
5765 o->op_type = OP_RV2HV;
5766 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5771 if (ckWARN_d(WARN_INTERNAL))
5772 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
5779 Perl_newAVREF(pTHX_ OP *o)
5782 if (o->op_type == OP_PADANY) {
5783 o->op_type = OP_PADAV;
5784 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5787 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5788 && ckWARN(WARN_DEPRECATED)) {
5789 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5790 "Using an array as a reference is deprecated");
5792 return newUNOP(OP_RV2AV, 0, scalar(o));
5796 Perl_newGVREF(pTHX_ I32 type, OP *o)
5798 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5799 return newUNOP(OP_NULL, 0, o);
5800 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5804 Perl_newHVREF(pTHX_ OP *o)
5807 if (o->op_type == OP_PADANY) {
5808 o->op_type = OP_PADHV;
5809 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5812 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5813 && ckWARN(WARN_DEPRECATED)) {
5814 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5815 "Using a hash as a reference is deprecated");
5817 return newUNOP(OP_RV2HV, 0, scalar(o));
5821 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5823 return newUNOP(OP_RV2CV, flags, scalar(o));
5827 Perl_newSVREF(pTHX_ OP *o)
5830 if (o->op_type == OP_PADANY) {
5831 o->op_type = OP_PADSV;
5832 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5835 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5836 o->op_flags |= OPpDONE_SVREF;
5839 return newUNOP(OP_RV2SV, 0, scalar(o));
5842 /* Check routines. See the comments at the top of this file for details
5843 * on when these are called */
5846 Perl_ck_anoncode(pTHX_ OP *o)
5848 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
5850 cSVOPo->op_sv = NULL;
5855 Perl_ck_bitop(pTHX_ OP *o)
5858 #define OP_IS_NUMCOMPARE(op) \
5859 ((op) == OP_LT || (op) == OP_I_LT || \
5860 (op) == OP_GT || (op) == OP_I_GT || \
5861 (op) == OP_LE || (op) == OP_I_LE || \
5862 (op) == OP_GE || (op) == OP_I_GE || \
5863 (op) == OP_EQ || (op) == OP_I_EQ || \
5864 (op) == OP_NE || (op) == OP_I_NE || \
5865 (op) == OP_NCMP || (op) == OP_I_NCMP)
5866 o->op_private = (U8)(PL_hints & HINT_INTEGER);
5867 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
5868 && (o->op_type == OP_BIT_OR
5869 || o->op_type == OP_BIT_AND
5870 || o->op_type == OP_BIT_XOR))
5872 const OP * const left = cBINOPo->op_first;
5873 const OP * const right = left->op_sibling;
5874 if ((OP_IS_NUMCOMPARE(left->op_type) &&
5875 (left->op_flags & OPf_PARENS) == 0) ||
5876 (OP_IS_NUMCOMPARE(right->op_type) &&
5877 (right->op_flags & OPf_PARENS) == 0))
5878 if (ckWARN(WARN_PRECEDENCE))
5879 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
5880 "Possible precedence problem on bitwise %c operator",
5881 o->op_type == OP_BIT_OR ? '|'
5882 : o->op_type == OP_BIT_AND ? '&' : '^'
5889 Perl_ck_concat(pTHX_ OP *o)
5891 const OP * const kid = cUNOPo->op_first;
5892 PERL_UNUSED_CONTEXT;
5893 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
5894 !(kUNOP->op_first->op_flags & OPf_MOD))
5895 o->op_flags |= OPf_STACKED;
5900 Perl_ck_spair(pTHX_ OP *o)
5903 if (o->op_flags & OPf_KIDS) {
5906 const OPCODE type = o->op_type;
5907 o = modkids(ck_fun(o), type);
5908 kid = cUNOPo->op_first;
5909 newop = kUNOP->op_first->op_sibling;
5911 const OPCODE type = newop->op_type;
5912 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
5913 type == OP_PADAV || type == OP_PADHV ||
5914 type == OP_RV2AV || type == OP_RV2HV)
5918 op_getmad(kUNOP->op_first,newop,'K');
5920 op_free(kUNOP->op_first);
5922 kUNOP->op_first = newop;
5924 o->op_ppaddr = PL_ppaddr[++o->op_type];
5929 Perl_ck_delete(pTHX_ OP *o)
5933 if (o->op_flags & OPf_KIDS) {
5934 OP * const kid = cUNOPo->op_first;
5935 switch (kid->op_type) {
5937 o->op_flags |= OPf_SPECIAL;
5940 o->op_private |= OPpSLICE;
5943 o->op_flags |= OPf_SPECIAL;
5948 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5957 Perl_ck_die(pTHX_ OP *o)
5960 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5966 Perl_ck_eof(pTHX_ OP *o)
5970 if (o->op_flags & OPf_KIDS) {
5971 if (cLISTOPo->op_first->op_type == OP_STUB) {
5973 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
5975 op_getmad(o,newop,'O');
5987 Perl_ck_eval(pTHX_ OP *o)
5990 PL_hints |= HINT_BLOCK_SCOPE;
5991 if (o->op_flags & OPf_KIDS) {
5992 SVOP * const kid = (SVOP*)cUNOPo->op_first;
5995 o->op_flags &= ~OPf_KIDS;
5998 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
6004 cUNOPo->op_first = 0;
6009 NewOp(1101, enter, 1, LOGOP);
6010 enter->op_type = OP_ENTERTRY;
6011 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
6012 enter->op_private = 0;
6014 /* establish postfix order */
6015 enter->op_next = (OP*)enter;
6017 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
6018 o->op_type = OP_LEAVETRY;
6019 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
6020 enter->op_other = o;
6021 op_getmad(oldo,o,'O');
6035 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
6036 op_getmad(oldo,o,'O');
6038 o->op_targ = (PADOFFSET)PL_hints;
6039 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
6040 /* Store a copy of %^H that pp_entereval can pick up */
6041 OP *hhop = newSVOP(OP_CONST, 0,
6042 (SV*)Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv)));
6043 cUNOPo->op_first->op_sibling = hhop;
6044 o->op_private |= OPpEVAL_HAS_HH;
6050 Perl_ck_exit(pTHX_ OP *o)
6053 HV * const table = GvHV(PL_hintgv);
6055 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
6056 if (svp && *svp && SvTRUE(*svp))
6057 o->op_private |= OPpEXIT_VMSISH;
6059 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6065 Perl_ck_exec(pTHX_ OP *o)
6067 if (o->op_flags & OPf_STACKED) {
6070 kid = cUNOPo->op_first->op_sibling;
6071 if (kid->op_type == OP_RV2GV)
6080 Perl_ck_exists(pTHX_ OP *o)
6084 if (o->op_flags & OPf_KIDS) {
6085 OP * const kid = cUNOPo->op_first;
6086 if (kid->op_type == OP_ENTERSUB) {
6087 (void) ref(kid, o->op_type);
6088 if (kid->op_type != OP_RV2CV && !PL_error_count)
6089 Perl_croak(aTHX_ "%s argument is not a subroutine name",
6091 o->op_private |= OPpEXISTS_SUB;
6093 else if (kid->op_type == OP_AELEM)
6094 o->op_flags |= OPf_SPECIAL;
6095 else if (kid->op_type != OP_HELEM)
6096 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
6104 Perl_ck_rvconst(pTHX_ register OP *o)
6107 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6109 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6110 if (o->op_type == OP_RV2CV)
6111 o->op_private &= ~1;
6113 if (kid->op_type == OP_CONST) {
6116 SV * const kidsv = kid->op_sv;
6118 /* Is it a constant from cv_const_sv()? */
6119 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
6120 SV * const rsv = SvRV(kidsv);
6121 const svtype type = SvTYPE(rsv);
6122 const char *badtype = NULL;
6124 switch (o->op_type) {
6126 if (type > SVt_PVMG)
6127 badtype = "a SCALAR";
6130 if (type != SVt_PVAV)
6131 badtype = "an ARRAY";
6134 if (type != SVt_PVHV)
6138 if (type != SVt_PVCV)
6143 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
6146 else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
6147 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
6148 /* If this is an access to a stash, disable "strict refs", because
6149 * stashes aren't auto-vivified at compile-time (unless we store
6150 * symbols in them), and we don't want to produce a run-time
6151 * stricture error when auto-vivifying the stash. */
6152 const char *s = SvPV_nolen(kidsv);
6153 const STRLEN l = SvCUR(kidsv);
6154 if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
6155 o->op_private &= ~HINT_STRICT_REFS;
6157 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
6158 const char *badthing;
6159 switch (o->op_type) {
6161 badthing = "a SCALAR";
6164 badthing = "an ARRAY";
6167 badthing = "a HASH";
6175 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
6176 (void*)kidsv, badthing);
6179 * This is a little tricky. We only want to add the symbol if we
6180 * didn't add it in the lexer. Otherwise we get duplicate strict
6181 * warnings. But if we didn't add it in the lexer, we must at
6182 * least pretend like we wanted to add it even if it existed before,
6183 * or we get possible typo warnings. OPpCONST_ENTERED says
6184 * whether the lexer already added THIS instance of this symbol.
6186 iscv = (o->op_type == OP_RV2CV) * 2;
6188 gv = gv_fetchsv(kidsv,
6189 iscv | !(kid->op_private & OPpCONST_ENTERED),
6192 : o->op_type == OP_RV2SV
6194 : o->op_type == OP_RV2AV
6196 : o->op_type == OP_RV2HV
6199 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
6201 kid->op_type = OP_GV;
6202 SvREFCNT_dec(kid->op_sv);
6204 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
6205 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
6206 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
6208 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc_simple_NN(gv));
6210 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
6212 kid->op_private = 0;
6213 kid->op_ppaddr = PL_ppaddr[OP_GV];
6220 Perl_ck_ftst(pTHX_ OP *o)
6223 const I32 type = o->op_type;
6225 if (o->op_flags & OPf_REF) {
6228 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
6229 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6230 const OPCODE kidtype = kid->op_type;
6232 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6233 OP * const newop = newGVOP(type, OPf_REF,
6234 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
6236 op_getmad(o,newop,'O');
6242 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o))
6243 o->op_private |= OPpFT_ACCESS;
6244 if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst)
6245 && kidtype != OP_STAT && kidtype != OP_LSTAT)
6246 o->op_private |= OPpFT_STACKED;
6254 if (type == OP_FTTTY)
6255 o = newGVOP(type, OPf_REF, PL_stdingv);
6257 o = newUNOP(type, 0, newDEFSVOP());
6258 op_getmad(oldo,o,'O');
6264 Perl_ck_fun(pTHX_ OP *o)
6267 const int type = o->op_type;
6268 register I32 oa = PL_opargs[type] >> OASHIFT;
6270 if (o->op_flags & OPf_STACKED) {
6271 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
6274 return no_fh_allowed(o);
6277 if (o->op_flags & OPf_KIDS) {
6278 OP **tokid = &cLISTOPo->op_first;
6279 register OP *kid = cLISTOPo->op_first;
6283 if (kid->op_type == OP_PUSHMARK ||
6284 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
6286 tokid = &kid->op_sibling;
6287 kid = kid->op_sibling;
6289 if (!kid && PL_opargs[type] & OA_DEFGV)
6290 *tokid = kid = newDEFSVOP();
6294 sibl = kid->op_sibling;
6296 if (!sibl && kid->op_type == OP_STUB) {
6303 /* list seen where single (scalar) arg expected? */
6304 if (numargs == 1 && !(oa >> 4)
6305 && kid->op_type == OP_LIST && type != OP_SCALAR)
6307 return too_many_arguments(o,PL_op_desc[type]);
6320 if ((type == OP_PUSH || type == OP_UNSHIFT)
6321 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
6322 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6323 "Useless use of %s with no values",
6326 if (kid->op_type == OP_CONST &&
6327 (kid->op_private & OPpCONST_BARE))
6329 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
6330 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
6331 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6332 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6333 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
6334 (void*)((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
6336 op_getmad(kid,newop,'K');
6341 kid->op_sibling = sibl;
6344 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
6345 bad_type(numargs, "array", PL_op_desc[type], kid);
6349 if (kid->op_type == OP_CONST &&
6350 (kid->op_private & OPpCONST_BARE))
6352 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
6353 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
6354 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6355 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6356 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
6357 (void*)((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
6359 op_getmad(kid,newop,'K');
6364 kid->op_sibling = sibl;
6367 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
6368 bad_type(numargs, "hash", PL_op_desc[type], kid);
6373 OP * const newop = newUNOP(OP_NULL, 0, kid);
6374 kid->op_sibling = 0;
6376 newop->op_next = newop;
6378 kid->op_sibling = sibl;
6383 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
6384 if (kid->op_type == OP_CONST &&
6385 (kid->op_private & OPpCONST_BARE))
6387 OP * const newop = newGVOP(OP_GV, 0,
6388 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
6389 if (!(o->op_private & 1) && /* if not unop */
6390 kid == cLISTOPo->op_last)
6391 cLISTOPo->op_last = newop;
6393 op_getmad(kid,newop,'K');
6399 else if (kid->op_type == OP_READLINE) {
6400 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
6401 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
6404 I32 flags = OPf_SPECIAL;
6408 /* is this op a FH constructor? */
6409 if (is_handle_constructor(o,numargs)) {
6410 const char *name = NULL;
6414 /* Set a flag to tell rv2gv to vivify
6415 * need to "prove" flag does not mean something
6416 * else already - NI-S 1999/05/07
6419 if (kid->op_type == OP_PADSV) {
6420 name = PAD_COMPNAME_PV(kid->op_targ);
6421 /* SvCUR of a pad namesv can't be trusted
6422 * (see PL_generation), so calc its length
6428 else if (kid->op_type == OP_RV2SV
6429 && kUNOP->op_first->op_type == OP_GV)
6431 GV * const gv = cGVOPx_gv(kUNOP->op_first);
6433 len = GvNAMELEN(gv);
6435 else if (kid->op_type == OP_AELEM
6436 || kid->op_type == OP_HELEM)
6439 OP *op = ((BINOP*)kid)->op_first;
6443 const char * const a =
6444 kid->op_type == OP_AELEM ?
6446 if (((op->op_type == OP_RV2AV) ||
6447 (op->op_type == OP_RV2HV)) &&
6448 (firstop = ((UNOP*)op)->op_first) &&
6449 (firstop->op_type == OP_GV)) {
6450 /* packagevar $a[] or $h{} */
6451 GV * const gv = cGVOPx_gv(firstop);
6459 else if (op->op_type == OP_PADAV
6460 || op->op_type == OP_PADHV) {
6461 /* lexicalvar $a[] or $h{} */
6462 const char * const padname =
6463 PAD_COMPNAME_PV(op->op_targ);
6472 name = SvPV_const(tmpstr, len);
6477 name = "__ANONIO__";
6484 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
6485 namesv = PAD_SVl(targ);
6486 SvUPGRADE(namesv, SVt_PV);
6488 sv_setpvn(namesv, "$", 1);
6489 sv_catpvn(namesv, name, len);
6492 kid->op_sibling = 0;
6493 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
6494 kid->op_targ = targ;
6495 kid->op_private |= priv;
6497 kid->op_sibling = sibl;
6503 mod(scalar(kid), type);
6507 tokid = &kid->op_sibling;
6508 kid = kid->op_sibling;
6511 if (kid && kid->op_type != OP_STUB)
6512 return too_many_arguments(o,OP_DESC(o));
6513 o->op_private |= numargs;
6515 /* FIXME - should the numargs move as for the PERL_MAD case? */
6516 o->op_private |= numargs;
6518 return too_many_arguments(o,OP_DESC(o));
6522 else if (PL_opargs[type] & OA_DEFGV) {
6524 OP *newop = newUNOP(type, 0, newDEFSVOP());
6525 op_getmad(o,newop,'O');
6528 /* Ordering of these two is important to keep f_map.t passing. */
6530 return newUNOP(type, 0, newDEFSVOP());
6535 while (oa & OA_OPTIONAL)
6537 if (oa && oa != OA_LIST)
6538 return too_few_arguments(o,OP_DESC(o));
6544 Perl_ck_glob(pTHX_ OP *o)
6550 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
6551 append_elem(OP_GLOB, o, newDEFSVOP());
6553 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
6554 && GvCVu(gv) && GvIMPORTED_CV(gv)))
6556 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6559 #if !defined(PERL_EXTERNAL_GLOB)
6560 /* XXX this can be tightened up and made more failsafe. */
6561 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
6564 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
6565 newSVpvs("File::Glob"), NULL, NULL, NULL);
6566 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6567 glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
6568 GvCV(gv) = GvCV(glob_gv);
6569 SvREFCNT_inc_void((SV*)GvCV(gv));
6570 GvIMPORTED_CV_on(gv);
6573 #endif /* PERL_EXTERNAL_GLOB */
6575 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6576 append_elem(OP_GLOB, o,
6577 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
6578 o->op_type = OP_LIST;
6579 o->op_ppaddr = PL_ppaddr[OP_LIST];
6580 cLISTOPo->op_first->op_type = OP_PUSHMARK;
6581 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
6582 cLISTOPo->op_first->op_targ = 0;
6583 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
6584 append_elem(OP_LIST, o,
6585 scalar(newUNOP(OP_RV2CV, 0,
6586 newGVOP(OP_GV, 0, gv)))));
6587 o = newUNOP(OP_NULL, 0, ck_subr(o));
6588 o->op_targ = OP_GLOB; /* hint at what it used to be */
6591 gv = newGVgen("main");
6593 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
6599 Perl_ck_grep(pTHX_ OP *o)
6604 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
6607 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
6608 /* don't allocate gwop here, as we may leak it if PL_error_count > 0 */
6610 if (o->op_flags & OPf_STACKED) {
6613 kid = cLISTOPo->op_first->op_sibling;
6614 if (!cUNOPx(kid)->op_next)
6615 Perl_croak(aTHX_ "panic: ck_grep");
6616 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
6619 NewOp(1101, gwop, 1, LOGOP);
6620 kid->op_next = (OP*)gwop;
6621 o->op_flags &= ~OPf_STACKED;
6623 kid = cLISTOPo->op_first->op_sibling;
6624 if (type == OP_MAPWHILE)
6631 kid = cLISTOPo->op_first->op_sibling;
6632 if (kid->op_type != OP_NULL)
6633 Perl_croak(aTHX_ "panic: ck_grep");
6634 kid = kUNOP->op_first;
6637 NewOp(1101, gwop, 1, LOGOP);
6638 gwop->op_type = type;
6639 gwop->op_ppaddr = PL_ppaddr[type];
6640 gwop->op_first = listkids(o);
6641 gwop->op_flags |= OPf_KIDS;
6642 gwop->op_other = LINKLIST(kid);
6643 kid->op_next = (OP*)gwop;
6644 offset = pad_findmy("$_");
6645 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
6646 o->op_private = gwop->op_private = 0;
6647 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
6650 o->op_private = gwop->op_private = OPpGREP_LEX;
6651 gwop->op_targ = o->op_targ = offset;
6654 kid = cLISTOPo->op_first->op_sibling;
6655 if (!kid || !kid->op_sibling)
6656 return too_few_arguments(o,OP_DESC(o));
6657 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
6658 mod(kid, OP_GREPSTART);
6664 Perl_ck_index(pTHX_ OP *o)
6666 if (o->op_flags & OPf_KIDS) {
6667 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6669 kid = kid->op_sibling; /* get past "big" */
6670 if (kid && kid->op_type == OP_CONST)
6671 fbm_compile(((SVOP*)kid)->op_sv, 0);
6677 Perl_ck_lengthconst(pTHX_ OP *o)
6679 /* XXX length optimization goes here */
6684 Perl_ck_lfun(pTHX_ OP *o)
6686 const OPCODE type = o->op_type;
6687 return modkids(ck_fun(o), type);
6691 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
6693 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
6694 switch (cUNOPo->op_first->op_type) {
6696 /* This is needed for
6697 if (defined %stash::)
6698 to work. Do not break Tk.
6700 break; /* Globals via GV can be undef */
6702 case OP_AASSIGN: /* Is this a good idea? */
6703 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6704 "defined(@array) is deprecated");
6705 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6706 "\t(Maybe you should just omit the defined()?)\n");
6709 /* This is needed for
6710 if (defined %stash::)
6711 to work. Do not break Tk.
6713 break; /* Globals via GV can be undef */
6715 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6716 "defined(%%hash) is deprecated");
6717 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6718 "\t(Maybe you should just omit the defined()?)\n");
6729 Perl_ck_rfun(pTHX_ OP *o)
6731 const OPCODE type = o->op_type;
6732 return refkids(ck_fun(o), type);
6736 Perl_ck_listiob(pTHX_ OP *o)
6740 kid = cLISTOPo->op_first;
6743 kid = cLISTOPo->op_first;
6745 if (kid->op_type == OP_PUSHMARK)
6746 kid = kid->op_sibling;
6747 if (kid && o->op_flags & OPf_STACKED)
6748 kid = kid->op_sibling;
6749 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6750 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6751 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6752 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6753 cLISTOPo->op_first->op_sibling = kid;
6754 cLISTOPo->op_last = kid;
6755 kid = kid->op_sibling;
6760 append_elem(o->op_type, o, newDEFSVOP());
6766 Perl_ck_smartmatch(pTHX_ OP *o)
6769 if (0 == (o->op_flags & OPf_SPECIAL)) {
6770 OP *first = cBINOPo->op_first;
6771 OP *second = first->op_sibling;
6773 /* Implicitly take a reference to an array or hash */
6774 first->op_sibling = NULL;
6775 first = cBINOPo->op_first = ref_array_or_hash(first);
6776 second = first->op_sibling = ref_array_or_hash(second);
6778 /* Implicitly take a reference to a regular expression */
6779 if (first->op_type == OP_MATCH) {
6780 first->op_type = OP_QR;
6781 first->op_ppaddr = PL_ppaddr[OP_QR];
6783 if (second->op_type == OP_MATCH) {
6784 second->op_type = OP_QR;
6785 second->op_ppaddr = PL_ppaddr[OP_QR];
6794 Perl_ck_sassign(pTHX_ OP *o)
6796 OP * const kid = cLISTOPo->op_first;
6797 /* has a disposable target? */
6798 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6799 && !(kid->op_flags & OPf_STACKED)
6800 /* Cannot steal the second time! */
6801 && !(kid->op_private & OPpTARGET_MY))
6803 OP * const kkid = kid->op_sibling;
6805 /* Can just relocate the target. */
6806 if (kkid && kkid->op_type == OP_PADSV
6807 && !(kkid->op_private & OPpLVAL_INTRO))
6809 kid->op_targ = kkid->op_targ;
6811 /* Now we do not need PADSV and SASSIGN. */
6812 kid->op_sibling = o->op_sibling; /* NULL */
6813 cLISTOPo->op_first = NULL;
6815 op_getmad(o,kid,'O');
6816 op_getmad(kkid,kid,'M');
6821 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6825 if (kid->op_sibling) {
6826 OP *kkid = kid->op_sibling;
6827 if (kkid->op_type == OP_PADSV
6828 && (kkid->op_private & OPpLVAL_INTRO)
6829 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
6830 o->op_private |= OPpASSIGN_STATE;
6831 /* hijacking PADSTALE for uninitialized state variables */
6832 SvPADSTALE_on(PAD_SVl(kkid->op_targ));
6839 Perl_ck_match(pTHX_ OP *o)
6842 if (o->op_type != OP_QR && PL_compcv) {
6843 const PADOFFSET offset = pad_findmy("$_");
6844 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
6845 o->op_targ = offset;
6846 o->op_private |= OPpTARGET_MY;
6849 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
6850 o->op_private |= OPpRUNTIME;
6855 Perl_ck_method(pTHX_ OP *o)
6857 OP * const kid = cUNOPo->op_first;
6858 if (kid->op_type == OP_CONST) {
6859 SV* sv = kSVOP->op_sv;
6860 const char * const method = SvPVX_const(sv);
6861 if (!(strchr(method, ':') || strchr(method, '\''))) {
6863 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6864 sv = newSVpvn_share(method, SvCUR(sv), 0);
6867 kSVOP->op_sv = NULL;
6869 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6871 op_getmad(o,cmop,'O');
6882 Perl_ck_null(pTHX_ OP *o)
6884 PERL_UNUSED_CONTEXT;
6889 Perl_ck_open(pTHX_ OP *o)
6892 HV * const table = GvHV(PL_hintgv);
6894 SV **svp = hv_fetchs(table, "open_IN", FALSE);
6896 const I32 mode = mode_from_discipline(*svp);
6897 if (mode & O_BINARY)
6898 o->op_private |= OPpOPEN_IN_RAW;
6899 else if (mode & O_TEXT)
6900 o->op_private |= OPpOPEN_IN_CRLF;
6903 svp = hv_fetchs(table, "open_OUT", FALSE);
6905 const I32 mode = mode_from_discipline(*svp);
6906 if (mode & O_BINARY)
6907 o->op_private |= OPpOPEN_OUT_RAW;
6908 else if (mode & O_TEXT)
6909 o->op_private |= OPpOPEN_OUT_CRLF;
6912 if (o->op_type == OP_BACKTICK)
6915 /* In case of three-arg dup open remove strictness
6916 * from the last arg if it is a bareword. */
6917 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
6918 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
6922 if ((last->op_type == OP_CONST) && /* The bareword. */
6923 (last->op_private & OPpCONST_BARE) &&
6924 (last->op_private & OPpCONST_STRICT) &&
6925 (oa = first->op_sibling) && /* The fh. */
6926 (oa = oa->op_sibling) && /* The mode. */
6927 (oa->op_type == OP_CONST) &&
6928 SvPOK(((SVOP*)oa)->op_sv) &&
6929 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
6930 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
6931 (last == oa->op_sibling)) /* The bareword. */
6932 last->op_private &= ~OPpCONST_STRICT;
6938 Perl_ck_repeat(pTHX_ OP *o)
6940 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6941 o->op_private |= OPpREPEAT_DOLIST;
6942 cBINOPo->op_first = force_list(cBINOPo->op_first);
6950 Perl_ck_require(pTHX_ OP *o)
6955 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6956 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6958 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6959 SV * const sv = kid->op_sv;
6960 U32 was_readonly = SvREADONLY(sv);
6965 sv_force_normal_flags(sv, 0);
6966 assert(!SvREADONLY(sv));
6973 for (s = SvPVX(sv); *s; s++) {
6974 if (*s == ':' && s[1] == ':') {
6975 const STRLEN len = strlen(s+2)+1;
6977 Move(s+2, s+1, len, char);
6978 SvCUR_set(sv, SvCUR(sv) - 1);
6981 sv_catpvs(sv, ".pm");
6982 SvFLAGS(sv) |= was_readonly;
6986 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
6987 /* handle override, if any */
6988 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
6989 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
6990 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
6991 gv = gvp ? *gvp : NULL;
6995 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6996 OP * const kid = cUNOPo->op_first;
6999 cUNOPo->op_first = 0;
7003 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
7004 append_elem(OP_LIST, kid,
7005 scalar(newUNOP(OP_RV2CV, 0,
7008 op_getmad(o,newop,'O');
7016 Perl_ck_return(pTHX_ OP *o)
7019 if (CvLVALUE(PL_compcv)) {
7021 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
7022 mod(kid, OP_LEAVESUBLV);
7028 Perl_ck_select(pTHX_ OP *o)
7032 if (o->op_flags & OPf_KIDS) {
7033 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7034 if (kid && kid->op_sibling) {
7035 o->op_type = OP_SSELECT;
7036 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
7038 return fold_constants(o);
7042 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7043 if (kid && kid->op_type == OP_RV2GV)
7044 kid->op_private &= ~HINT_STRICT_REFS;
7049 Perl_ck_shift(pTHX_ OP *o)
7052 const I32 type = o->op_type;
7054 if (!(o->op_flags & OPf_KIDS)) {
7056 /* FIXME - this can be refactored to reduce code in #ifdefs */
7058 OP * const oldo = o;
7062 argop = newUNOP(OP_RV2AV, 0,
7063 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
7065 o = newUNOP(type, 0, scalar(argop));
7066 op_getmad(oldo,o,'O');
7069 return newUNOP(type, 0, scalar(argop));
7072 return scalar(modkids(ck_fun(o), type));
7076 Perl_ck_sort(pTHX_ OP *o)
7081 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
7082 HV * const hinthv = GvHV(PL_hintgv);
7084 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
7086 const I32 sorthints = (I32)SvIV(*svp);
7087 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
7088 o->op_private |= OPpSORT_QSORT;
7089 if ((sorthints & HINT_SORT_STABLE) != 0)
7090 o->op_private |= OPpSORT_STABLE;
7095 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
7097 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7098 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
7100 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
7102 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
7104 if (kid->op_type == OP_SCOPE) {
7108 else if (kid->op_type == OP_LEAVE) {
7109 if (o->op_type == OP_SORT) {
7110 op_null(kid); /* wipe out leave */
7113 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
7114 if (k->op_next == kid)
7116 /* don't descend into loops */
7117 else if (k->op_type == OP_ENTERLOOP
7118 || k->op_type == OP_ENTERITER)
7120 k = cLOOPx(k)->op_lastop;
7125 kid->op_next = 0; /* just disconnect the leave */
7126 k = kLISTOP->op_first;
7131 if (o->op_type == OP_SORT) {
7132 /* provide scalar context for comparison function/block */
7138 o->op_flags |= OPf_SPECIAL;
7140 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
7143 firstkid = firstkid->op_sibling;
7146 /* provide list context for arguments */
7147 if (o->op_type == OP_SORT)
7154 S_simplify_sort(pTHX_ OP *o)
7157 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7162 if (!(o->op_flags & OPf_STACKED))
7164 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7165 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
7166 kid = kUNOP->op_first; /* get past null */
7167 if (kid->op_type != OP_SCOPE)
7169 kid = kLISTOP->op_last; /* get past scope */
7170 switch(kid->op_type) {
7178 k = kid; /* remember this node*/
7179 if (kBINOP->op_first->op_type != OP_RV2SV)
7181 kid = kBINOP->op_first; /* get past cmp */
7182 if (kUNOP->op_first->op_type != OP_GV)
7184 kid = kUNOP->op_first; /* get past rv2sv */
7186 if (GvSTASH(gv) != PL_curstash)
7188 gvname = GvNAME(gv);
7189 if (*gvname == 'a' && gvname[1] == '\0')
7191 else if (*gvname == 'b' && gvname[1] == '\0')
7196 kid = k; /* back to cmp */
7197 if (kBINOP->op_last->op_type != OP_RV2SV)
7199 kid = kBINOP->op_last; /* down to 2nd arg */
7200 if (kUNOP->op_first->op_type != OP_GV)
7202 kid = kUNOP->op_first; /* get past rv2sv */
7204 if (GvSTASH(gv) != PL_curstash)
7206 gvname = GvNAME(gv);
7208 ? !(*gvname == 'a' && gvname[1] == '\0')
7209 : !(*gvname == 'b' && gvname[1] == '\0'))
7211 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
7213 o->op_private |= OPpSORT_DESCEND;
7214 if (k->op_type == OP_NCMP)
7215 o->op_private |= OPpSORT_NUMERIC;
7216 if (k->op_type == OP_I_NCMP)
7217 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
7218 kid = cLISTOPo->op_first->op_sibling;
7219 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
7221 op_getmad(kid,o,'S'); /* then delete it */
7223 op_free(kid); /* then delete it */
7228 Perl_ck_split(pTHX_ OP *o)
7233 if (o->op_flags & OPf_STACKED)
7234 return no_fh_allowed(o);
7236 kid = cLISTOPo->op_first;
7237 if (kid->op_type != OP_NULL)
7238 Perl_croak(aTHX_ "panic: ck_split");
7239 kid = kid->op_sibling;
7240 op_free(cLISTOPo->op_first);
7241 cLISTOPo->op_first = kid;
7243 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
7244 cLISTOPo->op_last = kid; /* There was only one element previously */
7247 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
7248 OP * const sibl = kid->op_sibling;
7249 kid->op_sibling = 0;
7250 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
7251 if (cLISTOPo->op_first == cLISTOPo->op_last)
7252 cLISTOPo->op_last = kid;
7253 cLISTOPo->op_first = kid;
7254 kid->op_sibling = sibl;
7257 kid->op_type = OP_PUSHRE;
7258 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
7260 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
7261 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
7262 "Use of /g modifier is meaningless in split");
7265 if (!kid->op_sibling)
7266 append_elem(OP_SPLIT, o, newDEFSVOP());
7268 kid = kid->op_sibling;
7271 if (!kid->op_sibling)
7272 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
7273 assert(kid->op_sibling);
7275 kid = kid->op_sibling;
7278 if (kid->op_sibling)
7279 return too_many_arguments(o,OP_DESC(o));
7285 Perl_ck_join(pTHX_ OP *o)
7287 const OP * const kid = cLISTOPo->op_first->op_sibling;
7288 if (kid && kid->op_type == OP_MATCH) {
7289 if (ckWARN(WARN_SYNTAX)) {
7290 const REGEXP *re = PM_GETRE(kPMOP);
7291 const char *pmstr = re ? re->precomp : "STRING";
7292 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7293 "/%s/ should probably be written as \"%s\"",
7301 Perl_ck_subr(pTHX_ OP *o)
7304 OP *prev = ((cUNOPo->op_first->op_sibling)
7305 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
7306 OP *o2 = prev->op_sibling;
7308 const char *proto = NULL;
7309 const char *proto_end = NULL;
7314 I32 contextclass = 0;
7315 const char *e = NULL;
7318 o->op_private |= OPpENTERSUB_HASTARG;
7319 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
7320 if (cvop->op_type == OP_RV2CV) {
7322 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
7323 op_null(cvop); /* disable rv2cv */
7324 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
7325 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
7326 GV *gv = cGVOPx_gv(tmpop);
7329 tmpop->op_private |= OPpEARLY_CV;
7333 namegv = CvANON(cv) ? gv : CvGV(cv);
7334 proto = SvPV((SV*)cv, len);
7335 proto_end = proto + len;
7337 if (CvASSERTION(cv)) {
7338 U32 asserthints = 0;
7339 HV *const hinthv = GvHV(PL_hintgv);
7341 SV **svp = hv_fetchs(hinthv, "assertions", FALSE);
7343 asserthints = SvUV(*svp);
7345 if (asserthints & HINT_ASSERTING) {
7346 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
7347 o->op_private |= OPpENTERSUB_DB;
7351 if (!(asserthints & HINT_ASSERTIONSSEEN) && ckWARN(WARN_ASSERTIONS)) {
7352 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
7353 "Impossible to activate assertion call");
7360 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7361 if (o2->op_type == OP_CONST)
7362 o2->op_private &= ~OPpCONST_STRICT;
7363 else if (o2->op_type == OP_LIST) {
7364 OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
7365 if (sib && sib->op_type == OP_CONST)
7366 sib->op_private &= ~OPpCONST_STRICT;
7369 o->op_private |= (PL_hints & HINT_STRICT_REFS);
7370 if (PERLDB_SUB && PL_curstash != PL_debstash)
7371 o->op_private |= OPpENTERSUB_DB;
7372 while (o2 != cvop) {
7374 if (PL_madskills && o2->op_type == OP_NULL)
7375 o3 = ((UNOP*)o2)->op_first;
7379 if (proto >= proto_end)
7380 return too_many_arguments(o, gv_ename(namegv));
7388 /* _ must be at the end */
7389 if (proto[1] && proto[1] != ';')
7404 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
7406 arg == 1 ? "block or sub {}" : "sub {}",
7407 gv_ename(namegv), o3);
7410 /* '*' allows any scalar type, including bareword */
7413 if (o3->op_type == OP_RV2GV)
7414 goto wrapref; /* autoconvert GLOB -> GLOBref */
7415 else if (o3->op_type == OP_CONST)
7416 o3->op_private &= ~OPpCONST_STRICT;
7417 else if (o3->op_type == OP_ENTERSUB) {
7418 /* accidental subroutine, revert to bareword */
7419 OP *gvop = ((UNOP*)o3)->op_first;
7420 if (gvop && gvop->op_type == OP_NULL) {
7421 gvop = ((UNOP*)gvop)->op_first;
7423 for (; gvop->op_sibling; gvop = gvop->op_sibling)
7426 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
7427 (gvop = ((UNOP*)gvop)->op_first) &&
7428 gvop->op_type == OP_GV)
7430 GV * const gv = cGVOPx_gv(gvop);
7431 OP * const sibling = o2->op_sibling;
7432 SV * const n = newSVpvs("");
7434 OP * const oldo2 = o2;
7438 gv_fullname4(n, gv, "", FALSE);
7439 o2 = newSVOP(OP_CONST, 0, n);
7440 op_getmad(oldo2,o2,'O');
7441 prev->op_sibling = o2;
7442 o2->op_sibling = sibling;
7458 if (contextclass++ == 0) {
7459 e = strchr(proto, ']');
7460 if (!e || e == proto)
7469 const char *p = proto;
7470 const char *const end = proto;
7472 while (*--p != '[');
7473 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
7475 gv_ename(namegv), o3);
7480 if (o3->op_type == OP_RV2GV)
7483 bad_type(arg, "symbol", gv_ename(namegv), o3);
7486 if (o3->op_type == OP_ENTERSUB)
7489 bad_type(arg, "subroutine entry", gv_ename(namegv),
7493 if (o3->op_type == OP_RV2SV ||
7494 o3->op_type == OP_PADSV ||
7495 o3->op_type == OP_HELEM ||
7496 o3->op_type == OP_AELEM ||
7497 o3->op_type == OP_THREADSV)
7500 bad_type(arg, "scalar", gv_ename(namegv), o3);
7503 if (o3->op_type == OP_RV2AV ||
7504 o3->op_type == OP_PADAV)
7507 bad_type(arg, "array", gv_ename(namegv), o3);
7510 if (o3->op_type == OP_RV2HV ||
7511 o3->op_type == OP_PADHV)
7514 bad_type(arg, "hash", gv_ename(namegv), o3);
7519 OP* const sib = kid->op_sibling;
7520 kid->op_sibling = 0;
7521 o2 = newUNOP(OP_REFGEN, 0, kid);
7522 o2->op_sibling = sib;
7523 prev->op_sibling = o2;
7525 if (contextclass && e) {
7540 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
7541 gv_ename(namegv), (void*)cv);
7546 mod(o2, OP_ENTERSUB);
7548 o2 = o2->op_sibling;
7550 if (o2 == cvop && proto && *proto == '_') {
7551 /* generate an access to $_ */
7553 o2->op_sibling = prev->op_sibling;
7554 prev->op_sibling = o2; /* instead of cvop */
7556 if (proto && !optional && proto_end > proto &&
7557 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
7558 return too_few_arguments(o, gv_ename(namegv));
7561 OP * const oldo = o;
7565 o=newSVOP(OP_CONST, 0, newSViv(0));
7566 op_getmad(oldo,o,'O');
7572 Perl_ck_svconst(pTHX_ OP *o)
7574 PERL_UNUSED_CONTEXT;
7575 SvREADONLY_on(cSVOPo->op_sv);
7580 Perl_ck_chdir(pTHX_ OP *o)
7582 if (o->op_flags & OPf_KIDS) {
7583 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7585 if (kid && kid->op_type == OP_CONST &&
7586 (kid->op_private & OPpCONST_BARE))
7588 o->op_flags |= OPf_SPECIAL;
7589 kid->op_private &= ~OPpCONST_STRICT;
7596 Perl_ck_trunc(pTHX_ OP *o)
7598 if (o->op_flags & OPf_KIDS) {
7599 SVOP *kid = (SVOP*)cUNOPo->op_first;
7601 if (kid->op_type == OP_NULL)
7602 kid = (SVOP*)kid->op_sibling;
7603 if (kid && kid->op_type == OP_CONST &&
7604 (kid->op_private & OPpCONST_BARE))
7606 o->op_flags |= OPf_SPECIAL;
7607 kid->op_private &= ~OPpCONST_STRICT;
7614 Perl_ck_unpack(pTHX_ OP *o)
7616 OP *kid = cLISTOPo->op_first;
7617 if (kid->op_sibling) {
7618 kid = kid->op_sibling;
7619 if (!kid->op_sibling)
7620 kid->op_sibling = newDEFSVOP();
7626 Perl_ck_substr(pTHX_ OP *o)
7629 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
7630 OP *kid = cLISTOPo->op_first;
7632 if (kid->op_type == OP_NULL)
7633 kid = kid->op_sibling;
7635 kid->op_flags |= OPf_MOD;
7641 /* A peephole optimizer. We visit the ops in the order they're to execute.
7642 * See the comments at the top of this file for more details about when
7643 * peep() is called */
7646 Perl_peep(pTHX_ register OP *o)
7649 register OP* oldop = NULL;
7651 if (!o || o->op_opt)
7655 SAVEVPTR(PL_curcop);
7656 for (; o; o = o->op_next) {
7660 switch (o->op_type) {
7664 PL_curcop = ((COP*)o); /* for warnings */
7669 if (cSVOPo->op_private & OPpCONST_STRICT)
7670 no_bareword_allowed(o);
7672 case OP_METHOD_NAMED:
7673 /* Relocate sv to the pad for thread safety.
7674 * Despite being a "constant", the SV is written to,
7675 * for reference counts, sv_upgrade() etc. */
7677 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
7678 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
7679 /* If op_sv is already a PADTMP then it is being used by
7680 * some pad, so make a copy. */
7681 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
7682 SvREADONLY_on(PAD_SVl(ix));
7683 SvREFCNT_dec(cSVOPo->op_sv);
7685 else if (o->op_type == OP_CONST
7686 && cSVOPo->op_sv == &PL_sv_undef) {
7687 /* PL_sv_undef is hack - it's unsafe to store it in the
7688 AV that is the pad, because av_fetch treats values of
7689 PL_sv_undef as a "free" AV entry and will merrily
7690 replace them with a new SV, causing pad_alloc to think
7691 that this pad slot is free. (When, clearly, it is not)
7693 SvOK_off(PAD_SVl(ix));
7694 SvPADTMP_on(PAD_SVl(ix));
7695 SvREADONLY_on(PAD_SVl(ix));
7698 SvREFCNT_dec(PAD_SVl(ix));
7699 SvPADTMP_on(cSVOPo->op_sv);
7700 PAD_SETSV(ix, cSVOPo->op_sv);
7701 /* XXX I don't know how this isn't readonly already. */
7702 SvREADONLY_on(PAD_SVl(ix));
7704 cSVOPo->op_sv = NULL;
7712 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
7713 if (o->op_next->op_private & OPpTARGET_MY) {
7714 if (o->op_flags & OPf_STACKED) /* chained concats */
7715 goto ignore_optimization;
7717 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
7718 o->op_targ = o->op_next->op_targ;
7719 o->op_next->op_targ = 0;
7720 o->op_private |= OPpTARGET_MY;
7723 op_null(o->op_next);
7725 ignore_optimization:
7729 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
7731 break; /* Scalar stub must produce undef. List stub is noop */
7735 if (o->op_targ == OP_NEXTSTATE
7736 || o->op_targ == OP_DBSTATE
7737 || o->op_targ == OP_SETSTATE)
7739 PL_curcop = ((COP*)o);
7741 /* XXX: We avoid setting op_seq here to prevent later calls
7742 to peep() from mistakenly concluding that optimisation
7743 has already occurred. This doesn't fix the real problem,
7744 though (See 20010220.007). AMS 20010719 */
7745 /* op_seq functionality is now replaced by op_opt */
7746 if (oldop && o->op_next) {
7747 oldop->op_next = o->op_next;
7755 if (oldop && o->op_next) {
7756 oldop->op_next = o->op_next;
7764 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
7765 OP* const pop = (o->op_type == OP_PADAV) ?
7766 o->op_next : o->op_next->op_next;
7768 if (pop && pop->op_type == OP_CONST &&
7769 ((PL_op = pop->op_next)) &&
7770 pop->op_next->op_type == OP_AELEM &&
7771 !(pop->op_next->op_private &
7772 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
7773 (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
7778 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
7779 no_bareword_allowed(pop);
7780 if (o->op_type == OP_GV)
7781 op_null(o->op_next);
7782 op_null(pop->op_next);
7784 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
7785 o->op_next = pop->op_next->op_next;
7786 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
7787 o->op_private = (U8)i;
7788 if (o->op_type == OP_GV) {
7793 o->op_flags |= OPf_SPECIAL;
7794 o->op_type = OP_AELEMFAST;
7800 if (o->op_next->op_type == OP_RV2SV) {
7801 if (!(o->op_next->op_private & OPpDEREF)) {
7802 op_null(o->op_next);
7803 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
7805 o->op_next = o->op_next->op_next;
7806 o->op_type = OP_GVSV;
7807 o->op_ppaddr = PL_ppaddr[OP_GVSV];
7810 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
7811 GV * const gv = cGVOPo_gv;
7812 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
7813 /* XXX could check prototype here instead of just carping */
7814 SV * const sv = sv_newmortal();
7815 gv_efullname3(sv, gv, NULL);
7816 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
7817 "%"SVf"() called too early to check prototype",
7821 else if (o->op_next->op_type == OP_READLINE
7822 && o->op_next->op_next->op_type == OP_CONCAT
7823 && (o->op_next->op_next->op_flags & OPf_STACKED))
7825 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
7826 o->op_type = OP_RCATLINE;
7827 o->op_flags |= OPf_STACKED;
7828 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
7829 op_null(o->op_next->op_next);
7830 op_null(o->op_next);
7847 while (cLOGOP->op_other->op_type == OP_NULL)
7848 cLOGOP->op_other = cLOGOP->op_other->op_next;
7849 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
7855 while (cLOOP->op_redoop->op_type == OP_NULL)
7856 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
7857 peep(cLOOP->op_redoop);
7858 while (cLOOP->op_nextop->op_type == OP_NULL)
7859 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
7860 peep(cLOOP->op_nextop);
7861 while (cLOOP->op_lastop->op_type == OP_NULL)
7862 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
7863 peep(cLOOP->op_lastop);
7870 while (cPMOP->op_pmreplstart &&
7871 cPMOP->op_pmreplstart->op_type == OP_NULL)
7872 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
7873 peep(cPMOP->op_pmreplstart);
7878 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
7879 && ckWARN(WARN_SYNTAX))
7881 if (o->op_next->op_sibling) {
7882 const OPCODE type = o->op_next->op_sibling->op_type;
7883 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
7884 const line_t oldline = CopLINE(PL_curcop);
7885 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
7886 Perl_warner(aTHX_ packWARN(WARN_EXEC),
7887 "Statement unlikely to be reached");
7888 Perl_warner(aTHX_ packWARN(WARN_EXEC),
7889 "\t(Maybe you meant system() when you said exec()?)\n");
7890 CopLINE_set(PL_curcop, oldline);
7901 const char *key = NULL;
7906 if (((BINOP*)o)->op_last->op_type != OP_CONST)
7909 /* Make the CONST have a shared SV */
7910 svp = cSVOPx_svp(((BINOP*)o)->op_last);
7911 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
7912 key = SvPV_const(sv, keylen);
7913 lexname = newSVpvn_share(key,
7914 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
7920 if ((o->op_private & (OPpLVAL_INTRO)))
7923 rop = (UNOP*)((BINOP*)o)->op_first;
7924 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7926 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7927 if (!SvPAD_TYPED(lexname))
7929 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
7930 if (!fields || !GvHV(*fields))
7932 key = SvPV_const(*svp, keylen);
7933 if (!hv_fetch(GvHV(*fields), key,
7934 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
7936 Perl_croak(aTHX_ "No such class field \"%s\" "
7937 "in variable %s of type %s",
7938 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
7951 SVOP *first_key_op, *key_op;
7953 if ((o->op_private & (OPpLVAL_INTRO))
7954 /* I bet there's always a pushmark... */
7955 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
7956 /* hmmm, no optimization if list contains only one key. */
7958 rop = (UNOP*)((LISTOP*)o)->op_last;
7959 if (rop->op_type != OP_RV2HV)
7961 if (rop->op_first->op_type == OP_PADSV)
7962 /* @$hash{qw(keys here)} */
7963 rop = (UNOP*)rop->op_first;
7965 /* @{$hash}{qw(keys here)} */
7966 if (rop->op_first->op_type == OP_SCOPE
7967 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
7969 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
7975 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
7976 if (!SvPAD_TYPED(lexname))
7978 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
7979 if (!fields || !GvHV(*fields))
7981 /* Again guessing that the pushmark can be jumped over.... */
7982 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
7983 ->op_first->op_sibling;
7984 for (key_op = first_key_op; key_op;
7985 key_op = (SVOP*)key_op->op_sibling) {
7986 if (key_op->op_type != OP_CONST)
7988 svp = cSVOPx_svp(key_op);
7989 key = SvPV_const(*svp, keylen);
7990 if (!hv_fetch(GvHV(*fields), key,
7991 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
7993 Perl_croak(aTHX_ "No such class field \"%s\" "
7994 "in variable %s of type %s",
7995 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
8002 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
8006 /* check that RHS of sort is a single plain array */
8007 OP *oright = cUNOPo->op_first;
8008 if (!oright || oright->op_type != OP_PUSHMARK)
8011 /* reverse sort ... can be optimised. */
8012 if (!cUNOPo->op_sibling) {
8013 /* Nothing follows us on the list. */
8014 OP * const reverse = o->op_next;
8016 if (reverse->op_type == OP_REVERSE &&
8017 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
8018 OP * const pushmark = cUNOPx(reverse)->op_first;
8019 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
8020 && (cUNOPx(pushmark)->op_sibling == o)) {
8021 /* reverse -> pushmark -> sort */
8022 o->op_private |= OPpSORT_REVERSE;
8024 pushmark->op_next = oright->op_next;
8030 /* make @a = sort @a act in-place */
8034 oright = cUNOPx(oright)->op_sibling;
8037 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
8038 oright = cUNOPx(oright)->op_sibling;
8042 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
8043 || oright->op_next != o
8044 || (oright->op_private & OPpLVAL_INTRO)
8048 /* o2 follows the chain of op_nexts through the LHS of the
8049 * assign (if any) to the aassign op itself */
8051 if (!o2 || o2->op_type != OP_NULL)
8054 if (!o2 || o2->op_type != OP_PUSHMARK)
8057 if (o2 && o2->op_type == OP_GV)
8060 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
8061 || (o2->op_private & OPpLVAL_INTRO)
8066 if (!o2 || o2->op_type != OP_NULL)
8069 if (!o2 || o2->op_type != OP_AASSIGN
8070 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
8073 /* check that the sort is the first arg on RHS of assign */
8075 o2 = cUNOPx(o2)->op_first;
8076 if (!o2 || o2->op_type != OP_NULL)
8078 o2 = cUNOPx(o2)->op_first;
8079 if (!o2 || o2->op_type != OP_PUSHMARK)
8081 if (o2->op_sibling != o)
8084 /* check the array is the same on both sides */
8085 if (oleft->op_type == OP_RV2AV) {
8086 if (oright->op_type != OP_RV2AV
8087 || !cUNOPx(oright)->op_first
8088 || cUNOPx(oright)->op_first->op_type != OP_GV
8089 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
8090 cGVOPx_gv(cUNOPx(oright)->op_first)
8094 else if (oright->op_type != OP_PADAV
8095 || oright->op_targ != oleft->op_targ
8099 /* transfer MODishness etc from LHS arg to RHS arg */
8100 oright->op_flags = oleft->op_flags;
8101 o->op_private |= OPpSORT_INPLACE;
8103 /* excise push->gv->rv2av->null->aassign */
8104 o2 = o->op_next->op_next;
8105 op_null(o2); /* PUSHMARK */
8107 if (o2->op_type == OP_GV) {
8108 op_null(o2); /* GV */
8111 op_null(o2); /* RV2AV or PADAV */
8112 o2 = o2->op_next->op_next;
8113 op_null(o2); /* AASSIGN */
8115 o->op_next = o2->op_next;
8121 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
8123 LISTOP *enter, *exlist;
8126 enter = (LISTOP *) o->op_next;
8129 if (enter->op_type == OP_NULL) {
8130 enter = (LISTOP *) enter->op_next;
8134 /* for $a (...) will have OP_GV then OP_RV2GV here.
8135 for (...) just has an OP_GV. */
8136 if (enter->op_type == OP_GV) {
8137 gvop = (OP *) enter;
8138 enter = (LISTOP *) enter->op_next;
8141 if (enter->op_type == OP_RV2GV) {
8142 enter = (LISTOP *) enter->op_next;
8148 if (enter->op_type != OP_ENTERITER)
8151 iter = enter->op_next;
8152 if (!iter || iter->op_type != OP_ITER)
8155 expushmark = enter->op_first;
8156 if (!expushmark || expushmark->op_type != OP_NULL
8157 || expushmark->op_targ != OP_PUSHMARK)
8160 exlist = (LISTOP *) expushmark->op_sibling;
8161 if (!exlist || exlist->op_type != OP_NULL
8162 || exlist->op_targ != OP_LIST)
8165 if (exlist->op_last != o) {
8166 /* Mmm. Was expecting to point back to this op. */
8169 theirmark = exlist->op_first;
8170 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
8173 if (theirmark->op_sibling != o) {
8174 /* There's something between the mark and the reverse, eg
8175 for (1, reverse (...))
8180 ourmark = ((LISTOP *)o)->op_first;
8181 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
8184 ourlast = ((LISTOP *)o)->op_last;
8185 if (!ourlast || ourlast->op_next != o)
8188 rv2av = ourmark->op_sibling;
8189 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
8190 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
8191 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
8192 /* We're just reversing a single array. */
8193 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
8194 enter->op_flags |= OPf_STACKED;
8197 /* We don't have control over who points to theirmark, so sacrifice
8199 theirmark->op_next = ourmark->op_next;
8200 theirmark->op_flags = ourmark->op_flags;
8201 ourlast->op_next = gvop ? gvop : (OP *) enter;
8204 enter->op_private |= OPpITER_REVERSED;
8205 iter->op_private |= OPpITER_REVERSED;
8212 UNOP *refgen, *rv2cv;
8215 /* I do not understand this, but if o->op_opt isn't set to 1,
8216 various tests in ext/B/t/bytecode.t fail with no readily
8222 if ((o->op_flags && OPf_WANT) != OPf_WANT_VOID)
8225 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
8228 rv2gv = ((BINOP *)o)->op_last;
8229 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
8232 refgen = (UNOP *)((BINOP *)o)->op_first;
8234 if (!refgen || refgen->op_type != OP_REFGEN)
8237 exlist = (LISTOP *)refgen->op_first;
8238 if (!exlist || exlist->op_type != OP_NULL
8239 || exlist->op_targ != OP_LIST)
8242 if (exlist->op_first->op_type != OP_PUSHMARK)
8245 rv2cv = (UNOP*)exlist->op_last;
8247 if (rv2cv->op_type != OP_RV2CV)
8250 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
8251 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
8252 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
8254 o->op_private |= OPpASSIGN_CV_TO_GV;
8255 rv2gv->op_private |= OPpDONT_INIT_GV;
8256 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
8272 Perl_custom_op_name(pTHX_ const OP* o)
8275 const IV index = PTR2IV(o->op_ppaddr);
8279 if (!PL_custom_op_names) /* This probably shouldn't happen */
8280 return (char *)PL_op_name[OP_CUSTOM];
8282 keysv = sv_2mortal(newSViv(index));
8284 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
8286 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
8288 return SvPV_nolen(HeVAL(he));
8292 Perl_custom_op_desc(pTHX_ const OP* o)
8295 const IV index = PTR2IV(o->op_ppaddr);
8299 if (!PL_custom_op_descs)
8300 return (char *)PL_op_desc[OP_CUSTOM];
8302 keysv = sv_2mortal(newSViv(index));
8304 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
8306 return (char *)PL_op_desc[OP_CUSTOM];
8308 return SvPV_nolen(HeVAL(he));
8313 /* Efficient sub that returns a constant scalar value. */
8315 const_sv_xsub(pTHX_ CV* cv)
8322 Perl_croak(aTHX_ "usage: %s::%s()",
8323 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
8327 ST(0) = (SV*)XSANY.any_ptr;
8333 * c-indentation-style: bsd
8335 * indent-tabs-mode: t
8338 * ex: set ts=8 sts=4 sw=4 noet: