3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * "You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
13 * our Mr. Bilbo's first cousin on the mother's side (her mother being the
14 * youngest of the Old Took's daughters); and Mr. Drogo was his second
15 * cousin. So Mr. Frodo is his first *and* second cousin, once removed
16 * either way, as the saying is, if you follow me." --the Gaffer
19 /* This file contains the functions that create, manipulate and optimize
20 * the OP structures that hold a compiled perl program.
22 * A Perl program is compiled into a tree of OPs. Each op contains
23 * structural pointers (eg to its siblings and the next op in the
24 * execution sequence), a pointer to the function that would execute the
25 * op, plus any data specific to that op. For example, an OP_CONST op
26 * points to the pp_const() function and to an SV containing the constant
27 * value. When pp_const() is executed, its job is to push that SV onto the
30 * OPs are mainly created by the newFOO() functions, which are mainly
31 * called from the parser (in perly.y) as the code is parsed. For example
32 * the Perl code $a + $b * $c would cause the equivalent of the following
33 * to be called (oversimplifying a bit):
35 * newBINOP(OP_ADD, flags,
37 * newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
40 * Note that during the build of miniperl, a temporary copy of this file
41 * is made, called opmini.c.
45 Perl's compiler is essentially a 3-pass compiler with interleaved phases:
49 An execution-order pass
51 The bottom-up pass is represented by all the "newOP" routines and
52 the ck_ routines. The bottom-upness is actually driven by yacc.
53 So at the point that a ck_ routine fires, we have no idea what the
54 context is, either upward in the syntax tree, or either forward or
55 backward in the execution order. (The bottom-up parser builds that
56 part of the execution order it knows about, but if you follow the "next"
57 links around, you'll find it's actually a closed loop through the
60 Whenever the bottom-up parser gets to a node that supplies context to
61 its components, it invokes that portion of the top-down pass that applies
62 to that part of the subtree (and marks the top node as processed, so
63 if a node further up supplies context, it doesn't have to take the
64 plunge again). As a particular subcase of this, as the new node is
65 built, it takes all the closed execution loops of its subcomponents
66 and links them into a new closed loop for the higher level node. But
67 it's still not the real execution order.
69 The actual execution order is not known till we get a grammar reduction
70 to a top-level unit like a subroutine or file that will be called by
71 "name" rather than via a "next" pointer. At that point, we can call
72 into peep() to do that code's portion of the 3rd pass. It has to be
73 recursive, but it's recursive on basic blocks, not on tree nodes.
76 /* To implement user lexical pragmas, there needs to be a way at run time to
77 get the compile time state of %^H for that block. Storing %^H in every
78 block (or even COP) would be very expensive, so a different approach is
79 taken. The (running) state of %^H is serialised into a tree of HE-like
80 structs. Stores into %^H are chained onto the current leaf as a struct
81 refcounted_he * with the key and the value. Deletes from %^H are saved
82 with a value of PL_sv_placeholder. The state of %^H at any point can be
83 turned back into a regular HV by walking back up the tree from that point's
84 leaf, ignoring any key you've already seen (placeholder or not), storing
85 the rest into the HV structure, then removing the placeholders. Hence
86 memory is only used to store the %^H deltas from the enclosing COP, rather
87 than the entire %^H on each COP.
89 To cause actions on %^H to write out the serialisation records, it has
90 magic type 'H'. This magic (itself) does nothing, but its presence causes
91 the values to gain magic type 'h', which has entries for set and clear.
92 C<Perl_magic_sethint> updates C<PL_compiling.cop_hints_hash> with a store
93 record, with deletes written by C<Perl_magic_clearhint>. C<SAVE_HINTS>
94 saves the current C<PL_compiling.cop_hints_hash> on the save stack, so that
95 it will be correctly restored when any inner compiling scope is exited.
101 #include "keywords.h"
103 #define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
105 #if defined(PL_OP_SLAB_ALLOC)
107 #ifdef PERL_DEBUG_READONLY_OPS
108 # define PERL_SLAB_SIZE 4096
109 # include <sys/mman.h>
112 #ifndef PERL_SLAB_SIZE
113 #define PERL_SLAB_SIZE 2048
117 Perl_Slab_Alloc(pTHX_ size_t sz)
120 * To make incrementing use count easy PL_OpSlab is an I32 *
121 * To make inserting the link to slab PL_OpPtr is I32 **
122 * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
123 * Add an overhead for pointer to slab and round up as a number of pointers
125 sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
126 if ((PL_OpSpace -= sz) < 0) {
127 #ifdef PERL_DEBUG_READONLY_OPS
128 /* We need to allocate chunk by chunk so that we can control the VM
130 PL_OpPtr = mmap(0, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE,
131 MAP_ANON|MAP_PRIVATE, -1, 0);
133 DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
134 (unsigned long) PERL_SLAB_SIZE*sizeof(I32*),
136 if(PL_OpPtr == MAP_FAILED) {
137 perror("mmap failed");
142 PL_OpPtr = (I32 **) PerlMemShared_calloc(PERL_SLAB_SIZE,sizeof(I32*));
147 /* We reserve the 0'th I32 sized chunk as a use count */
148 PL_OpSlab = (I32 *) PL_OpPtr;
149 /* Reduce size by the use count word, and by the size we need.
150 * Latter is to mimic the '-=' in the if() above
152 PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
153 /* Allocation pointer starts at the top.
154 Theory: because we build leaves before trunk allocating at end
155 means that at run time access is cache friendly upward
157 PL_OpPtr += PERL_SLAB_SIZE;
159 #ifdef PERL_DEBUG_READONLY_OPS
160 /* We remember this slab. */
161 /* This implementation isn't efficient, but it is simple. */
162 PL_slabs = realloc(PL_slabs, sizeof(I32**) * (PL_slab_count + 1));
163 PL_slabs[PL_slab_count++] = PL_OpSlab;
164 DEBUG_m(PerlIO_printf(Perl_debug_log, "Allocate %p\n", PL_OpSlab));
167 assert( PL_OpSpace >= 0 );
168 /* Move the allocation pointer down */
170 assert( PL_OpPtr > (I32 **) PL_OpSlab );
171 *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */
172 (*PL_OpSlab)++; /* Increment use count of slab */
173 assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
174 assert( *PL_OpSlab > 0 );
175 return (void *)(PL_OpPtr + 1);
178 #ifdef PERL_DEBUG_READONLY_OPS
180 Perl_pending_Slabs_to_ro(pTHX) {
181 /* Turn all the allocated op slabs read only. */
182 U32 count = PL_slab_count;
183 I32 **const slabs = PL_slabs;
185 /* Reset the array of pending OP slabs, as we're about to turn this lot
186 read only. Also, do it ahead of the loop in case the warn triggers,
187 and a warn handler has an eval */
193 /* Force a new slab for any further allocation. */
197 const void *start = slabs[count];
198 const size_t size = PERL_SLAB_SIZE* sizeof(I32*);
199 if(mprotect(start, size, PROT_READ)) {
200 Perl_warn(aTHX_ "mprotect for %p %lu failed with %d",
201 start, (unsigned long) size, errno);
207 S_Slab_to_rw(pTHX_ void *op)
209 I32 * const * const ptr = (I32 **) op;
210 I32 * const slab = ptr[-1];
211 assert( ptr-1 > (I32 **) slab );
212 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
214 if(mprotect(slab, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE)) {
215 Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d",
216 slab, (unsigned long) PERL_SLAB_SIZE*sizeof(I32*), errno);
220 # define Slab_to_rw(op)
224 Perl_Slab_Free(pTHX_ void *op)
226 I32 * const * const ptr = (I32 **) op;
227 I32 * const slab = ptr[-1];
228 assert( ptr-1 > (I32 **) slab );
229 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
232 if (--(*slab) == 0) {
234 # define PerlMemShared PerlMem
237 #ifdef PERL_DEBUG_READONLY_OPS
238 U32 count = PL_slab_count;
239 /* Need to remove this slab from our list of slabs */
242 if (PL_slabs[count] == slab) {
243 /* Found it. Move the entry at the end to overwrite it. */
244 DEBUG_m(PerlIO_printf(Perl_debug_log,
245 "Deallocate %p by moving %p from %lu to %lu\n",
247 PL_slabs[PL_slab_count - 1],
248 PL_slab_count, count));
249 PL_slabs[count] = PL_slabs[--PL_slab_count];
250 /* Could realloc smaller at this point, but probably not
257 "panic: Couldn't find slab at %p (%lu allocated)",
258 slab, (unsigned long) PL_slabs);
260 if(munmap(slab, PERL_SLAB_SIZE*sizeof(I32*))) {
261 perror("munmap failed");
266 PerlMemShared_free(slab);
268 if (slab == PL_OpSlab) {
275 * In the following definition, the ", (OP*)0" is just to make the compiler
276 * think the expression is of the right type: croak actually does a Siglongjmp.
278 #define CHECKOP(type,o) \
279 ((PL_op_mask && PL_op_mask[type]) \
280 ? ( op_free((OP*)o), \
281 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
283 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
285 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
288 S_gv_ename(pTHX_ GV *gv)
290 SV* const tmpsv = sv_newmortal();
291 gv_efullname3(tmpsv, gv, NULL);
292 return SvPV_nolen_const(tmpsv);
296 S_no_fh_allowed(pTHX_ OP *o)
298 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
304 S_too_few_arguments(pTHX_ OP *o, const char *name)
306 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
311 S_too_many_arguments(pTHX_ OP *o, const char *name)
313 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
318 S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid)
320 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
321 (int)n, name, t, OP_DESC(kid)));
325 S_no_bareword_allowed(pTHX_ const OP *o)
328 return; /* various ok barewords are hidden in extra OP_NULL */
329 qerror(Perl_mess(aTHX_
330 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
334 /* "register" allocation */
337 Perl_allocmy(pTHX_ const char *const name)
341 const bool is_our = (PL_in_my == KEY_our);
343 /* complain about "my $<special_var>" etc etc */
347 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
348 (name[1] == '_' && (*name == '$' || name[2]))))
350 /* name[2] is true if strlen(name) > 2 */
351 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
352 yyerror(Perl_form(aTHX_ "Can't use global %c^%c%s in \"my\"",
353 name[0], toCTRL(name[1]), name + 2));
355 yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
359 /* check for duplicate declaration */
360 pad_check_dup(name, is_our, (PL_curstash ? PL_curstash : PL_defstash));
362 if (PL_in_my_stash && *name != '$') {
363 yyerror(Perl_form(aTHX_
364 "Can't declare class for non-scalar %s in \"%s\"",
366 is_our ? "our" : PL_in_my == KEY_state ? "state" : "my"));
369 /* allocate a spare slot and store the name in that slot */
371 off = pad_add_name(name,
374 /* $_ is always in main::, even with our */
375 ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
379 PL_in_my == KEY_state
384 /* free the body of an op without examining its contents.
385 * Always use this rather than FreeOp directly */
388 S_op_destroy(pTHX_ OP *o)
390 if (o->op_latefree) {
401 Perl_op_free(pTHX_ OP *o)
406 if (!o || o->op_static)
408 if (o->op_latefreed) {
415 if (o->op_private & OPpREFCOUNTED) {
425 #ifdef PERL_DEBUG_READONLY_OPS
429 refcnt = OpREFCNT_dec(o);
440 if (o->op_flags & OPf_KIDS) {
441 register OP *kid, *nextkid;
442 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
443 nextkid = kid->op_sibling; /* Get before next freeing kid */
448 type = (OPCODE)o->op_targ;
450 /* COP* is not cleared by op_clear() so that we may track line
451 * numbers etc even after null() */
452 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE) {
453 #ifdef PERL_DEBUG_READONLY_OPS
460 if (o->op_latefree) {
466 #ifdef DEBUG_LEAKING_SCALARS
473 Perl_op_clear(pTHX_ OP *o)
478 /* if (o->op_madprop && o->op_madprop->mad_next)
480 /* FIXME for MAD - if I uncomment these two lines t/op/pack.t fails with
481 "modification of a read only value" for a reason I can't fathom why.
482 It's the "" stringification of $_, where $_ was set to '' in a foreach
483 loop, but it defies simplification into a small test case.
484 However, commenting them out has caused ext/List/Util/t/weak.t to fail
487 mad_free(o->op_madprop);
493 switch (o->op_type) {
494 case OP_NULL: /* Was holding old type, if any. */
495 if (PL_madskills && o->op_targ != OP_NULL) {
496 o->op_type = o->op_targ;
500 case OP_ENTEREVAL: /* Was holding hints. */
504 if (!(o->op_flags & OPf_REF)
505 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
511 if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
512 /* not an OP_PADAV replacement */
514 if (cPADOPo->op_padix > 0) {
515 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
516 * may still exist on the pad */
517 pad_swipe(cPADOPo->op_padix, TRUE);
518 cPADOPo->op_padix = 0;
521 SvREFCNT_dec(cSVOPo->op_sv);
522 cSVOPo->op_sv = NULL;
526 case OP_METHOD_NAMED:
528 SvREFCNT_dec(cSVOPo->op_sv);
529 cSVOPo->op_sv = NULL;
532 Even if op_clear does a pad_free for the target of the op,
533 pad_free doesn't actually remove the sv that exists in the pad;
534 instead it lives on. This results in that it could be reused as
535 a target later on when the pad was reallocated.
538 pad_swipe(o->op_targ,1);
547 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
551 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
553 if (cPADOPo->op_padix > 0) {
554 pad_swipe(cPADOPo->op_padix, TRUE);
555 cPADOPo->op_padix = 0;
558 SvREFCNT_dec(cSVOPo->op_sv);
559 cSVOPo->op_sv = NULL;
563 PerlMemShared_free(cPVOPo->op_pv);
564 cPVOPo->op_pv = NULL;
568 op_free(cPMOPo->op_pmreplroot);
572 if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) {
573 /* No GvIN_PAD_off here, because other references may still
574 * exist on the pad */
575 pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot), TRUE);
578 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
584 forget_pmop(cPMOPo, 1);
585 cPMOPo->op_pmreplroot = NULL;
586 /* we use the "SAFE" version of the PM_ macros here
587 * since sv_clean_all might release some PMOPs
588 * after PL_regex_padav has been cleared
589 * and the clearing of PL_regex_padav needs to
590 * happen before sv_clean_all
592 ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
593 PM_SETRE_SAFE(cPMOPo, NULL);
595 if(PL_regex_pad) { /* We could be in destruction */
596 av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
597 SvREADONLY_off(PL_regex_pad[(cPMOPo)->op_pmoffset]);
598 SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
599 PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
606 if (o->op_targ > 0) {
607 pad_free(o->op_targ);
613 S_cop_free(pTHX_ COP* cop)
618 if (! specialWARN(cop->cop_warnings))
619 PerlMemShared_free(cop->cop_warnings);
620 Perl_refcounted_he_free(aTHX_ cop->cop_hints_hash);
624 S_forget_pmop(pTHX_ PMOP *const o, U32 flags)
626 HV * const pmstash = PmopSTASH(o);
627 if (pmstash && !SvIS_FREED(pmstash)) {
628 MAGIC * const mg = mg_find((SV*)pmstash, PERL_MAGIC_symtab);
630 PMOP **const array = (PMOP**) mg->mg_ptr;
631 U32 count = mg->mg_len / sizeof(PMOP**);
636 /* Found it. Move the entry at the end to overwrite it. */
637 array[i] = array[--count];
638 mg->mg_len = count * sizeof(PMOP**);
639 /* Could realloc smaller at this point always, but probably
640 not worth it. Probably worth free()ing if we're the
643 Safefree(mg->mg_ptr);
656 Perl_op_null(pTHX_ OP *o)
659 if (o->op_type == OP_NULL)
663 o->op_targ = o->op_type;
664 o->op_type = OP_NULL;
665 o->op_ppaddr = PL_ppaddr[OP_NULL];
669 Perl_op_refcnt_lock(pTHX)
677 Perl_op_refcnt_unlock(pTHX)
684 /* Contextualizers */
686 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
689 Perl_linklist(pTHX_ OP *o)
696 /* establish postfix order */
697 first = cUNOPo->op_first;
700 o->op_next = LINKLIST(first);
703 if (kid->op_sibling) {
704 kid->op_next = LINKLIST(kid->op_sibling);
705 kid = kid->op_sibling;
719 Perl_scalarkids(pTHX_ OP *o)
721 if (o && o->op_flags & OPf_KIDS) {
723 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
730 S_scalarboolean(pTHX_ OP *o)
733 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
734 if (ckWARN(WARN_SYNTAX)) {
735 const line_t oldline = CopLINE(PL_curcop);
737 if (PL_copline != NOLINE)
738 CopLINE_set(PL_curcop, PL_copline);
739 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
740 CopLINE_set(PL_curcop, oldline);
747 Perl_scalar(pTHX_ OP *o)
752 /* assumes no premature commitment */
753 if (!o || PL_error_count || (o->op_flags & OPf_WANT)
754 || o->op_type == OP_RETURN)
759 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
761 switch (o->op_type) {
763 scalar(cBINOPo->op_first);
768 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
772 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
773 if (!kPMOP->op_pmreplroot)
774 deprecate_old("implicit split to @_");
782 if (o->op_flags & OPf_KIDS) {
783 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
789 kid = cLISTOPo->op_first;
791 while ((kid = kid->op_sibling)) {
797 PL_curcop = &PL_compiling;
802 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
808 PL_curcop = &PL_compiling;
811 if (ckWARN(WARN_VOID))
812 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
818 Perl_scalarvoid(pTHX_ OP *o)
822 const char* useless = NULL;
826 /* trailing mad null ops don't count as "there" for void processing */
828 o->op_type != OP_NULL &&
830 o->op_sibling->op_type == OP_NULL)
833 for (sib = o->op_sibling;
834 sib && sib->op_type == OP_NULL;
835 sib = sib->op_sibling) ;
841 if (o->op_type == OP_NEXTSTATE
842 || o->op_type == OP_SETSTATE
843 || o->op_type == OP_DBSTATE
844 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
845 || o->op_targ == OP_SETSTATE
846 || o->op_targ == OP_DBSTATE)))
847 PL_curcop = (COP*)o; /* for warning below */
849 /* assumes no premature commitment */
850 want = o->op_flags & OPf_WANT;
851 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
852 || o->op_type == OP_RETURN)
857 if ((o->op_private & OPpTARGET_MY)
858 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
860 return scalar(o); /* As if inside SASSIGN */
863 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
865 switch (o->op_type) {
867 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
871 if (o->op_flags & OPf_STACKED)
875 if (o->op_private == 4)
947 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
948 useless = OP_DESC(o);
952 kid = cUNOPo->op_first;
953 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
954 kid->op_type != OP_TRANS) {
957 useless = "negative pattern binding (!~)";
964 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
965 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
966 useless = "a variable";
971 if (cSVOPo->op_private & OPpCONST_STRICT)
972 no_bareword_allowed(o);
974 if (ckWARN(WARN_VOID)) {
975 useless = "a constant";
976 if (o->op_private & OPpCONST_ARYBASE)
978 /* don't warn on optimised away booleans, eg
979 * use constant Foo, 5; Foo || print; */
980 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
982 /* the constants 0 and 1 are permitted as they are
983 conventionally used as dummies in constructs like
984 1 while some_condition_with_side_effects; */
985 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
987 else if (SvPOK(sv)) {
988 /* perl4's way of mixing documentation and code
989 (before the invention of POD) was based on a
990 trick to mix nroff and perl code. The trick was
991 built upon these three nroff macros being used in
992 void context. The pink camel has the details in
993 the script wrapman near page 319. */
994 const char * const maybe_macro = SvPVX_const(sv);
995 if (strnEQ(maybe_macro, "di", 2) ||
996 strnEQ(maybe_macro, "ds", 2) ||
997 strnEQ(maybe_macro, "ig", 2))
1002 op_null(o); /* don't execute or even remember it */
1006 o->op_type = OP_PREINC; /* pre-increment is faster */
1007 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1011 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1012 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1016 o->op_type = OP_I_PREINC; /* pre-increment is faster */
1017 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1021 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
1022 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1031 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1036 if (o->op_flags & OPf_STACKED)
1043 if (!(o->op_flags & OPf_KIDS))
1054 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1061 /* all requires must return a boolean value */
1062 o->op_flags &= ~OPf_WANT;
1067 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
1068 if (!kPMOP->op_pmreplroot)
1069 deprecate_old("implicit split to @_");
1073 if (useless && ckWARN(WARN_VOID))
1074 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
1079 Perl_listkids(pTHX_ OP *o)
1081 if (o && o->op_flags & OPf_KIDS) {
1083 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1090 Perl_list(pTHX_ OP *o)
1095 /* assumes no premature commitment */
1096 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
1097 || o->op_type == OP_RETURN)
1102 if ((o->op_private & OPpTARGET_MY)
1103 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1105 return o; /* As if inside SASSIGN */
1108 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1110 switch (o->op_type) {
1113 list(cBINOPo->op_first);
1118 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1126 if (!(o->op_flags & OPf_KIDS))
1128 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1129 list(cBINOPo->op_first);
1130 return gen_constant_list(o);
1137 kid = cLISTOPo->op_first;
1139 while ((kid = kid->op_sibling)) {
1140 if (kid->op_sibling)
1145 PL_curcop = &PL_compiling;
1149 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1150 if (kid->op_sibling)
1155 PL_curcop = &PL_compiling;
1158 /* all requires must return a boolean value */
1159 o->op_flags &= ~OPf_WANT;
1166 Perl_scalarseq(pTHX_ OP *o)
1170 const OPCODE type = o->op_type;
1172 if (type == OP_LINESEQ || type == OP_SCOPE ||
1173 type == OP_LEAVE || type == OP_LEAVETRY)
1176 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1177 if (kid->op_sibling) {
1181 PL_curcop = &PL_compiling;
1183 o->op_flags &= ~OPf_PARENS;
1184 if (PL_hints & HINT_BLOCK_SCOPE)
1185 o->op_flags |= OPf_PARENS;
1188 o = newOP(OP_STUB, 0);
1193 S_modkids(pTHX_ OP *o, I32 type)
1195 if (o && o->op_flags & OPf_KIDS) {
1197 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1203 /* Propagate lvalue ("modifiable") context to an op and its children.
1204 * 'type' represents the context type, roughly based on the type of op that
1205 * would do the modifying, although local() is represented by OP_NULL.
1206 * It's responsible for detecting things that can't be modified, flag
1207 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
1208 * might have to vivify a reference in $x), and so on.
1210 * For example, "$a+1 = 2" would cause mod() to be called with o being
1211 * OP_ADD and type being OP_SASSIGN, and would output an error.
1215 Perl_mod(pTHX_ OP *o, I32 type)
1219 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1222 if (!o || PL_error_count)
1225 if ((o->op_private & OPpTARGET_MY)
1226 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1231 switch (o->op_type) {
1237 if (!(o->op_private & OPpCONST_ARYBASE))
1240 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1241 CopARYBASE_set(&PL_compiling,
1242 (I32)SvIV(cSVOPx(PL_eval_start)->op_sv));
1246 SAVECOPARYBASE(&PL_compiling);
1247 CopARYBASE_set(&PL_compiling, 0);
1249 else if (type == OP_REFGEN)
1252 Perl_croak(aTHX_ "That use of $[ is unsupported");
1255 if (o->op_flags & OPf_PARENS || PL_madskills)
1259 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1260 !(o->op_flags & OPf_STACKED)) {
1261 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1262 /* The default is to set op_private to the number of children,
1263 which for a UNOP such as RV2CV is always 1. And w're using
1264 the bit for a flag in RV2CV, so we need it clear. */
1265 o->op_private &= ~1;
1266 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1267 assert(cUNOPo->op_first->op_type == OP_NULL);
1268 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1271 else if (o->op_private & OPpENTERSUB_NOMOD)
1273 else { /* lvalue subroutine call */
1274 o->op_private |= OPpLVAL_INTRO;
1275 PL_modcount = RETURN_UNLIMITED_NUMBER;
1276 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1277 /* Backward compatibility mode: */
1278 o->op_private |= OPpENTERSUB_INARGS;
1281 else { /* Compile-time error message: */
1282 OP *kid = cUNOPo->op_first;
1286 if (kid->op_type != OP_PUSHMARK) {
1287 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1289 "panic: unexpected lvalue entersub "
1290 "args: type/targ %ld:%"UVuf,
1291 (long)kid->op_type, (UV)kid->op_targ);
1292 kid = kLISTOP->op_first;
1294 while (kid->op_sibling)
1295 kid = kid->op_sibling;
1296 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1298 if (kid->op_type == OP_METHOD_NAMED
1299 || kid->op_type == OP_METHOD)
1303 NewOp(1101, newop, 1, UNOP);
1304 newop->op_type = OP_RV2CV;
1305 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1306 newop->op_first = NULL;
1307 newop->op_next = (OP*)newop;
1308 kid->op_sibling = (OP*)newop;
1309 newop->op_private |= OPpLVAL_INTRO;
1310 newop->op_private &= ~1;
1314 if (kid->op_type != OP_RV2CV)
1316 "panic: unexpected lvalue entersub "
1317 "entry via type/targ %ld:%"UVuf,
1318 (long)kid->op_type, (UV)kid->op_targ);
1319 kid->op_private |= OPpLVAL_INTRO;
1320 break; /* Postpone until runtime */
1324 kid = kUNOP->op_first;
1325 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1326 kid = kUNOP->op_first;
1327 if (kid->op_type == OP_NULL)
1329 "Unexpected constant lvalue entersub "
1330 "entry via type/targ %ld:%"UVuf,
1331 (long)kid->op_type, (UV)kid->op_targ);
1332 if (kid->op_type != OP_GV) {
1333 /* Restore RV2CV to check lvalueness */
1335 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1336 okid->op_next = kid->op_next;
1337 kid->op_next = okid;
1340 okid->op_next = NULL;
1341 okid->op_type = OP_RV2CV;
1343 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1344 okid->op_private |= OPpLVAL_INTRO;
1345 okid->op_private &= ~1;
1349 cv = GvCV(kGVOP_gv);
1359 /* grep, foreach, subcalls, refgen */
1360 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1362 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1363 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1365 : (o->op_type == OP_ENTERSUB
1366 ? "non-lvalue subroutine call"
1368 type ? PL_op_desc[type] : "local"));
1382 case OP_RIGHT_SHIFT:
1391 if (!(o->op_flags & OPf_STACKED))
1398 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1404 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1405 PL_modcount = RETURN_UNLIMITED_NUMBER;
1406 return o; /* Treat \(@foo) like ordinary list. */
1410 if (scalar_mod_type(o, type))
1412 ref(cUNOPo->op_first, o->op_type);
1416 if (type == OP_LEAVESUBLV)
1417 o->op_private |= OPpMAYBE_LVSUB;
1423 PL_modcount = RETURN_UNLIMITED_NUMBER;
1426 ref(cUNOPo->op_first, o->op_type);
1431 PL_hints |= HINT_BLOCK_SCOPE;
1446 PL_modcount = RETURN_UNLIMITED_NUMBER;
1447 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1448 return o; /* Treat \(@foo) like ordinary list. */
1449 if (scalar_mod_type(o, type))
1451 if (type == OP_LEAVESUBLV)
1452 o->op_private |= OPpMAYBE_LVSUB;
1456 if (!type) /* local() */
1457 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1458 PAD_COMPNAME_PV(o->op_targ));
1466 if (type != OP_SASSIGN)
1470 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1475 if (type == OP_LEAVESUBLV)
1476 o->op_private |= OPpMAYBE_LVSUB;
1478 pad_free(o->op_targ);
1479 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1480 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1481 if (o->op_flags & OPf_KIDS)
1482 mod(cBINOPo->op_first->op_sibling, type);
1487 ref(cBINOPo->op_first, o->op_type);
1488 if (type == OP_ENTERSUB &&
1489 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1490 o->op_private |= OPpLVAL_DEFER;
1491 if (type == OP_LEAVESUBLV)
1492 o->op_private |= OPpMAYBE_LVSUB;
1502 if (o->op_flags & OPf_KIDS)
1503 mod(cLISTOPo->op_last, type);
1508 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1510 else if (!(o->op_flags & OPf_KIDS))
1512 if (o->op_targ != OP_LIST) {
1513 mod(cBINOPo->op_first, type);
1519 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1524 if (type != OP_LEAVESUBLV)
1526 break; /* mod()ing was handled by ck_return() */
1529 /* [20011101.069] File test operators interpret OPf_REF to mean that
1530 their argument is a filehandle; thus \stat(".") should not set
1532 if (type == OP_REFGEN &&
1533 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1536 if (type != OP_LEAVESUBLV)
1537 o->op_flags |= OPf_MOD;
1539 if (type == OP_AASSIGN || type == OP_SASSIGN)
1540 o->op_flags |= OPf_SPECIAL|OPf_REF;
1541 else if (!type) { /* local() */
1544 o->op_private |= OPpLVAL_INTRO;
1545 o->op_flags &= ~OPf_SPECIAL;
1546 PL_hints |= HINT_BLOCK_SCOPE;
1551 if (ckWARN(WARN_SYNTAX)) {
1552 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1553 "Useless localization of %s", OP_DESC(o));
1557 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1558 && type != OP_LEAVESUBLV)
1559 o->op_flags |= OPf_REF;
1564 S_scalar_mod_type(const OP *o, I32 type)
1568 if (o->op_type == OP_RV2GV)
1592 case OP_RIGHT_SHIFT:
1611 S_is_handle_constructor(const OP *o, I32 numargs)
1613 switch (o->op_type) {
1621 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1634 Perl_refkids(pTHX_ OP *o, I32 type)
1636 if (o && o->op_flags & OPf_KIDS) {
1638 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1645 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
1650 if (!o || PL_error_count)
1653 switch (o->op_type) {
1655 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1656 !(o->op_flags & OPf_STACKED)) {
1657 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1658 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1659 assert(cUNOPo->op_first->op_type == OP_NULL);
1660 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1661 o->op_flags |= OPf_SPECIAL;
1662 o->op_private &= ~1;
1667 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1668 doref(kid, type, set_op_ref);
1671 if (type == OP_DEFINED)
1672 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1673 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1676 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1677 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1678 : type == OP_RV2HV ? OPpDEREF_HV
1680 o->op_flags |= OPf_MOD;
1687 o->op_flags |= OPf_REF;
1690 if (type == OP_DEFINED)
1691 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1692 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1698 o->op_flags |= OPf_REF;
1703 if (!(o->op_flags & OPf_KIDS))
1705 doref(cBINOPo->op_first, type, set_op_ref);
1709 doref(cBINOPo->op_first, o->op_type, set_op_ref);
1710 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1711 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1712 : type == OP_RV2HV ? OPpDEREF_HV
1714 o->op_flags |= OPf_MOD;
1724 if (!(o->op_flags & OPf_KIDS))
1726 doref(cLISTOPo->op_last, type, set_op_ref);
1736 S_dup_attrlist(pTHX_ OP *o)
1741 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1742 * where the first kid is OP_PUSHMARK and the remaining ones
1743 * are OP_CONST. We need to push the OP_CONST values.
1745 if (o->op_type == OP_CONST)
1746 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
1748 else if (o->op_type == OP_NULL)
1752 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1754 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1755 if (o->op_type == OP_CONST)
1756 rop = append_elem(OP_LIST, rop,
1757 newSVOP(OP_CONST, o->op_flags,
1758 SvREFCNT_inc_NN(cSVOPo->op_sv)));
1765 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1770 /* fake up C<use attributes $pkg,$rv,@attrs> */
1771 ENTER; /* need to protect against side-effects of 'use' */
1773 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1775 #define ATTRSMODULE "attributes"
1776 #define ATTRSMODULE_PM "attributes.pm"
1779 /* Don't force the C<use> if we don't need it. */
1780 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
1781 if (svp && *svp != &PL_sv_undef)
1782 NOOP; /* already in %INC */
1784 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1785 newSVpvs(ATTRSMODULE), NULL);
1788 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1789 newSVpvs(ATTRSMODULE),
1791 prepend_elem(OP_LIST,
1792 newSVOP(OP_CONST, 0, stashsv),
1793 prepend_elem(OP_LIST,
1794 newSVOP(OP_CONST, 0,
1796 dup_attrlist(attrs))));
1802 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1805 OP *pack, *imop, *arg;
1811 assert(target->op_type == OP_PADSV ||
1812 target->op_type == OP_PADHV ||
1813 target->op_type == OP_PADAV);
1815 /* Ensure that attributes.pm is loaded. */
1816 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1818 /* Need package name for method call. */
1819 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
1821 /* Build up the real arg-list. */
1822 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1824 arg = newOP(OP_PADSV, 0);
1825 arg->op_targ = target->op_targ;
1826 arg = prepend_elem(OP_LIST,
1827 newSVOP(OP_CONST, 0, stashsv),
1828 prepend_elem(OP_LIST,
1829 newUNOP(OP_REFGEN, 0,
1830 mod(arg, OP_REFGEN)),
1831 dup_attrlist(attrs)));
1833 /* Fake up a method call to import */
1834 meth = newSVpvs_share("import");
1835 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1836 append_elem(OP_LIST,
1837 prepend_elem(OP_LIST, pack, list(arg)),
1838 newSVOP(OP_METHOD_NAMED, 0, meth)));
1839 imop->op_private |= OPpENTERSUB_NOMOD;
1841 /* Combine the ops. */
1842 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1846 =notfor apidoc apply_attrs_string
1848 Attempts to apply a list of attributes specified by the C<attrstr> and
1849 C<len> arguments to the subroutine identified by the C<cv> argument which
1850 is expected to be associated with the package identified by the C<stashpv>
1851 argument (see L<attributes>). It gets this wrong, though, in that it
1852 does not correctly identify the boundaries of the individual attribute
1853 specifications within C<attrstr>. This is not really intended for the
1854 public API, but has to be listed here for systems such as AIX which
1855 need an explicit export list for symbols. (It's called from XS code
1856 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1857 to respect attribute syntax properly would be welcome.
1863 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
1864 const char *attrstr, STRLEN len)
1869 len = strlen(attrstr);
1873 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1875 const char * const sstr = attrstr;
1876 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1877 attrs = append_elem(OP_LIST, attrs,
1878 newSVOP(OP_CONST, 0,
1879 newSVpvn(sstr, attrstr-sstr)));
1883 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1884 newSVpvs(ATTRSMODULE),
1885 NULL, prepend_elem(OP_LIST,
1886 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1887 prepend_elem(OP_LIST,
1888 newSVOP(OP_CONST, 0,
1894 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
1899 if (!o || PL_error_count)
1903 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
1904 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
1908 if (type == OP_LIST) {
1910 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1911 my_kid(kid, attrs, imopsp);
1912 } else if (type == OP_UNDEF
1918 } else if (type == OP_RV2SV || /* "our" declaration */
1920 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1921 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1922 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1924 PL_in_my == KEY_our ? "our" : PL_in_my == KEY_state ? "state" : "my"));
1926 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
1928 PL_in_my_stash = NULL;
1929 apply_attrs(GvSTASH(gv),
1930 (type == OP_RV2SV ? GvSV(gv) :
1931 type == OP_RV2AV ? (SV*)GvAV(gv) :
1932 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1935 o->op_private |= OPpOUR_INTRO;
1938 else if (type != OP_PADSV &&
1941 type != OP_PUSHMARK)
1943 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1945 PL_in_my == KEY_our ? "our" : PL_in_my == KEY_state ? "state" : "my"));
1948 else if (attrs && type != OP_PUSHMARK) {
1952 PL_in_my_stash = NULL;
1954 /* check for C<my Dog $spot> when deciding package */
1955 stash = PAD_COMPNAME_TYPE(o->op_targ);
1957 stash = PL_curstash;
1958 apply_attrs_my(stash, o, attrs, imopsp);
1960 o->op_flags |= OPf_MOD;
1961 o->op_private |= OPpLVAL_INTRO;
1962 if (PL_in_my == KEY_state)
1963 o->op_private |= OPpPAD_STATE;
1968 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1972 int maybe_scalar = 0;
1974 /* [perl #17376]: this appears to be premature, and results in code such as
1975 C< our(%x); > executing in list mode rather than void mode */
1977 if (o->op_flags & OPf_PARENS)
1987 o = my_kid(o, attrs, &rops);
1989 if (maybe_scalar && o->op_type == OP_PADSV) {
1990 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
1991 o->op_private |= OPpLVAL_INTRO;
1994 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
1997 PL_in_my_stash = NULL;
2002 Perl_my(pTHX_ OP *o)
2004 return my_attrs(o, NULL);
2008 Perl_sawparens(pTHX_ OP *o)
2010 PERL_UNUSED_CONTEXT;
2012 o->op_flags |= OPf_PARENS;
2017 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2021 const OPCODE ltype = left->op_type;
2022 const OPCODE rtype = right->op_type;
2024 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2025 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
2027 const char * const desc
2028 = PL_op_desc[(rtype == OP_SUBST || rtype == OP_TRANS)
2029 ? (int)rtype : OP_MATCH];
2030 const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV)
2031 ? "@array" : "%hash");
2032 Perl_warner(aTHX_ packWARN(WARN_MISC),
2033 "Applying %s to %s will act on scalar(%s)",
2034 desc, sample, sample);
2037 if (rtype == OP_CONST &&
2038 cSVOPx(right)->op_private & OPpCONST_BARE &&
2039 cSVOPx(right)->op_private & OPpCONST_STRICT)
2041 no_bareword_allowed(right);
2044 ismatchop = rtype == OP_MATCH ||
2045 rtype == OP_SUBST ||
2047 if (ismatchop && right->op_private & OPpTARGET_MY) {
2049 right->op_private &= ~OPpTARGET_MY;
2051 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
2054 right->op_flags |= OPf_STACKED;
2055 if (rtype != OP_MATCH &&
2056 ! (rtype == OP_TRANS &&
2057 right->op_private & OPpTRANS_IDENTICAL))
2058 newleft = mod(left, rtype);
2061 if (right->op_type == OP_TRANS)
2062 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
2064 o = prepend_elem(rtype, scalar(newleft), right);
2066 return newUNOP(OP_NOT, 0, scalar(o));
2070 return bind_match(type, left,
2071 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
2075 Perl_invert(pTHX_ OP *o)
2079 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2083 Perl_scope(pTHX_ OP *o)
2087 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2088 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2089 o->op_type = OP_LEAVE;
2090 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2092 else if (o->op_type == OP_LINESEQ) {
2094 o->op_type = OP_SCOPE;
2095 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2096 kid = ((LISTOP*)o)->op_first;
2097 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2100 /* The following deals with things like 'do {1 for 1}' */
2101 kid = kid->op_sibling;
2103 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2108 o = newLISTOP(OP_SCOPE, 0, o, NULL);
2114 Perl_block_start(pTHX_ int full)
2117 const int retval = PL_savestack_ix;
2118 pad_block_start(full);
2120 PL_hints &= ~HINT_BLOCK_SCOPE;
2121 SAVECOMPILEWARNINGS();
2122 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
2127 Perl_block_end(pTHX_ I32 floor, OP *seq)
2130 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2131 OP* const retval = scalarseq(seq);
2133 CopHINTS_set(&PL_compiling, PL_hints);
2135 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2144 const PADOFFSET offset = pad_findmy("$_");
2145 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
2146 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2149 OP * const o = newOP(OP_PADSV, 0);
2150 o->op_targ = offset;
2156 Perl_newPROG(pTHX_ OP *o)
2162 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2163 ((PL_in_eval & EVAL_KEEPERR)
2164 ? OPf_SPECIAL : 0), o);
2165 PL_eval_start = linklist(PL_eval_root);
2166 PL_eval_root->op_private |= OPpREFCOUNTED;
2167 OpREFCNT_set(PL_eval_root, 1);
2168 PL_eval_root->op_next = 0;
2169 CALL_PEEP(PL_eval_start);
2172 if (o->op_type == OP_STUB) {
2173 PL_comppad_name = 0;
2175 S_op_destroy(aTHX_ o);
2178 PL_main_root = scope(sawparens(scalarvoid(o)));
2179 PL_curcop = &PL_compiling;
2180 PL_main_start = LINKLIST(PL_main_root);
2181 PL_main_root->op_private |= OPpREFCOUNTED;
2182 OpREFCNT_set(PL_main_root, 1);
2183 PL_main_root->op_next = 0;
2184 CALL_PEEP(PL_main_start);
2187 /* Register with debugger */
2190 = Perl_get_cvn_flags(aTHX_ STR_WITH_LEN("DB::postponed"), 0);
2194 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2196 call_sv((SV*)cv, G_DISCARD);
2203 Perl_localize(pTHX_ OP *o, I32 lex)
2206 if (o->op_flags & OPf_PARENS)
2207 /* [perl #17376]: this appears to be premature, and results in code such as
2208 C< our(%x); > executing in list mode rather than void mode */
2215 if ( PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ','
2216 && ckWARN(WARN_PARENTHESIS))
2218 char *s = PL_bufptr;
2221 /* some heuristics to detect a potential error */
2222 while (*s && (strchr(", \t\n", *s)))
2226 if (*s && strchr("@$%*", *s) && *++s
2227 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2230 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2232 while (*s && (strchr(", \t\n", *s)))
2238 if (sigil && (*s == ';' || *s == '=')) {
2239 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2240 "Parentheses missing around \"%s\" list",
2241 lex ? (PL_in_my == KEY_our ? "our" : PL_in_my == KEY_state ? "state" : "my")
2249 o = mod(o, OP_NULL); /* a bit kludgey */
2251 PL_in_my_stash = NULL;
2256 Perl_jmaybe(pTHX_ OP *o)
2258 if (o->op_type == OP_LIST) {
2260 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2261 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2267 Perl_fold_constants(pTHX_ register OP *o)
2272 VOL I32 type = o->op_type;
2277 SV * const oldwarnhook = PL_warnhook;
2278 SV * const olddiehook = PL_diehook;
2281 if (PL_opargs[type] & OA_RETSCALAR)
2283 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2284 o->op_targ = pad_alloc(type, SVs_PADTMP);
2286 /* integerize op, unless it happens to be C<-foo>.
2287 * XXX should pp_i_negate() do magic string negation instead? */
2288 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2289 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2290 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2292 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2295 if (!(PL_opargs[type] & OA_FOLDCONST))
2300 /* XXX might want a ck_negate() for this */
2301 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2312 /* XXX what about the numeric ops? */
2313 if (PL_hints & HINT_LOCALE)
2318 goto nope; /* Don't try to run w/ errors */
2320 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2321 const OPCODE type = curop->op_type;
2322 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2324 type != OP_SCALAR &&
2326 type != OP_PUSHMARK)
2332 curop = LINKLIST(o);
2333 old_next = o->op_next;
2337 oldscope = PL_scopestack_ix;
2338 create_eval_scope(G_FAKINGEVAL);
2340 PL_warnhook = PERL_WARNHOOK_FATAL;
2347 sv = *(PL_stack_sp--);
2348 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2349 pad_swipe(o->op_targ, FALSE);
2350 else if (SvTEMP(sv)) { /* grab mortal temp? */
2351 SvREFCNT_inc_simple_void(sv);
2356 /* Something tried to die. Abandon constant folding. */
2357 /* Pretend the error never happened. */
2358 sv_setpvn(ERRSV,"",0);
2359 o->op_next = old_next;
2363 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
2364 PL_warnhook = oldwarnhook;
2365 PL_diehook = olddiehook;
2366 /* XXX note that this croak may fail as we've already blown away
2367 * the stack - eg any nested evals */
2368 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
2371 PL_warnhook = oldwarnhook;
2372 PL_diehook = olddiehook;
2374 if (PL_scopestack_ix > oldscope)
2375 delete_eval_scope();
2384 if (type == OP_RV2GV)
2385 newop = newGVOP(OP_GV, 0, (GV*)sv);
2387 newop = newSVOP(OP_CONST, 0, (SV*)sv);
2388 op_getmad(o,newop,'f');
2396 Perl_gen_constant_list(pTHX_ register OP *o)
2400 const I32 oldtmps_floor = PL_tmps_floor;
2404 return o; /* Don't attempt to run with errors */
2406 PL_op = curop = LINKLIST(o);
2412 assert (!(curop->op_flags & OPf_SPECIAL));
2413 assert(curop->op_type == OP_RANGE);
2415 PL_tmps_floor = oldtmps_floor;
2417 o->op_type = OP_RV2AV;
2418 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2419 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2420 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2421 o->op_opt = 0; /* needs to be revisited in peep() */
2422 curop = ((UNOP*)o)->op_first;
2423 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
2425 op_getmad(curop,o,'O');
2434 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2437 if (!o || o->op_type != OP_LIST)
2438 o = newLISTOP(OP_LIST, 0, o, NULL);
2440 o->op_flags &= ~OPf_WANT;
2442 if (!(PL_opargs[type] & OA_MARK))
2443 op_null(cLISTOPo->op_first);
2445 o->op_type = (OPCODE)type;
2446 o->op_ppaddr = PL_ppaddr[type];
2447 o->op_flags |= flags;
2449 o = CHECKOP(type, o);
2450 if (o->op_type != (unsigned)type)
2453 return fold_constants(o);
2456 /* List constructors */
2459 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2467 if (first->op_type != (unsigned)type
2468 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2470 return newLISTOP(type, 0, first, last);
2473 if (first->op_flags & OPf_KIDS)
2474 ((LISTOP*)first)->op_last->op_sibling = last;
2476 first->op_flags |= OPf_KIDS;
2477 ((LISTOP*)first)->op_first = last;
2479 ((LISTOP*)first)->op_last = last;
2484 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2492 if (first->op_type != (unsigned)type)
2493 return prepend_elem(type, (OP*)first, (OP*)last);
2495 if (last->op_type != (unsigned)type)
2496 return append_elem(type, (OP*)first, (OP*)last);
2498 first->op_last->op_sibling = last->op_first;
2499 first->op_last = last->op_last;
2500 first->op_flags |= (last->op_flags & OPf_KIDS);
2503 if (last->op_first && first->op_madprop) {
2504 MADPROP *mp = last->op_first->op_madprop;
2506 while (mp->mad_next)
2508 mp->mad_next = first->op_madprop;
2511 last->op_first->op_madprop = first->op_madprop;
2514 first->op_madprop = last->op_madprop;
2515 last->op_madprop = 0;
2518 S_op_destroy(aTHX_ (OP*)last);
2524 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2532 if (last->op_type == (unsigned)type) {
2533 if (type == OP_LIST) { /* already a PUSHMARK there */
2534 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2535 ((LISTOP*)last)->op_first->op_sibling = first;
2536 if (!(first->op_flags & OPf_PARENS))
2537 last->op_flags &= ~OPf_PARENS;
2540 if (!(last->op_flags & OPf_KIDS)) {
2541 ((LISTOP*)last)->op_last = first;
2542 last->op_flags |= OPf_KIDS;
2544 first->op_sibling = ((LISTOP*)last)->op_first;
2545 ((LISTOP*)last)->op_first = first;
2547 last->op_flags |= OPf_KIDS;
2551 return newLISTOP(type, 0, first, last);
2559 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2562 Newxz(tk, 1, TOKEN);
2563 tk->tk_type = (OPCODE)optype;
2564 tk->tk_type = 12345;
2566 tk->tk_mad = madprop;
2571 Perl_token_free(pTHX_ TOKEN* tk)
2573 if (tk->tk_type != 12345)
2575 mad_free(tk->tk_mad);
2580 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2584 if (tk->tk_type != 12345) {
2585 Perl_warner(aTHX_ packWARN(WARN_MISC),
2586 "Invalid TOKEN object ignored");
2593 /* faked up qw list? */
2595 tm->mad_type == MAD_SV &&
2596 SvPVX((SV*)tm->mad_val)[0] == 'q')
2603 /* pretend constant fold didn't happen? */
2604 if (mp->mad_key == 'f' &&
2605 (o->op_type == OP_CONST ||
2606 o->op_type == OP_GV) )
2608 token_getmad(tk,(OP*)mp->mad_val,slot);
2622 if (mp->mad_key == 'X')
2623 mp->mad_key = slot; /* just change the first one */
2633 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
2642 /* pretend constant fold didn't happen? */
2643 if (mp->mad_key == 'f' &&
2644 (o->op_type == OP_CONST ||
2645 o->op_type == OP_GV) )
2647 op_getmad(from,(OP*)mp->mad_val,slot);
2654 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
2657 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
2663 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
2672 /* pretend constant fold didn't happen? */
2673 if (mp->mad_key == 'f' &&
2674 (o->op_type == OP_CONST ||
2675 o->op_type == OP_GV) )
2677 op_getmad(from,(OP*)mp->mad_val,slot);
2684 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
2687 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
2691 PerlIO_printf(PerlIO_stderr(),
2692 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
2698 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
2716 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
2720 addmad(tm, &(o->op_madprop), slot);
2724 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
2745 Perl_newMADsv(pTHX_ char key, SV* sv)
2747 return newMADPROP(key, MAD_SV, sv, 0);
2751 Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
2754 Newxz(mp, 1, MADPROP);
2757 mp->mad_vlen = vlen;
2758 mp->mad_type = type;
2760 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
2765 Perl_mad_free(pTHX_ MADPROP* mp)
2767 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
2771 mad_free(mp->mad_next);
2772 /* if (PL_lex_state != LEX_NOTPARSING && mp->mad_vlen)
2773 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
2774 switch (mp->mad_type) {
2778 Safefree((char*)mp->mad_val);
2781 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
2782 op_free((OP*)mp->mad_val);
2785 sv_free((SV*)mp->mad_val);
2788 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
2797 Perl_newNULLLIST(pTHX)
2799 return newOP(OP_STUB, 0);
2803 Perl_force_list(pTHX_ OP *o)
2805 if (!o || o->op_type != OP_LIST)
2806 o = newLISTOP(OP_LIST, 0, o, NULL);
2812 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2817 NewOp(1101, listop, 1, LISTOP);
2819 listop->op_type = (OPCODE)type;
2820 listop->op_ppaddr = PL_ppaddr[type];
2823 listop->op_flags = (U8)flags;
2827 else if (!first && last)
2830 first->op_sibling = last;
2831 listop->op_first = first;
2832 listop->op_last = last;
2833 if (type == OP_LIST) {
2834 OP* const pushop = newOP(OP_PUSHMARK, 0);
2835 pushop->op_sibling = first;
2836 listop->op_first = pushop;
2837 listop->op_flags |= OPf_KIDS;
2839 listop->op_last = pushop;
2842 return CHECKOP(type, listop);
2846 Perl_newOP(pTHX_ I32 type, I32 flags)
2850 NewOp(1101, o, 1, OP);
2851 o->op_type = (OPCODE)type;
2852 o->op_ppaddr = PL_ppaddr[type];
2853 o->op_flags = (U8)flags;
2855 o->op_latefreed = 0;
2859 o->op_private = (U8)(0 | (flags >> 8));
2860 if (PL_opargs[type] & OA_RETSCALAR)
2862 if (PL_opargs[type] & OA_TARGET)
2863 o->op_targ = pad_alloc(type, SVs_PADTMP);
2864 return CHECKOP(type, o);
2868 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2874 first = newOP(OP_STUB, 0);
2875 if (PL_opargs[type] & OA_MARK)
2876 first = force_list(first);
2878 NewOp(1101, unop, 1, UNOP);
2879 unop->op_type = (OPCODE)type;
2880 unop->op_ppaddr = PL_ppaddr[type];
2881 unop->op_first = first;
2882 unop->op_flags = (U8)(flags | OPf_KIDS);
2883 unop->op_private = (U8)(1 | (flags >> 8));
2884 unop = (UNOP*) CHECKOP(type, unop);
2888 return fold_constants((OP *) unop);
2892 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2896 NewOp(1101, binop, 1, BINOP);
2899 first = newOP(OP_NULL, 0);
2901 binop->op_type = (OPCODE)type;
2902 binop->op_ppaddr = PL_ppaddr[type];
2903 binop->op_first = first;
2904 binop->op_flags = (U8)(flags | OPf_KIDS);
2907 binop->op_private = (U8)(1 | (flags >> 8));
2910 binop->op_private = (U8)(2 | (flags >> 8));
2911 first->op_sibling = last;
2914 binop = (BINOP*)CHECKOP(type, binop);
2915 if (binop->op_next || binop->op_type != (OPCODE)type)
2918 binop->op_last = binop->op_first->op_sibling;
2920 return fold_constants((OP *)binop);
2923 static int uvcompare(const void *a, const void *b)
2924 __attribute__nonnull__(1)
2925 __attribute__nonnull__(2)
2926 __attribute__pure__;
2927 static int uvcompare(const void *a, const void *b)
2929 if (*((const UV *)a) < (*(const UV *)b))
2931 if (*((const UV *)a) > (*(const UV *)b))
2933 if (*((const UV *)a+1) < (*(const UV *)b+1))
2935 if (*((const UV *)a+1) > (*(const UV *)b+1))
2941 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2944 SV * const tstr = ((SVOP*)expr)->op_sv;
2947 (repl->op_type == OP_NULL)
2948 ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
2950 ((SVOP*)repl)->op_sv;
2953 const U8 *t = (U8*)SvPV_const(tstr, tlen);
2954 const U8 *r = (U8*)SvPV_const(rstr, rlen);
2958 register short *tbl;
2960 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
2961 const I32 squash = o->op_private & OPpTRANS_SQUASH;
2962 I32 del = o->op_private & OPpTRANS_DELETE;
2964 PL_hints |= HINT_BLOCK_SCOPE;
2967 o->op_private |= OPpTRANS_FROM_UTF;
2970 o->op_private |= OPpTRANS_TO_UTF;
2972 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2973 SV* const listsv = newSVpvs("# comment\n");
2975 const U8* tend = t + tlen;
2976 const U8* rend = r + rlen;
2990 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2991 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2994 const U32 flags = UTF8_ALLOW_DEFAULT;
2998 t = tsave = bytes_to_utf8(t, &len);
3001 if (!to_utf && rlen) {
3003 r = rsave = bytes_to_utf8(r, &len);
3007 /* There are several snags with this code on EBCDIC:
3008 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
3009 2. scan_const() in toke.c has encoded chars in native encoding which makes
3010 ranges at least in EBCDIC 0..255 range the bottom odd.
3014 U8 tmpbuf[UTF8_MAXBYTES+1];
3017 Newx(cp, 2*tlen, UV);
3019 transv = newSVpvs("");
3021 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3023 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
3025 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3029 cp[2*i+1] = cp[2*i];
3033 qsort(cp, i, 2*sizeof(UV), uvcompare);
3034 for (j = 0; j < i; j++) {
3036 diff = val - nextmin;
3038 t = uvuni_to_utf8(tmpbuf,nextmin);
3039 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3041 U8 range_mark = UTF_TO_NATIVE(0xff);
3042 t = uvuni_to_utf8(tmpbuf, val - 1);
3043 sv_catpvn(transv, (char *)&range_mark, 1);
3044 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3051 t = uvuni_to_utf8(tmpbuf,nextmin);
3052 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3054 U8 range_mark = UTF_TO_NATIVE(0xff);
3055 sv_catpvn(transv, (char *)&range_mark, 1);
3057 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
3058 UNICODE_ALLOW_SUPER);
3059 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3060 t = (const U8*)SvPVX_const(transv);
3061 tlen = SvCUR(transv);
3065 else if (!rlen && !del) {
3066 r = t; rlen = tlen; rend = tend;
3069 if ((!rlen && !del) || t == r ||
3070 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
3072 o->op_private |= OPpTRANS_IDENTICAL;
3076 while (t < tend || tfirst <= tlast) {
3077 /* see if we need more "t" chars */
3078 if (tfirst > tlast) {
3079 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3081 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
3083 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3090 /* now see if we need more "r" chars */
3091 if (rfirst > rlast) {
3093 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3095 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
3097 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3106 rfirst = rlast = 0xffffffff;
3110 /* now see which range will peter our first, if either. */
3111 tdiff = tlast - tfirst;
3112 rdiff = rlast - rfirst;
3119 if (rfirst == 0xffffffff) {
3120 diff = tdiff; /* oops, pretend rdiff is infinite */
3122 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
3123 (long)tfirst, (long)tlast);
3125 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
3129 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
3130 (long)tfirst, (long)(tfirst + diff),
3133 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3134 (long)tfirst, (long)rfirst);
3136 if (rfirst + diff > max)
3137 max = rfirst + diff;
3139 grows = (tfirst < rfirst &&
3140 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3152 else if (max > 0xff)
3157 PerlMemShared_free(cPVOPo->op_pv);
3158 cPVOPo->op_pv = NULL;
3160 swash = (SV*)swash_init("utf8", "", listsv, bits, none);
3162 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
3163 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
3164 PAD_SETSV(cPADOPo->op_padix, swash);
3167 cSVOPo->op_sv = swash;
3169 SvREFCNT_dec(listsv);
3170 SvREFCNT_dec(transv);
3172 if (!del && havefinal && rlen)
3173 (void)hv_store((HV*)SvRV(swash), "FINAL", 5,
3174 newSVuv((UV)final), 0);
3177 o->op_private |= OPpTRANS_GROWS;
3183 op_getmad(expr,o,'e');
3184 op_getmad(repl,o,'r');
3192 tbl = (short*)cPVOPo->op_pv;
3194 Zero(tbl, 256, short);
3195 for (i = 0; i < (I32)tlen; i++)
3197 for (i = 0, j = 0; i < 256; i++) {
3199 if (j >= (I32)rlen) {
3208 if (i < 128 && r[j] >= 128)
3218 o->op_private |= OPpTRANS_IDENTICAL;
3220 else if (j >= (I32)rlen)
3225 PerlMemShared_realloc(tbl,
3226 (0x101+rlen-j) * sizeof(short));
3227 cPVOPo->op_pv = (char*)tbl;
3229 tbl[0x100] = (short)(rlen - j);
3230 for (i=0; i < (I32)rlen - j; i++)
3231 tbl[0x101+i] = r[j+i];
3235 if (!rlen && !del) {
3238 o->op_private |= OPpTRANS_IDENTICAL;
3240 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3241 o->op_private |= OPpTRANS_IDENTICAL;
3243 for (i = 0; i < 256; i++)
3245 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3246 if (j >= (I32)rlen) {
3248 if (tbl[t[i]] == -1)
3254 if (tbl[t[i]] == -1) {
3255 if (t[i] < 128 && r[j] >= 128)
3262 o->op_private |= OPpTRANS_GROWS;
3264 op_getmad(expr,o,'e');
3265 op_getmad(repl,o,'r');
3275 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3280 NewOp(1101, pmop, 1, PMOP);
3281 pmop->op_type = (OPCODE)type;
3282 pmop->op_ppaddr = PL_ppaddr[type];
3283 pmop->op_flags = (U8)flags;
3284 pmop->op_private = (U8)(0 | (flags >> 8));
3286 if (PL_hints & HINT_RE_TAINT)
3287 pmop->op_pmflags |= PMf_RETAINT;
3288 if (PL_hints & HINT_LOCALE)
3289 pmop->op_pmflags |= PMf_LOCALE;
3293 if (av_len((AV*) PL_regex_pad[0]) > -1) {
3294 SV * const repointer = av_pop((AV*)PL_regex_pad[0]);
3295 pmop->op_pmoffset = SvIV(repointer);
3296 SvREPADTMP_off(repointer);
3297 sv_setiv(repointer,0);
3299 SV * const repointer = newSViv(0);
3300 av_push(PL_regex_padav, SvREFCNT_inc_simple_NN(repointer));
3301 pmop->op_pmoffset = av_len(PL_regex_padav);
3302 PL_regex_pad = AvARRAY(PL_regex_padav);
3306 /* append to pm list */
3307 if (type != OP_TRANS && PL_curstash) {
3308 MAGIC *mg = mg_find((SV*)PL_curstash, PERL_MAGIC_symtab);
3311 mg = sv_magicext((SV*)PL_curstash, 0, PERL_MAGIC_symtab, 0, 0, 0);
3313 elements = mg->mg_len / sizeof(PMOP**);
3314 Renewc(mg->mg_ptr, elements + 1, PMOP*, char);
3315 ((PMOP**)mg->mg_ptr) [elements++] = pmop;
3316 mg->mg_len = elements * sizeof(PMOP**);
3317 PmopSTASH_set(pmop,PL_curstash);
3320 return CHECKOP(type, pmop);
3323 /* Given some sort of match op o, and an expression expr containing a
3324 * pattern, either compile expr into a regex and attach it to o (if it's
3325 * constant), or convert expr into a runtime regcomp op sequence (if it's
3328 * isreg indicates that the pattern is part of a regex construct, eg
3329 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3330 * split "pattern", which aren't. In the former case, expr will be a list
3331 * if the pattern contains more than one term (eg /a$b/) or if it contains
3332 * a replacement, ie s/// or tr///.
3336 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
3341 I32 repl_has_vars = 0;
3345 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
3346 /* last element in list is the replacement; pop it */
3348 repl = cLISTOPx(expr)->op_last;
3349 kid = cLISTOPx(expr)->op_first;
3350 while (kid->op_sibling != repl)
3351 kid = kid->op_sibling;
3352 kid->op_sibling = NULL;
3353 cLISTOPx(expr)->op_last = kid;
3356 if (isreg && expr->op_type == OP_LIST &&
3357 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3359 /* convert single element list to element */
3360 OP* const oe = expr;
3361 expr = cLISTOPx(oe)->op_first->op_sibling;
3362 cLISTOPx(oe)->op_first->op_sibling = NULL;
3363 cLISTOPx(oe)->op_last = NULL;
3367 if (o->op_type == OP_TRANS) {
3368 return pmtrans(o, expr, repl);
3371 reglist = isreg && expr->op_type == OP_LIST;
3375 PL_hints |= HINT_BLOCK_SCOPE;
3378 if (expr->op_type == OP_CONST) {
3380 SV * const pat = ((SVOP*)expr)->op_sv;
3381 const char *p = SvPV_const(pat, plen);
3382 U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
3383 if ((o->op_flags & OPf_SPECIAL) && (plen == 1 && *p == ' ')) {
3384 U32 was_readonly = SvREADONLY(pat);
3388 sv_force_normal_flags(pat, 0);
3389 assert(!SvREADONLY(pat));
3392 SvREADONLY_off(pat);
3396 sv_setpvn(pat, "\\s+", 3);
3398 SvFLAGS(pat) |= was_readonly;
3400 p = SvPV_const(pat, plen);
3401 pm_flags |= RXf_SKIPWHITE;
3404 pm_flags |= RXf_UTF8;
3405 /* FIXME - can we make this function take const char * args? */
3406 PM_SETRE(pm, CALLREGCOMP((char*)p, (char*)p + plen, pm_flags));
3409 op_getmad(expr,(OP*)pm,'e');
3415 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3416 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3418 : OP_REGCMAYBE),0,expr);
3420 NewOp(1101, rcop, 1, LOGOP);
3421 rcop->op_type = OP_REGCOMP;
3422 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3423 rcop->op_first = scalar(expr);
3424 rcop->op_flags |= OPf_KIDS
3425 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3426 | (reglist ? OPf_STACKED : 0);
3427 rcop->op_private = 1;
3430 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3432 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
3435 /* establish postfix order */
3436 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3438 rcop->op_next = expr;
3439 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3442 rcop->op_next = LINKLIST(expr);
3443 expr->op_next = (OP*)rcop;
3446 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3451 if (pm->op_pmflags & PMf_EVAL) {
3453 if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
3454 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
3456 else if (repl->op_type == OP_CONST)
3460 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3461 if (curop->op_type == OP_SCOPE
3462 || curop->op_type == OP_LEAVE
3463 || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
3464 if (curop->op_type == OP_GV) {
3465 GV * const gv = cGVOPx_gv(curop);
3467 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3470 else if (curop->op_type == OP_RV2CV)
3472 else if (curop->op_type == OP_RV2SV ||
3473 curop->op_type == OP_RV2AV ||
3474 curop->op_type == OP_RV2HV ||
3475 curop->op_type == OP_RV2GV) {
3476 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3479 else if (curop->op_type == OP_PADSV ||
3480 curop->op_type == OP_PADAV ||
3481 curop->op_type == OP_PADHV ||
3482 curop->op_type == OP_PADANY)
3486 else if (curop->op_type == OP_PUSHRE)
3487 NOOP; /* Okay here, dangerous in newASSIGNOP */
3497 || PM_GETRE(pm)->extflags & RXf_EVAL_SEEN)))
3499 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3500 prepend_elem(o->op_type, scalar(repl), o);
3503 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3504 pm->op_pmflags |= PMf_MAYBE_CONST;
3506 NewOp(1101, rcop, 1, LOGOP);
3507 rcop->op_type = OP_SUBSTCONT;
3508 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3509 rcop->op_first = scalar(repl);
3510 rcop->op_flags |= OPf_KIDS;
3511 rcop->op_private = 1;
3514 /* establish postfix order */
3515 rcop->op_next = LINKLIST(repl);
3516 repl->op_next = (OP*)rcop;
3518 pm->op_pmreplroot = scalar((OP*)rcop);
3519 pm->op_pmreplstart = LINKLIST(rcop);
3528 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3532 NewOp(1101, svop, 1, SVOP);
3533 svop->op_type = (OPCODE)type;
3534 svop->op_ppaddr = PL_ppaddr[type];
3536 svop->op_next = (OP*)svop;
3537 svop->op_flags = (U8)flags;
3538 if (PL_opargs[type] & OA_RETSCALAR)
3540 if (PL_opargs[type] & OA_TARGET)
3541 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3542 return CHECKOP(type, svop);
3547 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3551 NewOp(1101, padop, 1, PADOP);
3552 padop->op_type = (OPCODE)type;
3553 padop->op_ppaddr = PL_ppaddr[type];
3554 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3555 SvREFCNT_dec(PAD_SVl(padop->op_padix));
3556 PAD_SETSV(padop->op_padix, sv);
3559 padop->op_next = (OP*)padop;
3560 padop->op_flags = (U8)flags;
3561 if (PL_opargs[type] & OA_RETSCALAR)
3563 if (PL_opargs[type] & OA_TARGET)
3564 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3565 return CHECKOP(type, padop);
3570 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3576 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3578 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3583 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3587 NewOp(1101, pvop, 1, PVOP);
3588 pvop->op_type = (OPCODE)type;
3589 pvop->op_ppaddr = PL_ppaddr[type];
3591 pvop->op_next = (OP*)pvop;
3592 pvop->op_flags = (U8)flags;
3593 if (PL_opargs[type] & OA_RETSCALAR)
3595 if (PL_opargs[type] & OA_TARGET)
3596 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3597 return CHECKOP(type, pvop);
3605 Perl_package(pTHX_ OP *o)
3608 SV *const sv = cSVOPo->op_sv;
3613 save_hptr(&PL_curstash);
3614 save_item(PL_curstname);
3616 PL_curstash = gv_stashsv(sv, GV_ADD);
3617 sv_setsv(PL_curstname, sv);
3619 PL_hints |= HINT_BLOCK_SCOPE;
3620 PL_copline = NOLINE;
3626 if (!PL_madskills) {
3631 pegop = newOP(OP_NULL,0);
3632 op_getmad(o,pegop,'P');
3642 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3649 OP *pegop = newOP(OP_NULL,0);
3652 if (idop->op_type != OP_CONST)
3653 Perl_croak(aTHX_ "Module name must be constant");
3656 op_getmad(idop,pegop,'U');
3661 SV * const vesv = ((SVOP*)version)->op_sv;
3664 op_getmad(version,pegop,'V');
3665 if (!arg && !SvNIOKp(vesv)) {
3672 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3673 Perl_croak(aTHX_ "Version number must be constant number");
3675 /* Make copy of idop so we don't free it twice */
3676 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3678 /* Fake up a method call to VERSION */
3679 meth = newSVpvs_share("VERSION");
3680 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3681 append_elem(OP_LIST,
3682 prepend_elem(OP_LIST, pack, list(version)),
3683 newSVOP(OP_METHOD_NAMED, 0, meth)));
3687 /* Fake up an import/unimport */
3688 if (arg && arg->op_type == OP_STUB) {
3690 op_getmad(arg,pegop,'S');
3691 imop = arg; /* no import on explicit () */
3693 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3694 imop = NULL; /* use 5.0; */
3696 idop->op_private |= OPpCONST_NOVER;
3702 op_getmad(arg,pegop,'A');
3704 /* Make copy of idop so we don't free it twice */
3705 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3707 /* Fake up a method call to import/unimport */
3709 ? newSVpvs_share("import") : newSVpvs_share("unimport");
3710 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3711 append_elem(OP_LIST,
3712 prepend_elem(OP_LIST, pack, list(arg)),
3713 newSVOP(OP_METHOD_NAMED, 0, meth)));
3716 /* Fake up the BEGIN {}, which does its thing immediately. */
3718 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
3721 append_elem(OP_LINESEQ,
3722 append_elem(OP_LINESEQ,
3723 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
3724 newSTATEOP(0, NULL, veop)),
3725 newSTATEOP(0, NULL, imop) ));
3727 /* The "did you use incorrect case?" warning used to be here.
3728 * The problem is that on case-insensitive filesystems one
3729 * might get false positives for "use" (and "require"):
3730 * "use Strict" or "require CARP" will work. This causes
3731 * portability problems for the script: in case-strict
3732 * filesystems the script will stop working.
3734 * The "incorrect case" warning checked whether "use Foo"
3735 * imported "Foo" to your namespace, but that is wrong, too:
3736 * there is no requirement nor promise in the language that
3737 * a Foo.pm should or would contain anything in package "Foo".
3739 * There is very little Configure-wise that can be done, either:
3740 * the case-sensitivity of the build filesystem of Perl does not
3741 * help in guessing the case-sensitivity of the runtime environment.
3744 PL_hints |= HINT_BLOCK_SCOPE;
3745 PL_copline = NOLINE;
3747 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3750 if (!PL_madskills) {
3751 /* FIXME - don't allocate pegop if !PL_madskills */
3760 =head1 Embedding Functions
3762 =for apidoc load_module
3764 Loads the module whose name is pointed to by the string part of name.
3765 Note that the actual module name, not its filename, should be given.
3766 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3767 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3768 (or 0 for no flags). ver, if specified, provides version semantics
3769 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3770 arguments can be used to specify arguments to the module's import()
3771 method, similar to C<use Foo::Bar VERSION LIST>.
3776 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3779 va_start(args, ver);
3780 vload_module(flags, name, ver, &args);
3784 #ifdef PERL_IMPLICIT_CONTEXT
3786 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3790 va_start(args, ver);
3791 vload_module(flags, name, ver, &args);
3797 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3802 OP * const modname = newSVOP(OP_CONST, 0, name);
3803 modname->op_private |= OPpCONST_BARE;
3805 veop = newSVOP(OP_CONST, 0, ver);
3809 if (flags & PERL_LOADMOD_NOIMPORT) {
3810 imop = sawparens(newNULLLIST());
3812 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3813 imop = va_arg(*args, OP*);
3818 sv = va_arg(*args, SV*);
3820 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3821 sv = va_arg(*args, SV*);
3825 const line_t ocopline = PL_copline;
3826 COP * const ocurcop = PL_curcop;
3827 const int oexpect = PL_expect;
3829 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3830 veop, modname, imop);
3831 PL_expect = oexpect;
3832 PL_copline = ocopline;
3833 PL_curcop = ocurcop;
3838 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
3844 if (!force_builtin) {
3845 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
3846 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
3847 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
3848 gv = gvp ? *gvp : NULL;
3852 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3853 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3854 append_elem(OP_LIST, term,
3855 scalar(newUNOP(OP_RV2CV, 0,
3856 newGVOP(OP_GV, 0, gv))))));
3859 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3865 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3867 return newBINOP(OP_LSLICE, flags,
3868 list(force_list(subscript)),
3869 list(force_list(listval)) );
3873 S_is_list_assignment(pTHX_ register const OP *o)
3881 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
3882 o = cUNOPo->op_first;
3884 flags = o->op_flags;
3886 if (type == OP_COND_EXPR) {
3887 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
3888 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3893 yyerror("Assignment to both a list and a scalar");
3897 if (type == OP_LIST &&
3898 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
3899 o->op_private & OPpLVAL_INTRO)
3902 if (type == OP_LIST || flags & OPf_PARENS ||
3903 type == OP_RV2AV || type == OP_RV2HV ||
3904 type == OP_ASLICE || type == OP_HSLICE)
3907 if (type == OP_PADAV || type == OP_PADHV)
3910 if (type == OP_RV2SV)
3917 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3923 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3924 return newLOGOP(optype, 0,
3925 mod(scalar(left), optype),
3926 newUNOP(OP_SASSIGN, 0, scalar(right)));
3929 return newBINOP(optype, OPf_STACKED,
3930 mod(scalar(left), optype), scalar(right));
3934 if (is_list_assignment(left)) {
3938 /* Grandfathering $[ assignment here. Bletch.*/
3939 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
3940 PL_eval_start = (left->op_type == OP_CONST) ? right : 0;
3941 left = mod(left, OP_AASSIGN);
3944 else if (left->op_type == OP_CONST) {
3946 /* Result of assignment is always 1 (or we'd be dead already) */
3947 return newSVOP(OP_CONST, 0, newSViv(1));
3949 curop = list(force_list(left));
3950 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3951 o->op_private = (U8)(0 | (flags >> 8));
3953 /* PL_generation sorcery:
3954 * an assignment like ($a,$b) = ($c,$d) is easier than
3955 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3956 * To detect whether there are common vars, the global var
3957 * PL_generation is incremented for each assign op we compile.
3958 * Then, while compiling the assign op, we run through all the
3959 * variables on both sides of the assignment, setting a spare slot
3960 * in each of them to PL_generation. If any of them already have
3961 * that value, we know we've got commonality. We could use a
3962 * single bit marker, but then we'd have to make 2 passes, first
3963 * to clear the flag, then to test and set it. To find somewhere
3964 * to store these values, evil chicanery is done with SvUVX().
3970 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3971 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3972 if (curop->op_type == OP_GV) {
3973 GV *gv = cGVOPx_gv(curop);
3975 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
3977 GvASSIGN_GENERATION_set(gv, PL_generation);
3979 else if (curop->op_type == OP_PADSV ||
3980 curop->op_type == OP_PADAV ||
3981 curop->op_type == OP_PADHV ||
3982 curop->op_type == OP_PADANY)
3984 if (PAD_COMPNAME_GEN(curop->op_targ)
3985 == (STRLEN)PL_generation)
3987 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
3990 else if (curop->op_type == OP_RV2CV)
3992 else if (curop->op_type == OP_RV2SV ||
3993 curop->op_type == OP_RV2AV ||
3994 curop->op_type == OP_RV2HV ||
3995 curop->op_type == OP_RV2GV) {
3996 if (lastop->op_type != OP_GV) /* funny deref? */
3999 else if (curop->op_type == OP_PUSHRE) {
4000 if (((PMOP*)curop)->op_pmreplroot) {
4002 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
4003 ((PMOP*)curop)->op_pmreplroot));
4005 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
4008 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4010 GvASSIGN_GENERATION_set(gv, PL_generation);
4011 GvASSIGN_GENERATION_set(gv, PL_generation);
4020 o->op_private |= OPpASSIGN_COMMON;
4023 if ( ((left->op_private & OPpLVAL_INTRO) || ckWARN(WARN_MISC))
4024 && (left->op_type == OP_LIST
4025 || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
4027 OP* lop = ((LISTOP*)left)->op_first;
4029 if (lop->op_type == OP_PADSV ||
4030 lop->op_type == OP_PADAV ||
4031 lop->op_type == OP_PADHV ||
4032 lop->op_type == OP_PADANY)
4034 if (lop->op_private & OPpPAD_STATE) {
4035 if (left->op_private & OPpLVAL_INTRO) {
4036 o->op_private |= OPpASSIGN_STATE;
4037 /* hijacking PADSTALE for uninitialized state variables */
4038 SvPADSTALE_on(PAD_SVl(lop->op_targ));
4040 else { /* we already checked for WARN_MISC before */
4041 Perl_warner(aTHX_ packWARN(WARN_MISC), "State variable %s will be reinitialized",
4042 PAD_COMPNAME_PV(lop->op_targ));
4046 lop = lop->op_sibling;
4049 else if (((left->op_private & (OPpLVAL_INTRO | OPpPAD_STATE))
4050 == (OPpLVAL_INTRO | OPpPAD_STATE))
4051 && ( left->op_type == OP_PADSV
4052 || left->op_type == OP_PADAV
4053 || left->op_type == OP_PADHV
4054 || left->op_type == OP_PADANY))
4056 o->op_private |= OPpASSIGN_STATE;
4057 /* hijacking PADSTALE for uninitialized state variables */
4058 SvPADSTALE_on(PAD_SVl(left->op_targ));
4061 if (right && right->op_type == OP_SPLIT) {
4062 OP* tmpop = ((LISTOP*)right)->op_first;
4063 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
4064 PMOP * const pm = (PMOP*)tmpop;
4065 if (left->op_type == OP_RV2AV &&
4066 !(left->op_private & OPpLVAL_INTRO) &&
4067 !(o->op_private & OPpASSIGN_COMMON) )
4069 tmpop = ((UNOP*)left)->op_first;
4070 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
4072 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
4073 cPADOPx(tmpop)->op_padix = 0; /* steal it */
4075 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
4076 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
4078 pm->op_pmflags |= PMf_ONCE;
4079 tmpop = cUNOPo->op_first; /* to list (nulled) */
4080 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
4081 tmpop->op_sibling = NULL; /* don't free split */
4082 right->op_next = tmpop->op_next; /* fix starting loc */
4084 op_getmad(o,right,'R'); /* blow off assign */
4086 op_free(o); /* blow off assign */
4088 right->op_flags &= ~OPf_WANT;
4089 /* "I don't know and I don't care." */
4094 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
4095 ((LISTOP*)right)->op_last->op_type == OP_CONST)
4097 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
4099 sv_setiv(sv, PL_modcount+1);
4107 right = newOP(OP_UNDEF, 0);
4108 if (right->op_type == OP_READLINE) {
4109 right->op_flags |= OPf_STACKED;
4110 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
4113 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
4114 o = newBINOP(OP_SASSIGN, flags,
4115 scalar(right), mod(scalar(left), OP_SASSIGN) );
4121 o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
4122 o->op_private |= OPpCONST_ARYBASE;
4129 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
4132 const U32 seq = intro_my();
4135 NewOp(1101, cop, 1, COP);
4136 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
4137 cop->op_type = OP_DBSTATE;
4138 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
4141 cop->op_type = OP_NEXTSTATE;
4142 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
4144 cop->op_flags = (U8)flags;
4145 CopHINTS_set(cop, PL_hints);
4147 cop->op_private |= NATIVE_HINTS;
4149 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
4150 cop->op_next = (OP*)cop;
4153 CopLABEL_set(cop, label);
4154 PL_hints |= HINT_BLOCK_SCOPE;
4157 /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
4158 CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
4160 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
4161 cop->cop_hints_hash = PL_curcop->cop_hints_hash;
4162 if (cop->cop_hints_hash) {
4164 cop->cop_hints_hash->refcounted_he_refcnt++;
4165 HINTS_REFCNT_UNLOCK;
4168 if (PL_copline == NOLINE)
4169 CopLINE_set(cop, CopLINE(PL_curcop));
4171 CopLINE_set(cop, PL_copline);
4172 PL_copline = NOLINE;
4175 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
4177 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
4179 CopSTASH_set(cop, PL_curstash);
4181 if (PERLDB_LINE && PL_curstash != PL_debstash) {
4182 AV *av = CopFILEAVx(PL_curcop);
4184 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
4185 if (svp && *svp != &PL_sv_undef ) {
4186 (void)SvIOK_on(*svp);
4187 SvIV_set(*svp, PTR2IV(cop));
4192 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
4197 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
4200 return new_logop(type, flags, &first, &other);
4204 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
4209 OP *first = *firstp;
4210 OP * const other = *otherp;
4212 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
4213 return newBINOP(type, flags, scalar(first), scalar(other));
4215 scalarboolean(first);
4216 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
4217 if (first->op_type == OP_NOT
4218 && (first->op_flags & OPf_SPECIAL)
4219 && (first->op_flags & OPf_KIDS)) {
4220 if (type == OP_AND || type == OP_OR) {
4226 first = *firstp = cUNOPo->op_first;
4228 first->op_next = o->op_next;
4229 cUNOPo->op_first = NULL;
4231 op_getmad(o,first,'O');
4237 if (first->op_type == OP_CONST) {
4238 if (first->op_private & OPpCONST_STRICT)
4239 no_bareword_allowed(first);
4240 else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
4241 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
4242 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
4243 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
4244 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
4246 if (other->op_type == OP_CONST)
4247 other->op_private |= OPpCONST_SHORTCIRCUIT;
4249 OP *newop = newUNOP(OP_NULL, 0, other);
4250 op_getmad(first, newop, '1');
4251 newop->op_targ = type; /* set "was" field */
4258 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
4259 const OP *o2 = other;
4260 if ( ! (o2->op_type == OP_LIST
4261 && (( o2 = cUNOPx(o2)->op_first))
4262 && o2->op_type == OP_PUSHMARK
4263 && (( o2 = o2->op_sibling)) )
4266 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
4267 || o2->op_type == OP_PADHV)
4268 && o2->op_private & OPpLVAL_INTRO
4269 && ckWARN(WARN_DEPRECATED))
4271 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4272 "Deprecated use of my() in false conditional");
4276 if (first->op_type == OP_CONST)
4277 first->op_private |= OPpCONST_SHORTCIRCUIT;
4279 first = newUNOP(OP_NULL, 0, first);
4280 op_getmad(other, first, '2');
4281 first->op_targ = type; /* set "was" field */
4288 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
4289 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
4291 const OP * const k1 = ((UNOP*)first)->op_first;
4292 const OP * const k2 = k1->op_sibling;
4294 switch (first->op_type)
4297 if (k2 && k2->op_type == OP_READLINE
4298 && (k2->op_flags & OPf_STACKED)
4299 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4301 warnop = k2->op_type;
4306 if (k1->op_type == OP_READDIR
4307 || k1->op_type == OP_GLOB
4308 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4309 || k1->op_type == OP_EACH)
4311 warnop = ((k1->op_type == OP_NULL)
4312 ? (OPCODE)k1->op_targ : k1->op_type);
4317 const line_t oldline = CopLINE(PL_curcop);
4318 CopLINE_set(PL_curcop, PL_copline);
4319 Perl_warner(aTHX_ packWARN(WARN_MISC),
4320 "Value of %s%s can be \"0\"; test with defined()",
4322 ((warnop == OP_READLINE || warnop == OP_GLOB)
4323 ? " construct" : "() operator"));
4324 CopLINE_set(PL_curcop, oldline);
4331 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
4332 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
4334 NewOp(1101, logop, 1, LOGOP);
4336 logop->op_type = (OPCODE)type;
4337 logop->op_ppaddr = PL_ppaddr[type];
4338 logop->op_first = first;
4339 logop->op_flags = (U8)(flags | OPf_KIDS);
4340 logop->op_other = LINKLIST(other);
4341 logop->op_private = (U8)(1 | (flags >> 8));
4343 /* establish postfix order */
4344 logop->op_next = LINKLIST(first);
4345 first->op_next = (OP*)logop;
4346 first->op_sibling = other;
4348 CHECKOP(type,logop);
4350 o = newUNOP(OP_NULL, 0, (OP*)logop);
4357 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
4365 return newLOGOP(OP_AND, 0, first, trueop);
4367 return newLOGOP(OP_OR, 0, first, falseop);
4369 scalarboolean(first);
4370 if (first->op_type == OP_CONST) {
4371 /* Left or right arm of the conditional? */
4372 const bool left = SvTRUE(((SVOP*)first)->op_sv);
4373 OP *live = left ? trueop : falseop;
4374 OP *const dead = left ? falseop : trueop;
4375 if (first->op_private & OPpCONST_BARE &&
4376 first->op_private & OPpCONST_STRICT) {
4377 no_bareword_allowed(first);
4380 /* This is all dead code when PERL_MAD is not defined. */
4381 live = newUNOP(OP_NULL, 0, live);
4382 op_getmad(first, live, 'C');
4383 op_getmad(dead, live, left ? 'e' : 't');
4390 NewOp(1101, logop, 1, LOGOP);
4391 logop->op_type = OP_COND_EXPR;
4392 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4393 logop->op_first = first;
4394 logop->op_flags = (U8)(flags | OPf_KIDS);
4395 logop->op_private = (U8)(1 | (flags >> 8));
4396 logop->op_other = LINKLIST(trueop);
4397 logop->op_next = LINKLIST(falseop);
4399 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
4402 /* establish postfix order */
4403 start = LINKLIST(first);
4404 first->op_next = (OP*)logop;
4406 first->op_sibling = trueop;
4407 trueop->op_sibling = falseop;
4408 o = newUNOP(OP_NULL, 0, (OP*)logop);
4410 trueop->op_next = falseop->op_next = o;
4417 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4426 NewOp(1101, range, 1, LOGOP);
4428 range->op_type = OP_RANGE;
4429 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4430 range->op_first = left;
4431 range->op_flags = OPf_KIDS;
4432 leftstart = LINKLIST(left);
4433 range->op_other = LINKLIST(right);
4434 range->op_private = (U8)(1 | (flags >> 8));
4436 left->op_sibling = right;
4438 range->op_next = (OP*)range;
4439 flip = newUNOP(OP_FLIP, flags, (OP*)range);
4440 flop = newUNOP(OP_FLOP, 0, flip);
4441 o = newUNOP(OP_NULL, 0, flop);
4443 range->op_next = leftstart;
4445 left->op_next = flip;
4446 right->op_next = flop;
4448 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4449 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4450 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4451 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4453 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4454 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4457 if (!flip->op_private || !flop->op_private)
4458 linklist(o); /* blow off optimizer unless constant */
4464 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4469 const bool once = block && block->op_flags & OPf_SPECIAL &&
4470 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4472 PERL_UNUSED_ARG(debuggable);
4475 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4476 return block; /* do {} while 0 does once */
4477 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4478 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4479 expr = newUNOP(OP_DEFINED, 0,
4480 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4481 } else if (expr->op_flags & OPf_KIDS) {
4482 const OP * const k1 = ((UNOP*)expr)->op_first;
4483 const OP * const k2 = k1 ? k1->op_sibling : NULL;
4484 switch (expr->op_type) {
4486 if (k2 && k2->op_type == OP_READLINE
4487 && (k2->op_flags & OPf_STACKED)
4488 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4489 expr = newUNOP(OP_DEFINED, 0, expr);
4493 if (k1 && (k1->op_type == OP_READDIR
4494 || k1->op_type == OP_GLOB
4495 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4496 || k1->op_type == OP_EACH))
4497 expr = newUNOP(OP_DEFINED, 0, expr);
4503 /* if block is null, the next append_elem() would put UNSTACK, a scalar
4504 * op, in listop. This is wrong. [perl #27024] */
4506 block = newOP(OP_NULL, 0);
4507 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4508 o = new_logop(OP_AND, 0, &expr, &listop);
4511 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4513 if (once && o != listop)
4514 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4517 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
4519 o->op_flags |= flags;
4521 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4526 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
4527 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
4536 PERL_UNUSED_ARG(debuggable);
4539 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4540 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4541 expr = newUNOP(OP_DEFINED, 0,
4542 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4543 } else if (expr->op_flags & OPf_KIDS) {
4544 const OP * const k1 = ((UNOP*)expr)->op_first;
4545 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
4546 switch (expr->op_type) {
4548 if (k2 && k2->op_type == OP_READLINE
4549 && (k2->op_flags & OPf_STACKED)
4550 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4551 expr = newUNOP(OP_DEFINED, 0, expr);
4555 if (k1 && (k1->op_type == OP_READDIR
4556 || k1->op_type == OP_GLOB
4557 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4558 || k1->op_type == OP_EACH))
4559 expr = newUNOP(OP_DEFINED, 0, expr);
4566 block = newOP(OP_NULL, 0);
4567 else if (cont || has_my) {
4568 block = scope(block);
4572 next = LINKLIST(cont);
4575 OP * const unstack = newOP(OP_UNSTACK, 0);
4578 cont = append_elem(OP_LINESEQ, cont, unstack);
4582 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4584 redo = LINKLIST(listop);
4587 PL_copline = (line_t)whileline;
4589 o = new_logop(OP_AND, 0, &expr, &listop);
4590 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4591 op_free(expr); /* oops, it's a while (0) */
4593 return NULL; /* listop already freed by new_logop */
4596 ((LISTOP*)listop)->op_last->op_next =
4597 (o == listop ? redo : LINKLIST(o));
4603 NewOp(1101,loop,1,LOOP);
4604 loop->op_type = OP_ENTERLOOP;
4605 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4606 loop->op_private = 0;
4607 loop->op_next = (OP*)loop;
4610 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4612 loop->op_redoop = redo;
4613 loop->op_lastop = o;
4614 o->op_private |= loopflags;
4617 loop->op_nextop = next;
4619 loop->op_nextop = o;
4621 o->op_flags |= flags;
4622 o->op_private |= (flags >> 8);
4627 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
4632 PADOFFSET padoff = 0;
4638 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4639 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
4640 sv->op_type = OP_RV2GV;
4641 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4643 /* The op_type check is needed to prevent a possible segfault
4644 * if the loop variable is undeclared and 'strict vars' is in
4645 * effect. This is illegal but is nonetheless parsed, so we
4646 * may reach this point with an OP_CONST where we're expecting
4649 if (cUNOPx(sv)->op_first->op_type == OP_GV
4650 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
4651 iterpflags |= OPpITER_DEF;
4653 else if (sv->op_type == OP_PADSV) { /* private variable */
4654 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
4655 padoff = sv->op_targ;
4665 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4667 SV *const namesv = PAD_COMPNAME_SV(padoff);
4669 const char *const name = SvPV_const(namesv, len);
4671 if (len == 2 && name[0] == '$' && name[1] == '_')
4672 iterpflags |= OPpITER_DEF;
4676 const PADOFFSET offset = pad_findmy("$_");
4677 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
4678 sv = newGVOP(OP_GV, 0, PL_defgv);
4683 iterpflags |= OPpITER_DEF;
4685 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4686 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4687 iterflags |= OPf_STACKED;
4689 else if (expr->op_type == OP_NULL &&
4690 (expr->op_flags & OPf_KIDS) &&
4691 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4693 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4694 * set the STACKED flag to indicate that these values are to be
4695 * treated as min/max values by 'pp_iterinit'.
4697 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4698 LOGOP* const range = (LOGOP*) flip->op_first;
4699 OP* const left = range->op_first;
4700 OP* const right = left->op_sibling;
4703 range->op_flags &= ~OPf_KIDS;
4704 range->op_first = NULL;
4706 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4707 listop->op_first->op_next = range->op_next;
4708 left->op_next = range->op_other;
4709 right->op_next = (OP*)listop;
4710 listop->op_next = listop->op_first;
4713 op_getmad(expr,(OP*)listop,'O');
4717 expr = (OP*)(listop);
4719 iterflags |= OPf_STACKED;
4722 expr = mod(force_list(expr), OP_GREPSTART);
4725 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4726 append_elem(OP_LIST, expr, scalar(sv))));
4727 assert(!loop->op_next);
4728 /* for my $x () sets OPpLVAL_INTRO;
4729 * for our $x () sets OPpOUR_INTRO */
4730 loop->op_private = (U8)iterpflags;
4731 #ifdef PL_OP_SLAB_ALLOC
4734 NewOp(1234,tmp,1,LOOP);
4735 Copy(loop,tmp,1,LISTOP);
4736 S_op_destroy(aTHX_ (OP*)loop);
4740 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
4742 loop->op_targ = padoff;
4743 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
4745 op_getmad(madsv, (OP*)loop, 'v');
4746 PL_copline = forline;
4747 return newSTATEOP(0, label, wop);
4751 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4756 if (type != OP_GOTO || label->op_type == OP_CONST) {
4757 /* "last()" means "last" */
4758 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4759 o = newOP(type, OPf_SPECIAL);
4761 o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
4762 ? SvPVx_nolen_const(((SVOP*)label)->op_sv)
4766 op_getmad(label,o,'L');
4772 /* Check whether it's going to be a goto &function */
4773 if (label->op_type == OP_ENTERSUB
4774 && !(label->op_flags & OPf_STACKED))
4775 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4776 o = newUNOP(type, OPf_STACKED, label);
4778 PL_hints |= HINT_BLOCK_SCOPE;
4782 /* if the condition is a literal array or hash
4783 (or @{ ... } etc), make a reference to it.
4786 S_ref_array_or_hash(pTHX_ OP *cond)
4789 && (cond->op_type == OP_RV2AV
4790 || cond->op_type == OP_PADAV
4791 || cond->op_type == OP_RV2HV
4792 || cond->op_type == OP_PADHV))
4794 return newUNOP(OP_REFGEN,
4795 0, mod(cond, OP_REFGEN));
4801 /* These construct the optree fragments representing given()
4804 entergiven and enterwhen are LOGOPs; the op_other pointer
4805 points up to the associated leave op. We need this so we
4806 can put it in the context and make break/continue work.
4807 (Also, of course, pp_enterwhen will jump straight to
4808 op_other if the match fails.)
4812 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
4813 I32 enter_opcode, I32 leave_opcode,
4814 PADOFFSET entertarg)
4820 NewOp(1101, enterop, 1, LOGOP);
4821 enterop->op_type = enter_opcode;
4822 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
4823 enterop->op_flags = (U8) OPf_KIDS;
4824 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
4825 enterop->op_private = 0;
4827 o = newUNOP(leave_opcode, 0, (OP *) enterop);
4830 enterop->op_first = scalar(cond);
4831 cond->op_sibling = block;
4833 o->op_next = LINKLIST(cond);
4834 cond->op_next = (OP *) enterop;
4837 /* This is a default {} block */
4838 enterop->op_first = block;
4839 enterop->op_flags |= OPf_SPECIAL;
4841 o->op_next = (OP *) enterop;
4844 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
4845 entergiven and enterwhen both
4848 enterop->op_next = LINKLIST(block);
4849 block->op_next = enterop->op_other = o;
4854 /* Does this look like a boolean operation? For these purposes
4855 a boolean operation is:
4856 - a subroutine call [*]
4857 - a logical connective
4858 - a comparison operator
4859 - a filetest operator, with the exception of -s -M -A -C
4860 - defined(), exists() or eof()
4861 - /$re/ or $foo =~ /$re/
4863 [*] possibly surprising
4866 S_looks_like_bool(pTHX_ const OP *o)
4869 switch(o->op_type) {
4871 return looks_like_bool(cLOGOPo->op_first);
4875 looks_like_bool(cLOGOPo->op_first)
4876 && looks_like_bool(cLOGOPo->op_first->op_sibling));
4880 case OP_NOT: case OP_XOR:
4881 /* Note that OP_DOR is not here */
4883 case OP_EQ: case OP_NE: case OP_LT:
4884 case OP_GT: case OP_LE: case OP_GE:
4886 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
4887 case OP_I_GT: case OP_I_LE: case OP_I_GE:
4889 case OP_SEQ: case OP_SNE: case OP_SLT:
4890 case OP_SGT: case OP_SLE: case OP_SGE:
4894 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
4895 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
4896 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
4897 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
4898 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
4899 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
4900 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
4901 case OP_FTTEXT: case OP_FTBINARY:
4903 case OP_DEFINED: case OP_EXISTS:
4904 case OP_MATCH: case OP_EOF:
4909 /* Detect comparisons that have been optimized away */
4910 if (cSVOPo->op_sv == &PL_sv_yes
4911 || cSVOPo->op_sv == &PL_sv_no)
4922 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
4926 return newGIVWHENOP(
4927 ref_array_or_hash(cond),
4929 OP_ENTERGIVEN, OP_LEAVEGIVEN,
4933 /* If cond is null, this is a default {} block */
4935 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
4937 const bool cond_llb = (!cond || looks_like_bool(cond));
4943 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
4945 scalar(ref_array_or_hash(cond)));
4948 return newGIVWHENOP(
4950 append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
4951 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
4955 =for apidoc cv_undef
4957 Clear out all the active components of a CV. This can happen either
4958 by an explicit C<undef &foo>, or by the reference count going to zero.
4959 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
4960 children can still follow the full lexical scope chain.
4966 Perl_cv_undef(pTHX_ CV *cv)
4970 if (CvFILE(cv) && !CvISXSUB(cv)) {
4971 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4972 Safefree(CvFILE(cv));
4977 if (!CvISXSUB(cv) && CvROOT(cv)) {
4978 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
4979 Perl_croak(aTHX_ "Can't undef active subroutine");
4982 PAD_SAVE_SETNULLPAD();
4984 op_free(CvROOT(cv));
4989 SvPOK_off((SV*)cv); /* forget prototype */
4994 /* remove CvOUTSIDE unless this is an undef rather than a free */
4995 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
4996 if (!CvWEAKOUTSIDE(cv))
4997 SvREFCNT_dec(CvOUTSIDE(cv));
4998 CvOUTSIDE(cv) = NULL;
5001 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
5004 if (CvISXSUB(cv) && CvXSUB(cv)) {
5007 /* delete all flags except WEAKOUTSIDE */
5008 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
5012 Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
5015 /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
5016 relying on SvCUR, and doubling up the buffer to hold CvFILE(). */
5017 if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
5018 || (p && (len != SvCUR(cv) /* Not the same length. */
5019 || memNE(p, SvPVX_const(cv), len))))
5020 && ckWARN_d(WARN_PROTOTYPE)) {
5021 SV* const msg = sv_newmortal();
5025 gv_efullname3(name = sv_newmortal(), gv, NULL);
5026 sv_setpvs(msg, "Prototype mismatch:");
5028 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
5030 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv));
5032 sv_catpvs(msg, ": none");
5033 sv_catpvs(msg, " vs ");
5035 Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
5037 sv_catpvs(msg, "none");
5038 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
5042 static void const_sv_xsub(pTHX_ CV* cv);
5046 =head1 Optree Manipulation Functions
5048 =for apidoc cv_const_sv
5050 If C<cv> is a constant sub eligible for inlining. returns the constant
5051 value returned by the sub. Otherwise, returns NULL.
5053 Constant subs can be created with C<newCONSTSUB> or as described in
5054 L<perlsub/"Constant Functions">.
5059 Perl_cv_const_sv(pTHX_ CV *cv)
5061 PERL_UNUSED_CONTEXT;
5064 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
5066 return CvCONST(cv) ? (SV*)CvXSUBANY(cv).any_ptr : NULL;
5069 /* op_const_sv: examine an optree to determine whether it's in-lineable.
5070 * Can be called in 3 ways:
5073 * look for a single OP_CONST with attached value: return the value
5075 * cv && CvCLONE(cv) && !CvCONST(cv)
5077 * examine the clone prototype, and if contains only a single
5078 * OP_CONST referencing a pad const, or a single PADSV referencing
5079 * an outer lexical, return a non-zero value to indicate the CV is
5080 * a candidate for "constizing" at clone time
5084 * We have just cloned an anon prototype that was marked as a const
5085 * candidiate. Try to grab the current value, and in the case of
5086 * PADSV, ignore it if it has multiple references. Return the value.
5090 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
5098 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
5099 o = cLISTOPo->op_first->op_sibling;
5101 for (; o; o = o->op_next) {
5102 const OPCODE type = o->op_type;
5104 if (sv && o->op_next == o)
5106 if (o->op_next != o) {
5107 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
5109 if (type == OP_DBSTATE)
5112 if (type == OP_LEAVESUB || type == OP_RETURN)
5116 if (type == OP_CONST && cSVOPo->op_sv)
5118 else if (cv && type == OP_CONST) {
5119 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5123 else if (cv && type == OP_PADSV) {
5124 if (CvCONST(cv)) { /* newly cloned anon */
5125 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5126 /* the candidate should have 1 ref from this pad and 1 ref
5127 * from the parent */
5128 if (!sv || SvREFCNT(sv) != 2)
5135 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
5136 sv = &PL_sv_undef; /* an arbitrary non-null value */
5151 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5154 /* This would be the return value, but the return cannot be reached. */
5155 OP* pegop = newOP(OP_NULL, 0);
5158 PERL_UNUSED_ARG(floor);
5168 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
5170 NORETURN_FUNCTION_END;
5175 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
5177 return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
5181 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5188 register CV *cv = NULL;
5190 /* If the subroutine has no body, no attributes, and no builtin attributes
5191 then it's just a sub declaration, and we may be able to get away with
5192 storing with a placeholder scalar in the symbol table, rather than a
5193 full GV and CV. If anything is present then it will take a full CV to
5195 const I32 gv_fetch_flags
5196 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5198 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
5199 const char * const name = o ? SvPVx_nolen_const(cSVOPo->op_sv) : NULL;
5202 assert(proto->op_type == OP_CONST);
5203 ps = SvPVx_const(((SVOP*)proto)->op_sv, ps_len);
5208 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
5209 SV * const sv = sv_newmortal();
5210 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
5211 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
5212 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
5213 aname = SvPVX_const(sv);
5218 gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
5219 : gv_fetchpv(aname ? aname
5220 : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5221 gv_fetch_flags, SVt_PVCV);
5223 if (!PL_madskills) {
5232 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
5233 maximum a prototype before. */
5234 if (SvTYPE(gv) > SVt_NULL) {
5235 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
5236 && ckWARN_d(WARN_PROTOTYPE))
5238 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
5240 cv_ckproto_len((CV*)gv, NULL, ps, ps_len);
5243 sv_setpvn((SV*)gv, ps, ps_len);
5245 sv_setiv((SV*)gv, -1);
5246 SvREFCNT_dec(PL_compcv);
5247 cv = PL_compcv = NULL;
5248 PL_sub_generation++;
5252 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
5254 #ifdef GV_UNIQUE_CHECK
5255 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
5256 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
5260 if (!block || !ps || *ps || attrs
5261 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5263 || block->op_type == OP_NULL
5268 const_sv = op_const_sv(block, NULL);
5271 const bool exists = CvROOT(cv) || CvXSUB(cv);
5273 #ifdef GV_UNIQUE_CHECK
5274 if (exists && GvUNIQUE(gv)) {
5275 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
5279 /* if the subroutine doesn't exist and wasn't pre-declared
5280 * with a prototype, assume it will be AUTOLOADed,
5281 * skipping the prototype check
5283 if (exists || SvPOK(cv))
5284 cv_ckproto_len(cv, gv, ps, ps_len);
5285 /* already defined (or promised)? */
5286 if (exists || GvASSUMECV(gv)) {
5289 || block->op_type == OP_NULL
5292 if (CvFLAGS(PL_compcv)) {
5293 /* might have had built-in attrs applied */
5294 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5296 /* just a "sub foo;" when &foo is already defined */
5297 SAVEFREESV(PL_compcv);
5302 && block->op_type != OP_NULL
5305 if (ckWARN(WARN_REDEFINE)
5307 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
5309 const line_t oldline = CopLINE(PL_curcop);
5310 if (PL_copline != NOLINE)
5311 CopLINE_set(PL_curcop, PL_copline);
5312 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5313 CvCONST(cv) ? "Constant subroutine %s redefined"
5314 : "Subroutine %s redefined", name);
5315 CopLINE_set(PL_curcop, oldline);
5318 if (!PL_minus_c) /* keep old one around for madskills */
5321 /* (PL_madskills unset in used file.) */
5329 SvREFCNT_inc_simple_void_NN(const_sv);
5331 assert(!CvROOT(cv) && !CvCONST(cv));
5332 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
5333 CvXSUBANY(cv).any_ptr = const_sv;
5334 CvXSUB(cv) = const_sv_xsub;
5340 cv = newCONSTSUB(NULL, name, const_sv);
5342 PL_sub_generation++;
5346 SvREFCNT_dec(PL_compcv);
5354 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
5355 * before we clobber PL_compcv.
5359 || block->op_type == OP_NULL
5363 /* Might have had built-in attributes applied -- propagate them. */
5364 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5365 if (CvGV(cv) && GvSTASH(CvGV(cv)))
5366 stash = GvSTASH(CvGV(cv));
5367 else if (CvSTASH(cv))
5368 stash = CvSTASH(cv);
5370 stash = PL_curstash;
5373 /* possibly about to re-define existing subr -- ignore old cv */
5374 rcv = (SV*)PL_compcv;
5375 if (name && GvSTASH(gv))
5376 stash = GvSTASH(gv);
5378 stash = PL_curstash;
5380 apply_attrs(stash, rcv, attrs, FALSE);
5382 if (cv) { /* must reuse cv if autoloaded */
5389 || block->op_type == OP_NULL) && !PL_madskills
5392 /* got here with just attrs -- work done, so bug out */
5393 SAVEFREESV(PL_compcv);
5396 /* transfer PL_compcv to cv */
5398 CvFLAGS(cv) = CvFLAGS(PL_compcv);
5399 if (!CvWEAKOUTSIDE(cv))
5400 SvREFCNT_dec(CvOUTSIDE(cv));
5401 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
5402 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
5403 CvOUTSIDE(PL_compcv) = 0;
5404 CvPADLIST(cv) = CvPADLIST(PL_compcv);
5405 CvPADLIST(PL_compcv) = 0;
5406 /* inner references to PL_compcv must be fixed up ... */
5407 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
5408 /* ... before we throw it away */
5409 SvREFCNT_dec(PL_compcv);
5411 if (PERLDB_INTER)/* Advice debugger on the new sub. */
5412 ++PL_sub_generation;
5419 if (strEQ(name, "import")) {
5420 PL_formfeed = (SV*)cv;
5421 Perl_warner(aTHX_ packWARN(WARN_VOID), "%lx\n", (long)cv);
5425 PL_sub_generation++;
5429 CvFILE_set_from_cop(cv, PL_curcop);
5430 CvSTASH(cv) = PL_curstash;
5433 sv_setpvn((SV*)cv, ps, ps_len);
5435 if (PL_error_count) {
5439 const char *s = strrchr(name, ':');
5441 if (strEQ(s, "BEGIN")) {
5442 const char not_safe[] =
5443 "BEGIN not safe after errors--compilation aborted";
5444 if (PL_in_eval & EVAL_KEEPERR)
5445 Perl_croak(aTHX_ not_safe);
5447 /* force display of errors found but not reported */
5448 sv_catpv(ERRSV, not_safe);
5449 Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
5459 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5460 mod(scalarseq(block), OP_LEAVESUBLV));
5461 block->op_attached = 1;
5464 /* This makes sub {}; work as expected. */
5465 if (block->op_type == OP_STUB) {
5466 OP* const newblock = newSTATEOP(0, NULL, 0);
5468 op_getmad(block,newblock,'B');
5475 block->op_attached = 1;
5476 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5478 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5479 OpREFCNT_set(CvROOT(cv), 1);
5480 CvSTART(cv) = LINKLIST(CvROOT(cv));
5481 CvROOT(cv)->op_next = 0;
5482 CALL_PEEP(CvSTART(cv));
5484 /* now that optimizer has done its work, adjust pad values */
5486 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
5489 assert(!CvCONST(cv));
5490 if (ps && !*ps && op_const_sv(block, cv))
5494 if (name || aname) {
5495 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5496 SV * const sv = newSV(0);
5497 SV * const tmpstr = sv_newmortal();
5498 GV * const db_postponed = gv_fetchpvs("DB::postponed",
5499 GV_ADDMULTI, SVt_PVHV);
5502 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5504 (long)PL_subline, (long)CopLINE(PL_curcop));
5505 gv_efullname3(tmpstr, gv, NULL);
5506 hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0);
5507 hv = GvHVn(db_postponed);
5508 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
5509 CV * const pcv = GvCV(db_postponed);
5515 call_sv((SV*)pcv, G_DISCARD);
5520 if (name && !PL_error_count)
5521 process_special_blocks(name, gv, cv);
5525 PL_copline = NOLINE;
5531 S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
5534 const char *const colon = strrchr(fullname,':');
5535 const char *const name = colon ? colon + 1 : fullname;
5538 if (strEQ(name, "BEGIN")) {
5539 const I32 oldscope = PL_scopestack_ix;
5541 SAVECOPFILE(&PL_compiling);
5542 SAVECOPLINE(&PL_compiling);
5544 DEBUG_x( dump_sub(gv) );
5545 Perl_av_create_and_push(aTHX_ &PL_beginav, (SV*)cv);
5546 GvCV(gv) = 0; /* cv has been hijacked */
5547 call_list(oldscope, PL_beginav);
5549 PL_curcop = &PL_compiling;
5550 CopHINTS_set(&PL_compiling, PL_hints);
5557 if strEQ(name, "END") {
5558 DEBUG_x( dump_sub(gv) );
5559 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, (SV*)cv);
5562 } else if (*name == 'U') {
5563 if (strEQ(name, "UNITCHECK")) {
5564 /* It's never too late to run a unitcheck block */
5565 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, (SV*)cv);
5569 } else if (*name == 'C') {
5570 if (strEQ(name, "CHECK")) {
5571 if (PL_main_start && ckWARN(WARN_VOID))
5572 Perl_warner(aTHX_ packWARN(WARN_VOID),
5573 "Too late to run CHECK block");
5574 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, (SV*)cv);
5578 } else if (*name == 'I') {
5579 if (strEQ(name, "INIT")) {
5580 if (PL_main_start && ckWARN(WARN_VOID))
5581 Perl_warner(aTHX_ packWARN(WARN_VOID),
5582 "Too late to run INIT block");
5583 Perl_av_create_and_push(aTHX_ &PL_initav, (SV*)cv);
5589 DEBUG_x( dump_sub(gv) );
5590 GvCV(gv) = 0; /* cv has been hijacked */
5595 =for apidoc newCONSTSUB
5597 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5598 eligible for inlining at compile-time.
5604 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
5609 const char *const temp_p = CopFILE(PL_curcop);
5610 const STRLEN len = temp_p ? strlen(temp_p) : 0;
5612 SV *const temp_sv = CopFILESV(PL_curcop);
5614 const char *const temp_p = temp_sv ? SvPV_const(temp_sv, len) : NULL;
5616 char *const file = savepvn(temp_p, temp_p ? len : 0);
5620 SAVECOPLINE(PL_curcop);
5621 CopLINE_set(PL_curcop, PL_copline);
5624 PL_hints &= ~HINT_BLOCK_SCOPE;
5627 SAVESPTR(PL_curstash);
5628 SAVECOPSTASH(PL_curcop);
5629 PL_curstash = stash;
5630 CopSTASH_set(PL_curcop,stash);
5633 /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
5634 and so doesn't get free()d. (It's expected to be from the C pre-
5635 processor __FILE__ directive). But we need a dynamically allocated one,
5636 and we need it to get freed. */
5637 cv = newXS_flags(name, const_sv_xsub, file, "", XS_DYNAMIC_FILENAME);
5638 CvXSUBANY(cv).any_ptr = sv;
5644 CopSTASH_free(PL_curcop);
5652 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
5653 const char *const filename, const char *const proto,
5656 CV *cv = newXS(name, subaddr, filename);
5658 if (flags & XS_DYNAMIC_FILENAME) {
5659 /* We need to "make arrangements" (ie cheat) to ensure that the
5660 filename lasts as long as the PVCV we just created, but also doesn't
5662 STRLEN filename_len = strlen(filename);
5663 STRLEN proto_and_file_len = filename_len;
5664 char *proto_and_file;
5668 proto_len = strlen(proto);
5669 proto_and_file_len += proto_len;
5671 Newx(proto_and_file, proto_and_file_len + 1, char);
5672 Copy(proto, proto_and_file, proto_len, char);
5673 Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
5676 proto_and_file = savepvn(filename, filename_len);
5679 /* This gets free()d. :-) */
5680 sv_usepvn_flags((SV*)cv, proto_and_file, proto_and_file_len,
5681 SV_HAS_TRAILING_NUL);
5683 /* This gives us the correct prototype, rather than one with the
5684 file name appended. */
5685 SvCUR_set(cv, proto_len);
5689 CvFILE(cv) = proto_and_file + proto_len;
5691 sv_setpv((SV *)cv, proto);
5697 =for apidoc U||newXS
5699 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
5700 static storage, as it is used directly as CvFILE(), without a copy being made.
5706 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
5709 GV * const gv = gv_fetchpv(name ? name :
5710 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5711 GV_ADDMULTI, SVt_PVCV);
5715 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
5717 if ((cv = (name ? GvCV(gv) : NULL))) {
5719 /* just a cached method */
5723 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5724 /* already defined (or promised) */
5725 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
5726 if (ckWARN(WARN_REDEFINE)) {
5727 GV * const gvcv = CvGV(cv);
5729 HV * const stash = GvSTASH(gvcv);
5731 const char *redefined_name = HvNAME_get(stash);
5732 if ( strEQ(redefined_name,"autouse") ) {
5733 const line_t oldline = CopLINE(PL_curcop);
5734 if (PL_copline != NOLINE)
5735 CopLINE_set(PL_curcop, PL_copline);
5736 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5737 CvCONST(cv) ? "Constant subroutine %s redefined"
5738 : "Subroutine %s redefined"
5740 CopLINE_set(PL_curcop, oldline);
5750 if (cv) /* must reuse cv if autoloaded */
5753 cv = (CV*)newSV_type(SVt_PVCV);
5757 PL_sub_generation++;
5761 (void)gv_fetchfile(filename);
5762 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
5763 an external constant string */
5765 CvXSUB(cv) = subaddr;
5768 process_special_blocks(name, gv, cv);
5780 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5785 OP* pegop = newOP(OP_NULL, 0);
5789 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
5790 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
5792 #ifdef GV_UNIQUE_CHECK
5794 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5798 if ((cv = GvFORM(gv))) {
5799 if (ckWARN(WARN_REDEFINE)) {
5800 const line_t oldline = CopLINE(PL_curcop);
5801 if (PL_copline != NOLINE)
5802 CopLINE_set(PL_curcop, PL_copline);
5803 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5804 o ? "Format %"SVf" redefined"
5805 : "Format STDOUT redefined", SVfARG(cSVOPo->op_sv));
5806 CopLINE_set(PL_curcop, oldline);
5813 CvFILE_set_from_cop(cv, PL_curcop);
5816 pad_tidy(padtidy_FORMAT);
5817 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5818 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5819 OpREFCNT_set(CvROOT(cv), 1);
5820 CvSTART(cv) = LINKLIST(CvROOT(cv));
5821 CvROOT(cv)->op_next = 0;
5822 CALL_PEEP(CvSTART(cv));
5824 op_getmad(o,pegop,'n');
5825 op_getmad_weak(block, pegop, 'b');
5829 PL_copline = NOLINE;
5837 Perl_newANONLIST(pTHX_ OP *o)
5839 return convert(OP_ANONLIST, OPf_SPECIAL, o);
5843 Perl_newANONHASH(pTHX_ OP *o)
5845 return convert(OP_ANONHASH, OPf_SPECIAL, o);
5849 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5851 return newANONATTRSUB(floor, proto, NULL, block);
5855 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5857 return newUNOP(OP_REFGEN, 0,
5858 newSVOP(OP_ANONCODE, 0,
5859 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5863 Perl_oopsAV(pTHX_ OP *o)
5866 switch (o->op_type) {
5868 o->op_type = OP_PADAV;
5869 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5870 return ref(o, OP_RV2AV);
5873 o->op_type = OP_RV2AV;
5874 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5879 if (ckWARN_d(WARN_INTERNAL))
5880 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
5887 Perl_oopsHV(pTHX_ OP *o)
5890 switch (o->op_type) {
5893 o->op_type = OP_PADHV;
5894 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5895 return ref(o, OP_RV2HV);
5899 o->op_type = OP_RV2HV;
5900 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5905 if (ckWARN_d(WARN_INTERNAL))
5906 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
5913 Perl_newAVREF(pTHX_ OP *o)
5916 if (o->op_type == OP_PADANY) {
5917 o->op_type = OP_PADAV;
5918 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5921 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5922 && ckWARN(WARN_DEPRECATED)) {
5923 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5924 "Using an array as a reference is deprecated");
5926 return newUNOP(OP_RV2AV, 0, scalar(o));
5930 Perl_newGVREF(pTHX_ I32 type, OP *o)
5932 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5933 return newUNOP(OP_NULL, 0, o);
5934 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5938 Perl_newHVREF(pTHX_ OP *o)
5941 if (o->op_type == OP_PADANY) {
5942 o->op_type = OP_PADHV;
5943 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5946 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5947 && ckWARN(WARN_DEPRECATED)) {
5948 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5949 "Using a hash as a reference is deprecated");
5951 return newUNOP(OP_RV2HV, 0, scalar(o));
5955 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5957 return newUNOP(OP_RV2CV, flags, scalar(o));
5961 Perl_newSVREF(pTHX_ OP *o)
5964 if (o->op_type == OP_PADANY) {
5965 o->op_type = OP_PADSV;
5966 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5969 return newUNOP(OP_RV2SV, 0, scalar(o));
5972 /* Check routines. See the comments at the top of this file for details
5973 * on when these are called */
5976 Perl_ck_anoncode(pTHX_ OP *o)
5978 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
5980 cSVOPo->op_sv = NULL;
5985 Perl_ck_bitop(pTHX_ OP *o)
5988 #define OP_IS_NUMCOMPARE(op) \
5989 ((op) == OP_LT || (op) == OP_I_LT || \
5990 (op) == OP_GT || (op) == OP_I_GT || \
5991 (op) == OP_LE || (op) == OP_I_LE || \
5992 (op) == OP_GE || (op) == OP_I_GE || \
5993 (op) == OP_EQ || (op) == OP_I_EQ || \
5994 (op) == OP_NE || (op) == OP_I_NE || \
5995 (op) == OP_NCMP || (op) == OP_I_NCMP)
5996 o->op_private = (U8)(PL_hints & HINT_INTEGER);
5997 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
5998 && (o->op_type == OP_BIT_OR
5999 || o->op_type == OP_BIT_AND
6000 || o->op_type == OP_BIT_XOR))
6002 const OP * const left = cBINOPo->op_first;
6003 const OP * const right = left->op_sibling;
6004 if ((OP_IS_NUMCOMPARE(left->op_type) &&
6005 (left->op_flags & OPf_PARENS) == 0) ||
6006 (OP_IS_NUMCOMPARE(right->op_type) &&
6007 (right->op_flags & OPf_PARENS) == 0))
6008 if (ckWARN(WARN_PRECEDENCE))
6009 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
6010 "Possible precedence problem on bitwise %c operator",
6011 o->op_type == OP_BIT_OR ? '|'
6012 : o->op_type == OP_BIT_AND ? '&' : '^'
6019 Perl_ck_concat(pTHX_ OP *o)
6021 const OP * const kid = cUNOPo->op_first;
6022 PERL_UNUSED_CONTEXT;
6023 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
6024 !(kUNOP->op_first->op_flags & OPf_MOD))
6025 o->op_flags |= OPf_STACKED;
6030 Perl_ck_spair(pTHX_ OP *o)
6033 if (o->op_flags & OPf_KIDS) {
6036 const OPCODE type = o->op_type;
6037 o = modkids(ck_fun(o), type);
6038 kid = cUNOPo->op_first;
6039 newop = kUNOP->op_first->op_sibling;
6041 const OPCODE type = newop->op_type;
6042 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
6043 type == OP_PADAV || type == OP_PADHV ||
6044 type == OP_RV2AV || type == OP_RV2HV)
6048 op_getmad(kUNOP->op_first,newop,'K');
6050 op_free(kUNOP->op_first);
6052 kUNOP->op_first = newop;
6054 o->op_ppaddr = PL_ppaddr[++o->op_type];
6059 Perl_ck_delete(pTHX_ OP *o)
6063 if (o->op_flags & OPf_KIDS) {
6064 OP * const kid = cUNOPo->op_first;
6065 switch (kid->op_type) {
6067 o->op_flags |= OPf_SPECIAL;
6070 o->op_private |= OPpSLICE;
6073 o->op_flags |= OPf_SPECIAL;
6078 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
6087 Perl_ck_die(pTHX_ OP *o)
6090 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6096 Perl_ck_eof(pTHX_ OP *o)
6100 if (o->op_flags & OPf_KIDS) {
6101 if (cLISTOPo->op_first->op_type == OP_STUB) {
6103 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
6105 op_getmad(o,newop,'O');
6117 Perl_ck_eval(pTHX_ OP *o)
6120 PL_hints |= HINT_BLOCK_SCOPE;
6121 if (o->op_flags & OPf_KIDS) {
6122 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6125 o->op_flags &= ~OPf_KIDS;
6128 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
6134 cUNOPo->op_first = 0;
6139 NewOp(1101, enter, 1, LOGOP);
6140 enter->op_type = OP_ENTERTRY;
6141 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
6142 enter->op_private = 0;
6144 /* establish postfix order */
6145 enter->op_next = (OP*)enter;
6147 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
6148 o->op_type = OP_LEAVETRY;
6149 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
6150 enter->op_other = o;
6151 op_getmad(oldo,o,'O');
6165 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
6166 op_getmad(oldo,o,'O');
6168 o->op_targ = (PADOFFSET)PL_hints;
6169 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
6170 /* Store a copy of %^H that pp_entereval can pick up.
6171 OPf_SPECIAL flags the opcode as being for this purpose,
6172 so that it in turn will return a copy at every
6174 OP *hhop = newSVOP(OP_CONST, OPf_SPECIAL,
6175 (SV*)Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv)));
6176 cUNOPo->op_first->op_sibling = hhop;
6177 o->op_private |= OPpEVAL_HAS_HH;
6183 Perl_ck_exit(pTHX_ OP *o)
6186 HV * const table = GvHV(PL_hintgv);
6188 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
6189 if (svp && *svp && SvTRUE(*svp))
6190 o->op_private |= OPpEXIT_VMSISH;
6192 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6198 Perl_ck_exec(pTHX_ OP *o)
6200 if (o->op_flags & OPf_STACKED) {
6203 kid = cUNOPo->op_first->op_sibling;
6204 if (kid->op_type == OP_RV2GV)
6213 Perl_ck_exists(pTHX_ OP *o)
6217 if (o->op_flags & OPf_KIDS) {
6218 OP * const kid = cUNOPo->op_first;
6219 if (kid->op_type == OP_ENTERSUB) {
6220 (void) ref(kid, o->op_type);
6221 if (kid->op_type != OP_RV2CV && !PL_error_count)
6222 Perl_croak(aTHX_ "%s argument is not a subroutine name",
6224 o->op_private |= OPpEXISTS_SUB;
6226 else if (kid->op_type == OP_AELEM)
6227 o->op_flags |= OPf_SPECIAL;
6228 else if (kid->op_type != OP_HELEM)
6229 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
6237 Perl_ck_rvconst(pTHX_ register OP *o)
6240 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6242 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6243 if (o->op_type == OP_RV2CV)
6244 o->op_private &= ~1;
6246 if (kid->op_type == OP_CONST) {
6249 SV * const kidsv = kid->op_sv;
6251 /* Is it a constant from cv_const_sv()? */
6252 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
6253 SV * const rsv = SvRV(kidsv);
6254 const svtype type = SvTYPE(rsv);
6255 const char *badtype = NULL;
6257 switch (o->op_type) {
6259 if (type > SVt_PVMG)
6260 badtype = "a SCALAR";
6263 if (type != SVt_PVAV)
6264 badtype = "an ARRAY";
6267 if (type != SVt_PVHV)
6271 if (type != SVt_PVCV)
6276 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
6279 else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
6280 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
6281 /* If this is an access to a stash, disable "strict refs", because
6282 * stashes aren't auto-vivified at compile-time (unless we store
6283 * symbols in them), and we don't want to produce a run-time
6284 * stricture error when auto-vivifying the stash. */
6285 const char *s = SvPV_nolen(kidsv);
6286 const STRLEN l = SvCUR(kidsv);
6287 if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
6288 o->op_private &= ~HINT_STRICT_REFS;
6290 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
6291 const char *badthing;
6292 switch (o->op_type) {
6294 badthing = "a SCALAR";
6297 badthing = "an ARRAY";
6300 badthing = "a HASH";
6308 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
6309 SVfARG(kidsv), badthing);
6312 * This is a little tricky. We only want to add the symbol if we
6313 * didn't add it in the lexer. Otherwise we get duplicate strict
6314 * warnings. But if we didn't add it in the lexer, we must at
6315 * least pretend like we wanted to add it even if it existed before,
6316 * or we get possible typo warnings. OPpCONST_ENTERED says
6317 * whether the lexer already added THIS instance of this symbol.
6319 iscv = (o->op_type == OP_RV2CV) * 2;
6321 gv = gv_fetchsv(kidsv,
6322 iscv | !(kid->op_private & OPpCONST_ENTERED),
6325 : o->op_type == OP_RV2SV
6327 : o->op_type == OP_RV2AV
6329 : o->op_type == OP_RV2HV
6332 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
6334 kid->op_type = OP_GV;
6335 SvREFCNT_dec(kid->op_sv);
6337 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
6338 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
6339 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
6341 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc_simple_NN(gv));
6343 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
6345 kid->op_private = 0;
6346 kid->op_ppaddr = PL_ppaddr[OP_GV];
6353 Perl_ck_ftst(pTHX_ OP *o)
6356 const I32 type = o->op_type;
6358 if (o->op_flags & OPf_REF) {
6361 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
6362 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6363 const OPCODE kidtype = kid->op_type;
6365 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6366 OP * const newop = newGVOP(type, OPf_REF,
6367 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
6369 op_getmad(o,newop,'O');
6375 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o))
6376 o->op_private |= OPpFT_ACCESS;
6377 if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst)
6378 && kidtype != OP_STAT && kidtype != OP_LSTAT)
6379 o->op_private |= OPpFT_STACKED;
6387 if (type == OP_FTTTY)
6388 o = newGVOP(type, OPf_REF, PL_stdingv);
6390 o = newUNOP(type, 0, newDEFSVOP());
6391 op_getmad(oldo,o,'O');
6397 Perl_ck_fun(pTHX_ OP *o)
6400 const int type = o->op_type;
6401 register I32 oa = PL_opargs[type] >> OASHIFT;
6403 if (o->op_flags & OPf_STACKED) {
6404 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
6407 return no_fh_allowed(o);
6410 if (o->op_flags & OPf_KIDS) {
6411 OP **tokid = &cLISTOPo->op_first;
6412 register OP *kid = cLISTOPo->op_first;
6416 if (kid->op_type == OP_PUSHMARK ||
6417 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
6419 tokid = &kid->op_sibling;
6420 kid = kid->op_sibling;
6422 if (!kid && PL_opargs[type] & OA_DEFGV)
6423 *tokid = kid = newDEFSVOP();
6427 sibl = kid->op_sibling;
6429 if (!sibl && kid->op_type == OP_STUB) {
6436 /* list seen where single (scalar) arg expected? */
6437 if (numargs == 1 && !(oa >> 4)
6438 && kid->op_type == OP_LIST && type != OP_SCALAR)
6440 return too_many_arguments(o,PL_op_desc[type]);
6453 if ((type == OP_PUSH || type == OP_UNSHIFT)
6454 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
6455 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6456 "Useless use of %s with no values",
6459 if (kid->op_type == OP_CONST &&
6460 (kid->op_private & OPpCONST_BARE))
6462 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
6463 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
6464 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6465 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6466 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
6467 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6469 op_getmad(kid,newop,'K');
6474 kid->op_sibling = sibl;
6477 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
6478 bad_type(numargs, "array", PL_op_desc[type], kid);
6482 if (kid->op_type == OP_CONST &&
6483 (kid->op_private & OPpCONST_BARE))
6485 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
6486 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
6487 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6488 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6489 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
6490 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6492 op_getmad(kid,newop,'K');
6497 kid->op_sibling = sibl;
6500 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
6501 bad_type(numargs, "hash", PL_op_desc[type], kid);
6506 OP * const newop = newUNOP(OP_NULL, 0, kid);
6507 kid->op_sibling = 0;
6509 newop->op_next = newop;
6511 kid->op_sibling = sibl;
6516 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
6517 if (kid->op_type == OP_CONST &&
6518 (kid->op_private & OPpCONST_BARE))
6520 OP * const newop = newGVOP(OP_GV, 0,
6521 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
6522 if (!(o->op_private & 1) && /* if not unop */
6523 kid == cLISTOPo->op_last)
6524 cLISTOPo->op_last = newop;
6526 op_getmad(kid,newop,'K');
6532 else if (kid->op_type == OP_READLINE) {
6533 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
6534 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
6537 I32 flags = OPf_SPECIAL;
6541 /* is this op a FH constructor? */
6542 if (is_handle_constructor(o,numargs)) {
6543 const char *name = NULL;
6547 /* Set a flag to tell rv2gv to vivify
6548 * need to "prove" flag does not mean something
6549 * else already - NI-S 1999/05/07
6552 if (kid->op_type == OP_PADSV) {
6554 = PAD_COMPNAME_SV(kid->op_targ);
6555 name = SvPV_const(namesv, len);
6557 else if (kid->op_type == OP_RV2SV
6558 && kUNOP->op_first->op_type == OP_GV)
6560 GV * const gv = cGVOPx_gv(kUNOP->op_first);
6562 len = GvNAMELEN(gv);
6564 else if (kid->op_type == OP_AELEM
6565 || kid->op_type == OP_HELEM)
6568 OP *op = ((BINOP*)kid)->op_first;
6572 const char * const a =
6573 kid->op_type == OP_AELEM ?
6575 if (((op->op_type == OP_RV2AV) ||
6576 (op->op_type == OP_RV2HV)) &&
6577 (firstop = ((UNOP*)op)->op_first) &&
6578 (firstop->op_type == OP_GV)) {
6579 /* packagevar $a[] or $h{} */
6580 GV * const gv = cGVOPx_gv(firstop);
6588 else if (op->op_type == OP_PADAV
6589 || op->op_type == OP_PADHV) {
6590 /* lexicalvar $a[] or $h{} */
6591 const char * const padname =
6592 PAD_COMPNAME_PV(op->op_targ);
6601 name = SvPV_const(tmpstr, len);
6606 name = "__ANONIO__";
6613 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
6614 namesv = PAD_SVl(targ);
6615 SvUPGRADE(namesv, SVt_PV);
6617 sv_setpvn(namesv, "$", 1);
6618 sv_catpvn(namesv, name, len);
6621 kid->op_sibling = 0;
6622 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
6623 kid->op_targ = targ;
6624 kid->op_private |= priv;
6626 kid->op_sibling = sibl;
6632 mod(scalar(kid), type);
6636 tokid = &kid->op_sibling;
6637 kid = kid->op_sibling;
6640 if (kid && kid->op_type != OP_STUB)
6641 return too_many_arguments(o,OP_DESC(o));
6642 o->op_private |= numargs;
6644 /* FIXME - should the numargs move as for the PERL_MAD case? */
6645 o->op_private |= numargs;
6647 return too_many_arguments(o,OP_DESC(o));
6651 else if (PL_opargs[type] & OA_DEFGV) {
6653 OP *newop = newUNOP(type, 0, newDEFSVOP());
6654 op_getmad(o,newop,'O');
6657 /* Ordering of these two is important to keep f_map.t passing. */
6659 return newUNOP(type, 0, newDEFSVOP());
6664 while (oa & OA_OPTIONAL)
6666 if (oa && oa != OA_LIST)
6667 return too_few_arguments(o,OP_DESC(o));
6673 Perl_ck_glob(pTHX_ OP *o)
6679 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
6680 append_elem(OP_GLOB, o, newDEFSVOP());
6682 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
6683 && GvCVu(gv) && GvIMPORTED_CV(gv)))
6685 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6688 #if !defined(PERL_EXTERNAL_GLOB)
6689 /* XXX this can be tightened up and made more failsafe. */
6690 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
6693 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
6694 newSVpvs("File::Glob"), NULL, NULL, NULL);
6695 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6696 glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
6697 GvCV(gv) = GvCV(glob_gv);
6698 SvREFCNT_inc_void((SV*)GvCV(gv));
6699 GvIMPORTED_CV_on(gv);
6702 #endif /* PERL_EXTERNAL_GLOB */
6704 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6705 append_elem(OP_GLOB, o,
6706 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
6707 o->op_type = OP_LIST;
6708 o->op_ppaddr = PL_ppaddr[OP_LIST];
6709 cLISTOPo->op_first->op_type = OP_PUSHMARK;
6710 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
6711 cLISTOPo->op_first->op_targ = 0;
6712 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
6713 append_elem(OP_LIST, o,
6714 scalar(newUNOP(OP_RV2CV, 0,
6715 newGVOP(OP_GV, 0, gv)))));
6716 o = newUNOP(OP_NULL, 0, ck_subr(o));
6717 o->op_targ = OP_GLOB; /* hint at what it used to be */
6720 gv = newGVgen("main");
6722 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
6728 Perl_ck_grep(pTHX_ OP *o)
6733 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
6736 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
6737 /* don't allocate gwop here, as we may leak it if PL_error_count > 0 */
6739 if (o->op_flags & OPf_STACKED) {
6742 kid = cLISTOPo->op_first->op_sibling;
6743 if (!cUNOPx(kid)->op_next)
6744 Perl_croak(aTHX_ "panic: ck_grep");
6745 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
6748 NewOp(1101, gwop, 1, LOGOP);
6749 kid->op_next = (OP*)gwop;
6750 o->op_flags &= ~OPf_STACKED;
6752 kid = cLISTOPo->op_first->op_sibling;
6753 if (type == OP_MAPWHILE)
6760 kid = cLISTOPo->op_first->op_sibling;
6761 if (kid->op_type != OP_NULL)
6762 Perl_croak(aTHX_ "panic: ck_grep");
6763 kid = kUNOP->op_first;
6766 NewOp(1101, gwop, 1, LOGOP);
6767 gwop->op_type = type;
6768 gwop->op_ppaddr = PL_ppaddr[type];
6769 gwop->op_first = listkids(o);
6770 gwop->op_flags |= OPf_KIDS;
6771 gwop->op_other = LINKLIST(kid);
6772 kid->op_next = (OP*)gwop;
6773 offset = pad_findmy("$_");
6774 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
6775 o->op_private = gwop->op_private = 0;
6776 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
6779 o->op_private = gwop->op_private = OPpGREP_LEX;
6780 gwop->op_targ = o->op_targ = offset;
6783 kid = cLISTOPo->op_first->op_sibling;
6784 if (!kid || !kid->op_sibling)
6785 return too_few_arguments(o,OP_DESC(o));
6786 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
6787 mod(kid, OP_GREPSTART);
6793 Perl_ck_index(pTHX_ OP *o)
6795 if (o->op_flags & OPf_KIDS) {
6796 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6798 kid = kid->op_sibling; /* get past "big" */
6799 if (kid && kid->op_type == OP_CONST)
6800 fbm_compile(((SVOP*)kid)->op_sv, 0);
6806 Perl_ck_lengthconst(pTHX_ OP *o)
6808 /* XXX length optimization goes here */
6813 Perl_ck_lfun(pTHX_ OP *o)
6815 const OPCODE type = o->op_type;
6816 return modkids(ck_fun(o), type);
6820 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
6822 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
6823 switch (cUNOPo->op_first->op_type) {
6825 /* This is needed for
6826 if (defined %stash::)
6827 to work. Do not break Tk.
6829 break; /* Globals via GV can be undef */
6831 case OP_AASSIGN: /* Is this a good idea? */
6832 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6833 "defined(@array) is deprecated");
6834 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6835 "\t(Maybe you should just omit the defined()?)\n");
6838 /* This is needed for
6839 if (defined %stash::)
6840 to work. Do not break Tk.
6842 break; /* Globals via GV can be undef */
6844 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6845 "defined(%%hash) is deprecated");
6846 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6847 "\t(Maybe you should just omit the defined()?)\n");
6858 Perl_ck_readline(pTHX_ OP *o)
6860 if (!(o->op_flags & OPf_KIDS)) {
6862 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
6864 op_getmad(o,newop,'O');
6874 Perl_ck_rfun(pTHX_ OP *o)
6876 const OPCODE type = o->op_type;
6877 return refkids(ck_fun(o), type);
6881 Perl_ck_listiob(pTHX_ OP *o)
6885 kid = cLISTOPo->op_first;
6888 kid = cLISTOPo->op_first;
6890 if (kid->op_type == OP_PUSHMARK)
6891 kid = kid->op_sibling;
6892 if (kid && o->op_flags & OPf_STACKED)
6893 kid = kid->op_sibling;
6894 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6895 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6896 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6897 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6898 cLISTOPo->op_first->op_sibling = kid;
6899 cLISTOPo->op_last = kid;
6900 kid = kid->op_sibling;
6905 append_elem(o->op_type, o, newDEFSVOP());
6911 Perl_ck_smartmatch(pTHX_ OP *o)
6914 if (0 == (o->op_flags & OPf_SPECIAL)) {
6915 OP *first = cBINOPo->op_first;
6916 OP *second = first->op_sibling;
6918 /* Implicitly take a reference to an array or hash */
6919 first->op_sibling = NULL;
6920 first = cBINOPo->op_first = ref_array_or_hash(first);
6921 second = first->op_sibling = ref_array_or_hash(second);
6923 /* Implicitly take a reference to a regular expression */
6924 if (first->op_type == OP_MATCH) {
6925 first->op_type = OP_QR;
6926 first->op_ppaddr = PL_ppaddr[OP_QR];
6928 if (second->op_type == OP_MATCH) {
6929 second->op_type = OP_QR;
6930 second->op_ppaddr = PL_ppaddr[OP_QR];
6939 Perl_ck_sassign(pTHX_ OP *o)
6941 OP * const kid = cLISTOPo->op_first;
6942 /* has a disposable target? */
6943 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6944 && !(kid->op_flags & OPf_STACKED)
6945 /* Cannot steal the second time! */
6946 && !(kid->op_private & OPpTARGET_MY))
6948 OP * const kkid = kid->op_sibling;
6950 /* Can just relocate the target. */
6951 if (kkid && kkid->op_type == OP_PADSV
6952 && !(kkid->op_private & OPpLVAL_INTRO))
6954 kid->op_targ = kkid->op_targ;
6956 /* Now we do not need PADSV and SASSIGN. */
6957 kid->op_sibling = o->op_sibling; /* NULL */
6958 cLISTOPo->op_first = NULL;
6960 op_getmad(o,kid,'O');
6961 op_getmad(kkid,kid,'M');
6966 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6970 if (kid->op_sibling) {
6971 OP *kkid = kid->op_sibling;
6972 if (kkid->op_type == OP_PADSV
6973 && (kkid->op_private & OPpLVAL_INTRO)
6974 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
6975 o->op_private |= OPpASSIGN_STATE;
6976 /* hijacking PADSTALE for uninitialized state variables */
6977 SvPADSTALE_on(PAD_SVl(kkid->op_targ));
6984 Perl_ck_match(pTHX_ OP *o)
6987 if (o->op_type != OP_QR && PL_compcv) {
6988 const PADOFFSET offset = pad_findmy("$_");
6989 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
6990 o->op_targ = offset;
6991 o->op_private |= OPpTARGET_MY;
6994 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
6995 o->op_private |= OPpRUNTIME;
7000 Perl_ck_method(pTHX_ OP *o)
7002 OP * const kid = cUNOPo->op_first;
7003 if (kid->op_type == OP_CONST) {
7004 SV* sv = kSVOP->op_sv;
7005 const char * const method = SvPVX_const(sv);
7006 if (!(strchr(method, ':') || strchr(method, '\''))) {
7008 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
7009 sv = newSVpvn_share(method, SvCUR(sv), 0);
7012 kSVOP->op_sv = NULL;
7014 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
7016 op_getmad(o,cmop,'O');
7027 Perl_ck_null(pTHX_ OP *o)
7029 PERL_UNUSED_CONTEXT;
7034 Perl_ck_open(pTHX_ OP *o)
7037 HV * const table = GvHV(PL_hintgv);
7039 SV **svp = hv_fetchs(table, "open_IN", FALSE);
7041 const I32 mode = mode_from_discipline(*svp);
7042 if (mode & O_BINARY)
7043 o->op_private |= OPpOPEN_IN_RAW;
7044 else if (mode & O_TEXT)
7045 o->op_private |= OPpOPEN_IN_CRLF;
7048 svp = hv_fetchs(table, "open_OUT", FALSE);
7050 const I32 mode = mode_from_discipline(*svp);
7051 if (mode & O_BINARY)
7052 o->op_private |= OPpOPEN_OUT_RAW;
7053 else if (mode & O_TEXT)
7054 o->op_private |= OPpOPEN_OUT_CRLF;
7057 if (o->op_type == OP_BACKTICK) {
7058 if (!(o->op_flags & OPf_KIDS)) {
7059 OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
7061 op_getmad(o,newop,'O');
7070 /* In case of three-arg dup open remove strictness
7071 * from the last arg if it is a bareword. */
7072 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
7073 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
7077 if ((last->op_type == OP_CONST) && /* The bareword. */
7078 (last->op_private & OPpCONST_BARE) &&
7079 (last->op_private & OPpCONST_STRICT) &&
7080 (oa = first->op_sibling) && /* The fh. */
7081 (oa = oa->op_sibling) && /* The mode. */
7082 (oa->op_type == OP_CONST) &&
7083 SvPOK(((SVOP*)oa)->op_sv) &&
7084 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
7085 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
7086 (last == oa->op_sibling)) /* The bareword. */
7087 last->op_private &= ~OPpCONST_STRICT;
7093 Perl_ck_repeat(pTHX_ OP *o)
7095 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
7096 o->op_private |= OPpREPEAT_DOLIST;
7097 cBINOPo->op_first = force_list(cBINOPo->op_first);
7105 Perl_ck_require(pTHX_ OP *o)
7110 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
7111 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7113 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
7114 SV * const sv = kid->op_sv;
7115 U32 was_readonly = SvREADONLY(sv);
7120 sv_force_normal_flags(sv, 0);
7121 assert(!SvREADONLY(sv));
7128 for (s = SvPVX(sv); *s; s++) {
7129 if (*s == ':' && s[1] == ':') {
7130 const STRLEN len = strlen(s+2)+1;
7132 Move(s+2, s+1, len, char);
7133 SvCUR_set(sv, SvCUR(sv) - 1);
7136 sv_catpvs(sv, ".pm");
7137 SvFLAGS(sv) |= was_readonly;
7141 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
7142 /* handle override, if any */
7143 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
7144 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7145 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
7146 gv = gvp ? *gvp : NULL;
7150 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7151 OP * const kid = cUNOPo->op_first;
7154 cUNOPo->op_first = 0;
7158 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
7159 append_elem(OP_LIST, kid,
7160 scalar(newUNOP(OP_RV2CV, 0,
7163 op_getmad(o,newop,'O');
7171 Perl_ck_return(pTHX_ OP *o)
7174 if (CvLVALUE(PL_compcv)) {
7176 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
7177 mod(kid, OP_LEAVESUBLV);
7183 Perl_ck_select(pTHX_ OP *o)
7187 if (o->op_flags & OPf_KIDS) {
7188 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7189 if (kid && kid->op_sibling) {
7190 o->op_type = OP_SSELECT;
7191 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
7193 return fold_constants(o);
7197 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7198 if (kid && kid->op_type == OP_RV2GV)
7199 kid->op_private &= ~HINT_STRICT_REFS;
7204 Perl_ck_shift(pTHX_ OP *o)
7207 const I32 type = o->op_type;
7209 if (!(o->op_flags & OPf_KIDS)) {
7211 /* FIXME - this can be refactored to reduce code in #ifdefs */
7213 OP * const oldo = o;
7217 argop = newUNOP(OP_RV2AV, 0,
7218 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
7220 o = newUNOP(type, 0, scalar(argop));
7221 op_getmad(oldo,o,'O');
7224 return newUNOP(type, 0, scalar(argop));
7227 return scalar(modkids(ck_fun(o), type));
7231 Perl_ck_sort(pTHX_ OP *o)
7236 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
7237 HV * const hinthv = GvHV(PL_hintgv);
7239 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
7241 const I32 sorthints = (I32)SvIV(*svp);
7242 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
7243 o->op_private |= OPpSORT_QSORT;
7244 if ((sorthints & HINT_SORT_STABLE) != 0)
7245 o->op_private |= OPpSORT_STABLE;
7250 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
7252 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7253 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
7255 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
7257 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
7259 if (kid->op_type == OP_SCOPE) {
7263 else if (kid->op_type == OP_LEAVE) {
7264 if (o->op_type == OP_SORT) {
7265 op_null(kid); /* wipe out leave */
7268 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
7269 if (k->op_next == kid)
7271 /* don't descend into loops */
7272 else if (k->op_type == OP_ENTERLOOP
7273 || k->op_type == OP_ENTERITER)
7275 k = cLOOPx(k)->op_lastop;
7280 kid->op_next = 0; /* just disconnect the leave */
7281 k = kLISTOP->op_first;
7286 if (o->op_type == OP_SORT) {
7287 /* provide scalar context for comparison function/block */
7293 o->op_flags |= OPf_SPECIAL;
7295 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
7298 firstkid = firstkid->op_sibling;
7301 /* provide list context for arguments */
7302 if (o->op_type == OP_SORT)
7309 S_simplify_sort(pTHX_ OP *o)
7312 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7317 if (!(o->op_flags & OPf_STACKED))
7319 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7320 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
7321 kid = kUNOP->op_first; /* get past null */
7322 if (kid->op_type != OP_SCOPE)
7324 kid = kLISTOP->op_last; /* get past scope */
7325 switch(kid->op_type) {
7333 k = kid; /* remember this node*/
7334 if (kBINOP->op_first->op_type != OP_RV2SV)
7336 kid = kBINOP->op_first; /* get past cmp */
7337 if (kUNOP->op_first->op_type != OP_GV)
7339 kid = kUNOP->op_first; /* get past rv2sv */
7341 if (GvSTASH(gv) != PL_curstash)
7343 gvname = GvNAME(gv);
7344 if (*gvname == 'a' && gvname[1] == '\0')
7346 else if (*gvname == 'b' && gvname[1] == '\0')
7351 kid = k; /* back to cmp */
7352 if (kBINOP->op_last->op_type != OP_RV2SV)
7354 kid = kBINOP->op_last; /* down to 2nd arg */
7355 if (kUNOP->op_first->op_type != OP_GV)
7357 kid = kUNOP->op_first; /* get past rv2sv */
7359 if (GvSTASH(gv) != PL_curstash)
7361 gvname = GvNAME(gv);
7363 ? !(*gvname == 'a' && gvname[1] == '\0')
7364 : !(*gvname == 'b' && gvname[1] == '\0'))
7366 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
7368 o->op_private |= OPpSORT_DESCEND;
7369 if (k->op_type == OP_NCMP)
7370 o->op_private |= OPpSORT_NUMERIC;
7371 if (k->op_type == OP_I_NCMP)
7372 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
7373 kid = cLISTOPo->op_first->op_sibling;
7374 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
7376 op_getmad(kid,o,'S'); /* then delete it */
7378 op_free(kid); /* then delete it */
7383 Perl_ck_split(pTHX_ OP *o)
7388 if (o->op_flags & OPf_STACKED)
7389 return no_fh_allowed(o);
7391 kid = cLISTOPo->op_first;
7392 if (kid->op_type != OP_NULL)
7393 Perl_croak(aTHX_ "panic: ck_split");
7394 kid = kid->op_sibling;
7395 op_free(cLISTOPo->op_first);
7396 cLISTOPo->op_first = kid;
7398 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
7399 cLISTOPo->op_last = kid; /* There was only one element previously */
7402 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
7403 OP * const sibl = kid->op_sibling;
7404 kid->op_sibling = 0;
7405 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
7406 if (cLISTOPo->op_first == cLISTOPo->op_last)
7407 cLISTOPo->op_last = kid;
7408 cLISTOPo->op_first = kid;
7409 kid->op_sibling = sibl;
7412 kid->op_type = OP_PUSHRE;
7413 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
7415 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
7416 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
7417 "Use of /g modifier is meaningless in split");
7420 if (!kid->op_sibling)
7421 append_elem(OP_SPLIT, o, newDEFSVOP());
7423 kid = kid->op_sibling;
7426 if (!kid->op_sibling)
7427 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
7428 assert(kid->op_sibling);
7430 kid = kid->op_sibling;
7433 if (kid->op_sibling)
7434 return too_many_arguments(o,OP_DESC(o));
7440 Perl_ck_join(pTHX_ OP *o)
7442 const OP * const kid = cLISTOPo->op_first->op_sibling;
7443 if (kid && kid->op_type == OP_MATCH) {
7444 if (ckWARN(WARN_SYNTAX)) {
7445 const REGEXP *re = PM_GETRE(kPMOP);
7446 const char *pmstr = re ? re->precomp : "STRING";
7447 const STRLEN len = re ? re->prelen : 6;
7448 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7449 "/%.*s/ should probably be written as \"%.*s\"",
7450 (int)len, pmstr, (int)len, pmstr);
7457 Perl_ck_subr(pTHX_ OP *o)
7460 OP *prev = ((cUNOPo->op_first->op_sibling)
7461 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
7462 OP *o2 = prev->op_sibling;
7464 const char *proto = NULL;
7465 const char *proto_end = NULL;
7470 I32 contextclass = 0;
7471 const char *e = NULL;
7474 o->op_private |= OPpENTERSUB_HASTARG;
7475 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
7476 if (cvop->op_type == OP_RV2CV) {
7478 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
7479 op_null(cvop); /* disable rv2cv */
7480 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
7481 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
7482 GV *gv = cGVOPx_gv(tmpop);
7485 tmpop->op_private |= OPpEARLY_CV;
7489 namegv = CvANON(cv) ? gv : CvGV(cv);
7490 proto = SvPV((SV*)cv, len);
7491 proto_end = proto + len;
7493 if (CvASSERTION(cv)) {
7494 U32 asserthints = 0;
7495 HV *const hinthv = GvHV(PL_hintgv);
7497 SV **svp = hv_fetchs(hinthv, "assertions", FALSE);
7499 asserthints = SvUV(*svp);
7501 if (asserthints & HINT_ASSERTING) {
7502 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
7503 o->op_private |= OPpENTERSUB_DB;
7507 if (!(asserthints & HINT_ASSERTIONSSEEN) && ckWARN(WARN_ASSERTIONS)) {
7508 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
7509 "Impossible to activate assertion call");
7516 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7517 if (o2->op_type == OP_CONST)
7518 o2->op_private &= ~OPpCONST_STRICT;
7519 else if (o2->op_type == OP_LIST) {
7520 OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
7521 if (sib && sib->op_type == OP_CONST)
7522 sib->op_private &= ~OPpCONST_STRICT;
7525 o->op_private |= (PL_hints & HINT_STRICT_REFS);
7526 if (PERLDB_SUB && PL_curstash != PL_debstash)
7527 o->op_private |= OPpENTERSUB_DB;
7528 while (o2 != cvop) {
7530 if (PL_madskills && o2->op_type == OP_STUB) {
7531 o2 = o2->op_sibling;
7534 if (PL_madskills && o2->op_type == OP_NULL)
7535 o3 = ((UNOP*)o2)->op_first;
7539 if (proto >= proto_end)
7540 return too_many_arguments(o, gv_ename(namegv));
7548 /* _ must be at the end */
7549 if (proto[1] && proto[1] != ';')
7564 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
7566 arg == 1 ? "block or sub {}" : "sub {}",
7567 gv_ename(namegv), o3);
7570 /* '*' allows any scalar type, including bareword */
7573 if (o3->op_type == OP_RV2GV)
7574 goto wrapref; /* autoconvert GLOB -> GLOBref */
7575 else if (o3->op_type == OP_CONST)
7576 o3->op_private &= ~OPpCONST_STRICT;
7577 else if (o3->op_type == OP_ENTERSUB) {
7578 /* accidental subroutine, revert to bareword */
7579 OP *gvop = ((UNOP*)o3)->op_first;
7580 if (gvop && gvop->op_type == OP_NULL) {
7581 gvop = ((UNOP*)gvop)->op_first;
7583 for (; gvop->op_sibling; gvop = gvop->op_sibling)
7586 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
7587 (gvop = ((UNOP*)gvop)->op_first) &&
7588 gvop->op_type == OP_GV)
7590 GV * const gv = cGVOPx_gv(gvop);
7591 OP * const sibling = o2->op_sibling;
7592 SV * const n = newSVpvs("");
7594 OP * const oldo2 = o2;
7598 gv_fullname4(n, gv, "", FALSE);
7599 o2 = newSVOP(OP_CONST, 0, n);
7600 op_getmad(oldo2,o2,'O');
7601 prev->op_sibling = o2;
7602 o2->op_sibling = sibling;
7618 if (contextclass++ == 0) {
7619 e = strchr(proto, ']');
7620 if (!e || e == proto)
7629 const char *p = proto;
7630 const char *const end = proto;
7632 while (*--p != '[');
7633 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
7635 gv_ename(namegv), o3);
7640 if (o3->op_type == OP_RV2GV)
7643 bad_type(arg, "symbol", gv_ename(namegv), o3);
7646 if (o3->op_type == OP_ENTERSUB)
7649 bad_type(arg, "subroutine entry", gv_ename(namegv),
7653 if (o3->op_type == OP_RV2SV ||
7654 o3->op_type == OP_PADSV ||
7655 o3->op_type == OP_HELEM ||
7656 o3->op_type == OP_AELEM)
7659 bad_type(arg, "scalar", gv_ename(namegv), o3);
7662 if (o3->op_type == OP_RV2AV ||
7663 o3->op_type == OP_PADAV)
7666 bad_type(arg, "array", gv_ename(namegv), o3);
7669 if (o3->op_type == OP_RV2HV ||
7670 o3->op_type == OP_PADHV)
7673 bad_type(arg, "hash", gv_ename(namegv), o3);
7678 OP* const sib = kid->op_sibling;
7679 kid->op_sibling = 0;
7680 o2 = newUNOP(OP_REFGEN, 0, kid);
7681 o2->op_sibling = sib;
7682 prev->op_sibling = o2;
7684 if (contextclass && e) {
7699 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
7700 gv_ename(namegv), SVfARG(cv));
7705 mod(o2, OP_ENTERSUB);
7707 o2 = o2->op_sibling;
7709 if (o2 == cvop && proto && *proto == '_') {
7710 /* generate an access to $_ */
7712 o2->op_sibling = prev->op_sibling;
7713 prev->op_sibling = o2; /* instead of cvop */
7715 if (proto && !optional && proto_end > proto &&
7716 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
7717 return too_few_arguments(o, gv_ename(namegv));
7720 OP * const oldo = o;
7724 o=newSVOP(OP_CONST, 0, newSViv(0));
7725 op_getmad(oldo,o,'O');
7731 Perl_ck_svconst(pTHX_ OP *o)
7733 PERL_UNUSED_CONTEXT;
7734 SvREADONLY_on(cSVOPo->op_sv);
7739 Perl_ck_chdir(pTHX_ OP *o)
7741 if (o->op_flags & OPf_KIDS) {
7742 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7744 if (kid && kid->op_type == OP_CONST &&
7745 (kid->op_private & OPpCONST_BARE))
7747 o->op_flags |= OPf_SPECIAL;
7748 kid->op_private &= ~OPpCONST_STRICT;
7755 Perl_ck_trunc(pTHX_ OP *o)
7757 if (o->op_flags & OPf_KIDS) {
7758 SVOP *kid = (SVOP*)cUNOPo->op_first;
7760 if (kid->op_type == OP_NULL)
7761 kid = (SVOP*)kid->op_sibling;
7762 if (kid && kid->op_type == OP_CONST &&
7763 (kid->op_private & OPpCONST_BARE))
7765 o->op_flags |= OPf_SPECIAL;
7766 kid->op_private &= ~OPpCONST_STRICT;
7773 Perl_ck_unpack(pTHX_ OP *o)
7775 OP *kid = cLISTOPo->op_first;
7776 if (kid->op_sibling) {
7777 kid = kid->op_sibling;
7778 if (!kid->op_sibling)
7779 kid->op_sibling = newDEFSVOP();
7785 Perl_ck_substr(pTHX_ OP *o)
7788 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
7789 OP *kid = cLISTOPo->op_first;
7791 if (kid->op_type == OP_NULL)
7792 kid = kid->op_sibling;
7794 kid->op_flags |= OPf_MOD;
7800 /* A peephole optimizer. We visit the ops in the order they're to execute.
7801 * See the comments at the top of this file for more details about when
7802 * peep() is called */
7805 Perl_peep(pTHX_ register OP *o)
7808 register OP* oldop = NULL;
7810 if (!o || o->op_opt)
7814 SAVEVPTR(PL_curcop);
7815 for (; o; o = o->op_next) {
7819 switch (o->op_type) {
7823 PL_curcop = ((COP*)o); /* for warnings */
7828 if (cSVOPo->op_private & OPpCONST_STRICT)
7829 no_bareword_allowed(o);
7831 case OP_METHOD_NAMED:
7832 /* Relocate sv to the pad for thread safety.
7833 * Despite being a "constant", the SV is written to,
7834 * for reference counts, sv_upgrade() etc. */
7836 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
7837 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
7838 /* If op_sv is already a PADTMP then it is being used by
7839 * some pad, so make a copy. */
7840 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
7841 SvREADONLY_on(PAD_SVl(ix));
7842 SvREFCNT_dec(cSVOPo->op_sv);
7844 else if (o->op_type == OP_CONST
7845 && cSVOPo->op_sv == &PL_sv_undef) {
7846 /* PL_sv_undef is hack - it's unsafe to store it in the
7847 AV that is the pad, because av_fetch treats values of
7848 PL_sv_undef as a "free" AV entry and will merrily
7849 replace them with a new SV, causing pad_alloc to think
7850 that this pad slot is free. (When, clearly, it is not)
7852 SvOK_off(PAD_SVl(ix));
7853 SvPADTMP_on(PAD_SVl(ix));
7854 SvREADONLY_on(PAD_SVl(ix));
7857 SvREFCNT_dec(PAD_SVl(ix));
7858 SvPADTMP_on(cSVOPo->op_sv);
7859 PAD_SETSV(ix, cSVOPo->op_sv);
7860 /* XXX I don't know how this isn't readonly already. */
7861 SvREADONLY_on(PAD_SVl(ix));
7863 cSVOPo->op_sv = NULL;
7871 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
7872 if (o->op_next->op_private & OPpTARGET_MY) {
7873 if (o->op_flags & OPf_STACKED) /* chained concats */
7874 goto ignore_optimization;
7876 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
7877 o->op_targ = o->op_next->op_targ;
7878 o->op_next->op_targ = 0;
7879 o->op_private |= OPpTARGET_MY;
7882 op_null(o->op_next);
7884 ignore_optimization:
7888 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
7890 break; /* Scalar stub must produce undef. List stub is noop */
7894 if (o->op_targ == OP_NEXTSTATE
7895 || o->op_targ == OP_DBSTATE
7896 || o->op_targ == OP_SETSTATE)
7898 PL_curcop = ((COP*)o);
7900 /* XXX: We avoid setting op_seq here to prevent later calls
7901 to peep() from mistakenly concluding that optimisation
7902 has already occurred. This doesn't fix the real problem,
7903 though (See 20010220.007). AMS 20010719 */
7904 /* op_seq functionality is now replaced by op_opt */
7905 if (oldop && o->op_next) {
7906 oldop->op_next = o->op_next;
7914 if (oldop && o->op_next) {
7915 oldop->op_next = o->op_next;
7923 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
7924 OP* const pop = (o->op_type == OP_PADAV) ?
7925 o->op_next : o->op_next->op_next;
7927 if (pop && pop->op_type == OP_CONST &&
7928 ((PL_op = pop->op_next)) &&
7929 pop->op_next->op_type == OP_AELEM &&
7930 !(pop->op_next->op_private &
7931 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
7932 (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
7937 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
7938 no_bareword_allowed(pop);
7939 if (o->op_type == OP_GV)
7940 op_null(o->op_next);
7941 op_null(pop->op_next);
7943 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
7944 o->op_next = pop->op_next->op_next;
7945 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
7946 o->op_private = (U8)i;
7947 if (o->op_type == OP_GV) {
7952 o->op_flags |= OPf_SPECIAL;
7953 o->op_type = OP_AELEMFAST;
7959 if (o->op_next->op_type == OP_RV2SV) {
7960 if (!(o->op_next->op_private & OPpDEREF)) {
7961 op_null(o->op_next);
7962 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
7964 o->op_next = o->op_next->op_next;
7965 o->op_type = OP_GVSV;
7966 o->op_ppaddr = PL_ppaddr[OP_GVSV];
7969 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
7970 GV * const gv = cGVOPo_gv;
7971 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
7972 /* XXX could check prototype here instead of just carping */
7973 SV * const sv = sv_newmortal();
7974 gv_efullname3(sv, gv, NULL);
7975 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
7976 "%"SVf"() called too early to check prototype",
7980 else if (o->op_next->op_type == OP_READLINE
7981 && o->op_next->op_next->op_type == OP_CONCAT
7982 && (o->op_next->op_next->op_flags & OPf_STACKED))
7984 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
7985 o->op_type = OP_RCATLINE;
7986 o->op_flags |= OPf_STACKED;
7987 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
7988 op_null(o->op_next->op_next);
7989 op_null(o->op_next);
8006 while (cLOGOP->op_other->op_type == OP_NULL)
8007 cLOGOP->op_other = cLOGOP->op_other->op_next;
8008 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
8014 while (cLOOP->op_redoop->op_type == OP_NULL)
8015 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
8016 peep(cLOOP->op_redoop);
8017 while (cLOOP->op_nextop->op_type == OP_NULL)
8018 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
8019 peep(cLOOP->op_nextop);
8020 while (cLOOP->op_lastop->op_type == OP_NULL)
8021 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
8022 peep(cLOOP->op_lastop);
8029 while (cPMOP->op_pmreplstart &&
8030 cPMOP->op_pmreplstart->op_type == OP_NULL)
8031 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
8032 peep(cPMOP->op_pmreplstart);
8037 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
8038 && ckWARN(WARN_SYNTAX))
8040 if (o->op_next->op_sibling) {
8041 const OPCODE type = o->op_next->op_sibling->op_type;
8042 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
8043 const line_t oldline = CopLINE(PL_curcop);
8044 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
8045 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8046 "Statement unlikely to be reached");
8047 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8048 "\t(Maybe you meant system() when you said exec()?)\n");
8049 CopLINE_set(PL_curcop, oldline);
8060 const char *key = NULL;
8065 if (((BINOP*)o)->op_last->op_type != OP_CONST)
8068 /* Make the CONST have a shared SV */
8069 svp = cSVOPx_svp(((BINOP*)o)->op_last);
8070 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
8071 key = SvPV_const(sv, keylen);
8072 lexname = newSVpvn_share(key,
8073 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
8079 if ((o->op_private & (OPpLVAL_INTRO)))
8082 rop = (UNOP*)((BINOP*)o)->op_first;
8083 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
8085 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
8086 if (!SvPAD_TYPED(lexname))
8088 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8089 if (!fields || !GvHV(*fields))
8091 key = SvPV_const(*svp, keylen);
8092 if (!hv_fetch(GvHV(*fields), key,
8093 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8095 Perl_croak(aTHX_ "No such class field \"%s\" "
8096 "in variable %s of type %s",
8097 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
8110 SVOP *first_key_op, *key_op;
8112 if ((o->op_private & (OPpLVAL_INTRO))
8113 /* I bet there's always a pushmark... */
8114 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
8115 /* hmmm, no optimization if list contains only one key. */
8117 rop = (UNOP*)((LISTOP*)o)->op_last;
8118 if (rop->op_type != OP_RV2HV)
8120 if (rop->op_first->op_type == OP_PADSV)
8121 /* @$hash{qw(keys here)} */
8122 rop = (UNOP*)rop->op_first;
8124 /* @{$hash}{qw(keys here)} */
8125 if (rop->op_first->op_type == OP_SCOPE
8126 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
8128 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
8134 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
8135 if (!SvPAD_TYPED(lexname))
8137 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8138 if (!fields || !GvHV(*fields))
8140 /* Again guessing that the pushmark can be jumped over.... */
8141 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
8142 ->op_first->op_sibling;
8143 for (key_op = first_key_op; key_op;
8144 key_op = (SVOP*)key_op->op_sibling) {
8145 if (key_op->op_type != OP_CONST)
8147 svp = cSVOPx_svp(key_op);
8148 key = SvPV_const(*svp, keylen);
8149 if (!hv_fetch(GvHV(*fields), key,
8150 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8152 Perl_croak(aTHX_ "No such class field \"%s\" "
8153 "in variable %s of type %s",
8154 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
8161 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
8165 /* check that RHS of sort is a single plain array */
8166 OP *oright = cUNOPo->op_first;
8167 if (!oright || oright->op_type != OP_PUSHMARK)
8170 /* reverse sort ... can be optimised. */
8171 if (!cUNOPo->op_sibling) {
8172 /* Nothing follows us on the list. */
8173 OP * const reverse = o->op_next;
8175 if (reverse->op_type == OP_REVERSE &&
8176 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
8177 OP * const pushmark = cUNOPx(reverse)->op_first;
8178 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
8179 && (cUNOPx(pushmark)->op_sibling == o)) {
8180 /* reverse -> pushmark -> sort */
8181 o->op_private |= OPpSORT_REVERSE;
8183 pushmark->op_next = oright->op_next;
8189 /* make @a = sort @a act in-place */
8193 oright = cUNOPx(oright)->op_sibling;
8196 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
8197 oright = cUNOPx(oright)->op_sibling;
8201 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
8202 || oright->op_next != o
8203 || (oright->op_private & OPpLVAL_INTRO)
8207 /* o2 follows the chain of op_nexts through the LHS of the
8208 * assign (if any) to the aassign op itself */
8210 if (!o2 || o2->op_type != OP_NULL)
8213 if (!o2 || o2->op_type != OP_PUSHMARK)
8216 if (o2 && o2->op_type == OP_GV)
8219 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
8220 || (o2->op_private & OPpLVAL_INTRO)
8225 if (!o2 || o2->op_type != OP_NULL)
8228 if (!o2 || o2->op_type != OP_AASSIGN
8229 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
8232 /* check that the sort is the first arg on RHS of assign */
8234 o2 = cUNOPx(o2)->op_first;
8235 if (!o2 || o2->op_type != OP_NULL)
8237 o2 = cUNOPx(o2)->op_first;
8238 if (!o2 || o2->op_type != OP_PUSHMARK)
8240 if (o2->op_sibling != o)
8243 /* check the array is the same on both sides */
8244 if (oleft->op_type == OP_RV2AV) {
8245 if (oright->op_type != OP_RV2AV
8246 || !cUNOPx(oright)->op_first
8247 || cUNOPx(oright)->op_first->op_type != OP_GV
8248 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
8249 cGVOPx_gv(cUNOPx(oright)->op_first)
8253 else if (oright->op_type != OP_PADAV
8254 || oright->op_targ != oleft->op_targ
8258 /* transfer MODishness etc from LHS arg to RHS arg */
8259 oright->op_flags = oleft->op_flags;
8260 o->op_private |= OPpSORT_INPLACE;
8262 /* excise push->gv->rv2av->null->aassign */
8263 o2 = o->op_next->op_next;
8264 op_null(o2); /* PUSHMARK */
8266 if (o2->op_type == OP_GV) {
8267 op_null(o2); /* GV */
8270 op_null(o2); /* RV2AV or PADAV */
8271 o2 = o2->op_next->op_next;
8272 op_null(o2); /* AASSIGN */
8274 o->op_next = o2->op_next;
8280 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
8282 LISTOP *enter, *exlist;
8285 enter = (LISTOP *) o->op_next;
8288 if (enter->op_type == OP_NULL) {
8289 enter = (LISTOP *) enter->op_next;
8293 /* for $a (...) will have OP_GV then OP_RV2GV here.
8294 for (...) just has an OP_GV. */
8295 if (enter->op_type == OP_GV) {
8296 gvop = (OP *) enter;
8297 enter = (LISTOP *) enter->op_next;
8300 if (enter->op_type == OP_RV2GV) {
8301 enter = (LISTOP *) enter->op_next;
8307 if (enter->op_type != OP_ENTERITER)
8310 iter = enter->op_next;
8311 if (!iter || iter->op_type != OP_ITER)
8314 expushmark = enter->op_first;
8315 if (!expushmark || expushmark->op_type != OP_NULL
8316 || expushmark->op_targ != OP_PUSHMARK)
8319 exlist = (LISTOP *) expushmark->op_sibling;
8320 if (!exlist || exlist->op_type != OP_NULL
8321 || exlist->op_targ != OP_LIST)
8324 if (exlist->op_last != o) {
8325 /* Mmm. Was expecting to point back to this op. */
8328 theirmark = exlist->op_first;
8329 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
8332 if (theirmark->op_sibling != o) {
8333 /* There's something between the mark and the reverse, eg
8334 for (1, reverse (...))
8339 ourmark = ((LISTOP *)o)->op_first;
8340 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
8343 ourlast = ((LISTOP *)o)->op_last;
8344 if (!ourlast || ourlast->op_next != o)
8347 rv2av = ourmark->op_sibling;
8348 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
8349 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
8350 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
8351 /* We're just reversing a single array. */
8352 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
8353 enter->op_flags |= OPf_STACKED;
8356 /* We don't have control over who points to theirmark, so sacrifice
8358 theirmark->op_next = ourmark->op_next;
8359 theirmark->op_flags = ourmark->op_flags;
8360 ourlast->op_next = gvop ? gvop : (OP *) enter;
8363 enter->op_private |= OPpITER_REVERSED;
8364 iter->op_private |= OPpITER_REVERSED;
8371 UNOP *refgen, *rv2cv;
8374 /* I do not understand this, but if o->op_opt isn't set to 1,
8375 various tests in ext/B/t/bytecode.t fail with no readily
8381 if ((o->op_flags && OPf_WANT) != OPf_WANT_VOID)
8384 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
8387 rv2gv = ((BINOP *)o)->op_last;
8388 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
8391 refgen = (UNOP *)((BINOP *)o)->op_first;
8393 if (!refgen || refgen->op_type != OP_REFGEN)
8396 exlist = (LISTOP *)refgen->op_first;
8397 if (!exlist || exlist->op_type != OP_NULL
8398 || exlist->op_targ != OP_LIST)
8401 if (exlist->op_first->op_type != OP_PUSHMARK)
8404 rv2cv = (UNOP*)exlist->op_last;
8406 if (rv2cv->op_type != OP_RV2CV)
8409 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
8410 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
8411 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
8413 o->op_private |= OPpASSIGN_CV_TO_GV;
8414 rv2gv->op_private |= OPpDONT_INIT_GV;
8415 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
8431 Perl_custom_op_name(pTHX_ const OP* o)
8434 const IV index = PTR2IV(o->op_ppaddr);
8438 if (!PL_custom_op_names) /* This probably shouldn't happen */
8439 return (char *)PL_op_name[OP_CUSTOM];
8441 keysv = sv_2mortal(newSViv(index));
8443 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
8445 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
8447 return SvPV_nolen(HeVAL(he));
8451 Perl_custom_op_desc(pTHX_ const OP* o)
8454 const IV index = PTR2IV(o->op_ppaddr);
8458 if (!PL_custom_op_descs)
8459 return (char *)PL_op_desc[OP_CUSTOM];
8461 keysv = sv_2mortal(newSViv(index));
8463 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
8465 return (char *)PL_op_desc[OP_CUSTOM];
8467 return SvPV_nolen(HeVAL(he));
8472 /* Efficient sub that returns a constant scalar value. */
8474 const_sv_xsub(pTHX_ CV* cv)
8481 Perl_croak(aTHX_ "usage: %s::%s()",
8482 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
8486 ST(0) = (SV*)XSANY.any_ptr;
8492 * c-indentation-style: bsd
8494 * indent-tabs-mode: t
8497 * ex: set ts=8 sts=4 sw=4 noet: