3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * "You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
13 * our Mr. Bilbo's first cousin on the mother's side (her mother being the
14 * youngest of the Old Took's daughters); and Mr. Drogo was his second
15 * cousin. So Mr. Frodo is his first *and* second cousin, once removed
16 * either way, as the saying is, if you follow me." --the Gaffer
19 /* This file contains the functions that create, manipulate and optimize
20 * the OP structures that hold a compiled perl program.
22 * A Perl program is compiled into a tree of OPs. Each op contains
23 * structural pointers (eg to its siblings and the next op in the
24 * execution sequence), a pointer to the function that would execute the
25 * op, plus any data specific to that op. For example, an OP_CONST op
26 * points to the pp_const() function and to an SV containing the constant
27 * value. When pp_const() is executed, its job is to push that SV onto the
30 * OPs are mainly created by the newFOO() functions, which are mainly
31 * called from the parser (in perly.y) as the code is parsed. For example
32 * the Perl code $a + $b * $c would cause the equivalent of the following
33 * to be called (oversimplifying a bit):
35 * newBINOP(OP_ADD, flags,
37 * newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
40 * Note that during the build of miniperl, a temporary copy of this file
41 * is made, called opmini.c.
45 Perl's compiler is essentially a 3-pass compiler with interleaved phases:
49 An execution-order pass
51 The bottom-up pass is represented by all the "newOP" routines and
52 the ck_ routines. The bottom-upness is actually driven by yacc.
53 So at the point that a ck_ routine fires, we have no idea what the
54 context is, either upward in the syntax tree, or either forward or
55 backward in the execution order. (The bottom-up parser builds that
56 part of the execution order it knows about, but if you follow the "next"
57 links around, you'll find it's actually a closed loop through the
60 Whenever the bottom-up parser gets to a node that supplies context to
61 its components, it invokes that portion of the top-down pass that applies
62 to that part of the subtree (and marks the top node as processed, so
63 if a node further up supplies context, it doesn't have to take the
64 plunge again). As a particular subcase of this, as the new node is
65 built, it takes all the closed execution loops of its subcomponents
66 and links them into a new closed loop for the higher level node. But
67 it's still not the real execution order.
69 The actual execution order is not known till we get a grammar reduction
70 to a top-level unit like a subroutine or file that will be called by
71 "name" rather than via a "next" pointer. At that point, we can call
72 into peep() to do that code's portion of the 3rd pass. It has to be
73 recursive, but it's recursive on basic blocks, not on tree nodes.
76 /* To implement user lexical pragmas, there needs to be a way at run time to
77 get the compile time state of %^H for that block. Storing %^H in every
78 block (or even COP) would be very expensive, so a different approach is
79 taken. The (running) state of %^H is serialised into a tree of HE-like
80 structs. Stores into %^H are chained onto the current leaf as a struct
81 refcounted_he * with the key and the value. Deletes from %^H are saved
82 with a value of PL_sv_placeholder. The state of %^H at any point can be
83 turned back into a regular HV by walking back up the tree from that point's
84 leaf, ignoring any key you've already seen (placeholder or not), storing
85 the rest into the HV structure, then removing the placeholders. Hence
86 memory is only used to store the %^H deltas from the enclosing COP, rather
87 than the entire %^H on each COP.
89 To cause actions on %^H to write out the serialisation records, it has
90 magic type 'H'. This magic (itself) does nothing, but its presence causes
91 the values to gain magic type 'h', which has entries for set and clear.
92 C<Perl_magic_sethint> updates C<PL_compiling.cop_hints_hash> with a store
93 record, with deletes written by C<Perl_magic_clearhint>. C<SAVE_HINTS>
94 saves the current C<PL_compiling.cop_hints_hash> on the save stack, so that
95 it will be correctly restored when any inner compiling scope is exited.
101 #include "keywords.h"
103 #define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
105 #if defined(PL_OP_SLAB_ALLOC)
107 #ifndef PERL_SLAB_SIZE
108 #define PERL_SLAB_SIZE 2048
112 Perl_Slab_Alloc(pTHX_ int m, size_t sz)
115 * To make incrementing use count easy PL_OpSlab is an I32 *
116 * To make inserting the link to slab PL_OpPtr is I32 **
117 * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
118 * Add an overhead for pointer to slab and round up as a number of pointers
120 sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
121 if ((PL_OpSpace -= sz) < 0) {
122 PL_OpPtr = (I32 **) PerlMemShared_malloc(PERL_SLAB_SIZE*sizeof(I32*));
126 Zero(PL_OpPtr,PERL_SLAB_SIZE,I32 **);
127 /* We reserve the 0'th I32 sized chunk as a use count */
128 PL_OpSlab = (I32 *) PL_OpPtr;
129 /* Reduce size by the use count word, and by the size we need.
130 * Latter is to mimic the '-=' in the if() above
132 PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
133 /* Allocation pointer starts at the top.
134 Theory: because we build leaves before trunk allocating at end
135 means that at run time access is cache friendly upward
137 PL_OpPtr += PERL_SLAB_SIZE;
139 assert( PL_OpSpace >= 0 );
140 /* Move the allocation pointer down */
142 assert( PL_OpPtr > (I32 **) PL_OpSlab );
143 *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */
144 (*PL_OpSlab)++; /* Increment use count of slab */
145 assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
146 assert( *PL_OpSlab > 0 );
147 return (void *)(PL_OpPtr + 1);
151 Perl_Slab_Free(pTHX_ void *op)
153 I32 * const * const ptr = (I32 **) op;
154 I32 * const slab = ptr[-1];
155 assert( ptr-1 > (I32 **) slab );
156 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
158 if (--(*slab) == 0) {
160 # define PerlMemShared PerlMem
163 PerlMemShared_free(slab);
164 if (slab == PL_OpSlab) {
171 * In the following definition, the ", (OP*)0" is just to make the compiler
172 * think the expression is of the right type: croak actually does a Siglongjmp.
174 #define CHECKOP(type,o) \
175 ((PL_op_mask && PL_op_mask[type]) \
176 ? ( op_free((OP*)o), \
177 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
179 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
181 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
184 S_gv_ename(pTHX_ GV *gv)
186 SV* const tmpsv = sv_newmortal();
187 gv_efullname3(tmpsv, gv, NULL);
188 return SvPV_nolen_const(tmpsv);
192 S_no_fh_allowed(pTHX_ OP *o)
194 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
200 S_too_few_arguments(pTHX_ OP *o, const char *name)
202 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
207 S_too_many_arguments(pTHX_ OP *o, const char *name)
209 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
214 S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid)
216 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
217 (int)n, name, t, OP_DESC(kid)));
221 S_no_bareword_allowed(pTHX_ const OP *o)
224 return; /* various ok barewords are hidden in extra OP_NULL */
225 qerror(Perl_mess(aTHX_
226 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
230 /* "register" allocation */
233 Perl_allocmy(pTHX_ const char *const name)
237 const bool is_our = (PL_in_my == KEY_our);
239 /* complain about "my $<special_var>" etc etc */
243 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
244 (name[1] == '_' && (*name == '$' || name[2]))))
246 /* name[2] is true if strlen(name) > 2 */
247 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
248 yyerror(Perl_form(aTHX_ "Can't use global %c^%c%s in \"my\"",
249 name[0], toCTRL(name[1]), name + 2));
251 yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
255 /* check for duplicate declaration */
256 pad_check_dup(name, is_our, (PL_curstash ? PL_curstash : PL_defstash));
258 if (PL_in_my_stash && *name != '$') {
259 yyerror(Perl_form(aTHX_
260 "Can't declare class for non-scalar %s in \"%s\"",
262 is_our ? "our" : PL_in_my == KEY_state ? "state" : "my"));
265 /* allocate a spare slot and store the name in that slot */
267 off = pad_add_name(name,
270 /* $_ is always in main::, even with our */
271 ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
275 PL_in_my == KEY_state
280 /* free the body of an op without examining its contents.
281 * Always use this rather than FreeOp directly */
284 S_op_destroy(pTHX_ OP *o)
286 if (o->op_latefree) {
297 Perl_op_free(pTHX_ OP *o)
302 if (!o || o->op_static)
304 if (o->op_latefreed) {
311 if (o->op_private & OPpREFCOUNTED) {
322 refcnt = OpREFCNT_dec(o);
333 if (o->op_flags & OPf_KIDS) {
334 register OP *kid, *nextkid;
335 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
336 nextkid = kid->op_sibling; /* Get before next freeing kid */
341 type = (OPCODE)o->op_targ;
343 /* COP* is not cleared by op_clear() so that we may track line
344 * numbers etc even after null() */
345 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
349 if (o->op_latefree) {
355 #ifdef DEBUG_LEAKING_SCALARS
362 Perl_op_clear(pTHX_ OP *o)
367 /* if (o->op_madprop && o->op_madprop->mad_next)
369 /* FIXME for MAD - if I uncomment these two lines t/op/pack.t fails with
370 "modification of a read only value" for a reason I can't fathom why.
371 It's the "" stringification of $_, where $_ was set to '' in a foreach
372 loop, but it defies simplification into a small test case.
373 However, commenting them out has caused ext/List/Util/t/weak.t to fail
376 mad_free(o->op_madprop);
382 switch (o->op_type) {
383 case OP_NULL: /* Was holding old type, if any. */
384 if (PL_madskills && o->op_targ != OP_NULL) {
385 o->op_type = o->op_targ;
389 case OP_ENTEREVAL: /* Was holding hints. */
393 if (!(o->op_flags & OPf_REF)
394 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
400 if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
401 /* not an OP_PADAV replacement */
403 if (cPADOPo->op_padix > 0) {
404 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
405 * may still exist on the pad */
406 pad_swipe(cPADOPo->op_padix, TRUE);
407 cPADOPo->op_padix = 0;
410 SvREFCNT_dec(cSVOPo->op_sv);
411 cSVOPo->op_sv = NULL;
415 case OP_METHOD_NAMED:
417 SvREFCNT_dec(cSVOPo->op_sv);
418 cSVOPo->op_sv = NULL;
421 Even if op_clear does a pad_free for the target of the op,
422 pad_free doesn't actually remove the sv that exists in the pad;
423 instead it lives on. This results in that it could be reused as
424 a target later on when the pad was reallocated.
427 pad_swipe(o->op_targ,1);
436 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
440 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
442 if (cPADOPo->op_padix > 0) {
443 pad_swipe(cPADOPo->op_padix, TRUE);
444 cPADOPo->op_padix = 0;
447 SvREFCNT_dec(cSVOPo->op_sv);
448 cSVOPo->op_sv = NULL;
452 PerlMemShared_free(cPVOPo->op_pv);
453 cPVOPo->op_pv = NULL;
457 op_free(cPMOPo->op_pmreplroot);
461 if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) {
462 /* No GvIN_PAD_off here, because other references may still
463 * exist on the pad */
464 pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot), TRUE);
467 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
474 HV * const pmstash = PmopSTASH(cPMOPo);
475 if (pmstash && !SvIS_FREED(pmstash)) {
476 MAGIC * const mg = mg_find((SV*)pmstash, PERL_MAGIC_symtab);
478 PMOP *pmop = (PMOP*) mg->mg_obj;
479 PMOP *lastpmop = NULL;
481 if (cPMOPo == pmop) {
483 lastpmop->op_pmnext = pmop->op_pmnext;
485 mg->mg_obj = (SV*) pmop->op_pmnext;
489 pmop = pmop->op_pmnext;
493 PmopSTASH_free(cPMOPo);
495 cPMOPo->op_pmreplroot = NULL;
496 /* we use the "SAFE" version of the PM_ macros here
497 * since sv_clean_all might release some PMOPs
498 * after PL_regex_padav has been cleared
499 * and the clearing of PL_regex_padav needs to
500 * happen before sv_clean_all
502 ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
503 PM_SETRE_SAFE(cPMOPo, NULL);
505 if(PL_regex_pad) { /* We could be in destruction */
506 av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
507 SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
508 PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
515 if (o->op_targ > 0) {
516 pad_free(o->op_targ);
522 S_cop_free(pTHX_ COP* cop)
527 if (! specialWARN(cop->cop_warnings))
528 PerlMemShared_free(cop->cop_warnings);
529 Perl_refcounted_he_free(aTHX_ cop->cop_hints_hash);
533 Perl_op_null(pTHX_ OP *o)
536 if (o->op_type == OP_NULL)
540 o->op_targ = o->op_type;
541 o->op_type = OP_NULL;
542 o->op_ppaddr = PL_ppaddr[OP_NULL];
546 Perl_op_refcnt_lock(pTHX)
554 Perl_op_refcnt_unlock(pTHX)
561 /* Contextualizers */
563 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
566 Perl_linklist(pTHX_ OP *o)
573 /* establish postfix order */
574 first = cUNOPo->op_first;
577 o->op_next = LINKLIST(first);
580 if (kid->op_sibling) {
581 kid->op_next = LINKLIST(kid->op_sibling);
582 kid = kid->op_sibling;
596 Perl_scalarkids(pTHX_ OP *o)
598 if (o && o->op_flags & OPf_KIDS) {
600 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
607 S_scalarboolean(pTHX_ OP *o)
610 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
611 if (ckWARN(WARN_SYNTAX)) {
612 const line_t oldline = CopLINE(PL_curcop);
614 if (PL_copline != NOLINE)
615 CopLINE_set(PL_curcop, PL_copline);
616 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
617 CopLINE_set(PL_curcop, oldline);
624 Perl_scalar(pTHX_ OP *o)
629 /* assumes no premature commitment */
630 if (!o || PL_error_count || (o->op_flags & OPf_WANT)
631 || o->op_type == OP_RETURN)
636 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
638 switch (o->op_type) {
640 scalar(cBINOPo->op_first);
645 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
649 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
650 if (!kPMOP->op_pmreplroot)
651 deprecate_old("implicit split to @_");
659 if (o->op_flags & OPf_KIDS) {
660 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
666 kid = cLISTOPo->op_first;
668 while ((kid = kid->op_sibling)) {
674 PL_curcop = &PL_compiling;
679 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
685 PL_curcop = &PL_compiling;
688 if (ckWARN(WARN_VOID))
689 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
695 Perl_scalarvoid(pTHX_ OP *o)
699 const char* useless = NULL;
703 /* trailing mad null ops don't count as "there" for void processing */
705 o->op_type != OP_NULL &&
707 o->op_sibling->op_type == OP_NULL)
710 for (sib = o->op_sibling;
711 sib && sib->op_type == OP_NULL;
712 sib = sib->op_sibling) ;
718 if (o->op_type == OP_NEXTSTATE
719 || o->op_type == OP_SETSTATE
720 || o->op_type == OP_DBSTATE
721 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
722 || o->op_targ == OP_SETSTATE
723 || o->op_targ == OP_DBSTATE)))
724 PL_curcop = (COP*)o; /* for warning below */
726 /* assumes no premature commitment */
727 want = o->op_flags & OPf_WANT;
728 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
729 || o->op_type == OP_RETURN)
734 if ((o->op_private & OPpTARGET_MY)
735 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
737 return scalar(o); /* As if inside SASSIGN */
740 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
742 switch (o->op_type) {
744 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
748 if (o->op_flags & OPf_STACKED)
752 if (o->op_private == 4)
824 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
825 useless = OP_DESC(o);
829 kid = cUNOPo->op_first;
830 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
831 kid->op_type != OP_TRANS) {
834 useless = "negative pattern binding (!~)";
841 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
842 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
843 useless = "a variable";
848 if (cSVOPo->op_private & OPpCONST_STRICT)
849 no_bareword_allowed(o);
851 if (ckWARN(WARN_VOID)) {
852 useless = "a constant";
853 if (o->op_private & OPpCONST_ARYBASE)
855 /* don't warn on optimised away booleans, eg
856 * use constant Foo, 5; Foo || print; */
857 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
859 /* the constants 0 and 1 are permitted as they are
860 conventionally used as dummies in constructs like
861 1 while some_condition_with_side_effects; */
862 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
864 else if (SvPOK(sv)) {
865 /* perl4's way of mixing documentation and code
866 (before the invention of POD) was based on a
867 trick to mix nroff and perl code. The trick was
868 built upon these three nroff macros being used in
869 void context. The pink camel has the details in
870 the script wrapman near page 319. */
871 const char * const maybe_macro = SvPVX_const(sv);
872 if (strnEQ(maybe_macro, "di", 2) ||
873 strnEQ(maybe_macro, "ds", 2) ||
874 strnEQ(maybe_macro, "ig", 2))
879 op_null(o); /* don't execute or even remember it */
883 o->op_type = OP_PREINC; /* pre-increment is faster */
884 o->op_ppaddr = PL_ppaddr[OP_PREINC];
888 o->op_type = OP_PREDEC; /* pre-decrement is faster */
889 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
893 o->op_type = OP_I_PREINC; /* pre-increment is faster */
894 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
898 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
899 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
908 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
913 if (o->op_flags & OPf_STACKED)
920 if (!(o->op_flags & OPf_KIDS))
931 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
938 /* all requires must return a boolean value */
939 o->op_flags &= ~OPf_WANT;
944 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
945 if (!kPMOP->op_pmreplroot)
946 deprecate_old("implicit split to @_");
950 if (useless && ckWARN(WARN_VOID))
951 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
956 Perl_listkids(pTHX_ OP *o)
958 if (o && o->op_flags & OPf_KIDS) {
960 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
967 Perl_list(pTHX_ OP *o)
972 /* assumes no premature commitment */
973 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
974 || o->op_type == OP_RETURN)
979 if ((o->op_private & OPpTARGET_MY)
980 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
982 return o; /* As if inside SASSIGN */
985 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
987 switch (o->op_type) {
990 list(cBINOPo->op_first);
995 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1003 if (!(o->op_flags & OPf_KIDS))
1005 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1006 list(cBINOPo->op_first);
1007 return gen_constant_list(o);
1014 kid = cLISTOPo->op_first;
1016 while ((kid = kid->op_sibling)) {
1017 if (kid->op_sibling)
1022 PL_curcop = &PL_compiling;
1026 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1027 if (kid->op_sibling)
1032 PL_curcop = &PL_compiling;
1035 /* all requires must return a boolean value */
1036 o->op_flags &= ~OPf_WANT;
1043 Perl_scalarseq(pTHX_ OP *o)
1047 const OPCODE type = o->op_type;
1049 if (type == OP_LINESEQ || type == OP_SCOPE ||
1050 type == OP_LEAVE || type == OP_LEAVETRY)
1053 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1054 if (kid->op_sibling) {
1058 PL_curcop = &PL_compiling;
1060 o->op_flags &= ~OPf_PARENS;
1061 if (PL_hints & HINT_BLOCK_SCOPE)
1062 o->op_flags |= OPf_PARENS;
1065 o = newOP(OP_STUB, 0);
1070 S_modkids(pTHX_ OP *o, I32 type)
1072 if (o && o->op_flags & OPf_KIDS) {
1074 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1080 /* Propagate lvalue ("modifiable") context to an op and its children.
1081 * 'type' represents the context type, roughly based on the type of op that
1082 * would do the modifying, although local() is represented by OP_NULL.
1083 * It's responsible for detecting things that can't be modified, flag
1084 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
1085 * might have to vivify a reference in $x), and so on.
1087 * For example, "$a+1 = 2" would cause mod() to be called with o being
1088 * OP_ADD and type being OP_SASSIGN, and would output an error.
1092 Perl_mod(pTHX_ OP *o, I32 type)
1096 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1099 if (!o || PL_error_count)
1102 if ((o->op_private & OPpTARGET_MY)
1103 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1108 switch (o->op_type) {
1114 if (!(o->op_private & OPpCONST_ARYBASE))
1117 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1118 CopARYBASE_set(&PL_compiling,
1119 (I32)SvIV(cSVOPx(PL_eval_start)->op_sv));
1123 SAVECOPARYBASE(&PL_compiling);
1124 CopARYBASE_set(&PL_compiling, 0);
1126 else if (type == OP_REFGEN)
1129 Perl_croak(aTHX_ "That use of $[ is unsupported");
1132 if (o->op_flags & OPf_PARENS || PL_madskills)
1136 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1137 !(o->op_flags & OPf_STACKED)) {
1138 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1139 /* The default is to set op_private to the number of children,
1140 which for a UNOP such as RV2CV is always 1. And w're using
1141 the bit for a flag in RV2CV, so we need it clear. */
1142 o->op_private &= ~1;
1143 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1144 assert(cUNOPo->op_first->op_type == OP_NULL);
1145 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1148 else if (o->op_private & OPpENTERSUB_NOMOD)
1150 else { /* lvalue subroutine call */
1151 o->op_private |= OPpLVAL_INTRO;
1152 PL_modcount = RETURN_UNLIMITED_NUMBER;
1153 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1154 /* Backward compatibility mode: */
1155 o->op_private |= OPpENTERSUB_INARGS;
1158 else { /* Compile-time error message: */
1159 OP *kid = cUNOPo->op_first;
1163 if (kid->op_type != OP_PUSHMARK) {
1164 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1166 "panic: unexpected lvalue entersub "
1167 "args: type/targ %ld:%"UVuf,
1168 (long)kid->op_type, (UV)kid->op_targ);
1169 kid = kLISTOP->op_first;
1171 while (kid->op_sibling)
1172 kid = kid->op_sibling;
1173 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1175 if (kid->op_type == OP_METHOD_NAMED
1176 || kid->op_type == OP_METHOD)
1180 NewOp(1101, newop, 1, UNOP);
1181 newop->op_type = OP_RV2CV;
1182 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1183 newop->op_first = NULL;
1184 newop->op_next = (OP*)newop;
1185 kid->op_sibling = (OP*)newop;
1186 newop->op_private |= OPpLVAL_INTRO;
1187 newop->op_private &= ~1;
1191 if (kid->op_type != OP_RV2CV)
1193 "panic: unexpected lvalue entersub "
1194 "entry via type/targ %ld:%"UVuf,
1195 (long)kid->op_type, (UV)kid->op_targ);
1196 kid->op_private |= OPpLVAL_INTRO;
1197 break; /* Postpone until runtime */
1201 kid = kUNOP->op_first;
1202 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1203 kid = kUNOP->op_first;
1204 if (kid->op_type == OP_NULL)
1206 "Unexpected constant lvalue entersub "
1207 "entry via type/targ %ld:%"UVuf,
1208 (long)kid->op_type, (UV)kid->op_targ);
1209 if (kid->op_type != OP_GV) {
1210 /* Restore RV2CV to check lvalueness */
1212 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1213 okid->op_next = kid->op_next;
1214 kid->op_next = okid;
1217 okid->op_next = NULL;
1218 okid->op_type = OP_RV2CV;
1220 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1221 okid->op_private |= OPpLVAL_INTRO;
1222 okid->op_private &= ~1;
1226 cv = GvCV(kGVOP_gv);
1236 /* grep, foreach, subcalls, refgen */
1237 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1239 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1240 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1242 : (o->op_type == OP_ENTERSUB
1243 ? "non-lvalue subroutine call"
1245 type ? PL_op_desc[type] : "local"));
1259 case OP_RIGHT_SHIFT:
1268 if (!(o->op_flags & OPf_STACKED))
1275 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1281 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1282 PL_modcount = RETURN_UNLIMITED_NUMBER;
1283 return o; /* Treat \(@foo) like ordinary list. */
1287 if (scalar_mod_type(o, type))
1289 ref(cUNOPo->op_first, o->op_type);
1293 if (type == OP_LEAVESUBLV)
1294 o->op_private |= OPpMAYBE_LVSUB;
1300 PL_modcount = RETURN_UNLIMITED_NUMBER;
1303 ref(cUNOPo->op_first, o->op_type);
1308 PL_hints |= HINT_BLOCK_SCOPE;
1323 PL_modcount = RETURN_UNLIMITED_NUMBER;
1324 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1325 return o; /* Treat \(@foo) like ordinary list. */
1326 if (scalar_mod_type(o, type))
1328 if (type == OP_LEAVESUBLV)
1329 o->op_private |= OPpMAYBE_LVSUB;
1333 if (!type) /* local() */
1334 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1335 PAD_COMPNAME_PV(o->op_targ));
1343 if (type != OP_SASSIGN)
1347 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1352 if (type == OP_LEAVESUBLV)
1353 o->op_private |= OPpMAYBE_LVSUB;
1355 pad_free(o->op_targ);
1356 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1357 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1358 if (o->op_flags & OPf_KIDS)
1359 mod(cBINOPo->op_first->op_sibling, type);
1364 ref(cBINOPo->op_first, o->op_type);
1365 if (type == OP_ENTERSUB &&
1366 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1367 o->op_private |= OPpLVAL_DEFER;
1368 if (type == OP_LEAVESUBLV)
1369 o->op_private |= OPpMAYBE_LVSUB;
1379 if (o->op_flags & OPf_KIDS)
1380 mod(cLISTOPo->op_last, type);
1385 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1387 else if (!(o->op_flags & OPf_KIDS))
1389 if (o->op_targ != OP_LIST) {
1390 mod(cBINOPo->op_first, type);
1396 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1401 if (type != OP_LEAVESUBLV)
1403 break; /* mod()ing was handled by ck_return() */
1406 /* [20011101.069] File test operators interpret OPf_REF to mean that
1407 their argument is a filehandle; thus \stat(".") should not set
1409 if (type == OP_REFGEN &&
1410 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1413 if (type != OP_LEAVESUBLV)
1414 o->op_flags |= OPf_MOD;
1416 if (type == OP_AASSIGN || type == OP_SASSIGN)
1417 o->op_flags |= OPf_SPECIAL|OPf_REF;
1418 else if (!type) { /* local() */
1421 o->op_private |= OPpLVAL_INTRO;
1422 o->op_flags &= ~OPf_SPECIAL;
1423 PL_hints |= HINT_BLOCK_SCOPE;
1428 if (ckWARN(WARN_SYNTAX)) {
1429 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1430 "Useless localization of %s", OP_DESC(o));
1434 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1435 && type != OP_LEAVESUBLV)
1436 o->op_flags |= OPf_REF;
1441 S_scalar_mod_type(const OP *o, I32 type)
1445 if (o->op_type == OP_RV2GV)
1469 case OP_RIGHT_SHIFT:
1488 S_is_handle_constructor(const OP *o, I32 numargs)
1490 switch (o->op_type) {
1498 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1511 Perl_refkids(pTHX_ OP *o, I32 type)
1513 if (o && o->op_flags & OPf_KIDS) {
1515 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1522 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
1527 if (!o || PL_error_count)
1530 switch (o->op_type) {
1532 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1533 !(o->op_flags & OPf_STACKED)) {
1534 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1535 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1536 assert(cUNOPo->op_first->op_type == OP_NULL);
1537 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1538 o->op_flags |= OPf_SPECIAL;
1539 o->op_private &= ~1;
1544 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1545 doref(kid, type, set_op_ref);
1548 if (type == OP_DEFINED)
1549 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1550 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1553 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1554 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1555 : type == OP_RV2HV ? OPpDEREF_HV
1557 o->op_flags |= OPf_MOD;
1564 o->op_flags |= OPf_REF;
1567 if (type == OP_DEFINED)
1568 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1569 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1575 o->op_flags |= OPf_REF;
1580 if (!(o->op_flags & OPf_KIDS))
1582 doref(cBINOPo->op_first, type, set_op_ref);
1586 doref(cBINOPo->op_first, o->op_type, set_op_ref);
1587 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1588 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1589 : type == OP_RV2HV ? OPpDEREF_HV
1591 o->op_flags |= OPf_MOD;
1601 if (!(o->op_flags & OPf_KIDS))
1603 doref(cLISTOPo->op_last, type, set_op_ref);
1613 S_dup_attrlist(pTHX_ OP *o)
1618 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1619 * where the first kid is OP_PUSHMARK and the remaining ones
1620 * are OP_CONST. We need to push the OP_CONST values.
1622 if (o->op_type == OP_CONST)
1623 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
1625 else if (o->op_type == OP_NULL)
1629 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1631 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1632 if (o->op_type == OP_CONST)
1633 rop = append_elem(OP_LIST, rop,
1634 newSVOP(OP_CONST, o->op_flags,
1635 SvREFCNT_inc_NN(cSVOPo->op_sv)));
1642 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1647 /* fake up C<use attributes $pkg,$rv,@attrs> */
1648 ENTER; /* need to protect against side-effects of 'use' */
1650 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1652 #define ATTRSMODULE "attributes"
1653 #define ATTRSMODULE_PM "attributes.pm"
1656 /* Don't force the C<use> if we don't need it. */
1657 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
1658 if (svp && *svp != &PL_sv_undef)
1659 NOOP; /* already in %INC */
1661 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1662 newSVpvs(ATTRSMODULE), NULL);
1665 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1666 newSVpvs(ATTRSMODULE),
1668 prepend_elem(OP_LIST,
1669 newSVOP(OP_CONST, 0, stashsv),
1670 prepend_elem(OP_LIST,
1671 newSVOP(OP_CONST, 0,
1673 dup_attrlist(attrs))));
1679 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1682 OP *pack, *imop, *arg;
1688 assert(target->op_type == OP_PADSV ||
1689 target->op_type == OP_PADHV ||
1690 target->op_type == OP_PADAV);
1692 /* Ensure that attributes.pm is loaded. */
1693 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1695 /* Need package name for method call. */
1696 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
1698 /* Build up the real arg-list. */
1699 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1701 arg = newOP(OP_PADSV, 0);
1702 arg->op_targ = target->op_targ;
1703 arg = prepend_elem(OP_LIST,
1704 newSVOP(OP_CONST, 0, stashsv),
1705 prepend_elem(OP_LIST,
1706 newUNOP(OP_REFGEN, 0,
1707 mod(arg, OP_REFGEN)),
1708 dup_attrlist(attrs)));
1710 /* Fake up a method call to import */
1711 meth = newSVpvs_share("import");
1712 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1713 append_elem(OP_LIST,
1714 prepend_elem(OP_LIST, pack, list(arg)),
1715 newSVOP(OP_METHOD_NAMED, 0, meth)));
1716 imop->op_private |= OPpENTERSUB_NOMOD;
1718 /* Combine the ops. */
1719 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1723 =notfor apidoc apply_attrs_string
1725 Attempts to apply a list of attributes specified by the C<attrstr> and
1726 C<len> arguments to the subroutine identified by the C<cv> argument which
1727 is expected to be associated with the package identified by the C<stashpv>
1728 argument (see L<attributes>). It gets this wrong, though, in that it
1729 does not correctly identify the boundaries of the individual attribute
1730 specifications within C<attrstr>. This is not really intended for the
1731 public API, but has to be listed here for systems such as AIX which
1732 need an explicit export list for symbols. (It's called from XS code
1733 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1734 to respect attribute syntax properly would be welcome.
1740 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
1741 const char *attrstr, STRLEN len)
1746 len = strlen(attrstr);
1750 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1752 const char * const sstr = attrstr;
1753 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1754 attrs = append_elem(OP_LIST, attrs,
1755 newSVOP(OP_CONST, 0,
1756 newSVpvn(sstr, attrstr-sstr)));
1760 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1761 newSVpvs(ATTRSMODULE),
1762 NULL, prepend_elem(OP_LIST,
1763 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1764 prepend_elem(OP_LIST,
1765 newSVOP(OP_CONST, 0,
1771 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
1776 if (!o || PL_error_count)
1780 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
1781 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
1785 if (type == OP_LIST) {
1787 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1788 my_kid(kid, attrs, imopsp);
1789 } else if (type == OP_UNDEF
1795 } else if (type == OP_RV2SV || /* "our" declaration */
1797 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1798 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1799 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1801 PL_in_my == KEY_our ? "our" : PL_in_my == KEY_state ? "state" : "my"));
1803 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
1805 PL_in_my_stash = NULL;
1806 apply_attrs(GvSTASH(gv),
1807 (type == OP_RV2SV ? GvSV(gv) :
1808 type == OP_RV2AV ? (SV*)GvAV(gv) :
1809 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1812 o->op_private |= OPpOUR_INTRO;
1815 else if (type != OP_PADSV &&
1818 type != OP_PUSHMARK)
1820 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1822 PL_in_my == KEY_our ? "our" : PL_in_my == KEY_state ? "state" : "my"));
1825 else if (attrs && type != OP_PUSHMARK) {
1829 PL_in_my_stash = NULL;
1831 /* check for C<my Dog $spot> when deciding package */
1832 stash = PAD_COMPNAME_TYPE(o->op_targ);
1834 stash = PL_curstash;
1835 apply_attrs_my(stash, o, attrs, imopsp);
1837 o->op_flags |= OPf_MOD;
1838 o->op_private |= OPpLVAL_INTRO;
1839 if (PL_in_my == KEY_state)
1840 o->op_private |= OPpPAD_STATE;
1845 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1849 int maybe_scalar = 0;
1851 /* [perl #17376]: this appears to be premature, and results in code such as
1852 C< our(%x); > executing in list mode rather than void mode */
1854 if (o->op_flags & OPf_PARENS)
1864 o = my_kid(o, attrs, &rops);
1866 if (maybe_scalar && o->op_type == OP_PADSV) {
1867 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
1868 o->op_private |= OPpLVAL_INTRO;
1871 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
1874 PL_in_my_stash = NULL;
1879 Perl_my(pTHX_ OP *o)
1881 return my_attrs(o, NULL);
1885 Perl_sawparens(pTHX_ OP *o)
1887 PERL_UNUSED_CONTEXT;
1889 o->op_flags |= OPf_PARENS;
1894 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
1898 const OPCODE ltype = left->op_type;
1899 const OPCODE rtype = right->op_type;
1901 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
1902 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
1904 const char * const desc
1905 = PL_op_desc[(rtype == OP_SUBST || rtype == OP_TRANS)
1906 ? (int)rtype : OP_MATCH];
1907 const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV)
1908 ? "@array" : "%hash");
1909 Perl_warner(aTHX_ packWARN(WARN_MISC),
1910 "Applying %s to %s will act on scalar(%s)",
1911 desc, sample, sample);
1914 if (rtype == OP_CONST &&
1915 cSVOPx(right)->op_private & OPpCONST_BARE &&
1916 cSVOPx(right)->op_private & OPpCONST_STRICT)
1918 no_bareword_allowed(right);
1921 ismatchop = rtype == OP_MATCH ||
1922 rtype == OP_SUBST ||
1924 if (ismatchop && right->op_private & OPpTARGET_MY) {
1926 right->op_private &= ~OPpTARGET_MY;
1928 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
1931 right->op_flags |= OPf_STACKED;
1932 if (rtype != OP_MATCH &&
1933 ! (rtype == OP_TRANS &&
1934 right->op_private & OPpTRANS_IDENTICAL))
1935 newleft = mod(left, rtype);
1938 if (right->op_type == OP_TRANS)
1939 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
1941 o = prepend_elem(rtype, scalar(newleft), right);
1943 return newUNOP(OP_NOT, 0, scalar(o));
1947 return bind_match(type, left,
1948 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
1952 Perl_invert(pTHX_ OP *o)
1956 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
1960 Perl_scope(pTHX_ OP *o)
1964 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
1965 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
1966 o->op_type = OP_LEAVE;
1967 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
1969 else if (o->op_type == OP_LINESEQ) {
1971 o->op_type = OP_SCOPE;
1972 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
1973 kid = ((LISTOP*)o)->op_first;
1974 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
1977 /* The following deals with things like 'do {1 for 1}' */
1978 kid = kid->op_sibling;
1980 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
1985 o = newLISTOP(OP_SCOPE, 0, o, NULL);
1991 Perl_block_start(pTHX_ int full)
1994 const int retval = PL_savestack_ix;
1995 pad_block_start(full);
1997 PL_hints &= ~HINT_BLOCK_SCOPE;
1998 SAVECOMPILEWARNINGS();
1999 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
2004 Perl_block_end(pTHX_ I32 floor, OP *seq)
2007 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2008 OP* const retval = scalarseq(seq);
2010 CopHINTS_set(&PL_compiling, PL_hints);
2012 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2021 const PADOFFSET offset = pad_findmy("$_");
2022 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
2023 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2026 OP * const o = newOP(OP_PADSV, 0);
2027 o->op_targ = offset;
2033 Perl_newPROG(pTHX_ OP *o)
2039 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2040 ((PL_in_eval & EVAL_KEEPERR)
2041 ? OPf_SPECIAL : 0), o);
2042 PL_eval_start = linklist(PL_eval_root);
2043 PL_eval_root->op_private |= OPpREFCOUNTED;
2044 OpREFCNT_set(PL_eval_root, 1);
2045 PL_eval_root->op_next = 0;
2046 CALL_PEEP(PL_eval_start);
2049 if (o->op_type == OP_STUB) {
2050 PL_comppad_name = 0;
2052 S_op_destroy(aTHX_ o);
2055 PL_main_root = scope(sawparens(scalarvoid(o)));
2056 PL_curcop = &PL_compiling;
2057 PL_main_start = LINKLIST(PL_main_root);
2058 PL_main_root->op_private |= OPpREFCOUNTED;
2059 OpREFCNT_set(PL_main_root, 1);
2060 PL_main_root->op_next = 0;
2061 CALL_PEEP(PL_main_start);
2064 /* Register with debugger */
2067 = Perl_get_cvn_flags(aTHX_ STR_WITH_LEN("DB::postponed"), 0);
2071 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2073 call_sv((SV*)cv, G_DISCARD);
2080 Perl_localize(pTHX_ OP *o, I32 lex)
2083 if (o->op_flags & OPf_PARENS)
2084 /* [perl #17376]: this appears to be premature, and results in code such as
2085 C< our(%x); > executing in list mode rather than void mode */
2092 if ( PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ','
2093 && ckWARN(WARN_PARENTHESIS))
2095 char *s = PL_bufptr;
2098 /* some heuristics to detect a potential error */
2099 while (*s && (strchr(", \t\n", *s)))
2103 if (*s && strchr("@$%*", *s) && *++s
2104 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2107 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2109 while (*s && (strchr(", \t\n", *s)))
2115 if (sigil && (*s == ';' || *s == '=')) {
2116 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2117 "Parentheses missing around \"%s\" list",
2118 lex ? (PL_in_my == KEY_our ? "our" : PL_in_my == KEY_state ? "state" : "my")
2126 o = mod(o, OP_NULL); /* a bit kludgey */
2128 PL_in_my_stash = NULL;
2133 Perl_jmaybe(pTHX_ OP *o)
2135 if (o->op_type == OP_LIST) {
2137 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2138 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2144 Perl_fold_constants(pTHX_ register OP *o)
2149 VOL I32 type = o->op_type;
2154 SV * const oldwarnhook = PL_warnhook;
2155 SV * const olddiehook = PL_diehook;
2158 if (PL_opargs[type] & OA_RETSCALAR)
2160 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2161 o->op_targ = pad_alloc(type, SVs_PADTMP);
2163 /* integerize op, unless it happens to be C<-foo>.
2164 * XXX should pp_i_negate() do magic string negation instead? */
2165 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2166 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2167 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2169 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2172 if (!(PL_opargs[type] & OA_FOLDCONST))
2177 /* XXX might want a ck_negate() for this */
2178 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2189 /* XXX what about the numeric ops? */
2190 if (PL_hints & HINT_LOCALE)
2195 goto nope; /* Don't try to run w/ errors */
2197 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2198 const OPCODE type = curop->op_type;
2199 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2201 type != OP_SCALAR &&
2203 type != OP_PUSHMARK)
2209 curop = LINKLIST(o);
2210 old_next = o->op_next;
2214 oldscope = PL_scopestack_ix;
2215 create_eval_scope(G_FAKINGEVAL);
2217 PL_warnhook = PERL_WARNHOOK_FATAL;
2224 sv = *(PL_stack_sp--);
2225 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2226 pad_swipe(o->op_targ, FALSE);
2227 else if (SvTEMP(sv)) { /* grab mortal temp? */
2228 SvREFCNT_inc_simple_void(sv);
2233 /* Something tried to die. Abandon constant folding. */
2234 /* Pretend the error never happened. */
2235 sv_setpvn(ERRSV,"",0);
2236 o->op_next = old_next;
2240 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
2241 PL_warnhook = oldwarnhook;
2242 PL_diehook = olddiehook;
2243 /* XXX note that this croak may fail as we've already blown away
2244 * the stack - eg any nested evals */
2245 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
2248 PL_warnhook = oldwarnhook;
2249 PL_diehook = olddiehook;
2251 if (PL_scopestack_ix > oldscope)
2252 delete_eval_scope();
2261 if (type == OP_RV2GV)
2262 newop = newGVOP(OP_GV, 0, (GV*)sv);
2264 newop = newSVOP(OP_CONST, 0, (SV*)sv);
2265 op_getmad(o,newop,'f');
2273 Perl_gen_constant_list(pTHX_ register OP *o)
2277 const I32 oldtmps_floor = PL_tmps_floor;
2281 return o; /* Don't attempt to run with errors */
2283 PL_op = curop = LINKLIST(o);
2289 assert (!(curop->op_flags & OPf_SPECIAL));
2290 assert(curop->op_type == OP_RANGE);
2292 PL_tmps_floor = oldtmps_floor;
2294 o->op_type = OP_RV2AV;
2295 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2296 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2297 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2298 o->op_opt = 0; /* needs to be revisited in peep() */
2299 curop = ((UNOP*)o)->op_first;
2300 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
2302 op_getmad(curop,o,'O');
2311 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2314 if (!o || o->op_type != OP_LIST)
2315 o = newLISTOP(OP_LIST, 0, o, NULL);
2317 o->op_flags &= ~OPf_WANT;
2319 if (!(PL_opargs[type] & OA_MARK))
2320 op_null(cLISTOPo->op_first);
2322 o->op_type = (OPCODE)type;
2323 o->op_ppaddr = PL_ppaddr[type];
2324 o->op_flags |= flags;
2326 o = CHECKOP(type, o);
2327 if (o->op_type != (unsigned)type)
2330 return fold_constants(o);
2333 /* List constructors */
2336 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2344 if (first->op_type != (unsigned)type
2345 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2347 return newLISTOP(type, 0, first, last);
2350 if (first->op_flags & OPf_KIDS)
2351 ((LISTOP*)first)->op_last->op_sibling = last;
2353 first->op_flags |= OPf_KIDS;
2354 ((LISTOP*)first)->op_first = last;
2356 ((LISTOP*)first)->op_last = last;
2361 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2369 if (first->op_type != (unsigned)type)
2370 return prepend_elem(type, (OP*)first, (OP*)last);
2372 if (last->op_type != (unsigned)type)
2373 return append_elem(type, (OP*)first, (OP*)last);
2375 first->op_last->op_sibling = last->op_first;
2376 first->op_last = last->op_last;
2377 first->op_flags |= (last->op_flags & OPf_KIDS);
2380 if (last->op_first && first->op_madprop) {
2381 MADPROP *mp = last->op_first->op_madprop;
2383 while (mp->mad_next)
2385 mp->mad_next = first->op_madprop;
2388 last->op_first->op_madprop = first->op_madprop;
2391 first->op_madprop = last->op_madprop;
2392 last->op_madprop = 0;
2395 S_op_destroy(aTHX_ (OP*)last);
2401 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2409 if (last->op_type == (unsigned)type) {
2410 if (type == OP_LIST) { /* already a PUSHMARK there */
2411 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2412 ((LISTOP*)last)->op_first->op_sibling = first;
2413 if (!(first->op_flags & OPf_PARENS))
2414 last->op_flags &= ~OPf_PARENS;
2417 if (!(last->op_flags & OPf_KIDS)) {
2418 ((LISTOP*)last)->op_last = first;
2419 last->op_flags |= OPf_KIDS;
2421 first->op_sibling = ((LISTOP*)last)->op_first;
2422 ((LISTOP*)last)->op_first = first;
2424 last->op_flags |= OPf_KIDS;
2428 return newLISTOP(type, 0, first, last);
2436 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2439 Newxz(tk, 1, TOKEN);
2440 tk->tk_type = (OPCODE)optype;
2441 tk->tk_type = 12345;
2443 tk->tk_mad = madprop;
2448 Perl_token_free(pTHX_ TOKEN* tk)
2450 if (tk->tk_type != 12345)
2452 mad_free(tk->tk_mad);
2457 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2461 if (tk->tk_type != 12345) {
2462 Perl_warner(aTHX_ packWARN(WARN_MISC),
2463 "Invalid TOKEN object ignored");
2470 /* faked up qw list? */
2472 tm->mad_type == MAD_SV &&
2473 SvPVX((SV*)tm->mad_val)[0] == 'q')
2480 /* pretend constant fold didn't happen? */
2481 if (mp->mad_key == 'f' &&
2482 (o->op_type == OP_CONST ||
2483 o->op_type == OP_GV) )
2485 token_getmad(tk,(OP*)mp->mad_val,slot);
2499 if (mp->mad_key == 'X')
2500 mp->mad_key = slot; /* just change the first one */
2510 Perl_op_getmad_weak(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,0);
2534 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
2540 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
2549 /* pretend constant fold didn't happen? */
2550 if (mp->mad_key == 'f' &&
2551 (o->op_type == OP_CONST ||
2552 o->op_type == OP_GV) )
2554 op_getmad(from,(OP*)mp->mad_val,slot);
2561 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
2564 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
2568 PerlIO_printf(PerlIO_stderr(),
2569 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
2575 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
2593 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
2597 addmad(tm, &(o->op_madprop), slot);
2601 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
2622 Perl_newMADsv(pTHX_ char key, SV* sv)
2624 return newMADPROP(key, MAD_SV, sv, 0);
2628 Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
2631 Newxz(mp, 1, MADPROP);
2634 mp->mad_vlen = vlen;
2635 mp->mad_type = type;
2637 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
2642 Perl_mad_free(pTHX_ MADPROP* mp)
2644 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
2648 mad_free(mp->mad_next);
2649 /* if (PL_lex_state != LEX_NOTPARSING && mp->mad_vlen)
2650 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
2651 switch (mp->mad_type) {
2655 Safefree((char*)mp->mad_val);
2658 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
2659 op_free((OP*)mp->mad_val);
2662 sv_free((SV*)mp->mad_val);
2665 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
2674 Perl_newNULLLIST(pTHX)
2676 return newOP(OP_STUB, 0);
2680 Perl_force_list(pTHX_ OP *o)
2682 if (!o || o->op_type != OP_LIST)
2683 o = newLISTOP(OP_LIST, 0, o, NULL);
2689 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2694 NewOp(1101, listop, 1, LISTOP);
2696 listop->op_type = (OPCODE)type;
2697 listop->op_ppaddr = PL_ppaddr[type];
2700 listop->op_flags = (U8)flags;
2704 else if (!first && last)
2707 first->op_sibling = last;
2708 listop->op_first = first;
2709 listop->op_last = last;
2710 if (type == OP_LIST) {
2711 OP* const pushop = newOP(OP_PUSHMARK, 0);
2712 pushop->op_sibling = first;
2713 listop->op_first = pushop;
2714 listop->op_flags |= OPf_KIDS;
2716 listop->op_last = pushop;
2719 return CHECKOP(type, listop);
2723 Perl_newOP(pTHX_ I32 type, I32 flags)
2727 NewOp(1101, o, 1, OP);
2728 o->op_type = (OPCODE)type;
2729 o->op_ppaddr = PL_ppaddr[type];
2730 o->op_flags = (U8)flags;
2732 o->op_latefreed = 0;
2736 o->op_private = (U8)(0 | (flags >> 8));
2737 if (PL_opargs[type] & OA_RETSCALAR)
2739 if (PL_opargs[type] & OA_TARGET)
2740 o->op_targ = pad_alloc(type, SVs_PADTMP);
2741 return CHECKOP(type, o);
2745 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2751 first = newOP(OP_STUB, 0);
2752 if (PL_opargs[type] & OA_MARK)
2753 first = force_list(first);
2755 NewOp(1101, unop, 1, UNOP);
2756 unop->op_type = (OPCODE)type;
2757 unop->op_ppaddr = PL_ppaddr[type];
2758 unop->op_first = first;
2759 unop->op_flags = (U8)(flags | OPf_KIDS);
2760 unop->op_private = (U8)(1 | (flags >> 8));
2761 unop = (UNOP*) CHECKOP(type, unop);
2765 return fold_constants((OP *) unop);
2769 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2773 NewOp(1101, binop, 1, BINOP);
2776 first = newOP(OP_NULL, 0);
2778 binop->op_type = (OPCODE)type;
2779 binop->op_ppaddr = PL_ppaddr[type];
2780 binop->op_first = first;
2781 binop->op_flags = (U8)(flags | OPf_KIDS);
2784 binop->op_private = (U8)(1 | (flags >> 8));
2787 binop->op_private = (U8)(2 | (flags >> 8));
2788 first->op_sibling = last;
2791 binop = (BINOP*)CHECKOP(type, binop);
2792 if (binop->op_next || binop->op_type != (OPCODE)type)
2795 binop->op_last = binop->op_first->op_sibling;
2797 return fold_constants((OP *)binop);
2800 static int uvcompare(const void *a, const void *b)
2801 __attribute__nonnull__(1)
2802 __attribute__nonnull__(2)
2803 __attribute__pure__;
2804 static int uvcompare(const void *a, const void *b)
2806 if (*((const UV *)a) < (*(const UV *)b))
2808 if (*((const UV *)a) > (*(const UV *)b))
2810 if (*((const UV *)a+1) < (*(const UV *)b+1))
2812 if (*((const UV *)a+1) > (*(const UV *)b+1))
2818 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2821 SV * const tstr = ((SVOP*)expr)->op_sv;
2824 (repl->op_type == OP_NULL)
2825 ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
2827 ((SVOP*)repl)->op_sv;
2830 const U8 *t = (U8*)SvPV_const(tstr, tlen);
2831 const U8 *r = (U8*)SvPV_const(rstr, rlen);
2835 register short *tbl;
2837 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
2838 const I32 squash = o->op_private & OPpTRANS_SQUASH;
2839 I32 del = o->op_private & OPpTRANS_DELETE;
2841 PL_hints |= HINT_BLOCK_SCOPE;
2844 o->op_private |= OPpTRANS_FROM_UTF;
2847 o->op_private |= OPpTRANS_TO_UTF;
2849 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2850 SV* const listsv = newSVpvs("# comment\n");
2852 const U8* tend = t + tlen;
2853 const U8* rend = r + rlen;
2867 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2868 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2871 const U32 flags = UTF8_ALLOW_DEFAULT;
2875 t = tsave = bytes_to_utf8(t, &len);
2878 if (!to_utf && rlen) {
2880 r = rsave = bytes_to_utf8(r, &len);
2884 /* There are several snags with this code on EBCDIC:
2885 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2886 2. scan_const() in toke.c has encoded chars in native encoding which makes
2887 ranges at least in EBCDIC 0..255 range the bottom odd.
2891 U8 tmpbuf[UTF8_MAXBYTES+1];
2894 Newx(cp, 2*tlen, UV);
2896 transv = newSVpvs("");
2898 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
2900 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2902 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
2906 cp[2*i+1] = cp[2*i];
2910 qsort(cp, i, 2*sizeof(UV), uvcompare);
2911 for (j = 0; j < i; j++) {
2913 diff = val - nextmin;
2915 t = uvuni_to_utf8(tmpbuf,nextmin);
2916 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2918 U8 range_mark = UTF_TO_NATIVE(0xff);
2919 t = uvuni_to_utf8(tmpbuf, val - 1);
2920 sv_catpvn(transv, (char *)&range_mark, 1);
2921 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2928 t = uvuni_to_utf8(tmpbuf,nextmin);
2929 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2931 U8 range_mark = UTF_TO_NATIVE(0xff);
2932 sv_catpvn(transv, (char *)&range_mark, 1);
2934 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2935 UNICODE_ALLOW_SUPER);
2936 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2937 t = (const U8*)SvPVX_const(transv);
2938 tlen = SvCUR(transv);
2942 else if (!rlen && !del) {
2943 r = t; rlen = tlen; rend = tend;
2946 if ((!rlen && !del) || t == r ||
2947 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2949 o->op_private |= OPpTRANS_IDENTICAL;
2953 while (t < tend || tfirst <= tlast) {
2954 /* see if we need more "t" chars */
2955 if (tfirst > tlast) {
2956 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
2958 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2960 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
2967 /* now see if we need more "r" chars */
2968 if (rfirst > rlast) {
2970 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
2972 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2974 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
2983 rfirst = rlast = 0xffffffff;
2987 /* now see which range will peter our first, if either. */
2988 tdiff = tlast - tfirst;
2989 rdiff = rlast - rfirst;
2996 if (rfirst == 0xffffffff) {
2997 diff = tdiff; /* oops, pretend rdiff is infinite */
2999 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
3000 (long)tfirst, (long)tlast);
3002 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
3006 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
3007 (long)tfirst, (long)(tfirst + diff),
3010 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3011 (long)tfirst, (long)rfirst);
3013 if (rfirst + diff > max)
3014 max = rfirst + diff;
3016 grows = (tfirst < rfirst &&
3017 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3029 else if (max > 0xff)
3034 PerlMemShared_free(cPVOPo->op_pv);
3035 cPVOPo->op_pv = NULL;
3037 swash = (SV*)swash_init("utf8", "", listsv, bits, none);
3039 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
3040 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
3041 PAD_SETSV(cPADOPo->op_padix, swash);
3044 cSVOPo->op_sv = swash;
3046 SvREFCNT_dec(listsv);
3047 SvREFCNT_dec(transv);
3049 if (!del && havefinal && rlen)
3050 (void)hv_store((HV*)SvRV(swash), "FINAL", 5,
3051 newSVuv((UV)final), 0);
3054 o->op_private |= OPpTRANS_GROWS;
3060 op_getmad(expr,o,'e');
3061 op_getmad(repl,o,'r');
3069 tbl = (short*)cPVOPo->op_pv;
3071 Zero(tbl, 256, short);
3072 for (i = 0; i < (I32)tlen; i++)
3074 for (i = 0, j = 0; i < 256; i++) {
3076 if (j >= (I32)rlen) {
3085 if (i < 128 && r[j] >= 128)
3095 o->op_private |= OPpTRANS_IDENTICAL;
3097 else if (j >= (I32)rlen)
3102 PerlMemShared_realloc(tbl,
3103 (0x101+rlen-j) * sizeof(short));
3104 cPVOPo->op_pv = (char*)tbl;
3106 tbl[0x100] = (short)(rlen - j);
3107 for (i=0; i < (I32)rlen - j; i++)
3108 tbl[0x101+i] = r[j+i];
3112 if (!rlen && !del) {
3115 o->op_private |= OPpTRANS_IDENTICAL;
3117 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3118 o->op_private |= OPpTRANS_IDENTICAL;
3120 for (i = 0; i < 256; i++)
3122 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3123 if (j >= (I32)rlen) {
3125 if (tbl[t[i]] == -1)
3131 if (tbl[t[i]] == -1) {
3132 if (t[i] < 128 && r[j] >= 128)
3139 o->op_private |= OPpTRANS_GROWS;
3141 op_getmad(expr,o,'e');
3142 op_getmad(repl,o,'r');
3152 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3157 NewOp(1101, pmop, 1, PMOP);
3158 pmop->op_type = (OPCODE)type;
3159 pmop->op_ppaddr = PL_ppaddr[type];
3160 pmop->op_flags = (U8)flags;
3161 pmop->op_private = (U8)(0 | (flags >> 8));
3163 if (PL_hints & HINT_RE_TAINT)
3164 pmop->op_pmpermflags |= PMf_RETAINT;
3165 if (PL_hints & HINT_LOCALE)
3166 pmop->op_pmpermflags |= PMf_LOCALE;
3167 pmop->op_pmflags = pmop->op_pmpermflags;
3170 if (av_len((AV*) PL_regex_pad[0]) > -1) {
3171 SV * const repointer = av_pop((AV*)PL_regex_pad[0]);
3172 pmop->op_pmoffset = SvIV(repointer);
3173 SvREPADTMP_off(repointer);
3174 sv_setiv(repointer,0);
3176 SV * const repointer = newSViv(0);
3177 av_push(PL_regex_padav, SvREFCNT_inc_simple_NN(repointer));
3178 pmop->op_pmoffset = av_len(PL_regex_padav);
3179 PL_regex_pad = AvARRAY(PL_regex_padav);
3183 /* link into pm list */
3184 if (type != OP_TRANS && PL_curstash) {
3185 MAGIC *mg = mg_find((SV*)PL_curstash, PERL_MAGIC_symtab);
3188 mg = sv_magicext((SV*)PL_curstash, 0, PERL_MAGIC_symtab, 0, 0, 0);
3190 pmop->op_pmnext = (PMOP*)mg->mg_obj;
3191 mg->mg_obj = (SV*)pmop;
3192 PmopSTASH_set(pmop,PL_curstash);
3195 return CHECKOP(type, pmop);
3198 /* Given some sort of match op o, and an expression expr containing a
3199 * pattern, either compile expr into a regex and attach it to o (if it's
3200 * constant), or convert expr into a runtime regcomp op sequence (if it's
3203 * isreg indicates that the pattern is part of a regex construct, eg
3204 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3205 * split "pattern", which aren't. In the former case, expr will be a list
3206 * if the pattern contains more than one term (eg /a$b/) or if it contains
3207 * a replacement, ie s/// or tr///.
3211 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
3216 I32 repl_has_vars = 0;
3220 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
3221 /* last element in list is the replacement; pop it */
3223 repl = cLISTOPx(expr)->op_last;
3224 kid = cLISTOPx(expr)->op_first;
3225 while (kid->op_sibling != repl)
3226 kid = kid->op_sibling;
3227 kid->op_sibling = NULL;
3228 cLISTOPx(expr)->op_last = kid;
3231 if (isreg && expr->op_type == OP_LIST &&
3232 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3234 /* convert single element list to element */
3235 OP* const oe = expr;
3236 expr = cLISTOPx(oe)->op_first->op_sibling;
3237 cLISTOPx(oe)->op_first->op_sibling = NULL;
3238 cLISTOPx(oe)->op_last = NULL;
3242 if (o->op_type == OP_TRANS) {
3243 return pmtrans(o, expr, repl);
3246 reglist = isreg && expr->op_type == OP_LIST;
3250 PL_hints |= HINT_BLOCK_SCOPE;
3253 if (expr->op_type == OP_CONST) {
3255 SV * const pat = ((SVOP*)expr)->op_sv;
3256 const char *p = SvPV_const(pat, plen);
3257 if ((o->op_flags & OPf_SPECIAL) && (plen == 1 && *p == ' ')) {
3258 U32 was_readonly = SvREADONLY(pat);
3262 sv_force_normal_flags(pat, 0);
3263 assert(!SvREADONLY(pat));
3266 SvREADONLY_off(pat);
3270 sv_setpvn(pat, "\\s+", 3);
3272 SvFLAGS(pat) |= was_readonly;
3274 p = SvPV_const(pat, plen);
3275 pm->op_pmflags |= PMf_SKIPWHITE;
3278 pm->op_pmdynflags |= PMdf_UTF8;
3279 /* FIXME - can we make this function take const char * args? */
3280 PM_SETRE(pm, CALLREGCOMP((char*)p, (char*)p + plen, pm));
3281 if (PM_GETRE(pm)->extflags & RXf_WHITE)
3282 pm->op_pmflags |= PMf_WHITE;
3284 pm->op_pmflags &= ~PMf_WHITE;
3286 op_getmad(expr,(OP*)pm,'e');
3292 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3293 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3295 : OP_REGCMAYBE),0,expr);
3297 NewOp(1101, rcop, 1, LOGOP);
3298 rcop->op_type = OP_REGCOMP;
3299 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3300 rcop->op_first = scalar(expr);
3301 rcop->op_flags |= OPf_KIDS
3302 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3303 | (reglist ? OPf_STACKED : 0);
3304 rcop->op_private = 1;
3307 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3309 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
3312 /* establish postfix order */
3313 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3315 rcop->op_next = expr;
3316 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3319 rcop->op_next = LINKLIST(expr);
3320 expr->op_next = (OP*)rcop;
3323 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3328 if (pm->op_pmflags & PMf_EVAL) {
3330 if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
3331 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
3333 else if (repl->op_type == OP_CONST)
3337 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3338 if (curop->op_type == OP_SCOPE
3339 || curop->op_type == OP_LEAVE
3340 || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
3341 if (curop->op_type == OP_GV) {
3342 GV * const gv = cGVOPx_gv(curop);
3344 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3347 else if (curop->op_type == OP_RV2CV)
3349 else if (curop->op_type == OP_RV2SV ||
3350 curop->op_type == OP_RV2AV ||
3351 curop->op_type == OP_RV2HV ||
3352 curop->op_type == OP_RV2GV) {
3353 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3356 else if (curop->op_type == OP_PADSV ||
3357 curop->op_type == OP_PADAV ||
3358 curop->op_type == OP_PADHV ||
3359 curop->op_type == OP_PADANY)
3363 else if (curop->op_type == OP_PUSHRE)
3364 NOOP; /* Okay here, dangerous in newASSIGNOP */
3374 || PM_GETRE(pm)->extflags & RXf_EVAL_SEEN)))
3376 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3377 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
3378 prepend_elem(o->op_type, scalar(repl), o);
3381 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3382 pm->op_pmflags |= PMf_MAYBE_CONST;
3383 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3385 NewOp(1101, rcop, 1, LOGOP);
3386 rcop->op_type = OP_SUBSTCONT;
3387 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3388 rcop->op_first = scalar(repl);
3389 rcop->op_flags |= OPf_KIDS;
3390 rcop->op_private = 1;
3393 /* establish postfix order */
3394 rcop->op_next = LINKLIST(repl);
3395 repl->op_next = (OP*)rcop;
3397 pm->op_pmreplroot = scalar((OP*)rcop);
3398 pm->op_pmreplstart = LINKLIST(rcop);
3407 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3411 NewOp(1101, svop, 1, SVOP);
3412 svop->op_type = (OPCODE)type;
3413 svop->op_ppaddr = PL_ppaddr[type];
3415 svop->op_next = (OP*)svop;
3416 svop->op_flags = (U8)flags;
3417 if (PL_opargs[type] & OA_RETSCALAR)
3419 if (PL_opargs[type] & OA_TARGET)
3420 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3421 return CHECKOP(type, svop);
3426 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3430 NewOp(1101, padop, 1, PADOP);
3431 padop->op_type = (OPCODE)type;
3432 padop->op_ppaddr = PL_ppaddr[type];
3433 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3434 SvREFCNT_dec(PAD_SVl(padop->op_padix));
3435 PAD_SETSV(padop->op_padix, sv);
3438 padop->op_next = (OP*)padop;
3439 padop->op_flags = (U8)flags;
3440 if (PL_opargs[type] & OA_RETSCALAR)
3442 if (PL_opargs[type] & OA_TARGET)
3443 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3444 return CHECKOP(type, padop);
3449 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3455 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3457 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3462 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3466 NewOp(1101, pvop, 1, PVOP);
3467 pvop->op_type = (OPCODE)type;
3468 pvop->op_ppaddr = PL_ppaddr[type];
3470 pvop->op_next = (OP*)pvop;
3471 pvop->op_flags = (U8)flags;
3472 if (PL_opargs[type] & OA_RETSCALAR)
3474 if (PL_opargs[type] & OA_TARGET)
3475 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3476 return CHECKOP(type, pvop);
3484 Perl_package(pTHX_ OP *o)
3487 SV *const sv = cSVOPo->op_sv;
3492 save_hptr(&PL_curstash);
3493 save_item(PL_curstname);
3495 PL_curstash = gv_stashsv(sv, GV_ADD);
3496 sv_setsv(PL_curstname, sv);
3498 PL_hints |= HINT_BLOCK_SCOPE;
3499 PL_copline = NOLINE;
3505 if (!PL_madskills) {
3510 pegop = newOP(OP_NULL,0);
3511 op_getmad(o,pegop,'P');
3521 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3528 OP *pegop = newOP(OP_NULL,0);
3531 if (idop->op_type != OP_CONST)
3532 Perl_croak(aTHX_ "Module name must be constant");
3535 op_getmad(idop,pegop,'U');
3540 SV * const vesv = ((SVOP*)version)->op_sv;
3543 op_getmad(version,pegop,'V');
3544 if (!arg && !SvNIOKp(vesv)) {
3551 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3552 Perl_croak(aTHX_ "Version number must be constant number");
3554 /* Make copy of idop so we don't free it twice */
3555 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3557 /* Fake up a method call to VERSION */
3558 meth = newSVpvs_share("VERSION");
3559 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3560 append_elem(OP_LIST,
3561 prepend_elem(OP_LIST, pack, list(version)),
3562 newSVOP(OP_METHOD_NAMED, 0, meth)));
3566 /* Fake up an import/unimport */
3567 if (arg && arg->op_type == OP_STUB) {
3569 op_getmad(arg,pegop,'S');
3570 imop = arg; /* no import on explicit () */
3572 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3573 imop = NULL; /* use 5.0; */
3575 idop->op_private |= OPpCONST_NOVER;
3581 op_getmad(arg,pegop,'A');
3583 /* Make copy of idop so we don't free it twice */
3584 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3586 /* Fake up a method call to import/unimport */
3588 ? newSVpvs_share("import") : newSVpvs_share("unimport");
3589 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3590 append_elem(OP_LIST,
3591 prepend_elem(OP_LIST, pack, list(arg)),
3592 newSVOP(OP_METHOD_NAMED, 0, meth)));
3595 /* Fake up the BEGIN {}, which does its thing immediately. */
3597 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
3600 append_elem(OP_LINESEQ,
3601 append_elem(OP_LINESEQ,
3602 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
3603 newSTATEOP(0, NULL, veop)),
3604 newSTATEOP(0, NULL, imop) ));
3606 /* The "did you use incorrect case?" warning used to be here.
3607 * The problem is that on case-insensitive filesystems one
3608 * might get false positives for "use" (and "require"):
3609 * "use Strict" or "require CARP" will work. This causes
3610 * portability problems for the script: in case-strict
3611 * filesystems the script will stop working.
3613 * The "incorrect case" warning checked whether "use Foo"
3614 * imported "Foo" to your namespace, but that is wrong, too:
3615 * there is no requirement nor promise in the language that
3616 * a Foo.pm should or would contain anything in package "Foo".
3618 * There is very little Configure-wise that can be done, either:
3619 * the case-sensitivity of the build filesystem of Perl does not
3620 * help in guessing the case-sensitivity of the runtime environment.
3623 PL_hints |= HINT_BLOCK_SCOPE;
3624 PL_copline = NOLINE;
3626 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3629 if (!PL_madskills) {
3630 /* FIXME - don't allocate pegop if !PL_madskills */
3639 =head1 Embedding Functions
3641 =for apidoc load_module
3643 Loads the module whose name is pointed to by the string part of name.
3644 Note that the actual module name, not its filename, should be given.
3645 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3646 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3647 (or 0 for no flags). ver, if specified, provides version semantics
3648 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3649 arguments can be used to specify arguments to the module's import()
3650 method, similar to C<use Foo::Bar VERSION LIST>.
3655 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3658 va_start(args, ver);
3659 vload_module(flags, name, ver, &args);
3663 #ifdef PERL_IMPLICIT_CONTEXT
3665 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3669 va_start(args, ver);
3670 vload_module(flags, name, ver, &args);
3676 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3681 OP * const modname = newSVOP(OP_CONST, 0, name);
3682 modname->op_private |= OPpCONST_BARE;
3684 veop = newSVOP(OP_CONST, 0, ver);
3688 if (flags & PERL_LOADMOD_NOIMPORT) {
3689 imop = sawparens(newNULLLIST());
3691 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3692 imop = va_arg(*args, OP*);
3697 sv = va_arg(*args, SV*);
3699 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3700 sv = va_arg(*args, SV*);
3704 const line_t ocopline = PL_copline;
3705 COP * const ocurcop = PL_curcop;
3706 const int oexpect = PL_expect;
3708 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3709 veop, modname, imop);
3710 PL_expect = oexpect;
3711 PL_copline = ocopline;
3712 PL_curcop = ocurcop;
3717 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
3723 if (!force_builtin) {
3724 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
3725 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
3726 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
3727 gv = gvp ? *gvp : NULL;
3731 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3732 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3733 append_elem(OP_LIST, term,
3734 scalar(newUNOP(OP_RV2CV, 0,
3735 newGVOP(OP_GV, 0, gv))))));
3738 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3744 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3746 return newBINOP(OP_LSLICE, flags,
3747 list(force_list(subscript)),
3748 list(force_list(listval)) );
3752 S_is_list_assignment(pTHX_ register const OP *o)
3760 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
3761 o = cUNOPo->op_first;
3763 flags = o->op_flags;
3765 if (type == OP_COND_EXPR) {
3766 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
3767 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3772 yyerror("Assignment to both a list and a scalar");
3776 if (type == OP_LIST &&
3777 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
3778 o->op_private & OPpLVAL_INTRO)
3781 if (type == OP_LIST || flags & OPf_PARENS ||
3782 type == OP_RV2AV || type == OP_RV2HV ||
3783 type == OP_ASLICE || type == OP_HSLICE)
3786 if (type == OP_PADAV || type == OP_PADHV)
3789 if (type == OP_RV2SV)
3796 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3802 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3803 return newLOGOP(optype, 0,
3804 mod(scalar(left), optype),
3805 newUNOP(OP_SASSIGN, 0, scalar(right)));
3808 return newBINOP(optype, OPf_STACKED,
3809 mod(scalar(left), optype), scalar(right));
3813 if (is_list_assignment(left)) {
3817 /* Grandfathering $[ assignment here. Bletch.*/
3818 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
3819 PL_eval_start = (left->op_type == OP_CONST) ? right : 0;
3820 left = mod(left, OP_AASSIGN);
3823 else if (left->op_type == OP_CONST) {
3825 /* Result of assignment is always 1 (or we'd be dead already) */
3826 return newSVOP(OP_CONST, 0, newSViv(1));
3828 curop = list(force_list(left));
3829 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3830 o->op_private = (U8)(0 | (flags >> 8));
3832 /* PL_generation sorcery:
3833 * an assignment like ($a,$b) = ($c,$d) is easier than
3834 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3835 * To detect whether there are common vars, the global var
3836 * PL_generation is incremented for each assign op we compile.
3837 * Then, while compiling the assign op, we run through all the
3838 * variables on both sides of the assignment, setting a spare slot
3839 * in each of them to PL_generation. If any of them already have
3840 * that value, we know we've got commonality. We could use a
3841 * single bit marker, but then we'd have to make 2 passes, first
3842 * to clear the flag, then to test and set it. To find somewhere
3843 * to store these values, evil chicanery is done with SvUVX().
3849 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3850 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3851 if (curop->op_type == OP_GV) {
3852 GV *gv = cGVOPx_gv(curop);
3854 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
3856 GvASSIGN_GENERATION_set(gv, PL_generation);
3858 else if (curop->op_type == OP_PADSV ||
3859 curop->op_type == OP_PADAV ||
3860 curop->op_type == OP_PADHV ||
3861 curop->op_type == OP_PADANY)
3863 if (PAD_COMPNAME_GEN(curop->op_targ)
3864 == (STRLEN)PL_generation)
3866 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
3869 else if (curop->op_type == OP_RV2CV)
3871 else if (curop->op_type == OP_RV2SV ||
3872 curop->op_type == OP_RV2AV ||
3873 curop->op_type == OP_RV2HV ||
3874 curop->op_type == OP_RV2GV) {
3875 if (lastop->op_type != OP_GV) /* funny deref? */
3878 else if (curop->op_type == OP_PUSHRE) {
3879 if (((PMOP*)curop)->op_pmreplroot) {
3881 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3882 ((PMOP*)curop)->op_pmreplroot));
3884 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3887 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
3889 GvASSIGN_GENERATION_set(gv, PL_generation);
3890 GvASSIGN_GENERATION_set(gv, PL_generation);
3899 o->op_private |= OPpASSIGN_COMMON;
3902 if ( ((left->op_private & OPpLVAL_INTRO) || ckWARN(WARN_MISC))
3903 && (left->op_type == OP_LIST
3904 || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
3906 OP* lop = ((LISTOP*)left)->op_first;
3908 if (lop->op_type == OP_PADSV ||
3909 lop->op_type == OP_PADAV ||
3910 lop->op_type == OP_PADHV ||
3911 lop->op_type == OP_PADANY)
3913 if (lop->op_private & OPpPAD_STATE) {
3914 if (left->op_private & OPpLVAL_INTRO) {
3915 o->op_private |= OPpASSIGN_STATE;
3916 /* hijacking PADSTALE for uninitialized state variables */
3917 SvPADSTALE_on(PAD_SVl(lop->op_targ));
3919 else { /* we already checked for WARN_MISC before */
3920 Perl_warner(aTHX_ packWARN(WARN_MISC), "State variable %s will be reinitialized",
3921 PAD_COMPNAME_PV(lop->op_targ));
3925 lop = lop->op_sibling;
3929 if (right && right->op_type == OP_SPLIT) {
3930 OP* tmpop = ((LISTOP*)right)->op_first;
3931 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
3932 PMOP * const pm = (PMOP*)tmpop;
3933 if (left->op_type == OP_RV2AV &&
3934 !(left->op_private & OPpLVAL_INTRO) &&
3935 !(o->op_private & OPpASSIGN_COMMON) )
3937 tmpop = ((UNOP*)left)->op_first;
3938 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3940 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3941 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3943 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3944 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
3946 pm->op_pmflags |= PMf_ONCE;
3947 tmpop = cUNOPo->op_first; /* to list (nulled) */
3948 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3949 tmpop->op_sibling = NULL; /* don't free split */
3950 right->op_next = tmpop->op_next; /* fix starting loc */
3952 op_getmad(o,right,'R'); /* blow off assign */
3954 op_free(o); /* blow off assign */
3956 right->op_flags &= ~OPf_WANT;
3957 /* "I don't know and I don't care." */
3962 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3963 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3965 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3967 sv_setiv(sv, PL_modcount+1);
3975 right = newOP(OP_UNDEF, 0);
3976 if (right->op_type == OP_READLINE) {
3977 right->op_flags |= OPf_STACKED;
3978 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3981 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3982 o = newBINOP(OP_SASSIGN, flags,
3983 scalar(right), mod(scalar(left), OP_SASSIGN) );
3989 o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
3990 o->op_private |= OPpCONST_ARYBASE;
3997 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
4000 const U32 seq = intro_my();
4003 NewOp(1101, cop, 1, COP);
4004 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
4005 cop->op_type = OP_DBSTATE;
4006 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
4009 cop->op_type = OP_NEXTSTATE;
4010 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
4012 cop->op_flags = (U8)flags;
4013 CopHINTS_set(cop, PL_hints);
4015 cop->op_private |= NATIVE_HINTS;
4017 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
4018 cop->op_next = (OP*)cop;
4021 CopLABEL_set(cop, label);
4022 PL_hints |= HINT_BLOCK_SCOPE;
4025 /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
4026 CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
4028 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
4029 cop->cop_hints_hash = PL_curcop->cop_hints_hash;
4030 if (cop->cop_hints_hash) {
4032 cop->cop_hints_hash->refcounted_he_refcnt++;
4033 HINTS_REFCNT_UNLOCK;
4036 if (PL_copline == NOLINE)
4037 CopLINE_set(cop, CopLINE(PL_curcop));
4039 CopLINE_set(cop, PL_copline);
4040 PL_copline = NOLINE;
4043 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
4045 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
4047 CopSTASH_set(cop, PL_curstash);
4049 if (PERLDB_LINE && PL_curstash != PL_debstash) {
4050 AV *av = CopFILEAVx(PL_curcop);
4052 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
4053 if (svp && *svp != &PL_sv_undef ) {
4054 (void)SvIOK_on(*svp);
4055 SvIV_set(*svp, PTR2IV(cop));
4060 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
4065 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
4068 return new_logop(type, flags, &first, &other);
4072 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
4077 OP *first = *firstp;
4078 OP * const other = *otherp;
4080 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
4081 return newBINOP(type, flags, scalar(first), scalar(other));
4083 scalarboolean(first);
4084 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
4085 if (first->op_type == OP_NOT
4086 && (first->op_flags & OPf_SPECIAL)
4087 && (first->op_flags & OPf_KIDS)) {
4088 if (type == OP_AND || type == OP_OR) {
4094 first = *firstp = cUNOPo->op_first;
4096 first->op_next = o->op_next;
4097 cUNOPo->op_first = NULL;
4099 op_getmad(o,first,'O');
4105 if (first->op_type == OP_CONST) {
4106 if (first->op_private & OPpCONST_STRICT)
4107 no_bareword_allowed(first);
4108 else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
4109 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
4110 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
4111 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
4112 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
4114 if (other->op_type == OP_CONST)
4115 other->op_private |= OPpCONST_SHORTCIRCUIT;
4117 OP *newop = newUNOP(OP_NULL, 0, other);
4118 op_getmad(first, newop, '1');
4119 newop->op_targ = type; /* set "was" field */
4126 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
4127 const OP *o2 = other;
4128 if ( ! (o2->op_type == OP_LIST
4129 && (( o2 = cUNOPx(o2)->op_first))
4130 && o2->op_type == OP_PUSHMARK
4131 && (( o2 = o2->op_sibling)) )
4134 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
4135 || o2->op_type == OP_PADHV)
4136 && o2->op_private & OPpLVAL_INTRO
4137 && ckWARN(WARN_DEPRECATED))
4139 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4140 "Deprecated use of my() in false conditional");
4144 if (first->op_type == OP_CONST)
4145 first->op_private |= OPpCONST_SHORTCIRCUIT;
4147 first = newUNOP(OP_NULL, 0, first);
4148 op_getmad(other, first, '2');
4149 first->op_targ = type; /* set "was" field */
4156 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
4157 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
4159 const OP * const k1 = ((UNOP*)first)->op_first;
4160 const OP * const k2 = k1->op_sibling;
4162 switch (first->op_type)
4165 if (k2 && k2->op_type == OP_READLINE
4166 && (k2->op_flags & OPf_STACKED)
4167 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4169 warnop = k2->op_type;
4174 if (k1->op_type == OP_READDIR
4175 || k1->op_type == OP_GLOB
4176 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4177 || k1->op_type == OP_EACH)
4179 warnop = ((k1->op_type == OP_NULL)
4180 ? (OPCODE)k1->op_targ : k1->op_type);
4185 const line_t oldline = CopLINE(PL_curcop);
4186 CopLINE_set(PL_curcop, PL_copline);
4187 Perl_warner(aTHX_ packWARN(WARN_MISC),
4188 "Value of %s%s can be \"0\"; test with defined()",
4190 ((warnop == OP_READLINE || warnop == OP_GLOB)
4191 ? " construct" : "() operator"));
4192 CopLINE_set(PL_curcop, oldline);
4199 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
4200 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
4202 NewOp(1101, logop, 1, LOGOP);
4204 logop->op_type = (OPCODE)type;
4205 logop->op_ppaddr = PL_ppaddr[type];
4206 logop->op_first = first;
4207 logop->op_flags = (U8)(flags | OPf_KIDS);
4208 logop->op_other = LINKLIST(other);
4209 logop->op_private = (U8)(1 | (flags >> 8));
4211 /* establish postfix order */
4212 logop->op_next = LINKLIST(first);
4213 first->op_next = (OP*)logop;
4214 first->op_sibling = other;
4216 CHECKOP(type,logop);
4218 o = newUNOP(OP_NULL, 0, (OP*)logop);
4225 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
4233 return newLOGOP(OP_AND, 0, first, trueop);
4235 return newLOGOP(OP_OR, 0, first, falseop);
4237 scalarboolean(first);
4238 if (first->op_type == OP_CONST) {
4239 if (first->op_private & OPpCONST_BARE &&
4240 first->op_private & OPpCONST_STRICT) {
4241 no_bareword_allowed(first);
4243 if (SvTRUE(((SVOP*)first)->op_sv)) {
4246 trueop = newUNOP(OP_NULL, 0, trueop);
4247 op_getmad(first,trueop,'C');
4248 op_getmad(falseop,trueop,'e');
4250 /* FIXME for MAD - should there be an ELSE here? */
4260 falseop = newUNOP(OP_NULL, 0, falseop);
4261 op_getmad(first,falseop,'C');
4262 op_getmad(trueop,falseop,'t');
4264 /* FIXME for MAD - should there be an ELSE here? */
4272 NewOp(1101, logop, 1, LOGOP);
4273 logop->op_type = OP_COND_EXPR;
4274 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4275 logop->op_first = first;
4276 logop->op_flags = (U8)(flags | OPf_KIDS);
4277 logop->op_private = (U8)(1 | (flags >> 8));
4278 logop->op_other = LINKLIST(trueop);
4279 logop->op_next = LINKLIST(falseop);
4281 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
4284 /* establish postfix order */
4285 start = LINKLIST(first);
4286 first->op_next = (OP*)logop;
4288 first->op_sibling = trueop;
4289 trueop->op_sibling = falseop;
4290 o = newUNOP(OP_NULL, 0, (OP*)logop);
4292 trueop->op_next = falseop->op_next = o;
4299 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4308 NewOp(1101, range, 1, LOGOP);
4310 range->op_type = OP_RANGE;
4311 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4312 range->op_first = left;
4313 range->op_flags = OPf_KIDS;
4314 leftstart = LINKLIST(left);
4315 range->op_other = LINKLIST(right);
4316 range->op_private = (U8)(1 | (flags >> 8));
4318 left->op_sibling = right;
4320 range->op_next = (OP*)range;
4321 flip = newUNOP(OP_FLIP, flags, (OP*)range);
4322 flop = newUNOP(OP_FLOP, 0, flip);
4323 o = newUNOP(OP_NULL, 0, flop);
4325 range->op_next = leftstart;
4327 left->op_next = flip;
4328 right->op_next = flop;
4330 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4331 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4332 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4333 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4335 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4336 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4339 if (!flip->op_private || !flop->op_private)
4340 linklist(o); /* blow off optimizer unless constant */
4346 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4351 const bool once = block && block->op_flags & OPf_SPECIAL &&
4352 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4354 PERL_UNUSED_ARG(debuggable);
4357 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4358 return block; /* do {} while 0 does once */
4359 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4360 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4361 expr = newUNOP(OP_DEFINED, 0,
4362 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4363 } else if (expr->op_flags & OPf_KIDS) {
4364 const OP * const k1 = ((UNOP*)expr)->op_first;
4365 const OP * const k2 = k1 ? k1->op_sibling : NULL;
4366 switch (expr->op_type) {
4368 if (k2 && k2->op_type == OP_READLINE
4369 && (k2->op_flags & OPf_STACKED)
4370 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4371 expr = newUNOP(OP_DEFINED, 0, expr);
4375 if (k1 && (k1->op_type == OP_READDIR
4376 || k1->op_type == OP_GLOB
4377 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4378 || k1->op_type == OP_EACH))
4379 expr = newUNOP(OP_DEFINED, 0, expr);
4385 /* if block is null, the next append_elem() would put UNSTACK, a scalar
4386 * op, in listop. This is wrong. [perl #27024] */
4388 block = newOP(OP_NULL, 0);
4389 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4390 o = new_logop(OP_AND, 0, &expr, &listop);
4393 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4395 if (once && o != listop)
4396 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4399 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
4401 o->op_flags |= flags;
4403 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4408 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
4409 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
4418 PERL_UNUSED_ARG(debuggable);
4421 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4422 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4423 expr = newUNOP(OP_DEFINED, 0,
4424 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4425 } else if (expr->op_flags & OPf_KIDS) {
4426 const OP * const k1 = ((UNOP*)expr)->op_first;
4427 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
4428 switch (expr->op_type) {
4430 if (k2 && k2->op_type == OP_READLINE
4431 && (k2->op_flags & OPf_STACKED)
4432 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4433 expr = newUNOP(OP_DEFINED, 0, expr);
4437 if (k1 && (k1->op_type == OP_READDIR
4438 || k1->op_type == OP_GLOB
4439 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4440 || k1->op_type == OP_EACH))
4441 expr = newUNOP(OP_DEFINED, 0, expr);
4448 block = newOP(OP_NULL, 0);
4449 else if (cont || has_my) {
4450 block = scope(block);
4454 next = LINKLIST(cont);
4457 OP * const unstack = newOP(OP_UNSTACK, 0);
4460 cont = append_elem(OP_LINESEQ, cont, unstack);
4464 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4466 redo = LINKLIST(listop);
4469 PL_copline = (line_t)whileline;
4471 o = new_logop(OP_AND, 0, &expr, &listop);
4472 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4473 op_free(expr); /* oops, it's a while (0) */
4475 return NULL; /* listop already freed by new_logop */
4478 ((LISTOP*)listop)->op_last->op_next =
4479 (o == listop ? redo : LINKLIST(o));
4485 NewOp(1101,loop,1,LOOP);
4486 loop->op_type = OP_ENTERLOOP;
4487 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4488 loop->op_private = 0;
4489 loop->op_next = (OP*)loop;
4492 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4494 loop->op_redoop = redo;
4495 loop->op_lastop = o;
4496 o->op_private |= loopflags;
4499 loop->op_nextop = next;
4501 loop->op_nextop = o;
4503 o->op_flags |= flags;
4504 o->op_private |= (flags >> 8);
4509 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
4514 PADOFFSET padoff = 0;
4520 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4521 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
4522 sv->op_type = OP_RV2GV;
4523 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4524 if (cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
4525 iterpflags |= OPpITER_DEF;
4527 else if (sv->op_type == OP_PADSV) { /* private variable */
4528 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
4529 padoff = sv->op_targ;
4539 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4541 SV *const namesv = PAD_COMPNAME_SV(padoff);
4543 const char *const name = SvPV_const(namesv, len);
4545 if (len == 2 && name[0] == '$' && name[1] == '_')
4546 iterpflags |= OPpITER_DEF;
4550 const PADOFFSET offset = pad_findmy("$_");
4551 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
4552 sv = newGVOP(OP_GV, 0, PL_defgv);
4557 iterpflags |= OPpITER_DEF;
4559 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4560 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4561 iterflags |= OPf_STACKED;
4563 else if (expr->op_type == OP_NULL &&
4564 (expr->op_flags & OPf_KIDS) &&
4565 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4567 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4568 * set the STACKED flag to indicate that these values are to be
4569 * treated as min/max values by 'pp_iterinit'.
4571 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4572 LOGOP* const range = (LOGOP*) flip->op_first;
4573 OP* const left = range->op_first;
4574 OP* const right = left->op_sibling;
4577 range->op_flags &= ~OPf_KIDS;
4578 range->op_first = NULL;
4580 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4581 listop->op_first->op_next = range->op_next;
4582 left->op_next = range->op_other;
4583 right->op_next = (OP*)listop;
4584 listop->op_next = listop->op_first;
4587 op_getmad(expr,(OP*)listop,'O');
4591 expr = (OP*)(listop);
4593 iterflags |= OPf_STACKED;
4596 expr = mod(force_list(expr), OP_GREPSTART);
4599 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4600 append_elem(OP_LIST, expr, scalar(sv))));
4601 assert(!loop->op_next);
4602 /* for my $x () sets OPpLVAL_INTRO;
4603 * for our $x () sets OPpOUR_INTRO */
4604 loop->op_private = (U8)iterpflags;
4605 #ifdef PL_OP_SLAB_ALLOC
4608 NewOp(1234,tmp,1,LOOP);
4609 Copy(loop,tmp,1,LISTOP);
4610 S_op_destroy(aTHX_ (OP*)loop);
4614 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
4616 loop->op_targ = padoff;
4617 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
4619 op_getmad(madsv, (OP*)loop, 'v');
4620 PL_copline = forline;
4621 return newSTATEOP(0, label, wop);
4625 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4630 if (type != OP_GOTO || label->op_type == OP_CONST) {
4631 /* "last()" means "last" */
4632 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4633 o = newOP(type, OPf_SPECIAL);
4635 o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
4636 ? SvPVx_nolen_const(((SVOP*)label)->op_sv)
4640 op_getmad(label,o,'L');
4646 /* Check whether it's going to be a goto &function */
4647 if (label->op_type == OP_ENTERSUB
4648 && !(label->op_flags & OPf_STACKED))
4649 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4650 o = newUNOP(type, OPf_STACKED, label);
4652 PL_hints |= HINT_BLOCK_SCOPE;
4656 /* if the condition is a literal array or hash
4657 (or @{ ... } etc), make a reference to it.
4660 S_ref_array_or_hash(pTHX_ OP *cond)
4663 && (cond->op_type == OP_RV2AV
4664 || cond->op_type == OP_PADAV
4665 || cond->op_type == OP_RV2HV
4666 || cond->op_type == OP_PADHV))
4668 return newUNOP(OP_REFGEN,
4669 0, mod(cond, OP_REFGEN));
4675 /* These construct the optree fragments representing given()
4678 entergiven and enterwhen are LOGOPs; the op_other pointer
4679 points up to the associated leave op. We need this so we
4680 can put it in the context and make break/continue work.
4681 (Also, of course, pp_enterwhen will jump straight to
4682 op_other if the match fails.)
4687 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
4688 I32 enter_opcode, I32 leave_opcode,
4689 PADOFFSET entertarg)
4695 NewOp(1101, enterop, 1, LOGOP);
4696 enterop->op_type = enter_opcode;
4697 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
4698 enterop->op_flags = (U8) OPf_KIDS;
4699 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
4700 enterop->op_private = 0;
4702 o = newUNOP(leave_opcode, 0, (OP *) enterop);
4705 enterop->op_first = scalar(cond);
4706 cond->op_sibling = block;
4708 o->op_next = LINKLIST(cond);
4709 cond->op_next = (OP *) enterop;
4712 /* This is a default {} block */
4713 enterop->op_first = block;
4714 enterop->op_flags |= OPf_SPECIAL;
4716 o->op_next = (OP *) enterop;
4719 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
4720 entergiven and enterwhen both
4723 enterop->op_next = LINKLIST(block);
4724 block->op_next = enterop->op_other = o;
4729 /* Does this look like a boolean operation? For these purposes
4730 a boolean operation is:
4731 - a subroutine call [*]
4732 - a logical connective
4733 - a comparison operator
4734 - a filetest operator, with the exception of -s -M -A -C
4735 - defined(), exists() or eof()
4736 - /$re/ or $foo =~ /$re/
4738 [*] possibly surprising
4742 S_looks_like_bool(pTHX_ const OP *o)
4745 switch(o->op_type) {
4747 return looks_like_bool(cLOGOPo->op_first);
4751 looks_like_bool(cLOGOPo->op_first)
4752 && looks_like_bool(cLOGOPo->op_first->op_sibling));
4756 case OP_NOT: case OP_XOR:
4757 /* Note that OP_DOR is not here */
4759 case OP_EQ: case OP_NE: case OP_LT:
4760 case OP_GT: case OP_LE: case OP_GE:
4762 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
4763 case OP_I_GT: case OP_I_LE: case OP_I_GE:
4765 case OP_SEQ: case OP_SNE: case OP_SLT:
4766 case OP_SGT: case OP_SLE: case OP_SGE:
4770 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
4771 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
4772 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
4773 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
4774 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
4775 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
4776 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
4777 case OP_FTTEXT: case OP_FTBINARY:
4779 case OP_DEFINED: case OP_EXISTS:
4780 case OP_MATCH: case OP_EOF:
4785 /* Detect comparisons that have been optimized away */
4786 if (cSVOPo->op_sv == &PL_sv_yes
4787 || cSVOPo->op_sv == &PL_sv_no)
4798 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
4802 return newGIVWHENOP(
4803 ref_array_or_hash(cond),
4805 OP_ENTERGIVEN, OP_LEAVEGIVEN,
4809 /* If cond is null, this is a default {} block */
4811 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
4813 const bool cond_llb = (!cond || looks_like_bool(cond));
4819 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
4821 scalar(ref_array_or_hash(cond)));
4824 return newGIVWHENOP(
4826 append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
4827 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
4831 =for apidoc cv_undef
4833 Clear out all the active components of a CV. This can happen either
4834 by an explicit C<undef &foo>, or by the reference count going to zero.
4835 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
4836 children can still follow the full lexical scope chain.
4842 Perl_cv_undef(pTHX_ CV *cv)
4846 if (CvFILE(cv) && !CvISXSUB(cv)) {
4847 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4848 Safefree(CvFILE(cv));
4853 if (!CvISXSUB(cv) && CvROOT(cv)) {
4854 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
4855 Perl_croak(aTHX_ "Can't undef active subroutine");
4858 PAD_SAVE_SETNULLPAD();
4860 op_free(CvROOT(cv));
4865 SvPOK_off((SV*)cv); /* forget prototype */
4870 /* remove CvOUTSIDE unless this is an undef rather than a free */
4871 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
4872 if (!CvWEAKOUTSIDE(cv))
4873 SvREFCNT_dec(CvOUTSIDE(cv));
4874 CvOUTSIDE(cv) = NULL;
4877 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4880 if (CvISXSUB(cv) && CvXSUB(cv)) {
4883 /* delete all flags except WEAKOUTSIDE */
4884 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
4888 Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
4891 /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
4892 relying on SvCUR, and doubling up the buffer to hold CvFILE(). */
4893 if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
4894 || (p && (len != SvCUR(cv) /* Not the same length. */
4895 || memNE(p, SvPVX_const(cv), len))))
4896 && ckWARN_d(WARN_PROTOTYPE)) {
4897 SV* const msg = sv_newmortal();
4901 gv_efullname3(name = sv_newmortal(), gv, NULL);
4902 sv_setpv(msg, "Prototype mismatch:");
4904 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
4906 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv));
4908 sv_catpvs(msg, ": none");
4909 sv_catpvs(msg, " vs ");
4911 Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
4913 sv_catpvs(msg, "none");
4914 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
4918 static void const_sv_xsub(pTHX_ CV* cv);
4922 =head1 Optree Manipulation Functions
4924 =for apidoc cv_const_sv
4926 If C<cv> is a constant sub eligible for inlining. returns the constant
4927 value returned by the sub. Otherwise, returns NULL.
4929 Constant subs can be created with C<newCONSTSUB> or as described in
4930 L<perlsub/"Constant Functions">.
4935 Perl_cv_const_sv(pTHX_ CV *cv)
4937 PERL_UNUSED_CONTEXT;
4940 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
4942 return CvCONST(cv) ? (SV*)CvXSUBANY(cv).any_ptr : NULL;
4945 /* op_const_sv: examine an optree to determine whether it's in-lineable.
4946 * Can be called in 3 ways:
4949 * look for a single OP_CONST with attached value: return the value
4951 * cv && CvCLONE(cv) && !CvCONST(cv)
4953 * examine the clone prototype, and if contains only a single
4954 * OP_CONST referencing a pad const, or a single PADSV referencing
4955 * an outer lexical, return a non-zero value to indicate the CV is
4956 * a candidate for "constizing" at clone time
4960 * We have just cloned an anon prototype that was marked as a const
4961 * candidiate. Try to grab the current value, and in the case of
4962 * PADSV, ignore it if it has multiple references. Return the value.
4966 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
4974 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4975 o = cLISTOPo->op_first->op_sibling;
4977 for (; o; o = o->op_next) {
4978 const OPCODE type = o->op_type;
4980 if (sv && o->op_next == o)
4982 if (o->op_next != o) {
4983 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4985 if (type == OP_DBSTATE)
4988 if (type == OP_LEAVESUB || type == OP_RETURN)
4992 if (type == OP_CONST && cSVOPo->op_sv)
4994 else if (cv && type == OP_CONST) {
4995 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4999 else if (cv && type == OP_PADSV) {
5000 if (CvCONST(cv)) { /* newly cloned anon */
5001 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5002 /* the candidate should have 1 ref from this pad and 1 ref
5003 * from the parent */
5004 if (!sv || SvREFCNT(sv) != 2)
5011 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
5012 sv = &PL_sv_undef; /* an arbitrary non-null value */
5027 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5030 /* This would be the return value, but the return cannot be reached. */
5031 OP* pegop = newOP(OP_NULL, 0);
5034 PERL_UNUSED_ARG(floor);
5044 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
5046 NORETURN_FUNCTION_END;
5051 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
5053 return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
5057 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5064 register CV *cv = NULL;
5066 /* If the subroutine has no body, no attributes, and no builtin attributes
5067 then it's just a sub declaration, and we may be able to get away with
5068 storing with a placeholder scalar in the symbol table, rather than a
5069 full GV and CV. If anything is present then it will take a full CV to
5071 const I32 gv_fetch_flags
5072 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5074 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
5075 const char * const name = o ? SvPVx_nolen_const(cSVOPo->op_sv) : NULL;
5078 assert(proto->op_type == OP_CONST);
5079 ps = SvPVx_const(((SVOP*)proto)->op_sv, ps_len);
5084 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
5085 SV * const sv = sv_newmortal();
5086 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
5087 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
5088 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
5089 aname = SvPVX_const(sv);
5094 gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
5095 : gv_fetchpv(aname ? aname
5096 : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5097 gv_fetch_flags, SVt_PVCV);
5099 if (!PL_madskills) {
5108 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
5109 maximum a prototype before. */
5110 if (SvTYPE(gv) > SVt_NULL) {
5111 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
5112 && ckWARN_d(WARN_PROTOTYPE))
5114 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
5116 cv_ckproto_len((CV*)gv, NULL, ps, ps_len);
5119 sv_setpvn((SV*)gv, ps, ps_len);
5121 sv_setiv((SV*)gv, -1);
5122 SvREFCNT_dec(PL_compcv);
5123 cv = PL_compcv = NULL;
5124 PL_sub_generation++;
5128 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
5130 #ifdef GV_UNIQUE_CHECK
5131 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
5132 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
5136 if (!block || !ps || *ps || attrs
5137 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5139 || block->op_type == OP_NULL
5144 const_sv = op_const_sv(block, NULL);
5147 const bool exists = CvROOT(cv) || CvXSUB(cv);
5149 #ifdef GV_UNIQUE_CHECK
5150 if (exists && GvUNIQUE(gv)) {
5151 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
5155 /* if the subroutine doesn't exist and wasn't pre-declared
5156 * with a prototype, assume it will be AUTOLOADed,
5157 * skipping the prototype check
5159 if (exists || SvPOK(cv))
5160 cv_ckproto_len(cv, gv, ps, ps_len);
5161 /* already defined (or promised)? */
5162 if (exists || GvASSUMECV(gv)) {
5165 || block->op_type == OP_NULL
5168 if (CvFLAGS(PL_compcv)) {
5169 /* might have had built-in attrs applied */
5170 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5172 /* just a "sub foo;" when &foo is already defined */
5173 SAVEFREESV(PL_compcv);
5178 && block->op_type != OP_NULL
5181 if (ckWARN(WARN_REDEFINE)
5183 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
5185 const line_t oldline = CopLINE(PL_curcop);
5186 if (PL_copline != NOLINE)
5187 CopLINE_set(PL_curcop, PL_copline);
5188 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5189 CvCONST(cv) ? "Constant subroutine %s redefined"
5190 : "Subroutine %s redefined", name);
5191 CopLINE_set(PL_curcop, oldline);
5194 if (!PL_minus_c) /* keep old one around for madskills */
5197 /* (PL_madskills unset in used file.) */
5205 SvREFCNT_inc_simple_void_NN(const_sv);
5207 assert(!CvROOT(cv) && !CvCONST(cv));
5208 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
5209 CvXSUBANY(cv).any_ptr = const_sv;
5210 CvXSUB(cv) = const_sv_xsub;
5216 cv = newCONSTSUB(NULL, name, const_sv);
5218 PL_sub_generation++;
5222 SvREFCNT_dec(PL_compcv);
5230 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
5231 * before we clobber PL_compcv.
5235 || block->op_type == OP_NULL
5239 /* Might have had built-in attributes applied -- propagate them. */
5240 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5241 if (CvGV(cv) && GvSTASH(CvGV(cv)))
5242 stash = GvSTASH(CvGV(cv));
5243 else if (CvSTASH(cv))
5244 stash = CvSTASH(cv);
5246 stash = PL_curstash;
5249 /* possibly about to re-define existing subr -- ignore old cv */
5250 rcv = (SV*)PL_compcv;
5251 if (name && GvSTASH(gv))
5252 stash = GvSTASH(gv);
5254 stash = PL_curstash;
5256 apply_attrs(stash, rcv, attrs, FALSE);
5258 if (cv) { /* must reuse cv if autoloaded */
5265 || block->op_type == OP_NULL) && !PL_madskills
5268 /* got here with just attrs -- work done, so bug out */
5269 SAVEFREESV(PL_compcv);
5272 /* transfer PL_compcv to cv */
5274 CvFLAGS(cv) = CvFLAGS(PL_compcv);
5275 if (!CvWEAKOUTSIDE(cv))
5276 SvREFCNT_dec(CvOUTSIDE(cv));
5277 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
5278 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
5279 CvOUTSIDE(PL_compcv) = 0;
5280 CvPADLIST(cv) = CvPADLIST(PL_compcv);
5281 CvPADLIST(PL_compcv) = 0;
5282 /* inner references to PL_compcv must be fixed up ... */
5283 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
5284 /* ... before we throw it away */
5285 SvREFCNT_dec(PL_compcv);
5287 if (PERLDB_INTER)/* Advice debugger on the new sub. */
5288 ++PL_sub_generation;
5295 if (strEQ(name, "import")) {
5296 PL_formfeed = (SV*)cv;
5297 Perl_warner(aTHX_ packWARN(WARN_VOID), "%lx\n", (long)cv);
5301 PL_sub_generation++;
5305 CvFILE_set_from_cop(cv, PL_curcop);
5306 CvSTASH(cv) = PL_curstash;
5309 sv_setpvn((SV*)cv, ps, ps_len);
5311 if (PL_error_count) {
5315 const char *s = strrchr(name, ':');
5317 if (strEQ(s, "BEGIN")) {
5318 const char not_safe[] =
5319 "BEGIN not safe after errors--compilation aborted";
5320 if (PL_in_eval & EVAL_KEEPERR)
5321 Perl_croak(aTHX_ not_safe);
5323 /* force display of errors found but not reported */
5324 sv_catpv(ERRSV, not_safe);
5325 Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
5335 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5336 mod(scalarseq(block), OP_LEAVESUBLV));
5337 block->op_attached = 1;
5340 /* This makes sub {}; work as expected. */
5341 if (block->op_type == OP_STUB) {
5342 OP* const newblock = newSTATEOP(0, NULL, 0);
5344 op_getmad(block,newblock,'B');
5351 block->op_attached = 1;
5352 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5354 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5355 OpREFCNT_set(CvROOT(cv), 1);
5356 CvSTART(cv) = LINKLIST(CvROOT(cv));
5357 CvROOT(cv)->op_next = 0;
5358 CALL_PEEP(CvSTART(cv));
5360 /* now that optimizer has done its work, adjust pad values */
5362 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
5365 assert(!CvCONST(cv));
5366 if (ps && !*ps && op_const_sv(block, cv))
5370 if (name || aname) {
5372 const char * const tname = (name ? name : aname);
5374 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5375 SV * const sv = newSV(0);
5376 SV * const tmpstr = sv_newmortal();
5377 GV * const db_postponed = gv_fetchpvs("DB::postponed",
5378 GV_ADDMULTI, SVt_PVHV);
5381 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5383 (long)PL_subline, (long)CopLINE(PL_curcop));
5384 gv_efullname3(tmpstr, gv, NULL);
5385 hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0);
5386 hv = GvHVn(db_postponed);
5387 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
5388 CV * const pcv = GvCV(db_postponed);
5394 call_sv((SV*)pcv, G_DISCARD);
5399 if ((s = strrchr(tname,':')))
5404 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I' && *s != 'U')
5407 if (strEQ(s, "BEGIN") && !PL_error_count) {
5408 const I32 oldscope = PL_scopestack_ix;
5410 SAVECOPFILE(&PL_compiling);
5411 SAVECOPLINE(&PL_compiling);
5413 DEBUG_x( dump_sub(gv) );
5414 Perl_av_create_and_push(aTHX_ &PL_beginav, (SV*)cv);
5415 GvCV(gv) = 0; /* cv has been hijacked */
5416 call_list(oldscope, PL_beginav);
5418 PL_curcop = &PL_compiling;
5419 CopHINTS_set(&PL_compiling, PL_hints);
5422 else if (strEQ(s, "END") && !PL_error_count) {
5423 DEBUG_x( dump_sub(gv) );
5424 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, (SV*)cv);
5425 GvCV(gv) = 0; /* cv has been hijacked */
5427 else if (strEQ(s, "UNITCHECK") && !PL_error_count) {
5428 /* It's never too late to run a unitcheck block */
5429 DEBUG_x( dump_sub(gv) );
5430 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, (SV*)cv);
5431 GvCV(gv) = 0; /* cv has been hijacked */
5433 else if (strEQ(s, "CHECK") && !PL_error_count) {
5434 DEBUG_x( dump_sub(gv) );
5435 if (PL_main_start && ckWARN(WARN_VOID))
5436 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
5437 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, (SV*)cv);
5438 GvCV(gv) = 0; /* cv has been hijacked */
5440 else if (strEQ(s, "INIT") && !PL_error_count) {
5441 DEBUG_x( dump_sub(gv) );
5442 if (PL_main_start && ckWARN(WARN_VOID))
5443 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
5444 Perl_av_create_and_push(aTHX_ &PL_initav, (SV*)cv);
5445 GvCV(gv) = 0; /* cv has been hijacked */
5450 PL_copline = NOLINE;
5455 /* XXX unsafe for threads if eval_owner isn't held */
5457 =for apidoc newCONSTSUB
5459 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5460 eligible for inlining at compile-time.
5466 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
5471 const char *const temp_p = CopFILE(PL_curcop);
5472 const STRLEN len = temp_p ? strlen(temp_p) : 0;
5474 SV *const temp_sv = CopFILESV(PL_curcop);
5476 const char *const temp_p = temp_sv ? SvPV_const(temp_sv, len) : NULL;
5478 char *const file = savepvn(temp_p, temp_p ? len : 0);
5482 SAVECOPLINE(PL_curcop);
5483 CopLINE_set(PL_curcop, PL_copline);
5486 PL_hints &= ~HINT_BLOCK_SCOPE;
5489 SAVESPTR(PL_curstash);
5490 SAVECOPSTASH(PL_curcop);
5491 PL_curstash = stash;
5492 CopSTASH_set(PL_curcop,stash);
5495 /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
5496 and so doesn't get free()d. (It's expected to be from the C pre-
5497 processor __FILE__ directive). But we need a dynamically allocated one,
5498 and we need it to get freed. */
5499 cv = newXS_flags(name, const_sv_xsub, file, "", XS_DYNAMIC_FILENAME);
5500 CvXSUBANY(cv).any_ptr = sv;
5506 CopSTASH_free(PL_curcop);
5514 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
5515 const char *const filename, const char *const proto,
5518 CV *cv = newXS(name, subaddr, filename);
5520 if (flags & XS_DYNAMIC_FILENAME) {
5521 /* We need to "make arrangements" (ie cheat) to ensure that the
5522 filename lasts as long as the PVCV we just created, but also doesn't
5524 STRLEN filename_len = strlen(filename);
5525 STRLEN proto_and_file_len = filename_len;
5526 char *proto_and_file;
5530 proto_len = strlen(proto);
5531 proto_and_file_len += proto_len;
5533 Newx(proto_and_file, proto_and_file_len + 1, char);
5534 Copy(proto, proto_and_file, proto_len, char);
5535 Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
5538 proto_and_file = savepvn(filename, filename_len);
5541 /* This gets free()d. :-) */
5542 sv_usepvn_flags((SV*)cv, proto_and_file, proto_and_file_len,
5543 SV_HAS_TRAILING_NUL);
5545 /* This gives us the correct prototype, rather than one with the
5546 file name appended. */
5547 SvCUR_set(cv, proto_len);
5551 CvFILE(cv) = proto_and_file + proto_len;
5553 sv_setpv((SV *)cv, proto);
5559 =for apidoc U||newXS
5561 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
5562 static storage, as it is used directly as CvFILE(), without a copy being made.
5568 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
5571 GV * const gv = gv_fetchpv(name ? name :
5572 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5573 GV_ADDMULTI, SVt_PVCV);
5577 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
5579 if ((cv = (name ? GvCV(gv) : NULL))) {
5581 /* just a cached method */
5585 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5586 /* already defined (or promised) */
5587 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
5588 if (ckWARN(WARN_REDEFINE)) {
5589 GV * const gvcv = CvGV(cv);
5591 HV * const stash = GvSTASH(gvcv);
5593 const char *redefined_name = HvNAME_get(stash);
5594 if ( strEQ(redefined_name,"autouse") ) {
5595 const line_t oldline = CopLINE(PL_curcop);
5596 if (PL_copline != NOLINE)
5597 CopLINE_set(PL_curcop, PL_copline);
5598 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5599 CvCONST(cv) ? "Constant subroutine %s redefined"
5600 : "Subroutine %s redefined"
5602 CopLINE_set(PL_curcop, oldline);
5612 if (cv) /* must reuse cv if autoloaded */
5616 sv_upgrade((SV *)cv, SVt_PVCV);
5620 PL_sub_generation++;
5624 (void)gv_fetchfile(filename);
5625 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
5626 an external constant string */
5628 CvXSUB(cv) = subaddr;
5631 const char *s = strrchr(name,':');
5637 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5640 if (strEQ(s, "BEGIN")) {
5641 const I32 oldscope = PL_scopestack_ix;
5643 SAVECOPFILE(&PL_compiling);
5644 SAVECOPLINE(&PL_compiling);
5646 Perl_av_create_and_push(aTHX_ &PL_beginav, (SV*)cv);
5647 GvCV(gv) = 0; /* cv has been hijacked */
5648 call_list(oldscope, PL_beginav);
5650 PL_curcop = &PL_compiling;
5651 CopHINTS_set(&PL_compiling, PL_hints);
5654 else if (strEQ(s, "END")) {
5655 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, (SV*)cv);
5656 GvCV(gv) = 0; /* cv has been hijacked */
5658 else if (strEQ(s, "CHECK")) {
5659 if (PL_main_start && ckWARN(WARN_VOID))
5660 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
5661 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, (SV*)cv);
5662 GvCV(gv) = 0; /* cv has been hijacked */
5664 else if (strEQ(s, "INIT")) {
5665 if (PL_main_start && ckWARN(WARN_VOID))
5666 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
5667 Perl_av_create_and_push(aTHX_ &PL_initav, (SV*)cv);
5668 GvCV(gv) = 0; /* cv has been hijacked */
5683 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5688 OP* pegop = newOP(OP_NULL, 0);
5692 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
5693 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
5695 #ifdef GV_UNIQUE_CHECK
5697 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5701 if ((cv = GvFORM(gv))) {
5702 if (ckWARN(WARN_REDEFINE)) {
5703 const line_t oldline = CopLINE(PL_curcop);
5704 if (PL_copline != NOLINE)
5705 CopLINE_set(PL_curcop, PL_copline);
5706 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5707 o ? "Format %"SVf" redefined"
5708 : "Format STDOUT redefined", SVfARG(cSVOPo->op_sv));
5709 CopLINE_set(PL_curcop, oldline);
5716 CvFILE_set_from_cop(cv, PL_curcop);
5719 pad_tidy(padtidy_FORMAT);
5720 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5721 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5722 OpREFCNT_set(CvROOT(cv), 1);
5723 CvSTART(cv) = LINKLIST(CvROOT(cv));
5724 CvROOT(cv)->op_next = 0;
5725 CALL_PEEP(CvSTART(cv));
5727 op_getmad(o,pegop,'n');
5728 op_getmad_weak(block, pegop, 'b');
5732 PL_copline = NOLINE;
5740 Perl_newANONLIST(pTHX_ OP *o)
5742 return convert(OP_ANONLIST, OPf_SPECIAL, o);
5746 Perl_newANONHASH(pTHX_ OP *o)
5748 return convert(OP_ANONHASH, OPf_SPECIAL, o);
5752 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5754 return newANONATTRSUB(floor, proto, NULL, block);
5758 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5760 return newUNOP(OP_REFGEN, 0,
5761 newSVOP(OP_ANONCODE, 0,
5762 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5766 Perl_oopsAV(pTHX_ OP *o)
5769 switch (o->op_type) {
5771 o->op_type = OP_PADAV;
5772 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5773 return ref(o, OP_RV2AV);
5776 o->op_type = OP_RV2AV;
5777 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5782 if (ckWARN_d(WARN_INTERNAL))
5783 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
5790 Perl_oopsHV(pTHX_ OP *o)
5793 switch (o->op_type) {
5796 o->op_type = OP_PADHV;
5797 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5798 return ref(o, OP_RV2HV);
5802 o->op_type = OP_RV2HV;
5803 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5808 if (ckWARN_d(WARN_INTERNAL))
5809 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
5816 Perl_newAVREF(pTHX_ OP *o)
5819 if (o->op_type == OP_PADANY) {
5820 o->op_type = OP_PADAV;
5821 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5824 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5825 && ckWARN(WARN_DEPRECATED)) {
5826 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5827 "Using an array as a reference is deprecated");
5829 return newUNOP(OP_RV2AV, 0, scalar(o));
5833 Perl_newGVREF(pTHX_ I32 type, OP *o)
5835 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5836 return newUNOP(OP_NULL, 0, o);
5837 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5841 Perl_newHVREF(pTHX_ OP *o)
5844 if (o->op_type == OP_PADANY) {
5845 o->op_type = OP_PADHV;
5846 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5849 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5850 && ckWARN(WARN_DEPRECATED)) {
5851 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5852 "Using a hash as a reference is deprecated");
5854 return newUNOP(OP_RV2HV, 0, scalar(o));
5858 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5860 return newUNOP(OP_RV2CV, flags, scalar(o));
5864 Perl_newSVREF(pTHX_ OP *o)
5867 if (o->op_type == OP_PADANY) {
5868 o->op_type = OP_PADSV;
5869 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5872 return newUNOP(OP_RV2SV, 0, scalar(o));
5875 /* Check routines. See the comments at the top of this file for details
5876 * on when these are called */
5879 Perl_ck_anoncode(pTHX_ OP *o)
5881 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
5883 cSVOPo->op_sv = NULL;
5888 Perl_ck_bitop(pTHX_ OP *o)
5891 #define OP_IS_NUMCOMPARE(op) \
5892 ((op) == OP_LT || (op) == OP_I_LT || \
5893 (op) == OP_GT || (op) == OP_I_GT || \
5894 (op) == OP_LE || (op) == OP_I_LE || \
5895 (op) == OP_GE || (op) == OP_I_GE || \
5896 (op) == OP_EQ || (op) == OP_I_EQ || \
5897 (op) == OP_NE || (op) == OP_I_NE || \
5898 (op) == OP_NCMP || (op) == OP_I_NCMP)
5899 o->op_private = (U8)(PL_hints & HINT_INTEGER);
5900 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
5901 && (o->op_type == OP_BIT_OR
5902 || o->op_type == OP_BIT_AND
5903 || o->op_type == OP_BIT_XOR))
5905 const OP * const left = cBINOPo->op_first;
5906 const OP * const right = left->op_sibling;
5907 if ((OP_IS_NUMCOMPARE(left->op_type) &&
5908 (left->op_flags & OPf_PARENS) == 0) ||
5909 (OP_IS_NUMCOMPARE(right->op_type) &&
5910 (right->op_flags & OPf_PARENS) == 0))
5911 if (ckWARN(WARN_PRECEDENCE))
5912 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
5913 "Possible precedence problem on bitwise %c operator",
5914 o->op_type == OP_BIT_OR ? '|'
5915 : o->op_type == OP_BIT_AND ? '&' : '^'
5922 Perl_ck_concat(pTHX_ OP *o)
5924 const OP * const kid = cUNOPo->op_first;
5925 PERL_UNUSED_CONTEXT;
5926 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
5927 !(kUNOP->op_first->op_flags & OPf_MOD))
5928 o->op_flags |= OPf_STACKED;
5933 Perl_ck_spair(pTHX_ OP *o)
5936 if (o->op_flags & OPf_KIDS) {
5939 const OPCODE type = o->op_type;
5940 o = modkids(ck_fun(o), type);
5941 kid = cUNOPo->op_first;
5942 newop = kUNOP->op_first->op_sibling;
5944 const OPCODE type = newop->op_type;
5945 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
5946 type == OP_PADAV || type == OP_PADHV ||
5947 type == OP_RV2AV || type == OP_RV2HV)
5951 op_getmad(kUNOP->op_first,newop,'K');
5953 op_free(kUNOP->op_first);
5955 kUNOP->op_first = newop;
5957 o->op_ppaddr = PL_ppaddr[++o->op_type];
5962 Perl_ck_delete(pTHX_ OP *o)
5966 if (o->op_flags & OPf_KIDS) {
5967 OP * const kid = cUNOPo->op_first;
5968 switch (kid->op_type) {
5970 o->op_flags |= OPf_SPECIAL;
5973 o->op_private |= OPpSLICE;
5976 o->op_flags |= OPf_SPECIAL;
5981 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5990 Perl_ck_die(pTHX_ OP *o)
5993 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5999 Perl_ck_eof(pTHX_ OP *o)
6003 if (o->op_flags & OPf_KIDS) {
6004 if (cLISTOPo->op_first->op_type == OP_STUB) {
6006 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
6008 op_getmad(o,newop,'O');
6020 Perl_ck_eval(pTHX_ OP *o)
6023 PL_hints |= HINT_BLOCK_SCOPE;
6024 if (o->op_flags & OPf_KIDS) {
6025 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6028 o->op_flags &= ~OPf_KIDS;
6031 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
6037 cUNOPo->op_first = 0;
6042 NewOp(1101, enter, 1, LOGOP);
6043 enter->op_type = OP_ENTERTRY;
6044 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
6045 enter->op_private = 0;
6047 /* establish postfix order */
6048 enter->op_next = (OP*)enter;
6050 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
6051 o->op_type = OP_LEAVETRY;
6052 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
6053 enter->op_other = o;
6054 op_getmad(oldo,o,'O');
6068 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
6069 op_getmad(oldo,o,'O');
6071 o->op_targ = (PADOFFSET)PL_hints;
6072 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
6073 /* Store a copy of %^H that pp_entereval can pick up */
6074 OP *hhop = newSVOP(OP_CONST, 0,
6075 (SV*)Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv)));
6076 cUNOPo->op_first->op_sibling = hhop;
6077 o->op_private |= OPpEVAL_HAS_HH;
6083 Perl_ck_exit(pTHX_ OP *o)
6086 HV * const table = GvHV(PL_hintgv);
6088 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
6089 if (svp && *svp && SvTRUE(*svp))
6090 o->op_private |= OPpEXIT_VMSISH;
6092 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6098 Perl_ck_exec(pTHX_ OP *o)
6100 if (o->op_flags & OPf_STACKED) {
6103 kid = cUNOPo->op_first->op_sibling;
6104 if (kid->op_type == OP_RV2GV)
6113 Perl_ck_exists(pTHX_ OP *o)
6117 if (o->op_flags & OPf_KIDS) {
6118 OP * const kid = cUNOPo->op_first;
6119 if (kid->op_type == OP_ENTERSUB) {
6120 (void) ref(kid, o->op_type);
6121 if (kid->op_type != OP_RV2CV && !PL_error_count)
6122 Perl_croak(aTHX_ "%s argument is not a subroutine name",
6124 o->op_private |= OPpEXISTS_SUB;
6126 else if (kid->op_type == OP_AELEM)
6127 o->op_flags |= OPf_SPECIAL;
6128 else if (kid->op_type != OP_HELEM)
6129 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
6137 Perl_ck_rvconst(pTHX_ register OP *o)
6140 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6142 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6143 if (o->op_type == OP_RV2CV)
6144 o->op_private &= ~1;
6146 if (kid->op_type == OP_CONST) {
6149 SV * const kidsv = kid->op_sv;
6151 /* Is it a constant from cv_const_sv()? */
6152 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
6153 SV * const rsv = SvRV(kidsv);
6154 const svtype type = SvTYPE(rsv);
6155 const char *badtype = NULL;
6157 switch (o->op_type) {
6159 if (type > SVt_PVMG)
6160 badtype = "a SCALAR";
6163 if (type != SVt_PVAV)
6164 badtype = "an ARRAY";
6167 if (type != SVt_PVHV)
6171 if (type != SVt_PVCV)
6176 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
6179 else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
6180 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
6181 /* If this is an access to a stash, disable "strict refs", because
6182 * stashes aren't auto-vivified at compile-time (unless we store
6183 * symbols in them), and we don't want to produce a run-time
6184 * stricture error when auto-vivifying the stash. */
6185 const char *s = SvPV_nolen(kidsv);
6186 const STRLEN l = SvCUR(kidsv);
6187 if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
6188 o->op_private &= ~HINT_STRICT_REFS;
6190 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
6191 const char *badthing;
6192 switch (o->op_type) {
6194 badthing = "a SCALAR";
6197 badthing = "an ARRAY";
6200 badthing = "a HASH";
6208 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
6209 SVfARG(kidsv), badthing);
6212 * This is a little tricky. We only want to add the symbol if we
6213 * didn't add it in the lexer. Otherwise we get duplicate strict
6214 * warnings. But if we didn't add it in the lexer, we must at
6215 * least pretend like we wanted to add it even if it existed before,
6216 * or we get possible typo warnings. OPpCONST_ENTERED says
6217 * whether the lexer already added THIS instance of this symbol.
6219 iscv = (o->op_type == OP_RV2CV) * 2;
6221 gv = gv_fetchsv(kidsv,
6222 iscv | !(kid->op_private & OPpCONST_ENTERED),
6225 : o->op_type == OP_RV2SV
6227 : o->op_type == OP_RV2AV
6229 : o->op_type == OP_RV2HV
6232 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
6234 kid->op_type = OP_GV;
6235 SvREFCNT_dec(kid->op_sv);
6237 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
6238 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
6239 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
6241 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc_simple_NN(gv));
6243 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
6245 kid->op_private = 0;
6246 kid->op_ppaddr = PL_ppaddr[OP_GV];
6253 Perl_ck_ftst(pTHX_ OP *o)
6256 const I32 type = o->op_type;
6258 if (o->op_flags & OPf_REF) {
6261 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
6262 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6263 const OPCODE kidtype = kid->op_type;
6265 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6266 OP * const newop = newGVOP(type, OPf_REF,
6267 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
6269 op_getmad(o,newop,'O');
6275 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o))
6276 o->op_private |= OPpFT_ACCESS;
6277 if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst)
6278 && kidtype != OP_STAT && kidtype != OP_LSTAT)
6279 o->op_private |= OPpFT_STACKED;
6287 if (type == OP_FTTTY)
6288 o = newGVOP(type, OPf_REF, PL_stdingv);
6290 o = newUNOP(type, 0, newDEFSVOP());
6291 op_getmad(oldo,o,'O');
6297 Perl_ck_fun(pTHX_ OP *o)
6300 const int type = o->op_type;
6301 register I32 oa = PL_opargs[type] >> OASHIFT;
6303 if (o->op_flags & OPf_STACKED) {
6304 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
6307 return no_fh_allowed(o);
6310 if (o->op_flags & OPf_KIDS) {
6311 OP **tokid = &cLISTOPo->op_first;
6312 register OP *kid = cLISTOPo->op_first;
6316 if (kid->op_type == OP_PUSHMARK ||
6317 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
6319 tokid = &kid->op_sibling;
6320 kid = kid->op_sibling;
6322 if (!kid && PL_opargs[type] & OA_DEFGV)
6323 *tokid = kid = newDEFSVOP();
6327 sibl = kid->op_sibling;
6329 if (!sibl && kid->op_type == OP_STUB) {
6336 /* list seen where single (scalar) arg expected? */
6337 if (numargs == 1 && !(oa >> 4)
6338 && kid->op_type == OP_LIST && type != OP_SCALAR)
6340 return too_many_arguments(o,PL_op_desc[type]);
6353 if ((type == OP_PUSH || type == OP_UNSHIFT)
6354 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
6355 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6356 "Useless use of %s with no values",
6359 if (kid->op_type == OP_CONST &&
6360 (kid->op_private & OPpCONST_BARE))
6362 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
6363 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
6364 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6365 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6366 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
6367 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6369 op_getmad(kid,newop,'K');
6374 kid->op_sibling = sibl;
6377 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
6378 bad_type(numargs, "array", PL_op_desc[type], kid);
6382 if (kid->op_type == OP_CONST &&
6383 (kid->op_private & OPpCONST_BARE))
6385 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
6386 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
6387 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6388 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6389 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
6390 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6392 op_getmad(kid,newop,'K');
6397 kid->op_sibling = sibl;
6400 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
6401 bad_type(numargs, "hash", PL_op_desc[type], kid);
6406 OP * const newop = newUNOP(OP_NULL, 0, kid);
6407 kid->op_sibling = 0;
6409 newop->op_next = newop;
6411 kid->op_sibling = sibl;
6416 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
6417 if (kid->op_type == OP_CONST &&
6418 (kid->op_private & OPpCONST_BARE))
6420 OP * const newop = newGVOP(OP_GV, 0,
6421 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
6422 if (!(o->op_private & 1) && /* if not unop */
6423 kid == cLISTOPo->op_last)
6424 cLISTOPo->op_last = newop;
6426 op_getmad(kid,newop,'K');
6432 else if (kid->op_type == OP_READLINE) {
6433 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
6434 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
6437 I32 flags = OPf_SPECIAL;
6441 /* is this op a FH constructor? */
6442 if (is_handle_constructor(o,numargs)) {
6443 const char *name = NULL;
6447 /* Set a flag to tell rv2gv to vivify
6448 * need to "prove" flag does not mean something
6449 * else already - NI-S 1999/05/07
6452 if (kid->op_type == OP_PADSV) {
6454 = PAD_COMPNAME_SV(kid->op_targ);
6455 name = SvPV_const(namesv, len);
6457 else if (kid->op_type == OP_RV2SV
6458 && kUNOP->op_first->op_type == OP_GV)
6460 GV * const gv = cGVOPx_gv(kUNOP->op_first);
6462 len = GvNAMELEN(gv);
6464 else if (kid->op_type == OP_AELEM
6465 || kid->op_type == OP_HELEM)
6468 OP *op = ((BINOP*)kid)->op_first;
6472 const char * const a =
6473 kid->op_type == OP_AELEM ?
6475 if (((op->op_type == OP_RV2AV) ||
6476 (op->op_type == OP_RV2HV)) &&
6477 (firstop = ((UNOP*)op)->op_first) &&
6478 (firstop->op_type == OP_GV)) {
6479 /* packagevar $a[] or $h{} */
6480 GV * const gv = cGVOPx_gv(firstop);
6488 else if (op->op_type == OP_PADAV
6489 || op->op_type == OP_PADHV) {
6490 /* lexicalvar $a[] or $h{} */
6491 const char * const padname =
6492 PAD_COMPNAME_PV(op->op_targ);
6501 name = SvPV_const(tmpstr, len);
6506 name = "__ANONIO__";
6513 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
6514 namesv = PAD_SVl(targ);
6515 SvUPGRADE(namesv, SVt_PV);
6517 sv_setpvn(namesv, "$", 1);
6518 sv_catpvn(namesv, name, len);
6521 kid->op_sibling = 0;
6522 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
6523 kid->op_targ = targ;
6524 kid->op_private |= priv;
6526 kid->op_sibling = sibl;
6532 mod(scalar(kid), type);
6536 tokid = &kid->op_sibling;
6537 kid = kid->op_sibling;
6540 if (kid && kid->op_type != OP_STUB)
6541 return too_many_arguments(o,OP_DESC(o));
6542 o->op_private |= numargs;
6544 /* FIXME - should the numargs move as for the PERL_MAD case? */
6545 o->op_private |= numargs;
6547 return too_many_arguments(o,OP_DESC(o));
6551 else if (PL_opargs[type] & OA_DEFGV) {
6553 OP *newop = newUNOP(type, 0, newDEFSVOP());
6554 op_getmad(o,newop,'O');
6557 /* Ordering of these two is important to keep f_map.t passing. */
6559 return newUNOP(type, 0, newDEFSVOP());
6564 while (oa & OA_OPTIONAL)
6566 if (oa && oa != OA_LIST)
6567 return too_few_arguments(o,OP_DESC(o));
6573 Perl_ck_glob(pTHX_ OP *o)
6579 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
6580 append_elem(OP_GLOB, o, newDEFSVOP());
6582 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
6583 && GvCVu(gv) && GvIMPORTED_CV(gv)))
6585 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6588 #if !defined(PERL_EXTERNAL_GLOB)
6589 /* XXX this can be tightened up and made more failsafe. */
6590 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
6593 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
6594 newSVpvs("File::Glob"), NULL, NULL, NULL);
6595 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6596 glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
6597 GvCV(gv) = GvCV(glob_gv);
6598 SvREFCNT_inc_void((SV*)GvCV(gv));
6599 GvIMPORTED_CV_on(gv);
6602 #endif /* PERL_EXTERNAL_GLOB */
6604 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6605 append_elem(OP_GLOB, o,
6606 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
6607 o->op_type = OP_LIST;
6608 o->op_ppaddr = PL_ppaddr[OP_LIST];
6609 cLISTOPo->op_first->op_type = OP_PUSHMARK;
6610 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
6611 cLISTOPo->op_first->op_targ = 0;
6612 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
6613 append_elem(OP_LIST, o,
6614 scalar(newUNOP(OP_RV2CV, 0,
6615 newGVOP(OP_GV, 0, gv)))));
6616 o = newUNOP(OP_NULL, 0, ck_subr(o));
6617 o->op_targ = OP_GLOB; /* hint at what it used to be */
6620 gv = newGVgen("main");
6622 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
6628 Perl_ck_grep(pTHX_ OP *o)
6633 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
6636 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
6637 /* don't allocate gwop here, as we may leak it if PL_error_count > 0 */
6639 if (o->op_flags & OPf_STACKED) {
6642 kid = cLISTOPo->op_first->op_sibling;
6643 if (!cUNOPx(kid)->op_next)
6644 Perl_croak(aTHX_ "panic: ck_grep");
6645 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
6648 NewOp(1101, gwop, 1, LOGOP);
6649 kid->op_next = (OP*)gwop;
6650 o->op_flags &= ~OPf_STACKED;
6652 kid = cLISTOPo->op_first->op_sibling;
6653 if (type == OP_MAPWHILE)
6660 kid = cLISTOPo->op_first->op_sibling;
6661 if (kid->op_type != OP_NULL)
6662 Perl_croak(aTHX_ "panic: ck_grep");
6663 kid = kUNOP->op_first;
6666 NewOp(1101, gwop, 1, LOGOP);
6667 gwop->op_type = type;
6668 gwop->op_ppaddr = PL_ppaddr[type];
6669 gwop->op_first = listkids(o);
6670 gwop->op_flags |= OPf_KIDS;
6671 gwop->op_other = LINKLIST(kid);
6672 kid->op_next = (OP*)gwop;
6673 offset = pad_findmy("$_");
6674 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
6675 o->op_private = gwop->op_private = 0;
6676 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
6679 o->op_private = gwop->op_private = OPpGREP_LEX;
6680 gwop->op_targ = o->op_targ = offset;
6683 kid = cLISTOPo->op_first->op_sibling;
6684 if (!kid || !kid->op_sibling)
6685 return too_few_arguments(o,OP_DESC(o));
6686 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
6687 mod(kid, OP_GREPSTART);
6693 Perl_ck_index(pTHX_ OP *o)
6695 if (o->op_flags & OPf_KIDS) {
6696 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6698 kid = kid->op_sibling; /* get past "big" */
6699 if (kid && kid->op_type == OP_CONST)
6700 fbm_compile(((SVOP*)kid)->op_sv, 0);
6706 Perl_ck_lengthconst(pTHX_ OP *o)
6708 /* XXX length optimization goes here */
6713 Perl_ck_lfun(pTHX_ OP *o)
6715 const OPCODE type = o->op_type;
6716 return modkids(ck_fun(o), type);
6720 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
6722 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
6723 switch (cUNOPo->op_first->op_type) {
6725 /* This is needed for
6726 if (defined %stash::)
6727 to work. Do not break Tk.
6729 break; /* Globals via GV can be undef */
6731 case OP_AASSIGN: /* Is this a good idea? */
6732 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6733 "defined(@array) is deprecated");
6734 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6735 "\t(Maybe you should just omit the defined()?)\n");
6738 /* This is needed for
6739 if (defined %stash::)
6740 to work. Do not break Tk.
6742 break; /* Globals via GV can be undef */
6744 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6745 "defined(%%hash) is deprecated");
6746 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6747 "\t(Maybe you should just omit the defined()?)\n");
6758 Perl_ck_rfun(pTHX_ OP *o)
6760 const OPCODE type = o->op_type;
6761 return refkids(ck_fun(o), type);
6765 Perl_ck_listiob(pTHX_ OP *o)
6769 kid = cLISTOPo->op_first;
6772 kid = cLISTOPo->op_first;
6774 if (kid->op_type == OP_PUSHMARK)
6775 kid = kid->op_sibling;
6776 if (kid && o->op_flags & OPf_STACKED)
6777 kid = kid->op_sibling;
6778 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6779 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6780 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6781 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6782 cLISTOPo->op_first->op_sibling = kid;
6783 cLISTOPo->op_last = kid;
6784 kid = kid->op_sibling;
6789 append_elem(o->op_type, o, newDEFSVOP());
6795 Perl_ck_smartmatch(pTHX_ OP *o)
6798 if (0 == (o->op_flags & OPf_SPECIAL)) {
6799 OP *first = cBINOPo->op_first;
6800 OP *second = first->op_sibling;
6802 /* Implicitly take a reference to an array or hash */
6803 first->op_sibling = NULL;
6804 first = cBINOPo->op_first = ref_array_or_hash(first);
6805 second = first->op_sibling = ref_array_or_hash(second);
6807 /* Implicitly take a reference to a regular expression */
6808 if (first->op_type == OP_MATCH) {
6809 first->op_type = OP_QR;
6810 first->op_ppaddr = PL_ppaddr[OP_QR];
6812 if (second->op_type == OP_MATCH) {
6813 second->op_type = OP_QR;
6814 second->op_ppaddr = PL_ppaddr[OP_QR];
6823 Perl_ck_sassign(pTHX_ OP *o)
6825 OP * const kid = cLISTOPo->op_first;
6826 /* has a disposable target? */
6827 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6828 && !(kid->op_flags & OPf_STACKED)
6829 /* Cannot steal the second time! */
6830 && !(kid->op_private & OPpTARGET_MY))
6832 OP * const kkid = kid->op_sibling;
6834 /* Can just relocate the target. */
6835 if (kkid && kkid->op_type == OP_PADSV
6836 && !(kkid->op_private & OPpLVAL_INTRO))
6838 kid->op_targ = kkid->op_targ;
6840 /* Now we do not need PADSV and SASSIGN. */
6841 kid->op_sibling = o->op_sibling; /* NULL */
6842 cLISTOPo->op_first = NULL;
6844 op_getmad(o,kid,'O');
6845 op_getmad(kkid,kid,'M');
6850 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6854 if (kid->op_sibling) {
6855 OP *kkid = kid->op_sibling;
6856 if (kkid->op_type == OP_PADSV
6857 && (kkid->op_private & OPpLVAL_INTRO)
6858 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
6859 o->op_private |= OPpASSIGN_STATE;
6860 /* hijacking PADSTALE for uninitialized state variables */
6861 SvPADSTALE_on(PAD_SVl(kkid->op_targ));
6868 Perl_ck_match(pTHX_ OP *o)
6871 if (o->op_type != OP_QR && PL_compcv) {
6872 const PADOFFSET offset = pad_findmy("$_");
6873 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
6874 o->op_targ = offset;
6875 o->op_private |= OPpTARGET_MY;
6878 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
6879 o->op_private |= OPpRUNTIME;
6884 Perl_ck_method(pTHX_ OP *o)
6886 OP * const kid = cUNOPo->op_first;
6887 if (kid->op_type == OP_CONST) {
6888 SV* sv = kSVOP->op_sv;
6889 const char * const method = SvPVX_const(sv);
6890 if (!(strchr(method, ':') || strchr(method, '\''))) {
6892 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6893 sv = newSVpvn_share(method, SvCUR(sv), 0);
6896 kSVOP->op_sv = NULL;
6898 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6900 op_getmad(o,cmop,'O');
6911 Perl_ck_null(pTHX_ OP *o)
6913 PERL_UNUSED_CONTEXT;
6918 Perl_ck_open(pTHX_ OP *o)
6921 HV * const table = GvHV(PL_hintgv);
6923 SV **svp = hv_fetchs(table, "open_IN", FALSE);
6925 const I32 mode = mode_from_discipline(*svp);
6926 if (mode & O_BINARY)
6927 o->op_private |= OPpOPEN_IN_RAW;
6928 else if (mode & O_TEXT)
6929 o->op_private |= OPpOPEN_IN_CRLF;
6932 svp = hv_fetchs(table, "open_OUT", FALSE);
6934 const I32 mode = mode_from_discipline(*svp);
6935 if (mode & O_BINARY)
6936 o->op_private |= OPpOPEN_OUT_RAW;
6937 else if (mode & O_TEXT)
6938 o->op_private |= OPpOPEN_OUT_CRLF;
6941 if (o->op_type == OP_BACKTICK)
6944 /* In case of three-arg dup open remove strictness
6945 * from the last arg if it is a bareword. */
6946 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
6947 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
6951 if ((last->op_type == OP_CONST) && /* The bareword. */
6952 (last->op_private & OPpCONST_BARE) &&
6953 (last->op_private & OPpCONST_STRICT) &&
6954 (oa = first->op_sibling) && /* The fh. */
6955 (oa = oa->op_sibling) && /* The mode. */
6956 (oa->op_type == OP_CONST) &&
6957 SvPOK(((SVOP*)oa)->op_sv) &&
6958 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
6959 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
6960 (last == oa->op_sibling)) /* The bareword. */
6961 last->op_private &= ~OPpCONST_STRICT;
6967 Perl_ck_repeat(pTHX_ OP *o)
6969 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6970 o->op_private |= OPpREPEAT_DOLIST;
6971 cBINOPo->op_first = force_list(cBINOPo->op_first);
6979 Perl_ck_require(pTHX_ OP *o)
6984 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6985 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6987 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6988 SV * const sv = kid->op_sv;
6989 U32 was_readonly = SvREADONLY(sv);
6994 sv_force_normal_flags(sv, 0);
6995 assert(!SvREADONLY(sv));
7002 for (s = SvPVX(sv); *s; s++) {
7003 if (*s == ':' && s[1] == ':') {
7004 const STRLEN len = strlen(s+2)+1;
7006 Move(s+2, s+1, len, char);
7007 SvCUR_set(sv, SvCUR(sv) - 1);
7010 sv_catpvs(sv, ".pm");
7011 SvFLAGS(sv) |= was_readonly;
7015 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
7016 /* handle override, if any */
7017 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
7018 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7019 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
7020 gv = gvp ? *gvp : NULL;
7024 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7025 OP * const kid = cUNOPo->op_first;
7028 cUNOPo->op_first = 0;
7032 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
7033 append_elem(OP_LIST, kid,
7034 scalar(newUNOP(OP_RV2CV, 0,
7037 op_getmad(o,newop,'O');
7045 Perl_ck_return(pTHX_ OP *o)
7048 if (CvLVALUE(PL_compcv)) {
7050 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
7051 mod(kid, OP_LEAVESUBLV);
7057 Perl_ck_select(pTHX_ OP *o)
7061 if (o->op_flags & OPf_KIDS) {
7062 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7063 if (kid && kid->op_sibling) {
7064 o->op_type = OP_SSELECT;
7065 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
7067 return fold_constants(o);
7071 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7072 if (kid && kid->op_type == OP_RV2GV)
7073 kid->op_private &= ~HINT_STRICT_REFS;
7078 Perl_ck_shift(pTHX_ OP *o)
7081 const I32 type = o->op_type;
7083 if (!(o->op_flags & OPf_KIDS)) {
7085 /* FIXME - this can be refactored to reduce code in #ifdefs */
7087 OP * const oldo = o;
7091 argop = newUNOP(OP_RV2AV, 0,
7092 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
7094 o = newUNOP(type, 0, scalar(argop));
7095 op_getmad(oldo,o,'O');
7098 return newUNOP(type, 0, scalar(argop));
7101 return scalar(modkids(ck_fun(o), type));
7105 Perl_ck_sort(pTHX_ OP *o)
7110 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
7111 HV * const hinthv = GvHV(PL_hintgv);
7113 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
7115 const I32 sorthints = (I32)SvIV(*svp);
7116 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
7117 o->op_private |= OPpSORT_QSORT;
7118 if ((sorthints & HINT_SORT_STABLE) != 0)
7119 o->op_private |= OPpSORT_STABLE;
7124 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
7126 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7127 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
7129 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
7131 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
7133 if (kid->op_type == OP_SCOPE) {
7137 else if (kid->op_type == OP_LEAVE) {
7138 if (o->op_type == OP_SORT) {
7139 op_null(kid); /* wipe out leave */
7142 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
7143 if (k->op_next == kid)
7145 /* don't descend into loops */
7146 else if (k->op_type == OP_ENTERLOOP
7147 || k->op_type == OP_ENTERITER)
7149 k = cLOOPx(k)->op_lastop;
7154 kid->op_next = 0; /* just disconnect the leave */
7155 k = kLISTOP->op_first;
7160 if (o->op_type == OP_SORT) {
7161 /* provide scalar context for comparison function/block */
7167 o->op_flags |= OPf_SPECIAL;
7169 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
7172 firstkid = firstkid->op_sibling;
7175 /* provide list context for arguments */
7176 if (o->op_type == OP_SORT)
7183 S_simplify_sort(pTHX_ OP *o)
7186 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7191 if (!(o->op_flags & OPf_STACKED))
7193 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7194 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
7195 kid = kUNOP->op_first; /* get past null */
7196 if (kid->op_type != OP_SCOPE)
7198 kid = kLISTOP->op_last; /* get past scope */
7199 switch(kid->op_type) {
7207 k = kid; /* remember this node*/
7208 if (kBINOP->op_first->op_type != OP_RV2SV)
7210 kid = kBINOP->op_first; /* get past cmp */
7211 if (kUNOP->op_first->op_type != OP_GV)
7213 kid = kUNOP->op_first; /* get past rv2sv */
7215 if (GvSTASH(gv) != PL_curstash)
7217 gvname = GvNAME(gv);
7218 if (*gvname == 'a' && gvname[1] == '\0')
7220 else if (*gvname == 'b' && gvname[1] == '\0')
7225 kid = k; /* back to cmp */
7226 if (kBINOP->op_last->op_type != OP_RV2SV)
7228 kid = kBINOP->op_last; /* down to 2nd arg */
7229 if (kUNOP->op_first->op_type != OP_GV)
7231 kid = kUNOP->op_first; /* get past rv2sv */
7233 if (GvSTASH(gv) != PL_curstash)
7235 gvname = GvNAME(gv);
7237 ? !(*gvname == 'a' && gvname[1] == '\0')
7238 : !(*gvname == 'b' && gvname[1] == '\0'))
7240 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
7242 o->op_private |= OPpSORT_DESCEND;
7243 if (k->op_type == OP_NCMP)
7244 o->op_private |= OPpSORT_NUMERIC;
7245 if (k->op_type == OP_I_NCMP)
7246 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
7247 kid = cLISTOPo->op_first->op_sibling;
7248 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
7250 op_getmad(kid,o,'S'); /* then delete it */
7252 op_free(kid); /* then delete it */
7257 Perl_ck_split(pTHX_ OP *o)
7262 if (o->op_flags & OPf_STACKED)
7263 return no_fh_allowed(o);
7265 kid = cLISTOPo->op_first;
7266 if (kid->op_type != OP_NULL)
7267 Perl_croak(aTHX_ "panic: ck_split");
7268 kid = kid->op_sibling;
7269 op_free(cLISTOPo->op_first);
7270 cLISTOPo->op_first = kid;
7272 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
7273 cLISTOPo->op_last = kid; /* There was only one element previously */
7276 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
7277 OP * const sibl = kid->op_sibling;
7278 kid->op_sibling = 0;
7279 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
7280 if (cLISTOPo->op_first == cLISTOPo->op_last)
7281 cLISTOPo->op_last = kid;
7282 cLISTOPo->op_first = kid;
7283 kid->op_sibling = sibl;
7286 kid->op_type = OP_PUSHRE;
7287 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
7289 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
7290 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
7291 "Use of /g modifier is meaningless in split");
7294 if (!kid->op_sibling)
7295 append_elem(OP_SPLIT, o, newDEFSVOP());
7297 kid = kid->op_sibling;
7300 if (!kid->op_sibling)
7301 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
7302 assert(kid->op_sibling);
7304 kid = kid->op_sibling;
7307 if (kid->op_sibling)
7308 return too_many_arguments(o,OP_DESC(o));
7314 Perl_ck_join(pTHX_ OP *o)
7316 const OP * const kid = cLISTOPo->op_first->op_sibling;
7317 if (kid && kid->op_type == OP_MATCH) {
7318 if (ckWARN(WARN_SYNTAX)) {
7319 const REGEXP *re = PM_GETRE(kPMOP);
7320 const char *pmstr = re ? re->precomp : "STRING";
7321 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7322 "/%s/ should probably be written as \"%s\"",
7330 Perl_ck_subr(pTHX_ OP *o)
7333 OP *prev = ((cUNOPo->op_first->op_sibling)
7334 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
7335 OP *o2 = prev->op_sibling;
7337 const char *proto = NULL;
7338 const char *proto_end = NULL;
7343 I32 contextclass = 0;
7344 const char *e = NULL;
7347 o->op_private |= OPpENTERSUB_HASTARG;
7348 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
7349 if (cvop->op_type == OP_RV2CV) {
7351 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
7352 op_null(cvop); /* disable rv2cv */
7353 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
7354 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
7355 GV *gv = cGVOPx_gv(tmpop);
7358 tmpop->op_private |= OPpEARLY_CV;
7362 namegv = CvANON(cv) ? gv : CvGV(cv);
7363 proto = SvPV((SV*)cv, len);
7364 proto_end = proto + len;
7366 if (CvASSERTION(cv)) {
7367 U32 asserthints = 0;
7368 HV *const hinthv = GvHV(PL_hintgv);
7370 SV **svp = hv_fetchs(hinthv, "assertions", FALSE);
7372 asserthints = SvUV(*svp);
7374 if (asserthints & HINT_ASSERTING) {
7375 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
7376 o->op_private |= OPpENTERSUB_DB;
7380 if (!(asserthints & HINT_ASSERTIONSSEEN) && ckWARN(WARN_ASSERTIONS)) {
7381 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
7382 "Impossible to activate assertion call");
7389 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7390 if (o2->op_type == OP_CONST)
7391 o2->op_private &= ~OPpCONST_STRICT;
7392 else if (o2->op_type == OP_LIST) {
7393 OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
7394 if (sib && sib->op_type == OP_CONST)
7395 sib->op_private &= ~OPpCONST_STRICT;
7398 o->op_private |= (PL_hints & HINT_STRICT_REFS);
7399 if (PERLDB_SUB && PL_curstash != PL_debstash)
7400 o->op_private |= OPpENTERSUB_DB;
7401 while (o2 != cvop) {
7403 if (PL_madskills && o2->op_type == OP_NULL)
7404 o3 = ((UNOP*)o2)->op_first;
7408 if (proto >= proto_end)
7409 return too_many_arguments(o, gv_ename(namegv));
7417 /* _ must be at the end */
7418 if (proto[1] && proto[1] != ';')
7433 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
7435 arg == 1 ? "block or sub {}" : "sub {}",
7436 gv_ename(namegv), o3);
7439 /* '*' allows any scalar type, including bareword */
7442 if (o3->op_type == OP_RV2GV)
7443 goto wrapref; /* autoconvert GLOB -> GLOBref */
7444 else if (o3->op_type == OP_CONST)
7445 o3->op_private &= ~OPpCONST_STRICT;
7446 else if (o3->op_type == OP_ENTERSUB) {
7447 /* accidental subroutine, revert to bareword */
7448 OP *gvop = ((UNOP*)o3)->op_first;
7449 if (gvop && gvop->op_type == OP_NULL) {
7450 gvop = ((UNOP*)gvop)->op_first;
7452 for (; gvop->op_sibling; gvop = gvop->op_sibling)
7455 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
7456 (gvop = ((UNOP*)gvop)->op_first) &&
7457 gvop->op_type == OP_GV)
7459 GV * const gv = cGVOPx_gv(gvop);
7460 OP * const sibling = o2->op_sibling;
7461 SV * const n = newSVpvs("");
7463 OP * const oldo2 = o2;
7467 gv_fullname4(n, gv, "", FALSE);
7468 o2 = newSVOP(OP_CONST, 0, n);
7469 op_getmad(oldo2,o2,'O');
7470 prev->op_sibling = o2;
7471 o2->op_sibling = sibling;
7487 if (contextclass++ == 0) {
7488 e = strchr(proto, ']');
7489 if (!e || e == proto)
7498 const char *p = proto;
7499 const char *const end = proto;
7501 while (*--p != '[');
7502 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
7504 gv_ename(namegv), o3);
7509 if (o3->op_type == OP_RV2GV)
7512 bad_type(arg, "symbol", gv_ename(namegv), o3);
7515 if (o3->op_type == OP_ENTERSUB)
7518 bad_type(arg, "subroutine entry", gv_ename(namegv),
7522 if (o3->op_type == OP_RV2SV ||
7523 o3->op_type == OP_PADSV ||
7524 o3->op_type == OP_HELEM ||
7525 o3->op_type == OP_AELEM)
7528 bad_type(arg, "scalar", gv_ename(namegv), o3);
7531 if (o3->op_type == OP_RV2AV ||
7532 o3->op_type == OP_PADAV)
7535 bad_type(arg, "array", gv_ename(namegv), o3);
7538 if (o3->op_type == OP_RV2HV ||
7539 o3->op_type == OP_PADHV)
7542 bad_type(arg, "hash", gv_ename(namegv), o3);
7547 OP* const sib = kid->op_sibling;
7548 kid->op_sibling = 0;
7549 o2 = newUNOP(OP_REFGEN, 0, kid);
7550 o2->op_sibling = sib;
7551 prev->op_sibling = o2;
7553 if (contextclass && e) {
7568 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
7569 gv_ename(namegv), SVfARG(cv));
7574 mod(o2, OP_ENTERSUB);
7576 o2 = o2->op_sibling;
7578 if (o2 == cvop && proto && *proto == '_') {
7579 /* generate an access to $_ */
7581 o2->op_sibling = prev->op_sibling;
7582 prev->op_sibling = o2; /* instead of cvop */
7584 if (proto && !optional && proto_end > proto &&
7585 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
7586 return too_few_arguments(o, gv_ename(namegv));
7589 OP * const oldo = o;
7593 o=newSVOP(OP_CONST, 0, newSViv(0));
7594 op_getmad(oldo,o,'O');
7600 Perl_ck_svconst(pTHX_ OP *o)
7602 PERL_UNUSED_CONTEXT;
7603 SvREADONLY_on(cSVOPo->op_sv);
7608 Perl_ck_chdir(pTHX_ OP *o)
7610 if (o->op_flags & OPf_KIDS) {
7611 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7613 if (kid && kid->op_type == OP_CONST &&
7614 (kid->op_private & OPpCONST_BARE))
7616 o->op_flags |= OPf_SPECIAL;
7617 kid->op_private &= ~OPpCONST_STRICT;
7624 Perl_ck_trunc(pTHX_ OP *o)
7626 if (o->op_flags & OPf_KIDS) {
7627 SVOP *kid = (SVOP*)cUNOPo->op_first;
7629 if (kid->op_type == OP_NULL)
7630 kid = (SVOP*)kid->op_sibling;
7631 if (kid && kid->op_type == OP_CONST &&
7632 (kid->op_private & OPpCONST_BARE))
7634 o->op_flags |= OPf_SPECIAL;
7635 kid->op_private &= ~OPpCONST_STRICT;
7642 Perl_ck_unpack(pTHX_ OP *o)
7644 OP *kid = cLISTOPo->op_first;
7645 if (kid->op_sibling) {
7646 kid = kid->op_sibling;
7647 if (!kid->op_sibling)
7648 kid->op_sibling = newDEFSVOP();
7654 Perl_ck_substr(pTHX_ OP *o)
7657 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
7658 OP *kid = cLISTOPo->op_first;
7660 if (kid->op_type == OP_NULL)
7661 kid = kid->op_sibling;
7663 kid->op_flags |= OPf_MOD;
7669 /* A peephole optimizer. We visit the ops in the order they're to execute.
7670 * See the comments at the top of this file for more details about when
7671 * peep() is called */
7674 Perl_peep(pTHX_ register OP *o)
7677 register OP* oldop = NULL;
7679 if (!o || o->op_opt)
7683 SAVEVPTR(PL_curcop);
7684 for (; o; o = o->op_next) {
7688 switch (o->op_type) {
7692 PL_curcop = ((COP*)o); /* for warnings */
7697 if (cSVOPo->op_private & OPpCONST_STRICT)
7698 no_bareword_allowed(o);
7700 case OP_METHOD_NAMED:
7701 /* Relocate sv to the pad for thread safety.
7702 * Despite being a "constant", the SV is written to,
7703 * for reference counts, sv_upgrade() etc. */
7705 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
7706 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
7707 /* If op_sv is already a PADTMP then it is being used by
7708 * some pad, so make a copy. */
7709 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
7710 SvREADONLY_on(PAD_SVl(ix));
7711 SvREFCNT_dec(cSVOPo->op_sv);
7713 else if (o->op_type == OP_CONST
7714 && cSVOPo->op_sv == &PL_sv_undef) {
7715 /* PL_sv_undef is hack - it's unsafe to store it in the
7716 AV that is the pad, because av_fetch treats values of
7717 PL_sv_undef as a "free" AV entry and will merrily
7718 replace them with a new SV, causing pad_alloc to think
7719 that this pad slot is free. (When, clearly, it is not)
7721 SvOK_off(PAD_SVl(ix));
7722 SvPADTMP_on(PAD_SVl(ix));
7723 SvREADONLY_on(PAD_SVl(ix));
7726 SvREFCNT_dec(PAD_SVl(ix));
7727 SvPADTMP_on(cSVOPo->op_sv);
7728 PAD_SETSV(ix, cSVOPo->op_sv);
7729 /* XXX I don't know how this isn't readonly already. */
7730 SvREADONLY_on(PAD_SVl(ix));
7732 cSVOPo->op_sv = NULL;
7740 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
7741 if (o->op_next->op_private & OPpTARGET_MY) {
7742 if (o->op_flags & OPf_STACKED) /* chained concats */
7743 goto ignore_optimization;
7745 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
7746 o->op_targ = o->op_next->op_targ;
7747 o->op_next->op_targ = 0;
7748 o->op_private |= OPpTARGET_MY;
7751 op_null(o->op_next);
7753 ignore_optimization:
7757 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
7759 break; /* Scalar stub must produce undef. List stub is noop */
7763 if (o->op_targ == OP_NEXTSTATE
7764 || o->op_targ == OP_DBSTATE
7765 || o->op_targ == OP_SETSTATE)
7767 PL_curcop = ((COP*)o);
7769 /* XXX: We avoid setting op_seq here to prevent later calls
7770 to peep() from mistakenly concluding that optimisation
7771 has already occurred. This doesn't fix the real problem,
7772 though (See 20010220.007). AMS 20010719 */
7773 /* op_seq functionality is now replaced by op_opt */
7774 if (oldop && o->op_next) {
7775 oldop->op_next = o->op_next;
7783 if (oldop && o->op_next) {
7784 oldop->op_next = o->op_next;
7792 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
7793 OP* const pop = (o->op_type == OP_PADAV) ?
7794 o->op_next : o->op_next->op_next;
7796 if (pop && pop->op_type == OP_CONST &&
7797 ((PL_op = pop->op_next)) &&
7798 pop->op_next->op_type == OP_AELEM &&
7799 !(pop->op_next->op_private &
7800 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
7801 (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
7806 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
7807 no_bareword_allowed(pop);
7808 if (o->op_type == OP_GV)
7809 op_null(o->op_next);
7810 op_null(pop->op_next);
7812 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
7813 o->op_next = pop->op_next->op_next;
7814 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
7815 o->op_private = (U8)i;
7816 if (o->op_type == OP_GV) {
7821 o->op_flags |= OPf_SPECIAL;
7822 o->op_type = OP_AELEMFAST;
7828 if (o->op_next->op_type == OP_RV2SV) {
7829 if (!(o->op_next->op_private & OPpDEREF)) {
7830 op_null(o->op_next);
7831 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
7833 o->op_next = o->op_next->op_next;
7834 o->op_type = OP_GVSV;
7835 o->op_ppaddr = PL_ppaddr[OP_GVSV];
7838 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
7839 GV * const gv = cGVOPo_gv;
7840 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
7841 /* XXX could check prototype here instead of just carping */
7842 SV * const sv = sv_newmortal();
7843 gv_efullname3(sv, gv, NULL);
7844 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
7845 "%"SVf"() called too early to check prototype",
7849 else if (o->op_next->op_type == OP_READLINE
7850 && o->op_next->op_next->op_type == OP_CONCAT
7851 && (o->op_next->op_next->op_flags & OPf_STACKED))
7853 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
7854 o->op_type = OP_RCATLINE;
7855 o->op_flags |= OPf_STACKED;
7856 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
7857 op_null(o->op_next->op_next);
7858 op_null(o->op_next);
7875 while (cLOGOP->op_other->op_type == OP_NULL)
7876 cLOGOP->op_other = cLOGOP->op_other->op_next;
7877 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
7883 while (cLOOP->op_redoop->op_type == OP_NULL)
7884 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
7885 peep(cLOOP->op_redoop);
7886 while (cLOOP->op_nextop->op_type == OP_NULL)
7887 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
7888 peep(cLOOP->op_nextop);
7889 while (cLOOP->op_lastop->op_type == OP_NULL)
7890 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
7891 peep(cLOOP->op_lastop);
7898 while (cPMOP->op_pmreplstart &&
7899 cPMOP->op_pmreplstart->op_type == OP_NULL)
7900 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
7901 peep(cPMOP->op_pmreplstart);
7906 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
7907 && ckWARN(WARN_SYNTAX))
7909 if (o->op_next->op_sibling) {
7910 const OPCODE type = o->op_next->op_sibling->op_type;
7911 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
7912 const line_t oldline = CopLINE(PL_curcop);
7913 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
7914 Perl_warner(aTHX_ packWARN(WARN_EXEC),
7915 "Statement unlikely to be reached");
7916 Perl_warner(aTHX_ packWARN(WARN_EXEC),
7917 "\t(Maybe you meant system() when you said exec()?)\n");
7918 CopLINE_set(PL_curcop, oldline);
7929 const char *key = NULL;
7934 if (((BINOP*)o)->op_last->op_type != OP_CONST)
7937 /* Make the CONST have a shared SV */
7938 svp = cSVOPx_svp(((BINOP*)o)->op_last);
7939 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
7940 key = SvPV_const(sv, keylen);
7941 lexname = newSVpvn_share(key,
7942 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
7948 if ((o->op_private & (OPpLVAL_INTRO)))
7951 rop = (UNOP*)((BINOP*)o)->op_first;
7952 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7954 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7955 if (!SvPAD_TYPED(lexname))
7957 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
7958 if (!fields || !GvHV(*fields))
7960 key = SvPV_const(*svp, keylen);
7961 if (!hv_fetch(GvHV(*fields), key,
7962 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
7964 Perl_croak(aTHX_ "No such class field \"%s\" "
7965 "in variable %s of type %s",
7966 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
7979 SVOP *first_key_op, *key_op;
7981 if ((o->op_private & (OPpLVAL_INTRO))
7982 /* I bet there's always a pushmark... */
7983 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
7984 /* hmmm, no optimization if list contains only one key. */
7986 rop = (UNOP*)((LISTOP*)o)->op_last;
7987 if (rop->op_type != OP_RV2HV)
7989 if (rop->op_first->op_type == OP_PADSV)
7990 /* @$hash{qw(keys here)} */
7991 rop = (UNOP*)rop->op_first;
7993 /* @{$hash}{qw(keys here)} */
7994 if (rop->op_first->op_type == OP_SCOPE
7995 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
7997 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
8003 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
8004 if (!SvPAD_TYPED(lexname))
8006 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8007 if (!fields || !GvHV(*fields))
8009 /* Again guessing that the pushmark can be jumped over.... */
8010 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
8011 ->op_first->op_sibling;
8012 for (key_op = first_key_op; key_op;
8013 key_op = (SVOP*)key_op->op_sibling) {
8014 if (key_op->op_type != OP_CONST)
8016 svp = cSVOPx_svp(key_op);
8017 key = SvPV_const(*svp, keylen);
8018 if (!hv_fetch(GvHV(*fields), key,
8019 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8021 Perl_croak(aTHX_ "No such class field \"%s\" "
8022 "in variable %s of type %s",
8023 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
8030 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
8034 /* check that RHS of sort is a single plain array */
8035 OP *oright = cUNOPo->op_first;
8036 if (!oright || oright->op_type != OP_PUSHMARK)
8039 /* reverse sort ... can be optimised. */
8040 if (!cUNOPo->op_sibling) {
8041 /* Nothing follows us on the list. */
8042 OP * const reverse = o->op_next;
8044 if (reverse->op_type == OP_REVERSE &&
8045 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
8046 OP * const pushmark = cUNOPx(reverse)->op_first;
8047 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
8048 && (cUNOPx(pushmark)->op_sibling == o)) {
8049 /* reverse -> pushmark -> sort */
8050 o->op_private |= OPpSORT_REVERSE;
8052 pushmark->op_next = oright->op_next;
8058 /* make @a = sort @a act in-place */
8062 oright = cUNOPx(oright)->op_sibling;
8065 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
8066 oright = cUNOPx(oright)->op_sibling;
8070 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
8071 || oright->op_next != o
8072 || (oright->op_private & OPpLVAL_INTRO)
8076 /* o2 follows the chain of op_nexts through the LHS of the
8077 * assign (if any) to the aassign op itself */
8079 if (!o2 || o2->op_type != OP_NULL)
8082 if (!o2 || o2->op_type != OP_PUSHMARK)
8085 if (o2 && o2->op_type == OP_GV)
8088 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
8089 || (o2->op_private & OPpLVAL_INTRO)
8094 if (!o2 || o2->op_type != OP_NULL)
8097 if (!o2 || o2->op_type != OP_AASSIGN
8098 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
8101 /* check that the sort is the first arg on RHS of assign */
8103 o2 = cUNOPx(o2)->op_first;
8104 if (!o2 || o2->op_type != OP_NULL)
8106 o2 = cUNOPx(o2)->op_first;
8107 if (!o2 || o2->op_type != OP_PUSHMARK)
8109 if (o2->op_sibling != o)
8112 /* check the array is the same on both sides */
8113 if (oleft->op_type == OP_RV2AV) {
8114 if (oright->op_type != OP_RV2AV
8115 || !cUNOPx(oright)->op_first
8116 || cUNOPx(oright)->op_first->op_type != OP_GV
8117 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
8118 cGVOPx_gv(cUNOPx(oright)->op_first)
8122 else if (oright->op_type != OP_PADAV
8123 || oright->op_targ != oleft->op_targ
8127 /* transfer MODishness etc from LHS arg to RHS arg */
8128 oright->op_flags = oleft->op_flags;
8129 o->op_private |= OPpSORT_INPLACE;
8131 /* excise push->gv->rv2av->null->aassign */
8132 o2 = o->op_next->op_next;
8133 op_null(o2); /* PUSHMARK */
8135 if (o2->op_type == OP_GV) {
8136 op_null(o2); /* GV */
8139 op_null(o2); /* RV2AV or PADAV */
8140 o2 = o2->op_next->op_next;
8141 op_null(o2); /* AASSIGN */
8143 o->op_next = o2->op_next;
8149 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
8151 LISTOP *enter, *exlist;
8154 enter = (LISTOP *) o->op_next;
8157 if (enter->op_type == OP_NULL) {
8158 enter = (LISTOP *) enter->op_next;
8162 /* for $a (...) will have OP_GV then OP_RV2GV here.
8163 for (...) just has an OP_GV. */
8164 if (enter->op_type == OP_GV) {
8165 gvop = (OP *) enter;
8166 enter = (LISTOP *) enter->op_next;
8169 if (enter->op_type == OP_RV2GV) {
8170 enter = (LISTOP *) enter->op_next;
8176 if (enter->op_type != OP_ENTERITER)
8179 iter = enter->op_next;
8180 if (!iter || iter->op_type != OP_ITER)
8183 expushmark = enter->op_first;
8184 if (!expushmark || expushmark->op_type != OP_NULL
8185 || expushmark->op_targ != OP_PUSHMARK)
8188 exlist = (LISTOP *) expushmark->op_sibling;
8189 if (!exlist || exlist->op_type != OP_NULL
8190 || exlist->op_targ != OP_LIST)
8193 if (exlist->op_last != o) {
8194 /* Mmm. Was expecting to point back to this op. */
8197 theirmark = exlist->op_first;
8198 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
8201 if (theirmark->op_sibling != o) {
8202 /* There's something between the mark and the reverse, eg
8203 for (1, reverse (...))
8208 ourmark = ((LISTOP *)o)->op_first;
8209 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
8212 ourlast = ((LISTOP *)o)->op_last;
8213 if (!ourlast || ourlast->op_next != o)
8216 rv2av = ourmark->op_sibling;
8217 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
8218 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
8219 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
8220 /* We're just reversing a single array. */
8221 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
8222 enter->op_flags |= OPf_STACKED;
8225 /* We don't have control over who points to theirmark, so sacrifice
8227 theirmark->op_next = ourmark->op_next;
8228 theirmark->op_flags = ourmark->op_flags;
8229 ourlast->op_next = gvop ? gvop : (OP *) enter;
8232 enter->op_private |= OPpITER_REVERSED;
8233 iter->op_private |= OPpITER_REVERSED;
8240 UNOP *refgen, *rv2cv;
8243 /* I do not understand this, but if o->op_opt isn't set to 1,
8244 various tests in ext/B/t/bytecode.t fail with no readily
8250 if ((o->op_flags && OPf_WANT) != OPf_WANT_VOID)
8253 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
8256 rv2gv = ((BINOP *)o)->op_last;
8257 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
8260 refgen = (UNOP *)((BINOP *)o)->op_first;
8262 if (!refgen || refgen->op_type != OP_REFGEN)
8265 exlist = (LISTOP *)refgen->op_first;
8266 if (!exlist || exlist->op_type != OP_NULL
8267 || exlist->op_targ != OP_LIST)
8270 if (exlist->op_first->op_type != OP_PUSHMARK)
8273 rv2cv = (UNOP*)exlist->op_last;
8275 if (rv2cv->op_type != OP_RV2CV)
8278 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
8279 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
8280 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
8282 o->op_private |= OPpASSIGN_CV_TO_GV;
8283 rv2gv->op_private |= OPpDONT_INIT_GV;
8284 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
8300 Perl_custom_op_name(pTHX_ const OP* o)
8303 const IV index = PTR2IV(o->op_ppaddr);
8307 if (!PL_custom_op_names) /* This probably shouldn't happen */
8308 return (char *)PL_op_name[OP_CUSTOM];
8310 keysv = sv_2mortal(newSViv(index));
8312 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
8314 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
8316 return SvPV_nolen(HeVAL(he));
8320 Perl_custom_op_desc(pTHX_ const OP* o)
8323 const IV index = PTR2IV(o->op_ppaddr);
8327 if (!PL_custom_op_descs)
8328 return (char *)PL_op_desc[OP_CUSTOM];
8330 keysv = sv_2mortal(newSViv(index));
8332 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
8334 return (char *)PL_op_desc[OP_CUSTOM];
8336 return SvPV_nolen(HeVAL(he));
8341 /* Efficient sub that returns a constant scalar value. */
8343 const_sv_xsub(pTHX_ CV* cv)
8350 Perl_croak(aTHX_ "usage: %s::%s()",
8351 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
8355 ST(0) = (SV*)XSANY.any_ptr;
8361 * c-indentation-style: bsd
8363 * indent-tabs-mode: t
8366 * ex: set ts=8 sts=4 sw=4 noet: