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 */
2066 CV * const cv = get_cv("DB::postponed", FALSE);
2070 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2072 call_sv((SV*)cv, G_DISCARD);
2079 Perl_localize(pTHX_ OP *o, I32 lex)
2082 if (o->op_flags & OPf_PARENS)
2083 /* [perl #17376]: this appears to be premature, and results in code such as
2084 C< our(%x); > executing in list mode rather than void mode */
2091 if ( PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ','
2092 && ckWARN(WARN_PARENTHESIS))
2094 char *s = PL_bufptr;
2097 /* some heuristics to detect a potential error */
2098 while (*s && (strchr(", \t\n", *s)))
2102 if (*s && strchr("@$%*", *s) && *++s
2103 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2106 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2108 while (*s && (strchr(", \t\n", *s)))
2114 if (sigil && (*s == ';' || *s == '=')) {
2115 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2116 "Parentheses missing around \"%s\" list",
2117 lex ? (PL_in_my == KEY_our ? "our" : PL_in_my == KEY_state ? "state" : "my")
2125 o = mod(o, OP_NULL); /* a bit kludgey */
2127 PL_in_my_stash = NULL;
2132 Perl_jmaybe(pTHX_ OP *o)
2134 if (o->op_type == OP_LIST) {
2136 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2137 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2143 Perl_fold_constants(pTHX_ register OP *o)
2148 VOL I32 type = o->op_type;
2153 SV * const oldwarnhook = PL_warnhook;
2154 SV * const olddiehook = PL_diehook;
2157 if (PL_opargs[type] & OA_RETSCALAR)
2159 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2160 o->op_targ = pad_alloc(type, SVs_PADTMP);
2162 /* integerize op, unless it happens to be C<-foo>.
2163 * XXX should pp_i_negate() do magic string negation instead? */
2164 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2165 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2166 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2168 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2171 if (!(PL_opargs[type] & OA_FOLDCONST))
2176 /* XXX might want a ck_negate() for this */
2177 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2188 /* XXX what about the numeric ops? */
2189 if (PL_hints & HINT_LOCALE)
2194 goto nope; /* Don't try to run w/ errors */
2196 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2197 const OPCODE type = curop->op_type;
2198 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2200 type != OP_SCALAR &&
2202 type != OP_PUSHMARK)
2208 curop = LINKLIST(o);
2209 old_next = o->op_next;
2213 oldscope = PL_scopestack_ix;
2214 create_eval_scope(G_FAKINGEVAL);
2216 PL_warnhook = PERL_WARNHOOK_FATAL;
2223 sv = *(PL_stack_sp--);
2224 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2225 pad_swipe(o->op_targ, FALSE);
2226 else if (SvTEMP(sv)) { /* grab mortal temp? */
2227 SvREFCNT_inc_simple_void(sv);
2232 /* Something tried to die. Abandon constant folding. */
2233 /* Pretend the error never happened. */
2234 sv_setpvn(ERRSV,"",0);
2235 o->op_next = old_next;
2239 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
2240 PL_warnhook = oldwarnhook;
2241 PL_diehook = olddiehook;
2242 /* XXX note that this croak may fail as we've already blown away
2243 * the stack - eg any nested evals */
2244 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
2247 PL_warnhook = oldwarnhook;
2248 PL_diehook = olddiehook;
2250 if (PL_scopestack_ix > oldscope)
2251 delete_eval_scope();
2260 if (type == OP_RV2GV)
2261 newop = newGVOP(OP_GV, 0, (GV*)sv);
2263 newop = newSVOP(OP_CONST, 0, (SV*)sv);
2264 op_getmad(o,newop,'f');
2272 Perl_gen_constant_list(pTHX_ register OP *o)
2276 const I32 oldtmps_floor = PL_tmps_floor;
2280 return o; /* Don't attempt to run with errors */
2282 PL_op = curop = LINKLIST(o);
2288 assert (!(curop->op_flags & OPf_SPECIAL));
2289 assert(curop->op_type == OP_RANGE);
2291 PL_tmps_floor = oldtmps_floor;
2293 o->op_type = OP_RV2AV;
2294 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2295 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2296 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2297 o->op_opt = 0; /* needs to be revisited in peep() */
2298 curop = ((UNOP*)o)->op_first;
2299 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
2301 op_getmad(curop,o,'O');
2310 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2313 if (!o || o->op_type != OP_LIST)
2314 o = newLISTOP(OP_LIST, 0, o, NULL);
2316 o->op_flags &= ~OPf_WANT;
2318 if (!(PL_opargs[type] & OA_MARK))
2319 op_null(cLISTOPo->op_first);
2321 o->op_type = (OPCODE)type;
2322 o->op_ppaddr = PL_ppaddr[type];
2323 o->op_flags |= flags;
2325 o = CHECKOP(type, o);
2326 if (o->op_type != (unsigned)type)
2329 return fold_constants(o);
2332 /* List constructors */
2335 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2343 if (first->op_type != (unsigned)type
2344 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2346 return newLISTOP(type, 0, first, last);
2349 if (first->op_flags & OPf_KIDS)
2350 ((LISTOP*)first)->op_last->op_sibling = last;
2352 first->op_flags |= OPf_KIDS;
2353 ((LISTOP*)first)->op_first = last;
2355 ((LISTOP*)first)->op_last = last;
2360 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2368 if (first->op_type != (unsigned)type)
2369 return prepend_elem(type, (OP*)first, (OP*)last);
2371 if (last->op_type != (unsigned)type)
2372 return append_elem(type, (OP*)first, (OP*)last);
2374 first->op_last->op_sibling = last->op_first;
2375 first->op_last = last->op_last;
2376 first->op_flags |= (last->op_flags & OPf_KIDS);
2379 if (last->op_first && first->op_madprop) {
2380 MADPROP *mp = last->op_first->op_madprop;
2382 while (mp->mad_next)
2384 mp->mad_next = first->op_madprop;
2387 last->op_first->op_madprop = first->op_madprop;
2390 first->op_madprop = last->op_madprop;
2391 last->op_madprop = 0;
2394 S_op_destroy(aTHX_ (OP*)last);
2400 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2408 if (last->op_type == (unsigned)type) {
2409 if (type == OP_LIST) { /* already a PUSHMARK there */
2410 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2411 ((LISTOP*)last)->op_first->op_sibling = first;
2412 if (!(first->op_flags & OPf_PARENS))
2413 last->op_flags &= ~OPf_PARENS;
2416 if (!(last->op_flags & OPf_KIDS)) {
2417 ((LISTOP*)last)->op_last = first;
2418 last->op_flags |= OPf_KIDS;
2420 first->op_sibling = ((LISTOP*)last)->op_first;
2421 ((LISTOP*)last)->op_first = first;
2423 last->op_flags |= OPf_KIDS;
2427 return newLISTOP(type, 0, first, last);
2435 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2438 Newxz(tk, 1, TOKEN);
2439 tk->tk_type = (OPCODE)optype;
2440 tk->tk_type = 12345;
2442 tk->tk_mad = madprop;
2447 Perl_token_free(pTHX_ TOKEN* tk)
2449 if (tk->tk_type != 12345)
2451 mad_free(tk->tk_mad);
2456 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2460 if (tk->tk_type != 12345) {
2461 Perl_warner(aTHX_ packWARN(WARN_MISC),
2462 "Invalid TOKEN object ignored");
2469 /* faked up qw list? */
2471 tm->mad_type == MAD_SV &&
2472 SvPVX((SV*)tm->mad_val)[0] == 'q')
2479 /* pretend constant fold didn't happen? */
2480 if (mp->mad_key == 'f' &&
2481 (o->op_type == OP_CONST ||
2482 o->op_type == OP_GV) )
2484 token_getmad(tk,(OP*)mp->mad_val,slot);
2498 if (mp->mad_key == 'X')
2499 mp->mad_key = slot; /* just change the first one */
2509 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
2518 /* pretend constant fold didn't happen? */
2519 if (mp->mad_key == 'f' &&
2520 (o->op_type == OP_CONST ||
2521 o->op_type == OP_GV) )
2523 op_getmad(from,(OP*)mp->mad_val,slot);
2530 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
2533 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
2539 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
2548 /* pretend constant fold didn't happen? */
2549 if (mp->mad_key == 'f' &&
2550 (o->op_type == OP_CONST ||
2551 o->op_type == OP_GV) )
2553 op_getmad(from,(OP*)mp->mad_val,slot);
2560 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
2563 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
2567 PerlIO_printf(PerlIO_stderr(),
2568 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
2574 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
2592 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
2596 addmad(tm, &(o->op_madprop), slot);
2600 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
2621 Perl_newMADsv(pTHX_ char key, SV* sv)
2623 return newMADPROP(key, MAD_SV, sv, 0);
2627 Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
2630 Newxz(mp, 1, MADPROP);
2633 mp->mad_vlen = vlen;
2634 mp->mad_type = type;
2636 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
2641 Perl_mad_free(pTHX_ MADPROP* mp)
2643 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
2647 mad_free(mp->mad_next);
2648 /* if (PL_lex_state != LEX_NOTPARSING && mp->mad_vlen)
2649 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
2650 switch (mp->mad_type) {
2654 Safefree((char*)mp->mad_val);
2657 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
2658 op_free((OP*)mp->mad_val);
2661 sv_free((SV*)mp->mad_val);
2664 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
2673 Perl_newNULLLIST(pTHX)
2675 return newOP(OP_STUB, 0);
2679 Perl_force_list(pTHX_ OP *o)
2681 if (!o || o->op_type != OP_LIST)
2682 o = newLISTOP(OP_LIST, 0, o, NULL);
2688 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2693 NewOp(1101, listop, 1, LISTOP);
2695 listop->op_type = (OPCODE)type;
2696 listop->op_ppaddr = PL_ppaddr[type];
2699 listop->op_flags = (U8)flags;
2703 else if (!first && last)
2706 first->op_sibling = last;
2707 listop->op_first = first;
2708 listop->op_last = last;
2709 if (type == OP_LIST) {
2710 OP* const pushop = newOP(OP_PUSHMARK, 0);
2711 pushop->op_sibling = first;
2712 listop->op_first = pushop;
2713 listop->op_flags |= OPf_KIDS;
2715 listop->op_last = pushop;
2718 return CHECKOP(type, listop);
2722 Perl_newOP(pTHX_ I32 type, I32 flags)
2726 NewOp(1101, o, 1, OP);
2727 o->op_type = (OPCODE)type;
2728 o->op_ppaddr = PL_ppaddr[type];
2729 o->op_flags = (U8)flags;
2731 o->op_latefreed = 0;
2735 o->op_private = (U8)(0 | (flags >> 8));
2736 if (PL_opargs[type] & OA_RETSCALAR)
2738 if (PL_opargs[type] & OA_TARGET)
2739 o->op_targ = pad_alloc(type, SVs_PADTMP);
2740 return CHECKOP(type, o);
2744 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2750 first = newOP(OP_STUB, 0);
2751 if (PL_opargs[type] & OA_MARK)
2752 first = force_list(first);
2754 NewOp(1101, unop, 1, UNOP);
2755 unop->op_type = (OPCODE)type;
2756 unop->op_ppaddr = PL_ppaddr[type];
2757 unop->op_first = first;
2758 unop->op_flags = (U8)(flags | OPf_KIDS);
2759 unop->op_private = (U8)(1 | (flags >> 8));
2760 unop = (UNOP*) CHECKOP(type, unop);
2764 return fold_constants((OP *) unop);
2768 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2772 NewOp(1101, binop, 1, BINOP);
2775 first = newOP(OP_NULL, 0);
2777 binop->op_type = (OPCODE)type;
2778 binop->op_ppaddr = PL_ppaddr[type];
2779 binop->op_first = first;
2780 binop->op_flags = (U8)(flags | OPf_KIDS);
2783 binop->op_private = (U8)(1 | (flags >> 8));
2786 binop->op_private = (U8)(2 | (flags >> 8));
2787 first->op_sibling = last;
2790 binop = (BINOP*)CHECKOP(type, binop);
2791 if (binop->op_next || binop->op_type != (OPCODE)type)
2794 binop->op_last = binop->op_first->op_sibling;
2796 return fold_constants((OP *)binop);
2799 static int uvcompare(const void *a, const void *b)
2800 __attribute__nonnull__(1)
2801 __attribute__nonnull__(2)
2802 __attribute__pure__;
2803 static int uvcompare(const void *a, const void *b)
2805 if (*((const UV *)a) < (*(const UV *)b))
2807 if (*((const UV *)a) > (*(const UV *)b))
2809 if (*((const UV *)a+1) < (*(const UV *)b+1))
2811 if (*((const UV *)a+1) > (*(const UV *)b+1))
2817 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2820 SV * const tstr = ((SVOP*)expr)->op_sv;
2823 (repl->op_type == OP_NULL)
2824 ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
2826 ((SVOP*)repl)->op_sv;
2829 const U8 *t = (U8*)SvPV_const(tstr, tlen);
2830 const U8 *r = (U8*)SvPV_const(rstr, rlen);
2834 register short *tbl;
2836 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
2837 const I32 squash = o->op_private & OPpTRANS_SQUASH;
2838 I32 del = o->op_private & OPpTRANS_DELETE;
2840 PL_hints |= HINT_BLOCK_SCOPE;
2843 o->op_private |= OPpTRANS_FROM_UTF;
2846 o->op_private |= OPpTRANS_TO_UTF;
2848 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2849 SV* const listsv = newSVpvs("# comment\n");
2851 const U8* tend = t + tlen;
2852 const U8* rend = r + rlen;
2866 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2867 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2870 const U32 flags = UTF8_ALLOW_DEFAULT;
2874 t = tsave = bytes_to_utf8(t, &len);
2877 if (!to_utf && rlen) {
2879 r = rsave = bytes_to_utf8(r, &len);
2883 /* There are several snags with this code on EBCDIC:
2884 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2885 2. scan_const() in toke.c has encoded chars in native encoding which makes
2886 ranges at least in EBCDIC 0..255 range the bottom odd.
2890 U8 tmpbuf[UTF8_MAXBYTES+1];
2893 Newx(cp, 2*tlen, UV);
2895 transv = newSVpvs("");
2897 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
2899 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2901 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
2905 cp[2*i+1] = cp[2*i];
2909 qsort(cp, i, 2*sizeof(UV), uvcompare);
2910 for (j = 0; j < i; j++) {
2912 diff = val - nextmin;
2914 t = uvuni_to_utf8(tmpbuf,nextmin);
2915 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2917 U8 range_mark = UTF_TO_NATIVE(0xff);
2918 t = uvuni_to_utf8(tmpbuf, val - 1);
2919 sv_catpvn(transv, (char *)&range_mark, 1);
2920 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2927 t = uvuni_to_utf8(tmpbuf,nextmin);
2928 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2930 U8 range_mark = UTF_TO_NATIVE(0xff);
2931 sv_catpvn(transv, (char *)&range_mark, 1);
2933 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2934 UNICODE_ALLOW_SUPER);
2935 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2936 t = (const U8*)SvPVX_const(transv);
2937 tlen = SvCUR(transv);
2941 else if (!rlen && !del) {
2942 r = t; rlen = tlen; rend = tend;
2945 if ((!rlen && !del) || t == r ||
2946 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2948 o->op_private |= OPpTRANS_IDENTICAL;
2952 while (t < tend || tfirst <= tlast) {
2953 /* see if we need more "t" chars */
2954 if (tfirst > tlast) {
2955 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
2957 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
2959 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
2966 /* now see if we need more "r" chars */
2967 if (rfirst > rlast) {
2969 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
2971 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
2973 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
2982 rfirst = rlast = 0xffffffff;
2986 /* now see which range will peter our first, if either. */
2987 tdiff = tlast - tfirst;
2988 rdiff = rlast - rfirst;
2995 if (rfirst == 0xffffffff) {
2996 diff = tdiff; /* oops, pretend rdiff is infinite */
2998 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2999 (long)tfirst, (long)tlast);
3001 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
3005 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
3006 (long)tfirst, (long)(tfirst + diff),
3009 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3010 (long)tfirst, (long)rfirst);
3012 if (rfirst + diff > max)
3013 max = rfirst + diff;
3015 grows = (tfirst < rfirst &&
3016 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3028 else if (max > 0xff)
3033 PerlMemShared_free(cPVOPo->op_pv);
3034 cPVOPo->op_pv = NULL;
3036 swash = (SV*)swash_init("utf8", "", listsv, bits, none);
3038 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
3039 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
3040 PAD_SETSV(cPADOPo->op_padix, swash);
3043 cSVOPo->op_sv = swash;
3045 SvREFCNT_dec(listsv);
3046 SvREFCNT_dec(transv);
3048 if (!del && havefinal && rlen)
3049 (void)hv_store((HV*)SvRV(swash), "FINAL", 5,
3050 newSVuv((UV)final), 0);
3053 o->op_private |= OPpTRANS_GROWS;
3059 op_getmad(expr,o,'e');
3060 op_getmad(repl,o,'r');
3068 tbl = (short*)cPVOPo->op_pv;
3070 Zero(tbl, 256, short);
3071 for (i = 0; i < (I32)tlen; i++)
3073 for (i = 0, j = 0; i < 256; i++) {
3075 if (j >= (I32)rlen) {
3084 if (i < 128 && r[j] >= 128)
3094 o->op_private |= OPpTRANS_IDENTICAL;
3096 else if (j >= (I32)rlen)
3099 tbl = PerlMemShared_realloc(tbl,
3100 (0x101+rlen-j) * sizeof(short));
3101 cPVOPo->op_pv = (char*)tbl;
3103 tbl[0x100] = (short)(rlen - j);
3104 for (i=0; i < (I32)rlen - j; i++)
3105 tbl[0x101+i] = r[j+i];
3109 if (!rlen && !del) {
3112 o->op_private |= OPpTRANS_IDENTICAL;
3114 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3115 o->op_private |= OPpTRANS_IDENTICAL;
3117 for (i = 0; i < 256; i++)
3119 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3120 if (j >= (I32)rlen) {
3122 if (tbl[t[i]] == -1)
3128 if (tbl[t[i]] == -1) {
3129 if (t[i] < 128 && r[j] >= 128)
3136 o->op_private |= OPpTRANS_GROWS;
3138 op_getmad(expr,o,'e');
3139 op_getmad(repl,o,'r');
3149 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3154 NewOp(1101, pmop, 1, PMOP);
3155 pmop->op_type = (OPCODE)type;
3156 pmop->op_ppaddr = PL_ppaddr[type];
3157 pmop->op_flags = (U8)flags;
3158 pmop->op_private = (U8)(0 | (flags >> 8));
3160 if (PL_hints & HINT_RE_TAINT)
3161 pmop->op_pmpermflags |= PMf_RETAINT;
3162 if (PL_hints & HINT_LOCALE)
3163 pmop->op_pmpermflags |= PMf_LOCALE;
3164 pmop->op_pmflags = pmop->op_pmpermflags;
3167 if (av_len((AV*) PL_regex_pad[0]) > -1) {
3168 SV * const repointer = av_pop((AV*)PL_regex_pad[0]);
3169 pmop->op_pmoffset = SvIV(repointer);
3170 SvREPADTMP_off(repointer);
3171 sv_setiv(repointer,0);
3173 SV * const repointer = newSViv(0);
3174 av_push(PL_regex_padav, SvREFCNT_inc_simple_NN(repointer));
3175 pmop->op_pmoffset = av_len(PL_regex_padav);
3176 PL_regex_pad = AvARRAY(PL_regex_padav);
3180 /* link into pm list */
3181 if (type != OP_TRANS && PL_curstash) {
3182 MAGIC *mg = mg_find((SV*)PL_curstash, PERL_MAGIC_symtab);
3185 mg = sv_magicext((SV*)PL_curstash, 0, PERL_MAGIC_symtab, 0, 0, 0);
3187 pmop->op_pmnext = (PMOP*)mg->mg_obj;
3188 mg->mg_obj = (SV*)pmop;
3189 PmopSTASH_set(pmop,PL_curstash);
3192 return CHECKOP(type, pmop);
3195 /* Given some sort of match op o, and an expression expr containing a
3196 * pattern, either compile expr into a regex and attach it to o (if it's
3197 * constant), or convert expr into a runtime regcomp op sequence (if it's
3200 * isreg indicates that the pattern is part of a regex construct, eg
3201 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3202 * split "pattern", which aren't. In the former case, expr will be a list
3203 * if the pattern contains more than one term (eg /a$b/) or if it contains
3204 * a replacement, ie s/// or tr///.
3208 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
3213 I32 repl_has_vars = 0;
3217 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
3218 /* last element in list is the replacement; pop it */
3220 repl = cLISTOPx(expr)->op_last;
3221 kid = cLISTOPx(expr)->op_first;
3222 while (kid->op_sibling != repl)
3223 kid = kid->op_sibling;
3224 kid->op_sibling = NULL;
3225 cLISTOPx(expr)->op_last = kid;
3228 if (isreg && expr->op_type == OP_LIST &&
3229 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3231 /* convert single element list to element */
3232 OP* const oe = expr;
3233 expr = cLISTOPx(oe)->op_first->op_sibling;
3234 cLISTOPx(oe)->op_first->op_sibling = NULL;
3235 cLISTOPx(oe)->op_last = NULL;
3239 if (o->op_type == OP_TRANS) {
3240 return pmtrans(o, expr, repl);
3243 reglist = isreg && expr->op_type == OP_LIST;
3247 PL_hints |= HINT_BLOCK_SCOPE;
3250 if (expr->op_type == OP_CONST) {
3252 SV * const pat = ((SVOP*)expr)->op_sv;
3253 const char *p = SvPV_const(pat, plen);
3254 if ((o->op_flags & OPf_SPECIAL) && (*p == ' ' && p[1] == '\0')) {
3255 U32 was_readonly = SvREADONLY(pat);
3259 sv_force_normal_flags(pat, 0);
3260 assert(!SvREADONLY(pat));
3263 SvREADONLY_off(pat);
3267 sv_setpvn(pat, "\\s+", 3);
3269 SvFLAGS(pat) |= was_readonly;
3271 p = SvPV_const(pat, plen);
3272 pm->op_pmflags |= PMf_SKIPWHITE;
3275 pm->op_pmdynflags |= PMdf_UTF8;
3276 /* FIXME - can we make this function take const char * args? */
3277 PM_SETRE(pm, CALLREGCOMP((char*)p, (char*)p + plen, pm));
3278 if (PM_GETRE(pm)->extflags & RXf_WHITE)
3279 pm->op_pmflags |= PMf_WHITE;
3281 pm->op_pmflags &= ~PMf_WHITE;
3283 op_getmad(expr,(OP*)pm,'e');
3289 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3290 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3292 : OP_REGCMAYBE),0,expr);
3294 NewOp(1101, rcop, 1, LOGOP);
3295 rcop->op_type = OP_REGCOMP;
3296 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3297 rcop->op_first = scalar(expr);
3298 rcop->op_flags |= OPf_KIDS
3299 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3300 | (reglist ? OPf_STACKED : 0);
3301 rcop->op_private = 1;
3304 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3306 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
3309 /* establish postfix order */
3310 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3312 rcop->op_next = expr;
3313 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3316 rcop->op_next = LINKLIST(expr);
3317 expr->op_next = (OP*)rcop;
3320 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3325 if (pm->op_pmflags & PMf_EVAL) {
3327 if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
3328 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
3330 else if (repl->op_type == OP_CONST)
3334 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3335 if (curop->op_type == OP_SCOPE
3336 || curop->op_type == OP_LEAVE
3337 || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
3338 if (curop->op_type == OP_GV) {
3339 GV * const gv = cGVOPx_gv(curop);
3341 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3344 else if (curop->op_type == OP_RV2CV)
3346 else if (curop->op_type == OP_RV2SV ||
3347 curop->op_type == OP_RV2AV ||
3348 curop->op_type == OP_RV2HV ||
3349 curop->op_type == OP_RV2GV) {
3350 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3353 else if (curop->op_type == OP_PADSV ||
3354 curop->op_type == OP_PADAV ||
3355 curop->op_type == OP_PADHV ||
3356 curop->op_type == OP_PADANY)
3360 else if (curop->op_type == OP_PUSHRE)
3361 NOOP; /* Okay here, dangerous in newASSIGNOP */
3371 || PM_GETRE(pm)->extflags & RXf_EVAL_SEEN)))
3373 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3374 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
3375 prepend_elem(o->op_type, scalar(repl), o);
3378 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3379 pm->op_pmflags |= PMf_MAYBE_CONST;
3380 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3382 NewOp(1101, rcop, 1, LOGOP);
3383 rcop->op_type = OP_SUBSTCONT;
3384 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3385 rcop->op_first = scalar(repl);
3386 rcop->op_flags |= OPf_KIDS;
3387 rcop->op_private = 1;
3390 /* establish postfix order */
3391 rcop->op_next = LINKLIST(repl);
3392 repl->op_next = (OP*)rcop;
3394 pm->op_pmreplroot = scalar((OP*)rcop);
3395 pm->op_pmreplstart = LINKLIST(rcop);
3404 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3408 NewOp(1101, svop, 1, SVOP);
3409 svop->op_type = (OPCODE)type;
3410 svop->op_ppaddr = PL_ppaddr[type];
3412 svop->op_next = (OP*)svop;
3413 svop->op_flags = (U8)flags;
3414 if (PL_opargs[type] & OA_RETSCALAR)
3416 if (PL_opargs[type] & OA_TARGET)
3417 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3418 return CHECKOP(type, svop);
3422 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3426 NewOp(1101, padop, 1, PADOP);
3427 padop->op_type = (OPCODE)type;
3428 padop->op_ppaddr = PL_ppaddr[type];
3429 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3430 SvREFCNT_dec(PAD_SVl(padop->op_padix));
3431 PAD_SETSV(padop->op_padix, sv);
3434 padop->op_next = (OP*)padop;
3435 padop->op_flags = (U8)flags;
3436 if (PL_opargs[type] & OA_RETSCALAR)
3438 if (PL_opargs[type] & OA_TARGET)
3439 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3440 return CHECKOP(type, padop);
3444 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3450 return newPADOP(type, flags, SvREFCNT_inc_simple(gv));
3452 return newSVOP(type, flags, SvREFCNT_inc_simple(gv));
3457 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3461 NewOp(1101, pvop, 1, PVOP);
3462 pvop->op_type = (OPCODE)type;
3463 pvop->op_ppaddr = PL_ppaddr[type];
3465 pvop->op_next = (OP*)pvop;
3466 pvop->op_flags = (U8)flags;
3467 if (PL_opargs[type] & OA_RETSCALAR)
3469 if (PL_opargs[type] & OA_TARGET)
3470 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3471 return CHECKOP(type, pvop);
3479 Perl_package(pTHX_ OP *o)
3488 save_hptr(&PL_curstash);
3489 save_item(PL_curstname);
3491 name = SvPV_const(cSVOPo->op_sv, len);
3492 PL_curstash = gv_stashpvn(name, len, TRUE);
3493 sv_setpvn(PL_curstname, name, len);
3495 PL_hints |= HINT_BLOCK_SCOPE;
3496 PL_copline = NOLINE;
3502 if (!PL_madskills) {
3507 pegop = newOP(OP_NULL,0);
3508 op_getmad(o,pegop,'P');
3518 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3525 OP *pegop = newOP(OP_NULL,0);
3528 if (idop->op_type != OP_CONST)
3529 Perl_croak(aTHX_ "Module name must be constant");
3532 op_getmad(idop,pegop,'U');
3537 SV * const vesv = ((SVOP*)version)->op_sv;
3540 op_getmad(version,pegop,'V');
3541 if (!arg && !SvNIOKp(vesv)) {
3548 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3549 Perl_croak(aTHX_ "Version number must be constant number");
3551 /* Make copy of idop so we don't free it twice */
3552 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3554 /* Fake up a method call to VERSION */
3555 meth = newSVpvs_share("VERSION");
3556 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3557 append_elem(OP_LIST,
3558 prepend_elem(OP_LIST, pack, list(version)),
3559 newSVOP(OP_METHOD_NAMED, 0, meth)));
3563 /* Fake up an import/unimport */
3564 if (arg && arg->op_type == OP_STUB) {
3566 op_getmad(arg,pegop,'S');
3567 imop = arg; /* no import on explicit () */
3569 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3570 imop = NULL; /* use 5.0; */
3572 idop->op_private |= OPpCONST_NOVER;
3578 op_getmad(arg,pegop,'A');
3580 /* Make copy of idop so we don't free it twice */
3581 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3583 /* Fake up a method call to import/unimport */
3585 ? newSVpvs_share("import") : newSVpvs_share("unimport");
3586 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3587 append_elem(OP_LIST,
3588 prepend_elem(OP_LIST, pack, list(arg)),
3589 newSVOP(OP_METHOD_NAMED, 0, meth)));
3592 /* Fake up the BEGIN {}, which does its thing immediately. */
3594 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
3597 append_elem(OP_LINESEQ,
3598 append_elem(OP_LINESEQ,
3599 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
3600 newSTATEOP(0, NULL, veop)),
3601 newSTATEOP(0, NULL, imop) ));
3603 /* The "did you use incorrect case?" warning used to be here.
3604 * The problem is that on case-insensitive filesystems one
3605 * might get false positives for "use" (and "require"):
3606 * "use Strict" or "require CARP" will work. This causes
3607 * portability problems for the script: in case-strict
3608 * filesystems the script will stop working.
3610 * The "incorrect case" warning checked whether "use Foo"
3611 * imported "Foo" to your namespace, but that is wrong, too:
3612 * there is no requirement nor promise in the language that
3613 * a Foo.pm should or would contain anything in package "Foo".
3615 * There is very little Configure-wise that can be done, either:
3616 * the case-sensitivity of the build filesystem of Perl does not
3617 * help in guessing the case-sensitivity of the runtime environment.
3620 PL_hints |= HINT_BLOCK_SCOPE;
3621 PL_copline = NOLINE;
3623 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3626 if (!PL_madskills) {
3627 /* FIXME - don't allocate pegop if !PL_madskills */
3636 =head1 Embedding Functions
3638 =for apidoc load_module
3640 Loads the module whose name is pointed to by the string part of name.
3641 Note that the actual module name, not its filename, should be given.
3642 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3643 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3644 (or 0 for no flags). ver, if specified, provides version semantics
3645 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3646 arguments can be used to specify arguments to the module's import()
3647 method, similar to C<use Foo::Bar VERSION LIST>.
3652 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3655 va_start(args, ver);
3656 vload_module(flags, name, ver, &args);
3660 #ifdef PERL_IMPLICIT_CONTEXT
3662 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3666 va_start(args, ver);
3667 vload_module(flags, name, ver, &args);
3673 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3678 OP * const modname = newSVOP(OP_CONST, 0, name);
3679 modname->op_private |= OPpCONST_BARE;
3681 veop = newSVOP(OP_CONST, 0, ver);
3685 if (flags & PERL_LOADMOD_NOIMPORT) {
3686 imop = sawparens(newNULLLIST());
3688 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3689 imop = va_arg(*args, OP*);
3694 sv = va_arg(*args, SV*);
3696 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3697 sv = va_arg(*args, SV*);
3701 const line_t ocopline = PL_copline;
3702 COP * const ocurcop = PL_curcop;
3703 const int oexpect = PL_expect;
3705 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3706 veop, modname, imop);
3707 PL_expect = oexpect;
3708 PL_copline = ocopline;
3709 PL_curcop = ocurcop;
3714 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
3720 if (!force_builtin) {
3721 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
3722 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
3723 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
3724 gv = gvp ? *gvp : NULL;
3728 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3729 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3730 append_elem(OP_LIST, term,
3731 scalar(newUNOP(OP_RV2CV, 0,
3732 newGVOP(OP_GV, 0, gv))))));
3735 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3741 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3743 return newBINOP(OP_LSLICE, flags,
3744 list(force_list(subscript)),
3745 list(force_list(listval)) );
3749 S_is_list_assignment(pTHX_ register const OP *o)
3757 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
3758 o = cUNOPo->op_first;
3760 flags = o->op_flags;
3762 if (type == OP_COND_EXPR) {
3763 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
3764 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3769 yyerror("Assignment to both a list and a scalar");
3773 if (type == OP_LIST &&
3774 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
3775 o->op_private & OPpLVAL_INTRO)
3778 if (type == OP_LIST || flags & OPf_PARENS ||
3779 type == OP_RV2AV || type == OP_RV2HV ||
3780 type == OP_ASLICE || type == OP_HSLICE)
3783 if (type == OP_PADAV || type == OP_PADHV)
3786 if (type == OP_RV2SV)
3793 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3799 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3800 return newLOGOP(optype, 0,
3801 mod(scalar(left), optype),
3802 newUNOP(OP_SASSIGN, 0, scalar(right)));
3805 return newBINOP(optype, OPf_STACKED,
3806 mod(scalar(left), optype), scalar(right));
3810 if (is_list_assignment(left)) {
3814 /* Grandfathering $[ assignment here. Bletch.*/
3815 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
3816 PL_eval_start = (left->op_type == OP_CONST) ? right : 0;
3817 left = mod(left, OP_AASSIGN);
3820 else if (left->op_type == OP_CONST) {
3822 /* Result of assignment is always 1 (or we'd be dead already) */
3823 return newSVOP(OP_CONST, 0, newSViv(1));
3825 curop = list(force_list(left));
3826 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3827 o->op_private = (U8)(0 | (flags >> 8));
3829 /* PL_generation sorcery:
3830 * an assignment like ($a,$b) = ($c,$d) is easier than
3831 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3832 * To detect whether there are common vars, the global var
3833 * PL_generation is incremented for each assign op we compile.
3834 * Then, while compiling the assign op, we run through all the
3835 * variables on both sides of the assignment, setting a spare slot
3836 * in each of them to PL_generation. If any of them already have
3837 * that value, we know we've got commonality. We could use a
3838 * single bit marker, but then we'd have to make 2 passes, first
3839 * to clear the flag, then to test and set it. To find somewhere
3840 * to store these values, evil chicanery is done with SvUVX().
3846 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3847 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3848 if (curop->op_type == OP_GV) {
3849 GV *gv = cGVOPx_gv(curop);
3851 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
3853 GvASSIGN_GENERATION_set(gv, PL_generation);
3855 else if (curop->op_type == OP_PADSV ||
3856 curop->op_type == OP_PADAV ||
3857 curop->op_type == OP_PADHV ||
3858 curop->op_type == OP_PADANY)
3860 if (PAD_COMPNAME_GEN(curop->op_targ)
3861 == (STRLEN)PL_generation)
3863 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
3866 else if (curop->op_type == OP_RV2CV)
3868 else if (curop->op_type == OP_RV2SV ||
3869 curop->op_type == OP_RV2AV ||
3870 curop->op_type == OP_RV2HV ||
3871 curop->op_type == OP_RV2GV) {
3872 if (lastop->op_type != OP_GV) /* funny deref? */
3875 else if (curop->op_type == OP_PUSHRE) {
3876 if (((PMOP*)curop)->op_pmreplroot) {
3878 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3879 ((PMOP*)curop)->op_pmreplroot));
3881 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3884 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
3886 GvASSIGN_GENERATION_set(gv, PL_generation);
3887 GvASSIGN_GENERATION_set(gv, PL_generation);
3896 o->op_private |= OPpASSIGN_COMMON;
3899 if ( ((left->op_private & OPpLVAL_INTRO) || ckWARN(WARN_MISC))
3900 && (left->op_type == OP_LIST
3901 || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
3903 OP* lop = ((LISTOP*)left)->op_first;
3905 if (lop->op_type == OP_PADSV ||
3906 lop->op_type == OP_PADAV ||
3907 lop->op_type == OP_PADHV ||
3908 lop->op_type == OP_PADANY)
3910 if (lop->op_private & OPpPAD_STATE) {
3911 if (left->op_private & OPpLVAL_INTRO) {
3912 o->op_private |= OPpASSIGN_STATE;
3913 /* hijacking PADSTALE for uninitialized state variables */
3914 SvPADSTALE_on(PAD_SVl(lop->op_targ));
3916 else { /* we already checked for WARN_MISC before */
3917 Perl_warner(aTHX_ packWARN(WARN_MISC), "State variable %s will be reinitialized",
3918 PAD_COMPNAME_PV(lop->op_targ));
3922 lop = lop->op_sibling;
3926 if (right && right->op_type == OP_SPLIT) {
3927 OP* tmpop = ((LISTOP*)right)->op_first;
3928 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
3929 PMOP * const pm = (PMOP*)tmpop;
3930 if (left->op_type == OP_RV2AV &&
3931 !(left->op_private & OPpLVAL_INTRO) &&
3932 !(o->op_private & OPpASSIGN_COMMON) )
3934 tmpop = ((UNOP*)left)->op_first;
3935 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3937 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3938 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3940 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3941 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
3943 pm->op_pmflags |= PMf_ONCE;
3944 tmpop = cUNOPo->op_first; /* to list (nulled) */
3945 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3946 tmpop->op_sibling = NULL; /* don't free split */
3947 right->op_next = tmpop->op_next; /* fix starting loc */
3949 op_getmad(o,right,'R'); /* blow off assign */
3951 op_free(o); /* blow off assign */
3953 right->op_flags &= ~OPf_WANT;
3954 /* "I don't know and I don't care." */
3959 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3960 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3962 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3964 sv_setiv(sv, PL_modcount+1);
3972 right = newOP(OP_UNDEF, 0);
3973 if (right->op_type == OP_READLINE) {
3974 right->op_flags |= OPf_STACKED;
3975 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3978 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3979 o = newBINOP(OP_SASSIGN, flags,
3980 scalar(right), mod(scalar(left), OP_SASSIGN) );
3986 o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
3987 o->op_private |= OPpCONST_ARYBASE;
3994 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3997 const U32 seq = intro_my();
4000 NewOp(1101, cop, 1, COP);
4001 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
4002 cop->op_type = OP_DBSTATE;
4003 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
4006 cop->op_type = OP_NEXTSTATE;
4007 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
4009 cop->op_flags = (U8)flags;
4010 CopHINTS_set(cop, PL_hints);
4012 cop->op_private |= NATIVE_HINTS;
4014 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
4015 cop->op_next = (OP*)cop;
4018 CopLABEL_set(cop, label);
4019 PL_hints |= HINT_BLOCK_SCOPE;
4022 /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
4023 CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
4025 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
4026 cop->cop_hints_hash = PL_curcop->cop_hints_hash;
4027 if (cop->cop_hints_hash) {
4029 cop->cop_hints_hash->refcounted_he_refcnt++;
4030 HINTS_REFCNT_UNLOCK;
4033 if (PL_copline == NOLINE)
4034 CopLINE_set(cop, CopLINE(PL_curcop));
4036 CopLINE_set(cop, PL_copline);
4037 PL_copline = NOLINE;
4040 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
4042 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
4044 CopSTASH_set(cop, PL_curstash);
4046 if (PERLDB_LINE && PL_curstash != PL_debstash) {
4047 AV *av = CopFILEAVx(PL_curcop);
4049 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
4050 if (svp && *svp != &PL_sv_undef ) {
4051 (void)SvIOK_on(*svp);
4052 SvIV_set(*svp, PTR2IV(cop));
4057 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
4062 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
4065 return new_logop(type, flags, &first, &other);
4069 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
4074 OP *first = *firstp;
4075 OP * const other = *otherp;
4077 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
4078 return newBINOP(type, flags, scalar(first), scalar(other));
4080 scalarboolean(first);
4081 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
4082 if (first->op_type == OP_NOT
4083 && (first->op_flags & OPf_SPECIAL)
4084 && (first->op_flags & OPf_KIDS)) {
4085 if (type == OP_AND || type == OP_OR) {
4091 first = *firstp = cUNOPo->op_first;
4093 first->op_next = o->op_next;
4094 cUNOPo->op_first = NULL;
4096 op_getmad(o,first,'O');
4102 if (first->op_type == OP_CONST) {
4103 if (first->op_private & OPpCONST_STRICT)
4104 no_bareword_allowed(first);
4105 else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
4106 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
4107 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
4108 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
4109 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
4111 if (other->op_type == OP_CONST)
4112 other->op_private |= OPpCONST_SHORTCIRCUIT;
4114 OP *newop = newUNOP(OP_NULL, 0, other);
4115 op_getmad(first, newop, '1');
4116 newop->op_targ = type; /* set "was" field */
4123 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
4124 const OP *o2 = other;
4125 if ( ! (o2->op_type == OP_LIST
4126 && (( o2 = cUNOPx(o2)->op_first))
4127 && o2->op_type == OP_PUSHMARK
4128 && (( o2 = o2->op_sibling)) )
4131 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
4132 || o2->op_type == OP_PADHV)
4133 && o2->op_private & OPpLVAL_INTRO
4134 && ckWARN(WARN_DEPRECATED))
4136 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4137 "Deprecated use of my() in false conditional");
4141 if (first->op_type == OP_CONST)
4142 first->op_private |= OPpCONST_SHORTCIRCUIT;
4144 first = newUNOP(OP_NULL, 0, first);
4145 op_getmad(other, first, '2');
4146 first->op_targ = type; /* set "was" field */
4153 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
4154 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
4156 const OP * const k1 = ((UNOP*)first)->op_first;
4157 const OP * const k2 = k1->op_sibling;
4159 switch (first->op_type)
4162 if (k2 && k2->op_type == OP_READLINE
4163 && (k2->op_flags & OPf_STACKED)
4164 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4166 warnop = k2->op_type;
4171 if (k1->op_type == OP_READDIR
4172 || k1->op_type == OP_GLOB
4173 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4174 || k1->op_type == OP_EACH)
4176 warnop = ((k1->op_type == OP_NULL)
4177 ? (OPCODE)k1->op_targ : k1->op_type);
4182 const line_t oldline = CopLINE(PL_curcop);
4183 CopLINE_set(PL_curcop, PL_copline);
4184 Perl_warner(aTHX_ packWARN(WARN_MISC),
4185 "Value of %s%s can be \"0\"; test with defined()",
4187 ((warnop == OP_READLINE || warnop == OP_GLOB)
4188 ? " construct" : "() operator"));
4189 CopLINE_set(PL_curcop, oldline);
4196 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
4197 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
4199 NewOp(1101, logop, 1, LOGOP);
4201 logop->op_type = (OPCODE)type;
4202 logop->op_ppaddr = PL_ppaddr[type];
4203 logop->op_first = first;
4204 logop->op_flags = (U8)(flags | OPf_KIDS);
4205 logop->op_other = LINKLIST(other);
4206 logop->op_private = (U8)(1 | (flags >> 8));
4208 /* establish postfix order */
4209 logop->op_next = LINKLIST(first);
4210 first->op_next = (OP*)logop;
4211 first->op_sibling = other;
4213 CHECKOP(type,logop);
4215 o = newUNOP(OP_NULL, 0, (OP*)logop);
4222 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
4230 return newLOGOP(OP_AND, 0, first, trueop);
4232 return newLOGOP(OP_OR, 0, first, falseop);
4234 scalarboolean(first);
4235 if (first->op_type == OP_CONST) {
4236 if (first->op_private & OPpCONST_BARE &&
4237 first->op_private & OPpCONST_STRICT) {
4238 no_bareword_allowed(first);
4240 if (SvTRUE(((SVOP*)first)->op_sv)) {
4243 trueop = newUNOP(OP_NULL, 0, trueop);
4244 op_getmad(first,trueop,'C');
4245 op_getmad(falseop,trueop,'e');
4247 /* FIXME for MAD - should there be an ELSE here? */
4257 falseop = newUNOP(OP_NULL, 0, falseop);
4258 op_getmad(first,falseop,'C');
4259 op_getmad(trueop,falseop,'t');
4261 /* FIXME for MAD - should there be an ELSE here? */
4269 NewOp(1101, logop, 1, LOGOP);
4270 logop->op_type = OP_COND_EXPR;
4271 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4272 logop->op_first = first;
4273 logop->op_flags = (U8)(flags | OPf_KIDS);
4274 logop->op_private = (U8)(1 | (flags >> 8));
4275 logop->op_other = LINKLIST(trueop);
4276 logop->op_next = LINKLIST(falseop);
4278 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
4281 /* establish postfix order */
4282 start = LINKLIST(first);
4283 first->op_next = (OP*)logop;
4285 first->op_sibling = trueop;
4286 trueop->op_sibling = falseop;
4287 o = newUNOP(OP_NULL, 0, (OP*)logop);
4289 trueop->op_next = falseop->op_next = o;
4296 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4305 NewOp(1101, range, 1, LOGOP);
4307 range->op_type = OP_RANGE;
4308 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4309 range->op_first = left;
4310 range->op_flags = OPf_KIDS;
4311 leftstart = LINKLIST(left);
4312 range->op_other = LINKLIST(right);
4313 range->op_private = (U8)(1 | (flags >> 8));
4315 left->op_sibling = right;
4317 range->op_next = (OP*)range;
4318 flip = newUNOP(OP_FLIP, flags, (OP*)range);
4319 flop = newUNOP(OP_FLOP, 0, flip);
4320 o = newUNOP(OP_NULL, 0, flop);
4322 range->op_next = leftstart;
4324 left->op_next = flip;
4325 right->op_next = flop;
4327 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4328 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4329 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4330 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4332 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4333 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4336 if (!flip->op_private || !flop->op_private)
4337 linklist(o); /* blow off optimizer unless constant */
4343 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4348 const bool once = block && block->op_flags & OPf_SPECIAL &&
4349 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4351 PERL_UNUSED_ARG(debuggable);
4354 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4355 return block; /* do {} while 0 does once */
4356 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4357 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4358 expr = newUNOP(OP_DEFINED, 0,
4359 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4360 } else if (expr->op_flags & OPf_KIDS) {
4361 const OP * const k1 = ((UNOP*)expr)->op_first;
4362 const OP * const k2 = k1 ? k1->op_sibling : NULL;
4363 switch (expr->op_type) {
4365 if (k2 && k2->op_type == OP_READLINE
4366 && (k2->op_flags & OPf_STACKED)
4367 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4368 expr = newUNOP(OP_DEFINED, 0, expr);
4372 if (k1 && (k1->op_type == OP_READDIR
4373 || k1->op_type == OP_GLOB
4374 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4375 || k1->op_type == OP_EACH))
4376 expr = newUNOP(OP_DEFINED, 0, expr);
4382 /* if block is null, the next append_elem() would put UNSTACK, a scalar
4383 * op, in listop. This is wrong. [perl #27024] */
4385 block = newOP(OP_NULL, 0);
4386 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4387 o = new_logop(OP_AND, 0, &expr, &listop);
4390 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4392 if (once && o != listop)
4393 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4396 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
4398 o->op_flags |= flags;
4400 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4405 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
4406 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
4415 PERL_UNUSED_ARG(debuggable);
4418 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4419 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4420 expr = newUNOP(OP_DEFINED, 0,
4421 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4422 } else if (expr->op_flags & OPf_KIDS) {
4423 const OP * const k1 = ((UNOP*)expr)->op_first;
4424 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
4425 switch (expr->op_type) {
4427 if (k2 && k2->op_type == OP_READLINE
4428 && (k2->op_flags & OPf_STACKED)
4429 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4430 expr = newUNOP(OP_DEFINED, 0, expr);
4434 if (k1 && (k1->op_type == OP_READDIR
4435 || k1->op_type == OP_GLOB
4436 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4437 || k1->op_type == OP_EACH))
4438 expr = newUNOP(OP_DEFINED, 0, expr);
4445 block = newOP(OP_NULL, 0);
4446 else if (cont || has_my) {
4447 block = scope(block);
4451 next = LINKLIST(cont);
4454 OP * const unstack = newOP(OP_UNSTACK, 0);
4457 cont = append_elem(OP_LINESEQ, cont, unstack);
4461 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4463 redo = LINKLIST(listop);
4466 PL_copline = (line_t)whileline;
4468 o = new_logop(OP_AND, 0, &expr, &listop);
4469 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4470 op_free(expr); /* oops, it's a while (0) */
4472 return NULL; /* listop already freed by new_logop */
4475 ((LISTOP*)listop)->op_last->op_next =
4476 (o == listop ? redo : LINKLIST(o));
4482 NewOp(1101,loop,1,LOOP);
4483 loop->op_type = OP_ENTERLOOP;
4484 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4485 loop->op_private = 0;
4486 loop->op_next = (OP*)loop;
4489 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4491 loop->op_redoop = redo;
4492 loop->op_lastop = o;
4493 o->op_private |= loopflags;
4496 loop->op_nextop = next;
4498 loop->op_nextop = o;
4500 o->op_flags |= flags;
4501 o->op_private |= (flags >> 8);
4506 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
4511 PADOFFSET padoff = 0;
4517 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4518 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
4519 sv->op_type = OP_RV2GV;
4520 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4521 if (cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
4522 iterpflags |= OPpITER_DEF;
4524 else if (sv->op_type == OP_PADSV) { /* private variable */
4525 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
4526 padoff = sv->op_targ;
4536 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4538 SV *const namesv = PAD_COMPNAME_SV(padoff);
4540 const char *const name = SvPV_const(namesv, len);
4542 if (len == 2 && name[0] == '$' && name[1] == '_')
4543 iterpflags |= OPpITER_DEF;
4547 const PADOFFSET offset = pad_findmy("$_");
4548 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
4549 sv = newGVOP(OP_GV, 0, PL_defgv);
4554 iterpflags |= OPpITER_DEF;
4556 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4557 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4558 iterflags |= OPf_STACKED;
4560 else if (expr->op_type == OP_NULL &&
4561 (expr->op_flags & OPf_KIDS) &&
4562 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4564 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4565 * set the STACKED flag to indicate that these values are to be
4566 * treated as min/max values by 'pp_iterinit'.
4568 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4569 LOGOP* const range = (LOGOP*) flip->op_first;
4570 OP* const left = range->op_first;
4571 OP* const right = left->op_sibling;
4574 range->op_flags &= ~OPf_KIDS;
4575 range->op_first = NULL;
4577 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4578 listop->op_first->op_next = range->op_next;
4579 left->op_next = range->op_other;
4580 right->op_next = (OP*)listop;
4581 listop->op_next = listop->op_first;
4584 op_getmad(expr,(OP*)listop,'O');
4588 expr = (OP*)(listop);
4590 iterflags |= OPf_STACKED;
4593 expr = mod(force_list(expr), OP_GREPSTART);
4596 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4597 append_elem(OP_LIST, expr, scalar(sv))));
4598 assert(!loop->op_next);
4599 /* for my $x () sets OPpLVAL_INTRO;
4600 * for our $x () sets OPpOUR_INTRO */
4601 loop->op_private = (U8)iterpflags;
4602 #ifdef PL_OP_SLAB_ALLOC
4605 NewOp(1234,tmp,1,LOOP);
4606 Copy(loop,tmp,1,LISTOP);
4607 S_op_destroy(aTHX_ (OP*)loop);
4611 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
4613 loop->op_targ = padoff;
4614 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
4616 op_getmad(madsv, (OP*)loop, 'v');
4617 PL_copline = forline;
4618 return newSTATEOP(0, label, wop);
4622 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4627 if (type != OP_GOTO || label->op_type == OP_CONST) {
4628 /* "last()" means "last" */
4629 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4630 o = newOP(type, OPf_SPECIAL);
4632 o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
4633 ? SvPVx_nolen_const(((SVOP*)label)->op_sv)
4637 op_getmad(label,o,'L');
4643 /* Check whether it's going to be a goto &function */
4644 if (label->op_type == OP_ENTERSUB
4645 && !(label->op_flags & OPf_STACKED))
4646 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4647 o = newUNOP(type, OPf_STACKED, label);
4649 PL_hints |= HINT_BLOCK_SCOPE;
4653 /* if the condition is a literal array or hash
4654 (or @{ ... } etc), make a reference to it.
4657 S_ref_array_or_hash(pTHX_ OP *cond)
4660 && (cond->op_type == OP_RV2AV
4661 || cond->op_type == OP_PADAV
4662 || cond->op_type == OP_RV2HV
4663 || cond->op_type == OP_PADHV))
4665 return newUNOP(OP_REFGEN,
4666 0, mod(cond, OP_REFGEN));
4672 /* These construct the optree fragments representing given()
4675 entergiven and enterwhen are LOGOPs; the op_other pointer
4676 points up to the associated leave op. We need this so we
4677 can put it in the context and make break/continue work.
4678 (Also, of course, pp_enterwhen will jump straight to
4679 op_other if the match fails.)
4684 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
4685 I32 enter_opcode, I32 leave_opcode,
4686 PADOFFSET entertarg)
4692 NewOp(1101, enterop, 1, LOGOP);
4693 enterop->op_type = enter_opcode;
4694 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
4695 enterop->op_flags = (U8) OPf_KIDS;
4696 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
4697 enterop->op_private = 0;
4699 o = newUNOP(leave_opcode, 0, (OP *) enterop);
4702 enterop->op_first = scalar(cond);
4703 cond->op_sibling = block;
4705 o->op_next = LINKLIST(cond);
4706 cond->op_next = (OP *) enterop;
4709 /* This is a default {} block */
4710 enterop->op_first = block;
4711 enterop->op_flags |= OPf_SPECIAL;
4713 o->op_next = (OP *) enterop;
4716 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
4717 entergiven and enterwhen both
4720 enterop->op_next = LINKLIST(block);
4721 block->op_next = enterop->op_other = o;
4726 /* Does this look like a boolean operation? For these purposes
4727 a boolean operation is:
4728 - a subroutine call [*]
4729 - a logical connective
4730 - a comparison operator
4731 - a filetest operator, with the exception of -s -M -A -C
4732 - defined(), exists() or eof()
4733 - /$re/ or $foo =~ /$re/
4735 [*] possibly surprising
4739 S_looks_like_bool(pTHX_ const OP *o)
4742 switch(o->op_type) {
4744 return looks_like_bool(cLOGOPo->op_first);
4748 looks_like_bool(cLOGOPo->op_first)
4749 && looks_like_bool(cLOGOPo->op_first->op_sibling));
4753 case OP_NOT: case OP_XOR:
4754 /* Note that OP_DOR is not here */
4756 case OP_EQ: case OP_NE: case OP_LT:
4757 case OP_GT: case OP_LE: case OP_GE:
4759 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
4760 case OP_I_GT: case OP_I_LE: case OP_I_GE:
4762 case OP_SEQ: case OP_SNE: case OP_SLT:
4763 case OP_SGT: case OP_SLE: case OP_SGE:
4767 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
4768 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
4769 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
4770 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
4771 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
4772 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
4773 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
4774 case OP_FTTEXT: case OP_FTBINARY:
4776 case OP_DEFINED: case OP_EXISTS:
4777 case OP_MATCH: case OP_EOF:
4782 /* Detect comparisons that have been optimized away */
4783 if (cSVOPo->op_sv == &PL_sv_yes
4784 || cSVOPo->op_sv == &PL_sv_no)
4795 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
4799 return newGIVWHENOP(
4800 ref_array_or_hash(cond),
4802 OP_ENTERGIVEN, OP_LEAVEGIVEN,
4806 /* If cond is null, this is a default {} block */
4808 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
4810 const bool cond_llb = (!cond || looks_like_bool(cond));
4816 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
4818 scalar(ref_array_or_hash(cond)));
4821 return newGIVWHENOP(
4823 append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
4824 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
4828 =for apidoc cv_undef
4830 Clear out all the active components of a CV. This can happen either
4831 by an explicit C<undef &foo>, or by the reference count going to zero.
4832 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
4833 children can still follow the full lexical scope chain.
4839 Perl_cv_undef(pTHX_ CV *cv)
4843 if (CvFILE(cv) && !CvISXSUB(cv)) {
4844 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4845 Safefree(CvFILE(cv));
4850 if (!CvISXSUB(cv) && CvROOT(cv)) {
4851 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
4852 Perl_croak(aTHX_ "Can't undef active subroutine");
4855 PAD_SAVE_SETNULLPAD();
4857 op_free(CvROOT(cv));
4862 SvPOK_off((SV*)cv); /* forget prototype */
4867 /* remove CvOUTSIDE unless this is an undef rather than a free */
4868 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
4869 if (!CvWEAKOUTSIDE(cv))
4870 SvREFCNT_dec(CvOUTSIDE(cv));
4871 CvOUTSIDE(cv) = NULL;
4874 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4877 if (CvISXSUB(cv) && CvXSUB(cv)) {
4880 /* delete all flags except WEAKOUTSIDE */
4881 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
4885 Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
4888 /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
4889 relying on SvCUR, and doubling up the buffer to hold CvFILE(). */
4890 if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
4891 || (p && (len != SvCUR(cv) /* Not the same length. */
4892 || memNE(p, SvPVX_const(cv), len))))
4893 && ckWARN_d(WARN_PROTOTYPE)) {
4894 SV* const msg = sv_newmortal();
4898 gv_efullname3(name = sv_newmortal(), gv, NULL);
4899 sv_setpv(msg, "Prototype mismatch:");
4901 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
4903 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv));
4905 sv_catpvs(msg, ": none");
4906 sv_catpvs(msg, " vs ");
4908 Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
4910 sv_catpvs(msg, "none");
4911 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
4915 static void const_sv_xsub(pTHX_ CV* cv);
4919 =head1 Optree Manipulation Functions
4921 =for apidoc cv_const_sv
4923 If C<cv> is a constant sub eligible for inlining. returns the constant
4924 value returned by the sub. Otherwise, returns NULL.
4926 Constant subs can be created with C<newCONSTSUB> or as described in
4927 L<perlsub/"Constant Functions">.
4932 Perl_cv_const_sv(pTHX_ CV *cv)
4934 PERL_UNUSED_CONTEXT;
4937 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
4939 return CvCONST(cv) ? (SV*)CvXSUBANY(cv).any_ptr : NULL;
4942 /* op_const_sv: examine an optree to determine whether it's in-lineable.
4943 * Can be called in 3 ways:
4946 * look for a single OP_CONST with attached value: return the value
4948 * cv && CvCLONE(cv) && !CvCONST(cv)
4950 * examine the clone prototype, and if contains only a single
4951 * OP_CONST referencing a pad const, or a single PADSV referencing
4952 * an outer lexical, return a non-zero value to indicate the CV is
4953 * a candidate for "constizing" at clone time
4957 * We have just cloned an anon prototype that was marked as a const
4958 * candidiate. Try to grab the current value, and in the case of
4959 * PADSV, ignore it if it has multiple references. Return the value.
4963 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
4971 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4972 o = cLISTOPo->op_first->op_sibling;
4974 for (; o; o = o->op_next) {
4975 const OPCODE type = o->op_type;
4977 if (sv && o->op_next == o)
4979 if (o->op_next != o) {
4980 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4982 if (type == OP_DBSTATE)
4985 if (type == OP_LEAVESUB || type == OP_RETURN)
4989 if (type == OP_CONST && cSVOPo->op_sv)
4991 else if (cv && type == OP_CONST) {
4992 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4996 else if (cv && type == OP_PADSV) {
4997 if (CvCONST(cv)) { /* newly cloned anon */
4998 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4999 /* the candidate should have 1 ref from this pad and 1 ref
5000 * from the parent */
5001 if (!sv || SvREFCNT(sv) != 2)
5008 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
5009 sv = &PL_sv_undef; /* an arbitrary non-null value */
5024 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5027 /* This would be the return value, but the return cannot be reached. */
5028 OP* pegop = newOP(OP_NULL, 0);
5031 PERL_UNUSED_ARG(floor);
5041 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
5043 NORETURN_FUNCTION_END;
5048 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
5050 return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
5054 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5061 register CV *cv = NULL;
5063 /* If the subroutine has no body, no attributes, and no builtin attributes
5064 then it's just a sub declaration, and we may be able to get away with
5065 storing with a placeholder scalar in the symbol table, rather than a
5066 full GV and CV. If anything is present then it will take a full CV to
5068 const I32 gv_fetch_flags
5069 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5071 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
5072 const char * const name = o ? SvPVx_nolen_const(cSVOPo->op_sv) : NULL;
5075 assert(proto->op_type == OP_CONST);
5076 ps = SvPVx_const(((SVOP*)proto)->op_sv, ps_len);
5081 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
5082 SV * const sv = sv_newmortal();
5083 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
5084 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
5085 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
5086 aname = SvPVX_const(sv);
5091 gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
5092 : gv_fetchpv(aname ? aname
5093 : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5094 gv_fetch_flags, SVt_PVCV);
5096 if (!PL_madskills) {
5105 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
5106 maximum a prototype before. */
5107 if (SvTYPE(gv) > SVt_NULL) {
5108 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
5109 && ckWARN_d(WARN_PROTOTYPE))
5111 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
5113 cv_ckproto_len((CV*)gv, NULL, ps, ps_len);
5116 sv_setpvn((SV*)gv, ps, ps_len);
5118 sv_setiv((SV*)gv, -1);
5119 SvREFCNT_dec(PL_compcv);
5120 cv = PL_compcv = NULL;
5121 PL_sub_generation++;
5125 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
5127 #ifdef GV_UNIQUE_CHECK
5128 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
5129 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
5133 if (!block || !ps || *ps || attrs
5134 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5136 || block->op_type == OP_NULL
5141 const_sv = op_const_sv(block, NULL);
5144 const bool exists = CvROOT(cv) || CvXSUB(cv);
5146 #ifdef GV_UNIQUE_CHECK
5147 if (exists && GvUNIQUE(gv)) {
5148 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
5152 /* if the subroutine doesn't exist and wasn't pre-declared
5153 * with a prototype, assume it will be AUTOLOADed,
5154 * skipping the prototype check
5156 if (exists || SvPOK(cv))
5157 cv_ckproto_len(cv, gv, ps, ps_len);
5158 /* already defined (or promised)? */
5159 if (exists || GvASSUMECV(gv)) {
5162 || block->op_type == OP_NULL
5165 if (CvFLAGS(PL_compcv)) {
5166 /* might have had built-in attrs applied */
5167 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5169 /* just a "sub foo;" when &foo is already defined */
5170 SAVEFREESV(PL_compcv);
5175 && block->op_type != OP_NULL
5178 if (ckWARN(WARN_REDEFINE)
5180 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
5182 const line_t oldline = CopLINE(PL_curcop);
5183 if (PL_copline != NOLINE)
5184 CopLINE_set(PL_curcop, PL_copline);
5185 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5186 CvCONST(cv) ? "Constant subroutine %s redefined"
5187 : "Subroutine %s redefined", name);
5188 CopLINE_set(PL_curcop, oldline);
5191 if (!PL_minus_c) /* keep old one around for madskills */
5194 /* (PL_madskills unset in used file.) */
5202 SvREFCNT_inc_simple_void_NN(const_sv);
5204 assert(!CvROOT(cv) && !CvCONST(cv));
5205 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
5206 CvXSUBANY(cv).any_ptr = const_sv;
5207 CvXSUB(cv) = const_sv_xsub;
5213 cv = newCONSTSUB(NULL, name, const_sv);
5215 PL_sub_generation++;
5219 SvREFCNT_dec(PL_compcv);
5227 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
5228 * before we clobber PL_compcv.
5232 || block->op_type == OP_NULL
5236 /* Might have had built-in attributes applied -- propagate them. */
5237 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5238 if (CvGV(cv) && GvSTASH(CvGV(cv)))
5239 stash = GvSTASH(CvGV(cv));
5240 else if (CvSTASH(cv))
5241 stash = CvSTASH(cv);
5243 stash = PL_curstash;
5246 /* possibly about to re-define existing subr -- ignore old cv */
5247 rcv = (SV*)PL_compcv;
5248 if (name && GvSTASH(gv))
5249 stash = GvSTASH(gv);
5251 stash = PL_curstash;
5253 apply_attrs(stash, rcv, attrs, FALSE);
5255 if (cv) { /* must reuse cv if autoloaded */
5262 || block->op_type == OP_NULL) && !PL_madskills
5265 /* got here with just attrs -- work done, so bug out */
5266 SAVEFREESV(PL_compcv);
5269 /* transfer PL_compcv to cv */
5271 CvFLAGS(cv) = CvFLAGS(PL_compcv);
5272 if (!CvWEAKOUTSIDE(cv))
5273 SvREFCNT_dec(CvOUTSIDE(cv));
5274 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
5275 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
5276 CvOUTSIDE(PL_compcv) = 0;
5277 CvPADLIST(cv) = CvPADLIST(PL_compcv);
5278 CvPADLIST(PL_compcv) = 0;
5279 /* inner references to PL_compcv must be fixed up ... */
5280 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
5281 /* ... before we throw it away */
5282 SvREFCNT_dec(PL_compcv);
5284 if (PERLDB_INTER)/* Advice debugger on the new sub. */
5285 ++PL_sub_generation;
5292 if (strEQ(name, "import")) {
5293 PL_formfeed = (SV*)cv;
5294 Perl_warner(aTHX_ packWARN(WARN_VOID), "%lx\n", (long)cv);
5298 PL_sub_generation++;
5302 CvFILE_set_from_cop(cv, PL_curcop);
5303 CvSTASH(cv) = PL_curstash;
5306 sv_setpvn((SV*)cv, ps, ps_len);
5308 if (PL_error_count) {
5312 const char *s = strrchr(name, ':');
5314 if (strEQ(s, "BEGIN")) {
5315 const char not_safe[] =
5316 "BEGIN not safe after errors--compilation aborted";
5317 if (PL_in_eval & EVAL_KEEPERR)
5318 Perl_croak(aTHX_ not_safe);
5320 /* force display of errors found but not reported */
5321 sv_catpv(ERRSV, not_safe);
5322 Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
5332 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5333 mod(scalarseq(block), OP_LEAVESUBLV));
5334 block->op_attached = 1;
5337 /* This makes sub {}; work as expected. */
5338 if (block->op_type == OP_STUB) {
5339 OP* const newblock = newSTATEOP(0, NULL, 0);
5341 op_getmad(block,newblock,'B');
5348 block->op_attached = 1;
5349 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5351 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5352 OpREFCNT_set(CvROOT(cv), 1);
5353 CvSTART(cv) = LINKLIST(CvROOT(cv));
5354 CvROOT(cv)->op_next = 0;
5355 CALL_PEEP(CvSTART(cv));
5357 /* now that optimizer has done its work, adjust pad values */
5359 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
5362 assert(!CvCONST(cv));
5363 if (ps && !*ps && op_const_sv(block, cv))
5367 if (name || aname) {
5369 const char * const tname = (name ? name : aname);
5371 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5372 SV * const sv = newSV(0);
5373 SV * const tmpstr = sv_newmortal();
5374 GV * const db_postponed = gv_fetchpvs("DB::postponed",
5375 GV_ADDMULTI, SVt_PVHV);
5378 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5380 (long)PL_subline, (long)CopLINE(PL_curcop));
5381 gv_efullname3(tmpstr, gv, NULL);
5382 hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0);
5383 hv = GvHVn(db_postponed);
5384 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
5385 CV * const pcv = GvCV(db_postponed);
5391 call_sv((SV*)pcv, G_DISCARD);
5396 if ((s = strrchr(tname,':')))
5401 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I' && *s != 'U')
5404 if (strEQ(s, "BEGIN") && !PL_error_count) {
5405 const I32 oldscope = PL_scopestack_ix;
5407 SAVECOPFILE(&PL_compiling);
5408 SAVECOPLINE(&PL_compiling);
5411 PL_beginav = newAV();
5412 DEBUG_x( dump_sub(gv) );
5413 av_push(PL_beginav, (SV*)cv);
5414 GvCV(gv) = 0; /* cv has been hijacked */
5415 call_list(oldscope, PL_beginav);
5417 PL_curcop = &PL_compiling;
5418 CopHINTS_set(&PL_compiling, PL_hints);
5421 else if (strEQ(s, "END") && !PL_error_count) {
5424 DEBUG_x( dump_sub(gv) );
5425 av_unshift(PL_endav, 1);
5426 av_store(PL_endav, 0, (SV*)cv);
5427 GvCV(gv) = 0; /* cv has been hijacked */
5429 else if (strEQ(s, "UNITCHECK") && !PL_error_count) {
5430 /* It's never too late to run a unitcheck block */
5431 if (!PL_unitcheckav)
5432 PL_unitcheckav = newAV();
5433 DEBUG_x( dump_sub(gv) );
5434 av_unshift(PL_unitcheckav, 1);
5435 av_store(PL_unitcheckav, 0, (SV*)cv);
5436 GvCV(gv) = 0; /* cv has been hijacked */
5438 else if (strEQ(s, "CHECK") && !PL_error_count) {
5440 PL_checkav = newAV();
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 CHECK block");
5444 av_unshift(PL_checkav, 1);
5445 av_store(PL_checkav, 0, (SV*)cv);
5446 GvCV(gv) = 0; /* cv has been hijacked */
5448 else if (strEQ(s, "INIT") && !PL_error_count) {
5450 PL_initav = newAV();
5451 DEBUG_x( dump_sub(gv) );
5452 if (PL_main_start && ckWARN(WARN_VOID))
5453 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
5454 av_push(PL_initav, (SV*)cv);
5455 GvCV(gv) = 0; /* cv has been hijacked */
5460 PL_copline = NOLINE;
5465 /* XXX unsafe for threads if eval_owner isn't held */
5467 =for apidoc newCONSTSUB
5469 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5470 eligible for inlining at compile-time.
5476 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
5481 const char *const temp_p = CopFILE(PL_curcop);
5482 const STRLEN len = temp_p ? strlen(temp_p) : 0;
5484 SV *const temp_sv = CopFILESV(PL_curcop);
5486 const char *const temp_p = temp_sv ? SvPV_const(temp_sv, len) : NULL;
5488 char *const file = savepvn(temp_p, temp_p ? len : 0);
5492 SAVECOPLINE(PL_curcop);
5493 CopLINE_set(PL_curcop, PL_copline);
5496 PL_hints &= ~HINT_BLOCK_SCOPE;
5499 SAVESPTR(PL_curstash);
5500 SAVECOPSTASH(PL_curcop);
5501 PL_curstash = stash;
5502 CopSTASH_set(PL_curcop,stash);
5505 /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
5506 and so doesn't get free()d. (It's expected to be from the C pre-
5507 processor __FILE__ directive). But we need a dynamically allocated one,
5508 and we need it to get freed. */
5509 cv = newXS_flags(name, const_sv_xsub, file, "", XS_DYNAMIC_FILENAME);
5510 CvXSUBANY(cv).any_ptr = sv;
5516 CopSTASH_free(PL_curcop);
5524 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
5525 const char *const filename, const char *const proto,
5528 CV *cv = newXS(name, subaddr, filename);
5530 if (flags & XS_DYNAMIC_FILENAME) {
5531 /* We need to "make arrangements" (ie cheat) to ensure that the
5532 filename lasts as long as the PVCV we just created, but also doesn't
5534 STRLEN filename_len = strlen(filename);
5535 STRLEN proto_and_file_len = filename_len;
5536 char *proto_and_file;
5540 proto_len = strlen(proto);
5541 proto_and_file_len += proto_len;
5543 Newx(proto_and_file, proto_and_file_len + 1, char);
5544 Copy(proto, proto_and_file, proto_len, char);
5545 Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
5548 proto_and_file = savepvn(filename, filename_len);
5551 /* This gets free()d. :-) */
5552 sv_usepvn_flags((SV*)cv, proto_and_file, proto_and_file_len,
5553 SV_HAS_TRAILING_NUL);
5555 /* This gives us the correct prototype, rather than one with the
5556 file name appended. */
5557 SvCUR_set(cv, proto_len);
5561 CvFILE(cv) = proto_and_file + proto_len;
5563 sv_setpv((SV *)cv, proto);
5569 =for apidoc U||newXS
5571 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
5572 static storage, as it is used directly as CvFILE(), without a copy being made.
5578 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
5581 GV * const gv = gv_fetchpv(name ? name :
5582 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5583 GV_ADDMULTI, SVt_PVCV);
5587 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
5589 if ((cv = (name ? GvCV(gv) : NULL))) {
5591 /* just a cached method */
5595 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5596 /* already defined (or promised) */
5597 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
5598 if (ckWARN(WARN_REDEFINE)) {
5599 GV * const gvcv = CvGV(cv);
5601 HV * const stash = GvSTASH(gvcv);
5603 const char *redefined_name = HvNAME_get(stash);
5604 if ( strEQ(redefined_name,"autouse") ) {
5605 const line_t oldline = CopLINE(PL_curcop);
5606 if (PL_copline != NOLINE)
5607 CopLINE_set(PL_curcop, PL_copline);
5608 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5609 CvCONST(cv) ? "Constant subroutine %s redefined"
5610 : "Subroutine %s redefined"
5612 CopLINE_set(PL_curcop, oldline);
5622 if (cv) /* must reuse cv if autoloaded */
5626 sv_upgrade((SV *)cv, SVt_PVCV);
5630 PL_sub_generation++;
5634 (void)gv_fetchfile(filename);
5635 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
5636 an external constant string */
5638 CvXSUB(cv) = subaddr;
5641 const char *s = strrchr(name,':');
5647 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5650 if (strEQ(s, "BEGIN")) {
5652 PL_beginav = newAV();
5653 av_push(PL_beginav, (SV*)cv);
5654 GvCV(gv) = 0; /* cv has been hijacked */
5656 else if (strEQ(s, "END")) {
5659 av_unshift(PL_endav, 1);
5660 av_store(PL_endav, 0, (SV*)cv);
5661 GvCV(gv) = 0; /* cv has been hijacked */
5663 else if (strEQ(s, "CHECK")) {
5665 PL_checkav = newAV();
5666 if (PL_main_start && ckWARN(WARN_VOID))
5667 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
5668 av_unshift(PL_checkav, 1);
5669 av_store(PL_checkav, 0, (SV*)cv);
5670 GvCV(gv) = 0; /* cv has been hijacked */
5672 else if (strEQ(s, "INIT")) {
5674 PL_initav = newAV();
5675 if (PL_main_start && ckWARN(WARN_VOID))
5676 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
5677 av_push(PL_initav, (SV*)cv);
5678 GvCV(gv) = 0; /* cv has been hijacked */
5693 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5698 OP* pegop = newOP(OP_NULL, 0);
5702 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
5703 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
5705 #ifdef GV_UNIQUE_CHECK
5707 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5711 if ((cv = GvFORM(gv))) {
5712 if (ckWARN(WARN_REDEFINE)) {
5713 const line_t oldline = CopLINE(PL_curcop);
5714 if (PL_copline != NOLINE)
5715 CopLINE_set(PL_curcop, PL_copline);
5716 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5717 o ? "Format %"SVf" redefined"
5718 : "Format STDOUT redefined", SVfARG(cSVOPo->op_sv));
5719 CopLINE_set(PL_curcop, oldline);
5726 CvFILE_set_from_cop(cv, PL_curcop);
5729 pad_tidy(padtidy_FORMAT);
5730 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5731 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5732 OpREFCNT_set(CvROOT(cv), 1);
5733 CvSTART(cv) = LINKLIST(CvROOT(cv));
5734 CvROOT(cv)->op_next = 0;
5735 CALL_PEEP(CvSTART(cv));
5737 op_getmad(o,pegop,'n');
5738 op_getmad_weak(block, pegop, 'b');
5742 PL_copline = NOLINE;
5750 Perl_newANONLIST(pTHX_ OP *o)
5752 return convert(OP_ANONLIST, OPf_SPECIAL, o);
5756 Perl_newANONHASH(pTHX_ OP *o)
5758 return convert(OP_ANONHASH, OPf_SPECIAL, o);
5762 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5764 return newANONATTRSUB(floor, proto, NULL, block);
5768 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5770 return newUNOP(OP_REFGEN, 0,
5771 newSVOP(OP_ANONCODE, 0,
5772 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5776 Perl_oopsAV(pTHX_ OP *o)
5779 switch (o->op_type) {
5781 o->op_type = OP_PADAV;
5782 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5783 return ref(o, OP_RV2AV);
5786 o->op_type = OP_RV2AV;
5787 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5792 if (ckWARN_d(WARN_INTERNAL))
5793 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
5800 Perl_oopsHV(pTHX_ OP *o)
5803 switch (o->op_type) {
5806 o->op_type = OP_PADHV;
5807 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5808 return ref(o, OP_RV2HV);
5812 o->op_type = OP_RV2HV;
5813 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5818 if (ckWARN_d(WARN_INTERNAL))
5819 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
5826 Perl_newAVREF(pTHX_ OP *o)
5829 if (o->op_type == OP_PADANY) {
5830 o->op_type = OP_PADAV;
5831 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5834 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5835 && ckWARN(WARN_DEPRECATED)) {
5836 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5837 "Using an array as a reference is deprecated");
5839 return newUNOP(OP_RV2AV, 0, scalar(o));
5843 Perl_newGVREF(pTHX_ I32 type, OP *o)
5845 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5846 return newUNOP(OP_NULL, 0, o);
5847 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5851 Perl_newHVREF(pTHX_ OP *o)
5854 if (o->op_type == OP_PADANY) {
5855 o->op_type = OP_PADHV;
5856 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5859 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5860 && ckWARN(WARN_DEPRECATED)) {
5861 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5862 "Using a hash as a reference is deprecated");
5864 return newUNOP(OP_RV2HV, 0, scalar(o));
5868 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5870 return newUNOP(OP_RV2CV, flags, scalar(o));
5874 Perl_newSVREF(pTHX_ OP *o)
5877 if (o->op_type == OP_PADANY) {
5878 o->op_type = OP_PADSV;
5879 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5882 return newUNOP(OP_RV2SV, 0, scalar(o));
5885 /* Check routines. See the comments at the top of this file for details
5886 * on when these are called */
5889 Perl_ck_anoncode(pTHX_ OP *o)
5891 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
5893 cSVOPo->op_sv = NULL;
5898 Perl_ck_bitop(pTHX_ OP *o)
5901 #define OP_IS_NUMCOMPARE(op) \
5902 ((op) == OP_LT || (op) == OP_I_LT || \
5903 (op) == OP_GT || (op) == OP_I_GT || \
5904 (op) == OP_LE || (op) == OP_I_LE || \
5905 (op) == OP_GE || (op) == OP_I_GE || \
5906 (op) == OP_EQ || (op) == OP_I_EQ || \
5907 (op) == OP_NE || (op) == OP_I_NE || \
5908 (op) == OP_NCMP || (op) == OP_I_NCMP)
5909 o->op_private = (U8)(PL_hints & HINT_INTEGER);
5910 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
5911 && (o->op_type == OP_BIT_OR
5912 || o->op_type == OP_BIT_AND
5913 || o->op_type == OP_BIT_XOR))
5915 const OP * const left = cBINOPo->op_first;
5916 const OP * const right = left->op_sibling;
5917 if ((OP_IS_NUMCOMPARE(left->op_type) &&
5918 (left->op_flags & OPf_PARENS) == 0) ||
5919 (OP_IS_NUMCOMPARE(right->op_type) &&
5920 (right->op_flags & OPf_PARENS) == 0))
5921 if (ckWARN(WARN_PRECEDENCE))
5922 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
5923 "Possible precedence problem on bitwise %c operator",
5924 o->op_type == OP_BIT_OR ? '|'
5925 : o->op_type == OP_BIT_AND ? '&' : '^'
5932 Perl_ck_concat(pTHX_ OP *o)
5934 const OP * const kid = cUNOPo->op_first;
5935 PERL_UNUSED_CONTEXT;
5936 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
5937 !(kUNOP->op_first->op_flags & OPf_MOD))
5938 o->op_flags |= OPf_STACKED;
5943 Perl_ck_spair(pTHX_ OP *o)
5946 if (o->op_flags & OPf_KIDS) {
5949 const OPCODE type = o->op_type;
5950 o = modkids(ck_fun(o), type);
5951 kid = cUNOPo->op_first;
5952 newop = kUNOP->op_first->op_sibling;
5954 const OPCODE type = newop->op_type;
5955 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
5956 type == OP_PADAV || type == OP_PADHV ||
5957 type == OP_RV2AV || type == OP_RV2HV)
5961 op_getmad(kUNOP->op_first,newop,'K');
5963 op_free(kUNOP->op_first);
5965 kUNOP->op_first = newop;
5967 o->op_ppaddr = PL_ppaddr[++o->op_type];
5972 Perl_ck_delete(pTHX_ OP *o)
5976 if (o->op_flags & OPf_KIDS) {
5977 OP * const kid = cUNOPo->op_first;
5978 switch (kid->op_type) {
5980 o->op_flags |= OPf_SPECIAL;
5983 o->op_private |= OPpSLICE;
5986 o->op_flags |= OPf_SPECIAL;
5991 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
6000 Perl_ck_die(pTHX_ OP *o)
6003 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6009 Perl_ck_eof(pTHX_ OP *o)
6013 if (o->op_flags & OPf_KIDS) {
6014 if (cLISTOPo->op_first->op_type == OP_STUB) {
6016 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
6018 op_getmad(o,newop,'O');
6030 Perl_ck_eval(pTHX_ OP *o)
6033 PL_hints |= HINT_BLOCK_SCOPE;
6034 if (o->op_flags & OPf_KIDS) {
6035 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6038 o->op_flags &= ~OPf_KIDS;
6041 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
6047 cUNOPo->op_first = 0;
6052 NewOp(1101, enter, 1, LOGOP);
6053 enter->op_type = OP_ENTERTRY;
6054 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
6055 enter->op_private = 0;
6057 /* establish postfix order */
6058 enter->op_next = (OP*)enter;
6060 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
6061 o->op_type = OP_LEAVETRY;
6062 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
6063 enter->op_other = o;
6064 op_getmad(oldo,o,'O');
6078 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
6079 op_getmad(oldo,o,'O');
6081 o->op_targ = (PADOFFSET)PL_hints;
6082 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
6083 /* Store a copy of %^H that pp_entereval can pick up */
6084 OP *hhop = newSVOP(OP_CONST, 0,
6085 (SV*)Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv)));
6086 cUNOPo->op_first->op_sibling = hhop;
6087 o->op_private |= OPpEVAL_HAS_HH;
6093 Perl_ck_exit(pTHX_ OP *o)
6096 HV * const table = GvHV(PL_hintgv);
6098 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
6099 if (svp && *svp && SvTRUE(*svp))
6100 o->op_private |= OPpEXIT_VMSISH;
6102 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6108 Perl_ck_exec(pTHX_ OP *o)
6110 if (o->op_flags & OPf_STACKED) {
6113 kid = cUNOPo->op_first->op_sibling;
6114 if (kid->op_type == OP_RV2GV)
6123 Perl_ck_exists(pTHX_ OP *o)
6127 if (o->op_flags & OPf_KIDS) {
6128 OP * const kid = cUNOPo->op_first;
6129 if (kid->op_type == OP_ENTERSUB) {
6130 (void) ref(kid, o->op_type);
6131 if (kid->op_type != OP_RV2CV && !PL_error_count)
6132 Perl_croak(aTHX_ "%s argument is not a subroutine name",
6134 o->op_private |= OPpEXISTS_SUB;
6136 else if (kid->op_type == OP_AELEM)
6137 o->op_flags |= OPf_SPECIAL;
6138 else if (kid->op_type != OP_HELEM)
6139 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
6147 Perl_ck_rvconst(pTHX_ register OP *o)
6150 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6152 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6153 if (o->op_type == OP_RV2CV)
6154 o->op_private &= ~1;
6156 if (kid->op_type == OP_CONST) {
6159 SV * const kidsv = kid->op_sv;
6161 /* Is it a constant from cv_const_sv()? */
6162 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
6163 SV * const rsv = SvRV(kidsv);
6164 const svtype type = SvTYPE(rsv);
6165 const char *badtype = NULL;
6167 switch (o->op_type) {
6169 if (type > SVt_PVMG)
6170 badtype = "a SCALAR";
6173 if (type != SVt_PVAV)
6174 badtype = "an ARRAY";
6177 if (type != SVt_PVHV)
6181 if (type != SVt_PVCV)
6186 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
6189 else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
6190 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
6191 /* If this is an access to a stash, disable "strict refs", because
6192 * stashes aren't auto-vivified at compile-time (unless we store
6193 * symbols in them), and we don't want to produce a run-time
6194 * stricture error when auto-vivifying the stash. */
6195 const char *s = SvPV_nolen(kidsv);
6196 const STRLEN l = SvCUR(kidsv);
6197 if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
6198 o->op_private &= ~HINT_STRICT_REFS;
6200 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
6201 const char *badthing;
6202 switch (o->op_type) {
6204 badthing = "a SCALAR";
6207 badthing = "an ARRAY";
6210 badthing = "a HASH";
6218 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
6219 SVfARG(kidsv), badthing);
6222 * This is a little tricky. We only want to add the symbol if we
6223 * didn't add it in the lexer. Otherwise we get duplicate strict
6224 * warnings. But if we didn't add it in the lexer, we must at
6225 * least pretend like we wanted to add it even if it existed before,
6226 * or we get possible typo warnings. OPpCONST_ENTERED says
6227 * whether the lexer already added THIS instance of this symbol.
6229 iscv = (o->op_type == OP_RV2CV) * 2;
6231 gv = gv_fetchsv(kidsv,
6232 iscv | !(kid->op_private & OPpCONST_ENTERED),
6235 : o->op_type == OP_RV2SV
6237 : o->op_type == OP_RV2AV
6239 : o->op_type == OP_RV2HV
6242 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
6244 kid->op_type = OP_GV;
6245 SvREFCNT_dec(kid->op_sv);
6247 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
6248 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
6249 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
6251 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc_simple_NN(gv));
6253 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
6255 kid->op_private = 0;
6256 kid->op_ppaddr = PL_ppaddr[OP_GV];
6263 Perl_ck_ftst(pTHX_ OP *o)
6266 const I32 type = o->op_type;
6268 if (o->op_flags & OPf_REF) {
6271 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
6272 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6273 const OPCODE kidtype = kid->op_type;
6275 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6276 OP * const newop = newGVOP(type, OPf_REF,
6277 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
6279 op_getmad(o,newop,'O');
6285 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o))
6286 o->op_private |= OPpFT_ACCESS;
6287 if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst)
6288 && kidtype != OP_STAT && kidtype != OP_LSTAT)
6289 o->op_private |= OPpFT_STACKED;
6297 if (type == OP_FTTTY)
6298 o = newGVOP(type, OPf_REF, PL_stdingv);
6300 o = newUNOP(type, 0, newDEFSVOP());
6301 op_getmad(oldo,o,'O');
6307 Perl_ck_fun(pTHX_ OP *o)
6310 const int type = o->op_type;
6311 register I32 oa = PL_opargs[type] >> OASHIFT;
6313 if (o->op_flags & OPf_STACKED) {
6314 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
6317 return no_fh_allowed(o);
6320 if (o->op_flags & OPf_KIDS) {
6321 OP **tokid = &cLISTOPo->op_first;
6322 register OP *kid = cLISTOPo->op_first;
6326 if (kid->op_type == OP_PUSHMARK ||
6327 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
6329 tokid = &kid->op_sibling;
6330 kid = kid->op_sibling;
6332 if (!kid && PL_opargs[type] & OA_DEFGV)
6333 *tokid = kid = newDEFSVOP();
6337 sibl = kid->op_sibling;
6339 if (!sibl && kid->op_type == OP_STUB) {
6346 /* list seen where single (scalar) arg expected? */
6347 if (numargs == 1 && !(oa >> 4)
6348 && kid->op_type == OP_LIST && type != OP_SCALAR)
6350 return too_many_arguments(o,PL_op_desc[type]);
6363 if ((type == OP_PUSH || type == OP_UNSHIFT)
6364 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
6365 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6366 "Useless use of %s with no values",
6369 if (kid->op_type == OP_CONST &&
6370 (kid->op_private & OPpCONST_BARE))
6372 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
6373 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
6374 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6375 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6376 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
6377 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6379 op_getmad(kid,newop,'K');
6384 kid->op_sibling = sibl;
6387 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
6388 bad_type(numargs, "array", PL_op_desc[type], kid);
6392 if (kid->op_type == OP_CONST &&
6393 (kid->op_private & OPpCONST_BARE))
6395 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
6396 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
6397 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6398 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6399 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
6400 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6402 op_getmad(kid,newop,'K');
6407 kid->op_sibling = sibl;
6410 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
6411 bad_type(numargs, "hash", PL_op_desc[type], kid);
6416 OP * const newop = newUNOP(OP_NULL, 0, kid);
6417 kid->op_sibling = 0;
6419 newop->op_next = newop;
6421 kid->op_sibling = sibl;
6426 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
6427 if (kid->op_type == OP_CONST &&
6428 (kid->op_private & OPpCONST_BARE))
6430 OP * const newop = newGVOP(OP_GV, 0,
6431 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
6432 if (!(o->op_private & 1) && /* if not unop */
6433 kid == cLISTOPo->op_last)
6434 cLISTOPo->op_last = newop;
6436 op_getmad(kid,newop,'K');
6442 else if (kid->op_type == OP_READLINE) {
6443 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
6444 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
6447 I32 flags = OPf_SPECIAL;
6451 /* is this op a FH constructor? */
6452 if (is_handle_constructor(o,numargs)) {
6453 const char *name = NULL;
6457 /* Set a flag to tell rv2gv to vivify
6458 * need to "prove" flag does not mean something
6459 * else already - NI-S 1999/05/07
6462 if (kid->op_type == OP_PADSV) {
6464 = PAD_COMPNAME_SV(kid->op_targ);
6465 name = SvPV_const(namesv, len);
6467 else if (kid->op_type == OP_RV2SV
6468 && kUNOP->op_first->op_type == OP_GV)
6470 GV * const gv = cGVOPx_gv(kUNOP->op_first);
6472 len = GvNAMELEN(gv);
6474 else if (kid->op_type == OP_AELEM
6475 || kid->op_type == OP_HELEM)
6478 OP *op = ((BINOP*)kid)->op_first;
6482 const char * const a =
6483 kid->op_type == OP_AELEM ?
6485 if (((op->op_type == OP_RV2AV) ||
6486 (op->op_type == OP_RV2HV)) &&
6487 (firstop = ((UNOP*)op)->op_first) &&
6488 (firstop->op_type == OP_GV)) {
6489 /* packagevar $a[] or $h{} */
6490 GV * const gv = cGVOPx_gv(firstop);
6498 else if (op->op_type == OP_PADAV
6499 || op->op_type == OP_PADHV) {
6500 /* lexicalvar $a[] or $h{} */
6501 const char * const padname =
6502 PAD_COMPNAME_PV(op->op_targ);
6511 name = SvPV_const(tmpstr, len);
6516 name = "__ANONIO__";
6523 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
6524 namesv = PAD_SVl(targ);
6525 SvUPGRADE(namesv, SVt_PV);
6527 sv_setpvn(namesv, "$", 1);
6528 sv_catpvn(namesv, name, len);
6531 kid->op_sibling = 0;
6532 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
6533 kid->op_targ = targ;
6534 kid->op_private |= priv;
6536 kid->op_sibling = sibl;
6542 mod(scalar(kid), type);
6546 tokid = &kid->op_sibling;
6547 kid = kid->op_sibling;
6550 if (kid && kid->op_type != OP_STUB)
6551 return too_many_arguments(o,OP_DESC(o));
6552 o->op_private |= numargs;
6554 /* FIXME - should the numargs move as for the PERL_MAD case? */
6555 o->op_private |= numargs;
6557 return too_many_arguments(o,OP_DESC(o));
6561 else if (PL_opargs[type] & OA_DEFGV) {
6563 OP *newop = newUNOP(type, 0, newDEFSVOP());
6564 op_getmad(o,newop,'O');
6567 /* Ordering of these two is important to keep f_map.t passing. */
6569 return newUNOP(type, 0, newDEFSVOP());
6574 while (oa & OA_OPTIONAL)
6576 if (oa && oa != OA_LIST)
6577 return too_few_arguments(o,OP_DESC(o));
6583 Perl_ck_glob(pTHX_ OP *o)
6589 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
6590 append_elem(OP_GLOB, o, newDEFSVOP());
6592 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
6593 && GvCVu(gv) && GvIMPORTED_CV(gv)))
6595 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6598 #if !defined(PERL_EXTERNAL_GLOB)
6599 /* XXX this can be tightened up and made more failsafe. */
6600 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
6603 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
6604 newSVpvs("File::Glob"), NULL, NULL, NULL);
6605 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6606 glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
6607 GvCV(gv) = GvCV(glob_gv);
6608 SvREFCNT_inc_void((SV*)GvCV(gv));
6609 GvIMPORTED_CV_on(gv);
6612 #endif /* PERL_EXTERNAL_GLOB */
6614 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6615 append_elem(OP_GLOB, o,
6616 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
6617 o->op_type = OP_LIST;
6618 o->op_ppaddr = PL_ppaddr[OP_LIST];
6619 cLISTOPo->op_first->op_type = OP_PUSHMARK;
6620 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
6621 cLISTOPo->op_first->op_targ = 0;
6622 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
6623 append_elem(OP_LIST, o,
6624 scalar(newUNOP(OP_RV2CV, 0,
6625 newGVOP(OP_GV, 0, gv)))));
6626 o = newUNOP(OP_NULL, 0, ck_subr(o));
6627 o->op_targ = OP_GLOB; /* hint at what it used to be */
6630 gv = newGVgen("main");
6632 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
6638 Perl_ck_grep(pTHX_ OP *o)
6643 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
6646 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
6647 /* don't allocate gwop here, as we may leak it if PL_error_count > 0 */
6649 if (o->op_flags & OPf_STACKED) {
6652 kid = cLISTOPo->op_first->op_sibling;
6653 if (!cUNOPx(kid)->op_next)
6654 Perl_croak(aTHX_ "panic: ck_grep");
6655 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
6658 NewOp(1101, gwop, 1, LOGOP);
6659 kid->op_next = (OP*)gwop;
6660 o->op_flags &= ~OPf_STACKED;
6662 kid = cLISTOPo->op_first->op_sibling;
6663 if (type == OP_MAPWHILE)
6670 kid = cLISTOPo->op_first->op_sibling;
6671 if (kid->op_type != OP_NULL)
6672 Perl_croak(aTHX_ "panic: ck_grep");
6673 kid = kUNOP->op_first;
6676 NewOp(1101, gwop, 1, LOGOP);
6677 gwop->op_type = type;
6678 gwop->op_ppaddr = PL_ppaddr[type];
6679 gwop->op_first = listkids(o);
6680 gwop->op_flags |= OPf_KIDS;
6681 gwop->op_other = LINKLIST(kid);
6682 kid->op_next = (OP*)gwop;
6683 offset = pad_findmy("$_");
6684 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
6685 o->op_private = gwop->op_private = 0;
6686 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
6689 o->op_private = gwop->op_private = OPpGREP_LEX;
6690 gwop->op_targ = o->op_targ = offset;
6693 kid = cLISTOPo->op_first->op_sibling;
6694 if (!kid || !kid->op_sibling)
6695 return too_few_arguments(o,OP_DESC(o));
6696 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
6697 mod(kid, OP_GREPSTART);
6703 Perl_ck_index(pTHX_ OP *o)
6705 if (o->op_flags & OPf_KIDS) {
6706 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6708 kid = kid->op_sibling; /* get past "big" */
6709 if (kid && kid->op_type == OP_CONST)
6710 fbm_compile(((SVOP*)kid)->op_sv, 0);
6716 Perl_ck_lengthconst(pTHX_ OP *o)
6718 /* XXX length optimization goes here */
6723 Perl_ck_lfun(pTHX_ OP *o)
6725 const OPCODE type = o->op_type;
6726 return modkids(ck_fun(o), type);
6730 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
6732 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
6733 switch (cUNOPo->op_first->op_type) {
6735 /* This is needed for
6736 if (defined %stash::)
6737 to work. Do not break Tk.
6739 break; /* Globals via GV can be undef */
6741 case OP_AASSIGN: /* Is this a good idea? */
6742 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6743 "defined(@array) is deprecated");
6744 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6745 "\t(Maybe you should just omit the defined()?)\n");
6748 /* This is needed for
6749 if (defined %stash::)
6750 to work. Do not break Tk.
6752 break; /* Globals via GV can be undef */
6754 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6755 "defined(%%hash) is deprecated");
6756 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6757 "\t(Maybe you should just omit the defined()?)\n");
6768 Perl_ck_rfun(pTHX_ OP *o)
6770 const OPCODE type = o->op_type;
6771 return refkids(ck_fun(o), type);
6775 Perl_ck_listiob(pTHX_ OP *o)
6779 kid = cLISTOPo->op_first;
6782 kid = cLISTOPo->op_first;
6784 if (kid->op_type == OP_PUSHMARK)
6785 kid = kid->op_sibling;
6786 if (kid && o->op_flags & OPf_STACKED)
6787 kid = kid->op_sibling;
6788 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6789 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6790 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6791 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6792 cLISTOPo->op_first->op_sibling = kid;
6793 cLISTOPo->op_last = kid;
6794 kid = kid->op_sibling;
6799 append_elem(o->op_type, o, newDEFSVOP());
6805 Perl_ck_smartmatch(pTHX_ OP *o)
6808 if (0 == (o->op_flags & OPf_SPECIAL)) {
6809 OP *first = cBINOPo->op_first;
6810 OP *second = first->op_sibling;
6812 /* Implicitly take a reference to an array or hash */
6813 first->op_sibling = NULL;
6814 first = cBINOPo->op_first = ref_array_or_hash(first);
6815 second = first->op_sibling = ref_array_or_hash(second);
6817 /* Implicitly take a reference to a regular expression */
6818 if (first->op_type == OP_MATCH) {
6819 first->op_type = OP_QR;
6820 first->op_ppaddr = PL_ppaddr[OP_QR];
6822 if (second->op_type == OP_MATCH) {
6823 second->op_type = OP_QR;
6824 second->op_ppaddr = PL_ppaddr[OP_QR];
6833 Perl_ck_sassign(pTHX_ OP *o)
6835 OP * const kid = cLISTOPo->op_first;
6836 /* has a disposable target? */
6837 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6838 && !(kid->op_flags & OPf_STACKED)
6839 /* Cannot steal the second time! */
6840 && !(kid->op_private & OPpTARGET_MY))
6842 OP * const kkid = kid->op_sibling;
6844 /* Can just relocate the target. */
6845 if (kkid && kkid->op_type == OP_PADSV
6846 && !(kkid->op_private & OPpLVAL_INTRO))
6848 kid->op_targ = kkid->op_targ;
6850 /* Now we do not need PADSV and SASSIGN. */
6851 kid->op_sibling = o->op_sibling; /* NULL */
6852 cLISTOPo->op_first = NULL;
6854 op_getmad(o,kid,'O');
6855 op_getmad(kkid,kid,'M');
6860 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6864 if (kid->op_sibling) {
6865 OP *kkid = kid->op_sibling;
6866 if (kkid->op_type == OP_PADSV
6867 && (kkid->op_private & OPpLVAL_INTRO)
6868 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
6869 o->op_private |= OPpASSIGN_STATE;
6870 /* hijacking PADSTALE for uninitialized state variables */
6871 SvPADSTALE_on(PAD_SVl(kkid->op_targ));
6878 Perl_ck_match(pTHX_ OP *o)
6881 if (o->op_type != OP_QR && PL_compcv) {
6882 const PADOFFSET offset = pad_findmy("$_");
6883 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
6884 o->op_targ = offset;
6885 o->op_private |= OPpTARGET_MY;
6888 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
6889 o->op_private |= OPpRUNTIME;
6894 Perl_ck_method(pTHX_ OP *o)
6896 OP * const kid = cUNOPo->op_first;
6897 if (kid->op_type == OP_CONST) {
6898 SV* sv = kSVOP->op_sv;
6899 const char * const method = SvPVX_const(sv);
6900 if (!(strchr(method, ':') || strchr(method, '\''))) {
6902 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6903 sv = newSVpvn_share(method, SvCUR(sv), 0);
6906 kSVOP->op_sv = NULL;
6908 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6910 op_getmad(o,cmop,'O');
6921 Perl_ck_null(pTHX_ OP *o)
6923 PERL_UNUSED_CONTEXT;
6928 Perl_ck_open(pTHX_ OP *o)
6931 HV * const table = GvHV(PL_hintgv);
6933 SV **svp = hv_fetchs(table, "open_IN", FALSE);
6935 const I32 mode = mode_from_discipline(*svp);
6936 if (mode & O_BINARY)
6937 o->op_private |= OPpOPEN_IN_RAW;
6938 else if (mode & O_TEXT)
6939 o->op_private |= OPpOPEN_IN_CRLF;
6942 svp = hv_fetchs(table, "open_OUT", FALSE);
6944 const I32 mode = mode_from_discipline(*svp);
6945 if (mode & O_BINARY)
6946 o->op_private |= OPpOPEN_OUT_RAW;
6947 else if (mode & O_TEXT)
6948 o->op_private |= OPpOPEN_OUT_CRLF;
6951 if (o->op_type == OP_BACKTICK)
6954 /* In case of three-arg dup open remove strictness
6955 * from the last arg if it is a bareword. */
6956 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
6957 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
6961 if ((last->op_type == OP_CONST) && /* The bareword. */
6962 (last->op_private & OPpCONST_BARE) &&
6963 (last->op_private & OPpCONST_STRICT) &&
6964 (oa = first->op_sibling) && /* The fh. */
6965 (oa = oa->op_sibling) && /* The mode. */
6966 (oa->op_type == OP_CONST) &&
6967 SvPOK(((SVOP*)oa)->op_sv) &&
6968 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
6969 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
6970 (last == oa->op_sibling)) /* The bareword. */
6971 last->op_private &= ~OPpCONST_STRICT;
6977 Perl_ck_repeat(pTHX_ OP *o)
6979 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6980 o->op_private |= OPpREPEAT_DOLIST;
6981 cBINOPo->op_first = force_list(cBINOPo->op_first);
6989 Perl_ck_require(pTHX_ OP *o)
6994 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6995 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6997 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6998 SV * const sv = kid->op_sv;
6999 U32 was_readonly = SvREADONLY(sv);
7004 sv_force_normal_flags(sv, 0);
7005 assert(!SvREADONLY(sv));
7012 for (s = SvPVX(sv); *s; s++) {
7013 if (*s == ':' && s[1] == ':') {
7014 const STRLEN len = strlen(s+2)+1;
7016 Move(s+2, s+1, len, char);
7017 SvCUR_set(sv, SvCUR(sv) - 1);
7020 sv_catpvs(sv, ".pm");
7021 SvFLAGS(sv) |= was_readonly;
7025 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
7026 /* handle override, if any */
7027 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
7028 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7029 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
7030 gv = gvp ? *gvp : NULL;
7034 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7035 OP * const kid = cUNOPo->op_first;
7038 cUNOPo->op_first = 0;
7042 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
7043 append_elem(OP_LIST, kid,
7044 scalar(newUNOP(OP_RV2CV, 0,
7047 op_getmad(o,newop,'O');
7055 Perl_ck_return(pTHX_ OP *o)
7058 if (CvLVALUE(PL_compcv)) {
7060 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
7061 mod(kid, OP_LEAVESUBLV);
7067 Perl_ck_select(pTHX_ OP *o)
7071 if (o->op_flags & OPf_KIDS) {
7072 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7073 if (kid && kid->op_sibling) {
7074 o->op_type = OP_SSELECT;
7075 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
7077 return fold_constants(o);
7081 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7082 if (kid && kid->op_type == OP_RV2GV)
7083 kid->op_private &= ~HINT_STRICT_REFS;
7088 Perl_ck_shift(pTHX_ OP *o)
7091 const I32 type = o->op_type;
7093 if (!(o->op_flags & OPf_KIDS)) {
7095 /* FIXME - this can be refactored to reduce code in #ifdefs */
7097 OP * const oldo = o;
7101 argop = newUNOP(OP_RV2AV, 0,
7102 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
7104 o = newUNOP(type, 0, scalar(argop));
7105 op_getmad(oldo,o,'O');
7108 return newUNOP(type, 0, scalar(argop));
7111 return scalar(modkids(ck_fun(o), type));
7115 Perl_ck_sort(pTHX_ OP *o)
7120 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
7121 HV * const hinthv = GvHV(PL_hintgv);
7123 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
7125 const I32 sorthints = (I32)SvIV(*svp);
7126 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
7127 o->op_private |= OPpSORT_QSORT;
7128 if ((sorthints & HINT_SORT_STABLE) != 0)
7129 o->op_private |= OPpSORT_STABLE;
7134 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
7136 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7137 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
7139 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
7141 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
7143 if (kid->op_type == OP_SCOPE) {
7147 else if (kid->op_type == OP_LEAVE) {
7148 if (o->op_type == OP_SORT) {
7149 op_null(kid); /* wipe out leave */
7152 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
7153 if (k->op_next == kid)
7155 /* don't descend into loops */
7156 else if (k->op_type == OP_ENTERLOOP
7157 || k->op_type == OP_ENTERITER)
7159 k = cLOOPx(k)->op_lastop;
7164 kid->op_next = 0; /* just disconnect the leave */
7165 k = kLISTOP->op_first;
7170 if (o->op_type == OP_SORT) {
7171 /* provide scalar context for comparison function/block */
7177 o->op_flags |= OPf_SPECIAL;
7179 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
7182 firstkid = firstkid->op_sibling;
7185 /* provide list context for arguments */
7186 if (o->op_type == OP_SORT)
7193 S_simplify_sort(pTHX_ OP *o)
7196 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7201 if (!(o->op_flags & OPf_STACKED))
7203 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7204 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
7205 kid = kUNOP->op_first; /* get past null */
7206 if (kid->op_type != OP_SCOPE)
7208 kid = kLISTOP->op_last; /* get past scope */
7209 switch(kid->op_type) {
7217 k = kid; /* remember this node*/
7218 if (kBINOP->op_first->op_type != OP_RV2SV)
7220 kid = kBINOP->op_first; /* get past cmp */
7221 if (kUNOP->op_first->op_type != OP_GV)
7223 kid = kUNOP->op_first; /* get past rv2sv */
7225 if (GvSTASH(gv) != PL_curstash)
7227 gvname = GvNAME(gv);
7228 if (*gvname == 'a' && gvname[1] == '\0')
7230 else if (*gvname == 'b' && gvname[1] == '\0')
7235 kid = k; /* back to cmp */
7236 if (kBINOP->op_last->op_type != OP_RV2SV)
7238 kid = kBINOP->op_last; /* down to 2nd arg */
7239 if (kUNOP->op_first->op_type != OP_GV)
7241 kid = kUNOP->op_first; /* get past rv2sv */
7243 if (GvSTASH(gv) != PL_curstash)
7245 gvname = GvNAME(gv);
7247 ? !(*gvname == 'a' && gvname[1] == '\0')
7248 : !(*gvname == 'b' && gvname[1] == '\0'))
7250 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
7252 o->op_private |= OPpSORT_DESCEND;
7253 if (k->op_type == OP_NCMP)
7254 o->op_private |= OPpSORT_NUMERIC;
7255 if (k->op_type == OP_I_NCMP)
7256 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
7257 kid = cLISTOPo->op_first->op_sibling;
7258 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
7260 op_getmad(kid,o,'S'); /* then delete it */
7262 op_free(kid); /* then delete it */
7267 Perl_ck_split(pTHX_ OP *o)
7272 if (o->op_flags & OPf_STACKED)
7273 return no_fh_allowed(o);
7275 kid = cLISTOPo->op_first;
7276 if (kid->op_type != OP_NULL)
7277 Perl_croak(aTHX_ "panic: ck_split");
7278 kid = kid->op_sibling;
7279 op_free(cLISTOPo->op_first);
7280 cLISTOPo->op_first = kid;
7282 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
7283 cLISTOPo->op_last = kid; /* There was only one element previously */
7286 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
7287 OP * const sibl = kid->op_sibling;
7288 kid->op_sibling = 0;
7289 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
7290 if (cLISTOPo->op_first == cLISTOPo->op_last)
7291 cLISTOPo->op_last = kid;
7292 cLISTOPo->op_first = kid;
7293 kid->op_sibling = sibl;
7296 kid->op_type = OP_PUSHRE;
7297 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
7299 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
7300 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
7301 "Use of /g modifier is meaningless in split");
7304 if (!kid->op_sibling)
7305 append_elem(OP_SPLIT, o, newDEFSVOP());
7307 kid = kid->op_sibling;
7310 if (!kid->op_sibling)
7311 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
7312 assert(kid->op_sibling);
7314 kid = kid->op_sibling;
7317 if (kid->op_sibling)
7318 return too_many_arguments(o,OP_DESC(o));
7324 Perl_ck_join(pTHX_ OP *o)
7326 const OP * const kid = cLISTOPo->op_first->op_sibling;
7327 if (kid && kid->op_type == OP_MATCH) {
7328 if (ckWARN(WARN_SYNTAX)) {
7329 const REGEXP *re = PM_GETRE(kPMOP);
7330 const char *pmstr = re ? re->precomp : "STRING";
7331 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7332 "/%s/ should probably be written as \"%s\"",
7340 Perl_ck_subr(pTHX_ OP *o)
7343 OP *prev = ((cUNOPo->op_first->op_sibling)
7344 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
7345 OP *o2 = prev->op_sibling;
7347 const char *proto = NULL;
7348 const char *proto_end = NULL;
7353 I32 contextclass = 0;
7354 const char *e = NULL;
7357 o->op_private |= OPpENTERSUB_HASTARG;
7358 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
7359 if (cvop->op_type == OP_RV2CV) {
7361 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
7362 op_null(cvop); /* disable rv2cv */
7363 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
7364 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
7365 GV *gv = cGVOPx_gv(tmpop);
7368 tmpop->op_private |= OPpEARLY_CV;
7372 namegv = CvANON(cv) ? gv : CvGV(cv);
7373 proto = SvPV((SV*)cv, len);
7374 proto_end = proto + len;
7376 if (CvASSERTION(cv)) {
7377 U32 asserthints = 0;
7378 HV *const hinthv = GvHV(PL_hintgv);
7380 SV **svp = hv_fetchs(hinthv, "assertions", FALSE);
7382 asserthints = SvUV(*svp);
7384 if (asserthints & HINT_ASSERTING) {
7385 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
7386 o->op_private |= OPpENTERSUB_DB;
7390 if (!(asserthints & HINT_ASSERTIONSSEEN) && ckWARN(WARN_ASSERTIONS)) {
7391 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
7392 "Impossible to activate assertion call");
7399 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7400 if (o2->op_type == OP_CONST)
7401 o2->op_private &= ~OPpCONST_STRICT;
7402 else if (o2->op_type == OP_LIST) {
7403 OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
7404 if (sib && sib->op_type == OP_CONST)
7405 sib->op_private &= ~OPpCONST_STRICT;
7408 o->op_private |= (PL_hints & HINT_STRICT_REFS);
7409 if (PERLDB_SUB && PL_curstash != PL_debstash)
7410 o->op_private |= OPpENTERSUB_DB;
7411 while (o2 != cvop) {
7413 if (PL_madskills && o2->op_type == OP_NULL)
7414 o3 = ((UNOP*)o2)->op_first;
7418 if (proto >= proto_end)
7419 return too_many_arguments(o, gv_ename(namegv));
7427 /* _ must be at the end */
7428 if (proto[1] && proto[1] != ';')
7443 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
7445 arg == 1 ? "block or sub {}" : "sub {}",
7446 gv_ename(namegv), o3);
7449 /* '*' allows any scalar type, including bareword */
7452 if (o3->op_type == OP_RV2GV)
7453 goto wrapref; /* autoconvert GLOB -> GLOBref */
7454 else if (o3->op_type == OP_CONST)
7455 o3->op_private &= ~OPpCONST_STRICT;
7456 else if (o3->op_type == OP_ENTERSUB) {
7457 /* accidental subroutine, revert to bareword */
7458 OP *gvop = ((UNOP*)o3)->op_first;
7459 if (gvop && gvop->op_type == OP_NULL) {
7460 gvop = ((UNOP*)gvop)->op_first;
7462 for (; gvop->op_sibling; gvop = gvop->op_sibling)
7465 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
7466 (gvop = ((UNOP*)gvop)->op_first) &&
7467 gvop->op_type == OP_GV)
7469 GV * const gv = cGVOPx_gv(gvop);
7470 OP * const sibling = o2->op_sibling;
7471 SV * const n = newSVpvs("");
7473 OP * const oldo2 = o2;
7477 gv_fullname4(n, gv, "", FALSE);
7478 o2 = newSVOP(OP_CONST, 0, n);
7479 op_getmad(oldo2,o2,'O');
7480 prev->op_sibling = o2;
7481 o2->op_sibling = sibling;
7497 if (contextclass++ == 0) {
7498 e = strchr(proto, ']');
7499 if (!e || e == proto)
7508 const char *p = proto;
7509 const char *const end = proto;
7511 while (*--p != '[');
7512 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
7514 gv_ename(namegv), o3);
7519 if (o3->op_type == OP_RV2GV)
7522 bad_type(arg, "symbol", gv_ename(namegv), o3);
7525 if (o3->op_type == OP_ENTERSUB)
7528 bad_type(arg, "subroutine entry", gv_ename(namegv),
7532 if (o3->op_type == OP_RV2SV ||
7533 o3->op_type == OP_PADSV ||
7534 o3->op_type == OP_HELEM ||
7535 o3->op_type == OP_AELEM)
7538 bad_type(arg, "scalar", gv_ename(namegv), o3);
7541 if (o3->op_type == OP_RV2AV ||
7542 o3->op_type == OP_PADAV)
7545 bad_type(arg, "array", gv_ename(namegv), o3);
7548 if (o3->op_type == OP_RV2HV ||
7549 o3->op_type == OP_PADHV)
7552 bad_type(arg, "hash", gv_ename(namegv), o3);
7557 OP* const sib = kid->op_sibling;
7558 kid->op_sibling = 0;
7559 o2 = newUNOP(OP_REFGEN, 0, kid);
7560 o2->op_sibling = sib;
7561 prev->op_sibling = o2;
7563 if (contextclass && e) {
7578 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
7579 gv_ename(namegv), SVfARG(cv));
7584 mod(o2, OP_ENTERSUB);
7586 o2 = o2->op_sibling;
7588 if (o2 == cvop && proto && *proto == '_') {
7589 /* generate an access to $_ */
7591 o2->op_sibling = prev->op_sibling;
7592 prev->op_sibling = o2; /* instead of cvop */
7594 if (proto && !optional && proto_end > proto &&
7595 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
7596 return too_few_arguments(o, gv_ename(namegv));
7599 OP * const oldo = o;
7603 o=newSVOP(OP_CONST, 0, newSViv(0));
7604 op_getmad(oldo,o,'O');
7610 Perl_ck_svconst(pTHX_ OP *o)
7612 PERL_UNUSED_CONTEXT;
7613 SvREADONLY_on(cSVOPo->op_sv);
7618 Perl_ck_chdir(pTHX_ OP *o)
7620 if (o->op_flags & OPf_KIDS) {
7621 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7623 if (kid && kid->op_type == OP_CONST &&
7624 (kid->op_private & OPpCONST_BARE))
7626 o->op_flags |= OPf_SPECIAL;
7627 kid->op_private &= ~OPpCONST_STRICT;
7634 Perl_ck_trunc(pTHX_ OP *o)
7636 if (o->op_flags & OPf_KIDS) {
7637 SVOP *kid = (SVOP*)cUNOPo->op_first;
7639 if (kid->op_type == OP_NULL)
7640 kid = (SVOP*)kid->op_sibling;
7641 if (kid && kid->op_type == OP_CONST &&
7642 (kid->op_private & OPpCONST_BARE))
7644 o->op_flags |= OPf_SPECIAL;
7645 kid->op_private &= ~OPpCONST_STRICT;
7652 Perl_ck_unpack(pTHX_ OP *o)
7654 OP *kid = cLISTOPo->op_first;
7655 if (kid->op_sibling) {
7656 kid = kid->op_sibling;
7657 if (!kid->op_sibling)
7658 kid->op_sibling = newDEFSVOP();
7664 Perl_ck_substr(pTHX_ OP *o)
7667 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
7668 OP *kid = cLISTOPo->op_first;
7670 if (kid->op_type == OP_NULL)
7671 kid = kid->op_sibling;
7673 kid->op_flags |= OPf_MOD;
7679 /* A peephole optimizer. We visit the ops in the order they're to execute.
7680 * See the comments at the top of this file for more details about when
7681 * peep() is called */
7684 Perl_peep(pTHX_ register OP *o)
7687 register OP* oldop = NULL;
7689 if (!o || o->op_opt)
7693 SAVEVPTR(PL_curcop);
7694 for (; o; o = o->op_next) {
7698 switch (o->op_type) {
7702 PL_curcop = ((COP*)o); /* for warnings */
7707 if (cSVOPo->op_private & OPpCONST_STRICT)
7708 no_bareword_allowed(o);
7710 case OP_METHOD_NAMED:
7711 /* Relocate sv to the pad for thread safety.
7712 * Despite being a "constant", the SV is written to,
7713 * for reference counts, sv_upgrade() etc. */
7715 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
7716 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
7717 /* If op_sv is already a PADTMP then it is being used by
7718 * some pad, so make a copy. */
7719 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
7720 SvREADONLY_on(PAD_SVl(ix));
7721 SvREFCNT_dec(cSVOPo->op_sv);
7723 else if (o->op_type == OP_CONST
7724 && cSVOPo->op_sv == &PL_sv_undef) {
7725 /* PL_sv_undef is hack - it's unsafe to store it in the
7726 AV that is the pad, because av_fetch treats values of
7727 PL_sv_undef as a "free" AV entry and will merrily
7728 replace them with a new SV, causing pad_alloc to think
7729 that this pad slot is free. (When, clearly, it is not)
7731 SvOK_off(PAD_SVl(ix));
7732 SvPADTMP_on(PAD_SVl(ix));
7733 SvREADONLY_on(PAD_SVl(ix));
7736 SvREFCNT_dec(PAD_SVl(ix));
7737 SvPADTMP_on(cSVOPo->op_sv);
7738 PAD_SETSV(ix, cSVOPo->op_sv);
7739 /* XXX I don't know how this isn't readonly already. */
7740 SvREADONLY_on(PAD_SVl(ix));
7742 cSVOPo->op_sv = NULL;
7750 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
7751 if (o->op_next->op_private & OPpTARGET_MY) {
7752 if (o->op_flags & OPf_STACKED) /* chained concats */
7753 goto ignore_optimization;
7755 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
7756 o->op_targ = o->op_next->op_targ;
7757 o->op_next->op_targ = 0;
7758 o->op_private |= OPpTARGET_MY;
7761 op_null(o->op_next);
7763 ignore_optimization:
7767 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
7769 break; /* Scalar stub must produce undef. List stub is noop */
7773 if (o->op_targ == OP_NEXTSTATE
7774 || o->op_targ == OP_DBSTATE
7775 || o->op_targ == OP_SETSTATE)
7777 PL_curcop = ((COP*)o);
7779 /* XXX: We avoid setting op_seq here to prevent later calls
7780 to peep() from mistakenly concluding that optimisation
7781 has already occurred. This doesn't fix the real problem,
7782 though (See 20010220.007). AMS 20010719 */
7783 /* op_seq functionality is now replaced by op_opt */
7784 if (oldop && o->op_next) {
7785 oldop->op_next = o->op_next;
7793 if (oldop && o->op_next) {
7794 oldop->op_next = o->op_next;
7802 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
7803 OP* const pop = (o->op_type == OP_PADAV) ?
7804 o->op_next : o->op_next->op_next;
7806 if (pop && pop->op_type == OP_CONST &&
7807 ((PL_op = pop->op_next)) &&
7808 pop->op_next->op_type == OP_AELEM &&
7809 !(pop->op_next->op_private &
7810 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
7811 (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
7816 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
7817 no_bareword_allowed(pop);
7818 if (o->op_type == OP_GV)
7819 op_null(o->op_next);
7820 op_null(pop->op_next);
7822 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
7823 o->op_next = pop->op_next->op_next;
7824 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
7825 o->op_private = (U8)i;
7826 if (o->op_type == OP_GV) {
7831 o->op_flags |= OPf_SPECIAL;
7832 o->op_type = OP_AELEMFAST;
7838 if (o->op_next->op_type == OP_RV2SV) {
7839 if (!(o->op_next->op_private & OPpDEREF)) {
7840 op_null(o->op_next);
7841 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
7843 o->op_next = o->op_next->op_next;
7844 o->op_type = OP_GVSV;
7845 o->op_ppaddr = PL_ppaddr[OP_GVSV];
7848 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
7849 GV * const gv = cGVOPo_gv;
7850 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
7851 /* XXX could check prototype here instead of just carping */
7852 SV * const sv = sv_newmortal();
7853 gv_efullname3(sv, gv, NULL);
7854 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
7855 "%"SVf"() called too early to check prototype",
7859 else if (o->op_next->op_type == OP_READLINE
7860 && o->op_next->op_next->op_type == OP_CONCAT
7861 && (o->op_next->op_next->op_flags & OPf_STACKED))
7863 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
7864 o->op_type = OP_RCATLINE;
7865 o->op_flags |= OPf_STACKED;
7866 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
7867 op_null(o->op_next->op_next);
7868 op_null(o->op_next);
7885 while (cLOGOP->op_other->op_type == OP_NULL)
7886 cLOGOP->op_other = cLOGOP->op_other->op_next;
7887 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
7893 while (cLOOP->op_redoop->op_type == OP_NULL)
7894 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
7895 peep(cLOOP->op_redoop);
7896 while (cLOOP->op_nextop->op_type == OP_NULL)
7897 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
7898 peep(cLOOP->op_nextop);
7899 while (cLOOP->op_lastop->op_type == OP_NULL)
7900 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
7901 peep(cLOOP->op_lastop);
7908 while (cPMOP->op_pmreplstart &&
7909 cPMOP->op_pmreplstart->op_type == OP_NULL)
7910 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
7911 peep(cPMOP->op_pmreplstart);
7916 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
7917 && ckWARN(WARN_SYNTAX))
7919 if (o->op_next->op_sibling) {
7920 const OPCODE type = o->op_next->op_sibling->op_type;
7921 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
7922 const line_t oldline = CopLINE(PL_curcop);
7923 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
7924 Perl_warner(aTHX_ packWARN(WARN_EXEC),
7925 "Statement unlikely to be reached");
7926 Perl_warner(aTHX_ packWARN(WARN_EXEC),
7927 "\t(Maybe you meant system() when you said exec()?)\n");
7928 CopLINE_set(PL_curcop, oldline);
7939 const char *key = NULL;
7944 if (((BINOP*)o)->op_last->op_type != OP_CONST)
7947 /* Make the CONST have a shared SV */
7948 svp = cSVOPx_svp(((BINOP*)o)->op_last);
7949 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
7950 key = SvPV_const(sv, keylen);
7951 lexname = newSVpvn_share(key,
7952 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
7958 if ((o->op_private & (OPpLVAL_INTRO)))
7961 rop = (UNOP*)((BINOP*)o)->op_first;
7962 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7964 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7965 if (!SvPAD_TYPED(lexname))
7967 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
7968 if (!fields || !GvHV(*fields))
7970 key = SvPV_const(*svp, keylen);
7971 if (!hv_fetch(GvHV(*fields), key,
7972 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
7974 Perl_croak(aTHX_ "No such class field \"%s\" "
7975 "in variable %s of type %s",
7976 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
7989 SVOP *first_key_op, *key_op;
7991 if ((o->op_private & (OPpLVAL_INTRO))
7992 /* I bet there's always a pushmark... */
7993 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
7994 /* hmmm, no optimization if list contains only one key. */
7996 rop = (UNOP*)((LISTOP*)o)->op_last;
7997 if (rop->op_type != OP_RV2HV)
7999 if (rop->op_first->op_type == OP_PADSV)
8000 /* @$hash{qw(keys here)} */
8001 rop = (UNOP*)rop->op_first;
8003 /* @{$hash}{qw(keys here)} */
8004 if (rop->op_first->op_type == OP_SCOPE
8005 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
8007 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
8013 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
8014 if (!SvPAD_TYPED(lexname))
8016 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8017 if (!fields || !GvHV(*fields))
8019 /* Again guessing that the pushmark can be jumped over.... */
8020 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
8021 ->op_first->op_sibling;
8022 for (key_op = first_key_op; key_op;
8023 key_op = (SVOP*)key_op->op_sibling) {
8024 if (key_op->op_type != OP_CONST)
8026 svp = cSVOPx_svp(key_op);
8027 key = SvPV_const(*svp, keylen);
8028 if (!hv_fetch(GvHV(*fields), key,
8029 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8031 Perl_croak(aTHX_ "No such class field \"%s\" "
8032 "in variable %s of type %s",
8033 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
8040 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
8044 /* check that RHS of sort is a single plain array */
8045 OP *oright = cUNOPo->op_first;
8046 if (!oright || oright->op_type != OP_PUSHMARK)
8049 /* reverse sort ... can be optimised. */
8050 if (!cUNOPo->op_sibling) {
8051 /* Nothing follows us on the list. */
8052 OP * const reverse = o->op_next;
8054 if (reverse->op_type == OP_REVERSE &&
8055 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
8056 OP * const pushmark = cUNOPx(reverse)->op_first;
8057 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
8058 && (cUNOPx(pushmark)->op_sibling == o)) {
8059 /* reverse -> pushmark -> sort */
8060 o->op_private |= OPpSORT_REVERSE;
8062 pushmark->op_next = oright->op_next;
8068 /* make @a = sort @a act in-place */
8072 oright = cUNOPx(oright)->op_sibling;
8075 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
8076 oright = cUNOPx(oright)->op_sibling;
8080 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
8081 || oright->op_next != o
8082 || (oright->op_private & OPpLVAL_INTRO)
8086 /* o2 follows the chain of op_nexts through the LHS of the
8087 * assign (if any) to the aassign op itself */
8089 if (!o2 || o2->op_type != OP_NULL)
8092 if (!o2 || o2->op_type != OP_PUSHMARK)
8095 if (o2 && o2->op_type == OP_GV)
8098 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
8099 || (o2->op_private & OPpLVAL_INTRO)
8104 if (!o2 || o2->op_type != OP_NULL)
8107 if (!o2 || o2->op_type != OP_AASSIGN
8108 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
8111 /* check that the sort is the first arg on RHS of assign */
8113 o2 = cUNOPx(o2)->op_first;
8114 if (!o2 || o2->op_type != OP_NULL)
8116 o2 = cUNOPx(o2)->op_first;
8117 if (!o2 || o2->op_type != OP_PUSHMARK)
8119 if (o2->op_sibling != o)
8122 /* check the array is the same on both sides */
8123 if (oleft->op_type == OP_RV2AV) {
8124 if (oright->op_type != OP_RV2AV
8125 || !cUNOPx(oright)->op_first
8126 || cUNOPx(oright)->op_first->op_type != OP_GV
8127 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
8128 cGVOPx_gv(cUNOPx(oright)->op_first)
8132 else if (oright->op_type != OP_PADAV
8133 || oright->op_targ != oleft->op_targ
8137 /* transfer MODishness etc from LHS arg to RHS arg */
8138 oright->op_flags = oleft->op_flags;
8139 o->op_private |= OPpSORT_INPLACE;
8141 /* excise push->gv->rv2av->null->aassign */
8142 o2 = o->op_next->op_next;
8143 op_null(o2); /* PUSHMARK */
8145 if (o2->op_type == OP_GV) {
8146 op_null(o2); /* GV */
8149 op_null(o2); /* RV2AV or PADAV */
8150 o2 = o2->op_next->op_next;
8151 op_null(o2); /* AASSIGN */
8153 o->op_next = o2->op_next;
8159 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
8161 LISTOP *enter, *exlist;
8164 enter = (LISTOP *) o->op_next;
8167 if (enter->op_type == OP_NULL) {
8168 enter = (LISTOP *) enter->op_next;
8172 /* for $a (...) will have OP_GV then OP_RV2GV here.
8173 for (...) just has an OP_GV. */
8174 if (enter->op_type == OP_GV) {
8175 gvop = (OP *) enter;
8176 enter = (LISTOP *) enter->op_next;
8179 if (enter->op_type == OP_RV2GV) {
8180 enter = (LISTOP *) enter->op_next;
8186 if (enter->op_type != OP_ENTERITER)
8189 iter = enter->op_next;
8190 if (!iter || iter->op_type != OP_ITER)
8193 expushmark = enter->op_first;
8194 if (!expushmark || expushmark->op_type != OP_NULL
8195 || expushmark->op_targ != OP_PUSHMARK)
8198 exlist = (LISTOP *) expushmark->op_sibling;
8199 if (!exlist || exlist->op_type != OP_NULL
8200 || exlist->op_targ != OP_LIST)
8203 if (exlist->op_last != o) {
8204 /* Mmm. Was expecting to point back to this op. */
8207 theirmark = exlist->op_first;
8208 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
8211 if (theirmark->op_sibling != o) {
8212 /* There's something between the mark and the reverse, eg
8213 for (1, reverse (...))
8218 ourmark = ((LISTOP *)o)->op_first;
8219 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
8222 ourlast = ((LISTOP *)o)->op_last;
8223 if (!ourlast || ourlast->op_next != o)
8226 rv2av = ourmark->op_sibling;
8227 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
8228 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
8229 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
8230 /* We're just reversing a single array. */
8231 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
8232 enter->op_flags |= OPf_STACKED;
8235 /* We don't have control over who points to theirmark, so sacrifice
8237 theirmark->op_next = ourmark->op_next;
8238 theirmark->op_flags = ourmark->op_flags;
8239 ourlast->op_next = gvop ? gvop : (OP *) enter;
8242 enter->op_private |= OPpITER_REVERSED;
8243 iter->op_private |= OPpITER_REVERSED;
8250 UNOP *refgen, *rv2cv;
8253 /* I do not understand this, but if o->op_opt isn't set to 1,
8254 various tests in ext/B/t/bytecode.t fail with no readily
8260 if ((o->op_flags && OPf_WANT) != OPf_WANT_VOID)
8263 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
8266 rv2gv = ((BINOP *)o)->op_last;
8267 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
8270 refgen = (UNOP *)((BINOP *)o)->op_first;
8272 if (!refgen || refgen->op_type != OP_REFGEN)
8275 exlist = (LISTOP *)refgen->op_first;
8276 if (!exlist || exlist->op_type != OP_NULL
8277 || exlist->op_targ != OP_LIST)
8280 if (exlist->op_first->op_type != OP_PUSHMARK)
8283 rv2cv = (UNOP*)exlist->op_last;
8285 if (rv2cv->op_type != OP_RV2CV)
8288 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
8289 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
8290 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
8292 o->op_private |= OPpASSIGN_CV_TO_GV;
8293 rv2gv->op_private |= OPpDONT_INIT_GV;
8294 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
8310 Perl_custom_op_name(pTHX_ const OP* o)
8313 const IV index = PTR2IV(o->op_ppaddr);
8317 if (!PL_custom_op_names) /* This probably shouldn't happen */
8318 return (char *)PL_op_name[OP_CUSTOM];
8320 keysv = sv_2mortal(newSViv(index));
8322 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
8324 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
8326 return SvPV_nolen(HeVAL(he));
8330 Perl_custom_op_desc(pTHX_ const OP* o)
8333 const IV index = PTR2IV(o->op_ppaddr);
8337 if (!PL_custom_op_descs)
8338 return (char *)PL_op_desc[OP_CUSTOM];
8340 keysv = sv_2mortal(newSViv(index));
8342 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
8344 return (char *)PL_op_desc[OP_CUSTOM];
8346 return SvPV_nolen(HeVAL(he));
8351 /* Efficient sub that returns a constant scalar value. */
8353 const_sv_xsub(pTHX_ CV* cv)
8360 Perl_croak(aTHX_ "usage: %s::%s()",
8361 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
8365 ST(0) = (SV*)XSANY.any_ptr;
8371 * c-indentation-style: bsd
8373 * indent-tabs-mode: t
8376 * ex: set ts=8 sts=4 sw=4 noet: