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_SETSTATE || 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_SETSTATE
905 || o->op_type == OP_DBSTATE
906 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
907 || o->op_targ == OP_SETSTATE
908 || o->op_targ == OP_DBSTATE)))
909 PL_curcop = (COP*)o; /* for warning below */
911 /* assumes no premature commitment */
912 want = o->op_flags & OPf_WANT;
913 if ((want && want != OPf_WANT_SCALAR)
914 || (PL_parser && PL_parser->error_count)
915 || o->op_type == OP_RETURN)
920 if ((o->op_private & OPpTARGET_MY)
921 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
923 return scalar(o); /* As if inside SASSIGN */
926 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
928 switch (o->op_type) {
930 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
934 if (o->op_flags & OPf_STACKED)
938 if (o->op_private == 4)
1011 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1012 /* Otherwise it's "Useless use of grep iterator" */
1013 useless = OP_DESC(o);
1017 kid = cUNOPo->op_first;
1018 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1019 kid->op_type != OP_TRANS) {
1022 useless = "negative pattern binding (!~)";
1029 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1030 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1031 useless = "a variable";
1036 if (cSVOPo->op_private & OPpCONST_STRICT)
1037 no_bareword_allowed(o);
1039 if (ckWARN(WARN_VOID)) {
1040 useless = "a constant";
1041 if (o->op_private & OPpCONST_ARYBASE)
1043 /* don't warn on optimised away booleans, eg
1044 * use constant Foo, 5; Foo || print; */
1045 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1047 /* the constants 0 and 1 are permitted as they are
1048 conventionally used as dummies in constructs like
1049 1 while some_condition_with_side_effects; */
1050 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1052 else if (SvPOK(sv)) {
1053 /* perl4's way of mixing documentation and code
1054 (before the invention of POD) was based on a
1055 trick to mix nroff and perl code. The trick was
1056 built upon these three nroff macros being used in
1057 void context. The pink camel has the details in
1058 the script wrapman near page 319. */
1059 const char * const maybe_macro = SvPVX_const(sv);
1060 if (strnEQ(maybe_macro, "di", 2) ||
1061 strnEQ(maybe_macro, "ds", 2) ||
1062 strnEQ(maybe_macro, "ig", 2))
1067 op_null(o); /* don't execute or even remember it */
1071 o->op_type = OP_PREINC; /* pre-increment is faster */
1072 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1076 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1077 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1081 o->op_type = OP_I_PREINC; /* pre-increment is faster */
1082 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1086 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
1087 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1096 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1101 if (o->op_flags & OPf_STACKED)
1108 if (!(o->op_flags & OPf_KIDS))
1119 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1126 /* all requires must return a boolean value */
1127 o->op_flags &= ~OPf_WANT;
1132 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
1133 if (!kPMOP->op_pmreplrootu.op_pmreplroot)
1134 deprecate_old("implicit split to @_");
1138 if (useless && ckWARN(WARN_VOID))
1139 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
1144 Perl_listkids(pTHX_ OP *o)
1146 if (o && o->op_flags & OPf_KIDS) {
1148 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1155 Perl_list(pTHX_ OP *o)
1160 /* assumes no premature commitment */
1161 if (!o || (o->op_flags & OPf_WANT)
1162 || (PL_parser && PL_parser->error_count)
1163 || o->op_type == OP_RETURN)
1168 if ((o->op_private & OPpTARGET_MY)
1169 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1171 return o; /* As if inside SASSIGN */
1174 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1176 switch (o->op_type) {
1179 list(cBINOPo->op_first);
1184 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1192 if (!(o->op_flags & OPf_KIDS))
1194 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1195 list(cBINOPo->op_first);
1196 return gen_constant_list(o);
1203 kid = cLISTOPo->op_first;
1205 while ((kid = kid->op_sibling)) {
1206 if (kid->op_sibling)
1211 PL_curcop = &PL_compiling;
1215 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1216 if (kid->op_sibling)
1221 PL_curcop = &PL_compiling;
1224 /* all requires must return a boolean value */
1225 o->op_flags &= ~OPf_WANT;
1232 Perl_scalarseq(pTHX_ OP *o)
1236 const OPCODE type = o->op_type;
1238 if (type == OP_LINESEQ || type == OP_SCOPE ||
1239 type == OP_LEAVE || type == OP_LEAVETRY)
1242 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1243 if (kid->op_sibling) {
1247 PL_curcop = &PL_compiling;
1249 o->op_flags &= ~OPf_PARENS;
1250 if (PL_hints & HINT_BLOCK_SCOPE)
1251 o->op_flags |= OPf_PARENS;
1254 o = newOP(OP_STUB, 0);
1259 S_modkids(pTHX_ OP *o, I32 type)
1261 if (o && o->op_flags & OPf_KIDS) {
1263 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1269 /* Propagate lvalue ("modifiable") context to an op and its children.
1270 * 'type' represents the context type, roughly based on the type of op that
1271 * would do the modifying, although local() is represented by OP_NULL.
1272 * It's responsible for detecting things that can't be modified, flag
1273 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
1274 * might have to vivify a reference in $x), and so on.
1276 * For example, "$a+1 = 2" would cause mod() to be called with o being
1277 * OP_ADD and type being OP_SASSIGN, and would output an error.
1281 Perl_mod(pTHX_ OP *o, I32 type)
1285 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1288 if (!o || (PL_parser && PL_parser->error_count))
1291 if ((o->op_private & OPpTARGET_MY)
1292 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1297 switch (o->op_type) {
1303 if (!(o->op_private & OPpCONST_ARYBASE))
1306 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1307 CopARYBASE_set(&PL_compiling,
1308 (I32)SvIV(cSVOPx(PL_eval_start)->op_sv));
1312 SAVECOPARYBASE(&PL_compiling);
1313 CopARYBASE_set(&PL_compiling, 0);
1315 else if (type == OP_REFGEN)
1318 Perl_croak(aTHX_ "That use of $[ is unsupported");
1321 if ((o->op_flags & OPf_PARENS) || PL_madskills)
1325 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1326 !(o->op_flags & OPf_STACKED)) {
1327 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1328 /* The default is to set op_private to the number of children,
1329 which for a UNOP such as RV2CV is always 1. And w're using
1330 the bit for a flag in RV2CV, so we need it clear. */
1331 o->op_private &= ~1;
1332 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1333 assert(cUNOPo->op_first->op_type == OP_NULL);
1334 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1337 else if (o->op_private & OPpENTERSUB_NOMOD)
1339 else { /* lvalue subroutine call */
1340 o->op_private |= OPpLVAL_INTRO;
1341 PL_modcount = RETURN_UNLIMITED_NUMBER;
1342 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1343 /* Backward compatibility mode: */
1344 o->op_private |= OPpENTERSUB_INARGS;
1347 else { /* Compile-time error message: */
1348 OP *kid = cUNOPo->op_first;
1352 if (kid->op_type != OP_PUSHMARK) {
1353 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1355 "panic: unexpected lvalue entersub "
1356 "args: type/targ %ld:%"UVuf,
1357 (long)kid->op_type, (UV)kid->op_targ);
1358 kid = kLISTOP->op_first;
1360 while (kid->op_sibling)
1361 kid = kid->op_sibling;
1362 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1364 if (kid->op_type == OP_METHOD_NAMED
1365 || kid->op_type == OP_METHOD)
1369 NewOp(1101, newop, 1, UNOP);
1370 newop->op_type = OP_RV2CV;
1371 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1372 newop->op_first = NULL;
1373 newop->op_next = (OP*)newop;
1374 kid->op_sibling = (OP*)newop;
1375 newop->op_private |= OPpLVAL_INTRO;
1376 newop->op_private &= ~1;
1380 if (kid->op_type != OP_RV2CV)
1382 "panic: unexpected lvalue entersub "
1383 "entry via type/targ %ld:%"UVuf,
1384 (long)kid->op_type, (UV)kid->op_targ);
1385 kid->op_private |= OPpLVAL_INTRO;
1386 break; /* Postpone until runtime */
1390 kid = kUNOP->op_first;
1391 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1392 kid = kUNOP->op_first;
1393 if (kid->op_type == OP_NULL)
1395 "Unexpected constant lvalue entersub "
1396 "entry via type/targ %ld:%"UVuf,
1397 (long)kid->op_type, (UV)kid->op_targ);
1398 if (kid->op_type != OP_GV) {
1399 /* Restore RV2CV to check lvalueness */
1401 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1402 okid->op_next = kid->op_next;
1403 kid->op_next = okid;
1406 okid->op_next = NULL;
1407 okid->op_type = OP_RV2CV;
1409 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1410 okid->op_private |= OPpLVAL_INTRO;
1411 okid->op_private &= ~1;
1415 cv = GvCV(kGVOP_gv);
1425 /* grep, foreach, subcalls, refgen */
1426 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1428 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1429 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1431 : (o->op_type == OP_ENTERSUB
1432 ? "non-lvalue subroutine call"
1434 type ? PL_op_desc[type] : "local"));
1448 case OP_RIGHT_SHIFT:
1457 if (!(o->op_flags & OPf_STACKED))
1464 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1470 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1471 PL_modcount = RETURN_UNLIMITED_NUMBER;
1472 return o; /* Treat \(@foo) like ordinary list. */
1476 if (scalar_mod_type(o, type))
1478 ref(cUNOPo->op_first, o->op_type);
1482 if (type == OP_LEAVESUBLV)
1483 o->op_private |= OPpMAYBE_LVSUB;
1489 PL_modcount = RETURN_UNLIMITED_NUMBER;
1492 ref(cUNOPo->op_first, o->op_type);
1497 PL_hints |= HINT_BLOCK_SCOPE;
1512 PL_modcount = RETURN_UNLIMITED_NUMBER;
1513 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1514 return o; /* Treat \(@foo) like ordinary list. */
1515 if (scalar_mod_type(o, type))
1517 if (type == OP_LEAVESUBLV)
1518 o->op_private |= OPpMAYBE_LVSUB;
1522 if (!type) /* local() */
1523 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1524 PAD_COMPNAME_PV(o->op_targ));
1532 if (type != OP_SASSIGN)
1536 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1541 if (type == OP_LEAVESUBLV)
1542 o->op_private |= OPpMAYBE_LVSUB;
1544 pad_free(o->op_targ);
1545 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1546 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1547 if (o->op_flags & OPf_KIDS)
1548 mod(cBINOPo->op_first->op_sibling, type);
1553 ref(cBINOPo->op_first, o->op_type);
1554 if (type == OP_ENTERSUB &&
1555 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1556 o->op_private |= OPpLVAL_DEFER;
1557 if (type == OP_LEAVESUBLV)
1558 o->op_private |= OPpMAYBE_LVSUB;
1568 if (o->op_flags & OPf_KIDS)
1569 mod(cLISTOPo->op_last, type);
1574 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1576 else if (!(o->op_flags & OPf_KIDS))
1578 if (o->op_targ != OP_LIST) {
1579 mod(cBINOPo->op_first, type);
1585 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1590 if (type != OP_LEAVESUBLV)
1592 break; /* mod()ing was handled by ck_return() */
1595 /* [20011101.069] File test operators interpret OPf_REF to mean that
1596 their argument is a filehandle; thus \stat(".") should not set
1598 if (type == OP_REFGEN &&
1599 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1602 if (type != OP_LEAVESUBLV)
1603 o->op_flags |= OPf_MOD;
1605 if (type == OP_AASSIGN || type == OP_SASSIGN)
1606 o->op_flags |= OPf_SPECIAL|OPf_REF;
1607 else if (!type) { /* local() */
1610 o->op_private |= OPpLVAL_INTRO;
1611 o->op_flags &= ~OPf_SPECIAL;
1612 PL_hints |= HINT_BLOCK_SCOPE;
1617 if (ckWARN(WARN_SYNTAX)) {
1618 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1619 "Useless localization of %s", OP_DESC(o));
1623 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1624 && type != OP_LEAVESUBLV)
1625 o->op_flags |= OPf_REF;
1630 S_scalar_mod_type(const OP *o, I32 type)
1634 if (o->op_type == OP_RV2GV)
1658 case OP_RIGHT_SHIFT:
1678 S_is_handle_constructor(const OP *o, I32 numargs)
1680 switch (o->op_type) {
1688 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1701 Perl_refkids(pTHX_ OP *o, I32 type)
1703 if (o && o->op_flags & OPf_KIDS) {
1705 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1712 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
1717 if (!o || (PL_parser && PL_parser->error_count))
1720 switch (o->op_type) {
1722 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1723 !(o->op_flags & OPf_STACKED)) {
1724 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1725 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1726 assert(cUNOPo->op_first->op_type == OP_NULL);
1727 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1728 o->op_flags |= OPf_SPECIAL;
1729 o->op_private &= ~1;
1734 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1735 doref(kid, type, set_op_ref);
1738 if (type == OP_DEFINED)
1739 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1740 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1743 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1744 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1745 : type == OP_RV2HV ? OPpDEREF_HV
1747 o->op_flags |= OPf_MOD;
1754 o->op_flags |= OPf_REF;
1757 if (type == OP_DEFINED)
1758 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1759 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1765 o->op_flags |= OPf_REF;
1770 if (!(o->op_flags & OPf_KIDS))
1772 doref(cBINOPo->op_first, type, set_op_ref);
1776 doref(cBINOPo->op_first, o->op_type, set_op_ref);
1777 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1778 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1779 : type == OP_RV2HV ? OPpDEREF_HV
1781 o->op_flags |= OPf_MOD;
1791 if (!(o->op_flags & OPf_KIDS))
1793 doref(cLISTOPo->op_last, type, set_op_ref);
1803 S_dup_attrlist(pTHX_ OP *o)
1808 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1809 * where the first kid is OP_PUSHMARK and the remaining ones
1810 * are OP_CONST. We need to push the OP_CONST values.
1812 if (o->op_type == OP_CONST)
1813 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
1815 else if (o->op_type == OP_NULL)
1819 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1821 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1822 if (o->op_type == OP_CONST)
1823 rop = append_elem(OP_LIST, rop,
1824 newSVOP(OP_CONST, o->op_flags,
1825 SvREFCNT_inc_NN(cSVOPo->op_sv)));
1832 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1837 /* fake up C<use attributes $pkg,$rv,@attrs> */
1838 ENTER; /* need to protect against side-effects of 'use' */
1839 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1841 #define ATTRSMODULE "attributes"
1842 #define ATTRSMODULE_PM "attributes.pm"
1845 /* Don't force the C<use> if we don't need it. */
1846 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
1847 if (svp && *svp != &PL_sv_undef)
1848 NOOP; /* already in %INC */
1850 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1851 newSVpvs(ATTRSMODULE), NULL);
1854 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1855 newSVpvs(ATTRSMODULE),
1857 prepend_elem(OP_LIST,
1858 newSVOP(OP_CONST, 0, stashsv),
1859 prepend_elem(OP_LIST,
1860 newSVOP(OP_CONST, 0,
1862 dup_attrlist(attrs))));
1868 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1871 OP *pack, *imop, *arg;
1877 assert(target->op_type == OP_PADSV ||
1878 target->op_type == OP_PADHV ||
1879 target->op_type == OP_PADAV);
1881 /* Ensure that attributes.pm is loaded. */
1882 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1884 /* Need package name for method call. */
1885 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
1887 /* Build up the real arg-list. */
1888 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1890 arg = newOP(OP_PADSV, 0);
1891 arg->op_targ = target->op_targ;
1892 arg = prepend_elem(OP_LIST,
1893 newSVOP(OP_CONST, 0, stashsv),
1894 prepend_elem(OP_LIST,
1895 newUNOP(OP_REFGEN, 0,
1896 mod(arg, OP_REFGEN)),
1897 dup_attrlist(attrs)));
1899 /* Fake up a method call to import */
1900 meth = newSVpvs_share("import");
1901 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1902 append_elem(OP_LIST,
1903 prepend_elem(OP_LIST, pack, list(arg)),
1904 newSVOP(OP_METHOD_NAMED, 0, meth)));
1905 imop->op_private |= OPpENTERSUB_NOMOD;
1907 /* Combine the ops. */
1908 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1912 =notfor apidoc apply_attrs_string
1914 Attempts to apply a list of attributes specified by the C<attrstr> and
1915 C<len> arguments to the subroutine identified by the C<cv> argument which
1916 is expected to be associated with the package identified by the C<stashpv>
1917 argument (see L<attributes>). It gets this wrong, though, in that it
1918 does not correctly identify the boundaries of the individual attribute
1919 specifications within C<attrstr>. This is not really intended for the
1920 public API, but has to be listed here for systems such as AIX which
1921 need an explicit export list for symbols. (It's called from XS code
1922 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1923 to respect attribute syntax properly would be welcome.
1929 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
1930 const char *attrstr, STRLEN len)
1935 len = strlen(attrstr);
1939 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1941 const char * const sstr = attrstr;
1942 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1943 attrs = append_elem(OP_LIST, attrs,
1944 newSVOP(OP_CONST, 0,
1945 newSVpvn(sstr, attrstr-sstr)));
1949 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1950 newSVpvs(ATTRSMODULE),
1951 NULL, prepend_elem(OP_LIST,
1952 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1953 prepend_elem(OP_LIST,
1954 newSVOP(OP_CONST, 0,
1960 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
1965 if (!o || (PL_parser && PL_parser->error_count))
1969 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
1970 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
1974 if (type == OP_LIST) {
1976 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1977 my_kid(kid, attrs, imopsp);
1978 } else if (type == OP_UNDEF
1984 } else if (type == OP_RV2SV || /* "our" declaration */
1986 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1987 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1988 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1990 PL_parser->in_my == KEY_our
1992 : PL_parser->in_my == KEY_state ? "state" : "my"));
1994 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
1995 PL_parser->in_my = FALSE;
1996 PL_parser->in_my_stash = NULL;
1997 apply_attrs(GvSTASH(gv),
1998 (type == OP_RV2SV ? GvSV(gv) :
1999 type == OP_RV2AV ? (SV*)GvAV(gv) :
2000 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
2003 o->op_private |= OPpOUR_INTRO;
2006 else if (type != OP_PADSV &&
2009 type != OP_PUSHMARK)
2011 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2013 PL_parser->in_my == KEY_our
2015 : PL_parser->in_my == KEY_state ? "state" : "my"));
2018 else if (attrs && type != OP_PUSHMARK) {
2021 PL_parser->in_my = FALSE;
2022 PL_parser->in_my_stash = NULL;
2024 /* check for C<my Dog $spot> when deciding package */
2025 stash = PAD_COMPNAME_TYPE(o->op_targ);
2027 stash = PL_curstash;
2028 apply_attrs_my(stash, o, attrs, imopsp);
2030 o->op_flags |= OPf_MOD;
2031 o->op_private |= OPpLVAL_INTRO;
2032 if (PL_parser->in_my == KEY_state)
2033 o->op_private |= OPpPAD_STATE;
2038 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2042 int maybe_scalar = 0;
2044 /* [perl #17376]: this appears to be premature, and results in code such as
2045 C< our(%x); > executing in list mode rather than void mode */
2047 if (o->op_flags & OPf_PARENS)
2057 o = my_kid(o, attrs, &rops);
2059 if (maybe_scalar && o->op_type == OP_PADSV) {
2060 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
2061 o->op_private |= OPpLVAL_INTRO;
2064 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
2066 PL_parser->in_my = FALSE;
2067 PL_parser->in_my_stash = NULL;
2072 Perl_my(pTHX_ OP *o)
2074 return my_attrs(o, NULL);
2078 Perl_sawparens(pTHX_ OP *o)
2080 PERL_UNUSED_CONTEXT;
2082 o->op_flags |= OPf_PARENS;
2087 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2091 const OPCODE ltype = left->op_type;
2092 const OPCODE rtype = right->op_type;
2094 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2095 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
2097 const char * const desc
2098 = PL_op_desc[(rtype == OP_SUBST || rtype == OP_TRANS)
2099 ? (int)rtype : OP_MATCH];
2100 const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV)
2101 ? "@array" : "%hash");
2102 Perl_warner(aTHX_ packWARN(WARN_MISC),
2103 "Applying %s to %s will act on scalar(%s)",
2104 desc, sample, sample);
2107 if (rtype == OP_CONST &&
2108 cSVOPx(right)->op_private & OPpCONST_BARE &&
2109 cSVOPx(right)->op_private & OPpCONST_STRICT)
2111 no_bareword_allowed(right);
2114 ismatchop = rtype == OP_MATCH ||
2115 rtype == OP_SUBST ||
2117 if (ismatchop && right->op_private & OPpTARGET_MY) {
2119 right->op_private &= ~OPpTARGET_MY;
2121 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
2124 right->op_flags |= OPf_STACKED;
2125 if (rtype != OP_MATCH &&
2126 ! (rtype == OP_TRANS &&
2127 right->op_private & OPpTRANS_IDENTICAL))
2128 newleft = mod(left, rtype);
2131 if (right->op_type == OP_TRANS)
2132 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
2134 o = prepend_elem(rtype, scalar(newleft), right);
2136 return newUNOP(OP_NOT, 0, scalar(o));
2140 return bind_match(type, left,
2141 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
2145 Perl_invert(pTHX_ OP *o)
2149 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2153 Perl_scope(pTHX_ OP *o)
2157 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2158 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2159 o->op_type = OP_LEAVE;
2160 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2162 else if (o->op_type == OP_LINESEQ) {
2164 o->op_type = OP_SCOPE;
2165 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2166 kid = ((LISTOP*)o)->op_first;
2167 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2170 /* The following deals with things like 'do {1 for 1}' */
2171 kid = kid->op_sibling;
2173 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2178 o = newLISTOP(OP_SCOPE, 0, o, NULL);
2184 Perl_block_start(pTHX_ int full)
2187 const int retval = PL_savestack_ix;
2188 pad_block_start(full);
2190 PL_hints &= ~HINT_BLOCK_SCOPE;
2191 SAVECOMPILEWARNINGS();
2192 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
2197 Perl_block_end(pTHX_ I32 floor, OP *seq)
2200 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2201 OP* const retval = scalarseq(seq);
2203 CopHINTS_set(&PL_compiling, PL_hints);
2205 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2214 const PADOFFSET offset = pad_findmy("$_");
2215 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
2216 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2219 OP * const o = newOP(OP_PADSV, 0);
2220 o->op_targ = offset;
2226 Perl_newPROG(pTHX_ OP *o)
2232 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2233 ((PL_in_eval & EVAL_KEEPERR)
2234 ? OPf_SPECIAL : 0), o);
2235 PL_eval_start = linklist(PL_eval_root);
2236 PL_eval_root->op_private |= OPpREFCOUNTED;
2237 OpREFCNT_set(PL_eval_root, 1);
2238 PL_eval_root->op_next = 0;
2239 CALL_PEEP(PL_eval_start);
2242 if (o->op_type == OP_STUB) {
2243 PL_comppad_name = 0;
2245 S_op_destroy(aTHX_ o);
2248 PL_main_root = scope(sawparens(scalarvoid(o)));
2249 PL_curcop = &PL_compiling;
2250 PL_main_start = LINKLIST(PL_main_root);
2251 PL_main_root->op_private |= OPpREFCOUNTED;
2252 OpREFCNT_set(PL_main_root, 1);
2253 PL_main_root->op_next = 0;
2254 CALL_PEEP(PL_main_start);
2257 /* Register with debugger */
2260 = Perl_get_cvn_flags(aTHX_ STR_WITH_LEN("DB::postponed"), 0);
2264 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2266 call_sv((SV*)cv, G_DISCARD);
2273 Perl_localize(pTHX_ OP *o, I32 lex)
2276 if (o->op_flags & OPf_PARENS)
2277 /* [perl #17376]: this appears to be premature, and results in code such as
2278 C< our(%x); > executing in list mode rather than void mode */
2285 if ( PL_parser->bufptr > PL_parser->oldbufptr
2286 && PL_parser->bufptr[-1] == ','
2287 && ckWARN(WARN_PARENTHESIS))
2289 char *s = PL_parser->bufptr;
2292 /* some heuristics to detect a potential error */
2293 while (*s && (strchr(", \t\n", *s)))
2297 if (*s && strchr("@$%*", *s) && *++s
2298 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2301 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2303 while (*s && (strchr(", \t\n", *s)))
2309 if (sigil && (*s == ';' || *s == '=')) {
2310 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2311 "Parentheses missing around \"%s\" list",
2313 ? (PL_parser->in_my == KEY_our
2315 : PL_parser->in_my == KEY_state
2325 o = mod(o, OP_NULL); /* a bit kludgey */
2326 PL_parser->in_my = FALSE;
2327 PL_parser->in_my_stash = NULL;
2332 Perl_jmaybe(pTHX_ OP *o)
2334 if (o->op_type == OP_LIST) {
2336 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2337 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2343 Perl_fold_constants(pTHX_ register OP *o)
2348 VOL I32 type = o->op_type;
2353 SV * const oldwarnhook = PL_warnhook;
2354 SV * const olddiehook = PL_diehook;
2357 if (PL_opargs[type] & OA_RETSCALAR)
2359 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2360 o->op_targ = pad_alloc(type, SVs_PADTMP);
2362 /* integerize op, unless it happens to be C<-foo>.
2363 * XXX should pp_i_negate() do magic string negation instead? */
2364 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2365 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2366 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2368 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2371 if (!(PL_opargs[type] & OA_FOLDCONST))
2376 /* XXX might want a ck_negate() for this */
2377 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2388 /* XXX what about the numeric ops? */
2389 if (PL_hints & HINT_LOCALE)
2393 if (PL_parser && PL_parser->error_count)
2394 goto nope; /* Don't try to run w/ errors */
2396 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2397 const OPCODE type = curop->op_type;
2398 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2400 type != OP_SCALAR &&
2402 type != OP_PUSHMARK)
2408 curop = LINKLIST(o);
2409 old_next = o->op_next;
2413 oldscope = PL_scopestack_ix;
2414 create_eval_scope(G_FAKINGEVAL);
2416 PL_warnhook = PERL_WARNHOOK_FATAL;
2423 sv = *(PL_stack_sp--);
2424 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2425 pad_swipe(o->op_targ, FALSE);
2426 else if (SvTEMP(sv)) { /* grab mortal temp? */
2427 SvREFCNT_inc_simple_void(sv);
2432 /* Something tried to die. Abandon constant folding. */
2433 /* Pretend the error never happened. */
2434 sv_setpvn(ERRSV,"",0);
2435 o->op_next = old_next;
2439 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
2440 PL_warnhook = oldwarnhook;
2441 PL_diehook = olddiehook;
2442 /* XXX note that this croak may fail as we've already blown away
2443 * the stack - eg any nested evals */
2444 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
2447 PL_warnhook = oldwarnhook;
2448 PL_diehook = olddiehook;
2450 if (PL_scopestack_ix > oldscope)
2451 delete_eval_scope();
2460 if (type == OP_RV2GV)
2461 newop = newGVOP(OP_GV, 0, (GV*)sv);
2463 newop = newSVOP(OP_CONST, 0, (SV*)sv);
2464 op_getmad(o,newop,'f');
2472 Perl_gen_constant_list(pTHX_ register OP *o)
2476 const I32 oldtmps_floor = PL_tmps_floor;
2479 if (PL_parser && PL_parser->error_count)
2480 return o; /* Don't attempt to run with errors */
2482 PL_op = curop = LINKLIST(o);
2488 assert (!(curop->op_flags & OPf_SPECIAL));
2489 assert(curop->op_type == OP_RANGE);
2491 PL_tmps_floor = oldtmps_floor;
2493 o->op_type = OP_RV2AV;
2494 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2495 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2496 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2497 o->op_opt = 0; /* needs to be revisited in peep() */
2498 curop = ((UNOP*)o)->op_first;
2499 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
2501 op_getmad(curop,o,'O');
2510 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2513 if (!o || o->op_type != OP_LIST)
2514 o = newLISTOP(OP_LIST, 0, o, NULL);
2516 o->op_flags &= ~OPf_WANT;
2518 if (!(PL_opargs[type] & OA_MARK))
2519 op_null(cLISTOPo->op_first);
2521 o->op_type = (OPCODE)type;
2522 o->op_ppaddr = PL_ppaddr[type];
2523 o->op_flags |= flags;
2525 o = CHECKOP(type, o);
2526 if (o->op_type != (unsigned)type)
2529 return fold_constants(o);
2532 /* List constructors */
2535 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2543 if (first->op_type != (unsigned)type
2544 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2546 return newLISTOP(type, 0, first, last);
2549 if (first->op_flags & OPf_KIDS)
2550 ((LISTOP*)first)->op_last->op_sibling = last;
2552 first->op_flags |= OPf_KIDS;
2553 ((LISTOP*)first)->op_first = last;
2555 ((LISTOP*)first)->op_last = last;
2560 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2568 if (first->op_type != (unsigned)type)
2569 return prepend_elem(type, (OP*)first, (OP*)last);
2571 if (last->op_type != (unsigned)type)
2572 return append_elem(type, (OP*)first, (OP*)last);
2574 first->op_last->op_sibling = last->op_first;
2575 first->op_last = last->op_last;
2576 first->op_flags |= (last->op_flags & OPf_KIDS);
2579 if (last->op_first && first->op_madprop) {
2580 MADPROP *mp = last->op_first->op_madprop;
2582 while (mp->mad_next)
2584 mp->mad_next = first->op_madprop;
2587 last->op_first->op_madprop = first->op_madprop;
2590 first->op_madprop = last->op_madprop;
2591 last->op_madprop = 0;
2594 S_op_destroy(aTHX_ (OP*)last);
2600 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2608 if (last->op_type == (unsigned)type) {
2609 if (type == OP_LIST) { /* already a PUSHMARK there */
2610 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2611 ((LISTOP*)last)->op_first->op_sibling = first;
2612 if (!(first->op_flags & OPf_PARENS))
2613 last->op_flags &= ~OPf_PARENS;
2616 if (!(last->op_flags & OPf_KIDS)) {
2617 ((LISTOP*)last)->op_last = first;
2618 last->op_flags |= OPf_KIDS;
2620 first->op_sibling = ((LISTOP*)last)->op_first;
2621 ((LISTOP*)last)->op_first = first;
2623 last->op_flags |= OPf_KIDS;
2627 return newLISTOP(type, 0, first, last);
2635 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2638 Newxz(tk, 1, TOKEN);
2639 tk->tk_type = (OPCODE)optype;
2640 tk->tk_type = 12345;
2642 tk->tk_mad = madprop;
2647 Perl_token_free(pTHX_ TOKEN* tk)
2649 if (tk->tk_type != 12345)
2651 mad_free(tk->tk_mad);
2656 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2660 if (tk->tk_type != 12345) {
2661 Perl_warner(aTHX_ packWARN(WARN_MISC),
2662 "Invalid TOKEN object ignored");
2669 /* faked up qw list? */
2671 tm->mad_type == MAD_SV &&
2672 SvPVX((SV*)tm->mad_val)[0] == 'q')
2679 /* pretend constant fold didn't happen? */
2680 if (mp->mad_key == 'f' &&
2681 (o->op_type == OP_CONST ||
2682 o->op_type == OP_GV) )
2684 token_getmad(tk,(OP*)mp->mad_val,slot);
2698 if (mp->mad_key == 'X')
2699 mp->mad_key = slot; /* just change the first one */
2709 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
2718 /* pretend constant fold didn't happen? */
2719 if (mp->mad_key == 'f' &&
2720 (o->op_type == OP_CONST ||
2721 o->op_type == OP_GV) )
2723 op_getmad(from,(OP*)mp->mad_val,slot);
2730 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
2733 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
2739 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
2748 /* pretend constant fold didn't happen? */
2749 if (mp->mad_key == 'f' &&
2750 (o->op_type == OP_CONST ||
2751 o->op_type == OP_GV) )
2753 op_getmad(from,(OP*)mp->mad_val,slot);
2760 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
2763 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
2767 PerlIO_printf(PerlIO_stderr(),
2768 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
2774 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
2792 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
2796 addmad(tm, &(o->op_madprop), slot);
2800 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
2821 Perl_newMADsv(pTHX_ char key, SV* sv)
2823 return newMADPROP(key, MAD_SV, sv, 0);
2827 Perl_newMADPROP(pTHX_ char key, char type, const void* val, I32 vlen)
2830 Newxz(mp, 1, MADPROP);
2833 mp->mad_vlen = vlen;
2834 mp->mad_type = type;
2836 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
2841 Perl_mad_free(pTHX_ MADPROP* mp)
2843 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
2847 mad_free(mp->mad_next);
2848 /* if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
2849 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
2850 switch (mp->mad_type) {
2854 Safefree((char*)mp->mad_val);
2857 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
2858 op_free((OP*)mp->mad_val);
2861 sv_free((SV*)mp->mad_val);
2864 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
2873 Perl_newNULLLIST(pTHX)
2875 return newOP(OP_STUB, 0);
2879 Perl_force_list(pTHX_ OP *o)
2881 if (!o || o->op_type != OP_LIST)
2882 o = newLISTOP(OP_LIST, 0, o, NULL);
2888 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2893 NewOp(1101, listop, 1, LISTOP);
2895 listop->op_type = (OPCODE)type;
2896 listop->op_ppaddr = PL_ppaddr[type];
2899 listop->op_flags = (U8)flags;
2903 else if (!first && last)
2906 first->op_sibling = last;
2907 listop->op_first = first;
2908 listop->op_last = last;
2909 if (type == OP_LIST) {
2910 OP* const pushop = newOP(OP_PUSHMARK, 0);
2911 pushop->op_sibling = first;
2912 listop->op_first = pushop;
2913 listop->op_flags |= OPf_KIDS;
2915 listop->op_last = pushop;
2918 return CHECKOP(type, listop);
2922 Perl_newOP(pTHX_ I32 type, I32 flags)
2926 NewOp(1101, o, 1, OP);
2927 o->op_type = (OPCODE)type;
2928 o->op_ppaddr = PL_ppaddr[type];
2929 o->op_flags = (U8)flags;
2931 o->op_latefreed = 0;
2935 o->op_private = (U8)(0 | (flags >> 8));
2936 if (PL_opargs[type] & OA_RETSCALAR)
2938 if (PL_opargs[type] & OA_TARGET)
2939 o->op_targ = pad_alloc(type, SVs_PADTMP);
2940 return CHECKOP(type, o);
2944 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2950 first = newOP(OP_STUB, 0);
2951 if (PL_opargs[type] & OA_MARK)
2952 first = force_list(first);
2954 NewOp(1101, unop, 1, UNOP);
2955 unop->op_type = (OPCODE)type;
2956 unop->op_ppaddr = PL_ppaddr[type];
2957 unop->op_first = first;
2958 unop->op_flags = (U8)(flags | OPf_KIDS);
2959 unop->op_private = (U8)(1 | (flags >> 8));
2960 unop = (UNOP*) CHECKOP(type, unop);
2964 return fold_constants((OP *) unop);
2968 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2972 NewOp(1101, binop, 1, BINOP);
2975 first = newOP(OP_NULL, 0);
2977 binop->op_type = (OPCODE)type;
2978 binop->op_ppaddr = PL_ppaddr[type];
2979 binop->op_first = first;
2980 binop->op_flags = (U8)(flags | OPf_KIDS);
2983 binop->op_private = (U8)(1 | (flags >> 8));
2986 binop->op_private = (U8)(2 | (flags >> 8));
2987 first->op_sibling = last;
2990 binop = (BINOP*)CHECKOP(type, binop);
2991 if (binop->op_next || binop->op_type != (OPCODE)type)
2994 binop->op_last = binop->op_first->op_sibling;
2996 return fold_constants((OP *)binop);
2999 static int uvcompare(const void *a, const void *b)
3000 __attribute__nonnull__(1)
3001 __attribute__nonnull__(2)
3002 __attribute__pure__;
3003 static int uvcompare(const void *a, const void *b)
3005 if (*((const UV *)a) < (*(const UV *)b))
3007 if (*((const UV *)a) > (*(const UV *)b))
3009 if (*((const UV *)a+1) < (*(const UV *)b+1))
3011 if (*((const UV *)a+1) > (*(const UV *)b+1))
3017 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
3020 SV * const tstr = ((SVOP*)expr)->op_sv;
3023 (repl->op_type == OP_NULL)
3024 ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
3026 ((SVOP*)repl)->op_sv;
3029 const U8 *t = (U8*)SvPV_const(tstr, tlen);
3030 const U8 *r = (U8*)SvPV_const(rstr, rlen);
3034 register short *tbl;
3036 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
3037 const I32 squash = o->op_private & OPpTRANS_SQUASH;
3038 I32 del = o->op_private & OPpTRANS_DELETE;
3040 PL_hints |= HINT_BLOCK_SCOPE;
3043 o->op_private |= OPpTRANS_FROM_UTF;
3046 o->op_private |= OPpTRANS_TO_UTF;
3048 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
3049 SV* const listsv = newSVpvs("# comment\n");
3051 const U8* tend = t + tlen;
3052 const U8* rend = r + rlen;
3066 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
3067 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
3070 const U32 flags = UTF8_ALLOW_DEFAULT;
3074 t = tsave = bytes_to_utf8(t, &len);
3077 if (!to_utf && rlen) {
3079 r = rsave = bytes_to_utf8(r, &len);
3083 /* There are several snags with this code on EBCDIC:
3084 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
3085 2. scan_const() in toke.c has encoded chars in native encoding which makes
3086 ranges at least in EBCDIC 0..255 range the bottom odd.
3090 U8 tmpbuf[UTF8_MAXBYTES+1];
3093 Newx(cp, 2*tlen, UV);
3095 transv = newSVpvs("");
3097 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3099 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
3101 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3105 cp[2*i+1] = cp[2*i];
3109 qsort(cp, i, 2*sizeof(UV), uvcompare);
3110 for (j = 0; j < i; j++) {
3112 diff = val - nextmin;
3114 t = uvuni_to_utf8(tmpbuf,nextmin);
3115 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3117 U8 range_mark = UTF_TO_NATIVE(0xff);
3118 t = uvuni_to_utf8(tmpbuf, val - 1);
3119 sv_catpvn(transv, (char *)&range_mark, 1);
3120 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3127 t = uvuni_to_utf8(tmpbuf,nextmin);
3128 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3130 U8 range_mark = UTF_TO_NATIVE(0xff);
3131 sv_catpvn(transv, (char *)&range_mark, 1);
3133 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
3134 UNICODE_ALLOW_SUPER);
3135 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3136 t = (const U8*)SvPVX_const(transv);
3137 tlen = SvCUR(transv);
3141 else if (!rlen && !del) {
3142 r = t; rlen = tlen; rend = tend;
3145 if ((!rlen && !del) || t == r ||
3146 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
3148 o->op_private |= OPpTRANS_IDENTICAL;
3152 while (t < tend || tfirst <= tlast) {
3153 /* see if we need more "t" chars */
3154 if (tfirst > tlast) {
3155 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3157 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
3159 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3166 /* now see if we need more "r" chars */
3167 if (rfirst > rlast) {
3169 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3171 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
3173 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3182 rfirst = rlast = 0xffffffff;
3186 /* now see which range will peter our first, if either. */
3187 tdiff = tlast - tfirst;
3188 rdiff = rlast - rfirst;
3195 if (rfirst == 0xffffffff) {
3196 diff = tdiff; /* oops, pretend rdiff is infinite */
3198 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
3199 (long)tfirst, (long)tlast);
3201 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
3205 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
3206 (long)tfirst, (long)(tfirst + diff),
3209 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3210 (long)tfirst, (long)rfirst);
3212 if (rfirst + diff > max)
3213 max = rfirst + diff;
3215 grows = (tfirst < rfirst &&
3216 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3228 else if (max > 0xff)
3233 PerlMemShared_free(cPVOPo->op_pv);
3234 cPVOPo->op_pv = NULL;
3236 swash = (SV*)swash_init("utf8", "", listsv, bits, none);
3238 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
3239 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
3240 PAD_SETSV(cPADOPo->op_padix, swash);
3243 cSVOPo->op_sv = swash;
3245 SvREFCNT_dec(listsv);
3246 SvREFCNT_dec(transv);
3248 if (!del && havefinal && rlen)
3249 (void)hv_store((HV*)SvRV(swash), "FINAL", 5,
3250 newSVuv((UV)final), 0);
3253 o->op_private |= OPpTRANS_GROWS;
3259 op_getmad(expr,o,'e');
3260 op_getmad(repl,o,'r');
3268 tbl = (short*)cPVOPo->op_pv;
3270 Zero(tbl, 256, short);
3271 for (i = 0; i < (I32)tlen; i++)
3273 for (i = 0, j = 0; i < 256; i++) {
3275 if (j >= (I32)rlen) {
3284 if (i < 128 && r[j] >= 128)
3294 o->op_private |= OPpTRANS_IDENTICAL;
3296 else if (j >= (I32)rlen)
3301 PerlMemShared_realloc(tbl,
3302 (0x101+rlen-j) * sizeof(short));
3303 cPVOPo->op_pv = (char*)tbl;
3305 tbl[0x100] = (short)(rlen - j);
3306 for (i=0; i < (I32)rlen - j; i++)
3307 tbl[0x101+i] = r[j+i];
3311 if (!rlen && !del) {
3314 o->op_private |= OPpTRANS_IDENTICAL;
3316 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3317 o->op_private |= OPpTRANS_IDENTICAL;
3319 for (i = 0; i < 256; i++)
3321 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3322 if (j >= (I32)rlen) {
3324 if (tbl[t[i]] == -1)
3330 if (tbl[t[i]] == -1) {
3331 if (t[i] < 128 && r[j] >= 128)
3338 o->op_private |= OPpTRANS_GROWS;
3340 op_getmad(expr,o,'e');
3341 op_getmad(repl,o,'r');
3351 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3356 NewOp(1101, pmop, 1, PMOP);
3357 pmop->op_type = (OPCODE)type;
3358 pmop->op_ppaddr = PL_ppaddr[type];
3359 pmop->op_flags = (U8)flags;
3360 pmop->op_private = (U8)(0 | (flags >> 8));
3362 if (PL_hints & HINT_RE_TAINT)
3363 pmop->op_pmflags |= PMf_RETAINT;
3364 if (PL_hints & HINT_LOCALE)
3365 pmop->op_pmflags |= PMf_LOCALE;
3369 assert(SvPOK(PL_regex_pad[0]));
3370 if (SvCUR(PL_regex_pad[0])) {
3371 /* Pop off the "packed" IV from the end. */
3372 SV *const repointer_list = PL_regex_pad[0];
3373 const char *p = SvEND(repointer_list) - sizeof(IV);
3374 const IV offset = *((IV*)p);
3376 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
3378 SvEND_set(repointer_list, p);
3380 pmop->op_pmoffset = offset;
3381 /* This slot should be free, so assert this: */
3382 assert(PL_regex_pad[offset] == &PL_sv_undef);
3384 SV * const repointer = &PL_sv_undef;
3385 av_push(PL_regex_padav, repointer);
3386 pmop->op_pmoffset = av_len(PL_regex_padav);
3387 PL_regex_pad = AvARRAY(PL_regex_padav);
3391 return CHECKOP(type, pmop);
3394 /* Given some sort of match op o, and an expression expr containing a
3395 * pattern, either compile expr into a regex and attach it to o (if it's
3396 * constant), or convert expr into a runtime regcomp op sequence (if it's
3399 * isreg indicates that the pattern is part of a regex construct, eg
3400 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3401 * split "pattern", which aren't. In the former case, expr will be a list
3402 * if the pattern contains more than one term (eg /a$b/) or if it contains
3403 * a replacement, ie s/// or tr///.
3407 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
3412 I32 repl_has_vars = 0;
3416 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
3417 /* last element in list is the replacement; pop it */
3419 repl = cLISTOPx(expr)->op_last;
3420 kid = cLISTOPx(expr)->op_first;
3421 while (kid->op_sibling != repl)
3422 kid = kid->op_sibling;
3423 kid->op_sibling = NULL;
3424 cLISTOPx(expr)->op_last = kid;
3427 if (isreg && expr->op_type == OP_LIST &&
3428 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3430 /* convert single element list to element */
3431 OP* const oe = expr;
3432 expr = cLISTOPx(oe)->op_first->op_sibling;
3433 cLISTOPx(oe)->op_first->op_sibling = NULL;
3434 cLISTOPx(oe)->op_last = NULL;
3438 if (o->op_type == OP_TRANS) {
3439 return pmtrans(o, expr, repl);
3442 reglist = isreg && expr->op_type == OP_LIST;
3446 PL_hints |= HINT_BLOCK_SCOPE;
3449 if (expr->op_type == OP_CONST) {
3450 SV *pat = ((SVOP*)expr)->op_sv;
3451 U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
3453 if (o->op_flags & OPf_SPECIAL)
3454 pm_flags |= RXf_SPLIT;
3457 assert (SvUTF8(pat));
3458 } else if (SvUTF8(pat)) {
3459 /* Not doing UTF-8, despite what the SV says. Is this only if we're
3460 trapped in use 'bytes'? */
3461 /* Make a copy of the octet sequence, but without the flag on, as
3462 the compiler now honours the SvUTF8 flag on pat. */
3464 const char *const p = SvPV(pat, len);
3465 pat = newSVpvn_flags(p, len, SVs_TEMP);
3468 PM_SETRE(pm, CALLREGCOMP(pat, pm_flags));
3471 op_getmad(expr,(OP*)pm,'e');
3477 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3478 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3480 : OP_REGCMAYBE),0,expr);
3482 NewOp(1101, rcop, 1, LOGOP);
3483 rcop->op_type = OP_REGCOMP;
3484 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3485 rcop->op_first = scalar(expr);
3486 rcop->op_flags |= OPf_KIDS
3487 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3488 | (reglist ? OPf_STACKED : 0);
3489 rcop->op_private = 1;
3492 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3494 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
3497 /* establish postfix order */
3498 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3500 rcop->op_next = expr;
3501 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3504 rcop->op_next = LINKLIST(expr);
3505 expr->op_next = (OP*)rcop;
3508 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3513 if (pm->op_pmflags & PMf_EVAL) {
3515 if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
3516 CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
3518 else if (repl->op_type == OP_CONST)
3522 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3523 if (curop->op_type == OP_SCOPE
3524 || curop->op_type == OP_LEAVE
3525 || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
3526 if (curop->op_type == OP_GV) {
3527 GV * const gv = cGVOPx_gv(curop);
3529 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3532 else if (curop->op_type == OP_RV2CV)
3534 else if (curop->op_type == OP_RV2SV ||
3535 curop->op_type == OP_RV2AV ||
3536 curop->op_type == OP_RV2HV ||
3537 curop->op_type == OP_RV2GV) {
3538 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3541 else if (curop->op_type == OP_PADSV ||
3542 curop->op_type == OP_PADAV ||
3543 curop->op_type == OP_PADHV ||
3544 curop->op_type == OP_PADANY)
3548 else if (curop->op_type == OP_PUSHRE)
3549 NOOP; /* Okay here, dangerous in newASSIGNOP */
3559 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
3561 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3562 prepend_elem(o->op_type, scalar(repl), o);
3565 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3566 pm->op_pmflags |= PMf_MAYBE_CONST;
3568 NewOp(1101, rcop, 1, LOGOP);
3569 rcop->op_type = OP_SUBSTCONT;
3570 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3571 rcop->op_first = scalar(repl);
3572 rcop->op_flags |= OPf_KIDS;
3573 rcop->op_private = 1;
3576 /* establish postfix order */
3577 rcop->op_next = LINKLIST(repl);
3578 repl->op_next = (OP*)rcop;
3580 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
3581 assert(!(pm->op_pmflags & PMf_ONCE));
3582 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
3591 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3595 NewOp(1101, svop, 1, SVOP);
3596 svop->op_type = (OPCODE)type;
3597 svop->op_ppaddr = PL_ppaddr[type];
3599 svop->op_next = (OP*)svop;
3600 svop->op_flags = (U8)flags;
3601 if (PL_opargs[type] & OA_RETSCALAR)
3603 if (PL_opargs[type] & OA_TARGET)
3604 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3605 return CHECKOP(type, svop);
3610 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3614 NewOp(1101, padop, 1, PADOP);
3615 padop->op_type = (OPCODE)type;
3616 padop->op_ppaddr = PL_ppaddr[type];
3617 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3618 SvREFCNT_dec(PAD_SVl(padop->op_padix));
3619 PAD_SETSV(padop->op_padix, sv);
3622 padop->op_next = (OP*)padop;
3623 padop->op_flags = (U8)flags;
3624 if (PL_opargs[type] & OA_RETSCALAR)
3626 if (PL_opargs[type] & OA_TARGET)
3627 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3628 return CHECKOP(type, padop);
3633 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3639 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3641 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3646 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3650 NewOp(1101, pvop, 1, PVOP);
3651 pvop->op_type = (OPCODE)type;
3652 pvop->op_ppaddr = PL_ppaddr[type];
3654 pvop->op_next = (OP*)pvop;
3655 pvop->op_flags = (U8)flags;
3656 if (PL_opargs[type] & OA_RETSCALAR)
3658 if (PL_opargs[type] & OA_TARGET)
3659 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3660 return CHECKOP(type, pvop);
3668 Perl_package(pTHX_ OP *o)
3671 SV *const sv = cSVOPo->op_sv;
3676 save_hptr(&PL_curstash);
3677 save_item(PL_curstname);
3679 PL_curstash = gv_stashsv(sv, GV_ADD);
3681 sv_setsv(PL_curstname, sv);
3683 PL_hints |= HINT_BLOCK_SCOPE;
3684 PL_parser->copline = NOLINE;
3685 PL_parser->expect = XSTATE;
3690 if (!PL_madskills) {
3695 pegop = newOP(OP_NULL,0);
3696 op_getmad(o,pegop,'P');
3706 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3713 OP *pegop = newOP(OP_NULL,0);
3716 if (idop->op_type != OP_CONST)
3717 Perl_croak(aTHX_ "Module name must be constant");
3720 op_getmad(idop,pegop,'U');
3725 SV * const vesv = ((SVOP*)version)->op_sv;
3728 op_getmad(version,pegop,'V');
3729 if (!arg && !SvNIOKp(vesv)) {
3736 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3737 Perl_croak(aTHX_ "Version number must be constant number");
3739 /* Make copy of idop so we don't free it twice */
3740 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3742 /* Fake up a method call to VERSION */
3743 meth = newSVpvs_share("VERSION");
3744 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3745 append_elem(OP_LIST,
3746 prepend_elem(OP_LIST, pack, list(version)),
3747 newSVOP(OP_METHOD_NAMED, 0, meth)));
3751 /* Fake up an import/unimport */
3752 if (arg && arg->op_type == OP_STUB) {
3754 op_getmad(arg,pegop,'S');
3755 imop = arg; /* no import on explicit () */
3757 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3758 imop = NULL; /* use 5.0; */
3760 idop->op_private |= OPpCONST_NOVER;
3766 op_getmad(arg,pegop,'A');
3768 /* Make copy of idop so we don't free it twice */
3769 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3771 /* Fake up a method call to import/unimport */
3773 ? newSVpvs_share("import") : newSVpvs_share("unimport");
3774 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3775 append_elem(OP_LIST,
3776 prepend_elem(OP_LIST, pack, list(arg)),
3777 newSVOP(OP_METHOD_NAMED, 0, meth)));
3780 /* Fake up the BEGIN {}, which does its thing immediately. */
3782 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
3785 append_elem(OP_LINESEQ,
3786 append_elem(OP_LINESEQ,
3787 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
3788 newSTATEOP(0, NULL, veop)),
3789 newSTATEOP(0, NULL, imop) ));
3791 /* The "did you use incorrect case?" warning used to be here.
3792 * The problem is that on case-insensitive filesystems one
3793 * might get false positives for "use" (and "require"):
3794 * "use Strict" or "require CARP" will work. This causes
3795 * portability problems for the script: in case-strict
3796 * filesystems the script will stop working.
3798 * The "incorrect case" warning checked whether "use Foo"
3799 * imported "Foo" to your namespace, but that is wrong, too:
3800 * there is no requirement nor promise in the language that
3801 * a Foo.pm should or would contain anything in package "Foo".
3803 * There is very little Configure-wise that can be done, either:
3804 * the case-sensitivity of the build filesystem of Perl does not
3805 * help in guessing the case-sensitivity of the runtime environment.
3808 PL_hints |= HINT_BLOCK_SCOPE;
3809 PL_parser->copline = NOLINE;
3810 PL_parser->expect = XSTATE;
3811 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3814 if (!PL_madskills) {
3815 /* FIXME - don't allocate pegop if !PL_madskills */
3824 =head1 Embedding Functions
3826 =for apidoc load_module
3828 Loads the module whose name is pointed to by the string part of name.
3829 Note that the actual module name, not its filename, should be given.
3830 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3831 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3832 (or 0 for no flags). ver, if specified, provides version semantics
3833 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3834 arguments can be used to specify arguments to the module's import()
3835 method, similar to C<use Foo::Bar VERSION LIST>.
3840 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3843 va_start(args, ver);
3844 vload_module(flags, name, ver, &args);
3848 #ifdef PERL_IMPLICIT_CONTEXT
3850 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3854 va_start(args, ver);
3855 vload_module(flags, name, ver, &args);
3861 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3866 OP * const modname = newSVOP(OP_CONST, 0, name);
3867 modname->op_private |= OPpCONST_BARE;
3869 veop = newSVOP(OP_CONST, 0, ver);
3873 if (flags & PERL_LOADMOD_NOIMPORT) {
3874 imop = sawparens(newNULLLIST());
3876 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3877 imop = va_arg(*args, OP*);
3882 sv = va_arg(*args, SV*);
3884 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3885 sv = va_arg(*args, SV*);
3889 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
3890 * that it has a PL_parser to play with while doing that, and also
3891 * that it doesn't mess with any existing parser, by creating a tmp
3892 * new parser with lex_start(). This won't actually be used for much,
3893 * since pp_require() will create another parser for the real work. */
3896 SAVEVPTR(PL_curcop);
3897 lex_start(NULL, NULL, FALSE);
3898 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3899 veop, modname, imop);
3904 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
3910 if (!force_builtin) {
3911 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
3912 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
3913 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
3914 gv = gvp ? *gvp : NULL;
3918 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3919 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3920 append_elem(OP_LIST, term,
3921 scalar(newUNOP(OP_RV2CV, 0,
3922 newGVOP(OP_GV, 0, gv))))));
3925 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3931 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3933 return newBINOP(OP_LSLICE, flags,
3934 list(force_list(subscript)),
3935 list(force_list(listval)) );
3939 S_is_list_assignment(pTHX_ register const OP *o)
3947 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
3948 o = cUNOPo->op_first;
3950 flags = o->op_flags;
3952 if (type == OP_COND_EXPR) {
3953 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
3954 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3959 yyerror("Assignment to both a list and a scalar");
3963 if (type == OP_LIST &&
3964 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
3965 o->op_private & OPpLVAL_INTRO)
3968 if (type == OP_LIST || flags & OPf_PARENS ||
3969 type == OP_RV2AV || type == OP_RV2HV ||
3970 type == OP_ASLICE || type == OP_HSLICE)
3973 if (type == OP_PADAV || type == OP_PADHV)
3976 if (type == OP_RV2SV)
3983 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3989 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3990 return newLOGOP(optype, 0,
3991 mod(scalar(left), optype),
3992 newUNOP(OP_SASSIGN, 0, scalar(right)));
3995 return newBINOP(optype, OPf_STACKED,
3996 mod(scalar(left), optype), scalar(right));
4000 if (is_list_assignment(left)) {
4001 static const char no_list_state[] = "Initialization of state variables"
4002 " in list context currently forbidden";
4004 bool maybe_common_vars = TRUE;
4007 /* Grandfathering $[ assignment here. Bletch.*/
4008 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
4009 PL_eval_start = (left->op_type == OP_CONST) ? right : NULL;
4010 left = mod(left, OP_AASSIGN);
4013 else if (left->op_type == OP_CONST) {
4015 /* Result of assignment is always 1 (or we'd be dead already) */
4016 return newSVOP(OP_CONST, 0, newSViv(1));
4018 curop = list(force_list(left));
4019 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
4020 o->op_private = (U8)(0 | (flags >> 8));
4022 if ((left->op_type == OP_LIST
4023 || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
4025 OP* lop = ((LISTOP*)left)->op_first;
4026 maybe_common_vars = FALSE;
4028 if (lop->op_type == OP_PADSV ||
4029 lop->op_type == OP_PADAV ||
4030 lop->op_type == OP_PADHV ||
4031 lop->op_type == OP_PADANY) {
4032 if (!(lop->op_private & OPpLVAL_INTRO))
4033 maybe_common_vars = TRUE;
4035 if (lop->op_private & OPpPAD_STATE) {
4036 if (left->op_private & OPpLVAL_INTRO) {
4037 /* Each variable in state($a, $b, $c) = ... */
4040 /* Each state variable in
4041 (state $a, my $b, our $c, $d, undef) = ... */
4043 yyerror(no_list_state);
4045 /* Each my variable in
4046 (state $a, my $b, our $c, $d, undef) = ... */
4048 } else if (lop->op_type == OP_UNDEF ||
4049 lop->op_type == OP_PUSHMARK) {
4050 /* undef may be interesting in
4051 (state $a, undef, state $c) */
4053 /* Other ops in the list. */
4054 maybe_common_vars = TRUE;
4056 lop = lop->op_sibling;
4059 else if ((left->op_private & OPpLVAL_INTRO)
4060 && ( left->op_type == OP_PADSV
4061 || left->op_type == OP_PADAV
4062 || left->op_type == OP_PADHV
4063 || left->op_type == OP_PADANY))
4065 maybe_common_vars = FALSE;
4066 if (left->op_private & OPpPAD_STATE) {
4067 /* All single variable list context state assignments, hence
4077 yyerror(no_list_state);
4081 /* PL_generation sorcery:
4082 * an assignment like ($a,$b) = ($c,$d) is easier than
4083 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
4084 * To detect whether there are common vars, the global var
4085 * PL_generation is incremented for each assign op we compile.
4086 * Then, while compiling the assign op, we run through all the
4087 * variables on both sides of the assignment, setting a spare slot
4088 * in each of them to PL_generation. If any of them already have
4089 * that value, we know we've got commonality. We could use a
4090 * single bit marker, but then we'd have to make 2 passes, first
4091 * to clear the flag, then to test and set it. To find somewhere
4092 * to store these values, evil chicanery is done with SvUVX().
4095 if (maybe_common_vars) {
4098 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4099 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
4100 if (curop->op_type == OP_GV) {
4101 GV *gv = cGVOPx_gv(curop);
4103 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4105 GvASSIGN_GENERATION_set(gv, PL_generation);
4107 else if (curop->op_type == OP_PADSV ||
4108 curop->op_type == OP_PADAV ||
4109 curop->op_type == OP_PADHV ||
4110 curop->op_type == OP_PADANY)
4112 if (PAD_COMPNAME_GEN(curop->op_targ)
4113 == (STRLEN)PL_generation)
4115 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
4118 else if (curop->op_type == OP_RV2CV)
4120 else if (curop->op_type == OP_RV2SV ||
4121 curop->op_type == OP_RV2AV ||
4122 curop->op_type == OP_RV2HV ||
4123 curop->op_type == OP_RV2GV) {
4124 if (lastop->op_type != OP_GV) /* funny deref? */
4127 else if (curop->op_type == OP_PUSHRE) {
4129 if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
4130 GV *const gv = (GV*)PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff);
4132 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4134 GvASSIGN_GENERATION_set(gv, PL_generation);
4138 = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
4141 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4143 GvASSIGN_GENERATION_set(gv, PL_generation);
4153 o->op_private |= OPpASSIGN_COMMON;
4156 if (right && right->op_type == OP_SPLIT && !PL_madskills) {
4157 OP* tmpop = ((LISTOP*)right)->op_first;
4158 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
4159 PMOP * const pm = (PMOP*)tmpop;
4160 if (left->op_type == OP_RV2AV &&
4161 !(left->op_private & OPpLVAL_INTRO) &&
4162 !(o->op_private & OPpASSIGN_COMMON) )
4164 tmpop = ((UNOP*)left)->op_first;
4165 if (tmpop->op_type == OP_GV
4167 && !pm->op_pmreplrootu.op_pmtargetoff
4169 && !pm->op_pmreplrootu.op_pmtargetgv
4173 pm->op_pmreplrootu.op_pmtargetoff
4174 = cPADOPx(tmpop)->op_padix;
4175 cPADOPx(tmpop)->op_padix = 0; /* steal it */
4177 pm->op_pmreplrootu.op_pmtargetgv
4178 = (GV*)cSVOPx(tmpop)->op_sv;
4179 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
4181 pm->op_pmflags |= PMf_ONCE;
4182 tmpop = cUNOPo->op_first; /* to list (nulled) */
4183 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
4184 tmpop->op_sibling = NULL; /* don't free split */
4185 right->op_next = tmpop->op_next; /* fix starting loc */
4186 op_free(o); /* blow off assign */
4187 right->op_flags &= ~OPf_WANT;
4188 /* "I don't know and I don't care." */
4193 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
4194 ((LISTOP*)right)->op_last->op_type == OP_CONST)
4196 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
4198 sv_setiv(sv, PL_modcount+1);
4206 right = newOP(OP_UNDEF, 0);
4207 if (right->op_type == OP_READLINE) {
4208 right->op_flags |= OPf_STACKED;
4209 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
4212 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
4213 o = newBINOP(OP_SASSIGN, flags,
4214 scalar(right), mod(scalar(left), OP_SASSIGN) );
4220 o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
4221 o->op_private |= OPpCONST_ARYBASE;
4228 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
4231 const U32 seq = intro_my();
4234 NewOp(1101, cop, 1, COP);
4235 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
4236 cop->op_type = OP_DBSTATE;
4237 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
4240 cop->op_type = OP_NEXTSTATE;
4241 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
4243 cop->op_flags = (U8)flags;
4244 CopHINTS_set(cop, PL_hints);
4246 cop->op_private |= NATIVE_HINTS;
4248 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
4249 cop->op_next = (OP*)cop;
4252 CopLABEL_set(cop, label);
4253 PL_hints |= HINT_BLOCK_SCOPE;
4256 /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
4257 CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
4259 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
4260 cop->cop_hints_hash = PL_curcop->cop_hints_hash;
4261 if (cop->cop_hints_hash) {
4263 cop->cop_hints_hash->refcounted_he_refcnt++;
4264 HINTS_REFCNT_UNLOCK;
4267 if (PL_parser && PL_parser->copline == NOLINE)
4268 CopLINE_set(cop, CopLINE(PL_curcop));
4270 CopLINE_set(cop, PL_parser->copline);
4272 PL_parser->copline = NOLINE;
4275 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
4277 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
4279 CopSTASH_set(cop, PL_curstash);
4281 if (PERLDB_LINE && PL_curstash != PL_debstash) {
4282 AV *av = CopFILEAVx(PL_curcop);
4284 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
4285 if (svp && *svp != &PL_sv_undef ) {
4286 (void)SvIOK_on(*svp);
4287 SvIV_set(*svp, PTR2IV(cop));
4292 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
4297 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
4300 return new_logop(type, flags, &first, &other);
4304 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
4309 OP *first = *firstp;
4310 OP * const other = *otherp;
4312 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
4313 return newBINOP(type, flags, scalar(first), scalar(other));
4315 scalarboolean(first);
4316 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
4317 if (first->op_type == OP_NOT
4318 && (first->op_flags & OPf_SPECIAL)
4319 && (first->op_flags & OPf_KIDS)
4321 if (type == OP_AND || type == OP_OR) {
4327 first = *firstp = cUNOPo->op_first;
4329 first->op_next = o->op_next;
4330 cUNOPo->op_first = NULL;
4334 if (first->op_type == OP_CONST) {
4335 if (first->op_private & OPpCONST_STRICT)
4336 no_bareword_allowed(first);
4337 else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
4338 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
4339 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
4340 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
4341 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
4343 if (other->op_type == OP_CONST)
4344 other->op_private |= OPpCONST_SHORTCIRCUIT;
4346 OP *newop = newUNOP(OP_NULL, 0, other);
4347 op_getmad(first, newop, '1');
4348 newop->op_targ = type; /* set "was" field */
4355 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
4356 const OP *o2 = other;
4357 if ( ! (o2->op_type == OP_LIST
4358 && (( o2 = cUNOPx(o2)->op_first))
4359 && o2->op_type == OP_PUSHMARK
4360 && (( o2 = o2->op_sibling)) )
4363 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
4364 || o2->op_type == OP_PADHV)
4365 && o2->op_private & OPpLVAL_INTRO
4366 && !(o2->op_private & OPpPAD_STATE)
4367 && ckWARN(WARN_DEPRECATED))
4369 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4370 "Deprecated use of my() in false conditional");
4374 if (first->op_type == OP_CONST)
4375 first->op_private |= OPpCONST_SHORTCIRCUIT;
4377 first = newUNOP(OP_NULL, 0, first);
4378 op_getmad(other, first, '2');
4379 first->op_targ = type; /* set "was" field */
4386 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
4387 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
4389 const OP * const k1 = ((UNOP*)first)->op_first;
4390 const OP * const k2 = k1->op_sibling;
4392 switch (first->op_type)
4395 if (k2 && k2->op_type == OP_READLINE
4396 && (k2->op_flags & OPf_STACKED)
4397 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4399 warnop = k2->op_type;
4404 if (k1->op_type == OP_READDIR
4405 || k1->op_type == OP_GLOB
4406 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4407 || k1->op_type == OP_EACH)
4409 warnop = ((k1->op_type == OP_NULL)
4410 ? (OPCODE)k1->op_targ : k1->op_type);
4415 const line_t oldline = CopLINE(PL_curcop);
4416 CopLINE_set(PL_curcop, PL_parser->copline);
4417 Perl_warner(aTHX_ packWARN(WARN_MISC),
4418 "Value of %s%s can be \"0\"; test with defined()",
4420 ((warnop == OP_READLINE || warnop == OP_GLOB)
4421 ? " construct" : "() operator"));
4422 CopLINE_set(PL_curcop, oldline);
4429 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
4430 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
4432 NewOp(1101, logop, 1, LOGOP);
4434 logop->op_type = (OPCODE)type;
4435 logop->op_ppaddr = PL_ppaddr[type];
4436 logop->op_first = first;
4437 logop->op_flags = (U8)(flags | OPf_KIDS);
4438 logop->op_other = LINKLIST(other);
4439 logop->op_private = (U8)(1 | (flags >> 8));
4441 /* establish postfix order */
4442 logop->op_next = LINKLIST(first);
4443 first->op_next = (OP*)logop;
4444 first->op_sibling = other;
4446 CHECKOP(type,logop);
4448 o = newUNOP(OP_NULL, 0, (OP*)logop);
4455 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
4463 return newLOGOP(OP_AND, 0, first, trueop);
4465 return newLOGOP(OP_OR, 0, first, falseop);
4467 scalarboolean(first);
4468 if (first->op_type == OP_CONST) {
4469 /* Left or right arm of the conditional? */
4470 const bool left = SvTRUE(((SVOP*)first)->op_sv);
4471 OP *live = left ? trueop : falseop;
4472 OP *const dead = left ? falseop : trueop;
4473 if (first->op_private & OPpCONST_BARE &&
4474 first->op_private & OPpCONST_STRICT) {
4475 no_bareword_allowed(first);
4478 /* This is all dead code when PERL_MAD is not defined. */
4479 live = newUNOP(OP_NULL, 0, live);
4480 op_getmad(first, live, 'C');
4481 op_getmad(dead, live, left ? 'e' : 't');
4488 NewOp(1101, logop, 1, LOGOP);
4489 logop->op_type = OP_COND_EXPR;
4490 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4491 logop->op_first = first;
4492 logop->op_flags = (U8)(flags | OPf_KIDS);
4493 logop->op_private = (U8)(1 | (flags >> 8));
4494 logop->op_other = LINKLIST(trueop);
4495 logop->op_next = LINKLIST(falseop);
4497 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
4500 /* establish postfix order */
4501 start = LINKLIST(first);
4502 first->op_next = (OP*)logop;
4504 first->op_sibling = trueop;
4505 trueop->op_sibling = falseop;
4506 o = newUNOP(OP_NULL, 0, (OP*)logop);
4508 trueop->op_next = falseop->op_next = o;
4515 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4524 NewOp(1101, range, 1, LOGOP);
4526 range->op_type = OP_RANGE;
4527 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4528 range->op_first = left;
4529 range->op_flags = OPf_KIDS;
4530 leftstart = LINKLIST(left);
4531 range->op_other = LINKLIST(right);
4532 range->op_private = (U8)(1 | (flags >> 8));
4534 left->op_sibling = right;
4536 range->op_next = (OP*)range;
4537 flip = newUNOP(OP_FLIP, flags, (OP*)range);
4538 flop = newUNOP(OP_FLOP, 0, flip);
4539 o = newUNOP(OP_NULL, 0, flop);
4541 range->op_next = leftstart;
4543 left->op_next = flip;
4544 right->op_next = flop;
4546 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4547 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4548 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4549 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4551 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4552 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4555 if (!flip->op_private || !flop->op_private)
4556 linklist(o); /* blow off optimizer unless constant */
4562 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4567 const bool once = block && block->op_flags & OPf_SPECIAL &&
4568 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4570 PERL_UNUSED_ARG(debuggable);
4573 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4574 return block; /* do {} while 0 does once */
4575 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4576 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4577 expr = newUNOP(OP_DEFINED, 0,
4578 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4579 } else if (expr->op_flags & OPf_KIDS) {
4580 const OP * const k1 = ((UNOP*)expr)->op_first;
4581 const OP * const k2 = k1 ? k1->op_sibling : NULL;
4582 switch (expr->op_type) {
4584 if (k2 && k2->op_type == OP_READLINE
4585 && (k2->op_flags & OPf_STACKED)
4586 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4587 expr = newUNOP(OP_DEFINED, 0, expr);
4591 if (k1 && (k1->op_type == OP_READDIR
4592 || k1->op_type == OP_GLOB
4593 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4594 || k1->op_type == OP_EACH))
4595 expr = newUNOP(OP_DEFINED, 0, expr);
4601 /* if block is null, the next append_elem() would put UNSTACK, a scalar
4602 * op, in listop. This is wrong. [perl #27024] */
4604 block = newOP(OP_NULL, 0);
4605 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4606 o = new_logop(OP_AND, 0, &expr, &listop);
4609 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4611 if (once && o != listop)
4612 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4615 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
4617 o->op_flags |= flags;
4619 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4624 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
4625 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
4634 PERL_UNUSED_ARG(debuggable);
4637 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4638 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4639 expr = newUNOP(OP_DEFINED, 0,
4640 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4641 } else if (expr->op_flags & OPf_KIDS) {
4642 const OP * const k1 = ((UNOP*)expr)->op_first;
4643 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
4644 switch (expr->op_type) {
4646 if (k2 && k2->op_type == OP_READLINE
4647 && (k2->op_flags & OPf_STACKED)
4648 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4649 expr = newUNOP(OP_DEFINED, 0, expr);
4653 if (k1 && (k1->op_type == OP_READDIR
4654 || k1->op_type == OP_GLOB
4655 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4656 || k1->op_type == OP_EACH))
4657 expr = newUNOP(OP_DEFINED, 0, expr);
4664 block = newOP(OP_NULL, 0);
4665 else if (cont || has_my) {
4666 block = scope(block);
4670 next = LINKLIST(cont);
4673 OP * const unstack = newOP(OP_UNSTACK, 0);
4676 cont = append_elem(OP_LINESEQ, cont, unstack);
4680 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4682 redo = LINKLIST(listop);
4685 PL_parser->copline = (line_t)whileline;
4687 o = new_logop(OP_AND, 0, &expr, &listop);
4688 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4689 op_free(expr); /* oops, it's a while (0) */
4691 return NULL; /* listop already freed by new_logop */
4694 ((LISTOP*)listop)->op_last->op_next =
4695 (o == listop ? redo : LINKLIST(o));
4701 NewOp(1101,loop,1,LOOP);
4702 loop->op_type = OP_ENTERLOOP;
4703 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4704 loop->op_private = 0;
4705 loop->op_next = (OP*)loop;
4708 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4710 loop->op_redoop = redo;
4711 loop->op_lastop = o;
4712 o->op_private |= loopflags;
4715 loop->op_nextop = next;
4717 loop->op_nextop = o;
4719 o->op_flags |= flags;
4720 o->op_private |= (flags >> 8);
4725 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
4730 PADOFFSET padoff = 0;
4736 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4737 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
4738 sv->op_type = OP_RV2GV;
4739 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4741 /* The op_type check is needed to prevent a possible segfault
4742 * if the loop variable is undeclared and 'strict vars' is in
4743 * effect. This is illegal but is nonetheless parsed, so we
4744 * may reach this point with an OP_CONST where we're expecting
4747 if (cUNOPx(sv)->op_first->op_type == OP_GV
4748 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
4749 iterpflags |= OPpITER_DEF;
4751 else if (sv->op_type == OP_PADSV) { /* private variable */
4752 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
4753 padoff = sv->op_targ;
4763 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4765 SV *const namesv = PAD_COMPNAME_SV(padoff);
4767 const char *const name = SvPV_const(namesv, len);
4769 if (len == 2 && name[0] == '$' && name[1] == '_')
4770 iterpflags |= OPpITER_DEF;
4774 const PADOFFSET offset = pad_findmy("$_");
4775 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
4776 sv = newGVOP(OP_GV, 0, PL_defgv);
4781 iterpflags |= OPpITER_DEF;
4783 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4784 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4785 iterflags |= OPf_STACKED;
4787 else if (expr->op_type == OP_NULL &&
4788 (expr->op_flags & OPf_KIDS) &&
4789 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4791 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4792 * set the STACKED flag to indicate that these values are to be
4793 * treated as min/max values by 'pp_iterinit'.
4795 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4796 LOGOP* const range = (LOGOP*) flip->op_first;
4797 OP* const left = range->op_first;
4798 OP* const right = left->op_sibling;
4801 range->op_flags &= ~OPf_KIDS;
4802 range->op_first = NULL;
4804 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4805 listop->op_first->op_next = range->op_next;
4806 left->op_next = range->op_other;
4807 right->op_next = (OP*)listop;
4808 listop->op_next = listop->op_first;
4811 op_getmad(expr,(OP*)listop,'O');
4815 expr = (OP*)(listop);
4817 iterflags |= OPf_STACKED;
4820 expr = mod(force_list(expr), OP_GREPSTART);
4823 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4824 append_elem(OP_LIST, expr, scalar(sv))));
4825 assert(!loop->op_next);
4826 /* for my $x () sets OPpLVAL_INTRO;
4827 * for our $x () sets OPpOUR_INTRO */
4828 loop->op_private = (U8)iterpflags;
4829 #ifdef PL_OP_SLAB_ALLOC
4832 NewOp(1234,tmp,1,LOOP);
4833 Copy(loop,tmp,1,LISTOP);
4834 S_op_destroy(aTHX_ (OP*)loop);
4838 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
4840 loop->op_targ = padoff;
4841 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
4843 op_getmad(madsv, (OP*)loop, 'v');
4844 PL_parser->copline = forline;
4845 return newSTATEOP(0, label, wop);
4849 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4854 if (type != OP_GOTO || label->op_type == OP_CONST) {
4855 /* "last()" means "last" */
4856 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4857 o = newOP(type, OPf_SPECIAL);
4859 o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
4860 ? SvPV_nolen_const(((SVOP*)label)->op_sv)
4864 op_getmad(label,o,'L');
4870 /* Check whether it's going to be a goto &function */
4871 if (label->op_type == OP_ENTERSUB
4872 && !(label->op_flags & OPf_STACKED))
4873 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4874 o = newUNOP(type, OPf_STACKED, label);
4876 PL_hints |= HINT_BLOCK_SCOPE;
4880 /* if the condition is a literal array or hash
4881 (or @{ ... } etc), make a reference to it.
4884 S_ref_array_or_hash(pTHX_ OP *cond)
4887 && (cond->op_type == OP_RV2AV
4888 || cond->op_type == OP_PADAV
4889 || cond->op_type == OP_RV2HV
4890 || cond->op_type == OP_PADHV))
4892 return newUNOP(OP_REFGEN,
4893 0, mod(cond, OP_REFGEN));
4899 /* These construct the optree fragments representing given()
4902 entergiven and enterwhen are LOGOPs; the op_other pointer
4903 points up to the associated leave op. We need this so we
4904 can put it in the context and make break/continue work.
4905 (Also, of course, pp_enterwhen will jump straight to
4906 op_other if the match fails.)
4910 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
4911 I32 enter_opcode, I32 leave_opcode,
4912 PADOFFSET entertarg)
4918 NewOp(1101, enterop, 1, LOGOP);
4919 enterop->op_type = enter_opcode;
4920 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
4921 enterop->op_flags = (U8) OPf_KIDS;
4922 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
4923 enterop->op_private = 0;
4925 o = newUNOP(leave_opcode, 0, (OP *) enterop);
4928 enterop->op_first = scalar(cond);
4929 cond->op_sibling = block;
4931 o->op_next = LINKLIST(cond);
4932 cond->op_next = (OP *) enterop;
4935 /* This is a default {} block */
4936 enterop->op_first = block;
4937 enterop->op_flags |= OPf_SPECIAL;
4939 o->op_next = (OP *) enterop;
4942 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
4943 entergiven and enterwhen both
4946 enterop->op_next = LINKLIST(block);
4947 block->op_next = enterop->op_other = o;
4952 /* Does this look like a boolean operation? For these purposes
4953 a boolean operation is:
4954 - a subroutine call [*]
4955 - a logical connective
4956 - a comparison operator
4957 - a filetest operator, with the exception of -s -M -A -C
4958 - defined(), exists() or eof()
4959 - /$re/ or $foo =~ /$re/
4961 [*] possibly surprising
4964 S_looks_like_bool(pTHX_ const OP *o)
4967 switch(o->op_type) {
4969 return looks_like_bool(cLOGOPo->op_first);
4973 looks_like_bool(cLOGOPo->op_first)
4974 && looks_like_bool(cLOGOPo->op_first->op_sibling));
4978 o->op_flags & OPf_KIDS
4979 && looks_like_bool(cUNOPo->op_first));
4983 case OP_NOT: case OP_XOR:
4984 /* Note that OP_DOR is not here */
4986 case OP_EQ: case OP_NE: case OP_LT:
4987 case OP_GT: case OP_LE: case OP_GE:
4989 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
4990 case OP_I_GT: case OP_I_LE: case OP_I_GE:
4992 case OP_SEQ: case OP_SNE: case OP_SLT:
4993 case OP_SGT: case OP_SLE: case OP_SGE:
4997 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
4998 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
4999 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
5000 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
5001 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
5002 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
5003 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
5004 case OP_FTTEXT: case OP_FTBINARY:
5006 case OP_DEFINED: case OP_EXISTS:
5007 case OP_MATCH: case OP_EOF:
5012 /* Detect comparisons that have been optimized away */
5013 if (cSVOPo->op_sv == &PL_sv_yes
5014 || cSVOPo->op_sv == &PL_sv_no)
5025 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
5029 return newGIVWHENOP(
5030 ref_array_or_hash(cond),
5032 OP_ENTERGIVEN, OP_LEAVEGIVEN,
5036 /* If cond is null, this is a default {} block */
5038 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
5040 const bool cond_llb = (!cond || looks_like_bool(cond));
5046 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
5048 scalar(ref_array_or_hash(cond)));
5051 return newGIVWHENOP(
5053 append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
5054 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
5058 =for apidoc cv_undef
5060 Clear out all the active components of a CV. This can happen either
5061 by an explicit C<undef &foo>, or by the reference count going to zero.
5062 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
5063 children can still follow the full lexical scope chain.
5069 Perl_cv_undef(pTHX_ CV *cv)
5073 DEBUG_X(PerlIO_printf(Perl_debug_log,
5074 "CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n",
5075 PTR2UV(cv), PTR2UV(PL_comppad))
5079 if (CvFILE(cv) && !CvISXSUB(cv)) {
5080 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
5081 Safefree(CvFILE(cv));
5086 if (!CvISXSUB(cv) && CvROOT(cv)) {
5087 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
5088 Perl_croak(aTHX_ "Can't undef active subroutine");
5091 PAD_SAVE_SETNULLPAD();
5093 op_free(CvROOT(cv));
5098 SvPOK_off((SV*)cv); /* forget prototype */
5103 /* remove CvOUTSIDE unless this is an undef rather than a free */
5104 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
5105 if (!CvWEAKOUTSIDE(cv))
5106 SvREFCNT_dec(CvOUTSIDE(cv));
5107 CvOUTSIDE(cv) = NULL;
5110 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
5113 if (CvISXSUB(cv) && CvXSUB(cv)) {
5116 /* delete all flags except WEAKOUTSIDE */
5117 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
5121 Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
5124 /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
5125 relying on SvCUR, and doubling up the buffer to hold CvFILE(). */
5126 if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
5127 || (p && (len != SvCUR(cv) /* Not the same length. */
5128 || memNE(p, SvPVX_const(cv), len))))
5129 && ckWARN_d(WARN_PROTOTYPE)) {
5130 SV* const msg = sv_newmortal();
5134 gv_efullname3(name = sv_newmortal(), gv, NULL);
5135 sv_setpvs(msg, "Prototype mismatch:");
5137 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
5139 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv));
5141 sv_catpvs(msg, ": none");
5142 sv_catpvs(msg, " vs ");
5144 Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
5146 sv_catpvs(msg, "none");
5147 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
5151 static void const_sv_xsub(pTHX_ CV* cv);
5155 =head1 Optree Manipulation Functions
5157 =for apidoc cv_const_sv
5159 If C<cv> is a constant sub eligible for inlining. returns the constant
5160 value returned by the sub. Otherwise, returns NULL.
5162 Constant subs can be created with C<newCONSTSUB> or as described in
5163 L<perlsub/"Constant Functions">.
5168 Perl_cv_const_sv(pTHX_ CV *cv)
5170 PERL_UNUSED_CONTEXT;
5173 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
5175 return CvCONST(cv) ? (SV*)CvXSUBANY(cv).any_ptr : NULL;
5178 /* op_const_sv: examine an optree to determine whether it's in-lineable.
5179 * Can be called in 3 ways:
5182 * look for a single OP_CONST with attached value: return the value
5184 * cv && CvCLONE(cv) && !CvCONST(cv)
5186 * examine the clone prototype, and if contains only a single
5187 * OP_CONST referencing a pad const, or a single PADSV referencing
5188 * an outer lexical, return a non-zero value to indicate the CV is
5189 * a candidate for "constizing" at clone time
5193 * We have just cloned an anon prototype that was marked as a const
5194 * candidiate. Try to grab the current value, and in the case of
5195 * PADSV, ignore it if it has multiple references. Return the value.
5199 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
5210 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
5211 o = cLISTOPo->op_first->op_sibling;
5213 for (; o; o = o->op_next) {
5214 const OPCODE type = o->op_type;
5216 if (sv && o->op_next == o)
5218 if (o->op_next != o) {
5219 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
5221 if (type == OP_DBSTATE)
5224 if (type == OP_LEAVESUB || type == OP_RETURN)
5228 if (type == OP_CONST && cSVOPo->op_sv)
5230 else if (cv && type == OP_CONST) {
5231 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5235 else if (cv && type == OP_PADSV) {
5236 if (CvCONST(cv)) { /* newly cloned anon */
5237 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5238 /* the candidate should have 1 ref from this pad and 1 ref
5239 * from the parent */
5240 if (!sv || SvREFCNT(sv) != 2)
5247 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
5248 sv = &PL_sv_undef; /* an arbitrary non-null value */
5263 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5266 /* This would be the return value, but the return cannot be reached. */
5267 OP* pegop = newOP(OP_NULL, 0);
5270 PERL_UNUSED_ARG(floor);
5280 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
5282 NORETURN_FUNCTION_END;
5287 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
5289 return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
5293 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5300 register CV *cv = NULL;
5302 /* If the subroutine has no body, no attributes, and no builtin attributes
5303 then it's just a sub declaration, and we may be able to get away with
5304 storing with a placeholder scalar in the symbol table, rather than a
5305 full GV and CV. If anything is present then it will take a full CV to
5307 const I32 gv_fetch_flags
5308 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5310 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
5311 const char * const name = o ? SvPV_nolen_const(cSVOPo->op_sv) : NULL;
5314 assert(proto->op_type == OP_CONST);
5315 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
5320 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
5321 SV * const sv = sv_newmortal();
5322 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
5323 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
5324 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
5325 aname = SvPVX_const(sv);
5330 gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
5331 : gv_fetchpv(aname ? aname
5332 : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5333 gv_fetch_flags, SVt_PVCV);
5335 if (!PL_madskills) {
5344 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
5345 maximum a prototype before. */
5346 if (SvTYPE(gv) > SVt_NULL) {
5347 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
5348 && ckWARN_d(WARN_PROTOTYPE))
5350 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
5352 cv_ckproto_len((CV*)gv, NULL, ps, ps_len);
5355 sv_setpvn((SV*)gv, ps, ps_len);
5357 sv_setiv((SV*)gv, -1);
5359 SvREFCNT_dec(PL_compcv);
5360 cv = PL_compcv = NULL;
5364 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
5366 #ifdef GV_UNIQUE_CHECK
5367 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
5368 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
5372 if (!block || !ps || *ps || attrs
5373 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5375 || block->op_type == OP_NULL
5380 const_sv = op_const_sv(block, NULL);
5383 const bool exists = CvROOT(cv) || CvXSUB(cv);
5385 #ifdef GV_UNIQUE_CHECK
5386 if (exists && GvUNIQUE(gv)) {
5387 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
5391 /* if the subroutine doesn't exist and wasn't pre-declared
5392 * with a prototype, assume it will be AUTOLOADed,
5393 * skipping the prototype check
5395 if (exists || SvPOK(cv))
5396 cv_ckproto_len(cv, gv, ps, ps_len);
5397 /* already defined (or promised)? */
5398 if (exists || GvASSUMECV(gv)) {
5401 || block->op_type == OP_NULL
5404 if (CvFLAGS(PL_compcv)) {
5405 /* might have had built-in attrs applied */
5406 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5408 /* just a "sub foo;" when &foo is already defined */
5409 SAVEFREESV(PL_compcv);
5414 && block->op_type != OP_NULL
5417 if (ckWARN(WARN_REDEFINE)
5419 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
5421 const line_t oldline = CopLINE(PL_curcop);
5422 if (PL_parser && PL_parser->copline != NOLINE)
5423 CopLINE_set(PL_curcop, PL_parser->copline);
5424 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5425 CvCONST(cv) ? "Constant subroutine %s redefined"
5426 : "Subroutine %s redefined", name);
5427 CopLINE_set(PL_curcop, oldline);
5430 if (!PL_minus_c) /* keep old one around for madskills */
5433 /* (PL_madskills unset in used file.) */
5441 SvREFCNT_inc_simple_void_NN(const_sv);
5443 assert(!CvROOT(cv) && !CvCONST(cv));
5444 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
5445 CvXSUBANY(cv).any_ptr = const_sv;
5446 CvXSUB(cv) = const_sv_xsub;
5452 cv = newCONSTSUB(NULL, name, const_sv);
5454 mro_method_changed_in( /* sub Foo::Bar () { 123 } */
5455 (CvGV(cv) && GvSTASH(CvGV(cv)))
5464 SvREFCNT_dec(PL_compcv);
5472 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
5473 * before we clobber PL_compcv.
5477 || block->op_type == OP_NULL
5481 /* Might have had built-in attributes applied -- propagate them. */
5482 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5483 if (CvGV(cv) && GvSTASH(CvGV(cv)))
5484 stash = GvSTASH(CvGV(cv));
5485 else if (CvSTASH(cv))
5486 stash = CvSTASH(cv);
5488 stash = PL_curstash;
5491 /* possibly about to re-define existing subr -- ignore old cv */
5492 rcv = (SV*)PL_compcv;
5493 if (name && GvSTASH(gv))
5494 stash = GvSTASH(gv);
5496 stash = PL_curstash;
5498 apply_attrs(stash, rcv, attrs, FALSE);
5500 if (cv) { /* must reuse cv if autoloaded */
5507 || block->op_type == OP_NULL) && !PL_madskills
5510 /* got here with just attrs -- work done, so bug out */
5511 SAVEFREESV(PL_compcv);
5514 /* transfer PL_compcv to cv */
5516 CvFLAGS(cv) = CvFLAGS(PL_compcv);
5517 if (!CvWEAKOUTSIDE(cv))
5518 SvREFCNT_dec(CvOUTSIDE(cv));
5519 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
5520 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
5521 CvOUTSIDE(PL_compcv) = 0;
5522 CvPADLIST(cv) = CvPADLIST(PL_compcv);
5523 CvPADLIST(PL_compcv) = 0;
5524 /* inner references to PL_compcv must be fixed up ... */
5525 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
5526 /* ... before we throw it away */
5527 SvREFCNT_dec(PL_compcv);
5529 if (PERLDB_INTER)/* Advice debugger on the new sub. */
5530 ++PL_sub_generation;
5537 if (strEQ(name, "import")) {
5538 PL_formfeed = (SV*)cv;
5539 Perl_warner(aTHX_ packWARN(WARN_VOID), "%lx\n", (long)cv);
5543 mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */
5547 CvFILE_set_from_cop(cv, PL_curcop);
5548 CvSTASH(cv) = PL_curstash;
5551 sv_setpvn((SV*)cv, ps, ps_len);
5553 if (PL_parser && PL_parser->error_count) {
5557 const char *s = strrchr(name, ':');
5559 if (strEQ(s, "BEGIN")) {
5560 const char not_safe[] =
5561 "BEGIN not safe after errors--compilation aborted";
5562 if (PL_in_eval & EVAL_KEEPERR)
5563 Perl_croak(aTHX_ not_safe);
5565 /* force display of errors found but not reported */
5566 sv_catpv(ERRSV, not_safe);
5567 Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
5577 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5578 mod(scalarseq(block), OP_LEAVESUBLV));
5579 block->op_attached = 1;
5582 /* This makes sub {}; work as expected. */
5583 if (block->op_type == OP_STUB) {
5584 OP* const newblock = newSTATEOP(0, NULL, 0);
5586 op_getmad(block,newblock,'B');
5593 block->op_attached = 1;
5594 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5596 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5597 OpREFCNT_set(CvROOT(cv), 1);
5598 CvSTART(cv) = LINKLIST(CvROOT(cv));
5599 CvROOT(cv)->op_next = 0;
5600 CALL_PEEP(CvSTART(cv));
5602 /* now that optimizer has done its work, adjust pad values */
5604 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
5607 assert(!CvCONST(cv));
5608 if (ps && !*ps && op_const_sv(block, cv))
5612 if (name || aname) {
5613 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5614 SV * const sv = newSV(0);
5615 SV * const tmpstr = sv_newmortal();
5616 GV * const db_postponed = gv_fetchpvs("DB::postponed",
5617 GV_ADDMULTI, SVt_PVHV);
5620 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5622 (long)PL_subline, (long)CopLINE(PL_curcop));
5623 gv_efullname3(tmpstr, gv, NULL);
5624 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
5625 SvCUR(tmpstr), sv, 0);
5626 hv = GvHVn(db_postponed);
5627 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
5628 CV * const pcv = GvCV(db_postponed);
5634 call_sv((SV*)pcv, G_DISCARD);
5639 if (name && ! (PL_parser && PL_parser->error_count))
5640 process_special_blocks(name, gv, cv);
5645 PL_parser->copline = NOLINE;
5651 S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
5654 const char *const colon = strrchr(fullname,':');
5655 const char *const name = colon ? colon + 1 : fullname;
5658 if (strEQ(name, "BEGIN")) {
5659 const I32 oldscope = PL_scopestack_ix;
5661 SAVECOPFILE(&PL_compiling);
5662 SAVECOPLINE(&PL_compiling);
5664 DEBUG_x( dump_sub(gv) );
5665 Perl_av_create_and_push(aTHX_ &PL_beginav, (SV*)cv);
5666 GvCV(gv) = 0; /* cv has been hijacked */
5667 call_list(oldscope, PL_beginav);
5669 PL_curcop = &PL_compiling;
5670 CopHINTS_set(&PL_compiling, PL_hints);
5677 if strEQ(name, "END") {
5678 DEBUG_x( dump_sub(gv) );
5679 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, (SV*)cv);
5682 } else if (*name == 'U') {
5683 if (strEQ(name, "UNITCHECK")) {
5684 /* It's never too late to run a unitcheck block */
5685 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, (SV*)cv);
5689 } else if (*name == 'C') {
5690 if (strEQ(name, "CHECK")) {
5691 if (PL_main_start && ckWARN(WARN_VOID))
5692 Perl_warner(aTHX_ packWARN(WARN_VOID),
5693 "Too late to run CHECK block");
5694 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, (SV*)cv);
5698 } else if (*name == 'I') {
5699 if (strEQ(name, "INIT")) {
5700 if (PL_main_start && ckWARN(WARN_VOID))
5701 Perl_warner(aTHX_ packWARN(WARN_VOID),
5702 "Too late to run INIT block");
5703 Perl_av_create_and_push(aTHX_ &PL_initav, (SV*)cv);
5709 DEBUG_x( dump_sub(gv) );
5710 GvCV(gv) = 0; /* cv has been hijacked */
5715 =for apidoc newCONSTSUB
5717 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5718 eligible for inlining at compile-time.
5724 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
5729 const char *const temp_p = CopFILE(PL_curcop);
5730 const STRLEN len = temp_p ? strlen(temp_p) : 0;
5732 SV *const temp_sv = CopFILESV(PL_curcop);
5734 const char *const temp_p = temp_sv ? SvPV_const(temp_sv, len) : NULL;
5736 char *const file = savepvn(temp_p, temp_p ? len : 0);
5740 if (IN_PERL_RUNTIME) {
5741 /* at runtime, it's not safe to manipulate PL_curcop: it may be
5742 * an op shared between threads. Use a non-shared COP for our
5744 SAVEVPTR(PL_curcop);
5745 PL_curcop = &PL_compiling;
5747 SAVECOPLINE(PL_curcop);
5748 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
5751 PL_hints &= ~HINT_BLOCK_SCOPE;
5754 SAVESPTR(PL_curstash);
5755 SAVECOPSTASH(PL_curcop);
5756 PL_curstash = stash;
5757 CopSTASH_set(PL_curcop,stash);
5760 /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
5761 and so doesn't get free()d. (It's expected to be from the C pre-
5762 processor __FILE__ directive). But we need a dynamically allocated one,
5763 and we need it to get freed. */
5764 cv = newXS_flags(name, const_sv_xsub, file, "", XS_DYNAMIC_FILENAME);
5765 CvXSUBANY(cv).any_ptr = sv;
5771 CopSTASH_free(PL_curcop);
5779 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
5780 const char *const filename, const char *const proto,
5783 CV *cv = newXS(name, subaddr, filename);
5785 if (flags & XS_DYNAMIC_FILENAME) {
5786 /* We need to "make arrangements" (ie cheat) to ensure that the
5787 filename lasts as long as the PVCV we just created, but also doesn't
5789 STRLEN filename_len = strlen(filename);
5790 STRLEN proto_and_file_len = filename_len;
5791 char *proto_and_file;
5795 proto_len = strlen(proto);
5796 proto_and_file_len += proto_len;
5798 Newx(proto_and_file, proto_and_file_len + 1, char);
5799 Copy(proto, proto_and_file, proto_len, char);
5800 Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
5803 proto_and_file = savepvn(filename, filename_len);
5806 /* This gets free()d. :-) */
5807 sv_usepvn_flags((SV*)cv, proto_and_file, proto_and_file_len,
5808 SV_HAS_TRAILING_NUL);
5810 /* This gives us the correct prototype, rather than one with the
5811 file name appended. */
5812 SvCUR_set(cv, proto_len);
5816 CvFILE(cv) = proto_and_file + proto_len;
5818 sv_setpv((SV *)cv, proto);
5824 =for apidoc U||newXS
5826 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
5827 static storage, as it is used directly as CvFILE(), without a copy being made.
5833 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
5836 GV * const gv = gv_fetchpv(name ? name :
5837 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5838 GV_ADDMULTI, SVt_PVCV);
5842 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
5844 if ((cv = (name ? GvCV(gv) : NULL))) {
5846 /* just a cached method */
5850 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5851 /* already defined (or promised) */
5852 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
5853 if (ckWARN(WARN_REDEFINE)) {
5854 GV * const gvcv = CvGV(cv);
5856 HV * const stash = GvSTASH(gvcv);
5858 const char *redefined_name = HvNAME_get(stash);
5859 if ( strEQ(redefined_name,"autouse") ) {
5860 const line_t oldline = CopLINE(PL_curcop);
5861 if (PL_parser && PL_parser->copline != NOLINE)
5862 CopLINE_set(PL_curcop, PL_parser->copline);
5863 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5864 CvCONST(cv) ? "Constant subroutine %s redefined"
5865 : "Subroutine %s redefined"
5867 CopLINE_set(PL_curcop, oldline);
5877 if (cv) /* must reuse cv if autoloaded */
5880 cv = (CV*)newSV_type(SVt_PVCV);
5884 mro_method_changed_in(GvSTASH(gv)); /* newXS */
5888 (void)gv_fetchfile(filename);
5889 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
5890 an external constant string */
5892 CvXSUB(cv) = subaddr;
5895 process_special_blocks(name, gv, cv);
5907 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5912 OP* pegop = newOP(OP_NULL, 0);
5916 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
5917 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
5919 #ifdef GV_UNIQUE_CHECK
5921 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5925 if ((cv = GvFORM(gv))) {
5926 if (ckWARN(WARN_REDEFINE)) {
5927 const line_t oldline = CopLINE(PL_curcop);
5928 if (PL_parser && PL_parser->copline != NOLINE)
5929 CopLINE_set(PL_curcop, PL_parser->copline);
5930 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5931 o ? "Format %"SVf" redefined"
5932 : "Format STDOUT redefined", SVfARG(cSVOPo->op_sv));
5933 CopLINE_set(PL_curcop, oldline);
5940 CvFILE_set_from_cop(cv, PL_curcop);
5943 pad_tidy(padtidy_FORMAT);
5944 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5945 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5946 OpREFCNT_set(CvROOT(cv), 1);
5947 CvSTART(cv) = LINKLIST(CvROOT(cv));
5948 CvROOT(cv)->op_next = 0;
5949 CALL_PEEP(CvSTART(cv));
5951 op_getmad(o,pegop,'n');
5952 op_getmad_weak(block, pegop, 'b');
5957 PL_parser->copline = NOLINE;
5965 Perl_newANONLIST(pTHX_ OP *o)
5967 return convert(OP_ANONLIST, OPf_SPECIAL, o);
5971 Perl_newANONHASH(pTHX_ OP *o)
5973 return convert(OP_ANONHASH, OPf_SPECIAL, o);
5977 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5979 return newANONATTRSUB(floor, proto, NULL, block);
5983 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5985 return newUNOP(OP_REFGEN, 0,
5986 newSVOP(OP_ANONCODE, 0,
5987 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5991 Perl_oopsAV(pTHX_ OP *o)
5994 switch (o->op_type) {
5996 o->op_type = OP_PADAV;
5997 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5998 return ref(o, OP_RV2AV);
6001 o->op_type = OP_RV2AV;
6002 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
6007 if (ckWARN_d(WARN_INTERNAL))
6008 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
6015 Perl_oopsHV(pTHX_ OP *o)
6018 switch (o->op_type) {
6021 o->op_type = OP_PADHV;
6022 o->op_ppaddr = PL_ppaddr[OP_PADHV];
6023 return ref(o, OP_RV2HV);
6027 o->op_type = OP_RV2HV;
6028 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
6033 if (ckWARN_d(WARN_INTERNAL))
6034 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
6041 Perl_newAVREF(pTHX_ OP *o)
6044 if (o->op_type == OP_PADANY) {
6045 o->op_type = OP_PADAV;
6046 o->op_ppaddr = PL_ppaddr[OP_PADAV];
6049 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
6050 && ckWARN(WARN_DEPRECATED)) {
6051 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
6052 "Using an array as a reference is deprecated");
6054 return newUNOP(OP_RV2AV, 0, scalar(o));
6058 Perl_newGVREF(pTHX_ I32 type, OP *o)
6060 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
6061 return newUNOP(OP_NULL, 0, o);
6062 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
6066 Perl_newHVREF(pTHX_ OP *o)
6069 if (o->op_type == OP_PADANY) {
6070 o->op_type = OP_PADHV;
6071 o->op_ppaddr = PL_ppaddr[OP_PADHV];
6074 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
6075 && ckWARN(WARN_DEPRECATED)) {
6076 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
6077 "Using a hash as a reference is deprecated");
6079 return newUNOP(OP_RV2HV, 0, scalar(o));
6083 Perl_newCVREF(pTHX_ I32 flags, OP *o)
6085 return newUNOP(OP_RV2CV, flags, scalar(o));
6089 Perl_newSVREF(pTHX_ OP *o)
6092 if (o->op_type == OP_PADANY) {
6093 o->op_type = OP_PADSV;
6094 o->op_ppaddr = PL_ppaddr[OP_PADSV];
6097 return newUNOP(OP_RV2SV, 0, scalar(o));
6100 /* Check routines. See the comments at the top of this file for details
6101 * on when these are called */
6104 Perl_ck_anoncode(pTHX_ OP *o)
6106 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
6108 cSVOPo->op_sv = NULL;
6113 Perl_ck_bitop(pTHX_ OP *o)
6116 #define OP_IS_NUMCOMPARE(op) \
6117 ((op) == OP_LT || (op) == OP_I_LT || \
6118 (op) == OP_GT || (op) == OP_I_GT || \
6119 (op) == OP_LE || (op) == OP_I_LE || \
6120 (op) == OP_GE || (op) == OP_I_GE || \
6121 (op) == OP_EQ || (op) == OP_I_EQ || \
6122 (op) == OP_NE || (op) == OP_I_NE || \
6123 (op) == OP_NCMP || (op) == OP_I_NCMP)
6124 o->op_private = (U8)(PL_hints & HINT_INTEGER);
6125 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
6126 && (o->op_type == OP_BIT_OR
6127 || o->op_type == OP_BIT_AND
6128 || o->op_type == OP_BIT_XOR))
6130 const OP * const left = cBINOPo->op_first;
6131 const OP * const right = left->op_sibling;
6132 if ((OP_IS_NUMCOMPARE(left->op_type) &&
6133 (left->op_flags & OPf_PARENS) == 0) ||
6134 (OP_IS_NUMCOMPARE(right->op_type) &&
6135 (right->op_flags & OPf_PARENS) == 0))
6136 if (ckWARN(WARN_PRECEDENCE))
6137 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
6138 "Possible precedence problem on bitwise %c operator",
6139 o->op_type == OP_BIT_OR ? '|'
6140 : o->op_type == OP_BIT_AND ? '&' : '^'
6147 Perl_ck_concat(pTHX_ OP *o)
6149 const OP * const kid = cUNOPo->op_first;
6150 PERL_UNUSED_CONTEXT;
6151 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
6152 !(kUNOP->op_first->op_flags & OPf_MOD))
6153 o->op_flags |= OPf_STACKED;
6158 Perl_ck_spair(pTHX_ OP *o)
6161 if (o->op_flags & OPf_KIDS) {
6164 const OPCODE type = o->op_type;
6165 o = modkids(ck_fun(o), type);
6166 kid = cUNOPo->op_first;
6167 newop = kUNOP->op_first->op_sibling;
6169 const OPCODE type = newop->op_type;
6170 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
6171 type == OP_PADAV || type == OP_PADHV ||
6172 type == OP_RV2AV || type == OP_RV2HV)
6176 op_getmad(kUNOP->op_first,newop,'K');
6178 op_free(kUNOP->op_first);
6180 kUNOP->op_first = newop;
6182 o->op_ppaddr = PL_ppaddr[++o->op_type];
6187 Perl_ck_delete(pTHX_ OP *o)
6191 if (o->op_flags & OPf_KIDS) {
6192 OP * const kid = cUNOPo->op_first;
6193 switch (kid->op_type) {
6195 o->op_flags |= OPf_SPECIAL;
6198 o->op_private |= OPpSLICE;
6201 o->op_flags |= OPf_SPECIAL;
6206 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
6215 Perl_ck_die(pTHX_ OP *o)
6218 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6224 Perl_ck_eof(pTHX_ OP *o)
6228 if (o->op_flags & OPf_KIDS) {
6229 if (cLISTOPo->op_first->op_type == OP_STUB) {
6231 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
6233 op_getmad(o,newop,'O');
6245 Perl_ck_eval(pTHX_ OP *o)
6248 PL_hints |= HINT_BLOCK_SCOPE;
6249 if (o->op_flags & OPf_KIDS) {
6250 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6253 o->op_flags &= ~OPf_KIDS;
6256 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
6262 cUNOPo->op_first = 0;
6267 NewOp(1101, enter, 1, LOGOP);
6268 enter->op_type = OP_ENTERTRY;
6269 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
6270 enter->op_private = 0;
6272 /* establish postfix order */
6273 enter->op_next = (OP*)enter;
6275 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
6276 o->op_type = OP_LEAVETRY;
6277 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
6278 enter->op_other = o;
6279 op_getmad(oldo,o,'O');
6293 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
6294 op_getmad(oldo,o,'O');
6296 o->op_targ = (PADOFFSET)PL_hints;
6297 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
6298 /* Store a copy of %^H that pp_entereval can pick up.
6299 OPf_SPECIAL flags the opcode as being for this purpose,
6300 so that it in turn will return a copy at every
6302 OP *hhop = newSVOP(OP_CONST, OPf_SPECIAL,
6303 (SV*)Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv)));
6304 cUNOPo->op_first->op_sibling = hhop;
6305 o->op_private |= OPpEVAL_HAS_HH;
6311 Perl_ck_exit(pTHX_ OP *o)
6314 HV * const table = GvHV(PL_hintgv);
6316 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
6317 if (svp && *svp && SvTRUE(*svp))
6318 o->op_private |= OPpEXIT_VMSISH;
6320 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6326 Perl_ck_exec(pTHX_ OP *o)
6328 if (o->op_flags & OPf_STACKED) {
6331 kid = cUNOPo->op_first->op_sibling;
6332 if (kid->op_type == OP_RV2GV)
6341 Perl_ck_exists(pTHX_ OP *o)
6345 if (o->op_flags & OPf_KIDS) {
6346 OP * const kid = cUNOPo->op_first;
6347 if (kid->op_type == OP_ENTERSUB) {
6348 (void) ref(kid, o->op_type);
6349 if (kid->op_type != OP_RV2CV
6350 && !(PL_parser && PL_parser->error_count))
6351 Perl_croak(aTHX_ "%s argument is not a subroutine name",
6353 o->op_private |= OPpEXISTS_SUB;
6355 else if (kid->op_type == OP_AELEM)
6356 o->op_flags |= OPf_SPECIAL;
6357 else if (kid->op_type != OP_HELEM)
6358 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
6366 Perl_ck_rvconst(pTHX_ register OP *o)
6369 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6371 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6372 if (o->op_type == OP_RV2CV)
6373 o->op_private &= ~1;
6375 if (kid->op_type == OP_CONST) {
6378 SV * const kidsv = kid->op_sv;
6380 /* Is it a constant from cv_const_sv()? */
6381 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
6382 SV * const rsv = SvRV(kidsv);
6383 const svtype type = SvTYPE(rsv);
6384 const char *badtype = NULL;
6386 switch (o->op_type) {
6388 if (type > SVt_PVMG)
6389 badtype = "a SCALAR";
6392 if (type != SVt_PVAV)
6393 badtype = "an ARRAY";
6396 if (type != SVt_PVHV)
6400 if (type != SVt_PVCV)
6405 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
6408 else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
6409 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
6410 /* If this is an access to a stash, disable "strict refs", because
6411 * stashes aren't auto-vivified at compile-time (unless we store
6412 * symbols in them), and we don't want to produce a run-time
6413 * stricture error when auto-vivifying the stash. */
6414 const char *s = SvPV_nolen(kidsv);
6415 const STRLEN l = SvCUR(kidsv);
6416 if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
6417 o->op_private &= ~HINT_STRICT_REFS;
6419 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
6420 const char *badthing;
6421 switch (o->op_type) {
6423 badthing = "a SCALAR";
6426 badthing = "an ARRAY";
6429 badthing = "a HASH";
6437 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
6438 SVfARG(kidsv), badthing);
6441 * This is a little tricky. We only want to add the symbol if we
6442 * didn't add it in the lexer. Otherwise we get duplicate strict
6443 * warnings. But if we didn't add it in the lexer, we must at
6444 * least pretend like we wanted to add it even if it existed before,
6445 * or we get possible typo warnings. OPpCONST_ENTERED says
6446 * whether the lexer already added THIS instance of this symbol.
6448 iscv = (o->op_type == OP_RV2CV) * 2;
6450 gv = gv_fetchsv(kidsv,
6451 iscv | !(kid->op_private & OPpCONST_ENTERED),
6454 : o->op_type == OP_RV2SV
6456 : o->op_type == OP_RV2AV
6458 : o->op_type == OP_RV2HV
6461 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
6463 kid->op_type = OP_GV;
6464 SvREFCNT_dec(kid->op_sv);
6466 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
6467 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
6468 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
6470 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc_simple_NN(gv));
6472 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
6474 kid->op_private = 0;
6475 kid->op_ppaddr = PL_ppaddr[OP_GV];
6482 Perl_ck_ftst(pTHX_ OP *o)
6485 const I32 type = o->op_type;
6487 if (o->op_flags & OPf_REF) {
6490 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
6491 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6492 const OPCODE kidtype = kid->op_type;
6494 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6495 OP * const newop = newGVOP(type, OPf_REF,
6496 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
6498 op_getmad(o,newop,'O');
6504 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o))
6505 o->op_private |= OPpFT_ACCESS;
6506 if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst)
6507 && kidtype != OP_STAT && kidtype != OP_LSTAT)
6508 o->op_private |= OPpFT_STACKED;
6516 if (type == OP_FTTTY)
6517 o = newGVOP(type, OPf_REF, PL_stdingv);
6519 o = newUNOP(type, 0, newDEFSVOP());
6520 op_getmad(oldo,o,'O');
6526 Perl_ck_fun(pTHX_ OP *o)
6529 const int type = o->op_type;
6530 register I32 oa = PL_opargs[type] >> OASHIFT;
6532 if (o->op_flags & OPf_STACKED) {
6533 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
6536 return no_fh_allowed(o);
6539 if (o->op_flags & OPf_KIDS) {
6540 OP **tokid = &cLISTOPo->op_first;
6541 register OP *kid = cLISTOPo->op_first;
6545 if (kid->op_type == OP_PUSHMARK ||
6546 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
6548 tokid = &kid->op_sibling;
6549 kid = kid->op_sibling;
6551 if (!kid && PL_opargs[type] & OA_DEFGV)
6552 *tokid = kid = newDEFSVOP();
6556 sibl = kid->op_sibling;
6558 if (!sibl && kid->op_type == OP_STUB) {
6565 /* list seen where single (scalar) arg expected? */
6566 if (numargs == 1 && !(oa >> 4)
6567 && kid->op_type == OP_LIST && type != OP_SCALAR)
6569 return too_many_arguments(o,PL_op_desc[type]);
6582 if ((type == OP_PUSH || type == OP_UNSHIFT)
6583 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
6584 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6585 "Useless use of %s with no values",
6588 if (kid->op_type == OP_CONST &&
6589 (kid->op_private & OPpCONST_BARE))
6591 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
6592 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
6593 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6594 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6595 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
6596 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6598 op_getmad(kid,newop,'K');
6603 kid->op_sibling = sibl;
6606 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
6607 bad_type(numargs, "array", PL_op_desc[type], kid);
6611 if (kid->op_type == OP_CONST &&
6612 (kid->op_private & OPpCONST_BARE))
6614 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
6615 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
6616 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6617 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6618 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
6619 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6621 op_getmad(kid,newop,'K');
6626 kid->op_sibling = sibl;
6629 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
6630 bad_type(numargs, "hash", PL_op_desc[type], kid);
6635 OP * const newop = newUNOP(OP_NULL, 0, kid);
6636 kid->op_sibling = 0;
6638 newop->op_next = newop;
6640 kid->op_sibling = sibl;
6645 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
6646 if (kid->op_type == OP_CONST &&
6647 (kid->op_private & OPpCONST_BARE))
6649 OP * const newop = newGVOP(OP_GV, 0,
6650 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
6651 if (!(o->op_private & 1) && /* if not unop */
6652 kid == cLISTOPo->op_last)
6653 cLISTOPo->op_last = newop;
6655 op_getmad(kid,newop,'K');
6661 else if (kid->op_type == OP_READLINE) {
6662 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
6663 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
6666 I32 flags = OPf_SPECIAL;
6670 /* is this op a FH constructor? */
6671 if (is_handle_constructor(o,numargs)) {
6672 const char *name = NULL;
6676 /* Set a flag to tell rv2gv to vivify
6677 * need to "prove" flag does not mean something
6678 * else already - NI-S 1999/05/07
6681 if (kid->op_type == OP_PADSV) {
6683 = PAD_COMPNAME_SV(kid->op_targ);
6684 name = SvPV_const(namesv, len);
6686 else if (kid->op_type == OP_RV2SV
6687 && kUNOP->op_first->op_type == OP_GV)
6689 GV * const gv = cGVOPx_gv(kUNOP->op_first);
6691 len = GvNAMELEN(gv);
6693 else if (kid->op_type == OP_AELEM
6694 || kid->op_type == OP_HELEM)
6697 OP *op = ((BINOP*)kid)->op_first;
6701 const char * const a =
6702 kid->op_type == OP_AELEM ?
6704 if (((op->op_type == OP_RV2AV) ||
6705 (op->op_type == OP_RV2HV)) &&
6706 (firstop = ((UNOP*)op)->op_first) &&
6707 (firstop->op_type == OP_GV)) {
6708 /* packagevar $a[] or $h{} */
6709 GV * const gv = cGVOPx_gv(firstop);
6717 else if (op->op_type == OP_PADAV
6718 || op->op_type == OP_PADHV) {
6719 /* lexicalvar $a[] or $h{} */
6720 const char * const padname =
6721 PAD_COMPNAME_PV(op->op_targ);
6730 name = SvPV_const(tmpstr, len);
6735 name = "__ANONIO__";
6742 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
6743 namesv = PAD_SVl(targ);
6744 SvUPGRADE(namesv, SVt_PV);
6746 sv_setpvn(namesv, "$", 1);
6747 sv_catpvn(namesv, name, len);
6750 kid->op_sibling = 0;
6751 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
6752 kid->op_targ = targ;
6753 kid->op_private |= priv;
6755 kid->op_sibling = sibl;
6761 mod(scalar(kid), type);
6765 tokid = &kid->op_sibling;
6766 kid = kid->op_sibling;
6769 if (kid && kid->op_type != OP_STUB)
6770 return too_many_arguments(o,OP_DESC(o));
6771 o->op_private |= numargs;
6773 /* FIXME - should the numargs move as for the PERL_MAD case? */
6774 o->op_private |= numargs;
6776 return too_many_arguments(o,OP_DESC(o));
6780 else if (PL_opargs[type] & OA_DEFGV) {
6782 OP *newop = newUNOP(type, 0, newDEFSVOP());
6783 op_getmad(o,newop,'O');
6786 /* Ordering of these two is important to keep f_map.t passing. */
6788 return newUNOP(type, 0, newDEFSVOP());
6793 while (oa & OA_OPTIONAL)
6795 if (oa && oa != OA_LIST)
6796 return too_few_arguments(o,OP_DESC(o));
6802 Perl_ck_glob(pTHX_ OP *o)
6808 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
6809 append_elem(OP_GLOB, o, newDEFSVOP());
6811 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
6812 && GvCVu(gv) && GvIMPORTED_CV(gv)))
6814 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6817 #if !defined(PERL_EXTERNAL_GLOB)
6818 /* XXX this can be tightened up and made more failsafe. */
6819 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
6822 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
6823 newSVpvs("File::Glob"), NULL, NULL, NULL);
6824 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6825 glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
6826 GvCV(gv) = GvCV(glob_gv);
6827 SvREFCNT_inc_void((SV*)GvCV(gv));
6828 GvIMPORTED_CV_on(gv);
6831 #endif /* PERL_EXTERNAL_GLOB */
6833 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6834 append_elem(OP_GLOB, o,
6835 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
6836 o->op_type = OP_LIST;
6837 o->op_ppaddr = PL_ppaddr[OP_LIST];
6838 cLISTOPo->op_first->op_type = OP_PUSHMARK;
6839 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
6840 cLISTOPo->op_first->op_targ = 0;
6841 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
6842 append_elem(OP_LIST, o,
6843 scalar(newUNOP(OP_RV2CV, 0,
6844 newGVOP(OP_GV, 0, gv)))));
6845 o = newUNOP(OP_NULL, 0, ck_subr(o));
6846 o->op_targ = OP_GLOB; /* hint at what it used to be */
6849 gv = newGVgen("main");
6851 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
6857 Perl_ck_grep(pTHX_ OP *o)
6862 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
6865 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
6866 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
6868 if (o->op_flags & OPf_STACKED) {
6871 kid = cLISTOPo->op_first->op_sibling;
6872 if (!cUNOPx(kid)->op_next)
6873 Perl_croak(aTHX_ "panic: ck_grep");
6874 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
6877 NewOp(1101, gwop, 1, LOGOP);
6878 kid->op_next = (OP*)gwop;
6879 o->op_flags &= ~OPf_STACKED;
6881 kid = cLISTOPo->op_first->op_sibling;
6882 if (type == OP_MAPWHILE)
6887 if (PL_parser && PL_parser->error_count)
6889 kid = cLISTOPo->op_first->op_sibling;
6890 if (kid->op_type != OP_NULL)
6891 Perl_croak(aTHX_ "panic: ck_grep");
6892 kid = kUNOP->op_first;
6895 NewOp(1101, gwop, 1, LOGOP);
6896 gwop->op_type = type;
6897 gwop->op_ppaddr = PL_ppaddr[type];
6898 gwop->op_first = listkids(o);
6899 gwop->op_flags |= OPf_KIDS;
6900 gwop->op_other = LINKLIST(kid);
6901 kid->op_next = (OP*)gwop;
6902 offset = pad_findmy("$_");
6903 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
6904 o->op_private = gwop->op_private = 0;
6905 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
6908 o->op_private = gwop->op_private = OPpGREP_LEX;
6909 gwop->op_targ = o->op_targ = offset;
6912 kid = cLISTOPo->op_first->op_sibling;
6913 if (!kid || !kid->op_sibling)
6914 return too_few_arguments(o,OP_DESC(o));
6915 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
6916 mod(kid, OP_GREPSTART);
6922 Perl_ck_index(pTHX_ OP *o)
6924 if (o->op_flags & OPf_KIDS) {
6925 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6927 kid = kid->op_sibling; /* get past "big" */
6928 if (kid && kid->op_type == OP_CONST)
6929 fbm_compile(((SVOP*)kid)->op_sv, 0);
6935 Perl_ck_lengthconst(pTHX_ OP *o)
6937 /* XXX length optimization goes here */
6942 Perl_ck_lfun(pTHX_ OP *o)
6944 const OPCODE type = o->op_type;
6945 return modkids(ck_fun(o), type);
6949 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
6951 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
6952 switch (cUNOPo->op_first->op_type) {
6954 /* This is needed for
6955 if (defined %stash::)
6956 to work. Do not break Tk.
6958 break; /* Globals via GV can be undef */
6960 case OP_AASSIGN: /* Is this a good idea? */
6961 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6962 "defined(@array) is deprecated");
6963 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6964 "\t(Maybe you should just omit the defined()?)\n");
6967 /* This is needed for
6968 if (defined %stash::)
6969 to work. Do not break Tk.
6971 break; /* Globals via GV can be undef */
6973 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6974 "defined(%%hash) is deprecated");
6975 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6976 "\t(Maybe you should just omit the defined()?)\n");
6987 Perl_ck_readline(pTHX_ OP *o)
6989 if (!(o->op_flags & OPf_KIDS)) {
6991 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
6993 op_getmad(o,newop,'O');
7003 Perl_ck_rfun(pTHX_ OP *o)
7005 const OPCODE type = o->op_type;
7006 return refkids(ck_fun(o), type);
7010 Perl_ck_listiob(pTHX_ OP *o)
7014 kid = cLISTOPo->op_first;
7017 kid = cLISTOPo->op_first;
7019 if (kid->op_type == OP_PUSHMARK)
7020 kid = kid->op_sibling;
7021 if (kid && o->op_flags & OPf_STACKED)
7022 kid = kid->op_sibling;
7023 else if (kid && !kid->op_sibling) { /* print HANDLE; */
7024 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
7025 o->op_flags |= OPf_STACKED; /* make it a filehandle */
7026 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
7027 cLISTOPo->op_first->op_sibling = kid;
7028 cLISTOPo->op_last = kid;
7029 kid = kid->op_sibling;
7034 append_elem(o->op_type, o, newDEFSVOP());
7040 Perl_ck_smartmatch(pTHX_ OP *o)
7043 if (0 == (o->op_flags & OPf_SPECIAL)) {
7044 OP *first = cBINOPo->op_first;
7045 OP *second = first->op_sibling;
7047 /* Implicitly take a reference to an array or hash */
7048 first->op_sibling = NULL;
7049 first = cBINOPo->op_first = ref_array_or_hash(first);
7050 second = first->op_sibling = ref_array_or_hash(second);
7052 /* Implicitly take a reference to a regular expression */
7053 if (first->op_type == OP_MATCH) {
7054 first->op_type = OP_QR;
7055 first->op_ppaddr = PL_ppaddr[OP_QR];
7057 if (second->op_type == OP_MATCH) {
7058 second->op_type = OP_QR;
7059 second->op_ppaddr = PL_ppaddr[OP_QR];
7068 Perl_ck_sassign(pTHX_ OP *o)
7071 OP * const kid = cLISTOPo->op_first;
7072 /* has a disposable target? */
7073 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
7074 && !(kid->op_flags & OPf_STACKED)
7075 /* Cannot steal the second time! */
7076 && !(kid->op_private & OPpTARGET_MY)
7077 /* Keep the full thing for madskills */
7081 OP * const kkid = kid->op_sibling;
7083 /* Can just relocate the target. */
7084 if (kkid && kkid->op_type == OP_PADSV
7085 && !(kkid->op_private & OPpLVAL_INTRO))
7087 kid->op_targ = kkid->op_targ;
7089 /* Now we do not need PADSV and SASSIGN. */
7090 kid->op_sibling = o->op_sibling; /* NULL */
7091 cLISTOPo->op_first = NULL;
7094 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
7098 if (kid->op_sibling) {
7099 OP *kkid = kid->op_sibling;
7100 if (kkid->op_type == OP_PADSV
7101 && (kkid->op_private & OPpLVAL_INTRO)
7102 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
7103 const PADOFFSET target = kkid->op_targ;
7104 OP *const other = newOP(OP_PADSV,
7106 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
7107 OP *const first = newOP(OP_NULL, 0);
7108 OP *const nullop = newCONDOP(0, first, o, other);
7109 OP *const condop = first->op_next;
7110 /* hijacking PADSTALE for uninitialized state variables */
7111 SvPADSTALE_on(PAD_SVl(target));
7113 condop->op_type = OP_ONCE;
7114 condop->op_ppaddr = PL_ppaddr[OP_ONCE];
7115 condop->op_targ = target;
7116 other->op_targ = target;
7118 /* Because we change the type of the op here, we will skip the
7119 assinment binop->op_last = binop->op_first->op_sibling; at the
7120 end of Perl_newBINOP(). So need to do it here. */
7121 cBINOPo->op_last = cBINOPo->op_first->op_sibling;
7130 Perl_ck_match(pTHX_ OP *o)
7133 if (o->op_type != OP_QR && PL_compcv) {
7134 const PADOFFSET offset = pad_findmy("$_");
7135 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
7136 o->op_targ = offset;
7137 o->op_private |= OPpTARGET_MY;
7140 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
7141 o->op_private |= OPpRUNTIME;
7146 Perl_ck_method(pTHX_ OP *o)
7148 OP * const kid = cUNOPo->op_first;
7149 if (kid->op_type == OP_CONST) {
7150 SV* sv = kSVOP->op_sv;
7151 const char * const method = SvPVX_const(sv);
7152 if (!(strchr(method, ':') || strchr(method, '\''))) {
7154 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
7155 sv = newSVpvn_share(method, SvCUR(sv), 0);
7158 kSVOP->op_sv = NULL;
7160 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
7162 op_getmad(o,cmop,'O');
7173 Perl_ck_null(pTHX_ OP *o)
7175 PERL_UNUSED_CONTEXT;
7180 Perl_ck_open(pTHX_ OP *o)
7183 HV * const table = GvHV(PL_hintgv);
7185 SV **svp = hv_fetchs(table, "open_IN", FALSE);
7187 const I32 mode = mode_from_discipline(*svp);
7188 if (mode & O_BINARY)
7189 o->op_private |= OPpOPEN_IN_RAW;
7190 else if (mode & O_TEXT)
7191 o->op_private |= OPpOPEN_IN_CRLF;
7194 svp = hv_fetchs(table, "open_OUT", FALSE);
7196 const I32 mode = mode_from_discipline(*svp);
7197 if (mode & O_BINARY)
7198 o->op_private |= OPpOPEN_OUT_RAW;
7199 else if (mode & O_TEXT)
7200 o->op_private |= OPpOPEN_OUT_CRLF;
7203 if (o->op_type == OP_BACKTICK) {
7204 if (!(o->op_flags & OPf_KIDS)) {
7205 OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
7207 op_getmad(o,newop,'O');
7216 /* In case of three-arg dup open remove strictness
7217 * from the last arg if it is a bareword. */
7218 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
7219 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
7223 if ((last->op_type == OP_CONST) && /* The bareword. */
7224 (last->op_private & OPpCONST_BARE) &&
7225 (last->op_private & OPpCONST_STRICT) &&
7226 (oa = first->op_sibling) && /* The fh. */
7227 (oa = oa->op_sibling) && /* The mode. */
7228 (oa->op_type == OP_CONST) &&
7229 SvPOK(((SVOP*)oa)->op_sv) &&
7230 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
7231 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
7232 (last == oa->op_sibling)) /* The bareword. */
7233 last->op_private &= ~OPpCONST_STRICT;
7239 Perl_ck_repeat(pTHX_ OP *o)
7241 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
7242 o->op_private |= OPpREPEAT_DOLIST;
7243 cBINOPo->op_first = force_list(cBINOPo->op_first);
7251 Perl_ck_require(pTHX_ OP *o)
7256 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
7257 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7259 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
7260 SV * const sv = kid->op_sv;
7261 U32 was_readonly = SvREADONLY(sv);
7268 sv_force_normal_flags(sv, 0);
7269 assert(!SvREADONLY(sv));
7279 for (; s < end; s++) {
7280 if (*s == ':' && s[1] == ':') {
7282 Move(s+2, s+1, end - s - 1, char);
7287 sv_catpvs(sv, ".pm");
7288 SvFLAGS(sv) |= was_readonly;
7292 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
7293 /* handle override, if any */
7294 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
7295 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7296 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
7297 gv = gvp ? *gvp : NULL;
7301 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7302 OP * const kid = cUNOPo->op_first;
7305 cUNOPo->op_first = 0;
7309 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
7310 append_elem(OP_LIST, kid,
7311 scalar(newUNOP(OP_RV2CV, 0,
7314 op_getmad(o,newop,'O');
7322 Perl_ck_return(pTHX_ OP *o)
7325 if (CvLVALUE(PL_compcv)) {
7327 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
7328 mod(kid, OP_LEAVESUBLV);
7334 Perl_ck_select(pTHX_ OP *o)
7338 if (o->op_flags & OPf_KIDS) {
7339 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7340 if (kid && kid->op_sibling) {
7341 o->op_type = OP_SSELECT;
7342 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
7344 return fold_constants(o);
7348 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7349 if (kid && kid->op_type == OP_RV2GV)
7350 kid->op_private &= ~HINT_STRICT_REFS;
7355 Perl_ck_shift(pTHX_ OP *o)
7358 const I32 type = o->op_type;
7360 if (!(o->op_flags & OPf_KIDS)) {
7362 /* FIXME - this can be refactored to reduce code in #ifdefs */
7364 OP * const oldo = o;
7368 argop = newUNOP(OP_RV2AV, 0,
7369 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
7371 o = newUNOP(type, 0, scalar(argop));
7372 op_getmad(oldo,o,'O');
7375 return newUNOP(type, 0, scalar(argop));
7378 return scalar(modkids(ck_fun(o), type));
7382 Perl_ck_sort(pTHX_ OP *o)
7387 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
7388 HV * const hinthv = GvHV(PL_hintgv);
7390 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
7392 const I32 sorthints = (I32)SvIV(*svp);
7393 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
7394 o->op_private |= OPpSORT_QSORT;
7395 if ((sorthints & HINT_SORT_STABLE) != 0)
7396 o->op_private |= OPpSORT_STABLE;
7401 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
7403 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7404 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
7406 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
7408 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
7410 if (kid->op_type == OP_SCOPE) {
7414 else if (kid->op_type == OP_LEAVE) {
7415 if (o->op_type == OP_SORT) {
7416 op_null(kid); /* wipe out leave */
7419 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
7420 if (k->op_next == kid)
7422 /* don't descend into loops */
7423 else if (k->op_type == OP_ENTERLOOP
7424 || k->op_type == OP_ENTERITER)
7426 k = cLOOPx(k)->op_lastop;
7431 kid->op_next = 0; /* just disconnect the leave */
7432 k = kLISTOP->op_first;
7437 if (o->op_type == OP_SORT) {
7438 /* provide scalar context for comparison function/block */
7444 o->op_flags |= OPf_SPECIAL;
7446 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
7449 firstkid = firstkid->op_sibling;
7452 /* provide list context for arguments */
7453 if (o->op_type == OP_SORT)
7460 S_simplify_sort(pTHX_ OP *o)
7463 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7468 if (!(o->op_flags & OPf_STACKED))
7470 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7471 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
7472 kid = kUNOP->op_first; /* get past null */
7473 if (kid->op_type != OP_SCOPE)
7475 kid = kLISTOP->op_last; /* get past scope */
7476 switch(kid->op_type) {
7484 k = kid; /* remember this node*/
7485 if (kBINOP->op_first->op_type != OP_RV2SV)
7487 kid = kBINOP->op_first; /* get past cmp */
7488 if (kUNOP->op_first->op_type != OP_GV)
7490 kid = kUNOP->op_first; /* get past rv2sv */
7492 if (GvSTASH(gv) != PL_curstash)
7494 gvname = GvNAME(gv);
7495 if (*gvname == 'a' && gvname[1] == '\0')
7497 else if (*gvname == 'b' && gvname[1] == '\0')
7502 kid = k; /* back to cmp */
7503 if (kBINOP->op_last->op_type != OP_RV2SV)
7505 kid = kBINOP->op_last; /* down to 2nd arg */
7506 if (kUNOP->op_first->op_type != OP_GV)
7508 kid = kUNOP->op_first; /* get past rv2sv */
7510 if (GvSTASH(gv) != PL_curstash)
7512 gvname = GvNAME(gv);
7514 ? !(*gvname == 'a' && gvname[1] == '\0')
7515 : !(*gvname == 'b' && gvname[1] == '\0'))
7517 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
7519 o->op_private |= OPpSORT_DESCEND;
7520 if (k->op_type == OP_NCMP)
7521 o->op_private |= OPpSORT_NUMERIC;
7522 if (k->op_type == OP_I_NCMP)
7523 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
7524 kid = cLISTOPo->op_first->op_sibling;
7525 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
7527 op_getmad(kid,o,'S'); /* then delete it */
7529 op_free(kid); /* then delete it */
7534 Perl_ck_split(pTHX_ OP *o)
7539 if (o->op_flags & OPf_STACKED)
7540 return no_fh_allowed(o);
7542 kid = cLISTOPo->op_first;
7543 if (kid->op_type != OP_NULL)
7544 Perl_croak(aTHX_ "panic: ck_split");
7545 kid = kid->op_sibling;
7546 op_free(cLISTOPo->op_first);
7547 cLISTOPo->op_first = kid;
7549 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
7550 cLISTOPo->op_last = kid; /* There was only one element previously */
7553 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
7554 OP * const sibl = kid->op_sibling;
7555 kid->op_sibling = 0;
7556 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
7557 if (cLISTOPo->op_first == cLISTOPo->op_last)
7558 cLISTOPo->op_last = kid;
7559 cLISTOPo->op_first = kid;
7560 kid->op_sibling = sibl;
7563 kid->op_type = OP_PUSHRE;
7564 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
7566 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
7567 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
7568 "Use of /g modifier is meaningless in split");
7571 if (!kid->op_sibling)
7572 append_elem(OP_SPLIT, o, newDEFSVOP());
7574 kid = kid->op_sibling;
7577 if (!kid->op_sibling)
7578 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
7579 assert(kid->op_sibling);
7581 kid = kid->op_sibling;
7584 if (kid->op_sibling)
7585 return too_many_arguments(o,OP_DESC(o));
7591 Perl_ck_join(pTHX_ OP *o)
7593 const OP * const kid = cLISTOPo->op_first->op_sibling;
7594 if (kid && kid->op_type == OP_MATCH) {
7595 if (ckWARN(WARN_SYNTAX)) {
7596 const REGEXP *re = PM_GETRE(kPMOP);
7597 const char *pmstr = re ? RX_PRECOMP(re) : "STRING";
7598 const STRLEN len = re ? RX_PRELEN(re) : 6;
7599 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7600 "/%.*s/ should probably be written as \"%.*s\"",
7601 (int)len, pmstr, (int)len, pmstr);
7608 Perl_ck_subr(pTHX_ OP *o)
7611 OP *prev = ((cUNOPo->op_first->op_sibling)
7612 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
7613 OP *o2 = prev->op_sibling;
7615 const char *proto = NULL;
7616 const char *proto_end = NULL;
7621 I32 contextclass = 0;
7622 const char *e = NULL;
7625 o->op_private |= OPpENTERSUB_HASTARG;
7626 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
7627 if (cvop->op_type == OP_RV2CV) {
7629 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
7630 op_null(cvop); /* disable rv2cv */
7631 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
7632 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
7633 GV *gv = cGVOPx_gv(tmpop);
7636 tmpop->op_private |= OPpEARLY_CV;
7640 namegv = CvANON(cv) ? gv : CvGV(cv);
7641 proto = SvPV((SV*)cv, len);
7642 proto_end = proto + len;
7647 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7648 if (o2->op_type == OP_CONST)
7649 o2->op_private &= ~OPpCONST_STRICT;
7650 else if (o2->op_type == OP_LIST) {
7651 OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
7652 if (sib && sib->op_type == OP_CONST)
7653 sib->op_private &= ~OPpCONST_STRICT;
7656 o->op_private |= (PL_hints & HINT_STRICT_REFS);
7657 if (PERLDB_SUB && PL_curstash != PL_debstash)
7658 o->op_private |= OPpENTERSUB_DB;
7659 while (o2 != cvop) {
7661 if (PL_madskills && o2->op_type == OP_STUB) {
7662 o2 = o2->op_sibling;
7665 if (PL_madskills && o2->op_type == OP_NULL)
7666 o3 = ((UNOP*)o2)->op_first;
7670 if (proto >= proto_end)
7671 return too_many_arguments(o, gv_ename(namegv));
7679 /* _ must be at the end */
7680 if (proto[1] && proto[1] != ';')
7695 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
7697 arg == 1 ? "block or sub {}" : "sub {}",
7698 gv_ename(namegv), o3);
7701 /* '*' allows any scalar type, including bareword */
7704 if (o3->op_type == OP_RV2GV)
7705 goto wrapref; /* autoconvert GLOB -> GLOBref */
7706 else if (o3->op_type == OP_CONST)
7707 o3->op_private &= ~OPpCONST_STRICT;
7708 else if (o3->op_type == OP_ENTERSUB) {
7709 /* accidental subroutine, revert to bareword */
7710 OP *gvop = ((UNOP*)o3)->op_first;
7711 if (gvop && gvop->op_type == OP_NULL) {
7712 gvop = ((UNOP*)gvop)->op_first;
7714 for (; gvop->op_sibling; gvop = gvop->op_sibling)
7717 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
7718 (gvop = ((UNOP*)gvop)->op_first) &&
7719 gvop->op_type == OP_GV)
7721 GV * const gv = cGVOPx_gv(gvop);
7722 OP * const sibling = o2->op_sibling;
7723 SV * const n = newSVpvs("");
7725 OP * const oldo2 = o2;
7729 gv_fullname4(n, gv, "", FALSE);
7730 o2 = newSVOP(OP_CONST, 0, n);
7731 op_getmad(oldo2,o2,'O');
7732 prev->op_sibling = o2;
7733 o2->op_sibling = sibling;
7749 if (contextclass++ == 0) {
7750 e = strchr(proto, ']');
7751 if (!e || e == proto)
7760 const char *p = proto;
7761 const char *const end = proto;
7763 while (*--p != '[');
7764 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
7766 gv_ename(namegv), o3);
7771 if (o3->op_type == OP_RV2GV)
7774 bad_type(arg, "symbol", gv_ename(namegv), o3);
7777 if (o3->op_type == OP_ENTERSUB)
7780 bad_type(arg, "subroutine entry", gv_ename(namegv),
7784 if (o3->op_type == OP_RV2SV ||
7785 o3->op_type == OP_PADSV ||
7786 o3->op_type == OP_HELEM ||
7787 o3->op_type == OP_AELEM)
7790 bad_type(arg, "scalar", gv_ename(namegv), o3);
7793 if (o3->op_type == OP_RV2AV ||
7794 o3->op_type == OP_PADAV)
7797 bad_type(arg, "array", gv_ename(namegv), o3);
7800 if (o3->op_type == OP_RV2HV ||
7801 o3->op_type == OP_PADHV)
7804 bad_type(arg, "hash", gv_ename(namegv), o3);
7809 OP* const sib = kid->op_sibling;
7810 kid->op_sibling = 0;
7811 o2 = newUNOP(OP_REFGEN, 0, kid);
7812 o2->op_sibling = sib;
7813 prev->op_sibling = o2;
7815 if (contextclass && e) {
7830 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
7831 gv_ename(namegv), SVfARG(cv));
7836 mod(o2, OP_ENTERSUB);
7838 o2 = o2->op_sibling;
7840 if (o2 == cvop && proto && *proto == '_') {
7841 /* generate an access to $_ */
7843 o2->op_sibling = prev->op_sibling;
7844 prev->op_sibling = o2; /* instead of cvop */
7846 if (proto && !optional && proto_end > proto &&
7847 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
7848 return too_few_arguments(o, gv_ename(namegv));
7851 OP * const oldo = o;
7855 o=newSVOP(OP_CONST, 0, newSViv(0));
7856 op_getmad(oldo,o,'O');
7862 Perl_ck_svconst(pTHX_ OP *o)
7864 PERL_UNUSED_CONTEXT;
7865 SvREADONLY_on(cSVOPo->op_sv);
7870 Perl_ck_chdir(pTHX_ OP *o)
7872 if (o->op_flags & OPf_KIDS) {
7873 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7875 if (kid && kid->op_type == OP_CONST &&
7876 (kid->op_private & OPpCONST_BARE))
7878 o->op_flags |= OPf_SPECIAL;
7879 kid->op_private &= ~OPpCONST_STRICT;
7886 Perl_ck_trunc(pTHX_ OP *o)
7888 if (o->op_flags & OPf_KIDS) {
7889 SVOP *kid = (SVOP*)cUNOPo->op_first;
7891 if (kid->op_type == OP_NULL)
7892 kid = (SVOP*)kid->op_sibling;
7893 if (kid && kid->op_type == OP_CONST &&
7894 (kid->op_private & OPpCONST_BARE))
7896 o->op_flags |= OPf_SPECIAL;
7897 kid->op_private &= ~OPpCONST_STRICT;
7904 Perl_ck_unpack(pTHX_ OP *o)
7906 OP *kid = cLISTOPo->op_first;
7907 if (kid->op_sibling) {
7908 kid = kid->op_sibling;
7909 if (!kid->op_sibling)
7910 kid->op_sibling = newDEFSVOP();
7916 Perl_ck_substr(pTHX_ OP *o)
7919 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
7920 OP *kid = cLISTOPo->op_first;
7922 if (kid->op_type == OP_NULL)
7923 kid = kid->op_sibling;
7925 kid->op_flags |= OPf_MOD;
7932 Perl_ck_each(pTHX_ OP *o)
7935 OP *kid = cLISTOPo->op_first;
7937 if (kid->op_type == OP_PADAV || kid->op_type == OP_RV2AV) {
7938 const unsigned new_type = o->op_type == OP_EACH ? OP_AEACH
7939 : o->op_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
7940 o->op_type = new_type;
7941 o->op_ppaddr = PL_ppaddr[new_type];
7943 else if (!(kid->op_type == OP_PADHV || kid->op_type == OP_RV2HV
7944 || (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE)
7946 bad_type(1, "hash or array", PL_op_desc[o->op_type], kid);
7952 /* A peephole optimizer. We visit the ops in the order they're to execute.
7953 * See the comments at the top of this file for more details about when
7954 * peep() is called */
7957 Perl_peep(pTHX_ register OP *o)
7960 register OP* oldop = NULL;
7962 if (!o || o->op_opt)
7966 SAVEVPTR(PL_curcop);
7967 for (; o; o = o->op_next) {
7970 /* By default, this op has now been optimised. A couple of cases below
7971 clear this again. */
7974 switch (o->op_type) {
7978 PL_curcop = ((COP*)o); /* for warnings */
7982 if (cSVOPo->op_private & OPpCONST_STRICT)
7983 no_bareword_allowed(o);
7985 case OP_METHOD_NAMED:
7986 /* Relocate sv to the pad for thread safety.
7987 * Despite being a "constant", the SV is written to,
7988 * for reference counts, sv_upgrade() etc. */
7990 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
7991 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
7992 /* If op_sv is already a PADTMP then it is being used by
7993 * some pad, so make a copy. */
7994 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
7995 SvREADONLY_on(PAD_SVl(ix));
7996 SvREFCNT_dec(cSVOPo->op_sv);
7998 else if (o->op_type == OP_CONST
7999 && cSVOPo->op_sv == &PL_sv_undef) {
8000 /* PL_sv_undef is hack - it's unsafe to store it in the
8001 AV that is the pad, because av_fetch treats values of
8002 PL_sv_undef as a "free" AV entry and will merrily
8003 replace them with a new SV, causing pad_alloc to think
8004 that this pad slot is free. (When, clearly, it is not)
8006 SvOK_off(PAD_SVl(ix));
8007 SvPADTMP_on(PAD_SVl(ix));
8008 SvREADONLY_on(PAD_SVl(ix));
8011 SvREFCNT_dec(PAD_SVl(ix));
8012 SvPADTMP_on(cSVOPo->op_sv);
8013 PAD_SETSV(ix, cSVOPo->op_sv);
8014 /* XXX I don't know how this isn't readonly already. */
8015 SvREADONLY_on(PAD_SVl(ix));
8017 cSVOPo->op_sv = NULL;
8024 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
8025 if (o->op_next->op_private & OPpTARGET_MY) {
8026 if (o->op_flags & OPf_STACKED) /* chained concats */
8027 break; /* ignore_optimization */
8029 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
8030 o->op_targ = o->op_next->op_targ;
8031 o->op_next->op_targ = 0;
8032 o->op_private |= OPpTARGET_MY;
8035 op_null(o->op_next);
8039 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
8040 break; /* Scalar stub must produce undef. List stub is noop */
8044 if (o->op_targ == OP_NEXTSTATE
8045 || o->op_targ == OP_DBSTATE
8046 || o->op_targ == OP_SETSTATE)
8048 PL_curcop = ((COP*)o);
8050 /* XXX: We avoid setting op_seq here to prevent later calls
8051 to peep() from mistakenly concluding that optimisation
8052 has already occurred. This doesn't fix the real problem,
8053 though (See 20010220.007). AMS 20010719 */
8054 /* op_seq functionality is now replaced by op_opt */
8061 if (oldop && o->op_next) {
8062 oldop->op_next = o->op_next;
8070 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
8071 OP* const pop = (o->op_type == OP_PADAV) ?
8072 o->op_next : o->op_next->op_next;
8074 if (pop && pop->op_type == OP_CONST &&
8075 ((PL_op = pop->op_next)) &&
8076 pop->op_next->op_type == OP_AELEM &&
8077 !(pop->op_next->op_private &
8078 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
8079 (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
8084 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
8085 no_bareword_allowed(pop);
8086 if (o->op_type == OP_GV)
8087 op_null(o->op_next);
8088 op_null(pop->op_next);
8090 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
8091 o->op_next = pop->op_next->op_next;
8092 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
8093 o->op_private = (U8)i;
8094 if (o->op_type == OP_GV) {
8099 o->op_flags |= OPf_SPECIAL;
8100 o->op_type = OP_AELEMFAST;
8105 if (o->op_next->op_type == OP_RV2SV) {
8106 if (!(o->op_next->op_private & OPpDEREF)) {
8107 op_null(o->op_next);
8108 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
8110 o->op_next = o->op_next->op_next;
8111 o->op_type = OP_GVSV;
8112 o->op_ppaddr = PL_ppaddr[OP_GVSV];
8115 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
8116 GV * const gv = cGVOPo_gv;
8117 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
8118 /* XXX could check prototype here instead of just carping */
8119 SV * const sv = sv_newmortal();
8120 gv_efullname3(sv, gv, NULL);
8121 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
8122 "%"SVf"() called too early to check prototype",
8126 else if (o->op_next->op_type == OP_READLINE
8127 && o->op_next->op_next->op_type == OP_CONCAT
8128 && (o->op_next->op_next->op_flags & OPf_STACKED))
8130 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
8131 o->op_type = OP_RCATLINE;
8132 o->op_flags |= OPf_STACKED;
8133 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
8134 op_null(o->op_next->op_next);
8135 op_null(o->op_next);
8151 while (cLOGOP->op_other->op_type == OP_NULL)
8152 cLOGOP->op_other = cLOGOP->op_other->op_next;
8153 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
8158 while (cLOOP->op_redoop->op_type == OP_NULL)
8159 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
8160 peep(cLOOP->op_redoop);
8161 while (cLOOP->op_nextop->op_type == OP_NULL)
8162 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
8163 peep(cLOOP->op_nextop);
8164 while (cLOOP->op_lastop->op_type == OP_NULL)
8165 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
8166 peep(cLOOP->op_lastop);
8170 assert(!(cPMOP->op_pmflags & PMf_ONCE));
8171 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
8172 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
8173 cPMOP->op_pmstashstartu.op_pmreplstart
8174 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
8175 peep(cPMOP->op_pmstashstartu.op_pmreplstart);
8179 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
8180 && ckWARN(WARN_SYNTAX))
8182 if (o->op_next->op_sibling) {
8183 const OPCODE type = o->op_next->op_sibling->op_type;
8184 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
8185 const line_t oldline = CopLINE(PL_curcop);
8186 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
8187 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8188 "Statement unlikely to be reached");
8189 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8190 "\t(Maybe you meant system() when you said exec()?)\n");
8191 CopLINE_set(PL_curcop, oldline);
8202 const char *key = NULL;
8205 if (((BINOP*)o)->op_last->op_type != OP_CONST)
8208 /* Make the CONST have a shared SV */
8209 svp = cSVOPx_svp(((BINOP*)o)->op_last);
8210 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
8211 key = SvPV_const(sv, keylen);
8212 lexname = newSVpvn_share(key,
8213 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
8219 if ((o->op_private & (OPpLVAL_INTRO)))
8222 rop = (UNOP*)((BINOP*)o)->op_first;
8223 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
8225 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
8226 if (!SvPAD_TYPED(lexname))
8228 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8229 if (!fields || !GvHV(*fields))
8231 key = SvPV_const(*svp, keylen);
8232 if (!hv_fetch(GvHV(*fields), key,
8233 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8235 Perl_croak(aTHX_ "No such class field \"%s\" "
8236 "in variable %s of type %s",
8237 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
8250 SVOP *first_key_op, *key_op;
8252 if ((o->op_private & (OPpLVAL_INTRO))
8253 /* I bet there's always a pushmark... */
8254 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
8255 /* hmmm, no optimization if list contains only one key. */
8257 rop = (UNOP*)((LISTOP*)o)->op_last;
8258 if (rop->op_type != OP_RV2HV)
8260 if (rop->op_first->op_type == OP_PADSV)
8261 /* @$hash{qw(keys here)} */
8262 rop = (UNOP*)rop->op_first;
8264 /* @{$hash}{qw(keys here)} */
8265 if (rop->op_first->op_type == OP_SCOPE
8266 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
8268 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
8274 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
8275 if (!SvPAD_TYPED(lexname))
8277 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8278 if (!fields || !GvHV(*fields))
8280 /* Again guessing that the pushmark can be jumped over.... */
8281 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
8282 ->op_first->op_sibling;
8283 for (key_op = first_key_op; key_op;
8284 key_op = (SVOP*)key_op->op_sibling) {
8285 if (key_op->op_type != OP_CONST)
8287 svp = cSVOPx_svp(key_op);
8288 key = SvPV_const(*svp, keylen);
8289 if (!hv_fetch(GvHV(*fields), key,
8290 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8292 Perl_croak(aTHX_ "No such class field \"%s\" "
8293 "in variable %s of type %s",
8294 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
8301 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
8305 /* check that RHS of sort is a single plain array */
8306 OP *oright = cUNOPo->op_first;
8307 if (!oright || oright->op_type != OP_PUSHMARK)
8310 /* reverse sort ... can be optimised. */
8311 if (!cUNOPo->op_sibling) {
8312 /* Nothing follows us on the list. */
8313 OP * const reverse = o->op_next;
8315 if (reverse->op_type == OP_REVERSE &&
8316 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
8317 OP * const pushmark = cUNOPx(reverse)->op_first;
8318 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
8319 && (cUNOPx(pushmark)->op_sibling == o)) {
8320 /* reverse -> pushmark -> sort */
8321 o->op_private |= OPpSORT_REVERSE;
8323 pushmark->op_next = oright->op_next;
8329 /* make @a = sort @a act in-place */
8331 oright = cUNOPx(oright)->op_sibling;
8334 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
8335 oright = cUNOPx(oright)->op_sibling;
8339 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
8340 || oright->op_next != o
8341 || (oright->op_private & OPpLVAL_INTRO)
8345 /* o2 follows the chain of op_nexts through the LHS of the
8346 * assign (if any) to the aassign op itself */
8348 if (!o2 || o2->op_type != OP_NULL)
8351 if (!o2 || o2->op_type != OP_PUSHMARK)
8354 if (o2 && o2->op_type == OP_GV)
8357 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
8358 || (o2->op_private & OPpLVAL_INTRO)
8363 if (!o2 || o2->op_type != OP_NULL)
8366 if (!o2 || o2->op_type != OP_AASSIGN
8367 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
8370 /* check that the sort is the first arg on RHS of assign */
8372 o2 = cUNOPx(o2)->op_first;
8373 if (!o2 || o2->op_type != OP_NULL)
8375 o2 = cUNOPx(o2)->op_first;
8376 if (!o2 || o2->op_type != OP_PUSHMARK)
8378 if (o2->op_sibling != o)
8381 /* check the array is the same on both sides */
8382 if (oleft->op_type == OP_RV2AV) {
8383 if (oright->op_type != OP_RV2AV
8384 || !cUNOPx(oright)->op_first
8385 || cUNOPx(oright)->op_first->op_type != OP_GV
8386 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
8387 cGVOPx_gv(cUNOPx(oright)->op_first)
8391 else if (oright->op_type != OP_PADAV
8392 || oright->op_targ != oleft->op_targ
8396 /* transfer MODishness etc from LHS arg to RHS arg */
8397 oright->op_flags = oleft->op_flags;
8398 o->op_private |= OPpSORT_INPLACE;
8400 /* excise push->gv->rv2av->null->aassign */
8401 o2 = o->op_next->op_next;
8402 op_null(o2); /* PUSHMARK */
8404 if (o2->op_type == OP_GV) {
8405 op_null(o2); /* GV */
8408 op_null(o2); /* RV2AV or PADAV */
8409 o2 = o2->op_next->op_next;
8410 op_null(o2); /* AASSIGN */
8412 o->op_next = o2->op_next;
8418 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
8420 LISTOP *enter, *exlist;
8422 enter = (LISTOP *) o->op_next;
8425 if (enter->op_type == OP_NULL) {
8426 enter = (LISTOP *) enter->op_next;
8430 /* for $a (...) will have OP_GV then OP_RV2GV here.
8431 for (...) just has an OP_GV. */
8432 if (enter->op_type == OP_GV) {
8433 gvop = (OP *) enter;
8434 enter = (LISTOP *) enter->op_next;
8437 if (enter->op_type == OP_RV2GV) {
8438 enter = (LISTOP *) enter->op_next;
8444 if (enter->op_type != OP_ENTERITER)
8447 iter = enter->op_next;
8448 if (!iter || iter->op_type != OP_ITER)
8451 expushmark = enter->op_first;
8452 if (!expushmark || expushmark->op_type != OP_NULL
8453 || expushmark->op_targ != OP_PUSHMARK)
8456 exlist = (LISTOP *) expushmark->op_sibling;
8457 if (!exlist || exlist->op_type != OP_NULL
8458 || exlist->op_targ != OP_LIST)
8461 if (exlist->op_last != o) {
8462 /* Mmm. Was expecting to point back to this op. */
8465 theirmark = exlist->op_first;
8466 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
8469 if (theirmark->op_sibling != o) {
8470 /* There's something between the mark and the reverse, eg
8471 for (1, reverse (...))
8476 ourmark = ((LISTOP *)o)->op_first;
8477 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
8480 ourlast = ((LISTOP *)o)->op_last;
8481 if (!ourlast || ourlast->op_next != o)
8484 rv2av = ourmark->op_sibling;
8485 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
8486 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
8487 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
8488 /* We're just reversing a single array. */
8489 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
8490 enter->op_flags |= OPf_STACKED;
8493 /* We don't have control over who points to theirmark, so sacrifice
8495 theirmark->op_next = ourmark->op_next;
8496 theirmark->op_flags = ourmark->op_flags;
8497 ourlast->op_next = gvop ? gvop : (OP *) enter;
8500 enter->op_private |= OPpITER_REVERSED;
8501 iter->op_private |= OPpITER_REVERSED;
8508 UNOP *refgen, *rv2cv;
8511 if ((o->op_flags & OPf_WANT) != OPf_WANT_VOID)
8514 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
8517 rv2gv = ((BINOP *)o)->op_last;
8518 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
8521 refgen = (UNOP *)((BINOP *)o)->op_first;
8523 if (!refgen || refgen->op_type != OP_REFGEN)
8526 exlist = (LISTOP *)refgen->op_first;
8527 if (!exlist || exlist->op_type != OP_NULL
8528 || exlist->op_targ != OP_LIST)
8531 if (exlist->op_first->op_type != OP_PUSHMARK)
8534 rv2cv = (UNOP*)exlist->op_last;
8536 if (rv2cv->op_type != OP_RV2CV)
8539 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
8540 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
8541 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
8543 o->op_private |= OPpASSIGN_CV_TO_GV;
8544 rv2gv->op_private |= OPpDONT_INIT_GV;
8545 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
8553 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
8554 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
8564 Perl_custom_op_name(pTHX_ const OP* o)
8567 const IV index = PTR2IV(o->op_ppaddr);
8571 if (!PL_custom_op_names) /* This probably shouldn't happen */
8572 return (char *)PL_op_name[OP_CUSTOM];
8574 keysv = sv_2mortal(newSViv(index));
8576 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
8578 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
8580 return SvPV_nolen(HeVAL(he));
8584 Perl_custom_op_desc(pTHX_ const OP* o)
8587 const IV index = PTR2IV(o->op_ppaddr);
8591 if (!PL_custom_op_descs)
8592 return (char *)PL_op_desc[OP_CUSTOM];
8594 keysv = sv_2mortal(newSViv(index));
8596 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
8598 return (char *)PL_op_desc[OP_CUSTOM];
8600 return SvPV_nolen(HeVAL(he));
8605 /* Efficient sub that returns a constant scalar value. */
8607 const_sv_xsub(pTHX_ CV* cv)
8614 Perl_croak(aTHX_ "usage: %s::%s()",
8615 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
8619 ST(0) = (SV*)XSANY.any_ptr;
8625 * c-indentation-style: bsd
8627 * indent-tabs-mode: t
8630 * ex: set ts=8 sts=4 sw=4 noet: