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);
432 /* Need to find and remove any pattern match ops from the list
433 we maintain for reset(). */
434 find_and_forget_pmops(o);
444 if (o->op_flags & OPf_KIDS) {
445 register OP *kid, *nextkid;
446 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
447 nextkid = kid->op_sibling; /* Get before next freeing kid */
452 type = (OPCODE)o->op_targ;
454 /* COP* is not cleared by op_clear() so that we may track line
455 * numbers etc even after null() */
456 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE) {
457 #ifdef PERL_DEBUG_READONLY_OPS
464 if (o->op_latefree) {
470 #ifdef DEBUG_LEAKING_SCALARS
477 Perl_op_clear(pTHX_ OP *o)
482 /* if (o->op_madprop && o->op_madprop->mad_next)
484 /* FIXME for MAD - if I uncomment these two lines t/op/pack.t fails with
485 "modification of a read only value" for a reason I can't fathom why.
486 It's the "" stringification of $_, where $_ was set to '' in a foreach
487 loop, but it defies simplification into a small test case.
488 However, commenting them out has caused ext/List/Util/t/weak.t to fail
491 mad_free(o->op_madprop);
497 switch (o->op_type) {
498 case OP_NULL: /* Was holding old type, if any. */
499 if (PL_madskills && o->op_targ != OP_NULL) {
500 o->op_type = o->op_targ;
504 case OP_ENTEREVAL: /* Was holding hints. */
508 if (!(o->op_flags & OPf_REF)
509 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
515 if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
516 /* not an OP_PADAV replacement */
518 if (cPADOPo->op_padix > 0) {
519 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
520 * may still exist on the pad */
521 pad_swipe(cPADOPo->op_padix, TRUE);
522 cPADOPo->op_padix = 0;
525 SvREFCNT_dec(cSVOPo->op_sv);
526 cSVOPo->op_sv = NULL;
530 case OP_METHOD_NAMED:
532 SvREFCNT_dec(cSVOPo->op_sv);
533 cSVOPo->op_sv = NULL;
536 Even if op_clear does a pad_free for the target of the op,
537 pad_free doesn't actually remove the sv that exists in the pad;
538 instead it lives on. This results in that it could be reused as
539 a target later on when the pad was reallocated.
542 pad_swipe(o->op_targ,1);
551 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
555 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
557 if (cPADOPo->op_padix > 0) {
558 pad_swipe(cPADOPo->op_padix, TRUE);
559 cPADOPo->op_padix = 0;
562 SvREFCNT_dec(cSVOPo->op_sv);
563 cSVOPo->op_sv = NULL;
567 PerlMemShared_free(cPVOPo->op_pv);
568 cPVOPo->op_pv = NULL;
572 op_free(cPMOPo->op_pmreplroot);
576 if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) {
577 /* No GvIN_PAD_off here, because other references may still
578 * exist on the pad */
579 pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot), TRUE);
582 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
588 forget_pmop(cPMOPo, 1);
589 cPMOPo->op_pmreplroot = NULL;
590 /* we use the "SAFE" version of the PM_ macros here
591 * since sv_clean_all might release some PMOPs
592 * after PL_regex_padav has been cleared
593 * and the clearing of PL_regex_padav needs to
594 * happen before sv_clean_all
596 ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
597 PM_SETRE_SAFE(cPMOPo, NULL);
599 if(PL_regex_pad) { /* We could be in destruction */
600 av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
601 SvREADONLY_off(PL_regex_pad[(cPMOPo)->op_pmoffset]);
602 SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
603 PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
610 if (o->op_targ > 0) {
611 pad_free(o->op_targ);
617 S_cop_free(pTHX_ COP* cop)
622 if (! specialWARN(cop->cop_warnings))
623 PerlMemShared_free(cop->cop_warnings);
624 Perl_refcounted_he_free(aTHX_ cop->cop_hints_hash);
628 S_forget_pmop(pTHX_ PMOP *const o, U32 flags)
630 HV * const pmstash = PmopSTASH(o);
631 if (pmstash && !SvIS_FREED(pmstash)) {
632 MAGIC * const mg = mg_find((SV*)pmstash, PERL_MAGIC_symtab);
634 PMOP **const array = (PMOP**) mg->mg_ptr;
635 U32 count = mg->mg_len / sizeof(PMOP**);
640 /* Found it. Move the entry at the end to overwrite it. */
641 array[i] = array[--count];
642 mg->mg_len = count * sizeof(PMOP**);
643 /* Could realloc smaller at this point always, but probably
644 not worth it. Probably worth free()ing if we're the
647 Safefree(mg->mg_ptr);
660 S_find_and_forget_pmops(pTHX_ OP *o)
662 if (o->op_flags & OPf_KIDS) {
663 OP *kid = cUNOPo->op_first;
665 switch (kid->op_type) {
670 forget_pmop((PMOP*)kid, 0);
672 find_and_forget_pmops(kid);
673 kid = kid->op_sibling;
679 Perl_op_null(pTHX_ OP *o)
682 if (o->op_type == OP_NULL)
686 o->op_targ = o->op_type;
687 o->op_type = OP_NULL;
688 o->op_ppaddr = PL_ppaddr[OP_NULL];
692 Perl_op_refcnt_lock(pTHX)
700 Perl_op_refcnt_unlock(pTHX)
707 /* Contextualizers */
709 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
712 Perl_linklist(pTHX_ OP *o)
719 /* establish postfix order */
720 first = cUNOPo->op_first;
723 o->op_next = LINKLIST(first);
726 if (kid->op_sibling) {
727 kid->op_next = LINKLIST(kid->op_sibling);
728 kid = kid->op_sibling;
742 Perl_scalarkids(pTHX_ OP *o)
744 if (o && o->op_flags & OPf_KIDS) {
746 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
753 S_scalarboolean(pTHX_ OP *o)
756 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
757 if (ckWARN(WARN_SYNTAX)) {
758 const line_t oldline = CopLINE(PL_curcop);
760 if (PL_copline != NOLINE)
761 CopLINE_set(PL_curcop, PL_copline);
762 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
763 CopLINE_set(PL_curcop, oldline);
770 Perl_scalar(pTHX_ OP *o)
775 /* assumes no premature commitment */
776 if (!o || PL_error_count || (o->op_flags & OPf_WANT)
777 || o->op_type == OP_RETURN)
782 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
784 switch (o->op_type) {
786 scalar(cBINOPo->op_first);
791 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
795 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
796 if (!kPMOP->op_pmreplroot)
797 deprecate_old("implicit split to @_");
805 if (o->op_flags & OPf_KIDS) {
806 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
812 kid = cLISTOPo->op_first;
814 while ((kid = kid->op_sibling)) {
820 PL_curcop = &PL_compiling;
825 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
831 PL_curcop = &PL_compiling;
834 if (ckWARN(WARN_VOID))
835 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
841 Perl_scalarvoid(pTHX_ OP *o)
845 const char* useless = NULL;
849 /* trailing mad null ops don't count as "there" for void processing */
851 o->op_type != OP_NULL &&
853 o->op_sibling->op_type == OP_NULL)
856 for (sib = o->op_sibling;
857 sib && sib->op_type == OP_NULL;
858 sib = sib->op_sibling) ;
864 if (o->op_type == OP_NEXTSTATE
865 || o->op_type == OP_SETSTATE
866 || o->op_type == OP_DBSTATE
867 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
868 || o->op_targ == OP_SETSTATE
869 || o->op_targ == OP_DBSTATE)))
870 PL_curcop = (COP*)o; /* for warning below */
872 /* assumes no premature commitment */
873 want = o->op_flags & OPf_WANT;
874 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
875 || o->op_type == OP_RETURN)
880 if ((o->op_private & OPpTARGET_MY)
881 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
883 return scalar(o); /* As if inside SASSIGN */
886 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
888 switch (o->op_type) {
890 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
894 if (o->op_flags & OPf_STACKED)
898 if (o->op_private == 4)
970 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
971 useless = OP_DESC(o);
975 kid = cUNOPo->op_first;
976 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
977 kid->op_type != OP_TRANS) {
980 useless = "negative pattern binding (!~)";
987 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
988 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
989 useless = "a variable";
994 if (cSVOPo->op_private & OPpCONST_STRICT)
995 no_bareword_allowed(o);
997 if (ckWARN(WARN_VOID)) {
998 useless = "a constant";
999 if (o->op_private & OPpCONST_ARYBASE)
1001 /* don't warn on optimised away booleans, eg
1002 * use constant Foo, 5; Foo || print; */
1003 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1005 /* the constants 0 and 1 are permitted as they are
1006 conventionally used as dummies in constructs like
1007 1 while some_condition_with_side_effects; */
1008 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1010 else if (SvPOK(sv)) {
1011 /* perl4's way of mixing documentation and code
1012 (before the invention of POD) was based on a
1013 trick to mix nroff and perl code. The trick was
1014 built upon these three nroff macros being used in
1015 void context. The pink camel has the details in
1016 the script wrapman near page 319. */
1017 const char * const maybe_macro = SvPVX_const(sv);
1018 if (strnEQ(maybe_macro, "di", 2) ||
1019 strnEQ(maybe_macro, "ds", 2) ||
1020 strnEQ(maybe_macro, "ig", 2))
1025 op_null(o); /* don't execute or even remember it */
1029 o->op_type = OP_PREINC; /* pre-increment is faster */
1030 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1034 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1035 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1039 o->op_type = OP_I_PREINC; /* pre-increment is faster */
1040 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1044 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
1045 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1054 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1059 if (o->op_flags & OPf_STACKED)
1066 if (!(o->op_flags & OPf_KIDS))
1077 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1084 /* all requires must return a boolean value */
1085 o->op_flags &= ~OPf_WANT;
1090 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
1091 if (!kPMOP->op_pmreplroot)
1092 deprecate_old("implicit split to @_");
1096 if (useless && ckWARN(WARN_VOID))
1097 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
1102 Perl_listkids(pTHX_ OP *o)
1104 if (o && o->op_flags & OPf_KIDS) {
1106 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1113 Perl_list(pTHX_ OP *o)
1118 /* assumes no premature commitment */
1119 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
1120 || o->op_type == OP_RETURN)
1125 if ((o->op_private & OPpTARGET_MY)
1126 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1128 return o; /* As if inside SASSIGN */
1131 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1133 switch (o->op_type) {
1136 list(cBINOPo->op_first);
1141 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1149 if (!(o->op_flags & OPf_KIDS))
1151 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1152 list(cBINOPo->op_first);
1153 return gen_constant_list(o);
1160 kid = cLISTOPo->op_first;
1162 while ((kid = kid->op_sibling)) {
1163 if (kid->op_sibling)
1168 PL_curcop = &PL_compiling;
1172 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1173 if (kid->op_sibling)
1178 PL_curcop = &PL_compiling;
1181 /* all requires must return a boolean value */
1182 o->op_flags &= ~OPf_WANT;
1189 Perl_scalarseq(pTHX_ OP *o)
1193 const OPCODE type = o->op_type;
1195 if (type == OP_LINESEQ || type == OP_SCOPE ||
1196 type == OP_LEAVE || type == OP_LEAVETRY)
1199 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1200 if (kid->op_sibling) {
1204 PL_curcop = &PL_compiling;
1206 o->op_flags &= ~OPf_PARENS;
1207 if (PL_hints & HINT_BLOCK_SCOPE)
1208 o->op_flags |= OPf_PARENS;
1211 o = newOP(OP_STUB, 0);
1216 S_modkids(pTHX_ OP *o, I32 type)
1218 if (o && o->op_flags & OPf_KIDS) {
1220 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1226 /* Propagate lvalue ("modifiable") context to an op and its children.
1227 * 'type' represents the context type, roughly based on the type of op that
1228 * would do the modifying, although local() is represented by OP_NULL.
1229 * It's responsible for detecting things that can't be modified, flag
1230 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
1231 * might have to vivify a reference in $x), and so on.
1233 * For example, "$a+1 = 2" would cause mod() to be called with o being
1234 * OP_ADD and type being OP_SASSIGN, and would output an error.
1238 Perl_mod(pTHX_ OP *o, I32 type)
1242 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1245 if (!o || PL_error_count)
1248 if ((o->op_private & OPpTARGET_MY)
1249 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1254 switch (o->op_type) {
1260 if (!(o->op_private & OPpCONST_ARYBASE))
1263 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1264 CopARYBASE_set(&PL_compiling,
1265 (I32)SvIV(cSVOPx(PL_eval_start)->op_sv));
1269 SAVECOPARYBASE(&PL_compiling);
1270 CopARYBASE_set(&PL_compiling, 0);
1272 else if (type == OP_REFGEN)
1275 Perl_croak(aTHX_ "That use of $[ is unsupported");
1278 if (o->op_flags & OPf_PARENS || PL_madskills)
1282 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1283 !(o->op_flags & OPf_STACKED)) {
1284 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1285 /* The default is to set op_private to the number of children,
1286 which for a UNOP such as RV2CV is always 1. And w're using
1287 the bit for a flag in RV2CV, so we need it clear. */
1288 o->op_private &= ~1;
1289 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1290 assert(cUNOPo->op_first->op_type == OP_NULL);
1291 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1294 else if (o->op_private & OPpENTERSUB_NOMOD)
1296 else { /* lvalue subroutine call */
1297 o->op_private |= OPpLVAL_INTRO;
1298 PL_modcount = RETURN_UNLIMITED_NUMBER;
1299 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1300 /* Backward compatibility mode: */
1301 o->op_private |= OPpENTERSUB_INARGS;
1304 else { /* Compile-time error message: */
1305 OP *kid = cUNOPo->op_first;
1309 if (kid->op_type != OP_PUSHMARK) {
1310 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1312 "panic: unexpected lvalue entersub "
1313 "args: type/targ %ld:%"UVuf,
1314 (long)kid->op_type, (UV)kid->op_targ);
1315 kid = kLISTOP->op_first;
1317 while (kid->op_sibling)
1318 kid = kid->op_sibling;
1319 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1321 if (kid->op_type == OP_METHOD_NAMED
1322 || kid->op_type == OP_METHOD)
1326 NewOp(1101, newop, 1, UNOP);
1327 newop->op_type = OP_RV2CV;
1328 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1329 newop->op_first = NULL;
1330 newop->op_next = (OP*)newop;
1331 kid->op_sibling = (OP*)newop;
1332 newop->op_private |= OPpLVAL_INTRO;
1333 newop->op_private &= ~1;
1337 if (kid->op_type != OP_RV2CV)
1339 "panic: unexpected lvalue entersub "
1340 "entry via type/targ %ld:%"UVuf,
1341 (long)kid->op_type, (UV)kid->op_targ);
1342 kid->op_private |= OPpLVAL_INTRO;
1343 break; /* Postpone until runtime */
1347 kid = kUNOP->op_first;
1348 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1349 kid = kUNOP->op_first;
1350 if (kid->op_type == OP_NULL)
1352 "Unexpected constant lvalue entersub "
1353 "entry via type/targ %ld:%"UVuf,
1354 (long)kid->op_type, (UV)kid->op_targ);
1355 if (kid->op_type != OP_GV) {
1356 /* Restore RV2CV to check lvalueness */
1358 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1359 okid->op_next = kid->op_next;
1360 kid->op_next = okid;
1363 okid->op_next = NULL;
1364 okid->op_type = OP_RV2CV;
1366 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1367 okid->op_private |= OPpLVAL_INTRO;
1368 okid->op_private &= ~1;
1372 cv = GvCV(kGVOP_gv);
1382 /* grep, foreach, subcalls, refgen */
1383 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1385 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1386 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1388 : (o->op_type == OP_ENTERSUB
1389 ? "non-lvalue subroutine call"
1391 type ? PL_op_desc[type] : "local"));
1405 case OP_RIGHT_SHIFT:
1414 if (!(o->op_flags & OPf_STACKED))
1421 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1427 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1428 PL_modcount = RETURN_UNLIMITED_NUMBER;
1429 return o; /* Treat \(@foo) like ordinary list. */
1433 if (scalar_mod_type(o, type))
1435 ref(cUNOPo->op_first, o->op_type);
1439 if (type == OP_LEAVESUBLV)
1440 o->op_private |= OPpMAYBE_LVSUB;
1446 PL_modcount = RETURN_UNLIMITED_NUMBER;
1449 ref(cUNOPo->op_first, o->op_type);
1454 PL_hints |= HINT_BLOCK_SCOPE;
1469 PL_modcount = RETURN_UNLIMITED_NUMBER;
1470 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1471 return o; /* Treat \(@foo) like ordinary list. */
1472 if (scalar_mod_type(o, type))
1474 if (type == OP_LEAVESUBLV)
1475 o->op_private |= OPpMAYBE_LVSUB;
1479 if (!type) /* local() */
1480 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1481 PAD_COMPNAME_PV(o->op_targ));
1489 if (type != OP_SASSIGN)
1493 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1498 if (type == OP_LEAVESUBLV)
1499 o->op_private |= OPpMAYBE_LVSUB;
1501 pad_free(o->op_targ);
1502 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1503 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1504 if (o->op_flags & OPf_KIDS)
1505 mod(cBINOPo->op_first->op_sibling, type);
1510 ref(cBINOPo->op_first, o->op_type);
1511 if (type == OP_ENTERSUB &&
1512 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1513 o->op_private |= OPpLVAL_DEFER;
1514 if (type == OP_LEAVESUBLV)
1515 o->op_private |= OPpMAYBE_LVSUB;
1525 if (o->op_flags & OPf_KIDS)
1526 mod(cLISTOPo->op_last, type);
1531 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1533 else if (!(o->op_flags & OPf_KIDS))
1535 if (o->op_targ != OP_LIST) {
1536 mod(cBINOPo->op_first, type);
1542 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1547 if (type != OP_LEAVESUBLV)
1549 break; /* mod()ing was handled by ck_return() */
1552 /* [20011101.069] File test operators interpret OPf_REF to mean that
1553 their argument is a filehandle; thus \stat(".") should not set
1555 if (type == OP_REFGEN &&
1556 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1559 if (type != OP_LEAVESUBLV)
1560 o->op_flags |= OPf_MOD;
1562 if (type == OP_AASSIGN || type == OP_SASSIGN)
1563 o->op_flags |= OPf_SPECIAL|OPf_REF;
1564 else if (!type) { /* local() */
1567 o->op_private |= OPpLVAL_INTRO;
1568 o->op_flags &= ~OPf_SPECIAL;
1569 PL_hints |= HINT_BLOCK_SCOPE;
1574 if (ckWARN(WARN_SYNTAX)) {
1575 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1576 "Useless localization of %s", OP_DESC(o));
1580 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1581 && type != OP_LEAVESUBLV)
1582 o->op_flags |= OPf_REF;
1587 S_scalar_mod_type(const OP *o, I32 type)
1591 if (o->op_type == OP_RV2GV)
1615 case OP_RIGHT_SHIFT:
1634 S_is_handle_constructor(const OP *o, I32 numargs)
1636 switch (o->op_type) {
1644 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1657 Perl_refkids(pTHX_ OP *o, I32 type)
1659 if (o && o->op_flags & OPf_KIDS) {
1661 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1668 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
1673 if (!o || PL_error_count)
1676 switch (o->op_type) {
1678 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1679 !(o->op_flags & OPf_STACKED)) {
1680 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1681 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1682 assert(cUNOPo->op_first->op_type == OP_NULL);
1683 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1684 o->op_flags |= OPf_SPECIAL;
1685 o->op_private &= ~1;
1690 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1691 doref(kid, type, set_op_ref);
1694 if (type == OP_DEFINED)
1695 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1696 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1699 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1700 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1701 : type == OP_RV2HV ? OPpDEREF_HV
1703 o->op_flags |= OPf_MOD;
1710 o->op_flags |= OPf_REF;
1713 if (type == OP_DEFINED)
1714 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1715 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1721 o->op_flags |= OPf_REF;
1726 if (!(o->op_flags & OPf_KIDS))
1728 doref(cBINOPo->op_first, type, set_op_ref);
1732 doref(cBINOPo->op_first, o->op_type, set_op_ref);
1733 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1734 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1735 : type == OP_RV2HV ? OPpDEREF_HV
1737 o->op_flags |= OPf_MOD;
1747 if (!(o->op_flags & OPf_KIDS))
1749 doref(cLISTOPo->op_last, type, set_op_ref);
1759 S_dup_attrlist(pTHX_ OP *o)
1764 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1765 * where the first kid is OP_PUSHMARK and the remaining ones
1766 * are OP_CONST. We need to push the OP_CONST values.
1768 if (o->op_type == OP_CONST)
1769 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
1771 else if (o->op_type == OP_NULL)
1775 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1777 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1778 if (o->op_type == OP_CONST)
1779 rop = append_elem(OP_LIST, rop,
1780 newSVOP(OP_CONST, o->op_flags,
1781 SvREFCNT_inc_NN(cSVOPo->op_sv)));
1788 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1793 /* fake up C<use attributes $pkg,$rv,@attrs> */
1794 ENTER; /* need to protect against side-effects of 'use' */
1796 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1798 #define ATTRSMODULE "attributes"
1799 #define ATTRSMODULE_PM "attributes.pm"
1802 /* Don't force the C<use> if we don't need it. */
1803 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
1804 if (svp && *svp != &PL_sv_undef)
1805 NOOP; /* already in %INC */
1807 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1808 newSVpvs(ATTRSMODULE), NULL);
1811 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1812 newSVpvs(ATTRSMODULE),
1814 prepend_elem(OP_LIST,
1815 newSVOP(OP_CONST, 0, stashsv),
1816 prepend_elem(OP_LIST,
1817 newSVOP(OP_CONST, 0,
1819 dup_attrlist(attrs))));
1825 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1828 OP *pack, *imop, *arg;
1834 assert(target->op_type == OP_PADSV ||
1835 target->op_type == OP_PADHV ||
1836 target->op_type == OP_PADAV);
1838 /* Ensure that attributes.pm is loaded. */
1839 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1841 /* Need package name for method call. */
1842 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
1844 /* Build up the real arg-list. */
1845 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1847 arg = newOP(OP_PADSV, 0);
1848 arg->op_targ = target->op_targ;
1849 arg = prepend_elem(OP_LIST,
1850 newSVOP(OP_CONST, 0, stashsv),
1851 prepend_elem(OP_LIST,
1852 newUNOP(OP_REFGEN, 0,
1853 mod(arg, OP_REFGEN)),
1854 dup_attrlist(attrs)));
1856 /* Fake up a method call to import */
1857 meth = newSVpvs_share("import");
1858 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1859 append_elem(OP_LIST,
1860 prepend_elem(OP_LIST, pack, list(arg)),
1861 newSVOP(OP_METHOD_NAMED, 0, meth)));
1862 imop->op_private |= OPpENTERSUB_NOMOD;
1864 /* Combine the ops. */
1865 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1869 =notfor apidoc apply_attrs_string
1871 Attempts to apply a list of attributes specified by the C<attrstr> and
1872 C<len> arguments to the subroutine identified by the C<cv> argument which
1873 is expected to be associated with the package identified by the C<stashpv>
1874 argument (see L<attributes>). It gets this wrong, though, in that it
1875 does not correctly identify the boundaries of the individual attribute
1876 specifications within C<attrstr>. This is not really intended for the
1877 public API, but has to be listed here for systems such as AIX which
1878 need an explicit export list for symbols. (It's called from XS code
1879 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1880 to respect attribute syntax properly would be welcome.
1886 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
1887 const char *attrstr, STRLEN len)
1892 len = strlen(attrstr);
1896 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1898 const char * const sstr = attrstr;
1899 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1900 attrs = append_elem(OP_LIST, attrs,
1901 newSVOP(OP_CONST, 0,
1902 newSVpvn(sstr, attrstr-sstr)));
1906 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1907 newSVpvs(ATTRSMODULE),
1908 NULL, prepend_elem(OP_LIST,
1909 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1910 prepend_elem(OP_LIST,
1911 newSVOP(OP_CONST, 0,
1917 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
1922 if (!o || PL_error_count)
1926 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
1927 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
1931 if (type == OP_LIST) {
1933 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1934 my_kid(kid, attrs, imopsp);
1935 } else if (type == OP_UNDEF
1941 } else if (type == OP_RV2SV || /* "our" declaration */
1943 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1944 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1945 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1947 PL_in_my == KEY_our ? "our" : PL_in_my == KEY_state ? "state" : "my"));
1949 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
1951 PL_in_my_stash = NULL;
1952 apply_attrs(GvSTASH(gv),
1953 (type == OP_RV2SV ? GvSV(gv) :
1954 type == OP_RV2AV ? (SV*)GvAV(gv) :
1955 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1958 o->op_private |= OPpOUR_INTRO;
1961 else if (type != OP_PADSV &&
1964 type != OP_PUSHMARK)
1966 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1968 PL_in_my == KEY_our ? "our" : PL_in_my == KEY_state ? "state" : "my"));
1971 else if (attrs && type != OP_PUSHMARK) {
1975 PL_in_my_stash = NULL;
1977 /* check for C<my Dog $spot> when deciding package */
1978 stash = PAD_COMPNAME_TYPE(o->op_targ);
1980 stash = PL_curstash;
1981 apply_attrs_my(stash, o, attrs, imopsp);
1983 o->op_flags |= OPf_MOD;
1984 o->op_private |= OPpLVAL_INTRO;
1985 if (PL_in_my == KEY_state)
1986 o->op_private |= OPpPAD_STATE;
1991 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1995 int maybe_scalar = 0;
1997 /* [perl #17376]: this appears to be premature, and results in code such as
1998 C< our(%x); > executing in list mode rather than void mode */
2000 if (o->op_flags & OPf_PARENS)
2010 o = my_kid(o, attrs, &rops);
2012 if (maybe_scalar && o->op_type == OP_PADSV) {
2013 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
2014 o->op_private |= OPpLVAL_INTRO;
2017 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
2020 PL_in_my_stash = NULL;
2025 Perl_my(pTHX_ OP *o)
2027 return my_attrs(o, NULL);
2031 Perl_sawparens(pTHX_ OP *o)
2033 PERL_UNUSED_CONTEXT;
2035 o->op_flags |= OPf_PARENS;
2040 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2044 const OPCODE ltype = left->op_type;
2045 const OPCODE rtype = right->op_type;
2047 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2048 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
2050 const char * const desc
2051 = PL_op_desc[(rtype == OP_SUBST || rtype == OP_TRANS)
2052 ? (int)rtype : OP_MATCH];
2053 const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV)
2054 ? "@array" : "%hash");
2055 Perl_warner(aTHX_ packWARN(WARN_MISC),
2056 "Applying %s to %s will act on scalar(%s)",
2057 desc, sample, sample);
2060 if (rtype == OP_CONST &&
2061 cSVOPx(right)->op_private & OPpCONST_BARE &&
2062 cSVOPx(right)->op_private & OPpCONST_STRICT)
2064 no_bareword_allowed(right);
2067 ismatchop = rtype == OP_MATCH ||
2068 rtype == OP_SUBST ||
2070 if (ismatchop && right->op_private & OPpTARGET_MY) {
2072 right->op_private &= ~OPpTARGET_MY;
2074 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
2077 right->op_flags |= OPf_STACKED;
2078 if (rtype != OP_MATCH &&
2079 ! (rtype == OP_TRANS &&
2080 right->op_private & OPpTRANS_IDENTICAL))
2081 newleft = mod(left, rtype);
2084 if (right->op_type == OP_TRANS)
2085 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
2087 o = prepend_elem(rtype, scalar(newleft), right);
2089 return newUNOP(OP_NOT, 0, scalar(o));
2093 return bind_match(type, left,
2094 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
2098 Perl_invert(pTHX_ OP *o)
2102 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2106 Perl_scope(pTHX_ OP *o)
2110 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2111 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2112 o->op_type = OP_LEAVE;
2113 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2115 else if (o->op_type == OP_LINESEQ) {
2117 o->op_type = OP_SCOPE;
2118 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2119 kid = ((LISTOP*)o)->op_first;
2120 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2123 /* The following deals with things like 'do {1 for 1}' */
2124 kid = kid->op_sibling;
2126 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2131 o = newLISTOP(OP_SCOPE, 0, o, NULL);
2137 Perl_block_start(pTHX_ int full)
2140 const int retval = PL_savestack_ix;
2141 pad_block_start(full);
2143 PL_hints &= ~HINT_BLOCK_SCOPE;
2144 SAVECOMPILEWARNINGS();
2145 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
2150 Perl_block_end(pTHX_ I32 floor, OP *seq)
2153 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2154 OP* const retval = scalarseq(seq);
2156 CopHINTS_set(&PL_compiling, PL_hints);
2158 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2167 const PADOFFSET offset = pad_findmy("$_");
2168 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
2169 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2172 OP * const o = newOP(OP_PADSV, 0);
2173 o->op_targ = offset;
2179 Perl_newPROG(pTHX_ OP *o)
2185 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2186 ((PL_in_eval & EVAL_KEEPERR)
2187 ? OPf_SPECIAL : 0), o);
2188 PL_eval_start = linklist(PL_eval_root);
2189 PL_eval_root->op_private |= OPpREFCOUNTED;
2190 OpREFCNT_set(PL_eval_root, 1);
2191 PL_eval_root->op_next = 0;
2192 CALL_PEEP(PL_eval_start);
2195 if (o->op_type == OP_STUB) {
2196 PL_comppad_name = 0;
2198 S_op_destroy(aTHX_ o);
2201 PL_main_root = scope(sawparens(scalarvoid(o)));
2202 PL_curcop = &PL_compiling;
2203 PL_main_start = LINKLIST(PL_main_root);
2204 PL_main_root->op_private |= OPpREFCOUNTED;
2205 OpREFCNT_set(PL_main_root, 1);
2206 PL_main_root->op_next = 0;
2207 CALL_PEEP(PL_main_start);
2210 /* Register with debugger */
2213 = Perl_get_cvn_flags(aTHX_ STR_WITH_LEN("DB::postponed"), 0);
2217 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2219 call_sv((SV*)cv, G_DISCARD);
2226 Perl_localize(pTHX_ OP *o, I32 lex)
2229 if (o->op_flags & OPf_PARENS)
2230 /* [perl #17376]: this appears to be premature, and results in code such as
2231 C< our(%x); > executing in list mode rather than void mode */
2238 if ( PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ','
2239 && ckWARN(WARN_PARENTHESIS))
2241 char *s = PL_bufptr;
2244 /* some heuristics to detect a potential error */
2245 while (*s && (strchr(", \t\n", *s)))
2249 if (*s && strchr("@$%*", *s) && *++s
2250 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2253 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2255 while (*s && (strchr(", \t\n", *s)))
2261 if (sigil && (*s == ';' || *s == '=')) {
2262 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2263 "Parentheses missing around \"%s\" list",
2264 lex ? (PL_in_my == KEY_our ? "our" : PL_in_my == KEY_state ? "state" : "my")
2272 o = mod(o, OP_NULL); /* a bit kludgey */
2274 PL_in_my_stash = NULL;
2279 Perl_jmaybe(pTHX_ OP *o)
2281 if (o->op_type == OP_LIST) {
2283 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2284 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2290 Perl_fold_constants(pTHX_ register OP *o)
2295 VOL I32 type = o->op_type;
2300 SV * const oldwarnhook = PL_warnhook;
2301 SV * const olddiehook = PL_diehook;
2304 if (PL_opargs[type] & OA_RETSCALAR)
2306 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2307 o->op_targ = pad_alloc(type, SVs_PADTMP);
2309 /* integerize op, unless it happens to be C<-foo>.
2310 * XXX should pp_i_negate() do magic string negation instead? */
2311 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2312 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2313 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2315 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2318 if (!(PL_opargs[type] & OA_FOLDCONST))
2323 /* XXX might want a ck_negate() for this */
2324 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2335 /* XXX what about the numeric ops? */
2336 if (PL_hints & HINT_LOCALE)
2341 goto nope; /* Don't try to run w/ errors */
2343 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2344 const OPCODE type = curop->op_type;
2345 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2347 type != OP_SCALAR &&
2349 type != OP_PUSHMARK)
2355 curop = LINKLIST(o);
2356 old_next = o->op_next;
2360 oldscope = PL_scopestack_ix;
2361 create_eval_scope(G_FAKINGEVAL);
2363 PL_warnhook = PERL_WARNHOOK_FATAL;
2370 sv = *(PL_stack_sp--);
2371 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2372 pad_swipe(o->op_targ, FALSE);
2373 else if (SvTEMP(sv)) { /* grab mortal temp? */
2374 SvREFCNT_inc_simple_void(sv);
2379 /* Something tried to die. Abandon constant folding. */
2380 /* Pretend the error never happened. */
2381 sv_setpvn(ERRSV,"",0);
2382 o->op_next = old_next;
2386 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
2387 PL_warnhook = oldwarnhook;
2388 PL_diehook = olddiehook;
2389 /* XXX note that this croak may fail as we've already blown away
2390 * the stack - eg any nested evals */
2391 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
2394 PL_warnhook = oldwarnhook;
2395 PL_diehook = olddiehook;
2397 if (PL_scopestack_ix > oldscope)
2398 delete_eval_scope();
2407 if (type == OP_RV2GV)
2408 newop = newGVOP(OP_GV, 0, (GV*)sv);
2410 newop = newSVOP(OP_CONST, 0, (SV*)sv);
2411 op_getmad(o,newop,'f');
2419 Perl_gen_constant_list(pTHX_ register OP *o)
2423 const I32 oldtmps_floor = PL_tmps_floor;
2427 return o; /* Don't attempt to run with errors */
2429 PL_op = curop = LINKLIST(o);
2435 assert (!(curop->op_flags & OPf_SPECIAL));
2436 assert(curop->op_type == OP_RANGE);
2438 PL_tmps_floor = oldtmps_floor;
2440 o->op_type = OP_RV2AV;
2441 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2442 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2443 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2444 o->op_opt = 0; /* needs to be revisited in peep() */
2445 curop = ((UNOP*)o)->op_first;
2446 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
2448 op_getmad(curop,o,'O');
2457 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2460 if (!o || o->op_type != OP_LIST)
2461 o = newLISTOP(OP_LIST, 0, o, NULL);
2463 o->op_flags &= ~OPf_WANT;
2465 if (!(PL_opargs[type] & OA_MARK))
2466 op_null(cLISTOPo->op_first);
2468 o->op_type = (OPCODE)type;
2469 o->op_ppaddr = PL_ppaddr[type];
2470 o->op_flags |= flags;
2472 o = CHECKOP(type, o);
2473 if (o->op_type != (unsigned)type)
2476 return fold_constants(o);
2479 /* List constructors */
2482 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2490 if (first->op_type != (unsigned)type
2491 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2493 return newLISTOP(type, 0, first, last);
2496 if (first->op_flags & OPf_KIDS)
2497 ((LISTOP*)first)->op_last->op_sibling = last;
2499 first->op_flags |= OPf_KIDS;
2500 ((LISTOP*)first)->op_first = last;
2502 ((LISTOP*)first)->op_last = last;
2507 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2515 if (first->op_type != (unsigned)type)
2516 return prepend_elem(type, (OP*)first, (OP*)last);
2518 if (last->op_type != (unsigned)type)
2519 return append_elem(type, (OP*)first, (OP*)last);
2521 first->op_last->op_sibling = last->op_first;
2522 first->op_last = last->op_last;
2523 first->op_flags |= (last->op_flags & OPf_KIDS);
2526 if (last->op_first && first->op_madprop) {
2527 MADPROP *mp = last->op_first->op_madprop;
2529 while (mp->mad_next)
2531 mp->mad_next = first->op_madprop;
2534 last->op_first->op_madprop = first->op_madprop;
2537 first->op_madprop = last->op_madprop;
2538 last->op_madprop = 0;
2541 S_op_destroy(aTHX_ (OP*)last);
2547 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2555 if (last->op_type == (unsigned)type) {
2556 if (type == OP_LIST) { /* already a PUSHMARK there */
2557 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2558 ((LISTOP*)last)->op_first->op_sibling = first;
2559 if (!(first->op_flags & OPf_PARENS))
2560 last->op_flags &= ~OPf_PARENS;
2563 if (!(last->op_flags & OPf_KIDS)) {
2564 ((LISTOP*)last)->op_last = first;
2565 last->op_flags |= OPf_KIDS;
2567 first->op_sibling = ((LISTOP*)last)->op_first;
2568 ((LISTOP*)last)->op_first = first;
2570 last->op_flags |= OPf_KIDS;
2574 return newLISTOP(type, 0, first, last);
2582 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2585 Newxz(tk, 1, TOKEN);
2586 tk->tk_type = (OPCODE)optype;
2587 tk->tk_type = 12345;
2589 tk->tk_mad = madprop;
2594 Perl_token_free(pTHX_ TOKEN* tk)
2596 if (tk->tk_type != 12345)
2598 mad_free(tk->tk_mad);
2603 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2607 if (tk->tk_type != 12345) {
2608 Perl_warner(aTHX_ packWARN(WARN_MISC),
2609 "Invalid TOKEN object ignored");
2616 /* faked up qw list? */
2618 tm->mad_type == MAD_SV &&
2619 SvPVX((SV*)tm->mad_val)[0] == 'q')
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 token_getmad(tk,(OP*)mp->mad_val,slot);
2645 if (mp->mad_key == 'X')
2646 mp->mad_key = slot; /* just change the first one */
2656 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
2665 /* pretend constant fold didn't happen? */
2666 if (mp->mad_key == 'f' &&
2667 (o->op_type == OP_CONST ||
2668 o->op_type == OP_GV) )
2670 op_getmad(from,(OP*)mp->mad_val,slot);
2677 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
2680 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
2686 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
2695 /* pretend constant fold didn't happen? */
2696 if (mp->mad_key == 'f' &&
2697 (o->op_type == OP_CONST ||
2698 o->op_type == OP_GV) )
2700 op_getmad(from,(OP*)mp->mad_val,slot);
2707 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
2710 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
2714 PerlIO_printf(PerlIO_stderr(),
2715 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
2721 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
2739 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
2743 addmad(tm, &(o->op_madprop), slot);
2747 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
2768 Perl_newMADsv(pTHX_ char key, SV* sv)
2770 return newMADPROP(key, MAD_SV, sv, 0);
2774 Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
2777 Newxz(mp, 1, MADPROP);
2780 mp->mad_vlen = vlen;
2781 mp->mad_type = type;
2783 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
2788 Perl_mad_free(pTHX_ MADPROP* mp)
2790 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
2794 mad_free(mp->mad_next);
2795 /* if (PL_lex_state != LEX_NOTPARSING && mp->mad_vlen)
2796 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
2797 switch (mp->mad_type) {
2801 Safefree((char*)mp->mad_val);
2804 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
2805 op_free((OP*)mp->mad_val);
2808 sv_free((SV*)mp->mad_val);
2811 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
2820 Perl_newNULLLIST(pTHX)
2822 return newOP(OP_STUB, 0);
2826 Perl_force_list(pTHX_ OP *o)
2828 if (!o || o->op_type != OP_LIST)
2829 o = newLISTOP(OP_LIST, 0, o, NULL);
2835 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2840 NewOp(1101, listop, 1, LISTOP);
2842 listop->op_type = (OPCODE)type;
2843 listop->op_ppaddr = PL_ppaddr[type];
2846 listop->op_flags = (U8)flags;
2850 else if (!first && last)
2853 first->op_sibling = last;
2854 listop->op_first = first;
2855 listop->op_last = last;
2856 if (type == OP_LIST) {
2857 OP* const pushop = newOP(OP_PUSHMARK, 0);
2858 pushop->op_sibling = first;
2859 listop->op_first = pushop;
2860 listop->op_flags |= OPf_KIDS;
2862 listop->op_last = pushop;
2865 return CHECKOP(type, listop);
2869 Perl_newOP(pTHX_ I32 type, I32 flags)
2873 NewOp(1101, o, 1, OP);
2874 o->op_type = (OPCODE)type;
2875 o->op_ppaddr = PL_ppaddr[type];
2876 o->op_flags = (U8)flags;
2878 o->op_latefreed = 0;
2882 o->op_private = (U8)(0 | (flags >> 8));
2883 if (PL_opargs[type] & OA_RETSCALAR)
2885 if (PL_opargs[type] & OA_TARGET)
2886 o->op_targ = pad_alloc(type, SVs_PADTMP);
2887 return CHECKOP(type, o);
2891 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2897 first = newOP(OP_STUB, 0);
2898 if (PL_opargs[type] & OA_MARK)
2899 first = force_list(first);
2901 NewOp(1101, unop, 1, UNOP);
2902 unop->op_type = (OPCODE)type;
2903 unop->op_ppaddr = PL_ppaddr[type];
2904 unop->op_first = first;
2905 unop->op_flags = (U8)(flags | OPf_KIDS);
2906 unop->op_private = (U8)(1 | (flags >> 8));
2907 unop = (UNOP*) CHECKOP(type, unop);
2911 return fold_constants((OP *) unop);
2915 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2919 NewOp(1101, binop, 1, BINOP);
2922 first = newOP(OP_NULL, 0);
2924 binop->op_type = (OPCODE)type;
2925 binop->op_ppaddr = PL_ppaddr[type];
2926 binop->op_first = first;
2927 binop->op_flags = (U8)(flags | OPf_KIDS);
2930 binop->op_private = (U8)(1 | (flags >> 8));
2933 binop->op_private = (U8)(2 | (flags >> 8));
2934 first->op_sibling = last;
2937 binop = (BINOP*)CHECKOP(type, binop);
2938 if (binop->op_next || binop->op_type != (OPCODE)type)
2941 binop->op_last = binop->op_first->op_sibling;
2943 return fold_constants((OP *)binop);
2946 static int uvcompare(const void *a, const void *b)
2947 __attribute__nonnull__(1)
2948 __attribute__nonnull__(2)
2949 __attribute__pure__;
2950 static int uvcompare(const void *a, const void *b)
2952 if (*((const UV *)a) < (*(const UV *)b))
2954 if (*((const UV *)a) > (*(const UV *)b))
2956 if (*((const UV *)a+1) < (*(const UV *)b+1))
2958 if (*((const UV *)a+1) > (*(const UV *)b+1))
2964 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2967 SV * const tstr = ((SVOP*)expr)->op_sv;
2970 (repl->op_type == OP_NULL)
2971 ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
2973 ((SVOP*)repl)->op_sv;
2976 const U8 *t = (U8*)SvPV_const(tstr, tlen);
2977 const U8 *r = (U8*)SvPV_const(rstr, rlen);
2981 register short *tbl;
2983 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
2984 const I32 squash = o->op_private & OPpTRANS_SQUASH;
2985 I32 del = o->op_private & OPpTRANS_DELETE;
2987 PL_hints |= HINT_BLOCK_SCOPE;
2990 o->op_private |= OPpTRANS_FROM_UTF;
2993 o->op_private |= OPpTRANS_TO_UTF;
2995 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2996 SV* const listsv = newSVpvs("# comment\n");
2998 const U8* tend = t + tlen;
2999 const U8* rend = r + rlen;
3013 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
3014 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
3017 const U32 flags = UTF8_ALLOW_DEFAULT;
3021 t = tsave = bytes_to_utf8(t, &len);
3024 if (!to_utf && rlen) {
3026 r = rsave = bytes_to_utf8(r, &len);
3030 /* There are several snags with this code on EBCDIC:
3031 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
3032 2. scan_const() in toke.c has encoded chars in native encoding which makes
3033 ranges at least in EBCDIC 0..255 range the bottom odd.
3037 U8 tmpbuf[UTF8_MAXBYTES+1];
3040 Newx(cp, 2*tlen, UV);
3042 transv = newSVpvs("");
3044 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3046 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
3048 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3052 cp[2*i+1] = cp[2*i];
3056 qsort(cp, i, 2*sizeof(UV), uvcompare);
3057 for (j = 0; j < i; j++) {
3059 diff = val - nextmin;
3061 t = uvuni_to_utf8(tmpbuf,nextmin);
3062 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3064 U8 range_mark = UTF_TO_NATIVE(0xff);
3065 t = uvuni_to_utf8(tmpbuf, val - 1);
3066 sv_catpvn(transv, (char *)&range_mark, 1);
3067 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3074 t = uvuni_to_utf8(tmpbuf,nextmin);
3075 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3077 U8 range_mark = UTF_TO_NATIVE(0xff);
3078 sv_catpvn(transv, (char *)&range_mark, 1);
3080 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
3081 UNICODE_ALLOW_SUPER);
3082 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3083 t = (const U8*)SvPVX_const(transv);
3084 tlen = SvCUR(transv);
3088 else if (!rlen && !del) {
3089 r = t; rlen = tlen; rend = tend;
3092 if ((!rlen && !del) || t == r ||
3093 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
3095 o->op_private |= OPpTRANS_IDENTICAL;
3099 while (t < tend || tfirst <= tlast) {
3100 /* see if we need more "t" chars */
3101 if (tfirst > tlast) {
3102 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3104 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
3106 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3113 /* now see if we need more "r" chars */
3114 if (rfirst > rlast) {
3116 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3118 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
3120 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3129 rfirst = rlast = 0xffffffff;
3133 /* now see which range will peter our first, if either. */
3134 tdiff = tlast - tfirst;
3135 rdiff = rlast - rfirst;
3142 if (rfirst == 0xffffffff) {
3143 diff = tdiff; /* oops, pretend rdiff is infinite */
3145 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
3146 (long)tfirst, (long)tlast);
3148 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
3152 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
3153 (long)tfirst, (long)(tfirst + diff),
3156 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3157 (long)tfirst, (long)rfirst);
3159 if (rfirst + diff > max)
3160 max = rfirst + diff;
3162 grows = (tfirst < rfirst &&
3163 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3175 else if (max > 0xff)
3180 PerlMemShared_free(cPVOPo->op_pv);
3181 cPVOPo->op_pv = NULL;
3183 swash = (SV*)swash_init("utf8", "", listsv, bits, none);
3185 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
3186 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
3187 PAD_SETSV(cPADOPo->op_padix, swash);
3190 cSVOPo->op_sv = swash;
3192 SvREFCNT_dec(listsv);
3193 SvREFCNT_dec(transv);
3195 if (!del && havefinal && rlen)
3196 (void)hv_store((HV*)SvRV(swash), "FINAL", 5,
3197 newSVuv((UV)final), 0);
3200 o->op_private |= OPpTRANS_GROWS;
3206 op_getmad(expr,o,'e');
3207 op_getmad(repl,o,'r');
3215 tbl = (short*)cPVOPo->op_pv;
3217 Zero(tbl, 256, short);
3218 for (i = 0; i < (I32)tlen; i++)
3220 for (i = 0, j = 0; i < 256; i++) {
3222 if (j >= (I32)rlen) {
3231 if (i < 128 && r[j] >= 128)
3241 o->op_private |= OPpTRANS_IDENTICAL;
3243 else if (j >= (I32)rlen)
3248 PerlMemShared_realloc(tbl,
3249 (0x101+rlen-j) * sizeof(short));
3250 cPVOPo->op_pv = (char*)tbl;
3252 tbl[0x100] = (short)(rlen - j);
3253 for (i=0; i < (I32)rlen - j; i++)
3254 tbl[0x101+i] = r[j+i];
3258 if (!rlen && !del) {
3261 o->op_private |= OPpTRANS_IDENTICAL;
3263 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3264 o->op_private |= OPpTRANS_IDENTICAL;
3266 for (i = 0; i < 256; i++)
3268 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3269 if (j >= (I32)rlen) {
3271 if (tbl[t[i]] == -1)
3277 if (tbl[t[i]] == -1) {
3278 if (t[i] < 128 && r[j] >= 128)
3285 o->op_private |= OPpTRANS_GROWS;
3287 op_getmad(expr,o,'e');
3288 op_getmad(repl,o,'r');
3298 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3303 NewOp(1101, pmop, 1, PMOP);
3304 pmop->op_type = (OPCODE)type;
3305 pmop->op_ppaddr = PL_ppaddr[type];
3306 pmop->op_flags = (U8)flags;
3307 pmop->op_private = (U8)(0 | (flags >> 8));
3309 if (PL_hints & HINT_RE_TAINT)
3310 pmop->op_pmflags |= PMf_RETAINT;
3311 if (PL_hints & HINT_LOCALE)
3312 pmop->op_pmflags |= PMf_LOCALE;
3316 if (av_len((AV*) PL_regex_pad[0]) > -1) {
3317 SV * const repointer = av_pop((AV*)PL_regex_pad[0]);
3318 pmop->op_pmoffset = SvIV(repointer);
3319 SvREPADTMP_off(repointer);
3320 sv_setiv(repointer,0);
3322 SV * const repointer = newSViv(0);
3323 av_push(PL_regex_padav, SvREFCNT_inc_simple_NN(repointer));
3324 pmop->op_pmoffset = av_len(PL_regex_padav);
3325 PL_regex_pad = AvARRAY(PL_regex_padav);
3329 return CHECKOP(type, pmop);
3332 /* Given some sort of match op o, and an expression expr containing a
3333 * pattern, either compile expr into a regex and attach it to o (if it's
3334 * constant), or convert expr into a runtime regcomp op sequence (if it's
3337 * isreg indicates that the pattern is part of a regex construct, eg
3338 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3339 * split "pattern", which aren't. In the former case, expr will be a list
3340 * if the pattern contains more than one term (eg /a$b/) or if it contains
3341 * a replacement, ie s/// or tr///.
3345 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
3350 I32 repl_has_vars = 0;
3354 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
3355 /* last element in list is the replacement; pop it */
3357 repl = cLISTOPx(expr)->op_last;
3358 kid = cLISTOPx(expr)->op_first;
3359 while (kid->op_sibling != repl)
3360 kid = kid->op_sibling;
3361 kid->op_sibling = NULL;
3362 cLISTOPx(expr)->op_last = kid;
3365 if (isreg && expr->op_type == OP_LIST &&
3366 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3368 /* convert single element list to element */
3369 OP* const oe = expr;
3370 expr = cLISTOPx(oe)->op_first->op_sibling;
3371 cLISTOPx(oe)->op_first->op_sibling = NULL;
3372 cLISTOPx(oe)->op_last = NULL;
3376 if (o->op_type == OP_TRANS) {
3377 return pmtrans(o, expr, repl);
3380 reglist = isreg && expr->op_type == OP_LIST;
3384 PL_hints |= HINT_BLOCK_SCOPE;
3387 if (expr->op_type == OP_CONST) {
3389 SV * const pat = ((SVOP*)expr)->op_sv;
3390 const char *p = SvPV_const(pat, plen);
3391 U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
3392 if ((o->op_flags & OPf_SPECIAL) && (plen == 1 && *p == ' ')) {
3393 U32 was_readonly = SvREADONLY(pat);
3397 sv_force_normal_flags(pat, 0);
3398 assert(!SvREADONLY(pat));
3401 SvREADONLY_off(pat);
3405 sv_setpvn(pat, "\\s+", 3);
3407 SvFLAGS(pat) |= was_readonly;
3409 p = SvPV_const(pat, plen);
3410 pm_flags |= RXf_SKIPWHITE;
3413 pm_flags |= RXf_UTF8;
3414 /* FIXME - can we make this function take const char * args? */
3415 PM_SETRE(pm, CALLREGCOMP((char*)p, (char*)p + plen, pm_flags));
3418 op_getmad(expr,(OP*)pm,'e');
3424 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3425 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3427 : OP_REGCMAYBE),0,expr);
3429 NewOp(1101, rcop, 1, LOGOP);
3430 rcop->op_type = OP_REGCOMP;
3431 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3432 rcop->op_first = scalar(expr);
3433 rcop->op_flags |= OPf_KIDS
3434 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3435 | (reglist ? OPf_STACKED : 0);
3436 rcop->op_private = 1;
3439 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3441 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
3444 /* establish postfix order */
3445 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3447 rcop->op_next = expr;
3448 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3451 rcop->op_next = LINKLIST(expr);
3452 expr->op_next = (OP*)rcop;
3455 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3460 if (pm->op_pmflags & PMf_EVAL) {
3462 if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
3463 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
3465 else if (repl->op_type == OP_CONST)
3469 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3470 if (curop->op_type == OP_SCOPE
3471 || curop->op_type == OP_LEAVE
3472 || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
3473 if (curop->op_type == OP_GV) {
3474 GV * const gv = cGVOPx_gv(curop);
3476 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3479 else if (curop->op_type == OP_RV2CV)
3481 else if (curop->op_type == OP_RV2SV ||
3482 curop->op_type == OP_RV2AV ||
3483 curop->op_type == OP_RV2HV ||
3484 curop->op_type == OP_RV2GV) {
3485 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3488 else if (curop->op_type == OP_PADSV ||
3489 curop->op_type == OP_PADAV ||
3490 curop->op_type == OP_PADHV ||
3491 curop->op_type == OP_PADANY)
3495 else if (curop->op_type == OP_PUSHRE)
3496 NOOP; /* Okay here, dangerous in newASSIGNOP */
3506 || PM_GETRE(pm)->extflags & RXf_EVAL_SEEN)))
3508 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3509 prepend_elem(o->op_type, scalar(repl), o);
3512 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3513 pm->op_pmflags |= PMf_MAYBE_CONST;
3515 NewOp(1101, rcop, 1, LOGOP);
3516 rcop->op_type = OP_SUBSTCONT;
3517 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3518 rcop->op_first = scalar(repl);
3519 rcop->op_flags |= OPf_KIDS;
3520 rcop->op_private = 1;
3523 /* establish postfix order */
3524 rcop->op_next = LINKLIST(repl);
3525 repl->op_next = (OP*)rcop;
3527 pm->op_pmreplroot = scalar((OP*)rcop);
3528 pm->op_pmreplstart = LINKLIST(rcop);
3537 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3541 NewOp(1101, svop, 1, SVOP);
3542 svop->op_type = (OPCODE)type;
3543 svop->op_ppaddr = PL_ppaddr[type];
3545 svop->op_next = (OP*)svop;
3546 svop->op_flags = (U8)flags;
3547 if (PL_opargs[type] & OA_RETSCALAR)
3549 if (PL_opargs[type] & OA_TARGET)
3550 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3551 return CHECKOP(type, svop);
3556 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3560 NewOp(1101, padop, 1, PADOP);
3561 padop->op_type = (OPCODE)type;
3562 padop->op_ppaddr = PL_ppaddr[type];
3563 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3564 SvREFCNT_dec(PAD_SVl(padop->op_padix));
3565 PAD_SETSV(padop->op_padix, sv);
3568 padop->op_next = (OP*)padop;
3569 padop->op_flags = (U8)flags;
3570 if (PL_opargs[type] & OA_RETSCALAR)
3572 if (PL_opargs[type] & OA_TARGET)
3573 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3574 return CHECKOP(type, padop);
3579 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3585 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3587 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3592 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3596 NewOp(1101, pvop, 1, PVOP);
3597 pvop->op_type = (OPCODE)type;
3598 pvop->op_ppaddr = PL_ppaddr[type];
3600 pvop->op_next = (OP*)pvop;
3601 pvop->op_flags = (U8)flags;
3602 if (PL_opargs[type] & OA_RETSCALAR)
3604 if (PL_opargs[type] & OA_TARGET)
3605 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3606 return CHECKOP(type, pvop);
3614 Perl_package(pTHX_ OP *o)
3617 SV *const sv = cSVOPo->op_sv;
3622 save_hptr(&PL_curstash);
3623 save_item(PL_curstname);
3625 PL_curstash = gv_stashsv(sv, GV_ADD);
3626 sv_setsv(PL_curstname, sv);
3628 PL_hints |= HINT_BLOCK_SCOPE;
3629 PL_copline = NOLINE;
3635 if (!PL_madskills) {
3640 pegop = newOP(OP_NULL,0);
3641 op_getmad(o,pegop,'P');
3651 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3658 OP *pegop = newOP(OP_NULL,0);
3661 if (idop->op_type != OP_CONST)
3662 Perl_croak(aTHX_ "Module name must be constant");
3665 op_getmad(idop,pegop,'U');
3670 SV * const vesv = ((SVOP*)version)->op_sv;
3673 op_getmad(version,pegop,'V');
3674 if (!arg && !SvNIOKp(vesv)) {
3681 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3682 Perl_croak(aTHX_ "Version number must be constant number");
3684 /* Make copy of idop so we don't free it twice */
3685 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3687 /* Fake up a method call to VERSION */
3688 meth = newSVpvs_share("VERSION");
3689 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3690 append_elem(OP_LIST,
3691 prepend_elem(OP_LIST, pack, list(version)),
3692 newSVOP(OP_METHOD_NAMED, 0, meth)));
3696 /* Fake up an import/unimport */
3697 if (arg && arg->op_type == OP_STUB) {
3699 op_getmad(arg,pegop,'S');
3700 imop = arg; /* no import on explicit () */
3702 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3703 imop = NULL; /* use 5.0; */
3705 idop->op_private |= OPpCONST_NOVER;
3711 op_getmad(arg,pegop,'A');
3713 /* Make copy of idop so we don't free it twice */
3714 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3716 /* Fake up a method call to import/unimport */
3718 ? newSVpvs_share("import") : newSVpvs_share("unimport");
3719 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3720 append_elem(OP_LIST,
3721 prepend_elem(OP_LIST, pack, list(arg)),
3722 newSVOP(OP_METHOD_NAMED, 0, meth)));
3725 /* Fake up the BEGIN {}, which does its thing immediately. */
3727 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
3730 append_elem(OP_LINESEQ,
3731 append_elem(OP_LINESEQ,
3732 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
3733 newSTATEOP(0, NULL, veop)),
3734 newSTATEOP(0, NULL, imop) ));
3736 /* The "did you use incorrect case?" warning used to be here.
3737 * The problem is that on case-insensitive filesystems one
3738 * might get false positives for "use" (and "require"):
3739 * "use Strict" or "require CARP" will work. This causes
3740 * portability problems for the script: in case-strict
3741 * filesystems the script will stop working.
3743 * The "incorrect case" warning checked whether "use Foo"
3744 * imported "Foo" to your namespace, but that is wrong, too:
3745 * there is no requirement nor promise in the language that
3746 * a Foo.pm should or would contain anything in package "Foo".
3748 * There is very little Configure-wise that can be done, either:
3749 * the case-sensitivity of the build filesystem of Perl does not
3750 * help in guessing the case-sensitivity of the runtime environment.
3753 PL_hints |= HINT_BLOCK_SCOPE;
3754 PL_copline = NOLINE;
3756 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3759 if (!PL_madskills) {
3760 /* FIXME - don't allocate pegop if !PL_madskills */
3769 =head1 Embedding Functions
3771 =for apidoc load_module
3773 Loads the module whose name is pointed to by the string part of name.
3774 Note that the actual module name, not its filename, should be given.
3775 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3776 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3777 (or 0 for no flags). ver, if specified, provides version semantics
3778 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3779 arguments can be used to specify arguments to the module's import()
3780 method, similar to C<use Foo::Bar VERSION LIST>.
3785 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3788 va_start(args, ver);
3789 vload_module(flags, name, ver, &args);
3793 #ifdef PERL_IMPLICIT_CONTEXT
3795 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3799 va_start(args, ver);
3800 vload_module(flags, name, ver, &args);
3806 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3811 OP * const modname = newSVOP(OP_CONST, 0, name);
3812 modname->op_private |= OPpCONST_BARE;
3814 veop = newSVOP(OP_CONST, 0, ver);
3818 if (flags & PERL_LOADMOD_NOIMPORT) {
3819 imop = sawparens(newNULLLIST());
3821 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3822 imop = va_arg(*args, OP*);
3827 sv = va_arg(*args, SV*);
3829 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3830 sv = va_arg(*args, SV*);
3834 const line_t ocopline = PL_copline;
3835 COP * const ocurcop = PL_curcop;
3836 const int oexpect = PL_expect;
3838 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3839 veop, modname, imop);
3840 PL_expect = oexpect;
3841 PL_copline = ocopline;
3842 PL_curcop = ocurcop;
3847 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
3853 if (!force_builtin) {
3854 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
3855 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
3856 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
3857 gv = gvp ? *gvp : NULL;
3861 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3862 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3863 append_elem(OP_LIST, term,
3864 scalar(newUNOP(OP_RV2CV, 0,
3865 newGVOP(OP_GV, 0, gv))))));
3868 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3874 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3876 return newBINOP(OP_LSLICE, flags,
3877 list(force_list(subscript)),
3878 list(force_list(listval)) );
3882 S_is_list_assignment(pTHX_ register const OP *o)
3890 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
3891 o = cUNOPo->op_first;
3893 flags = o->op_flags;
3895 if (type == OP_COND_EXPR) {
3896 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
3897 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3902 yyerror("Assignment to both a list and a scalar");
3906 if (type == OP_LIST &&
3907 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
3908 o->op_private & OPpLVAL_INTRO)
3911 if (type == OP_LIST || flags & OPf_PARENS ||
3912 type == OP_RV2AV || type == OP_RV2HV ||
3913 type == OP_ASLICE || type == OP_HSLICE)
3916 if (type == OP_PADAV || type == OP_PADHV)
3919 if (type == OP_RV2SV)
3926 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3932 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3933 return newLOGOP(optype, 0,
3934 mod(scalar(left), optype),
3935 newUNOP(OP_SASSIGN, 0, scalar(right)));
3938 return newBINOP(optype, OPf_STACKED,
3939 mod(scalar(left), optype), scalar(right));
3943 if (is_list_assignment(left)) {
3947 /* Grandfathering $[ assignment here. Bletch.*/
3948 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
3949 PL_eval_start = (left->op_type == OP_CONST) ? right : 0;
3950 left = mod(left, OP_AASSIGN);
3953 else if (left->op_type == OP_CONST) {
3955 /* Result of assignment is always 1 (or we'd be dead already) */
3956 return newSVOP(OP_CONST, 0, newSViv(1));
3958 curop = list(force_list(left));
3959 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3960 o->op_private = (U8)(0 | (flags >> 8));
3962 /* PL_generation sorcery:
3963 * an assignment like ($a,$b) = ($c,$d) is easier than
3964 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3965 * To detect whether there are common vars, the global var
3966 * PL_generation is incremented for each assign op we compile.
3967 * Then, while compiling the assign op, we run through all the
3968 * variables on both sides of the assignment, setting a spare slot
3969 * in each of them to PL_generation. If any of them already have
3970 * that value, we know we've got commonality. We could use a
3971 * single bit marker, but then we'd have to make 2 passes, first
3972 * to clear the flag, then to test and set it. To find somewhere
3973 * to store these values, evil chicanery is done with SvUVX().
3979 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3980 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3981 if (curop->op_type == OP_GV) {
3982 GV *gv = cGVOPx_gv(curop);
3984 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
3986 GvASSIGN_GENERATION_set(gv, PL_generation);
3988 else if (curop->op_type == OP_PADSV ||
3989 curop->op_type == OP_PADAV ||
3990 curop->op_type == OP_PADHV ||
3991 curop->op_type == OP_PADANY)
3993 if (PAD_COMPNAME_GEN(curop->op_targ)
3994 == (STRLEN)PL_generation)
3996 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
3999 else if (curop->op_type == OP_RV2CV)
4001 else if (curop->op_type == OP_RV2SV ||
4002 curop->op_type == OP_RV2AV ||
4003 curop->op_type == OP_RV2HV ||
4004 curop->op_type == OP_RV2GV) {
4005 if (lastop->op_type != OP_GV) /* funny deref? */
4008 else if (curop->op_type == OP_PUSHRE) {
4009 if (((PMOP*)curop)->op_pmreplroot) {
4011 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
4012 ((PMOP*)curop)->op_pmreplroot));
4014 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
4017 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4019 GvASSIGN_GENERATION_set(gv, PL_generation);
4020 GvASSIGN_GENERATION_set(gv, PL_generation);
4029 o->op_private |= OPpASSIGN_COMMON;
4032 if ( ((left->op_private & OPpLVAL_INTRO) || ckWARN(WARN_MISC))
4033 && (left->op_type == OP_LIST
4034 || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
4036 OP* lop = ((LISTOP*)left)->op_first;
4038 if (lop->op_type == OP_PADSV ||
4039 lop->op_type == OP_PADAV ||
4040 lop->op_type == OP_PADHV ||
4041 lop->op_type == OP_PADANY)
4043 if (lop->op_private & OPpPAD_STATE) {
4044 if (left->op_private & OPpLVAL_INTRO) {
4045 o->op_private |= OPpASSIGN_STATE;
4046 /* hijacking PADSTALE for uninitialized state variables */
4047 SvPADSTALE_on(PAD_SVl(lop->op_targ));
4049 else { /* we already checked for WARN_MISC before */
4050 Perl_warner(aTHX_ packWARN(WARN_MISC), "State variable %s will be reinitialized",
4051 PAD_COMPNAME_PV(lop->op_targ));
4055 lop = lop->op_sibling;
4058 else if (((left->op_private & (OPpLVAL_INTRO | OPpPAD_STATE))
4059 == (OPpLVAL_INTRO | OPpPAD_STATE))
4060 && ( left->op_type == OP_PADSV
4061 || left->op_type == OP_PADAV
4062 || left->op_type == OP_PADHV
4063 || left->op_type == OP_PADANY))
4065 o->op_private |= OPpASSIGN_STATE;
4066 /* hijacking PADSTALE for uninitialized state variables */
4067 SvPADSTALE_on(PAD_SVl(left->op_targ));
4070 if (right && right->op_type == OP_SPLIT) {
4071 OP* tmpop = ((LISTOP*)right)->op_first;
4072 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
4073 PMOP * const pm = (PMOP*)tmpop;
4074 if (left->op_type == OP_RV2AV &&
4075 !(left->op_private & OPpLVAL_INTRO) &&
4076 !(o->op_private & OPpASSIGN_COMMON) )
4078 tmpop = ((UNOP*)left)->op_first;
4079 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
4081 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
4082 cPADOPx(tmpop)->op_padix = 0; /* steal it */
4084 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
4085 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
4087 pm->op_pmflags |= PMf_ONCE;
4088 tmpop = cUNOPo->op_first; /* to list (nulled) */
4089 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
4090 tmpop->op_sibling = NULL; /* don't free split */
4091 right->op_next = tmpop->op_next; /* fix starting loc */
4093 op_getmad(o,right,'R'); /* blow off assign */
4095 op_free(o); /* blow off assign */
4097 right->op_flags &= ~OPf_WANT;
4098 /* "I don't know and I don't care." */
4103 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
4104 ((LISTOP*)right)->op_last->op_type == OP_CONST)
4106 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
4108 sv_setiv(sv, PL_modcount+1);
4116 right = newOP(OP_UNDEF, 0);
4117 if (right->op_type == OP_READLINE) {
4118 right->op_flags |= OPf_STACKED;
4119 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
4122 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
4123 o = newBINOP(OP_SASSIGN, flags,
4124 scalar(right), mod(scalar(left), OP_SASSIGN) );
4130 o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
4131 o->op_private |= OPpCONST_ARYBASE;
4138 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
4141 const U32 seq = intro_my();
4144 NewOp(1101, cop, 1, COP);
4145 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
4146 cop->op_type = OP_DBSTATE;
4147 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
4150 cop->op_type = OP_NEXTSTATE;
4151 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
4153 cop->op_flags = (U8)flags;
4154 CopHINTS_set(cop, PL_hints);
4156 cop->op_private |= NATIVE_HINTS;
4158 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
4159 cop->op_next = (OP*)cop;
4162 CopLABEL_set(cop, label);
4163 PL_hints |= HINT_BLOCK_SCOPE;
4166 /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
4167 CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
4169 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
4170 cop->cop_hints_hash = PL_curcop->cop_hints_hash;
4171 if (cop->cop_hints_hash) {
4173 cop->cop_hints_hash->refcounted_he_refcnt++;
4174 HINTS_REFCNT_UNLOCK;
4177 if (PL_copline == NOLINE)
4178 CopLINE_set(cop, CopLINE(PL_curcop));
4180 CopLINE_set(cop, PL_copline);
4181 PL_copline = NOLINE;
4184 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
4186 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
4188 CopSTASH_set(cop, PL_curstash);
4190 if (PERLDB_LINE && PL_curstash != PL_debstash) {
4191 AV *av = CopFILEAVx(PL_curcop);
4193 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
4194 if (svp && *svp != &PL_sv_undef ) {
4195 (void)SvIOK_on(*svp);
4196 SvIV_set(*svp, PTR2IV(cop));
4201 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
4206 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
4209 return new_logop(type, flags, &first, &other);
4213 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
4218 OP *first = *firstp;
4219 OP * const other = *otherp;
4221 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
4222 return newBINOP(type, flags, scalar(first), scalar(other));
4224 scalarboolean(first);
4225 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
4226 if (first->op_type == OP_NOT
4227 && (first->op_flags & OPf_SPECIAL)
4228 && (first->op_flags & OPf_KIDS)) {
4229 if (type == OP_AND || type == OP_OR) {
4235 first = *firstp = cUNOPo->op_first;
4237 first->op_next = o->op_next;
4238 cUNOPo->op_first = NULL;
4240 op_getmad(o,first,'O');
4246 if (first->op_type == OP_CONST) {
4247 if (first->op_private & OPpCONST_STRICT)
4248 no_bareword_allowed(first);
4249 else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
4250 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
4251 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
4252 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
4253 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
4255 if (other->op_type == OP_CONST)
4256 other->op_private |= OPpCONST_SHORTCIRCUIT;
4258 OP *newop = newUNOP(OP_NULL, 0, other);
4259 op_getmad(first, newop, '1');
4260 newop->op_targ = type; /* set "was" field */
4267 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
4268 const OP *o2 = other;
4269 if ( ! (o2->op_type == OP_LIST
4270 && (( o2 = cUNOPx(o2)->op_first))
4271 && o2->op_type == OP_PUSHMARK
4272 && (( o2 = o2->op_sibling)) )
4275 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
4276 || o2->op_type == OP_PADHV)
4277 && o2->op_private & OPpLVAL_INTRO
4278 && ckWARN(WARN_DEPRECATED))
4280 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4281 "Deprecated use of my() in false conditional");
4285 if (first->op_type == OP_CONST)
4286 first->op_private |= OPpCONST_SHORTCIRCUIT;
4288 first = newUNOP(OP_NULL, 0, first);
4289 op_getmad(other, first, '2');
4290 first->op_targ = type; /* set "was" field */
4297 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
4298 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
4300 const OP * const k1 = ((UNOP*)first)->op_first;
4301 const OP * const k2 = k1->op_sibling;
4303 switch (first->op_type)
4306 if (k2 && k2->op_type == OP_READLINE
4307 && (k2->op_flags & OPf_STACKED)
4308 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4310 warnop = k2->op_type;
4315 if (k1->op_type == OP_READDIR
4316 || k1->op_type == OP_GLOB
4317 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4318 || k1->op_type == OP_EACH)
4320 warnop = ((k1->op_type == OP_NULL)
4321 ? (OPCODE)k1->op_targ : k1->op_type);
4326 const line_t oldline = CopLINE(PL_curcop);
4327 CopLINE_set(PL_curcop, PL_copline);
4328 Perl_warner(aTHX_ packWARN(WARN_MISC),
4329 "Value of %s%s can be \"0\"; test with defined()",
4331 ((warnop == OP_READLINE || warnop == OP_GLOB)
4332 ? " construct" : "() operator"));
4333 CopLINE_set(PL_curcop, oldline);
4340 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
4341 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
4343 NewOp(1101, logop, 1, LOGOP);
4345 logop->op_type = (OPCODE)type;
4346 logop->op_ppaddr = PL_ppaddr[type];
4347 logop->op_first = first;
4348 logop->op_flags = (U8)(flags | OPf_KIDS);
4349 logop->op_other = LINKLIST(other);
4350 logop->op_private = (U8)(1 | (flags >> 8));
4352 /* establish postfix order */
4353 logop->op_next = LINKLIST(first);
4354 first->op_next = (OP*)logop;
4355 first->op_sibling = other;
4357 CHECKOP(type,logop);
4359 o = newUNOP(OP_NULL, 0, (OP*)logop);
4366 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
4374 return newLOGOP(OP_AND, 0, first, trueop);
4376 return newLOGOP(OP_OR, 0, first, falseop);
4378 scalarboolean(first);
4379 if (first->op_type == OP_CONST) {
4380 /* Left or right arm of the conditional? */
4381 const bool left = SvTRUE(((SVOP*)first)->op_sv);
4382 OP *live = left ? trueop : falseop;
4383 OP *const dead = left ? falseop : trueop;
4384 if (first->op_private & OPpCONST_BARE &&
4385 first->op_private & OPpCONST_STRICT) {
4386 no_bareword_allowed(first);
4389 /* This is all dead code when PERL_MAD is not defined. */
4390 live = newUNOP(OP_NULL, 0, live);
4391 op_getmad(first, live, 'C');
4392 op_getmad(dead, live, left ? 'e' : 't');
4399 NewOp(1101, logop, 1, LOGOP);
4400 logop->op_type = OP_COND_EXPR;
4401 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4402 logop->op_first = first;
4403 logop->op_flags = (U8)(flags | OPf_KIDS);
4404 logop->op_private = (U8)(1 | (flags >> 8));
4405 logop->op_other = LINKLIST(trueop);
4406 logop->op_next = LINKLIST(falseop);
4408 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
4411 /* establish postfix order */
4412 start = LINKLIST(first);
4413 first->op_next = (OP*)logop;
4415 first->op_sibling = trueop;
4416 trueop->op_sibling = falseop;
4417 o = newUNOP(OP_NULL, 0, (OP*)logop);
4419 trueop->op_next = falseop->op_next = o;
4426 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4435 NewOp(1101, range, 1, LOGOP);
4437 range->op_type = OP_RANGE;
4438 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4439 range->op_first = left;
4440 range->op_flags = OPf_KIDS;
4441 leftstart = LINKLIST(left);
4442 range->op_other = LINKLIST(right);
4443 range->op_private = (U8)(1 | (flags >> 8));
4445 left->op_sibling = right;
4447 range->op_next = (OP*)range;
4448 flip = newUNOP(OP_FLIP, flags, (OP*)range);
4449 flop = newUNOP(OP_FLOP, 0, flip);
4450 o = newUNOP(OP_NULL, 0, flop);
4452 range->op_next = leftstart;
4454 left->op_next = flip;
4455 right->op_next = flop;
4457 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4458 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4459 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4460 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4462 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4463 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4466 if (!flip->op_private || !flop->op_private)
4467 linklist(o); /* blow off optimizer unless constant */
4473 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4478 const bool once = block && block->op_flags & OPf_SPECIAL &&
4479 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4481 PERL_UNUSED_ARG(debuggable);
4484 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4485 return block; /* do {} while 0 does once */
4486 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4487 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4488 expr = newUNOP(OP_DEFINED, 0,
4489 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4490 } else if (expr->op_flags & OPf_KIDS) {
4491 const OP * const k1 = ((UNOP*)expr)->op_first;
4492 const OP * const k2 = k1 ? k1->op_sibling : NULL;
4493 switch (expr->op_type) {
4495 if (k2 && k2->op_type == OP_READLINE
4496 && (k2->op_flags & OPf_STACKED)
4497 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4498 expr = newUNOP(OP_DEFINED, 0, expr);
4502 if (k1 && (k1->op_type == OP_READDIR
4503 || k1->op_type == OP_GLOB
4504 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4505 || k1->op_type == OP_EACH))
4506 expr = newUNOP(OP_DEFINED, 0, expr);
4512 /* if block is null, the next append_elem() would put UNSTACK, a scalar
4513 * op, in listop. This is wrong. [perl #27024] */
4515 block = newOP(OP_NULL, 0);
4516 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4517 o = new_logop(OP_AND, 0, &expr, &listop);
4520 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4522 if (once && o != listop)
4523 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4526 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
4528 o->op_flags |= flags;
4530 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4535 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
4536 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
4545 PERL_UNUSED_ARG(debuggable);
4548 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4549 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4550 expr = newUNOP(OP_DEFINED, 0,
4551 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4552 } else if (expr->op_flags & OPf_KIDS) {
4553 const OP * const k1 = ((UNOP*)expr)->op_first;
4554 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
4555 switch (expr->op_type) {
4557 if (k2 && k2->op_type == OP_READLINE
4558 && (k2->op_flags & OPf_STACKED)
4559 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4560 expr = newUNOP(OP_DEFINED, 0, expr);
4564 if (k1 && (k1->op_type == OP_READDIR
4565 || k1->op_type == OP_GLOB
4566 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4567 || k1->op_type == OP_EACH))
4568 expr = newUNOP(OP_DEFINED, 0, expr);
4575 block = newOP(OP_NULL, 0);
4576 else if (cont || has_my) {
4577 block = scope(block);
4581 next = LINKLIST(cont);
4584 OP * const unstack = newOP(OP_UNSTACK, 0);
4587 cont = append_elem(OP_LINESEQ, cont, unstack);
4591 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4593 redo = LINKLIST(listop);
4596 PL_copline = (line_t)whileline;
4598 o = new_logop(OP_AND, 0, &expr, &listop);
4599 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4600 op_free(expr); /* oops, it's a while (0) */
4602 return NULL; /* listop already freed by new_logop */
4605 ((LISTOP*)listop)->op_last->op_next =
4606 (o == listop ? redo : LINKLIST(o));
4612 NewOp(1101,loop,1,LOOP);
4613 loop->op_type = OP_ENTERLOOP;
4614 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4615 loop->op_private = 0;
4616 loop->op_next = (OP*)loop;
4619 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4621 loop->op_redoop = redo;
4622 loop->op_lastop = o;
4623 o->op_private |= loopflags;
4626 loop->op_nextop = next;
4628 loop->op_nextop = o;
4630 o->op_flags |= flags;
4631 o->op_private |= (flags >> 8);
4636 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
4641 PADOFFSET padoff = 0;
4647 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4648 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
4649 sv->op_type = OP_RV2GV;
4650 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4652 /* The op_type check is needed to prevent a possible segfault
4653 * if the loop variable is undeclared and 'strict vars' is in
4654 * effect. This is illegal but is nonetheless parsed, so we
4655 * may reach this point with an OP_CONST where we're expecting
4658 if (cUNOPx(sv)->op_first->op_type == OP_GV
4659 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
4660 iterpflags |= OPpITER_DEF;
4662 else if (sv->op_type == OP_PADSV) { /* private variable */
4663 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
4664 padoff = sv->op_targ;
4674 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4676 SV *const namesv = PAD_COMPNAME_SV(padoff);
4678 const char *const name = SvPV_const(namesv, len);
4680 if (len == 2 && name[0] == '$' && name[1] == '_')
4681 iterpflags |= OPpITER_DEF;
4685 const PADOFFSET offset = pad_findmy("$_");
4686 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
4687 sv = newGVOP(OP_GV, 0, PL_defgv);
4692 iterpflags |= OPpITER_DEF;
4694 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4695 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4696 iterflags |= OPf_STACKED;
4698 else if (expr->op_type == OP_NULL &&
4699 (expr->op_flags & OPf_KIDS) &&
4700 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4702 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4703 * set the STACKED flag to indicate that these values are to be
4704 * treated as min/max values by 'pp_iterinit'.
4706 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4707 LOGOP* const range = (LOGOP*) flip->op_first;
4708 OP* const left = range->op_first;
4709 OP* const right = left->op_sibling;
4712 range->op_flags &= ~OPf_KIDS;
4713 range->op_first = NULL;
4715 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4716 listop->op_first->op_next = range->op_next;
4717 left->op_next = range->op_other;
4718 right->op_next = (OP*)listop;
4719 listop->op_next = listop->op_first;
4722 op_getmad(expr,(OP*)listop,'O');
4726 expr = (OP*)(listop);
4728 iterflags |= OPf_STACKED;
4731 expr = mod(force_list(expr), OP_GREPSTART);
4734 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4735 append_elem(OP_LIST, expr, scalar(sv))));
4736 assert(!loop->op_next);
4737 /* for my $x () sets OPpLVAL_INTRO;
4738 * for our $x () sets OPpOUR_INTRO */
4739 loop->op_private = (U8)iterpflags;
4740 #ifdef PL_OP_SLAB_ALLOC
4743 NewOp(1234,tmp,1,LOOP);
4744 Copy(loop,tmp,1,LISTOP);
4745 S_op_destroy(aTHX_ (OP*)loop);
4749 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
4751 loop->op_targ = padoff;
4752 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
4754 op_getmad(madsv, (OP*)loop, 'v');
4755 PL_copline = forline;
4756 return newSTATEOP(0, label, wop);
4760 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4765 if (type != OP_GOTO || label->op_type == OP_CONST) {
4766 /* "last()" means "last" */
4767 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4768 o = newOP(type, OPf_SPECIAL);
4770 o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
4771 ? SvPVx_nolen_const(((SVOP*)label)->op_sv)
4775 op_getmad(label,o,'L');
4781 /* Check whether it's going to be a goto &function */
4782 if (label->op_type == OP_ENTERSUB
4783 && !(label->op_flags & OPf_STACKED))
4784 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4785 o = newUNOP(type, OPf_STACKED, label);
4787 PL_hints |= HINT_BLOCK_SCOPE;
4791 /* if the condition is a literal array or hash
4792 (or @{ ... } etc), make a reference to it.
4795 S_ref_array_or_hash(pTHX_ OP *cond)
4798 && (cond->op_type == OP_RV2AV
4799 || cond->op_type == OP_PADAV
4800 || cond->op_type == OP_RV2HV
4801 || cond->op_type == OP_PADHV))
4803 return newUNOP(OP_REFGEN,
4804 0, mod(cond, OP_REFGEN));
4810 /* These construct the optree fragments representing given()
4813 entergiven and enterwhen are LOGOPs; the op_other pointer
4814 points up to the associated leave op. We need this so we
4815 can put it in the context and make break/continue work.
4816 (Also, of course, pp_enterwhen will jump straight to
4817 op_other if the match fails.)
4821 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
4822 I32 enter_opcode, I32 leave_opcode,
4823 PADOFFSET entertarg)
4829 NewOp(1101, enterop, 1, LOGOP);
4830 enterop->op_type = enter_opcode;
4831 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
4832 enterop->op_flags = (U8) OPf_KIDS;
4833 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
4834 enterop->op_private = 0;
4836 o = newUNOP(leave_opcode, 0, (OP *) enterop);
4839 enterop->op_first = scalar(cond);
4840 cond->op_sibling = block;
4842 o->op_next = LINKLIST(cond);
4843 cond->op_next = (OP *) enterop;
4846 /* This is a default {} block */
4847 enterop->op_first = block;
4848 enterop->op_flags |= OPf_SPECIAL;
4850 o->op_next = (OP *) enterop;
4853 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
4854 entergiven and enterwhen both
4857 enterop->op_next = LINKLIST(block);
4858 block->op_next = enterop->op_other = o;
4863 /* Does this look like a boolean operation? For these purposes
4864 a boolean operation is:
4865 - a subroutine call [*]
4866 - a logical connective
4867 - a comparison operator
4868 - a filetest operator, with the exception of -s -M -A -C
4869 - defined(), exists() or eof()
4870 - /$re/ or $foo =~ /$re/
4872 [*] possibly surprising
4875 S_looks_like_bool(pTHX_ const OP *o)
4878 switch(o->op_type) {
4880 return looks_like_bool(cLOGOPo->op_first);
4884 looks_like_bool(cLOGOPo->op_first)
4885 && looks_like_bool(cLOGOPo->op_first->op_sibling));
4889 case OP_NOT: case OP_XOR:
4890 /* Note that OP_DOR is not here */
4892 case OP_EQ: case OP_NE: case OP_LT:
4893 case OP_GT: case OP_LE: case OP_GE:
4895 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
4896 case OP_I_GT: case OP_I_LE: case OP_I_GE:
4898 case OP_SEQ: case OP_SNE: case OP_SLT:
4899 case OP_SGT: case OP_SLE: case OP_SGE:
4903 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
4904 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
4905 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
4906 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
4907 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
4908 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
4909 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
4910 case OP_FTTEXT: case OP_FTBINARY:
4912 case OP_DEFINED: case OP_EXISTS:
4913 case OP_MATCH: case OP_EOF:
4918 /* Detect comparisons that have been optimized away */
4919 if (cSVOPo->op_sv == &PL_sv_yes
4920 || cSVOPo->op_sv == &PL_sv_no)
4931 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
4935 return newGIVWHENOP(
4936 ref_array_or_hash(cond),
4938 OP_ENTERGIVEN, OP_LEAVEGIVEN,
4942 /* If cond is null, this is a default {} block */
4944 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
4946 const bool cond_llb = (!cond || looks_like_bool(cond));
4952 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
4954 scalar(ref_array_or_hash(cond)));
4957 return newGIVWHENOP(
4959 append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
4960 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
4964 =for apidoc cv_undef
4966 Clear out all the active components of a CV. This can happen either
4967 by an explicit C<undef &foo>, or by the reference count going to zero.
4968 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
4969 children can still follow the full lexical scope chain.
4975 Perl_cv_undef(pTHX_ CV *cv)
4979 if (CvFILE(cv) && !CvISXSUB(cv)) {
4980 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4981 Safefree(CvFILE(cv));
4986 if (!CvISXSUB(cv) && CvROOT(cv)) {
4987 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
4988 Perl_croak(aTHX_ "Can't undef active subroutine");
4991 PAD_SAVE_SETNULLPAD();
4993 op_free(CvROOT(cv));
4998 SvPOK_off((SV*)cv); /* forget prototype */
5003 /* remove CvOUTSIDE unless this is an undef rather than a free */
5004 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
5005 if (!CvWEAKOUTSIDE(cv))
5006 SvREFCNT_dec(CvOUTSIDE(cv));
5007 CvOUTSIDE(cv) = NULL;
5010 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
5013 if (CvISXSUB(cv) && CvXSUB(cv)) {
5016 /* delete all flags except WEAKOUTSIDE */
5017 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
5021 Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
5024 /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
5025 relying on SvCUR, and doubling up the buffer to hold CvFILE(). */
5026 if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
5027 || (p && (len != SvCUR(cv) /* Not the same length. */
5028 || memNE(p, SvPVX_const(cv), len))))
5029 && ckWARN_d(WARN_PROTOTYPE)) {
5030 SV* const msg = sv_newmortal();
5034 gv_efullname3(name = sv_newmortal(), gv, NULL);
5035 sv_setpvs(msg, "Prototype mismatch:");
5037 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
5039 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv));
5041 sv_catpvs(msg, ": none");
5042 sv_catpvs(msg, " vs ");
5044 Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
5046 sv_catpvs(msg, "none");
5047 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
5051 static void const_sv_xsub(pTHX_ CV* cv);
5055 =head1 Optree Manipulation Functions
5057 =for apidoc cv_const_sv
5059 If C<cv> is a constant sub eligible for inlining. returns the constant
5060 value returned by the sub. Otherwise, returns NULL.
5062 Constant subs can be created with C<newCONSTSUB> or as described in
5063 L<perlsub/"Constant Functions">.
5068 Perl_cv_const_sv(pTHX_ CV *cv)
5070 PERL_UNUSED_CONTEXT;
5073 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
5075 return CvCONST(cv) ? (SV*)CvXSUBANY(cv).any_ptr : NULL;
5078 /* op_const_sv: examine an optree to determine whether it's in-lineable.
5079 * Can be called in 3 ways:
5082 * look for a single OP_CONST with attached value: return the value
5084 * cv && CvCLONE(cv) && !CvCONST(cv)
5086 * examine the clone prototype, and if contains only a single
5087 * OP_CONST referencing a pad const, or a single PADSV referencing
5088 * an outer lexical, return a non-zero value to indicate the CV is
5089 * a candidate for "constizing" at clone time
5093 * We have just cloned an anon prototype that was marked as a const
5094 * candidiate. Try to grab the current value, and in the case of
5095 * PADSV, ignore it if it has multiple references. Return the value.
5099 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
5107 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
5108 o = cLISTOPo->op_first->op_sibling;
5110 for (; o; o = o->op_next) {
5111 const OPCODE type = o->op_type;
5113 if (sv && o->op_next == o)
5115 if (o->op_next != o) {
5116 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
5118 if (type == OP_DBSTATE)
5121 if (type == OP_LEAVESUB || type == OP_RETURN)
5125 if (type == OP_CONST && cSVOPo->op_sv)
5127 else if (cv && type == OP_CONST) {
5128 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5132 else if (cv && type == OP_PADSV) {
5133 if (CvCONST(cv)) { /* newly cloned anon */
5134 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5135 /* the candidate should have 1 ref from this pad and 1 ref
5136 * from the parent */
5137 if (!sv || SvREFCNT(sv) != 2)
5144 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
5145 sv = &PL_sv_undef; /* an arbitrary non-null value */
5160 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5163 /* This would be the return value, but the return cannot be reached. */
5164 OP* pegop = newOP(OP_NULL, 0);
5167 PERL_UNUSED_ARG(floor);
5177 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
5179 NORETURN_FUNCTION_END;
5184 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
5186 return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
5190 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5197 register CV *cv = NULL;
5199 /* If the subroutine has no body, no attributes, and no builtin attributes
5200 then it's just a sub declaration, and we may be able to get away with
5201 storing with a placeholder scalar in the symbol table, rather than a
5202 full GV and CV. If anything is present then it will take a full CV to
5204 const I32 gv_fetch_flags
5205 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5207 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
5208 const char * const name = o ? SvPVx_nolen_const(cSVOPo->op_sv) : NULL;
5211 assert(proto->op_type == OP_CONST);
5212 ps = SvPVx_const(((SVOP*)proto)->op_sv, ps_len);
5217 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
5218 SV * const sv = sv_newmortal();
5219 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
5220 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
5221 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
5222 aname = SvPVX_const(sv);
5227 gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
5228 : gv_fetchpv(aname ? aname
5229 : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5230 gv_fetch_flags, SVt_PVCV);
5232 if (!PL_madskills) {
5241 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
5242 maximum a prototype before. */
5243 if (SvTYPE(gv) > SVt_NULL) {
5244 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
5245 && ckWARN_d(WARN_PROTOTYPE))
5247 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
5249 cv_ckproto_len((CV*)gv, NULL, ps, ps_len);
5252 sv_setpvn((SV*)gv, ps, ps_len);
5254 sv_setiv((SV*)gv, -1);
5255 SvREFCNT_dec(PL_compcv);
5256 cv = PL_compcv = NULL;
5257 PL_sub_generation++;
5261 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
5263 #ifdef GV_UNIQUE_CHECK
5264 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
5265 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
5269 if (!block || !ps || *ps || attrs
5270 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5272 || block->op_type == OP_NULL
5277 const_sv = op_const_sv(block, NULL);
5280 const bool exists = CvROOT(cv) || CvXSUB(cv);
5282 #ifdef GV_UNIQUE_CHECK
5283 if (exists && GvUNIQUE(gv)) {
5284 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
5288 /* if the subroutine doesn't exist and wasn't pre-declared
5289 * with a prototype, assume it will be AUTOLOADed,
5290 * skipping the prototype check
5292 if (exists || SvPOK(cv))
5293 cv_ckproto_len(cv, gv, ps, ps_len);
5294 /* already defined (or promised)? */
5295 if (exists || GvASSUMECV(gv)) {
5298 || block->op_type == OP_NULL
5301 if (CvFLAGS(PL_compcv)) {
5302 /* might have had built-in attrs applied */
5303 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5305 /* just a "sub foo;" when &foo is already defined */
5306 SAVEFREESV(PL_compcv);
5311 && block->op_type != OP_NULL
5314 if (ckWARN(WARN_REDEFINE)
5316 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
5318 const line_t oldline = CopLINE(PL_curcop);
5319 if (PL_copline != NOLINE)
5320 CopLINE_set(PL_curcop, PL_copline);
5321 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5322 CvCONST(cv) ? "Constant subroutine %s redefined"
5323 : "Subroutine %s redefined", name);
5324 CopLINE_set(PL_curcop, oldline);
5327 if (!PL_minus_c) /* keep old one around for madskills */
5330 /* (PL_madskills unset in used file.) */
5338 SvREFCNT_inc_simple_void_NN(const_sv);
5340 assert(!CvROOT(cv) && !CvCONST(cv));
5341 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
5342 CvXSUBANY(cv).any_ptr = const_sv;
5343 CvXSUB(cv) = const_sv_xsub;
5349 cv = newCONSTSUB(NULL, name, const_sv);
5351 PL_sub_generation++;
5355 SvREFCNT_dec(PL_compcv);
5363 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
5364 * before we clobber PL_compcv.
5368 || block->op_type == OP_NULL
5372 /* Might have had built-in attributes applied -- propagate them. */
5373 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5374 if (CvGV(cv) && GvSTASH(CvGV(cv)))
5375 stash = GvSTASH(CvGV(cv));
5376 else if (CvSTASH(cv))
5377 stash = CvSTASH(cv);
5379 stash = PL_curstash;
5382 /* possibly about to re-define existing subr -- ignore old cv */
5383 rcv = (SV*)PL_compcv;
5384 if (name && GvSTASH(gv))
5385 stash = GvSTASH(gv);
5387 stash = PL_curstash;
5389 apply_attrs(stash, rcv, attrs, FALSE);
5391 if (cv) { /* must reuse cv if autoloaded */
5398 || block->op_type == OP_NULL) && !PL_madskills
5401 /* got here with just attrs -- work done, so bug out */
5402 SAVEFREESV(PL_compcv);
5405 /* transfer PL_compcv to cv */
5407 CvFLAGS(cv) = CvFLAGS(PL_compcv);
5408 if (!CvWEAKOUTSIDE(cv))
5409 SvREFCNT_dec(CvOUTSIDE(cv));
5410 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
5411 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
5412 CvOUTSIDE(PL_compcv) = 0;
5413 CvPADLIST(cv) = CvPADLIST(PL_compcv);
5414 CvPADLIST(PL_compcv) = 0;
5415 /* inner references to PL_compcv must be fixed up ... */
5416 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
5417 /* ... before we throw it away */
5418 SvREFCNT_dec(PL_compcv);
5420 if (PERLDB_INTER)/* Advice debugger on the new sub. */
5421 ++PL_sub_generation;
5428 if (strEQ(name, "import")) {
5429 PL_formfeed = (SV*)cv;
5430 Perl_warner(aTHX_ packWARN(WARN_VOID), "%lx\n", (long)cv);
5434 PL_sub_generation++;
5438 CvFILE_set_from_cop(cv, PL_curcop);
5439 CvSTASH(cv) = PL_curstash;
5442 sv_setpvn((SV*)cv, ps, ps_len);
5444 if (PL_error_count) {
5448 const char *s = strrchr(name, ':');
5450 if (strEQ(s, "BEGIN")) {
5451 const char not_safe[] =
5452 "BEGIN not safe after errors--compilation aborted";
5453 if (PL_in_eval & EVAL_KEEPERR)
5454 Perl_croak(aTHX_ not_safe);
5456 /* force display of errors found but not reported */
5457 sv_catpv(ERRSV, not_safe);
5458 Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
5468 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5469 mod(scalarseq(block), OP_LEAVESUBLV));
5470 block->op_attached = 1;
5473 /* This makes sub {}; work as expected. */
5474 if (block->op_type == OP_STUB) {
5475 OP* const newblock = newSTATEOP(0, NULL, 0);
5477 op_getmad(block,newblock,'B');
5484 block->op_attached = 1;
5485 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5487 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5488 OpREFCNT_set(CvROOT(cv), 1);
5489 CvSTART(cv) = LINKLIST(CvROOT(cv));
5490 CvROOT(cv)->op_next = 0;
5491 CALL_PEEP(CvSTART(cv));
5493 /* now that optimizer has done its work, adjust pad values */
5495 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
5498 assert(!CvCONST(cv));
5499 if (ps && !*ps && op_const_sv(block, cv))
5503 if (name || aname) {
5504 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5505 SV * const sv = newSV(0);
5506 SV * const tmpstr = sv_newmortal();
5507 GV * const db_postponed = gv_fetchpvs("DB::postponed",
5508 GV_ADDMULTI, SVt_PVHV);
5511 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5513 (long)PL_subline, (long)CopLINE(PL_curcop));
5514 gv_efullname3(tmpstr, gv, NULL);
5515 hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0);
5516 hv = GvHVn(db_postponed);
5517 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
5518 CV * const pcv = GvCV(db_postponed);
5524 call_sv((SV*)pcv, G_DISCARD);
5529 if (name && !PL_error_count)
5530 process_special_blocks(name, gv, cv);
5534 PL_copline = NOLINE;
5540 S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
5543 const char *const colon = strrchr(fullname,':');
5544 const char *const name = colon ? colon + 1 : fullname;
5547 if (strEQ(name, "BEGIN")) {
5548 const I32 oldscope = PL_scopestack_ix;
5550 SAVECOPFILE(&PL_compiling);
5551 SAVECOPLINE(&PL_compiling);
5553 DEBUG_x( dump_sub(gv) );
5554 Perl_av_create_and_push(aTHX_ &PL_beginav, (SV*)cv);
5555 GvCV(gv) = 0; /* cv has been hijacked */
5556 call_list(oldscope, PL_beginav);
5558 PL_curcop = &PL_compiling;
5559 CopHINTS_set(&PL_compiling, PL_hints);
5566 if strEQ(name, "END") {
5567 DEBUG_x( dump_sub(gv) );
5568 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, (SV*)cv);
5571 } else if (*name == 'U') {
5572 if (strEQ(name, "UNITCHECK")) {
5573 /* It's never too late to run a unitcheck block */
5574 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, (SV*)cv);
5578 } else if (*name == 'C') {
5579 if (strEQ(name, "CHECK")) {
5580 if (PL_main_start && ckWARN(WARN_VOID))
5581 Perl_warner(aTHX_ packWARN(WARN_VOID),
5582 "Too late to run CHECK block");
5583 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, (SV*)cv);
5587 } else if (*name == 'I') {
5588 if (strEQ(name, "INIT")) {
5589 if (PL_main_start && ckWARN(WARN_VOID))
5590 Perl_warner(aTHX_ packWARN(WARN_VOID),
5591 "Too late to run INIT block");
5592 Perl_av_create_and_push(aTHX_ &PL_initav, (SV*)cv);
5598 DEBUG_x( dump_sub(gv) );
5599 GvCV(gv) = 0; /* cv has been hijacked */
5604 =for apidoc newCONSTSUB
5606 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5607 eligible for inlining at compile-time.
5613 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
5618 const char *const temp_p = CopFILE(PL_curcop);
5619 const STRLEN len = temp_p ? strlen(temp_p) : 0;
5621 SV *const temp_sv = CopFILESV(PL_curcop);
5623 const char *const temp_p = temp_sv ? SvPV_const(temp_sv, len) : NULL;
5625 char *const file = savepvn(temp_p, temp_p ? len : 0);
5629 SAVECOPLINE(PL_curcop);
5630 CopLINE_set(PL_curcop, PL_copline);
5633 PL_hints &= ~HINT_BLOCK_SCOPE;
5636 SAVESPTR(PL_curstash);
5637 SAVECOPSTASH(PL_curcop);
5638 PL_curstash = stash;
5639 CopSTASH_set(PL_curcop,stash);
5642 /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
5643 and so doesn't get free()d. (It's expected to be from the C pre-
5644 processor __FILE__ directive). But we need a dynamically allocated one,
5645 and we need it to get freed. */
5646 cv = newXS_flags(name, const_sv_xsub, file, "", XS_DYNAMIC_FILENAME);
5647 CvXSUBANY(cv).any_ptr = sv;
5653 CopSTASH_free(PL_curcop);
5661 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
5662 const char *const filename, const char *const proto,
5665 CV *cv = newXS(name, subaddr, filename);
5667 if (flags & XS_DYNAMIC_FILENAME) {
5668 /* We need to "make arrangements" (ie cheat) to ensure that the
5669 filename lasts as long as the PVCV we just created, but also doesn't
5671 STRLEN filename_len = strlen(filename);
5672 STRLEN proto_and_file_len = filename_len;
5673 char *proto_and_file;
5677 proto_len = strlen(proto);
5678 proto_and_file_len += proto_len;
5680 Newx(proto_and_file, proto_and_file_len + 1, char);
5681 Copy(proto, proto_and_file, proto_len, char);
5682 Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
5685 proto_and_file = savepvn(filename, filename_len);
5688 /* This gets free()d. :-) */
5689 sv_usepvn_flags((SV*)cv, proto_and_file, proto_and_file_len,
5690 SV_HAS_TRAILING_NUL);
5692 /* This gives us the correct prototype, rather than one with the
5693 file name appended. */
5694 SvCUR_set(cv, proto_len);
5698 CvFILE(cv) = proto_and_file + proto_len;
5700 sv_setpv((SV *)cv, proto);
5706 =for apidoc U||newXS
5708 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
5709 static storage, as it is used directly as CvFILE(), without a copy being made.
5715 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
5718 GV * const gv = gv_fetchpv(name ? name :
5719 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5720 GV_ADDMULTI, SVt_PVCV);
5724 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
5726 if ((cv = (name ? GvCV(gv) : NULL))) {
5728 /* just a cached method */
5732 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5733 /* already defined (or promised) */
5734 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
5735 if (ckWARN(WARN_REDEFINE)) {
5736 GV * const gvcv = CvGV(cv);
5738 HV * const stash = GvSTASH(gvcv);
5740 const char *redefined_name = HvNAME_get(stash);
5741 if ( strEQ(redefined_name,"autouse") ) {
5742 const line_t oldline = CopLINE(PL_curcop);
5743 if (PL_copline != NOLINE)
5744 CopLINE_set(PL_curcop, PL_copline);
5745 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5746 CvCONST(cv) ? "Constant subroutine %s redefined"
5747 : "Subroutine %s redefined"
5749 CopLINE_set(PL_curcop, oldline);
5759 if (cv) /* must reuse cv if autoloaded */
5762 cv = (CV*)newSV_type(SVt_PVCV);
5766 PL_sub_generation++;
5770 (void)gv_fetchfile(filename);
5771 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
5772 an external constant string */
5774 CvXSUB(cv) = subaddr;
5777 process_special_blocks(name, gv, cv);
5789 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5794 OP* pegop = newOP(OP_NULL, 0);
5798 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
5799 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
5801 #ifdef GV_UNIQUE_CHECK
5803 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5807 if ((cv = GvFORM(gv))) {
5808 if (ckWARN(WARN_REDEFINE)) {
5809 const line_t oldline = CopLINE(PL_curcop);
5810 if (PL_copline != NOLINE)
5811 CopLINE_set(PL_curcop, PL_copline);
5812 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5813 o ? "Format %"SVf" redefined"
5814 : "Format STDOUT redefined", SVfARG(cSVOPo->op_sv));
5815 CopLINE_set(PL_curcop, oldline);
5822 CvFILE_set_from_cop(cv, PL_curcop);
5825 pad_tidy(padtidy_FORMAT);
5826 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5827 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5828 OpREFCNT_set(CvROOT(cv), 1);
5829 CvSTART(cv) = LINKLIST(CvROOT(cv));
5830 CvROOT(cv)->op_next = 0;
5831 CALL_PEEP(CvSTART(cv));
5833 op_getmad(o,pegop,'n');
5834 op_getmad_weak(block, pegop, 'b');
5838 PL_copline = NOLINE;
5846 Perl_newANONLIST(pTHX_ OP *o)
5848 return convert(OP_ANONLIST, OPf_SPECIAL, o);
5852 Perl_newANONHASH(pTHX_ OP *o)
5854 return convert(OP_ANONHASH, OPf_SPECIAL, o);
5858 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5860 return newANONATTRSUB(floor, proto, NULL, block);
5864 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5866 return newUNOP(OP_REFGEN, 0,
5867 newSVOP(OP_ANONCODE, 0,
5868 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5872 Perl_oopsAV(pTHX_ OP *o)
5875 switch (o->op_type) {
5877 o->op_type = OP_PADAV;
5878 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5879 return ref(o, OP_RV2AV);
5882 o->op_type = OP_RV2AV;
5883 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5888 if (ckWARN_d(WARN_INTERNAL))
5889 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
5896 Perl_oopsHV(pTHX_ OP *o)
5899 switch (o->op_type) {
5902 o->op_type = OP_PADHV;
5903 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5904 return ref(o, OP_RV2HV);
5908 o->op_type = OP_RV2HV;
5909 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5914 if (ckWARN_d(WARN_INTERNAL))
5915 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
5922 Perl_newAVREF(pTHX_ OP *o)
5925 if (o->op_type == OP_PADANY) {
5926 o->op_type = OP_PADAV;
5927 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5930 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5931 && ckWARN(WARN_DEPRECATED)) {
5932 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5933 "Using an array as a reference is deprecated");
5935 return newUNOP(OP_RV2AV, 0, scalar(o));
5939 Perl_newGVREF(pTHX_ I32 type, OP *o)
5941 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5942 return newUNOP(OP_NULL, 0, o);
5943 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5947 Perl_newHVREF(pTHX_ OP *o)
5950 if (o->op_type == OP_PADANY) {
5951 o->op_type = OP_PADHV;
5952 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5955 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5956 && ckWARN(WARN_DEPRECATED)) {
5957 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5958 "Using a hash as a reference is deprecated");
5960 return newUNOP(OP_RV2HV, 0, scalar(o));
5964 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5966 return newUNOP(OP_RV2CV, flags, scalar(o));
5970 Perl_newSVREF(pTHX_ OP *o)
5973 if (o->op_type == OP_PADANY) {
5974 o->op_type = OP_PADSV;
5975 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5978 return newUNOP(OP_RV2SV, 0, scalar(o));
5981 /* Check routines. See the comments at the top of this file for details
5982 * on when these are called */
5985 Perl_ck_anoncode(pTHX_ OP *o)
5987 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
5989 cSVOPo->op_sv = NULL;
5994 Perl_ck_bitop(pTHX_ OP *o)
5997 #define OP_IS_NUMCOMPARE(op) \
5998 ((op) == OP_LT || (op) == OP_I_LT || \
5999 (op) == OP_GT || (op) == OP_I_GT || \
6000 (op) == OP_LE || (op) == OP_I_LE || \
6001 (op) == OP_GE || (op) == OP_I_GE || \
6002 (op) == OP_EQ || (op) == OP_I_EQ || \
6003 (op) == OP_NE || (op) == OP_I_NE || \
6004 (op) == OP_NCMP || (op) == OP_I_NCMP)
6005 o->op_private = (U8)(PL_hints & HINT_INTEGER);
6006 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
6007 && (o->op_type == OP_BIT_OR
6008 || o->op_type == OP_BIT_AND
6009 || o->op_type == OP_BIT_XOR))
6011 const OP * const left = cBINOPo->op_first;
6012 const OP * const right = left->op_sibling;
6013 if ((OP_IS_NUMCOMPARE(left->op_type) &&
6014 (left->op_flags & OPf_PARENS) == 0) ||
6015 (OP_IS_NUMCOMPARE(right->op_type) &&
6016 (right->op_flags & OPf_PARENS) == 0))
6017 if (ckWARN(WARN_PRECEDENCE))
6018 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
6019 "Possible precedence problem on bitwise %c operator",
6020 o->op_type == OP_BIT_OR ? '|'
6021 : o->op_type == OP_BIT_AND ? '&' : '^'
6028 Perl_ck_concat(pTHX_ OP *o)
6030 const OP * const kid = cUNOPo->op_first;
6031 PERL_UNUSED_CONTEXT;
6032 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
6033 !(kUNOP->op_first->op_flags & OPf_MOD))
6034 o->op_flags |= OPf_STACKED;
6039 Perl_ck_spair(pTHX_ OP *o)
6042 if (o->op_flags & OPf_KIDS) {
6045 const OPCODE type = o->op_type;
6046 o = modkids(ck_fun(o), type);
6047 kid = cUNOPo->op_first;
6048 newop = kUNOP->op_first->op_sibling;
6050 const OPCODE type = newop->op_type;
6051 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
6052 type == OP_PADAV || type == OP_PADHV ||
6053 type == OP_RV2AV || type == OP_RV2HV)
6057 op_getmad(kUNOP->op_first,newop,'K');
6059 op_free(kUNOP->op_first);
6061 kUNOP->op_first = newop;
6063 o->op_ppaddr = PL_ppaddr[++o->op_type];
6068 Perl_ck_delete(pTHX_ OP *o)
6072 if (o->op_flags & OPf_KIDS) {
6073 OP * const kid = cUNOPo->op_first;
6074 switch (kid->op_type) {
6076 o->op_flags |= OPf_SPECIAL;
6079 o->op_private |= OPpSLICE;
6082 o->op_flags |= OPf_SPECIAL;
6087 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
6096 Perl_ck_die(pTHX_ OP *o)
6099 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6105 Perl_ck_eof(pTHX_ OP *o)
6109 if (o->op_flags & OPf_KIDS) {
6110 if (cLISTOPo->op_first->op_type == OP_STUB) {
6112 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
6114 op_getmad(o,newop,'O');
6126 Perl_ck_eval(pTHX_ OP *o)
6129 PL_hints |= HINT_BLOCK_SCOPE;
6130 if (o->op_flags & OPf_KIDS) {
6131 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6134 o->op_flags &= ~OPf_KIDS;
6137 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
6143 cUNOPo->op_first = 0;
6148 NewOp(1101, enter, 1, LOGOP);
6149 enter->op_type = OP_ENTERTRY;
6150 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
6151 enter->op_private = 0;
6153 /* establish postfix order */
6154 enter->op_next = (OP*)enter;
6156 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
6157 o->op_type = OP_LEAVETRY;
6158 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
6159 enter->op_other = o;
6160 op_getmad(oldo,o,'O');
6174 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
6175 op_getmad(oldo,o,'O');
6177 o->op_targ = (PADOFFSET)PL_hints;
6178 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
6179 /* Store a copy of %^H that pp_entereval can pick up.
6180 OPf_SPECIAL flags the opcode as being for this purpose,
6181 so that it in turn will return a copy at every
6183 OP *hhop = newSVOP(OP_CONST, OPf_SPECIAL,
6184 (SV*)Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv)));
6185 cUNOPo->op_first->op_sibling = hhop;
6186 o->op_private |= OPpEVAL_HAS_HH;
6192 Perl_ck_exit(pTHX_ OP *o)
6195 HV * const table = GvHV(PL_hintgv);
6197 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
6198 if (svp && *svp && SvTRUE(*svp))
6199 o->op_private |= OPpEXIT_VMSISH;
6201 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6207 Perl_ck_exec(pTHX_ OP *o)
6209 if (o->op_flags & OPf_STACKED) {
6212 kid = cUNOPo->op_first->op_sibling;
6213 if (kid->op_type == OP_RV2GV)
6222 Perl_ck_exists(pTHX_ OP *o)
6226 if (o->op_flags & OPf_KIDS) {
6227 OP * const kid = cUNOPo->op_first;
6228 if (kid->op_type == OP_ENTERSUB) {
6229 (void) ref(kid, o->op_type);
6230 if (kid->op_type != OP_RV2CV && !PL_error_count)
6231 Perl_croak(aTHX_ "%s argument is not a subroutine name",
6233 o->op_private |= OPpEXISTS_SUB;
6235 else if (kid->op_type == OP_AELEM)
6236 o->op_flags |= OPf_SPECIAL;
6237 else if (kid->op_type != OP_HELEM)
6238 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
6246 Perl_ck_rvconst(pTHX_ register OP *o)
6249 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6251 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6252 if (o->op_type == OP_RV2CV)
6253 o->op_private &= ~1;
6255 if (kid->op_type == OP_CONST) {
6258 SV * const kidsv = kid->op_sv;
6260 /* Is it a constant from cv_const_sv()? */
6261 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
6262 SV * const rsv = SvRV(kidsv);
6263 const svtype type = SvTYPE(rsv);
6264 const char *badtype = NULL;
6266 switch (o->op_type) {
6268 if (type > SVt_PVMG)
6269 badtype = "a SCALAR";
6272 if (type != SVt_PVAV)
6273 badtype = "an ARRAY";
6276 if (type != SVt_PVHV)
6280 if (type != SVt_PVCV)
6285 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
6288 else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
6289 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
6290 /* If this is an access to a stash, disable "strict refs", because
6291 * stashes aren't auto-vivified at compile-time (unless we store
6292 * symbols in them), and we don't want to produce a run-time
6293 * stricture error when auto-vivifying the stash. */
6294 const char *s = SvPV_nolen(kidsv);
6295 const STRLEN l = SvCUR(kidsv);
6296 if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
6297 o->op_private &= ~HINT_STRICT_REFS;
6299 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
6300 const char *badthing;
6301 switch (o->op_type) {
6303 badthing = "a SCALAR";
6306 badthing = "an ARRAY";
6309 badthing = "a HASH";
6317 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
6318 SVfARG(kidsv), badthing);
6321 * This is a little tricky. We only want to add the symbol if we
6322 * didn't add it in the lexer. Otherwise we get duplicate strict
6323 * warnings. But if we didn't add it in the lexer, we must at
6324 * least pretend like we wanted to add it even if it existed before,
6325 * or we get possible typo warnings. OPpCONST_ENTERED says
6326 * whether the lexer already added THIS instance of this symbol.
6328 iscv = (o->op_type == OP_RV2CV) * 2;
6330 gv = gv_fetchsv(kidsv,
6331 iscv | !(kid->op_private & OPpCONST_ENTERED),
6334 : o->op_type == OP_RV2SV
6336 : o->op_type == OP_RV2AV
6338 : o->op_type == OP_RV2HV
6341 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
6343 kid->op_type = OP_GV;
6344 SvREFCNT_dec(kid->op_sv);
6346 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
6347 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
6348 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
6350 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc_simple_NN(gv));
6352 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
6354 kid->op_private = 0;
6355 kid->op_ppaddr = PL_ppaddr[OP_GV];
6362 Perl_ck_ftst(pTHX_ OP *o)
6365 const I32 type = o->op_type;
6367 if (o->op_flags & OPf_REF) {
6370 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
6371 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6372 const OPCODE kidtype = kid->op_type;
6374 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6375 OP * const newop = newGVOP(type, OPf_REF,
6376 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
6378 op_getmad(o,newop,'O');
6384 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o))
6385 o->op_private |= OPpFT_ACCESS;
6386 if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst)
6387 && kidtype != OP_STAT && kidtype != OP_LSTAT)
6388 o->op_private |= OPpFT_STACKED;
6396 if (type == OP_FTTTY)
6397 o = newGVOP(type, OPf_REF, PL_stdingv);
6399 o = newUNOP(type, 0, newDEFSVOP());
6400 op_getmad(oldo,o,'O');
6406 Perl_ck_fun(pTHX_ OP *o)
6409 const int type = o->op_type;
6410 register I32 oa = PL_opargs[type] >> OASHIFT;
6412 if (o->op_flags & OPf_STACKED) {
6413 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
6416 return no_fh_allowed(o);
6419 if (o->op_flags & OPf_KIDS) {
6420 OP **tokid = &cLISTOPo->op_first;
6421 register OP *kid = cLISTOPo->op_first;
6425 if (kid->op_type == OP_PUSHMARK ||
6426 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
6428 tokid = &kid->op_sibling;
6429 kid = kid->op_sibling;
6431 if (!kid && PL_opargs[type] & OA_DEFGV)
6432 *tokid = kid = newDEFSVOP();
6436 sibl = kid->op_sibling;
6438 if (!sibl && kid->op_type == OP_STUB) {
6445 /* list seen where single (scalar) arg expected? */
6446 if (numargs == 1 && !(oa >> 4)
6447 && kid->op_type == OP_LIST && type != OP_SCALAR)
6449 return too_many_arguments(o,PL_op_desc[type]);
6462 if ((type == OP_PUSH || type == OP_UNSHIFT)
6463 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
6464 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6465 "Useless use of %s with no values",
6468 if (kid->op_type == OP_CONST &&
6469 (kid->op_private & OPpCONST_BARE))
6471 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
6472 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
6473 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6474 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6475 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
6476 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6478 op_getmad(kid,newop,'K');
6483 kid->op_sibling = sibl;
6486 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
6487 bad_type(numargs, "array", PL_op_desc[type], kid);
6491 if (kid->op_type == OP_CONST &&
6492 (kid->op_private & OPpCONST_BARE))
6494 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
6495 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
6496 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6497 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6498 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
6499 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6501 op_getmad(kid,newop,'K');
6506 kid->op_sibling = sibl;
6509 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
6510 bad_type(numargs, "hash", PL_op_desc[type], kid);
6515 OP * const newop = newUNOP(OP_NULL, 0, kid);
6516 kid->op_sibling = 0;
6518 newop->op_next = newop;
6520 kid->op_sibling = sibl;
6525 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
6526 if (kid->op_type == OP_CONST &&
6527 (kid->op_private & OPpCONST_BARE))
6529 OP * const newop = newGVOP(OP_GV, 0,
6530 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
6531 if (!(o->op_private & 1) && /* if not unop */
6532 kid == cLISTOPo->op_last)
6533 cLISTOPo->op_last = newop;
6535 op_getmad(kid,newop,'K');
6541 else if (kid->op_type == OP_READLINE) {
6542 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
6543 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
6546 I32 flags = OPf_SPECIAL;
6550 /* is this op a FH constructor? */
6551 if (is_handle_constructor(o,numargs)) {
6552 const char *name = NULL;
6556 /* Set a flag to tell rv2gv to vivify
6557 * need to "prove" flag does not mean something
6558 * else already - NI-S 1999/05/07
6561 if (kid->op_type == OP_PADSV) {
6563 = PAD_COMPNAME_SV(kid->op_targ);
6564 name = SvPV_const(namesv, len);
6566 else if (kid->op_type == OP_RV2SV
6567 && kUNOP->op_first->op_type == OP_GV)
6569 GV * const gv = cGVOPx_gv(kUNOP->op_first);
6571 len = GvNAMELEN(gv);
6573 else if (kid->op_type == OP_AELEM
6574 || kid->op_type == OP_HELEM)
6577 OP *op = ((BINOP*)kid)->op_first;
6581 const char * const a =
6582 kid->op_type == OP_AELEM ?
6584 if (((op->op_type == OP_RV2AV) ||
6585 (op->op_type == OP_RV2HV)) &&
6586 (firstop = ((UNOP*)op)->op_first) &&
6587 (firstop->op_type == OP_GV)) {
6588 /* packagevar $a[] or $h{} */
6589 GV * const gv = cGVOPx_gv(firstop);
6597 else if (op->op_type == OP_PADAV
6598 || op->op_type == OP_PADHV) {
6599 /* lexicalvar $a[] or $h{} */
6600 const char * const padname =
6601 PAD_COMPNAME_PV(op->op_targ);
6610 name = SvPV_const(tmpstr, len);
6615 name = "__ANONIO__";
6622 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
6623 namesv = PAD_SVl(targ);
6624 SvUPGRADE(namesv, SVt_PV);
6626 sv_setpvn(namesv, "$", 1);
6627 sv_catpvn(namesv, name, len);
6630 kid->op_sibling = 0;
6631 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
6632 kid->op_targ = targ;
6633 kid->op_private |= priv;
6635 kid->op_sibling = sibl;
6641 mod(scalar(kid), type);
6645 tokid = &kid->op_sibling;
6646 kid = kid->op_sibling;
6649 if (kid && kid->op_type != OP_STUB)
6650 return too_many_arguments(o,OP_DESC(o));
6651 o->op_private |= numargs;
6653 /* FIXME - should the numargs move as for the PERL_MAD case? */
6654 o->op_private |= numargs;
6656 return too_many_arguments(o,OP_DESC(o));
6660 else if (PL_opargs[type] & OA_DEFGV) {
6662 OP *newop = newUNOP(type, 0, newDEFSVOP());
6663 op_getmad(o,newop,'O');
6666 /* Ordering of these two is important to keep f_map.t passing. */
6668 return newUNOP(type, 0, newDEFSVOP());
6673 while (oa & OA_OPTIONAL)
6675 if (oa && oa != OA_LIST)
6676 return too_few_arguments(o,OP_DESC(o));
6682 Perl_ck_glob(pTHX_ OP *o)
6688 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
6689 append_elem(OP_GLOB, o, newDEFSVOP());
6691 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
6692 && GvCVu(gv) && GvIMPORTED_CV(gv)))
6694 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6697 #if !defined(PERL_EXTERNAL_GLOB)
6698 /* XXX this can be tightened up and made more failsafe. */
6699 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
6702 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
6703 newSVpvs("File::Glob"), NULL, NULL, NULL);
6704 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6705 glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
6706 GvCV(gv) = GvCV(glob_gv);
6707 SvREFCNT_inc_void((SV*)GvCV(gv));
6708 GvIMPORTED_CV_on(gv);
6711 #endif /* PERL_EXTERNAL_GLOB */
6713 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6714 append_elem(OP_GLOB, o,
6715 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
6716 o->op_type = OP_LIST;
6717 o->op_ppaddr = PL_ppaddr[OP_LIST];
6718 cLISTOPo->op_first->op_type = OP_PUSHMARK;
6719 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
6720 cLISTOPo->op_first->op_targ = 0;
6721 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
6722 append_elem(OP_LIST, o,
6723 scalar(newUNOP(OP_RV2CV, 0,
6724 newGVOP(OP_GV, 0, gv)))));
6725 o = newUNOP(OP_NULL, 0, ck_subr(o));
6726 o->op_targ = OP_GLOB; /* hint at what it used to be */
6729 gv = newGVgen("main");
6731 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
6737 Perl_ck_grep(pTHX_ OP *o)
6742 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
6745 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
6746 /* don't allocate gwop here, as we may leak it if PL_error_count > 0 */
6748 if (o->op_flags & OPf_STACKED) {
6751 kid = cLISTOPo->op_first->op_sibling;
6752 if (!cUNOPx(kid)->op_next)
6753 Perl_croak(aTHX_ "panic: ck_grep");
6754 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
6757 NewOp(1101, gwop, 1, LOGOP);
6758 kid->op_next = (OP*)gwop;
6759 o->op_flags &= ~OPf_STACKED;
6761 kid = cLISTOPo->op_first->op_sibling;
6762 if (type == OP_MAPWHILE)
6769 kid = cLISTOPo->op_first->op_sibling;
6770 if (kid->op_type != OP_NULL)
6771 Perl_croak(aTHX_ "panic: ck_grep");
6772 kid = kUNOP->op_first;
6775 NewOp(1101, gwop, 1, LOGOP);
6776 gwop->op_type = type;
6777 gwop->op_ppaddr = PL_ppaddr[type];
6778 gwop->op_first = listkids(o);
6779 gwop->op_flags |= OPf_KIDS;
6780 gwop->op_other = LINKLIST(kid);
6781 kid->op_next = (OP*)gwop;
6782 offset = pad_findmy("$_");
6783 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
6784 o->op_private = gwop->op_private = 0;
6785 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
6788 o->op_private = gwop->op_private = OPpGREP_LEX;
6789 gwop->op_targ = o->op_targ = offset;
6792 kid = cLISTOPo->op_first->op_sibling;
6793 if (!kid || !kid->op_sibling)
6794 return too_few_arguments(o,OP_DESC(o));
6795 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
6796 mod(kid, OP_GREPSTART);
6802 Perl_ck_index(pTHX_ OP *o)
6804 if (o->op_flags & OPf_KIDS) {
6805 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6807 kid = kid->op_sibling; /* get past "big" */
6808 if (kid && kid->op_type == OP_CONST)
6809 fbm_compile(((SVOP*)kid)->op_sv, 0);
6815 Perl_ck_lengthconst(pTHX_ OP *o)
6817 /* XXX length optimization goes here */
6822 Perl_ck_lfun(pTHX_ OP *o)
6824 const OPCODE type = o->op_type;
6825 return modkids(ck_fun(o), type);
6829 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
6831 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
6832 switch (cUNOPo->op_first->op_type) {
6834 /* This is needed for
6835 if (defined %stash::)
6836 to work. Do not break Tk.
6838 break; /* Globals via GV can be undef */
6840 case OP_AASSIGN: /* Is this a good idea? */
6841 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6842 "defined(@array) is deprecated");
6843 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6844 "\t(Maybe you should just omit the defined()?)\n");
6847 /* This is needed for
6848 if (defined %stash::)
6849 to work. Do not break Tk.
6851 break; /* Globals via GV can be undef */
6853 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6854 "defined(%%hash) is deprecated");
6855 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6856 "\t(Maybe you should just omit the defined()?)\n");
6867 Perl_ck_readline(pTHX_ OP *o)
6869 if (!(o->op_flags & OPf_KIDS)) {
6871 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
6873 op_getmad(o,newop,'O');
6883 Perl_ck_rfun(pTHX_ OP *o)
6885 const OPCODE type = o->op_type;
6886 return refkids(ck_fun(o), type);
6890 Perl_ck_listiob(pTHX_ OP *o)
6894 kid = cLISTOPo->op_first;
6897 kid = cLISTOPo->op_first;
6899 if (kid->op_type == OP_PUSHMARK)
6900 kid = kid->op_sibling;
6901 if (kid && o->op_flags & OPf_STACKED)
6902 kid = kid->op_sibling;
6903 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6904 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6905 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6906 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6907 cLISTOPo->op_first->op_sibling = kid;
6908 cLISTOPo->op_last = kid;
6909 kid = kid->op_sibling;
6914 append_elem(o->op_type, o, newDEFSVOP());
6920 Perl_ck_smartmatch(pTHX_ OP *o)
6923 if (0 == (o->op_flags & OPf_SPECIAL)) {
6924 OP *first = cBINOPo->op_first;
6925 OP *second = first->op_sibling;
6927 /* Implicitly take a reference to an array or hash */
6928 first->op_sibling = NULL;
6929 first = cBINOPo->op_first = ref_array_or_hash(first);
6930 second = first->op_sibling = ref_array_or_hash(second);
6932 /* Implicitly take a reference to a regular expression */
6933 if (first->op_type == OP_MATCH) {
6934 first->op_type = OP_QR;
6935 first->op_ppaddr = PL_ppaddr[OP_QR];
6937 if (second->op_type == OP_MATCH) {
6938 second->op_type = OP_QR;
6939 second->op_ppaddr = PL_ppaddr[OP_QR];
6948 Perl_ck_sassign(pTHX_ OP *o)
6950 OP * const kid = cLISTOPo->op_first;
6951 /* has a disposable target? */
6952 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6953 && !(kid->op_flags & OPf_STACKED)
6954 /* Cannot steal the second time! */
6955 && !(kid->op_private & OPpTARGET_MY))
6957 OP * const kkid = kid->op_sibling;
6959 /* Can just relocate the target. */
6960 if (kkid && kkid->op_type == OP_PADSV
6961 && !(kkid->op_private & OPpLVAL_INTRO))
6963 kid->op_targ = kkid->op_targ;
6965 /* Now we do not need PADSV and SASSIGN. */
6966 kid->op_sibling = o->op_sibling; /* NULL */
6967 cLISTOPo->op_first = NULL;
6969 op_getmad(o,kid,'O');
6970 op_getmad(kkid,kid,'M');
6975 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6979 if (kid->op_sibling) {
6980 OP *kkid = kid->op_sibling;
6981 if (kkid->op_type == OP_PADSV
6982 && (kkid->op_private & OPpLVAL_INTRO)
6983 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
6984 o->op_private |= OPpASSIGN_STATE;
6985 /* hijacking PADSTALE for uninitialized state variables */
6986 SvPADSTALE_on(PAD_SVl(kkid->op_targ));
6993 Perl_ck_match(pTHX_ OP *o)
6996 if (o->op_type != OP_QR && PL_compcv) {
6997 const PADOFFSET offset = pad_findmy("$_");
6998 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
6999 o->op_targ = offset;
7000 o->op_private |= OPpTARGET_MY;
7003 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
7004 o->op_private |= OPpRUNTIME;
7009 Perl_ck_method(pTHX_ OP *o)
7011 OP * const kid = cUNOPo->op_first;
7012 if (kid->op_type == OP_CONST) {
7013 SV* sv = kSVOP->op_sv;
7014 const char * const method = SvPVX_const(sv);
7015 if (!(strchr(method, ':') || strchr(method, '\''))) {
7017 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
7018 sv = newSVpvn_share(method, SvCUR(sv), 0);
7021 kSVOP->op_sv = NULL;
7023 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
7025 op_getmad(o,cmop,'O');
7036 Perl_ck_null(pTHX_ OP *o)
7038 PERL_UNUSED_CONTEXT;
7043 Perl_ck_open(pTHX_ OP *o)
7046 HV * const table = GvHV(PL_hintgv);
7048 SV **svp = hv_fetchs(table, "open_IN", FALSE);
7050 const I32 mode = mode_from_discipline(*svp);
7051 if (mode & O_BINARY)
7052 o->op_private |= OPpOPEN_IN_RAW;
7053 else if (mode & O_TEXT)
7054 o->op_private |= OPpOPEN_IN_CRLF;
7057 svp = hv_fetchs(table, "open_OUT", FALSE);
7059 const I32 mode = mode_from_discipline(*svp);
7060 if (mode & O_BINARY)
7061 o->op_private |= OPpOPEN_OUT_RAW;
7062 else if (mode & O_TEXT)
7063 o->op_private |= OPpOPEN_OUT_CRLF;
7066 if (o->op_type == OP_BACKTICK) {
7067 if (!(o->op_flags & OPf_KIDS)) {
7068 OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
7070 op_getmad(o,newop,'O');
7079 /* In case of three-arg dup open remove strictness
7080 * from the last arg if it is a bareword. */
7081 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
7082 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
7086 if ((last->op_type == OP_CONST) && /* The bareword. */
7087 (last->op_private & OPpCONST_BARE) &&
7088 (last->op_private & OPpCONST_STRICT) &&
7089 (oa = first->op_sibling) && /* The fh. */
7090 (oa = oa->op_sibling) && /* The mode. */
7091 (oa->op_type == OP_CONST) &&
7092 SvPOK(((SVOP*)oa)->op_sv) &&
7093 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
7094 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
7095 (last == oa->op_sibling)) /* The bareword. */
7096 last->op_private &= ~OPpCONST_STRICT;
7102 Perl_ck_repeat(pTHX_ OP *o)
7104 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
7105 o->op_private |= OPpREPEAT_DOLIST;
7106 cBINOPo->op_first = force_list(cBINOPo->op_first);
7114 Perl_ck_require(pTHX_ OP *o)
7119 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
7120 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7122 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
7123 SV * const sv = kid->op_sv;
7124 U32 was_readonly = SvREADONLY(sv);
7129 sv_force_normal_flags(sv, 0);
7130 assert(!SvREADONLY(sv));
7137 for (s = SvPVX(sv); *s; s++) {
7138 if (*s == ':' && s[1] == ':') {
7139 const STRLEN len = strlen(s+2)+1;
7141 Move(s+2, s+1, len, char);
7142 SvCUR_set(sv, SvCUR(sv) - 1);
7145 sv_catpvs(sv, ".pm");
7146 SvFLAGS(sv) |= was_readonly;
7150 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
7151 /* handle override, if any */
7152 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
7153 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7154 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
7155 gv = gvp ? *gvp : NULL;
7159 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7160 OP * const kid = cUNOPo->op_first;
7163 cUNOPo->op_first = 0;
7167 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
7168 append_elem(OP_LIST, kid,
7169 scalar(newUNOP(OP_RV2CV, 0,
7172 op_getmad(o,newop,'O');
7180 Perl_ck_return(pTHX_ OP *o)
7183 if (CvLVALUE(PL_compcv)) {
7185 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
7186 mod(kid, OP_LEAVESUBLV);
7192 Perl_ck_select(pTHX_ OP *o)
7196 if (o->op_flags & OPf_KIDS) {
7197 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7198 if (kid && kid->op_sibling) {
7199 o->op_type = OP_SSELECT;
7200 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
7202 return fold_constants(o);
7206 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7207 if (kid && kid->op_type == OP_RV2GV)
7208 kid->op_private &= ~HINT_STRICT_REFS;
7213 Perl_ck_shift(pTHX_ OP *o)
7216 const I32 type = o->op_type;
7218 if (!(o->op_flags & OPf_KIDS)) {
7220 /* FIXME - this can be refactored to reduce code in #ifdefs */
7222 OP * const oldo = o;
7226 argop = newUNOP(OP_RV2AV, 0,
7227 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
7229 o = newUNOP(type, 0, scalar(argop));
7230 op_getmad(oldo,o,'O');
7233 return newUNOP(type, 0, scalar(argop));
7236 return scalar(modkids(ck_fun(o), type));
7240 Perl_ck_sort(pTHX_ OP *o)
7245 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
7246 HV * const hinthv = GvHV(PL_hintgv);
7248 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
7250 const I32 sorthints = (I32)SvIV(*svp);
7251 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
7252 o->op_private |= OPpSORT_QSORT;
7253 if ((sorthints & HINT_SORT_STABLE) != 0)
7254 o->op_private |= OPpSORT_STABLE;
7259 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
7261 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7262 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
7264 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
7266 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
7268 if (kid->op_type == OP_SCOPE) {
7272 else if (kid->op_type == OP_LEAVE) {
7273 if (o->op_type == OP_SORT) {
7274 op_null(kid); /* wipe out leave */
7277 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
7278 if (k->op_next == kid)
7280 /* don't descend into loops */
7281 else if (k->op_type == OP_ENTERLOOP
7282 || k->op_type == OP_ENTERITER)
7284 k = cLOOPx(k)->op_lastop;
7289 kid->op_next = 0; /* just disconnect the leave */
7290 k = kLISTOP->op_first;
7295 if (o->op_type == OP_SORT) {
7296 /* provide scalar context for comparison function/block */
7302 o->op_flags |= OPf_SPECIAL;
7304 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
7307 firstkid = firstkid->op_sibling;
7310 /* provide list context for arguments */
7311 if (o->op_type == OP_SORT)
7318 S_simplify_sort(pTHX_ OP *o)
7321 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7326 if (!(o->op_flags & OPf_STACKED))
7328 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7329 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
7330 kid = kUNOP->op_first; /* get past null */
7331 if (kid->op_type != OP_SCOPE)
7333 kid = kLISTOP->op_last; /* get past scope */
7334 switch(kid->op_type) {
7342 k = kid; /* remember this node*/
7343 if (kBINOP->op_first->op_type != OP_RV2SV)
7345 kid = kBINOP->op_first; /* get past cmp */
7346 if (kUNOP->op_first->op_type != OP_GV)
7348 kid = kUNOP->op_first; /* get past rv2sv */
7350 if (GvSTASH(gv) != PL_curstash)
7352 gvname = GvNAME(gv);
7353 if (*gvname == 'a' && gvname[1] == '\0')
7355 else if (*gvname == 'b' && gvname[1] == '\0')
7360 kid = k; /* back to cmp */
7361 if (kBINOP->op_last->op_type != OP_RV2SV)
7363 kid = kBINOP->op_last; /* down to 2nd arg */
7364 if (kUNOP->op_first->op_type != OP_GV)
7366 kid = kUNOP->op_first; /* get past rv2sv */
7368 if (GvSTASH(gv) != PL_curstash)
7370 gvname = GvNAME(gv);
7372 ? !(*gvname == 'a' && gvname[1] == '\0')
7373 : !(*gvname == 'b' && gvname[1] == '\0'))
7375 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
7377 o->op_private |= OPpSORT_DESCEND;
7378 if (k->op_type == OP_NCMP)
7379 o->op_private |= OPpSORT_NUMERIC;
7380 if (k->op_type == OP_I_NCMP)
7381 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
7382 kid = cLISTOPo->op_first->op_sibling;
7383 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
7385 op_getmad(kid,o,'S'); /* then delete it */
7387 op_free(kid); /* then delete it */
7392 Perl_ck_split(pTHX_ OP *o)
7397 if (o->op_flags & OPf_STACKED)
7398 return no_fh_allowed(o);
7400 kid = cLISTOPo->op_first;
7401 if (kid->op_type != OP_NULL)
7402 Perl_croak(aTHX_ "panic: ck_split");
7403 kid = kid->op_sibling;
7404 op_free(cLISTOPo->op_first);
7405 cLISTOPo->op_first = kid;
7407 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
7408 cLISTOPo->op_last = kid; /* There was only one element previously */
7411 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
7412 OP * const sibl = kid->op_sibling;
7413 kid->op_sibling = 0;
7414 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
7415 if (cLISTOPo->op_first == cLISTOPo->op_last)
7416 cLISTOPo->op_last = kid;
7417 cLISTOPo->op_first = kid;
7418 kid->op_sibling = sibl;
7421 kid->op_type = OP_PUSHRE;
7422 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
7424 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
7425 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
7426 "Use of /g modifier is meaningless in split");
7429 if (!kid->op_sibling)
7430 append_elem(OP_SPLIT, o, newDEFSVOP());
7432 kid = kid->op_sibling;
7435 if (!kid->op_sibling)
7436 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
7437 assert(kid->op_sibling);
7439 kid = kid->op_sibling;
7442 if (kid->op_sibling)
7443 return too_many_arguments(o,OP_DESC(o));
7449 Perl_ck_join(pTHX_ OP *o)
7451 const OP * const kid = cLISTOPo->op_first->op_sibling;
7452 if (kid && kid->op_type == OP_MATCH) {
7453 if (ckWARN(WARN_SYNTAX)) {
7454 const REGEXP *re = PM_GETRE(kPMOP);
7455 const char *pmstr = re ? re->precomp : "STRING";
7456 const STRLEN len = re ? re->prelen : 6;
7457 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7458 "/%.*s/ should probably be written as \"%.*s\"",
7459 (int)len, pmstr, (int)len, pmstr);
7466 Perl_ck_subr(pTHX_ OP *o)
7469 OP *prev = ((cUNOPo->op_first->op_sibling)
7470 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
7471 OP *o2 = prev->op_sibling;
7473 const char *proto = NULL;
7474 const char *proto_end = NULL;
7479 I32 contextclass = 0;
7480 const char *e = NULL;
7483 o->op_private |= OPpENTERSUB_HASTARG;
7484 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
7485 if (cvop->op_type == OP_RV2CV) {
7487 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
7488 op_null(cvop); /* disable rv2cv */
7489 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
7490 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
7491 GV *gv = cGVOPx_gv(tmpop);
7494 tmpop->op_private |= OPpEARLY_CV;
7498 namegv = CvANON(cv) ? gv : CvGV(cv);
7499 proto = SvPV((SV*)cv, len);
7500 proto_end = proto + len;
7502 if (CvASSERTION(cv)) {
7503 U32 asserthints = 0;
7504 HV *const hinthv = GvHV(PL_hintgv);
7506 SV **svp = hv_fetchs(hinthv, "assertions", FALSE);
7508 asserthints = SvUV(*svp);
7510 if (asserthints & HINT_ASSERTING) {
7511 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
7512 o->op_private |= OPpENTERSUB_DB;
7516 if (!(asserthints & HINT_ASSERTIONSSEEN) && ckWARN(WARN_ASSERTIONS)) {
7517 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
7518 "Impossible to activate assertion call");
7525 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7526 if (o2->op_type == OP_CONST)
7527 o2->op_private &= ~OPpCONST_STRICT;
7528 else if (o2->op_type == OP_LIST) {
7529 OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
7530 if (sib && sib->op_type == OP_CONST)
7531 sib->op_private &= ~OPpCONST_STRICT;
7534 o->op_private |= (PL_hints & HINT_STRICT_REFS);
7535 if (PERLDB_SUB && PL_curstash != PL_debstash)
7536 o->op_private |= OPpENTERSUB_DB;
7537 while (o2 != cvop) {
7539 if (PL_madskills && o2->op_type == OP_STUB) {
7540 o2 = o2->op_sibling;
7543 if (PL_madskills && o2->op_type == OP_NULL)
7544 o3 = ((UNOP*)o2)->op_first;
7548 if (proto >= proto_end)
7549 return too_many_arguments(o, gv_ename(namegv));
7557 /* _ must be at the end */
7558 if (proto[1] && proto[1] != ';')
7573 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
7575 arg == 1 ? "block or sub {}" : "sub {}",
7576 gv_ename(namegv), o3);
7579 /* '*' allows any scalar type, including bareword */
7582 if (o3->op_type == OP_RV2GV)
7583 goto wrapref; /* autoconvert GLOB -> GLOBref */
7584 else if (o3->op_type == OP_CONST)
7585 o3->op_private &= ~OPpCONST_STRICT;
7586 else if (o3->op_type == OP_ENTERSUB) {
7587 /* accidental subroutine, revert to bareword */
7588 OP *gvop = ((UNOP*)o3)->op_first;
7589 if (gvop && gvop->op_type == OP_NULL) {
7590 gvop = ((UNOP*)gvop)->op_first;
7592 for (; gvop->op_sibling; gvop = gvop->op_sibling)
7595 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
7596 (gvop = ((UNOP*)gvop)->op_first) &&
7597 gvop->op_type == OP_GV)
7599 GV * const gv = cGVOPx_gv(gvop);
7600 OP * const sibling = o2->op_sibling;
7601 SV * const n = newSVpvs("");
7603 OP * const oldo2 = o2;
7607 gv_fullname4(n, gv, "", FALSE);
7608 o2 = newSVOP(OP_CONST, 0, n);
7609 op_getmad(oldo2,o2,'O');
7610 prev->op_sibling = o2;
7611 o2->op_sibling = sibling;
7627 if (contextclass++ == 0) {
7628 e = strchr(proto, ']');
7629 if (!e || e == proto)
7638 const char *p = proto;
7639 const char *const end = proto;
7641 while (*--p != '[');
7642 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
7644 gv_ename(namegv), o3);
7649 if (o3->op_type == OP_RV2GV)
7652 bad_type(arg, "symbol", gv_ename(namegv), o3);
7655 if (o3->op_type == OP_ENTERSUB)
7658 bad_type(arg, "subroutine entry", gv_ename(namegv),
7662 if (o3->op_type == OP_RV2SV ||
7663 o3->op_type == OP_PADSV ||
7664 o3->op_type == OP_HELEM ||
7665 o3->op_type == OP_AELEM)
7668 bad_type(arg, "scalar", gv_ename(namegv), o3);
7671 if (o3->op_type == OP_RV2AV ||
7672 o3->op_type == OP_PADAV)
7675 bad_type(arg, "array", gv_ename(namegv), o3);
7678 if (o3->op_type == OP_RV2HV ||
7679 o3->op_type == OP_PADHV)
7682 bad_type(arg, "hash", gv_ename(namegv), o3);
7687 OP* const sib = kid->op_sibling;
7688 kid->op_sibling = 0;
7689 o2 = newUNOP(OP_REFGEN, 0, kid);
7690 o2->op_sibling = sib;
7691 prev->op_sibling = o2;
7693 if (contextclass && e) {
7708 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
7709 gv_ename(namegv), SVfARG(cv));
7714 mod(o2, OP_ENTERSUB);
7716 o2 = o2->op_sibling;
7718 if (o2 == cvop && proto && *proto == '_') {
7719 /* generate an access to $_ */
7721 o2->op_sibling = prev->op_sibling;
7722 prev->op_sibling = o2; /* instead of cvop */
7724 if (proto && !optional && proto_end > proto &&
7725 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
7726 return too_few_arguments(o, gv_ename(namegv));
7729 OP * const oldo = o;
7733 o=newSVOP(OP_CONST, 0, newSViv(0));
7734 op_getmad(oldo,o,'O');
7740 Perl_ck_svconst(pTHX_ OP *o)
7742 PERL_UNUSED_CONTEXT;
7743 SvREADONLY_on(cSVOPo->op_sv);
7748 Perl_ck_chdir(pTHX_ OP *o)
7750 if (o->op_flags & OPf_KIDS) {
7751 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7753 if (kid && kid->op_type == OP_CONST &&
7754 (kid->op_private & OPpCONST_BARE))
7756 o->op_flags |= OPf_SPECIAL;
7757 kid->op_private &= ~OPpCONST_STRICT;
7764 Perl_ck_trunc(pTHX_ OP *o)
7766 if (o->op_flags & OPf_KIDS) {
7767 SVOP *kid = (SVOP*)cUNOPo->op_first;
7769 if (kid->op_type == OP_NULL)
7770 kid = (SVOP*)kid->op_sibling;
7771 if (kid && kid->op_type == OP_CONST &&
7772 (kid->op_private & OPpCONST_BARE))
7774 o->op_flags |= OPf_SPECIAL;
7775 kid->op_private &= ~OPpCONST_STRICT;
7782 Perl_ck_unpack(pTHX_ OP *o)
7784 OP *kid = cLISTOPo->op_first;
7785 if (kid->op_sibling) {
7786 kid = kid->op_sibling;
7787 if (!kid->op_sibling)
7788 kid->op_sibling = newDEFSVOP();
7794 Perl_ck_substr(pTHX_ OP *o)
7797 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
7798 OP *kid = cLISTOPo->op_first;
7800 if (kid->op_type == OP_NULL)
7801 kid = kid->op_sibling;
7803 kid->op_flags |= OPf_MOD;
7809 /* A peephole optimizer. We visit the ops in the order they're to execute.
7810 * See the comments at the top of this file for more details about when
7811 * peep() is called */
7814 Perl_peep(pTHX_ register OP *o)
7817 register OP* oldop = NULL;
7819 if (!o || o->op_opt)
7823 SAVEVPTR(PL_curcop);
7824 for (; o; o = o->op_next) {
7828 switch (o->op_type) {
7832 PL_curcop = ((COP*)o); /* for warnings */
7837 if (cSVOPo->op_private & OPpCONST_STRICT)
7838 no_bareword_allowed(o);
7840 case OP_METHOD_NAMED:
7841 /* Relocate sv to the pad for thread safety.
7842 * Despite being a "constant", the SV is written to,
7843 * for reference counts, sv_upgrade() etc. */
7845 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
7846 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
7847 /* If op_sv is already a PADTMP then it is being used by
7848 * some pad, so make a copy. */
7849 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
7850 SvREADONLY_on(PAD_SVl(ix));
7851 SvREFCNT_dec(cSVOPo->op_sv);
7853 else if (o->op_type == OP_CONST
7854 && cSVOPo->op_sv == &PL_sv_undef) {
7855 /* PL_sv_undef is hack - it's unsafe to store it in the
7856 AV that is the pad, because av_fetch treats values of
7857 PL_sv_undef as a "free" AV entry and will merrily
7858 replace them with a new SV, causing pad_alloc to think
7859 that this pad slot is free. (When, clearly, it is not)
7861 SvOK_off(PAD_SVl(ix));
7862 SvPADTMP_on(PAD_SVl(ix));
7863 SvREADONLY_on(PAD_SVl(ix));
7866 SvREFCNT_dec(PAD_SVl(ix));
7867 SvPADTMP_on(cSVOPo->op_sv);
7868 PAD_SETSV(ix, cSVOPo->op_sv);
7869 /* XXX I don't know how this isn't readonly already. */
7870 SvREADONLY_on(PAD_SVl(ix));
7872 cSVOPo->op_sv = NULL;
7880 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
7881 if (o->op_next->op_private & OPpTARGET_MY) {
7882 if (o->op_flags & OPf_STACKED) /* chained concats */
7883 goto ignore_optimization;
7885 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
7886 o->op_targ = o->op_next->op_targ;
7887 o->op_next->op_targ = 0;
7888 o->op_private |= OPpTARGET_MY;
7891 op_null(o->op_next);
7893 ignore_optimization:
7897 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
7899 break; /* Scalar stub must produce undef. List stub is noop */
7903 if (o->op_targ == OP_NEXTSTATE
7904 || o->op_targ == OP_DBSTATE
7905 || o->op_targ == OP_SETSTATE)
7907 PL_curcop = ((COP*)o);
7909 /* XXX: We avoid setting op_seq here to prevent later calls
7910 to peep() from mistakenly concluding that optimisation
7911 has already occurred. This doesn't fix the real problem,
7912 though (See 20010220.007). AMS 20010719 */
7913 /* op_seq functionality is now replaced by op_opt */
7914 if (oldop && o->op_next) {
7915 oldop->op_next = o->op_next;
7923 if (oldop && o->op_next) {
7924 oldop->op_next = o->op_next;
7932 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
7933 OP* const pop = (o->op_type == OP_PADAV) ?
7934 o->op_next : o->op_next->op_next;
7936 if (pop && pop->op_type == OP_CONST &&
7937 ((PL_op = pop->op_next)) &&
7938 pop->op_next->op_type == OP_AELEM &&
7939 !(pop->op_next->op_private &
7940 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
7941 (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
7946 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
7947 no_bareword_allowed(pop);
7948 if (o->op_type == OP_GV)
7949 op_null(o->op_next);
7950 op_null(pop->op_next);
7952 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
7953 o->op_next = pop->op_next->op_next;
7954 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
7955 o->op_private = (U8)i;
7956 if (o->op_type == OP_GV) {
7961 o->op_flags |= OPf_SPECIAL;
7962 o->op_type = OP_AELEMFAST;
7968 if (o->op_next->op_type == OP_RV2SV) {
7969 if (!(o->op_next->op_private & OPpDEREF)) {
7970 op_null(o->op_next);
7971 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
7973 o->op_next = o->op_next->op_next;
7974 o->op_type = OP_GVSV;
7975 o->op_ppaddr = PL_ppaddr[OP_GVSV];
7978 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
7979 GV * const gv = cGVOPo_gv;
7980 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
7981 /* XXX could check prototype here instead of just carping */
7982 SV * const sv = sv_newmortal();
7983 gv_efullname3(sv, gv, NULL);
7984 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
7985 "%"SVf"() called too early to check prototype",
7989 else if (o->op_next->op_type == OP_READLINE
7990 && o->op_next->op_next->op_type == OP_CONCAT
7991 && (o->op_next->op_next->op_flags & OPf_STACKED))
7993 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
7994 o->op_type = OP_RCATLINE;
7995 o->op_flags |= OPf_STACKED;
7996 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
7997 op_null(o->op_next->op_next);
7998 op_null(o->op_next);
8015 while (cLOGOP->op_other->op_type == OP_NULL)
8016 cLOGOP->op_other = cLOGOP->op_other->op_next;
8017 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
8023 while (cLOOP->op_redoop->op_type == OP_NULL)
8024 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
8025 peep(cLOOP->op_redoop);
8026 while (cLOOP->op_nextop->op_type == OP_NULL)
8027 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
8028 peep(cLOOP->op_nextop);
8029 while (cLOOP->op_lastop->op_type == OP_NULL)
8030 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
8031 peep(cLOOP->op_lastop);
8038 while (cPMOP->op_pmreplstart &&
8039 cPMOP->op_pmreplstart->op_type == OP_NULL)
8040 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
8041 peep(cPMOP->op_pmreplstart);
8046 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
8047 && ckWARN(WARN_SYNTAX))
8049 if (o->op_next->op_sibling) {
8050 const OPCODE type = o->op_next->op_sibling->op_type;
8051 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
8052 const line_t oldline = CopLINE(PL_curcop);
8053 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
8054 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8055 "Statement unlikely to be reached");
8056 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8057 "\t(Maybe you meant system() when you said exec()?)\n");
8058 CopLINE_set(PL_curcop, oldline);
8069 const char *key = NULL;
8074 if (((BINOP*)o)->op_last->op_type != OP_CONST)
8077 /* Make the CONST have a shared SV */
8078 svp = cSVOPx_svp(((BINOP*)o)->op_last);
8079 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
8080 key = SvPV_const(sv, keylen);
8081 lexname = newSVpvn_share(key,
8082 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
8088 if ((o->op_private & (OPpLVAL_INTRO)))
8091 rop = (UNOP*)((BINOP*)o)->op_first;
8092 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
8094 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
8095 if (!SvPAD_TYPED(lexname))
8097 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8098 if (!fields || !GvHV(*fields))
8100 key = SvPV_const(*svp, keylen);
8101 if (!hv_fetch(GvHV(*fields), key,
8102 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8104 Perl_croak(aTHX_ "No such class field \"%s\" "
8105 "in variable %s of type %s",
8106 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
8119 SVOP *first_key_op, *key_op;
8121 if ((o->op_private & (OPpLVAL_INTRO))
8122 /* I bet there's always a pushmark... */
8123 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
8124 /* hmmm, no optimization if list contains only one key. */
8126 rop = (UNOP*)((LISTOP*)o)->op_last;
8127 if (rop->op_type != OP_RV2HV)
8129 if (rop->op_first->op_type == OP_PADSV)
8130 /* @$hash{qw(keys here)} */
8131 rop = (UNOP*)rop->op_first;
8133 /* @{$hash}{qw(keys here)} */
8134 if (rop->op_first->op_type == OP_SCOPE
8135 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
8137 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
8143 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
8144 if (!SvPAD_TYPED(lexname))
8146 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8147 if (!fields || !GvHV(*fields))
8149 /* Again guessing that the pushmark can be jumped over.... */
8150 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
8151 ->op_first->op_sibling;
8152 for (key_op = first_key_op; key_op;
8153 key_op = (SVOP*)key_op->op_sibling) {
8154 if (key_op->op_type != OP_CONST)
8156 svp = cSVOPx_svp(key_op);
8157 key = SvPV_const(*svp, keylen);
8158 if (!hv_fetch(GvHV(*fields), key,
8159 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8161 Perl_croak(aTHX_ "No such class field \"%s\" "
8162 "in variable %s of type %s",
8163 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
8170 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
8174 /* check that RHS of sort is a single plain array */
8175 OP *oright = cUNOPo->op_first;
8176 if (!oright || oright->op_type != OP_PUSHMARK)
8179 /* reverse sort ... can be optimised. */
8180 if (!cUNOPo->op_sibling) {
8181 /* Nothing follows us on the list. */
8182 OP * const reverse = o->op_next;
8184 if (reverse->op_type == OP_REVERSE &&
8185 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
8186 OP * const pushmark = cUNOPx(reverse)->op_first;
8187 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
8188 && (cUNOPx(pushmark)->op_sibling == o)) {
8189 /* reverse -> pushmark -> sort */
8190 o->op_private |= OPpSORT_REVERSE;
8192 pushmark->op_next = oright->op_next;
8198 /* make @a = sort @a act in-place */
8202 oright = cUNOPx(oright)->op_sibling;
8205 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
8206 oright = cUNOPx(oright)->op_sibling;
8210 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
8211 || oright->op_next != o
8212 || (oright->op_private & OPpLVAL_INTRO)
8216 /* o2 follows the chain of op_nexts through the LHS of the
8217 * assign (if any) to the aassign op itself */
8219 if (!o2 || o2->op_type != OP_NULL)
8222 if (!o2 || o2->op_type != OP_PUSHMARK)
8225 if (o2 && o2->op_type == OP_GV)
8228 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
8229 || (o2->op_private & OPpLVAL_INTRO)
8234 if (!o2 || o2->op_type != OP_NULL)
8237 if (!o2 || o2->op_type != OP_AASSIGN
8238 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
8241 /* check that the sort is the first arg on RHS of assign */
8243 o2 = cUNOPx(o2)->op_first;
8244 if (!o2 || o2->op_type != OP_NULL)
8246 o2 = cUNOPx(o2)->op_first;
8247 if (!o2 || o2->op_type != OP_PUSHMARK)
8249 if (o2->op_sibling != o)
8252 /* check the array is the same on both sides */
8253 if (oleft->op_type == OP_RV2AV) {
8254 if (oright->op_type != OP_RV2AV
8255 || !cUNOPx(oright)->op_first
8256 || cUNOPx(oright)->op_first->op_type != OP_GV
8257 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
8258 cGVOPx_gv(cUNOPx(oright)->op_first)
8262 else if (oright->op_type != OP_PADAV
8263 || oright->op_targ != oleft->op_targ
8267 /* transfer MODishness etc from LHS arg to RHS arg */
8268 oright->op_flags = oleft->op_flags;
8269 o->op_private |= OPpSORT_INPLACE;
8271 /* excise push->gv->rv2av->null->aassign */
8272 o2 = o->op_next->op_next;
8273 op_null(o2); /* PUSHMARK */
8275 if (o2->op_type == OP_GV) {
8276 op_null(o2); /* GV */
8279 op_null(o2); /* RV2AV or PADAV */
8280 o2 = o2->op_next->op_next;
8281 op_null(o2); /* AASSIGN */
8283 o->op_next = o2->op_next;
8289 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
8291 LISTOP *enter, *exlist;
8294 enter = (LISTOP *) o->op_next;
8297 if (enter->op_type == OP_NULL) {
8298 enter = (LISTOP *) enter->op_next;
8302 /* for $a (...) will have OP_GV then OP_RV2GV here.
8303 for (...) just has an OP_GV. */
8304 if (enter->op_type == OP_GV) {
8305 gvop = (OP *) enter;
8306 enter = (LISTOP *) enter->op_next;
8309 if (enter->op_type == OP_RV2GV) {
8310 enter = (LISTOP *) enter->op_next;
8316 if (enter->op_type != OP_ENTERITER)
8319 iter = enter->op_next;
8320 if (!iter || iter->op_type != OP_ITER)
8323 expushmark = enter->op_first;
8324 if (!expushmark || expushmark->op_type != OP_NULL
8325 || expushmark->op_targ != OP_PUSHMARK)
8328 exlist = (LISTOP *) expushmark->op_sibling;
8329 if (!exlist || exlist->op_type != OP_NULL
8330 || exlist->op_targ != OP_LIST)
8333 if (exlist->op_last != o) {
8334 /* Mmm. Was expecting to point back to this op. */
8337 theirmark = exlist->op_first;
8338 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
8341 if (theirmark->op_sibling != o) {
8342 /* There's something between the mark and the reverse, eg
8343 for (1, reverse (...))
8348 ourmark = ((LISTOP *)o)->op_first;
8349 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
8352 ourlast = ((LISTOP *)o)->op_last;
8353 if (!ourlast || ourlast->op_next != o)
8356 rv2av = ourmark->op_sibling;
8357 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
8358 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
8359 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
8360 /* We're just reversing a single array. */
8361 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
8362 enter->op_flags |= OPf_STACKED;
8365 /* We don't have control over who points to theirmark, so sacrifice
8367 theirmark->op_next = ourmark->op_next;
8368 theirmark->op_flags = ourmark->op_flags;
8369 ourlast->op_next = gvop ? gvop : (OP *) enter;
8372 enter->op_private |= OPpITER_REVERSED;
8373 iter->op_private |= OPpITER_REVERSED;
8380 UNOP *refgen, *rv2cv;
8383 /* I do not understand this, but if o->op_opt isn't set to 1,
8384 various tests in ext/B/t/bytecode.t fail with no readily
8390 if ((o->op_flags && OPf_WANT) != OPf_WANT_VOID)
8393 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
8396 rv2gv = ((BINOP *)o)->op_last;
8397 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
8400 refgen = (UNOP *)((BINOP *)o)->op_first;
8402 if (!refgen || refgen->op_type != OP_REFGEN)
8405 exlist = (LISTOP *)refgen->op_first;
8406 if (!exlist || exlist->op_type != OP_NULL
8407 || exlist->op_targ != OP_LIST)
8410 if (exlist->op_first->op_type != OP_PUSHMARK)
8413 rv2cv = (UNOP*)exlist->op_last;
8415 if (rv2cv->op_type != OP_RV2CV)
8418 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
8419 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
8420 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
8422 o->op_private |= OPpASSIGN_CV_TO_GV;
8423 rv2gv->op_private |= OPpDONT_INIT_GV;
8424 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
8440 Perl_custom_op_name(pTHX_ const OP* o)
8443 const IV index = PTR2IV(o->op_ppaddr);
8447 if (!PL_custom_op_names) /* This probably shouldn't happen */
8448 return (char *)PL_op_name[OP_CUSTOM];
8450 keysv = sv_2mortal(newSViv(index));
8452 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
8454 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
8456 return SvPV_nolen(HeVAL(he));
8460 Perl_custom_op_desc(pTHX_ const OP* o)
8463 const IV index = PTR2IV(o->op_ppaddr);
8467 if (!PL_custom_op_descs)
8468 return (char *)PL_op_desc[OP_CUSTOM];
8470 keysv = sv_2mortal(newSViv(index));
8472 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
8474 return (char *)PL_op_desc[OP_CUSTOM];
8476 return SvPV_nolen(HeVAL(he));
8481 /* Efficient sub that returns a constant scalar value. */
8483 const_sv_xsub(pTHX_ CV* cv)
8490 Perl_croak(aTHX_ "usage: %s::%s()",
8491 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
8495 ST(0) = (SV*)XSANY.any_ptr;
8501 * c-indentation-style: bsd
8503 * indent-tabs-mode: t
8506 * ex: set ts=8 sts=4 sw=4 noet: