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 #ifdef PERL_DEBUG_READONLY_OPS
108 # define PERL_SLAB_SIZE 4096
109 # include <sys/mman.h>
112 #ifndef PERL_SLAB_SIZE
113 #define PERL_SLAB_SIZE 2048
117 Perl_Slab_Alloc(pTHX_ size_t sz)
120 * To make incrementing use count easy PL_OpSlab is an I32 *
121 * To make inserting the link to slab PL_OpPtr is I32 **
122 * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
123 * Add an overhead for pointer to slab and round up as a number of pointers
125 sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
126 if ((PL_OpSpace -= sz) < 0) {
127 #ifdef PERL_DEBUG_READONLY_OPS
128 /* We need to allocate chunk by chunk so that we can control the VM
130 PL_OpPtr = mmap(0, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE,
131 MAP_ANON|MAP_PRIVATE, -1, 0);
133 DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
134 (unsigned long) PERL_SLAB_SIZE*sizeof(I32*),
136 if(PL_OpPtr == MAP_FAILED) {
137 perror("mmap failed");
142 PL_OpPtr = (I32 **) PerlMemShared_calloc(PERL_SLAB_SIZE,sizeof(I32*));
147 /* We reserve the 0'th I32 sized chunk as a use count */
148 PL_OpSlab = (I32 *) PL_OpPtr;
149 /* Reduce size by the use count word, and by the size we need.
150 * Latter is to mimic the '-=' in the if() above
152 PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
153 /* Allocation pointer starts at the top.
154 Theory: because we build leaves before trunk allocating at end
155 means that at run time access is cache friendly upward
157 PL_OpPtr += PERL_SLAB_SIZE;
159 #ifdef PERL_DEBUG_READONLY_OPS
160 /* We remember this slab. */
161 /* This implementation isn't efficient, but it is simple. */
162 PL_slabs = realloc(PL_slabs, sizeof(I32**) * (PL_slab_count + 1));
163 PL_slabs[PL_slab_count++] = PL_OpSlab;
164 DEBUG_m(PerlIO_printf(Perl_debug_log, "Allocate %p\n", PL_OpSlab));
167 assert( PL_OpSpace >= 0 );
168 /* Move the allocation pointer down */
170 assert( PL_OpPtr > (I32 **) PL_OpSlab );
171 *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */
172 (*PL_OpSlab)++; /* Increment use count of slab */
173 assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
174 assert( *PL_OpSlab > 0 );
175 return (void *)(PL_OpPtr + 1);
178 #ifdef PERL_DEBUG_READONLY_OPS
180 Perl_pending_Slabs_to_ro(pTHX) {
181 /* Turn all the allocated op slabs read only. */
182 U32 count = PL_slab_count;
183 I32 **const slabs = PL_slabs;
185 /* Reset the array of pending OP slabs, as we're about to turn this lot
186 read only. Also, do it ahead of the loop in case the warn triggers,
187 and a warn handler has an eval */
193 /* Force a new slab for any further allocation. */
197 const void *start = slabs[count];
198 const size_t size = PERL_SLAB_SIZE* sizeof(I32*);
199 if(mprotect(start, size, PROT_READ)) {
200 Perl_warn(aTHX_ "mprotect for %p %lu failed with %d",
201 start, (unsigned long) size, errno);
207 S_Slab_to_rw(pTHX_ void *op)
209 I32 * const * const ptr = (I32 **) op;
210 I32 * const slab = ptr[-1];
211 assert( ptr-1 > (I32 **) slab );
212 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
214 if(mprotect(slab, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE)) {
215 Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d",
216 slab, (unsigned long) PERL_SLAB_SIZE*sizeof(I32*), errno);
220 # define Slab_to_rw(op)
224 Perl_Slab_Free(pTHX_ void *op)
226 I32 * const * const ptr = (I32 **) op;
227 I32 * const slab = ptr[-1];
228 assert( ptr-1 > (I32 **) slab );
229 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
232 if (--(*slab) == 0) {
234 # define PerlMemShared PerlMem
237 #ifdef PERL_DEBUG_READONLY_OPS
238 U32 count = PL_slab_count;
239 /* Need to remove this slab from our list of slabs */
242 if (PL_slabs[count] == slab) {
243 /* Found it. Move the entry at the end to overwrite it. */
244 DEBUG_m(PerlIO_printf(Perl_debug_log,
245 "Deallocate %p by moving %p from %lu to %lu\n",
247 PL_slabs[PL_slab_count - 1],
248 PL_slab_count, count));
249 PL_slabs[count] = PL_slabs[--PL_slab_count];
250 /* Could realloc smaller at this point, but probably not
257 "panic: Couldn't find slab at %p (%lu allocated)",
258 slab, (unsigned long) PL_slabs);
260 if(munmap(slab, PERL_SLAB_SIZE*sizeof(I32*))) {
261 perror("munmap failed");
266 PerlMemShared_free(slab);
268 if (slab == PL_OpSlab) {
275 * In the following definition, the ", (OP*)0" is just to make the compiler
276 * think the expression is of the right type: croak actually does a Siglongjmp.
278 #define CHECKOP(type,o) \
279 ((PL_op_mask && PL_op_mask[type]) \
280 ? ( op_free((OP*)o), \
281 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
283 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
285 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
288 S_gv_ename(pTHX_ GV *gv)
290 SV* const tmpsv = sv_newmortal();
291 gv_efullname3(tmpsv, gv, NULL);
292 return SvPV_nolen_const(tmpsv);
296 S_no_fh_allowed(pTHX_ OP *o)
298 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
304 S_too_few_arguments(pTHX_ OP *o, const char *name)
306 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
311 S_too_many_arguments(pTHX_ OP *o, const char *name)
313 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
318 S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid)
320 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
321 (int)n, name, t, OP_DESC(kid)));
325 S_no_bareword_allowed(pTHX_ const OP *o)
328 return; /* various ok barewords are hidden in extra OP_NULL */
329 qerror(Perl_mess(aTHX_
330 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
334 /* "register" allocation */
337 Perl_allocmy(pTHX_ const char *const name)
341 const bool is_our = (PL_in_my == KEY_our);
343 /* complain about "my $<special_var>" etc etc */
347 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
348 (name[1] == '_' && (*name == '$' || name[2]))))
350 /* name[2] is true if strlen(name) > 2 */
351 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
352 yyerror(Perl_form(aTHX_ "Can't use global %c^%c%s in \"my\"",
353 name[0], toCTRL(name[1]), name + 2));
355 yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
359 /* check for duplicate declaration */
360 pad_check_dup(name, is_our, (PL_curstash ? PL_curstash : PL_defstash));
362 if (PL_in_my_stash && *name != '$') {
363 yyerror(Perl_form(aTHX_
364 "Can't declare class for non-scalar %s in \"%s\"",
366 is_our ? "our" : PL_in_my == KEY_state ? "state" : "my"));
369 /* allocate a spare slot and store the name in that slot */
371 off = pad_add_name(name,
374 /* $_ is always in main::, even with our */
375 ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
379 PL_in_my == KEY_state
384 /* free the body of an op without examining its contents.
385 * Always use this rather than FreeOp directly */
388 S_op_destroy(pTHX_ OP *o)
390 if (o->op_latefree) {
401 Perl_op_free(pTHX_ OP *o)
406 if (!o || o->op_static)
408 if (o->op_latefreed) {
415 if (o->op_private & OPpREFCOUNTED) {
425 #ifdef PERL_DEBUG_READONLY_OPS
429 refcnt = OpREFCNT_dec(o);
440 if (o->op_flags & OPf_KIDS) {
441 register OP *kid, *nextkid;
442 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
443 nextkid = kid->op_sibling; /* Get before next freeing kid */
448 type = (OPCODE)o->op_targ;
450 /* COP* is not cleared by op_clear() so that we may track line
451 * numbers etc even after null() */
452 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
456 if (o->op_latefree) {
462 #ifdef DEBUG_LEAKING_SCALARS
469 Perl_op_clear(pTHX_ OP *o)
474 /* if (o->op_madprop && o->op_madprop->mad_next)
476 /* FIXME for MAD - if I uncomment these two lines t/op/pack.t fails with
477 "modification of a read only value" for a reason I can't fathom why.
478 It's the "" stringification of $_, where $_ was set to '' in a foreach
479 loop, but it defies simplification into a small test case.
480 However, commenting them out has caused ext/List/Util/t/weak.t to fail
483 mad_free(o->op_madprop);
489 switch (o->op_type) {
490 case OP_NULL: /* Was holding old type, if any. */
491 if (PL_madskills && o->op_targ != OP_NULL) {
492 o->op_type = o->op_targ;
496 case OP_ENTEREVAL: /* Was holding hints. */
500 if (!(o->op_flags & OPf_REF)
501 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
507 if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
508 /* not an OP_PADAV replacement */
510 if (cPADOPo->op_padix > 0) {
511 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
512 * may still exist on the pad */
513 pad_swipe(cPADOPo->op_padix, TRUE);
514 cPADOPo->op_padix = 0;
517 SvREFCNT_dec(cSVOPo->op_sv);
518 cSVOPo->op_sv = NULL;
522 case OP_METHOD_NAMED:
524 SvREFCNT_dec(cSVOPo->op_sv);
525 cSVOPo->op_sv = NULL;
528 Even if op_clear does a pad_free for the target of the op,
529 pad_free doesn't actually remove the sv that exists in the pad;
530 instead it lives on. This results in that it could be reused as
531 a target later on when the pad was reallocated.
534 pad_swipe(o->op_targ,1);
543 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
547 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
549 if (cPADOPo->op_padix > 0) {
550 pad_swipe(cPADOPo->op_padix, TRUE);
551 cPADOPo->op_padix = 0;
554 SvREFCNT_dec(cSVOPo->op_sv);
555 cSVOPo->op_sv = NULL;
559 PerlMemShared_free(cPVOPo->op_pv);
560 cPVOPo->op_pv = NULL;
564 op_free(cPMOPo->op_pmreplroot);
568 if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) {
569 /* No GvIN_PAD_off here, because other references may still
570 * exist on the pad */
571 pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot), TRUE);
574 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
581 HV * const pmstash = PmopSTASH(cPMOPo);
582 if (pmstash && !SvIS_FREED(pmstash)) {
583 MAGIC * const mg = mg_find((SV*)pmstash, PERL_MAGIC_symtab);
585 PMOP *pmop = (PMOP*) mg->mg_obj;
586 PMOP *lastpmop = NULL;
588 if (cPMOPo == pmop) {
590 lastpmop->op_pmnext = pmop->op_pmnext;
592 mg->mg_obj = (SV*) pmop->op_pmnext;
596 pmop = pmop->op_pmnext;
600 PmopSTASH_free(cPMOPo);
602 cPMOPo->op_pmreplroot = NULL;
603 /* we use the "SAFE" version of the PM_ macros here
604 * since sv_clean_all might release some PMOPs
605 * after PL_regex_padav has been cleared
606 * and the clearing of PL_regex_padav needs to
607 * happen before sv_clean_all
609 ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
610 PM_SETRE_SAFE(cPMOPo, NULL);
612 if(PL_regex_pad) { /* We could be in destruction */
613 av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
614 SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
615 PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
622 if (o->op_targ > 0) {
623 pad_free(o->op_targ);
629 S_cop_free(pTHX_ COP* cop)
634 if (! specialWARN(cop->cop_warnings))
635 PerlMemShared_free(cop->cop_warnings);
636 Perl_refcounted_he_free(aTHX_ cop->cop_hints_hash);
640 Perl_op_null(pTHX_ OP *o)
643 if (o->op_type == OP_NULL)
647 o->op_targ = o->op_type;
648 o->op_type = OP_NULL;
649 o->op_ppaddr = PL_ppaddr[OP_NULL];
653 Perl_op_refcnt_lock(pTHX)
661 Perl_op_refcnt_unlock(pTHX)
668 /* Contextualizers */
670 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
673 Perl_linklist(pTHX_ OP *o)
680 /* establish postfix order */
681 first = cUNOPo->op_first;
684 o->op_next = LINKLIST(first);
687 if (kid->op_sibling) {
688 kid->op_next = LINKLIST(kid->op_sibling);
689 kid = kid->op_sibling;
703 Perl_scalarkids(pTHX_ OP *o)
705 if (o && o->op_flags & OPf_KIDS) {
707 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
714 S_scalarboolean(pTHX_ OP *o)
717 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
718 if (ckWARN(WARN_SYNTAX)) {
719 const line_t oldline = CopLINE(PL_curcop);
721 if (PL_copline != NOLINE)
722 CopLINE_set(PL_curcop, PL_copline);
723 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
724 CopLINE_set(PL_curcop, oldline);
731 Perl_scalar(pTHX_ OP *o)
736 /* assumes no premature commitment */
737 if (!o || PL_error_count || (o->op_flags & OPf_WANT)
738 || o->op_type == OP_RETURN)
743 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
745 switch (o->op_type) {
747 scalar(cBINOPo->op_first);
752 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
756 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
757 if (!kPMOP->op_pmreplroot)
758 deprecate_old("implicit split to @_");
766 if (o->op_flags & OPf_KIDS) {
767 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
773 kid = cLISTOPo->op_first;
775 while ((kid = kid->op_sibling)) {
781 PL_curcop = &PL_compiling;
786 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
792 PL_curcop = &PL_compiling;
795 if (ckWARN(WARN_VOID))
796 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
802 Perl_scalarvoid(pTHX_ OP *o)
806 const char* useless = NULL;
810 /* trailing mad null ops don't count as "there" for void processing */
812 o->op_type != OP_NULL &&
814 o->op_sibling->op_type == OP_NULL)
817 for (sib = o->op_sibling;
818 sib && sib->op_type == OP_NULL;
819 sib = sib->op_sibling) ;
825 if (o->op_type == OP_NEXTSTATE
826 || o->op_type == OP_SETSTATE
827 || o->op_type == OP_DBSTATE
828 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
829 || o->op_targ == OP_SETSTATE
830 || o->op_targ == OP_DBSTATE)))
831 PL_curcop = (COP*)o; /* for warning below */
833 /* assumes no premature commitment */
834 want = o->op_flags & OPf_WANT;
835 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
836 || o->op_type == OP_RETURN)
841 if ((o->op_private & OPpTARGET_MY)
842 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
844 return scalar(o); /* As if inside SASSIGN */
847 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
849 switch (o->op_type) {
851 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
855 if (o->op_flags & OPf_STACKED)
859 if (o->op_private == 4)
931 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
932 useless = OP_DESC(o);
936 kid = cUNOPo->op_first;
937 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
938 kid->op_type != OP_TRANS) {
941 useless = "negative pattern binding (!~)";
948 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
949 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
950 useless = "a variable";
955 if (cSVOPo->op_private & OPpCONST_STRICT)
956 no_bareword_allowed(o);
958 if (ckWARN(WARN_VOID)) {
959 useless = "a constant";
960 if (o->op_private & OPpCONST_ARYBASE)
962 /* don't warn on optimised away booleans, eg
963 * use constant Foo, 5; Foo || print; */
964 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
966 /* the constants 0 and 1 are permitted as they are
967 conventionally used as dummies in constructs like
968 1 while some_condition_with_side_effects; */
969 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
971 else if (SvPOK(sv)) {
972 /* perl4's way of mixing documentation and code
973 (before the invention of POD) was based on a
974 trick to mix nroff and perl code. The trick was
975 built upon these three nroff macros being used in
976 void context. The pink camel has the details in
977 the script wrapman near page 319. */
978 const char * const maybe_macro = SvPVX_const(sv);
979 if (strnEQ(maybe_macro, "di", 2) ||
980 strnEQ(maybe_macro, "ds", 2) ||
981 strnEQ(maybe_macro, "ig", 2))
986 op_null(o); /* don't execute or even remember it */
990 o->op_type = OP_PREINC; /* pre-increment is faster */
991 o->op_ppaddr = PL_ppaddr[OP_PREINC];
995 o->op_type = OP_PREDEC; /* pre-decrement is faster */
996 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1000 o->op_type = OP_I_PREINC; /* pre-increment is faster */
1001 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1005 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
1006 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1015 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1020 if (o->op_flags & OPf_STACKED)
1027 if (!(o->op_flags & OPf_KIDS))
1038 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1045 /* all requires must return a boolean value */
1046 o->op_flags &= ~OPf_WANT;
1051 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
1052 if (!kPMOP->op_pmreplroot)
1053 deprecate_old("implicit split to @_");
1057 if (useless && ckWARN(WARN_VOID))
1058 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
1063 Perl_listkids(pTHX_ OP *o)
1065 if (o && o->op_flags & OPf_KIDS) {
1067 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1074 Perl_list(pTHX_ OP *o)
1079 /* assumes no premature commitment */
1080 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
1081 || o->op_type == OP_RETURN)
1086 if ((o->op_private & OPpTARGET_MY)
1087 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1089 return o; /* As if inside SASSIGN */
1092 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1094 switch (o->op_type) {
1097 list(cBINOPo->op_first);
1102 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1110 if (!(o->op_flags & OPf_KIDS))
1112 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1113 list(cBINOPo->op_first);
1114 return gen_constant_list(o);
1121 kid = cLISTOPo->op_first;
1123 while ((kid = kid->op_sibling)) {
1124 if (kid->op_sibling)
1129 PL_curcop = &PL_compiling;
1133 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1134 if (kid->op_sibling)
1139 PL_curcop = &PL_compiling;
1142 /* all requires must return a boolean value */
1143 o->op_flags &= ~OPf_WANT;
1150 Perl_scalarseq(pTHX_ OP *o)
1154 const OPCODE type = o->op_type;
1156 if (type == OP_LINESEQ || type == OP_SCOPE ||
1157 type == OP_LEAVE || type == OP_LEAVETRY)
1160 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1161 if (kid->op_sibling) {
1165 PL_curcop = &PL_compiling;
1167 o->op_flags &= ~OPf_PARENS;
1168 if (PL_hints & HINT_BLOCK_SCOPE)
1169 o->op_flags |= OPf_PARENS;
1172 o = newOP(OP_STUB, 0);
1177 S_modkids(pTHX_ OP *o, I32 type)
1179 if (o && o->op_flags & OPf_KIDS) {
1181 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1187 /* Propagate lvalue ("modifiable") context to an op and its children.
1188 * 'type' represents the context type, roughly based on the type of op that
1189 * would do the modifying, although local() is represented by OP_NULL.
1190 * It's responsible for detecting things that can't be modified, flag
1191 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
1192 * might have to vivify a reference in $x), and so on.
1194 * For example, "$a+1 = 2" would cause mod() to be called with o being
1195 * OP_ADD and type being OP_SASSIGN, and would output an error.
1199 Perl_mod(pTHX_ OP *o, I32 type)
1203 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1206 if (!o || PL_error_count)
1209 if ((o->op_private & OPpTARGET_MY)
1210 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1215 switch (o->op_type) {
1221 if (!(o->op_private & OPpCONST_ARYBASE))
1224 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1225 CopARYBASE_set(&PL_compiling,
1226 (I32)SvIV(cSVOPx(PL_eval_start)->op_sv));
1230 SAVECOPARYBASE(&PL_compiling);
1231 CopARYBASE_set(&PL_compiling, 0);
1233 else if (type == OP_REFGEN)
1236 Perl_croak(aTHX_ "That use of $[ is unsupported");
1239 if (o->op_flags & OPf_PARENS || PL_madskills)
1243 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1244 !(o->op_flags & OPf_STACKED)) {
1245 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1246 /* The default is to set op_private to the number of children,
1247 which for a UNOP such as RV2CV is always 1. And w're using
1248 the bit for a flag in RV2CV, so we need it clear. */
1249 o->op_private &= ~1;
1250 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1251 assert(cUNOPo->op_first->op_type == OP_NULL);
1252 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1255 else if (o->op_private & OPpENTERSUB_NOMOD)
1257 else { /* lvalue subroutine call */
1258 o->op_private |= OPpLVAL_INTRO;
1259 PL_modcount = RETURN_UNLIMITED_NUMBER;
1260 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1261 /* Backward compatibility mode: */
1262 o->op_private |= OPpENTERSUB_INARGS;
1265 else { /* Compile-time error message: */
1266 OP *kid = cUNOPo->op_first;
1270 if (kid->op_type != OP_PUSHMARK) {
1271 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1273 "panic: unexpected lvalue entersub "
1274 "args: type/targ %ld:%"UVuf,
1275 (long)kid->op_type, (UV)kid->op_targ);
1276 kid = kLISTOP->op_first;
1278 while (kid->op_sibling)
1279 kid = kid->op_sibling;
1280 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1282 if (kid->op_type == OP_METHOD_NAMED
1283 || kid->op_type == OP_METHOD)
1287 NewOp(1101, newop, 1, UNOP);
1288 newop->op_type = OP_RV2CV;
1289 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1290 newop->op_first = NULL;
1291 newop->op_next = (OP*)newop;
1292 kid->op_sibling = (OP*)newop;
1293 newop->op_private |= OPpLVAL_INTRO;
1294 newop->op_private &= ~1;
1298 if (kid->op_type != OP_RV2CV)
1300 "panic: unexpected lvalue entersub "
1301 "entry via type/targ %ld:%"UVuf,
1302 (long)kid->op_type, (UV)kid->op_targ);
1303 kid->op_private |= OPpLVAL_INTRO;
1304 break; /* Postpone until runtime */
1308 kid = kUNOP->op_first;
1309 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1310 kid = kUNOP->op_first;
1311 if (kid->op_type == OP_NULL)
1313 "Unexpected constant lvalue entersub "
1314 "entry via type/targ %ld:%"UVuf,
1315 (long)kid->op_type, (UV)kid->op_targ);
1316 if (kid->op_type != OP_GV) {
1317 /* Restore RV2CV to check lvalueness */
1319 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1320 okid->op_next = kid->op_next;
1321 kid->op_next = okid;
1324 okid->op_next = NULL;
1325 okid->op_type = OP_RV2CV;
1327 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1328 okid->op_private |= OPpLVAL_INTRO;
1329 okid->op_private &= ~1;
1333 cv = GvCV(kGVOP_gv);
1343 /* grep, foreach, subcalls, refgen */
1344 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1346 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1347 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1349 : (o->op_type == OP_ENTERSUB
1350 ? "non-lvalue subroutine call"
1352 type ? PL_op_desc[type] : "local"));
1366 case OP_RIGHT_SHIFT:
1375 if (!(o->op_flags & OPf_STACKED))
1382 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1388 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1389 PL_modcount = RETURN_UNLIMITED_NUMBER;
1390 return o; /* Treat \(@foo) like ordinary list. */
1394 if (scalar_mod_type(o, type))
1396 ref(cUNOPo->op_first, o->op_type);
1400 if (type == OP_LEAVESUBLV)
1401 o->op_private |= OPpMAYBE_LVSUB;
1407 PL_modcount = RETURN_UNLIMITED_NUMBER;
1410 ref(cUNOPo->op_first, o->op_type);
1415 PL_hints |= HINT_BLOCK_SCOPE;
1430 PL_modcount = RETURN_UNLIMITED_NUMBER;
1431 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1432 return o; /* Treat \(@foo) like ordinary list. */
1433 if (scalar_mod_type(o, type))
1435 if (type == OP_LEAVESUBLV)
1436 o->op_private |= OPpMAYBE_LVSUB;
1440 if (!type) /* local() */
1441 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1442 PAD_COMPNAME_PV(o->op_targ));
1450 if (type != OP_SASSIGN)
1454 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1459 if (type == OP_LEAVESUBLV)
1460 o->op_private |= OPpMAYBE_LVSUB;
1462 pad_free(o->op_targ);
1463 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1464 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1465 if (o->op_flags & OPf_KIDS)
1466 mod(cBINOPo->op_first->op_sibling, type);
1471 ref(cBINOPo->op_first, o->op_type);
1472 if (type == OP_ENTERSUB &&
1473 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1474 o->op_private |= OPpLVAL_DEFER;
1475 if (type == OP_LEAVESUBLV)
1476 o->op_private |= OPpMAYBE_LVSUB;
1486 if (o->op_flags & OPf_KIDS)
1487 mod(cLISTOPo->op_last, type);
1492 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1494 else if (!(o->op_flags & OPf_KIDS))
1496 if (o->op_targ != OP_LIST) {
1497 mod(cBINOPo->op_first, type);
1503 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1508 if (type != OP_LEAVESUBLV)
1510 break; /* mod()ing was handled by ck_return() */
1513 /* [20011101.069] File test operators interpret OPf_REF to mean that
1514 their argument is a filehandle; thus \stat(".") should not set
1516 if (type == OP_REFGEN &&
1517 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1520 if (type != OP_LEAVESUBLV)
1521 o->op_flags |= OPf_MOD;
1523 if (type == OP_AASSIGN || type == OP_SASSIGN)
1524 o->op_flags |= OPf_SPECIAL|OPf_REF;
1525 else if (!type) { /* local() */
1528 o->op_private |= OPpLVAL_INTRO;
1529 o->op_flags &= ~OPf_SPECIAL;
1530 PL_hints |= HINT_BLOCK_SCOPE;
1535 if (ckWARN(WARN_SYNTAX)) {
1536 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1537 "Useless localization of %s", OP_DESC(o));
1541 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1542 && type != OP_LEAVESUBLV)
1543 o->op_flags |= OPf_REF;
1548 S_scalar_mod_type(const OP *o, I32 type)
1552 if (o->op_type == OP_RV2GV)
1576 case OP_RIGHT_SHIFT:
1595 S_is_handle_constructor(const OP *o, I32 numargs)
1597 switch (o->op_type) {
1605 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1618 Perl_refkids(pTHX_ OP *o, I32 type)
1620 if (o && o->op_flags & OPf_KIDS) {
1622 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1629 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
1634 if (!o || PL_error_count)
1637 switch (o->op_type) {
1639 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1640 !(o->op_flags & OPf_STACKED)) {
1641 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1642 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1643 assert(cUNOPo->op_first->op_type == OP_NULL);
1644 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1645 o->op_flags |= OPf_SPECIAL;
1646 o->op_private &= ~1;
1651 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1652 doref(kid, type, set_op_ref);
1655 if (type == OP_DEFINED)
1656 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1657 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1660 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1661 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1662 : type == OP_RV2HV ? OPpDEREF_HV
1664 o->op_flags |= OPf_MOD;
1671 o->op_flags |= OPf_REF;
1674 if (type == OP_DEFINED)
1675 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1676 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1682 o->op_flags |= OPf_REF;
1687 if (!(o->op_flags & OPf_KIDS))
1689 doref(cBINOPo->op_first, type, set_op_ref);
1693 doref(cBINOPo->op_first, o->op_type, set_op_ref);
1694 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1695 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1696 : type == OP_RV2HV ? OPpDEREF_HV
1698 o->op_flags |= OPf_MOD;
1708 if (!(o->op_flags & OPf_KIDS))
1710 doref(cLISTOPo->op_last, type, set_op_ref);
1720 S_dup_attrlist(pTHX_ OP *o)
1725 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1726 * where the first kid is OP_PUSHMARK and the remaining ones
1727 * are OP_CONST. We need to push the OP_CONST values.
1729 if (o->op_type == OP_CONST)
1730 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
1732 else if (o->op_type == OP_NULL)
1736 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1738 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1739 if (o->op_type == OP_CONST)
1740 rop = append_elem(OP_LIST, rop,
1741 newSVOP(OP_CONST, o->op_flags,
1742 SvREFCNT_inc_NN(cSVOPo->op_sv)));
1749 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1754 /* fake up C<use attributes $pkg,$rv,@attrs> */
1755 ENTER; /* need to protect against side-effects of 'use' */
1757 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1759 #define ATTRSMODULE "attributes"
1760 #define ATTRSMODULE_PM "attributes.pm"
1763 /* Don't force the C<use> if we don't need it. */
1764 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
1765 if (svp && *svp != &PL_sv_undef)
1766 NOOP; /* already in %INC */
1768 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1769 newSVpvs(ATTRSMODULE), NULL);
1772 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1773 newSVpvs(ATTRSMODULE),
1775 prepend_elem(OP_LIST,
1776 newSVOP(OP_CONST, 0, stashsv),
1777 prepend_elem(OP_LIST,
1778 newSVOP(OP_CONST, 0,
1780 dup_attrlist(attrs))));
1786 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1789 OP *pack, *imop, *arg;
1795 assert(target->op_type == OP_PADSV ||
1796 target->op_type == OP_PADHV ||
1797 target->op_type == OP_PADAV);
1799 /* Ensure that attributes.pm is loaded. */
1800 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1802 /* Need package name for method call. */
1803 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
1805 /* Build up the real arg-list. */
1806 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1808 arg = newOP(OP_PADSV, 0);
1809 arg->op_targ = target->op_targ;
1810 arg = prepend_elem(OP_LIST,
1811 newSVOP(OP_CONST, 0, stashsv),
1812 prepend_elem(OP_LIST,
1813 newUNOP(OP_REFGEN, 0,
1814 mod(arg, OP_REFGEN)),
1815 dup_attrlist(attrs)));
1817 /* Fake up a method call to import */
1818 meth = newSVpvs_share("import");
1819 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1820 append_elem(OP_LIST,
1821 prepend_elem(OP_LIST, pack, list(arg)),
1822 newSVOP(OP_METHOD_NAMED, 0, meth)));
1823 imop->op_private |= OPpENTERSUB_NOMOD;
1825 /* Combine the ops. */
1826 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1830 =notfor apidoc apply_attrs_string
1832 Attempts to apply a list of attributes specified by the C<attrstr> and
1833 C<len> arguments to the subroutine identified by the C<cv> argument which
1834 is expected to be associated with the package identified by the C<stashpv>
1835 argument (see L<attributes>). It gets this wrong, though, in that it
1836 does not correctly identify the boundaries of the individual attribute
1837 specifications within C<attrstr>. This is not really intended for the
1838 public API, but has to be listed here for systems such as AIX which
1839 need an explicit export list for symbols. (It's called from XS code
1840 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1841 to respect attribute syntax properly would be welcome.
1847 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
1848 const char *attrstr, STRLEN len)
1853 len = strlen(attrstr);
1857 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1859 const char * const sstr = attrstr;
1860 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1861 attrs = append_elem(OP_LIST, attrs,
1862 newSVOP(OP_CONST, 0,
1863 newSVpvn(sstr, attrstr-sstr)));
1867 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1868 newSVpvs(ATTRSMODULE),
1869 NULL, prepend_elem(OP_LIST,
1870 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1871 prepend_elem(OP_LIST,
1872 newSVOP(OP_CONST, 0,
1878 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
1883 if (!o || PL_error_count)
1887 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
1888 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
1892 if (type == OP_LIST) {
1894 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1895 my_kid(kid, attrs, imopsp);
1896 } else if (type == OP_UNDEF
1902 } else if (type == OP_RV2SV || /* "our" declaration */
1904 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1905 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1906 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1908 PL_in_my == KEY_our ? "our" : PL_in_my == KEY_state ? "state" : "my"));
1910 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
1912 PL_in_my_stash = NULL;
1913 apply_attrs(GvSTASH(gv),
1914 (type == OP_RV2SV ? GvSV(gv) :
1915 type == OP_RV2AV ? (SV*)GvAV(gv) :
1916 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1919 o->op_private |= OPpOUR_INTRO;
1922 else if (type != OP_PADSV &&
1925 type != OP_PUSHMARK)
1927 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1929 PL_in_my == KEY_our ? "our" : PL_in_my == KEY_state ? "state" : "my"));
1932 else if (attrs && type != OP_PUSHMARK) {
1936 PL_in_my_stash = NULL;
1938 /* check for C<my Dog $spot> when deciding package */
1939 stash = PAD_COMPNAME_TYPE(o->op_targ);
1941 stash = PL_curstash;
1942 apply_attrs_my(stash, o, attrs, imopsp);
1944 o->op_flags |= OPf_MOD;
1945 o->op_private |= OPpLVAL_INTRO;
1946 if (PL_in_my == KEY_state)
1947 o->op_private |= OPpPAD_STATE;
1952 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1956 int maybe_scalar = 0;
1958 /* [perl #17376]: this appears to be premature, and results in code such as
1959 C< our(%x); > executing in list mode rather than void mode */
1961 if (o->op_flags & OPf_PARENS)
1971 o = my_kid(o, attrs, &rops);
1973 if (maybe_scalar && o->op_type == OP_PADSV) {
1974 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
1975 o->op_private |= OPpLVAL_INTRO;
1978 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
1981 PL_in_my_stash = NULL;
1986 Perl_my(pTHX_ OP *o)
1988 return my_attrs(o, NULL);
1992 Perl_sawparens(pTHX_ OP *o)
1994 PERL_UNUSED_CONTEXT;
1996 o->op_flags |= OPf_PARENS;
2001 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2005 const OPCODE ltype = left->op_type;
2006 const OPCODE rtype = right->op_type;
2008 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2009 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
2011 const char * const desc
2012 = PL_op_desc[(rtype == OP_SUBST || rtype == OP_TRANS)
2013 ? (int)rtype : OP_MATCH];
2014 const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV)
2015 ? "@array" : "%hash");
2016 Perl_warner(aTHX_ packWARN(WARN_MISC),
2017 "Applying %s to %s will act on scalar(%s)",
2018 desc, sample, sample);
2021 if (rtype == OP_CONST &&
2022 cSVOPx(right)->op_private & OPpCONST_BARE &&
2023 cSVOPx(right)->op_private & OPpCONST_STRICT)
2025 no_bareword_allowed(right);
2028 ismatchop = rtype == OP_MATCH ||
2029 rtype == OP_SUBST ||
2031 if (ismatchop && right->op_private & OPpTARGET_MY) {
2033 right->op_private &= ~OPpTARGET_MY;
2035 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
2038 right->op_flags |= OPf_STACKED;
2039 if (rtype != OP_MATCH &&
2040 ! (rtype == OP_TRANS &&
2041 right->op_private & OPpTRANS_IDENTICAL))
2042 newleft = mod(left, rtype);
2045 if (right->op_type == OP_TRANS)
2046 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
2048 o = prepend_elem(rtype, scalar(newleft), right);
2050 return newUNOP(OP_NOT, 0, scalar(o));
2054 return bind_match(type, left,
2055 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
2059 Perl_invert(pTHX_ OP *o)
2063 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2067 Perl_scope(pTHX_ OP *o)
2071 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2072 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2073 o->op_type = OP_LEAVE;
2074 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2076 else if (o->op_type == OP_LINESEQ) {
2078 o->op_type = OP_SCOPE;
2079 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2080 kid = ((LISTOP*)o)->op_first;
2081 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2084 /* The following deals with things like 'do {1 for 1}' */
2085 kid = kid->op_sibling;
2087 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2092 o = newLISTOP(OP_SCOPE, 0, o, NULL);
2098 Perl_block_start(pTHX_ int full)
2101 const int retval = PL_savestack_ix;
2102 pad_block_start(full);
2104 PL_hints &= ~HINT_BLOCK_SCOPE;
2105 SAVECOMPILEWARNINGS();
2106 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
2111 Perl_block_end(pTHX_ I32 floor, OP *seq)
2114 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2115 OP* const retval = scalarseq(seq);
2117 CopHINTS_set(&PL_compiling, PL_hints);
2119 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2128 const PADOFFSET offset = pad_findmy("$_");
2129 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
2130 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2133 OP * const o = newOP(OP_PADSV, 0);
2134 o->op_targ = offset;
2140 Perl_newPROG(pTHX_ OP *o)
2146 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2147 ((PL_in_eval & EVAL_KEEPERR)
2148 ? OPf_SPECIAL : 0), o);
2149 PL_eval_start = linklist(PL_eval_root);
2150 PL_eval_root->op_private |= OPpREFCOUNTED;
2151 OpREFCNT_set(PL_eval_root, 1);
2152 PL_eval_root->op_next = 0;
2153 CALL_PEEP(PL_eval_start);
2156 if (o->op_type == OP_STUB) {
2157 PL_comppad_name = 0;
2159 S_op_destroy(aTHX_ o);
2162 PL_main_root = scope(sawparens(scalarvoid(o)));
2163 PL_curcop = &PL_compiling;
2164 PL_main_start = LINKLIST(PL_main_root);
2165 PL_main_root->op_private |= OPpREFCOUNTED;
2166 OpREFCNT_set(PL_main_root, 1);
2167 PL_main_root->op_next = 0;
2168 CALL_PEEP(PL_main_start);
2171 /* Register with debugger */
2174 = Perl_get_cvn_flags(aTHX_ STR_WITH_LEN("DB::postponed"), 0);
2178 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2180 call_sv((SV*)cv, G_DISCARD);
2187 Perl_localize(pTHX_ OP *o, I32 lex)
2190 if (o->op_flags & OPf_PARENS)
2191 /* [perl #17376]: this appears to be premature, and results in code such as
2192 C< our(%x); > executing in list mode rather than void mode */
2199 if ( PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ','
2200 && ckWARN(WARN_PARENTHESIS))
2202 char *s = PL_bufptr;
2205 /* some heuristics to detect a potential error */
2206 while (*s && (strchr(", \t\n", *s)))
2210 if (*s && strchr("@$%*", *s) && *++s
2211 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2214 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2216 while (*s && (strchr(", \t\n", *s)))
2222 if (sigil && (*s == ';' || *s == '=')) {
2223 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2224 "Parentheses missing around \"%s\" list",
2225 lex ? (PL_in_my == KEY_our ? "our" : PL_in_my == KEY_state ? "state" : "my")
2233 o = mod(o, OP_NULL); /* a bit kludgey */
2235 PL_in_my_stash = NULL;
2240 Perl_jmaybe(pTHX_ OP *o)
2242 if (o->op_type == OP_LIST) {
2244 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2245 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2251 Perl_fold_constants(pTHX_ register OP *o)
2256 VOL I32 type = o->op_type;
2261 SV * const oldwarnhook = PL_warnhook;
2262 SV * const olddiehook = PL_diehook;
2265 if (PL_opargs[type] & OA_RETSCALAR)
2267 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2268 o->op_targ = pad_alloc(type, SVs_PADTMP);
2270 /* integerize op, unless it happens to be C<-foo>.
2271 * XXX should pp_i_negate() do magic string negation instead? */
2272 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2273 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2274 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2276 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2279 if (!(PL_opargs[type] & OA_FOLDCONST))
2284 /* XXX might want a ck_negate() for this */
2285 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2296 /* XXX what about the numeric ops? */
2297 if (PL_hints & HINT_LOCALE)
2302 goto nope; /* Don't try to run w/ errors */
2304 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2305 const OPCODE type = curop->op_type;
2306 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2308 type != OP_SCALAR &&
2310 type != OP_PUSHMARK)
2316 curop = LINKLIST(o);
2317 old_next = o->op_next;
2321 oldscope = PL_scopestack_ix;
2322 create_eval_scope(G_FAKINGEVAL);
2324 PL_warnhook = PERL_WARNHOOK_FATAL;
2331 sv = *(PL_stack_sp--);
2332 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2333 pad_swipe(o->op_targ, FALSE);
2334 else if (SvTEMP(sv)) { /* grab mortal temp? */
2335 SvREFCNT_inc_simple_void(sv);
2340 /* Something tried to die. Abandon constant folding. */
2341 /* Pretend the error never happened. */
2342 sv_setpvn(ERRSV,"",0);
2343 o->op_next = old_next;
2347 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
2348 PL_warnhook = oldwarnhook;
2349 PL_diehook = olddiehook;
2350 /* XXX note that this croak may fail as we've already blown away
2351 * the stack - eg any nested evals */
2352 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
2355 PL_warnhook = oldwarnhook;
2356 PL_diehook = olddiehook;
2358 if (PL_scopestack_ix > oldscope)
2359 delete_eval_scope();
2368 if (type == OP_RV2GV)
2369 newop = newGVOP(OP_GV, 0, (GV*)sv);
2371 newop = newSVOP(OP_CONST, 0, (SV*)sv);
2372 op_getmad(o,newop,'f');
2380 Perl_gen_constant_list(pTHX_ register OP *o)
2384 const I32 oldtmps_floor = PL_tmps_floor;
2388 return o; /* Don't attempt to run with errors */
2390 PL_op = curop = LINKLIST(o);
2396 assert (!(curop->op_flags & OPf_SPECIAL));
2397 assert(curop->op_type == OP_RANGE);
2399 PL_tmps_floor = oldtmps_floor;
2401 o->op_type = OP_RV2AV;
2402 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2403 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2404 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2405 o->op_opt = 0; /* needs to be revisited in peep() */
2406 curop = ((UNOP*)o)->op_first;
2407 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
2409 op_getmad(curop,o,'O');
2418 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2421 if (!o || o->op_type != OP_LIST)
2422 o = newLISTOP(OP_LIST, 0, o, NULL);
2424 o->op_flags &= ~OPf_WANT;
2426 if (!(PL_opargs[type] & OA_MARK))
2427 op_null(cLISTOPo->op_first);
2429 o->op_type = (OPCODE)type;
2430 o->op_ppaddr = PL_ppaddr[type];
2431 o->op_flags |= flags;
2433 o = CHECKOP(type, o);
2434 if (o->op_type != (unsigned)type)
2437 return fold_constants(o);
2440 /* List constructors */
2443 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2451 if (first->op_type != (unsigned)type
2452 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2454 return newLISTOP(type, 0, first, last);
2457 if (first->op_flags & OPf_KIDS)
2458 ((LISTOP*)first)->op_last->op_sibling = last;
2460 first->op_flags |= OPf_KIDS;
2461 ((LISTOP*)first)->op_first = last;
2463 ((LISTOP*)first)->op_last = last;
2468 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2476 if (first->op_type != (unsigned)type)
2477 return prepend_elem(type, (OP*)first, (OP*)last);
2479 if (last->op_type != (unsigned)type)
2480 return append_elem(type, (OP*)first, (OP*)last);
2482 first->op_last->op_sibling = last->op_first;
2483 first->op_last = last->op_last;
2484 first->op_flags |= (last->op_flags & OPf_KIDS);
2487 if (last->op_first && first->op_madprop) {
2488 MADPROP *mp = last->op_first->op_madprop;
2490 while (mp->mad_next)
2492 mp->mad_next = first->op_madprop;
2495 last->op_first->op_madprop = first->op_madprop;
2498 first->op_madprop = last->op_madprop;
2499 last->op_madprop = 0;
2502 S_op_destroy(aTHX_ (OP*)last);
2508 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2516 if (last->op_type == (unsigned)type) {
2517 if (type == OP_LIST) { /* already a PUSHMARK there */
2518 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2519 ((LISTOP*)last)->op_first->op_sibling = first;
2520 if (!(first->op_flags & OPf_PARENS))
2521 last->op_flags &= ~OPf_PARENS;
2524 if (!(last->op_flags & OPf_KIDS)) {
2525 ((LISTOP*)last)->op_last = first;
2526 last->op_flags |= OPf_KIDS;
2528 first->op_sibling = ((LISTOP*)last)->op_first;
2529 ((LISTOP*)last)->op_first = first;
2531 last->op_flags |= OPf_KIDS;
2535 return newLISTOP(type, 0, first, last);
2543 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2546 Newxz(tk, 1, TOKEN);
2547 tk->tk_type = (OPCODE)optype;
2548 tk->tk_type = 12345;
2550 tk->tk_mad = madprop;
2555 Perl_token_free(pTHX_ TOKEN* tk)
2557 if (tk->tk_type != 12345)
2559 mad_free(tk->tk_mad);
2564 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2568 if (tk->tk_type != 12345) {
2569 Perl_warner(aTHX_ packWARN(WARN_MISC),
2570 "Invalid TOKEN object ignored");
2577 /* faked up qw list? */
2579 tm->mad_type == MAD_SV &&
2580 SvPVX((SV*)tm->mad_val)[0] == 'q')
2587 /* pretend constant fold didn't happen? */
2588 if (mp->mad_key == 'f' &&
2589 (o->op_type == OP_CONST ||
2590 o->op_type == OP_GV) )
2592 token_getmad(tk,(OP*)mp->mad_val,slot);
2606 if (mp->mad_key == 'X')
2607 mp->mad_key = slot; /* just change the first one */
2617 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
2626 /* pretend constant fold didn't happen? */
2627 if (mp->mad_key == 'f' &&
2628 (o->op_type == OP_CONST ||
2629 o->op_type == OP_GV) )
2631 op_getmad(from,(OP*)mp->mad_val,slot);
2638 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
2641 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
2647 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
2656 /* pretend constant fold didn't happen? */
2657 if (mp->mad_key == 'f' &&
2658 (o->op_type == OP_CONST ||
2659 o->op_type == OP_GV) )
2661 op_getmad(from,(OP*)mp->mad_val,slot);
2668 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
2671 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
2675 PerlIO_printf(PerlIO_stderr(),
2676 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
2682 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
2700 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
2704 addmad(tm, &(o->op_madprop), slot);
2708 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
2729 Perl_newMADsv(pTHX_ char key, SV* sv)
2731 return newMADPROP(key, MAD_SV, sv, 0);
2735 Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
2738 Newxz(mp, 1, MADPROP);
2741 mp->mad_vlen = vlen;
2742 mp->mad_type = type;
2744 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
2749 Perl_mad_free(pTHX_ MADPROP* mp)
2751 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
2755 mad_free(mp->mad_next);
2756 /* if (PL_lex_state != LEX_NOTPARSING && mp->mad_vlen)
2757 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
2758 switch (mp->mad_type) {
2762 Safefree((char*)mp->mad_val);
2765 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
2766 op_free((OP*)mp->mad_val);
2769 sv_free((SV*)mp->mad_val);
2772 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
2781 Perl_newNULLLIST(pTHX)
2783 return newOP(OP_STUB, 0);
2787 Perl_force_list(pTHX_ OP *o)
2789 if (!o || o->op_type != OP_LIST)
2790 o = newLISTOP(OP_LIST, 0, o, NULL);
2796 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2801 NewOp(1101, listop, 1, LISTOP);
2803 listop->op_type = (OPCODE)type;
2804 listop->op_ppaddr = PL_ppaddr[type];
2807 listop->op_flags = (U8)flags;
2811 else if (!first && last)
2814 first->op_sibling = last;
2815 listop->op_first = first;
2816 listop->op_last = last;
2817 if (type == OP_LIST) {
2818 OP* const pushop = newOP(OP_PUSHMARK, 0);
2819 pushop->op_sibling = first;
2820 listop->op_first = pushop;
2821 listop->op_flags |= OPf_KIDS;
2823 listop->op_last = pushop;
2826 return CHECKOP(type, listop);
2830 Perl_newOP(pTHX_ I32 type, I32 flags)
2834 NewOp(1101, o, 1, OP);
2835 o->op_type = (OPCODE)type;
2836 o->op_ppaddr = PL_ppaddr[type];
2837 o->op_flags = (U8)flags;
2839 o->op_latefreed = 0;
2843 o->op_private = (U8)(0 | (flags >> 8));
2844 if (PL_opargs[type] & OA_RETSCALAR)
2846 if (PL_opargs[type] & OA_TARGET)
2847 o->op_targ = pad_alloc(type, SVs_PADTMP);
2848 return CHECKOP(type, o);
2852 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2858 first = newOP(OP_STUB, 0);
2859 if (PL_opargs[type] & OA_MARK)
2860 first = force_list(first);
2862 NewOp(1101, unop, 1, UNOP);
2863 unop->op_type = (OPCODE)type;
2864 unop->op_ppaddr = PL_ppaddr[type];
2865 unop->op_first = first;
2866 unop->op_flags = (U8)(flags | OPf_KIDS);
2867 unop->op_private = (U8)(1 | (flags >> 8));
2868 unop = (UNOP*) CHECKOP(type, unop);
2872 return fold_constants((OP *) unop);
2876 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2880 NewOp(1101, binop, 1, BINOP);
2883 first = newOP(OP_NULL, 0);
2885 binop->op_type = (OPCODE)type;
2886 binop->op_ppaddr = PL_ppaddr[type];
2887 binop->op_first = first;
2888 binop->op_flags = (U8)(flags | OPf_KIDS);
2891 binop->op_private = (U8)(1 | (flags >> 8));
2894 binop->op_private = (U8)(2 | (flags >> 8));
2895 first->op_sibling = last;
2898 binop = (BINOP*)CHECKOP(type, binop);
2899 if (binop->op_next || binop->op_type != (OPCODE)type)
2902 binop->op_last = binop->op_first->op_sibling;
2904 return fold_constants((OP *)binop);
2907 static int uvcompare(const void *a, const void *b)
2908 __attribute__nonnull__(1)
2909 __attribute__nonnull__(2)
2910 __attribute__pure__;
2911 static int uvcompare(const void *a, const void *b)
2913 if (*((const UV *)a) < (*(const UV *)b))
2915 if (*((const UV *)a) > (*(const UV *)b))
2917 if (*((const UV *)a+1) < (*(const UV *)b+1))
2919 if (*((const UV *)a+1) > (*(const UV *)b+1))
2925 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2928 SV * const tstr = ((SVOP*)expr)->op_sv;
2931 (repl->op_type == OP_NULL)
2932 ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
2934 ((SVOP*)repl)->op_sv;
2937 const U8 *t = (U8*)SvPV_const(tstr, tlen);
2938 const U8 *r = (U8*)SvPV_const(rstr, rlen);
2942 register short *tbl;
2944 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
2945 const I32 squash = o->op_private & OPpTRANS_SQUASH;
2946 I32 del = o->op_private & OPpTRANS_DELETE;
2948 PL_hints |= HINT_BLOCK_SCOPE;
2951 o->op_private |= OPpTRANS_FROM_UTF;
2954 o->op_private |= OPpTRANS_TO_UTF;
2956 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2957 SV* const listsv = newSVpvs("# comment\n");
2959 const U8* tend = t + tlen;
2960 const U8* rend = r + rlen;
2974 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2975 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2978 const U32 flags = UTF8_ALLOW_DEFAULT;
2982 t = tsave = bytes_to_utf8(t, &len);
2985 if (!to_utf && rlen) {
2987 r = rsave = bytes_to_utf8(r, &len);
2991 /* There are several snags with this code on EBCDIC:
2992 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2993 2. scan_const() in toke.c has encoded chars in native encoding which makes
2994 ranges at least in EBCDIC 0..255 range the bottom odd.
2998 U8 tmpbuf[UTF8_MAXBYTES+1];
3001 Newx(cp, 2*tlen, UV);
3003 transv = newSVpvs("");
3005 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3007 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
3009 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3013 cp[2*i+1] = cp[2*i];
3017 qsort(cp, i, 2*sizeof(UV), uvcompare);
3018 for (j = 0; j < i; j++) {
3020 diff = val - nextmin;
3022 t = uvuni_to_utf8(tmpbuf,nextmin);
3023 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3025 U8 range_mark = UTF_TO_NATIVE(0xff);
3026 t = uvuni_to_utf8(tmpbuf, val - 1);
3027 sv_catpvn(transv, (char *)&range_mark, 1);
3028 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3035 t = uvuni_to_utf8(tmpbuf,nextmin);
3036 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3038 U8 range_mark = UTF_TO_NATIVE(0xff);
3039 sv_catpvn(transv, (char *)&range_mark, 1);
3041 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
3042 UNICODE_ALLOW_SUPER);
3043 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3044 t = (const U8*)SvPVX_const(transv);
3045 tlen = SvCUR(transv);
3049 else if (!rlen && !del) {
3050 r = t; rlen = tlen; rend = tend;
3053 if ((!rlen && !del) || t == r ||
3054 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
3056 o->op_private |= OPpTRANS_IDENTICAL;
3060 while (t < tend || tfirst <= tlast) {
3061 /* see if we need more "t" chars */
3062 if (tfirst > tlast) {
3063 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3065 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
3067 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3074 /* now see if we need more "r" chars */
3075 if (rfirst > rlast) {
3077 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3079 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
3081 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3090 rfirst = rlast = 0xffffffff;
3094 /* now see which range will peter our first, if either. */
3095 tdiff = tlast - tfirst;
3096 rdiff = rlast - rfirst;
3103 if (rfirst == 0xffffffff) {
3104 diff = tdiff; /* oops, pretend rdiff is infinite */
3106 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
3107 (long)tfirst, (long)tlast);
3109 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
3113 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
3114 (long)tfirst, (long)(tfirst + diff),
3117 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3118 (long)tfirst, (long)rfirst);
3120 if (rfirst + diff > max)
3121 max = rfirst + diff;
3123 grows = (tfirst < rfirst &&
3124 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3136 else if (max > 0xff)
3141 PerlMemShared_free(cPVOPo->op_pv);
3142 cPVOPo->op_pv = NULL;
3144 swash = (SV*)swash_init("utf8", "", listsv, bits, none);
3146 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
3147 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
3148 PAD_SETSV(cPADOPo->op_padix, swash);
3151 cSVOPo->op_sv = swash;
3153 SvREFCNT_dec(listsv);
3154 SvREFCNT_dec(transv);
3156 if (!del && havefinal && rlen)
3157 (void)hv_store((HV*)SvRV(swash), "FINAL", 5,
3158 newSVuv((UV)final), 0);
3161 o->op_private |= OPpTRANS_GROWS;
3167 op_getmad(expr,o,'e');
3168 op_getmad(repl,o,'r');
3176 tbl = (short*)cPVOPo->op_pv;
3178 Zero(tbl, 256, short);
3179 for (i = 0; i < (I32)tlen; i++)
3181 for (i = 0, j = 0; i < 256; i++) {
3183 if (j >= (I32)rlen) {
3192 if (i < 128 && r[j] >= 128)
3202 o->op_private |= OPpTRANS_IDENTICAL;
3204 else if (j >= (I32)rlen)
3209 PerlMemShared_realloc(tbl,
3210 (0x101+rlen-j) * sizeof(short));
3211 cPVOPo->op_pv = (char*)tbl;
3213 tbl[0x100] = (short)(rlen - j);
3214 for (i=0; i < (I32)rlen - j; i++)
3215 tbl[0x101+i] = r[j+i];
3219 if (!rlen && !del) {
3222 o->op_private |= OPpTRANS_IDENTICAL;
3224 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3225 o->op_private |= OPpTRANS_IDENTICAL;
3227 for (i = 0; i < 256; i++)
3229 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3230 if (j >= (I32)rlen) {
3232 if (tbl[t[i]] == -1)
3238 if (tbl[t[i]] == -1) {
3239 if (t[i] < 128 && r[j] >= 128)
3246 o->op_private |= OPpTRANS_GROWS;
3248 op_getmad(expr,o,'e');
3249 op_getmad(repl,o,'r');
3259 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3264 NewOp(1101, pmop, 1, PMOP);
3265 pmop->op_type = (OPCODE)type;
3266 pmop->op_ppaddr = PL_ppaddr[type];
3267 pmop->op_flags = (U8)flags;
3268 pmop->op_private = (U8)(0 | (flags >> 8));
3270 if (PL_hints & HINT_RE_TAINT)
3271 pmop->op_pmpermflags |= PMf_RETAINT;
3272 if (PL_hints & HINT_LOCALE)
3273 pmop->op_pmpermflags |= PMf_LOCALE;
3274 pmop->op_pmflags = pmop->op_pmpermflags;
3277 if (av_len((AV*) PL_regex_pad[0]) > -1) {
3278 SV * const repointer = av_pop((AV*)PL_regex_pad[0]);
3279 pmop->op_pmoffset = SvIV(repointer);
3280 SvREPADTMP_off(repointer);
3281 sv_setiv(repointer,0);
3283 SV * const repointer = newSViv(0);
3284 av_push(PL_regex_padav, SvREFCNT_inc_simple_NN(repointer));
3285 pmop->op_pmoffset = av_len(PL_regex_padav);
3286 PL_regex_pad = AvARRAY(PL_regex_padav);
3290 /* link into pm list */
3291 if (type != OP_TRANS && PL_curstash) {
3292 MAGIC *mg = mg_find((SV*)PL_curstash, PERL_MAGIC_symtab);
3295 mg = sv_magicext((SV*)PL_curstash, 0, PERL_MAGIC_symtab, 0, 0, 0);
3297 pmop->op_pmnext = (PMOP*)mg->mg_obj;
3298 mg->mg_obj = (SV*)pmop;
3299 PmopSTASH_set(pmop,PL_curstash);
3302 return CHECKOP(type, pmop);
3305 /* Given some sort of match op o, and an expression expr containing a
3306 * pattern, either compile expr into a regex and attach it to o (if it's
3307 * constant), or convert expr into a runtime regcomp op sequence (if it's
3310 * isreg indicates that the pattern is part of a regex construct, eg
3311 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3312 * split "pattern", which aren't. In the former case, expr will be a list
3313 * if the pattern contains more than one term (eg /a$b/) or if it contains
3314 * a replacement, ie s/// or tr///.
3318 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
3323 I32 repl_has_vars = 0;
3327 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
3328 /* last element in list is the replacement; pop it */
3330 repl = cLISTOPx(expr)->op_last;
3331 kid = cLISTOPx(expr)->op_first;
3332 while (kid->op_sibling != repl)
3333 kid = kid->op_sibling;
3334 kid->op_sibling = NULL;
3335 cLISTOPx(expr)->op_last = kid;
3338 if (isreg && expr->op_type == OP_LIST &&
3339 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3341 /* convert single element list to element */
3342 OP* const oe = expr;
3343 expr = cLISTOPx(oe)->op_first->op_sibling;
3344 cLISTOPx(oe)->op_first->op_sibling = NULL;
3345 cLISTOPx(oe)->op_last = NULL;
3349 if (o->op_type == OP_TRANS) {
3350 return pmtrans(o, expr, repl);
3353 reglist = isreg && expr->op_type == OP_LIST;
3357 PL_hints |= HINT_BLOCK_SCOPE;
3360 if (expr->op_type == OP_CONST) {
3362 SV * const pat = ((SVOP*)expr)->op_sv;
3363 const char *p = SvPV_const(pat, plen);
3364 if ((o->op_flags & OPf_SPECIAL) && (plen == 1 && *p == ' ')) {
3365 U32 was_readonly = SvREADONLY(pat);
3369 sv_force_normal_flags(pat, 0);
3370 assert(!SvREADONLY(pat));
3373 SvREADONLY_off(pat);
3377 sv_setpvn(pat, "\\s+", 3);
3379 SvFLAGS(pat) |= was_readonly;
3381 p = SvPV_const(pat, plen);
3382 pm->op_pmflags |= PMf_SKIPWHITE;
3385 pm->op_pmdynflags |= PMdf_UTF8;
3386 /* FIXME - can we make this function take const char * args? */
3387 PM_SETRE(pm, CALLREGCOMP((char*)p, (char*)p + plen, pm));
3388 if (PM_GETRE(pm)->extflags & RXf_WHITE)
3389 pm->op_pmflags |= PMf_WHITE;
3391 pm->op_pmflags &= ~PMf_WHITE;
3393 op_getmad(expr,(OP*)pm,'e');
3399 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3400 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3402 : OP_REGCMAYBE),0,expr);
3404 NewOp(1101, rcop, 1, LOGOP);
3405 rcop->op_type = OP_REGCOMP;
3406 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3407 rcop->op_first = scalar(expr);
3408 rcop->op_flags |= OPf_KIDS
3409 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3410 | (reglist ? OPf_STACKED : 0);
3411 rcop->op_private = 1;
3414 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3416 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
3419 /* establish postfix order */
3420 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3422 rcop->op_next = expr;
3423 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3426 rcop->op_next = LINKLIST(expr);
3427 expr->op_next = (OP*)rcop;
3430 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3435 if (pm->op_pmflags & PMf_EVAL) {
3437 if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
3438 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
3440 else if (repl->op_type == OP_CONST)
3444 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3445 if (curop->op_type == OP_SCOPE
3446 || curop->op_type == OP_LEAVE
3447 || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
3448 if (curop->op_type == OP_GV) {
3449 GV * const gv = cGVOPx_gv(curop);
3451 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3454 else if (curop->op_type == OP_RV2CV)
3456 else if (curop->op_type == OP_RV2SV ||
3457 curop->op_type == OP_RV2AV ||
3458 curop->op_type == OP_RV2HV ||
3459 curop->op_type == OP_RV2GV) {
3460 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3463 else if (curop->op_type == OP_PADSV ||
3464 curop->op_type == OP_PADAV ||
3465 curop->op_type == OP_PADHV ||
3466 curop->op_type == OP_PADANY)
3470 else if (curop->op_type == OP_PUSHRE)
3471 NOOP; /* Okay here, dangerous in newASSIGNOP */
3481 || PM_GETRE(pm)->extflags & RXf_EVAL_SEEN)))
3483 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3484 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
3485 prepend_elem(o->op_type, scalar(repl), o);
3488 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3489 pm->op_pmflags |= PMf_MAYBE_CONST;
3490 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3492 NewOp(1101, rcop, 1, LOGOP);
3493 rcop->op_type = OP_SUBSTCONT;
3494 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3495 rcop->op_first = scalar(repl);
3496 rcop->op_flags |= OPf_KIDS;
3497 rcop->op_private = 1;
3500 /* establish postfix order */
3501 rcop->op_next = LINKLIST(repl);
3502 repl->op_next = (OP*)rcop;
3504 pm->op_pmreplroot = scalar((OP*)rcop);
3505 pm->op_pmreplstart = LINKLIST(rcop);
3514 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3518 NewOp(1101, svop, 1, SVOP);
3519 svop->op_type = (OPCODE)type;
3520 svop->op_ppaddr = PL_ppaddr[type];
3522 svop->op_next = (OP*)svop;
3523 svop->op_flags = (U8)flags;
3524 if (PL_opargs[type] & OA_RETSCALAR)
3526 if (PL_opargs[type] & OA_TARGET)
3527 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3528 return CHECKOP(type, svop);
3533 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3537 NewOp(1101, padop, 1, PADOP);
3538 padop->op_type = (OPCODE)type;
3539 padop->op_ppaddr = PL_ppaddr[type];
3540 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3541 SvREFCNT_dec(PAD_SVl(padop->op_padix));
3542 PAD_SETSV(padop->op_padix, sv);
3545 padop->op_next = (OP*)padop;
3546 padop->op_flags = (U8)flags;
3547 if (PL_opargs[type] & OA_RETSCALAR)
3549 if (PL_opargs[type] & OA_TARGET)
3550 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3551 return CHECKOP(type, padop);
3556 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3562 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3564 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3569 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3573 NewOp(1101, pvop, 1, PVOP);
3574 pvop->op_type = (OPCODE)type;
3575 pvop->op_ppaddr = PL_ppaddr[type];
3577 pvop->op_next = (OP*)pvop;
3578 pvop->op_flags = (U8)flags;
3579 if (PL_opargs[type] & OA_RETSCALAR)
3581 if (PL_opargs[type] & OA_TARGET)
3582 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3583 return CHECKOP(type, pvop);
3591 Perl_package(pTHX_ OP *o)
3594 SV *const sv = cSVOPo->op_sv;
3599 save_hptr(&PL_curstash);
3600 save_item(PL_curstname);
3602 PL_curstash = gv_stashsv(sv, GV_ADD);
3603 sv_setsv(PL_curstname, sv);
3605 PL_hints |= HINT_BLOCK_SCOPE;
3606 PL_copline = NOLINE;
3612 if (!PL_madskills) {
3617 pegop = newOP(OP_NULL,0);
3618 op_getmad(o,pegop,'P');
3628 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3635 OP *pegop = newOP(OP_NULL,0);
3638 if (idop->op_type != OP_CONST)
3639 Perl_croak(aTHX_ "Module name must be constant");
3642 op_getmad(idop,pegop,'U');
3647 SV * const vesv = ((SVOP*)version)->op_sv;
3650 op_getmad(version,pegop,'V');
3651 if (!arg && !SvNIOKp(vesv)) {
3658 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3659 Perl_croak(aTHX_ "Version number must be constant number");
3661 /* Make copy of idop so we don't free it twice */
3662 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3664 /* Fake up a method call to VERSION */
3665 meth = newSVpvs_share("VERSION");
3666 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3667 append_elem(OP_LIST,
3668 prepend_elem(OP_LIST, pack, list(version)),
3669 newSVOP(OP_METHOD_NAMED, 0, meth)));
3673 /* Fake up an import/unimport */
3674 if (arg && arg->op_type == OP_STUB) {
3676 op_getmad(arg,pegop,'S');
3677 imop = arg; /* no import on explicit () */
3679 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3680 imop = NULL; /* use 5.0; */
3682 idop->op_private |= OPpCONST_NOVER;
3688 op_getmad(arg,pegop,'A');
3690 /* Make copy of idop so we don't free it twice */
3691 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3693 /* Fake up a method call to import/unimport */
3695 ? newSVpvs_share("import") : newSVpvs_share("unimport");
3696 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3697 append_elem(OP_LIST,
3698 prepend_elem(OP_LIST, pack, list(arg)),
3699 newSVOP(OP_METHOD_NAMED, 0, meth)));
3702 /* Fake up the BEGIN {}, which does its thing immediately. */
3704 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
3707 append_elem(OP_LINESEQ,
3708 append_elem(OP_LINESEQ,
3709 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
3710 newSTATEOP(0, NULL, veop)),
3711 newSTATEOP(0, NULL, imop) ));
3713 /* The "did you use incorrect case?" warning used to be here.
3714 * The problem is that on case-insensitive filesystems one
3715 * might get false positives for "use" (and "require"):
3716 * "use Strict" or "require CARP" will work. This causes
3717 * portability problems for the script: in case-strict
3718 * filesystems the script will stop working.
3720 * The "incorrect case" warning checked whether "use Foo"
3721 * imported "Foo" to your namespace, but that is wrong, too:
3722 * there is no requirement nor promise in the language that
3723 * a Foo.pm should or would contain anything in package "Foo".
3725 * There is very little Configure-wise that can be done, either:
3726 * the case-sensitivity of the build filesystem of Perl does not
3727 * help in guessing the case-sensitivity of the runtime environment.
3730 PL_hints |= HINT_BLOCK_SCOPE;
3731 PL_copline = NOLINE;
3733 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3736 if (!PL_madskills) {
3737 /* FIXME - don't allocate pegop if !PL_madskills */
3746 =head1 Embedding Functions
3748 =for apidoc load_module
3750 Loads the module whose name is pointed to by the string part of name.
3751 Note that the actual module name, not its filename, should be given.
3752 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3753 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3754 (or 0 for no flags). ver, if specified, provides version semantics
3755 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3756 arguments can be used to specify arguments to the module's import()
3757 method, similar to C<use Foo::Bar VERSION LIST>.
3762 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3765 va_start(args, ver);
3766 vload_module(flags, name, ver, &args);
3770 #ifdef PERL_IMPLICIT_CONTEXT
3772 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3776 va_start(args, ver);
3777 vload_module(flags, name, ver, &args);
3783 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3788 OP * const modname = newSVOP(OP_CONST, 0, name);
3789 modname->op_private |= OPpCONST_BARE;
3791 veop = newSVOP(OP_CONST, 0, ver);
3795 if (flags & PERL_LOADMOD_NOIMPORT) {
3796 imop = sawparens(newNULLLIST());
3798 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3799 imop = va_arg(*args, OP*);
3804 sv = va_arg(*args, SV*);
3806 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3807 sv = va_arg(*args, SV*);
3811 const line_t ocopline = PL_copline;
3812 COP * const ocurcop = PL_curcop;
3813 const int oexpect = PL_expect;
3815 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3816 veop, modname, imop);
3817 PL_expect = oexpect;
3818 PL_copline = ocopline;
3819 PL_curcop = ocurcop;
3824 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
3830 if (!force_builtin) {
3831 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
3832 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
3833 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
3834 gv = gvp ? *gvp : NULL;
3838 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3839 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3840 append_elem(OP_LIST, term,
3841 scalar(newUNOP(OP_RV2CV, 0,
3842 newGVOP(OP_GV, 0, gv))))));
3845 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3851 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3853 return newBINOP(OP_LSLICE, flags,
3854 list(force_list(subscript)),
3855 list(force_list(listval)) );
3859 S_is_list_assignment(pTHX_ register const OP *o)
3867 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
3868 o = cUNOPo->op_first;
3870 flags = o->op_flags;
3872 if (type == OP_COND_EXPR) {
3873 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
3874 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3879 yyerror("Assignment to both a list and a scalar");
3883 if (type == OP_LIST &&
3884 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
3885 o->op_private & OPpLVAL_INTRO)
3888 if (type == OP_LIST || flags & OPf_PARENS ||
3889 type == OP_RV2AV || type == OP_RV2HV ||
3890 type == OP_ASLICE || type == OP_HSLICE)
3893 if (type == OP_PADAV || type == OP_PADHV)
3896 if (type == OP_RV2SV)
3903 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3909 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3910 return newLOGOP(optype, 0,
3911 mod(scalar(left), optype),
3912 newUNOP(OP_SASSIGN, 0, scalar(right)));
3915 return newBINOP(optype, OPf_STACKED,
3916 mod(scalar(left), optype), scalar(right));
3920 if (is_list_assignment(left)) {
3924 /* Grandfathering $[ assignment here. Bletch.*/
3925 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
3926 PL_eval_start = (left->op_type == OP_CONST) ? right : 0;
3927 left = mod(left, OP_AASSIGN);
3930 else if (left->op_type == OP_CONST) {
3932 /* Result of assignment is always 1 (or we'd be dead already) */
3933 return newSVOP(OP_CONST, 0, newSViv(1));
3935 curop = list(force_list(left));
3936 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3937 o->op_private = (U8)(0 | (flags >> 8));
3939 /* PL_generation sorcery:
3940 * an assignment like ($a,$b) = ($c,$d) is easier than
3941 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3942 * To detect whether there are common vars, the global var
3943 * PL_generation is incremented for each assign op we compile.
3944 * Then, while compiling the assign op, we run through all the
3945 * variables on both sides of the assignment, setting a spare slot
3946 * in each of them to PL_generation. If any of them already have
3947 * that value, we know we've got commonality. We could use a
3948 * single bit marker, but then we'd have to make 2 passes, first
3949 * to clear the flag, then to test and set it. To find somewhere
3950 * to store these values, evil chicanery is done with SvUVX().
3956 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3957 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3958 if (curop->op_type == OP_GV) {
3959 GV *gv = cGVOPx_gv(curop);
3961 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
3963 GvASSIGN_GENERATION_set(gv, PL_generation);
3965 else if (curop->op_type == OP_PADSV ||
3966 curop->op_type == OP_PADAV ||
3967 curop->op_type == OP_PADHV ||
3968 curop->op_type == OP_PADANY)
3970 if (PAD_COMPNAME_GEN(curop->op_targ)
3971 == (STRLEN)PL_generation)
3973 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
3976 else if (curop->op_type == OP_RV2CV)
3978 else if (curop->op_type == OP_RV2SV ||
3979 curop->op_type == OP_RV2AV ||
3980 curop->op_type == OP_RV2HV ||
3981 curop->op_type == OP_RV2GV) {
3982 if (lastop->op_type != OP_GV) /* funny deref? */
3985 else if (curop->op_type == OP_PUSHRE) {
3986 if (((PMOP*)curop)->op_pmreplroot) {
3988 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3989 ((PMOP*)curop)->op_pmreplroot));
3991 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3994 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
3996 GvASSIGN_GENERATION_set(gv, PL_generation);
3997 GvASSIGN_GENERATION_set(gv, PL_generation);
4006 o->op_private |= OPpASSIGN_COMMON;
4009 if ( ((left->op_private & OPpLVAL_INTRO) || ckWARN(WARN_MISC))
4010 && (left->op_type == OP_LIST
4011 || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
4013 OP* lop = ((LISTOP*)left)->op_first;
4015 if (lop->op_type == OP_PADSV ||
4016 lop->op_type == OP_PADAV ||
4017 lop->op_type == OP_PADHV ||
4018 lop->op_type == OP_PADANY)
4020 if (lop->op_private & OPpPAD_STATE) {
4021 if (left->op_private & OPpLVAL_INTRO) {
4022 o->op_private |= OPpASSIGN_STATE;
4023 /* hijacking PADSTALE for uninitialized state variables */
4024 SvPADSTALE_on(PAD_SVl(lop->op_targ));
4026 else { /* we already checked for WARN_MISC before */
4027 Perl_warner(aTHX_ packWARN(WARN_MISC), "State variable %s will be reinitialized",
4028 PAD_COMPNAME_PV(lop->op_targ));
4032 lop = lop->op_sibling;
4035 else if (((left->op_private & (OPpLVAL_INTRO | OPpPAD_STATE))
4036 == (OPpLVAL_INTRO | OPpPAD_STATE))
4037 && ( left->op_type == OP_PADSV
4038 || left->op_type == OP_PADAV
4039 || left->op_type == OP_PADHV
4040 || left->op_type == OP_PADANY))
4042 o->op_private |= OPpASSIGN_STATE;
4043 /* hijacking PADSTALE for uninitialized state variables */
4044 SvPADSTALE_on(PAD_SVl(left->op_targ));
4047 if (right && right->op_type == OP_SPLIT) {
4048 OP* tmpop = ((LISTOP*)right)->op_first;
4049 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
4050 PMOP * const pm = (PMOP*)tmpop;
4051 if (left->op_type == OP_RV2AV &&
4052 !(left->op_private & OPpLVAL_INTRO) &&
4053 !(o->op_private & OPpASSIGN_COMMON) )
4055 tmpop = ((UNOP*)left)->op_first;
4056 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
4058 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
4059 cPADOPx(tmpop)->op_padix = 0; /* steal it */
4061 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
4062 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
4064 pm->op_pmflags |= PMf_ONCE;
4065 tmpop = cUNOPo->op_first; /* to list (nulled) */
4066 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
4067 tmpop->op_sibling = NULL; /* don't free split */
4068 right->op_next = tmpop->op_next; /* fix starting loc */
4070 op_getmad(o,right,'R'); /* blow off assign */
4072 op_free(o); /* blow off assign */
4074 right->op_flags &= ~OPf_WANT;
4075 /* "I don't know and I don't care." */
4080 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
4081 ((LISTOP*)right)->op_last->op_type == OP_CONST)
4083 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
4085 sv_setiv(sv, PL_modcount+1);
4093 right = newOP(OP_UNDEF, 0);
4094 if (right->op_type == OP_READLINE) {
4095 right->op_flags |= OPf_STACKED;
4096 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
4099 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
4100 o = newBINOP(OP_SASSIGN, flags,
4101 scalar(right), mod(scalar(left), OP_SASSIGN) );
4107 o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
4108 o->op_private |= OPpCONST_ARYBASE;
4115 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
4118 const U32 seq = intro_my();
4121 NewOp(1101, cop, 1, COP);
4122 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
4123 cop->op_type = OP_DBSTATE;
4124 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
4127 cop->op_type = OP_NEXTSTATE;
4128 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
4130 cop->op_flags = (U8)flags;
4131 CopHINTS_set(cop, PL_hints);
4133 cop->op_private |= NATIVE_HINTS;
4135 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
4136 cop->op_next = (OP*)cop;
4139 CopLABEL_set(cop, label);
4140 PL_hints |= HINT_BLOCK_SCOPE;
4143 /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
4144 CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
4146 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
4147 cop->cop_hints_hash = PL_curcop->cop_hints_hash;
4148 if (cop->cop_hints_hash) {
4150 cop->cop_hints_hash->refcounted_he_refcnt++;
4151 HINTS_REFCNT_UNLOCK;
4154 if (PL_copline == NOLINE)
4155 CopLINE_set(cop, CopLINE(PL_curcop));
4157 CopLINE_set(cop, PL_copline);
4158 PL_copline = NOLINE;
4161 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
4163 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
4165 CopSTASH_set(cop, PL_curstash);
4167 if (PERLDB_LINE && PL_curstash != PL_debstash) {
4168 AV *av = CopFILEAVx(PL_curcop);
4170 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
4171 if (svp && *svp != &PL_sv_undef ) {
4172 (void)SvIOK_on(*svp);
4173 SvIV_set(*svp, PTR2IV(cop));
4178 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
4183 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
4186 return new_logop(type, flags, &first, &other);
4190 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
4195 OP *first = *firstp;
4196 OP * const other = *otherp;
4198 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
4199 return newBINOP(type, flags, scalar(first), scalar(other));
4201 scalarboolean(first);
4202 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
4203 if (first->op_type == OP_NOT
4204 && (first->op_flags & OPf_SPECIAL)
4205 && (first->op_flags & OPf_KIDS)) {
4206 if (type == OP_AND || type == OP_OR) {
4212 first = *firstp = cUNOPo->op_first;
4214 first->op_next = o->op_next;
4215 cUNOPo->op_first = NULL;
4217 op_getmad(o,first,'O');
4223 if (first->op_type == OP_CONST) {
4224 if (first->op_private & OPpCONST_STRICT)
4225 no_bareword_allowed(first);
4226 else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
4227 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
4228 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
4229 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
4230 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
4232 if (other->op_type == OP_CONST)
4233 other->op_private |= OPpCONST_SHORTCIRCUIT;
4235 OP *newop = newUNOP(OP_NULL, 0, other);
4236 op_getmad(first, newop, '1');
4237 newop->op_targ = type; /* set "was" field */
4244 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
4245 const OP *o2 = other;
4246 if ( ! (o2->op_type == OP_LIST
4247 && (( o2 = cUNOPx(o2)->op_first))
4248 && o2->op_type == OP_PUSHMARK
4249 && (( o2 = o2->op_sibling)) )
4252 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
4253 || o2->op_type == OP_PADHV)
4254 && o2->op_private & OPpLVAL_INTRO
4255 && ckWARN(WARN_DEPRECATED))
4257 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4258 "Deprecated use of my() in false conditional");
4262 if (first->op_type == OP_CONST)
4263 first->op_private |= OPpCONST_SHORTCIRCUIT;
4265 first = newUNOP(OP_NULL, 0, first);
4266 op_getmad(other, first, '2');
4267 first->op_targ = type; /* set "was" field */
4274 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
4275 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
4277 const OP * const k1 = ((UNOP*)first)->op_first;
4278 const OP * const k2 = k1->op_sibling;
4280 switch (first->op_type)
4283 if (k2 && k2->op_type == OP_READLINE
4284 && (k2->op_flags & OPf_STACKED)
4285 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4287 warnop = k2->op_type;
4292 if (k1->op_type == OP_READDIR
4293 || k1->op_type == OP_GLOB
4294 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4295 || k1->op_type == OP_EACH)
4297 warnop = ((k1->op_type == OP_NULL)
4298 ? (OPCODE)k1->op_targ : k1->op_type);
4303 const line_t oldline = CopLINE(PL_curcop);
4304 CopLINE_set(PL_curcop, PL_copline);
4305 Perl_warner(aTHX_ packWARN(WARN_MISC),
4306 "Value of %s%s can be \"0\"; test with defined()",
4308 ((warnop == OP_READLINE || warnop == OP_GLOB)
4309 ? " construct" : "() operator"));
4310 CopLINE_set(PL_curcop, oldline);
4317 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
4318 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
4320 NewOp(1101, logop, 1, LOGOP);
4322 logop->op_type = (OPCODE)type;
4323 logop->op_ppaddr = PL_ppaddr[type];
4324 logop->op_first = first;
4325 logop->op_flags = (U8)(flags | OPf_KIDS);
4326 logop->op_other = LINKLIST(other);
4327 logop->op_private = (U8)(1 | (flags >> 8));
4329 /* establish postfix order */
4330 logop->op_next = LINKLIST(first);
4331 first->op_next = (OP*)logop;
4332 first->op_sibling = other;
4334 CHECKOP(type,logop);
4336 o = newUNOP(OP_NULL, 0, (OP*)logop);
4343 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
4351 return newLOGOP(OP_AND, 0, first, trueop);
4353 return newLOGOP(OP_OR, 0, first, falseop);
4355 scalarboolean(first);
4356 if (first->op_type == OP_CONST) {
4357 /* Left or right arm of the conditional? */
4358 const bool left = SvTRUE(((SVOP*)first)->op_sv);
4359 OP *live = left ? trueop : falseop;
4360 OP *const dead = left ? falseop : trueop;
4361 if (first->op_private & OPpCONST_BARE &&
4362 first->op_private & OPpCONST_STRICT) {
4363 no_bareword_allowed(first);
4366 /* This is all dead code when PERL_MAD is not defined. */
4367 live = newUNOP(OP_NULL, 0, live);
4368 op_getmad(first, live, 'C');
4369 op_getmad(dead, live, left ? 'e' : 't');
4376 NewOp(1101, logop, 1, LOGOP);
4377 logop->op_type = OP_COND_EXPR;
4378 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4379 logop->op_first = first;
4380 logop->op_flags = (U8)(flags | OPf_KIDS);
4381 logop->op_private = (U8)(1 | (flags >> 8));
4382 logop->op_other = LINKLIST(trueop);
4383 logop->op_next = LINKLIST(falseop);
4385 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
4388 /* establish postfix order */
4389 start = LINKLIST(first);
4390 first->op_next = (OP*)logop;
4392 first->op_sibling = trueop;
4393 trueop->op_sibling = falseop;
4394 o = newUNOP(OP_NULL, 0, (OP*)logop);
4396 trueop->op_next = falseop->op_next = o;
4403 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4412 NewOp(1101, range, 1, LOGOP);
4414 range->op_type = OP_RANGE;
4415 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4416 range->op_first = left;
4417 range->op_flags = OPf_KIDS;
4418 leftstart = LINKLIST(left);
4419 range->op_other = LINKLIST(right);
4420 range->op_private = (U8)(1 | (flags >> 8));
4422 left->op_sibling = right;
4424 range->op_next = (OP*)range;
4425 flip = newUNOP(OP_FLIP, flags, (OP*)range);
4426 flop = newUNOP(OP_FLOP, 0, flip);
4427 o = newUNOP(OP_NULL, 0, flop);
4429 range->op_next = leftstart;
4431 left->op_next = flip;
4432 right->op_next = flop;
4434 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4435 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4436 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4437 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4439 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4440 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4443 if (!flip->op_private || !flop->op_private)
4444 linklist(o); /* blow off optimizer unless constant */
4450 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4455 const bool once = block && block->op_flags & OPf_SPECIAL &&
4456 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4458 PERL_UNUSED_ARG(debuggable);
4461 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4462 return block; /* do {} while 0 does once */
4463 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4464 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4465 expr = newUNOP(OP_DEFINED, 0,
4466 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4467 } else if (expr->op_flags & OPf_KIDS) {
4468 const OP * const k1 = ((UNOP*)expr)->op_first;
4469 const OP * const k2 = k1 ? k1->op_sibling : NULL;
4470 switch (expr->op_type) {
4472 if (k2 && k2->op_type == OP_READLINE
4473 && (k2->op_flags & OPf_STACKED)
4474 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4475 expr = newUNOP(OP_DEFINED, 0, expr);
4479 if (k1 && (k1->op_type == OP_READDIR
4480 || k1->op_type == OP_GLOB
4481 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4482 || k1->op_type == OP_EACH))
4483 expr = newUNOP(OP_DEFINED, 0, expr);
4489 /* if block is null, the next append_elem() would put UNSTACK, a scalar
4490 * op, in listop. This is wrong. [perl #27024] */
4492 block = newOP(OP_NULL, 0);
4493 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4494 o = new_logop(OP_AND, 0, &expr, &listop);
4497 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4499 if (once && o != listop)
4500 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4503 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
4505 o->op_flags |= flags;
4507 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4512 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
4513 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
4522 PERL_UNUSED_ARG(debuggable);
4525 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4526 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4527 expr = newUNOP(OP_DEFINED, 0,
4528 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4529 } else if (expr->op_flags & OPf_KIDS) {
4530 const OP * const k1 = ((UNOP*)expr)->op_first;
4531 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
4532 switch (expr->op_type) {
4534 if (k2 && k2->op_type == OP_READLINE
4535 && (k2->op_flags & OPf_STACKED)
4536 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4537 expr = newUNOP(OP_DEFINED, 0, expr);
4541 if (k1 && (k1->op_type == OP_READDIR
4542 || k1->op_type == OP_GLOB
4543 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4544 || k1->op_type == OP_EACH))
4545 expr = newUNOP(OP_DEFINED, 0, expr);
4552 block = newOP(OP_NULL, 0);
4553 else if (cont || has_my) {
4554 block = scope(block);
4558 next = LINKLIST(cont);
4561 OP * const unstack = newOP(OP_UNSTACK, 0);
4564 cont = append_elem(OP_LINESEQ, cont, unstack);
4568 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4570 redo = LINKLIST(listop);
4573 PL_copline = (line_t)whileline;
4575 o = new_logop(OP_AND, 0, &expr, &listop);
4576 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4577 op_free(expr); /* oops, it's a while (0) */
4579 return NULL; /* listop already freed by new_logop */
4582 ((LISTOP*)listop)->op_last->op_next =
4583 (o == listop ? redo : LINKLIST(o));
4589 NewOp(1101,loop,1,LOOP);
4590 loop->op_type = OP_ENTERLOOP;
4591 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4592 loop->op_private = 0;
4593 loop->op_next = (OP*)loop;
4596 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4598 loop->op_redoop = redo;
4599 loop->op_lastop = o;
4600 o->op_private |= loopflags;
4603 loop->op_nextop = next;
4605 loop->op_nextop = o;
4607 o->op_flags |= flags;
4608 o->op_private |= (flags >> 8);
4613 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
4618 PADOFFSET padoff = 0;
4624 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4625 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
4626 sv->op_type = OP_RV2GV;
4627 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4629 /* The op_type check is needed to prevent a possible segfault
4630 * if the loop variable is undeclared and 'strict vars' is in
4631 * effect. This is illegal but is nonetheless parsed, so we
4632 * may reach this point with an OP_CONST where we're expecting
4635 if (cUNOPx(sv)->op_first->op_type == OP_GV
4636 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
4637 iterpflags |= OPpITER_DEF;
4639 else if (sv->op_type == OP_PADSV) { /* private variable */
4640 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
4641 padoff = sv->op_targ;
4651 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4653 SV *const namesv = PAD_COMPNAME_SV(padoff);
4655 const char *const name = SvPV_const(namesv, len);
4657 if (len == 2 && name[0] == '$' && name[1] == '_')
4658 iterpflags |= OPpITER_DEF;
4662 const PADOFFSET offset = pad_findmy("$_");
4663 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
4664 sv = newGVOP(OP_GV, 0, PL_defgv);
4669 iterpflags |= OPpITER_DEF;
4671 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4672 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4673 iterflags |= OPf_STACKED;
4675 else if (expr->op_type == OP_NULL &&
4676 (expr->op_flags & OPf_KIDS) &&
4677 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4679 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4680 * set the STACKED flag to indicate that these values are to be
4681 * treated as min/max values by 'pp_iterinit'.
4683 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4684 LOGOP* const range = (LOGOP*) flip->op_first;
4685 OP* const left = range->op_first;
4686 OP* const right = left->op_sibling;
4689 range->op_flags &= ~OPf_KIDS;
4690 range->op_first = NULL;
4692 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4693 listop->op_first->op_next = range->op_next;
4694 left->op_next = range->op_other;
4695 right->op_next = (OP*)listop;
4696 listop->op_next = listop->op_first;
4699 op_getmad(expr,(OP*)listop,'O');
4703 expr = (OP*)(listop);
4705 iterflags |= OPf_STACKED;
4708 expr = mod(force_list(expr), OP_GREPSTART);
4711 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4712 append_elem(OP_LIST, expr, scalar(sv))));
4713 assert(!loop->op_next);
4714 /* for my $x () sets OPpLVAL_INTRO;
4715 * for our $x () sets OPpOUR_INTRO */
4716 loop->op_private = (U8)iterpflags;
4717 #ifdef PL_OP_SLAB_ALLOC
4720 NewOp(1234,tmp,1,LOOP);
4721 Copy(loop,tmp,1,LISTOP);
4722 S_op_destroy(aTHX_ (OP*)loop);
4726 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
4728 loop->op_targ = padoff;
4729 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
4731 op_getmad(madsv, (OP*)loop, 'v');
4732 PL_copline = forline;
4733 return newSTATEOP(0, label, wop);
4737 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4742 if (type != OP_GOTO || label->op_type == OP_CONST) {
4743 /* "last()" means "last" */
4744 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4745 o = newOP(type, OPf_SPECIAL);
4747 o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
4748 ? SvPVx_nolen_const(((SVOP*)label)->op_sv)
4752 op_getmad(label,o,'L');
4758 /* Check whether it's going to be a goto &function */
4759 if (label->op_type == OP_ENTERSUB
4760 && !(label->op_flags & OPf_STACKED))
4761 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4762 o = newUNOP(type, OPf_STACKED, label);
4764 PL_hints |= HINT_BLOCK_SCOPE;
4768 /* if the condition is a literal array or hash
4769 (or @{ ... } etc), make a reference to it.
4772 S_ref_array_or_hash(pTHX_ OP *cond)
4775 && (cond->op_type == OP_RV2AV
4776 || cond->op_type == OP_PADAV
4777 || cond->op_type == OP_RV2HV
4778 || cond->op_type == OP_PADHV))
4780 return newUNOP(OP_REFGEN,
4781 0, mod(cond, OP_REFGEN));
4787 /* These construct the optree fragments representing given()
4790 entergiven and enterwhen are LOGOPs; the op_other pointer
4791 points up to the associated leave op. We need this so we
4792 can put it in the context and make break/continue work.
4793 (Also, of course, pp_enterwhen will jump straight to
4794 op_other if the match fails.)
4799 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
4800 I32 enter_opcode, I32 leave_opcode,
4801 PADOFFSET entertarg)
4807 NewOp(1101, enterop, 1, LOGOP);
4808 enterop->op_type = enter_opcode;
4809 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
4810 enterop->op_flags = (U8) OPf_KIDS;
4811 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
4812 enterop->op_private = 0;
4814 o = newUNOP(leave_opcode, 0, (OP *) enterop);
4817 enterop->op_first = scalar(cond);
4818 cond->op_sibling = block;
4820 o->op_next = LINKLIST(cond);
4821 cond->op_next = (OP *) enterop;
4824 /* This is a default {} block */
4825 enterop->op_first = block;
4826 enterop->op_flags |= OPf_SPECIAL;
4828 o->op_next = (OP *) enterop;
4831 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
4832 entergiven and enterwhen both
4835 enterop->op_next = LINKLIST(block);
4836 block->op_next = enterop->op_other = o;
4841 /* Does this look like a boolean operation? For these purposes
4842 a boolean operation is:
4843 - a subroutine call [*]
4844 - a logical connective
4845 - a comparison operator
4846 - a filetest operator, with the exception of -s -M -A -C
4847 - defined(), exists() or eof()
4848 - /$re/ or $foo =~ /$re/
4850 [*] possibly surprising
4854 S_looks_like_bool(pTHX_ const OP *o)
4857 switch(o->op_type) {
4859 return looks_like_bool(cLOGOPo->op_first);
4863 looks_like_bool(cLOGOPo->op_first)
4864 && looks_like_bool(cLOGOPo->op_first->op_sibling));
4868 case OP_NOT: case OP_XOR:
4869 /* Note that OP_DOR is not here */
4871 case OP_EQ: case OP_NE: case OP_LT:
4872 case OP_GT: case OP_LE: case OP_GE:
4874 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
4875 case OP_I_GT: case OP_I_LE: case OP_I_GE:
4877 case OP_SEQ: case OP_SNE: case OP_SLT:
4878 case OP_SGT: case OP_SLE: case OP_SGE:
4882 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
4883 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
4884 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
4885 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
4886 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
4887 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
4888 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
4889 case OP_FTTEXT: case OP_FTBINARY:
4891 case OP_DEFINED: case OP_EXISTS:
4892 case OP_MATCH: case OP_EOF:
4897 /* Detect comparisons that have been optimized away */
4898 if (cSVOPo->op_sv == &PL_sv_yes
4899 || cSVOPo->op_sv == &PL_sv_no)
4910 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
4914 return newGIVWHENOP(
4915 ref_array_or_hash(cond),
4917 OP_ENTERGIVEN, OP_LEAVEGIVEN,
4921 /* If cond is null, this is a default {} block */
4923 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
4925 const bool cond_llb = (!cond || looks_like_bool(cond));
4931 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
4933 scalar(ref_array_or_hash(cond)));
4936 return newGIVWHENOP(
4938 append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
4939 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
4943 =for apidoc cv_undef
4945 Clear out all the active components of a CV. This can happen either
4946 by an explicit C<undef &foo>, or by the reference count going to zero.
4947 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
4948 children can still follow the full lexical scope chain.
4954 Perl_cv_undef(pTHX_ CV *cv)
4958 if (CvFILE(cv) && !CvISXSUB(cv)) {
4959 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4960 Safefree(CvFILE(cv));
4965 if (!CvISXSUB(cv) && CvROOT(cv)) {
4966 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
4967 Perl_croak(aTHX_ "Can't undef active subroutine");
4970 PAD_SAVE_SETNULLPAD();
4972 op_free(CvROOT(cv));
4977 SvPOK_off((SV*)cv); /* forget prototype */
4982 /* remove CvOUTSIDE unless this is an undef rather than a free */
4983 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
4984 if (!CvWEAKOUTSIDE(cv))
4985 SvREFCNT_dec(CvOUTSIDE(cv));
4986 CvOUTSIDE(cv) = NULL;
4989 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4992 if (CvISXSUB(cv) && CvXSUB(cv)) {
4995 /* delete all flags except WEAKOUTSIDE */
4996 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
5000 Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
5003 /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
5004 relying on SvCUR, and doubling up the buffer to hold CvFILE(). */
5005 if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
5006 || (p && (len != SvCUR(cv) /* Not the same length. */
5007 || memNE(p, SvPVX_const(cv), len))))
5008 && ckWARN_d(WARN_PROTOTYPE)) {
5009 SV* const msg = sv_newmortal();
5013 gv_efullname3(name = sv_newmortal(), gv, NULL);
5014 sv_setpvs(msg, "Prototype mismatch:");
5016 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
5018 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv));
5020 sv_catpvs(msg, ": none");
5021 sv_catpvs(msg, " vs ");
5023 Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
5025 sv_catpvs(msg, "none");
5026 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
5030 static void const_sv_xsub(pTHX_ CV* cv);
5034 =head1 Optree Manipulation Functions
5036 =for apidoc cv_const_sv
5038 If C<cv> is a constant sub eligible for inlining. returns the constant
5039 value returned by the sub. Otherwise, returns NULL.
5041 Constant subs can be created with C<newCONSTSUB> or as described in
5042 L<perlsub/"Constant Functions">.
5047 Perl_cv_const_sv(pTHX_ CV *cv)
5049 PERL_UNUSED_CONTEXT;
5052 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
5054 return CvCONST(cv) ? (SV*)CvXSUBANY(cv).any_ptr : NULL;
5057 /* op_const_sv: examine an optree to determine whether it's in-lineable.
5058 * Can be called in 3 ways:
5061 * look for a single OP_CONST with attached value: return the value
5063 * cv && CvCLONE(cv) && !CvCONST(cv)
5065 * examine the clone prototype, and if contains only a single
5066 * OP_CONST referencing a pad const, or a single PADSV referencing
5067 * an outer lexical, return a non-zero value to indicate the CV is
5068 * a candidate for "constizing" at clone time
5072 * We have just cloned an anon prototype that was marked as a const
5073 * candidiate. Try to grab the current value, and in the case of
5074 * PADSV, ignore it if it has multiple references. Return the value.
5078 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
5086 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
5087 o = cLISTOPo->op_first->op_sibling;
5089 for (; o; o = o->op_next) {
5090 const OPCODE type = o->op_type;
5092 if (sv && o->op_next == o)
5094 if (o->op_next != o) {
5095 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
5097 if (type == OP_DBSTATE)
5100 if (type == OP_LEAVESUB || type == OP_RETURN)
5104 if (type == OP_CONST && cSVOPo->op_sv)
5106 else if (cv && type == OP_CONST) {
5107 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5111 else if (cv && type == OP_PADSV) {
5112 if (CvCONST(cv)) { /* newly cloned anon */
5113 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5114 /* the candidate should have 1 ref from this pad and 1 ref
5115 * from the parent */
5116 if (!sv || SvREFCNT(sv) != 2)
5123 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
5124 sv = &PL_sv_undef; /* an arbitrary non-null value */
5139 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5142 /* This would be the return value, but the return cannot be reached. */
5143 OP* pegop = newOP(OP_NULL, 0);
5146 PERL_UNUSED_ARG(floor);
5156 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
5158 NORETURN_FUNCTION_END;
5163 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
5165 return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
5169 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5176 register CV *cv = NULL;
5178 /* If the subroutine has no body, no attributes, and no builtin attributes
5179 then it's just a sub declaration, and we may be able to get away with
5180 storing with a placeholder scalar in the symbol table, rather than a
5181 full GV and CV. If anything is present then it will take a full CV to
5183 const I32 gv_fetch_flags
5184 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5186 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
5187 const char * const name = o ? SvPVx_nolen_const(cSVOPo->op_sv) : NULL;
5190 assert(proto->op_type == OP_CONST);
5191 ps = SvPVx_const(((SVOP*)proto)->op_sv, ps_len);
5196 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
5197 SV * const sv = sv_newmortal();
5198 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
5199 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
5200 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
5201 aname = SvPVX_const(sv);
5206 gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
5207 : gv_fetchpv(aname ? aname
5208 : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5209 gv_fetch_flags, SVt_PVCV);
5211 if (!PL_madskills) {
5220 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
5221 maximum a prototype before. */
5222 if (SvTYPE(gv) > SVt_NULL) {
5223 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
5224 && ckWARN_d(WARN_PROTOTYPE))
5226 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
5228 cv_ckproto_len((CV*)gv, NULL, ps, ps_len);
5231 sv_setpvn((SV*)gv, ps, ps_len);
5233 sv_setiv((SV*)gv, -1);
5234 SvREFCNT_dec(PL_compcv);
5235 cv = PL_compcv = NULL;
5236 PL_sub_generation++;
5240 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
5242 #ifdef GV_UNIQUE_CHECK
5243 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
5244 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
5248 if (!block || !ps || *ps || attrs
5249 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5251 || block->op_type == OP_NULL
5256 const_sv = op_const_sv(block, NULL);
5259 const bool exists = CvROOT(cv) || CvXSUB(cv);
5261 #ifdef GV_UNIQUE_CHECK
5262 if (exists && GvUNIQUE(gv)) {
5263 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
5267 /* if the subroutine doesn't exist and wasn't pre-declared
5268 * with a prototype, assume it will be AUTOLOADed,
5269 * skipping the prototype check
5271 if (exists || SvPOK(cv))
5272 cv_ckproto_len(cv, gv, ps, ps_len);
5273 /* already defined (or promised)? */
5274 if (exists || GvASSUMECV(gv)) {
5277 || block->op_type == OP_NULL
5280 if (CvFLAGS(PL_compcv)) {
5281 /* might have had built-in attrs applied */
5282 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5284 /* just a "sub foo;" when &foo is already defined */
5285 SAVEFREESV(PL_compcv);
5290 && block->op_type != OP_NULL
5293 if (ckWARN(WARN_REDEFINE)
5295 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
5297 const line_t oldline = CopLINE(PL_curcop);
5298 if (PL_copline != NOLINE)
5299 CopLINE_set(PL_curcop, PL_copline);
5300 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5301 CvCONST(cv) ? "Constant subroutine %s redefined"
5302 : "Subroutine %s redefined", name);
5303 CopLINE_set(PL_curcop, oldline);
5306 if (!PL_minus_c) /* keep old one around for madskills */
5309 /* (PL_madskills unset in used file.) */
5317 SvREFCNT_inc_simple_void_NN(const_sv);
5319 assert(!CvROOT(cv) && !CvCONST(cv));
5320 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
5321 CvXSUBANY(cv).any_ptr = const_sv;
5322 CvXSUB(cv) = const_sv_xsub;
5328 cv = newCONSTSUB(NULL, name, const_sv);
5330 PL_sub_generation++;
5334 SvREFCNT_dec(PL_compcv);
5342 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
5343 * before we clobber PL_compcv.
5347 || block->op_type == OP_NULL
5351 /* Might have had built-in attributes applied -- propagate them. */
5352 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5353 if (CvGV(cv) && GvSTASH(CvGV(cv)))
5354 stash = GvSTASH(CvGV(cv));
5355 else if (CvSTASH(cv))
5356 stash = CvSTASH(cv);
5358 stash = PL_curstash;
5361 /* possibly about to re-define existing subr -- ignore old cv */
5362 rcv = (SV*)PL_compcv;
5363 if (name && GvSTASH(gv))
5364 stash = GvSTASH(gv);
5366 stash = PL_curstash;
5368 apply_attrs(stash, rcv, attrs, FALSE);
5370 if (cv) { /* must reuse cv if autoloaded */
5377 || block->op_type == OP_NULL) && !PL_madskills
5380 /* got here with just attrs -- work done, so bug out */
5381 SAVEFREESV(PL_compcv);
5384 /* transfer PL_compcv to cv */
5386 CvFLAGS(cv) = CvFLAGS(PL_compcv);
5387 if (!CvWEAKOUTSIDE(cv))
5388 SvREFCNT_dec(CvOUTSIDE(cv));
5389 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
5390 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
5391 CvOUTSIDE(PL_compcv) = 0;
5392 CvPADLIST(cv) = CvPADLIST(PL_compcv);
5393 CvPADLIST(PL_compcv) = 0;
5394 /* inner references to PL_compcv must be fixed up ... */
5395 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
5396 /* ... before we throw it away */
5397 SvREFCNT_dec(PL_compcv);
5399 if (PERLDB_INTER)/* Advice debugger on the new sub. */
5400 ++PL_sub_generation;
5407 if (strEQ(name, "import")) {
5408 PL_formfeed = (SV*)cv;
5409 Perl_warner(aTHX_ packWARN(WARN_VOID), "%lx\n", (long)cv);
5413 PL_sub_generation++;
5417 CvFILE_set_from_cop(cv, PL_curcop);
5418 CvSTASH(cv) = PL_curstash;
5421 sv_setpvn((SV*)cv, ps, ps_len);
5423 if (PL_error_count) {
5427 const char *s = strrchr(name, ':');
5429 if (strEQ(s, "BEGIN")) {
5430 const char not_safe[] =
5431 "BEGIN not safe after errors--compilation aborted";
5432 if (PL_in_eval & EVAL_KEEPERR)
5433 Perl_croak(aTHX_ not_safe);
5435 /* force display of errors found but not reported */
5436 sv_catpv(ERRSV, not_safe);
5437 Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
5447 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5448 mod(scalarseq(block), OP_LEAVESUBLV));
5449 block->op_attached = 1;
5452 /* This makes sub {}; work as expected. */
5453 if (block->op_type == OP_STUB) {
5454 OP* const newblock = newSTATEOP(0, NULL, 0);
5456 op_getmad(block,newblock,'B');
5463 block->op_attached = 1;
5464 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5466 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5467 OpREFCNT_set(CvROOT(cv), 1);
5468 CvSTART(cv) = LINKLIST(CvROOT(cv));
5469 CvROOT(cv)->op_next = 0;
5470 CALL_PEEP(CvSTART(cv));
5472 /* now that optimizer has done its work, adjust pad values */
5474 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
5477 assert(!CvCONST(cv));
5478 if (ps && !*ps && op_const_sv(block, cv))
5482 if (name || aname) {
5483 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5484 SV * const sv = newSV(0);
5485 SV * const tmpstr = sv_newmortal();
5486 GV * const db_postponed = gv_fetchpvs("DB::postponed",
5487 GV_ADDMULTI, SVt_PVHV);
5490 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5492 (long)PL_subline, (long)CopLINE(PL_curcop));
5493 gv_efullname3(tmpstr, gv, NULL);
5494 hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0);
5495 hv = GvHVn(db_postponed);
5496 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
5497 CV * const pcv = GvCV(db_postponed);
5503 call_sv((SV*)pcv, G_DISCARD);
5508 if (name && !PL_error_count)
5509 process_special_blocks(name, gv, cv);
5513 PL_copline = NOLINE;
5519 S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
5522 const char *const colon = strrchr(fullname,':');
5523 const char *const name = colon ? colon + 1 : fullname;
5526 if (strEQ(name, "BEGIN")) {
5527 const I32 oldscope = PL_scopestack_ix;
5529 SAVECOPFILE(&PL_compiling);
5530 SAVECOPLINE(&PL_compiling);
5532 DEBUG_x( dump_sub(gv) );
5533 Perl_av_create_and_push(aTHX_ &PL_beginav, (SV*)cv);
5534 GvCV(gv) = 0; /* cv has been hijacked */
5535 call_list(oldscope, PL_beginav);
5537 PL_curcop = &PL_compiling;
5538 CopHINTS_set(&PL_compiling, PL_hints);
5545 if strEQ(name, "END") {
5546 DEBUG_x( dump_sub(gv) );
5547 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, (SV*)cv);
5550 } else if (*name == 'U') {
5551 if (strEQ(name, "UNITCHECK")) {
5552 /* It's never too late to run a unitcheck block */
5553 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, (SV*)cv);
5557 } else if (*name == 'C') {
5558 if (strEQ(name, "CHECK")) {
5559 if (PL_main_start && ckWARN(WARN_VOID))
5560 Perl_warner(aTHX_ packWARN(WARN_VOID),
5561 "Too late to run CHECK block");
5562 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, (SV*)cv);
5566 } else if (*name == 'I') {
5567 if (strEQ(name, "INIT")) {
5568 if (PL_main_start && ckWARN(WARN_VOID))
5569 Perl_warner(aTHX_ packWARN(WARN_VOID),
5570 "Too late to run INIT block");
5571 Perl_av_create_and_push(aTHX_ &PL_initav, (SV*)cv);
5577 DEBUG_x( dump_sub(gv) );
5578 GvCV(gv) = 0; /* cv has been hijacked */
5583 =for apidoc newCONSTSUB
5585 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5586 eligible for inlining at compile-time.
5592 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
5597 const char *const temp_p = CopFILE(PL_curcop);
5598 const STRLEN len = temp_p ? strlen(temp_p) : 0;
5600 SV *const temp_sv = CopFILESV(PL_curcop);
5602 const char *const temp_p = temp_sv ? SvPV_const(temp_sv, len) : NULL;
5604 char *const file = savepvn(temp_p, temp_p ? len : 0);
5608 SAVECOPLINE(PL_curcop);
5609 CopLINE_set(PL_curcop, PL_copline);
5612 PL_hints &= ~HINT_BLOCK_SCOPE;
5615 SAVESPTR(PL_curstash);
5616 SAVECOPSTASH(PL_curcop);
5617 PL_curstash = stash;
5618 CopSTASH_set(PL_curcop,stash);
5621 /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
5622 and so doesn't get free()d. (It's expected to be from the C pre-
5623 processor __FILE__ directive). But we need a dynamically allocated one,
5624 and we need it to get freed. */
5625 cv = newXS_flags(name, const_sv_xsub, file, "", XS_DYNAMIC_FILENAME);
5626 CvXSUBANY(cv).any_ptr = sv;
5632 CopSTASH_free(PL_curcop);
5640 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
5641 const char *const filename, const char *const proto,
5644 CV *cv = newXS(name, subaddr, filename);
5646 if (flags & XS_DYNAMIC_FILENAME) {
5647 /* We need to "make arrangements" (ie cheat) to ensure that the
5648 filename lasts as long as the PVCV we just created, but also doesn't
5650 STRLEN filename_len = strlen(filename);
5651 STRLEN proto_and_file_len = filename_len;
5652 char *proto_and_file;
5656 proto_len = strlen(proto);
5657 proto_and_file_len += proto_len;
5659 Newx(proto_and_file, proto_and_file_len + 1, char);
5660 Copy(proto, proto_and_file, proto_len, char);
5661 Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
5664 proto_and_file = savepvn(filename, filename_len);
5667 /* This gets free()d. :-) */
5668 sv_usepvn_flags((SV*)cv, proto_and_file, proto_and_file_len,
5669 SV_HAS_TRAILING_NUL);
5671 /* This gives us the correct prototype, rather than one with the
5672 file name appended. */
5673 SvCUR_set(cv, proto_len);
5677 CvFILE(cv) = proto_and_file + proto_len;
5679 sv_setpv((SV *)cv, proto);
5685 =for apidoc U||newXS
5687 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
5688 static storage, as it is used directly as CvFILE(), without a copy being made.
5694 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
5697 GV * const gv = gv_fetchpv(name ? name :
5698 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5699 GV_ADDMULTI, SVt_PVCV);
5703 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
5705 if ((cv = (name ? GvCV(gv) : NULL))) {
5707 /* just a cached method */
5711 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5712 /* already defined (or promised) */
5713 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
5714 if (ckWARN(WARN_REDEFINE)) {
5715 GV * const gvcv = CvGV(cv);
5717 HV * const stash = GvSTASH(gvcv);
5719 const char *redefined_name = HvNAME_get(stash);
5720 if ( strEQ(redefined_name,"autouse") ) {
5721 const line_t oldline = CopLINE(PL_curcop);
5722 if (PL_copline != NOLINE)
5723 CopLINE_set(PL_curcop, PL_copline);
5724 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5725 CvCONST(cv) ? "Constant subroutine %s redefined"
5726 : "Subroutine %s redefined"
5728 CopLINE_set(PL_curcop, oldline);
5738 if (cv) /* must reuse cv if autoloaded */
5741 cv = (CV*)newSV_type(SVt_PVCV);
5745 PL_sub_generation++;
5749 (void)gv_fetchfile(filename);
5750 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
5751 an external constant string */
5753 CvXSUB(cv) = subaddr;
5756 process_special_blocks(name, gv, cv);
5768 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5773 OP* pegop = newOP(OP_NULL, 0);
5777 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
5778 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
5780 #ifdef GV_UNIQUE_CHECK
5782 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5786 if ((cv = GvFORM(gv))) {
5787 if (ckWARN(WARN_REDEFINE)) {
5788 const line_t oldline = CopLINE(PL_curcop);
5789 if (PL_copline != NOLINE)
5790 CopLINE_set(PL_curcop, PL_copline);
5791 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5792 o ? "Format %"SVf" redefined"
5793 : "Format STDOUT redefined", SVfARG(cSVOPo->op_sv));
5794 CopLINE_set(PL_curcop, oldline);
5801 CvFILE_set_from_cop(cv, PL_curcop);
5804 pad_tidy(padtidy_FORMAT);
5805 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5806 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5807 OpREFCNT_set(CvROOT(cv), 1);
5808 CvSTART(cv) = LINKLIST(CvROOT(cv));
5809 CvROOT(cv)->op_next = 0;
5810 CALL_PEEP(CvSTART(cv));
5812 op_getmad(o,pegop,'n');
5813 op_getmad_weak(block, pegop, 'b');
5817 PL_copline = NOLINE;
5825 Perl_newANONLIST(pTHX_ OP *o)
5827 return convert(OP_ANONLIST, OPf_SPECIAL, o);
5831 Perl_newANONHASH(pTHX_ OP *o)
5833 return convert(OP_ANONHASH, OPf_SPECIAL, o);
5837 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5839 return newANONATTRSUB(floor, proto, NULL, block);
5843 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5845 return newUNOP(OP_REFGEN, 0,
5846 newSVOP(OP_ANONCODE, 0,
5847 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5851 Perl_oopsAV(pTHX_ OP *o)
5854 switch (o->op_type) {
5856 o->op_type = OP_PADAV;
5857 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5858 return ref(o, OP_RV2AV);
5861 o->op_type = OP_RV2AV;
5862 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5867 if (ckWARN_d(WARN_INTERNAL))
5868 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
5875 Perl_oopsHV(pTHX_ OP *o)
5878 switch (o->op_type) {
5881 o->op_type = OP_PADHV;
5882 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5883 return ref(o, OP_RV2HV);
5887 o->op_type = OP_RV2HV;
5888 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5893 if (ckWARN_d(WARN_INTERNAL))
5894 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
5901 Perl_newAVREF(pTHX_ OP *o)
5904 if (o->op_type == OP_PADANY) {
5905 o->op_type = OP_PADAV;
5906 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5909 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5910 && ckWARN(WARN_DEPRECATED)) {
5911 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5912 "Using an array as a reference is deprecated");
5914 return newUNOP(OP_RV2AV, 0, scalar(o));
5918 Perl_newGVREF(pTHX_ I32 type, OP *o)
5920 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5921 return newUNOP(OP_NULL, 0, o);
5922 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5926 Perl_newHVREF(pTHX_ OP *o)
5929 if (o->op_type == OP_PADANY) {
5930 o->op_type = OP_PADHV;
5931 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5934 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5935 && ckWARN(WARN_DEPRECATED)) {
5936 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5937 "Using a hash as a reference is deprecated");
5939 return newUNOP(OP_RV2HV, 0, scalar(o));
5943 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5945 return newUNOP(OP_RV2CV, flags, scalar(o));
5949 Perl_newSVREF(pTHX_ OP *o)
5952 if (o->op_type == OP_PADANY) {
5953 o->op_type = OP_PADSV;
5954 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5957 return newUNOP(OP_RV2SV, 0, scalar(o));
5960 /* Check routines. See the comments at the top of this file for details
5961 * on when these are called */
5964 Perl_ck_anoncode(pTHX_ OP *o)
5966 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
5968 cSVOPo->op_sv = NULL;
5973 Perl_ck_bitop(pTHX_ OP *o)
5976 #define OP_IS_NUMCOMPARE(op) \
5977 ((op) == OP_LT || (op) == OP_I_LT || \
5978 (op) == OP_GT || (op) == OP_I_GT || \
5979 (op) == OP_LE || (op) == OP_I_LE || \
5980 (op) == OP_GE || (op) == OP_I_GE || \
5981 (op) == OP_EQ || (op) == OP_I_EQ || \
5982 (op) == OP_NE || (op) == OP_I_NE || \
5983 (op) == OP_NCMP || (op) == OP_I_NCMP)
5984 o->op_private = (U8)(PL_hints & HINT_INTEGER);
5985 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
5986 && (o->op_type == OP_BIT_OR
5987 || o->op_type == OP_BIT_AND
5988 || o->op_type == OP_BIT_XOR))
5990 const OP * const left = cBINOPo->op_first;
5991 const OP * const right = left->op_sibling;
5992 if ((OP_IS_NUMCOMPARE(left->op_type) &&
5993 (left->op_flags & OPf_PARENS) == 0) ||
5994 (OP_IS_NUMCOMPARE(right->op_type) &&
5995 (right->op_flags & OPf_PARENS) == 0))
5996 if (ckWARN(WARN_PRECEDENCE))
5997 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
5998 "Possible precedence problem on bitwise %c operator",
5999 o->op_type == OP_BIT_OR ? '|'
6000 : o->op_type == OP_BIT_AND ? '&' : '^'
6007 Perl_ck_concat(pTHX_ OP *o)
6009 const OP * const kid = cUNOPo->op_first;
6010 PERL_UNUSED_CONTEXT;
6011 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
6012 !(kUNOP->op_first->op_flags & OPf_MOD))
6013 o->op_flags |= OPf_STACKED;
6018 Perl_ck_spair(pTHX_ OP *o)
6021 if (o->op_flags & OPf_KIDS) {
6024 const OPCODE type = o->op_type;
6025 o = modkids(ck_fun(o), type);
6026 kid = cUNOPo->op_first;
6027 newop = kUNOP->op_first->op_sibling;
6029 const OPCODE type = newop->op_type;
6030 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
6031 type == OP_PADAV || type == OP_PADHV ||
6032 type == OP_RV2AV || type == OP_RV2HV)
6036 op_getmad(kUNOP->op_first,newop,'K');
6038 op_free(kUNOP->op_first);
6040 kUNOP->op_first = newop;
6042 o->op_ppaddr = PL_ppaddr[++o->op_type];
6047 Perl_ck_delete(pTHX_ OP *o)
6051 if (o->op_flags & OPf_KIDS) {
6052 OP * const kid = cUNOPo->op_first;
6053 switch (kid->op_type) {
6055 o->op_flags |= OPf_SPECIAL;
6058 o->op_private |= OPpSLICE;
6061 o->op_flags |= OPf_SPECIAL;
6066 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
6075 Perl_ck_die(pTHX_ OP *o)
6078 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6084 Perl_ck_eof(pTHX_ OP *o)
6088 if (o->op_flags & OPf_KIDS) {
6089 if (cLISTOPo->op_first->op_type == OP_STUB) {
6091 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
6093 op_getmad(o,newop,'O');
6105 Perl_ck_eval(pTHX_ OP *o)
6108 PL_hints |= HINT_BLOCK_SCOPE;
6109 if (o->op_flags & OPf_KIDS) {
6110 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6113 o->op_flags &= ~OPf_KIDS;
6116 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
6122 cUNOPo->op_first = 0;
6127 NewOp(1101, enter, 1, LOGOP);
6128 enter->op_type = OP_ENTERTRY;
6129 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
6130 enter->op_private = 0;
6132 /* establish postfix order */
6133 enter->op_next = (OP*)enter;
6135 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
6136 o->op_type = OP_LEAVETRY;
6137 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
6138 enter->op_other = o;
6139 op_getmad(oldo,o,'O');
6153 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
6154 op_getmad(oldo,o,'O');
6156 o->op_targ = (PADOFFSET)PL_hints;
6157 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
6158 /* Store a copy of %^H that pp_entereval can pick up.
6159 OPf_SPECIAL flags the opcode as being for this purpose,
6160 so that it in turn will return a copy at every
6162 OP *hhop = newSVOP(OP_CONST, OPf_SPECIAL,
6163 (SV*)Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv)));
6164 cUNOPo->op_first->op_sibling = hhop;
6165 o->op_private |= OPpEVAL_HAS_HH;
6171 Perl_ck_exit(pTHX_ OP *o)
6174 HV * const table = GvHV(PL_hintgv);
6176 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
6177 if (svp && *svp && SvTRUE(*svp))
6178 o->op_private |= OPpEXIT_VMSISH;
6180 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6186 Perl_ck_exec(pTHX_ OP *o)
6188 if (o->op_flags & OPf_STACKED) {
6191 kid = cUNOPo->op_first->op_sibling;
6192 if (kid->op_type == OP_RV2GV)
6201 Perl_ck_exists(pTHX_ OP *o)
6205 if (o->op_flags & OPf_KIDS) {
6206 OP * const kid = cUNOPo->op_first;
6207 if (kid->op_type == OP_ENTERSUB) {
6208 (void) ref(kid, o->op_type);
6209 if (kid->op_type != OP_RV2CV && !PL_error_count)
6210 Perl_croak(aTHX_ "%s argument is not a subroutine name",
6212 o->op_private |= OPpEXISTS_SUB;
6214 else if (kid->op_type == OP_AELEM)
6215 o->op_flags |= OPf_SPECIAL;
6216 else if (kid->op_type != OP_HELEM)
6217 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
6225 Perl_ck_rvconst(pTHX_ register OP *o)
6228 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6230 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6231 if (o->op_type == OP_RV2CV)
6232 o->op_private &= ~1;
6234 if (kid->op_type == OP_CONST) {
6237 SV * const kidsv = kid->op_sv;
6239 /* Is it a constant from cv_const_sv()? */
6240 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
6241 SV * const rsv = SvRV(kidsv);
6242 const svtype type = SvTYPE(rsv);
6243 const char *badtype = NULL;
6245 switch (o->op_type) {
6247 if (type > SVt_PVMG)
6248 badtype = "a SCALAR";
6251 if (type != SVt_PVAV)
6252 badtype = "an ARRAY";
6255 if (type != SVt_PVHV)
6259 if (type != SVt_PVCV)
6264 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
6267 else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
6268 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
6269 /* If this is an access to a stash, disable "strict refs", because
6270 * stashes aren't auto-vivified at compile-time (unless we store
6271 * symbols in them), and we don't want to produce a run-time
6272 * stricture error when auto-vivifying the stash. */
6273 const char *s = SvPV_nolen(kidsv);
6274 const STRLEN l = SvCUR(kidsv);
6275 if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
6276 o->op_private &= ~HINT_STRICT_REFS;
6278 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
6279 const char *badthing;
6280 switch (o->op_type) {
6282 badthing = "a SCALAR";
6285 badthing = "an ARRAY";
6288 badthing = "a HASH";
6296 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
6297 SVfARG(kidsv), badthing);
6300 * This is a little tricky. We only want to add the symbol if we
6301 * didn't add it in the lexer. Otherwise we get duplicate strict
6302 * warnings. But if we didn't add it in the lexer, we must at
6303 * least pretend like we wanted to add it even if it existed before,
6304 * or we get possible typo warnings. OPpCONST_ENTERED says
6305 * whether the lexer already added THIS instance of this symbol.
6307 iscv = (o->op_type == OP_RV2CV) * 2;
6309 gv = gv_fetchsv(kidsv,
6310 iscv | !(kid->op_private & OPpCONST_ENTERED),
6313 : o->op_type == OP_RV2SV
6315 : o->op_type == OP_RV2AV
6317 : o->op_type == OP_RV2HV
6320 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
6322 kid->op_type = OP_GV;
6323 SvREFCNT_dec(kid->op_sv);
6325 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
6326 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
6327 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
6329 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc_simple_NN(gv));
6331 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
6333 kid->op_private = 0;
6334 kid->op_ppaddr = PL_ppaddr[OP_GV];
6341 Perl_ck_ftst(pTHX_ OP *o)
6344 const I32 type = o->op_type;
6346 if (o->op_flags & OPf_REF) {
6349 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
6350 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6351 const OPCODE kidtype = kid->op_type;
6353 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6354 OP * const newop = newGVOP(type, OPf_REF,
6355 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
6357 op_getmad(o,newop,'O');
6363 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o))
6364 o->op_private |= OPpFT_ACCESS;
6365 if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst)
6366 && kidtype != OP_STAT && kidtype != OP_LSTAT)
6367 o->op_private |= OPpFT_STACKED;
6375 if (type == OP_FTTTY)
6376 o = newGVOP(type, OPf_REF, PL_stdingv);
6378 o = newUNOP(type, 0, newDEFSVOP());
6379 op_getmad(oldo,o,'O');
6385 Perl_ck_fun(pTHX_ OP *o)
6388 const int type = o->op_type;
6389 register I32 oa = PL_opargs[type] >> OASHIFT;
6391 if (o->op_flags & OPf_STACKED) {
6392 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
6395 return no_fh_allowed(o);
6398 if (o->op_flags & OPf_KIDS) {
6399 OP **tokid = &cLISTOPo->op_first;
6400 register OP *kid = cLISTOPo->op_first;
6404 if (kid->op_type == OP_PUSHMARK ||
6405 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
6407 tokid = &kid->op_sibling;
6408 kid = kid->op_sibling;
6410 if (!kid && PL_opargs[type] & OA_DEFGV)
6411 *tokid = kid = newDEFSVOP();
6415 sibl = kid->op_sibling;
6417 if (!sibl && kid->op_type == OP_STUB) {
6424 /* list seen where single (scalar) arg expected? */
6425 if (numargs == 1 && !(oa >> 4)
6426 && kid->op_type == OP_LIST && type != OP_SCALAR)
6428 return too_many_arguments(o,PL_op_desc[type]);
6441 if ((type == OP_PUSH || type == OP_UNSHIFT)
6442 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
6443 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6444 "Useless use of %s with no values",
6447 if (kid->op_type == OP_CONST &&
6448 (kid->op_private & OPpCONST_BARE))
6450 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
6451 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
6452 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6453 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6454 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
6455 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6457 op_getmad(kid,newop,'K');
6462 kid->op_sibling = sibl;
6465 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
6466 bad_type(numargs, "array", PL_op_desc[type], kid);
6470 if (kid->op_type == OP_CONST &&
6471 (kid->op_private & OPpCONST_BARE))
6473 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
6474 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
6475 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6476 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6477 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
6478 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6480 op_getmad(kid,newop,'K');
6485 kid->op_sibling = sibl;
6488 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
6489 bad_type(numargs, "hash", PL_op_desc[type], kid);
6494 OP * const newop = newUNOP(OP_NULL, 0, kid);
6495 kid->op_sibling = 0;
6497 newop->op_next = newop;
6499 kid->op_sibling = sibl;
6504 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
6505 if (kid->op_type == OP_CONST &&
6506 (kid->op_private & OPpCONST_BARE))
6508 OP * const newop = newGVOP(OP_GV, 0,
6509 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
6510 if (!(o->op_private & 1) && /* if not unop */
6511 kid == cLISTOPo->op_last)
6512 cLISTOPo->op_last = newop;
6514 op_getmad(kid,newop,'K');
6520 else if (kid->op_type == OP_READLINE) {
6521 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
6522 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
6525 I32 flags = OPf_SPECIAL;
6529 /* is this op a FH constructor? */
6530 if (is_handle_constructor(o,numargs)) {
6531 const char *name = NULL;
6535 /* Set a flag to tell rv2gv to vivify
6536 * need to "prove" flag does not mean something
6537 * else already - NI-S 1999/05/07
6540 if (kid->op_type == OP_PADSV) {
6542 = PAD_COMPNAME_SV(kid->op_targ);
6543 name = SvPV_const(namesv, len);
6545 else if (kid->op_type == OP_RV2SV
6546 && kUNOP->op_first->op_type == OP_GV)
6548 GV * const gv = cGVOPx_gv(kUNOP->op_first);
6550 len = GvNAMELEN(gv);
6552 else if (kid->op_type == OP_AELEM
6553 || kid->op_type == OP_HELEM)
6556 OP *op = ((BINOP*)kid)->op_first;
6560 const char * const a =
6561 kid->op_type == OP_AELEM ?
6563 if (((op->op_type == OP_RV2AV) ||
6564 (op->op_type == OP_RV2HV)) &&
6565 (firstop = ((UNOP*)op)->op_first) &&
6566 (firstop->op_type == OP_GV)) {
6567 /* packagevar $a[] or $h{} */
6568 GV * const gv = cGVOPx_gv(firstop);
6576 else if (op->op_type == OP_PADAV
6577 || op->op_type == OP_PADHV) {
6578 /* lexicalvar $a[] or $h{} */
6579 const char * const padname =
6580 PAD_COMPNAME_PV(op->op_targ);
6589 name = SvPV_const(tmpstr, len);
6594 name = "__ANONIO__";
6601 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
6602 namesv = PAD_SVl(targ);
6603 SvUPGRADE(namesv, SVt_PV);
6605 sv_setpvn(namesv, "$", 1);
6606 sv_catpvn(namesv, name, len);
6609 kid->op_sibling = 0;
6610 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
6611 kid->op_targ = targ;
6612 kid->op_private |= priv;
6614 kid->op_sibling = sibl;
6620 mod(scalar(kid), type);
6624 tokid = &kid->op_sibling;
6625 kid = kid->op_sibling;
6628 if (kid && kid->op_type != OP_STUB)
6629 return too_many_arguments(o,OP_DESC(o));
6630 o->op_private |= numargs;
6632 /* FIXME - should the numargs move as for the PERL_MAD case? */
6633 o->op_private |= numargs;
6635 return too_many_arguments(o,OP_DESC(o));
6639 else if (PL_opargs[type] & OA_DEFGV) {
6641 OP *newop = newUNOP(type, 0, newDEFSVOP());
6642 op_getmad(o,newop,'O');
6645 /* Ordering of these two is important to keep f_map.t passing. */
6647 return newUNOP(type, 0, newDEFSVOP());
6652 while (oa & OA_OPTIONAL)
6654 if (oa && oa != OA_LIST)
6655 return too_few_arguments(o,OP_DESC(o));
6661 Perl_ck_glob(pTHX_ OP *o)
6667 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
6668 append_elem(OP_GLOB, o, newDEFSVOP());
6670 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
6671 && GvCVu(gv) && GvIMPORTED_CV(gv)))
6673 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6676 #if !defined(PERL_EXTERNAL_GLOB)
6677 /* XXX this can be tightened up and made more failsafe. */
6678 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
6681 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
6682 newSVpvs("File::Glob"), NULL, NULL, NULL);
6683 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6684 glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
6685 GvCV(gv) = GvCV(glob_gv);
6686 SvREFCNT_inc_void((SV*)GvCV(gv));
6687 GvIMPORTED_CV_on(gv);
6690 #endif /* PERL_EXTERNAL_GLOB */
6692 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6693 append_elem(OP_GLOB, o,
6694 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
6695 o->op_type = OP_LIST;
6696 o->op_ppaddr = PL_ppaddr[OP_LIST];
6697 cLISTOPo->op_first->op_type = OP_PUSHMARK;
6698 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
6699 cLISTOPo->op_first->op_targ = 0;
6700 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
6701 append_elem(OP_LIST, o,
6702 scalar(newUNOP(OP_RV2CV, 0,
6703 newGVOP(OP_GV, 0, gv)))));
6704 o = newUNOP(OP_NULL, 0, ck_subr(o));
6705 o->op_targ = OP_GLOB; /* hint at what it used to be */
6708 gv = newGVgen("main");
6710 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
6716 Perl_ck_grep(pTHX_ OP *o)
6721 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
6724 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
6725 /* don't allocate gwop here, as we may leak it if PL_error_count > 0 */
6727 if (o->op_flags & OPf_STACKED) {
6730 kid = cLISTOPo->op_first->op_sibling;
6731 if (!cUNOPx(kid)->op_next)
6732 Perl_croak(aTHX_ "panic: ck_grep");
6733 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
6736 NewOp(1101, gwop, 1, LOGOP);
6737 kid->op_next = (OP*)gwop;
6738 o->op_flags &= ~OPf_STACKED;
6740 kid = cLISTOPo->op_first->op_sibling;
6741 if (type == OP_MAPWHILE)
6748 kid = cLISTOPo->op_first->op_sibling;
6749 if (kid->op_type != OP_NULL)
6750 Perl_croak(aTHX_ "panic: ck_grep");
6751 kid = kUNOP->op_first;
6754 NewOp(1101, gwop, 1, LOGOP);
6755 gwop->op_type = type;
6756 gwop->op_ppaddr = PL_ppaddr[type];
6757 gwop->op_first = listkids(o);
6758 gwop->op_flags |= OPf_KIDS;
6759 gwop->op_other = LINKLIST(kid);
6760 kid->op_next = (OP*)gwop;
6761 offset = pad_findmy("$_");
6762 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
6763 o->op_private = gwop->op_private = 0;
6764 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
6767 o->op_private = gwop->op_private = OPpGREP_LEX;
6768 gwop->op_targ = o->op_targ = offset;
6771 kid = cLISTOPo->op_first->op_sibling;
6772 if (!kid || !kid->op_sibling)
6773 return too_few_arguments(o,OP_DESC(o));
6774 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
6775 mod(kid, OP_GREPSTART);
6781 Perl_ck_index(pTHX_ OP *o)
6783 if (o->op_flags & OPf_KIDS) {
6784 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6786 kid = kid->op_sibling; /* get past "big" */
6787 if (kid && kid->op_type == OP_CONST)
6788 fbm_compile(((SVOP*)kid)->op_sv, 0);
6794 Perl_ck_lengthconst(pTHX_ OP *o)
6796 /* XXX length optimization goes here */
6801 Perl_ck_lfun(pTHX_ OP *o)
6803 const OPCODE type = o->op_type;
6804 return modkids(ck_fun(o), type);
6808 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
6810 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
6811 switch (cUNOPo->op_first->op_type) {
6813 /* This is needed for
6814 if (defined %stash::)
6815 to work. Do not break Tk.
6817 break; /* Globals via GV can be undef */
6819 case OP_AASSIGN: /* Is this a good idea? */
6820 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6821 "defined(@array) is deprecated");
6822 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6823 "\t(Maybe you should just omit the defined()?)\n");
6826 /* This is needed for
6827 if (defined %stash::)
6828 to work. Do not break Tk.
6830 break; /* Globals via GV can be undef */
6832 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6833 "defined(%%hash) is deprecated");
6834 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6835 "\t(Maybe you should just omit the defined()?)\n");
6846 Perl_ck_readline(pTHX_ OP *o)
6848 if (!(o->op_flags & OPf_KIDS)) {
6850 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
6852 op_getmad(o,newop,'O');
6862 Perl_ck_rfun(pTHX_ OP *o)
6864 const OPCODE type = o->op_type;
6865 return refkids(ck_fun(o), type);
6869 Perl_ck_listiob(pTHX_ OP *o)
6873 kid = cLISTOPo->op_first;
6876 kid = cLISTOPo->op_first;
6878 if (kid->op_type == OP_PUSHMARK)
6879 kid = kid->op_sibling;
6880 if (kid && o->op_flags & OPf_STACKED)
6881 kid = kid->op_sibling;
6882 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6883 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6884 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6885 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6886 cLISTOPo->op_first->op_sibling = kid;
6887 cLISTOPo->op_last = kid;
6888 kid = kid->op_sibling;
6893 append_elem(o->op_type, o, newDEFSVOP());
6899 Perl_ck_smartmatch(pTHX_ OP *o)
6902 if (0 == (o->op_flags & OPf_SPECIAL)) {
6903 OP *first = cBINOPo->op_first;
6904 OP *second = first->op_sibling;
6906 /* Implicitly take a reference to an array or hash */
6907 first->op_sibling = NULL;
6908 first = cBINOPo->op_first = ref_array_or_hash(first);
6909 second = first->op_sibling = ref_array_or_hash(second);
6911 /* Implicitly take a reference to a regular expression */
6912 if (first->op_type == OP_MATCH) {
6913 first->op_type = OP_QR;
6914 first->op_ppaddr = PL_ppaddr[OP_QR];
6916 if (second->op_type == OP_MATCH) {
6917 second->op_type = OP_QR;
6918 second->op_ppaddr = PL_ppaddr[OP_QR];
6927 Perl_ck_sassign(pTHX_ OP *o)
6929 OP * const kid = cLISTOPo->op_first;
6930 /* has a disposable target? */
6931 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6932 && !(kid->op_flags & OPf_STACKED)
6933 /* Cannot steal the second time! */
6934 && !(kid->op_private & OPpTARGET_MY))
6936 OP * const kkid = kid->op_sibling;
6938 /* Can just relocate the target. */
6939 if (kkid && kkid->op_type == OP_PADSV
6940 && !(kkid->op_private & OPpLVAL_INTRO))
6942 kid->op_targ = kkid->op_targ;
6944 /* Now we do not need PADSV and SASSIGN. */
6945 kid->op_sibling = o->op_sibling; /* NULL */
6946 cLISTOPo->op_first = NULL;
6948 op_getmad(o,kid,'O');
6949 op_getmad(kkid,kid,'M');
6954 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6958 if (kid->op_sibling) {
6959 OP *kkid = kid->op_sibling;
6960 if (kkid->op_type == OP_PADSV
6961 && (kkid->op_private & OPpLVAL_INTRO)
6962 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
6963 o->op_private |= OPpASSIGN_STATE;
6964 /* hijacking PADSTALE for uninitialized state variables */
6965 SvPADSTALE_on(PAD_SVl(kkid->op_targ));
6972 Perl_ck_match(pTHX_ OP *o)
6975 if (o->op_type != OP_QR && PL_compcv) {
6976 const PADOFFSET offset = pad_findmy("$_");
6977 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
6978 o->op_targ = offset;
6979 o->op_private |= OPpTARGET_MY;
6982 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
6983 o->op_private |= OPpRUNTIME;
6988 Perl_ck_method(pTHX_ OP *o)
6990 OP * const kid = cUNOPo->op_first;
6991 if (kid->op_type == OP_CONST) {
6992 SV* sv = kSVOP->op_sv;
6993 const char * const method = SvPVX_const(sv);
6994 if (!(strchr(method, ':') || strchr(method, '\''))) {
6996 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6997 sv = newSVpvn_share(method, SvCUR(sv), 0);
7000 kSVOP->op_sv = NULL;
7002 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
7004 op_getmad(o,cmop,'O');
7015 Perl_ck_null(pTHX_ OP *o)
7017 PERL_UNUSED_CONTEXT;
7022 Perl_ck_open(pTHX_ OP *o)
7025 HV * const table = GvHV(PL_hintgv);
7027 SV **svp = hv_fetchs(table, "open_IN", FALSE);
7029 const I32 mode = mode_from_discipline(*svp);
7030 if (mode & O_BINARY)
7031 o->op_private |= OPpOPEN_IN_RAW;
7032 else if (mode & O_TEXT)
7033 o->op_private |= OPpOPEN_IN_CRLF;
7036 svp = hv_fetchs(table, "open_OUT", FALSE);
7038 const I32 mode = mode_from_discipline(*svp);
7039 if (mode & O_BINARY)
7040 o->op_private |= OPpOPEN_OUT_RAW;
7041 else if (mode & O_TEXT)
7042 o->op_private |= OPpOPEN_OUT_CRLF;
7045 if (o->op_type == OP_BACKTICK) {
7046 if (!(o->op_flags & OPf_KIDS)) {
7047 OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
7049 op_getmad(o,newop,'O');
7058 /* In case of three-arg dup open remove strictness
7059 * from the last arg if it is a bareword. */
7060 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
7061 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
7065 if ((last->op_type == OP_CONST) && /* The bareword. */
7066 (last->op_private & OPpCONST_BARE) &&
7067 (last->op_private & OPpCONST_STRICT) &&
7068 (oa = first->op_sibling) && /* The fh. */
7069 (oa = oa->op_sibling) && /* The mode. */
7070 (oa->op_type == OP_CONST) &&
7071 SvPOK(((SVOP*)oa)->op_sv) &&
7072 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
7073 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
7074 (last == oa->op_sibling)) /* The bareword. */
7075 last->op_private &= ~OPpCONST_STRICT;
7081 Perl_ck_repeat(pTHX_ OP *o)
7083 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
7084 o->op_private |= OPpREPEAT_DOLIST;
7085 cBINOPo->op_first = force_list(cBINOPo->op_first);
7093 Perl_ck_require(pTHX_ OP *o)
7098 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
7099 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7101 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
7102 SV * const sv = kid->op_sv;
7103 U32 was_readonly = SvREADONLY(sv);
7108 sv_force_normal_flags(sv, 0);
7109 assert(!SvREADONLY(sv));
7116 for (s = SvPVX(sv); *s; s++) {
7117 if (*s == ':' && s[1] == ':') {
7118 const STRLEN len = strlen(s+2)+1;
7120 Move(s+2, s+1, len, char);
7121 SvCUR_set(sv, SvCUR(sv) - 1);
7124 sv_catpvs(sv, ".pm");
7125 SvFLAGS(sv) |= was_readonly;
7129 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
7130 /* handle override, if any */
7131 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
7132 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7133 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
7134 gv = gvp ? *gvp : NULL;
7138 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7139 OP * const kid = cUNOPo->op_first;
7142 cUNOPo->op_first = 0;
7146 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
7147 append_elem(OP_LIST, kid,
7148 scalar(newUNOP(OP_RV2CV, 0,
7151 op_getmad(o,newop,'O');
7159 Perl_ck_return(pTHX_ OP *o)
7162 if (CvLVALUE(PL_compcv)) {
7164 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
7165 mod(kid, OP_LEAVESUBLV);
7171 Perl_ck_select(pTHX_ OP *o)
7175 if (o->op_flags & OPf_KIDS) {
7176 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7177 if (kid && kid->op_sibling) {
7178 o->op_type = OP_SSELECT;
7179 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
7181 return fold_constants(o);
7185 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7186 if (kid && kid->op_type == OP_RV2GV)
7187 kid->op_private &= ~HINT_STRICT_REFS;
7192 Perl_ck_shift(pTHX_ OP *o)
7195 const I32 type = o->op_type;
7197 if (!(o->op_flags & OPf_KIDS)) {
7199 /* FIXME - this can be refactored to reduce code in #ifdefs */
7201 OP * const oldo = o;
7205 argop = newUNOP(OP_RV2AV, 0,
7206 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
7208 o = newUNOP(type, 0, scalar(argop));
7209 op_getmad(oldo,o,'O');
7212 return newUNOP(type, 0, scalar(argop));
7215 return scalar(modkids(ck_fun(o), type));
7219 Perl_ck_sort(pTHX_ OP *o)
7224 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
7225 HV * const hinthv = GvHV(PL_hintgv);
7227 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
7229 const I32 sorthints = (I32)SvIV(*svp);
7230 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
7231 o->op_private |= OPpSORT_QSORT;
7232 if ((sorthints & HINT_SORT_STABLE) != 0)
7233 o->op_private |= OPpSORT_STABLE;
7238 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
7240 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7241 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
7243 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
7245 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
7247 if (kid->op_type == OP_SCOPE) {
7251 else if (kid->op_type == OP_LEAVE) {
7252 if (o->op_type == OP_SORT) {
7253 op_null(kid); /* wipe out leave */
7256 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
7257 if (k->op_next == kid)
7259 /* don't descend into loops */
7260 else if (k->op_type == OP_ENTERLOOP
7261 || k->op_type == OP_ENTERITER)
7263 k = cLOOPx(k)->op_lastop;
7268 kid->op_next = 0; /* just disconnect the leave */
7269 k = kLISTOP->op_first;
7274 if (o->op_type == OP_SORT) {
7275 /* provide scalar context for comparison function/block */
7281 o->op_flags |= OPf_SPECIAL;
7283 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
7286 firstkid = firstkid->op_sibling;
7289 /* provide list context for arguments */
7290 if (o->op_type == OP_SORT)
7297 S_simplify_sort(pTHX_ OP *o)
7300 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7305 if (!(o->op_flags & OPf_STACKED))
7307 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7308 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
7309 kid = kUNOP->op_first; /* get past null */
7310 if (kid->op_type != OP_SCOPE)
7312 kid = kLISTOP->op_last; /* get past scope */
7313 switch(kid->op_type) {
7321 k = kid; /* remember this node*/
7322 if (kBINOP->op_first->op_type != OP_RV2SV)
7324 kid = kBINOP->op_first; /* get past cmp */
7325 if (kUNOP->op_first->op_type != OP_GV)
7327 kid = kUNOP->op_first; /* get past rv2sv */
7329 if (GvSTASH(gv) != PL_curstash)
7331 gvname = GvNAME(gv);
7332 if (*gvname == 'a' && gvname[1] == '\0')
7334 else if (*gvname == 'b' && gvname[1] == '\0')
7339 kid = k; /* back to cmp */
7340 if (kBINOP->op_last->op_type != OP_RV2SV)
7342 kid = kBINOP->op_last; /* down to 2nd arg */
7343 if (kUNOP->op_first->op_type != OP_GV)
7345 kid = kUNOP->op_first; /* get past rv2sv */
7347 if (GvSTASH(gv) != PL_curstash)
7349 gvname = GvNAME(gv);
7351 ? !(*gvname == 'a' && gvname[1] == '\0')
7352 : !(*gvname == 'b' && gvname[1] == '\0'))
7354 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
7356 o->op_private |= OPpSORT_DESCEND;
7357 if (k->op_type == OP_NCMP)
7358 o->op_private |= OPpSORT_NUMERIC;
7359 if (k->op_type == OP_I_NCMP)
7360 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
7361 kid = cLISTOPo->op_first->op_sibling;
7362 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
7364 op_getmad(kid,o,'S'); /* then delete it */
7366 op_free(kid); /* then delete it */
7371 Perl_ck_split(pTHX_ OP *o)
7376 if (o->op_flags & OPf_STACKED)
7377 return no_fh_allowed(o);
7379 kid = cLISTOPo->op_first;
7380 if (kid->op_type != OP_NULL)
7381 Perl_croak(aTHX_ "panic: ck_split");
7382 kid = kid->op_sibling;
7383 op_free(cLISTOPo->op_first);
7384 cLISTOPo->op_first = kid;
7386 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
7387 cLISTOPo->op_last = kid; /* There was only one element previously */
7390 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
7391 OP * const sibl = kid->op_sibling;
7392 kid->op_sibling = 0;
7393 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
7394 if (cLISTOPo->op_first == cLISTOPo->op_last)
7395 cLISTOPo->op_last = kid;
7396 cLISTOPo->op_first = kid;
7397 kid->op_sibling = sibl;
7400 kid->op_type = OP_PUSHRE;
7401 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
7403 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
7404 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
7405 "Use of /g modifier is meaningless in split");
7408 if (!kid->op_sibling)
7409 append_elem(OP_SPLIT, o, newDEFSVOP());
7411 kid = kid->op_sibling;
7414 if (!kid->op_sibling)
7415 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
7416 assert(kid->op_sibling);
7418 kid = kid->op_sibling;
7421 if (kid->op_sibling)
7422 return too_many_arguments(o,OP_DESC(o));
7428 Perl_ck_join(pTHX_ OP *o)
7430 const OP * const kid = cLISTOPo->op_first->op_sibling;
7431 if (kid && kid->op_type == OP_MATCH) {
7432 if (ckWARN(WARN_SYNTAX)) {
7433 const REGEXP *re = PM_GETRE(kPMOP);
7434 const char *pmstr = re ? re->precomp : "STRING";
7435 const STRLEN len = re ? re->prelen : 6;
7436 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7437 "/%.*s/ should probably be written as \"%.*s\"",
7438 (int)len, pmstr, (int)len, pmstr);
7445 Perl_ck_subr(pTHX_ OP *o)
7448 OP *prev = ((cUNOPo->op_first->op_sibling)
7449 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
7450 OP *o2 = prev->op_sibling;
7452 const char *proto = NULL;
7453 const char *proto_end = NULL;
7458 I32 contextclass = 0;
7459 const char *e = NULL;
7462 o->op_private |= OPpENTERSUB_HASTARG;
7463 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
7464 if (cvop->op_type == OP_RV2CV) {
7466 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
7467 op_null(cvop); /* disable rv2cv */
7468 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
7469 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
7470 GV *gv = cGVOPx_gv(tmpop);
7473 tmpop->op_private |= OPpEARLY_CV;
7477 namegv = CvANON(cv) ? gv : CvGV(cv);
7478 proto = SvPV((SV*)cv, len);
7479 proto_end = proto + len;
7481 if (CvASSERTION(cv)) {
7482 U32 asserthints = 0;
7483 HV *const hinthv = GvHV(PL_hintgv);
7485 SV **svp = hv_fetchs(hinthv, "assertions", FALSE);
7487 asserthints = SvUV(*svp);
7489 if (asserthints & HINT_ASSERTING) {
7490 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
7491 o->op_private |= OPpENTERSUB_DB;
7495 if (!(asserthints & HINT_ASSERTIONSSEEN) && ckWARN(WARN_ASSERTIONS)) {
7496 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
7497 "Impossible to activate assertion call");
7504 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7505 if (o2->op_type == OP_CONST)
7506 o2->op_private &= ~OPpCONST_STRICT;
7507 else if (o2->op_type == OP_LIST) {
7508 OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
7509 if (sib && sib->op_type == OP_CONST)
7510 sib->op_private &= ~OPpCONST_STRICT;
7513 o->op_private |= (PL_hints & HINT_STRICT_REFS);
7514 if (PERLDB_SUB && PL_curstash != PL_debstash)
7515 o->op_private |= OPpENTERSUB_DB;
7516 while (o2 != cvop) {
7518 if (PL_madskills && o2->op_type == OP_NULL)
7519 o3 = ((UNOP*)o2)->op_first;
7523 if (proto >= proto_end)
7524 return too_many_arguments(o, gv_ename(namegv));
7532 /* _ must be at the end */
7533 if (proto[1] && proto[1] != ';')
7548 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
7550 arg == 1 ? "block or sub {}" : "sub {}",
7551 gv_ename(namegv), o3);
7554 /* '*' allows any scalar type, including bareword */
7557 if (o3->op_type == OP_RV2GV)
7558 goto wrapref; /* autoconvert GLOB -> GLOBref */
7559 else if (o3->op_type == OP_CONST)
7560 o3->op_private &= ~OPpCONST_STRICT;
7561 else if (o3->op_type == OP_ENTERSUB) {
7562 /* accidental subroutine, revert to bareword */
7563 OP *gvop = ((UNOP*)o3)->op_first;
7564 if (gvop && gvop->op_type == OP_NULL) {
7565 gvop = ((UNOP*)gvop)->op_first;
7567 for (; gvop->op_sibling; gvop = gvop->op_sibling)
7570 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
7571 (gvop = ((UNOP*)gvop)->op_first) &&
7572 gvop->op_type == OP_GV)
7574 GV * const gv = cGVOPx_gv(gvop);
7575 OP * const sibling = o2->op_sibling;
7576 SV * const n = newSVpvs("");
7578 OP * const oldo2 = o2;
7582 gv_fullname4(n, gv, "", FALSE);
7583 o2 = newSVOP(OP_CONST, 0, n);
7584 op_getmad(oldo2,o2,'O');
7585 prev->op_sibling = o2;
7586 o2->op_sibling = sibling;
7602 if (contextclass++ == 0) {
7603 e = strchr(proto, ']');
7604 if (!e || e == proto)
7613 const char *p = proto;
7614 const char *const end = proto;
7616 while (*--p != '[');
7617 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
7619 gv_ename(namegv), o3);
7624 if (o3->op_type == OP_RV2GV)
7627 bad_type(arg, "symbol", gv_ename(namegv), o3);
7630 if (o3->op_type == OP_ENTERSUB)
7633 bad_type(arg, "subroutine entry", gv_ename(namegv),
7637 if (o3->op_type == OP_RV2SV ||
7638 o3->op_type == OP_PADSV ||
7639 o3->op_type == OP_HELEM ||
7640 o3->op_type == OP_AELEM)
7643 bad_type(arg, "scalar", gv_ename(namegv), o3);
7646 if (o3->op_type == OP_RV2AV ||
7647 o3->op_type == OP_PADAV)
7650 bad_type(arg, "array", gv_ename(namegv), o3);
7653 if (o3->op_type == OP_RV2HV ||
7654 o3->op_type == OP_PADHV)
7657 bad_type(arg, "hash", gv_ename(namegv), o3);
7662 OP* const sib = kid->op_sibling;
7663 kid->op_sibling = 0;
7664 o2 = newUNOP(OP_REFGEN, 0, kid);
7665 o2->op_sibling = sib;
7666 prev->op_sibling = o2;
7668 if (contextclass && e) {
7683 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
7684 gv_ename(namegv), SVfARG(cv));
7689 mod(o2, OP_ENTERSUB);
7691 o2 = o2->op_sibling;
7693 if (o2 == cvop && proto && *proto == '_') {
7694 /* generate an access to $_ */
7696 o2->op_sibling = prev->op_sibling;
7697 prev->op_sibling = o2; /* instead of cvop */
7699 if (proto && !optional && proto_end > proto &&
7700 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
7701 return too_few_arguments(o, gv_ename(namegv));
7704 OP * const oldo = o;
7708 o=newSVOP(OP_CONST, 0, newSViv(0));
7709 op_getmad(oldo,o,'O');
7715 Perl_ck_svconst(pTHX_ OP *o)
7717 PERL_UNUSED_CONTEXT;
7718 SvREADONLY_on(cSVOPo->op_sv);
7723 Perl_ck_chdir(pTHX_ OP *o)
7725 if (o->op_flags & OPf_KIDS) {
7726 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7728 if (kid && kid->op_type == OP_CONST &&
7729 (kid->op_private & OPpCONST_BARE))
7731 o->op_flags |= OPf_SPECIAL;
7732 kid->op_private &= ~OPpCONST_STRICT;
7739 Perl_ck_trunc(pTHX_ OP *o)
7741 if (o->op_flags & OPf_KIDS) {
7742 SVOP *kid = (SVOP*)cUNOPo->op_first;
7744 if (kid->op_type == OP_NULL)
7745 kid = (SVOP*)kid->op_sibling;
7746 if (kid && kid->op_type == OP_CONST &&
7747 (kid->op_private & OPpCONST_BARE))
7749 o->op_flags |= OPf_SPECIAL;
7750 kid->op_private &= ~OPpCONST_STRICT;
7757 Perl_ck_unpack(pTHX_ OP *o)
7759 OP *kid = cLISTOPo->op_first;
7760 if (kid->op_sibling) {
7761 kid = kid->op_sibling;
7762 if (!kid->op_sibling)
7763 kid->op_sibling = newDEFSVOP();
7769 Perl_ck_substr(pTHX_ OP *o)
7772 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
7773 OP *kid = cLISTOPo->op_first;
7775 if (kid->op_type == OP_NULL)
7776 kid = kid->op_sibling;
7778 kid->op_flags |= OPf_MOD;
7784 /* A peephole optimizer. We visit the ops in the order they're to execute.
7785 * See the comments at the top of this file for more details about when
7786 * peep() is called */
7789 Perl_peep(pTHX_ register OP *o)
7792 register OP* oldop = NULL;
7794 if (!o || o->op_opt)
7798 SAVEVPTR(PL_curcop);
7799 for (; o; o = o->op_next) {
7803 switch (o->op_type) {
7807 PL_curcop = ((COP*)o); /* for warnings */
7812 if (cSVOPo->op_private & OPpCONST_STRICT)
7813 no_bareword_allowed(o);
7815 case OP_METHOD_NAMED:
7816 /* Relocate sv to the pad for thread safety.
7817 * Despite being a "constant", the SV is written to,
7818 * for reference counts, sv_upgrade() etc. */
7820 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
7821 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
7822 /* If op_sv is already a PADTMP then it is being used by
7823 * some pad, so make a copy. */
7824 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
7825 SvREADONLY_on(PAD_SVl(ix));
7826 SvREFCNT_dec(cSVOPo->op_sv);
7828 else if (o->op_type == OP_CONST
7829 && cSVOPo->op_sv == &PL_sv_undef) {
7830 /* PL_sv_undef is hack - it's unsafe to store it in the
7831 AV that is the pad, because av_fetch treats values of
7832 PL_sv_undef as a "free" AV entry and will merrily
7833 replace them with a new SV, causing pad_alloc to think
7834 that this pad slot is free. (When, clearly, it is not)
7836 SvOK_off(PAD_SVl(ix));
7837 SvPADTMP_on(PAD_SVl(ix));
7838 SvREADONLY_on(PAD_SVl(ix));
7841 SvREFCNT_dec(PAD_SVl(ix));
7842 SvPADTMP_on(cSVOPo->op_sv);
7843 PAD_SETSV(ix, cSVOPo->op_sv);
7844 /* XXX I don't know how this isn't readonly already. */
7845 SvREADONLY_on(PAD_SVl(ix));
7847 cSVOPo->op_sv = NULL;
7855 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
7856 if (o->op_next->op_private & OPpTARGET_MY) {
7857 if (o->op_flags & OPf_STACKED) /* chained concats */
7858 goto ignore_optimization;
7860 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
7861 o->op_targ = o->op_next->op_targ;
7862 o->op_next->op_targ = 0;
7863 o->op_private |= OPpTARGET_MY;
7866 op_null(o->op_next);
7868 ignore_optimization:
7872 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
7874 break; /* Scalar stub must produce undef. List stub is noop */
7878 if (o->op_targ == OP_NEXTSTATE
7879 || o->op_targ == OP_DBSTATE
7880 || o->op_targ == OP_SETSTATE)
7882 PL_curcop = ((COP*)o);
7884 /* XXX: We avoid setting op_seq here to prevent later calls
7885 to peep() from mistakenly concluding that optimisation
7886 has already occurred. This doesn't fix the real problem,
7887 though (See 20010220.007). AMS 20010719 */
7888 /* op_seq functionality is now replaced by op_opt */
7889 if (oldop && o->op_next) {
7890 oldop->op_next = o->op_next;
7898 if (oldop && o->op_next) {
7899 oldop->op_next = o->op_next;
7907 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
7908 OP* const pop = (o->op_type == OP_PADAV) ?
7909 o->op_next : o->op_next->op_next;
7911 if (pop && pop->op_type == OP_CONST &&
7912 ((PL_op = pop->op_next)) &&
7913 pop->op_next->op_type == OP_AELEM &&
7914 !(pop->op_next->op_private &
7915 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
7916 (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
7921 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
7922 no_bareword_allowed(pop);
7923 if (o->op_type == OP_GV)
7924 op_null(o->op_next);
7925 op_null(pop->op_next);
7927 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
7928 o->op_next = pop->op_next->op_next;
7929 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
7930 o->op_private = (U8)i;
7931 if (o->op_type == OP_GV) {
7936 o->op_flags |= OPf_SPECIAL;
7937 o->op_type = OP_AELEMFAST;
7943 if (o->op_next->op_type == OP_RV2SV) {
7944 if (!(o->op_next->op_private & OPpDEREF)) {
7945 op_null(o->op_next);
7946 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
7948 o->op_next = o->op_next->op_next;
7949 o->op_type = OP_GVSV;
7950 o->op_ppaddr = PL_ppaddr[OP_GVSV];
7953 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
7954 GV * const gv = cGVOPo_gv;
7955 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
7956 /* XXX could check prototype here instead of just carping */
7957 SV * const sv = sv_newmortal();
7958 gv_efullname3(sv, gv, NULL);
7959 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
7960 "%"SVf"() called too early to check prototype",
7964 else if (o->op_next->op_type == OP_READLINE
7965 && o->op_next->op_next->op_type == OP_CONCAT
7966 && (o->op_next->op_next->op_flags & OPf_STACKED))
7968 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
7969 o->op_type = OP_RCATLINE;
7970 o->op_flags |= OPf_STACKED;
7971 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
7972 op_null(o->op_next->op_next);
7973 op_null(o->op_next);
7990 while (cLOGOP->op_other->op_type == OP_NULL)
7991 cLOGOP->op_other = cLOGOP->op_other->op_next;
7992 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
7998 while (cLOOP->op_redoop->op_type == OP_NULL)
7999 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
8000 peep(cLOOP->op_redoop);
8001 while (cLOOP->op_nextop->op_type == OP_NULL)
8002 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
8003 peep(cLOOP->op_nextop);
8004 while (cLOOP->op_lastop->op_type == OP_NULL)
8005 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
8006 peep(cLOOP->op_lastop);
8013 while (cPMOP->op_pmreplstart &&
8014 cPMOP->op_pmreplstart->op_type == OP_NULL)
8015 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
8016 peep(cPMOP->op_pmreplstart);
8021 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
8022 && ckWARN(WARN_SYNTAX))
8024 if (o->op_next->op_sibling) {
8025 const OPCODE type = o->op_next->op_sibling->op_type;
8026 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
8027 const line_t oldline = CopLINE(PL_curcop);
8028 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
8029 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8030 "Statement unlikely to be reached");
8031 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8032 "\t(Maybe you meant system() when you said exec()?)\n");
8033 CopLINE_set(PL_curcop, oldline);
8044 const char *key = NULL;
8049 if (((BINOP*)o)->op_last->op_type != OP_CONST)
8052 /* Make the CONST have a shared SV */
8053 svp = cSVOPx_svp(((BINOP*)o)->op_last);
8054 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
8055 key = SvPV_const(sv, keylen);
8056 lexname = newSVpvn_share(key,
8057 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
8063 if ((o->op_private & (OPpLVAL_INTRO)))
8066 rop = (UNOP*)((BINOP*)o)->op_first;
8067 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
8069 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
8070 if (!SvPAD_TYPED(lexname))
8072 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8073 if (!fields || !GvHV(*fields))
8075 key = SvPV_const(*svp, keylen);
8076 if (!hv_fetch(GvHV(*fields), key,
8077 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8079 Perl_croak(aTHX_ "No such class field \"%s\" "
8080 "in variable %s of type %s",
8081 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
8094 SVOP *first_key_op, *key_op;
8096 if ((o->op_private & (OPpLVAL_INTRO))
8097 /* I bet there's always a pushmark... */
8098 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
8099 /* hmmm, no optimization if list contains only one key. */
8101 rop = (UNOP*)((LISTOP*)o)->op_last;
8102 if (rop->op_type != OP_RV2HV)
8104 if (rop->op_first->op_type == OP_PADSV)
8105 /* @$hash{qw(keys here)} */
8106 rop = (UNOP*)rop->op_first;
8108 /* @{$hash}{qw(keys here)} */
8109 if (rop->op_first->op_type == OP_SCOPE
8110 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
8112 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
8118 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
8119 if (!SvPAD_TYPED(lexname))
8121 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8122 if (!fields || !GvHV(*fields))
8124 /* Again guessing that the pushmark can be jumped over.... */
8125 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
8126 ->op_first->op_sibling;
8127 for (key_op = first_key_op; key_op;
8128 key_op = (SVOP*)key_op->op_sibling) {
8129 if (key_op->op_type != OP_CONST)
8131 svp = cSVOPx_svp(key_op);
8132 key = SvPV_const(*svp, keylen);
8133 if (!hv_fetch(GvHV(*fields), key,
8134 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8136 Perl_croak(aTHX_ "No such class field \"%s\" "
8137 "in variable %s of type %s",
8138 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
8145 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
8149 /* check that RHS of sort is a single plain array */
8150 OP *oright = cUNOPo->op_first;
8151 if (!oright || oright->op_type != OP_PUSHMARK)
8154 /* reverse sort ... can be optimised. */
8155 if (!cUNOPo->op_sibling) {
8156 /* Nothing follows us on the list. */
8157 OP * const reverse = o->op_next;
8159 if (reverse->op_type == OP_REVERSE &&
8160 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
8161 OP * const pushmark = cUNOPx(reverse)->op_first;
8162 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
8163 && (cUNOPx(pushmark)->op_sibling == o)) {
8164 /* reverse -> pushmark -> sort */
8165 o->op_private |= OPpSORT_REVERSE;
8167 pushmark->op_next = oright->op_next;
8173 /* make @a = sort @a act in-place */
8177 oright = cUNOPx(oright)->op_sibling;
8180 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
8181 oright = cUNOPx(oright)->op_sibling;
8185 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
8186 || oright->op_next != o
8187 || (oright->op_private & OPpLVAL_INTRO)
8191 /* o2 follows the chain of op_nexts through the LHS of the
8192 * assign (if any) to the aassign op itself */
8194 if (!o2 || o2->op_type != OP_NULL)
8197 if (!o2 || o2->op_type != OP_PUSHMARK)
8200 if (o2 && o2->op_type == OP_GV)
8203 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
8204 || (o2->op_private & OPpLVAL_INTRO)
8209 if (!o2 || o2->op_type != OP_NULL)
8212 if (!o2 || o2->op_type != OP_AASSIGN
8213 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
8216 /* check that the sort is the first arg on RHS of assign */
8218 o2 = cUNOPx(o2)->op_first;
8219 if (!o2 || o2->op_type != OP_NULL)
8221 o2 = cUNOPx(o2)->op_first;
8222 if (!o2 || o2->op_type != OP_PUSHMARK)
8224 if (o2->op_sibling != o)
8227 /* check the array is the same on both sides */
8228 if (oleft->op_type == OP_RV2AV) {
8229 if (oright->op_type != OP_RV2AV
8230 || !cUNOPx(oright)->op_first
8231 || cUNOPx(oright)->op_first->op_type != OP_GV
8232 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
8233 cGVOPx_gv(cUNOPx(oright)->op_first)
8237 else if (oright->op_type != OP_PADAV
8238 || oright->op_targ != oleft->op_targ
8242 /* transfer MODishness etc from LHS arg to RHS arg */
8243 oright->op_flags = oleft->op_flags;
8244 o->op_private |= OPpSORT_INPLACE;
8246 /* excise push->gv->rv2av->null->aassign */
8247 o2 = o->op_next->op_next;
8248 op_null(o2); /* PUSHMARK */
8250 if (o2->op_type == OP_GV) {
8251 op_null(o2); /* GV */
8254 op_null(o2); /* RV2AV or PADAV */
8255 o2 = o2->op_next->op_next;
8256 op_null(o2); /* AASSIGN */
8258 o->op_next = o2->op_next;
8264 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
8266 LISTOP *enter, *exlist;
8269 enter = (LISTOP *) o->op_next;
8272 if (enter->op_type == OP_NULL) {
8273 enter = (LISTOP *) enter->op_next;
8277 /* for $a (...) will have OP_GV then OP_RV2GV here.
8278 for (...) just has an OP_GV. */
8279 if (enter->op_type == OP_GV) {
8280 gvop = (OP *) enter;
8281 enter = (LISTOP *) enter->op_next;
8284 if (enter->op_type == OP_RV2GV) {
8285 enter = (LISTOP *) enter->op_next;
8291 if (enter->op_type != OP_ENTERITER)
8294 iter = enter->op_next;
8295 if (!iter || iter->op_type != OP_ITER)
8298 expushmark = enter->op_first;
8299 if (!expushmark || expushmark->op_type != OP_NULL
8300 || expushmark->op_targ != OP_PUSHMARK)
8303 exlist = (LISTOP *) expushmark->op_sibling;
8304 if (!exlist || exlist->op_type != OP_NULL
8305 || exlist->op_targ != OP_LIST)
8308 if (exlist->op_last != o) {
8309 /* Mmm. Was expecting to point back to this op. */
8312 theirmark = exlist->op_first;
8313 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
8316 if (theirmark->op_sibling != o) {
8317 /* There's something between the mark and the reverse, eg
8318 for (1, reverse (...))
8323 ourmark = ((LISTOP *)o)->op_first;
8324 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
8327 ourlast = ((LISTOP *)o)->op_last;
8328 if (!ourlast || ourlast->op_next != o)
8331 rv2av = ourmark->op_sibling;
8332 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
8333 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
8334 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
8335 /* We're just reversing a single array. */
8336 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
8337 enter->op_flags |= OPf_STACKED;
8340 /* We don't have control over who points to theirmark, so sacrifice
8342 theirmark->op_next = ourmark->op_next;
8343 theirmark->op_flags = ourmark->op_flags;
8344 ourlast->op_next = gvop ? gvop : (OP *) enter;
8347 enter->op_private |= OPpITER_REVERSED;
8348 iter->op_private |= OPpITER_REVERSED;
8355 UNOP *refgen, *rv2cv;
8358 /* I do not understand this, but if o->op_opt isn't set to 1,
8359 various tests in ext/B/t/bytecode.t fail with no readily
8365 if ((o->op_flags && OPf_WANT) != OPf_WANT_VOID)
8368 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
8371 rv2gv = ((BINOP *)o)->op_last;
8372 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
8375 refgen = (UNOP *)((BINOP *)o)->op_first;
8377 if (!refgen || refgen->op_type != OP_REFGEN)
8380 exlist = (LISTOP *)refgen->op_first;
8381 if (!exlist || exlist->op_type != OP_NULL
8382 || exlist->op_targ != OP_LIST)
8385 if (exlist->op_first->op_type != OP_PUSHMARK)
8388 rv2cv = (UNOP*)exlist->op_last;
8390 if (rv2cv->op_type != OP_RV2CV)
8393 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
8394 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
8395 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
8397 o->op_private |= OPpASSIGN_CV_TO_GV;
8398 rv2gv->op_private |= OPpDONT_INIT_GV;
8399 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
8415 Perl_custom_op_name(pTHX_ const OP* o)
8418 const IV index = PTR2IV(o->op_ppaddr);
8422 if (!PL_custom_op_names) /* This probably shouldn't happen */
8423 return (char *)PL_op_name[OP_CUSTOM];
8425 keysv = sv_2mortal(newSViv(index));
8427 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
8429 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
8431 return SvPV_nolen(HeVAL(he));
8435 Perl_custom_op_desc(pTHX_ const OP* o)
8438 const IV index = PTR2IV(o->op_ppaddr);
8442 if (!PL_custom_op_descs)
8443 return (char *)PL_op_desc[OP_CUSTOM];
8445 keysv = sv_2mortal(newSViv(index));
8447 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
8449 return (char *)PL_op_desc[OP_CUSTOM];
8451 return SvPV_nolen(HeVAL(he));
8456 /* Efficient sub that returns a constant scalar value. */
8458 const_sv_xsub(pTHX_ CV* cv)
8465 Perl_croak(aTHX_ "usage: %s::%s()",
8466 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
8470 ST(0) = (SV*)XSANY.any_ptr;
8476 * c-indentation-style: bsd
8478 * indent-tabs-mode: t
8481 * ex: set ts=8 sts=4 sw=4 noet: