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)
121 * To make incrementing use count easy PL_OpSlab is an I32 *
122 * To make inserting the link to slab PL_OpPtr is I32 **
123 * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
124 * Add an overhead for pointer to slab and round up as a number of pointers
126 sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
127 if ((PL_OpSpace -= sz) < 0) {
128 #ifdef PERL_DEBUG_READONLY_OPS
129 /* We need to allocate chunk by chunk so that we can control the VM
131 PL_OpPtr = (I32**) mmap(0, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE,
132 MAP_ANON|MAP_PRIVATE, -1, 0);
134 DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
135 (unsigned long) PERL_SLAB_SIZE*sizeof(I32*),
137 if(PL_OpPtr == MAP_FAILED) {
138 perror("mmap failed");
143 PL_OpPtr = (I32 **) PerlMemShared_calloc(PERL_SLAB_SIZE,sizeof(I32*));
148 /* We reserve the 0'th I32 sized chunk as a use count */
149 PL_OpSlab = (I32 *) PL_OpPtr;
150 /* Reduce size by the use count word, and by the size we need.
151 * Latter is to mimic the '-=' in the if() above
153 PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
154 /* Allocation pointer starts at the top.
155 Theory: because we build leaves before trunk allocating at end
156 means that at run time access is cache friendly upward
158 PL_OpPtr += PERL_SLAB_SIZE;
160 #ifdef PERL_DEBUG_READONLY_OPS
161 /* We remember this slab. */
162 /* This implementation isn't efficient, but it is simple. */
163 PL_slabs = (I32**) realloc(PL_slabs, sizeof(I32**) * (PL_slab_count + 1));
164 PL_slabs[PL_slab_count++] = PL_OpSlab;
165 DEBUG_m(PerlIO_printf(Perl_debug_log, "Allocate %p\n", PL_OpSlab));
168 assert( PL_OpSpace >= 0 );
169 /* Move the allocation pointer down */
171 assert( PL_OpPtr > (I32 **) PL_OpSlab );
172 *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */
173 (*PL_OpSlab)++; /* Increment use count of slab */
174 assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
175 assert( *PL_OpSlab > 0 );
176 return (void *)(PL_OpPtr + 1);
179 #ifdef PERL_DEBUG_READONLY_OPS
181 Perl_pending_Slabs_to_ro(pTHX) {
182 /* Turn all the allocated op slabs read only. */
183 U32 count = PL_slab_count;
184 I32 **const slabs = PL_slabs;
186 /* Reset the array of pending OP slabs, as we're about to turn this lot
187 read only. Also, do it ahead of the loop in case the warn triggers,
188 and a warn handler has an eval */
193 /* Force a new slab for any further allocation. */
197 void *const 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);
209 S_Slab_to_rw(pTHX_ void *op)
211 I32 * const * const ptr = (I32 **) op;
212 I32 * const slab = ptr[-1];
213 assert( ptr-1 > (I32 **) slab );
214 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
216 if(mprotect(slab, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE)) {
217 Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d",
218 slab, (unsigned long) PERL_SLAB_SIZE*sizeof(I32*), errno);
223 Perl_op_refcnt_inc(pTHX_ OP *o)
234 Perl_op_refcnt_dec(pTHX_ OP *o)
240 # define Slab_to_rw(op)
244 Perl_Slab_Free(pTHX_ void *op)
246 I32 * const * const ptr = (I32 **) op;
247 I32 * const slab = ptr[-1];
248 assert( ptr-1 > (I32 **) slab );
249 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
252 if (--(*slab) == 0) {
254 # define PerlMemShared PerlMem
257 #ifdef PERL_DEBUG_READONLY_OPS
258 U32 count = PL_slab_count;
259 /* Need to remove this slab from our list of slabs */
262 if (PL_slabs[count] == slab) {
264 /* Found it. Move the entry at the end to overwrite it. */
265 DEBUG_m(PerlIO_printf(Perl_debug_log,
266 "Deallocate %p by moving %p from %lu to %lu\n",
268 PL_slabs[PL_slab_count - 1],
269 PL_slab_count, count));
270 PL_slabs[count] = PL_slabs[--PL_slab_count];
271 /* Could realloc smaller at this point, but probably not
273 if(munmap(slab, PERL_SLAB_SIZE*sizeof(I32*))) {
274 perror("munmap failed");
282 PerlMemShared_free(slab);
284 if (slab == PL_OpSlab) {
291 * In the following definition, the ", (OP*)0" is just to make the compiler
292 * think the expression is of the right type: croak actually does a Siglongjmp.
294 #define CHECKOP(type,o) \
295 ((PL_op_mask && PL_op_mask[type]) \
296 ? ( op_free((OP*)o), \
297 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
299 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
301 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
304 S_gv_ename(pTHX_ GV *gv)
306 SV* const tmpsv = sv_newmortal();
307 gv_efullname3(tmpsv, gv, NULL);
308 return SvPV_nolen_const(tmpsv);
312 S_no_fh_allowed(pTHX_ OP *o)
314 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
320 S_too_few_arguments(pTHX_ OP *o, const char *name)
322 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
327 S_too_many_arguments(pTHX_ OP *o, const char *name)
329 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
334 S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid)
336 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
337 (int)n, name, t, OP_DESC(kid)));
341 S_no_bareword_allowed(pTHX_ const OP *o)
344 return; /* various ok barewords are hidden in extra OP_NULL */
345 qerror(Perl_mess(aTHX_
346 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
350 /* "register" allocation */
353 Perl_allocmy(pTHX_ const char *const name)
357 const bool is_our = (PL_parser->in_my == KEY_our);
359 /* complain about "my $<special_var>" etc etc */
363 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
364 (name[1] == '_' && (*name == '$' || name[2]))))
366 /* name[2] is true if strlen(name) > 2 */
367 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
368 yyerror(Perl_form(aTHX_ "Can't use global %c^%c%s in \"%s\"",
369 name[0], toCTRL(name[1]), name + 2,
370 PL_parser->in_my == KEY_state ? "state" : "my"));
372 yyerror(Perl_form(aTHX_ "Can't use global %s in \"%s\"",name,
373 PL_parser->in_my == KEY_state ? "state" : "my"));
377 /* check for duplicate declaration */
378 pad_check_dup(name, is_our, (PL_curstash ? PL_curstash : PL_defstash));
380 if (PL_parser->in_my_stash && *name != '$') {
381 yyerror(Perl_form(aTHX_
382 "Can't declare class for non-scalar %s in \"%s\"",
385 : PL_parser->in_my == KEY_state ? "state" : "my"));
388 /* allocate a spare slot and store the name in that slot */
390 off = pad_add_name(name,
391 PL_parser->in_my_stash,
393 /* $_ is always in main::, even with our */
394 ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
398 PL_parser->in_my == KEY_state
400 /* anon sub prototypes contains state vars should always be cloned,
401 * otherwise the state var would be shared between anon subs */
403 if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
404 CvCLONE_on(PL_compcv);
409 /* free the body of an op without examining its contents.
410 * Always use this rather than FreeOp directly */
413 S_op_destroy(pTHX_ OP *o)
415 if (o->op_latefree) {
423 # define forget_pmop(a,b) S_forget_pmop(aTHX_ a,b)
425 # define forget_pmop(a,b) S_forget_pmop(aTHX_ a)
431 Perl_op_free(pTHX_ OP *o)
438 if (o->op_latefreed) {
445 if (o->op_private & OPpREFCOUNTED) {
456 refcnt = OpREFCNT_dec(o);
459 /* Need to find and remove any pattern match ops from the list
460 we maintain for reset(). */
461 find_and_forget_pmops(o);
471 if (o->op_flags & OPf_KIDS) {
472 register OP *kid, *nextkid;
473 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
474 nextkid = kid->op_sibling; /* Get before next freeing kid */
479 type = (OPCODE)o->op_targ;
481 #ifdef PERL_DEBUG_READONLY_OPS
485 /* COP* is not cleared by op_clear() so that we may track line
486 * numbers etc even after null() */
487 if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
492 if (o->op_latefree) {
498 #ifdef DEBUG_LEAKING_SCALARS
505 Perl_op_clear(pTHX_ OP *o)
510 /* if (o->op_madprop && o->op_madprop->mad_next)
512 /* FIXME for MAD - if I uncomment these two lines t/op/pack.t fails with
513 "modification of a read only value" for a reason I can't fathom why.
514 It's the "" stringification of $_, where $_ was set to '' in a foreach
515 loop, but it defies simplification into a small test case.
516 However, commenting them out has caused ext/List/Util/t/weak.t to fail
519 mad_free(o->op_madprop);
525 switch (o->op_type) {
526 case OP_NULL: /* Was holding old type, if any. */
527 if (PL_madskills && o->op_targ != OP_NULL) {
528 o->op_type = o->op_targ;
532 case OP_ENTEREVAL: /* Was holding hints. */
536 if (!(o->op_flags & OPf_REF)
537 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
543 if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
544 /* not an OP_PADAV replacement */
546 if (cPADOPo->op_padix > 0) {
547 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
548 * may still exist on the pad */
549 pad_swipe(cPADOPo->op_padix, TRUE);
550 cPADOPo->op_padix = 0;
553 SvREFCNT_dec(cSVOPo->op_sv);
554 cSVOPo->op_sv = NULL;
558 case OP_METHOD_NAMED:
560 SvREFCNT_dec(cSVOPo->op_sv);
561 cSVOPo->op_sv = NULL;
564 Even if op_clear does a pad_free for the target of the op,
565 pad_free doesn't actually remove the sv that exists in the pad;
566 instead it lives on. This results in that it could be reused as
567 a target later on when the pad was reallocated.
570 pad_swipe(o->op_targ,1);
579 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
583 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
585 if (cPADOPo->op_padix > 0) {
586 pad_swipe(cPADOPo->op_padix, TRUE);
587 cPADOPo->op_padix = 0;
590 SvREFCNT_dec(cSVOPo->op_sv);
591 cSVOPo->op_sv = NULL;
595 PerlMemShared_free(cPVOPo->op_pv);
596 cPVOPo->op_pv = NULL;
600 op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
604 if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
605 /* No GvIN_PAD_off here, because other references may still
606 * exist on the pad */
607 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
610 SvREFCNT_dec((SV*)cPMOPo->op_pmreplrootu.op_pmtargetgv);
616 forget_pmop(cPMOPo, 1);
617 cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
618 /* we use the same protection as the "SAFE" version of the PM_ macros
619 * here since sv_clean_all might release some PMOPs
620 * after PL_regex_padav has been cleared
621 * and the clearing of PL_regex_padav needs to
622 * happen before sv_clean_all
625 if(PL_regex_pad) { /* We could be in destruction */
626 const IV offset = (cPMOPo)->op_pmoffset;
627 ReREFCNT_dec(PM_GETRE(cPMOPo));
628 PL_regex_pad[offset] = &PL_sv_undef;
629 sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
633 ReREFCNT_dec(PM_GETRE(cPMOPo));
634 PM_SETRE(cPMOPo, NULL);
640 if (o->op_targ > 0) {
641 pad_free(o->op_targ);
647 S_cop_free(pTHX_ COP* cop)
652 if (! specialWARN(cop->cop_warnings))
653 PerlMemShared_free(cop->cop_warnings);
654 Perl_refcounted_he_free(aTHX_ cop->cop_hints_hash);
658 S_forget_pmop(pTHX_ PMOP *const o
664 HV * const pmstash = PmopSTASH(o);
665 if (pmstash && !SvIS_FREED(pmstash)) {
666 MAGIC * const mg = mg_find((SV*)pmstash, PERL_MAGIC_symtab);
668 PMOP **const array = (PMOP**) mg->mg_ptr;
669 U32 count = mg->mg_len / sizeof(PMOP**);
674 /* Found it. Move the entry at the end to overwrite it. */
675 array[i] = array[--count];
676 mg->mg_len = count * sizeof(PMOP**);
677 /* Could realloc smaller at this point always, but probably
678 not worth it. Probably worth free()ing if we're the
681 Safefree(mg->mg_ptr);
698 S_find_and_forget_pmops(pTHX_ OP *o)
700 if (o->op_flags & OPf_KIDS) {
701 OP *kid = cUNOPo->op_first;
703 switch (kid->op_type) {
708 forget_pmop((PMOP*)kid, 0);
710 find_and_forget_pmops(kid);
711 kid = kid->op_sibling;
717 Perl_op_null(pTHX_ OP *o)
720 if (o->op_type == OP_NULL)
724 o->op_targ = o->op_type;
725 o->op_type = OP_NULL;
726 o->op_ppaddr = PL_ppaddr[OP_NULL];
730 Perl_op_refcnt_lock(pTHX)
738 Perl_op_refcnt_unlock(pTHX)
745 /* Contextualizers */
747 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
750 Perl_linklist(pTHX_ OP *o)
757 /* establish postfix order */
758 first = cUNOPo->op_first;
761 o->op_next = LINKLIST(first);
764 if (kid->op_sibling) {
765 kid->op_next = LINKLIST(kid->op_sibling);
766 kid = kid->op_sibling;
780 Perl_scalarkids(pTHX_ OP *o)
782 if (o && o->op_flags & OPf_KIDS) {
784 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
791 S_scalarboolean(pTHX_ OP *o)
794 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
795 if (ckWARN(WARN_SYNTAX)) {
796 const line_t oldline = CopLINE(PL_curcop);
798 if (PL_parser && PL_parser->copline != NOLINE)
799 CopLINE_set(PL_curcop, PL_parser->copline);
800 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
801 CopLINE_set(PL_curcop, oldline);
808 Perl_scalar(pTHX_ OP *o)
813 /* assumes no premature commitment */
814 if (!o || (PL_parser && PL_parser->error_count)
815 || (o->op_flags & OPf_WANT)
816 || o->op_type == OP_RETURN)
821 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
823 switch (o->op_type) {
825 scalar(cBINOPo->op_first);
830 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
834 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
835 if (!kPMOP->op_pmreplrootu.op_pmreplroot)
836 deprecate_old("implicit split to @_");
844 if (o->op_flags & OPf_KIDS) {
845 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
851 kid = cLISTOPo->op_first;
853 while ((kid = kid->op_sibling)) {
859 PL_curcop = &PL_compiling;
864 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
870 PL_curcop = &PL_compiling;
873 if (ckWARN(WARN_VOID))
874 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
880 Perl_scalarvoid(pTHX_ OP *o)
884 const char* useless = NULL;
888 /* trailing mad null ops don't count as "there" for void processing */
890 o->op_type != OP_NULL &&
892 o->op_sibling->op_type == OP_NULL)
895 for (sib = o->op_sibling;
896 sib && sib->op_type == OP_NULL;
897 sib = sib->op_sibling) ;
903 if (o->op_type == OP_NEXTSTATE
904 || o->op_type == OP_DBSTATE
905 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
906 || o->op_targ == OP_DBSTATE)))
907 PL_curcop = (COP*)o; /* for warning below */
909 /* assumes no premature commitment */
910 want = o->op_flags & OPf_WANT;
911 if ((want && want != OPf_WANT_SCALAR)
912 || (PL_parser && PL_parser->error_count)
913 || o->op_type == OP_RETURN)
918 if ((o->op_private & OPpTARGET_MY)
919 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
921 return scalar(o); /* As if inside SASSIGN */
924 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
926 switch (o->op_type) {
928 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
932 if (o->op_flags & OPf_STACKED)
936 if (o->op_private == 4)
1009 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1010 /* Otherwise it's "Useless use of grep iterator" */
1011 useless = OP_DESC(o);
1015 kid = cUNOPo->op_first;
1016 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1017 kid->op_type != OP_TRANS) {
1020 useless = "negative pattern binding (!~)";
1027 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1028 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1029 useless = "a variable";
1034 if (cSVOPo->op_private & OPpCONST_STRICT)
1035 no_bareword_allowed(o);
1037 if (ckWARN(WARN_VOID)) {
1038 useless = "a constant";
1039 if (o->op_private & OPpCONST_ARYBASE)
1041 /* don't warn on optimised away booleans, eg
1042 * use constant Foo, 5; Foo || print; */
1043 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1045 /* the constants 0 and 1 are permitted as they are
1046 conventionally used as dummies in constructs like
1047 1 while some_condition_with_side_effects; */
1048 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1050 else if (SvPOK(sv)) {
1051 /* perl4's way of mixing documentation and code
1052 (before the invention of POD) was based on a
1053 trick to mix nroff and perl code. The trick was
1054 built upon these three nroff macros being used in
1055 void context. The pink camel has the details in
1056 the script wrapman near page 319. */
1057 const char * const maybe_macro = SvPVX_const(sv);
1058 if (strnEQ(maybe_macro, "di", 2) ||
1059 strnEQ(maybe_macro, "ds", 2) ||
1060 strnEQ(maybe_macro, "ig", 2))
1065 op_null(o); /* don't execute or even remember it */
1069 o->op_type = OP_PREINC; /* pre-increment is faster */
1070 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1074 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1075 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1079 o->op_type = OP_I_PREINC; /* pre-increment is faster */
1080 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1084 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
1085 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1094 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1099 if (o->op_flags & OPf_STACKED)
1106 if (!(o->op_flags & OPf_KIDS))
1117 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1124 /* all requires must return a boolean value */
1125 o->op_flags &= ~OPf_WANT;
1130 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
1131 if (!kPMOP->op_pmreplrootu.op_pmreplroot)
1132 deprecate_old("implicit split to @_");
1136 if (useless && ckWARN(WARN_VOID))
1137 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
1142 Perl_listkids(pTHX_ OP *o)
1144 if (o && o->op_flags & OPf_KIDS) {
1146 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1153 Perl_list(pTHX_ OP *o)
1158 /* assumes no premature commitment */
1159 if (!o || (o->op_flags & OPf_WANT)
1160 || (PL_parser && PL_parser->error_count)
1161 || o->op_type == OP_RETURN)
1166 if ((o->op_private & OPpTARGET_MY)
1167 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1169 return o; /* As if inside SASSIGN */
1172 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1174 switch (o->op_type) {
1177 list(cBINOPo->op_first);
1182 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1190 if (!(o->op_flags & OPf_KIDS))
1192 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1193 list(cBINOPo->op_first);
1194 return gen_constant_list(o);
1201 kid = cLISTOPo->op_first;
1203 while ((kid = kid->op_sibling)) {
1204 if (kid->op_sibling)
1209 PL_curcop = &PL_compiling;
1213 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1214 if (kid->op_sibling)
1219 PL_curcop = &PL_compiling;
1222 /* all requires must return a boolean value */
1223 o->op_flags &= ~OPf_WANT;
1230 Perl_scalarseq(pTHX_ OP *o)
1234 const OPCODE type = o->op_type;
1236 if (type == OP_LINESEQ || type == OP_SCOPE ||
1237 type == OP_LEAVE || type == OP_LEAVETRY)
1240 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1241 if (kid->op_sibling) {
1245 PL_curcop = &PL_compiling;
1247 o->op_flags &= ~OPf_PARENS;
1248 if (PL_hints & HINT_BLOCK_SCOPE)
1249 o->op_flags |= OPf_PARENS;
1252 o = newOP(OP_STUB, 0);
1257 S_modkids(pTHX_ OP *o, I32 type)
1259 if (o && o->op_flags & OPf_KIDS) {
1261 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1267 /* Propagate lvalue ("modifiable") context to an op and its children.
1268 * 'type' represents the context type, roughly based on the type of op that
1269 * would do the modifying, although local() is represented by OP_NULL.
1270 * It's responsible for detecting things that can't be modified, flag
1271 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
1272 * might have to vivify a reference in $x), and so on.
1274 * For example, "$a+1 = 2" would cause mod() to be called with o being
1275 * OP_ADD and type being OP_SASSIGN, and would output an error.
1279 Perl_mod(pTHX_ OP *o, I32 type)
1283 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1286 if (!o || (PL_parser && PL_parser->error_count))
1289 if ((o->op_private & OPpTARGET_MY)
1290 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1295 switch (o->op_type) {
1301 if (!(o->op_private & OPpCONST_ARYBASE))
1304 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1305 CopARYBASE_set(&PL_compiling,
1306 (I32)SvIV(cSVOPx(PL_eval_start)->op_sv));
1310 SAVECOPARYBASE(&PL_compiling);
1311 CopARYBASE_set(&PL_compiling, 0);
1313 else if (type == OP_REFGEN)
1316 Perl_croak(aTHX_ "That use of $[ is unsupported");
1319 if ((o->op_flags & OPf_PARENS) || PL_madskills)
1323 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1324 !(o->op_flags & OPf_STACKED)) {
1325 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1326 /* The default is to set op_private to the number of children,
1327 which for a UNOP such as RV2CV is always 1. And w're using
1328 the bit for a flag in RV2CV, so we need it clear. */
1329 o->op_private &= ~1;
1330 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1331 assert(cUNOPo->op_first->op_type == OP_NULL);
1332 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1335 else if (o->op_private & OPpENTERSUB_NOMOD)
1337 else { /* lvalue subroutine call */
1338 o->op_private |= OPpLVAL_INTRO;
1339 PL_modcount = RETURN_UNLIMITED_NUMBER;
1340 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1341 /* Backward compatibility mode: */
1342 o->op_private |= OPpENTERSUB_INARGS;
1345 else { /* Compile-time error message: */
1346 OP *kid = cUNOPo->op_first;
1350 if (kid->op_type != OP_PUSHMARK) {
1351 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1353 "panic: unexpected lvalue entersub "
1354 "args: type/targ %ld:%"UVuf,
1355 (long)kid->op_type, (UV)kid->op_targ);
1356 kid = kLISTOP->op_first;
1358 while (kid->op_sibling)
1359 kid = kid->op_sibling;
1360 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1362 if (kid->op_type == OP_METHOD_NAMED
1363 || kid->op_type == OP_METHOD)
1367 NewOp(1101, newop, 1, UNOP);
1368 newop->op_type = OP_RV2CV;
1369 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1370 newop->op_first = NULL;
1371 newop->op_next = (OP*)newop;
1372 kid->op_sibling = (OP*)newop;
1373 newop->op_private |= OPpLVAL_INTRO;
1374 newop->op_private &= ~1;
1378 if (kid->op_type != OP_RV2CV)
1380 "panic: unexpected lvalue entersub "
1381 "entry via type/targ %ld:%"UVuf,
1382 (long)kid->op_type, (UV)kid->op_targ);
1383 kid->op_private |= OPpLVAL_INTRO;
1384 break; /* Postpone until runtime */
1388 kid = kUNOP->op_first;
1389 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1390 kid = kUNOP->op_first;
1391 if (kid->op_type == OP_NULL)
1393 "Unexpected constant lvalue entersub "
1394 "entry via type/targ %ld:%"UVuf,
1395 (long)kid->op_type, (UV)kid->op_targ);
1396 if (kid->op_type != OP_GV) {
1397 /* Restore RV2CV to check lvalueness */
1399 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1400 okid->op_next = kid->op_next;
1401 kid->op_next = okid;
1404 okid->op_next = NULL;
1405 okid->op_type = OP_RV2CV;
1407 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1408 okid->op_private |= OPpLVAL_INTRO;
1409 okid->op_private &= ~1;
1413 cv = GvCV(kGVOP_gv);
1423 /* grep, foreach, subcalls, refgen */
1424 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1426 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1427 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1429 : (o->op_type == OP_ENTERSUB
1430 ? "non-lvalue subroutine call"
1432 type ? PL_op_desc[type] : "local"));
1446 case OP_RIGHT_SHIFT:
1455 if (!(o->op_flags & OPf_STACKED))
1462 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1468 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1469 PL_modcount = RETURN_UNLIMITED_NUMBER;
1470 return o; /* Treat \(@foo) like ordinary list. */
1474 if (scalar_mod_type(o, type))
1476 ref(cUNOPo->op_first, o->op_type);
1480 if (type == OP_LEAVESUBLV)
1481 o->op_private |= OPpMAYBE_LVSUB;
1487 PL_modcount = RETURN_UNLIMITED_NUMBER;
1490 ref(cUNOPo->op_first, o->op_type);
1495 PL_hints |= HINT_BLOCK_SCOPE;
1510 PL_modcount = RETURN_UNLIMITED_NUMBER;
1511 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1512 return o; /* Treat \(@foo) like ordinary list. */
1513 if (scalar_mod_type(o, type))
1515 if (type == OP_LEAVESUBLV)
1516 o->op_private |= OPpMAYBE_LVSUB;
1520 if (!type) /* local() */
1521 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1522 PAD_COMPNAME_PV(o->op_targ));
1530 if (type != OP_SASSIGN)
1534 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1539 if (type == OP_LEAVESUBLV)
1540 o->op_private |= OPpMAYBE_LVSUB;
1542 pad_free(o->op_targ);
1543 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1544 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1545 if (o->op_flags & OPf_KIDS)
1546 mod(cBINOPo->op_first->op_sibling, type);
1551 ref(cBINOPo->op_first, o->op_type);
1552 if (type == OP_ENTERSUB &&
1553 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1554 o->op_private |= OPpLVAL_DEFER;
1555 if (type == OP_LEAVESUBLV)
1556 o->op_private |= OPpMAYBE_LVSUB;
1566 if (o->op_flags & OPf_KIDS)
1567 mod(cLISTOPo->op_last, type);
1572 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1574 else if (!(o->op_flags & OPf_KIDS))
1576 if (o->op_targ != OP_LIST) {
1577 mod(cBINOPo->op_first, type);
1583 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1588 if (type != OP_LEAVESUBLV)
1590 break; /* mod()ing was handled by ck_return() */
1593 /* [20011101.069] File test operators interpret OPf_REF to mean that
1594 their argument is a filehandle; thus \stat(".") should not set
1596 if (type == OP_REFGEN &&
1597 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1600 if (type != OP_LEAVESUBLV)
1601 o->op_flags |= OPf_MOD;
1603 if (type == OP_AASSIGN || type == OP_SASSIGN)
1604 o->op_flags |= OPf_SPECIAL|OPf_REF;
1605 else if (!type) { /* local() */
1608 o->op_private |= OPpLVAL_INTRO;
1609 o->op_flags &= ~OPf_SPECIAL;
1610 PL_hints |= HINT_BLOCK_SCOPE;
1615 if (ckWARN(WARN_SYNTAX)) {
1616 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1617 "Useless localization of %s", OP_DESC(o));
1621 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1622 && type != OP_LEAVESUBLV)
1623 o->op_flags |= OPf_REF;
1628 S_scalar_mod_type(const OP *o, I32 type)
1632 if (o->op_type == OP_RV2GV)
1656 case OP_RIGHT_SHIFT:
1676 S_is_handle_constructor(const OP *o, I32 numargs)
1678 switch (o->op_type) {
1686 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1699 Perl_refkids(pTHX_ OP *o, I32 type)
1701 if (o && o->op_flags & OPf_KIDS) {
1703 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1710 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
1715 if (!o || (PL_parser && PL_parser->error_count))
1718 switch (o->op_type) {
1720 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1721 !(o->op_flags & OPf_STACKED)) {
1722 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1723 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1724 assert(cUNOPo->op_first->op_type == OP_NULL);
1725 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1726 o->op_flags |= OPf_SPECIAL;
1727 o->op_private &= ~1;
1732 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1733 doref(kid, type, set_op_ref);
1736 if (type == OP_DEFINED)
1737 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1738 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1741 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1742 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1743 : type == OP_RV2HV ? OPpDEREF_HV
1745 o->op_flags |= OPf_MOD;
1752 o->op_flags |= OPf_REF;
1755 if (type == OP_DEFINED)
1756 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1757 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1763 o->op_flags |= OPf_REF;
1768 if (!(o->op_flags & OPf_KIDS))
1770 doref(cBINOPo->op_first, type, set_op_ref);
1774 doref(cBINOPo->op_first, o->op_type, set_op_ref);
1775 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1776 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1777 : type == OP_RV2HV ? OPpDEREF_HV
1779 o->op_flags |= OPf_MOD;
1789 if (!(o->op_flags & OPf_KIDS))
1791 doref(cLISTOPo->op_last, type, set_op_ref);
1801 S_dup_attrlist(pTHX_ OP *o)
1806 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1807 * where the first kid is OP_PUSHMARK and the remaining ones
1808 * are OP_CONST. We need to push the OP_CONST values.
1810 if (o->op_type == OP_CONST)
1811 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
1813 else if (o->op_type == OP_NULL)
1817 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1819 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1820 if (o->op_type == OP_CONST)
1821 rop = append_elem(OP_LIST, rop,
1822 newSVOP(OP_CONST, o->op_flags,
1823 SvREFCNT_inc_NN(cSVOPo->op_sv)));
1830 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1835 /* fake up C<use attributes $pkg,$rv,@attrs> */
1836 ENTER; /* need to protect against side-effects of 'use' */
1837 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1839 #define ATTRSMODULE "attributes"
1840 #define ATTRSMODULE_PM "attributes.pm"
1843 /* Don't force the C<use> if we don't need it. */
1844 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
1845 if (svp && *svp != &PL_sv_undef)
1846 NOOP; /* already in %INC */
1848 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1849 newSVpvs(ATTRSMODULE), NULL);
1852 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1853 newSVpvs(ATTRSMODULE),
1855 prepend_elem(OP_LIST,
1856 newSVOP(OP_CONST, 0, stashsv),
1857 prepend_elem(OP_LIST,
1858 newSVOP(OP_CONST, 0,
1860 dup_attrlist(attrs))));
1866 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1869 OP *pack, *imop, *arg;
1875 assert(target->op_type == OP_PADSV ||
1876 target->op_type == OP_PADHV ||
1877 target->op_type == OP_PADAV);
1879 /* Ensure that attributes.pm is loaded. */
1880 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1882 /* Need package name for method call. */
1883 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
1885 /* Build up the real arg-list. */
1886 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1888 arg = newOP(OP_PADSV, 0);
1889 arg->op_targ = target->op_targ;
1890 arg = prepend_elem(OP_LIST,
1891 newSVOP(OP_CONST, 0, stashsv),
1892 prepend_elem(OP_LIST,
1893 newUNOP(OP_REFGEN, 0,
1894 mod(arg, OP_REFGEN)),
1895 dup_attrlist(attrs)));
1897 /* Fake up a method call to import */
1898 meth = newSVpvs_share("import");
1899 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1900 append_elem(OP_LIST,
1901 prepend_elem(OP_LIST, pack, list(arg)),
1902 newSVOP(OP_METHOD_NAMED, 0, meth)));
1903 imop->op_private |= OPpENTERSUB_NOMOD;
1905 /* Combine the ops. */
1906 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1910 =notfor apidoc apply_attrs_string
1912 Attempts to apply a list of attributes specified by the C<attrstr> and
1913 C<len> arguments to the subroutine identified by the C<cv> argument which
1914 is expected to be associated with the package identified by the C<stashpv>
1915 argument (see L<attributes>). It gets this wrong, though, in that it
1916 does not correctly identify the boundaries of the individual attribute
1917 specifications within C<attrstr>. This is not really intended for the
1918 public API, but has to be listed here for systems such as AIX which
1919 need an explicit export list for symbols. (It's called from XS code
1920 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1921 to respect attribute syntax properly would be welcome.
1927 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
1928 const char *attrstr, STRLEN len)
1933 len = strlen(attrstr);
1937 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1939 const char * const sstr = attrstr;
1940 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1941 attrs = append_elem(OP_LIST, attrs,
1942 newSVOP(OP_CONST, 0,
1943 newSVpvn(sstr, attrstr-sstr)));
1947 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1948 newSVpvs(ATTRSMODULE),
1949 NULL, prepend_elem(OP_LIST,
1950 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1951 prepend_elem(OP_LIST,
1952 newSVOP(OP_CONST, 0,
1958 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
1963 if (!o || (PL_parser && PL_parser->error_count))
1967 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
1968 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
1972 if (type == OP_LIST) {
1974 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1975 my_kid(kid, attrs, imopsp);
1976 } else if (type == OP_UNDEF
1982 } else if (type == OP_RV2SV || /* "our" declaration */
1984 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1985 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1986 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1988 PL_parser->in_my == KEY_our
1990 : PL_parser->in_my == KEY_state ? "state" : "my"));
1992 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
1993 PL_parser->in_my = FALSE;
1994 PL_parser->in_my_stash = NULL;
1995 apply_attrs(GvSTASH(gv),
1996 (type == OP_RV2SV ? GvSV(gv) :
1997 type == OP_RV2AV ? (SV*)GvAV(gv) :
1998 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
2001 o->op_private |= OPpOUR_INTRO;
2004 else if (type != OP_PADSV &&
2007 type != OP_PUSHMARK)
2009 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2011 PL_parser->in_my == KEY_our
2013 : PL_parser->in_my == KEY_state ? "state" : "my"));
2016 else if (attrs && type != OP_PUSHMARK) {
2019 PL_parser->in_my = FALSE;
2020 PL_parser->in_my_stash = NULL;
2022 /* check for C<my Dog $spot> when deciding package */
2023 stash = PAD_COMPNAME_TYPE(o->op_targ);
2025 stash = PL_curstash;
2026 apply_attrs_my(stash, o, attrs, imopsp);
2028 o->op_flags |= OPf_MOD;
2029 o->op_private |= OPpLVAL_INTRO;
2030 if (PL_parser->in_my == KEY_state)
2031 o->op_private |= OPpPAD_STATE;
2036 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2040 int maybe_scalar = 0;
2042 /* [perl #17376]: this appears to be premature, and results in code such as
2043 C< our(%x); > executing in list mode rather than void mode */
2045 if (o->op_flags & OPf_PARENS)
2055 o = my_kid(o, attrs, &rops);
2057 if (maybe_scalar && o->op_type == OP_PADSV) {
2058 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
2059 o->op_private |= OPpLVAL_INTRO;
2062 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
2064 PL_parser->in_my = FALSE;
2065 PL_parser->in_my_stash = NULL;
2070 Perl_my(pTHX_ OP *o)
2072 return my_attrs(o, NULL);
2076 Perl_sawparens(pTHX_ OP *o)
2078 PERL_UNUSED_CONTEXT;
2080 o->op_flags |= OPf_PARENS;
2085 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2089 const OPCODE ltype = left->op_type;
2090 const OPCODE rtype = right->op_type;
2092 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2093 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
2095 const char * const desc
2096 = PL_op_desc[(rtype == OP_SUBST || rtype == OP_TRANS)
2097 ? (int)rtype : OP_MATCH];
2098 const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV)
2099 ? "@array" : "%hash");
2100 Perl_warner(aTHX_ packWARN(WARN_MISC),
2101 "Applying %s to %s will act on scalar(%s)",
2102 desc, sample, sample);
2105 if (rtype == OP_CONST &&
2106 cSVOPx(right)->op_private & OPpCONST_BARE &&
2107 cSVOPx(right)->op_private & OPpCONST_STRICT)
2109 no_bareword_allowed(right);
2112 ismatchop = rtype == OP_MATCH ||
2113 rtype == OP_SUBST ||
2115 if (ismatchop && right->op_private & OPpTARGET_MY) {
2117 right->op_private &= ~OPpTARGET_MY;
2119 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
2122 right->op_flags |= OPf_STACKED;
2123 if (rtype != OP_MATCH &&
2124 ! (rtype == OP_TRANS &&
2125 right->op_private & OPpTRANS_IDENTICAL))
2126 newleft = mod(left, rtype);
2129 if (right->op_type == OP_TRANS)
2130 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
2132 o = prepend_elem(rtype, scalar(newleft), right);
2134 return newUNOP(OP_NOT, 0, scalar(o));
2138 return bind_match(type, left,
2139 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
2143 Perl_invert(pTHX_ OP *o)
2147 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2151 Perl_scope(pTHX_ OP *o)
2155 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2156 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2157 o->op_type = OP_LEAVE;
2158 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2160 else if (o->op_type == OP_LINESEQ) {
2162 o->op_type = OP_SCOPE;
2163 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2164 kid = ((LISTOP*)o)->op_first;
2165 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2168 /* The following deals with things like 'do {1 for 1}' */
2169 kid = kid->op_sibling;
2171 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2176 o = newLISTOP(OP_SCOPE, 0, o, NULL);
2182 Perl_block_start(pTHX_ int full)
2185 const int retval = PL_savestack_ix;
2186 pad_block_start(full);
2188 PL_hints &= ~HINT_BLOCK_SCOPE;
2189 SAVECOMPILEWARNINGS();
2190 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
2195 Perl_block_end(pTHX_ I32 floor, OP *seq)
2198 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2199 OP* const retval = scalarseq(seq);
2201 CopHINTS_set(&PL_compiling, PL_hints);
2203 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2212 const PADOFFSET offset = pad_findmy("$_");
2213 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
2214 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2217 OP * const o = newOP(OP_PADSV, 0);
2218 o->op_targ = offset;
2224 Perl_newPROG(pTHX_ OP *o)
2230 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2231 ((PL_in_eval & EVAL_KEEPERR)
2232 ? OPf_SPECIAL : 0), o);
2233 PL_eval_start = linklist(PL_eval_root);
2234 PL_eval_root->op_private |= OPpREFCOUNTED;
2235 OpREFCNT_set(PL_eval_root, 1);
2236 PL_eval_root->op_next = 0;
2237 CALL_PEEP(PL_eval_start);
2240 if (o->op_type == OP_STUB) {
2241 PL_comppad_name = 0;
2243 S_op_destroy(aTHX_ o);
2246 PL_main_root = scope(sawparens(scalarvoid(o)));
2247 PL_curcop = &PL_compiling;
2248 PL_main_start = LINKLIST(PL_main_root);
2249 PL_main_root->op_private |= OPpREFCOUNTED;
2250 OpREFCNT_set(PL_main_root, 1);
2251 PL_main_root->op_next = 0;
2252 CALL_PEEP(PL_main_start);
2255 /* Register with debugger */
2258 = Perl_get_cvn_flags(aTHX_ STR_WITH_LEN("DB::postponed"), 0);
2262 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2264 call_sv((SV*)cv, G_DISCARD);
2271 Perl_localize(pTHX_ OP *o, I32 lex)
2274 if (o->op_flags & OPf_PARENS)
2275 /* [perl #17376]: this appears to be premature, and results in code such as
2276 C< our(%x); > executing in list mode rather than void mode */
2283 if ( PL_parser->bufptr > PL_parser->oldbufptr
2284 && PL_parser->bufptr[-1] == ','
2285 && ckWARN(WARN_PARENTHESIS))
2287 char *s = PL_parser->bufptr;
2290 /* some heuristics to detect a potential error */
2291 while (*s && (strchr(", \t\n", *s)))
2295 if (*s && strchr("@$%*", *s) && *++s
2296 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2299 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2301 while (*s && (strchr(", \t\n", *s)))
2307 if (sigil && (*s == ';' || *s == '=')) {
2308 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2309 "Parentheses missing around \"%s\" list",
2311 ? (PL_parser->in_my == KEY_our
2313 : PL_parser->in_my == KEY_state
2323 o = mod(o, OP_NULL); /* a bit kludgey */
2324 PL_parser->in_my = FALSE;
2325 PL_parser->in_my_stash = NULL;
2330 Perl_jmaybe(pTHX_ OP *o)
2332 if (o->op_type == OP_LIST) {
2334 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2335 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2341 Perl_fold_constants(pTHX_ register OP *o)
2344 register OP * VOL curop;
2346 VOL I32 type = o->op_type;
2351 SV * const oldwarnhook = PL_warnhook;
2352 SV * const olddiehook = PL_diehook;
2355 if (PL_opargs[type] & OA_RETSCALAR)
2357 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2358 o->op_targ = pad_alloc(type, SVs_PADTMP);
2360 /* integerize op, unless it happens to be C<-foo>.
2361 * XXX should pp_i_negate() do magic string negation instead? */
2362 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2363 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2364 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2366 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2369 if (!(PL_opargs[type] & OA_FOLDCONST))
2374 /* XXX might want a ck_negate() for this */
2375 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2386 /* XXX what about the numeric ops? */
2387 if (PL_hints & HINT_LOCALE)
2391 if (PL_parser && PL_parser->error_count)
2392 goto nope; /* Don't try to run w/ errors */
2394 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2395 const OPCODE type = curop->op_type;
2396 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2398 type != OP_SCALAR &&
2400 type != OP_PUSHMARK)
2406 curop = LINKLIST(o);
2407 old_next = o->op_next;
2411 oldscope = PL_scopestack_ix;
2412 create_eval_scope(G_FAKINGEVAL);
2414 PL_warnhook = PERL_WARNHOOK_FATAL;
2421 sv = *(PL_stack_sp--);
2422 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2423 pad_swipe(o->op_targ, FALSE);
2424 else if (SvTEMP(sv)) { /* grab mortal temp? */
2425 SvREFCNT_inc_simple_void(sv);
2430 /* Something tried to die. Abandon constant folding. */
2431 /* Pretend the error never happened. */
2432 sv_setpvn(ERRSV,"",0);
2433 o->op_next = old_next;
2437 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
2438 PL_warnhook = oldwarnhook;
2439 PL_diehook = olddiehook;
2440 /* XXX note that this croak may fail as we've already blown away
2441 * the stack - eg any nested evals */
2442 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
2445 PL_warnhook = oldwarnhook;
2446 PL_diehook = olddiehook;
2448 if (PL_scopestack_ix > oldscope)
2449 delete_eval_scope();
2458 if (type == OP_RV2GV)
2459 newop = newGVOP(OP_GV, 0, (GV*)sv);
2461 newop = newSVOP(OP_CONST, 0, (SV*)sv);
2462 op_getmad(o,newop,'f');
2470 Perl_gen_constant_list(pTHX_ register OP *o)
2474 const I32 oldtmps_floor = PL_tmps_floor;
2477 if (PL_parser && PL_parser->error_count)
2478 return o; /* Don't attempt to run with errors */
2480 PL_op = curop = LINKLIST(o);
2486 assert (!(curop->op_flags & OPf_SPECIAL));
2487 assert(curop->op_type == OP_RANGE);
2489 PL_tmps_floor = oldtmps_floor;
2491 o->op_type = OP_RV2AV;
2492 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2493 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2494 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2495 o->op_opt = 0; /* needs to be revisited in peep() */
2496 curop = ((UNOP*)o)->op_first;
2497 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
2499 op_getmad(curop,o,'O');
2508 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2511 if (!o || o->op_type != OP_LIST)
2512 o = newLISTOP(OP_LIST, 0, o, NULL);
2514 o->op_flags &= ~OPf_WANT;
2516 if (!(PL_opargs[type] & OA_MARK))
2517 op_null(cLISTOPo->op_first);
2519 o->op_type = (OPCODE)type;
2520 o->op_ppaddr = PL_ppaddr[type];
2521 o->op_flags |= flags;
2523 o = CHECKOP(type, o);
2524 if (o->op_type != (unsigned)type)
2527 return fold_constants(o);
2530 /* List constructors */
2533 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2541 if (first->op_type != (unsigned)type
2542 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2544 return newLISTOP(type, 0, first, last);
2547 if (first->op_flags & OPf_KIDS)
2548 ((LISTOP*)first)->op_last->op_sibling = last;
2550 first->op_flags |= OPf_KIDS;
2551 ((LISTOP*)first)->op_first = last;
2553 ((LISTOP*)first)->op_last = last;
2558 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2566 if (first->op_type != (unsigned)type)
2567 return prepend_elem(type, (OP*)first, (OP*)last);
2569 if (last->op_type != (unsigned)type)
2570 return append_elem(type, (OP*)first, (OP*)last);
2572 first->op_last->op_sibling = last->op_first;
2573 first->op_last = last->op_last;
2574 first->op_flags |= (last->op_flags & OPf_KIDS);
2577 if (last->op_first && first->op_madprop) {
2578 MADPROP *mp = last->op_first->op_madprop;
2580 while (mp->mad_next)
2582 mp->mad_next = first->op_madprop;
2585 last->op_first->op_madprop = first->op_madprop;
2588 first->op_madprop = last->op_madprop;
2589 last->op_madprop = 0;
2592 S_op_destroy(aTHX_ (OP*)last);
2598 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2606 if (last->op_type == (unsigned)type) {
2607 if (type == OP_LIST) { /* already a PUSHMARK there */
2608 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2609 ((LISTOP*)last)->op_first->op_sibling = first;
2610 if (!(first->op_flags & OPf_PARENS))
2611 last->op_flags &= ~OPf_PARENS;
2614 if (!(last->op_flags & OPf_KIDS)) {
2615 ((LISTOP*)last)->op_last = first;
2616 last->op_flags |= OPf_KIDS;
2618 first->op_sibling = ((LISTOP*)last)->op_first;
2619 ((LISTOP*)last)->op_first = first;
2621 last->op_flags |= OPf_KIDS;
2625 return newLISTOP(type, 0, first, last);
2633 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2636 Newxz(tk, 1, TOKEN);
2637 tk->tk_type = (OPCODE)optype;
2638 tk->tk_type = 12345;
2640 tk->tk_mad = madprop;
2645 Perl_token_free(pTHX_ TOKEN* tk)
2647 if (tk->tk_type != 12345)
2649 mad_free(tk->tk_mad);
2654 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2658 if (tk->tk_type != 12345) {
2659 Perl_warner(aTHX_ packWARN(WARN_MISC),
2660 "Invalid TOKEN object ignored");
2667 /* faked up qw list? */
2669 tm->mad_type == MAD_SV &&
2670 SvPVX((SV*)tm->mad_val)[0] == 'q')
2677 /* pretend constant fold didn't happen? */
2678 if (mp->mad_key == 'f' &&
2679 (o->op_type == OP_CONST ||
2680 o->op_type == OP_GV) )
2682 token_getmad(tk,(OP*)mp->mad_val,slot);
2696 if (mp->mad_key == 'X')
2697 mp->mad_key = slot; /* just change the first one */
2707 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
2716 /* pretend constant fold didn't happen? */
2717 if (mp->mad_key == 'f' &&
2718 (o->op_type == OP_CONST ||
2719 o->op_type == OP_GV) )
2721 op_getmad(from,(OP*)mp->mad_val,slot);
2728 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
2731 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
2737 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
2746 /* pretend constant fold didn't happen? */
2747 if (mp->mad_key == 'f' &&
2748 (o->op_type == OP_CONST ||
2749 o->op_type == OP_GV) )
2751 op_getmad(from,(OP*)mp->mad_val,slot);
2758 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
2761 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
2765 PerlIO_printf(PerlIO_stderr(),
2766 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
2772 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
2790 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
2794 addmad(tm, &(o->op_madprop), slot);
2798 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
2819 Perl_newMADsv(pTHX_ char key, SV* sv)
2821 return newMADPROP(key, MAD_SV, sv, 0);
2825 Perl_newMADPROP(pTHX_ char key, char type, const void* val, I32 vlen)
2828 Newxz(mp, 1, MADPROP);
2831 mp->mad_vlen = vlen;
2832 mp->mad_type = type;
2834 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
2839 Perl_mad_free(pTHX_ MADPROP* mp)
2841 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
2845 mad_free(mp->mad_next);
2846 /* if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
2847 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
2848 switch (mp->mad_type) {
2852 Safefree((char*)mp->mad_val);
2855 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
2856 op_free((OP*)mp->mad_val);
2859 sv_free((SV*)mp->mad_val);
2862 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
2871 Perl_newNULLLIST(pTHX)
2873 return newOP(OP_STUB, 0);
2877 Perl_force_list(pTHX_ OP *o)
2879 if (!o || o->op_type != OP_LIST)
2880 o = newLISTOP(OP_LIST, 0, o, NULL);
2886 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2891 NewOp(1101, listop, 1, LISTOP);
2893 listop->op_type = (OPCODE)type;
2894 listop->op_ppaddr = PL_ppaddr[type];
2897 listop->op_flags = (U8)flags;
2901 else if (!first && last)
2904 first->op_sibling = last;
2905 listop->op_first = first;
2906 listop->op_last = last;
2907 if (type == OP_LIST) {
2908 OP* const pushop = newOP(OP_PUSHMARK, 0);
2909 pushop->op_sibling = first;
2910 listop->op_first = pushop;
2911 listop->op_flags |= OPf_KIDS;
2913 listop->op_last = pushop;
2916 return CHECKOP(type, listop);
2920 Perl_newOP(pTHX_ I32 type, I32 flags)
2924 NewOp(1101, o, 1, OP);
2925 o->op_type = (OPCODE)type;
2926 o->op_ppaddr = PL_ppaddr[type];
2927 o->op_flags = (U8)flags;
2929 o->op_latefreed = 0;
2933 o->op_private = (U8)(0 | (flags >> 8));
2934 if (PL_opargs[type] & OA_RETSCALAR)
2936 if (PL_opargs[type] & OA_TARGET)
2937 o->op_targ = pad_alloc(type, SVs_PADTMP);
2938 return CHECKOP(type, o);
2942 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2948 first = newOP(OP_STUB, 0);
2949 if (PL_opargs[type] & OA_MARK)
2950 first = force_list(first);
2952 NewOp(1101, unop, 1, UNOP);
2953 unop->op_type = (OPCODE)type;
2954 unop->op_ppaddr = PL_ppaddr[type];
2955 unop->op_first = first;
2956 unop->op_flags = (U8)(flags | OPf_KIDS);
2957 unop->op_private = (U8)(1 | (flags >> 8));
2958 unop = (UNOP*) CHECKOP(type, unop);
2962 return fold_constants((OP *) unop);
2966 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2970 NewOp(1101, binop, 1, BINOP);
2973 first = newOP(OP_NULL, 0);
2975 binop->op_type = (OPCODE)type;
2976 binop->op_ppaddr = PL_ppaddr[type];
2977 binop->op_first = first;
2978 binop->op_flags = (U8)(flags | OPf_KIDS);
2981 binop->op_private = (U8)(1 | (flags >> 8));
2984 binop->op_private = (U8)(2 | (flags >> 8));
2985 first->op_sibling = last;
2988 binop = (BINOP*)CHECKOP(type, binop);
2989 if (binop->op_next || binop->op_type != (OPCODE)type)
2992 binop->op_last = binop->op_first->op_sibling;
2994 return fold_constants((OP *)binop);
2997 static int uvcompare(const void *a, const void *b)
2998 __attribute__nonnull__(1)
2999 __attribute__nonnull__(2)
3000 __attribute__pure__;
3001 static int uvcompare(const void *a, const void *b)
3003 if (*((const UV *)a) < (*(const UV *)b))
3005 if (*((const UV *)a) > (*(const UV *)b))
3007 if (*((const UV *)a+1) < (*(const UV *)b+1))
3009 if (*((const UV *)a+1) > (*(const UV *)b+1))
3015 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
3018 SV * const tstr = ((SVOP*)expr)->op_sv;
3021 (repl->op_type == OP_NULL)
3022 ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
3024 ((SVOP*)repl)->op_sv;
3027 const U8 *t = (U8*)SvPV_const(tstr, tlen);
3028 const U8 *r = (U8*)SvPV_const(rstr, rlen);
3032 register short *tbl;
3034 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
3035 const I32 squash = o->op_private & OPpTRANS_SQUASH;
3036 I32 del = o->op_private & OPpTRANS_DELETE;
3038 PL_hints |= HINT_BLOCK_SCOPE;
3041 o->op_private |= OPpTRANS_FROM_UTF;
3044 o->op_private |= OPpTRANS_TO_UTF;
3046 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
3047 SV* const listsv = newSVpvs("# comment\n");
3049 const U8* tend = t + tlen;
3050 const U8* rend = r + rlen;
3064 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
3065 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
3068 const U32 flags = UTF8_ALLOW_DEFAULT;
3072 t = tsave = bytes_to_utf8(t, &len);
3075 if (!to_utf && rlen) {
3077 r = rsave = bytes_to_utf8(r, &len);
3081 /* There are several snags with this code on EBCDIC:
3082 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
3083 2. scan_const() in toke.c has encoded chars in native encoding which makes
3084 ranges at least in EBCDIC 0..255 range the bottom odd.
3088 U8 tmpbuf[UTF8_MAXBYTES+1];
3091 Newx(cp, 2*tlen, UV);
3093 transv = newSVpvs("");
3095 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3097 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
3099 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3103 cp[2*i+1] = cp[2*i];
3107 qsort(cp, i, 2*sizeof(UV), uvcompare);
3108 for (j = 0; j < i; j++) {
3110 diff = val - nextmin;
3112 t = uvuni_to_utf8(tmpbuf,nextmin);
3113 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3115 U8 range_mark = UTF_TO_NATIVE(0xff);
3116 t = uvuni_to_utf8(tmpbuf, val - 1);
3117 sv_catpvn(transv, (char *)&range_mark, 1);
3118 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3125 t = uvuni_to_utf8(tmpbuf,nextmin);
3126 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3128 U8 range_mark = UTF_TO_NATIVE(0xff);
3129 sv_catpvn(transv, (char *)&range_mark, 1);
3131 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
3132 UNICODE_ALLOW_SUPER);
3133 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3134 t = (const U8*)SvPVX_const(transv);
3135 tlen = SvCUR(transv);
3139 else if (!rlen && !del) {
3140 r = t; rlen = tlen; rend = tend;
3143 if ((!rlen && !del) || t == r ||
3144 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
3146 o->op_private |= OPpTRANS_IDENTICAL;
3150 while (t < tend || tfirst <= tlast) {
3151 /* see if we need more "t" chars */
3152 if (tfirst > tlast) {
3153 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3155 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
3157 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3164 /* now see if we need more "r" chars */
3165 if (rfirst > rlast) {
3167 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3169 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
3171 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3180 rfirst = rlast = 0xffffffff;
3184 /* now see which range will peter our first, if either. */
3185 tdiff = tlast - tfirst;
3186 rdiff = rlast - rfirst;
3193 if (rfirst == 0xffffffff) {
3194 diff = tdiff; /* oops, pretend rdiff is infinite */
3196 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
3197 (long)tfirst, (long)tlast);
3199 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
3203 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
3204 (long)tfirst, (long)(tfirst + diff),
3207 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3208 (long)tfirst, (long)rfirst);
3210 if (rfirst + diff > max)
3211 max = rfirst + diff;
3213 grows = (tfirst < rfirst &&
3214 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3226 else if (max > 0xff)
3231 PerlMemShared_free(cPVOPo->op_pv);
3232 cPVOPo->op_pv = NULL;
3234 swash = (SV*)swash_init("utf8", "", listsv, bits, none);
3236 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
3237 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
3238 PAD_SETSV(cPADOPo->op_padix, swash);
3241 cSVOPo->op_sv = swash;
3243 SvREFCNT_dec(listsv);
3244 SvREFCNT_dec(transv);
3246 if (!del && havefinal && rlen)
3247 (void)hv_store((HV*)SvRV(swash), "FINAL", 5,
3248 newSVuv((UV)final), 0);
3251 o->op_private |= OPpTRANS_GROWS;
3257 op_getmad(expr,o,'e');
3258 op_getmad(repl,o,'r');
3266 tbl = (short*)cPVOPo->op_pv;
3268 Zero(tbl, 256, short);
3269 for (i = 0; i < (I32)tlen; i++)
3271 for (i = 0, j = 0; i < 256; i++) {
3273 if (j >= (I32)rlen) {
3282 if (i < 128 && r[j] >= 128)
3292 o->op_private |= OPpTRANS_IDENTICAL;
3294 else if (j >= (I32)rlen)
3299 PerlMemShared_realloc(tbl,
3300 (0x101+rlen-j) * sizeof(short));
3301 cPVOPo->op_pv = (char*)tbl;
3303 tbl[0x100] = (short)(rlen - j);
3304 for (i=0; i < (I32)rlen - j; i++)
3305 tbl[0x101+i] = r[j+i];
3309 if (!rlen && !del) {
3312 o->op_private |= OPpTRANS_IDENTICAL;
3314 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3315 o->op_private |= OPpTRANS_IDENTICAL;
3317 for (i = 0; i < 256; i++)
3319 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3320 if (j >= (I32)rlen) {
3322 if (tbl[t[i]] == -1)
3328 if (tbl[t[i]] == -1) {
3329 if (t[i] < 128 && r[j] >= 128)
3336 o->op_private |= OPpTRANS_GROWS;
3338 op_getmad(expr,o,'e');
3339 op_getmad(repl,o,'r');
3349 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3354 NewOp(1101, pmop, 1, PMOP);
3355 pmop->op_type = (OPCODE)type;
3356 pmop->op_ppaddr = PL_ppaddr[type];
3357 pmop->op_flags = (U8)flags;
3358 pmop->op_private = (U8)(0 | (flags >> 8));
3360 if (PL_hints & HINT_RE_TAINT)
3361 pmop->op_pmflags |= PMf_RETAINT;
3362 if (PL_hints & HINT_LOCALE)
3363 pmop->op_pmflags |= PMf_LOCALE;
3367 assert(SvPOK(PL_regex_pad[0]));
3368 if (SvCUR(PL_regex_pad[0])) {
3369 /* Pop off the "packed" IV from the end. */
3370 SV *const repointer_list = PL_regex_pad[0];
3371 const char *p = SvEND(repointer_list) - sizeof(IV);
3372 const IV offset = *((IV*)p);
3374 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
3376 SvEND_set(repointer_list, p);
3378 pmop->op_pmoffset = offset;
3379 /* This slot should be free, so assert this: */
3380 assert(PL_regex_pad[offset] == &PL_sv_undef);
3382 SV * const repointer = &PL_sv_undef;
3383 av_push(PL_regex_padav, repointer);
3384 pmop->op_pmoffset = av_len(PL_regex_padav);
3385 PL_regex_pad = AvARRAY(PL_regex_padav);
3389 return CHECKOP(type, pmop);
3392 /* Given some sort of match op o, and an expression expr containing a
3393 * pattern, either compile expr into a regex and attach it to o (if it's
3394 * constant), or convert expr into a runtime regcomp op sequence (if it's
3397 * isreg indicates that the pattern is part of a regex construct, eg
3398 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3399 * split "pattern", which aren't. In the former case, expr will be a list
3400 * if the pattern contains more than one term (eg /a$b/) or if it contains
3401 * a replacement, ie s/// or tr///.
3405 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
3410 I32 repl_has_vars = 0;
3414 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
3415 /* last element in list is the replacement; pop it */
3417 repl = cLISTOPx(expr)->op_last;
3418 kid = cLISTOPx(expr)->op_first;
3419 while (kid->op_sibling != repl)
3420 kid = kid->op_sibling;
3421 kid->op_sibling = NULL;
3422 cLISTOPx(expr)->op_last = kid;
3425 if (isreg && expr->op_type == OP_LIST &&
3426 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3428 /* convert single element list to element */
3429 OP* const oe = expr;
3430 expr = cLISTOPx(oe)->op_first->op_sibling;
3431 cLISTOPx(oe)->op_first->op_sibling = NULL;
3432 cLISTOPx(oe)->op_last = NULL;
3436 if (o->op_type == OP_TRANS) {
3437 return pmtrans(o, expr, repl);
3440 reglist = isreg && expr->op_type == OP_LIST;
3444 PL_hints |= HINT_BLOCK_SCOPE;
3447 if (expr->op_type == OP_CONST) {
3448 SV *pat = ((SVOP*)expr)->op_sv;
3449 U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
3451 if (o->op_flags & OPf_SPECIAL)
3452 pm_flags |= RXf_SPLIT;
3455 assert (SvUTF8(pat));
3456 } else if (SvUTF8(pat)) {
3457 /* Not doing UTF-8, despite what the SV says. Is this only if we're
3458 trapped in use 'bytes'? */
3459 /* Make a copy of the octet sequence, but without the flag on, as
3460 the compiler now honours the SvUTF8 flag on pat. */
3462 const char *const p = SvPV(pat, len);
3463 pat = newSVpvn_flags(p, len, SVs_TEMP);
3466 PM_SETRE(pm, CALLREGCOMP(pat, pm_flags));
3469 op_getmad(expr,(OP*)pm,'e');
3475 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3476 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3478 : OP_REGCMAYBE),0,expr);
3480 NewOp(1101, rcop, 1, LOGOP);
3481 rcop->op_type = OP_REGCOMP;
3482 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3483 rcop->op_first = scalar(expr);
3484 rcop->op_flags |= OPf_KIDS
3485 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3486 | (reglist ? OPf_STACKED : 0);
3487 rcop->op_private = 1;
3490 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3492 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
3495 /* establish postfix order */
3496 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3498 rcop->op_next = expr;
3499 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3502 rcop->op_next = LINKLIST(expr);
3503 expr->op_next = (OP*)rcop;
3506 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3511 if (pm->op_pmflags & PMf_EVAL) {
3513 if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
3514 CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
3516 else if (repl->op_type == OP_CONST)
3520 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3521 if (curop->op_type == OP_SCOPE
3522 || curop->op_type == OP_LEAVE
3523 || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
3524 if (curop->op_type == OP_GV) {
3525 GV * const gv = cGVOPx_gv(curop);
3527 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3530 else if (curop->op_type == OP_RV2CV)
3532 else if (curop->op_type == OP_RV2SV ||
3533 curop->op_type == OP_RV2AV ||
3534 curop->op_type == OP_RV2HV ||
3535 curop->op_type == OP_RV2GV) {
3536 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3539 else if (curop->op_type == OP_PADSV ||
3540 curop->op_type == OP_PADAV ||
3541 curop->op_type == OP_PADHV ||
3542 curop->op_type == OP_PADANY)
3546 else if (curop->op_type == OP_PUSHRE)
3547 NOOP; /* Okay here, dangerous in newASSIGNOP */
3557 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
3559 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3560 prepend_elem(o->op_type, scalar(repl), o);
3563 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3564 pm->op_pmflags |= PMf_MAYBE_CONST;
3566 NewOp(1101, rcop, 1, LOGOP);
3567 rcop->op_type = OP_SUBSTCONT;
3568 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3569 rcop->op_first = scalar(repl);
3570 rcop->op_flags |= OPf_KIDS;
3571 rcop->op_private = 1;
3574 /* establish postfix order */
3575 rcop->op_next = LINKLIST(repl);
3576 repl->op_next = (OP*)rcop;
3578 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
3579 assert(!(pm->op_pmflags & PMf_ONCE));
3580 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
3589 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3593 NewOp(1101, svop, 1, SVOP);
3594 svop->op_type = (OPCODE)type;
3595 svop->op_ppaddr = PL_ppaddr[type];
3597 svop->op_next = (OP*)svop;
3598 svop->op_flags = (U8)flags;
3599 if (PL_opargs[type] & OA_RETSCALAR)
3601 if (PL_opargs[type] & OA_TARGET)
3602 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3603 return CHECKOP(type, svop);
3608 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3612 NewOp(1101, padop, 1, PADOP);
3613 padop->op_type = (OPCODE)type;
3614 padop->op_ppaddr = PL_ppaddr[type];
3615 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3616 SvREFCNT_dec(PAD_SVl(padop->op_padix));
3617 PAD_SETSV(padop->op_padix, sv);
3620 padop->op_next = (OP*)padop;
3621 padop->op_flags = (U8)flags;
3622 if (PL_opargs[type] & OA_RETSCALAR)
3624 if (PL_opargs[type] & OA_TARGET)
3625 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3626 return CHECKOP(type, padop);
3631 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3637 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3639 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3644 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3648 NewOp(1101, pvop, 1, PVOP);
3649 pvop->op_type = (OPCODE)type;
3650 pvop->op_ppaddr = PL_ppaddr[type];
3652 pvop->op_next = (OP*)pvop;
3653 pvop->op_flags = (U8)flags;
3654 if (PL_opargs[type] & OA_RETSCALAR)
3656 if (PL_opargs[type] & OA_TARGET)
3657 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3658 return CHECKOP(type, pvop);
3666 Perl_package(pTHX_ OP *o)
3669 SV *const sv = cSVOPo->op_sv;
3674 save_hptr(&PL_curstash);
3675 save_item(PL_curstname);
3677 PL_curstash = gv_stashsv(sv, GV_ADD);
3679 sv_setsv(PL_curstname, sv);
3681 PL_hints |= HINT_BLOCK_SCOPE;
3682 PL_parser->copline = NOLINE;
3683 PL_parser->expect = XSTATE;
3688 if (!PL_madskills) {
3693 pegop = newOP(OP_NULL,0);
3694 op_getmad(o,pegop,'P');
3704 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3711 OP *pegop = newOP(OP_NULL,0);
3714 if (idop->op_type != OP_CONST)
3715 Perl_croak(aTHX_ "Module name must be constant");
3718 op_getmad(idop,pegop,'U');
3723 SV * const vesv = ((SVOP*)version)->op_sv;
3726 op_getmad(version,pegop,'V');
3727 if (!arg && !SvNIOKp(vesv)) {
3734 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3735 Perl_croak(aTHX_ "Version number must be constant number");
3737 /* Make copy of idop so we don't free it twice */
3738 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3740 /* Fake up a method call to VERSION */
3741 meth = newSVpvs_share("VERSION");
3742 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3743 append_elem(OP_LIST,
3744 prepend_elem(OP_LIST, pack, list(version)),
3745 newSVOP(OP_METHOD_NAMED, 0, meth)));
3749 /* Fake up an import/unimport */
3750 if (arg && arg->op_type == OP_STUB) {
3752 op_getmad(arg,pegop,'S');
3753 imop = arg; /* no import on explicit () */
3755 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3756 imop = NULL; /* use 5.0; */
3758 idop->op_private |= OPpCONST_NOVER;
3764 op_getmad(arg,pegop,'A');
3766 /* Make copy of idop so we don't free it twice */
3767 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3769 /* Fake up a method call to import/unimport */
3771 ? newSVpvs_share("import") : newSVpvs_share("unimport");
3772 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3773 append_elem(OP_LIST,
3774 prepend_elem(OP_LIST, pack, list(arg)),
3775 newSVOP(OP_METHOD_NAMED, 0, meth)));
3778 /* Fake up the BEGIN {}, which does its thing immediately. */
3780 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
3783 append_elem(OP_LINESEQ,
3784 append_elem(OP_LINESEQ,
3785 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
3786 newSTATEOP(0, NULL, veop)),
3787 newSTATEOP(0, NULL, imop) ));
3789 /* The "did you use incorrect case?" warning used to be here.
3790 * The problem is that on case-insensitive filesystems one
3791 * might get false positives for "use" (and "require"):
3792 * "use Strict" or "require CARP" will work. This causes
3793 * portability problems for the script: in case-strict
3794 * filesystems the script will stop working.
3796 * The "incorrect case" warning checked whether "use Foo"
3797 * imported "Foo" to your namespace, but that is wrong, too:
3798 * there is no requirement nor promise in the language that
3799 * a Foo.pm should or would contain anything in package "Foo".
3801 * There is very little Configure-wise that can be done, either:
3802 * the case-sensitivity of the build filesystem of Perl does not
3803 * help in guessing the case-sensitivity of the runtime environment.
3806 PL_hints |= HINT_BLOCK_SCOPE;
3807 PL_parser->copline = NOLINE;
3808 PL_parser->expect = XSTATE;
3809 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3812 if (!PL_madskills) {
3813 /* FIXME - don't allocate pegop if !PL_madskills */
3822 =head1 Embedding Functions
3824 =for apidoc load_module
3826 Loads the module whose name is pointed to by the string part of name.
3827 Note that the actual module name, not its filename, should be given.
3828 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3829 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3830 (or 0 for no flags). ver, if specified, provides version semantics
3831 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3832 arguments can be used to specify arguments to the module's import()
3833 method, similar to C<use Foo::Bar VERSION LIST>.
3838 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3841 va_start(args, ver);
3842 vload_module(flags, name, ver, &args);
3846 #ifdef PERL_IMPLICIT_CONTEXT
3848 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3852 va_start(args, ver);
3853 vload_module(flags, name, ver, &args);
3859 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3864 OP * const modname = newSVOP(OP_CONST, 0, name);
3865 modname->op_private |= OPpCONST_BARE;
3867 veop = newSVOP(OP_CONST, 0, ver);
3871 if (flags & PERL_LOADMOD_NOIMPORT) {
3872 imop = sawparens(newNULLLIST());
3874 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3875 imop = va_arg(*args, OP*);
3880 sv = va_arg(*args, SV*);
3882 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3883 sv = va_arg(*args, SV*);
3887 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
3888 * that it has a PL_parser to play with while doing that, and also
3889 * that it doesn't mess with any existing parser, by creating a tmp
3890 * new parser with lex_start(). This won't actually be used for much,
3891 * since pp_require() will create another parser for the real work. */
3894 SAVEVPTR(PL_curcop);
3895 lex_start(NULL, NULL, FALSE);
3896 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3897 veop, modname, imop);
3902 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
3908 if (!force_builtin) {
3909 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
3910 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
3911 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
3912 gv = gvp ? *gvp : NULL;
3916 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3917 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3918 append_elem(OP_LIST, term,
3919 scalar(newUNOP(OP_RV2CV, 0,
3920 newGVOP(OP_GV, 0, gv))))));
3923 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3929 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3931 return newBINOP(OP_LSLICE, flags,
3932 list(force_list(subscript)),
3933 list(force_list(listval)) );
3937 S_is_list_assignment(pTHX_ register const OP *o)
3945 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
3946 o = cUNOPo->op_first;
3948 flags = o->op_flags;
3950 if (type == OP_COND_EXPR) {
3951 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
3952 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3957 yyerror("Assignment to both a list and a scalar");
3961 if (type == OP_LIST &&
3962 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
3963 o->op_private & OPpLVAL_INTRO)
3966 if (type == OP_LIST || flags & OPf_PARENS ||
3967 type == OP_RV2AV || type == OP_RV2HV ||
3968 type == OP_ASLICE || type == OP_HSLICE)
3971 if (type == OP_PADAV || type == OP_PADHV)
3974 if (type == OP_RV2SV)
3981 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3987 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3988 return newLOGOP(optype, 0,
3989 mod(scalar(left), optype),
3990 newUNOP(OP_SASSIGN, 0, scalar(right)));
3993 return newBINOP(optype, OPf_STACKED,
3994 mod(scalar(left), optype), scalar(right));
3998 if (is_list_assignment(left)) {
3999 static const char no_list_state[] = "Initialization of state variables"
4000 " in list context currently forbidden";
4002 bool maybe_common_vars = TRUE;
4005 /* Grandfathering $[ assignment here. Bletch.*/
4006 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
4007 PL_eval_start = (left->op_type == OP_CONST) ? right : NULL;
4008 left = mod(left, OP_AASSIGN);
4011 else if (left->op_type == OP_CONST) {
4013 /* Result of assignment is always 1 (or we'd be dead already) */
4014 return newSVOP(OP_CONST, 0, newSViv(1));
4016 curop = list(force_list(left));
4017 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
4018 o->op_private = (U8)(0 | (flags >> 8));
4020 if ((left->op_type == OP_LIST
4021 || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
4023 OP* lop = ((LISTOP*)left)->op_first;
4024 maybe_common_vars = FALSE;
4026 if (lop->op_type == OP_PADSV ||
4027 lop->op_type == OP_PADAV ||
4028 lop->op_type == OP_PADHV ||
4029 lop->op_type == OP_PADANY) {
4030 if (!(lop->op_private & OPpLVAL_INTRO))
4031 maybe_common_vars = TRUE;
4033 if (lop->op_private & OPpPAD_STATE) {
4034 if (left->op_private & OPpLVAL_INTRO) {
4035 /* Each variable in state($a, $b, $c) = ... */
4038 /* Each state variable in
4039 (state $a, my $b, our $c, $d, undef) = ... */
4041 yyerror(no_list_state);
4043 /* Each my variable in
4044 (state $a, my $b, our $c, $d, undef) = ... */
4046 } else if (lop->op_type == OP_UNDEF ||
4047 lop->op_type == OP_PUSHMARK) {
4048 /* undef may be interesting in
4049 (state $a, undef, state $c) */
4051 /* Other ops in the list. */
4052 maybe_common_vars = TRUE;
4054 lop = lop->op_sibling;
4057 else if ((left->op_private & OPpLVAL_INTRO)
4058 && ( left->op_type == OP_PADSV
4059 || left->op_type == OP_PADAV
4060 || left->op_type == OP_PADHV
4061 || left->op_type == OP_PADANY))
4063 maybe_common_vars = FALSE;
4064 if (left->op_private & OPpPAD_STATE) {
4065 /* All single variable list context state assignments, hence
4075 yyerror(no_list_state);
4079 /* PL_generation sorcery:
4080 * an assignment like ($a,$b) = ($c,$d) is easier than
4081 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
4082 * To detect whether there are common vars, the global var
4083 * PL_generation is incremented for each assign op we compile.
4084 * Then, while compiling the assign op, we run through all the
4085 * variables on both sides of the assignment, setting a spare slot
4086 * in each of them to PL_generation. If any of them already have
4087 * that value, we know we've got commonality. We could use a
4088 * single bit marker, but then we'd have to make 2 passes, first
4089 * to clear the flag, then to test and set it. To find somewhere
4090 * to store these values, evil chicanery is done with SvUVX().
4093 if (maybe_common_vars) {
4096 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4097 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
4098 if (curop->op_type == OP_GV) {
4099 GV *gv = cGVOPx_gv(curop);
4101 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4103 GvASSIGN_GENERATION_set(gv, PL_generation);
4105 else if (curop->op_type == OP_PADSV ||
4106 curop->op_type == OP_PADAV ||
4107 curop->op_type == OP_PADHV ||
4108 curop->op_type == OP_PADANY)
4110 if (PAD_COMPNAME_GEN(curop->op_targ)
4111 == (STRLEN)PL_generation)
4113 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
4116 else if (curop->op_type == OP_RV2CV)
4118 else if (curop->op_type == OP_RV2SV ||
4119 curop->op_type == OP_RV2AV ||
4120 curop->op_type == OP_RV2HV ||
4121 curop->op_type == OP_RV2GV) {
4122 if (lastop->op_type != OP_GV) /* funny deref? */
4125 else if (curop->op_type == OP_PUSHRE) {
4127 if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
4128 GV *const gv = (GV*)PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff);
4130 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4132 GvASSIGN_GENERATION_set(gv, PL_generation);
4136 = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
4139 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4141 GvASSIGN_GENERATION_set(gv, PL_generation);
4151 o->op_private |= OPpASSIGN_COMMON;
4154 if (right && right->op_type == OP_SPLIT && !PL_madskills) {
4155 OP* tmpop = ((LISTOP*)right)->op_first;
4156 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
4157 PMOP * const pm = (PMOP*)tmpop;
4158 if (left->op_type == OP_RV2AV &&
4159 !(left->op_private & OPpLVAL_INTRO) &&
4160 !(o->op_private & OPpASSIGN_COMMON) )
4162 tmpop = ((UNOP*)left)->op_first;
4163 if (tmpop->op_type == OP_GV
4165 && !pm->op_pmreplrootu.op_pmtargetoff
4167 && !pm->op_pmreplrootu.op_pmtargetgv
4171 pm->op_pmreplrootu.op_pmtargetoff
4172 = cPADOPx(tmpop)->op_padix;
4173 cPADOPx(tmpop)->op_padix = 0; /* steal it */
4175 pm->op_pmreplrootu.op_pmtargetgv
4176 = (GV*)cSVOPx(tmpop)->op_sv;
4177 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
4179 pm->op_pmflags |= PMf_ONCE;
4180 tmpop = cUNOPo->op_first; /* to list (nulled) */
4181 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
4182 tmpop->op_sibling = NULL; /* don't free split */
4183 right->op_next = tmpop->op_next; /* fix starting loc */
4184 op_free(o); /* blow off assign */
4185 right->op_flags &= ~OPf_WANT;
4186 /* "I don't know and I don't care." */
4191 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
4192 ((LISTOP*)right)->op_last->op_type == OP_CONST)
4194 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
4196 sv_setiv(sv, PL_modcount+1);
4204 right = newOP(OP_UNDEF, 0);
4205 if (right->op_type == OP_READLINE) {
4206 right->op_flags |= OPf_STACKED;
4207 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
4210 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
4211 o = newBINOP(OP_SASSIGN, flags,
4212 scalar(right), mod(scalar(left), OP_SASSIGN) );
4218 o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
4219 o->op_private |= OPpCONST_ARYBASE;
4226 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
4229 const U32 seq = intro_my();
4232 NewOp(1101, cop, 1, COP);
4233 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
4234 cop->op_type = OP_DBSTATE;
4235 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
4238 cop->op_type = OP_NEXTSTATE;
4239 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
4241 cop->op_flags = (U8)flags;
4242 CopHINTS_set(cop, PL_hints);
4244 cop->op_private |= NATIVE_HINTS;
4246 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
4247 cop->op_next = (OP*)cop;
4250 CopLABEL_set(cop, label);
4251 PL_hints |= HINT_BLOCK_SCOPE;
4254 /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
4255 CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
4257 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
4258 cop->cop_hints_hash = PL_curcop->cop_hints_hash;
4259 if (cop->cop_hints_hash) {
4261 cop->cop_hints_hash->refcounted_he_refcnt++;
4262 HINTS_REFCNT_UNLOCK;
4265 if (PL_parser && PL_parser->copline == NOLINE)
4266 CopLINE_set(cop, CopLINE(PL_curcop));
4268 CopLINE_set(cop, PL_parser->copline);
4270 PL_parser->copline = NOLINE;
4273 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
4275 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
4277 CopSTASH_set(cop, PL_curstash);
4279 if (PERLDB_LINE && PL_curstash != PL_debstash) {
4280 AV *av = CopFILEAVx(PL_curcop);
4282 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
4283 if (svp && *svp != &PL_sv_undef ) {
4284 (void)SvIOK_on(*svp);
4285 SvIV_set(*svp, PTR2IV(cop));
4290 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
4295 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
4298 return new_logop(type, flags, &first, &other);
4302 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
4307 OP *first = *firstp;
4308 OP * const other = *otherp;
4310 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
4311 return newBINOP(type, flags, scalar(first), scalar(other));
4313 scalarboolean(first);
4314 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
4315 if (first->op_type == OP_NOT
4316 && (first->op_flags & OPf_SPECIAL)
4317 && (first->op_flags & OPf_KIDS)
4319 if (type == OP_AND || type == OP_OR) {
4325 first = *firstp = cUNOPo->op_first;
4327 first->op_next = o->op_next;
4328 cUNOPo->op_first = NULL;
4332 if (first->op_type == OP_CONST) {
4333 if (first->op_private & OPpCONST_STRICT)
4334 no_bareword_allowed(first);
4335 else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
4336 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
4337 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
4338 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
4339 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
4341 if (other->op_type == OP_CONST)
4342 other->op_private |= OPpCONST_SHORTCIRCUIT;
4344 OP *newop = newUNOP(OP_NULL, 0, other);
4345 op_getmad(first, newop, '1');
4346 newop->op_targ = type; /* set "was" field */
4353 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
4354 const OP *o2 = other;
4355 if ( ! (o2->op_type == OP_LIST
4356 && (( o2 = cUNOPx(o2)->op_first))
4357 && o2->op_type == OP_PUSHMARK
4358 && (( o2 = o2->op_sibling)) )
4361 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
4362 || o2->op_type == OP_PADHV)
4363 && o2->op_private & OPpLVAL_INTRO
4364 && !(o2->op_private & OPpPAD_STATE)
4365 && ckWARN(WARN_DEPRECATED))
4367 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4368 "Deprecated use of my() in false conditional");
4372 if (first->op_type == OP_CONST)
4373 first->op_private |= OPpCONST_SHORTCIRCUIT;
4375 first = newUNOP(OP_NULL, 0, first);
4376 op_getmad(other, first, '2');
4377 first->op_targ = type; /* set "was" field */
4384 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
4385 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
4387 const OP * const k1 = ((UNOP*)first)->op_first;
4388 const OP * const k2 = k1->op_sibling;
4390 switch (first->op_type)
4393 if (k2 && k2->op_type == OP_READLINE
4394 && (k2->op_flags & OPf_STACKED)
4395 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4397 warnop = k2->op_type;
4402 if (k1->op_type == OP_READDIR
4403 || k1->op_type == OP_GLOB
4404 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4405 || k1->op_type == OP_EACH)
4407 warnop = ((k1->op_type == OP_NULL)
4408 ? (OPCODE)k1->op_targ : k1->op_type);
4413 const line_t oldline = CopLINE(PL_curcop);
4414 CopLINE_set(PL_curcop, PL_parser->copline);
4415 Perl_warner(aTHX_ packWARN(WARN_MISC),
4416 "Value of %s%s can be \"0\"; test with defined()",
4418 ((warnop == OP_READLINE || warnop == OP_GLOB)
4419 ? " construct" : "() operator"));
4420 CopLINE_set(PL_curcop, oldline);
4427 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
4428 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
4430 NewOp(1101, logop, 1, LOGOP);
4432 logop->op_type = (OPCODE)type;
4433 logop->op_ppaddr = PL_ppaddr[type];
4434 logop->op_first = first;
4435 logop->op_flags = (U8)(flags | OPf_KIDS);
4436 logop->op_other = LINKLIST(other);
4437 logop->op_private = (U8)(1 | (flags >> 8));
4439 /* establish postfix order */
4440 logop->op_next = LINKLIST(first);
4441 first->op_next = (OP*)logop;
4442 first->op_sibling = other;
4444 CHECKOP(type,logop);
4446 o = newUNOP(OP_NULL, 0, (OP*)logop);
4453 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
4461 return newLOGOP(OP_AND, 0, first, trueop);
4463 return newLOGOP(OP_OR, 0, first, falseop);
4465 scalarboolean(first);
4466 if (first->op_type == OP_CONST) {
4467 /* Left or right arm of the conditional? */
4468 const bool left = SvTRUE(((SVOP*)first)->op_sv);
4469 OP *live = left ? trueop : falseop;
4470 OP *const dead = left ? falseop : trueop;
4471 if (first->op_private & OPpCONST_BARE &&
4472 first->op_private & OPpCONST_STRICT) {
4473 no_bareword_allowed(first);
4476 /* This is all dead code when PERL_MAD is not defined. */
4477 live = newUNOP(OP_NULL, 0, live);
4478 op_getmad(first, live, 'C');
4479 op_getmad(dead, live, left ? 'e' : 't');
4486 NewOp(1101, logop, 1, LOGOP);
4487 logop->op_type = OP_COND_EXPR;
4488 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4489 logop->op_first = first;
4490 logop->op_flags = (U8)(flags | OPf_KIDS);
4491 logop->op_private = (U8)(1 | (flags >> 8));
4492 logop->op_other = LINKLIST(trueop);
4493 logop->op_next = LINKLIST(falseop);
4495 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
4498 /* establish postfix order */
4499 start = LINKLIST(first);
4500 first->op_next = (OP*)logop;
4502 first->op_sibling = trueop;
4503 trueop->op_sibling = falseop;
4504 o = newUNOP(OP_NULL, 0, (OP*)logop);
4506 trueop->op_next = falseop->op_next = o;
4513 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4522 NewOp(1101, range, 1, LOGOP);
4524 range->op_type = OP_RANGE;
4525 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4526 range->op_first = left;
4527 range->op_flags = OPf_KIDS;
4528 leftstart = LINKLIST(left);
4529 range->op_other = LINKLIST(right);
4530 range->op_private = (U8)(1 | (flags >> 8));
4532 left->op_sibling = right;
4534 range->op_next = (OP*)range;
4535 flip = newUNOP(OP_FLIP, flags, (OP*)range);
4536 flop = newUNOP(OP_FLOP, 0, flip);
4537 o = newUNOP(OP_NULL, 0, flop);
4539 range->op_next = leftstart;
4541 left->op_next = flip;
4542 right->op_next = flop;
4544 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4545 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4546 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4547 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4549 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4550 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4553 if (!flip->op_private || !flop->op_private)
4554 linklist(o); /* blow off optimizer unless constant */
4560 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4565 const bool once = block && block->op_flags & OPf_SPECIAL &&
4566 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4568 PERL_UNUSED_ARG(debuggable);
4571 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4572 return block; /* do {} while 0 does once */
4573 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4574 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4575 expr = newUNOP(OP_DEFINED, 0,
4576 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4577 } else if (expr->op_flags & OPf_KIDS) {
4578 const OP * const k1 = ((UNOP*)expr)->op_first;
4579 const OP * const k2 = k1 ? k1->op_sibling : NULL;
4580 switch (expr->op_type) {
4582 if (k2 && k2->op_type == OP_READLINE
4583 && (k2->op_flags & OPf_STACKED)
4584 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4585 expr = newUNOP(OP_DEFINED, 0, expr);
4589 if (k1 && (k1->op_type == OP_READDIR
4590 || k1->op_type == OP_GLOB
4591 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4592 || k1->op_type == OP_EACH))
4593 expr = newUNOP(OP_DEFINED, 0, expr);
4599 /* if block is null, the next append_elem() would put UNSTACK, a scalar
4600 * op, in listop. This is wrong. [perl #27024] */
4602 block = newOP(OP_NULL, 0);
4603 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4604 o = new_logop(OP_AND, 0, &expr, &listop);
4607 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4609 if (once && o != listop)
4610 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4613 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
4615 o->op_flags |= flags;
4617 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4622 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
4623 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
4632 PERL_UNUSED_ARG(debuggable);
4635 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4636 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4637 expr = newUNOP(OP_DEFINED, 0,
4638 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4639 } else if (expr->op_flags & OPf_KIDS) {
4640 const OP * const k1 = ((UNOP*)expr)->op_first;
4641 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
4642 switch (expr->op_type) {
4644 if (k2 && k2->op_type == OP_READLINE
4645 && (k2->op_flags & OPf_STACKED)
4646 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4647 expr = newUNOP(OP_DEFINED, 0, expr);
4651 if (k1 && (k1->op_type == OP_READDIR
4652 || k1->op_type == OP_GLOB
4653 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4654 || k1->op_type == OP_EACH))
4655 expr = newUNOP(OP_DEFINED, 0, expr);
4662 block = newOP(OP_NULL, 0);
4663 else if (cont || has_my) {
4664 block = scope(block);
4668 next = LINKLIST(cont);
4671 OP * const unstack = newOP(OP_UNSTACK, 0);
4674 cont = append_elem(OP_LINESEQ, cont, unstack);
4678 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4680 redo = LINKLIST(listop);
4683 PL_parser->copline = (line_t)whileline;
4685 o = new_logop(OP_AND, 0, &expr, &listop);
4686 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4687 op_free(expr); /* oops, it's a while (0) */
4689 return NULL; /* listop already freed by new_logop */
4692 ((LISTOP*)listop)->op_last->op_next =
4693 (o == listop ? redo : LINKLIST(o));
4699 NewOp(1101,loop,1,LOOP);
4700 loop->op_type = OP_ENTERLOOP;
4701 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4702 loop->op_private = 0;
4703 loop->op_next = (OP*)loop;
4706 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4708 loop->op_redoop = redo;
4709 loop->op_lastop = o;
4710 o->op_private |= loopflags;
4713 loop->op_nextop = next;
4715 loop->op_nextop = o;
4717 o->op_flags |= flags;
4718 o->op_private |= (flags >> 8);
4723 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
4728 PADOFFSET padoff = 0;
4734 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4735 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
4736 sv->op_type = OP_RV2GV;
4737 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4739 /* The op_type check is needed to prevent a possible segfault
4740 * if the loop variable is undeclared and 'strict vars' is in
4741 * effect. This is illegal but is nonetheless parsed, so we
4742 * may reach this point with an OP_CONST where we're expecting
4745 if (cUNOPx(sv)->op_first->op_type == OP_GV
4746 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
4747 iterpflags |= OPpITER_DEF;
4749 else if (sv->op_type == OP_PADSV) { /* private variable */
4750 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
4751 padoff = sv->op_targ;
4761 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4763 SV *const namesv = PAD_COMPNAME_SV(padoff);
4765 const char *const name = SvPV_const(namesv, len);
4767 if (len == 2 && name[0] == '$' && name[1] == '_')
4768 iterpflags |= OPpITER_DEF;
4772 const PADOFFSET offset = pad_findmy("$_");
4773 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
4774 sv = newGVOP(OP_GV, 0, PL_defgv);
4779 iterpflags |= OPpITER_DEF;
4781 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4782 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4783 iterflags |= OPf_STACKED;
4785 else if (expr->op_type == OP_NULL &&
4786 (expr->op_flags & OPf_KIDS) &&
4787 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4789 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4790 * set the STACKED flag to indicate that these values are to be
4791 * treated as min/max values by 'pp_iterinit'.
4793 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4794 LOGOP* const range = (LOGOP*) flip->op_first;
4795 OP* const left = range->op_first;
4796 OP* const right = left->op_sibling;
4799 range->op_flags &= ~OPf_KIDS;
4800 range->op_first = NULL;
4802 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4803 listop->op_first->op_next = range->op_next;
4804 left->op_next = range->op_other;
4805 right->op_next = (OP*)listop;
4806 listop->op_next = listop->op_first;
4809 op_getmad(expr,(OP*)listop,'O');
4813 expr = (OP*)(listop);
4815 iterflags |= OPf_STACKED;
4818 expr = mod(force_list(expr), OP_GREPSTART);
4821 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4822 append_elem(OP_LIST, expr, scalar(sv))));
4823 assert(!loop->op_next);
4824 /* for my $x () sets OPpLVAL_INTRO;
4825 * for our $x () sets OPpOUR_INTRO */
4826 loop->op_private = (U8)iterpflags;
4827 #ifdef PL_OP_SLAB_ALLOC
4830 NewOp(1234,tmp,1,LOOP);
4831 Copy(loop,tmp,1,LISTOP);
4832 S_op_destroy(aTHX_ (OP*)loop);
4836 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
4838 loop->op_targ = padoff;
4839 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
4841 op_getmad(madsv, (OP*)loop, 'v');
4842 PL_parser->copline = forline;
4843 return newSTATEOP(0, label, wop);
4847 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4852 if (type != OP_GOTO || label->op_type == OP_CONST) {
4853 /* "last()" means "last" */
4854 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4855 o = newOP(type, OPf_SPECIAL);
4857 o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
4858 ? SvPV_nolen_const(((SVOP*)label)->op_sv)
4862 op_getmad(label,o,'L');
4868 /* Check whether it's going to be a goto &function */
4869 if (label->op_type == OP_ENTERSUB
4870 && !(label->op_flags & OPf_STACKED))
4871 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4872 o = newUNOP(type, OPf_STACKED, label);
4874 PL_hints |= HINT_BLOCK_SCOPE;
4878 /* if the condition is a literal array or hash
4879 (or @{ ... } etc), make a reference to it.
4882 S_ref_array_or_hash(pTHX_ OP *cond)
4885 && (cond->op_type == OP_RV2AV
4886 || cond->op_type == OP_PADAV
4887 || cond->op_type == OP_RV2HV
4888 || cond->op_type == OP_PADHV))
4890 return newUNOP(OP_REFGEN,
4891 0, mod(cond, OP_REFGEN));
4897 /* These construct the optree fragments representing given()
4900 entergiven and enterwhen are LOGOPs; the op_other pointer
4901 points up to the associated leave op. We need this so we
4902 can put it in the context and make break/continue work.
4903 (Also, of course, pp_enterwhen will jump straight to
4904 op_other if the match fails.)
4908 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
4909 I32 enter_opcode, I32 leave_opcode,
4910 PADOFFSET entertarg)
4916 NewOp(1101, enterop, 1, LOGOP);
4917 enterop->op_type = enter_opcode;
4918 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
4919 enterop->op_flags = (U8) OPf_KIDS;
4920 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
4921 enterop->op_private = 0;
4923 o = newUNOP(leave_opcode, 0, (OP *) enterop);
4926 enterop->op_first = scalar(cond);
4927 cond->op_sibling = block;
4929 o->op_next = LINKLIST(cond);
4930 cond->op_next = (OP *) enterop;
4933 /* This is a default {} block */
4934 enterop->op_first = block;
4935 enterop->op_flags |= OPf_SPECIAL;
4937 o->op_next = (OP *) enterop;
4940 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
4941 entergiven and enterwhen both
4944 enterop->op_next = LINKLIST(block);
4945 block->op_next = enterop->op_other = o;
4950 /* Does this look like a boolean operation? For these purposes
4951 a boolean operation is:
4952 - a subroutine call [*]
4953 - a logical connective
4954 - a comparison operator
4955 - a filetest operator, with the exception of -s -M -A -C
4956 - defined(), exists() or eof()
4957 - /$re/ or $foo =~ /$re/
4959 [*] possibly surprising
4962 S_looks_like_bool(pTHX_ const OP *o)
4965 switch(o->op_type) {
4967 return looks_like_bool(cLOGOPo->op_first);
4971 looks_like_bool(cLOGOPo->op_first)
4972 && looks_like_bool(cLOGOPo->op_first->op_sibling));
4976 o->op_flags & OPf_KIDS
4977 && looks_like_bool(cUNOPo->op_first));
4981 case OP_NOT: case OP_XOR:
4982 /* Note that OP_DOR is not here */
4984 case OP_EQ: case OP_NE: case OP_LT:
4985 case OP_GT: case OP_LE: case OP_GE:
4987 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
4988 case OP_I_GT: case OP_I_LE: case OP_I_GE:
4990 case OP_SEQ: case OP_SNE: case OP_SLT:
4991 case OP_SGT: case OP_SLE: case OP_SGE:
4995 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
4996 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
4997 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
4998 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
4999 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
5000 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
5001 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
5002 case OP_FTTEXT: case OP_FTBINARY:
5004 case OP_DEFINED: case OP_EXISTS:
5005 case OP_MATCH: case OP_EOF:
5010 /* Detect comparisons that have been optimized away */
5011 if (cSVOPo->op_sv == &PL_sv_yes
5012 || cSVOPo->op_sv == &PL_sv_no)
5023 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
5027 return newGIVWHENOP(
5028 ref_array_or_hash(cond),
5030 OP_ENTERGIVEN, OP_LEAVEGIVEN,
5034 /* If cond is null, this is a default {} block */
5036 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
5038 const bool cond_llb = (!cond || looks_like_bool(cond));
5044 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
5046 scalar(ref_array_or_hash(cond)));
5049 return newGIVWHENOP(
5051 append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
5052 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
5056 =for apidoc cv_undef
5058 Clear out all the active components of a CV. This can happen either
5059 by an explicit C<undef &foo>, or by the reference count going to zero.
5060 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
5061 children can still follow the full lexical scope chain.
5067 Perl_cv_undef(pTHX_ CV *cv)
5071 DEBUG_X(PerlIO_printf(Perl_debug_log,
5072 "CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n",
5073 PTR2UV(cv), PTR2UV(PL_comppad))
5077 if (CvFILE(cv) && !CvISXSUB(cv)) {
5078 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
5079 Safefree(CvFILE(cv));
5084 if (!CvISXSUB(cv) && CvROOT(cv)) {
5085 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
5086 Perl_croak(aTHX_ "Can't undef active subroutine");
5089 PAD_SAVE_SETNULLPAD();
5091 op_free(CvROOT(cv));
5096 SvPOK_off((SV*)cv); /* forget prototype */
5101 /* remove CvOUTSIDE unless this is an undef rather than a free */
5102 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
5103 if (!CvWEAKOUTSIDE(cv))
5104 SvREFCNT_dec(CvOUTSIDE(cv));
5105 CvOUTSIDE(cv) = NULL;
5108 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
5111 if (CvISXSUB(cv) && CvXSUB(cv)) {
5114 /* delete all flags except WEAKOUTSIDE */
5115 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
5119 Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
5122 /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
5123 relying on SvCUR, and doubling up the buffer to hold CvFILE(). */
5124 if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
5125 || (p && (len != SvCUR(cv) /* Not the same length. */
5126 || memNE(p, SvPVX_const(cv), len))))
5127 && ckWARN_d(WARN_PROTOTYPE)) {
5128 SV* const msg = sv_newmortal();
5132 gv_efullname3(name = sv_newmortal(), gv, NULL);
5133 sv_setpvs(msg, "Prototype mismatch:");
5135 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
5137 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv));
5139 sv_catpvs(msg, ": none");
5140 sv_catpvs(msg, " vs ");
5142 Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
5144 sv_catpvs(msg, "none");
5145 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
5149 static void const_sv_xsub(pTHX_ CV* cv);
5153 =head1 Optree Manipulation Functions
5155 =for apidoc cv_const_sv
5157 If C<cv> is a constant sub eligible for inlining. returns the constant
5158 value returned by the sub. Otherwise, returns NULL.
5160 Constant subs can be created with C<newCONSTSUB> or as described in
5161 L<perlsub/"Constant Functions">.
5166 Perl_cv_const_sv(pTHX_ CV *cv)
5168 PERL_UNUSED_CONTEXT;
5171 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
5173 return CvCONST(cv) ? (SV*)CvXSUBANY(cv).any_ptr : NULL;
5176 /* op_const_sv: examine an optree to determine whether it's in-lineable.
5177 * Can be called in 3 ways:
5180 * look for a single OP_CONST with attached value: return the value
5182 * cv && CvCLONE(cv) && !CvCONST(cv)
5184 * examine the clone prototype, and if contains only a single
5185 * OP_CONST referencing a pad const, or a single PADSV referencing
5186 * an outer lexical, return a non-zero value to indicate the CV is
5187 * a candidate for "constizing" at clone time
5191 * We have just cloned an anon prototype that was marked as a const
5192 * candidiate. Try to grab the current value, and in the case of
5193 * PADSV, ignore it if it has multiple references. Return the value.
5197 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
5208 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
5209 o = cLISTOPo->op_first->op_sibling;
5211 for (; o; o = o->op_next) {
5212 const OPCODE type = o->op_type;
5214 if (sv && o->op_next == o)
5216 if (o->op_next != o) {
5217 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
5219 if (type == OP_DBSTATE)
5222 if (type == OP_LEAVESUB || type == OP_RETURN)
5226 if (type == OP_CONST && cSVOPo->op_sv)
5228 else if (cv && type == OP_CONST) {
5229 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5233 else if (cv && type == OP_PADSV) {
5234 if (CvCONST(cv)) { /* newly cloned anon */
5235 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5236 /* the candidate should have 1 ref from this pad and 1 ref
5237 * from the parent */
5238 if (!sv || SvREFCNT(sv) != 2)
5245 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
5246 sv = &PL_sv_undef; /* an arbitrary non-null value */
5261 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5264 /* This would be the return value, but the return cannot be reached. */
5265 OP* pegop = newOP(OP_NULL, 0);
5268 PERL_UNUSED_ARG(floor);
5278 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
5280 NORETURN_FUNCTION_END;
5285 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
5287 return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
5291 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5298 register CV *cv = NULL;
5300 /* If the subroutine has no body, no attributes, and no builtin attributes
5301 then it's just a sub declaration, and we may be able to get away with
5302 storing with a placeholder scalar in the symbol table, rather than a
5303 full GV and CV. If anything is present then it will take a full CV to
5305 const I32 gv_fetch_flags
5306 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5308 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
5309 const char * const name = o ? SvPV_nolen_const(cSVOPo->op_sv) : NULL;
5312 assert(proto->op_type == OP_CONST);
5313 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
5318 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
5319 SV * const sv = sv_newmortal();
5320 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
5321 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
5322 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
5323 aname = SvPVX_const(sv);
5328 gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
5329 : gv_fetchpv(aname ? aname
5330 : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5331 gv_fetch_flags, SVt_PVCV);
5333 if (!PL_madskills) {
5342 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
5343 maximum a prototype before. */
5344 if (SvTYPE(gv) > SVt_NULL) {
5345 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
5346 && ckWARN_d(WARN_PROTOTYPE))
5348 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
5350 cv_ckproto_len((CV*)gv, NULL, ps, ps_len);
5353 sv_setpvn((SV*)gv, ps, ps_len);
5355 sv_setiv((SV*)gv, -1);
5357 SvREFCNT_dec(PL_compcv);
5358 cv = PL_compcv = NULL;
5362 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
5364 #ifdef GV_UNIQUE_CHECK
5365 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
5366 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
5370 if (!block || !ps || *ps || attrs
5371 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5373 || block->op_type == OP_NULL
5378 const_sv = op_const_sv(block, NULL);
5381 const bool exists = CvROOT(cv) || CvXSUB(cv);
5383 #ifdef GV_UNIQUE_CHECK
5384 if (exists && GvUNIQUE(gv)) {
5385 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
5389 /* if the subroutine doesn't exist and wasn't pre-declared
5390 * with a prototype, assume it will be AUTOLOADed,
5391 * skipping the prototype check
5393 if (exists || SvPOK(cv))
5394 cv_ckproto_len(cv, gv, ps, ps_len);
5395 /* already defined (or promised)? */
5396 if (exists || GvASSUMECV(gv)) {
5399 || block->op_type == OP_NULL
5402 if (CvFLAGS(PL_compcv)) {
5403 /* might have had built-in attrs applied */
5404 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5406 /* just a "sub foo;" when &foo is already defined */
5407 SAVEFREESV(PL_compcv);
5412 && block->op_type != OP_NULL
5415 if (ckWARN(WARN_REDEFINE)
5417 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
5419 const line_t oldline = CopLINE(PL_curcop);
5420 if (PL_parser && PL_parser->copline != NOLINE)
5421 CopLINE_set(PL_curcop, PL_parser->copline);
5422 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5423 CvCONST(cv) ? "Constant subroutine %s redefined"
5424 : "Subroutine %s redefined", name);
5425 CopLINE_set(PL_curcop, oldline);
5428 if (!PL_minus_c) /* keep old one around for madskills */
5431 /* (PL_madskills unset in used file.) */
5439 SvREFCNT_inc_simple_void_NN(const_sv);
5441 assert(!CvROOT(cv) && !CvCONST(cv));
5442 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
5443 CvXSUBANY(cv).any_ptr = const_sv;
5444 CvXSUB(cv) = const_sv_xsub;
5450 cv = newCONSTSUB(NULL, name, const_sv);
5452 mro_method_changed_in( /* sub Foo::Bar () { 123 } */
5453 (CvGV(cv) && GvSTASH(CvGV(cv)))
5462 SvREFCNT_dec(PL_compcv);
5470 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
5471 * before we clobber PL_compcv.
5475 || block->op_type == OP_NULL
5479 /* Might have had built-in attributes applied -- propagate them. */
5480 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5481 if (CvGV(cv) && GvSTASH(CvGV(cv)))
5482 stash = GvSTASH(CvGV(cv));
5483 else if (CvSTASH(cv))
5484 stash = CvSTASH(cv);
5486 stash = PL_curstash;
5489 /* possibly about to re-define existing subr -- ignore old cv */
5490 rcv = (SV*)PL_compcv;
5491 if (name && GvSTASH(gv))
5492 stash = GvSTASH(gv);
5494 stash = PL_curstash;
5496 apply_attrs(stash, rcv, attrs, FALSE);
5498 if (cv) { /* must reuse cv if autoloaded */
5505 || block->op_type == OP_NULL) && !PL_madskills
5508 /* got here with just attrs -- work done, so bug out */
5509 SAVEFREESV(PL_compcv);
5512 /* transfer PL_compcv to cv */
5514 CvFLAGS(cv) = CvFLAGS(PL_compcv);
5515 if (!CvWEAKOUTSIDE(cv))
5516 SvREFCNT_dec(CvOUTSIDE(cv));
5517 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
5518 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
5519 CvOUTSIDE(PL_compcv) = 0;
5520 CvPADLIST(cv) = CvPADLIST(PL_compcv);
5521 CvPADLIST(PL_compcv) = 0;
5522 /* inner references to PL_compcv must be fixed up ... */
5523 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
5524 /* ... before we throw it away */
5525 SvREFCNT_dec(PL_compcv);
5527 if (PERLDB_INTER)/* Advice debugger on the new sub. */
5528 ++PL_sub_generation;
5535 if (strEQ(name, "import")) {
5536 PL_formfeed = (SV*)cv;
5537 Perl_warner(aTHX_ packWARN(WARN_VOID), "%lx\n", (long)cv);
5541 mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */
5545 CvFILE_set_from_cop(cv, PL_curcop);
5546 CvSTASH(cv) = PL_curstash;
5549 sv_setpvn((SV*)cv, ps, ps_len);
5551 if (PL_parser && PL_parser->error_count) {
5555 const char *s = strrchr(name, ':');
5557 if (strEQ(s, "BEGIN")) {
5558 const char not_safe[] =
5559 "BEGIN not safe after errors--compilation aborted";
5560 if (PL_in_eval & EVAL_KEEPERR)
5561 Perl_croak(aTHX_ not_safe);
5563 /* force display of errors found but not reported */
5564 sv_catpv(ERRSV, not_safe);
5565 Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
5575 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5576 mod(scalarseq(block), OP_LEAVESUBLV));
5577 block->op_attached = 1;
5580 /* This makes sub {}; work as expected. */
5581 if (block->op_type == OP_STUB) {
5582 OP* const newblock = newSTATEOP(0, NULL, 0);
5584 op_getmad(block,newblock,'B');
5591 block->op_attached = 1;
5592 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5594 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5595 OpREFCNT_set(CvROOT(cv), 1);
5596 CvSTART(cv) = LINKLIST(CvROOT(cv));
5597 CvROOT(cv)->op_next = 0;
5598 CALL_PEEP(CvSTART(cv));
5600 /* now that optimizer has done its work, adjust pad values */
5602 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
5605 assert(!CvCONST(cv));
5606 if (ps && !*ps && op_const_sv(block, cv))
5610 if (name || aname) {
5611 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5612 SV * const sv = newSV(0);
5613 SV * const tmpstr = sv_newmortal();
5614 GV * const db_postponed = gv_fetchpvs("DB::postponed",
5615 GV_ADDMULTI, SVt_PVHV);
5618 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5620 (long)PL_subline, (long)CopLINE(PL_curcop));
5621 gv_efullname3(tmpstr, gv, NULL);
5622 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
5623 SvCUR(tmpstr), sv, 0);
5624 hv = GvHVn(db_postponed);
5625 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
5626 CV * const pcv = GvCV(db_postponed);
5632 call_sv((SV*)pcv, G_DISCARD);
5637 if (name && ! (PL_parser && PL_parser->error_count))
5638 process_special_blocks(name, gv, cv);
5643 PL_parser->copline = NOLINE;
5649 S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
5652 const char *const colon = strrchr(fullname,':');
5653 const char *const name = colon ? colon + 1 : fullname;
5656 if (strEQ(name, "BEGIN")) {
5657 const I32 oldscope = PL_scopestack_ix;
5659 SAVECOPFILE(&PL_compiling);
5660 SAVECOPLINE(&PL_compiling);
5662 DEBUG_x( dump_sub(gv) );
5663 Perl_av_create_and_push(aTHX_ &PL_beginav, (SV*)cv);
5664 GvCV(gv) = 0; /* cv has been hijacked */
5665 call_list(oldscope, PL_beginav);
5667 PL_curcop = &PL_compiling;
5668 CopHINTS_set(&PL_compiling, PL_hints);
5675 if strEQ(name, "END") {
5676 DEBUG_x( dump_sub(gv) );
5677 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, (SV*)cv);
5680 } else if (*name == 'U') {
5681 if (strEQ(name, "UNITCHECK")) {
5682 /* It's never too late to run a unitcheck block */
5683 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, (SV*)cv);
5687 } else if (*name == 'C') {
5688 if (strEQ(name, "CHECK")) {
5689 if (PL_main_start && ckWARN(WARN_VOID))
5690 Perl_warner(aTHX_ packWARN(WARN_VOID),
5691 "Too late to run CHECK block");
5692 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, (SV*)cv);
5696 } else if (*name == 'I') {
5697 if (strEQ(name, "INIT")) {
5698 if (PL_main_start && ckWARN(WARN_VOID))
5699 Perl_warner(aTHX_ packWARN(WARN_VOID),
5700 "Too late to run INIT block");
5701 Perl_av_create_and_push(aTHX_ &PL_initav, (SV*)cv);
5707 DEBUG_x( dump_sub(gv) );
5708 GvCV(gv) = 0; /* cv has been hijacked */
5713 =for apidoc newCONSTSUB
5715 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5716 eligible for inlining at compile-time.
5722 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
5727 const char *const temp_p = CopFILE(PL_curcop);
5728 const STRLEN len = temp_p ? strlen(temp_p) : 0;
5730 SV *const temp_sv = CopFILESV(PL_curcop);
5732 const char *const temp_p = temp_sv ? SvPV_const(temp_sv, len) : NULL;
5734 char *const file = savepvn(temp_p, temp_p ? len : 0);
5738 if (IN_PERL_RUNTIME) {
5739 /* at runtime, it's not safe to manipulate PL_curcop: it may be
5740 * an op shared between threads. Use a non-shared COP for our
5742 SAVEVPTR(PL_curcop);
5743 PL_curcop = &PL_compiling;
5745 SAVECOPLINE(PL_curcop);
5746 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
5749 PL_hints &= ~HINT_BLOCK_SCOPE;
5752 SAVESPTR(PL_curstash);
5753 SAVECOPSTASH(PL_curcop);
5754 PL_curstash = stash;
5755 CopSTASH_set(PL_curcop,stash);
5758 /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
5759 and so doesn't get free()d. (It's expected to be from the C pre-
5760 processor __FILE__ directive). But we need a dynamically allocated one,
5761 and we need it to get freed. */
5762 cv = newXS_flags(name, const_sv_xsub, file, "", XS_DYNAMIC_FILENAME);
5763 CvXSUBANY(cv).any_ptr = sv;
5769 CopSTASH_free(PL_curcop);
5777 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
5778 const char *const filename, const char *const proto,
5781 CV *cv = newXS(name, subaddr, filename);
5783 if (flags & XS_DYNAMIC_FILENAME) {
5784 /* We need to "make arrangements" (ie cheat) to ensure that the
5785 filename lasts as long as the PVCV we just created, but also doesn't
5787 STRLEN filename_len = strlen(filename);
5788 STRLEN proto_and_file_len = filename_len;
5789 char *proto_and_file;
5793 proto_len = strlen(proto);
5794 proto_and_file_len += proto_len;
5796 Newx(proto_and_file, proto_and_file_len + 1, char);
5797 Copy(proto, proto_and_file, proto_len, char);
5798 Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
5801 proto_and_file = savepvn(filename, filename_len);
5804 /* This gets free()d. :-) */
5805 sv_usepvn_flags((SV*)cv, proto_and_file, proto_and_file_len,
5806 SV_HAS_TRAILING_NUL);
5808 /* This gives us the correct prototype, rather than one with the
5809 file name appended. */
5810 SvCUR_set(cv, proto_len);
5814 CvFILE(cv) = proto_and_file + proto_len;
5816 sv_setpv((SV *)cv, proto);
5822 =for apidoc U||newXS
5824 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
5825 static storage, as it is used directly as CvFILE(), without a copy being made.
5831 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
5834 GV * const gv = gv_fetchpv(name ? name :
5835 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5836 GV_ADDMULTI, SVt_PVCV);
5840 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
5842 if ((cv = (name ? GvCV(gv) : NULL))) {
5844 /* just a cached method */
5848 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5849 /* already defined (or promised) */
5850 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
5851 if (ckWARN(WARN_REDEFINE)) {
5852 GV * const gvcv = CvGV(cv);
5854 HV * const stash = GvSTASH(gvcv);
5856 const char *redefined_name = HvNAME_get(stash);
5857 if ( strEQ(redefined_name,"autouse") ) {
5858 const line_t oldline = CopLINE(PL_curcop);
5859 if (PL_parser && PL_parser->copline != NOLINE)
5860 CopLINE_set(PL_curcop, PL_parser->copline);
5861 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5862 CvCONST(cv) ? "Constant subroutine %s redefined"
5863 : "Subroutine %s redefined"
5865 CopLINE_set(PL_curcop, oldline);
5875 if (cv) /* must reuse cv if autoloaded */
5878 cv = (CV*)newSV_type(SVt_PVCV);
5882 mro_method_changed_in(GvSTASH(gv)); /* newXS */
5886 (void)gv_fetchfile(filename);
5887 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
5888 an external constant string */
5890 CvXSUB(cv) = subaddr;
5893 process_special_blocks(name, gv, cv);
5905 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5910 OP* pegop = newOP(OP_NULL, 0);
5914 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
5915 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
5917 #ifdef GV_UNIQUE_CHECK
5919 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5923 if ((cv = GvFORM(gv))) {
5924 if (ckWARN(WARN_REDEFINE)) {
5925 const line_t oldline = CopLINE(PL_curcop);
5926 if (PL_parser && PL_parser->copline != NOLINE)
5927 CopLINE_set(PL_curcop, PL_parser->copline);
5928 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5929 o ? "Format %"SVf" redefined"
5930 : "Format STDOUT redefined", SVfARG(cSVOPo->op_sv));
5931 CopLINE_set(PL_curcop, oldline);
5938 CvFILE_set_from_cop(cv, PL_curcop);
5941 pad_tidy(padtidy_FORMAT);
5942 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5943 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5944 OpREFCNT_set(CvROOT(cv), 1);
5945 CvSTART(cv) = LINKLIST(CvROOT(cv));
5946 CvROOT(cv)->op_next = 0;
5947 CALL_PEEP(CvSTART(cv));
5949 op_getmad(o,pegop,'n');
5950 op_getmad_weak(block, pegop, 'b');
5955 PL_parser->copline = NOLINE;
5963 Perl_newANONLIST(pTHX_ OP *o)
5965 return convert(OP_ANONLIST, OPf_SPECIAL, o);
5969 Perl_newANONHASH(pTHX_ OP *o)
5971 return convert(OP_ANONHASH, OPf_SPECIAL, o);
5975 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5977 return newANONATTRSUB(floor, proto, NULL, block);
5981 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5983 return newUNOP(OP_REFGEN, 0,
5984 newSVOP(OP_ANONCODE, 0,
5985 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5989 Perl_oopsAV(pTHX_ OP *o)
5992 switch (o->op_type) {
5994 o->op_type = OP_PADAV;
5995 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5996 return ref(o, OP_RV2AV);
5999 o->op_type = OP_RV2AV;
6000 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
6005 if (ckWARN_d(WARN_INTERNAL))
6006 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
6013 Perl_oopsHV(pTHX_ OP *o)
6016 switch (o->op_type) {
6019 o->op_type = OP_PADHV;
6020 o->op_ppaddr = PL_ppaddr[OP_PADHV];
6021 return ref(o, OP_RV2HV);
6025 o->op_type = OP_RV2HV;
6026 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
6031 if (ckWARN_d(WARN_INTERNAL))
6032 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
6039 Perl_newAVREF(pTHX_ OP *o)
6042 if (o->op_type == OP_PADANY) {
6043 o->op_type = OP_PADAV;
6044 o->op_ppaddr = PL_ppaddr[OP_PADAV];
6047 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
6048 && ckWARN(WARN_DEPRECATED)) {
6049 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
6050 "Using an array as a reference is deprecated");
6052 return newUNOP(OP_RV2AV, 0, scalar(o));
6056 Perl_newGVREF(pTHX_ I32 type, OP *o)
6058 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
6059 return newUNOP(OP_NULL, 0, o);
6060 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
6064 Perl_newHVREF(pTHX_ OP *o)
6067 if (o->op_type == OP_PADANY) {
6068 o->op_type = OP_PADHV;
6069 o->op_ppaddr = PL_ppaddr[OP_PADHV];
6072 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
6073 && ckWARN(WARN_DEPRECATED)) {
6074 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
6075 "Using a hash as a reference is deprecated");
6077 return newUNOP(OP_RV2HV, 0, scalar(o));
6081 Perl_newCVREF(pTHX_ I32 flags, OP *o)
6083 return newUNOP(OP_RV2CV, flags, scalar(o));
6087 Perl_newSVREF(pTHX_ OP *o)
6090 if (o->op_type == OP_PADANY) {
6091 o->op_type = OP_PADSV;
6092 o->op_ppaddr = PL_ppaddr[OP_PADSV];
6095 return newUNOP(OP_RV2SV, 0, scalar(o));
6098 /* Check routines. See the comments at the top of this file for details
6099 * on when these are called */
6102 Perl_ck_anoncode(pTHX_ OP *o)
6104 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
6106 cSVOPo->op_sv = NULL;
6111 Perl_ck_bitop(pTHX_ OP *o)
6114 #define OP_IS_NUMCOMPARE(op) \
6115 ((op) == OP_LT || (op) == OP_I_LT || \
6116 (op) == OP_GT || (op) == OP_I_GT || \
6117 (op) == OP_LE || (op) == OP_I_LE || \
6118 (op) == OP_GE || (op) == OP_I_GE || \
6119 (op) == OP_EQ || (op) == OP_I_EQ || \
6120 (op) == OP_NE || (op) == OP_I_NE || \
6121 (op) == OP_NCMP || (op) == OP_I_NCMP)
6122 o->op_private = (U8)(PL_hints & HINT_INTEGER);
6123 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
6124 && (o->op_type == OP_BIT_OR
6125 || o->op_type == OP_BIT_AND
6126 || o->op_type == OP_BIT_XOR))
6128 const OP * const left = cBINOPo->op_first;
6129 const OP * const right = left->op_sibling;
6130 if ((OP_IS_NUMCOMPARE(left->op_type) &&
6131 (left->op_flags & OPf_PARENS) == 0) ||
6132 (OP_IS_NUMCOMPARE(right->op_type) &&
6133 (right->op_flags & OPf_PARENS) == 0))
6134 if (ckWARN(WARN_PRECEDENCE))
6135 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
6136 "Possible precedence problem on bitwise %c operator",
6137 o->op_type == OP_BIT_OR ? '|'
6138 : o->op_type == OP_BIT_AND ? '&' : '^'
6145 Perl_ck_concat(pTHX_ OP *o)
6147 const OP * const kid = cUNOPo->op_first;
6148 PERL_UNUSED_CONTEXT;
6149 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
6150 !(kUNOP->op_first->op_flags & OPf_MOD))
6151 o->op_flags |= OPf_STACKED;
6156 Perl_ck_spair(pTHX_ OP *o)
6159 if (o->op_flags & OPf_KIDS) {
6162 const OPCODE type = o->op_type;
6163 o = modkids(ck_fun(o), type);
6164 kid = cUNOPo->op_first;
6165 newop = kUNOP->op_first->op_sibling;
6167 const OPCODE type = newop->op_type;
6168 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
6169 type == OP_PADAV || type == OP_PADHV ||
6170 type == OP_RV2AV || type == OP_RV2HV)
6174 op_getmad(kUNOP->op_first,newop,'K');
6176 op_free(kUNOP->op_first);
6178 kUNOP->op_first = newop;
6180 o->op_ppaddr = PL_ppaddr[++o->op_type];
6185 Perl_ck_delete(pTHX_ OP *o)
6189 if (o->op_flags & OPf_KIDS) {
6190 OP * const kid = cUNOPo->op_first;
6191 switch (kid->op_type) {
6193 o->op_flags |= OPf_SPECIAL;
6196 o->op_private |= OPpSLICE;
6199 o->op_flags |= OPf_SPECIAL;
6204 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
6213 Perl_ck_die(pTHX_ OP *o)
6216 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6222 Perl_ck_eof(pTHX_ OP *o)
6226 if (o->op_flags & OPf_KIDS) {
6227 if (cLISTOPo->op_first->op_type == OP_STUB) {
6229 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
6231 op_getmad(o,newop,'O');
6243 Perl_ck_eval(pTHX_ OP *o)
6246 PL_hints |= HINT_BLOCK_SCOPE;
6247 if (o->op_flags & OPf_KIDS) {
6248 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6251 o->op_flags &= ~OPf_KIDS;
6254 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
6260 cUNOPo->op_first = 0;
6265 NewOp(1101, enter, 1, LOGOP);
6266 enter->op_type = OP_ENTERTRY;
6267 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
6268 enter->op_private = 0;
6270 /* establish postfix order */
6271 enter->op_next = (OP*)enter;
6273 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
6274 o->op_type = OP_LEAVETRY;
6275 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
6276 enter->op_other = o;
6277 op_getmad(oldo,o,'O');
6291 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
6292 op_getmad(oldo,o,'O');
6294 o->op_targ = (PADOFFSET)PL_hints;
6295 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
6296 /* Store a copy of %^H that pp_entereval can pick up.
6297 OPf_SPECIAL flags the opcode as being for this purpose,
6298 so that it in turn will return a copy at every
6300 OP *hhop = newSVOP(OP_CONST, OPf_SPECIAL,
6301 (SV*)Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv)));
6302 cUNOPo->op_first->op_sibling = hhop;
6303 o->op_private |= OPpEVAL_HAS_HH;
6309 Perl_ck_exit(pTHX_ OP *o)
6312 HV * const table = GvHV(PL_hintgv);
6314 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
6315 if (svp && *svp && SvTRUE(*svp))
6316 o->op_private |= OPpEXIT_VMSISH;
6318 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6324 Perl_ck_exec(pTHX_ OP *o)
6326 if (o->op_flags & OPf_STACKED) {
6329 kid = cUNOPo->op_first->op_sibling;
6330 if (kid->op_type == OP_RV2GV)
6339 Perl_ck_exists(pTHX_ OP *o)
6343 if (o->op_flags & OPf_KIDS) {
6344 OP * const kid = cUNOPo->op_first;
6345 if (kid->op_type == OP_ENTERSUB) {
6346 (void) ref(kid, o->op_type);
6347 if (kid->op_type != OP_RV2CV
6348 && !(PL_parser && PL_parser->error_count))
6349 Perl_croak(aTHX_ "%s argument is not a subroutine name",
6351 o->op_private |= OPpEXISTS_SUB;
6353 else if (kid->op_type == OP_AELEM)
6354 o->op_flags |= OPf_SPECIAL;
6355 else if (kid->op_type != OP_HELEM)
6356 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
6364 Perl_ck_rvconst(pTHX_ register OP *o)
6367 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6369 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6370 if (o->op_type == OP_RV2CV)
6371 o->op_private &= ~1;
6373 if (kid->op_type == OP_CONST) {
6376 SV * const kidsv = kid->op_sv;
6378 /* Is it a constant from cv_const_sv()? */
6379 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
6380 SV * const rsv = SvRV(kidsv);
6381 const svtype type = SvTYPE(rsv);
6382 const char *badtype = NULL;
6384 switch (o->op_type) {
6386 if (type > SVt_PVMG)
6387 badtype = "a SCALAR";
6390 if (type != SVt_PVAV)
6391 badtype = "an ARRAY";
6394 if (type != SVt_PVHV)
6398 if (type != SVt_PVCV)
6403 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
6406 else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
6407 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
6408 /* If this is an access to a stash, disable "strict refs", because
6409 * stashes aren't auto-vivified at compile-time (unless we store
6410 * symbols in them), and we don't want to produce a run-time
6411 * stricture error when auto-vivifying the stash. */
6412 const char *s = SvPV_nolen(kidsv);
6413 const STRLEN l = SvCUR(kidsv);
6414 if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
6415 o->op_private &= ~HINT_STRICT_REFS;
6417 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
6418 const char *badthing;
6419 switch (o->op_type) {
6421 badthing = "a SCALAR";
6424 badthing = "an ARRAY";
6427 badthing = "a HASH";
6435 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
6436 SVfARG(kidsv), badthing);
6439 * This is a little tricky. We only want to add the symbol if we
6440 * didn't add it in the lexer. Otherwise we get duplicate strict
6441 * warnings. But if we didn't add it in the lexer, we must at
6442 * least pretend like we wanted to add it even if it existed before,
6443 * or we get possible typo warnings. OPpCONST_ENTERED says
6444 * whether the lexer already added THIS instance of this symbol.
6446 iscv = (o->op_type == OP_RV2CV) * 2;
6448 gv = gv_fetchsv(kidsv,
6449 iscv | !(kid->op_private & OPpCONST_ENTERED),
6452 : o->op_type == OP_RV2SV
6454 : o->op_type == OP_RV2AV
6456 : o->op_type == OP_RV2HV
6459 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
6461 kid->op_type = OP_GV;
6462 SvREFCNT_dec(kid->op_sv);
6464 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
6465 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
6466 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
6468 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc_simple_NN(gv));
6470 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
6472 kid->op_private = 0;
6473 kid->op_ppaddr = PL_ppaddr[OP_GV];
6480 Perl_ck_ftst(pTHX_ OP *o)
6483 const I32 type = o->op_type;
6485 if (o->op_flags & OPf_REF) {
6488 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
6489 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6490 const OPCODE kidtype = kid->op_type;
6492 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6493 OP * const newop = newGVOP(type, OPf_REF,
6494 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
6496 op_getmad(o,newop,'O');
6502 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o))
6503 o->op_private |= OPpFT_ACCESS;
6504 if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst)
6505 && kidtype != OP_STAT && kidtype != OP_LSTAT)
6506 o->op_private |= OPpFT_STACKED;
6514 if (type == OP_FTTTY)
6515 o = newGVOP(type, OPf_REF, PL_stdingv);
6517 o = newUNOP(type, 0, newDEFSVOP());
6518 op_getmad(oldo,o,'O');
6524 Perl_ck_fun(pTHX_ OP *o)
6527 const int type = o->op_type;
6528 register I32 oa = PL_opargs[type] >> OASHIFT;
6530 if (o->op_flags & OPf_STACKED) {
6531 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
6534 return no_fh_allowed(o);
6537 if (o->op_flags & OPf_KIDS) {
6538 OP **tokid = &cLISTOPo->op_first;
6539 register OP *kid = cLISTOPo->op_first;
6543 if (kid->op_type == OP_PUSHMARK ||
6544 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
6546 tokid = &kid->op_sibling;
6547 kid = kid->op_sibling;
6549 if (!kid && PL_opargs[type] & OA_DEFGV)
6550 *tokid = kid = newDEFSVOP();
6554 sibl = kid->op_sibling;
6556 if (!sibl && kid->op_type == OP_STUB) {
6563 /* list seen where single (scalar) arg expected? */
6564 if (numargs == 1 && !(oa >> 4)
6565 && kid->op_type == OP_LIST && type != OP_SCALAR)
6567 return too_many_arguments(o,PL_op_desc[type]);
6580 if ((type == OP_PUSH || type == OP_UNSHIFT)
6581 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
6582 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6583 "Useless use of %s with no values",
6586 if (kid->op_type == OP_CONST &&
6587 (kid->op_private & OPpCONST_BARE))
6589 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
6590 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
6591 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6592 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6593 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
6594 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6596 op_getmad(kid,newop,'K');
6601 kid->op_sibling = sibl;
6604 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
6605 bad_type(numargs, "array", PL_op_desc[type], kid);
6609 if (kid->op_type == OP_CONST &&
6610 (kid->op_private & OPpCONST_BARE))
6612 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
6613 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
6614 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6615 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6616 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
6617 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6619 op_getmad(kid,newop,'K');
6624 kid->op_sibling = sibl;
6627 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
6628 bad_type(numargs, "hash", PL_op_desc[type], kid);
6633 OP * const newop = newUNOP(OP_NULL, 0, kid);
6634 kid->op_sibling = 0;
6636 newop->op_next = newop;
6638 kid->op_sibling = sibl;
6643 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
6644 if (kid->op_type == OP_CONST &&
6645 (kid->op_private & OPpCONST_BARE))
6647 OP * const newop = newGVOP(OP_GV, 0,
6648 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
6649 if (!(o->op_private & 1) && /* if not unop */
6650 kid == cLISTOPo->op_last)
6651 cLISTOPo->op_last = newop;
6653 op_getmad(kid,newop,'K');
6659 else if (kid->op_type == OP_READLINE) {
6660 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
6661 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
6664 I32 flags = OPf_SPECIAL;
6668 /* is this op a FH constructor? */
6669 if (is_handle_constructor(o,numargs)) {
6670 const char *name = NULL;
6674 /* Set a flag to tell rv2gv to vivify
6675 * need to "prove" flag does not mean something
6676 * else already - NI-S 1999/05/07
6679 if (kid->op_type == OP_PADSV) {
6681 = PAD_COMPNAME_SV(kid->op_targ);
6682 name = SvPV_const(namesv, len);
6684 else if (kid->op_type == OP_RV2SV
6685 && kUNOP->op_first->op_type == OP_GV)
6687 GV * const gv = cGVOPx_gv(kUNOP->op_first);
6689 len = GvNAMELEN(gv);
6691 else if (kid->op_type == OP_AELEM
6692 || kid->op_type == OP_HELEM)
6695 OP *op = ((BINOP*)kid)->op_first;
6699 const char * const a =
6700 kid->op_type == OP_AELEM ?
6702 if (((op->op_type == OP_RV2AV) ||
6703 (op->op_type == OP_RV2HV)) &&
6704 (firstop = ((UNOP*)op)->op_first) &&
6705 (firstop->op_type == OP_GV)) {
6706 /* packagevar $a[] or $h{} */
6707 GV * const gv = cGVOPx_gv(firstop);
6715 else if (op->op_type == OP_PADAV
6716 || op->op_type == OP_PADHV) {
6717 /* lexicalvar $a[] or $h{} */
6718 const char * const padname =
6719 PAD_COMPNAME_PV(op->op_targ);
6728 name = SvPV_const(tmpstr, len);
6733 name = "__ANONIO__";
6740 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
6741 namesv = PAD_SVl(targ);
6742 SvUPGRADE(namesv, SVt_PV);
6744 sv_setpvn(namesv, "$", 1);
6745 sv_catpvn(namesv, name, len);
6748 kid->op_sibling = 0;
6749 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
6750 kid->op_targ = targ;
6751 kid->op_private |= priv;
6753 kid->op_sibling = sibl;
6759 mod(scalar(kid), type);
6763 tokid = &kid->op_sibling;
6764 kid = kid->op_sibling;
6767 if (kid && kid->op_type != OP_STUB)
6768 return too_many_arguments(o,OP_DESC(o));
6769 o->op_private |= numargs;
6771 /* FIXME - should the numargs move as for the PERL_MAD case? */
6772 o->op_private |= numargs;
6774 return too_many_arguments(o,OP_DESC(o));
6778 else if (PL_opargs[type] & OA_DEFGV) {
6780 OP *newop = newUNOP(type, 0, newDEFSVOP());
6781 op_getmad(o,newop,'O');
6784 /* Ordering of these two is important to keep f_map.t passing. */
6786 return newUNOP(type, 0, newDEFSVOP());
6791 while (oa & OA_OPTIONAL)
6793 if (oa && oa != OA_LIST)
6794 return too_few_arguments(o,OP_DESC(o));
6800 Perl_ck_glob(pTHX_ OP *o)
6806 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
6807 append_elem(OP_GLOB, o, newDEFSVOP());
6809 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
6810 && GvCVu(gv) && GvIMPORTED_CV(gv)))
6812 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6815 #if !defined(PERL_EXTERNAL_GLOB)
6816 /* XXX this can be tightened up and made more failsafe. */
6817 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
6820 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
6821 newSVpvs("File::Glob"), NULL, NULL, NULL);
6822 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6823 glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
6824 GvCV(gv) = GvCV(glob_gv);
6825 SvREFCNT_inc_void((SV*)GvCV(gv));
6826 GvIMPORTED_CV_on(gv);
6829 #endif /* PERL_EXTERNAL_GLOB */
6831 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6832 append_elem(OP_GLOB, o,
6833 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
6834 o->op_type = OP_LIST;
6835 o->op_ppaddr = PL_ppaddr[OP_LIST];
6836 cLISTOPo->op_first->op_type = OP_PUSHMARK;
6837 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
6838 cLISTOPo->op_first->op_targ = 0;
6839 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
6840 append_elem(OP_LIST, o,
6841 scalar(newUNOP(OP_RV2CV, 0,
6842 newGVOP(OP_GV, 0, gv)))));
6843 o = newUNOP(OP_NULL, 0, ck_subr(o));
6844 o->op_targ = OP_GLOB; /* hint at what it used to be */
6847 gv = newGVgen("main");
6849 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
6855 Perl_ck_grep(pTHX_ OP *o)
6860 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
6863 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
6864 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
6866 if (o->op_flags & OPf_STACKED) {
6869 kid = cLISTOPo->op_first->op_sibling;
6870 if (!cUNOPx(kid)->op_next)
6871 Perl_croak(aTHX_ "panic: ck_grep");
6872 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
6875 NewOp(1101, gwop, 1, LOGOP);
6876 kid->op_next = (OP*)gwop;
6877 o->op_flags &= ~OPf_STACKED;
6879 kid = cLISTOPo->op_first->op_sibling;
6880 if (type == OP_MAPWHILE)
6885 if (PL_parser && PL_parser->error_count)
6887 kid = cLISTOPo->op_first->op_sibling;
6888 if (kid->op_type != OP_NULL)
6889 Perl_croak(aTHX_ "panic: ck_grep");
6890 kid = kUNOP->op_first;
6893 NewOp(1101, gwop, 1, LOGOP);
6894 gwop->op_type = type;
6895 gwop->op_ppaddr = PL_ppaddr[type];
6896 gwop->op_first = listkids(o);
6897 gwop->op_flags |= OPf_KIDS;
6898 gwop->op_other = LINKLIST(kid);
6899 kid->op_next = (OP*)gwop;
6900 offset = pad_findmy("$_");
6901 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
6902 o->op_private = gwop->op_private = 0;
6903 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
6906 o->op_private = gwop->op_private = OPpGREP_LEX;
6907 gwop->op_targ = o->op_targ = offset;
6910 kid = cLISTOPo->op_first->op_sibling;
6911 if (!kid || !kid->op_sibling)
6912 return too_few_arguments(o,OP_DESC(o));
6913 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
6914 mod(kid, OP_GREPSTART);
6920 Perl_ck_index(pTHX_ OP *o)
6922 if (o->op_flags & OPf_KIDS) {
6923 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6925 kid = kid->op_sibling; /* get past "big" */
6926 if (kid && kid->op_type == OP_CONST)
6927 fbm_compile(((SVOP*)kid)->op_sv, 0);
6933 Perl_ck_lengthconst(pTHX_ OP *o)
6935 /* XXX length optimization goes here */
6940 Perl_ck_lfun(pTHX_ OP *o)
6942 const OPCODE type = o->op_type;
6943 return modkids(ck_fun(o), type);
6947 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
6949 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
6950 switch (cUNOPo->op_first->op_type) {
6952 /* This is needed for
6953 if (defined %stash::)
6954 to work. Do not break Tk.
6956 break; /* Globals via GV can be undef */
6958 case OP_AASSIGN: /* Is this a good idea? */
6959 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6960 "defined(@array) is deprecated");
6961 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6962 "\t(Maybe you should just omit the defined()?)\n");
6965 /* This is needed for
6966 if (defined %stash::)
6967 to work. Do not break Tk.
6969 break; /* Globals via GV can be undef */
6971 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6972 "defined(%%hash) is deprecated");
6973 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6974 "\t(Maybe you should just omit the defined()?)\n");
6985 Perl_ck_readline(pTHX_ OP *o)
6987 if (!(o->op_flags & OPf_KIDS)) {
6989 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
6991 op_getmad(o,newop,'O');
7001 Perl_ck_rfun(pTHX_ OP *o)
7003 const OPCODE type = o->op_type;
7004 return refkids(ck_fun(o), type);
7008 Perl_ck_listiob(pTHX_ OP *o)
7012 kid = cLISTOPo->op_first;
7015 kid = cLISTOPo->op_first;
7017 if (kid->op_type == OP_PUSHMARK)
7018 kid = kid->op_sibling;
7019 if (kid && o->op_flags & OPf_STACKED)
7020 kid = kid->op_sibling;
7021 else if (kid && !kid->op_sibling) { /* print HANDLE; */
7022 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
7023 o->op_flags |= OPf_STACKED; /* make it a filehandle */
7024 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
7025 cLISTOPo->op_first->op_sibling = kid;
7026 cLISTOPo->op_last = kid;
7027 kid = kid->op_sibling;
7032 append_elem(o->op_type, o, newDEFSVOP());
7038 Perl_ck_smartmatch(pTHX_ OP *o)
7041 if (0 == (o->op_flags & OPf_SPECIAL)) {
7042 OP *first = cBINOPo->op_first;
7043 OP *second = first->op_sibling;
7045 /* Implicitly take a reference to an array or hash */
7046 first->op_sibling = NULL;
7047 first = cBINOPo->op_first = ref_array_or_hash(first);
7048 second = first->op_sibling = ref_array_or_hash(second);
7050 /* Implicitly take a reference to a regular expression */
7051 if (first->op_type == OP_MATCH) {
7052 first->op_type = OP_QR;
7053 first->op_ppaddr = PL_ppaddr[OP_QR];
7055 if (second->op_type == OP_MATCH) {
7056 second->op_type = OP_QR;
7057 second->op_ppaddr = PL_ppaddr[OP_QR];
7066 Perl_ck_sassign(pTHX_ OP *o)
7069 OP * const kid = cLISTOPo->op_first;
7070 /* has a disposable target? */
7071 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
7072 && !(kid->op_flags & OPf_STACKED)
7073 /* Cannot steal the second time! */
7074 && !(kid->op_private & OPpTARGET_MY)
7075 /* Keep the full thing for madskills */
7079 OP * const kkid = kid->op_sibling;
7081 /* Can just relocate the target. */
7082 if (kkid && kkid->op_type == OP_PADSV
7083 && !(kkid->op_private & OPpLVAL_INTRO))
7085 kid->op_targ = kkid->op_targ;
7087 /* Now we do not need PADSV and SASSIGN. */
7088 kid->op_sibling = o->op_sibling; /* NULL */
7089 cLISTOPo->op_first = NULL;
7092 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
7096 if (kid->op_sibling) {
7097 OP *kkid = kid->op_sibling;
7098 if (kkid->op_type == OP_PADSV
7099 && (kkid->op_private & OPpLVAL_INTRO)
7100 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
7101 const PADOFFSET target = kkid->op_targ;
7102 OP *const other = newOP(OP_PADSV,
7104 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
7105 OP *const first = newOP(OP_NULL, 0);
7106 OP *const nullop = newCONDOP(0, first, o, other);
7107 OP *const condop = first->op_next;
7108 /* hijacking PADSTALE for uninitialized state variables */
7109 SvPADSTALE_on(PAD_SVl(target));
7111 condop->op_type = OP_ONCE;
7112 condop->op_ppaddr = PL_ppaddr[OP_ONCE];
7113 condop->op_targ = target;
7114 other->op_targ = target;
7116 /* Because we change the type of the op here, we will skip the
7117 assinment binop->op_last = binop->op_first->op_sibling; at the
7118 end of Perl_newBINOP(). So need to do it here. */
7119 cBINOPo->op_last = cBINOPo->op_first->op_sibling;
7128 Perl_ck_match(pTHX_ OP *o)
7131 if (o->op_type != OP_QR && PL_compcv) {
7132 const PADOFFSET offset = pad_findmy("$_");
7133 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
7134 o->op_targ = offset;
7135 o->op_private |= OPpTARGET_MY;
7138 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
7139 o->op_private |= OPpRUNTIME;
7144 Perl_ck_method(pTHX_ OP *o)
7146 OP * const kid = cUNOPo->op_first;
7147 if (kid->op_type == OP_CONST) {
7148 SV* sv = kSVOP->op_sv;
7149 const char * const method = SvPVX_const(sv);
7150 if (!(strchr(method, ':') || strchr(method, '\''))) {
7152 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
7153 sv = newSVpvn_share(method, SvCUR(sv), 0);
7156 kSVOP->op_sv = NULL;
7158 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
7160 op_getmad(o,cmop,'O');
7171 Perl_ck_null(pTHX_ OP *o)
7173 PERL_UNUSED_CONTEXT;
7178 Perl_ck_open(pTHX_ OP *o)
7181 HV * const table = GvHV(PL_hintgv);
7183 SV **svp = hv_fetchs(table, "open_IN", FALSE);
7185 const I32 mode = mode_from_discipline(*svp);
7186 if (mode & O_BINARY)
7187 o->op_private |= OPpOPEN_IN_RAW;
7188 else if (mode & O_TEXT)
7189 o->op_private |= OPpOPEN_IN_CRLF;
7192 svp = hv_fetchs(table, "open_OUT", FALSE);
7194 const I32 mode = mode_from_discipline(*svp);
7195 if (mode & O_BINARY)
7196 o->op_private |= OPpOPEN_OUT_RAW;
7197 else if (mode & O_TEXT)
7198 o->op_private |= OPpOPEN_OUT_CRLF;
7201 if (o->op_type == OP_BACKTICK) {
7202 if (!(o->op_flags & OPf_KIDS)) {
7203 OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
7205 op_getmad(o,newop,'O');
7214 /* In case of three-arg dup open remove strictness
7215 * from the last arg if it is a bareword. */
7216 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
7217 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
7221 if ((last->op_type == OP_CONST) && /* The bareword. */
7222 (last->op_private & OPpCONST_BARE) &&
7223 (last->op_private & OPpCONST_STRICT) &&
7224 (oa = first->op_sibling) && /* The fh. */
7225 (oa = oa->op_sibling) && /* The mode. */
7226 (oa->op_type == OP_CONST) &&
7227 SvPOK(((SVOP*)oa)->op_sv) &&
7228 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
7229 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
7230 (last == oa->op_sibling)) /* The bareword. */
7231 last->op_private &= ~OPpCONST_STRICT;
7237 Perl_ck_repeat(pTHX_ OP *o)
7239 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
7240 o->op_private |= OPpREPEAT_DOLIST;
7241 cBINOPo->op_first = force_list(cBINOPo->op_first);
7249 Perl_ck_require(pTHX_ OP *o)
7254 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
7255 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7257 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
7258 SV * const sv = kid->op_sv;
7259 U32 was_readonly = SvREADONLY(sv);
7266 sv_force_normal_flags(sv, 0);
7267 assert(!SvREADONLY(sv));
7277 for (; s < end; s++) {
7278 if (*s == ':' && s[1] == ':') {
7280 Move(s+2, s+1, end - s - 1, char);
7285 sv_catpvs(sv, ".pm");
7286 SvFLAGS(sv) |= was_readonly;
7290 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
7291 /* handle override, if any */
7292 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
7293 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7294 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
7295 gv = gvp ? *gvp : NULL;
7299 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7300 OP * const kid = cUNOPo->op_first;
7303 cUNOPo->op_first = 0;
7307 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
7308 append_elem(OP_LIST, kid,
7309 scalar(newUNOP(OP_RV2CV, 0,
7312 op_getmad(o,newop,'O');
7320 Perl_ck_return(pTHX_ OP *o)
7323 if (CvLVALUE(PL_compcv)) {
7325 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
7326 mod(kid, OP_LEAVESUBLV);
7332 Perl_ck_select(pTHX_ OP *o)
7336 if (o->op_flags & OPf_KIDS) {
7337 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7338 if (kid && kid->op_sibling) {
7339 o->op_type = OP_SSELECT;
7340 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
7342 return fold_constants(o);
7346 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7347 if (kid && kid->op_type == OP_RV2GV)
7348 kid->op_private &= ~HINT_STRICT_REFS;
7353 Perl_ck_shift(pTHX_ OP *o)
7356 const I32 type = o->op_type;
7358 if (!(o->op_flags & OPf_KIDS)) {
7360 /* FIXME - this can be refactored to reduce code in #ifdefs */
7362 OP * const oldo = o;
7366 argop = newUNOP(OP_RV2AV, 0,
7367 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
7369 o = newUNOP(type, 0, scalar(argop));
7370 op_getmad(oldo,o,'O');
7373 return newUNOP(type, 0, scalar(argop));
7376 return scalar(modkids(ck_fun(o), type));
7380 Perl_ck_sort(pTHX_ OP *o)
7385 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
7386 HV * const hinthv = GvHV(PL_hintgv);
7388 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
7390 const I32 sorthints = (I32)SvIV(*svp);
7391 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
7392 o->op_private |= OPpSORT_QSORT;
7393 if ((sorthints & HINT_SORT_STABLE) != 0)
7394 o->op_private |= OPpSORT_STABLE;
7399 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
7401 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7402 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
7404 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
7406 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
7408 if (kid->op_type == OP_SCOPE) {
7412 else if (kid->op_type == OP_LEAVE) {
7413 if (o->op_type == OP_SORT) {
7414 op_null(kid); /* wipe out leave */
7417 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
7418 if (k->op_next == kid)
7420 /* don't descend into loops */
7421 else if (k->op_type == OP_ENTERLOOP
7422 || k->op_type == OP_ENTERITER)
7424 k = cLOOPx(k)->op_lastop;
7429 kid->op_next = 0; /* just disconnect the leave */
7430 k = kLISTOP->op_first;
7435 if (o->op_type == OP_SORT) {
7436 /* provide scalar context for comparison function/block */
7442 o->op_flags |= OPf_SPECIAL;
7444 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
7447 firstkid = firstkid->op_sibling;
7450 /* provide list context for arguments */
7451 if (o->op_type == OP_SORT)
7458 S_simplify_sort(pTHX_ OP *o)
7461 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7466 if (!(o->op_flags & OPf_STACKED))
7468 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7469 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
7470 kid = kUNOP->op_first; /* get past null */
7471 if (kid->op_type != OP_SCOPE)
7473 kid = kLISTOP->op_last; /* get past scope */
7474 switch(kid->op_type) {
7482 k = kid; /* remember this node*/
7483 if (kBINOP->op_first->op_type != OP_RV2SV)
7485 kid = kBINOP->op_first; /* get past cmp */
7486 if (kUNOP->op_first->op_type != OP_GV)
7488 kid = kUNOP->op_first; /* get past rv2sv */
7490 if (GvSTASH(gv) != PL_curstash)
7492 gvname = GvNAME(gv);
7493 if (*gvname == 'a' && gvname[1] == '\0')
7495 else if (*gvname == 'b' && gvname[1] == '\0')
7500 kid = k; /* back to cmp */
7501 if (kBINOP->op_last->op_type != OP_RV2SV)
7503 kid = kBINOP->op_last; /* down to 2nd arg */
7504 if (kUNOP->op_first->op_type != OP_GV)
7506 kid = kUNOP->op_first; /* get past rv2sv */
7508 if (GvSTASH(gv) != PL_curstash)
7510 gvname = GvNAME(gv);
7512 ? !(*gvname == 'a' && gvname[1] == '\0')
7513 : !(*gvname == 'b' && gvname[1] == '\0'))
7515 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
7517 o->op_private |= OPpSORT_DESCEND;
7518 if (k->op_type == OP_NCMP)
7519 o->op_private |= OPpSORT_NUMERIC;
7520 if (k->op_type == OP_I_NCMP)
7521 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
7522 kid = cLISTOPo->op_first->op_sibling;
7523 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
7525 op_getmad(kid,o,'S'); /* then delete it */
7527 op_free(kid); /* then delete it */
7532 Perl_ck_split(pTHX_ OP *o)
7537 if (o->op_flags & OPf_STACKED)
7538 return no_fh_allowed(o);
7540 kid = cLISTOPo->op_first;
7541 if (kid->op_type != OP_NULL)
7542 Perl_croak(aTHX_ "panic: ck_split");
7543 kid = kid->op_sibling;
7544 op_free(cLISTOPo->op_first);
7545 cLISTOPo->op_first = kid;
7547 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
7548 cLISTOPo->op_last = kid; /* There was only one element previously */
7551 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
7552 OP * const sibl = kid->op_sibling;
7553 kid->op_sibling = 0;
7554 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
7555 if (cLISTOPo->op_first == cLISTOPo->op_last)
7556 cLISTOPo->op_last = kid;
7557 cLISTOPo->op_first = kid;
7558 kid->op_sibling = sibl;
7561 kid->op_type = OP_PUSHRE;
7562 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
7564 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
7565 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
7566 "Use of /g modifier is meaningless in split");
7569 if (!kid->op_sibling)
7570 append_elem(OP_SPLIT, o, newDEFSVOP());
7572 kid = kid->op_sibling;
7575 if (!kid->op_sibling)
7576 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
7577 assert(kid->op_sibling);
7579 kid = kid->op_sibling;
7582 if (kid->op_sibling)
7583 return too_many_arguments(o,OP_DESC(o));
7589 Perl_ck_join(pTHX_ OP *o)
7591 const OP * const kid = cLISTOPo->op_first->op_sibling;
7592 if (kid && kid->op_type == OP_MATCH) {
7593 if (ckWARN(WARN_SYNTAX)) {
7594 const REGEXP *re = PM_GETRE(kPMOP);
7595 const char *pmstr = re ? RX_PRECOMP(re) : "STRING";
7596 const STRLEN len = re ? RX_PRELEN(re) : 6;
7597 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7598 "/%.*s/ should probably be written as \"%.*s\"",
7599 (int)len, pmstr, (int)len, pmstr);
7606 Perl_ck_subr(pTHX_ OP *o)
7609 OP *prev = ((cUNOPo->op_first->op_sibling)
7610 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
7611 OP *o2 = prev->op_sibling;
7613 const char *proto = NULL;
7614 const char *proto_end = NULL;
7619 I32 contextclass = 0;
7620 const char *e = NULL;
7623 o->op_private |= OPpENTERSUB_HASTARG;
7624 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
7625 if (cvop->op_type == OP_RV2CV) {
7627 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
7628 op_null(cvop); /* disable rv2cv */
7629 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
7630 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
7631 GV *gv = cGVOPx_gv(tmpop);
7634 tmpop->op_private |= OPpEARLY_CV;
7638 namegv = CvANON(cv) ? gv : CvGV(cv);
7639 proto = SvPV((SV*)cv, len);
7640 proto_end = proto + len;
7645 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7646 if (o2->op_type == OP_CONST)
7647 o2->op_private &= ~OPpCONST_STRICT;
7648 else if (o2->op_type == OP_LIST) {
7649 OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
7650 if (sib && sib->op_type == OP_CONST)
7651 sib->op_private &= ~OPpCONST_STRICT;
7654 o->op_private |= (PL_hints & HINT_STRICT_REFS);
7655 if (PERLDB_SUB && PL_curstash != PL_debstash)
7656 o->op_private |= OPpENTERSUB_DB;
7657 while (o2 != cvop) {
7659 if (PL_madskills && o2->op_type == OP_STUB) {
7660 o2 = o2->op_sibling;
7663 if (PL_madskills && o2->op_type == OP_NULL)
7664 o3 = ((UNOP*)o2)->op_first;
7668 if (proto >= proto_end)
7669 return too_many_arguments(o, gv_ename(namegv));
7677 /* _ must be at the end */
7678 if (proto[1] && proto[1] != ';')
7693 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
7695 arg == 1 ? "block or sub {}" : "sub {}",
7696 gv_ename(namegv), o3);
7699 /* '*' allows any scalar type, including bareword */
7702 if (o3->op_type == OP_RV2GV)
7703 goto wrapref; /* autoconvert GLOB -> GLOBref */
7704 else if (o3->op_type == OP_CONST)
7705 o3->op_private &= ~OPpCONST_STRICT;
7706 else if (o3->op_type == OP_ENTERSUB) {
7707 /* accidental subroutine, revert to bareword */
7708 OP *gvop = ((UNOP*)o3)->op_first;
7709 if (gvop && gvop->op_type == OP_NULL) {
7710 gvop = ((UNOP*)gvop)->op_first;
7712 for (; gvop->op_sibling; gvop = gvop->op_sibling)
7715 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
7716 (gvop = ((UNOP*)gvop)->op_first) &&
7717 gvop->op_type == OP_GV)
7719 GV * const gv = cGVOPx_gv(gvop);
7720 OP * const sibling = o2->op_sibling;
7721 SV * const n = newSVpvs("");
7723 OP * const oldo2 = o2;
7727 gv_fullname4(n, gv, "", FALSE);
7728 o2 = newSVOP(OP_CONST, 0, n);
7729 op_getmad(oldo2,o2,'O');
7730 prev->op_sibling = o2;
7731 o2->op_sibling = sibling;
7747 if (contextclass++ == 0) {
7748 e = strchr(proto, ']');
7749 if (!e || e == proto)
7758 const char *p = proto;
7759 const char *const end = proto;
7761 while (*--p != '[');
7762 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
7764 gv_ename(namegv), o3);
7769 if (o3->op_type == OP_RV2GV)
7772 bad_type(arg, "symbol", gv_ename(namegv), o3);
7775 if (o3->op_type == OP_ENTERSUB)
7778 bad_type(arg, "subroutine entry", gv_ename(namegv),
7782 if (o3->op_type == OP_RV2SV ||
7783 o3->op_type == OP_PADSV ||
7784 o3->op_type == OP_HELEM ||
7785 o3->op_type == OP_AELEM)
7788 bad_type(arg, "scalar", gv_ename(namegv), o3);
7791 if (o3->op_type == OP_RV2AV ||
7792 o3->op_type == OP_PADAV)
7795 bad_type(arg, "array", gv_ename(namegv), o3);
7798 if (o3->op_type == OP_RV2HV ||
7799 o3->op_type == OP_PADHV)
7802 bad_type(arg, "hash", gv_ename(namegv), o3);
7807 OP* const sib = kid->op_sibling;
7808 kid->op_sibling = 0;
7809 o2 = newUNOP(OP_REFGEN, 0, kid);
7810 o2->op_sibling = sib;
7811 prev->op_sibling = o2;
7813 if (contextclass && e) {
7828 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
7829 gv_ename(namegv), SVfARG(cv));
7834 mod(o2, OP_ENTERSUB);
7836 o2 = o2->op_sibling;
7838 if (o2 == cvop && proto && *proto == '_') {
7839 /* generate an access to $_ */
7841 o2->op_sibling = prev->op_sibling;
7842 prev->op_sibling = o2; /* instead of cvop */
7844 if (proto && !optional && proto_end > proto &&
7845 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
7846 return too_few_arguments(o, gv_ename(namegv));
7849 OP * const oldo = o;
7853 o=newSVOP(OP_CONST, 0, newSViv(0));
7854 op_getmad(oldo,o,'O');
7860 Perl_ck_svconst(pTHX_ OP *o)
7862 PERL_UNUSED_CONTEXT;
7863 SvREADONLY_on(cSVOPo->op_sv);
7868 Perl_ck_chdir(pTHX_ OP *o)
7870 if (o->op_flags & OPf_KIDS) {
7871 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7873 if (kid && kid->op_type == OP_CONST &&
7874 (kid->op_private & OPpCONST_BARE))
7876 o->op_flags |= OPf_SPECIAL;
7877 kid->op_private &= ~OPpCONST_STRICT;
7884 Perl_ck_trunc(pTHX_ OP *o)
7886 if (o->op_flags & OPf_KIDS) {
7887 SVOP *kid = (SVOP*)cUNOPo->op_first;
7889 if (kid->op_type == OP_NULL)
7890 kid = (SVOP*)kid->op_sibling;
7891 if (kid && kid->op_type == OP_CONST &&
7892 (kid->op_private & OPpCONST_BARE))
7894 o->op_flags |= OPf_SPECIAL;
7895 kid->op_private &= ~OPpCONST_STRICT;
7902 Perl_ck_unpack(pTHX_ OP *o)
7904 OP *kid = cLISTOPo->op_first;
7905 if (kid->op_sibling) {
7906 kid = kid->op_sibling;
7907 if (!kid->op_sibling)
7908 kid->op_sibling = newDEFSVOP();
7914 Perl_ck_substr(pTHX_ OP *o)
7917 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
7918 OP *kid = cLISTOPo->op_first;
7920 if (kid->op_type == OP_NULL)
7921 kid = kid->op_sibling;
7923 kid->op_flags |= OPf_MOD;
7930 Perl_ck_each(pTHX_ OP *o)
7933 OP *kid = cLISTOPo->op_first;
7935 if (kid->op_type == OP_PADAV || kid->op_type == OP_RV2AV) {
7936 const unsigned new_type = o->op_type == OP_EACH ? OP_AEACH
7937 : o->op_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
7938 o->op_type = new_type;
7939 o->op_ppaddr = PL_ppaddr[new_type];
7941 else if (!(kid->op_type == OP_PADHV || kid->op_type == OP_RV2HV
7942 || (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE)
7944 bad_type(1, "hash or array", PL_op_desc[o->op_type], kid);
7950 /* A peephole optimizer. We visit the ops in the order they're to execute.
7951 * See the comments at the top of this file for more details about when
7952 * peep() is called */
7955 Perl_peep(pTHX_ register OP *o)
7958 register OP* oldop = NULL;
7960 if (!o || o->op_opt)
7964 SAVEVPTR(PL_curcop);
7965 for (; o; o = o->op_next) {
7968 /* By default, this op has now been optimised. A couple of cases below
7969 clear this again. */
7972 switch (o->op_type) {
7975 PL_curcop = ((COP*)o); /* for warnings */
7979 if (cSVOPo->op_private & OPpCONST_STRICT)
7980 no_bareword_allowed(o);
7982 case OP_METHOD_NAMED:
7983 /* Relocate sv to the pad for thread safety.
7984 * Despite being a "constant", the SV is written to,
7985 * for reference counts, sv_upgrade() etc. */
7987 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
7988 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
7989 /* If op_sv is already a PADTMP then it is being used by
7990 * some pad, so make a copy. */
7991 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
7992 SvREADONLY_on(PAD_SVl(ix));
7993 SvREFCNT_dec(cSVOPo->op_sv);
7995 else if (o->op_type == OP_CONST
7996 && cSVOPo->op_sv == &PL_sv_undef) {
7997 /* PL_sv_undef is hack - it's unsafe to store it in the
7998 AV that is the pad, because av_fetch treats values of
7999 PL_sv_undef as a "free" AV entry and will merrily
8000 replace them with a new SV, causing pad_alloc to think
8001 that this pad slot is free. (When, clearly, it is not)
8003 SvOK_off(PAD_SVl(ix));
8004 SvPADTMP_on(PAD_SVl(ix));
8005 SvREADONLY_on(PAD_SVl(ix));
8008 SvREFCNT_dec(PAD_SVl(ix));
8009 SvPADTMP_on(cSVOPo->op_sv);
8010 PAD_SETSV(ix, cSVOPo->op_sv);
8011 /* XXX I don't know how this isn't readonly already. */
8012 SvREADONLY_on(PAD_SVl(ix));
8014 cSVOPo->op_sv = NULL;
8021 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
8022 if (o->op_next->op_private & OPpTARGET_MY) {
8023 if (o->op_flags & OPf_STACKED) /* chained concats */
8024 break; /* ignore_optimization */
8026 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
8027 o->op_targ = o->op_next->op_targ;
8028 o->op_next->op_targ = 0;
8029 o->op_private |= OPpTARGET_MY;
8032 op_null(o->op_next);
8036 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
8037 break; /* Scalar stub must produce undef. List stub is noop */
8041 if (o->op_targ == OP_NEXTSTATE
8042 || o->op_targ == OP_DBSTATE)
8044 PL_curcop = ((COP*)o);
8046 /* XXX: We avoid setting op_seq here to prevent later calls
8047 to peep() from mistakenly concluding that optimisation
8048 has already occurred. This doesn't fix the real problem,
8049 though (See 20010220.007). AMS 20010719 */
8050 /* op_seq functionality is now replaced by op_opt */
8057 if (oldop && o->op_next) {
8058 oldop->op_next = o->op_next;
8066 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
8067 OP* const pop = (o->op_type == OP_PADAV) ?
8068 o->op_next : o->op_next->op_next;
8070 if (pop && pop->op_type == OP_CONST &&
8071 ((PL_op = pop->op_next)) &&
8072 pop->op_next->op_type == OP_AELEM &&
8073 !(pop->op_next->op_private &
8074 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
8075 (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
8080 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
8081 no_bareword_allowed(pop);
8082 if (o->op_type == OP_GV)
8083 op_null(o->op_next);
8084 op_null(pop->op_next);
8086 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
8087 o->op_next = pop->op_next->op_next;
8088 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
8089 o->op_private = (U8)i;
8090 if (o->op_type == OP_GV) {
8095 o->op_flags |= OPf_SPECIAL;
8096 o->op_type = OP_AELEMFAST;
8101 if (o->op_next->op_type == OP_RV2SV) {
8102 if (!(o->op_next->op_private & OPpDEREF)) {
8103 op_null(o->op_next);
8104 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
8106 o->op_next = o->op_next->op_next;
8107 o->op_type = OP_GVSV;
8108 o->op_ppaddr = PL_ppaddr[OP_GVSV];
8111 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
8112 GV * const gv = cGVOPo_gv;
8113 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
8114 /* XXX could check prototype here instead of just carping */
8115 SV * const sv = sv_newmortal();
8116 gv_efullname3(sv, gv, NULL);
8117 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
8118 "%"SVf"() called too early to check prototype",
8122 else if (o->op_next->op_type == OP_READLINE
8123 && o->op_next->op_next->op_type == OP_CONCAT
8124 && (o->op_next->op_next->op_flags & OPf_STACKED))
8126 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
8127 o->op_type = OP_RCATLINE;
8128 o->op_flags |= OPf_STACKED;
8129 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
8130 op_null(o->op_next->op_next);
8131 op_null(o->op_next);
8147 while (cLOGOP->op_other->op_type == OP_NULL)
8148 cLOGOP->op_other = cLOGOP->op_other->op_next;
8149 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
8154 while (cLOOP->op_redoop->op_type == OP_NULL)
8155 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
8156 peep(cLOOP->op_redoop);
8157 while (cLOOP->op_nextop->op_type == OP_NULL)
8158 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
8159 peep(cLOOP->op_nextop);
8160 while (cLOOP->op_lastop->op_type == OP_NULL)
8161 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
8162 peep(cLOOP->op_lastop);
8166 assert(!(cPMOP->op_pmflags & PMf_ONCE));
8167 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
8168 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
8169 cPMOP->op_pmstashstartu.op_pmreplstart
8170 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
8171 peep(cPMOP->op_pmstashstartu.op_pmreplstart);
8175 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
8176 && ckWARN(WARN_SYNTAX))
8178 if (o->op_next->op_sibling) {
8179 const OPCODE type = o->op_next->op_sibling->op_type;
8180 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
8181 const line_t oldline = CopLINE(PL_curcop);
8182 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
8183 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8184 "Statement unlikely to be reached");
8185 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8186 "\t(Maybe you meant system() when you said exec()?)\n");
8187 CopLINE_set(PL_curcop, oldline);
8198 const char *key = NULL;
8201 if (((BINOP*)o)->op_last->op_type != OP_CONST)
8204 /* Make the CONST have a shared SV */
8205 svp = cSVOPx_svp(((BINOP*)o)->op_last);
8206 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
8207 key = SvPV_const(sv, keylen);
8208 lexname = newSVpvn_share(key,
8209 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
8215 if ((o->op_private & (OPpLVAL_INTRO)))
8218 rop = (UNOP*)((BINOP*)o)->op_first;
8219 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
8221 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
8222 if (!SvPAD_TYPED(lexname))
8224 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8225 if (!fields || !GvHV(*fields))
8227 key = SvPV_const(*svp, keylen);
8228 if (!hv_fetch(GvHV(*fields), key,
8229 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8231 Perl_croak(aTHX_ "No such class field \"%s\" "
8232 "in variable %s of type %s",
8233 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
8246 SVOP *first_key_op, *key_op;
8248 if ((o->op_private & (OPpLVAL_INTRO))
8249 /* I bet there's always a pushmark... */
8250 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
8251 /* hmmm, no optimization if list contains only one key. */
8253 rop = (UNOP*)((LISTOP*)o)->op_last;
8254 if (rop->op_type != OP_RV2HV)
8256 if (rop->op_first->op_type == OP_PADSV)
8257 /* @$hash{qw(keys here)} */
8258 rop = (UNOP*)rop->op_first;
8260 /* @{$hash}{qw(keys here)} */
8261 if (rop->op_first->op_type == OP_SCOPE
8262 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
8264 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
8270 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
8271 if (!SvPAD_TYPED(lexname))
8273 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8274 if (!fields || !GvHV(*fields))
8276 /* Again guessing that the pushmark can be jumped over.... */
8277 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
8278 ->op_first->op_sibling;
8279 for (key_op = first_key_op; key_op;
8280 key_op = (SVOP*)key_op->op_sibling) {
8281 if (key_op->op_type != OP_CONST)
8283 svp = cSVOPx_svp(key_op);
8284 key = SvPV_const(*svp, keylen);
8285 if (!hv_fetch(GvHV(*fields), key,
8286 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8288 Perl_croak(aTHX_ "No such class field \"%s\" "
8289 "in variable %s of type %s",
8290 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
8297 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
8301 /* check that RHS of sort is a single plain array */
8302 OP *oright = cUNOPo->op_first;
8303 if (!oright || oright->op_type != OP_PUSHMARK)
8306 /* reverse sort ... can be optimised. */
8307 if (!cUNOPo->op_sibling) {
8308 /* Nothing follows us on the list. */
8309 OP * const reverse = o->op_next;
8311 if (reverse->op_type == OP_REVERSE &&
8312 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
8313 OP * const pushmark = cUNOPx(reverse)->op_first;
8314 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
8315 && (cUNOPx(pushmark)->op_sibling == o)) {
8316 /* reverse -> pushmark -> sort */
8317 o->op_private |= OPpSORT_REVERSE;
8319 pushmark->op_next = oright->op_next;
8325 /* make @a = sort @a act in-place */
8327 oright = cUNOPx(oright)->op_sibling;
8330 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
8331 oright = cUNOPx(oright)->op_sibling;
8335 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
8336 || oright->op_next != o
8337 || (oright->op_private & OPpLVAL_INTRO)
8341 /* o2 follows the chain of op_nexts through the LHS of the
8342 * assign (if any) to the aassign op itself */
8344 if (!o2 || o2->op_type != OP_NULL)
8347 if (!o2 || o2->op_type != OP_PUSHMARK)
8350 if (o2 && o2->op_type == OP_GV)
8353 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
8354 || (o2->op_private & OPpLVAL_INTRO)
8359 if (!o2 || o2->op_type != OP_NULL)
8362 if (!o2 || o2->op_type != OP_AASSIGN
8363 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
8366 /* check that the sort is the first arg on RHS of assign */
8368 o2 = cUNOPx(o2)->op_first;
8369 if (!o2 || o2->op_type != OP_NULL)
8371 o2 = cUNOPx(o2)->op_first;
8372 if (!o2 || o2->op_type != OP_PUSHMARK)
8374 if (o2->op_sibling != o)
8377 /* check the array is the same on both sides */
8378 if (oleft->op_type == OP_RV2AV) {
8379 if (oright->op_type != OP_RV2AV
8380 || !cUNOPx(oright)->op_first
8381 || cUNOPx(oright)->op_first->op_type != OP_GV
8382 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
8383 cGVOPx_gv(cUNOPx(oright)->op_first)
8387 else if (oright->op_type != OP_PADAV
8388 || oright->op_targ != oleft->op_targ
8392 /* transfer MODishness etc from LHS arg to RHS arg */
8393 oright->op_flags = oleft->op_flags;
8394 o->op_private |= OPpSORT_INPLACE;
8396 /* excise push->gv->rv2av->null->aassign */
8397 o2 = o->op_next->op_next;
8398 op_null(o2); /* PUSHMARK */
8400 if (o2->op_type == OP_GV) {
8401 op_null(o2); /* GV */
8404 op_null(o2); /* RV2AV or PADAV */
8405 o2 = o2->op_next->op_next;
8406 op_null(o2); /* AASSIGN */
8408 o->op_next = o2->op_next;
8414 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
8416 LISTOP *enter, *exlist;
8418 enter = (LISTOP *) o->op_next;
8421 if (enter->op_type == OP_NULL) {
8422 enter = (LISTOP *) enter->op_next;
8426 /* for $a (...) will have OP_GV then OP_RV2GV here.
8427 for (...) just has an OP_GV. */
8428 if (enter->op_type == OP_GV) {
8429 gvop = (OP *) enter;
8430 enter = (LISTOP *) enter->op_next;
8433 if (enter->op_type == OP_RV2GV) {
8434 enter = (LISTOP *) enter->op_next;
8440 if (enter->op_type != OP_ENTERITER)
8443 iter = enter->op_next;
8444 if (!iter || iter->op_type != OP_ITER)
8447 expushmark = enter->op_first;
8448 if (!expushmark || expushmark->op_type != OP_NULL
8449 || expushmark->op_targ != OP_PUSHMARK)
8452 exlist = (LISTOP *) expushmark->op_sibling;
8453 if (!exlist || exlist->op_type != OP_NULL
8454 || exlist->op_targ != OP_LIST)
8457 if (exlist->op_last != o) {
8458 /* Mmm. Was expecting to point back to this op. */
8461 theirmark = exlist->op_first;
8462 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
8465 if (theirmark->op_sibling != o) {
8466 /* There's something between the mark and the reverse, eg
8467 for (1, reverse (...))
8472 ourmark = ((LISTOP *)o)->op_first;
8473 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
8476 ourlast = ((LISTOP *)o)->op_last;
8477 if (!ourlast || ourlast->op_next != o)
8480 rv2av = ourmark->op_sibling;
8481 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
8482 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
8483 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
8484 /* We're just reversing a single array. */
8485 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
8486 enter->op_flags |= OPf_STACKED;
8489 /* We don't have control over who points to theirmark, so sacrifice
8491 theirmark->op_next = ourmark->op_next;
8492 theirmark->op_flags = ourmark->op_flags;
8493 ourlast->op_next = gvop ? gvop : (OP *) enter;
8496 enter->op_private |= OPpITER_REVERSED;
8497 iter->op_private |= OPpITER_REVERSED;
8504 UNOP *refgen, *rv2cv;
8507 if ((o->op_flags & OPf_WANT) != OPf_WANT_VOID)
8510 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
8513 rv2gv = ((BINOP *)o)->op_last;
8514 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
8517 refgen = (UNOP *)((BINOP *)o)->op_first;
8519 if (!refgen || refgen->op_type != OP_REFGEN)
8522 exlist = (LISTOP *)refgen->op_first;
8523 if (!exlist || exlist->op_type != OP_NULL
8524 || exlist->op_targ != OP_LIST)
8527 if (exlist->op_first->op_type != OP_PUSHMARK)
8530 rv2cv = (UNOP*)exlist->op_last;
8532 if (rv2cv->op_type != OP_RV2CV)
8535 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
8536 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
8537 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
8539 o->op_private |= OPpASSIGN_CV_TO_GV;
8540 rv2gv->op_private |= OPpDONT_INIT_GV;
8541 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
8549 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
8550 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
8560 Perl_custom_op_name(pTHX_ const OP* o)
8563 const IV index = PTR2IV(o->op_ppaddr);
8567 if (!PL_custom_op_names) /* This probably shouldn't happen */
8568 return (char *)PL_op_name[OP_CUSTOM];
8570 keysv = sv_2mortal(newSViv(index));
8572 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
8574 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
8576 return SvPV_nolen(HeVAL(he));
8580 Perl_custom_op_desc(pTHX_ const OP* o)
8583 const IV index = PTR2IV(o->op_ppaddr);
8587 if (!PL_custom_op_descs)
8588 return (char *)PL_op_desc[OP_CUSTOM];
8590 keysv = sv_2mortal(newSViv(index));
8592 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
8594 return (char *)PL_op_desc[OP_CUSTOM];
8596 return SvPV_nolen(HeVAL(he));
8601 /* Efficient sub that returns a constant scalar value. */
8603 const_sv_xsub(pTHX_ CV* cv)
8610 Perl_croak(aTHX_ "usage: %s::%s()",
8611 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
8615 ST(0) = (SV*)XSANY.any_ptr;
8621 * c-indentation-style: bsd
8623 * indent-tabs-mode: t
8626 * ex: set ts=8 sts=4 sw=4 noet: