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)
3101 PerlMemShared_realloc(tbl,
3102 (0x101+rlen-j) * sizeof(short));
3103 cPVOPo->op_pv = (char*)tbl;
3105 tbl[0x100] = (short)(rlen - j);
3106 for (i=0; i < (I32)rlen - j; i++)
3107 tbl[0x101+i] = r[j+i];
3111 if (!rlen && !del) {
3114 o->op_private |= OPpTRANS_IDENTICAL;
3116 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3117 o->op_private |= OPpTRANS_IDENTICAL;
3119 for (i = 0; i < 256; i++)
3121 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3122 if (j >= (I32)rlen) {
3124 if (tbl[t[i]] == -1)
3130 if (tbl[t[i]] == -1) {
3131 if (t[i] < 128 && r[j] >= 128)
3138 o->op_private |= OPpTRANS_GROWS;
3140 op_getmad(expr,o,'e');
3141 op_getmad(repl,o,'r');
3151 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3156 NewOp(1101, pmop, 1, PMOP);
3157 pmop->op_type = (OPCODE)type;
3158 pmop->op_ppaddr = PL_ppaddr[type];
3159 pmop->op_flags = (U8)flags;
3160 pmop->op_private = (U8)(0 | (flags >> 8));
3162 if (PL_hints & HINT_RE_TAINT)
3163 pmop->op_pmpermflags |= PMf_RETAINT;
3164 if (PL_hints & HINT_LOCALE)
3165 pmop->op_pmpermflags |= PMf_LOCALE;
3166 pmop->op_pmflags = pmop->op_pmpermflags;
3169 if (av_len((AV*) PL_regex_pad[0]) > -1) {
3170 SV * const repointer = av_pop((AV*)PL_regex_pad[0]);
3171 pmop->op_pmoffset = SvIV(repointer);
3172 SvREPADTMP_off(repointer);
3173 sv_setiv(repointer,0);
3175 SV * const repointer = newSViv(0);
3176 av_push(PL_regex_padav, SvREFCNT_inc_simple_NN(repointer));
3177 pmop->op_pmoffset = av_len(PL_regex_padav);
3178 PL_regex_pad = AvARRAY(PL_regex_padav);
3182 /* link into pm list */
3183 if (type != OP_TRANS && PL_curstash) {
3184 MAGIC *mg = mg_find((SV*)PL_curstash, PERL_MAGIC_symtab);
3187 mg = sv_magicext((SV*)PL_curstash, 0, PERL_MAGIC_symtab, 0, 0, 0);
3189 pmop->op_pmnext = (PMOP*)mg->mg_obj;
3190 mg->mg_obj = (SV*)pmop;
3191 PmopSTASH_set(pmop,PL_curstash);
3194 return CHECKOP(type, pmop);
3197 /* Given some sort of match op o, and an expression expr containing a
3198 * pattern, either compile expr into a regex and attach it to o (if it's
3199 * constant), or convert expr into a runtime regcomp op sequence (if it's
3202 * isreg indicates that the pattern is part of a regex construct, eg
3203 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3204 * split "pattern", which aren't. In the former case, expr will be a list
3205 * if the pattern contains more than one term (eg /a$b/) or if it contains
3206 * a replacement, ie s/// or tr///.
3210 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
3215 I32 repl_has_vars = 0;
3219 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
3220 /* last element in list is the replacement; pop it */
3222 repl = cLISTOPx(expr)->op_last;
3223 kid = cLISTOPx(expr)->op_first;
3224 while (kid->op_sibling != repl)
3225 kid = kid->op_sibling;
3226 kid->op_sibling = NULL;
3227 cLISTOPx(expr)->op_last = kid;
3230 if (isreg && expr->op_type == OP_LIST &&
3231 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3233 /* convert single element list to element */
3234 OP* const oe = expr;
3235 expr = cLISTOPx(oe)->op_first->op_sibling;
3236 cLISTOPx(oe)->op_first->op_sibling = NULL;
3237 cLISTOPx(oe)->op_last = NULL;
3241 if (o->op_type == OP_TRANS) {
3242 return pmtrans(o, expr, repl);
3245 reglist = isreg && expr->op_type == OP_LIST;
3249 PL_hints |= HINT_BLOCK_SCOPE;
3252 if (expr->op_type == OP_CONST) {
3254 SV * const pat = ((SVOP*)expr)->op_sv;
3255 const char *p = SvPV_const(pat, plen);
3256 if ((o->op_flags & OPf_SPECIAL) && (*p == ' ' && p[1] == '\0')) {
3257 U32 was_readonly = SvREADONLY(pat);
3261 sv_force_normal_flags(pat, 0);
3262 assert(!SvREADONLY(pat));
3265 SvREADONLY_off(pat);
3269 sv_setpvn(pat, "\\s+", 3);
3271 SvFLAGS(pat) |= was_readonly;
3273 p = SvPV_const(pat, plen);
3274 pm->op_pmflags |= PMf_SKIPWHITE;
3277 pm->op_pmdynflags |= PMdf_UTF8;
3278 /* FIXME - can we make this function take const char * args? */
3279 PM_SETRE(pm, CALLREGCOMP((char*)p, (char*)p + plen, pm));
3280 if (PM_GETRE(pm)->extflags & RXf_WHITE)
3281 pm->op_pmflags |= PMf_WHITE;
3283 pm->op_pmflags &= ~PMf_WHITE;
3285 op_getmad(expr,(OP*)pm,'e');
3291 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3292 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3294 : OP_REGCMAYBE),0,expr);
3296 NewOp(1101, rcop, 1, LOGOP);
3297 rcop->op_type = OP_REGCOMP;
3298 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3299 rcop->op_first = scalar(expr);
3300 rcop->op_flags |= OPf_KIDS
3301 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3302 | (reglist ? OPf_STACKED : 0);
3303 rcop->op_private = 1;
3306 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3308 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
3311 /* establish postfix order */
3312 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3314 rcop->op_next = expr;
3315 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3318 rcop->op_next = LINKLIST(expr);
3319 expr->op_next = (OP*)rcop;
3322 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3327 if (pm->op_pmflags & PMf_EVAL) {
3329 if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
3330 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
3332 else if (repl->op_type == OP_CONST)
3336 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3337 if (curop->op_type == OP_SCOPE
3338 || curop->op_type == OP_LEAVE
3339 || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
3340 if (curop->op_type == OP_GV) {
3341 GV * const gv = cGVOPx_gv(curop);
3343 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3346 else if (curop->op_type == OP_RV2CV)
3348 else if (curop->op_type == OP_RV2SV ||
3349 curop->op_type == OP_RV2AV ||
3350 curop->op_type == OP_RV2HV ||
3351 curop->op_type == OP_RV2GV) {
3352 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3355 else if (curop->op_type == OP_PADSV ||
3356 curop->op_type == OP_PADAV ||
3357 curop->op_type == OP_PADHV ||
3358 curop->op_type == OP_PADANY)
3362 else if (curop->op_type == OP_PUSHRE)
3363 NOOP; /* Okay here, dangerous in newASSIGNOP */
3373 || PM_GETRE(pm)->extflags & RXf_EVAL_SEEN)))
3375 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3376 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
3377 prepend_elem(o->op_type, scalar(repl), o);
3380 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3381 pm->op_pmflags |= PMf_MAYBE_CONST;
3382 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3384 NewOp(1101, rcop, 1, LOGOP);
3385 rcop->op_type = OP_SUBSTCONT;
3386 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3387 rcop->op_first = scalar(repl);
3388 rcop->op_flags |= OPf_KIDS;
3389 rcop->op_private = 1;
3392 /* establish postfix order */
3393 rcop->op_next = LINKLIST(repl);
3394 repl->op_next = (OP*)rcop;
3396 pm->op_pmreplroot = scalar((OP*)rcop);
3397 pm->op_pmreplstart = LINKLIST(rcop);
3406 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3410 NewOp(1101, svop, 1, SVOP);
3411 svop->op_type = (OPCODE)type;
3412 svop->op_ppaddr = PL_ppaddr[type];
3414 svop->op_next = (OP*)svop;
3415 svop->op_flags = (U8)flags;
3416 if (PL_opargs[type] & OA_RETSCALAR)
3418 if (PL_opargs[type] & OA_TARGET)
3419 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3420 return CHECKOP(type, svop);
3424 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3428 NewOp(1101, padop, 1, PADOP);
3429 padop->op_type = (OPCODE)type;
3430 padop->op_ppaddr = PL_ppaddr[type];
3431 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3432 SvREFCNT_dec(PAD_SVl(padop->op_padix));
3433 PAD_SETSV(padop->op_padix, sv);
3436 padop->op_next = (OP*)padop;
3437 padop->op_flags = (U8)flags;
3438 if (PL_opargs[type] & OA_RETSCALAR)
3440 if (PL_opargs[type] & OA_TARGET)
3441 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3442 return CHECKOP(type, padop);
3446 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3452 return newPADOP(type, flags, SvREFCNT_inc_simple(gv));
3454 return newSVOP(type, flags, SvREFCNT_inc_simple(gv));
3459 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3463 NewOp(1101, pvop, 1, PVOP);
3464 pvop->op_type = (OPCODE)type;
3465 pvop->op_ppaddr = PL_ppaddr[type];
3467 pvop->op_next = (OP*)pvop;
3468 pvop->op_flags = (U8)flags;
3469 if (PL_opargs[type] & OA_RETSCALAR)
3471 if (PL_opargs[type] & OA_TARGET)
3472 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3473 return CHECKOP(type, pvop);
3481 Perl_package(pTHX_ OP *o)
3490 save_hptr(&PL_curstash);
3491 save_item(PL_curstname);
3493 name = SvPV_const(cSVOPo->op_sv, len);
3494 PL_curstash = gv_stashpvn(name, len, TRUE);
3495 sv_setpvn(PL_curstname, name, len);
3497 PL_hints |= HINT_BLOCK_SCOPE;
3498 PL_copline = NOLINE;
3504 if (!PL_madskills) {
3509 pegop = newOP(OP_NULL,0);
3510 op_getmad(o,pegop,'P');
3520 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3527 OP *pegop = newOP(OP_NULL,0);
3530 if (idop->op_type != OP_CONST)
3531 Perl_croak(aTHX_ "Module name must be constant");
3534 op_getmad(idop,pegop,'U');
3539 SV * const vesv = ((SVOP*)version)->op_sv;
3542 op_getmad(version,pegop,'V');
3543 if (!arg && !SvNIOKp(vesv)) {
3550 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3551 Perl_croak(aTHX_ "Version number must be constant number");
3553 /* Make copy of idop so we don't free it twice */
3554 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3556 /* Fake up a method call to VERSION */
3557 meth = newSVpvs_share("VERSION");
3558 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3559 append_elem(OP_LIST,
3560 prepend_elem(OP_LIST, pack, list(version)),
3561 newSVOP(OP_METHOD_NAMED, 0, meth)));
3565 /* Fake up an import/unimport */
3566 if (arg && arg->op_type == OP_STUB) {
3568 op_getmad(arg,pegop,'S');
3569 imop = arg; /* no import on explicit () */
3571 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3572 imop = NULL; /* use 5.0; */
3574 idop->op_private |= OPpCONST_NOVER;
3580 op_getmad(arg,pegop,'A');
3582 /* Make copy of idop so we don't free it twice */
3583 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3585 /* Fake up a method call to import/unimport */
3587 ? newSVpvs_share("import") : newSVpvs_share("unimport");
3588 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3589 append_elem(OP_LIST,
3590 prepend_elem(OP_LIST, pack, list(arg)),
3591 newSVOP(OP_METHOD_NAMED, 0, meth)));
3594 /* Fake up the BEGIN {}, which does its thing immediately. */
3596 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
3599 append_elem(OP_LINESEQ,
3600 append_elem(OP_LINESEQ,
3601 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
3602 newSTATEOP(0, NULL, veop)),
3603 newSTATEOP(0, NULL, imop) ));
3605 /* The "did you use incorrect case?" warning used to be here.
3606 * The problem is that on case-insensitive filesystems one
3607 * might get false positives for "use" (and "require"):
3608 * "use Strict" or "require CARP" will work. This causes
3609 * portability problems for the script: in case-strict
3610 * filesystems the script will stop working.
3612 * The "incorrect case" warning checked whether "use Foo"
3613 * imported "Foo" to your namespace, but that is wrong, too:
3614 * there is no requirement nor promise in the language that
3615 * a Foo.pm should or would contain anything in package "Foo".
3617 * There is very little Configure-wise that can be done, either:
3618 * the case-sensitivity of the build filesystem of Perl does not
3619 * help in guessing the case-sensitivity of the runtime environment.
3622 PL_hints |= HINT_BLOCK_SCOPE;
3623 PL_copline = NOLINE;
3625 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3628 if (!PL_madskills) {
3629 /* FIXME - don't allocate pegop if !PL_madskills */
3638 =head1 Embedding Functions
3640 =for apidoc load_module
3642 Loads the module whose name is pointed to by the string part of name.
3643 Note that the actual module name, not its filename, should be given.
3644 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3645 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3646 (or 0 for no flags). ver, if specified, provides version semantics
3647 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3648 arguments can be used to specify arguments to the module's import()
3649 method, similar to C<use Foo::Bar VERSION LIST>.
3654 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3657 va_start(args, ver);
3658 vload_module(flags, name, ver, &args);
3662 #ifdef PERL_IMPLICIT_CONTEXT
3664 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3668 va_start(args, ver);
3669 vload_module(flags, name, ver, &args);
3675 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3680 OP * const modname = newSVOP(OP_CONST, 0, name);
3681 modname->op_private |= OPpCONST_BARE;
3683 veop = newSVOP(OP_CONST, 0, ver);
3687 if (flags & PERL_LOADMOD_NOIMPORT) {
3688 imop = sawparens(newNULLLIST());
3690 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3691 imop = va_arg(*args, OP*);
3696 sv = va_arg(*args, SV*);
3698 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3699 sv = va_arg(*args, SV*);
3703 const line_t ocopline = PL_copline;
3704 COP * const ocurcop = PL_curcop;
3705 const int oexpect = PL_expect;
3707 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3708 veop, modname, imop);
3709 PL_expect = oexpect;
3710 PL_copline = ocopline;
3711 PL_curcop = ocurcop;
3716 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
3722 if (!force_builtin) {
3723 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
3724 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
3725 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
3726 gv = gvp ? *gvp : NULL;
3730 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3731 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3732 append_elem(OP_LIST, term,
3733 scalar(newUNOP(OP_RV2CV, 0,
3734 newGVOP(OP_GV, 0, gv))))));
3737 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3743 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3745 return newBINOP(OP_LSLICE, flags,
3746 list(force_list(subscript)),
3747 list(force_list(listval)) );
3751 S_is_list_assignment(pTHX_ register const OP *o)
3759 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
3760 o = cUNOPo->op_first;
3762 flags = o->op_flags;
3764 if (type == OP_COND_EXPR) {
3765 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
3766 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3771 yyerror("Assignment to both a list and a scalar");
3775 if (type == OP_LIST &&
3776 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
3777 o->op_private & OPpLVAL_INTRO)
3780 if (type == OP_LIST || flags & OPf_PARENS ||
3781 type == OP_RV2AV || type == OP_RV2HV ||
3782 type == OP_ASLICE || type == OP_HSLICE)
3785 if (type == OP_PADAV || type == OP_PADHV)
3788 if (type == OP_RV2SV)
3795 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3801 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3802 return newLOGOP(optype, 0,
3803 mod(scalar(left), optype),
3804 newUNOP(OP_SASSIGN, 0, scalar(right)));
3807 return newBINOP(optype, OPf_STACKED,
3808 mod(scalar(left), optype), scalar(right));
3812 if (is_list_assignment(left)) {
3816 /* Grandfathering $[ assignment here. Bletch.*/
3817 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
3818 PL_eval_start = (left->op_type == OP_CONST) ? right : 0;
3819 left = mod(left, OP_AASSIGN);
3822 else if (left->op_type == OP_CONST) {
3824 /* Result of assignment is always 1 (or we'd be dead already) */
3825 return newSVOP(OP_CONST, 0, newSViv(1));
3827 curop = list(force_list(left));
3828 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3829 o->op_private = (U8)(0 | (flags >> 8));
3831 /* PL_generation sorcery:
3832 * an assignment like ($a,$b) = ($c,$d) is easier than
3833 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3834 * To detect whether there are common vars, the global var
3835 * PL_generation is incremented for each assign op we compile.
3836 * Then, while compiling the assign op, we run through all the
3837 * variables on both sides of the assignment, setting a spare slot
3838 * in each of them to PL_generation. If any of them already have
3839 * that value, we know we've got commonality. We could use a
3840 * single bit marker, but then we'd have to make 2 passes, first
3841 * to clear the flag, then to test and set it. To find somewhere
3842 * to store these values, evil chicanery is done with SvUVX().
3848 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3849 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3850 if (curop->op_type == OP_GV) {
3851 GV *gv = cGVOPx_gv(curop);
3853 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
3855 GvASSIGN_GENERATION_set(gv, PL_generation);
3857 else if (curop->op_type == OP_PADSV ||
3858 curop->op_type == OP_PADAV ||
3859 curop->op_type == OP_PADHV ||
3860 curop->op_type == OP_PADANY)
3862 if (PAD_COMPNAME_GEN(curop->op_targ)
3863 == (STRLEN)PL_generation)
3865 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
3868 else if (curop->op_type == OP_RV2CV)
3870 else if (curop->op_type == OP_RV2SV ||
3871 curop->op_type == OP_RV2AV ||
3872 curop->op_type == OP_RV2HV ||
3873 curop->op_type == OP_RV2GV) {
3874 if (lastop->op_type != OP_GV) /* funny deref? */
3877 else if (curop->op_type == OP_PUSHRE) {
3878 if (((PMOP*)curop)->op_pmreplroot) {
3880 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3881 ((PMOP*)curop)->op_pmreplroot));
3883 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3886 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
3888 GvASSIGN_GENERATION_set(gv, PL_generation);
3889 GvASSIGN_GENERATION_set(gv, PL_generation);
3898 o->op_private |= OPpASSIGN_COMMON;
3901 if ( ((left->op_private & OPpLVAL_INTRO) || ckWARN(WARN_MISC))
3902 && (left->op_type == OP_LIST
3903 || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
3905 OP* lop = ((LISTOP*)left)->op_first;
3907 if (lop->op_type == OP_PADSV ||
3908 lop->op_type == OP_PADAV ||
3909 lop->op_type == OP_PADHV ||
3910 lop->op_type == OP_PADANY)
3912 if (lop->op_private & OPpPAD_STATE) {
3913 if (left->op_private & OPpLVAL_INTRO) {
3914 o->op_private |= OPpASSIGN_STATE;
3915 /* hijacking PADSTALE for uninitialized state variables */
3916 SvPADSTALE_on(PAD_SVl(lop->op_targ));
3918 else { /* we already checked for WARN_MISC before */
3919 Perl_warner(aTHX_ packWARN(WARN_MISC), "State variable %s will be reinitialized",
3920 PAD_COMPNAME_PV(lop->op_targ));
3924 lop = lop->op_sibling;
3928 if (right && right->op_type == OP_SPLIT) {
3929 OP* tmpop = ((LISTOP*)right)->op_first;
3930 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
3931 PMOP * const pm = (PMOP*)tmpop;
3932 if (left->op_type == OP_RV2AV &&
3933 !(left->op_private & OPpLVAL_INTRO) &&
3934 !(o->op_private & OPpASSIGN_COMMON) )
3936 tmpop = ((UNOP*)left)->op_first;
3937 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3939 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3940 cPADOPx(tmpop)->op_padix = 0; /* steal it */
3942 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3943 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
3945 pm->op_pmflags |= PMf_ONCE;
3946 tmpop = cUNOPo->op_first; /* to list (nulled) */
3947 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3948 tmpop->op_sibling = NULL; /* don't free split */
3949 right->op_next = tmpop->op_next; /* fix starting loc */
3951 op_getmad(o,right,'R'); /* blow off assign */
3953 op_free(o); /* blow off assign */
3955 right->op_flags &= ~OPf_WANT;
3956 /* "I don't know and I don't care." */
3961 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3962 ((LISTOP*)right)->op_last->op_type == OP_CONST)
3964 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3966 sv_setiv(sv, PL_modcount+1);
3974 right = newOP(OP_UNDEF, 0);
3975 if (right->op_type == OP_READLINE) {
3976 right->op_flags |= OPf_STACKED;
3977 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3980 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
3981 o = newBINOP(OP_SASSIGN, flags,
3982 scalar(right), mod(scalar(left), OP_SASSIGN) );
3988 o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
3989 o->op_private |= OPpCONST_ARYBASE;
3996 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3999 const U32 seq = intro_my();
4002 NewOp(1101, cop, 1, COP);
4003 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
4004 cop->op_type = OP_DBSTATE;
4005 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
4008 cop->op_type = OP_NEXTSTATE;
4009 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
4011 cop->op_flags = (U8)flags;
4012 CopHINTS_set(cop, PL_hints);
4014 cop->op_private |= NATIVE_HINTS;
4016 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
4017 cop->op_next = (OP*)cop;
4020 CopLABEL_set(cop, label);
4021 PL_hints |= HINT_BLOCK_SCOPE;
4024 /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
4025 CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
4027 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
4028 cop->cop_hints_hash = PL_curcop->cop_hints_hash;
4029 if (cop->cop_hints_hash) {
4031 cop->cop_hints_hash->refcounted_he_refcnt++;
4032 HINTS_REFCNT_UNLOCK;
4035 if (PL_copline == NOLINE)
4036 CopLINE_set(cop, CopLINE(PL_curcop));
4038 CopLINE_set(cop, PL_copline);
4039 PL_copline = NOLINE;
4042 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
4044 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
4046 CopSTASH_set(cop, PL_curstash);
4048 if (PERLDB_LINE && PL_curstash != PL_debstash) {
4049 AV *av = CopFILEAVx(PL_curcop);
4051 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
4052 if (svp && *svp != &PL_sv_undef ) {
4053 (void)SvIOK_on(*svp);
4054 SvIV_set(*svp, PTR2IV(cop));
4059 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
4064 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
4067 return new_logop(type, flags, &first, &other);
4071 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
4076 OP *first = *firstp;
4077 OP * const other = *otherp;
4079 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
4080 return newBINOP(type, flags, scalar(first), scalar(other));
4082 scalarboolean(first);
4083 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
4084 if (first->op_type == OP_NOT
4085 && (first->op_flags & OPf_SPECIAL)
4086 && (first->op_flags & OPf_KIDS)) {
4087 if (type == OP_AND || type == OP_OR) {
4093 first = *firstp = cUNOPo->op_first;
4095 first->op_next = o->op_next;
4096 cUNOPo->op_first = NULL;
4098 op_getmad(o,first,'O');
4104 if (first->op_type == OP_CONST) {
4105 if (first->op_private & OPpCONST_STRICT)
4106 no_bareword_allowed(first);
4107 else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
4108 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
4109 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
4110 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
4111 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
4113 if (other->op_type == OP_CONST)
4114 other->op_private |= OPpCONST_SHORTCIRCUIT;
4116 OP *newop = newUNOP(OP_NULL, 0, other);
4117 op_getmad(first, newop, '1');
4118 newop->op_targ = type; /* set "was" field */
4125 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
4126 const OP *o2 = other;
4127 if ( ! (o2->op_type == OP_LIST
4128 && (( o2 = cUNOPx(o2)->op_first))
4129 && o2->op_type == OP_PUSHMARK
4130 && (( o2 = o2->op_sibling)) )
4133 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
4134 || o2->op_type == OP_PADHV)
4135 && o2->op_private & OPpLVAL_INTRO
4136 && ckWARN(WARN_DEPRECATED))
4138 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4139 "Deprecated use of my() in false conditional");
4143 if (first->op_type == OP_CONST)
4144 first->op_private |= OPpCONST_SHORTCIRCUIT;
4146 first = newUNOP(OP_NULL, 0, first);
4147 op_getmad(other, first, '2');
4148 first->op_targ = type; /* set "was" field */
4155 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
4156 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
4158 const OP * const k1 = ((UNOP*)first)->op_first;
4159 const OP * const k2 = k1->op_sibling;
4161 switch (first->op_type)
4164 if (k2 && k2->op_type == OP_READLINE
4165 && (k2->op_flags & OPf_STACKED)
4166 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4168 warnop = k2->op_type;
4173 if (k1->op_type == OP_READDIR
4174 || k1->op_type == OP_GLOB
4175 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4176 || k1->op_type == OP_EACH)
4178 warnop = ((k1->op_type == OP_NULL)
4179 ? (OPCODE)k1->op_targ : k1->op_type);
4184 const line_t oldline = CopLINE(PL_curcop);
4185 CopLINE_set(PL_curcop, PL_copline);
4186 Perl_warner(aTHX_ packWARN(WARN_MISC),
4187 "Value of %s%s can be \"0\"; test with defined()",
4189 ((warnop == OP_READLINE || warnop == OP_GLOB)
4190 ? " construct" : "() operator"));
4191 CopLINE_set(PL_curcop, oldline);
4198 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
4199 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
4201 NewOp(1101, logop, 1, LOGOP);
4203 logop->op_type = (OPCODE)type;
4204 logop->op_ppaddr = PL_ppaddr[type];
4205 logop->op_first = first;
4206 logop->op_flags = (U8)(flags | OPf_KIDS);
4207 logop->op_other = LINKLIST(other);
4208 logop->op_private = (U8)(1 | (flags >> 8));
4210 /* establish postfix order */
4211 logop->op_next = LINKLIST(first);
4212 first->op_next = (OP*)logop;
4213 first->op_sibling = other;
4215 CHECKOP(type,logop);
4217 o = newUNOP(OP_NULL, 0, (OP*)logop);
4224 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
4232 return newLOGOP(OP_AND, 0, first, trueop);
4234 return newLOGOP(OP_OR, 0, first, falseop);
4236 scalarboolean(first);
4237 if (first->op_type == OP_CONST) {
4238 if (first->op_private & OPpCONST_BARE &&
4239 first->op_private & OPpCONST_STRICT) {
4240 no_bareword_allowed(first);
4242 if (SvTRUE(((SVOP*)first)->op_sv)) {
4245 trueop = newUNOP(OP_NULL, 0, trueop);
4246 op_getmad(first,trueop,'C');
4247 op_getmad(falseop,trueop,'e');
4249 /* FIXME for MAD - should there be an ELSE here? */
4259 falseop = newUNOP(OP_NULL, 0, falseop);
4260 op_getmad(first,falseop,'C');
4261 op_getmad(trueop,falseop,'t');
4263 /* FIXME for MAD - should there be an ELSE here? */
4271 NewOp(1101, logop, 1, LOGOP);
4272 logop->op_type = OP_COND_EXPR;
4273 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4274 logop->op_first = first;
4275 logop->op_flags = (U8)(flags | OPf_KIDS);
4276 logop->op_private = (U8)(1 | (flags >> 8));
4277 logop->op_other = LINKLIST(trueop);
4278 logop->op_next = LINKLIST(falseop);
4280 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
4283 /* establish postfix order */
4284 start = LINKLIST(first);
4285 first->op_next = (OP*)logop;
4287 first->op_sibling = trueop;
4288 trueop->op_sibling = falseop;
4289 o = newUNOP(OP_NULL, 0, (OP*)logop);
4291 trueop->op_next = falseop->op_next = o;
4298 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4307 NewOp(1101, range, 1, LOGOP);
4309 range->op_type = OP_RANGE;
4310 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4311 range->op_first = left;
4312 range->op_flags = OPf_KIDS;
4313 leftstart = LINKLIST(left);
4314 range->op_other = LINKLIST(right);
4315 range->op_private = (U8)(1 | (flags >> 8));
4317 left->op_sibling = right;
4319 range->op_next = (OP*)range;
4320 flip = newUNOP(OP_FLIP, flags, (OP*)range);
4321 flop = newUNOP(OP_FLOP, 0, flip);
4322 o = newUNOP(OP_NULL, 0, flop);
4324 range->op_next = leftstart;
4326 left->op_next = flip;
4327 right->op_next = flop;
4329 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4330 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4331 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4332 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4334 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4335 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4338 if (!flip->op_private || !flop->op_private)
4339 linklist(o); /* blow off optimizer unless constant */
4345 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4350 const bool once = block && block->op_flags & OPf_SPECIAL &&
4351 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4353 PERL_UNUSED_ARG(debuggable);
4356 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4357 return block; /* do {} while 0 does once */
4358 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4359 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4360 expr = newUNOP(OP_DEFINED, 0,
4361 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4362 } else if (expr->op_flags & OPf_KIDS) {
4363 const OP * const k1 = ((UNOP*)expr)->op_first;
4364 const OP * const k2 = k1 ? k1->op_sibling : NULL;
4365 switch (expr->op_type) {
4367 if (k2 && k2->op_type == OP_READLINE
4368 && (k2->op_flags & OPf_STACKED)
4369 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4370 expr = newUNOP(OP_DEFINED, 0, expr);
4374 if (k1 && (k1->op_type == OP_READDIR
4375 || k1->op_type == OP_GLOB
4376 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4377 || k1->op_type == OP_EACH))
4378 expr = newUNOP(OP_DEFINED, 0, expr);
4384 /* if block is null, the next append_elem() would put UNSTACK, a scalar
4385 * op, in listop. This is wrong. [perl #27024] */
4387 block = newOP(OP_NULL, 0);
4388 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4389 o = new_logop(OP_AND, 0, &expr, &listop);
4392 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4394 if (once && o != listop)
4395 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4398 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
4400 o->op_flags |= flags;
4402 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4407 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
4408 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
4417 PERL_UNUSED_ARG(debuggable);
4420 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4421 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4422 expr = newUNOP(OP_DEFINED, 0,
4423 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4424 } else if (expr->op_flags & OPf_KIDS) {
4425 const OP * const k1 = ((UNOP*)expr)->op_first;
4426 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
4427 switch (expr->op_type) {
4429 if (k2 && k2->op_type == OP_READLINE
4430 && (k2->op_flags & OPf_STACKED)
4431 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4432 expr = newUNOP(OP_DEFINED, 0, expr);
4436 if (k1 && (k1->op_type == OP_READDIR
4437 || k1->op_type == OP_GLOB
4438 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4439 || k1->op_type == OP_EACH))
4440 expr = newUNOP(OP_DEFINED, 0, expr);
4447 block = newOP(OP_NULL, 0);
4448 else if (cont || has_my) {
4449 block = scope(block);
4453 next = LINKLIST(cont);
4456 OP * const unstack = newOP(OP_UNSTACK, 0);
4459 cont = append_elem(OP_LINESEQ, cont, unstack);
4463 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4465 redo = LINKLIST(listop);
4468 PL_copline = (line_t)whileline;
4470 o = new_logop(OP_AND, 0, &expr, &listop);
4471 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4472 op_free(expr); /* oops, it's a while (0) */
4474 return NULL; /* listop already freed by new_logop */
4477 ((LISTOP*)listop)->op_last->op_next =
4478 (o == listop ? redo : LINKLIST(o));
4484 NewOp(1101,loop,1,LOOP);
4485 loop->op_type = OP_ENTERLOOP;
4486 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4487 loop->op_private = 0;
4488 loop->op_next = (OP*)loop;
4491 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4493 loop->op_redoop = redo;
4494 loop->op_lastop = o;
4495 o->op_private |= loopflags;
4498 loop->op_nextop = next;
4500 loop->op_nextop = o;
4502 o->op_flags |= flags;
4503 o->op_private |= (flags >> 8);
4508 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
4513 PADOFFSET padoff = 0;
4519 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4520 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
4521 sv->op_type = OP_RV2GV;
4522 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4523 if (cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
4524 iterpflags |= OPpITER_DEF;
4526 else if (sv->op_type == OP_PADSV) { /* private variable */
4527 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
4528 padoff = sv->op_targ;
4538 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4540 SV *const namesv = PAD_COMPNAME_SV(padoff);
4542 const char *const name = SvPV_const(namesv, len);
4544 if (len == 2 && name[0] == '$' && name[1] == '_')
4545 iterpflags |= OPpITER_DEF;
4549 const PADOFFSET offset = pad_findmy("$_");
4550 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
4551 sv = newGVOP(OP_GV, 0, PL_defgv);
4556 iterpflags |= OPpITER_DEF;
4558 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4559 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4560 iterflags |= OPf_STACKED;
4562 else if (expr->op_type == OP_NULL &&
4563 (expr->op_flags & OPf_KIDS) &&
4564 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4566 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4567 * set the STACKED flag to indicate that these values are to be
4568 * treated as min/max values by 'pp_iterinit'.
4570 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4571 LOGOP* const range = (LOGOP*) flip->op_first;
4572 OP* const left = range->op_first;
4573 OP* const right = left->op_sibling;
4576 range->op_flags &= ~OPf_KIDS;
4577 range->op_first = NULL;
4579 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4580 listop->op_first->op_next = range->op_next;
4581 left->op_next = range->op_other;
4582 right->op_next = (OP*)listop;
4583 listop->op_next = listop->op_first;
4586 op_getmad(expr,(OP*)listop,'O');
4590 expr = (OP*)(listop);
4592 iterflags |= OPf_STACKED;
4595 expr = mod(force_list(expr), OP_GREPSTART);
4598 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4599 append_elem(OP_LIST, expr, scalar(sv))));
4600 assert(!loop->op_next);
4601 /* for my $x () sets OPpLVAL_INTRO;
4602 * for our $x () sets OPpOUR_INTRO */
4603 loop->op_private = (U8)iterpflags;
4604 #ifdef PL_OP_SLAB_ALLOC
4607 NewOp(1234,tmp,1,LOOP);
4608 Copy(loop,tmp,1,LISTOP);
4609 S_op_destroy(aTHX_ (OP*)loop);
4613 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
4615 loop->op_targ = padoff;
4616 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
4618 op_getmad(madsv, (OP*)loop, 'v');
4619 PL_copline = forline;
4620 return newSTATEOP(0, label, wop);
4624 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4629 if (type != OP_GOTO || label->op_type == OP_CONST) {
4630 /* "last()" means "last" */
4631 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4632 o = newOP(type, OPf_SPECIAL);
4634 o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
4635 ? SvPVx_nolen_const(((SVOP*)label)->op_sv)
4639 op_getmad(label,o,'L');
4645 /* Check whether it's going to be a goto &function */
4646 if (label->op_type == OP_ENTERSUB
4647 && !(label->op_flags & OPf_STACKED))
4648 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4649 o = newUNOP(type, OPf_STACKED, label);
4651 PL_hints |= HINT_BLOCK_SCOPE;
4655 /* if the condition is a literal array or hash
4656 (or @{ ... } etc), make a reference to it.
4659 S_ref_array_or_hash(pTHX_ OP *cond)
4662 && (cond->op_type == OP_RV2AV
4663 || cond->op_type == OP_PADAV
4664 || cond->op_type == OP_RV2HV
4665 || cond->op_type == OP_PADHV))
4667 return newUNOP(OP_REFGEN,
4668 0, mod(cond, OP_REFGEN));
4674 /* These construct the optree fragments representing given()
4677 entergiven and enterwhen are LOGOPs; the op_other pointer
4678 points up to the associated leave op. We need this so we
4679 can put it in the context and make break/continue work.
4680 (Also, of course, pp_enterwhen will jump straight to
4681 op_other if the match fails.)
4686 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
4687 I32 enter_opcode, I32 leave_opcode,
4688 PADOFFSET entertarg)
4694 NewOp(1101, enterop, 1, LOGOP);
4695 enterop->op_type = enter_opcode;
4696 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
4697 enterop->op_flags = (U8) OPf_KIDS;
4698 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
4699 enterop->op_private = 0;
4701 o = newUNOP(leave_opcode, 0, (OP *) enterop);
4704 enterop->op_first = scalar(cond);
4705 cond->op_sibling = block;
4707 o->op_next = LINKLIST(cond);
4708 cond->op_next = (OP *) enterop;
4711 /* This is a default {} block */
4712 enterop->op_first = block;
4713 enterop->op_flags |= OPf_SPECIAL;
4715 o->op_next = (OP *) enterop;
4718 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
4719 entergiven and enterwhen both
4722 enterop->op_next = LINKLIST(block);
4723 block->op_next = enterop->op_other = o;
4728 /* Does this look like a boolean operation? For these purposes
4729 a boolean operation is:
4730 - a subroutine call [*]
4731 - a logical connective
4732 - a comparison operator
4733 - a filetest operator, with the exception of -s -M -A -C
4734 - defined(), exists() or eof()
4735 - /$re/ or $foo =~ /$re/
4737 [*] possibly surprising
4741 S_looks_like_bool(pTHX_ const OP *o)
4744 switch(o->op_type) {
4746 return looks_like_bool(cLOGOPo->op_first);
4750 looks_like_bool(cLOGOPo->op_first)
4751 && looks_like_bool(cLOGOPo->op_first->op_sibling));
4755 case OP_NOT: case OP_XOR:
4756 /* Note that OP_DOR is not here */
4758 case OP_EQ: case OP_NE: case OP_LT:
4759 case OP_GT: case OP_LE: case OP_GE:
4761 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
4762 case OP_I_GT: case OP_I_LE: case OP_I_GE:
4764 case OP_SEQ: case OP_SNE: case OP_SLT:
4765 case OP_SGT: case OP_SLE: case OP_SGE:
4769 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
4770 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
4771 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
4772 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
4773 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
4774 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
4775 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
4776 case OP_FTTEXT: case OP_FTBINARY:
4778 case OP_DEFINED: case OP_EXISTS:
4779 case OP_MATCH: case OP_EOF:
4784 /* Detect comparisons that have been optimized away */
4785 if (cSVOPo->op_sv == &PL_sv_yes
4786 || cSVOPo->op_sv == &PL_sv_no)
4797 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
4801 return newGIVWHENOP(
4802 ref_array_or_hash(cond),
4804 OP_ENTERGIVEN, OP_LEAVEGIVEN,
4808 /* If cond is null, this is a default {} block */
4810 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
4812 const bool cond_llb = (!cond || looks_like_bool(cond));
4818 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
4820 scalar(ref_array_or_hash(cond)));
4823 return newGIVWHENOP(
4825 append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
4826 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
4830 =for apidoc cv_undef
4832 Clear out all the active components of a CV. This can happen either
4833 by an explicit C<undef &foo>, or by the reference count going to zero.
4834 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
4835 children can still follow the full lexical scope chain.
4841 Perl_cv_undef(pTHX_ CV *cv)
4845 if (CvFILE(cv) && !CvISXSUB(cv)) {
4846 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4847 Safefree(CvFILE(cv));
4852 if (!CvISXSUB(cv) && CvROOT(cv)) {
4853 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
4854 Perl_croak(aTHX_ "Can't undef active subroutine");
4857 PAD_SAVE_SETNULLPAD();
4859 op_free(CvROOT(cv));
4864 SvPOK_off((SV*)cv); /* forget prototype */
4869 /* remove CvOUTSIDE unless this is an undef rather than a free */
4870 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
4871 if (!CvWEAKOUTSIDE(cv))
4872 SvREFCNT_dec(CvOUTSIDE(cv));
4873 CvOUTSIDE(cv) = NULL;
4876 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4879 if (CvISXSUB(cv) && CvXSUB(cv)) {
4882 /* delete all flags except WEAKOUTSIDE */
4883 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
4887 Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
4890 /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
4891 relying on SvCUR, and doubling up the buffer to hold CvFILE(). */
4892 if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
4893 || (p && (len != SvCUR(cv) /* Not the same length. */
4894 || memNE(p, SvPVX_const(cv), len))))
4895 && ckWARN_d(WARN_PROTOTYPE)) {
4896 SV* const msg = sv_newmortal();
4900 gv_efullname3(name = sv_newmortal(), gv, NULL);
4901 sv_setpv(msg, "Prototype mismatch:");
4903 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
4905 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv));
4907 sv_catpvs(msg, ": none");
4908 sv_catpvs(msg, " vs ");
4910 Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
4912 sv_catpvs(msg, "none");
4913 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
4917 static void const_sv_xsub(pTHX_ CV* cv);
4921 =head1 Optree Manipulation Functions
4923 =for apidoc cv_const_sv
4925 If C<cv> is a constant sub eligible for inlining. returns the constant
4926 value returned by the sub. Otherwise, returns NULL.
4928 Constant subs can be created with C<newCONSTSUB> or as described in
4929 L<perlsub/"Constant Functions">.
4934 Perl_cv_const_sv(pTHX_ CV *cv)
4936 PERL_UNUSED_CONTEXT;
4939 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
4941 return CvCONST(cv) ? (SV*)CvXSUBANY(cv).any_ptr : NULL;
4944 /* op_const_sv: examine an optree to determine whether it's in-lineable.
4945 * Can be called in 3 ways:
4948 * look for a single OP_CONST with attached value: return the value
4950 * cv && CvCLONE(cv) && !CvCONST(cv)
4952 * examine the clone prototype, and if contains only a single
4953 * OP_CONST referencing a pad const, or a single PADSV referencing
4954 * an outer lexical, return a non-zero value to indicate the CV is
4955 * a candidate for "constizing" at clone time
4959 * We have just cloned an anon prototype that was marked as a const
4960 * candidiate. Try to grab the current value, and in the case of
4961 * PADSV, ignore it if it has multiple references. Return the value.
4965 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
4973 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4974 o = cLISTOPo->op_first->op_sibling;
4976 for (; o; o = o->op_next) {
4977 const OPCODE type = o->op_type;
4979 if (sv && o->op_next == o)
4981 if (o->op_next != o) {
4982 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4984 if (type == OP_DBSTATE)
4987 if (type == OP_LEAVESUB || type == OP_RETURN)
4991 if (type == OP_CONST && cSVOPo->op_sv)
4993 else if (cv && type == OP_CONST) {
4994 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4998 else if (cv && type == OP_PADSV) {
4999 if (CvCONST(cv)) { /* newly cloned anon */
5000 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5001 /* the candidate should have 1 ref from this pad and 1 ref
5002 * from the parent */
5003 if (!sv || SvREFCNT(sv) != 2)
5010 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
5011 sv = &PL_sv_undef; /* an arbitrary non-null value */
5026 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5029 /* This would be the return value, but the return cannot be reached. */
5030 OP* pegop = newOP(OP_NULL, 0);
5033 PERL_UNUSED_ARG(floor);
5043 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
5045 NORETURN_FUNCTION_END;
5050 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
5052 return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
5056 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5063 register CV *cv = NULL;
5065 /* If the subroutine has no body, no attributes, and no builtin attributes
5066 then it's just a sub declaration, and we may be able to get away with
5067 storing with a placeholder scalar in the symbol table, rather than a
5068 full GV and CV. If anything is present then it will take a full CV to
5070 const I32 gv_fetch_flags
5071 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5073 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
5074 const char * const name = o ? SvPVx_nolen_const(cSVOPo->op_sv) : NULL;
5077 assert(proto->op_type == OP_CONST);
5078 ps = SvPVx_const(((SVOP*)proto)->op_sv, ps_len);
5083 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
5084 SV * const sv = sv_newmortal();
5085 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
5086 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
5087 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
5088 aname = SvPVX_const(sv);
5093 gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
5094 : gv_fetchpv(aname ? aname
5095 : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5096 gv_fetch_flags, SVt_PVCV);
5098 if (!PL_madskills) {
5107 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
5108 maximum a prototype before. */
5109 if (SvTYPE(gv) > SVt_NULL) {
5110 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
5111 && ckWARN_d(WARN_PROTOTYPE))
5113 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
5115 cv_ckproto_len((CV*)gv, NULL, ps, ps_len);
5118 sv_setpvn((SV*)gv, ps, ps_len);
5120 sv_setiv((SV*)gv, -1);
5121 SvREFCNT_dec(PL_compcv);
5122 cv = PL_compcv = NULL;
5123 PL_sub_generation++;
5127 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
5129 #ifdef GV_UNIQUE_CHECK
5130 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
5131 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
5135 if (!block || !ps || *ps || attrs
5136 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5138 || block->op_type == OP_NULL
5143 const_sv = op_const_sv(block, NULL);
5146 const bool exists = CvROOT(cv) || CvXSUB(cv);
5148 #ifdef GV_UNIQUE_CHECK
5149 if (exists && GvUNIQUE(gv)) {
5150 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
5154 /* if the subroutine doesn't exist and wasn't pre-declared
5155 * with a prototype, assume it will be AUTOLOADed,
5156 * skipping the prototype check
5158 if (exists || SvPOK(cv))
5159 cv_ckproto_len(cv, gv, ps, ps_len);
5160 /* already defined (or promised)? */
5161 if (exists || GvASSUMECV(gv)) {
5164 || block->op_type == OP_NULL
5167 if (CvFLAGS(PL_compcv)) {
5168 /* might have had built-in attrs applied */
5169 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5171 /* just a "sub foo;" when &foo is already defined */
5172 SAVEFREESV(PL_compcv);
5177 && block->op_type != OP_NULL
5180 if (ckWARN(WARN_REDEFINE)
5182 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
5184 const line_t oldline = CopLINE(PL_curcop);
5185 if (PL_copline != NOLINE)
5186 CopLINE_set(PL_curcop, PL_copline);
5187 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5188 CvCONST(cv) ? "Constant subroutine %s redefined"
5189 : "Subroutine %s redefined", name);
5190 CopLINE_set(PL_curcop, oldline);
5193 if (!PL_minus_c) /* keep old one around for madskills */
5196 /* (PL_madskills unset in used file.) */
5204 SvREFCNT_inc_simple_void_NN(const_sv);
5206 assert(!CvROOT(cv) && !CvCONST(cv));
5207 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
5208 CvXSUBANY(cv).any_ptr = const_sv;
5209 CvXSUB(cv) = const_sv_xsub;
5215 cv = newCONSTSUB(NULL, name, const_sv);
5217 PL_sub_generation++;
5221 SvREFCNT_dec(PL_compcv);
5229 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
5230 * before we clobber PL_compcv.
5234 || block->op_type == OP_NULL
5238 /* Might have had built-in attributes applied -- propagate them. */
5239 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5240 if (CvGV(cv) && GvSTASH(CvGV(cv)))
5241 stash = GvSTASH(CvGV(cv));
5242 else if (CvSTASH(cv))
5243 stash = CvSTASH(cv);
5245 stash = PL_curstash;
5248 /* possibly about to re-define existing subr -- ignore old cv */
5249 rcv = (SV*)PL_compcv;
5250 if (name && GvSTASH(gv))
5251 stash = GvSTASH(gv);
5253 stash = PL_curstash;
5255 apply_attrs(stash, rcv, attrs, FALSE);
5257 if (cv) { /* must reuse cv if autoloaded */
5264 || block->op_type == OP_NULL) && !PL_madskills
5267 /* got here with just attrs -- work done, so bug out */
5268 SAVEFREESV(PL_compcv);
5271 /* transfer PL_compcv to cv */
5273 CvFLAGS(cv) = CvFLAGS(PL_compcv);
5274 if (!CvWEAKOUTSIDE(cv))
5275 SvREFCNT_dec(CvOUTSIDE(cv));
5276 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
5277 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
5278 CvOUTSIDE(PL_compcv) = 0;
5279 CvPADLIST(cv) = CvPADLIST(PL_compcv);
5280 CvPADLIST(PL_compcv) = 0;
5281 /* inner references to PL_compcv must be fixed up ... */
5282 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
5283 /* ... before we throw it away */
5284 SvREFCNT_dec(PL_compcv);
5286 if (PERLDB_INTER)/* Advice debugger on the new sub. */
5287 ++PL_sub_generation;
5294 if (strEQ(name, "import")) {
5295 PL_formfeed = (SV*)cv;
5296 Perl_warner(aTHX_ packWARN(WARN_VOID), "%lx\n", (long)cv);
5300 PL_sub_generation++;
5304 CvFILE_set_from_cop(cv, PL_curcop);
5305 CvSTASH(cv) = PL_curstash;
5308 sv_setpvn((SV*)cv, ps, ps_len);
5310 if (PL_error_count) {
5314 const char *s = strrchr(name, ':');
5316 if (strEQ(s, "BEGIN")) {
5317 const char not_safe[] =
5318 "BEGIN not safe after errors--compilation aborted";
5319 if (PL_in_eval & EVAL_KEEPERR)
5320 Perl_croak(aTHX_ not_safe);
5322 /* force display of errors found but not reported */
5323 sv_catpv(ERRSV, not_safe);
5324 Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
5334 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5335 mod(scalarseq(block), OP_LEAVESUBLV));
5336 block->op_attached = 1;
5339 /* This makes sub {}; work as expected. */
5340 if (block->op_type == OP_STUB) {
5341 OP* const newblock = newSTATEOP(0, NULL, 0);
5343 op_getmad(block,newblock,'B');
5350 block->op_attached = 1;
5351 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5353 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5354 OpREFCNT_set(CvROOT(cv), 1);
5355 CvSTART(cv) = LINKLIST(CvROOT(cv));
5356 CvROOT(cv)->op_next = 0;
5357 CALL_PEEP(CvSTART(cv));
5359 /* now that optimizer has done its work, adjust pad values */
5361 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
5364 assert(!CvCONST(cv));
5365 if (ps && !*ps && op_const_sv(block, cv))
5369 if (name || aname) {
5371 const char * const tname = (name ? name : aname);
5373 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5374 SV * const sv = newSV(0);
5375 SV * const tmpstr = sv_newmortal();
5376 GV * const db_postponed = gv_fetchpvs("DB::postponed",
5377 GV_ADDMULTI, SVt_PVHV);
5380 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5382 (long)PL_subline, (long)CopLINE(PL_curcop));
5383 gv_efullname3(tmpstr, gv, NULL);
5384 hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0);
5385 hv = GvHVn(db_postponed);
5386 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
5387 CV * const pcv = GvCV(db_postponed);
5393 call_sv((SV*)pcv, G_DISCARD);
5398 if ((s = strrchr(tname,':')))
5403 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I' && *s != 'U')
5406 if (strEQ(s, "BEGIN") && !PL_error_count) {
5407 const I32 oldscope = PL_scopestack_ix;
5409 SAVECOPFILE(&PL_compiling);
5410 SAVECOPLINE(&PL_compiling);
5413 PL_beginav = newAV();
5414 DEBUG_x( dump_sub(gv) );
5415 av_push(PL_beginav, (SV*)cv);
5416 GvCV(gv) = 0; /* cv has been hijacked */
5417 call_list(oldscope, PL_beginav);
5419 PL_curcop = &PL_compiling;
5420 CopHINTS_set(&PL_compiling, PL_hints);
5423 else if (strEQ(s, "END") && !PL_error_count) {
5426 DEBUG_x( dump_sub(gv) );
5427 av_unshift(PL_endav, 1);
5428 av_store(PL_endav, 0, (SV*)cv);
5429 GvCV(gv) = 0; /* cv has been hijacked */
5431 else if (strEQ(s, "UNITCHECK") && !PL_error_count) {
5432 /* It's never too late to run a unitcheck block */
5433 if (!PL_unitcheckav)
5434 PL_unitcheckav = newAV();
5435 DEBUG_x( dump_sub(gv) );
5436 av_unshift(PL_unitcheckav, 1);
5437 av_store(PL_unitcheckav, 0, (SV*)cv);
5438 GvCV(gv) = 0; /* cv has been hijacked */
5440 else if (strEQ(s, "CHECK") && !PL_error_count) {
5442 PL_checkav = newAV();
5443 DEBUG_x( dump_sub(gv) );
5444 if (PL_main_start && ckWARN(WARN_VOID))
5445 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
5446 av_unshift(PL_checkav, 1);
5447 av_store(PL_checkav, 0, (SV*)cv);
5448 GvCV(gv) = 0; /* cv has been hijacked */
5450 else if (strEQ(s, "INIT") && !PL_error_count) {
5452 PL_initav = newAV();
5453 DEBUG_x( dump_sub(gv) );
5454 if (PL_main_start && ckWARN(WARN_VOID))
5455 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
5456 av_push(PL_initav, (SV*)cv);
5457 GvCV(gv) = 0; /* cv has been hijacked */
5462 PL_copline = NOLINE;
5467 /* XXX unsafe for threads if eval_owner isn't held */
5469 =for apidoc newCONSTSUB
5471 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5472 eligible for inlining at compile-time.
5478 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
5483 const char *const temp_p = CopFILE(PL_curcop);
5484 const STRLEN len = temp_p ? strlen(temp_p) : 0;
5486 SV *const temp_sv = CopFILESV(PL_curcop);
5488 const char *const temp_p = temp_sv ? SvPV_const(temp_sv, len) : NULL;
5490 char *const file = savepvn(temp_p, temp_p ? len : 0);
5494 SAVECOPLINE(PL_curcop);
5495 CopLINE_set(PL_curcop, PL_copline);
5498 PL_hints &= ~HINT_BLOCK_SCOPE;
5501 SAVESPTR(PL_curstash);
5502 SAVECOPSTASH(PL_curcop);
5503 PL_curstash = stash;
5504 CopSTASH_set(PL_curcop,stash);
5507 /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
5508 and so doesn't get free()d. (It's expected to be from the C pre-
5509 processor __FILE__ directive). But we need a dynamically allocated one,
5510 and we need it to get freed. */
5511 cv = newXS_flags(name, const_sv_xsub, file, "", XS_DYNAMIC_FILENAME);
5512 CvXSUBANY(cv).any_ptr = sv;
5518 CopSTASH_free(PL_curcop);
5526 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
5527 const char *const filename, const char *const proto,
5530 CV *cv = newXS(name, subaddr, filename);
5532 if (flags & XS_DYNAMIC_FILENAME) {
5533 /* We need to "make arrangements" (ie cheat) to ensure that the
5534 filename lasts as long as the PVCV we just created, but also doesn't
5536 STRLEN filename_len = strlen(filename);
5537 STRLEN proto_and_file_len = filename_len;
5538 char *proto_and_file;
5542 proto_len = strlen(proto);
5543 proto_and_file_len += proto_len;
5545 Newx(proto_and_file, proto_and_file_len + 1, char);
5546 Copy(proto, proto_and_file, proto_len, char);
5547 Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
5550 proto_and_file = savepvn(filename, filename_len);
5553 /* This gets free()d. :-) */
5554 sv_usepvn_flags((SV*)cv, proto_and_file, proto_and_file_len,
5555 SV_HAS_TRAILING_NUL);
5557 /* This gives us the correct prototype, rather than one with the
5558 file name appended. */
5559 SvCUR_set(cv, proto_len);
5563 CvFILE(cv) = proto_and_file + proto_len;
5565 sv_setpv((SV *)cv, proto);
5571 =for apidoc U||newXS
5573 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
5574 static storage, as it is used directly as CvFILE(), without a copy being made.
5580 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
5583 GV * const gv = gv_fetchpv(name ? name :
5584 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5585 GV_ADDMULTI, SVt_PVCV);
5589 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
5591 if ((cv = (name ? GvCV(gv) : NULL))) {
5593 /* just a cached method */
5597 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5598 /* already defined (or promised) */
5599 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
5600 if (ckWARN(WARN_REDEFINE)) {
5601 GV * const gvcv = CvGV(cv);
5603 HV * const stash = GvSTASH(gvcv);
5605 const char *redefined_name = HvNAME_get(stash);
5606 if ( strEQ(redefined_name,"autouse") ) {
5607 const line_t oldline = CopLINE(PL_curcop);
5608 if (PL_copline != NOLINE)
5609 CopLINE_set(PL_curcop, PL_copline);
5610 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5611 CvCONST(cv) ? "Constant subroutine %s redefined"
5612 : "Subroutine %s redefined"
5614 CopLINE_set(PL_curcop, oldline);
5624 if (cv) /* must reuse cv if autoloaded */
5628 sv_upgrade((SV *)cv, SVt_PVCV);
5632 PL_sub_generation++;
5636 (void)gv_fetchfile(filename);
5637 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
5638 an external constant string */
5640 CvXSUB(cv) = subaddr;
5643 const char *s = strrchr(name,':');
5649 if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5652 if (strEQ(s, "BEGIN")) {
5654 PL_beginav = newAV();
5655 av_push(PL_beginav, (SV*)cv);
5656 GvCV(gv) = 0; /* cv has been hijacked */
5658 else if (strEQ(s, "END")) {
5661 av_unshift(PL_endav, 1);
5662 av_store(PL_endav, 0, (SV*)cv);
5663 GvCV(gv) = 0; /* cv has been hijacked */
5665 else if (strEQ(s, "CHECK")) {
5667 PL_checkav = newAV();
5668 if (PL_main_start && ckWARN(WARN_VOID))
5669 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
5670 av_unshift(PL_checkav, 1);
5671 av_store(PL_checkav, 0, (SV*)cv);
5672 GvCV(gv) = 0; /* cv has been hijacked */
5674 else if (strEQ(s, "INIT")) {
5676 PL_initav = newAV();
5677 if (PL_main_start && ckWARN(WARN_VOID))
5678 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
5679 av_push(PL_initav, (SV*)cv);
5680 GvCV(gv) = 0; /* cv has been hijacked */
5695 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5700 OP* pegop = newOP(OP_NULL, 0);
5704 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
5705 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
5707 #ifdef GV_UNIQUE_CHECK
5709 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5713 if ((cv = GvFORM(gv))) {
5714 if (ckWARN(WARN_REDEFINE)) {
5715 const line_t oldline = CopLINE(PL_curcop);
5716 if (PL_copline != NOLINE)
5717 CopLINE_set(PL_curcop, PL_copline);
5718 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5719 o ? "Format %"SVf" redefined"
5720 : "Format STDOUT redefined", SVfARG(cSVOPo->op_sv));
5721 CopLINE_set(PL_curcop, oldline);
5728 CvFILE_set_from_cop(cv, PL_curcop);
5731 pad_tidy(padtidy_FORMAT);
5732 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5733 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5734 OpREFCNT_set(CvROOT(cv), 1);
5735 CvSTART(cv) = LINKLIST(CvROOT(cv));
5736 CvROOT(cv)->op_next = 0;
5737 CALL_PEEP(CvSTART(cv));
5739 op_getmad(o,pegop,'n');
5740 op_getmad_weak(block, pegop, 'b');
5744 PL_copline = NOLINE;
5752 Perl_newANONLIST(pTHX_ OP *o)
5754 return convert(OP_ANONLIST, OPf_SPECIAL, o);
5758 Perl_newANONHASH(pTHX_ OP *o)
5760 return convert(OP_ANONHASH, OPf_SPECIAL, o);
5764 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5766 return newANONATTRSUB(floor, proto, NULL, block);
5770 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5772 return newUNOP(OP_REFGEN, 0,
5773 newSVOP(OP_ANONCODE, 0,
5774 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5778 Perl_oopsAV(pTHX_ OP *o)
5781 switch (o->op_type) {
5783 o->op_type = OP_PADAV;
5784 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5785 return ref(o, OP_RV2AV);
5788 o->op_type = OP_RV2AV;
5789 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5794 if (ckWARN_d(WARN_INTERNAL))
5795 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
5802 Perl_oopsHV(pTHX_ OP *o)
5805 switch (o->op_type) {
5808 o->op_type = OP_PADHV;
5809 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5810 return ref(o, OP_RV2HV);
5814 o->op_type = OP_RV2HV;
5815 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5820 if (ckWARN_d(WARN_INTERNAL))
5821 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
5828 Perl_newAVREF(pTHX_ OP *o)
5831 if (o->op_type == OP_PADANY) {
5832 o->op_type = OP_PADAV;
5833 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5836 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5837 && ckWARN(WARN_DEPRECATED)) {
5838 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5839 "Using an array as a reference is deprecated");
5841 return newUNOP(OP_RV2AV, 0, scalar(o));
5845 Perl_newGVREF(pTHX_ I32 type, OP *o)
5847 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5848 return newUNOP(OP_NULL, 0, o);
5849 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5853 Perl_newHVREF(pTHX_ OP *o)
5856 if (o->op_type == OP_PADANY) {
5857 o->op_type = OP_PADHV;
5858 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5861 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5862 && ckWARN(WARN_DEPRECATED)) {
5863 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5864 "Using a hash as a reference is deprecated");
5866 return newUNOP(OP_RV2HV, 0, scalar(o));
5870 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5872 return newUNOP(OP_RV2CV, flags, scalar(o));
5876 Perl_newSVREF(pTHX_ OP *o)
5879 if (o->op_type == OP_PADANY) {
5880 o->op_type = OP_PADSV;
5881 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5884 return newUNOP(OP_RV2SV, 0, scalar(o));
5887 /* Check routines. See the comments at the top of this file for details
5888 * on when these are called */
5891 Perl_ck_anoncode(pTHX_ OP *o)
5893 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
5895 cSVOPo->op_sv = NULL;
5900 Perl_ck_bitop(pTHX_ OP *o)
5903 #define OP_IS_NUMCOMPARE(op) \
5904 ((op) == OP_LT || (op) == OP_I_LT || \
5905 (op) == OP_GT || (op) == OP_I_GT || \
5906 (op) == OP_LE || (op) == OP_I_LE || \
5907 (op) == OP_GE || (op) == OP_I_GE || \
5908 (op) == OP_EQ || (op) == OP_I_EQ || \
5909 (op) == OP_NE || (op) == OP_I_NE || \
5910 (op) == OP_NCMP || (op) == OP_I_NCMP)
5911 o->op_private = (U8)(PL_hints & HINT_INTEGER);
5912 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
5913 && (o->op_type == OP_BIT_OR
5914 || o->op_type == OP_BIT_AND
5915 || o->op_type == OP_BIT_XOR))
5917 const OP * const left = cBINOPo->op_first;
5918 const OP * const right = left->op_sibling;
5919 if ((OP_IS_NUMCOMPARE(left->op_type) &&
5920 (left->op_flags & OPf_PARENS) == 0) ||
5921 (OP_IS_NUMCOMPARE(right->op_type) &&
5922 (right->op_flags & OPf_PARENS) == 0))
5923 if (ckWARN(WARN_PRECEDENCE))
5924 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
5925 "Possible precedence problem on bitwise %c operator",
5926 o->op_type == OP_BIT_OR ? '|'
5927 : o->op_type == OP_BIT_AND ? '&' : '^'
5934 Perl_ck_concat(pTHX_ OP *o)
5936 const OP * const kid = cUNOPo->op_first;
5937 PERL_UNUSED_CONTEXT;
5938 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
5939 !(kUNOP->op_first->op_flags & OPf_MOD))
5940 o->op_flags |= OPf_STACKED;
5945 Perl_ck_spair(pTHX_ OP *o)
5948 if (o->op_flags & OPf_KIDS) {
5951 const OPCODE type = o->op_type;
5952 o = modkids(ck_fun(o), type);
5953 kid = cUNOPo->op_first;
5954 newop = kUNOP->op_first->op_sibling;
5956 const OPCODE type = newop->op_type;
5957 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
5958 type == OP_PADAV || type == OP_PADHV ||
5959 type == OP_RV2AV || type == OP_RV2HV)
5963 op_getmad(kUNOP->op_first,newop,'K');
5965 op_free(kUNOP->op_first);
5967 kUNOP->op_first = newop;
5969 o->op_ppaddr = PL_ppaddr[++o->op_type];
5974 Perl_ck_delete(pTHX_ OP *o)
5978 if (o->op_flags & OPf_KIDS) {
5979 OP * const kid = cUNOPo->op_first;
5980 switch (kid->op_type) {
5982 o->op_flags |= OPf_SPECIAL;
5985 o->op_private |= OPpSLICE;
5988 o->op_flags |= OPf_SPECIAL;
5993 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
6002 Perl_ck_die(pTHX_ OP *o)
6005 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6011 Perl_ck_eof(pTHX_ OP *o)
6015 if (o->op_flags & OPf_KIDS) {
6016 if (cLISTOPo->op_first->op_type == OP_STUB) {
6018 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
6020 op_getmad(o,newop,'O');
6032 Perl_ck_eval(pTHX_ OP *o)
6035 PL_hints |= HINT_BLOCK_SCOPE;
6036 if (o->op_flags & OPf_KIDS) {
6037 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6040 o->op_flags &= ~OPf_KIDS;
6043 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
6049 cUNOPo->op_first = 0;
6054 NewOp(1101, enter, 1, LOGOP);
6055 enter->op_type = OP_ENTERTRY;
6056 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
6057 enter->op_private = 0;
6059 /* establish postfix order */
6060 enter->op_next = (OP*)enter;
6062 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
6063 o->op_type = OP_LEAVETRY;
6064 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
6065 enter->op_other = o;
6066 op_getmad(oldo,o,'O');
6080 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
6081 op_getmad(oldo,o,'O');
6083 o->op_targ = (PADOFFSET)PL_hints;
6084 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
6085 /* Store a copy of %^H that pp_entereval can pick up */
6086 OP *hhop = newSVOP(OP_CONST, 0,
6087 (SV*)Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv)));
6088 cUNOPo->op_first->op_sibling = hhop;
6089 o->op_private |= OPpEVAL_HAS_HH;
6095 Perl_ck_exit(pTHX_ OP *o)
6098 HV * const table = GvHV(PL_hintgv);
6100 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
6101 if (svp && *svp && SvTRUE(*svp))
6102 o->op_private |= OPpEXIT_VMSISH;
6104 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6110 Perl_ck_exec(pTHX_ OP *o)
6112 if (o->op_flags & OPf_STACKED) {
6115 kid = cUNOPo->op_first->op_sibling;
6116 if (kid->op_type == OP_RV2GV)
6125 Perl_ck_exists(pTHX_ OP *o)
6129 if (o->op_flags & OPf_KIDS) {
6130 OP * const kid = cUNOPo->op_first;
6131 if (kid->op_type == OP_ENTERSUB) {
6132 (void) ref(kid, o->op_type);
6133 if (kid->op_type != OP_RV2CV && !PL_error_count)
6134 Perl_croak(aTHX_ "%s argument is not a subroutine name",
6136 o->op_private |= OPpEXISTS_SUB;
6138 else if (kid->op_type == OP_AELEM)
6139 o->op_flags |= OPf_SPECIAL;
6140 else if (kid->op_type != OP_HELEM)
6141 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
6149 Perl_ck_rvconst(pTHX_ register OP *o)
6152 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6154 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6155 if (o->op_type == OP_RV2CV)
6156 o->op_private &= ~1;
6158 if (kid->op_type == OP_CONST) {
6161 SV * const kidsv = kid->op_sv;
6163 /* Is it a constant from cv_const_sv()? */
6164 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
6165 SV * const rsv = SvRV(kidsv);
6166 const svtype type = SvTYPE(rsv);
6167 const char *badtype = NULL;
6169 switch (o->op_type) {
6171 if (type > SVt_PVMG)
6172 badtype = "a SCALAR";
6175 if (type != SVt_PVAV)
6176 badtype = "an ARRAY";
6179 if (type != SVt_PVHV)
6183 if (type != SVt_PVCV)
6188 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
6191 else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
6192 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
6193 /* If this is an access to a stash, disable "strict refs", because
6194 * stashes aren't auto-vivified at compile-time (unless we store
6195 * symbols in them), and we don't want to produce a run-time
6196 * stricture error when auto-vivifying the stash. */
6197 const char *s = SvPV_nolen(kidsv);
6198 const STRLEN l = SvCUR(kidsv);
6199 if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
6200 o->op_private &= ~HINT_STRICT_REFS;
6202 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
6203 const char *badthing;
6204 switch (o->op_type) {
6206 badthing = "a SCALAR";
6209 badthing = "an ARRAY";
6212 badthing = "a HASH";
6220 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
6221 SVfARG(kidsv), badthing);
6224 * This is a little tricky. We only want to add the symbol if we
6225 * didn't add it in the lexer. Otherwise we get duplicate strict
6226 * warnings. But if we didn't add it in the lexer, we must at
6227 * least pretend like we wanted to add it even if it existed before,
6228 * or we get possible typo warnings. OPpCONST_ENTERED says
6229 * whether the lexer already added THIS instance of this symbol.
6231 iscv = (o->op_type == OP_RV2CV) * 2;
6233 gv = gv_fetchsv(kidsv,
6234 iscv | !(kid->op_private & OPpCONST_ENTERED),
6237 : o->op_type == OP_RV2SV
6239 : o->op_type == OP_RV2AV
6241 : o->op_type == OP_RV2HV
6244 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
6246 kid->op_type = OP_GV;
6247 SvREFCNT_dec(kid->op_sv);
6249 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
6250 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
6251 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
6253 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc_simple_NN(gv));
6255 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
6257 kid->op_private = 0;
6258 kid->op_ppaddr = PL_ppaddr[OP_GV];
6265 Perl_ck_ftst(pTHX_ OP *o)
6268 const I32 type = o->op_type;
6270 if (o->op_flags & OPf_REF) {
6273 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
6274 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6275 const OPCODE kidtype = kid->op_type;
6277 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6278 OP * const newop = newGVOP(type, OPf_REF,
6279 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
6281 op_getmad(o,newop,'O');
6287 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o))
6288 o->op_private |= OPpFT_ACCESS;
6289 if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst)
6290 && kidtype != OP_STAT && kidtype != OP_LSTAT)
6291 o->op_private |= OPpFT_STACKED;
6299 if (type == OP_FTTTY)
6300 o = newGVOP(type, OPf_REF, PL_stdingv);
6302 o = newUNOP(type, 0, newDEFSVOP());
6303 op_getmad(oldo,o,'O');
6309 Perl_ck_fun(pTHX_ OP *o)
6312 const int type = o->op_type;
6313 register I32 oa = PL_opargs[type] >> OASHIFT;
6315 if (o->op_flags & OPf_STACKED) {
6316 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
6319 return no_fh_allowed(o);
6322 if (o->op_flags & OPf_KIDS) {
6323 OP **tokid = &cLISTOPo->op_first;
6324 register OP *kid = cLISTOPo->op_first;
6328 if (kid->op_type == OP_PUSHMARK ||
6329 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
6331 tokid = &kid->op_sibling;
6332 kid = kid->op_sibling;
6334 if (!kid && PL_opargs[type] & OA_DEFGV)
6335 *tokid = kid = newDEFSVOP();
6339 sibl = kid->op_sibling;
6341 if (!sibl && kid->op_type == OP_STUB) {
6348 /* list seen where single (scalar) arg expected? */
6349 if (numargs == 1 && !(oa >> 4)
6350 && kid->op_type == OP_LIST && type != OP_SCALAR)
6352 return too_many_arguments(o,PL_op_desc[type]);
6365 if ((type == OP_PUSH || type == OP_UNSHIFT)
6366 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
6367 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6368 "Useless use of %s with no values",
6371 if (kid->op_type == OP_CONST &&
6372 (kid->op_private & OPpCONST_BARE))
6374 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
6375 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
6376 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6377 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6378 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
6379 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6381 op_getmad(kid,newop,'K');
6386 kid->op_sibling = sibl;
6389 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
6390 bad_type(numargs, "array", PL_op_desc[type], kid);
6394 if (kid->op_type == OP_CONST &&
6395 (kid->op_private & OPpCONST_BARE))
6397 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
6398 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
6399 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6400 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6401 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
6402 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6404 op_getmad(kid,newop,'K');
6409 kid->op_sibling = sibl;
6412 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
6413 bad_type(numargs, "hash", PL_op_desc[type], kid);
6418 OP * const newop = newUNOP(OP_NULL, 0, kid);
6419 kid->op_sibling = 0;
6421 newop->op_next = newop;
6423 kid->op_sibling = sibl;
6428 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
6429 if (kid->op_type == OP_CONST &&
6430 (kid->op_private & OPpCONST_BARE))
6432 OP * const newop = newGVOP(OP_GV, 0,
6433 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
6434 if (!(o->op_private & 1) && /* if not unop */
6435 kid == cLISTOPo->op_last)
6436 cLISTOPo->op_last = newop;
6438 op_getmad(kid,newop,'K');
6444 else if (kid->op_type == OP_READLINE) {
6445 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
6446 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
6449 I32 flags = OPf_SPECIAL;
6453 /* is this op a FH constructor? */
6454 if (is_handle_constructor(o,numargs)) {
6455 const char *name = NULL;
6459 /* Set a flag to tell rv2gv to vivify
6460 * need to "prove" flag does not mean something
6461 * else already - NI-S 1999/05/07
6464 if (kid->op_type == OP_PADSV) {
6466 = PAD_COMPNAME_SV(kid->op_targ);
6467 name = SvPV_const(namesv, len);
6469 else if (kid->op_type == OP_RV2SV
6470 && kUNOP->op_first->op_type == OP_GV)
6472 GV * const gv = cGVOPx_gv(kUNOP->op_first);
6474 len = GvNAMELEN(gv);
6476 else if (kid->op_type == OP_AELEM
6477 || kid->op_type == OP_HELEM)
6480 OP *op = ((BINOP*)kid)->op_first;
6484 const char * const a =
6485 kid->op_type == OP_AELEM ?
6487 if (((op->op_type == OP_RV2AV) ||
6488 (op->op_type == OP_RV2HV)) &&
6489 (firstop = ((UNOP*)op)->op_first) &&
6490 (firstop->op_type == OP_GV)) {
6491 /* packagevar $a[] or $h{} */
6492 GV * const gv = cGVOPx_gv(firstop);
6500 else if (op->op_type == OP_PADAV
6501 || op->op_type == OP_PADHV) {
6502 /* lexicalvar $a[] or $h{} */
6503 const char * const padname =
6504 PAD_COMPNAME_PV(op->op_targ);
6513 name = SvPV_const(tmpstr, len);
6518 name = "__ANONIO__";
6525 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
6526 namesv = PAD_SVl(targ);
6527 SvUPGRADE(namesv, SVt_PV);
6529 sv_setpvn(namesv, "$", 1);
6530 sv_catpvn(namesv, name, len);
6533 kid->op_sibling = 0;
6534 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
6535 kid->op_targ = targ;
6536 kid->op_private |= priv;
6538 kid->op_sibling = sibl;
6544 mod(scalar(kid), type);
6548 tokid = &kid->op_sibling;
6549 kid = kid->op_sibling;
6552 if (kid && kid->op_type != OP_STUB)
6553 return too_many_arguments(o,OP_DESC(o));
6554 o->op_private |= numargs;
6556 /* FIXME - should the numargs move as for the PERL_MAD case? */
6557 o->op_private |= numargs;
6559 return too_many_arguments(o,OP_DESC(o));
6563 else if (PL_opargs[type] & OA_DEFGV) {
6565 OP *newop = newUNOP(type, 0, newDEFSVOP());
6566 op_getmad(o,newop,'O');
6569 /* Ordering of these two is important to keep f_map.t passing. */
6571 return newUNOP(type, 0, newDEFSVOP());
6576 while (oa & OA_OPTIONAL)
6578 if (oa && oa != OA_LIST)
6579 return too_few_arguments(o,OP_DESC(o));
6585 Perl_ck_glob(pTHX_ OP *o)
6591 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
6592 append_elem(OP_GLOB, o, newDEFSVOP());
6594 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
6595 && GvCVu(gv) && GvIMPORTED_CV(gv)))
6597 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6600 #if !defined(PERL_EXTERNAL_GLOB)
6601 /* XXX this can be tightened up and made more failsafe. */
6602 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
6605 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
6606 newSVpvs("File::Glob"), NULL, NULL, NULL);
6607 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6608 glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
6609 GvCV(gv) = GvCV(glob_gv);
6610 SvREFCNT_inc_void((SV*)GvCV(gv));
6611 GvIMPORTED_CV_on(gv);
6614 #endif /* PERL_EXTERNAL_GLOB */
6616 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6617 append_elem(OP_GLOB, o,
6618 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
6619 o->op_type = OP_LIST;
6620 o->op_ppaddr = PL_ppaddr[OP_LIST];
6621 cLISTOPo->op_first->op_type = OP_PUSHMARK;
6622 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
6623 cLISTOPo->op_first->op_targ = 0;
6624 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
6625 append_elem(OP_LIST, o,
6626 scalar(newUNOP(OP_RV2CV, 0,
6627 newGVOP(OP_GV, 0, gv)))));
6628 o = newUNOP(OP_NULL, 0, ck_subr(o));
6629 o->op_targ = OP_GLOB; /* hint at what it used to be */
6632 gv = newGVgen("main");
6634 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
6640 Perl_ck_grep(pTHX_ OP *o)
6645 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
6648 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
6649 /* don't allocate gwop here, as we may leak it if PL_error_count > 0 */
6651 if (o->op_flags & OPf_STACKED) {
6654 kid = cLISTOPo->op_first->op_sibling;
6655 if (!cUNOPx(kid)->op_next)
6656 Perl_croak(aTHX_ "panic: ck_grep");
6657 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
6660 NewOp(1101, gwop, 1, LOGOP);
6661 kid->op_next = (OP*)gwop;
6662 o->op_flags &= ~OPf_STACKED;
6664 kid = cLISTOPo->op_first->op_sibling;
6665 if (type == OP_MAPWHILE)
6672 kid = cLISTOPo->op_first->op_sibling;
6673 if (kid->op_type != OP_NULL)
6674 Perl_croak(aTHX_ "panic: ck_grep");
6675 kid = kUNOP->op_first;
6678 NewOp(1101, gwop, 1, LOGOP);
6679 gwop->op_type = type;
6680 gwop->op_ppaddr = PL_ppaddr[type];
6681 gwop->op_first = listkids(o);
6682 gwop->op_flags |= OPf_KIDS;
6683 gwop->op_other = LINKLIST(kid);
6684 kid->op_next = (OP*)gwop;
6685 offset = pad_findmy("$_");
6686 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
6687 o->op_private = gwop->op_private = 0;
6688 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
6691 o->op_private = gwop->op_private = OPpGREP_LEX;
6692 gwop->op_targ = o->op_targ = offset;
6695 kid = cLISTOPo->op_first->op_sibling;
6696 if (!kid || !kid->op_sibling)
6697 return too_few_arguments(o,OP_DESC(o));
6698 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
6699 mod(kid, OP_GREPSTART);
6705 Perl_ck_index(pTHX_ OP *o)
6707 if (o->op_flags & OPf_KIDS) {
6708 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6710 kid = kid->op_sibling; /* get past "big" */
6711 if (kid && kid->op_type == OP_CONST)
6712 fbm_compile(((SVOP*)kid)->op_sv, 0);
6718 Perl_ck_lengthconst(pTHX_ OP *o)
6720 /* XXX length optimization goes here */
6725 Perl_ck_lfun(pTHX_ OP *o)
6727 const OPCODE type = o->op_type;
6728 return modkids(ck_fun(o), type);
6732 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
6734 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
6735 switch (cUNOPo->op_first->op_type) {
6737 /* This is needed for
6738 if (defined %stash::)
6739 to work. Do not break Tk.
6741 break; /* Globals via GV can be undef */
6743 case OP_AASSIGN: /* Is this a good idea? */
6744 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6745 "defined(@array) is deprecated");
6746 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6747 "\t(Maybe you should just omit the defined()?)\n");
6750 /* This is needed for
6751 if (defined %stash::)
6752 to work. Do not break Tk.
6754 break; /* Globals via GV can be undef */
6756 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6757 "defined(%%hash) is deprecated");
6758 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6759 "\t(Maybe you should just omit the defined()?)\n");
6770 Perl_ck_rfun(pTHX_ OP *o)
6772 const OPCODE type = o->op_type;
6773 return refkids(ck_fun(o), type);
6777 Perl_ck_listiob(pTHX_ OP *o)
6781 kid = cLISTOPo->op_first;
6784 kid = cLISTOPo->op_first;
6786 if (kid->op_type == OP_PUSHMARK)
6787 kid = kid->op_sibling;
6788 if (kid && o->op_flags & OPf_STACKED)
6789 kid = kid->op_sibling;
6790 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6791 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6792 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6793 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6794 cLISTOPo->op_first->op_sibling = kid;
6795 cLISTOPo->op_last = kid;
6796 kid = kid->op_sibling;
6801 append_elem(o->op_type, o, newDEFSVOP());
6807 Perl_ck_smartmatch(pTHX_ OP *o)
6810 if (0 == (o->op_flags & OPf_SPECIAL)) {
6811 OP *first = cBINOPo->op_first;
6812 OP *second = first->op_sibling;
6814 /* Implicitly take a reference to an array or hash */
6815 first->op_sibling = NULL;
6816 first = cBINOPo->op_first = ref_array_or_hash(first);
6817 second = first->op_sibling = ref_array_or_hash(second);
6819 /* Implicitly take a reference to a regular expression */
6820 if (first->op_type == OP_MATCH) {
6821 first->op_type = OP_QR;
6822 first->op_ppaddr = PL_ppaddr[OP_QR];
6824 if (second->op_type == OP_MATCH) {
6825 second->op_type = OP_QR;
6826 second->op_ppaddr = PL_ppaddr[OP_QR];
6835 Perl_ck_sassign(pTHX_ OP *o)
6837 OP * const kid = cLISTOPo->op_first;
6838 /* has a disposable target? */
6839 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6840 && !(kid->op_flags & OPf_STACKED)
6841 /* Cannot steal the second time! */
6842 && !(kid->op_private & OPpTARGET_MY))
6844 OP * const kkid = kid->op_sibling;
6846 /* Can just relocate the target. */
6847 if (kkid && kkid->op_type == OP_PADSV
6848 && !(kkid->op_private & OPpLVAL_INTRO))
6850 kid->op_targ = kkid->op_targ;
6852 /* Now we do not need PADSV and SASSIGN. */
6853 kid->op_sibling = o->op_sibling; /* NULL */
6854 cLISTOPo->op_first = NULL;
6856 op_getmad(o,kid,'O');
6857 op_getmad(kkid,kid,'M');
6862 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6866 if (kid->op_sibling) {
6867 OP *kkid = kid->op_sibling;
6868 if (kkid->op_type == OP_PADSV
6869 && (kkid->op_private & OPpLVAL_INTRO)
6870 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
6871 o->op_private |= OPpASSIGN_STATE;
6872 /* hijacking PADSTALE for uninitialized state variables */
6873 SvPADSTALE_on(PAD_SVl(kkid->op_targ));
6880 Perl_ck_match(pTHX_ OP *o)
6883 if (o->op_type != OP_QR && PL_compcv) {
6884 const PADOFFSET offset = pad_findmy("$_");
6885 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
6886 o->op_targ = offset;
6887 o->op_private |= OPpTARGET_MY;
6890 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
6891 o->op_private |= OPpRUNTIME;
6896 Perl_ck_method(pTHX_ OP *o)
6898 OP * const kid = cUNOPo->op_first;
6899 if (kid->op_type == OP_CONST) {
6900 SV* sv = kSVOP->op_sv;
6901 const char * const method = SvPVX_const(sv);
6902 if (!(strchr(method, ':') || strchr(method, '\''))) {
6904 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6905 sv = newSVpvn_share(method, SvCUR(sv), 0);
6908 kSVOP->op_sv = NULL;
6910 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6912 op_getmad(o,cmop,'O');
6923 Perl_ck_null(pTHX_ OP *o)
6925 PERL_UNUSED_CONTEXT;
6930 Perl_ck_open(pTHX_ OP *o)
6933 HV * const table = GvHV(PL_hintgv);
6935 SV **svp = hv_fetchs(table, "open_IN", FALSE);
6937 const I32 mode = mode_from_discipline(*svp);
6938 if (mode & O_BINARY)
6939 o->op_private |= OPpOPEN_IN_RAW;
6940 else if (mode & O_TEXT)
6941 o->op_private |= OPpOPEN_IN_CRLF;
6944 svp = hv_fetchs(table, "open_OUT", FALSE);
6946 const I32 mode = mode_from_discipline(*svp);
6947 if (mode & O_BINARY)
6948 o->op_private |= OPpOPEN_OUT_RAW;
6949 else if (mode & O_TEXT)
6950 o->op_private |= OPpOPEN_OUT_CRLF;
6953 if (o->op_type == OP_BACKTICK)
6956 /* In case of three-arg dup open remove strictness
6957 * from the last arg if it is a bareword. */
6958 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
6959 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
6963 if ((last->op_type == OP_CONST) && /* The bareword. */
6964 (last->op_private & OPpCONST_BARE) &&
6965 (last->op_private & OPpCONST_STRICT) &&
6966 (oa = first->op_sibling) && /* The fh. */
6967 (oa = oa->op_sibling) && /* The mode. */
6968 (oa->op_type == OP_CONST) &&
6969 SvPOK(((SVOP*)oa)->op_sv) &&
6970 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
6971 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
6972 (last == oa->op_sibling)) /* The bareword. */
6973 last->op_private &= ~OPpCONST_STRICT;
6979 Perl_ck_repeat(pTHX_ OP *o)
6981 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6982 o->op_private |= OPpREPEAT_DOLIST;
6983 cBINOPo->op_first = force_list(cBINOPo->op_first);
6991 Perl_ck_require(pTHX_ OP *o)
6996 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
6997 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6999 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
7000 SV * const sv = kid->op_sv;
7001 U32 was_readonly = SvREADONLY(sv);
7006 sv_force_normal_flags(sv, 0);
7007 assert(!SvREADONLY(sv));
7014 for (s = SvPVX(sv); *s; s++) {
7015 if (*s == ':' && s[1] == ':') {
7016 const STRLEN len = strlen(s+2)+1;
7018 Move(s+2, s+1, len, char);
7019 SvCUR_set(sv, SvCUR(sv) - 1);
7022 sv_catpvs(sv, ".pm");
7023 SvFLAGS(sv) |= was_readonly;
7027 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
7028 /* handle override, if any */
7029 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
7030 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7031 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
7032 gv = gvp ? *gvp : NULL;
7036 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7037 OP * const kid = cUNOPo->op_first;
7040 cUNOPo->op_first = 0;
7044 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
7045 append_elem(OP_LIST, kid,
7046 scalar(newUNOP(OP_RV2CV, 0,
7049 op_getmad(o,newop,'O');
7057 Perl_ck_return(pTHX_ OP *o)
7060 if (CvLVALUE(PL_compcv)) {
7062 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
7063 mod(kid, OP_LEAVESUBLV);
7069 Perl_ck_select(pTHX_ OP *o)
7073 if (o->op_flags & OPf_KIDS) {
7074 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7075 if (kid && kid->op_sibling) {
7076 o->op_type = OP_SSELECT;
7077 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
7079 return fold_constants(o);
7083 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7084 if (kid && kid->op_type == OP_RV2GV)
7085 kid->op_private &= ~HINT_STRICT_REFS;
7090 Perl_ck_shift(pTHX_ OP *o)
7093 const I32 type = o->op_type;
7095 if (!(o->op_flags & OPf_KIDS)) {
7097 /* FIXME - this can be refactored to reduce code in #ifdefs */
7099 OP * const oldo = o;
7103 argop = newUNOP(OP_RV2AV, 0,
7104 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
7106 o = newUNOP(type, 0, scalar(argop));
7107 op_getmad(oldo,o,'O');
7110 return newUNOP(type, 0, scalar(argop));
7113 return scalar(modkids(ck_fun(o), type));
7117 Perl_ck_sort(pTHX_ OP *o)
7122 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
7123 HV * const hinthv = GvHV(PL_hintgv);
7125 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
7127 const I32 sorthints = (I32)SvIV(*svp);
7128 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
7129 o->op_private |= OPpSORT_QSORT;
7130 if ((sorthints & HINT_SORT_STABLE) != 0)
7131 o->op_private |= OPpSORT_STABLE;
7136 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
7138 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7139 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
7141 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
7143 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
7145 if (kid->op_type == OP_SCOPE) {
7149 else if (kid->op_type == OP_LEAVE) {
7150 if (o->op_type == OP_SORT) {
7151 op_null(kid); /* wipe out leave */
7154 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
7155 if (k->op_next == kid)
7157 /* don't descend into loops */
7158 else if (k->op_type == OP_ENTERLOOP
7159 || k->op_type == OP_ENTERITER)
7161 k = cLOOPx(k)->op_lastop;
7166 kid->op_next = 0; /* just disconnect the leave */
7167 k = kLISTOP->op_first;
7172 if (o->op_type == OP_SORT) {
7173 /* provide scalar context for comparison function/block */
7179 o->op_flags |= OPf_SPECIAL;
7181 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
7184 firstkid = firstkid->op_sibling;
7187 /* provide list context for arguments */
7188 if (o->op_type == OP_SORT)
7195 S_simplify_sort(pTHX_ OP *o)
7198 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7203 if (!(o->op_flags & OPf_STACKED))
7205 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7206 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
7207 kid = kUNOP->op_first; /* get past null */
7208 if (kid->op_type != OP_SCOPE)
7210 kid = kLISTOP->op_last; /* get past scope */
7211 switch(kid->op_type) {
7219 k = kid; /* remember this node*/
7220 if (kBINOP->op_first->op_type != OP_RV2SV)
7222 kid = kBINOP->op_first; /* get past cmp */
7223 if (kUNOP->op_first->op_type != OP_GV)
7225 kid = kUNOP->op_first; /* get past rv2sv */
7227 if (GvSTASH(gv) != PL_curstash)
7229 gvname = GvNAME(gv);
7230 if (*gvname == 'a' && gvname[1] == '\0')
7232 else if (*gvname == 'b' && gvname[1] == '\0')
7237 kid = k; /* back to cmp */
7238 if (kBINOP->op_last->op_type != OP_RV2SV)
7240 kid = kBINOP->op_last; /* down to 2nd arg */
7241 if (kUNOP->op_first->op_type != OP_GV)
7243 kid = kUNOP->op_first; /* get past rv2sv */
7245 if (GvSTASH(gv) != PL_curstash)
7247 gvname = GvNAME(gv);
7249 ? !(*gvname == 'a' && gvname[1] == '\0')
7250 : !(*gvname == 'b' && gvname[1] == '\0'))
7252 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
7254 o->op_private |= OPpSORT_DESCEND;
7255 if (k->op_type == OP_NCMP)
7256 o->op_private |= OPpSORT_NUMERIC;
7257 if (k->op_type == OP_I_NCMP)
7258 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
7259 kid = cLISTOPo->op_first->op_sibling;
7260 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
7262 op_getmad(kid,o,'S'); /* then delete it */
7264 op_free(kid); /* then delete it */
7269 Perl_ck_split(pTHX_ OP *o)
7274 if (o->op_flags & OPf_STACKED)
7275 return no_fh_allowed(o);
7277 kid = cLISTOPo->op_first;
7278 if (kid->op_type != OP_NULL)
7279 Perl_croak(aTHX_ "panic: ck_split");
7280 kid = kid->op_sibling;
7281 op_free(cLISTOPo->op_first);
7282 cLISTOPo->op_first = kid;
7284 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
7285 cLISTOPo->op_last = kid; /* There was only one element previously */
7288 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
7289 OP * const sibl = kid->op_sibling;
7290 kid->op_sibling = 0;
7291 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
7292 if (cLISTOPo->op_first == cLISTOPo->op_last)
7293 cLISTOPo->op_last = kid;
7294 cLISTOPo->op_first = kid;
7295 kid->op_sibling = sibl;
7298 kid->op_type = OP_PUSHRE;
7299 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
7301 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
7302 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
7303 "Use of /g modifier is meaningless in split");
7306 if (!kid->op_sibling)
7307 append_elem(OP_SPLIT, o, newDEFSVOP());
7309 kid = kid->op_sibling;
7312 if (!kid->op_sibling)
7313 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
7314 assert(kid->op_sibling);
7316 kid = kid->op_sibling;
7319 if (kid->op_sibling)
7320 return too_many_arguments(o,OP_DESC(o));
7326 Perl_ck_join(pTHX_ OP *o)
7328 const OP * const kid = cLISTOPo->op_first->op_sibling;
7329 if (kid && kid->op_type == OP_MATCH) {
7330 if (ckWARN(WARN_SYNTAX)) {
7331 const REGEXP *re = PM_GETRE(kPMOP);
7332 const char *pmstr = re ? re->precomp : "STRING";
7333 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7334 "/%s/ should probably be written as \"%s\"",
7342 Perl_ck_subr(pTHX_ OP *o)
7345 OP *prev = ((cUNOPo->op_first->op_sibling)
7346 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
7347 OP *o2 = prev->op_sibling;
7349 const char *proto = NULL;
7350 const char *proto_end = NULL;
7355 I32 contextclass = 0;
7356 const char *e = NULL;
7359 o->op_private |= OPpENTERSUB_HASTARG;
7360 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
7361 if (cvop->op_type == OP_RV2CV) {
7363 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
7364 op_null(cvop); /* disable rv2cv */
7365 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
7366 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
7367 GV *gv = cGVOPx_gv(tmpop);
7370 tmpop->op_private |= OPpEARLY_CV;
7374 namegv = CvANON(cv) ? gv : CvGV(cv);
7375 proto = SvPV((SV*)cv, len);
7376 proto_end = proto + len;
7378 if (CvASSERTION(cv)) {
7379 U32 asserthints = 0;
7380 HV *const hinthv = GvHV(PL_hintgv);
7382 SV **svp = hv_fetchs(hinthv, "assertions", FALSE);
7384 asserthints = SvUV(*svp);
7386 if (asserthints & HINT_ASSERTING) {
7387 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
7388 o->op_private |= OPpENTERSUB_DB;
7392 if (!(asserthints & HINT_ASSERTIONSSEEN) && ckWARN(WARN_ASSERTIONS)) {
7393 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
7394 "Impossible to activate assertion call");
7401 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7402 if (o2->op_type == OP_CONST)
7403 o2->op_private &= ~OPpCONST_STRICT;
7404 else if (o2->op_type == OP_LIST) {
7405 OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
7406 if (sib && sib->op_type == OP_CONST)
7407 sib->op_private &= ~OPpCONST_STRICT;
7410 o->op_private |= (PL_hints & HINT_STRICT_REFS);
7411 if (PERLDB_SUB && PL_curstash != PL_debstash)
7412 o->op_private |= OPpENTERSUB_DB;
7413 while (o2 != cvop) {
7415 if (PL_madskills && o2->op_type == OP_NULL)
7416 o3 = ((UNOP*)o2)->op_first;
7420 if (proto >= proto_end)
7421 return too_many_arguments(o, gv_ename(namegv));
7429 /* _ must be at the end */
7430 if (proto[1] && proto[1] != ';')
7445 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
7447 arg == 1 ? "block or sub {}" : "sub {}",
7448 gv_ename(namegv), o3);
7451 /* '*' allows any scalar type, including bareword */
7454 if (o3->op_type == OP_RV2GV)
7455 goto wrapref; /* autoconvert GLOB -> GLOBref */
7456 else if (o3->op_type == OP_CONST)
7457 o3->op_private &= ~OPpCONST_STRICT;
7458 else if (o3->op_type == OP_ENTERSUB) {
7459 /* accidental subroutine, revert to bareword */
7460 OP *gvop = ((UNOP*)o3)->op_first;
7461 if (gvop && gvop->op_type == OP_NULL) {
7462 gvop = ((UNOP*)gvop)->op_first;
7464 for (; gvop->op_sibling; gvop = gvop->op_sibling)
7467 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
7468 (gvop = ((UNOP*)gvop)->op_first) &&
7469 gvop->op_type == OP_GV)
7471 GV * const gv = cGVOPx_gv(gvop);
7472 OP * const sibling = o2->op_sibling;
7473 SV * const n = newSVpvs("");
7475 OP * const oldo2 = o2;
7479 gv_fullname4(n, gv, "", FALSE);
7480 o2 = newSVOP(OP_CONST, 0, n);
7481 op_getmad(oldo2,o2,'O');
7482 prev->op_sibling = o2;
7483 o2->op_sibling = sibling;
7499 if (contextclass++ == 0) {
7500 e = strchr(proto, ']');
7501 if (!e || e == proto)
7510 const char *p = proto;
7511 const char *const end = proto;
7513 while (*--p != '[');
7514 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
7516 gv_ename(namegv), o3);
7521 if (o3->op_type == OP_RV2GV)
7524 bad_type(arg, "symbol", gv_ename(namegv), o3);
7527 if (o3->op_type == OP_ENTERSUB)
7530 bad_type(arg, "subroutine entry", gv_ename(namegv),
7534 if (o3->op_type == OP_RV2SV ||
7535 o3->op_type == OP_PADSV ||
7536 o3->op_type == OP_HELEM ||
7537 o3->op_type == OP_AELEM)
7540 bad_type(arg, "scalar", gv_ename(namegv), o3);
7543 if (o3->op_type == OP_RV2AV ||
7544 o3->op_type == OP_PADAV)
7547 bad_type(arg, "array", gv_ename(namegv), o3);
7550 if (o3->op_type == OP_RV2HV ||
7551 o3->op_type == OP_PADHV)
7554 bad_type(arg, "hash", gv_ename(namegv), o3);
7559 OP* const sib = kid->op_sibling;
7560 kid->op_sibling = 0;
7561 o2 = newUNOP(OP_REFGEN, 0, kid);
7562 o2->op_sibling = sib;
7563 prev->op_sibling = o2;
7565 if (contextclass && e) {
7580 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
7581 gv_ename(namegv), SVfARG(cv));
7586 mod(o2, OP_ENTERSUB);
7588 o2 = o2->op_sibling;
7590 if (o2 == cvop && proto && *proto == '_') {
7591 /* generate an access to $_ */
7593 o2->op_sibling = prev->op_sibling;
7594 prev->op_sibling = o2; /* instead of cvop */
7596 if (proto && !optional && proto_end > proto &&
7597 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
7598 return too_few_arguments(o, gv_ename(namegv));
7601 OP * const oldo = o;
7605 o=newSVOP(OP_CONST, 0, newSViv(0));
7606 op_getmad(oldo,o,'O');
7612 Perl_ck_svconst(pTHX_ OP *o)
7614 PERL_UNUSED_CONTEXT;
7615 SvREADONLY_on(cSVOPo->op_sv);
7620 Perl_ck_chdir(pTHX_ OP *o)
7622 if (o->op_flags & OPf_KIDS) {
7623 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7625 if (kid && kid->op_type == OP_CONST &&
7626 (kid->op_private & OPpCONST_BARE))
7628 o->op_flags |= OPf_SPECIAL;
7629 kid->op_private &= ~OPpCONST_STRICT;
7636 Perl_ck_trunc(pTHX_ OP *o)
7638 if (o->op_flags & OPf_KIDS) {
7639 SVOP *kid = (SVOP*)cUNOPo->op_first;
7641 if (kid->op_type == OP_NULL)
7642 kid = (SVOP*)kid->op_sibling;
7643 if (kid && kid->op_type == OP_CONST &&
7644 (kid->op_private & OPpCONST_BARE))
7646 o->op_flags |= OPf_SPECIAL;
7647 kid->op_private &= ~OPpCONST_STRICT;
7654 Perl_ck_unpack(pTHX_ OP *o)
7656 OP *kid = cLISTOPo->op_first;
7657 if (kid->op_sibling) {
7658 kid = kid->op_sibling;
7659 if (!kid->op_sibling)
7660 kid->op_sibling = newDEFSVOP();
7666 Perl_ck_substr(pTHX_ OP *o)
7669 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
7670 OP *kid = cLISTOPo->op_first;
7672 if (kid->op_type == OP_NULL)
7673 kid = kid->op_sibling;
7675 kid->op_flags |= OPf_MOD;
7681 /* A peephole optimizer. We visit the ops in the order they're to execute.
7682 * See the comments at the top of this file for more details about when
7683 * peep() is called */
7686 Perl_peep(pTHX_ register OP *o)
7689 register OP* oldop = NULL;
7691 if (!o || o->op_opt)
7695 SAVEVPTR(PL_curcop);
7696 for (; o; o = o->op_next) {
7700 switch (o->op_type) {
7704 PL_curcop = ((COP*)o); /* for warnings */
7709 if (cSVOPo->op_private & OPpCONST_STRICT)
7710 no_bareword_allowed(o);
7712 case OP_METHOD_NAMED:
7713 /* Relocate sv to the pad for thread safety.
7714 * Despite being a "constant", the SV is written to,
7715 * for reference counts, sv_upgrade() etc. */
7717 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
7718 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
7719 /* If op_sv is already a PADTMP then it is being used by
7720 * some pad, so make a copy. */
7721 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
7722 SvREADONLY_on(PAD_SVl(ix));
7723 SvREFCNT_dec(cSVOPo->op_sv);
7725 else if (o->op_type == OP_CONST
7726 && cSVOPo->op_sv == &PL_sv_undef) {
7727 /* PL_sv_undef is hack - it's unsafe to store it in the
7728 AV that is the pad, because av_fetch treats values of
7729 PL_sv_undef as a "free" AV entry and will merrily
7730 replace them with a new SV, causing pad_alloc to think
7731 that this pad slot is free. (When, clearly, it is not)
7733 SvOK_off(PAD_SVl(ix));
7734 SvPADTMP_on(PAD_SVl(ix));
7735 SvREADONLY_on(PAD_SVl(ix));
7738 SvREFCNT_dec(PAD_SVl(ix));
7739 SvPADTMP_on(cSVOPo->op_sv);
7740 PAD_SETSV(ix, cSVOPo->op_sv);
7741 /* XXX I don't know how this isn't readonly already. */
7742 SvREADONLY_on(PAD_SVl(ix));
7744 cSVOPo->op_sv = NULL;
7752 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
7753 if (o->op_next->op_private & OPpTARGET_MY) {
7754 if (o->op_flags & OPf_STACKED) /* chained concats */
7755 goto ignore_optimization;
7757 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
7758 o->op_targ = o->op_next->op_targ;
7759 o->op_next->op_targ = 0;
7760 o->op_private |= OPpTARGET_MY;
7763 op_null(o->op_next);
7765 ignore_optimization:
7769 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
7771 break; /* Scalar stub must produce undef. List stub is noop */
7775 if (o->op_targ == OP_NEXTSTATE
7776 || o->op_targ == OP_DBSTATE
7777 || o->op_targ == OP_SETSTATE)
7779 PL_curcop = ((COP*)o);
7781 /* XXX: We avoid setting op_seq here to prevent later calls
7782 to peep() from mistakenly concluding that optimisation
7783 has already occurred. This doesn't fix the real problem,
7784 though (See 20010220.007). AMS 20010719 */
7785 /* op_seq functionality is now replaced by op_opt */
7786 if (oldop && o->op_next) {
7787 oldop->op_next = o->op_next;
7795 if (oldop && o->op_next) {
7796 oldop->op_next = o->op_next;
7804 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
7805 OP* const pop = (o->op_type == OP_PADAV) ?
7806 o->op_next : o->op_next->op_next;
7808 if (pop && pop->op_type == OP_CONST &&
7809 ((PL_op = pop->op_next)) &&
7810 pop->op_next->op_type == OP_AELEM &&
7811 !(pop->op_next->op_private &
7812 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
7813 (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
7818 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
7819 no_bareword_allowed(pop);
7820 if (o->op_type == OP_GV)
7821 op_null(o->op_next);
7822 op_null(pop->op_next);
7824 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
7825 o->op_next = pop->op_next->op_next;
7826 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
7827 o->op_private = (U8)i;
7828 if (o->op_type == OP_GV) {
7833 o->op_flags |= OPf_SPECIAL;
7834 o->op_type = OP_AELEMFAST;
7840 if (o->op_next->op_type == OP_RV2SV) {
7841 if (!(o->op_next->op_private & OPpDEREF)) {
7842 op_null(o->op_next);
7843 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
7845 o->op_next = o->op_next->op_next;
7846 o->op_type = OP_GVSV;
7847 o->op_ppaddr = PL_ppaddr[OP_GVSV];
7850 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
7851 GV * const gv = cGVOPo_gv;
7852 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
7853 /* XXX could check prototype here instead of just carping */
7854 SV * const sv = sv_newmortal();
7855 gv_efullname3(sv, gv, NULL);
7856 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
7857 "%"SVf"() called too early to check prototype",
7861 else if (o->op_next->op_type == OP_READLINE
7862 && o->op_next->op_next->op_type == OP_CONCAT
7863 && (o->op_next->op_next->op_flags & OPf_STACKED))
7865 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
7866 o->op_type = OP_RCATLINE;
7867 o->op_flags |= OPf_STACKED;
7868 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
7869 op_null(o->op_next->op_next);
7870 op_null(o->op_next);
7887 while (cLOGOP->op_other->op_type == OP_NULL)
7888 cLOGOP->op_other = cLOGOP->op_other->op_next;
7889 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
7895 while (cLOOP->op_redoop->op_type == OP_NULL)
7896 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
7897 peep(cLOOP->op_redoop);
7898 while (cLOOP->op_nextop->op_type == OP_NULL)
7899 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
7900 peep(cLOOP->op_nextop);
7901 while (cLOOP->op_lastop->op_type == OP_NULL)
7902 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
7903 peep(cLOOP->op_lastop);
7910 while (cPMOP->op_pmreplstart &&
7911 cPMOP->op_pmreplstart->op_type == OP_NULL)
7912 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
7913 peep(cPMOP->op_pmreplstart);
7918 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
7919 && ckWARN(WARN_SYNTAX))
7921 if (o->op_next->op_sibling) {
7922 const OPCODE type = o->op_next->op_sibling->op_type;
7923 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
7924 const line_t oldline = CopLINE(PL_curcop);
7925 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
7926 Perl_warner(aTHX_ packWARN(WARN_EXEC),
7927 "Statement unlikely to be reached");
7928 Perl_warner(aTHX_ packWARN(WARN_EXEC),
7929 "\t(Maybe you meant system() when you said exec()?)\n");
7930 CopLINE_set(PL_curcop, oldline);
7941 const char *key = NULL;
7946 if (((BINOP*)o)->op_last->op_type != OP_CONST)
7949 /* Make the CONST have a shared SV */
7950 svp = cSVOPx_svp(((BINOP*)o)->op_last);
7951 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
7952 key = SvPV_const(sv, keylen);
7953 lexname = newSVpvn_share(key,
7954 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
7960 if ((o->op_private & (OPpLVAL_INTRO)))
7963 rop = (UNOP*)((BINOP*)o)->op_first;
7964 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7966 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7967 if (!SvPAD_TYPED(lexname))
7969 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
7970 if (!fields || !GvHV(*fields))
7972 key = SvPV_const(*svp, keylen);
7973 if (!hv_fetch(GvHV(*fields), key,
7974 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
7976 Perl_croak(aTHX_ "No such class field \"%s\" "
7977 "in variable %s of type %s",
7978 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
7991 SVOP *first_key_op, *key_op;
7993 if ((o->op_private & (OPpLVAL_INTRO))
7994 /* I bet there's always a pushmark... */
7995 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
7996 /* hmmm, no optimization if list contains only one key. */
7998 rop = (UNOP*)((LISTOP*)o)->op_last;
7999 if (rop->op_type != OP_RV2HV)
8001 if (rop->op_first->op_type == OP_PADSV)
8002 /* @$hash{qw(keys here)} */
8003 rop = (UNOP*)rop->op_first;
8005 /* @{$hash}{qw(keys here)} */
8006 if (rop->op_first->op_type == OP_SCOPE
8007 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
8009 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
8015 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
8016 if (!SvPAD_TYPED(lexname))
8018 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8019 if (!fields || !GvHV(*fields))
8021 /* Again guessing that the pushmark can be jumped over.... */
8022 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
8023 ->op_first->op_sibling;
8024 for (key_op = first_key_op; key_op;
8025 key_op = (SVOP*)key_op->op_sibling) {
8026 if (key_op->op_type != OP_CONST)
8028 svp = cSVOPx_svp(key_op);
8029 key = SvPV_const(*svp, keylen);
8030 if (!hv_fetch(GvHV(*fields), key,
8031 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8033 Perl_croak(aTHX_ "No such class field \"%s\" "
8034 "in variable %s of type %s",
8035 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
8042 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
8046 /* check that RHS of sort is a single plain array */
8047 OP *oright = cUNOPo->op_first;
8048 if (!oright || oright->op_type != OP_PUSHMARK)
8051 /* reverse sort ... can be optimised. */
8052 if (!cUNOPo->op_sibling) {
8053 /* Nothing follows us on the list. */
8054 OP * const reverse = o->op_next;
8056 if (reverse->op_type == OP_REVERSE &&
8057 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
8058 OP * const pushmark = cUNOPx(reverse)->op_first;
8059 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
8060 && (cUNOPx(pushmark)->op_sibling == o)) {
8061 /* reverse -> pushmark -> sort */
8062 o->op_private |= OPpSORT_REVERSE;
8064 pushmark->op_next = oright->op_next;
8070 /* make @a = sort @a act in-place */
8074 oright = cUNOPx(oright)->op_sibling;
8077 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
8078 oright = cUNOPx(oright)->op_sibling;
8082 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
8083 || oright->op_next != o
8084 || (oright->op_private & OPpLVAL_INTRO)
8088 /* o2 follows the chain of op_nexts through the LHS of the
8089 * assign (if any) to the aassign op itself */
8091 if (!o2 || o2->op_type != OP_NULL)
8094 if (!o2 || o2->op_type != OP_PUSHMARK)
8097 if (o2 && o2->op_type == OP_GV)
8100 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
8101 || (o2->op_private & OPpLVAL_INTRO)
8106 if (!o2 || o2->op_type != OP_NULL)
8109 if (!o2 || o2->op_type != OP_AASSIGN
8110 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
8113 /* check that the sort is the first arg on RHS of assign */
8115 o2 = cUNOPx(o2)->op_first;
8116 if (!o2 || o2->op_type != OP_NULL)
8118 o2 = cUNOPx(o2)->op_first;
8119 if (!o2 || o2->op_type != OP_PUSHMARK)
8121 if (o2->op_sibling != o)
8124 /* check the array is the same on both sides */
8125 if (oleft->op_type == OP_RV2AV) {
8126 if (oright->op_type != OP_RV2AV
8127 || !cUNOPx(oright)->op_first
8128 || cUNOPx(oright)->op_first->op_type != OP_GV
8129 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
8130 cGVOPx_gv(cUNOPx(oright)->op_first)
8134 else if (oright->op_type != OP_PADAV
8135 || oright->op_targ != oleft->op_targ
8139 /* transfer MODishness etc from LHS arg to RHS arg */
8140 oright->op_flags = oleft->op_flags;
8141 o->op_private |= OPpSORT_INPLACE;
8143 /* excise push->gv->rv2av->null->aassign */
8144 o2 = o->op_next->op_next;
8145 op_null(o2); /* PUSHMARK */
8147 if (o2->op_type == OP_GV) {
8148 op_null(o2); /* GV */
8151 op_null(o2); /* RV2AV or PADAV */
8152 o2 = o2->op_next->op_next;
8153 op_null(o2); /* AASSIGN */
8155 o->op_next = o2->op_next;
8161 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
8163 LISTOP *enter, *exlist;
8166 enter = (LISTOP *) o->op_next;
8169 if (enter->op_type == OP_NULL) {
8170 enter = (LISTOP *) enter->op_next;
8174 /* for $a (...) will have OP_GV then OP_RV2GV here.
8175 for (...) just has an OP_GV. */
8176 if (enter->op_type == OP_GV) {
8177 gvop = (OP *) enter;
8178 enter = (LISTOP *) enter->op_next;
8181 if (enter->op_type == OP_RV2GV) {
8182 enter = (LISTOP *) enter->op_next;
8188 if (enter->op_type != OP_ENTERITER)
8191 iter = enter->op_next;
8192 if (!iter || iter->op_type != OP_ITER)
8195 expushmark = enter->op_first;
8196 if (!expushmark || expushmark->op_type != OP_NULL
8197 || expushmark->op_targ != OP_PUSHMARK)
8200 exlist = (LISTOP *) expushmark->op_sibling;
8201 if (!exlist || exlist->op_type != OP_NULL
8202 || exlist->op_targ != OP_LIST)
8205 if (exlist->op_last != o) {
8206 /* Mmm. Was expecting to point back to this op. */
8209 theirmark = exlist->op_first;
8210 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
8213 if (theirmark->op_sibling != o) {
8214 /* There's something between the mark and the reverse, eg
8215 for (1, reverse (...))
8220 ourmark = ((LISTOP *)o)->op_first;
8221 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
8224 ourlast = ((LISTOP *)o)->op_last;
8225 if (!ourlast || ourlast->op_next != o)
8228 rv2av = ourmark->op_sibling;
8229 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
8230 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
8231 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
8232 /* We're just reversing a single array. */
8233 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
8234 enter->op_flags |= OPf_STACKED;
8237 /* We don't have control over who points to theirmark, so sacrifice
8239 theirmark->op_next = ourmark->op_next;
8240 theirmark->op_flags = ourmark->op_flags;
8241 ourlast->op_next = gvop ? gvop : (OP *) enter;
8244 enter->op_private |= OPpITER_REVERSED;
8245 iter->op_private |= OPpITER_REVERSED;
8252 UNOP *refgen, *rv2cv;
8255 /* I do not understand this, but if o->op_opt isn't set to 1,
8256 various tests in ext/B/t/bytecode.t fail with no readily
8262 if ((o->op_flags && OPf_WANT) != OPf_WANT_VOID)
8265 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
8268 rv2gv = ((BINOP *)o)->op_last;
8269 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
8272 refgen = (UNOP *)((BINOP *)o)->op_first;
8274 if (!refgen || refgen->op_type != OP_REFGEN)
8277 exlist = (LISTOP *)refgen->op_first;
8278 if (!exlist || exlist->op_type != OP_NULL
8279 || exlist->op_targ != OP_LIST)
8282 if (exlist->op_first->op_type != OP_PUSHMARK)
8285 rv2cv = (UNOP*)exlist->op_last;
8287 if (rv2cv->op_type != OP_RV2CV)
8290 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
8291 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
8292 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
8294 o->op_private |= OPpASSIGN_CV_TO_GV;
8295 rv2gv->op_private |= OPpDONT_INIT_GV;
8296 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
8312 Perl_custom_op_name(pTHX_ const OP* o)
8315 const IV index = PTR2IV(o->op_ppaddr);
8319 if (!PL_custom_op_names) /* This probably shouldn't happen */
8320 return (char *)PL_op_name[OP_CUSTOM];
8322 keysv = sv_2mortal(newSViv(index));
8324 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
8326 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
8328 return SvPV_nolen(HeVAL(he));
8332 Perl_custom_op_desc(pTHX_ const OP* o)
8335 const IV index = PTR2IV(o->op_ppaddr);
8339 if (!PL_custom_op_descs)
8340 return (char *)PL_op_desc[OP_CUSTOM];
8342 keysv = sv_2mortal(newSViv(index));
8344 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
8346 return (char *)PL_op_desc[OP_CUSTOM];
8348 return SvPV_nolen(HeVAL(he));
8353 /* Efficient sub that returns a constant scalar value. */
8355 const_sv_xsub(pTHX_ CV* cv)
8362 Perl_croak(aTHX_ "usage: %s::%s()",
8363 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
8367 ST(0) = (SV*)XSANY.any_ptr;
8373 * c-indentation-style: bsd
8375 * indent-tabs-mode: t
8378 * ex: set ts=8 sts=4 sw=4 noet: