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 Safefree(cop->cop_label); /* FIXME: treaddead ??? */
496 if (! specialWARN(cop->cop_warnings))
497 PerlMemShared_free(cop->cop_warnings);
498 Perl_refcounted_he_free(aTHX_ cop->cop_hints_hash);
502 Perl_op_null(pTHX_ OP *o)
505 if (o->op_type == OP_NULL)
509 o->op_targ = o->op_type;
510 o->op_type = OP_NULL;
511 o->op_ppaddr = PL_ppaddr[OP_NULL];
515 Perl_op_refcnt_lock(pTHX)
523 Perl_op_refcnt_unlock(pTHX)
530 /* Contextualizers */
532 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
535 Perl_linklist(pTHX_ OP *o)
542 /* establish postfix order */
543 first = cUNOPo->op_first;
546 o->op_next = LINKLIST(first);
549 if (kid->op_sibling) {
550 kid->op_next = LINKLIST(kid->op_sibling);
551 kid = kid->op_sibling;
565 Perl_scalarkids(pTHX_ OP *o)
567 if (o && o->op_flags & OPf_KIDS) {
569 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
576 S_scalarboolean(pTHX_ OP *o)
579 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
580 if (ckWARN(WARN_SYNTAX)) {
581 const line_t oldline = CopLINE(PL_curcop);
583 if (PL_copline != NOLINE)
584 CopLINE_set(PL_curcop, PL_copline);
585 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
586 CopLINE_set(PL_curcop, oldline);
593 Perl_scalar(pTHX_ OP *o)
598 /* assumes no premature commitment */
599 if (!o || PL_error_count || (o->op_flags & OPf_WANT)
600 || o->op_type == OP_RETURN)
605 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
607 switch (o->op_type) {
609 scalar(cBINOPo->op_first);
614 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
618 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
619 if (!kPMOP->op_pmreplroot)
620 deprecate_old("implicit split to @_");
628 if (o->op_flags & OPf_KIDS) {
629 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
635 kid = cLISTOPo->op_first;
637 while ((kid = kid->op_sibling)) {
643 PL_curcop = &PL_compiling;
648 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
654 PL_curcop = &PL_compiling;
657 if (ckWARN(WARN_VOID))
658 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
664 Perl_scalarvoid(pTHX_ OP *o)
668 const char* useless = NULL;
672 /* trailing mad null ops don't count as "there" for void processing */
674 o->op_type != OP_NULL &&
676 o->op_sibling->op_type == OP_NULL)
679 for (sib = o->op_sibling;
680 sib && sib->op_type == OP_NULL;
681 sib = sib->op_sibling) ;
687 if (o->op_type == OP_NEXTSTATE
688 || o->op_type == OP_SETSTATE
689 || o->op_type == OP_DBSTATE
690 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
691 || o->op_targ == OP_SETSTATE
692 || o->op_targ == OP_DBSTATE)))
693 PL_curcop = (COP*)o; /* for warning below */
695 /* assumes no premature commitment */
696 want = o->op_flags & OPf_WANT;
697 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
698 || o->op_type == OP_RETURN)
703 if ((o->op_private & OPpTARGET_MY)
704 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
706 return scalar(o); /* As if inside SASSIGN */
709 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
711 switch (o->op_type) {
713 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
717 if (o->op_flags & OPf_STACKED)
721 if (o->op_private == 4)
793 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
794 useless = OP_DESC(o);
798 kid = cUNOPo->op_first;
799 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
800 kid->op_type != OP_TRANS) {
803 useless = "negative pattern binding (!~)";
810 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
811 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
812 useless = "a variable";
817 if (cSVOPo->op_private & OPpCONST_STRICT)
818 no_bareword_allowed(o);
820 if (ckWARN(WARN_VOID)) {
821 useless = "a constant";
822 if (o->op_private & OPpCONST_ARYBASE)
824 /* don't warn on optimised away booleans, eg
825 * use constant Foo, 5; Foo || print; */
826 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
828 /* the constants 0 and 1 are permitted as they are
829 conventionally used as dummies in constructs like
830 1 while some_condition_with_side_effects; */
831 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
833 else if (SvPOK(sv)) {
834 /* perl4's way of mixing documentation and code
835 (before the invention of POD) was based on a
836 trick to mix nroff and perl code. The trick was
837 built upon these three nroff macros being used in
838 void context. The pink camel has the details in
839 the script wrapman near page 319. */
840 const char * const maybe_macro = SvPVX_const(sv);
841 if (strnEQ(maybe_macro, "di", 2) ||
842 strnEQ(maybe_macro, "ds", 2) ||
843 strnEQ(maybe_macro, "ig", 2))
848 op_null(o); /* don't execute or even remember it */
852 o->op_type = OP_PREINC; /* pre-increment is faster */
853 o->op_ppaddr = PL_ppaddr[OP_PREINC];
857 o->op_type = OP_PREDEC; /* pre-decrement is faster */
858 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
862 o->op_type = OP_I_PREINC; /* pre-increment is faster */
863 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
867 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
868 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
877 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
882 if (o->op_flags & OPf_STACKED)
889 if (!(o->op_flags & OPf_KIDS))
900 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
907 /* all requires must return a boolean value */
908 o->op_flags &= ~OPf_WANT;
913 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
914 if (!kPMOP->op_pmreplroot)
915 deprecate_old("implicit split to @_");
919 if (useless && ckWARN(WARN_VOID))
920 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
925 Perl_listkids(pTHX_ OP *o)
927 if (o && o->op_flags & OPf_KIDS) {
929 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
936 Perl_list(pTHX_ OP *o)
941 /* assumes no premature commitment */
942 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
943 || o->op_type == OP_RETURN)
948 if ((o->op_private & OPpTARGET_MY)
949 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
951 return o; /* As if inside SASSIGN */
954 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
956 switch (o->op_type) {
959 list(cBINOPo->op_first);
964 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
972 if (!(o->op_flags & OPf_KIDS))
974 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
975 list(cBINOPo->op_first);
976 return gen_constant_list(o);
983 kid = cLISTOPo->op_first;
985 while ((kid = kid->op_sibling)) {
991 PL_curcop = &PL_compiling;
995 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1001 PL_curcop = &PL_compiling;
1004 /* all requires must return a boolean value */
1005 o->op_flags &= ~OPf_WANT;
1012 Perl_scalarseq(pTHX_ OP *o)
1016 const OPCODE type = o->op_type;
1018 if (type == OP_LINESEQ || type == OP_SCOPE ||
1019 type == OP_LEAVE || type == OP_LEAVETRY)
1022 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1023 if (kid->op_sibling) {
1027 PL_curcop = &PL_compiling;
1029 o->op_flags &= ~OPf_PARENS;
1030 if (PL_hints & HINT_BLOCK_SCOPE)
1031 o->op_flags |= OPf_PARENS;
1034 o = newOP(OP_STUB, 0);
1039 S_modkids(pTHX_ OP *o, I32 type)
1041 if (o && o->op_flags & OPf_KIDS) {
1043 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1049 /* Propagate lvalue ("modifiable") context to an op and its children.
1050 * 'type' represents the context type, roughly based on the type of op that
1051 * would do the modifying, although local() is represented by OP_NULL.
1052 * It's responsible for detecting things that can't be modified, flag
1053 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
1054 * might have to vivify a reference in $x), and so on.
1056 * For example, "$a+1 = 2" would cause mod() to be called with o being
1057 * OP_ADD and type being OP_SASSIGN, and would output an error.
1061 Perl_mod(pTHX_ OP *o, I32 type)
1065 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1068 if (!o || PL_error_count)
1071 if ((o->op_private & OPpTARGET_MY)
1072 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1077 switch (o->op_type) {
1083 if (!(o->op_private & OPpCONST_ARYBASE))
1086 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1087 CopARYBASE_set(&PL_compiling,
1088 (I32)SvIV(cSVOPx(PL_eval_start)->op_sv));
1092 SAVECOPARYBASE(&PL_compiling);
1093 CopARYBASE_set(&PL_compiling, 0);
1095 else if (type == OP_REFGEN)
1098 Perl_croak(aTHX_ "That use of $[ is unsupported");
1101 if (o->op_flags & OPf_PARENS || PL_madskills)
1105 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1106 !(o->op_flags & OPf_STACKED)) {
1107 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1108 /* The default is to set op_private to the number of children,
1109 which for a UNOP such as RV2CV is always 1. And w're using
1110 the bit for a flag in RV2CV, so we need it clear. */
1111 o->op_private &= ~1;
1112 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1113 assert(cUNOPo->op_first->op_type == OP_NULL);
1114 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1117 else if (o->op_private & OPpENTERSUB_NOMOD)
1119 else { /* lvalue subroutine call */
1120 o->op_private |= OPpLVAL_INTRO;
1121 PL_modcount = RETURN_UNLIMITED_NUMBER;
1122 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1123 /* Backward compatibility mode: */
1124 o->op_private |= OPpENTERSUB_INARGS;
1127 else { /* Compile-time error message: */
1128 OP *kid = cUNOPo->op_first;
1132 if (kid->op_type != OP_PUSHMARK) {
1133 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1135 "panic: unexpected lvalue entersub "
1136 "args: type/targ %ld:%"UVuf,
1137 (long)kid->op_type, (UV)kid->op_targ);
1138 kid = kLISTOP->op_first;
1140 while (kid->op_sibling)
1141 kid = kid->op_sibling;
1142 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1144 if (kid->op_type == OP_METHOD_NAMED
1145 || kid->op_type == OP_METHOD)
1149 NewOp(1101, newop, 1, UNOP);
1150 newop->op_type = OP_RV2CV;
1151 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1152 newop->op_first = NULL;
1153 newop->op_next = (OP*)newop;
1154 kid->op_sibling = (OP*)newop;
1155 newop->op_private |= OPpLVAL_INTRO;
1156 newop->op_private &= ~1;
1160 if (kid->op_type != OP_RV2CV)
1162 "panic: unexpected lvalue entersub "
1163 "entry via type/targ %ld:%"UVuf,
1164 (long)kid->op_type, (UV)kid->op_targ);
1165 kid->op_private |= OPpLVAL_INTRO;
1166 break; /* Postpone until runtime */
1170 kid = kUNOP->op_first;
1171 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1172 kid = kUNOP->op_first;
1173 if (kid->op_type == OP_NULL)
1175 "Unexpected constant lvalue entersub "
1176 "entry via type/targ %ld:%"UVuf,
1177 (long)kid->op_type, (UV)kid->op_targ);
1178 if (kid->op_type != OP_GV) {
1179 /* Restore RV2CV to check lvalueness */
1181 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1182 okid->op_next = kid->op_next;
1183 kid->op_next = okid;
1186 okid->op_next = NULL;
1187 okid->op_type = OP_RV2CV;
1189 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1190 okid->op_private |= OPpLVAL_INTRO;
1191 okid->op_private &= ~1;
1195 cv = GvCV(kGVOP_gv);
1205 /* grep, foreach, subcalls, refgen */
1206 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1208 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1209 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1211 : (o->op_type == OP_ENTERSUB
1212 ? "non-lvalue subroutine call"
1214 type ? PL_op_desc[type] : "local"));
1228 case OP_RIGHT_SHIFT:
1237 if (!(o->op_flags & OPf_STACKED))
1244 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1250 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1251 PL_modcount = RETURN_UNLIMITED_NUMBER;
1252 return o; /* Treat \(@foo) like ordinary list. */
1256 if (scalar_mod_type(o, type))
1258 ref(cUNOPo->op_first, o->op_type);
1262 if (type == OP_LEAVESUBLV)
1263 o->op_private |= OPpMAYBE_LVSUB;
1269 PL_modcount = RETURN_UNLIMITED_NUMBER;
1272 ref(cUNOPo->op_first, o->op_type);
1277 PL_hints |= HINT_BLOCK_SCOPE;
1292 PL_modcount = RETURN_UNLIMITED_NUMBER;
1293 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1294 return o; /* Treat \(@foo) like ordinary list. */
1295 if (scalar_mod_type(o, type))
1297 if (type == OP_LEAVESUBLV)
1298 o->op_private |= OPpMAYBE_LVSUB;
1302 if (!type) /* local() */
1303 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1304 PAD_COMPNAME_PV(o->op_targ));
1312 if (type != OP_SASSIGN)
1316 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1321 if (type == OP_LEAVESUBLV)
1322 o->op_private |= OPpMAYBE_LVSUB;
1324 pad_free(o->op_targ);
1325 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1326 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1327 if (o->op_flags & OPf_KIDS)
1328 mod(cBINOPo->op_first->op_sibling, type);
1333 ref(cBINOPo->op_first, o->op_type);
1334 if (type == OP_ENTERSUB &&
1335 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1336 o->op_private |= OPpLVAL_DEFER;
1337 if (type == OP_LEAVESUBLV)
1338 o->op_private |= OPpMAYBE_LVSUB;
1348 if (o->op_flags & OPf_KIDS)
1349 mod(cLISTOPo->op_last, type);
1354 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1356 else if (!(o->op_flags & OPf_KIDS))
1358 if (o->op_targ != OP_LIST) {
1359 mod(cBINOPo->op_first, type);
1365 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1370 if (type != OP_LEAVESUBLV)
1372 break; /* mod()ing was handled by ck_return() */
1375 /* [20011101.069] File test operators interpret OPf_REF to mean that
1376 their argument is a filehandle; thus \stat(".") should not set
1378 if (type == OP_REFGEN &&
1379 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1382 if (type != OP_LEAVESUBLV)
1383 o->op_flags |= OPf_MOD;
1385 if (type == OP_AASSIGN || type == OP_SASSIGN)
1386 o->op_flags |= OPf_SPECIAL|OPf_REF;
1387 else if (!type) { /* local() */
1390 o->op_private |= OPpLVAL_INTRO;
1391 o->op_flags &= ~OPf_SPECIAL;
1392 PL_hints |= HINT_BLOCK_SCOPE;
1397 if (ckWARN(WARN_SYNTAX)) {
1398 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1399 "Useless localization of %s", OP_DESC(o));
1403 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1404 && type != OP_LEAVESUBLV)
1405 o->op_flags |= OPf_REF;
1410 S_scalar_mod_type(const OP *o, I32 type)
1414 if (o->op_type == OP_RV2GV)
1438 case OP_RIGHT_SHIFT:
1457 S_is_handle_constructor(const OP *o, I32 numargs)
1459 switch (o->op_type) {
1467 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1480 Perl_refkids(pTHX_ OP *o, I32 type)
1482 if (o && o->op_flags & OPf_KIDS) {
1484 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1491 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
1496 if (!o || PL_error_count)
1499 switch (o->op_type) {
1501 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1502 !(o->op_flags & OPf_STACKED)) {
1503 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1504 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1505 assert(cUNOPo->op_first->op_type == OP_NULL);
1506 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1507 o->op_flags |= OPf_SPECIAL;
1508 o->op_private &= ~1;
1513 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1514 doref(kid, type, set_op_ref);
1517 if (type == OP_DEFINED)
1518 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1519 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1522 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1523 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1524 : type == OP_RV2HV ? OPpDEREF_HV
1526 o->op_flags |= OPf_MOD;
1531 o->op_flags |= OPf_MOD; /* XXX ??? */
1537 o->op_flags |= OPf_REF;
1540 if (type == OP_DEFINED)
1541 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1542 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1548 o->op_flags |= OPf_REF;
1553 if (!(o->op_flags & OPf_KIDS))
1555 doref(cBINOPo->op_first, type, set_op_ref);
1559 doref(cBINOPo->op_first, o->op_type, set_op_ref);
1560 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1561 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1562 : type == OP_RV2HV ? OPpDEREF_HV
1564 o->op_flags |= OPf_MOD;
1574 if (!(o->op_flags & OPf_KIDS))
1576 doref(cLISTOPo->op_last, type, set_op_ref);
1586 S_dup_attrlist(pTHX_ OP *o)
1591 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1592 * where the first kid is OP_PUSHMARK and the remaining ones
1593 * are OP_CONST. We need to push the OP_CONST values.
1595 if (o->op_type == OP_CONST)
1596 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
1598 else if (o->op_type == OP_NULL)
1602 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1604 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1605 if (o->op_type == OP_CONST)
1606 rop = append_elem(OP_LIST, rop,
1607 newSVOP(OP_CONST, o->op_flags,
1608 SvREFCNT_inc_NN(cSVOPo->op_sv)));
1615 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1620 /* fake up C<use attributes $pkg,$rv,@attrs> */
1621 ENTER; /* need to protect against side-effects of 'use' */
1623 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1625 #define ATTRSMODULE "attributes"
1626 #define ATTRSMODULE_PM "attributes.pm"
1629 /* Don't force the C<use> if we don't need it. */
1630 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
1631 if (svp && *svp != &PL_sv_undef)
1632 NOOP; /* already in %INC */
1634 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1635 newSVpvs(ATTRSMODULE), NULL);
1638 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1639 newSVpvs(ATTRSMODULE),
1641 prepend_elem(OP_LIST,
1642 newSVOP(OP_CONST, 0, stashsv),
1643 prepend_elem(OP_LIST,
1644 newSVOP(OP_CONST, 0,
1646 dup_attrlist(attrs))));
1652 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1655 OP *pack, *imop, *arg;
1661 assert(target->op_type == OP_PADSV ||
1662 target->op_type == OP_PADHV ||
1663 target->op_type == OP_PADAV);
1665 /* Ensure that attributes.pm is loaded. */
1666 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1668 /* Need package name for method call. */
1669 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
1671 /* Build up the real arg-list. */
1672 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1674 arg = newOP(OP_PADSV, 0);
1675 arg->op_targ = target->op_targ;
1676 arg = prepend_elem(OP_LIST,
1677 newSVOP(OP_CONST, 0, stashsv),
1678 prepend_elem(OP_LIST,
1679 newUNOP(OP_REFGEN, 0,
1680 mod(arg, OP_REFGEN)),
1681 dup_attrlist(attrs)));
1683 /* Fake up a method call to import */
1684 meth = newSVpvs_share("import");
1685 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1686 append_elem(OP_LIST,
1687 prepend_elem(OP_LIST, pack, list(arg)),
1688 newSVOP(OP_METHOD_NAMED, 0, meth)));
1689 imop->op_private |= OPpENTERSUB_NOMOD;
1691 /* Combine the ops. */
1692 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1696 =notfor apidoc apply_attrs_string
1698 Attempts to apply a list of attributes specified by the C<attrstr> and
1699 C<len> arguments to the subroutine identified by the C<cv> argument which
1700 is expected to be associated with the package identified by the C<stashpv>
1701 argument (see L<attributes>). It gets this wrong, though, in that it
1702 does not correctly identify the boundaries of the individual attribute
1703 specifications within C<attrstr>. This is not really intended for the
1704 public API, but has to be listed here for systems such as AIX which
1705 need an explicit export list for symbols. (It's called from XS code
1706 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1707 to respect attribute syntax properly would be welcome.
1713 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
1714 const char *attrstr, STRLEN len)
1719 len = strlen(attrstr);
1723 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1725 const char * const sstr = attrstr;
1726 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1727 attrs = append_elem(OP_LIST, attrs,
1728 newSVOP(OP_CONST, 0,
1729 newSVpvn(sstr, attrstr-sstr)));
1733 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1734 newSVpvs(ATTRSMODULE),
1735 NULL, prepend_elem(OP_LIST,
1736 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1737 prepend_elem(OP_LIST,
1738 newSVOP(OP_CONST, 0,
1744 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
1749 if (!o || PL_error_count)
1753 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
1754 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
1758 if (type == OP_LIST) {
1760 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1761 my_kid(kid, attrs, imopsp);
1762 } else if (type == OP_UNDEF
1768 } else if (type == OP_RV2SV || /* "our" declaration */
1770 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1771 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1772 yyerror(Perl_form(aTHX_ "Can't declare %s in %s",
1774 PL_in_my == KEY_our ? "our" : PL_in_my == KEY_state ? "state" : "my"));
1776 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
1778 PL_in_my_stash = NULL;
1779 apply_attrs(GvSTASH(gv),
1780 (type == OP_RV2SV ? GvSV(gv) :
1781 type == OP_RV2AV ? (SV*)GvAV(gv) :
1782 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1785 o->op_private |= OPpOUR_INTRO;
1788 else if (type != OP_PADSV &&
1791 type != OP_PUSHMARK)
1793 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1795 PL_in_my == KEY_our ? "our" : PL_in_my == KEY_state ? "state" : "my"));
1798 else if (attrs && type != OP_PUSHMARK) {
1802 PL_in_my_stash = NULL;
1804 /* check for C<my Dog $spot> when deciding package */
1805 stash = PAD_COMPNAME_TYPE(o->op_targ);
1807 stash = PL_curstash;
1808 apply_attrs_my(stash, o, attrs, imopsp);
1810 o->op_flags |= OPf_MOD;
1811 o->op_private |= OPpLVAL_INTRO;
1812 if (PL_in_my == KEY_state)
1813 o->op_private |= OPpPAD_STATE;
1818 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1822 int maybe_scalar = 0;
1824 /* [perl #17376]: this appears to be premature, and results in code such as
1825 C< our(%x); > executing in list mode rather than void mode */
1827 if (o->op_flags & OPf_PARENS)
1837 o = my_kid(o, attrs, &rops);
1839 if (maybe_scalar && o->op_type == OP_PADSV) {
1840 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
1841 o->op_private |= OPpLVAL_INTRO;
1844 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
1847 PL_in_my_stash = NULL;
1852 Perl_my(pTHX_ OP *o)
1854 return my_attrs(o, NULL);
1858 Perl_sawparens(pTHX_ OP *o)
1860 PERL_UNUSED_CONTEXT;
1862 o->op_flags |= OPf_PARENS;
1867 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
1871 const OPCODE ltype = left->op_type;
1872 const OPCODE rtype = right->op_type;
1874 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
1875 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
1877 const char * const desc
1878 = PL_op_desc[(rtype == OP_SUBST || rtype == OP_TRANS)
1879 ? rtype : OP_MATCH];
1880 const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV)
1881 ? "@array" : "%hash");
1882 Perl_warner(aTHX_ packWARN(WARN_MISC),
1883 "Applying %s to %s will act on scalar(%s)",
1884 desc, sample, sample);
1887 if (rtype == OP_CONST &&
1888 cSVOPx(right)->op_private & OPpCONST_BARE &&
1889 cSVOPx(right)->op_private & OPpCONST_STRICT)
1891 no_bareword_allowed(right);
1894 ismatchop = rtype == OP_MATCH ||
1895 rtype == OP_SUBST ||
1897 if (ismatchop && right->op_private & OPpTARGET_MY) {
1899 right->op_private &= ~OPpTARGET_MY;
1901 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
1904 right->op_flags |= OPf_STACKED;
1905 if (rtype != OP_MATCH &&
1906 ! (rtype == OP_TRANS &&
1907 right->op_private & OPpTRANS_IDENTICAL))
1908 newleft = mod(left, rtype);
1911 if (right->op_type == OP_TRANS)
1912 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
1914 o = prepend_elem(rtype, scalar(newleft), right);
1916 return newUNOP(OP_NOT, 0, scalar(o));
1920 return bind_match(type, left,
1921 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
1925 Perl_invert(pTHX_ OP *o)
1929 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
1933 Perl_scope(pTHX_ OP *o)
1937 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
1938 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
1939 o->op_type = OP_LEAVE;
1940 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
1942 else if (o->op_type == OP_LINESEQ) {
1944 o->op_type = OP_SCOPE;
1945 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
1946 kid = ((LISTOP*)o)->op_first;
1947 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
1950 /* The following deals with things like 'do {1 for 1}' */
1951 kid = kid->op_sibling;
1953 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
1958 o = newLISTOP(OP_SCOPE, 0, o, NULL);
1964 Perl_block_start(pTHX_ int full)
1967 const int retval = PL_savestack_ix;
1968 pad_block_start(full);
1970 PL_hints &= ~HINT_BLOCK_SCOPE;
1971 SAVECOMPILEWARNINGS();
1972 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
1977 Perl_block_end(pTHX_ I32 floor, OP *seq)
1980 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
1981 OP* const retval = scalarseq(seq);
1983 CopHINTS_set(&PL_compiling, PL_hints);
1985 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
1994 const PADOFFSET offset = pad_findmy("$_");
1995 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
1996 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
1999 OP * const o = newOP(OP_PADSV, 0);
2000 o->op_targ = offset;
2006 Perl_newPROG(pTHX_ OP *o)
2012 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2013 ((PL_in_eval & EVAL_KEEPERR)
2014 ? OPf_SPECIAL : 0), o);
2015 PL_eval_start = linklist(PL_eval_root);
2016 PL_eval_root->op_private |= OPpREFCOUNTED;
2017 OpREFCNT_set(PL_eval_root, 1);
2018 PL_eval_root->op_next = 0;
2019 CALL_PEEP(PL_eval_start);
2022 if (o->op_type == OP_STUB) {
2023 PL_comppad_name = 0;
2028 PL_main_root = scope(sawparens(scalarvoid(o)));
2029 PL_curcop = &PL_compiling;
2030 PL_main_start = LINKLIST(PL_main_root);
2031 PL_main_root->op_private |= OPpREFCOUNTED;
2032 OpREFCNT_set(PL_main_root, 1);
2033 PL_main_root->op_next = 0;
2034 CALL_PEEP(PL_main_start);
2037 /* Register with debugger */
2039 CV * const cv = get_cv("DB::postponed", FALSE);
2043 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2045 call_sv((SV*)cv, G_DISCARD);
2052 Perl_localize(pTHX_ OP *o, I32 lex)
2055 if (o->op_flags & OPf_PARENS)
2056 /* [perl #17376]: this appears to be premature, and results in code such as
2057 C< our(%x); > executing in list mode rather than void mode */
2064 if ( PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ','
2065 && ckWARN(WARN_PARENTHESIS))
2067 char *s = PL_bufptr;
2070 /* some heuristics to detect a potential error */
2071 while (*s && (strchr(", \t\n", *s)))
2075 if (*s && strchr("@$%*", *s) && *++s
2076 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2079 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2081 while (*s && (strchr(", \t\n", *s)))
2087 if (sigil && (*s == ';' || *s == '=')) {
2088 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2089 "Parentheses missing around \"%s\" list",
2090 lex ? (PL_in_my == KEY_our ? "our" : PL_in_my == KEY_state ? "state" : "my")
2098 o = mod(o, OP_NULL); /* a bit kludgey */
2100 PL_in_my_stash = NULL;
2105 Perl_jmaybe(pTHX_ OP *o)
2107 if (o->op_type == OP_LIST) {
2109 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2110 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2116 Perl_fold_constants(pTHX_ register OP *o)
2121 I32 type = o->op_type;
2126 SV * const oldwarnhook = PL_warnhook;
2127 SV * const olddiehook = PL_diehook;
2130 if (PL_opargs[type] & OA_RETSCALAR)
2132 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2133 o->op_targ = pad_alloc(type, SVs_PADTMP);
2135 /* integerize op, unless it happens to be C<-foo>.
2136 * XXX should pp_i_negate() do magic string negation instead? */
2137 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2138 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2139 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2141 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2144 if (!(PL_opargs[type] & OA_FOLDCONST))
2149 /* XXX might want a ck_negate() for this */
2150 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2161 /* XXX what about the numeric ops? */
2162 if (PL_hints & HINT_LOCALE)
2167 goto nope; /* Don't try to run w/ errors */
2169 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2170 const OPCODE type = curop->op_type;
2171 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2173 type != OP_SCALAR &&
2175 type != OP_PUSHMARK)
2181 curop = LINKLIST(o);
2182 old_next = o->op_next;
2186 oldscope = PL_scopestack_ix;
2187 create_eval_scope(G_FAKINGEVAL);
2189 PL_warnhook = PERL_WARNHOOK_FATAL;
2196 sv = *(PL_stack_sp--);
2197 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2198 pad_swipe(o->op_targ, FALSE);
2199 else if (SvTEMP(sv)) { /* grab mortal temp? */
2200 SvREFCNT_inc_simple_void(sv);
2205 /* Something tried to die. Abandon constant folding. */
2206 /* Pretend the error never happened. */
2207 sv_setpvn(ERRSV,"",0);
2208 o->op_next = old_next;
2212 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
2213 PL_warnhook = oldwarnhook;
2214 PL_diehook = olddiehook;
2215 /* XXX note that this croak may fail as we've already blown away
2216 * the stack - eg any nested evals */
2217 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
2220 PL_warnhook = oldwarnhook;
2221 PL_diehook = olddiehook;
2223 if (PL_scopestack_ix > oldscope)
2224 delete_eval_scope();
2233 if (type == OP_RV2GV)
2234 newop = newGVOP(OP_GV, 0, (GV*)sv);
2236 newop = newSVOP(OP_CONST, 0, sv);
2237 op_getmad(o,newop,'f');
2245 Perl_gen_constant_list(pTHX_ register OP *o)
2249 const I32 oldtmps_floor = PL_tmps_floor;
2253 return o; /* Don't attempt to run with errors */
2255 PL_op = curop = LINKLIST(o);
2262 PL_tmps_floor = oldtmps_floor;
2264 o->op_type = OP_RV2AV;
2265 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2266 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2267 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2268 o->op_opt = 0; /* needs to be revisited in peep() */
2269 curop = ((UNOP*)o)->op_first;
2270 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
2272 op_getmad(curop,o,'O');
2281 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2284 if (!o || o->op_type != OP_LIST)
2285 o = newLISTOP(OP_LIST, 0, o, NULL);
2287 o->op_flags &= ~OPf_WANT;
2289 if (!(PL_opargs[type] & OA_MARK))
2290 op_null(cLISTOPo->op_first);
2292 o->op_type = (OPCODE)type;
2293 o->op_ppaddr = PL_ppaddr[type];
2294 o->op_flags |= flags;
2296 o = CHECKOP(type, o);
2297 if (o->op_type != (unsigned)type)
2300 return fold_constants(o);
2303 /* List constructors */
2306 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2314 if (first->op_type != (unsigned)type
2315 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2317 return newLISTOP(type, 0, first, last);
2320 if (first->op_flags & OPf_KIDS)
2321 ((LISTOP*)first)->op_last->op_sibling = last;
2323 first->op_flags |= OPf_KIDS;
2324 ((LISTOP*)first)->op_first = last;
2326 ((LISTOP*)first)->op_last = last;
2331 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2339 if (first->op_type != (unsigned)type)
2340 return prepend_elem(type, (OP*)first, (OP*)last);
2342 if (last->op_type != (unsigned)type)
2343 return append_elem(type, (OP*)first, (OP*)last);
2345 first->op_last->op_sibling = last->op_first;
2346 first->op_last = last->op_last;
2347 first->op_flags |= (last->op_flags & OPf_KIDS);
2350 if (last->op_first && first->op_madprop) {
2351 MADPROP *mp = last->op_first->op_madprop;
2353 while (mp->mad_next)
2355 mp->mad_next = first->op_madprop;
2358 last->op_first->op_madprop = first->op_madprop;
2361 first->op_madprop = last->op_madprop;
2362 last->op_madprop = 0;
2371 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2379 if (last->op_type == (unsigned)type) {
2380 if (type == OP_LIST) { /* already a PUSHMARK there */
2381 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2382 ((LISTOP*)last)->op_first->op_sibling = first;
2383 if (!(first->op_flags & OPf_PARENS))
2384 last->op_flags &= ~OPf_PARENS;
2387 if (!(last->op_flags & OPf_KIDS)) {
2388 ((LISTOP*)last)->op_last = first;
2389 last->op_flags |= OPf_KIDS;
2391 first->op_sibling = ((LISTOP*)last)->op_first;
2392 ((LISTOP*)last)->op_first = first;
2394 last->op_flags |= OPf_KIDS;
2398 return newLISTOP(type, 0, first, last);
2406 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2409 Newxz(tk, 1, TOKEN);
2410 tk->tk_type = (OPCODE)optype;
2411 tk->tk_type = 12345;
2413 tk->tk_mad = madprop;
2418 Perl_token_free(pTHX_ TOKEN* tk)
2420 if (tk->tk_type != 12345)
2422 mad_free(tk->tk_mad);
2427 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2431 if (tk->tk_type != 12345) {
2432 Perl_warner(aTHX_ packWARN(WARN_MISC),
2433 "Invalid TOKEN object ignored");
2440 /* faked up qw list? */
2442 tm->mad_type == MAD_SV &&
2443 SvPVX((SV*)tm->mad_val)[0] == 'q')
2450 /* pretend constant fold didn't happen? */
2451 if (mp->mad_key == 'f' &&
2452 (o->op_type == OP_CONST ||
2453 o->op_type == OP_GV) )
2455 token_getmad(tk,(OP*)mp->mad_val,slot);
2469 if (mp->mad_key == 'X')
2470 mp->mad_key = slot; /* just change the first one */
2480 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
2489 /* pretend constant fold didn't happen? */
2490 if (mp->mad_key == 'f' &&
2491 (o->op_type == OP_CONST ||
2492 o->op_type == OP_GV) )
2494 op_getmad(from,(OP*)mp->mad_val,slot);
2501 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
2504 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
2510 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
2519 /* pretend constant fold didn't happen? */
2520 if (mp->mad_key == 'f' &&
2521 (o->op_type == OP_CONST ||
2522 o->op_type == OP_GV) )
2524 op_getmad(from,(OP*)mp->mad_val,slot);
2531 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
2534 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
2538 PerlIO_printf(PerlIO_stderr(),
2539 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
2545 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
2563 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
2567 addmad(tm, &(o->op_madprop), slot);
2571 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
2592 Perl_newMADsv(pTHX_ char key, SV* sv)
2594 return newMADPROP(key, MAD_SV, sv, 0);
2598 Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
2601 Newxz(mp, 1, MADPROP);
2604 mp->mad_vlen = vlen;
2605 mp->mad_type = type;
2607 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
2612 Perl_mad_free(pTHX_ MADPROP* mp)
2614 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
2618 mad_free(mp->mad_next);
2619 /* if (PL_lex_state != LEX_NOTPARSING && mp->mad_vlen)
2620 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
2621 switch (mp->mad_type) {
2625 Safefree((char*)mp->mad_val);
2628 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
2629 op_free((OP*)mp->mad_val);
2632 sv_free((SV*)mp->mad_val);
2635 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
2644 Perl_newNULLLIST(pTHX)
2646 return newOP(OP_STUB, 0);
2650 Perl_force_list(pTHX_ OP *o)
2652 if (!o || o->op_type != OP_LIST)
2653 o = newLISTOP(OP_LIST, 0, o, NULL);
2659 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2664 NewOp(1101, listop, 1, LISTOP);
2666 listop->op_type = (OPCODE)type;
2667 listop->op_ppaddr = PL_ppaddr[type];
2670 listop->op_flags = (U8)flags;
2674 else if (!first && last)
2677 first->op_sibling = last;
2678 listop->op_first = first;
2679 listop->op_last = last;
2680 if (type == OP_LIST) {
2681 OP* const pushop = newOP(OP_PUSHMARK, 0);
2682 pushop->op_sibling = first;
2683 listop->op_first = pushop;
2684 listop->op_flags |= OPf_KIDS;
2686 listop->op_last = pushop;
2689 return CHECKOP(type, listop);
2693 Perl_newOP(pTHX_ I32 type, I32 flags)
2697 NewOp(1101, o, 1, OP);
2698 o->op_type = (OPCODE)type;
2699 o->op_ppaddr = PL_ppaddr[type];
2700 o->op_flags = (U8)flags;
2703 o->op_private = (U8)(0 | (flags >> 8));
2704 if (PL_opargs[type] & OA_RETSCALAR)
2706 if (PL_opargs[type] & OA_TARGET)
2707 o->op_targ = pad_alloc(type, SVs_PADTMP);
2708 return CHECKOP(type, o);
2712 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2718 first = newOP(OP_STUB, 0);
2719 if (PL_opargs[type] & OA_MARK)
2720 first = force_list(first);
2722 NewOp(1101, unop, 1, UNOP);
2723 unop->op_type = (OPCODE)type;
2724 unop->op_ppaddr = PL_ppaddr[type];
2725 unop->op_first = first;
2726 unop->op_flags = (U8)(flags | OPf_KIDS);
2727 unop->op_private = (U8)(1 | (flags >> 8));
2728 unop = (UNOP*) CHECKOP(type, unop);
2732 return fold_constants((OP *) unop);
2736 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2740 NewOp(1101, binop, 1, BINOP);
2743 first = newOP(OP_NULL, 0);
2745 binop->op_type = (OPCODE)type;
2746 binop->op_ppaddr = PL_ppaddr[type];
2747 binop->op_first = first;
2748 binop->op_flags = (U8)(flags | OPf_KIDS);
2751 binop->op_private = (U8)(1 | (flags >> 8));
2754 binop->op_private = (U8)(2 | (flags >> 8));
2755 first->op_sibling = last;
2758 binop = (BINOP*)CHECKOP(type, binop);
2759 if (binop->op_next || binop->op_type != (OPCODE)type)
2762 binop->op_last = binop->op_first->op_sibling;
2764 return fold_constants((OP *)binop);
2767 static int uvcompare(const void *a, const void *b)
2768 __attribute__nonnull__(1)
2769 __attribute__nonnull__(2)
2770 __attribute__pure__;
2771 static int uvcompare(const void *a, const void *b)
2773 if (*((const UV *)a) < (*(const UV *)b))
2775 if (*((const UV *)a) > (*(const UV *)b))
2777 if (*((const UV *)a+1) < (*(const UV *)b+1))
2779 if (*((const UV *)a+1) > (*(const UV *)b+1))
2785 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2788 SV * const tstr = ((SVOP*)expr)->op_sv;
2789 SV * const rstr = ((SVOP*)repl)->op_sv;
2792 const U8 *t = (U8*)SvPV_const(tstr, tlen);
2793 const U8 *r = (U8*)SvPV_const(rstr, rlen);
2797 register short *tbl;
2799 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
2800 const I32 squash = o->op_private & OPpTRANS_SQUASH;
2801 I32 del = o->op_private & OPpTRANS_DELETE;
2802 PL_hints |= HINT_BLOCK_SCOPE;
2805 o->op_private |= OPpTRANS_FROM_UTF;
2808 o->op_private |= OPpTRANS_TO_UTF;
2810 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2811 SV* const listsv = newSVpvs("# comment\n");
2813 const U8* tend = t + tlen;
2814 const U8* rend = r + rlen;
2828 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2829 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2832 const U32 flags = UTF8_ALLOW_DEFAULT;
2836 t = tsave = bytes_to_utf8(t, &len);
2839 if (!to_utf && rlen) {
2841 r = rsave = bytes_to_utf8(r, &len);
2845 /* There are several snags with this code on EBCDIC:
2846 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2847 2. scan_const() in toke.c has encoded chars in native encoding which makes
2848 ranges at least in EBCDIC 0..255 range the bottom odd.
2852 U8 tmpbuf[UTF8_MAXBYTES+1];
2855 Newx(cp, 2*tlen, UV);
2857 transv = newSVpvs("");
2859 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
2861 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2863 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
2867 cp[2*i+1] = cp[2*i];
2871 qsort(cp, i, 2*sizeof(UV), uvcompare);
2872 for (j = 0; j < i; j++) {
2874 diff = val - nextmin;
2876 t = uvuni_to_utf8(tmpbuf,nextmin);
2877 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2879 U8 range_mark = UTF_TO_NATIVE(0xff);
2880 t = uvuni_to_utf8(tmpbuf, val - 1);
2881 sv_catpvn(transv, (char *)&range_mark, 1);
2882 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2889 t = uvuni_to_utf8(tmpbuf,nextmin);
2890 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2892 U8 range_mark = UTF_TO_NATIVE(0xff);
2893 sv_catpvn(transv, (char *)&range_mark, 1);
2895 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2896 UNICODE_ALLOW_SUPER);
2897 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2898 t = (const U8*)SvPVX_const(transv);
2899 tlen = SvCUR(transv);
2903 else if (!rlen && !del) {
2904 r = t; rlen = tlen; rend = tend;
2907 if ((!rlen && !del) || t == r ||
2908 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2910 o->op_private |= OPpTRANS_IDENTICAL;
2914 while (t < tend || tfirst <= tlast) {
2915 /* see if we need more "t" chars */
2916 if (tfirst > tlast) {
2917 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
2919 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2921 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
2928 /* now see if we need more "r" chars */
2929 if (rfirst > rlast) {
2931 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
2933 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2935 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
2944 rfirst = rlast = 0xffffffff;
2948 /* now see which range will peter our first, if either. */
2949 tdiff = tlast - tfirst;
2950 rdiff = rlast - rfirst;
2957 if (rfirst == 0xffffffff) {
2958 diff = tdiff; /* oops, pretend rdiff is infinite */
2960 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2961 (long)tfirst, (long)tlast);
2963 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2967 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2968 (long)tfirst, (long)(tfirst + diff),
2971 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2972 (long)tfirst, (long)rfirst);
2974 if (rfirst + diff > max)
2975 max = rfirst + diff;
2977 grows = (tfirst < rfirst &&
2978 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2990 else if (max > 0xff)
2995 Safefree(cPVOPo->op_pv);
2996 cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2997 SvREFCNT_dec(listsv);
2998 SvREFCNT_dec(transv);
3000 if (!del && havefinal && rlen)
3001 (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
3002 newSVuv((UV)final), 0);
3005 o->op_private |= OPpTRANS_GROWS;
3011 op_getmad(expr,o,'e');
3012 op_getmad(repl,o,'r');
3020 tbl = (short*)cPVOPo->op_pv;
3022 Zero(tbl, 256, short);
3023 for (i = 0; i < (I32)tlen; i++)
3025 for (i = 0, j = 0; i < 256; i++) {
3027 if (j >= (I32)rlen) {
3036 if (i < 128 && r[j] >= 128)
3046 o->op_private |= OPpTRANS_IDENTICAL;
3048 else if (j >= (I32)rlen)
3051 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
3052 tbl[0x100] = (short)(rlen - j);
3053 for (i=0; i < (I32)rlen - j; i++)
3054 tbl[0x101+i] = r[j+i];
3058 if (!rlen && !del) {
3061 o->op_private |= OPpTRANS_IDENTICAL;
3063 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3064 o->op_private |= OPpTRANS_IDENTICAL;
3066 for (i = 0; i < 256; i++)
3068 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3069 if (j >= (I32)rlen) {
3071 if (tbl[t[i]] == -1)
3077 if (tbl[t[i]] == -1) {
3078 if (t[i] < 128 && r[j] >= 128)
3085 o->op_private |= OPpTRANS_GROWS;
3087 op_getmad(expr,o,'e');
3088 op_getmad(repl,o,'r');
3098 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3103 NewOp(1101, pmop, 1, PMOP);
3104 pmop->op_type = (OPCODE)type;
3105 pmop->op_ppaddr = PL_ppaddr[type];
3106 pmop->op_flags = (U8)flags;
3107 pmop->op_private = (U8)(0 | (flags >> 8));
3109 if (PL_hints & HINT_RE_TAINT)
3110 pmop->op_pmpermflags |= PMf_RETAINT;
3111 if (PL_hints & HINT_LOCALE)
3112 pmop->op_pmpermflags |= PMf_LOCALE;
3113 pmop->op_pmflags = pmop->op_pmpermflags;
3116 if (av_len((AV*) PL_regex_pad[0]) > -1) {
3117 SV * const repointer = av_pop((AV*)PL_regex_pad[0]);
3118 pmop->op_pmoffset = SvIV(repointer);
3119 SvREPADTMP_off(repointer);
3120 sv_setiv(repointer,0);
3122 SV * const repointer = newSViv(0);
3123 av_push(PL_regex_padav, SvREFCNT_inc_simple_NN(repointer));
3124 pmop->op_pmoffset = av_len(PL_regex_padav);
3125 PL_regex_pad = AvARRAY(PL_regex_padav);
3129 /* link into pm list */
3130 if (type != OP_TRANS && PL_curstash) {
3131 MAGIC *mg = mg_find((SV*)PL_curstash, PERL_MAGIC_symtab);
3134 mg = sv_magicext((SV*)PL_curstash, 0, PERL_MAGIC_symtab, 0, 0, 0);
3136 pmop->op_pmnext = (PMOP*)mg->mg_obj;
3137 mg->mg_obj = (SV*)pmop;
3138 PmopSTASH_set(pmop,PL_curstash);
3141 return CHECKOP(type, pmop);
3144 /* Given some sort of match op o, and an expression expr containing a
3145 * pattern, either compile expr into a regex and attach it to o (if it's
3146 * constant), or convert expr into a runtime regcomp op sequence (if it's
3149 * isreg indicates that the pattern is part of a regex construct, eg
3150 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3151 * split "pattern", which aren't. In the former case, expr will be a list
3152 * if the pattern contains more than one term (eg /a$b/) or if it contains
3153 * a replacement, ie s/// or tr///.
3157 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
3162 I32 repl_has_vars = 0;
3166 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
3167 /* last element in list is the replacement; pop it */
3169 repl = cLISTOPx(expr)->op_last;
3170 kid = cLISTOPx(expr)->op_first;
3171 while (kid->op_sibling != repl)
3172 kid = kid->op_sibling;
3173 kid->op_sibling = NULL;
3174 cLISTOPx(expr)->op_last = kid;
3177 if (isreg && expr->op_type == OP_LIST &&
3178 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3180 /* convert single element list to element */
3181 OP* const oe = expr;
3182 expr = cLISTOPx(oe)->op_first->op_sibling;
3183 cLISTOPx(oe)->op_first->op_sibling = NULL;
3184 cLISTOPx(oe)->op_last = NULL;
3188 if (o->op_type == OP_TRANS) {
3189 return pmtrans(o, expr, repl);
3192 reglist = isreg && expr->op_type == OP_LIST;
3196 PL_hints |= HINT_BLOCK_SCOPE;
3199 if (expr->op_type == OP_CONST) {
3201 SV * const pat = ((SVOP*)expr)->op_sv;
3202 const char *p = SvPV_const(pat, plen);
3203 if ((o->op_flags & OPf_SPECIAL) && (*p == ' ' && p[1] == '\0')) {
3204 U32 was_readonly = SvREADONLY(pat);
3208 sv_force_normal_flags(pat, 0);
3209 assert(!SvREADONLY(pat));
3212 SvREADONLY_off(pat);
3216 sv_setpvn(pat, "\\s+", 3);
3218 SvFLAGS(pat) |= was_readonly;
3220 p = SvPV_const(pat, plen);
3221 pm->op_pmflags |= PMf_SKIPWHITE;
3224 pm->op_pmdynflags |= PMdf_UTF8;
3225 /* FIXME - can we make this function take const char * args? */
3226 PM_SETRE(pm, CALLREGCOMP(aTHX_ (char*)p, (char*)p + plen, pm));
3227 if (strEQ("\\s+", PM_GETRE(pm)->precomp))
3228 pm->op_pmflags |= PMf_WHITE;
3230 op_getmad(expr,(OP*)pm,'e');
3236 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3237 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3239 : OP_REGCMAYBE),0,expr);
3241 NewOp(1101, rcop, 1, LOGOP);
3242 rcop->op_type = OP_REGCOMP;
3243 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3244 rcop->op_first = scalar(expr);
3245 rcop->op_flags |= OPf_KIDS
3246 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3247 | (reglist ? OPf_STACKED : 0);
3248 rcop->op_private = 1;
3251 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3253 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
3256 /* establish postfix order */
3257 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3259 rcop->op_next = expr;
3260 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3263 rcop->op_next = LINKLIST(expr);
3264 expr->op_next = (OP*)rcop;
3267 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3272 if (pm->op_pmflags & PMf_EVAL) {
3274 if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
3275 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
3277 else if (repl->op_type == OP_CONST)
3281 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3282 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3283 if (curop->op_type == OP_GV) {
3284 GV * const gv = cGVOPx_gv(curop);
3286 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3289 else if (curop->op_type == OP_RV2CV)
3291 else if (curop->op_type == OP_RV2SV ||
3292 curop->op_type == OP_RV2AV ||
3293 curop->op_type == OP_RV2HV ||
3294 curop->op_type == OP_RV2GV) {
3295 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3298 else if (curop->op_type == OP_PADSV ||
3299 curop->op_type == OP_PADAV ||
3300 curop->op_type == OP_PADHV ||
3301 curop->op_type == OP_PADANY) {
3304 else if (curop->op_type == OP_PUSHRE)
3305 NOOP; /* Okay here, dangerous in newASSIGNOP */
3315 || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
3316 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3317 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
3318 prepend_elem(o->op_type, scalar(repl), o);
3321 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3322 pm->op_pmflags |= PMf_MAYBE_CONST;
3323 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3325 NewOp(1101, rcop, 1, LOGOP);
3326 rcop->op_type = OP_SUBSTCONT;
3327 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3328 rcop->op_first = scalar(repl);
3329 rcop->op_flags |= OPf_KIDS;
3330 rcop->op_private = 1;
3333 /* establish postfix order */
3334 rcop->op_next = LINKLIST(repl);
3335 repl->op_next = (OP*)rcop;
3337 pm->op_pmreplroot = scalar((OP*)rcop);
3338 pm->op_pmreplstart = LINKLIST(rcop);
3347 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3351 NewOp(1101, svop, 1, SVOP);
3352 svop->op_type = (OPCODE)type;
3353 svop->op_ppaddr = PL_ppaddr[type];
3355 svop->op_next = (OP*)svop;
3356 svop->op_flags = (U8)flags;
3357 if (PL_opargs[type] & OA_RETSCALAR)
3359 if (PL_opargs[type] & OA_TARGET)
3360 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3361 return CHECKOP(type, svop);
3365 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3369 NewOp(1101, padop, 1, PADOP);
3370 padop->op_type = (OPCODE)type;
3371 padop->op_ppaddr = PL_ppaddr[type];
3372 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3373 SvREFCNT_dec(PAD_SVl(padop->op_padix));
3374 PAD_SETSV(padop->op_padix, sv);
3377 padop->op_next = (OP*)padop;
3378 padop->op_flags = (U8)flags;
3379 if (PL_opargs[type] & OA_RETSCALAR)
3381 if (PL_opargs[type] & OA_TARGET)
3382 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3383 return CHECKOP(type, padop);
3387 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3393 return newPADOP(type, flags, SvREFCNT_inc_simple(gv));
3395 return newSVOP(type, flags, SvREFCNT_inc_simple(gv));
3400 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3404 NewOp(1101, pvop, 1, PVOP);
3405 pvop->op_type = (OPCODE)type;
3406 pvop->op_ppaddr = PL_ppaddr[type];
3408 pvop->op_next = (OP*)pvop;
3409 pvop->op_flags = (U8)flags;
3410 if (PL_opargs[type] & OA_RETSCALAR)
3412 if (PL_opargs[type] & OA_TARGET)
3413 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3414 return CHECKOP(type, pvop);
3422 Perl_package(pTHX_ OP *o)
3431 save_hptr(&PL_curstash);
3432 save_item(PL_curstname);
3434 name = SvPV_const(cSVOPo->op_sv, len);
3435 PL_curstash = gv_stashpvn(name, len, TRUE);
3436 sv_setpvn(PL_curstname, name, len);
3438 PL_hints |= HINT_BLOCK_SCOPE;
3439 PL_copline = NOLINE;
3445 if (!PL_madskills) {
3450 pegop = newOP(OP_NULL,0);
3451 op_getmad(o,pegop,'P');
3461 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3468 OP *pegop = newOP(OP_NULL,0);
3471 if (idop->op_type != OP_CONST)
3472 Perl_croak(aTHX_ "Module name must be constant");
3475 op_getmad(idop,pegop,'U');
3480 SV * const vesv = ((SVOP*)version)->op_sv;
3483 op_getmad(version,pegop,'V');
3484 if (!arg && !SvNIOKp(vesv)) {
3491 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3492 Perl_croak(aTHX_ "Version number must be constant number");
3494 /* Make copy of idop so we don't free it twice */
3495 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3497 /* Fake up a method call to VERSION */
3498 meth = newSVpvs_share("VERSION");
3499 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3500 append_elem(OP_LIST,
3501 prepend_elem(OP_LIST, pack, list(version)),
3502 newSVOP(OP_METHOD_NAMED, 0, meth)));
3506 /* Fake up an import/unimport */
3507 if (arg && arg->op_type == OP_STUB) {
3509 op_getmad(arg,pegop,'S');
3510 imop = arg; /* no import on explicit () */
3512 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3513 imop = NULL; /* use 5.0; */
3515 idop->op_private |= OPpCONST_NOVER;
3521 op_getmad(arg,pegop,'A');
3523 /* Make copy of idop so we don't free it twice */
3524 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3526 /* Fake up a method call to import/unimport */
3528 ? newSVpvs_share("import") : newSVpvs_share("unimport");
3529 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3530 append_elem(OP_LIST,
3531 prepend_elem(OP_LIST, pack, list(arg)),
3532 newSVOP(OP_METHOD_NAMED, 0, meth)));
3535 /* Fake up the BEGIN {}, which does its thing immediately. */
3537 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
3540 append_elem(OP_LINESEQ,
3541 append_elem(OP_LINESEQ,
3542 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
3543 newSTATEOP(0, NULL, veop)),
3544 newSTATEOP(0, NULL, imop) ));
3546 /* The "did you use incorrect case?" warning used to be here.
3547 * The problem is that on case-insensitive filesystems one
3548 * might get false positives for "use" (and "require"):
3549 * "use Strict" or "require CARP" will work. This causes
3550 * portability problems for the script: in case-strict
3551 * filesystems the script will stop working.
3553 * The "incorrect case" warning checked whether "use Foo"
3554 * imported "Foo" to your namespace, but that is wrong, too:
3555 * there is no requirement nor promise in the language that
3556 * a Foo.pm should or would contain anything in package "Foo".
3558 * There is very little Configure-wise that can be done, either:
3559 * the case-sensitivity of the build filesystem of Perl does not
3560 * help in guessing the case-sensitivity of the runtime environment.
3563 PL_hints |= HINT_BLOCK_SCOPE;
3564 PL_copline = NOLINE;
3566 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3569 if (!PL_madskills) {
3570 /* FIXME - don't allocate pegop if !PL_madskills */
3579 =head1 Embedding Functions
3581 =for apidoc load_module
3583 Loads the module whose name is pointed to by the string part of name.
3584 Note that the actual module name, not its filename, should be given.
3585 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3586 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3587 (or 0 for no flags). ver, if specified, provides version semantics
3588 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3589 arguments can be used to specify arguments to the module's import()
3590 method, similar to C<use Foo::Bar VERSION LIST>.
3595 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3598 va_start(args, ver);
3599 vload_module(flags, name, ver, &args);
3603 #ifdef PERL_IMPLICIT_CONTEXT
3605 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3609 va_start(args, ver);
3610 vload_module(flags, name, ver, &args);
3616 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3621 OP * const modname = newSVOP(OP_CONST, 0, name);
3622 modname->op_private |= OPpCONST_BARE;
3624 veop = newSVOP(OP_CONST, 0, ver);
3628 if (flags & PERL_LOADMOD_NOIMPORT) {
3629 imop = sawparens(newNULLLIST());
3631 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3632 imop = va_arg(*args, OP*);
3637 sv = va_arg(*args, SV*);
3639 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3640 sv = va_arg(*args, SV*);
3644 const line_t ocopline = PL_copline;
3645 COP * const ocurcop = PL_curcop;
3646 const int oexpect = PL_expect;
3648 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3649 veop, modname, imop);
3650 PL_expect = oexpect;
3651 PL_copline = ocopline;
3652 PL_curcop = ocurcop;
3657 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
3663 if (!force_builtin) {
3664 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
3665 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
3666 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
3667 gv = gvp ? *gvp : NULL;
3671 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3672 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3673 append_elem(OP_LIST, term,
3674 scalar(newUNOP(OP_RV2CV, 0,
3675 newGVOP(OP_GV, 0, gv))))));
3678 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3684 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3686 return newBINOP(OP_LSLICE, flags,
3687 list(force_list(subscript)),
3688 list(force_list(listval)) );
3692 S_is_list_assignment(pTHX_ register const OP *o)
3700 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
3701 o = cUNOPo->op_first;
3703 flags = o->op_flags;
3705 if (type == OP_COND_EXPR) {
3706 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
3707 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3712 yyerror("Assignment to both a list and a scalar");
3716 if (type == OP_LIST &&
3717 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
3718 o->op_private & OPpLVAL_INTRO)
3721 if (type == OP_LIST || flags & OPf_PARENS ||
3722 type == OP_RV2AV || type == OP_RV2HV ||
3723 type == OP_ASLICE || type == OP_HSLICE)
3726 if (type == OP_PADAV || type == OP_PADHV)
3729 if (type == OP_RV2SV)
3736 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3742 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3743 return newLOGOP(optype, 0,
3744 mod(scalar(left), optype),
3745 newUNOP(OP_SASSIGN, 0, scalar(right)));
3748 return newBINOP(optype, OPf_STACKED,
3749 mod(scalar(left), optype), scalar(right));
3753 if (is_list_assignment(left)) {
3757 /* Grandfathering $[ assignment here. Bletch.*/
3758 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
3759 PL_eval_start = (left->op_type == OP_CONST) ? right : 0;
3760 left = mod(left, OP_AASSIGN);
3763 else if (left->op_type == OP_CONST) {
3765 /* Result of assignment is always 1 (or we'd be dead already) */
3766 return newSVOP(OP_CONST, 0, newSViv(1));
3768 curop = list(force_list(left));
3769 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3770 o->op_private = (U8)(0 | (flags >> 8));
3772 /* PL_generation sorcery:
3773 * an assignment like ($a,$b) = ($c,$d) is easier than
3774 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3775 * To detect whether there are common vars, the global var
3776 * PL_generation is incremented for each assign op we compile.
3777 * Then, while compiling the assign op, we run through all the
3778 * variables on both sides of the assignment, setting a spare slot
3779 * in each of them to PL_generation. If any of them already have
3780 * that value, we know we've got commonality. We could use a
3781 * single bit marker, but then we'd have to make 2 passes, first
3782 * to clear the flag, then to test and set it. To find somewhere
3783 * to store these values, evil chicanery is done with SvCUR().
3789 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3790 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3791 if (curop->op_type == OP_GV) {
3792 GV *gv = cGVOPx_gv(curop);
3794 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
3796 GvASSIGN_GENERATION_set(gv, PL_generation);
3798 else if (curop->op_type == OP_PADSV ||
3799 curop->op_type == OP_PADAV ||
3800 curop->op_type == OP_PADHV ||
3801 curop->op_type == OP_PADANY)
3803 if (PAD_COMPNAME_GEN(curop->op_targ)
3804 == (STRLEN)PL_generation)
3806 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
3809 else if (curop->op_type == OP_RV2CV)
3811 else if (curop->op_type == OP_RV2SV ||
3812 curop->op_type == OP_RV2AV ||
3813 curop->op_type == OP_RV2HV ||
3814 curop->op_type == OP_RV2GV) {
3815 if (lastop->op_type != OP_GV) /* funny deref? */
3818 else if (curop->op_type == OP_PUSHRE) {
3819 if (((PMOP*)curop)->op_pmreplroot) {
3821 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3822 ((PMOP*)curop)->op_pmreplroot));
3824 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3827 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
3829 GvASSIGN_GENERATION_set(gv, PL_generation);
3830 GvASSIGN_GENERATION_set(gv, PL_generation);
3839 o->op_private |= OPpASSIGN_COMMON;
3842 if ( ((left->op_private & OPpLVAL_INTRO) || ckWARN(WARN_MISC))
3843 && (left->op_type == OP_LIST
3844 || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
3846 OP* lop = ((LISTOP*)left)->op_first;
3848 if (lop->op_type == OP_PADSV ||
3849 lop->op_type == OP_PADAV ||
3850 lop->op_type == OP_PADHV ||
3851 lop->op_type == OP_PADANY)
3853 if (lop->op_private & OPpPAD_STATE) {
3854 if (left->op_private & OPpLVAL_INTRO) {
3855 o->op_private |= OPpASSIGN_STATE;
3856 /* hijacking PADSTALE for uninitialized state variables */
3857 SvPADSTALE_on(PAD_SVl(lop->op_targ));
3859 else { /* we already checked for WARN_MISC before */
3860 Perl_warner(aTHX_ packWARN(WARN_MISC), "State variable %s will be reinitialized",
3861 PAD_COMPNAME_PV(lop->op_targ));
3865 lop = lop->op_sibling;
3869 if (right && right->op_type == OP_SPLIT) {
3870 OP* tmpop = ((LISTOP*)right)->op_first;
3871 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
3872 PMOP * const pm = (PMOP*)tmpop;
3873 if (left->op_type == OP_RV2AV &&
3874 !(left->op_private & OPpLVAL_INTRO) &&
3875 !(o->op_private & OPpASSIGN_COMMON) )
3877 tmpop = ((UNOP*)left)->op_first;
3878 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3880 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3881 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3883 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3884 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
3886 pm->op_pmflags |= PMf_ONCE;
3887 tmpop = cUNOPo->op_first; /* to list (nulled) */
3888 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3889 tmpop->op_sibling = NULL; /* don't free split */
3890 right->op_next = tmpop->op_next; /* fix starting loc */
3892 op_getmad(o,right,'R'); /* blow off assign */
3894 op_free(o); /* blow off assign */
3896 right->op_flags &= ~OPf_WANT;
3897 /* "I don't know and I don't care." */
3902 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3903 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3905 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3907 sv_setiv(sv, PL_modcount+1);
3915 right = newOP(OP_UNDEF, 0);
3916 if (right->op_type == OP_READLINE) {
3917 right->op_flags |= OPf_STACKED;
3918 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3921 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3922 o = newBINOP(OP_SASSIGN, flags,
3923 scalar(right), mod(scalar(left), OP_SASSIGN) );
3929 o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
3930 o->op_private |= OPpCONST_ARYBASE;
3937 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3940 const U32 seq = intro_my();
3943 NewOp(1101, cop, 1, COP);
3944 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3945 cop->op_type = OP_DBSTATE;
3946 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3949 cop->op_type = OP_NEXTSTATE;
3950 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3952 cop->op_flags = (U8)flags;
3953 CopHINTS_set(cop, PL_hints);
3955 cop->op_private |= NATIVE_HINTS;
3957 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
3958 cop->op_next = (OP*)cop;
3961 cop->cop_label = label;
3962 PL_hints |= HINT_BLOCK_SCOPE;
3965 /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
3966 CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
3968 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
3969 cop->cop_hints_hash = PL_curcop->cop_hints_hash;
3970 if (cop->cop_hints_hash) {
3972 cop->cop_hints_hash->refcounted_he_refcnt++;
3973 HINTS_REFCNT_UNLOCK;
3976 if (PL_copline == NOLINE)
3977 CopLINE_set(cop, CopLINE(PL_curcop));
3979 CopLINE_set(cop, PL_copline);
3980 PL_copline = NOLINE;
3983 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
3985 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3987 CopSTASH_set(cop, PL_curstash);
3989 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3990 SV * const * const svp = av_fetch(CopFILEAVx(PL_curcop), (I32)CopLINE(cop), FALSE);
3991 if (svp && *svp != &PL_sv_undef ) {
3992 (void)SvIOK_on(*svp);
3993 SvIV_set(*svp, PTR2IV(cop));
3997 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
4002 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
4005 return new_logop(type, flags, &first, &other);
4009 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
4014 OP *first = *firstp;
4015 OP * const other = *otherp;
4017 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
4018 return newBINOP(type, flags, scalar(first), scalar(other));
4020 scalarboolean(first);
4021 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
4022 if (first->op_type == OP_NOT
4023 && (first->op_flags & OPf_SPECIAL)
4024 && (first->op_flags & OPf_KIDS)) {
4025 if (type == OP_AND || type == OP_OR) {
4031 first = *firstp = cUNOPo->op_first;
4033 first->op_next = o->op_next;
4034 cUNOPo->op_first = NULL;
4036 op_getmad(o,first,'O');
4042 if (first->op_type == OP_CONST) {
4043 if (first->op_private & OPpCONST_STRICT)
4044 no_bareword_allowed(first);
4045 else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
4046 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
4047 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
4048 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
4049 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
4051 if (other->op_type == OP_CONST)
4052 other->op_private |= OPpCONST_SHORTCIRCUIT;
4054 OP *newop = newUNOP(OP_NULL, 0, other);
4055 op_getmad(first, newop, '1');
4056 newop->op_targ = type; /* set "was" field */
4063 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
4064 const OP *o2 = other;
4065 if ( ! (o2->op_type == OP_LIST
4066 && (( o2 = cUNOPx(o2)->op_first))
4067 && o2->op_type == OP_PUSHMARK
4068 && (( o2 = o2->op_sibling)) )
4071 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
4072 || o2->op_type == OP_PADHV)
4073 && o2->op_private & OPpLVAL_INTRO
4074 && ckWARN(WARN_DEPRECATED))
4076 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4077 "Deprecated use of my() in false conditional");
4081 if (first->op_type == OP_CONST)
4082 first->op_private |= OPpCONST_SHORTCIRCUIT;
4084 first = newUNOP(OP_NULL, 0, first);
4085 op_getmad(other, first, '2');
4086 first->op_targ = type; /* set "was" field */
4093 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
4094 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
4096 const OP * const k1 = ((UNOP*)first)->op_first;
4097 const OP * const k2 = k1->op_sibling;
4099 switch (first->op_type)
4102 if (k2 && k2->op_type == OP_READLINE
4103 && (k2->op_flags & OPf_STACKED)
4104 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4106 warnop = k2->op_type;
4111 if (k1->op_type == OP_READDIR
4112 || k1->op_type == OP_GLOB
4113 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4114 || k1->op_type == OP_EACH)
4116 warnop = ((k1->op_type == OP_NULL)
4117 ? (OPCODE)k1->op_targ : k1->op_type);
4122 const line_t oldline = CopLINE(PL_curcop);
4123 CopLINE_set(PL_curcop, PL_copline);
4124 Perl_warner(aTHX_ packWARN(WARN_MISC),
4125 "Value of %s%s can be \"0\"; test with defined()",
4127 ((warnop == OP_READLINE || warnop == OP_GLOB)
4128 ? " construct" : "() operator"));
4129 CopLINE_set(PL_curcop, oldline);
4136 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
4137 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
4139 NewOp(1101, logop, 1, LOGOP);
4141 logop->op_type = (OPCODE)type;
4142 logop->op_ppaddr = PL_ppaddr[type];
4143 logop->op_first = first;
4144 logop->op_flags = (U8)(flags | OPf_KIDS);
4145 logop->op_other = LINKLIST(other);
4146 logop->op_private = (U8)(1 | (flags >> 8));
4148 /* establish postfix order */
4149 logop->op_next = LINKLIST(first);
4150 first->op_next = (OP*)logop;
4151 first->op_sibling = other;
4153 CHECKOP(type,logop);
4155 o = newUNOP(OP_NULL, 0, (OP*)logop);
4162 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
4170 return newLOGOP(OP_AND, 0, first, trueop);
4172 return newLOGOP(OP_OR, 0, first, falseop);
4174 scalarboolean(first);
4175 if (first->op_type == OP_CONST) {
4176 if (first->op_private & OPpCONST_BARE &&
4177 first->op_private & OPpCONST_STRICT) {
4178 no_bareword_allowed(first);
4180 if (SvTRUE(((SVOP*)first)->op_sv)) {
4183 trueop = newUNOP(OP_NULL, 0, trueop);
4184 op_getmad(first,trueop,'C');
4185 op_getmad(falseop,trueop,'e');
4187 /* FIXME for MAD - should there be an ELSE here? */
4197 falseop = newUNOP(OP_NULL, 0, falseop);
4198 op_getmad(first,falseop,'C');
4199 op_getmad(trueop,falseop,'t');
4201 /* FIXME for MAD - should there be an ELSE here? */
4209 NewOp(1101, logop, 1, LOGOP);
4210 logop->op_type = OP_COND_EXPR;
4211 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4212 logop->op_first = first;
4213 logop->op_flags = (U8)(flags | OPf_KIDS);
4214 logop->op_private = (U8)(1 | (flags >> 8));
4215 logop->op_other = LINKLIST(trueop);
4216 logop->op_next = LINKLIST(falseop);
4218 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
4221 /* establish postfix order */
4222 start = LINKLIST(first);
4223 first->op_next = (OP*)logop;
4225 first->op_sibling = trueop;
4226 trueop->op_sibling = falseop;
4227 o = newUNOP(OP_NULL, 0, (OP*)logop);
4229 trueop->op_next = falseop->op_next = o;
4236 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4245 NewOp(1101, range, 1, LOGOP);
4247 range->op_type = OP_RANGE;
4248 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4249 range->op_first = left;
4250 range->op_flags = OPf_KIDS;
4251 leftstart = LINKLIST(left);
4252 range->op_other = LINKLIST(right);
4253 range->op_private = (U8)(1 | (flags >> 8));
4255 left->op_sibling = right;
4257 range->op_next = (OP*)range;
4258 flip = newUNOP(OP_FLIP, flags, (OP*)range);
4259 flop = newUNOP(OP_FLOP, 0, flip);
4260 o = newUNOP(OP_NULL, 0, flop);
4262 range->op_next = leftstart;
4264 left->op_next = flip;
4265 right->op_next = flop;
4267 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4268 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4269 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4270 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4272 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4273 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4276 if (!flip->op_private || !flop->op_private)
4277 linklist(o); /* blow off optimizer unless constant */
4283 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4288 const bool once = block && block->op_flags & OPf_SPECIAL &&
4289 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4291 PERL_UNUSED_ARG(debuggable);
4294 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4295 return block; /* do {} while 0 does once */
4296 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4297 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4298 expr = newUNOP(OP_DEFINED, 0,
4299 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4300 } else if (expr->op_flags & OPf_KIDS) {
4301 const OP * const k1 = ((UNOP*)expr)->op_first;
4302 const OP * const k2 = k1 ? k1->op_sibling : NULL;
4303 switch (expr->op_type) {
4305 if (k2 && k2->op_type == OP_READLINE
4306 && (k2->op_flags & OPf_STACKED)
4307 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4308 expr = newUNOP(OP_DEFINED, 0, expr);
4312 if (k1 && (k1->op_type == OP_READDIR
4313 || k1->op_type == OP_GLOB
4314 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4315 || k1->op_type == OP_EACH))
4316 expr = newUNOP(OP_DEFINED, 0, expr);
4322 /* if block is null, the next append_elem() would put UNSTACK, a scalar
4323 * op, in listop. This is wrong. [perl #27024] */
4325 block = newOP(OP_NULL, 0);
4326 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4327 o = new_logop(OP_AND, 0, &expr, &listop);
4330 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4332 if (once && o != listop)
4333 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4336 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
4338 o->op_flags |= flags;
4340 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4345 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
4346 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
4355 PERL_UNUSED_ARG(debuggable);
4358 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4359 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4360 expr = newUNOP(OP_DEFINED, 0,
4361 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4362 } else if (expr->op_flags & OPf_KIDS) {
4363 const OP * const k1 = ((UNOP*)expr)->op_first;
4364 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
4365 switch (expr->op_type) {
4367 if (k2 && k2->op_type == OP_READLINE
4368 && (k2->op_flags & OPf_STACKED)
4369 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4370 expr = newUNOP(OP_DEFINED, 0, expr);
4374 if (k1 && (k1->op_type == OP_READDIR
4375 || k1->op_type == OP_GLOB
4376 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4377 || k1->op_type == OP_EACH))
4378 expr = newUNOP(OP_DEFINED, 0, expr);
4385 block = newOP(OP_NULL, 0);
4386 else if (cont || has_my) {
4387 block = scope(block);
4391 next = LINKLIST(cont);
4394 OP * const unstack = newOP(OP_UNSTACK, 0);
4397 cont = append_elem(OP_LINESEQ, cont, unstack);
4401 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4403 redo = LINKLIST(listop);
4406 PL_copline = (line_t)whileline;
4408 o = new_logop(OP_AND, 0, &expr, &listop);
4409 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4410 op_free(expr); /* oops, it's a while (0) */
4412 return NULL; /* listop already freed by new_logop */
4415 ((LISTOP*)listop)->op_last->op_next =
4416 (o == listop ? redo : LINKLIST(o));
4422 NewOp(1101,loop,1,LOOP);
4423 loop->op_type = OP_ENTERLOOP;
4424 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4425 loop->op_private = 0;
4426 loop->op_next = (OP*)loop;
4429 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4431 loop->op_redoop = redo;
4432 loop->op_lastop = o;
4433 o->op_private |= loopflags;
4436 loop->op_nextop = next;
4438 loop->op_nextop = o;
4440 o->op_flags |= flags;
4441 o->op_private |= (flags >> 8);
4446 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
4451 PADOFFSET padoff = 0;
4457 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4458 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
4459 sv->op_type = OP_RV2GV;
4460 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4461 if (cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
4462 iterpflags |= OPpITER_DEF;
4464 else if (sv->op_type == OP_PADSV) { /* private variable */
4465 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
4466 padoff = sv->op_targ;
4475 else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4476 padoff = sv->op_targ;
4481 iterflags |= OPf_SPECIAL;
4487 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4488 if (padoff && strEQ(PAD_COMPNAME_PV(padoff), "$_"))
4489 iterpflags |= OPpITER_DEF;
4492 const PADOFFSET offset = pad_findmy("$_");
4493 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
4494 sv = newGVOP(OP_GV, 0, PL_defgv);
4499 iterpflags |= OPpITER_DEF;
4501 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4502 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4503 iterflags |= OPf_STACKED;
4505 else if (expr->op_type == OP_NULL &&
4506 (expr->op_flags & OPf_KIDS) &&
4507 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4509 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4510 * set the STACKED flag to indicate that these values are to be
4511 * treated as min/max values by 'pp_iterinit'.
4513 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4514 LOGOP* const range = (LOGOP*) flip->op_first;
4515 OP* const left = range->op_first;
4516 OP* const right = left->op_sibling;
4519 range->op_flags &= ~OPf_KIDS;
4520 range->op_first = NULL;
4522 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4523 listop->op_first->op_next = range->op_next;
4524 left->op_next = range->op_other;
4525 right->op_next = (OP*)listop;
4526 listop->op_next = listop->op_first;
4529 op_getmad(expr,(OP*)listop,'O');
4533 expr = (OP*)(listop);
4535 iterflags |= OPf_STACKED;
4538 expr = mod(force_list(expr), OP_GREPSTART);
4541 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4542 append_elem(OP_LIST, expr, scalar(sv))));
4543 assert(!loop->op_next);
4544 /* for my $x () sets OPpLVAL_INTRO;
4545 * for our $x () sets OPpOUR_INTRO */
4546 loop->op_private = (U8)iterpflags;
4547 #ifdef PL_OP_SLAB_ALLOC
4550 NewOp(1234,tmp,1,LOOP);
4551 Copy(loop,tmp,1,LISTOP);
4556 loop = PerlMemShared_realloc(loop, sizeof(LOOP));
4558 loop->op_targ = padoff;
4559 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
4561 op_getmad(madsv, (OP*)loop, 'v');
4562 PL_copline = forline;
4563 return newSTATEOP(0, label, wop);
4567 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4572 if (type != OP_GOTO || label->op_type == OP_CONST) {
4573 /* "last()" means "last" */
4574 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4575 o = newOP(type, OPf_SPECIAL);
4577 o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4578 ? SvPVx_nolen_const(((SVOP*)label)->op_sv)
4582 op_getmad(label,o,'L');
4588 /* Check whether it's going to be a goto &function */
4589 if (label->op_type == OP_ENTERSUB
4590 && !(label->op_flags & OPf_STACKED))
4591 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4592 o = newUNOP(type, OPf_STACKED, label);
4594 PL_hints |= HINT_BLOCK_SCOPE;
4598 /* if the condition is a literal array or hash
4599 (or @{ ... } etc), make a reference to it.
4602 S_ref_array_or_hash(pTHX_ OP *cond)
4605 && (cond->op_type == OP_RV2AV
4606 || cond->op_type == OP_PADAV
4607 || cond->op_type == OP_RV2HV
4608 || cond->op_type == OP_PADHV))
4610 return newUNOP(OP_REFGEN,
4611 0, mod(cond, OP_REFGEN));
4617 /* These construct the optree fragments representing given()
4620 entergiven and enterwhen are LOGOPs; the op_other pointer
4621 points up to the associated leave op. We need this so we
4622 can put it in the context and make break/continue work.
4623 (Also, of course, pp_enterwhen will jump straight to
4624 op_other if the match fails.)
4629 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
4630 I32 enter_opcode, I32 leave_opcode,
4631 PADOFFSET entertarg)
4637 NewOp(1101, enterop, 1, LOGOP);
4638 enterop->op_type = enter_opcode;
4639 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
4640 enterop->op_flags = (U8) OPf_KIDS;
4641 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
4642 enterop->op_private = 0;
4644 o = newUNOP(leave_opcode, 0, (OP *) enterop);
4647 enterop->op_first = scalar(cond);
4648 cond->op_sibling = block;
4650 o->op_next = LINKLIST(cond);
4651 cond->op_next = (OP *) enterop;
4654 /* This is a default {} block */
4655 enterop->op_first = block;
4656 enterop->op_flags |= OPf_SPECIAL;
4658 o->op_next = (OP *) enterop;
4661 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
4662 entergiven and enterwhen both
4665 enterop->op_next = LINKLIST(block);
4666 block->op_next = enterop->op_other = o;
4671 /* Does this look like a boolean operation? For these purposes
4672 a boolean operation is:
4673 - a subroutine call [*]
4674 - a logical connective
4675 - a comparison operator
4676 - a filetest operator, with the exception of -s -M -A -C
4677 - defined(), exists() or eof()
4678 - /$re/ or $foo =~ /$re/
4680 [*] possibly surprising
4684 S_looks_like_bool(pTHX_ const OP *o)
4687 switch(o->op_type) {
4689 return looks_like_bool(cLOGOPo->op_first);
4693 looks_like_bool(cLOGOPo->op_first)
4694 && looks_like_bool(cLOGOPo->op_first->op_sibling));
4698 case OP_NOT: case OP_XOR:
4699 /* Note that OP_DOR is not here */
4701 case OP_EQ: case OP_NE: case OP_LT:
4702 case OP_GT: case OP_LE: case OP_GE:
4704 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
4705 case OP_I_GT: case OP_I_LE: case OP_I_GE:
4707 case OP_SEQ: case OP_SNE: case OP_SLT:
4708 case OP_SGT: case OP_SLE: case OP_SGE:
4712 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
4713 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
4714 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
4715 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
4716 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
4717 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
4718 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
4719 case OP_FTTEXT: case OP_FTBINARY:
4721 case OP_DEFINED: case OP_EXISTS:
4722 case OP_MATCH: case OP_EOF:
4727 /* Detect comparisons that have been optimized away */
4728 if (cSVOPo->op_sv == &PL_sv_yes
4729 || cSVOPo->op_sv == &PL_sv_no)
4740 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
4744 return newGIVWHENOP(
4745 ref_array_or_hash(cond),
4747 OP_ENTERGIVEN, OP_LEAVEGIVEN,
4751 /* If cond is null, this is a default {} block */
4753 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
4755 const bool cond_llb = (!cond || looks_like_bool(cond));
4761 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
4763 scalar(ref_array_or_hash(cond)));
4766 return newGIVWHENOP(
4768 append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
4769 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
4773 =for apidoc cv_undef
4775 Clear out all the active components of a CV. This can happen either
4776 by an explicit C<undef &foo>, or by the reference count going to zero.
4777 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
4778 children can still follow the full lexical scope chain.
4784 Perl_cv_undef(pTHX_ CV *cv)
4788 if (CvFILE(cv) && !CvISXSUB(cv)) {
4789 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4790 Safefree(CvFILE(cv));
4795 if (!CvISXSUB(cv) && CvROOT(cv)) {
4796 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
4797 Perl_croak(aTHX_ "Can't undef active subroutine");
4800 PAD_SAVE_SETNULLPAD();
4802 op_free(CvROOT(cv));
4807 SvPOK_off((SV*)cv); /* forget prototype */
4812 /* remove CvOUTSIDE unless this is an undef rather than a free */
4813 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
4814 if (!CvWEAKOUTSIDE(cv))
4815 SvREFCNT_dec(CvOUTSIDE(cv));
4816 CvOUTSIDE(cv) = NULL;
4819 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4822 if (CvISXSUB(cv) && CvXSUB(cv)) {
4825 /* delete all flags except WEAKOUTSIDE */
4826 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
4830 Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
4833 /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
4834 relying on SvCUR, and doubling up the buffer to hold CvFILE(). */
4835 if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
4836 || (p && (len != SvCUR(cv) /* Not the same length. */
4837 || memNE(p, SvPVX_const(cv), len))))
4838 && ckWARN_d(WARN_PROTOTYPE)) {
4839 SV* const msg = sv_newmortal();
4843 gv_efullname3(name = sv_newmortal(), gv, NULL);
4844 sv_setpv(msg, "Prototype mismatch:");
4846 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, (void*)name);
4848 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (void*)cv);
4850 sv_catpvs(msg, ": none");
4851 sv_catpvs(msg, " vs ");
4853 Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
4855 sv_catpvs(msg, "none");
4856 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, (void*)msg);
4860 static void const_sv_xsub(pTHX_ CV* cv);
4864 =head1 Optree Manipulation Functions
4866 =for apidoc cv_const_sv
4868 If C<cv> is a constant sub eligible for inlining. returns the constant
4869 value returned by the sub. Otherwise, returns NULL.
4871 Constant subs can be created with C<newCONSTSUB> or as described in
4872 L<perlsub/"Constant Functions">.
4877 Perl_cv_const_sv(pTHX_ CV *cv)
4879 PERL_UNUSED_CONTEXT;
4882 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
4884 return CvCONST(cv) ? (SV*)CvXSUBANY(cv).any_ptr : NULL;
4887 /* op_const_sv: examine an optree to determine whether it's in-lineable.
4888 * Can be called in 3 ways:
4891 * look for a single OP_CONST with attached value: return the value
4893 * cv && CvCLONE(cv) && !CvCONST(cv)
4895 * examine the clone prototype, and if contains only a single
4896 * OP_CONST referencing a pad const, or a single PADSV referencing
4897 * an outer lexical, return a non-zero value to indicate the CV is
4898 * a candidate for "constizing" at clone time
4902 * We have just cloned an anon prototype that was marked as a const
4903 * candidiate. Try to grab the current value, and in the case of
4904 * PADSV, ignore it if it has multiple references. Return the value.
4908 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
4916 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4917 o = cLISTOPo->op_first->op_sibling;
4919 for (; o; o = o->op_next) {
4920 const OPCODE type = o->op_type;
4922 if (sv && o->op_next == o)
4924 if (o->op_next != o) {
4925 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4927 if (type == OP_DBSTATE)
4930 if (type == OP_LEAVESUB || type == OP_RETURN)
4934 if (type == OP_CONST && cSVOPo->op_sv)
4936 else if (cv && type == OP_CONST) {
4937 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4941 else if (cv && type == OP_PADSV) {
4942 if (CvCONST(cv)) { /* newly cloned anon */
4943 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4944 /* the candidate should have 1 ref from this pad and 1 ref
4945 * from the parent */
4946 if (!sv || SvREFCNT(sv) != 2)
4953 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
4954 sv = &PL_sv_undef; /* an arbitrary non-null value */
4969 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4972 /* This would be the return value, but the return cannot be reached. */
4973 OP* pegop = newOP(OP_NULL, 0);
4976 PERL_UNUSED_ARG(floor);
4986 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4988 NORETURN_FUNCTION_END;
4993 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4995 return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
4999 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5006 register CV *cv = NULL;
5008 /* If the subroutine has no body, no attributes, and no builtin attributes
5009 then it's just a sub declaration, and we may be able to get away with
5010 storing with a placeholder scalar in the symbol table, rather than a
5011 full GV and CV. If anything is present then it will take a full CV to
5013 const I32 gv_fetch_flags
5014 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5016 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
5017 const char * const name = o ? SvPVx_nolen_const(cSVOPo->op_sv) : NULL;
5020 assert(proto->op_type == OP_CONST);
5021 ps = SvPVx_const(((SVOP*)proto)->op_sv, ps_len);
5026 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
5027 SV * const sv = sv_newmortal();
5028 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
5029 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
5030 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
5031 aname = SvPVX_const(sv);
5036 gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
5037 : gv_fetchpv(aname ? aname
5038 : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5039 gv_fetch_flags, SVt_PVCV);
5041 if (!PL_madskills) {
5050 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
5051 maximum a prototype before. */
5052 if (SvTYPE(gv) > SVt_NULL) {
5053 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
5054 && ckWARN_d(WARN_PROTOTYPE))
5056 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
5058 cv_ckproto_len((CV*)gv, NULL, ps, ps_len);
5061 sv_setpvn((SV*)gv, ps, ps_len);
5063 sv_setiv((SV*)gv, -1);
5064 SvREFCNT_dec(PL_compcv);
5065 cv = PL_compcv = NULL;
5066 PL_sub_generation++;
5070 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
5072 #ifdef GV_UNIQUE_CHECK
5073 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
5074 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
5078 if (!block || !ps || *ps || attrs
5079 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5081 || block->op_type == OP_NULL
5086 const_sv = op_const_sv(block, NULL);
5089 const bool exists = CvROOT(cv) || CvXSUB(cv);
5091 #ifdef GV_UNIQUE_CHECK
5092 if (exists && GvUNIQUE(gv)) {
5093 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
5097 /* if the subroutine doesn't exist and wasn't pre-declared
5098 * with a prototype, assume it will be AUTOLOADed,
5099 * skipping the prototype check
5101 if (exists || SvPOK(cv))
5102 cv_ckproto_len(cv, gv, ps, ps_len);
5103 /* already defined (or promised)? */
5104 if (exists || GvASSUMECV(gv)) {
5107 || block->op_type == OP_NULL
5110 if (CvFLAGS(PL_compcv)) {
5111 /* might have had built-in attrs applied */
5112 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5114 /* just a "sub foo;" when &foo is already defined */
5115 SAVEFREESV(PL_compcv);
5120 && block->op_type != OP_NULL
5123 if (ckWARN(WARN_REDEFINE)
5125 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
5127 const line_t oldline = CopLINE(PL_curcop);
5128 if (PL_copline != NOLINE)
5129 CopLINE_set(PL_curcop, PL_copline);
5130 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5131 CvCONST(cv) ? "Constant subroutine %s redefined"
5132 : "Subroutine %s redefined", name);
5133 CopLINE_set(PL_curcop, oldline);
5136 if (!PL_minus_c) /* keep old one around for madskills */
5139 /* (PL_madskills unset in used file.) */
5147 SvREFCNT_inc_simple_void_NN(const_sv);
5149 assert(!CvROOT(cv) && !CvCONST(cv));
5150 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
5151 CvXSUBANY(cv).any_ptr = const_sv;
5152 CvXSUB(cv) = const_sv_xsub;
5158 cv = newCONSTSUB(NULL, name, const_sv);
5160 PL_sub_generation++;
5164 SvREFCNT_dec(PL_compcv);
5172 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
5173 * before we clobber PL_compcv.
5177 || block->op_type == OP_NULL
5181 /* Might have had built-in attributes applied -- propagate them. */
5182 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5183 if (CvGV(cv) && GvSTASH(CvGV(cv)))
5184 stash = GvSTASH(CvGV(cv));
5185 else if (CvSTASH(cv))
5186 stash = CvSTASH(cv);
5188 stash = PL_curstash;
5191 /* possibly about to re-define existing subr -- ignore old cv */
5192 rcv = (SV*)PL_compcv;
5193 if (name && GvSTASH(gv))
5194 stash = GvSTASH(gv);
5196 stash = PL_curstash;
5198 apply_attrs(stash, rcv, attrs, FALSE);
5200 if (cv) { /* must reuse cv if autoloaded */
5207 || block->op_type == OP_NULL) && !PL_madskills
5210 /* got here with just attrs -- work done, so bug out */
5211 SAVEFREESV(PL_compcv);
5214 /* transfer PL_compcv to cv */
5216 CvFLAGS(cv) = CvFLAGS(PL_compcv);
5217 if (!CvWEAKOUTSIDE(cv))
5218 SvREFCNT_dec(CvOUTSIDE(cv));
5219 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
5220 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
5221 CvOUTSIDE(PL_compcv) = 0;
5222 CvPADLIST(cv) = CvPADLIST(PL_compcv);
5223 CvPADLIST(PL_compcv) = 0;
5224 /* inner references to PL_compcv must be fixed up ... */
5225 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
5226 /* ... before we throw it away */
5227 SvREFCNT_dec(PL_compcv);
5229 if (PERLDB_INTER)/* Advice debugger on the new sub. */
5230 ++PL_sub_generation;
5237 if (strEQ(name, "import")) {
5238 PL_formfeed = (SV*)cv;
5239 Perl_warner(aTHX_ packWARN(WARN_VOID), "%lx\n", (long)cv);
5243 PL_sub_generation++;
5247 CvFILE_set_from_cop(cv, PL_curcop);
5248 CvSTASH(cv) = PL_curstash;
5251 sv_setpvn((SV*)cv, ps, ps_len);
5253 if (PL_error_count) {
5257 const char *s = strrchr(name, ':');
5259 if (strEQ(s, "BEGIN")) {
5260 const char not_safe[] =
5261 "BEGIN not safe after errors--compilation aborted";
5262 if (PL_in_eval & EVAL_KEEPERR)
5263 Perl_croak(aTHX_ not_safe);
5265 /* force display of errors found but not reported */
5266 sv_catpv(ERRSV, not_safe);
5267 Perl_croak(aTHX_ "%"SVf, (void*)ERRSV);
5277 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5278 mod(scalarseq(block), OP_LEAVESUBLV));
5281 /* This makes sub {}; work as expected. */
5282 if (block->op_type == OP_STUB) {
5283 OP* const newblock = newSTATEOP(0, NULL, 0);
5285 op_getmad(block,newblock,'B');
5291 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5293 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5294 OpREFCNT_set(CvROOT(cv), 1);
5295 CvSTART(cv) = LINKLIST(CvROOT(cv));
5296 CvROOT(cv)->op_next = 0;
5297 CALL_PEEP(CvSTART(cv));
5299 /* now that optimizer has done its work, adjust pad values */
5301 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
5304 assert(!CvCONST(cv));
5305 if (ps && !*ps && op_const_sv(block, cv))
5309 if (name || aname) {
5311 const char * const tname = (name ? name : aname);
5313 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5314 SV * const sv = newSV(0);
5315 SV * const tmpstr = sv_newmortal();
5316 GV * const db_postponed = gv_fetchpvs("DB::postponed",
5317 GV_ADDMULTI, SVt_PVHV);
5320 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5322 (long)PL_subline, (long)CopLINE(PL_curcop));
5323 gv_efullname3(tmpstr, gv, NULL);
5324 hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0);
5325 hv = GvHVn(db_postponed);
5326 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
5327 CV * const pcv = GvCV(db_postponed);
5333 call_sv((SV*)pcv, G_DISCARD);
5338 if ((s = strrchr(tname,':')))
5343 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5346 if (strEQ(s, "BEGIN") && !PL_error_count) {
5347 const I32 oldscope = PL_scopestack_ix;
5349 SAVECOPFILE(&PL_compiling);
5350 SAVECOPLINE(&PL_compiling);
5353 PL_beginav = newAV();
5354 DEBUG_x( dump_sub(gv) );
5355 av_push(PL_beginav, (SV*)cv);
5356 GvCV(gv) = 0; /* cv has been hijacked */
5357 call_list(oldscope, PL_beginav);
5359 PL_curcop = &PL_compiling;
5360 CopHINTS_set(&PL_compiling, PL_hints);
5363 else if (strEQ(s, "END") && !PL_error_count) {
5366 DEBUG_x( dump_sub(gv) );
5367 av_unshift(PL_endav, 1);
5368 av_store(PL_endav, 0, (SV*)cv);
5369 GvCV(gv) = 0; /* cv has been hijacked */
5371 else if (strEQ(s, "CHECK") && !PL_error_count) {
5373 PL_checkav = newAV();
5374 DEBUG_x( dump_sub(gv) );
5375 if (PL_main_start && ckWARN(WARN_VOID))
5376 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
5377 av_unshift(PL_checkav, 1);
5378 av_store(PL_checkav, 0, (SV*)cv);
5379 GvCV(gv) = 0; /* cv has been hijacked */
5381 else if (strEQ(s, "INIT") && !PL_error_count) {
5383 PL_initav = newAV();
5384 DEBUG_x( dump_sub(gv) );
5385 if (PL_main_start && ckWARN(WARN_VOID))
5386 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
5387 av_push(PL_initav, (SV*)cv);
5388 GvCV(gv) = 0; /* cv has been hijacked */
5393 PL_copline = NOLINE;
5398 /* XXX unsafe for threads if eval_owner isn't held */
5400 =for apidoc newCONSTSUB
5402 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5403 eligible for inlining at compile-time.
5409 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
5414 const char *const temp_p = CopFILE(PL_curcop);
5415 const STRLEN len = temp_p ? strlen(temp_p) : 0;
5417 SV *const temp_sv = CopFILESV(PL_curcop);
5419 const char *const temp_p = temp_sv ? SvPV_const(temp_sv, len) : NULL;
5421 char *const file = savepvn(temp_p, temp_p ? len : 0);
5425 SAVECOPLINE(PL_curcop);
5426 CopLINE_set(PL_curcop, PL_copline);
5429 PL_hints &= ~HINT_BLOCK_SCOPE;
5432 SAVESPTR(PL_curstash);
5433 SAVECOPSTASH(PL_curcop);
5434 PL_curstash = stash;
5435 CopSTASH_set(PL_curcop,stash);
5438 /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
5439 and so doesn't get free()d. (It's expected to be from the C pre-
5440 processor __FILE__ directive). But we need a dynamically allocated one,
5441 and we need it to get freed. */
5442 cv = newXS_flags(name, const_sv_xsub, file, "", XS_DYNAMIC_FILENAME);
5443 CvXSUBANY(cv).any_ptr = sv;
5448 CopSTASH_free(PL_curcop);
5456 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
5457 const char *const filename, const char *const proto,
5460 CV *cv = newXS(name, subaddr, filename);
5462 if (flags & XS_DYNAMIC_FILENAME) {
5463 /* We need to "make arrangements" (ie cheat) to ensure that the
5464 filename lasts as long as the PVCV we just created, but also doesn't
5466 STRLEN filename_len = strlen(filename);
5467 STRLEN proto_and_file_len = filename_len;
5468 char *proto_and_file;
5472 proto_len = strlen(proto);
5473 proto_and_file_len += proto_len;
5475 Newx(proto_and_file, proto_and_file_len + 1, char);
5476 Copy(proto, proto_and_file, proto_len, char);
5477 Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
5480 proto_and_file = savepvn(filename, filename_len);
5483 /* This gets free()d. :-) */
5484 sv_usepvn_flags((SV*)cv, proto_and_file, proto_and_file_len,
5485 SV_HAS_TRAILING_NUL);
5487 /* This gives us the correct prototype, rather than one with the
5488 file name appended. */
5489 SvCUR_set(cv, proto_len);
5493 CvFILE(cv) = proto_and_file + proto_len;
5495 sv_setpv((SV *)cv, proto);
5501 =for apidoc U||newXS
5503 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
5504 static storage, as it is used directly as CvFILE(), without a copy being made.
5510 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
5513 GV * const gv = gv_fetchpv(name ? name :
5514 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5515 GV_ADDMULTI, SVt_PVCV);
5519 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
5521 if ((cv = (name ? GvCV(gv) : NULL))) {
5523 /* just a cached method */
5527 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5528 /* already defined (or promised) */
5529 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
5530 if (ckWARN(WARN_REDEFINE)) {
5531 GV * const gvcv = CvGV(cv);
5533 HV * const stash = GvSTASH(gvcv);
5535 const char *redefined_name = HvNAME_get(stash);
5536 if ( strEQ(redefined_name,"autouse") ) {
5537 const line_t oldline = CopLINE(PL_curcop);
5538 if (PL_copline != NOLINE)
5539 CopLINE_set(PL_curcop, PL_copline);
5540 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5541 CvCONST(cv) ? "Constant subroutine %s redefined"
5542 : "Subroutine %s redefined"
5544 CopLINE_set(PL_curcop, oldline);
5554 if (cv) /* must reuse cv if autoloaded */
5558 sv_upgrade((SV *)cv, SVt_PVCV);
5562 PL_sub_generation++;
5566 (void)gv_fetchfile(filename);
5567 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
5568 an external constant string */
5570 CvXSUB(cv) = subaddr;
5573 const char *s = strrchr(name,':');
5579 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5582 if (strEQ(s, "BEGIN")) {
5584 PL_beginav = newAV();
5585 av_push(PL_beginav, (SV*)cv);
5586 GvCV(gv) = 0; /* cv has been hijacked */
5588 else if (strEQ(s, "END")) {
5591 av_unshift(PL_endav, 1);
5592 av_store(PL_endav, 0, (SV*)cv);
5593 GvCV(gv) = 0; /* cv has been hijacked */
5595 else if (strEQ(s, "CHECK")) {
5597 PL_checkav = newAV();
5598 if (PL_main_start && ckWARN(WARN_VOID))
5599 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
5600 av_unshift(PL_checkav, 1);
5601 av_store(PL_checkav, 0, (SV*)cv);
5602 GvCV(gv) = 0; /* cv has been hijacked */
5604 else if (strEQ(s, "INIT")) {
5606 PL_initav = newAV();
5607 if (PL_main_start && ckWARN(WARN_VOID))
5608 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
5609 av_push(PL_initav, (SV*)cv);
5610 GvCV(gv) = 0; /* cv has been hijacked */
5625 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5630 OP* pegop = newOP(OP_NULL, 0);
5634 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
5635 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
5637 #ifdef GV_UNIQUE_CHECK
5639 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5643 if ((cv = GvFORM(gv))) {
5644 if (ckWARN(WARN_REDEFINE)) {
5645 const line_t oldline = CopLINE(PL_curcop);
5646 if (PL_copline != NOLINE)
5647 CopLINE_set(PL_curcop, PL_copline);
5648 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5649 o ? "Format %"SVf" redefined"
5650 : "Format STDOUT redefined", (void*)cSVOPo->op_sv);
5651 CopLINE_set(PL_curcop, oldline);
5658 CvFILE_set_from_cop(cv, PL_curcop);
5661 pad_tidy(padtidy_FORMAT);
5662 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5663 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5664 OpREFCNT_set(CvROOT(cv), 1);
5665 CvSTART(cv) = LINKLIST(CvROOT(cv));
5666 CvROOT(cv)->op_next = 0;
5667 CALL_PEEP(CvSTART(cv));
5669 op_getmad(o,pegop,'n');
5670 op_getmad_weak(block, pegop, 'b');
5674 PL_copline = NOLINE;
5682 Perl_newANONLIST(pTHX_ OP *o)
5684 return newUNOP(OP_REFGEN, 0,
5685 mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5689 Perl_newANONHASH(pTHX_ OP *o)
5691 return newUNOP(OP_REFGEN, 0,
5692 mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5696 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5698 return newANONATTRSUB(floor, proto, NULL, block);
5702 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5704 return newUNOP(OP_REFGEN, 0,
5705 newSVOP(OP_ANONCODE, 0,
5706 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5710 Perl_oopsAV(pTHX_ OP *o)
5713 switch (o->op_type) {
5715 o->op_type = OP_PADAV;
5716 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5717 return ref(o, OP_RV2AV);
5720 o->op_type = OP_RV2AV;
5721 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5726 if (ckWARN_d(WARN_INTERNAL))
5727 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
5734 Perl_oopsHV(pTHX_ OP *o)
5737 switch (o->op_type) {
5740 o->op_type = OP_PADHV;
5741 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5742 return ref(o, OP_RV2HV);
5746 o->op_type = OP_RV2HV;
5747 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5752 if (ckWARN_d(WARN_INTERNAL))
5753 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
5760 Perl_newAVREF(pTHX_ OP *o)
5763 if (o->op_type == OP_PADANY) {
5764 o->op_type = OP_PADAV;
5765 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5768 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5769 && ckWARN(WARN_DEPRECATED)) {
5770 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5771 "Using an array as a reference is deprecated");
5773 return newUNOP(OP_RV2AV, 0, scalar(o));
5777 Perl_newGVREF(pTHX_ I32 type, OP *o)
5779 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5780 return newUNOP(OP_NULL, 0, o);
5781 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5785 Perl_newHVREF(pTHX_ OP *o)
5788 if (o->op_type == OP_PADANY) {
5789 o->op_type = OP_PADHV;
5790 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5793 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5794 && ckWARN(WARN_DEPRECATED)) {
5795 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5796 "Using a hash as a reference is deprecated");
5798 return newUNOP(OP_RV2HV, 0, scalar(o));
5802 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5804 return newUNOP(OP_RV2CV, flags, scalar(o));
5808 Perl_newSVREF(pTHX_ OP *o)
5811 if (o->op_type == OP_PADANY) {
5812 o->op_type = OP_PADSV;
5813 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5816 else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5817 o->op_flags |= OPpDONE_SVREF;
5820 return newUNOP(OP_RV2SV, 0, scalar(o));
5823 /* Check routines. See the comments at the top of this file for details
5824 * on when these are called */
5827 Perl_ck_anoncode(pTHX_ OP *o)
5829 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
5831 cSVOPo->op_sv = NULL;
5836 Perl_ck_bitop(pTHX_ OP *o)
5839 #define OP_IS_NUMCOMPARE(op) \
5840 ((op) == OP_LT || (op) == OP_I_LT || \
5841 (op) == OP_GT || (op) == OP_I_GT || \
5842 (op) == OP_LE || (op) == OP_I_LE || \
5843 (op) == OP_GE || (op) == OP_I_GE || \
5844 (op) == OP_EQ || (op) == OP_I_EQ || \
5845 (op) == OP_NE || (op) == OP_I_NE || \
5846 (op) == OP_NCMP || (op) == OP_I_NCMP)
5847 o->op_private = (U8)(PL_hints & HINT_INTEGER);
5848 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
5849 && (o->op_type == OP_BIT_OR
5850 || o->op_type == OP_BIT_AND
5851 || o->op_type == OP_BIT_XOR))
5853 const OP * const left = cBINOPo->op_first;
5854 const OP * const right = left->op_sibling;
5855 if ((OP_IS_NUMCOMPARE(left->op_type) &&
5856 (left->op_flags & OPf_PARENS) == 0) ||
5857 (OP_IS_NUMCOMPARE(right->op_type) &&
5858 (right->op_flags & OPf_PARENS) == 0))
5859 if (ckWARN(WARN_PRECEDENCE))
5860 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
5861 "Possible precedence problem on bitwise %c operator",
5862 o->op_type == OP_BIT_OR ? '|'
5863 : o->op_type == OP_BIT_AND ? '&' : '^'
5870 Perl_ck_concat(pTHX_ OP *o)
5872 const OP * const kid = cUNOPo->op_first;
5873 PERL_UNUSED_CONTEXT;
5874 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
5875 !(kUNOP->op_first->op_flags & OPf_MOD))
5876 o->op_flags |= OPf_STACKED;
5881 Perl_ck_spair(pTHX_ OP *o)
5884 if (o->op_flags & OPf_KIDS) {
5887 const OPCODE type = o->op_type;
5888 o = modkids(ck_fun(o), type);
5889 kid = cUNOPo->op_first;
5890 newop = kUNOP->op_first->op_sibling;
5892 const OPCODE type = newop->op_type;
5893 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
5894 type == OP_PADAV || type == OP_PADHV ||
5895 type == OP_RV2AV || type == OP_RV2HV)
5899 op_getmad(kUNOP->op_first,newop,'K');
5901 op_free(kUNOP->op_first);
5903 kUNOP->op_first = newop;
5905 o->op_ppaddr = PL_ppaddr[++o->op_type];
5910 Perl_ck_delete(pTHX_ OP *o)
5914 if (o->op_flags & OPf_KIDS) {
5915 OP * const kid = cUNOPo->op_first;
5916 switch (kid->op_type) {
5918 o->op_flags |= OPf_SPECIAL;
5921 o->op_private |= OPpSLICE;
5924 o->op_flags |= OPf_SPECIAL;
5929 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5938 Perl_ck_die(pTHX_ OP *o)
5941 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5947 Perl_ck_eof(pTHX_ OP *o)
5951 if (o->op_flags & OPf_KIDS) {
5952 if (cLISTOPo->op_first->op_type == OP_STUB) {
5954 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
5956 op_getmad(o,newop,'O');
5968 Perl_ck_eval(pTHX_ OP *o)
5971 PL_hints |= HINT_BLOCK_SCOPE;
5972 if (o->op_flags & OPf_KIDS) {
5973 SVOP * const kid = (SVOP*)cUNOPo->op_first;
5976 o->op_flags &= ~OPf_KIDS;
5979 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
5985 cUNOPo->op_first = 0;
5990 NewOp(1101, enter, 1, LOGOP);
5991 enter->op_type = OP_ENTERTRY;
5992 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5993 enter->op_private = 0;
5995 /* establish postfix order */
5996 enter->op_next = (OP*)enter;
5998 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5999 o->op_type = OP_LEAVETRY;
6000 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
6001 enter->op_other = o;
6002 op_getmad(oldo,o,'O');
6016 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
6017 op_getmad(oldo,o,'O');
6019 o->op_targ = (PADOFFSET)PL_hints;
6020 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
6021 /* Store a copy of %^H that pp_entereval can pick up */
6022 OP *hhop = newSVOP(OP_CONST, 0,
6023 (SV*)Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv)));
6024 cUNOPo->op_first->op_sibling = hhop;
6025 o->op_private |= OPpEVAL_HAS_HH;
6031 Perl_ck_exit(pTHX_ OP *o)
6034 HV * const table = GvHV(PL_hintgv);
6036 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
6037 if (svp && *svp && SvTRUE(*svp))
6038 o->op_private |= OPpEXIT_VMSISH;
6040 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6046 Perl_ck_exec(pTHX_ OP *o)
6048 if (o->op_flags & OPf_STACKED) {
6051 kid = cUNOPo->op_first->op_sibling;
6052 if (kid->op_type == OP_RV2GV)
6061 Perl_ck_exists(pTHX_ OP *o)
6065 if (o->op_flags & OPf_KIDS) {
6066 OP * const kid = cUNOPo->op_first;
6067 if (kid->op_type == OP_ENTERSUB) {
6068 (void) ref(kid, o->op_type);
6069 if (kid->op_type != OP_RV2CV && !PL_error_count)
6070 Perl_croak(aTHX_ "%s argument is not a subroutine name",
6072 o->op_private |= OPpEXISTS_SUB;
6074 else if (kid->op_type == OP_AELEM)
6075 o->op_flags |= OPf_SPECIAL;
6076 else if (kid->op_type != OP_HELEM)
6077 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
6085 Perl_ck_rvconst(pTHX_ register OP *o)
6088 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6090 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6091 if (o->op_type == OP_RV2CV)
6092 o->op_private &= ~1;
6094 if (kid->op_type == OP_CONST) {
6097 SV * const kidsv = kid->op_sv;
6099 /* Is it a constant from cv_const_sv()? */
6100 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
6101 SV * const rsv = SvRV(kidsv);
6102 const svtype type = SvTYPE(rsv);
6103 const char *badtype = NULL;
6105 switch (o->op_type) {
6107 if (type > SVt_PVMG)
6108 badtype = "a SCALAR";
6111 if (type != SVt_PVAV)
6112 badtype = "an ARRAY";
6115 if (type != SVt_PVHV)
6119 if (type != SVt_PVCV)
6124 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
6127 else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
6128 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
6129 /* If this is an access to a stash, disable "strict refs", because
6130 * stashes aren't auto-vivified at compile-time (unless we store
6131 * symbols in them), and we don't want to produce a run-time
6132 * stricture error when auto-vivifying the stash. */
6133 const char *s = SvPV_nolen(kidsv);
6134 const STRLEN l = SvCUR(kidsv);
6135 if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
6136 o->op_private &= ~HINT_STRICT_REFS;
6138 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
6139 const char *badthing;
6140 switch (o->op_type) {
6142 badthing = "a SCALAR";
6145 badthing = "an ARRAY";
6148 badthing = "a HASH";
6156 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
6157 (void*)kidsv, badthing);
6160 * This is a little tricky. We only want to add the symbol if we
6161 * didn't add it in the lexer. Otherwise we get duplicate strict
6162 * warnings. But if we didn't add it in the lexer, we must at
6163 * least pretend like we wanted to add it even if it existed before,
6164 * or we get possible typo warnings. OPpCONST_ENTERED says
6165 * whether the lexer already added THIS instance of this symbol.
6167 iscv = (o->op_type == OP_RV2CV) * 2;
6169 gv = gv_fetchsv(kidsv,
6170 iscv | !(kid->op_private & OPpCONST_ENTERED),
6173 : o->op_type == OP_RV2SV
6175 : o->op_type == OP_RV2AV
6177 : o->op_type == OP_RV2HV
6180 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
6182 kid->op_type = OP_GV;
6183 SvREFCNT_dec(kid->op_sv);
6185 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
6186 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
6187 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
6189 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc_simple_NN(gv));
6191 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
6193 kid->op_private = 0;
6194 kid->op_ppaddr = PL_ppaddr[OP_GV];
6201 Perl_ck_ftst(pTHX_ OP *o)
6204 const I32 type = o->op_type;
6206 if (o->op_flags & OPf_REF) {
6209 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
6210 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6211 const OPCODE kidtype = kid->op_type;
6213 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6214 OP * const newop = newGVOP(type, OPf_REF,
6215 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
6217 op_getmad(o,newop,'O');
6223 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o))
6224 o->op_private |= OPpFT_ACCESS;
6225 if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst)
6226 && kidtype != OP_STAT && kidtype != OP_LSTAT)
6227 o->op_private |= OPpFT_STACKED;
6235 if (type == OP_FTTTY)
6236 o = newGVOP(type, OPf_REF, PL_stdingv);
6238 o = newUNOP(type, 0, newDEFSVOP());
6239 op_getmad(oldo,o,'O');
6245 Perl_ck_fun(pTHX_ OP *o)
6248 const int type = o->op_type;
6249 register I32 oa = PL_opargs[type] >> OASHIFT;
6251 if (o->op_flags & OPf_STACKED) {
6252 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
6255 return no_fh_allowed(o);
6258 if (o->op_flags & OPf_KIDS) {
6259 OP **tokid = &cLISTOPo->op_first;
6260 register OP *kid = cLISTOPo->op_first;
6264 if (kid->op_type == OP_PUSHMARK ||
6265 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
6267 tokid = &kid->op_sibling;
6268 kid = kid->op_sibling;
6270 if (!kid && PL_opargs[type] & OA_DEFGV)
6271 *tokid = kid = newDEFSVOP();
6275 sibl = kid->op_sibling;
6277 if (!sibl && kid->op_type == OP_STUB) {
6284 /* list seen where single (scalar) arg expected? */
6285 if (numargs == 1 && !(oa >> 4)
6286 && kid->op_type == OP_LIST && type != OP_SCALAR)
6288 return too_many_arguments(o,PL_op_desc[type]);
6301 if ((type == OP_PUSH || type == OP_UNSHIFT)
6302 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
6303 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6304 "Useless use of %s with no values",
6307 if (kid->op_type == OP_CONST &&
6308 (kid->op_private & OPpCONST_BARE))
6310 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
6311 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
6312 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6313 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6314 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
6315 (void*)((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
6317 op_getmad(kid,newop,'K');
6322 kid->op_sibling = sibl;
6325 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
6326 bad_type(numargs, "array", PL_op_desc[type], kid);
6330 if (kid->op_type == OP_CONST &&
6331 (kid->op_private & OPpCONST_BARE))
6333 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
6334 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
6335 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6336 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6337 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
6338 (void*)((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]);
6340 op_getmad(kid,newop,'K');
6345 kid->op_sibling = sibl;
6348 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
6349 bad_type(numargs, "hash", PL_op_desc[type], kid);
6354 OP * const newop = newUNOP(OP_NULL, 0, kid);
6355 kid->op_sibling = 0;
6357 newop->op_next = newop;
6359 kid->op_sibling = sibl;
6364 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
6365 if (kid->op_type == OP_CONST &&
6366 (kid->op_private & OPpCONST_BARE))
6368 OP * const newop = newGVOP(OP_GV, 0,
6369 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
6370 if (!(o->op_private & 1) && /* if not unop */
6371 kid == cLISTOPo->op_last)
6372 cLISTOPo->op_last = newop;
6374 op_getmad(kid,newop,'K');
6380 else if (kid->op_type == OP_READLINE) {
6381 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
6382 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
6385 I32 flags = OPf_SPECIAL;
6389 /* is this op a FH constructor? */
6390 if (is_handle_constructor(o,numargs)) {
6391 const char *name = NULL;
6395 /* Set a flag to tell rv2gv to vivify
6396 * need to "prove" flag does not mean something
6397 * else already - NI-S 1999/05/07
6400 if (kid->op_type == OP_PADSV) {
6401 name = PAD_COMPNAME_PV(kid->op_targ);
6402 /* SvCUR of a pad namesv can't be trusted
6403 * (see PL_generation), so calc its length
6409 else if (kid->op_type == OP_RV2SV
6410 && kUNOP->op_first->op_type == OP_GV)
6412 GV * const gv = cGVOPx_gv(kUNOP->op_first);
6414 len = GvNAMELEN(gv);
6416 else if (kid->op_type == OP_AELEM
6417 || kid->op_type == OP_HELEM)
6420 OP *op = ((BINOP*)kid)->op_first;
6424 const char * const a =
6425 kid->op_type == OP_AELEM ?
6427 if (((op->op_type == OP_RV2AV) ||
6428 (op->op_type == OP_RV2HV)) &&
6429 (firstop = ((UNOP*)op)->op_first) &&
6430 (firstop->op_type == OP_GV)) {
6431 /* packagevar $a[] or $h{} */
6432 GV * const gv = cGVOPx_gv(firstop);
6440 else if (op->op_type == OP_PADAV
6441 || op->op_type == OP_PADHV) {
6442 /* lexicalvar $a[] or $h{} */
6443 const char * const padname =
6444 PAD_COMPNAME_PV(op->op_targ);
6453 name = SvPV_const(tmpstr, len);
6458 name = "__ANONIO__";
6465 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
6466 namesv = PAD_SVl(targ);
6467 SvUPGRADE(namesv, SVt_PV);
6469 sv_setpvn(namesv, "$", 1);
6470 sv_catpvn(namesv, name, len);
6473 kid->op_sibling = 0;
6474 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
6475 kid->op_targ = targ;
6476 kid->op_private |= priv;
6478 kid->op_sibling = sibl;
6484 mod(scalar(kid), type);
6488 tokid = &kid->op_sibling;
6489 kid = kid->op_sibling;
6492 if (kid && kid->op_type != OP_STUB)
6493 return too_many_arguments(o,OP_DESC(o));
6494 o->op_private |= numargs;
6496 /* FIXME - should the numargs move as for the PERL_MAD case? */
6497 o->op_private |= numargs;
6499 return too_many_arguments(o,OP_DESC(o));
6503 else if (PL_opargs[type] & OA_DEFGV) {
6505 OP *newop = newUNOP(type, 0, newDEFSVOP());
6506 op_getmad(o,newop,'O');
6509 /* Ordering of these two is important to keep f_map.t passing. */
6511 return newUNOP(type, 0, newDEFSVOP());
6516 while (oa & OA_OPTIONAL)
6518 if (oa && oa != OA_LIST)
6519 return too_few_arguments(o,OP_DESC(o));
6525 Perl_ck_glob(pTHX_ OP *o)
6531 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
6532 append_elem(OP_GLOB, o, newDEFSVOP());
6534 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
6535 && GvCVu(gv) && GvIMPORTED_CV(gv)))
6537 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6540 #if !defined(PERL_EXTERNAL_GLOB)
6541 /* XXX this can be tightened up and made more failsafe. */
6542 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
6545 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
6546 newSVpvs("File::Glob"), NULL, NULL, NULL);
6547 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6548 glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
6549 GvCV(gv) = GvCV(glob_gv);
6550 SvREFCNT_inc_void((SV*)GvCV(gv));
6551 GvIMPORTED_CV_on(gv);
6554 #endif /* PERL_EXTERNAL_GLOB */
6556 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6557 append_elem(OP_GLOB, o,
6558 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
6559 o->op_type = OP_LIST;
6560 o->op_ppaddr = PL_ppaddr[OP_LIST];
6561 cLISTOPo->op_first->op_type = OP_PUSHMARK;
6562 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
6563 cLISTOPo->op_first->op_targ = 0;
6564 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
6565 append_elem(OP_LIST, o,
6566 scalar(newUNOP(OP_RV2CV, 0,
6567 newGVOP(OP_GV, 0, gv)))));
6568 o = newUNOP(OP_NULL, 0, ck_subr(o));
6569 o->op_targ = OP_GLOB; /* hint at what it used to be */
6572 gv = newGVgen("main");
6574 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
6580 Perl_ck_grep(pTHX_ OP *o)
6585 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
6588 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
6589 /* don't allocate gwop here, as we may leak it if PL_error_count > 0 */
6591 if (o->op_flags & OPf_STACKED) {
6594 kid = cLISTOPo->op_first->op_sibling;
6595 if (!cUNOPx(kid)->op_next)
6596 Perl_croak(aTHX_ "panic: ck_grep");
6597 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
6600 NewOp(1101, gwop, 1, LOGOP);
6601 kid->op_next = (OP*)gwop;
6602 o->op_flags &= ~OPf_STACKED;
6604 kid = cLISTOPo->op_first->op_sibling;
6605 if (type == OP_MAPWHILE)
6612 kid = cLISTOPo->op_first->op_sibling;
6613 if (kid->op_type != OP_NULL)
6614 Perl_croak(aTHX_ "panic: ck_grep");
6615 kid = kUNOP->op_first;
6618 NewOp(1101, gwop, 1, LOGOP);
6619 gwop->op_type = type;
6620 gwop->op_ppaddr = PL_ppaddr[type];
6621 gwop->op_first = listkids(o);
6622 gwop->op_flags |= OPf_KIDS;
6623 gwop->op_other = LINKLIST(kid);
6624 kid->op_next = (OP*)gwop;
6625 offset = pad_findmy("$_");
6626 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
6627 o->op_private = gwop->op_private = 0;
6628 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
6631 o->op_private = gwop->op_private = OPpGREP_LEX;
6632 gwop->op_targ = o->op_targ = offset;
6635 kid = cLISTOPo->op_first->op_sibling;
6636 if (!kid || !kid->op_sibling)
6637 return too_few_arguments(o,OP_DESC(o));
6638 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
6639 mod(kid, OP_GREPSTART);
6645 Perl_ck_index(pTHX_ OP *o)
6647 if (o->op_flags & OPf_KIDS) {
6648 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6650 kid = kid->op_sibling; /* get past "big" */
6651 if (kid && kid->op_type == OP_CONST)
6652 fbm_compile(((SVOP*)kid)->op_sv, 0);
6658 Perl_ck_lengthconst(pTHX_ OP *o)
6660 /* XXX length optimization goes here */
6665 Perl_ck_lfun(pTHX_ OP *o)
6667 const OPCODE type = o->op_type;
6668 return modkids(ck_fun(o), type);
6672 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
6674 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
6675 switch (cUNOPo->op_first->op_type) {
6677 /* This is needed for
6678 if (defined %stash::)
6679 to work. Do not break Tk.
6681 break; /* Globals via GV can be undef */
6683 case OP_AASSIGN: /* Is this a good idea? */
6684 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6685 "defined(@array) is deprecated");
6686 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6687 "\t(Maybe you should just omit the defined()?)\n");
6690 /* This is needed for
6691 if (defined %stash::)
6692 to work. Do not break Tk.
6694 break; /* Globals via GV can be undef */
6696 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6697 "defined(%%hash) is deprecated");
6698 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6699 "\t(Maybe you should just omit the defined()?)\n");
6710 Perl_ck_rfun(pTHX_ OP *o)
6712 const OPCODE type = o->op_type;
6713 return refkids(ck_fun(o), type);
6717 Perl_ck_listiob(pTHX_ OP *o)
6721 kid = cLISTOPo->op_first;
6724 kid = cLISTOPo->op_first;
6726 if (kid->op_type == OP_PUSHMARK)
6727 kid = kid->op_sibling;
6728 if (kid && o->op_flags & OPf_STACKED)
6729 kid = kid->op_sibling;
6730 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6731 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6732 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6733 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6734 cLISTOPo->op_first->op_sibling = kid;
6735 cLISTOPo->op_last = kid;
6736 kid = kid->op_sibling;
6741 append_elem(o->op_type, o, newDEFSVOP());
6747 Perl_ck_say(pTHX_ OP *o)
6750 o->op_type = OP_PRINT;
6751 cLISTOPo->op_last = cLISTOPo->op_last->op_sibling
6752 = newSVOP(OP_CONST, 0, newSVpvs("\n"));
6757 Perl_ck_smartmatch(pTHX_ OP *o)
6760 if (0 == (o->op_flags & OPf_SPECIAL)) {
6761 OP *first = cBINOPo->op_first;
6762 OP *second = first->op_sibling;
6764 /* Implicitly take a reference to an array or hash */
6765 first->op_sibling = NULL;
6766 first = cBINOPo->op_first = ref_array_or_hash(first);
6767 second = first->op_sibling = ref_array_or_hash(second);
6769 /* Implicitly take a reference to a regular expression */
6770 if (first->op_type == OP_MATCH) {
6771 first->op_type = OP_QR;
6772 first->op_ppaddr = PL_ppaddr[OP_QR];
6774 if (second->op_type == OP_MATCH) {
6775 second->op_type = OP_QR;
6776 second->op_ppaddr = PL_ppaddr[OP_QR];
6785 Perl_ck_sassign(pTHX_ OP *o)
6787 OP * const kid = cLISTOPo->op_first;
6788 /* has a disposable target? */
6789 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6790 && !(kid->op_flags & OPf_STACKED)
6791 /* Cannot steal the second time! */
6792 && !(kid->op_private & OPpTARGET_MY))
6794 OP * const kkid = kid->op_sibling;
6796 /* Can just relocate the target. */
6797 if (kkid && kkid->op_type == OP_PADSV
6798 && !(kkid->op_private & OPpLVAL_INTRO))
6800 kid->op_targ = kkid->op_targ;
6802 /* Now we do not need PADSV and SASSIGN. */
6803 kid->op_sibling = o->op_sibling; /* NULL */
6804 cLISTOPo->op_first = NULL;
6806 op_getmad(o,kid,'O');
6807 op_getmad(kkid,kid,'M');
6812 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6816 if (kid->op_sibling) {
6817 OP *kkid = kid->op_sibling;
6818 if (kkid->op_type == OP_PADSV
6819 && (kkid->op_private & OPpLVAL_INTRO)
6820 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
6821 o->op_private |= OPpASSIGN_STATE;
6822 /* hijacking PADSTALE for uninitialized state variables */
6823 SvPADSTALE_on(PAD_SVl(kkid->op_targ));
6830 Perl_ck_match(pTHX_ OP *o)
6833 if (o->op_type != OP_QR && PL_compcv) {
6834 const PADOFFSET offset = pad_findmy("$_");
6835 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
6836 o->op_targ = offset;
6837 o->op_private |= OPpTARGET_MY;
6840 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
6841 o->op_private |= OPpRUNTIME;
6846 Perl_ck_method(pTHX_ OP *o)
6848 OP * const kid = cUNOPo->op_first;
6849 if (kid->op_type == OP_CONST) {
6850 SV* sv = kSVOP->op_sv;
6851 const char * const method = SvPVX_const(sv);
6852 if (!(strchr(method, ':') || strchr(method, '\''))) {
6854 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6855 sv = newSVpvn_share(method, SvCUR(sv), 0);
6858 kSVOP->op_sv = NULL;
6860 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6862 op_getmad(o,cmop,'O');
6873 Perl_ck_null(pTHX_ OP *o)
6875 PERL_UNUSED_CONTEXT;
6880 Perl_ck_open(pTHX_ OP *o)
6883 HV * const table = GvHV(PL_hintgv);
6885 SV **svp = hv_fetchs(table, "open_IN", FALSE);
6887 const I32 mode = mode_from_discipline(*svp);
6888 if (mode & O_BINARY)
6889 o->op_private |= OPpOPEN_IN_RAW;
6890 else if (mode & O_TEXT)
6891 o->op_private |= OPpOPEN_IN_CRLF;
6894 svp = hv_fetchs(table, "open_OUT", FALSE);
6896 const I32 mode = mode_from_discipline(*svp);
6897 if (mode & O_BINARY)
6898 o->op_private |= OPpOPEN_OUT_RAW;
6899 else if (mode & O_TEXT)
6900 o->op_private |= OPpOPEN_OUT_CRLF;
6903 if (o->op_type == OP_BACKTICK)
6906 /* In case of three-arg dup open remove strictness
6907 * from the last arg if it is a bareword. */
6908 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
6909 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
6913 if ((last->op_type == OP_CONST) && /* The bareword. */
6914 (last->op_private & OPpCONST_BARE) &&
6915 (last->op_private & OPpCONST_STRICT) &&
6916 (oa = first->op_sibling) && /* The fh. */
6917 (oa = oa->op_sibling) && /* The mode. */
6918 (oa->op_type == OP_CONST) &&
6919 SvPOK(((SVOP*)oa)->op_sv) &&
6920 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
6921 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
6922 (last == oa->op_sibling)) /* The bareword. */
6923 last->op_private &= ~OPpCONST_STRICT;
6929 Perl_ck_repeat(pTHX_ OP *o)
6931 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6932 o->op_private |= OPpREPEAT_DOLIST;
6933 cBINOPo->op_first = force_list(cBINOPo->op_first);
6941 Perl_ck_require(pTHX_ OP *o)
6946 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6947 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6949 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6950 SV * const sv = kid->op_sv;
6951 U32 was_readonly = SvREADONLY(sv);
6956 sv_force_normal_flags(sv, 0);
6957 assert(!SvREADONLY(sv));
6964 for (s = SvPVX(sv); *s; s++) {
6965 if (*s == ':' && s[1] == ':') {
6966 const STRLEN len = strlen(s+2)+1;
6968 Move(s+2, s+1, len, char);
6969 SvCUR_set(sv, SvCUR(sv) - 1);
6972 sv_catpvs(sv, ".pm");
6973 SvFLAGS(sv) |= was_readonly;
6977 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
6978 /* handle override, if any */
6979 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
6980 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
6981 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
6982 gv = gvp ? *gvp : NULL;
6986 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6987 OP * const kid = cUNOPo->op_first;
6990 cUNOPo->op_first = 0;
6994 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
6995 append_elem(OP_LIST, kid,
6996 scalar(newUNOP(OP_RV2CV, 0,
6999 op_getmad(o,newop,'O');
7007 Perl_ck_return(pTHX_ OP *o)
7010 if (CvLVALUE(PL_compcv)) {
7012 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
7013 mod(kid, OP_LEAVESUBLV);
7019 Perl_ck_select(pTHX_ OP *o)
7023 if (o->op_flags & OPf_KIDS) {
7024 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7025 if (kid && kid->op_sibling) {
7026 o->op_type = OP_SSELECT;
7027 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
7029 return fold_constants(o);
7033 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7034 if (kid && kid->op_type == OP_RV2GV)
7035 kid->op_private &= ~HINT_STRICT_REFS;
7040 Perl_ck_shift(pTHX_ OP *o)
7043 const I32 type = o->op_type;
7045 if (!(o->op_flags & OPf_KIDS)) {
7047 /* FIXME - this can be refactored to reduce code in #ifdefs */
7049 OP * const oldo = o;
7053 argop = newUNOP(OP_RV2AV, 0,
7054 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
7056 o = newUNOP(type, 0, scalar(argop));
7057 op_getmad(oldo,o,'O');
7060 return newUNOP(type, 0, scalar(argop));
7063 return scalar(modkids(ck_fun(o), type));
7067 Perl_ck_sort(pTHX_ OP *o)
7072 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
7073 HV * const hinthv = GvHV(PL_hintgv);
7075 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
7077 const I32 sorthints = (I32)SvIV(*svp);
7078 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
7079 o->op_private |= OPpSORT_QSORT;
7080 if ((sorthints & HINT_SORT_STABLE) != 0)
7081 o->op_private |= OPpSORT_STABLE;
7086 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
7088 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7089 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
7091 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
7093 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
7095 if (kid->op_type == OP_SCOPE) {
7099 else if (kid->op_type == OP_LEAVE) {
7100 if (o->op_type == OP_SORT) {
7101 op_null(kid); /* wipe out leave */
7104 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
7105 if (k->op_next == kid)
7107 /* don't descend into loops */
7108 else if (k->op_type == OP_ENTERLOOP
7109 || k->op_type == OP_ENTERITER)
7111 k = cLOOPx(k)->op_lastop;
7116 kid->op_next = 0; /* just disconnect the leave */
7117 k = kLISTOP->op_first;
7122 if (o->op_type == OP_SORT) {
7123 /* provide scalar context for comparison function/block */
7129 o->op_flags |= OPf_SPECIAL;
7131 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
7134 firstkid = firstkid->op_sibling;
7137 /* provide list context for arguments */
7138 if (o->op_type == OP_SORT)
7145 S_simplify_sort(pTHX_ OP *o)
7148 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7153 if (!(o->op_flags & OPf_STACKED))
7155 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7156 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
7157 kid = kUNOP->op_first; /* get past null */
7158 if (kid->op_type != OP_SCOPE)
7160 kid = kLISTOP->op_last; /* get past scope */
7161 switch(kid->op_type) {
7169 k = kid; /* remember this node*/
7170 if (kBINOP->op_first->op_type != OP_RV2SV)
7172 kid = kBINOP->op_first; /* get past cmp */
7173 if (kUNOP->op_first->op_type != OP_GV)
7175 kid = kUNOP->op_first; /* get past rv2sv */
7177 if (GvSTASH(gv) != PL_curstash)
7179 gvname = GvNAME(gv);
7180 if (*gvname == 'a' && gvname[1] == '\0')
7182 else if (*gvname == 'b' && gvname[1] == '\0')
7187 kid = k; /* back to cmp */
7188 if (kBINOP->op_last->op_type != OP_RV2SV)
7190 kid = kBINOP->op_last; /* down to 2nd arg */
7191 if (kUNOP->op_first->op_type != OP_GV)
7193 kid = kUNOP->op_first; /* get past rv2sv */
7195 if (GvSTASH(gv) != PL_curstash)
7197 gvname = GvNAME(gv);
7199 ? !(*gvname == 'a' && gvname[1] == '\0')
7200 : !(*gvname == 'b' && gvname[1] == '\0'))
7202 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
7204 o->op_private |= OPpSORT_DESCEND;
7205 if (k->op_type == OP_NCMP)
7206 o->op_private |= OPpSORT_NUMERIC;
7207 if (k->op_type == OP_I_NCMP)
7208 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
7209 kid = cLISTOPo->op_first->op_sibling;
7210 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
7212 op_getmad(kid,o,'S'); /* then delete it */
7214 op_free(kid); /* then delete it */
7219 Perl_ck_split(pTHX_ OP *o)
7224 if (o->op_flags & OPf_STACKED)
7225 return no_fh_allowed(o);
7227 kid = cLISTOPo->op_first;
7228 if (kid->op_type != OP_NULL)
7229 Perl_croak(aTHX_ "panic: ck_split");
7230 kid = kid->op_sibling;
7231 op_free(cLISTOPo->op_first);
7232 cLISTOPo->op_first = kid;
7234 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
7235 cLISTOPo->op_last = kid; /* There was only one element previously */
7238 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
7239 OP * const sibl = kid->op_sibling;
7240 kid->op_sibling = 0;
7241 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
7242 if (cLISTOPo->op_first == cLISTOPo->op_last)
7243 cLISTOPo->op_last = kid;
7244 cLISTOPo->op_first = kid;
7245 kid->op_sibling = sibl;
7248 kid->op_type = OP_PUSHRE;
7249 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
7251 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
7252 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
7253 "Use of /g modifier is meaningless in split");
7256 if (!kid->op_sibling)
7257 append_elem(OP_SPLIT, o, newDEFSVOP());
7259 kid = kid->op_sibling;
7262 if (!kid->op_sibling)
7263 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
7264 assert(kid->op_sibling);
7266 kid = kid->op_sibling;
7269 if (kid->op_sibling)
7270 return too_many_arguments(o,OP_DESC(o));
7276 Perl_ck_join(pTHX_ OP *o)
7278 const OP * const kid = cLISTOPo->op_first->op_sibling;
7279 if (kid && kid->op_type == OP_MATCH) {
7280 if (ckWARN(WARN_SYNTAX)) {
7281 const REGEXP *re = PM_GETRE(kPMOP);
7282 const char *pmstr = re ? re->precomp : "STRING";
7283 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7284 "/%s/ should probably be written as \"%s\"",
7292 Perl_ck_subr(pTHX_ OP *o)
7295 OP *prev = ((cUNOPo->op_first->op_sibling)
7296 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
7297 OP *o2 = prev->op_sibling;
7299 const char *proto = NULL;
7300 const char *proto_end = NULL;
7305 I32 contextclass = 0;
7309 o->op_private |= OPpENTERSUB_HASTARG;
7310 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
7311 if (cvop->op_type == OP_RV2CV) {
7313 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
7314 op_null(cvop); /* disable rv2cv */
7315 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
7316 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
7317 GV *gv = cGVOPx_gv(tmpop);
7320 tmpop->op_private |= OPpEARLY_CV;
7324 namegv = CvANON(cv) ? gv : CvGV(cv);
7325 proto = SvPV((SV*)cv, len);
7326 proto_end = proto + len;
7328 if (CvASSERTION(cv)) {
7329 if (PL_hints & HINT_ASSERTING) {
7330 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
7331 o->op_private |= OPpENTERSUB_DB;
7335 if (!(PL_hints & HINT_ASSERTIONSSEEN) && ckWARN(WARN_ASSERTIONS)) {
7336 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
7337 "Impossible to activate assertion call");
7344 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7345 if (o2->op_type == OP_CONST)
7346 o2->op_private &= ~OPpCONST_STRICT;
7347 else if (o2->op_type == OP_LIST) {
7348 OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
7349 if (sib && sib->op_type == OP_CONST)
7350 sib->op_private &= ~OPpCONST_STRICT;
7353 o->op_private |= (PL_hints & HINT_STRICT_REFS);
7354 if (PERLDB_SUB && PL_curstash != PL_debstash)
7355 o->op_private |= OPpENTERSUB_DB;
7356 while (o2 != cvop) {
7358 if (PL_madskills && o2->op_type == OP_NULL)
7359 o3 = ((UNOP*)o2)->op_first;
7363 if (proto >= proto_end)
7364 return too_many_arguments(o, gv_ename(namegv));
7384 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
7386 arg == 1 ? "block or sub {}" : "sub {}",
7387 gv_ename(namegv), o3);
7390 /* '*' allows any scalar type, including bareword */
7393 if (o3->op_type == OP_RV2GV)
7394 goto wrapref; /* autoconvert GLOB -> GLOBref */
7395 else if (o3->op_type == OP_CONST)
7396 o3->op_private &= ~OPpCONST_STRICT;
7397 else if (o3->op_type == OP_ENTERSUB) {
7398 /* accidental subroutine, revert to bareword */
7399 OP *gvop = ((UNOP*)o3)->op_first;
7400 if (gvop && gvop->op_type == OP_NULL) {
7401 gvop = ((UNOP*)gvop)->op_first;
7403 for (; gvop->op_sibling; gvop = gvop->op_sibling)
7406 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
7407 (gvop = ((UNOP*)gvop)->op_first) &&
7408 gvop->op_type == OP_GV)
7410 GV * const gv = cGVOPx_gv(gvop);
7411 OP * const sibling = o2->op_sibling;
7412 SV * const n = newSVpvs("");
7414 OP * const oldo2 = o2;
7418 gv_fullname4(n, gv, "", FALSE);
7419 o2 = newSVOP(OP_CONST, 0, n);
7420 op_getmad(oldo2,o2,'O');
7421 prev->op_sibling = o2;
7422 o2->op_sibling = sibling;
7438 if (contextclass++ == 0) {
7439 e = strchr(proto, ']');
7440 if (!e || e == proto)
7449 const char *p = proto;
7450 const char *const end = proto;
7452 while (*--p != '[');
7453 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
7455 gv_ename(namegv), o3);
7460 if (o3->op_type == OP_RV2GV)
7463 bad_type(arg, "symbol", gv_ename(namegv), o3);
7466 if (o3->op_type == OP_ENTERSUB)
7469 bad_type(arg, "subroutine entry", gv_ename(namegv),
7473 if (o3->op_type == OP_RV2SV ||
7474 o3->op_type == OP_PADSV ||
7475 o3->op_type == OP_HELEM ||
7476 o3->op_type == OP_AELEM ||
7477 o3->op_type == OP_THREADSV)
7480 bad_type(arg, "scalar", gv_ename(namegv), o3);
7483 if (o3->op_type == OP_RV2AV ||
7484 o3->op_type == OP_PADAV)
7487 bad_type(arg, "array", gv_ename(namegv), o3);
7490 if (o3->op_type == OP_RV2HV ||
7491 o3->op_type == OP_PADHV)
7494 bad_type(arg, "hash", gv_ename(namegv), o3);
7499 OP* const sib = kid->op_sibling;
7500 kid->op_sibling = 0;
7501 o2 = newUNOP(OP_REFGEN, 0, kid);
7502 o2->op_sibling = sib;
7503 prev->op_sibling = o2;
7505 if (contextclass && e) {
7520 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
7521 gv_ename(namegv), (void*)cv);
7526 mod(o2, OP_ENTERSUB);
7528 o2 = o2->op_sibling;
7530 if (proto && !optional && proto_end > proto &&
7531 (*proto != '@' && *proto != '%' && *proto != ';'))
7532 return too_few_arguments(o, gv_ename(namegv));
7535 OP * const oldo = o;
7539 o=newSVOP(OP_CONST, 0, newSViv(0));
7540 op_getmad(oldo,o,'O');
7546 Perl_ck_svconst(pTHX_ OP *o)
7548 PERL_UNUSED_CONTEXT;
7549 SvREADONLY_on(cSVOPo->op_sv);
7554 Perl_ck_chdir(pTHX_ OP *o)
7556 if (o->op_flags & OPf_KIDS) {
7557 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7559 if (kid && kid->op_type == OP_CONST &&
7560 (kid->op_private & OPpCONST_BARE))
7562 o->op_flags |= OPf_SPECIAL;
7563 kid->op_private &= ~OPpCONST_STRICT;
7570 Perl_ck_trunc(pTHX_ OP *o)
7572 if (o->op_flags & OPf_KIDS) {
7573 SVOP *kid = (SVOP*)cUNOPo->op_first;
7575 if (kid->op_type == OP_NULL)
7576 kid = (SVOP*)kid->op_sibling;
7577 if (kid && kid->op_type == OP_CONST &&
7578 (kid->op_private & OPpCONST_BARE))
7580 o->op_flags |= OPf_SPECIAL;
7581 kid->op_private &= ~OPpCONST_STRICT;
7588 Perl_ck_unpack(pTHX_ OP *o)
7590 OP *kid = cLISTOPo->op_first;
7591 if (kid->op_sibling) {
7592 kid = kid->op_sibling;
7593 if (!kid->op_sibling)
7594 kid->op_sibling = newDEFSVOP();
7600 Perl_ck_substr(pTHX_ OP *o)
7603 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
7604 OP *kid = cLISTOPo->op_first;
7606 if (kid->op_type == OP_NULL)
7607 kid = kid->op_sibling;
7609 kid->op_flags |= OPf_MOD;
7615 /* A peephole optimizer. We visit the ops in the order they're to execute.
7616 * See the comments at the top of this file for more details about when
7617 * peep() is called */
7620 Perl_peep(pTHX_ register OP *o)
7623 register OP* oldop = NULL;
7625 if (!o || o->op_opt)
7629 SAVEVPTR(PL_curcop);
7630 for (; o; o = o->op_next) {
7634 switch (o->op_type) {
7638 PL_curcop = ((COP*)o); /* for warnings */
7643 if (cSVOPo->op_private & OPpCONST_STRICT)
7644 no_bareword_allowed(o);
7646 case OP_METHOD_NAMED:
7647 /* Relocate sv to the pad for thread safety.
7648 * Despite being a "constant", the SV is written to,
7649 * for reference counts, sv_upgrade() etc. */
7651 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
7652 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
7653 /* If op_sv is already a PADTMP then it is being used by
7654 * some pad, so make a copy. */
7655 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
7656 SvREADONLY_on(PAD_SVl(ix));
7657 SvREFCNT_dec(cSVOPo->op_sv);
7659 else if (o->op_type == OP_CONST
7660 && cSVOPo->op_sv == &PL_sv_undef) {
7661 /* PL_sv_undef is hack - it's unsafe to store it in the
7662 AV that is the pad, because av_fetch treats values of
7663 PL_sv_undef as a "free" AV entry and will merrily
7664 replace them with a new SV, causing pad_alloc to think
7665 that this pad slot is free. (When, clearly, it is not)
7667 SvOK_off(PAD_SVl(ix));
7668 SvPADTMP_on(PAD_SVl(ix));
7669 SvREADONLY_on(PAD_SVl(ix));
7672 SvREFCNT_dec(PAD_SVl(ix));
7673 SvPADTMP_on(cSVOPo->op_sv);
7674 PAD_SETSV(ix, cSVOPo->op_sv);
7675 /* XXX I don't know how this isn't readonly already. */
7676 SvREADONLY_on(PAD_SVl(ix));
7678 cSVOPo->op_sv = NULL;
7686 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
7687 if (o->op_next->op_private & OPpTARGET_MY) {
7688 if (o->op_flags & OPf_STACKED) /* chained concats */
7689 goto ignore_optimization;
7691 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
7692 o->op_targ = o->op_next->op_targ;
7693 o->op_next->op_targ = 0;
7694 o->op_private |= OPpTARGET_MY;
7697 op_null(o->op_next);
7699 ignore_optimization:
7703 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
7705 break; /* Scalar stub must produce undef. List stub is noop */
7709 if (o->op_targ == OP_NEXTSTATE
7710 || o->op_targ == OP_DBSTATE
7711 || o->op_targ == OP_SETSTATE)
7713 PL_curcop = ((COP*)o);
7715 /* XXX: We avoid setting op_seq here to prevent later calls
7716 to peep() from mistakenly concluding that optimisation
7717 has already occurred. This doesn't fix the real problem,
7718 though (See 20010220.007). AMS 20010719 */
7719 /* op_seq functionality is now replaced by op_opt */
7720 if (oldop && o->op_next) {
7721 oldop->op_next = o->op_next;
7729 if (oldop && o->op_next) {
7730 oldop->op_next = o->op_next;
7738 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
7739 OP* const pop = (o->op_type == OP_PADAV) ?
7740 o->op_next : o->op_next->op_next;
7742 if (pop && pop->op_type == OP_CONST &&
7743 ((PL_op = pop->op_next)) &&
7744 pop->op_next->op_type == OP_AELEM &&
7745 !(pop->op_next->op_private &
7746 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
7747 (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
7752 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
7753 no_bareword_allowed(pop);
7754 if (o->op_type == OP_GV)
7755 op_null(o->op_next);
7756 op_null(pop->op_next);
7758 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
7759 o->op_next = pop->op_next->op_next;
7760 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
7761 o->op_private = (U8)i;
7762 if (o->op_type == OP_GV) {
7767 o->op_flags |= OPf_SPECIAL;
7768 o->op_type = OP_AELEMFAST;
7774 if (o->op_next->op_type == OP_RV2SV) {
7775 if (!(o->op_next->op_private & OPpDEREF)) {
7776 op_null(o->op_next);
7777 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
7779 o->op_next = o->op_next->op_next;
7780 o->op_type = OP_GVSV;
7781 o->op_ppaddr = PL_ppaddr[OP_GVSV];
7784 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
7785 GV * const gv = cGVOPo_gv;
7786 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
7787 /* XXX could check prototype here instead of just carping */
7788 SV * const sv = sv_newmortal();
7789 gv_efullname3(sv, gv, NULL);
7790 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
7791 "%"SVf"() called too early to check prototype",
7795 else if (o->op_next->op_type == OP_READLINE
7796 && o->op_next->op_next->op_type == OP_CONCAT
7797 && (o->op_next->op_next->op_flags & OPf_STACKED))
7799 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
7800 o->op_type = OP_RCATLINE;
7801 o->op_flags |= OPf_STACKED;
7802 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
7803 op_null(o->op_next->op_next);
7804 op_null(o->op_next);
7821 while (cLOGOP->op_other->op_type == OP_NULL)
7822 cLOGOP->op_other = cLOGOP->op_other->op_next;
7823 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
7829 while (cLOOP->op_redoop->op_type == OP_NULL)
7830 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
7831 peep(cLOOP->op_redoop);
7832 while (cLOOP->op_nextop->op_type == OP_NULL)
7833 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
7834 peep(cLOOP->op_nextop);
7835 while (cLOOP->op_lastop->op_type == OP_NULL)
7836 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
7837 peep(cLOOP->op_lastop);
7844 while (cPMOP->op_pmreplstart &&
7845 cPMOP->op_pmreplstart->op_type == OP_NULL)
7846 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
7847 peep(cPMOP->op_pmreplstart);
7852 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
7853 && ckWARN(WARN_SYNTAX))
7855 if (o->op_next->op_sibling) {
7856 const OPCODE type = o->op_next->op_sibling->op_type;
7857 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
7858 const line_t oldline = CopLINE(PL_curcop);
7859 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
7860 Perl_warner(aTHX_ packWARN(WARN_EXEC),
7861 "Statement unlikely to be reached");
7862 Perl_warner(aTHX_ packWARN(WARN_EXEC),
7863 "\t(Maybe you meant system() when you said exec()?)\n");
7864 CopLINE_set(PL_curcop, oldline);
7875 const char *key = NULL;
7880 if (((BINOP*)o)->op_last->op_type != OP_CONST)
7883 /* Make the CONST have a shared SV */
7884 svp = cSVOPx_svp(((BINOP*)o)->op_last);
7885 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
7886 key = SvPV_const(sv, keylen);
7887 lexname = newSVpvn_share(key,
7888 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
7894 if ((o->op_private & (OPpLVAL_INTRO)))
7897 rop = (UNOP*)((BINOP*)o)->op_first;
7898 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7900 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7901 if (!SvPAD_TYPED(lexname))
7903 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
7904 if (!fields || !GvHV(*fields))
7906 key = SvPV_const(*svp, keylen);
7907 if (!hv_fetch(GvHV(*fields), key,
7908 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
7910 Perl_croak(aTHX_ "No such class field \"%s\" "
7911 "in variable %s of type %s",
7912 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
7925 SVOP *first_key_op, *key_op;
7927 if ((o->op_private & (OPpLVAL_INTRO))
7928 /* I bet there's always a pushmark... */
7929 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
7930 /* hmmm, no optimization if list contains only one key. */
7932 rop = (UNOP*)((LISTOP*)o)->op_last;
7933 if (rop->op_type != OP_RV2HV)
7935 if (rop->op_first->op_type == OP_PADSV)
7936 /* @$hash{qw(keys here)} */
7937 rop = (UNOP*)rop->op_first;
7939 /* @{$hash}{qw(keys here)} */
7940 if (rop->op_first->op_type == OP_SCOPE
7941 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
7943 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
7949 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
7950 if (!SvPAD_TYPED(lexname))
7952 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
7953 if (!fields || !GvHV(*fields))
7955 /* Again guessing that the pushmark can be jumped over.... */
7956 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
7957 ->op_first->op_sibling;
7958 for (key_op = first_key_op; key_op;
7959 key_op = (SVOP*)key_op->op_sibling) {
7960 if (key_op->op_type != OP_CONST)
7962 svp = cSVOPx_svp(key_op);
7963 key = SvPV_const(*svp, keylen);
7964 if (!hv_fetch(GvHV(*fields), key,
7965 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
7967 Perl_croak(aTHX_ "No such class field \"%s\" "
7968 "in variable %s of type %s",
7969 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
7976 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
7980 /* check that RHS of sort is a single plain array */
7981 OP *oright = cUNOPo->op_first;
7982 if (!oright || oright->op_type != OP_PUSHMARK)
7985 /* reverse sort ... can be optimised. */
7986 if (!cUNOPo->op_sibling) {
7987 /* Nothing follows us on the list. */
7988 OP * const reverse = o->op_next;
7990 if (reverse->op_type == OP_REVERSE &&
7991 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
7992 OP * const pushmark = cUNOPx(reverse)->op_first;
7993 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
7994 && (cUNOPx(pushmark)->op_sibling == o)) {
7995 /* reverse -> pushmark -> sort */
7996 o->op_private |= OPpSORT_REVERSE;
7998 pushmark->op_next = oright->op_next;
8004 /* make @a = sort @a act in-place */
8008 oright = cUNOPx(oright)->op_sibling;
8011 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
8012 oright = cUNOPx(oright)->op_sibling;
8016 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
8017 || oright->op_next != o
8018 || (oright->op_private & OPpLVAL_INTRO)
8022 /* o2 follows the chain of op_nexts through the LHS of the
8023 * assign (if any) to the aassign op itself */
8025 if (!o2 || o2->op_type != OP_NULL)
8028 if (!o2 || o2->op_type != OP_PUSHMARK)
8031 if (o2 && o2->op_type == OP_GV)
8034 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
8035 || (o2->op_private & OPpLVAL_INTRO)
8040 if (!o2 || o2->op_type != OP_NULL)
8043 if (!o2 || o2->op_type != OP_AASSIGN
8044 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
8047 /* check that the sort is the first arg on RHS of assign */
8049 o2 = cUNOPx(o2)->op_first;
8050 if (!o2 || o2->op_type != OP_NULL)
8052 o2 = cUNOPx(o2)->op_first;
8053 if (!o2 || o2->op_type != OP_PUSHMARK)
8055 if (o2->op_sibling != o)
8058 /* check the array is the same on both sides */
8059 if (oleft->op_type == OP_RV2AV) {
8060 if (oright->op_type != OP_RV2AV
8061 || !cUNOPx(oright)->op_first
8062 || cUNOPx(oright)->op_first->op_type != OP_GV
8063 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
8064 cGVOPx_gv(cUNOPx(oright)->op_first)
8068 else if (oright->op_type != OP_PADAV
8069 || oright->op_targ != oleft->op_targ
8073 /* transfer MODishness etc from LHS arg to RHS arg */
8074 oright->op_flags = oleft->op_flags;
8075 o->op_private |= OPpSORT_INPLACE;
8077 /* excise push->gv->rv2av->null->aassign */
8078 o2 = o->op_next->op_next;
8079 op_null(o2); /* PUSHMARK */
8081 if (o2->op_type == OP_GV) {
8082 op_null(o2); /* GV */
8085 op_null(o2); /* RV2AV or PADAV */
8086 o2 = o2->op_next->op_next;
8087 op_null(o2); /* AASSIGN */
8089 o->op_next = o2->op_next;
8095 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
8097 LISTOP *enter, *exlist;
8100 enter = (LISTOP *) o->op_next;
8103 if (enter->op_type == OP_NULL) {
8104 enter = (LISTOP *) enter->op_next;
8108 /* for $a (...) will have OP_GV then OP_RV2GV here.
8109 for (...) just has an OP_GV. */
8110 if (enter->op_type == OP_GV) {
8111 gvop = (OP *) enter;
8112 enter = (LISTOP *) enter->op_next;
8115 if (enter->op_type == OP_RV2GV) {
8116 enter = (LISTOP *) enter->op_next;
8122 if (enter->op_type != OP_ENTERITER)
8125 iter = enter->op_next;
8126 if (!iter || iter->op_type != OP_ITER)
8129 expushmark = enter->op_first;
8130 if (!expushmark || expushmark->op_type != OP_NULL
8131 || expushmark->op_targ != OP_PUSHMARK)
8134 exlist = (LISTOP *) expushmark->op_sibling;
8135 if (!exlist || exlist->op_type != OP_NULL
8136 || exlist->op_targ != OP_LIST)
8139 if (exlist->op_last != o) {
8140 /* Mmm. Was expecting to point back to this op. */
8143 theirmark = exlist->op_first;
8144 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
8147 if (theirmark->op_sibling != o) {
8148 /* There's something between the mark and the reverse, eg
8149 for (1, reverse (...))
8154 ourmark = ((LISTOP *)o)->op_first;
8155 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
8158 ourlast = ((LISTOP *)o)->op_last;
8159 if (!ourlast || ourlast->op_next != o)
8162 rv2av = ourmark->op_sibling;
8163 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
8164 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
8165 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
8166 /* We're just reversing a single array. */
8167 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
8168 enter->op_flags |= OPf_STACKED;
8171 /* We don't have control over who points to theirmark, so sacrifice
8173 theirmark->op_next = ourmark->op_next;
8174 theirmark->op_flags = ourmark->op_flags;
8175 ourlast->op_next = gvop ? gvop : (OP *) enter;
8178 enter->op_private |= OPpITER_REVERSED;
8179 iter->op_private |= OPpITER_REVERSED;
8186 UNOP *refgen, *rv2cv;
8189 /* I do not understand this, but if o->op_opt isn't set to 1,
8190 various tests in ext/B/t/bytecode.t fail with no readily
8196 if ((o->op_flags && OPf_WANT) != OPf_WANT_VOID)
8199 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
8202 rv2gv = ((BINOP *)o)->op_last;
8203 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
8206 refgen = (UNOP *)((BINOP *)o)->op_first;
8208 if (!refgen || refgen->op_type != OP_REFGEN)
8211 exlist = (LISTOP *)refgen->op_first;
8212 if (!exlist || exlist->op_type != OP_NULL
8213 || exlist->op_targ != OP_LIST)
8216 if (exlist->op_first->op_type != OP_PUSHMARK)
8219 rv2cv = (UNOP*)exlist->op_last;
8221 if (rv2cv->op_type != OP_RV2CV)
8224 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
8225 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
8226 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
8228 o->op_private |= OPpASSIGN_CV_TO_GV;
8229 rv2gv->op_private |= OPpDONT_INIT_GV;
8230 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
8246 Perl_custom_op_name(pTHX_ const OP* o)
8249 const IV index = PTR2IV(o->op_ppaddr);
8253 if (!PL_custom_op_names) /* This probably shouldn't happen */
8254 return (char *)PL_op_name[OP_CUSTOM];
8256 keysv = sv_2mortal(newSViv(index));
8258 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
8260 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
8262 return SvPV_nolen(HeVAL(he));
8266 Perl_custom_op_desc(pTHX_ const OP* o)
8269 const IV index = PTR2IV(o->op_ppaddr);
8273 if (!PL_custom_op_descs)
8274 return (char *)PL_op_desc[OP_CUSTOM];
8276 keysv = sv_2mortal(newSViv(index));
8278 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
8280 return (char *)PL_op_desc[OP_CUSTOM];
8282 return SvPV_nolen(HeVAL(he));
8287 /* Efficient sub that returns a constant scalar value. */
8289 const_sv_xsub(pTHX_ CV* cv)
8296 Perl_croak(aTHX_ "usage: %s::%s()",
8297 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
8301 ST(0) = (SV*)XSANY.any_ptr;
8307 * c-indentation-style: bsd
8309 * indent-tabs-mode: t
8312 * ex: set ts=8 sts=4 sw=4 noet: