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 ReREFCNT_dec(PM_GETRE(cPMOPo));
627 av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
628 SvREADONLY_off(PL_regex_pad[(cPMOPo)->op_pmoffset]);
629 SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
630 PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
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)
1010 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1011 useless = OP_DESC(o);
1015 kid = cUNOPo->op_first;
1016 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1017 kid->op_type != OP_TRANS) {
1020 useless = "negative pattern binding (!~)";
1027 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1028 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1029 useless = "a variable";
1034 if (cSVOPo->op_private & OPpCONST_STRICT)
1035 no_bareword_allowed(o);
1037 if (ckWARN(WARN_VOID)) {
1038 useless = "a constant";
1039 if (o->op_private & OPpCONST_ARYBASE)
1041 /* don't warn on optimised away booleans, eg
1042 * use constant Foo, 5; Foo || print; */
1043 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1045 /* the constants 0 and 1 are permitted as they are
1046 conventionally used as dummies in constructs like
1047 1 while some_condition_with_side_effects; */
1048 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1050 else if (SvPOK(sv)) {
1051 /* perl4's way of mixing documentation and code
1052 (before the invention of POD) was based on a
1053 trick to mix nroff and perl code. The trick was
1054 built upon these three nroff macros being used in
1055 void context. The pink camel has the details in
1056 the script wrapman near page 319. */
1057 const char * const maybe_macro = SvPVX_const(sv);
1058 if (strnEQ(maybe_macro, "di", 2) ||
1059 strnEQ(maybe_macro, "ds", 2) ||
1060 strnEQ(maybe_macro, "ig", 2))
1065 op_null(o); /* don't execute or even remember it */
1069 o->op_type = OP_PREINC; /* pre-increment is faster */
1070 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1074 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1075 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1079 o->op_type = OP_I_PREINC; /* pre-increment is faster */
1080 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1084 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
1085 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1094 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1099 if (o->op_flags & OPf_STACKED)
1106 if (!(o->op_flags & OPf_KIDS))
1117 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1124 /* all requires must return a boolean value */
1125 o->op_flags &= ~OPf_WANT;
1130 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
1131 if (!kPMOP->op_pmreplrootu.op_pmreplroot)
1132 deprecate_old("implicit split to @_");
1136 if (useless && ckWARN(WARN_VOID))
1137 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
1142 Perl_listkids(pTHX_ OP *o)
1144 if (o && o->op_flags & OPf_KIDS) {
1146 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1153 Perl_list(pTHX_ OP *o)
1158 /* assumes no premature commitment */
1159 if (!o || (o->op_flags & OPf_WANT)
1160 || (PL_parser && PL_parser->error_count)
1161 || o->op_type == OP_RETURN)
1166 if ((o->op_private & OPpTARGET_MY)
1167 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1169 return o; /* As if inside SASSIGN */
1172 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1174 switch (o->op_type) {
1177 list(cBINOPo->op_first);
1182 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1190 if (!(o->op_flags & OPf_KIDS))
1192 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1193 list(cBINOPo->op_first);
1194 return gen_constant_list(o);
1201 kid = cLISTOPo->op_first;
1203 while ((kid = kid->op_sibling)) {
1204 if (kid->op_sibling)
1209 PL_curcop = &PL_compiling;
1213 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1214 if (kid->op_sibling)
1219 PL_curcop = &PL_compiling;
1222 /* all requires must return a boolean value */
1223 o->op_flags &= ~OPf_WANT;
1230 Perl_scalarseq(pTHX_ OP *o)
1234 const OPCODE type = o->op_type;
1236 if (type == OP_LINESEQ || type == OP_SCOPE ||
1237 type == OP_LEAVE || type == OP_LEAVETRY)
1240 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1241 if (kid->op_sibling) {
1245 PL_curcop = &PL_compiling;
1247 o->op_flags &= ~OPf_PARENS;
1248 if (PL_hints & HINT_BLOCK_SCOPE)
1249 o->op_flags |= OPf_PARENS;
1252 o = newOP(OP_STUB, 0);
1257 S_modkids(pTHX_ OP *o, I32 type)
1259 if (o && o->op_flags & OPf_KIDS) {
1261 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1267 /* Propagate lvalue ("modifiable") context to an op and its children.
1268 * 'type' represents the context type, roughly based on the type of op that
1269 * would do the modifying, although local() is represented by OP_NULL.
1270 * It's responsible for detecting things that can't be modified, flag
1271 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
1272 * might have to vivify a reference in $x), and so on.
1274 * For example, "$a+1 = 2" would cause mod() to be called with o being
1275 * OP_ADD and type being OP_SASSIGN, and would output an error.
1279 Perl_mod(pTHX_ OP *o, I32 type)
1283 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1286 if (!o || (PL_parser && PL_parser->error_count))
1289 if ((o->op_private & OPpTARGET_MY)
1290 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1295 switch (o->op_type) {
1301 if (!(o->op_private & OPpCONST_ARYBASE))
1304 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1305 CopARYBASE_set(&PL_compiling,
1306 (I32)SvIV(cSVOPx(PL_eval_start)->op_sv));
1310 SAVECOPARYBASE(&PL_compiling);
1311 CopARYBASE_set(&PL_compiling, 0);
1313 else if (type == OP_REFGEN)
1316 Perl_croak(aTHX_ "That use of $[ is unsupported");
1319 if ((o->op_flags & OPf_PARENS) || PL_madskills)
1323 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1324 !(o->op_flags & OPf_STACKED)) {
1325 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1326 /* The default is to set op_private to the number of children,
1327 which for a UNOP such as RV2CV is always 1. And w're using
1328 the bit for a flag in RV2CV, so we need it clear. */
1329 o->op_private &= ~1;
1330 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1331 assert(cUNOPo->op_first->op_type == OP_NULL);
1332 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1335 else if (o->op_private & OPpENTERSUB_NOMOD)
1337 else { /* lvalue subroutine call */
1338 o->op_private |= OPpLVAL_INTRO;
1339 PL_modcount = RETURN_UNLIMITED_NUMBER;
1340 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1341 /* Backward compatibility mode: */
1342 o->op_private |= OPpENTERSUB_INARGS;
1345 else { /* Compile-time error message: */
1346 OP *kid = cUNOPo->op_first;
1350 if (kid->op_type != OP_PUSHMARK) {
1351 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1353 "panic: unexpected lvalue entersub "
1354 "args: type/targ %ld:%"UVuf,
1355 (long)kid->op_type, (UV)kid->op_targ);
1356 kid = kLISTOP->op_first;
1358 while (kid->op_sibling)
1359 kid = kid->op_sibling;
1360 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1362 if (kid->op_type == OP_METHOD_NAMED
1363 || kid->op_type == OP_METHOD)
1367 NewOp(1101, newop, 1, UNOP);
1368 newop->op_type = OP_RV2CV;
1369 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1370 newop->op_first = NULL;
1371 newop->op_next = (OP*)newop;
1372 kid->op_sibling = (OP*)newop;
1373 newop->op_private |= OPpLVAL_INTRO;
1374 newop->op_private &= ~1;
1378 if (kid->op_type != OP_RV2CV)
1380 "panic: unexpected lvalue entersub "
1381 "entry via type/targ %ld:%"UVuf,
1382 (long)kid->op_type, (UV)kid->op_targ);
1383 kid->op_private |= OPpLVAL_INTRO;
1384 break; /* Postpone until runtime */
1388 kid = kUNOP->op_first;
1389 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1390 kid = kUNOP->op_first;
1391 if (kid->op_type == OP_NULL)
1393 "Unexpected constant lvalue entersub "
1394 "entry via type/targ %ld:%"UVuf,
1395 (long)kid->op_type, (UV)kid->op_targ);
1396 if (kid->op_type != OP_GV) {
1397 /* Restore RV2CV to check lvalueness */
1399 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1400 okid->op_next = kid->op_next;
1401 kid->op_next = okid;
1404 okid->op_next = NULL;
1405 okid->op_type = OP_RV2CV;
1407 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1408 okid->op_private |= OPpLVAL_INTRO;
1409 okid->op_private &= ~1;
1413 cv = GvCV(kGVOP_gv);
1423 /* grep, foreach, subcalls, refgen */
1424 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1426 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1427 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1429 : (o->op_type == OP_ENTERSUB
1430 ? "non-lvalue subroutine call"
1432 type ? PL_op_desc[type] : "local"));
1446 case OP_RIGHT_SHIFT:
1455 if (!(o->op_flags & OPf_STACKED))
1462 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1468 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1469 PL_modcount = RETURN_UNLIMITED_NUMBER;
1470 return o; /* Treat \(@foo) like ordinary list. */
1474 if (scalar_mod_type(o, type))
1476 ref(cUNOPo->op_first, o->op_type);
1480 if (type == OP_LEAVESUBLV)
1481 o->op_private |= OPpMAYBE_LVSUB;
1487 PL_modcount = RETURN_UNLIMITED_NUMBER;
1490 ref(cUNOPo->op_first, o->op_type);
1495 PL_hints |= HINT_BLOCK_SCOPE;
1510 PL_modcount = RETURN_UNLIMITED_NUMBER;
1511 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1512 return o; /* Treat \(@foo) like ordinary list. */
1513 if (scalar_mod_type(o, type))
1515 if (type == OP_LEAVESUBLV)
1516 o->op_private |= OPpMAYBE_LVSUB;
1520 if (!type) /* local() */
1521 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1522 PAD_COMPNAME_PV(o->op_targ));
1530 if (type != OP_SASSIGN)
1534 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1539 if (type == OP_LEAVESUBLV)
1540 o->op_private |= OPpMAYBE_LVSUB;
1542 pad_free(o->op_targ);
1543 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1544 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1545 if (o->op_flags & OPf_KIDS)
1546 mod(cBINOPo->op_first->op_sibling, type);
1551 ref(cBINOPo->op_first, o->op_type);
1552 if (type == OP_ENTERSUB &&
1553 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1554 o->op_private |= OPpLVAL_DEFER;
1555 if (type == OP_LEAVESUBLV)
1556 o->op_private |= OPpMAYBE_LVSUB;
1566 if (o->op_flags & OPf_KIDS)
1567 mod(cLISTOPo->op_last, type);
1572 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1574 else if (!(o->op_flags & OPf_KIDS))
1576 if (o->op_targ != OP_LIST) {
1577 mod(cBINOPo->op_first, type);
1583 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1588 if (type != OP_LEAVESUBLV)
1590 break; /* mod()ing was handled by ck_return() */
1593 /* [20011101.069] File test operators interpret OPf_REF to mean that
1594 their argument is a filehandle; thus \stat(".") should not set
1596 if (type == OP_REFGEN &&
1597 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1600 if (type != OP_LEAVESUBLV)
1601 o->op_flags |= OPf_MOD;
1603 if (type == OP_AASSIGN || type == OP_SASSIGN)
1604 o->op_flags |= OPf_SPECIAL|OPf_REF;
1605 else if (!type) { /* local() */
1608 o->op_private |= OPpLVAL_INTRO;
1609 o->op_flags &= ~OPf_SPECIAL;
1610 PL_hints |= HINT_BLOCK_SCOPE;
1615 if (ckWARN(WARN_SYNTAX)) {
1616 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1617 "Useless localization of %s", OP_DESC(o));
1621 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1622 && type != OP_LEAVESUBLV)
1623 o->op_flags |= OPf_REF;
1628 S_scalar_mod_type(const OP *o, I32 type)
1632 if (o->op_type == OP_RV2GV)
1656 case OP_RIGHT_SHIFT:
1676 S_is_handle_constructor(const OP *o, I32 numargs)
1678 switch (o->op_type) {
1686 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1699 Perl_refkids(pTHX_ OP *o, I32 type)
1701 if (o && o->op_flags & OPf_KIDS) {
1703 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1710 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
1715 if (!o || (PL_parser && PL_parser->error_count))
1718 switch (o->op_type) {
1720 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1721 !(o->op_flags & OPf_STACKED)) {
1722 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1723 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1724 assert(cUNOPo->op_first->op_type == OP_NULL);
1725 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1726 o->op_flags |= OPf_SPECIAL;
1727 o->op_private &= ~1;
1732 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1733 doref(kid, type, set_op_ref);
1736 if (type == OP_DEFINED)
1737 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1738 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1741 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1742 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1743 : type == OP_RV2HV ? OPpDEREF_HV
1745 o->op_flags |= OPf_MOD;
1752 o->op_flags |= OPf_REF;
1755 if (type == OP_DEFINED)
1756 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1757 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1763 o->op_flags |= OPf_REF;
1768 if (!(o->op_flags & OPf_KIDS))
1770 doref(cBINOPo->op_first, type, set_op_ref);
1774 doref(cBINOPo->op_first, o->op_type, set_op_ref);
1775 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1776 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1777 : type == OP_RV2HV ? OPpDEREF_HV
1779 o->op_flags |= OPf_MOD;
1789 if (!(o->op_flags & OPf_KIDS))
1791 doref(cLISTOPo->op_last, type, set_op_ref);
1801 S_dup_attrlist(pTHX_ OP *o)
1806 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1807 * where the first kid is OP_PUSHMARK and the remaining ones
1808 * are OP_CONST. We need to push the OP_CONST values.
1810 if (o->op_type == OP_CONST)
1811 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
1813 else if (o->op_type == OP_NULL)
1817 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1819 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1820 if (o->op_type == OP_CONST)
1821 rop = append_elem(OP_LIST, rop,
1822 newSVOP(OP_CONST, o->op_flags,
1823 SvREFCNT_inc_NN(cSVOPo->op_sv)));
1830 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1835 /* fake up C<use attributes $pkg,$rv,@attrs> */
1836 ENTER; /* need to protect against side-effects of 'use' */
1837 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1839 #define ATTRSMODULE "attributes"
1840 #define ATTRSMODULE_PM "attributes.pm"
1843 /* Don't force the C<use> if we don't need it. */
1844 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
1845 if (svp && *svp != &PL_sv_undef)
1846 NOOP; /* already in %INC */
1848 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1849 newSVpvs(ATTRSMODULE), NULL);
1852 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1853 newSVpvs(ATTRSMODULE),
1855 prepend_elem(OP_LIST,
1856 newSVOP(OP_CONST, 0, stashsv),
1857 prepend_elem(OP_LIST,
1858 newSVOP(OP_CONST, 0,
1860 dup_attrlist(attrs))));
1866 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1869 OP *pack, *imop, *arg;
1875 assert(target->op_type == OP_PADSV ||
1876 target->op_type == OP_PADHV ||
1877 target->op_type == OP_PADAV);
1879 /* Ensure that attributes.pm is loaded. */
1880 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1882 /* Need package name for method call. */
1883 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
1885 /* Build up the real arg-list. */
1886 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1888 arg = newOP(OP_PADSV, 0);
1889 arg->op_targ = target->op_targ;
1890 arg = prepend_elem(OP_LIST,
1891 newSVOP(OP_CONST, 0, stashsv),
1892 prepend_elem(OP_LIST,
1893 newUNOP(OP_REFGEN, 0,
1894 mod(arg, OP_REFGEN)),
1895 dup_attrlist(attrs)));
1897 /* Fake up a method call to import */
1898 meth = newSVpvs_share("import");
1899 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1900 append_elem(OP_LIST,
1901 prepend_elem(OP_LIST, pack, list(arg)),
1902 newSVOP(OP_METHOD_NAMED, 0, meth)));
1903 imop->op_private |= OPpENTERSUB_NOMOD;
1905 /* Combine the ops. */
1906 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1910 =notfor apidoc apply_attrs_string
1912 Attempts to apply a list of attributes specified by the C<attrstr> and
1913 C<len> arguments to the subroutine identified by the C<cv> argument which
1914 is expected to be associated with the package identified by the C<stashpv>
1915 argument (see L<attributes>). It gets this wrong, though, in that it
1916 does not correctly identify the boundaries of the individual attribute
1917 specifications within C<attrstr>. This is not really intended for the
1918 public API, but has to be listed here for systems such as AIX which
1919 need an explicit export list for symbols. (It's called from XS code
1920 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1921 to respect attribute syntax properly would be welcome.
1927 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
1928 const char *attrstr, STRLEN len)
1933 len = strlen(attrstr);
1937 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1939 const char * const sstr = attrstr;
1940 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1941 attrs = append_elem(OP_LIST, attrs,
1942 newSVOP(OP_CONST, 0,
1943 newSVpvn(sstr, attrstr-sstr)));
1947 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1948 newSVpvs(ATTRSMODULE),
1949 NULL, prepend_elem(OP_LIST,
1950 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1951 prepend_elem(OP_LIST,
1952 newSVOP(OP_CONST, 0,
1958 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
1963 if (!o || (PL_parser && PL_parser->error_count))
1967 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
1968 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
1972 if (type == OP_LIST) {
1974 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1975 my_kid(kid, attrs, imopsp);
1976 } else if (type == OP_UNDEF
1982 } else if (type == OP_RV2SV || /* "our" declaration */
1984 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1985 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1986 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1988 PL_parser->in_my == KEY_our
1990 : PL_parser->in_my == KEY_state ? "state" : "my"));
1992 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
1993 PL_parser->in_my = FALSE;
1994 PL_parser->in_my_stash = NULL;
1995 apply_attrs(GvSTASH(gv),
1996 (type == OP_RV2SV ? GvSV(gv) :
1997 type == OP_RV2AV ? (SV*)GvAV(gv) :
1998 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
2001 o->op_private |= OPpOUR_INTRO;
2004 else if (type != OP_PADSV &&
2007 type != OP_PUSHMARK)
2009 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2011 PL_parser->in_my == KEY_our
2013 : PL_parser->in_my == KEY_state ? "state" : "my"));
2016 else if (attrs && type != OP_PUSHMARK) {
2019 PL_parser->in_my = FALSE;
2020 PL_parser->in_my_stash = NULL;
2022 /* check for C<my Dog $spot> when deciding package */
2023 stash = PAD_COMPNAME_TYPE(o->op_targ);
2025 stash = PL_curstash;
2026 apply_attrs_my(stash, o, attrs, imopsp);
2028 o->op_flags |= OPf_MOD;
2029 o->op_private |= OPpLVAL_INTRO;
2030 if (PL_parser->in_my == KEY_state)
2031 o->op_private |= OPpPAD_STATE;
2036 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2040 int maybe_scalar = 0;
2042 /* [perl #17376]: this appears to be premature, and results in code such as
2043 C< our(%x); > executing in list mode rather than void mode */
2045 if (o->op_flags & OPf_PARENS)
2055 o = my_kid(o, attrs, &rops);
2057 if (maybe_scalar && o->op_type == OP_PADSV) {
2058 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
2059 o->op_private |= OPpLVAL_INTRO;
2062 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
2064 PL_parser->in_my = FALSE;
2065 PL_parser->in_my_stash = NULL;
2070 Perl_my(pTHX_ OP *o)
2072 return my_attrs(o, NULL);
2076 Perl_sawparens(pTHX_ OP *o)
2078 PERL_UNUSED_CONTEXT;
2080 o->op_flags |= OPf_PARENS;
2085 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2089 const OPCODE ltype = left->op_type;
2090 const OPCODE rtype = right->op_type;
2092 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2093 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
2095 const char * const desc
2096 = PL_op_desc[(rtype == OP_SUBST || rtype == OP_TRANS)
2097 ? (int)rtype : OP_MATCH];
2098 const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV)
2099 ? "@array" : "%hash");
2100 Perl_warner(aTHX_ packWARN(WARN_MISC),
2101 "Applying %s to %s will act on scalar(%s)",
2102 desc, sample, sample);
2105 if (rtype == OP_CONST &&
2106 cSVOPx(right)->op_private & OPpCONST_BARE &&
2107 cSVOPx(right)->op_private & OPpCONST_STRICT)
2109 no_bareword_allowed(right);
2112 ismatchop = rtype == OP_MATCH ||
2113 rtype == OP_SUBST ||
2115 if (ismatchop && right->op_private & OPpTARGET_MY) {
2117 right->op_private &= ~OPpTARGET_MY;
2119 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
2122 right->op_flags |= OPf_STACKED;
2123 if (rtype != OP_MATCH &&
2124 ! (rtype == OP_TRANS &&
2125 right->op_private & OPpTRANS_IDENTICAL))
2126 newleft = mod(left, rtype);
2129 if (right->op_type == OP_TRANS)
2130 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
2132 o = prepend_elem(rtype, scalar(newleft), right);
2134 return newUNOP(OP_NOT, 0, scalar(o));
2138 return bind_match(type, left,
2139 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
2143 Perl_invert(pTHX_ OP *o)
2147 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2151 Perl_scope(pTHX_ OP *o)
2155 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2156 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2157 o->op_type = OP_LEAVE;
2158 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2160 else if (o->op_type == OP_LINESEQ) {
2162 o->op_type = OP_SCOPE;
2163 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2164 kid = ((LISTOP*)o)->op_first;
2165 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2168 /* The following deals with things like 'do {1 for 1}' */
2169 kid = kid->op_sibling;
2171 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2176 o = newLISTOP(OP_SCOPE, 0, o, NULL);
2182 Perl_block_start(pTHX_ int full)
2185 const int retval = PL_savestack_ix;
2186 pad_block_start(full);
2188 PL_hints &= ~HINT_BLOCK_SCOPE;
2189 SAVECOMPILEWARNINGS();
2190 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
2195 Perl_block_end(pTHX_ I32 floor, OP *seq)
2198 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2199 OP* const retval = scalarseq(seq);
2201 CopHINTS_set(&PL_compiling, PL_hints);
2203 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2212 const PADOFFSET offset = pad_findmy("$_");
2213 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
2214 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2217 OP * const o = newOP(OP_PADSV, 0);
2218 o->op_targ = offset;
2224 Perl_newPROG(pTHX_ OP *o)
2230 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2231 ((PL_in_eval & EVAL_KEEPERR)
2232 ? OPf_SPECIAL : 0), o);
2233 PL_eval_start = linklist(PL_eval_root);
2234 PL_eval_root->op_private |= OPpREFCOUNTED;
2235 OpREFCNT_set(PL_eval_root, 1);
2236 PL_eval_root->op_next = 0;
2237 CALL_PEEP(PL_eval_start);
2240 if (o->op_type == OP_STUB) {
2241 PL_comppad_name = 0;
2243 S_op_destroy(aTHX_ o);
2246 PL_main_root = scope(sawparens(scalarvoid(o)));
2247 PL_curcop = &PL_compiling;
2248 PL_main_start = LINKLIST(PL_main_root);
2249 PL_main_root->op_private |= OPpREFCOUNTED;
2250 OpREFCNT_set(PL_main_root, 1);
2251 PL_main_root->op_next = 0;
2252 CALL_PEEP(PL_main_start);
2255 /* Register with debugger */
2258 = Perl_get_cvn_flags(aTHX_ STR_WITH_LEN("DB::postponed"), 0);
2262 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2264 call_sv((SV*)cv, G_DISCARD);
2271 Perl_localize(pTHX_ OP *o, I32 lex)
2274 if (o->op_flags & OPf_PARENS)
2275 /* [perl #17376]: this appears to be premature, and results in code such as
2276 C< our(%x); > executing in list mode rather than void mode */
2283 if ( PL_parser->bufptr > PL_parser->oldbufptr
2284 && PL_parser->bufptr[-1] == ','
2285 && ckWARN(WARN_PARENTHESIS))
2287 char *s = PL_parser->bufptr;
2290 /* some heuristics to detect a potential error */
2291 while (*s && (strchr(", \t\n", *s)))
2295 if (*s && strchr("@$%*", *s) && *++s
2296 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2299 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2301 while (*s && (strchr(", \t\n", *s)))
2307 if (sigil && (*s == ';' || *s == '=')) {
2308 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2309 "Parentheses missing around \"%s\" list",
2311 ? (PL_parser->in_my == KEY_our
2313 : PL_parser->in_my == KEY_state
2323 o = mod(o, OP_NULL); /* a bit kludgey */
2324 PL_parser->in_my = FALSE;
2325 PL_parser->in_my_stash = NULL;
2330 Perl_jmaybe(pTHX_ OP *o)
2332 if (o->op_type == OP_LIST) {
2334 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2335 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2341 Perl_fold_constants(pTHX_ register OP *o)
2346 VOL I32 type = o->op_type;
2351 SV * const oldwarnhook = PL_warnhook;
2352 SV * const olddiehook = PL_diehook;
2355 if (PL_opargs[type] & OA_RETSCALAR)
2357 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2358 o->op_targ = pad_alloc(type, SVs_PADTMP);
2360 /* integerize op, unless it happens to be C<-foo>.
2361 * XXX should pp_i_negate() do magic string negation instead? */
2362 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2363 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2364 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2366 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2369 if (!(PL_opargs[type] & OA_FOLDCONST))
2374 /* XXX might want a ck_negate() for this */
2375 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2386 /* XXX what about the numeric ops? */
2387 if (PL_hints & HINT_LOCALE)
2391 if (PL_parser && PL_parser->error_count)
2392 goto nope; /* Don't try to run w/ errors */
2394 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2395 const OPCODE type = curop->op_type;
2396 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2398 type != OP_SCALAR &&
2400 type != OP_PUSHMARK)
2406 curop = LINKLIST(o);
2407 old_next = o->op_next;
2411 oldscope = PL_scopestack_ix;
2412 create_eval_scope(G_FAKINGEVAL);
2414 PL_warnhook = PERL_WARNHOOK_FATAL;
2421 sv = *(PL_stack_sp--);
2422 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2423 pad_swipe(o->op_targ, FALSE);
2424 else if (SvTEMP(sv)) { /* grab mortal temp? */
2425 SvREFCNT_inc_simple_void(sv);
2430 /* Something tried to die. Abandon constant folding. */
2431 /* Pretend the error never happened. */
2432 sv_setpvn(ERRSV,"",0);
2433 o->op_next = old_next;
2437 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
2438 PL_warnhook = oldwarnhook;
2439 PL_diehook = olddiehook;
2440 /* XXX note that this croak may fail as we've already blown away
2441 * the stack - eg any nested evals */
2442 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
2445 PL_warnhook = oldwarnhook;
2446 PL_diehook = olddiehook;
2448 if (PL_scopestack_ix > oldscope)
2449 delete_eval_scope();
2458 if (type == OP_RV2GV)
2459 newop = newGVOP(OP_GV, 0, (GV*)sv);
2461 newop = newSVOP(OP_CONST, 0, (SV*)sv);
2462 op_getmad(o,newop,'f');
2470 Perl_gen_constant_list(pTHX_ register OP *o)
2474 const I32 oldtmps_floor = PL_tmps_floor;
2477 if (PL_parser && PL_parser->error_count)
2478 return o; /* Don't attempt to run with errors */
2480 PL_op = curop = LINKLIST(o);
2486 assert (!(curop->op_flags & OPf_SPECIAL));
2487 assert(curop->op_type == OP_RANGE);
2489 PL_tmps_floor = oldtmps_floor;
2491 o->op_type = OP_RV2AV;
2492 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2493 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2494 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2495 o->op_opt = 0; /* needs to be revisited in peep() */
2496 curop = ((UNOP*)o)->op_first;
2497 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
2499 op_getmad(curop,o,'O');
2508 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2511 if (!o || o->op_type != OP_LIST)
2512 o = newLISTOP(OP_LIST, 0, o, NULL);
2514 o->op_flags &= ~OPf_WANT;
2516 if (!(PL_opargs[type] & OA_MARK))
2517 op_null(cLISTOPo->op_first);
2519 o->op_type = (OPCODE)type;
2520 o->op_ppaddr = PL_ppaddr[type];
2521 o->op_flags |= flags;
2523 o = CHECKOP(type, o);
2524 if (o->op_type != (unsigned)type)
2527 return fold_constants(o);
2530 /* List constructors */
2533 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2541 if (first->op_type != (unsigned)type
2542 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2544 return newLISTOP(type, 0, first, last);
2547 if (first->op_flags & OPf_KIDS)
2548 ((LISTOP*)first)->op_last->op_sibling = last;
2550 first->op_flags |= OPf_KIDS;
2551 ((LISTOP*)first)->op_first = last;
2553 ((LISTOP*)first)->op_last = last;
2558 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2566 if (first->op_type != (unsigned)type)
2567 return prepend_elem(type, (OP*)first, (OP*)last);
2569 if (last->op_type != (unsigned)type)
2570 return append_elem(type, (OP*)first, (OP*)last);
2572 first->op_last->op_sibling = last->op_first;
2573 first->op_last = last->op_last;
2574 first->op_flags |= (last->op_flags & OPf_KIDS);
2577 if (last->op_first && first->op_madprop) {
2578 MADPROP *mp = last->op_first->op_madprop;
2580 while (mp->mad_next)
2582 mp->mad_next = first->op_madprop;
2585 last->op_first->op_madprop = first->op_madprop;
2588 first->op_madprop = last->op_madprop;
2589 last->op_madprop = 0;
2592 S_op_destroy(aTHX_ (OP*)last);
2598 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2606 if (last->op_type == (unsigned)type) {
2607 if (type == OP_LIST) { /* already a PUSHMARK there */
2608 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2609 ((LISTOP*)last)->op_first->op_sibling = first;
2610 if (!(first->op_flags & OPf_PARENS))
2611 last->op_flags &= ~OPf_PARENS;
2614 if (!(last->op_flags & OPf_KIDS)) {
2615 ((LISTOP*)last)->op_last = first;
2616 last->op_flags |= OPf_KIDS;
2618 first->op_sibling = ((LISTOP*)last)->op_first;
2619 ((LISTOP*)last)->op_first = first;
2621 last->op_flags |= OPf_KIDS;
2625 return newLISTOP(type, 0, first, last);
2633 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2636 Newxz(tk, 1, TOKEN);
2637 tk->tk_type = (OPCODE)optype;
2638 tk->tk_type = 12345;
2640 tk->tk_mad = madprop;
2645 Perl_token_free(pTHX_ TOKEN* tk)
2647 if (tk->tk_type != 12345)
2649 mad_free(tk->tk_mad);
2654 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2658 if (tk->tk_type != 12345) {
2659 Perl_warner(aTHX_ packWARN(WARN_MISC),
2660 "Invalid TOKEN object ignored");
2667 /* faked up qw list? */
2669 tm->mad_type == MAD_SV &&
2670 SvPVX((SV*)tm->mad_val)[0] == 'q')
2677 /* pretend constant fold didn't happen? */
2678 if (mp->mad_key == 'f' &&
2679 (o->op_type == OP_CONST ||
2680 o->op_type == OP_GV) )
2682 token_getmad(tk,(OP*)mp->mad_val,slot);
2696 if (mp->mad_key == 'X')
2697 mp->mad_key = slot; /* just change the first one */
2707 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
2716 /* pretend constant fold didn't happen? */
2717 if (mp->mad_key == 'f' &&
2718 (o->op_type == OP_CONST ||
2719 o->op_type == OP_GV) )
2721 op_getmad(from,(OP*)mp->mad_val,slot);
2728 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
2731 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
2737 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
2746 /* pretend constant fold didn't happen? */
2747 if (mp->mad_key == 'f' &&
2748 (o->op_type == OP_CONST ||
2749 o->op_type == OP_GV) )
2751 op_getmad(from,(OP*)mp->mad_val,slot);
2758 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
2761 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
2765 PerlIO_printf(PerlIO_stderr(),
2766 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
2772 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
2790 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
2794 addmad(tm, &(o->op_madprop), slot);
2798 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
2819 Perl_newMADsv(pTHX_ char key, SV* sv)
2821 return newMADPROP(key, MAD_SV, sv, 0);
2825 Perl_newMADPROP(pTHX_ char key, char type, const void* val, I32 vlen)
2828 Newxz(mp, 1, MADPROP);
2831 mp->mad_vlen = vlen;
2832 mp->mad_type = type;
2834 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
2839 Perl_mad_free(pTHX_ MADPROP* mp)
2841 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
2845 mad_free(mp->mad_next);
2846 /* if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
2847 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
2848 switch (mp->mad_type) {
2852 Safefree((char*)mp->mad_val);
2855 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
2856 op_free((OP*)mp->mad_val);
2859 sv_free((SV*)mp->mad_val);
2862 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
2871 Perl_newNULLLIST(pTHX)
2873 return newOP(OP_STUB, 0);
2877 Perl_force_list(pTHX_ OP *o)
2879 if (!o || o->op_type != OP_LIST)
2880 o = newLISTOP(OP_LIST, 0, o, NULL);
2886 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2891 NewOp(1101, listop, 1, LISTOP);
2893 listop->op_type = (OPCODE)type;
2894 listop->op_ppaddr = PL_ppaddr[type];
2897 listop->op_flags = (U8)flags;
2901 else if (!first && last)
2904 first->op_sibling = last;
2905 listop->op_first = first;
2906 listop->op_last = last;
2907 if (type == OP_LIST) {
2908 OP* const pushop = newOP(OP_PUSHMARK, 0);
2909 pushop->op_sibling = first;
2910 listop->op_first = pushop;
2911 listop->op_flags |= OPf_KIDS;
2913 listop->op_last = pushop;
2916 return CHECKOP(type, listop);
2920 Perl_newOP(pTHX_ I32 type, I32 flags)
2924 NewOp(1101, o, 1, OP);
2925 o->op_type = (OPCODE)type;
2926 o->op_ppaddr = PL_ppaddr[type];
2927 o->op_flags = (U8)flags;
2929 o->op_latefreed = 0;
2933 o->op_private = (U8)(0 | (flags >> 8));
2934 if (PL_opargs[type] & OA_RETSCALAR)
2936 if (PL_opargs[type] & OA_TARGET)
2937 o->op_targ = pad_alloc(type, SVs_PADTMP);
2938 return CHECKOP(type, o);
2942 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2948 first = newOP(OP_STUB, 0);
2949 if (PL_opargs[type] & OA_MARK)
2950 first = force_list(first);
2952 NewOp(1101, unop, 1, UNOP);
2953 unop->op_type = (OPCODE)type;
2954 unop->op_ppaddr = PL_ppaddr[type];
2955 unop->op_first = first;
2956 unop->op_flags = (U8)(flags | OPf_KIDS);
2957 unop->op_private = (U8)(1 | (flags >> 8));
2958 unop = (UNOP*) CHECKOP(type, unop);
2962 return fold_constants((OP *) unop);
2966 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2970 NewOp(1101, binop, 1, BINOP);
2973 first = newOP(OP_NULL, 0);
2975 binop->op_type = (OPCODE)type;
2976 binop->op_ppaddr = PL_ppaddr[type];
2977 binop->op_first = first;
2978 binop->op_flags = (U8)(flags | OPf_KIDS);
2981 binop->op_private = (U8)(1 | (flags >> 8));
2984 binop->op_private = (U8)(2 | (flags >> 8));
2985 first->op_sibling = last;
2988 binop = (BINOP*)CHECKOP(type, binop);
2989 if (binop->op_next || binop->op_type != (OPCODE)type)
2992 binop->op_last = binop->op_first->op_sibling;
2994 return fold_constants((OP *)binop);
2997 static int uvcompare(const void *a, const void *b)
2998 __attribute__nonnull__(1)
2999 __attribute__nonnull__(2)
3000 __attribute__pure__;
3001 static int uvcompare(const void *a, const void *b)
3003 if (*((const UV *)a) < (*(const UV *)b))
3005 if (*((const UV *)a) > (*(const UV *)b))
3007 if (*((const UV *)a+1) < (*(const UV *)b+1))
3009 if (*((const UV *)a+1) > (*(const UV *)b+1))
3015 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
3018 SV * const tstr = ((SVOP*)expr)->op_sv;
3021 (repl->op_type == OP_NULL)
3022 ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
3024 ((SVOP*)repl)->op_sv;
3027 const U8 *t = (U8*)SvPV_const(tstr, tlen);
3028 const U8 *r = (U8*)SvPV_const(rstr, rlen);
3032 register short *tbl;
3034 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
3035 const I32 squash = o->op_private & OPpTRANS_SQUASH;
3036 I32 del = o->op_private & OPpTRANS_DELETE;
3038 PL_hints |= HINT_BLOCK_SCOPE;
3041 o->op_private |= OPpTRANS_FROM_UTF;
3044 o->op_private |= OPpTRANS_TO_UTF;
3046 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
3047 SV* const listsv = newSVpvs("# comment\n");
3049 const U8* tend = t + tlen;
3050 const U8* rend = r + rlen;
3064 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
3065 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
3068 const U32 flags = UTF8_ALLOW_DEFAULT;
3072 t = tsave = bytes_to_utf8(t, &len);
3075 if (!to_utf && rlen) {
3077 r = rsave = bytes_to_utf8(r, &len);
3081 /* There are several snags with this code on EBCDIC:
3082 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
3083 2. scan_const() in toke.c has encoded chars in native encoding which makes
3084 ranges at least in EBCDIC 0..255 range the bottom odd.
3088 U8 tmpbuf[UTF8_MAXBYTES+1];
3091 Newx(cp, 2*tlen, UV);
3093 transv = newSVpvs("");
3095 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3097 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
3099 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3103 cp[2*i+1] = cp[2*i];
3107 qsort(cp, i, 2*sizeof(UV), uvcompare);
3108 for (j = 0; j < i; j++) {
3110 diff = val - nextmin;
3112 t = uvuni_to_utf8(tmpbuf,nextmin);
3113 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3115 U8 range_mark = UTF_TO_NATIVE(0xff);
3116 t = uvuni_to_utf8(tmpbuf, val - 1);
3117 sv_catpvn(transv, (char *)&range_mark, 1);
3118 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3125 t = uvuni_to_utf8(tmpbuf,nextmin);
3126 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3128 U8 range_mark = UTF_TO_NATIVE(0xff);
3129 sv_catpvn(transv, (char *)&range_mark, 1);
3131 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
3132 UNICODE_ALLOW_SUPER);
3133 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3134 t = (const U8*)SvPVX_const(transv);
3135 tlen = SvCUR(transv);
3139 else if (!rlen && !del) {
3140 r = t; rlen = tlen; rend = tend;
3143 if ((!rlen && !del) || t == r ||
3144 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
3146 o->op_private |= OPpTRANS_IDENTICAL;
3150 while (t < tend || tfirst <= tlast) {
3151 /* see if we need more "t" chars */
3152 if (tfirst > tlast) {
3153 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3155 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
3157 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3164 /* now see if we need more "r" chars */
3165 if (rfirst > rlast) {
3167 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3169 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
3171 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3180 rfirst = rlast = 0xffffffff;
3184 /* now see which range will peter our first, if either. */
3185 tdiff = tlast - tfirst;
3186 rdiff = rlast - rfirst;
3193 if (rfirst == 0xffffffff) {
3194 diff = tdiff; /* oops, pretend rdiff is infinite */
3196 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
3197 (long)tfirst, (long)tlast);
3199 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
3203 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
3204 (long)tfirst, (long)(tfirst + diff),
3207 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3208 (long)tfirst, (long)rfirst);
3210 if (rfirst + diff > max)
3211 max = rfirst + diff;
3213 grows = (tfirst < rfirst &&
3214 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3226 else if (max > 0xff)
3231 PerlMemShared_free(cPVOPo->op_pv);
3232 cPVOPo->op_pv = NULL;
3234 swash = (SV*)swash_init("utf8", "", listsv, bits, none);
3236 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
3237 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
3238 PAD_SETSV(cPADOPo->op_padix, swash);
3241 cSVOPo->op_sv = swash;
3243 SvREFCNT_dec(listsv);
3244 SvREFCNT_dec(transv);
3246 if (!del && havefinal && rlen)
3247 (void)hv_store((HV*)SvRV(swash), "FINAL", 5,
3248 newSVuv((UV)final), 0);
3251 o->op_private |= OPpTRANS_GROWS;
3257 op_getmad(expr,o,'e');
3258 op_getmad(repl,o,'r');
3266 tbl = (short*)cPVOPo->op_pv;
3268 Zero(tbl, 256, short);
3269 for (i = 0; i < (I32)tlen; i++)
3271 for (i = 0, j = 0; i < 256; i++) {
3273 if (j >= (I32)rlen) {
3282 if (i < 128 && r[j] >= 128)
3292 o->op_private |= OPpTRANS_IDENTICAL;
3294 else if (j >= (I32)rlen)
3299 PerlMemShared_realloc(tbl,
3300 (0x101+rlen-j) * sizeof(short));
3301 cPVOPo->op_pv = (char*)tbl;
3303 tbl[0x100] = (short)(rlen - j);
3304 for (i=0; i < (I32)rlen - j; i++)
3305 tbl[0x101+i] = r[j+i];
3309 if (!rlen && !del) {
3312 o->op_private |= OPpTRANS_IDENTICAL;
3314 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3315 o->op_private |= OPpTRANS_IDENTICAL;
3317 for (i = 0; i < 256; i++)
3319 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3320 if (j >= (I32)rlen) {
3322 if (tbl[t[i]] == -1)
3328 if (tbl[t[i]] == -1) {
3329 if (t[i] < 128 && r[j] >= 128)
3336 o->op_private |= OPpTRANS_GROWS;
3338 op_getmad(expr,o,'e');
3339 op_getmad(repl,o,'r');
3349 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3354 NewOp(1101, pmop, 1, PMOP);
3355 pmop->op_type = (OPCODE)type;
3356 pmop->op_ppaddr = PL_ppaddr[type];
3357 pmop->op_flags = (U8)flags;
3358 pmop->op_private = (U8)(0 | (flags >> 8));
3360 if (PL_hints & HINT_RE_TAINT)
3361 pmop->op_pmflags |= PMf_RETAINT;
3362 if (PL_hints & HINT_LOCALE)
3363 pmop->op_pmflags |= PMf_LOCALE;
3367 if (av_len((AV*) PL_regex_pad[0]) > -1) {
3368 SV * const repointer = av_pop((AV*)PL_regex_pad[0]);
3369 pmop->op_pmoffset = SvIV(repointer);
3370 SvREPADTMP_off(repointer);
3371 sv_setiv(repointer,0);
3373 SV * const repointer = newSViv(0);
3374 av_push(PL_regex_padav, SvREFCNT_inc_simple_NN(repointer));
3375 pmop->op_pmoffset = av_len(PL_regex_padav);
3376 PL_regex_pad = AvARRAY(PL_regex_padav);
3380 return CHECKOP(type, pmop);
3383 /* Given some sort of match op o, and an expression expr containing a
3384 * pattern, either compile expr into a regex and attach it to o (if it's
3385 * constant), or convert expr into a runtime regcomp op sequence (if it's
3388 * isreg indicates that the pattern is part of a regex construct, eg
3389 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3390 * split "pattern", which aren't. In the former case, expr will be a list
3391 * if the pattern contains more than one term (eg /a$b/) or if it contains
3392 * a replacement, ie s/// or tr///.
3396 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
3401 I32 repl_has_vars = 0;
3405 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
3406 /* last element in list is the replacement; pop it */
3408 repl = cLISTOPx(expr)->op_last;
3409 kid = cLISTOPx(expr)->op_first;
3410 while (kid->op_sibling != repl)
3411 kid = kid->op_sibling;
3412 kid->op_sibling = NULL;
3413 cLISTOPx(expr)->op_last = kid;
3416 if (isreg && expr->op_type == OP_LIST &&
3417 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3419 /* convert single element list to element */
3420 OP* const oe = expr;
3421 expr = cLISTOPx(oe)->op_first->op_sibling;
3422 cLISTOPx(oe)->op_first->op_sibling = NULL;
3423 cLISTOPx(oe)->op_last = NULL;
3427 if (o->op_type == OP_TRANS) {
3428 return pmtrans(o, expr, repl);
3431 reglist = isreg && expr->op_type == OP_LIST;
3435 PL_hints |= HINT_BLOCK_SCOPE;
3438 if (expr->op_type == OP_CONST) {
3439 SV *pat = ((SVOP*)expr)->op_sv;
3440 U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
3442 if (o->op_flags & OPf_SPECIAL)
3443 pm_flags |= RXf_SPLIT;
3446 assert (SvUTF8(pat));
3447 } else if (SvUTF8(pat)) {
3448 /* Not doing UTF-8, despite what the SV says. Is this only if we're
3449 trapped in use 'bytes'? */
3450 /* Make a copy of the octet sequence, but without the flag on, as
3451 the compiler now honours the SvUTF8 flag on pat. */
3453 const char *const p = SvPV(pat, len);
3454 pat = newSVpvn_flags(p, len, SVs_TEMP);
3457 PM_SETRE(pm, CALLREGCOMP(pat, pm_flags));
3460 op_getmad(expr,(OP*)pm,'e');
3466 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3467 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3469 : OP_REGCMAYBE),0,expr);
3471 NewOp(1101, rcop, 1, LOGOP);
3472 rcop->op_type = OP_REGCOMP;
3473 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3474 rcop->op_first = scalar(expr);
3475 rcop->op_flags |= OPf_KIDS
3476 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3477 | (reglist ? OPf_STACKED : 0);
3478 rcop->op_private = 1;
3481 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3483 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
3486 /* establish postfix order */
3487 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3489 rcop->op_next = expr;
3490 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3493 rcop->op_next = LINKLIST(expr);
3494 expr->op_next = (OP*)rcop;
3497 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3502 if (pm->op_pmflags & PMf_EVAL) {
3504 if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
3505 CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
3507 else if (repl->op_type == OP_CONST)
3511 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3512 if (curop->op_type == OP_SCOPE
3513 || curop->op_type == OP_LEAVE
3514 || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
3515 if (curop->op_type == OP_GV) {
3516 GV * const gv = cGVOPx_gv(curop);
3518 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3521 else if (curop->op_type == OP_RV2CV)
3523 else if (curop->op_type == OP_RV2SV ||
3524 curop->op_type == OP_RV2AV ||
3525 curop->op_type == OP_RV2HV ||
3526 curop->op_type == OP_RV2GV) {
3527 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3530 else if (curop->op_type == OP_PADSV ||
3531 curop->op_type == OP_PADAV ||
3532 curop->op_type == OP_PADHV ||
3533 curop->op_type == OP_PADANY)
3537 else if (curop->op_type == OP_PUSHRE)
3538 NOOP; /* Okay here, dangerous in newASSIGNOP */
3548 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
3550 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3551 prepend_elem(o->op_type, scalar(repl), o);
3554 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3555 pm->op_pmflags |= PMf_MAYBE_CONST;
3557 NewOp(1101, rcop, 1, LOGOP);
3558 rcop->op_type = OP_SUBSTCONT;
3559 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3560 rcop->op_first = scalar(repl);
3561 rcop->op_flags |= OPf_KIDS;
3562 rcop->op_private = 1;
3565 /* establish postfix order */
3566 rcop->op_next = LINKLIST(repl);
3567 repl->op_next = (OP*)rcop;
3569 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
3570 assert(!(pm->op_pmflags & PMf_ONCE));
3571 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
3580 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3584 NewOp(1101, svop, 1, SVOP);
3585 svop->op_type = (OPCODE)type;
3586 svop->op_ppaddr = PL_ppaddr[type];
3588 svop->op_next = (OP*)svop;
3589 svop->op_flags = (U8)flags;
3590 if (PL_opargs[type] & OA_RETSCALAR)
3592 if (PL_opargs[type] & OA_TARGET)
3593 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3594 return CHECKOP(type, svop);
3599 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3603 NewOp(1101, padop, 1, PADOP);
3604 padop->op_type = (OPCODE)type;
3605 padop->op_ppaddr = PL_ppaddr[type];
3606 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3607 SvREFCNT_dec(PAD_SVl(padop->op_padix));
3608 PAD_SETSV(padop->op_padix, sv);
3611 padop->op_next = (OP*)padop;
3612 padop->op_flags = (U8)flags;
3613 if (PL_opargs[type] & OA_RETSCALAR)
3615 if (PL_opargs[type] & OA_TARGET)
3616 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3617 return CHECKOP(type, padop);
3622 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3628 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3630 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3635 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3639 NewOp(1101, pvop, 1, PVOP);
3640 pvop->op_type = (OPCODE)type;
3641 pvop->op_ppaddr = PL_ppaddr[type];
3643 pvop->op_next = (OP*)pvop;
3644 pvop->op_flags = (U8)flags;
3645 if (PL_opargs[type] & OA_RETSCALAR)
3647 if (PL_opargs[type] & OA_TARGET)
3648 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3649 return CHECKOP(type, pvop);
3657 Perl_package(pTHX_ OP *o)
3660 SV *const sv = cSVOPo->op_sv;
3665 save_hptr(&PL_curstash);
3666 save_item(PL_curstname);
3668 PL_curstash = gv_stashsv(sv, GV_ADD);
3670 sv_setsv(PL_curstname, sv);
3672 PL_hints |= HINT_BLOCK_SCOPE;
3673 PL_parser->copline = NOLINE;
3674 PL_parser->expect = XSTATE;
3679 if (!PL_madskills) {
3684 pegop = newOP(OP_NULL,0);
3685 op_getmad(o,pegop,'P');
3695 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3702 OP *pegop = newOP(OP_NULL,0);
3705 if (idop->op_type != OP_CONST)
3706 Perl_croak(aTHX_ "Module name must be constant");
3709 op_getmad(idop,pegop,'U');
3714 SV * const vesv = ((SVOP*)version)->op_sv;
3717 op_getmad(version,pegop,'V');
3718 if (!arg && !SvNIOKp(vesv)) {
3725 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3726 Perl_croak(aTHX_ "Version number must be constant number");
3728 /* Make copy of idop so we don't free it twice */
3729 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3731 /* Fake up a method call to VERSION */
3732 meth = newSVpvs_share("VERSION");
3733 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3734 append_elem(OP_LIST,
3735 prepend_elem(OP_LIST, pack, list(version)),
3736 newSVOP(OP_METHOD_NAMED, 0, meth)));
3740 /* Fake up an import/unimport */
3741 if (arg && arg->op_type == OP_STUB) {
3743 op_getmad(arg,pegop,'S');
3744 imop = arg; /* no import on explicit () */
3746 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3747 imop = NULL; /* use 5.0; */
3749 idop->op_private |= OPpCONST_NOVER;
3755 op_getmad(arg,pegop,'A');
3757 /* Make copy of idop so we don't free it twice */
3758 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3760 /* Fake up a method call to import/unimport */
3762 ? newSVpvs_share("import") : newSVpvs_share("unimport");
3763 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3764 append_elem(OP_LIST,
3765 prepend_elem(OP_LIST, pack, list(arg)),
3766 newSVOP(OP_METHOD_NAMED, 0, meth)));
3769 /* Fake up the BEGIN {}, which does its thing immediately. */
3771 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
3774 append_elem(OP_LINESEQ,
3775 append_elem(OP_LINESEQ,
3776 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
3777 newSTATEOP(0, NULL, veop)),
3778 newSTATEOP(0, NULL, imop) ));
3780 /* The "did you use incorrect case?" warning used to be here.
3781 * The problem is that on case-insensitive filesystems one
3782 * might get false positives for "use" (and "require"):
3783 * "use Strict" or "require CARP" will work. This causes
3784 * portability problems for the script: in case-strict
3785 * filesystems the script will stop working.
3787 * The "incorrect case" warning checked whether "use Foo"
3788 * imported "Foo" to your namespace, but that is wrong, too:
3789 * there is no requirement nor promise in the language that
3790 * a Foo.pm should or would contain anything in package "Foo".
3792 * There is very little Configure-wise that can be done, either:
3793 * the case-sensitivity of the build filesystem of Perl does not
3794 * help in guessing the case-sensitivity of the runtime environment.
3797 PL_hints |= HINT_BLOCK_SCOPE;
3798 PL_parser->copline = NOLINE;
3799 PL_parser->expect = XSTATE;
3800 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3803 if (!PL_madskills) {
3804 /* FIXME - don't allocate pegop if !PL_madskills */
3813 =head1 Embedding Functions
3815 =for apidoc load_module
3817 Loads the module whose name is pointed to by the string part of name.
3818 Note that the actual module name, not its filename, should be given.
3819 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3820 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3821 (or 0 for no flags). ver, if specified, provides version semantics
3822 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3823 arguments can be used to specify arguments to the module's import()
3824 method, similar to C<use Foo::Bar VERSION LIST>.
3829 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3832 va_start(args, ver);
3833 vload_module(flags, name, ver, &args);
3837 #ifdef PERL_IMPLICIT_CONTEXT
3839 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3843 va_start(args, ver);
3844 vload_module(flags, name, ver, &args);
3850 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3855 OP * const modname = newSVOP(OP_CONST, 0, name);
3856 modname->op_private |= OPpCONST_BARE;
3858 veop = newSVOP(OP_CONST, 0, ver);
3862 if (flags & PERL_LOADMOD_NOIMPORT) {
3863 imop = sawparens(newNULLLIST());
3865 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3866 imop = va_arg(*args, OP*);
3871 sv = va_arg(*args, SV*);
3873 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3874 sv = va_arg(*args, SV*);
3878 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
3879 * that it has a PL_parser to play with while doing that, and also
3880 * that it doesn't mess with any existing parser, by creating a tmp
3881 * new parser with lex_start(). This won't actually be used for much,
3882 * since pp_require() will create another parser for the real work. */
3885 SAVEVPTR(PL_curcop);
3886 lex_start(NULL, NULL, FALSE);
3887 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3888 veop, modname, imop);
3893 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
3899 if (!force_builtin) {
3900 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
3901 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
3902 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
3903 gv = gvp ? *gvp : NULL;
3907 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3908 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3909 append_elem(OP_LIST, term,
3910 scalar(newUNOP(OP_RV2CV, 0,
3911 newGVOP(OP_GV, 0, gv))))));
3914 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3920 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3922 return newBINOP(OP_LSLICE, flags,
3923 list(force_list(subscript)),
3924 list(force_list(listval)) );
3928 S_is_list_assignment(pTHX_ register const OP *o)
3936 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
3937 o = cUNOPo->op_first;
3939 flags = o->op_flags;
3941 if (type == OP_COND_EXPR) {
3942 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
3943 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3948 yyerror("Assignment to both a list and a scalar");
3952 if (type == OP_LIST &&
3953 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
3954 o->op_private & OPpLVAL_INTRO)
3957 if (type == OP_LIST || flags & OPf_PARENS ||
3958 type == OP_RV2AV || type == OP_RV2HV ||
3959 type == OP_ASLICE || type == OP_HSLICE)
3962 if (type == OP_PADAV || type == OP_PADHV)
3965 if (type == OP_RV2SV)
3972 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3978 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3979 return newLOGOP(optype, 0,
3980 mod(scalar(left), optype),
3981 newUNOP(OP_SASSIGN, 0, scalar(right)));
3984 return newBINOP(optype, OPf_STACKED,
3985 mod(scalar(left), optype), scalar(right));
3989 if (is_list_assignment(left)) {
3990 static const char no_list_state[] = "Initialization of state variables"
3991 " in list context currently forbidden";
3995 /* Grandfathering $[ assignment here. Bletch.*/
3996 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
3997 PL_eval_start = (left->op_type == OP_CONST) ? right : NULL;
3998 left = mod(left, OP_AASSIGN);
4001 else if (left->op_type == OP_CONST) {
4003 /* Result of assignment is always 1 (or we'd be dead already) */
4004 return newSVOP(OP_CONST, 0, newSViv(1));
4006 curop = list(force_list(left));
4007 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
4008 o->op_private = (U8)(0 | (flags >> 8));
4010 /* PL_generation sorcery:
4011 * an assignment like ($a,$b) = ($c,$d) is easier than
4012 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
4013 * To detect whether there are common vars, the global var
4014 * PL_generation is incremented for each assign op we compile.
4015 * Then, while compiling the assign op, we run through all the
4016 * variables on both sides of the assignment, setting a spare slot
4017 * in each of them to PL_generation. If any of them already have
4018 * that value, we know we've got commonality. We could use a
4019 * single bit marker, but then we'd have to make 2 passes, first
4020 * to clear the flag, then to test and set it. To find somewhere
4021 * to store these values, evil chicanery is done with SvUVX().
4027 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4028 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
4029 if (curop->op_type == OP_GV) {
4030 GV *gv = cGVOPx_gv(curop);
4032 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4034 GvASSIGN_GENERATION_set(gv, PL_generation);
4036 else if (curop->op_type == OP_PADSV ||
4037 curop->op_type == OP_PADAV ||
4038 curop->op_type == OP_PADHV ||
4039 curop->op_type == OP_PADANY)
4041 if (PAD_COMPNAME_GEN(curop->op_targ)
4042 == (STRLEN)PL_generation)
4044 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
4047 else if (curop->op_type == OP_RV2CV)
4049 else if (curop->op_type == OP_RV2SV ||
4050 curop->op_type == OP_RV2AV ||
4051 curop->op_type == OP_RV2HV ||
4052 curop->op_type == OP_RV2GV) {
4053 if (lastop->op_type != OP_GV) /* funny deref? */
4056 else if (curop->op_type == OP_PUSHRE) {
4058 if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
4059 GV *const gv = (GV*)PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff);
4061 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4063 GvASSIGN_GENERATION_set(gv, PL_generation);
4067 = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
4070 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4072 GvASSIGN_GENERATION_set(gv, PL_generation);
4082 o->op_private |= OPpASSIGN_COMMON;
4085 if ((left->op_type == OP_LIST
4086 || (left->op_type == OP_NULL && left->op_targ == OP_LIST))) {
4087 OP* lop = ((LISTOP*)left)->op_first;
4089 if (lop->op_type == OP_PADSV ||
4090 lop->op_type == OP_PADAV ||
4091 lop->op_type == OP_PADHV ||
4092 lop->op_type == OP_PADANY) {
4093 if (lop->op_private & OPpPAD_STATE) {
4094 if (left->op_private & OPpLVAL_INTRO) {
4095 /* Each variable in state($a, $b, $c) = ... */
4098 /* Each state variable in
4099 (state $a, my $b, our $c, $d, undef) = ... */
4101 yyerror(no_list_state);
4103 /* Each my variable in
4104 (state $a, my $b, our $c, $d, undef) = ... */
4107 /* Other ops in the list. undef may be interesting in
4108 (state $a, undef, state $c) */
4110 lop = lop->op_sibling;
4113 else if (((left->op_private & (OPpLVAL_INTRO | OPpPAD_STATE))
4114 == (OPpLVAL_INTRO | OPpPAD_STATE))
4115 && ( left->op_type == OP_PADSV
4116 || left->op_type == OP_PADAV
4117 || left->op_type == OP_PADHV
4118 || left->op_type == OP_PADANY))
4120 /* All single variable list context state assignments, hence
4130 yyerror(no_list_state);
4133 if (right && right->op_type == OP_SPLIT && !PL_madskills) {
4134 OP* tmpop = ((LISTOP*)right)->op_first;
4135 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
4136 PMOP * const pm = (PMOP*)tmpop;
4137 if (left->op_type == OP_RV2AV &&
4138 !(left->op_private & OPpLVAL_INTRO) &&
4139 !(o->op_private & OPpASSIGN_COMMON) )
4141 tmpop = ((UNOP*)left)->op_first;
4142 if (tmpop->op_type == OP_GV
4144 && !pm->op_pmreplrootu.op_pmtargetoff
4146 && !pm->op_pmreplrootu.op_pmtargetgv
4150 pm->op_pmreplrootu.op_pmtargetoff
4151 = cPADOPx(tmpop)->op_padix;
4152 cPADOPx(tmpop)->op_padix = 0; /* steal it */
4154 pm->op_pmreplrootu.op_pmtargetgv
4155 = (GV*)cSVOPx(tmpop)->op_sv;
4156 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
4158 pm->op_pmflags |= PMf_ONCE;
4159 tmpop = cUNOPo->op_first; /* to list (nulled) */
4160 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
4161 tmpop->op_sibling = NULL; /* don't free split */
4162 right->op_next = tmpop->op_next; /* fix starting loc */
4163 op_free(o); /* blow off assign */
4164 right->op_flags &= ~OPf_WANT;
4165 /* "I don't know and I don't care." */
4170 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
4171 ((LISTOP*)right)->op_last->op_type == OP_CONST)
4173 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
4175 sv_setiv(sv, PL_modcount+1);
4183 right = newOP(OP_UNDEF, 0);
4184 if (right->op_type == OP_READLINE) {
4185 right->op_flags |= OPf_STACKED;
4186 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
4189 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
4190 o = newBINOP(OP_SASSIGN, flags,
4191 scalar(right), mod(scalar(left), OP_SASSIGN) );
4197 o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
4198 o->op_private |= OPpCONST_ARYBASE;
4205 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
4208 const U32 seq = intro_my();
4211 NewOp(1101, cop, 1, COP);
4212 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
4213 cop->op_type = OP_DBSTATE;
4214 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
4217 cop->op_type = OP_NEXTSTATE;
4218 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
4220 cop->op_flags = (U8)flags;
4221 CopHINTS_set(cop, PL_hints);
4223 cop->op_private |= NATIVE_HINTS;
4225 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
4226 cop->op_next = (OP*)cop;
4229 CopLABEL_set(cop, label);
4230 PL_hints |= HINT_BLOCK_SCOPE;
4233 /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
4234 CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
4236 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
4237 cop->cop_hints_hash = PL_curcop->cop_hints_hash;
4238 if (cop->cop_hints_hash) {
4240 cop->cop_hints_hash->refcounted_he_refcnt++;
4241 HINTS_REFCNT_UNLOCK;
4244 if (PL_parser && PL_parser->copline == NOLINE)
4245 CopLINE_set(cop, CopLINE(PL_curcop));
4247 CopLINE_set(cop, PL_parser->copline);
4249 PL_parser->copline = NOLINE;
4252 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
4254 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
4256 CopSTASH_set(cop, PL_curstash);
4258 if (PERLDB_LINE && PL_curstash != PL_debstash) {
4259 AV *av = CopFILEAVx(PL_curcop);
4261 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
4262 if (svp && *svp != &PL_sv_undef ) {
4263 (void)SvIOK_on(*svp);
4264 SvIV_set(*svp, PTR2IV(cop));
4269 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
4274 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
4277 return new_logop(type, flags, &first, &other);
4281 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
4286 OP *first = *firstp;
4287 OP * const other = *otherp;
4289 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
4290 return newBINOP(type, flags, scalar(first), scalar(other));
4292 scalarboolean(first);
4293 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
4294 if (first->op_type == OP_NOT
4295 && (first->op_flags & OPf_SPECIAL)
4296 && (first->op_flags & OPf_KIDS)
4298 if (type == OP_AND || type == OP_OR) {
4304 first = *firstp = cUNOPo->op_first;
4306 first->op_next = o->op_next;
4307 cUNOPo->op_first = NULL;
4311 if (first->op_type == OP_CONST) {
4312 if (first->op_private & OPpCONST_STRICT)
4313 no_bareword_allowed(first);
4314 else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
4315 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
4316 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
4317 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
4318 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
4320 if (other->op_type == OP_CONST)
4321 other->op_private |= OPpCONST_SHORTCIRCUIT;
4323 OP *newop = newUNOP(OP_NULL, 0, other);
4324 op_getmad(first, newop, '1');
4325 newop->op_targ = type; /* set "was" field */
4332 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
4333 const OP *o2 = other;
4334 if ( ! (o2->op_type == OP_LIST
4335 && (( o2 = cUNOPx(o2)->op_first))
4336 && o2->op_type == OP_PUSHMARK
4337 && (( o2 = o2->op_sibling)) )
4340 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
4341 || o2->op_type == OP_PADHV)
4342 && o2->op_private & OPpLVAL_INTRO
4343 && !(o2->op_private & OPpPAD_STATE)
4344 && ckWARN(WARN_DEPRECATED))
4346 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4347 "Deprecated use of my() in false conditional");
4351 if (first->op_type == OP_CONST)
4352 first->op_private |= OPpCONST_SHORTCIRCUIT;
4354 first = newUNOP(OP_NULL, 0, first);
4355 op_getmad(other, first, '2');
4356 first->op_targ = type; /* set "was" field */
4363 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
4364 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
4366 const OP * const k1 = ((UNOP*)first)->op_first;
4367 const OP * const k2 = k1->op_sibling;
4369 switch (first->op_type)
4372 if (k2 && k2->op_type == OP_READLINE
4373 && (k2->op_flags & OPf_STACKED)
4374 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4376 warnop = k2->op_type;
4381 if (k1->op_type == OP_READDIR
4382 || k1->op_type == OP_GLOB
4383 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4384 || k1->op_type == OP_EACH)
4386 warnop = ((k1->op_type == OP_NULL)
4387 ? (OPCODE)k1->op_targ : k1->op_type);
4392 const line_t oldline = CopLINE(PL_curcop);
4393 CopLINE_set(PL_curcop, PL_parser->copline);
4394 Perl_warner(aTHX_ packWARN(WARN_MISC),
4395 "Value of %s%s can be \"0\"; test with defined()",
4397 ((warnop == OP_READLINE || warnop == OP_GLOB)
4398 ? " construct" : "() operator"));
4399 CopLINE_set(PL_curcop, oldline);
4406 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
4407 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
4409 NewOp(1101, logop, 1, LOGOP);
4411 logop->op_type = (OPCODE)type;
4412 logop->op_ppaddr = PL_ppaddr[type];
4413 logop->op_first = first;
4414 logop->op_flags = (U8)(flags | OPf_KIDS);
4415 logop->op_other = LINKLIST(other);
4416 logop->op_private = (U8)(1 | (flags >> 8));
4418 /* establish postfix order */
4419 logop->op_next = LINKLIST(first);
4420 first->op_next = (OP*)logop;
4421 first->op_sibling = other;
4423 CHECKOP(type,logop);
4425 o = newUNOP(OP_NULL, 0, (OP*)logop);
4432 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
4440 return newLOGOP(OP_AND, 0, first, trueop);
4442 return newLOGOP(OP_OR, 0, first, falseop);
4444 scalarboolean(first);
4445 if (first->op_type == OP_CONST) {
4446 /* Left or right arm of the conditional? */
4447 const bool left = SvTRUE(((SVOP*)first)->op_sv);
4448 OP *live = left ? trueop : falseop;
4449 OP *const dead = left ? falseop : trueop;
4450 if (first->op_private & OPpCONST_BARE &&
4451 first->op_private & OPpCONST_STRICT) {
4452 no_bareword_allowed(first);
4455 /* This is all dead code when PERL_MAD is not defined. */
4456 live = newUNOP(OP_NULL, 0, live);
4457 op_getmad(first, live, 'C');
4458 op_getmad(dead, live, left ? 'e' : 't');
4465 NewOp(1101, logop, 1, LOGOP);
4466 logop->op_type = OP_COND_EXPR;
4467 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4468 logop->op_first = first;
4469 logop->op_flags = (U8)(flags | OPf_KIDS);
4470 logop->op_private = (U8)(1 | (flags >> 8));
4471 logop->op_other = LINKLIST(trueop);
4472 logop->op_next = LINKLIST(falseop);
4474 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
4477 /* establish postfix order */
4478 start = LINKLIST(first);
4479 first->op_next = (OP*)logop;
4481 first->op_sibling = trueop;
4482 trueop->op_sibling = falseop;
4483 o = newUNOP(OP_NULL, 0, (OP*)logop);
4485 trueop->op_next = falseop->op_next = o;
4492 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4501 NewOp(1101, range, 1, LOGOP);
4503 range->op_type = OP_RANGE;
4504 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4505 range->op_first = left;
4506 range->op_flags = OPf_KIDS;
4507 leftstart = LINKLIST(left);
4508 range->op_other = LINKLIST(right);
4509 range->op_private = (U8)(1 | (flags >> 8));
4511 left->op_sibling = right;
4513 range->op_next = (OP*)range;
4514 flip = newUNOP(OP_FLIP, flags, (OP*)range);
4515 flop = newUNOP(OP_FLOP, 0, flip);
4516 o = newUNOP(OP_NULL, 0, flop);
4518 range->op_next = leftstart;
4520 left->op_next = flip;
4521 right->op_next = flop;
4523 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4524 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4525 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4526 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4528 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4529 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4532 if (!flip->op_private || !flop->op_private)
4533 linklist(o); /* blow off optimizer unless constant */
4539 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4544 const bool once = block && block->op_flags & OPf_SPECIAL &&
4545 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4547 PERL_UNUSED_ARG(debuggable);
4550 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4551 return block; /* do {} while 0 does once */
4552 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4553 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4554 expr = newUNOP(OP_DEFINED, 0,
4555 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4556 } else if (expr->op_flags & OPf_KIDS) {
4557 const OP * const k1 = ((UNOP*)expr)->op_first;
4558 const OP * const k2 = k1 ? k1->op_sibling : NULL;
4559 switch (expr->op_type) {
4561 if (k2 && k2->op_type == OP_READLINE
4562 && (k2->op_flags & OPf_STACKED)
4563 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4564 expr = newUNOP(OP_DEFINED, 0, expr);
4568 if (k1 && (k1->op_type == OP_READDIR
4569 || k1->op_type == OP_GLOB
4570 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4571 || k1->op_type == OP_EACH))
4572 expr = newUNOP(OP_DEFINED, 0, expr);
4578 /* if block is null, the next append_elem() would put UNSTACK, a scalar
4579 * op, in listop. This is wrong. [perl #27024] */
4581 block = newOP(OP_NULL, 0);
4582 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4583 o = new_logop(OP_AND, 0, &expr, &listop);
4586 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4588 if (once && o != listop)
4589 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4592 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
4594 o->op_flags |= flags;
4596 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4601 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
4602 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
4611 PERL_UNUSED_ARG(debuggable);
4614 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4615 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4616 expr = newUNOP(OP_DEFINED, 0,
4617 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4618 } else if (expr->op_flags & OPf_KIDS) {
4619 const OP * const k1 = ((UNOP*)expr)->op_first;
4620 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
4621 switch (expr->op_type) {
4623 if (k2 && k2->op_type == OP_READLINE
4624 && (k2->op_flags & OPf_STACKED)
4625 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4626 expr = newUNOP(OP_DEFINED, 0, expr);
4630 if (k1 && (k1->op_type == OP_READDIR
4631 || k1->op_type == OP_GLOB
4632 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4633 || k1->op_type == OP_EACH))
4634 expr = newUNOP(OP_DEFINED, 0, expr);
4641 block = newOP(OP_NULL, 0);
4642 else if (cont || has_my) {
4643 block = scope(block);
4647 next = LINKLIST(cont);
4650 OP * const unstack = newOP(OP_UNSTACK, 0);
4653 cont = append_elem(OP_LINESEQ, cont, unstack);
4657 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4659 redo = LINKLIST(listop);
4662 PL_parser->copline = (line_t)whileline;
4664 o = new_logop(OP_AND, 0, &expr, &listop);
4665 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4666 op_free(expr); /* oops, it's a while (0) */
4668 return NULL; /* listop already freed by new_logop */
4671 ((LISTOP*)listop)->op_last->op_next =
4672 (o == listop ? redo : LINKLIST(o));
4678 NewOp(1101,loop,1,LOOP);
4679 loop->op_type = OP_ENTERLOOP;
4680 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4681 loop->op_private = 0;
4682 loop->op_next = (OP*)loop;
4685 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4687 loop->op_redoop = redo;
4688 loop->op_lastop = o;
4689 o->op_private |= loopflags;
4692 loop->op_nextop = next;
4694 loop->op_nextop = o;
4696 o->op_flags |= flags;
4697 o->op_private |= (flags >> 8);
4702 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
4707 PADOFFSET padoff = 0;
4713 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4714 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
4715 sv->op_type = OP_RV2GV;
4716 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4718 /* The op_type check is needed to prevent a possible segfault
4719 * if the loop variable is undeclared and 'strict vars' is in
4720 * effect. This is illegal but is nonetheless parsed, so we
4721 * may reach this point with an OP_CONST where we're expecting
4724 if (cUNOPx(sv)->op_first->op_type == OP_GV
4725 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
4726 iterpflags |= OPpITER_DEF;
4728 else if (sv->op_type == OP_PADSV) { /* private variable */
4729 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
4730 padoff = sv->op_targ;
4740 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4742 SV *const namesv = PAD_COMPNAME_SV(padoff);
4744 const char *const name = SvPV_const(namesv, len);
4746 if (len == 2 && name[0] == '$' && name[1] == '_')
4747 iterpflags |= OPpITER_DEF;
4751 const PADOFFSET offset = pad_findmy("$_");
4752 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
4753 sv = newGVOP(OP_GV, 0, PL_defgv);
4758 iterpflags |= OPpITER_DEF;
4760 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4761 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4762 iterflags |= OPf_STACKED;
4764 else if (expr->op_type == OP_NULL &&
4765 (expr->op_flags & OPf_KIDS) &&
4766 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4768 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4769 * set the STACKED flag to indicate that these values are to be
4770 * treated as min/max values by 'pp_iterinit'.
4772 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4773 LOGOP* const range = (LOGOP*) flip->op_first;
4774 OP* const left = range->op_first;
4775 OP* const right = left->op_sibling;
4778 range->op_flags &= ~OPf_KIDS;
4779 range->op_first = NULL;
4781 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4782 listop->op_first->op_next = range->op_next;
4783 left->op_next = range->op_other;
4784 right->op_next = (OP*)listop;
4785 listop->op_next = listop->op_first;
4788 op_getmad(expr,(OP*)listop,'O');
4792 expr = (OP*)(listop);
4794 iterflags |= OPf_STACKED;
4797 expr = mod(force_list(expr), OP_GREPSTART);
4800 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4801 append_elem(OP_LIST, expr, scalar(sv))));
4802 assert(!loop->op_next);
4803 /* for my $x () sets OPpLVAL_INTRO;
4804 * for our $x () sets OPpOUR_INTRO */
4805 loop->op_private = (U8)iterpflags;
4806 #ifdef PL_OP_SLAB_ALLOC
4809 NewOp(1234,tmp,1,LOOP);
4810 Copy(loop,tmp,1,LISTOP);
4811 S_op_destroy(aTHX_ (OP*)loop);
4815 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
4817 loop->op_targ = padoff;
4818 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
4820 op_getmad(madsv, (OP*)loop, 'v');
4821 PL_parser->copline = forline;
4822 return newSTATEOP(0, label, wop);
4826 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4831 if (type != OP_GOTO || label->op_type == OP_CONST) {
4832 /* "last()" means "last" */
4833 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4834 o = newOP(type, OPf_SPECIAL);
4836 o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
4837 ? SvPV_nolen_const(((SVOP*)label)->op_sv)
4841 op_getmad(label,o,'L');
4847 /* Check whether it's going to be a goto &function */
4848 if (label->op_type == OP_ENTERSUB
4849 && !(label->op_flags & OPf_STACKED))
4850 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4851 o = newUNOP(type, OPf_STACKED, label);
4853 PL_hints |= HINT_BLOCK_SCOPE;
4857 /* if the condition is a literal array or hash
4858 (or @{ ... } etc), make a reference to it.
4861 S_ref_array_or_hash(pTHX_ OP *cond)
4864 && (cond->op_type == OP_RV2AV
4865 || cond->op_type == OP_PADAV
4866 || cond->op_type == OP_RV2HV
4867 || cond->op_type == OP_PADHV))
4869 return newUNOP(OP_REFGEN,
4870 0, mod(cond, OP_REFGEN));
4876 /* These construct the optree fragments representing given()
4879 entergiven and enterwhen are LOGOPs; the op_other pointer
4880 points up to the associated leave op. We need this so we
4881 can put it in the context and make break/continue work.
4882 (Also, of course, pp_enterwhen will jump straight to
4883 op_other if the match fails.)
4887 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
4888 I32 enter_opcode, I32 leave_opcode,
4889 PADOFFSET entertarg)
4895 NewOp(1101, enterop, 1, LOGOP);
4896 enterop->op_type = enter_opcode;
4897 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
4898 enterop->op_flags = (U8) OPf_KIDS;
4899 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
4900 enterop->op_private = 0;
4902 o = newUNOP(leave_opcode, 0, (OP *) enterop);
4905 enterop->op_first = scalar(cond);
4906 cond->op_sibling = block;
4908 o->op_next = LINKLIST(cond);
4909 cond->op_next = (OP *) enterop;
4912 /* This is a default {} block */
4913 enterop->op_first = block;
4914 enterop->op_flags |= OPf_SPECIAL;
4916 o->op_next = (OP *) enterop;
4919 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
4920 entergiven and enterwhen both
4923 enterop->op_next = LINKLIST(block);
4924 block->op_next = enterop->op_other = o;
4929 /* Does this look like a boolean operation? For these purposes
4930 a boolean operation is:
4931 - a subroutine call [*]
4932 - a logical connective
4933 - a comparison operator
4934 - a filetest operator, with the exception of -s -M -A -C
4935 - defined(), exists() or eof()
4936 - /$re/ or $foo =~ /$re/
4938 [*] possibly surprising
4941 S_looks_like_bool(pTHX_ const OP *o)
4944 switch(o->op_type) {
4946 return looks_like_bool(cLOGOPo->op_first);
4950 looks_like_bool(cLOGOPo->op_first)
4951 && looks_like_bool(cLOGOPo->op_first->op_sibling));
4955 o->op_flags & OPf_KIDS
4956 && looks_like_bool(cUNOPo->op_first));
4960 case OP_NOT: case OP_XOR:
4961 /* Note that OP_DOR is not here */
4963 case OP_EQ: case OP_NE: case OP_LT:
4964 case OP_GT: case OP_LE: case OP_GE:
4966 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
4967 case OP_I_GT: case OP_I_LE: case OP_I_GE:
4969 case OP_SEQ: case OP_SNE: case OP_SLT:
4970 case OP_SGT: case OP_SLE: case OP_SGE:
4974 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
4975 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
4976 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
4977 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
4978 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
4979 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
4980 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
4981 case OP_FTTEXT: case OP_FTBINARY:
4983 case OP_DEFINED: case OP_EXISTS:
4984 case OP_MATCH: case OP_EOF:
4989 /* Detect comparisons that have been optimized away */
4990 if (cSVOPo->op_sv == &PL_sv_yes
4991 || cSVOPo->op_sv == &PL_sv_no)
5002 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
5006 return newGIVWHENOP(
5007 ref_array_or_hash(cond),
5009 OP_ENTERGIVEN, OP_LEAVEGIVEN,
5013 /* If cond is null, this is a default {} block */
5015 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
5017 const bool cond_llb = (!cond || looks_like_bool(cond));
5023 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
5025 scalar(ref_array_or_hash(cond)));
5028 return newGIVWHENOP(
5030 append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
5031 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
5035 =for apidoc cv_undef
5037 Clear out all the active components of a CV. This can happen either
5038 by an explicit C<undef &foo>, or by the reference count going to zero.
5039 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
5040 children can still follow the full lexical scope chain.
5046 Perl_cv_undef(pTHX_ CV *cv)
5050 DEBUG_X(PerlIO_printf(Perl_debug_log,
5051 "CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n",
5052 PTR2UV(cv), PTR2UV(PL_comppad))
5056 if (CvFILE(cv) && !CvISXSUB(cv)) {
5057 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
5058 Safefree(CvFILE(cv));
5063 if (!CvISXSUB(cv) && CvROOT(cv)) {
5064 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
5065 Perl_croak(aTHX_ "Can't undef active subroutine");
5068 PAD_SAVE_SETNULLPAD();
5070 op_free(CvROOT(cv));
5075 SvPOK_off((SV*)cv); /* forget prototype */
5080 /* remove CvOUTSIDE unless this is an undef rather than a free */
5081 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
5082 if (!CvWEAKOUTSIDE(cv))
5083 SvREFCNT_dec(CvOUTSIDE(cv));
5084 CvOUTSIDE(cv) = NULL;
5087 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
5090 if (CvISXSUB(cv) && CvXSUB(cv)) {
5093 /* delete all flags except WEAKOUTSIDE */
5094 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
5098 Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
5101 /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
5102 relying on SvCUR, and doubling up the buffer to hold CvFILE(). */
5103 if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
5104 || (p && (len != SvCUR(cv) /* Not the same length. */
5105 || memNE(p, SvPVX_const(cv), len))))
5106 && ckWARN_d(WARN_PROTOTYPE)) {
5107 SV* const msg = sv_newmortal();
5111 gv_efullname3(name = sv_newmortal(), gv, NULL);
5112 sv_setpvs(msg, "Prototype mismatch:");
5114 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
5116 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv));
5118 sv_catpvs(msg, ": none");
5119 sv_catpvs(msg, " vs ");
5121 Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
5123 sv_catpvs(msg, "none");
5124 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
5128 static void const_sv_xsub(pTHX_ CV* cv);
5132 =head1 Optree Manipulation Functions
5134 =for apidoc cv_const_sv
5136 If C<cv> is a constant sub eligible for inlining. returns the constant
5137 value returned by the sub. Otherwise, returns NULL.
5139 Constant subs can be created with C<newCONSTSUB> or as described in
5140 L<perlsub/"Constant Functions">.
5145 Perl_cv_const_sv(pTHX_ CV *cv)
5147 PERL_UNUSED_CONTEXT;
5150 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
5152 return CvCONST(cv) ? (SV*)CvXSUBANY(cv).any_ptr : NULL;
5155 /* op_const_sv: examine an optree to determine whether it's in-lineable.
5156 * Can be called in 3 ways:
5159 * look for a single OP_CONST with attached value: return the value
5161 * cv && CvCLONE(cv) && !CvCONST(cv)
5163 * examine the clone prototype, and if contains only a single
5164 * OP_CONST referencing a pad const, or a single PADSV referencing
5165 * an outer lexical, return a non-zero value to indicate the CV is
5166 * a candidate for "constizing" at clone time
5170 * We have just cloned an anon prototype that was marked as a const
5171 * candidiate. Try to grab the current value, and in the case of
5172 * PADSV, ignore it if it has multiple references. Return the value.
5176 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
5187 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
5188 o = cLISTOPo->op_first->op_sibling;
5190 for (; o; o = o->op_next) {
5191 const OPCODE type = o->op_type;
5193 if (sv && o->op_next == o)
5195 if (o->op_next != o) {
5196 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
5198 if (type == OP_DBSTATE)
5201 if (type == OP_LEAVESUB || type == OP_RETURN)
5205 if (type == OP_CONST && cSVOPo->op_sv)
5207 else if (cv && type == OP_CONST) {
5208 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5212 else if (cv && type == OP_PADSV) {
5213 if (CvCONST(cv)) { /* newly cloned anon */
5214 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5215 /* the candidate should have 1 ref from this pad and 1 ref
5216 * from the parent */
5217 if (!sv || SvREFCNT(sv) != 2)
5224 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
5225 sv = &PL_sv_undef; /* an arbitrary non-null value */
5240 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5243 /* This would be the return value, but the return cannot be reached. */
5244 OP* pegop = newOP(OP_NULL, 0);
5247 PERL_UNUSED_ARG(floor);
5257 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
5259 NORETURN_FUNCTION_END;
5264 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
5266 return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
5270 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5277 register CV *cv = NULL;
5279 /* If the subroutine has no body, no attributes, and no builtin attributes
5280 then it's just a sub declaration, and we may be able to get away with
5281 storing with a placeholder scalar in the symbol table, rather than a
5282 full GV and CV. If anything is present then it will take a full CV to
5284 const I32 gv_fetch_flags
5285 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5287 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
5288 const char * const name = o ? SvPV_nolen_const(cSVOPo->op_sv) : NULL;
5291 assert(proto->op_type == OP_CONST);
5292 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
5297 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
5298 SV * const sv = sv_newmortal();
5299 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
5300 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
5301 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
5302 aname = SvPVX_const(sv);
5307 gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
5308 : gv_fetchpv(aname ? aname
5309 : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5310 gv_fetch_flags, SVt_PVCV);
5312 if (!PL_madskills) {
5321 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
5322 maximum a prototype before. */
5323 if (SvTYPE(gv) > SVt_NULL) {
5324 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
5325 && ckWARN_d(WARN_PROTOTYPE))
5327 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
5329 cv_ckproto_len((CV*)gv, NULL, ps, ps_len);
5332 sv_setpvn((SV*)gv, ps, ps_len);
5334 sv_setiv((SV*)gv, -1);
5336 SvREFCNT_dec(PL_compcv);
5337 cv = PL_compcv = NULL;
5341 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
5343 #ifdef GV_UNIQUE_CHECK
5344 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
5345 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
5349 if (!block || !ps || *ps || attrs
5350 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5352 || block->op_type == OP_NULL
5357 const_sv = op_const_sv(block, NULL);
5360 const bool exists = CvROOT(cv) || CvXSUB(cv);
5362 #ifdef GV_UNIQUE_CHECK
5363 if (exists && GvUNIQUE(gv)) {
5364 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
5368 /* if the subroutine doesn't exist and wasn't pre-declared
5369 * with a prototype, assume it will be AUTOLOADed,
5370 * skipping the prototype check
5372 if (exists || SvPOK(cv))
5373 cv_ckproto_len(cv, gv, ps, ps_len);
5374 /* already defined (or promised)? */
5375 if (exists || GvASSUMECV(gv)) {
5378 || block->op_type == OP_NULL
5381 if (CvFLAGS(PL_compcv)) {
5382 /* might have had built-in attrs applied */
5383 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5385 /* just a "sub foo;" when &foo is already defined */
5386 SAVEFREESV(PL_compcv);
5391 && block->op_type != OP_NULL
5394 if (ckWARN(WARN_REDEFINE)
5396 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
5398 const line_t oldline = CopLINE(PL_curcop);
5399 if (PL_parser && PL_parser->copline != NOLINE)
5400 CopLINE_set(PL_curcop, PL_parser->copline);
5401 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5402 CvCONST(cv) ? "Constant subroutine %s redefined"
5403 : "Subroutine %s redefined", name);
5404 CopLINE_set(PL_curcop, oldline);
5407 if (!PL_minus_c) /* keep old one around for madskills */
5410 /* (PL_madskills unset in used file.) */
5418 SvREFCNT_inc_simple_void_NN(const_sv);
5420 assert(!CvROOT(cv) && !CvCONST(cv));
5421 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
5422 CvXSUBANY(cv).any_ptr = const_sv;
5423 CvXSUB(cv) = const_sv_xsub;
5429 cv = newCONSTSUB(NULL, name, const_sv);
5431 mro_method_changed_in( /* sub Foo::Bar () { 123 } */
5432 (CvGV(cv) && GvSTASH(CvGV(cv)))
5441 SvREFCNT_dec(PL_compcv);
5449 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
5450 * before we clobber PL_compcv.
5454 || block->op_type == OP_NULL
5458 /* Might have had built-in attributes applied -- propagate them. */
5459 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5460 if (CvGV(cv) && GvSTASH(CvGV(cv)))
5461 stash = GvSTASH(CvGV(cv));
5462 else if (CvSTASH(cv))
5463 stash = CvSTASH(cv);
5465 stash = PL_curstash;
5468 /* possibly about to re-define existing subr -- ignore old cv */
5469 rcv = (SV*)PL_compcv;
5470 if (name && GvSTASH(gv))
5471 stash = GvSTASH(gv);
5473 stash = PL_curstash;
5475 apply_attrs(stash, rcv, attrs, FALSE);
5477 if (cv) { /* must reuse cv if autoloaded */
5484 || block->op_type == OP_NULL) && !PL_madskills
5487 /* got here with just attrs -- work done, so bug out */
5488 SAVEFREESV(PL_compcv);
5491 /* transfer PL_compcv to cv */
5493 CvFLAGS(cv) = CvFLAGS(PL_compcv);
5494 if (!CvWEAKOUTSIDE(cv))
5495 SvREFCNT_dec(CvOUTSIDE(cv));
5496 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
5497 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
5498 CvOUTSIDE(PL_compcv) = 0;
5499 CvPADLIST(cv) = CvPADLIST(PL_compcv);
5500 CvPADLIST(PL_compcv) = 0;
5501 /* inner references to PL_compcv must be fixed up ... */
5502 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
5503 /* ... before we throw it away */
5504 SvREFCNT_dec(PL_compcv);
5506 if (PERLDB_INTER)/* Advice debugger on the new sub. */
5507 ++PL_sub_generation;
5514 if (strEQ(name, "import")) {
5515 PL_formfeed = (SV*)cv;
5516 Perl_warner(aTHX_ packWARN(WARN_VOID), "%lx\n", (long)cv);
5520 mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */
5524 CvFILE_set_from_cop(cv, PL_curcop);
5525 CvSTASH(cv) = PL_curstash;
5528 sv_setpvn((SV*)cv, ps, ps_len);
5530 if (PL_parser && PL_parser->error_count) {
5534 const char *s = strrchr(name, ':');
5536 if (strEQ(s, "BEGIN")) {
5537 const char not_safe[] =
5538 "BEGIN not safe after errors--compilation aborted";
5539 if (PL_in_eval & EVAL_KEEPERR)
5540 Perl_croak(aTHX_ not_safe);
5542 /* force display of errors found but not reported */
5543 sv_catpv(ERRSV, not_safe);
5544 Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
5554 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5555 mod(scalarseq(block), OP_LEAVESUBLV));
5556 block->op_attached = 1;
5559 /* This makes sub {}; work as expected. */
5560 if (block->op_type == OP_STUB) {
5561 OP* const newblock = newSTATEOP(0, NULL, 0);
5563 op_getmad(block,newblock,'B');
5570 block->op_attached = 1;
5571 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5573 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5574 OpREFCNT_set(CvROOT(cv), 1);
5575 CvSTART(cv) = LINKLIST(CvROOT(cv));
5576 CvROOT(cv)->op_next = 0;
5577 CALL_PEEP(CvSTART(cv));
5579 /* now that optimizer has done its work, adjust pad values */
5581 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
5584 assert(!CvCONST(cv));
5585 if (ps && !*ps && op_const_sv(block, cv))
5589 if (name || aname) {
5590 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5591 SV * const sv = newSV(0);
5592 SV * const tmpstr = sv_newmortal();
5593 GV * const db_postponed = gv_fetchpvs("DB::postponed",
5594 GV_ADDMULTI, SVt_PVHV);
5597 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5599 (long)PL_subline, (long)CopLINE(PL_curcop));
5600 gv_efullname3(tmpstr, gv, NULL);
5601 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
5602 SvCUR(tmpstr), sv, 0);
5603 hv = GvHVn(db_postponed);
5604 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
5605 CV * const pcv = GvCV(db_postponed);
5611 call_sv((SV*)pcv, G_DISCARD);
5616 if (name && ! (PL_parser && PL_parser->error_count))
5617 process_special_blocks(name, gv, cv);
5622 PL_parser->copline = NOLINE;
5628 S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
5631 const char *const colon = strrchr(fullname,':');
5632 const char *const name = colon ? colon + 1 : fullname;
5635 if (strEQ(name, "BEGIN")) {
5636 const I32 oldscope = PL_scopestack_ix;
5638 SAVECOPFILE(&PL_compiling);
5639 SAVECOPLINE(&PL_compiling);
5641 DEBUG_x( dump_sub(gv) );
5642 Perl_av_create_and_push(aTHX_ &PL_beginav, (SV*)cv);
5643 GvCV(gv) = 0; /* cv has been hijacked */
5644 call_list(oldscope, PL_beginav);
5646 PL_curcop = &PL_compiling;
5647 CopHINTS_set(&PL_compiling, PL_hints);
5654 if strEQ(name, "END") {
5655 DEBUG_x( dump_sub(gv) );
5656 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, (SV*)cv);
5659 } else if (*name == 'U') {
5660 if (strEQ(name, "UNITCHECK")) {
5661 /* It's never too late to run a unitcheck block */
5662 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, (SV*)cv);
5666 } else if (*name == 'C') {
5667 if (strEQ(name, "CHECK")) {
5668 if (PL_main_start && ckWARN(WARN_VOID))
5669 Perl_warner(aTHX_ packWARN(WARN_VOID),
5670 "Too late to run CHECK block");
5671 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, (SV*)cv);
5675 } else if (*name == 'I') {
5676 if (strEQ(name, "INIT")) {
5677 if (PL_main_start && ckWARN(WARN_VOID))
5678 Perl_warner(aTHX_ packWARN(WARN_VOID),
5679 "Too late to run INIT block");
5680 Perl_av_create_and_push(aTHX_ &PL_initav, (SV*)cv);
5686 DEBUG_x( dump_sub(gv) );
5687 GvCV(gv) = 0; /* cv has been hijacked */
5692 =for apidoc newCONSTSUB
5694 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5695 eligible for inlining at compile-time.
5701 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
5706 const char *const temp_p = CopFILE(PL_curcop);
5707 const STRLEN len = temp_p ? strlen(temp_p) : 0;
5709 SV *const temp_sv = CopFILESV(PL_curcop);
5711 const char *const temp_p = temp_sv ? SvPV_const(temp_sv, len) : NULL;
5713 char *const file = savepvn(temp_p, temp_p ? len : 0);
5717 if (IN_PERL_RUNTIME) {
5718 /* at runtime, it's not safe to manipulate PL_curcop: it may be
5719 * an op shared between threads. Use a non-shared COP for our
5721 SAVEVPTR(PL_curcop);
5722 PL_curcop = &PL_compiling;
5724 SAVECOPLINE(PL_curcop);
5725 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
5728 PL_hints &= ~HINT_BLOCK_SCOPE;
5731 SAVESPTR(PL_curstash);
5732 SAVECOPSTASH(PL_curcop);
5733 PL_curstash = stash;
5734 CopSTASH_set(PL_curcop,stash);
5737 /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
5738 and so doesn't get free()d. (It's expected to be from the C pre-
5739 processor __FILE__ directive). But we need a dynamically allocated one,
5740 and we need it to get freed. */
5741 cv = newXS_flags(name, const_sv_xsub, file, "", XS_DYNAMIC_FILENAME);
5742 CvXSUBANY(cv).any_ptr = sv;
5748 CopSTASH_free(PL_curcop);
5756 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
5757 const char *const filename, const char *const proto,
5760 CV *cv = newXS(name, subaddr, filename);
5762 if (flags & XS_DYNAMIC_FILENAME) {
5763 /* We need to "make arrangements" (ie cheat) to ensure that the
5764 filename lasts as long as the PVCV we just created, but also doesn't
5766 STRLEN filename_len = strlen(filename);
5767 STRLEN proto_and_file_len = filename_len;
5768 char *proto_and_file;
5772 proto_len = strlen(proto);
5773 proto_and_file_len += proto_len;
5775 Newx(proto_and_file, proto_and_file_len + 1, char);
5776 Copy(proto, proto_and_file, proto_len, char);
5777 Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
5780 proto_and_file = savepvn(filename, filename_len);
5783 /* This gets free()d. :-) */
5784 sv_usepvn_flags((SV*)cv, proto_and_file, proto_and_file_len,
5785 SV_HAS_TRAILING_NUL);
5787 /* This gives us the correct prototype, rather than one with the
5788 file name appended. */
5789 SvCUR_set(cv, proto_len);
5793 CvFILE(cv) = proto_and_file + proto_len;
5795 sv_setpv((SV *)cv, proto);
5801 =for apidoc U||newXS
5803 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
5804 static storage, as it is used directly as CvFILE(), without a copy being made.
5810 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
5813 GV * const gv = gv_fetchpv(name ? name :
5814 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5815 GV_ADDMULTI, SVt_PVCV);
5819 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
5821 if ((cv = (name ? GvCV(gv) : NULL))) {
5823 /* just a cached method */
5827 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5828 /* already defined (or promised) */
5829 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
5830 if (ckWARN(WARN_REDEFINE)) {
5831 GV * const gvcv = CvGV(cv);
5833 HV * const stash = GvSTASH(gvcv);
5835 const char *redefined_name = HvNAME_get(stash);
5836 if ( strEQ(redefined_name,"autouse") ) {
5837 const line_t oldline = CopLINE(PL_curcop);
5838 if (PL_parser && PL_parser->copline != NOLINE)
5839 CopLINE_set(PL_curcop, PL_parser->copline);
5840 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5841 CvCONST(cv) ? "Constant subroutine %s redefined"
5842 : "Subroutine %s redefined"
5844 CopLINE_set(PL_curcop, oldline);
5854 if (cv) /* must reuse cv if autoloaded */
5857 cv = (CV*)newSV_type(SVt_PVCV);
5861 mro_method_changed_in(GvSTASH(gv)); /* newXS */
5865 (void)gv_fetchfile(filename);
5866 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
5867 an external constant string */
5869 CvXSUB(cv) = subaddr;
5872 process_special_blocks(name, gv, cv);
5884 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5889 OP* pegop = newOP(OP_NULL, 0);
5893 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
5894 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
5896 #ifdef GV_UNIQUE_CHECK
5898 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5902 if ((cv = GvFORM(gv))) {
5903 if (ckWARN(WARN_REDEFINE)) {
5904 const line_t oldline = CopLINE(PL_curcop);
5905 if (PL_parser && PL_parser->copline != NOLINE)
5906 CopLINE_set(PL_curcop, PL_parser->copline);
5907 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5908 o ? "Format %"SVf" redefined"
5909 : "Format STDOUT redefined", SVfARG(cSVOPo->op_sv));
5910 CopLINE_set(PL_curcop, oldline);
5917 CvFILE_set_from_cop(cv, PL_curcop);
5920 pad_tidy(padtidy_FORMAT);
5921 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5922 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5923 OpREFCNT_set(CvROOT(cv), 1);
5924 CvSTART(cv) = LINKLIST(CvROOT(cv));
5925 CvROOT(cv)->op_next = 0;
5926 CALL_PEEP(CvSTART(cv));
5928 op_getmad(o,pegop,'n');
5929 op_getmad_weak(block, pegop, 'b');
5934 PL_parser->copline = NOLINE;
5942 Perl_newANONLIST(pTHX_ OP *o)
5944 return convert(OP_ANONLIST, OPf_SPECIAL, o);
5948 Perl_newANONHASH(pTHX_ OP *o)
5950 return convert(OP_ANONHASH, OPf_SPECIAL, o);
5954 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5956 return newANONATTRSUB(floor, proto, NULL, block);
5960 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5962 return newUNOP(OP_REFGEN, 0,
5963 newSVOP(OP_ANONCODE, 0,
5964 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5968 Perl_oopsAV(pTHX_ OP *o)
5971 switch (o->op_type) {
5973 o->op_type = OP_PADAV;
5974 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5975 return ref(o, OP_RV2AV);
5978 o->op_type = OP_RV2AV;
5979 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5984 if (ckWARN_d(WARN_INTERNAL))
5985 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
5992 Perl_oopsHV(pTHX_ OP *o)
5995 switch (o->op_type) {
5998 o->op_type = OP_PADHV;
5999 o->op_ppaddr = PL_ppaddr[OP_PADHV];
6000 return ref(o, OP_RV2HV);
6004 o->op_type = OP_RV2HV;
6005 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
6010 if (ckWARN_d(WARN_INTERNAL))
6011 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
6018 Perl_newAVREF(pTHX_ OP *o)
6021 if (o->op_type == OP_PADANY) {
6022 o->op_type = OP_PADAV;
6023 o->op_ppaddr = PL_ppaddr[OP_PADAV];
6026 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
6027 && ckWARN(WARN_DEPRECATED)) {
6028 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
6029 "Using an array as a reference is deprecated");
6031 return newUNOP(OP_RV2AV, 0, scalar(o));
6035 Perl_newGVREF(pTHX_ I32 type, OP *o)
6037 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
6038 return newUNOP(OP_NULL, 0, o);
6039 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
6043 Perl_newHVREF(pTHX_ OP *o)
6046 if (o->op_type == OP_PADANY) {
6047 o->op_type = OP_PADHV;
6048 o->op_ppaddr = PL_ppaddr[OP_PADHV];
6051 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
6052 && ckWARN(WARN_DEPRECATED)) {
6053 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
6054 "Using a hash as a reference is deprecated");
6056 return newUNOP(OP_RV2HV, 0, scalar(o));
6060 Perl_newCVREF(pTHX_ I32 flags, OP *o)
6062 return newUNOP(OP_RV2CV, flags, scalar(o));
6066 Perl_newSVREF(pTHX_ OP *o)
6069 if (o->op_type == OP_PADANY) {
6070 o->op_type = OP_PADSV;
6071 o->op_ppaddr = PL_ppaddr[OP_PADSV];
6074 return newUNOP(OP_RV2SV, 0, scalar(o));
6077 /* Check routines. See the comments at the top of this file for details
6078 * on when these are called */
6081 Perl_ck_anoncode(pTHX_ OP *o)
6083 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
6085 cSVOPo->op_sv = NULL;
6090 Perl_ck_bitop(pTHX_ OP *o)
6093 #define OP_IS_NUMCOMPARE(op) \
6094 ((op) == OP_LT || (op) == OP_I_LT || \
6095 (op) == OP_GT || (op) == OP_I_GT || \
6096 (op) == OP_LE || (op) == OP_I_LE || \
6097 (op) == OP_GE || (op) == OP_I_GE || \
6098 (op) == OP_EQ || (op) == OP_I_EQ || \
6099 (op) == OP_NE || (op) == OP_I_NE || \
6100 (op) == OP_NCMP || (op) == OP_I_NCMP)
6101 o->op_private = (U8)(PL_hints & HINT_INTEGER);
6102 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
6103 && (o->op_type == OP_BIT_OR
6104 || o->op_type == OP_BIT_AND
6105 || o->op_type == OP_BIT_XOR))
6107 const OP * const left = cBINOPo->op_first;
6108 const OP * const right = left->op_sibling;
6109 if ((OP_IS_NUMCOMPARE(left->op_type) &&
6110 (left->op_flags & OPf_PARENS) == 0) ||
6111 (OP_IS_NUMCOMPARE(right->op_type) &&
6112 (right->op_flags & OPf_PARENS) == 0))
6113 if (ckWARN(WARN_PRECEDENCE))
6114 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
6115 "Possible precedence problem on bitwise %c operator",
6116 o->op_type == OP_BIT_OR ? '|'
6117 : o->op_type == OP_BIT_AND ? '&' : '^'
6124 Perl_ck_concat(pTHX_ OP *o)
6126 const OP * const kid = cUNOPo->op_first;
6127 PERL_UNUSED_CONTEXT;
6128 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
6129 !(kUNOP->op_first->op_flags & OPf_MOD))
6130 o->op_flags |= OPf_STACKED;
6135 Perl_ck_spair(pTHX_ OP *o)
6138 if (o->op_flags & OPf_KIDS) {
6141 const OPCODE type = o->op_type;
6142 o = modkids(ck_fun(o), type);
6143 kid = cUNOPo->op_first;
6144 newop = kUNOP->op_first->op_sibling;
6146 const OPCODE type = newop->op_type;
6147 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
6148 type == OP_PADAV || type == OP_PADHV ||
6149 type == OP_RV2AV || type == OP_RV2HV)
6153 op_getmad(kUNOP->op_first,newop,'K');
6155 op_free(kUNOP->op_first);
6157 kUNOP->op_first = newop;
6159 o->op_ppaddr = PL_ppaddr[++o->op_type];
6164 Perl_ck_delete(pTHX_ OP *o)
6168 if (o->op_flags & OPf_KIDS) {
6169 OP * const kid = cUNOPo->op_first;
6170 switch (kid->op_type) {
6172 o->op_flags |= OPf_SPECIAL;
6175 o->op_private |= OPpSLICE;
6178 o->op_flags |= OPf_SPECIAL;
6183 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
6192 Perl_ck_die(pTHX_ OP *o)
6195 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6201 Perl_ck_eof(pTHX_ OP *o)
6205 if (o->op_flags & OPf_KIDS) {
6206 if (cLISTOPo->op_first->op_type == OP_STUB) {
6208 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
6210 op_getmad(o,newop,'O');
6222 Perl_ck_eval(pTHX_ OP *o)
6225 PL_hints |= HINT_BLOCK_SCOPE;
6226 if (o->op_flags & OPf_KIDS) {
6227 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6230 o->op_flags &= ~OPf_KIDS;
6233 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
6239 cUNOPo->op_first = 0;
6244 NewOp(1101, enter, 1, LOGOP);
6245 enter->op_type = OP_ENTERTRY;
6246 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
6247 enter->op_private = 0;
6249 /* establish postfix order */
6250 enter->op_next = (OP*)enter;
6252 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
6253 o->op_type = OP_LEAVETRY;
6254 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
6255 enter->op_other = o;
6256 op_getmad(oldo,o,'O');
6270 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
6271 op_getmad(oldo,o,'O');
6273 o->op_targ = (PADOFFSET)PL_hints;
6274 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
6275 /* Store a copy of %^H that pp_entereval can pick up.
6276 OPf_SPECIAL flags the opcode as being for this purpose,
6277 so that it in turn will return a copy at every
6279 OP *hhop = newSVOP(OP_CONST, OPf_SPECIAL,
6280 (SV*)Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv)));
6281 cUNOPo->op_first->op_sibling = hhop;
6282 o->op_private |= OPpEVAL_HAS_HH;
6288 Perl_ck_exit(pTHX_ OP *o)
6291 HV * const table = GvHV(PL_hintgv);
6293 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
6294 if (svp && *svp && SvTRUE(*svp))
6295 o->op_private |= OPpEXIT_VMSISH;
6297 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6303 Perl_ck_exec(pTHX_ OP *o)
6305 if (o->op_flags & OPf_STACKED) {
6308 kid = cUNOPo->op_first->op_sibling;
6309 if (kid->op_type == OP_RV2GV)
6318 Perl_ck_exists(pTHX_ OP *o)
6322 if (o->op_flags & OPf_KIDS) {
6323 OP * const kid = cUNOPo->op_first;
6324 if (kid->op_type == OP_ENTERSUB) {
6325 (void) ref(kid, o->op_type);
6326 if (kid->op_type != OP_RV2CV
6327 && !(PL_parser && PL_parser->error_count))
6328 Perl_croak(aTHX_ "%s argument is not a subroutine name",
6330 o->op_private |= OPpEXISTS_SUB;
6332 else if (kid->op_type == OP_AELEM)
6333 o->op_flags |= OPf_SPECIAL;
6334 else if (kid->op_type != OP_HELEM)
6335 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
6343 Perl_ck_rvconst(pTHX_ register OP *o)
6346 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6348 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6349 if (o->op_type == OP_RV2CV)
6350 o->op_private &= ~1;
6352 if (kid->op_type == OP_CONST) {
6355 SV * const kidsv = kid->op_sv;
6357 /* Is it a constant from cv_const_sv()? */
6358 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
6359 SV * const rsv = SvRV(kidsv);
6360 const svtype type = SvTYPE(rsv);
6361 const char *badtype = NULL;
6363 switch (o->op_type) {
6365 if (type > SVt_PVMG)
6366 badtype = "a SCALAR";
6369 if (type != SVt_PVAV)
6370 badtype = "an ARRAY";
6373 if (type != SVt_PVHV)
6377 if (type != SVt_PVCV)
6382 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
6385 else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
6386 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
6387 /* If this is an access to a stash, disable "strict refs", because
6388 * stashes aren't auto-vivified at compile-time (unless we store
6389 * symbols in them), and we don't want to produce a run-time
6390 * stricture error when auto-vivifying the stash. */
6391 const char *s = SvPV_nolen(kidsv);
6392 const STRLEN l = SvCUR(kidsv);
6393 if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
6394 o->op_private &= ~HINT_STRICT_REFS;
6396 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
6397 const char *badthing;
6398 switch (o->op_type) {
6400 badthing = "a SCALAR";
6403 badthing = "an ARRAY";
6406 badthing = "a HASH";
6414 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
6415 SVfARG(kidsv), badthing);
6418 * This is a little tricky. We only want to add the symbol if we
6419 * didn't add it in the lexer. Otherwise we get duplicate strict
6420 * warnings. But if we didn't add it in the lexer, we must at
6421 * least pretend like we wanted to add it even if it existed before,
6422 * or we get possible typo warnings. OPpCONST_ENTERED says
6423 * whether the lexer already added THIS instance of this symbol.
6425 iscv = (o->op_type == OP_RV2CV) * 2;
6427 gv = gv_fetchsv(kidsv,
6428 iscv | !(kid->op_private & OPpCONST_ENTERED),
6431 : o->op_type == OP_RV2SV
6433 : o->op_type == OP_RV2AV
6435 : o->op_type == OP_RV2HV
6438 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
6440 kid->op_type = OP_GV;
6441 SvREFCNT_dec(kid->op_sv);
6443 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
6444 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
6445 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
6447 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc_simple_NN(gv));
6449 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
6451 kid->op_private = 0;
6452 kid->op_ppaddr = PL_ppaddr[OP_GV];
6459 Perl_ck_ftst(pTHX_ OP *o)
6462 const I32 type = o->op_type;
6464 if (o->op_flags & OPf_REF) {
6467 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
6468 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6469 const OPCODE kidtype = kid->op_type;
6471 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6472 OP * const newop = newGVOP(type, OPf_REF,
6473 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
6475 op_getmad(o,newop,'O');
6481 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o))
6482 o->op_private |= OPpFT_ACCESS;
6483 if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst)
6484 && kidtype != OP_STAT && kidtype != OP_LSTAT)
6485 o->op_private |= OPpFT_STACKED;
6493 if (type == OP_FTTTY)
6494 o = newGVOP(type, OPf_REF, PL_stdingv);
6496 o = newUNOP(type, 0, newDEFSVOP());
6497 op_getmad(oldo,o,'O');
6503 Perl_ck_fun(pTHX_ OP *o)
6506 const int type = o->op_type;
6507 register I32 oa = PL_opargs[type] >> OASHIFT;
6509 if (o->op_flags & OPf_STACKED) {
6510 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
6513 return no_fh_allowed(o);
6516 if (o->op_flags & OPf_KIDS) {
6517 OP **tokid = &cLISTOPo->op_first;
6518 register OP *kid = cLISTOPo->op_first;
6522 if (kid->op_type == OP_PUSHMARK ||
6523 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
6525 tokid = &kid->op_sibling;
6526 kid = kid->op_sibling;
6528 if (!kid && PL_opargs[type] & OA_DEFGV)
6529 *tokid = kid = newDEFSVOP();
6533 sibl = kid->op_sibling;
6535 if (!sibl && kid->op_type == OP_STUB) {
6542 /* list seen where single (scalar) arg expected? */
6543 if (numargs == 1 && !(oa >> 4)
6544 && kid->op_type == OP_LIST && type != OP_SCALAR)
6546 return too_many_arguments(o,PL_op_desc[type]);
6559 if ((type == OP_PUSH || type == OP_UNSHIFT)
6560 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
6561 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6562 "Useless use of %s with no values",
6565 if (kid->op_type == OP_CONST &&
6566 (kid->op_private & OPpCONST_BARE))
6568 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
6569 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
6570 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6571 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6572 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
6573 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6575 op_getmad(kid,newop,'K');
6580 kid->op_sibling = sibl;
6583 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
6584 bad_type(numargs, "array", PL_op_desc[type], kid);
6588 if (kid->op_type == OP_CONST &&
6589 (kid->op_private & OPpCONST_BARE))
6591 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
6592 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
6593 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6594 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6595 "Hash %%%"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_RV2HV && kid->op_type != OP_PADHV)
6607 bad_type(numargs, "hash", PL_op_desc[type], kid);
6612 OP * const newop = newUNOP(OP_NULL, 0, kid);
6613 kid->op_sibling = 0;
6615 newop->op_next = newop;
6617 kid->op_sibling = sibl;
6622 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
6623 if (kid->op_type == OP_CONST &&
6624 (kid->op_private & OPpCONST_BARE))
6626 OP * const newop = newGVOP(OP_GV, 0,
6627 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
6628 if (!(o->op_private & 1) && /* if not unop */
6629 kid == cLISTOPo->op_last)
6630 cLISTOPo->op_last = newop;
6632 op_getmad(kid,newop,'K');
6638 else if (kid->op_type == OP_READLINE) {
6639 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
6640 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
6643 I32 flags = OPf_SPECIAL;
6647 /* is this op a FH constructor? */
6648 if (is_handle_constructor(o,numargs)) {
6649 const char *name = NULL;
6653 /* Set a flag to tell rv2gv to vivify
6654 * need to "prove" flag does not mean something
6655 * else already - NI-S 1999/05/07
6658 if (kid->op_type == OP_PADSV) {
6660 = PAD_COMPNAME_SV(kid->op_targ);
6661 name = SvPV_const(namesv, len);
6663 else if (kid->op_type == OP_RV2SV
6664 && kUNOP->op_first->op_type == OP_GV)
6666 GV * const gv = cGVOPx_gv(kUNOP->op_first);
6668 len = GvNAMELEN(gv);
6670 else if (kid->op_type == OP_AELEM
6671 || kid->op_type == OP_HELEM)
6674 OP *op = ((BINOP*)kid)->op_first;
6678 const char * const a =
6679 kid->op_type == OP_AELEM ?
6681 if (((op->op_type == OP_RV2AV) ||
6682 (op->op_type == OP_RV2HV)) &&
6683 (firstop = ((UNOP*)op)->op_first) &&
6684 (firstop->op_type == OP_GV)) {
6685 /* packagevar $a[] or $h{} */
6686 GV * const gv = cGVOPx_gv(firstop);
6694 else if (op->op_type == OP_PADAV
6695 || op->op_type == OP_PADHV) {
6696 /* lexicalvar $a[] or $h{} */
6697 const char * const padname =
6698 PAD_COMPNAME_PV(op->op_targ);
6707 name = SvPV_const(tmpstr, len);
6712 name = "__ANONIO__";
6719 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
6720 namesv = PAD_SVl(targ);
6721 SvUPGRADE(namesv, SVt_PV);
6723 sv_setpvn(namesv, "$", 1);
6724 sv_catpvn(namesv, name, len);
6727 kid->op_sibling = 0;
6728 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
6729 kid->op_targ = targ;
6730 kid->op_private |= priv;
6732 kid->op_sibling = sibl;
6738 mod(scalar(kid), type);
6742 tokid = &kid->op_sibling;
6743 kid = kid->op_sibling;
6746 if (kid && kid->op_type != OP_STUB)
6747 return too_many_arguments(o,OP_DESC(o));
6748 o->op_private |= numargs;
6750 /* FIXME - should the numargs move as for the PERL_MAD case? */
6751 o->op_private |= numargs;
6753 return too_many_arguments(o,OP_DESC(o));
6757 else if (PL_opargs[type] & OA_DEFGV) {
6759 OP *newop = newUNOP(type, 0, newDEFSVOP());
6760 op_getmad(o,newop,'O');
6763 /* Ordering of these two is important to keep f_map.t passing. */
6765 return newUNOP(type, 0, newDEFSVOP());
6770 while (oa & OA_OPTIONAL)
6772 if (oa && oa != OA_LIST)
6773 return too_few_arguments(o,OP_DESC(o));
6779 Perl_ck_glob(pTHX_ OP *o)
6785 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
6786 append_elem(OP_GLOB, o, newDEFSVOP());
6788 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
6789 && GvCVu(gv) && GvIMPORTED_CV(gv)))
6791 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6794 #if !defined(PERL_EXTERNAL_GLOB)
6795 /* XXX this can be tightened up and made more failsafe. */
6796 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
6799 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
6800 newSVpvs("File::Glob"), NULL, NULL, NULL);
6801 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6802 glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
6803 GvCV(gv) = GvCV(glob_gv);
6804 SvREFCNT_inc_void((SV*)GvCV(gv));
6805 GvIMPORTED_CV_on(gv);
6808 #endif /* PERL_EXTERNAL_GLOB */
6810 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6811 append_elem(OP_GLOB, o,
6812 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
6813 o->op_type = OP_LIST;
6814 o->op_ppaddr = PL_ppaddr[OP_LIST];
6815 cLISTOPo->op_first->op_type = OP_PUSHMARK;
6816 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
6817 cLISTOPo->op_first->op_targ = 0;
6818 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
6819 append_elem(OP_LIST, o,
6820 scalar(newUNOP(OP_RV2CV, 0,
6821 newGVOP(OP_GV, 0, gv)))));
6822 o = newUNOP(OP_NULL, 0, ck_subr(o));
6823 o->op_targ = OP_GLOB; /* hint at what it used to be */
6826 gv = newGVgen("main");
6828 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
6834 Perl_ck_grep(pTHX_ OP *o)
6839 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
6842 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
6843 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
6845 if (o->op_flags & OPf_STACKED) {
6848 kid = cLISTOPo->op_first->op_sibling;
6849 if (!cUNOPx(kid)->op_next)
6850 Perl_croak(aTHX_ "panic: ck_grep");
6851 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
6854 NewOp(1101, gwop, 1, LOGOP);
6855 kid->op_next = (OP*)gwop;
6856 o->op_flags &= ~OPf_STACKED;
6858 kid = cLISTOPo->op_first->op_sibling;
6859 if (type == OP_MAPWHILE)
6864 if (PL_parser && PL_parser->error_count)
6866 kid = cLISTOPo->op_first->op_sibling;
6867 if (kid->op_type != OP_NULL)
6868 Perl_croak(aTHX_ "panic: ck_grep");
6869 kid = kUNOP->op_first;
6872 NewOp(1101, gwop, 1, LOGOP);
6873 gwop->op_type = type;
6874 gwop->op_ppaddr = PL_ppaddr[type];
6875 gwop->op_first = listkids(o);
6876 gwop->op_flags |= OPf_KIDS;
6877 gwop->op_other = LINKLIST(kid);
6878 kid->op_next = (OP*)gwop;
6879 offset = pad_findmy("$_");
6880 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
6881 o->op_private = gwop->op_private = 0;
6882 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
6885 o->op_private = gwop->op_private = OPpGREP_LEX;
6886 gwop->op_targ = o->op_targ = offset;
6889 kid = cLISTOPo->op_first->op_sibling;
6890 if (!kid || !kid->op_sibling)
6891 return too_few_arguments(o,OP_DESC(o));
6892 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
6893 mod(kid, OP_GREPSTART);
6899 Perl_ck_index(pTHX_ OP *o)
6901 if (o->op_flags & OPf_KIDS) {
6902 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6904 kid = kid->op_sibling; /* get past "big" */
6905 if (kid && kid->op_type == OP_CONST)
6906 fbm_compile(((SVOP*)kid)->op_sv, 0);
6912 Perl_ck_lengthconst(pTHX_ OP *o)
6914 /* XXX length optimization goes here */
6919 Perl_ck_lfun(pTHX_ OP *o)
6921 const OPCODE type = o->op_type;
6922 return modkids(ck_fun(o), type);
6926 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
6928 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
6929 switch (cUNOPo->op_first->op_type) {
6931 /* This is needed for
6932 if (defined %stash::)
6933 to work. Do not break Tk.
6935 break; /* Globals via GV can be undef */
6937 case OP_AASSIGN: /* Is this a good idea? */
6938 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6939 "defined(@array) is deprecated");
6940 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6941 "\t(Maybe you should just omit the defined()?)\n");
6944 /* This is needed for
6945 if (defined %stash::)
6946 to work. Do not break Tk.
6948 break; /* Globals via GV can be undef */
6950 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6951 "defined(%%hash) is deprecated");
6952 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6953 "\t(Maybe you should just omit the defined()?)\n");
6964 Perl_ck_readline(pTHX_ OP *o)
6966 if (!(o->op_flags & OPf_KIDS)) {
6968 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
6970 op_getmad(o,newop,'O');
6980 Perl_ck_rfun(pTHX_ OP *o)
6982 const OPCODE type = o->op_type;
6983 return refkids(ck_fun(o), type);
6987 Perl_ck_listiob(pTHX_ OP *o)
6991 kid = cLISTOPo->op_first;
6994 kid = cLISTOPo->op_first;
6996 if (kid->op_type == OP_PUSHMARK)
6997 kid = kid->op_sibling;
6998 if (kid && o->op_flags & OPf_STACKED)
6999 kid = kid->op_sibling;
7000 else if (kid && !kid->op_sibling) { /* print HANDLE; */
7001 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
7002 o->op_flags |= OPf_STACKED; /* make it a filehandle */
7003 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
7004 cLISTOPo->op_first->op_sibling = kid;
7005 cLISTOPo->op_last = kid;
7006 kid = kid->op_sibling;
7011 append_elem(o->op_type, o, newDEFSVOP());
7017 Perl_ck_smartmatch(pTHX_ OP *o)
7020 if (0 == (o->op_flags & OPf_SPECIAL)) {
7021 OP *first = cBINOPo->op_first;
7022 OP *second = first->op_sibling;
7024 /* Implicitly take a reference to an array or hash */
7025 first->op_sibling = NULL;
7026 first = cBINOPo->op_first = ref_array_or_hash(first);
7027 second = first->op_sibling = ref_array_or_hash(second);
7029 /* Implicitly take a reference to a regular expression */
7030 if (first->op_type == OP_MATCH) {
7031 first->op_type = OP_QR;
7032 first->op_ppaddr = PL_ppaddr[OP_QR];
7034 if (second->op_type == OP_MATCH) {
7035 second->op_type = OP_QR;
7036 second->op_ppaddr = PL_ppaddr[OP_QR];
7045 Perl_ck_sassign(pTHX_ OP *o)
7048 OP * const kid = cLISTOPo->op_first;
7049 /* has a disposable target? */
7050 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
7051 && !(kid->op_flags & OPf_STACKED)
7052 /* Cannot steal the second time! */
7053 && !(kid->op_private & OPpTARGET_MY)
7054 /* Keep the full thing for madskills */
7058 OP * const kkid = kid->op_sibling;
7060 /* Can just relocate the target. */
7061 if (kkid && kkid->op_type == OP_PADSV
7062 && !(kkid->op_private & OPpLVAL_INTRO))
7064 kid->op_targ = kkid->op_targ;
7066 /* Now we do not need PADSV and SASSIGN. */
7067 kid->op_sibling = o->op_sibling; /* NULL */
7068 cLISTOPo->op_first = NULL;
7071 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
7075 if (kid->op_sibling) {
7076 OP *kkid = kid->op_sibling;
7077 if (kkid->op_type == OP_PADSV
7078 && (kkid->op_private & OPpLVAL_INTRO)
7079 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
7080 const PADOFFSET target = kkid->op_targ;
7081 OP *const other = newOP(OP_PADSV,
7083 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
7084 OP *const first = newOP(OP_NULL, 0);
7085 OP *const nullop = newCONDOP(0, first, o, other);
7086 OP *const condop = first->op_next;
7087 /* hijacking PADSTALE for uninitialized state variables */
7088 SvPADSTALE_on(PAD_SVl(target));
7090 condop->op_type = OP_ONCE;
7091 condop->op_ppaddr = PL_ppaddr[OP_ONCE];
7092 condop->op_targ = target;
7093 other->op_targ = target;
7095 /* Because we change the type of the op here, we will skip the
7096 assinment binop->op_last = binop->op_first->op_sibling; at the
7097 end of Perl_newBINOP(). So need to do it here. */
7098 cBINOPo->op_last = cBINOPo->op_first->op_sibling;
7107 Perl_ck_match(pTHX_ OP *o)
7110 if (o->op_type != OP_QR && PL_compcv) {
7111 const PADOFFSET offset = pad_findmy("$_");
7112 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
7113 o->op_targ = offset;
7114 o->op_private |= OPpTARGET_MY;
7117 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
7118 o->op_private |= OPpRUNTIME;
7123 Perl_ck_method(pTHX_ OP *o)
7125 OP * const kid = cUNOPo->op_first;
7126 if (kid->op_type == OP_CONST) {
7127 SV* sv = kSVOP->op_sv;
7128 const char * const method = SvPVX_const(sv);
7129 if (!(strchr(method, ':') || strchr(method, '\''))) {
7131 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
7132 sv = newSVpvn_share(method, SvCUR(sv), 0);
7135 kSVOP->op_sv = NULL;
7137 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
7139 op_getmad(o,cmop,'O');
7150 Perl_ck_null(pTHX_ OP *o)
7152 PERL_UNUSED_CONTEXT;
7157 Perl_ck_open(pTHX_ OP *o)
7160 HV * const table = GvHV(PL_hintgv);
7162 SV **svp = hv_fetchs(table, "open_IN", FALSE);
7164 const I32 mode = mode_from_discipline(*svp);
7165 if (mode & O_BINARY)
7166 o->op_private |= OPpOPEN_IN_RAW;
7167 else if (mode & O_TEXT)
7168 o->op_private |= OPpOPEN_IN_CRLF;
7171 svp = hv_fetchs(table, "open_OUT", FALSE);
7173 const I32 mode = mode_from_discipline(*svp);
7174 if (mode & O_BINARY)
7175 o->op_private |= OPpOPEN_OUT_RAW;
7176 else if (mode & O_TEXT)
7177 o->op_private |= OPpOPEN_OUT_CRLF;
7180 if (o->op_type == OP_BACKTICK) {
7181 if (!(o->op_flags & OPf_KIDS)) {
7182 OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
7184 op_getmad(o,newop,'O');
7193 /* In case of three-arg dup open remove strictness
7194 * from the last arg if it is a bareword. */
7195 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
7196 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
7200 if ((last->op_type == OP_CONST) && /* The bareword. */
7201 (last->op_private & OPpCONST_BARE) &&
7202 (last->op_private & OPpCONST_STRICT) &&
7203 (oa = first->op_sibling) && /* The fh. */
7204 (oa = oa->op_sibling) && /* The mode. */
7205 (oa->op_type == OP_CONST) &&
7206 SvPOK(((SVOP*)oa)->op_sv) &&
7207 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
7208 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
7209 (last == oa->op_sibling)) /* The bareword. */
7210 last->op_private &= ~OPpCONST_STRICT;
7216 Perl_ck_repeat(pTHX_ OP *o)
7218 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
7219 o->op_private |= OPpREPEAT_DOLIST;
7220 cBINOPo->op_first = force_list(cBINOPo->op_first);
7228 Perl_ck_require(pTHX_ OP *o)
7233 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
7234 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7236 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
7237 SV * const sv = kid->op_sv;
7238 U32 was_readonly = SvREADONLY(sv);
7245 sv_force_normal_flags(sv, 0);
7246 assert(!SvREADONLY(sv));
7256 for (; s < end; s++) {
7257 if (*s == ':' && s[1] == ':') {
7259 Move(s+2, s+1, end - s - 1, char);
7264 sv_catpvs(sv, ".pm");
7265 SvFLAGS(sv) |= was_readonly;
7269 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
7270 /* handle override, if any */
7271 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
7272 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7273 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
7274 gv = gvp ? *gvp : NULL;
7278 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7279 OP * const kid = cUNOPo->op_first;
7282 cUNOPo->op_first = 0;
7286 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
7287 append_elem(OP_LIST, kid,
7288 scalar(newUNOP(OP_RV2CV, 0,
7291 op_getmad(o,newop,'O');
7299 Perl_ck_return(pTHX_ OP *o)
7302 if (CvLVALUE(PL_compcv)) {
7304 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
7305 mod(kid, OP_LEAVESUBLV);
7311 Perl_ck_select(pTHX_ OP *o)
7315 if (o->op_flags & OPf_KIDS) {
7316 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7317 if (kid && kid->op_sibling) {
7318 o->op_type = OP_SSELECT;
7319 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
7321 return fold_constants(o);
7325 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7326 if (kid && kid->op_type == OP_RV2GV)
7327 kid->op_private &= ~HINT_STRICT_REFS;
7332 Perl_ck_shift(pTHX_ OP *o)
7335 const I32 type = o->op_type;
7337 if (!(o->op_flags & OPf_KIDS)) {
7339 /* FIXME - this can be refactored to reduce code in #ifdefs */
7341 OP * const oldo = o;
7345 argop = newUNOP(OP_RV2AV, 0,
7346 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
7348 o = newUNOP(type, 0, scalar(argop));
7349 op_getmad(oldo,o,'O');
7352 return newUNOP(type, 0, scalar(argop));
7355 return scalar(modkids(ck_fun(o), type));
7359 Perl_ck_sort(pTHX_ OP *o)
7364 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
7365 HV * const hinthv = GvHV(PL_hintgv);
7367 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
7369 const I32 sorthints = (I32)SvIV(*svp);
7370 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
7371 o->op_private |= OPpSORT_QSORT;
7372 if ((sorthints & HINT_SORT_STABLE) != 0)
7373 o->op_private |= OPpSORT_STABLE;
7378 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
7380 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7381 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
7383 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
7385 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
7387 if (kid->op_type == OP_SCOPE) {
7391 else if (kid->op_type == OP_LEAVE) {
7392 if (o->op_type == OP_SORT) {
7393 op_null(kid); /* wipe out leave */
7396 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
7397 if (k->op_next == kid)
7399 /* don't descend into loops */
7400 else if (k->op_type == OP_ENTERLOOP
7401 || k->op_type == OP_ENTERITER)
7403 k = cLOOPx(k)->op_lastop;
7408 kid->op_next = 0; /* just disconnect the leave */
7409 k = kLISTOP->op_first;
7414 if (o->op_type == OP_SORT) {
7415 /* provide scalar context for comparison function/block */
7421 o->op_flags |= OPf_SPECIAL;
7423 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
7426 firstkid = firstkid->op_sibling;
7429 /* provide list context for arguments */
7430 if (o->op_type == OP_SORT)
7437 S_simplify_sort(pTHX_ OP *o)
7440 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7445 if (!(o->op_flags & OPf_STACKED))
7447 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7448 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
7449 kid = kUNOP->op_first; /* get past null */
7450 if (kid->op_type != OP_SCOPE)
7452 kid = kLISTOP->op_last; /* get past scope */
7453 switch(kid->op_type) {
7461 k = kid; /* remember this node*/
7462 if (kBINOP->op_first->op_type != OP_RV2SV)
7464 kid = kBINOP->op_first; /* get past cmp */
7465 if (kUNOP->op_first->op_type != OP_GV)
7467 kid = kUNOP->op_first; /* get past rv2sv */
7469 if (GvSTASH(gv) != PL_curstash)
7471 gvname = GvNAME(gv);
7472 if (*gvname == 'a' && gvname[1] == '\0')
7474 else if (*gvname == 'b' && gvname[1] == '\0')
7479 kid = k; /* back to cmp */
7480 if (kBINOP->op_last->op_type != OP_RV2SV)
7482 kid = kBINOP->op_last; /* down to 2nd arg */
7483 if (kUNOP->op_first->op_type != OP_GV)
7485 kid = kUNOP->op_first; /* get past rv2sv */
7487 if (GvSTASH(gv) != PL_curstash)
7489 gvname = GvNAME(gv);
7491 ? !(*gvname == 'a' && gvname[1] == '\0')
7492 : !(*gvname == 'b' && gvname[1] == '\0'))
7494 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
7496 o->op_private |= OPpSORT_DESCEND;
7497 if (k->op_type == OP_NCMP)
7498 o->op_private |= OPpSORT_NUMERIC;
7499 if (k->op_type == OP_I_NCMP)
7500 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
7501 kid = cLISTOPo->op_first->op_sibling;
7502 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
7504 op_getmad(kid,o,'S'); /* then delete it */
7506 op_free(kid); /* then delete it */
7511 Perl_ck_split(pTHX_ OP *o)
7516 if (o->op_flags & OPf_STACKED)
7517 return no_fh_allowed(o);
7519 kid = cLISTOPo->op_first;
7520 if (kid->op_type != OP_NULL)
7521 Perl_croak(aTHX_ "panic: ck_split");
7522 kid = kid->op_sibling;
7523 op_free(cLISTOPo->op_first);
7524 cLISTOPo->op_first = kid;
7526 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
7527 cLISTOPo->op_last = kid; /* There was only one element previously */
7530 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
7531 OP * const sibl = kid->op_sibling;
7532 kid->op_sibling = 0;
7533 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
7534 if (cLISTOPo->op_first == cLISTOPo->op_last)
7535 cLISTOPo->op_last = kid;
7536 cLISTOPo->op_first = kid;
7537 kid->op_sibling = sibl;
7540 kid->op_type = OP_PUSHRE;
7541 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
7543 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
7544 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
7545 "Use of /g modifier is meaningless in split");
7548 if (!kid->op_sibling)
7549 append_elem(OP_SPLIT, o, newDEFSVOP());
7551 kid = kid->op_sibling;
7554 if (!kid->op_sibling)
7555 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
7556 assert(kid->op_sibling);
7558 kid = kid->op_sibling;
7561 if (kid->op_sibling)
7562 return too_many_arguments(o,OP_DESC(o));
7568 Perl_ck_join(pTHX_ OP *o)
7570 const OP * const kid = cLISTOPo->op_first->op_sibling;
7571 if (kid && kid->op_type == OP_MATCH) {
7572 if (ckWARN(WARN_SYNTAX)) {
7573 const REGEXP *re = PM_GETRE(kPMOP);
7574 const char *pmstr = re ? RX_PRECOMP(re) : "STRING";
7575 const STRLEN len = re ? RX_PRELEN(re) : 6;
7576 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7577 "/%.*s/ should probably be written as \"%.*s\"",
7578 (int)len, pmstr, (int)len, pmstr);
7585 Perl_ck_subr(pTHX_ OP *o)
7588 OP *prev = ((cUNOPo->op_first->op_sibling)
7589 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
7590 OP *o2 = prev->op_sibling;
7592 const char *proto = NULL;
7593 const char *proto_end = NULL;
7598 I32 contextclass = 0;
7599 const char *e = NULL;
7602 o->op_private |= OPpENTERSUB_HASTARG;
7603 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
7604 if (cvop->op_type == OP_RV2CV) {
7606 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
7607 op_null(cvop); /* disable rv2cv */
7608 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
7609 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
7610 GV *gv = cGVOPx_gv(tmpop);
7613 tmpop->op_private |= OPpEARLY_CV;
7617 namegv = CvANON(cv) ? gv : CvGV(cv);
7618 proto = SvPV((SV*)cv, len);
7619 proto_end = proto + len;
7624 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7625 if (o2->op_type == OP_CONST)
7626 o2->op_private &= ~OPpCONST_STRICT;
7627 else if (o2->op_type == OP_LIST) {
7628 OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
7629 if (sib && sib->op_type == OP_CONST)
7630 sib->op_private &= ~OPpCONST_STRICT;
7633 o->op_private |= (PL_hints & HINT_STRICT_REFS);
7634 if (PERLDB_SUB && PL_curstash != PL_debstash)
7635 o->op_private |= OPpENTERSUB_DB;
7636 while (o2 != cvop) {
7638 if (PL_madskills && o2->op_type == OP_STUB) {
7639 o2 = o2->op_sibling;
7642 if (PL_madskills && o2->op_type == OP_NULL)
7643 o3 = ((UNOP*)o2)->op_first;
7647 if (proto >= proto_end)
7648 return too_many_arguments(o, gv_ename(namegv));
7656 /* _ must be at the end */
7657 if (proto[1] && proto[1] != ';')
7672 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
7674 arg == 1 ? "block or sub {}" : "sub {}",
7675 gv_ename(namegv), o3);
7678 /* '*' allows any scalar type, including bareword */
7681 if (o3->op_type == OP_RV2GV)
7682 goto wrapref; /* autoconvert GLOB -> GLOBref */
7683 else if (o3->op_type == OP_CONST)
7684 o3->op_private &= ~OPpCONST_STRICT;
7685 else if (o3->op_type == OP_ENTERSUB) {
7686 /* accidental subroutine, revert to bareword */
7687 OP *gvop = ((UNOP*)o3)->op_first;
7688 if (gvop && gvop->op_type == OP_NULL) {
7689 gvop = ((UNOP*)gvop)->op_first;
7691 for (; gvop->op_sibling; gvop = gvop->op_sibling)
7694 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
7695 (gvop = ((UNOP*)gvop)->op_first) &&
7696 gvop->op_type == OP_GV)
7698 GV * const gv = cGVOPx_gv(gvop);
7699 OP * const sibling = o2->op_sibling;
7700 SV * const n = newSVpvs("");
7702 OP * const oldo2 = o2;
7706 gv_fullname4(n, gv, "", FALSE);
7707 o2 = newSVOP(OP_CONST, 0, n);
7708 op_getmad(oldo2,o2,'O');
7709 prev->op_sibling = o2;
7710 o2->op_sibling = sibling;
7726 if (contextclass++ == 0) {
7727 e = strchr(proto, ']');
7728 if (!e || e == proto)
7737 const char *p = proto;
7738 const char *const end = proto;
7740 while (*--p != '[');
7741 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
7743 gv_ename(namegv), o3);
7748 if (o3->op_type == OP_RV2GV)
7751 bad_type(arg, "symbol", gv_ename(namegv), o3);
7754 if (o3->op_type == OP_ENTERSUB)
7757 bad_type(arg, "subroutine entry", gv_ename(namegv),
7761 if (o3->op_type == OP_RV2SV ||
7762 o3->op_type == OP_PADSV ||
7763 o3->op_type == OP_HELEM ||
7764 o3->op_type == OP_AELEM)
7767 bad_type(arg, "scalar", gv_ename(namegv), o3);
7770 if (o3->op_type == OP_RV2AV ||
7771 o3->op_type == OP_PADAV)
7774 bad_type(arg, "array", gv_ename(namegv), o3);
7777 if (o3->op_type == OP_RV2HV ||
7778 o3->op_type == OP_PADHV)
7781 bad_type(arg, "hash", gv_ename(namegv), o3);
7786 OP* const sib = kid->op_sibling;
7787 kid->op_sibling = 0;
7788 o2 = newUNOP(OP_REFGEN, 0, kid);
7789 o2->op_sibling = sib;
7790 prev->op_sibling = o2;
7792 if (contextclass && e) {
7807 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
7808 gv_ename(namegv), SVfARG(cv));
7813 mod(o2, OP_ENTERSUB);
7815 o2 = o2->op_sibling;
7817 if (o2 == cvop && proto && *proto == '_') {
7818 /* generate an access to $_ */
7820 o2->op_sibling = prev->op_sibling;
7821 prev->op_sibling = o2; /* instead of cvop */
7823 if (proto && !optional && proto_end > proto &&
7824 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
7825 return too_few_arguments(o, gv_ename(namegv));
7828 OP * const oldo = o;
7832 o=newSVOP(OP_CONST, 0, newSViv(0));
7833 op_getmad(oldo,o,'O');
7839 Perl_ck_svconst(pTHX_ OP *o)
7841 PERL_UNUSED_CONTEXT;
7842 SvREADONLY_on(cSVOPo->op_sv);
7847 Perl_ck_chdir(pTHX_ OP *o)
7849 if (o->op_flags & OPf_KIDS) {
7850 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7852 if (kid && kid->op_type == OP_CONST &&
7853 (kid->op_private & OPpCONST_BARE))
7855 o->op_flags |= OPf_SPECIAL;
7856 kid->op_private &= ~OPpCONST_STRICT;
7863 Perl_ck_trunc(pTHX_ OP *o)
7865 if (o->op_flags & OPf_KIDS) {
7866 SVOP *kid = (SVOP*)cUNOPo->op_first;
7868 if (kid->op_type == OP_NULL)
7869 kid = (SVOP*)kid->op_sibling;
7870 if (kid && kid->op_type == OP_CONST &&
7871 (kid->op_private & OPpCONST_BARE))
7873 o->op_flags |= OPf_SPECIAL;
7874 kid->op_private &= ~OPpCONST_STRICT;
7881 Perl_ck_unpack(pTHX_ OP *o)
7883 OP *kid = cLISTOPo->op_first;
7884 if (kid->op_sibling) {
7885 kid = kid->op_sibling;
7886 if (!kid->op_sibling)
7887 kid->op_sibling = newDEFSVOP();
7893 Perl_ck_substr(pTHX_ OP *o)
7896 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
7897 OP *kid = cLISTOPo->op_first;
7899 if (kid->op_type == OP_NULL)
7900 kid = kid->op_sibling;
7902 kid->op_flags |= OPf_MOD;
7909 Perl_ck_each(pTHX_ OP *o)
7912 OP *kid = cLISTOPo->op_first;
7914 if (kid->op_type == OP_PADAV || kid->op_type == OP_RV2AV) {
7915 const unsigned new_type = o->op_type == OP_EACH ? OP_AEACH
7916 : o->op_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
7917 o->op_type = new_type;
7918 o->op_ppaddr = PL_ppaddr[new_type];
7920 else if (!(kid->op_type == OP_PADHV || kid->op_type == OP_RV2HV
7921 || (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE)
7923 bad_type(1, "hash or array", PL_op_desc[o->op_type], kid);
7929 /* A peephole optimizer. We visit the ops in the order they're to execute.
7930 * See the comments at the top of this file for more details about when
7931 * peep() is called */
7934 Perl_peep(pTHX_ register OP *o)
7937 register OP* oldop = NULL;
7939 if (!o || o->op_opt)
7943 SAVEVPTR(PL_curcop);
7944 for (; o; o = o->op_next) {
7947 /* By default, this op has now been optimised. A couple of cases below
7948 clear this again. */
7951 switch (o->op_type) {
7955 PL_curcop = ((COP*)o); /* for warnings */
7959 if (cSVOPo->op_private & OPpCONST_STRICT)
7960 no_bareword_allowed(o);
7962 case OP_METHOD_NAMED:
7963 /* Relocate sv to the pad for thread safety.
7964 * Despite being a "constant", the SV is written to,
7965 * for reference counts, sv_upgrade() etc. */
7967 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
7968 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
7969 /* If op_sv is already a PADTMP then it is being used by
7970 * some pad, so make a copy. */
7971 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
7972 SvREADONLY_on(PAD_SVl(ix));
7973 SvREFCNT_dec(cSVOPo->op_sv);
7975 else if (o->op_type == OP_CONST
7976 && cSVOPo->op_sv == &PL_sv_undef) {
7977 /* PL_sv_undef is hack - it's unsafe to store it in the
7978 AV that is the pad, because av_fetch treats values of
7979 PL_sv_undef as a "free" AV entry and will merrily
7980 replace them with a new SV, causing pad_alloc to think
7981 that this pad slot is free. (When, clearly, it is not)
7983 SvOK_off(PAD_SVl(ix));
7984 SvPADTMP_on(PAD_SVl(ix));
7985 SvREADONLY_on(PAD_SVl(ix));
7988 SvREFCNT_dec(PAD_SVl(ix));
7989 SvPADTMP_on(cSVOPo->op_sv);
7990 PAD_SETSV(ix, cSVOPo->op_sv);
7991 /* XXX I don't know how this isn't readonly already. */
7992 SvREADONLY_on(PAD_SVl(ix));
7994 cSVOPo->op_sv = NULL;
8001 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
8002 if (o->op_next->op_private & OPpTARGET_MY) {
8003 if (o->op_flags & OPf_STACKED) /* chained concats */
8004 break; /* ignore_optimization */
8006 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
8007 o->op_targ = o->op_next->op_targ;
8008 o->op_next->op_targ = 0;
8009 o->op_private |= OPpTARGET_MY;
8012 op_null(o->op_next);
8016 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
8017 break; /* Scalar stub must produce undef. List stub is noop */
8021 if (o->op_targ == OP_NEXTSTATE
8022 || o->op_targ == OP_DBSTATE
8023 || o->op_targ == OP_SETSTATE)
8025 PL_curcop = ((COP*)o);
8027 /* XXX: We avoid setting op_seq here to prevent later calls
8028 to peep() from mistakenly concluding that optimisation
8029 has already occurred. This doesn't fix the real problem,
8030 though (See 20010220.007). AMS 20010719 */
8031 /* op_seq functionality is now replaced by op_opt */
8038 if (oldop && o->op_next) {
8039 oldop->op_next = o->op_next;
8047 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
8048 OP* const pop = (o->op_type == OP_PADAV) ?
8049 o->op_next : o->op_next->op_next;
8051 if (pop && pop->op_type == OP_CONST &&
8052 ((PL_op = pop->op_next)) &&
8053 pop->op_next->op_type == OP_AELEM &&
8054 !(pop->op_next->op_private &
8055 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
8056 (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
8061 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
8062 no_bareword_allowed(pop);
8063 if (o->op_type == OP_GV)
8064 op_null(o->op_next);
8065 op_null(pop->op_next);
8067 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
8068 o->op_next = pop->op_next->op_next;
8069 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
8070 o->op_private = (U8)i;
8071 if (o->op_type == OP_GV) {
8076 o->op_flags |= OPf_SPECIAL;
8077 o->op_type = OP_AELEMFAST;
8082 if (o->op_next->op_type == OP_RV2SV) {
8083 if (!(o->op_next->op_private & OPpDEREF)) {
8084 op_null(o->op_next);
8085 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
8087 o->op_next = o->op_next->op_next;
8088 o->op_type = OP_GVSV;
8089 o->op_ppaddr = PL_ppaddr[OP_GVSV];
8092 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
8093 GV * const gv = cGVOPo_gv;
8094 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
8095 /* XXX could check prototype here instead of just carping */
8096 SV * const sv = sv_newmortal();
8097 gv_efullname3(sv, gv, NULL);
8098 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
8099 "%"SVf"() called too early to check prototype",
8103 else if (o->op_next->op_type == OP_READLINE
8104 && o->op_next->op_next->op_type == OP_CONCAT
8105 && (o->op_next->op_next->op_flags & OPf_STACKED))
8107 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
8108 o->op_type = OP_RCATLINE;
8109 o->op_flags |= OPf_STACKED;
8110 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
8111 op_null(o->op_next->op_next);
8112 op_null(o->op_next);
8128 while (cLOGOP->op_other->op_type == OP_NULL)
8129 cLOGOP->op_other = cLOGOP->op_other->op_next;
8130 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
8135 while (cLOOP->op_redoop->op_type == OP_NULL)
8136 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
8137 peep(cLOOP->op_redoop);
8138 while (cLOOP->op_nextop->op_type == OP_NULL)
8139 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
8140 peep(cLOOP->op_nextop);
8141 while (cLOOP->op_lastop->op_type == OP_NULL)
8142 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
8143 peep(cLOOP->op_lastop);
8147 assert(!(cPMOP->op_pmflags & PMf_ONCE));
8148 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
8149 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
8150 cPMOP->op_pmstashstartu.op_pmreplstart
8151 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
8152 peep(cPMOP->op_pmstashstartu.op_pmreplstart);
8156 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
8157 && ckWARN(WARN_SYNTAX))
8159 if (o->op_next->op_sibling) {
8160 const OPCODE type = o->op_next->op_sibling->op_type;
8161 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
8162 const line_t oldline = CopLINE(PL_curcop);
8163 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
8164 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8165 "Statement unlikely to be reached");
8166 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8167 "\t(Maybe you meant system() when you said exec()?)\n");
8168 CopLINE_set(PL_curcop, oldline);
8179 const char *key = NULL;
8182 if (((BINOP*)o)->op_last->op_type != OP_CONST)
8185 /* Make the CONST have a shared SV */
8186 svp = cSVOPx_svp(((BINOP*)o)->op_last);
8187 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
8188 key = SvPV_const(sv, keylen);
8189 lexname = newSVpvn_share(key,
8190 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
8196 if ((o->op_private & (OPpLVAL_INTRO)))
8199 rop = (UNOP*)((BINOP*)o)->op_first;
8200 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
8202 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
8203 if (!SvPAD_TYPED(lexname))
8205 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8206 if (!fields || !GvHV(*fields))
8208 key = SvPV_const(*svp, keylen);
8209 if (!hv_fetch(GvHV(*fields), key,
8210 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8212 Perl_croak(aTHX_ "No such class field \"%s\" "
8213 "in variable %s of type %s",
8214 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
8227 SVOP *first_key_op, *key_op;
8229 if ((o->op_private & (OPpLVAL_INTRO))
8230 /* I bet there's always a pushmark... */
8231 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
8232 /* hmmm, no optimization if list contains only one key. */
8234 rop = (UNOP*)((LISTOP*)o)->op_last;
8235 if (rop->op_type != OP_RV2HV)
8237 if (rop->op_first->op_type == OP_PADSV)
8238 /* @$hash{qw(keys here)} */
8239 rop = (UNOP*)rop->op_first;
8241 /* @{$hash}{qw(keys here)} */
8242 if (rop->op_first->op_type == OP_SCOPE
8243 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
8245 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
8251 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
8252 if (!SvPAD_TYPED(lexname))
8254 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8255 if (!fields || !GvHV(*fields))
8257 /* Again guessing that the pushmark can be jumped over.... */
8258 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
8259 ->op_first->op_sibling;
8260 for (key_op = first_key_op; key_op;
8261 key_op = (SVOP*)key_op->op_sibling) {
8262 if (key_op->op_type != OP_CONST)
8264 svp = cSVOPx_svp(key_op);
8265 key = SvPV_const(*svp, keylen);
8266 if (!hv_fetch(GvHV(*fields), key,
8267 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8269 Perl_croak(aTHX_ "No such class field \"%s\" "
8270 "in variable %s of type %s",
8271 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
8278 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
8282 /* check that RHS of sort is a single plain array */
8283 OP *oright = cUNOPo->op_first;
8284 if (!oright || oright->op_type != OP_PUSHMARK)
8287 /* reverse sort ... can be optimised. */
8288 if (!cUNOPo->op_sibling) {
8289 /* Nothing follows us on the list. */
8290 OP * const reverse = o->op_next;
8292 if (reverse->op_type == OP_REVERSE &&
8293 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
8294 OP * const pushmark = cUNOPx(reverse)->op_first;
8295 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
8296 && (cUNOPx(pushmark)->op_sibling == o)) {
8297 /* reverse -> pushmark -> sort */
8298 o->op_private |= OPpSORT_REVERSE;
8300 pushmark->op_next = oright->op_next;
8306 /* make @a = sort @a act in-place */
8308 oright = cUNOPx(oright)->op_sibling;
8311 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
8312 oright = cUNOPx(oright)->op_sibling;
8316 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
8317 || oright->op_next != o
8318 || (oright->op_private & OPpLVAL_INTRO)
8322 /* o2 follows the chain of op_nexts through the LHS of the
8323 * assign (if any) to the aassign op itself */
8325 if (!o2 || o2->op_type != OP_NULL)
8328 if (!o2 || o2->op_type != OP_PUSHMARK)
8331 if (o2 && o2->op_type == OP_GV)
8334 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
8335 || (o2->op_private & OPpLVAL_INTRO)
8340 if (!o2 || o2->op_type != OP_NULL)
8343 if (!o2 || o2->op_type != OP_AASSIGN
8344 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
8347 /* check that the sort is the first arg on RHS of assign */
8349 o2 = cUNOPx(o2)->op_first;
8350 if (!o2 || o2->op_type != OP_NULL)
8352 o2 = cUNOPx(o2)->op_first;
8353 if (!o2 || o2->op_type != OP_PUSHMARK)
8355 if (o2->op_sibling != o)
8358 /* check the array is the same on both sides */
8359 if (oleft->op_type == OP_RV2AV) {
8360 if (oright->op_type != OP_RV2AV
8361 || !cUNOPx(oright)->op_first
8362 || cUNOPx(oright)->op_first->op_type != OP_GV
8363 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
8364 cGVOPx_gv(cUNOPx(oright)->op_first)
8368 else if (oright->op_type != OP_PADAV
8369 || oright->op_targ != oleft->op_targ
8373 /* transfer MODishness etc from LHS arg to RHS arg */
8374 oright->op_flags = oleft->op_flags;
8375 o->op_private |= OPpSORT_INPLACE;
8377 /* excise push->gv->rv2av->null->aassign */
8378 o2 = o->op_next->op_next;
8379 op_null(o2); /* PUSHMARK */
8381 if (o2->op_type == OP_GV) {
8382 op_null(o2); /* GV */
8385 op_null(o2); /* RV2AV or PADAV */
8386 o2 = o2->op_next->op_next;
8387 op_null(o2); /* AASSIGN */
8389 o->op_next = o2->op_next;
8395 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
8397 LISTOP *enter, *exlist;
8399 enter = (LISTOP *) o->op_next;
8402 if (enter->op_type == OP_NULL) {
8403 enter = (LISTOP *) enter->op_next;
8407 /* for $a (...) will have OP_GV then OP_RV2GV here.
8408 for (...) just has an OP_GV. */
8409 if (enter->op_type == OP_GV) {
8410 gvop = (OP *) enter;
8411 enter = (LISTOP *) enter->op_next;
8414 if (enter->op_type == OP_RV2GV) {
8415 enter = (LISTOP *) enter->op_next;
8421 if (enter->op_type != OP_ENTERITER)
8424 iter = enter->op_next;
8425 if (!iter || iter->op_type != OP_ITER)
8428 expushmark = enter->op_first;
8429 if (!expushmark || expushmark->op_type != OP_NULL
8430 || expushmark->op_targ != OP_PUSHMARK)
8433 exlist = (LISTOP *) expushmark->op_sibling;
8434 if (!exlist || exlist->op_type != OP_NULL
8435 || exlist->op_targ != OP_LIST)
8438 if (exlist->op_last != o) {
8439 /* Mmm. Was expecting to point back to this op. */
8442 theirmark = exlist->op_first;
8443 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
8446 if (theirmark->op_sibling != o) {
8447 /* There's something between the mark and the reverse, eg
8448 for (1, reverse (...))
8453 ourmark = ((LISTOP *)o)->op_first;
8454 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
8457 ourlast = ((LISTOP *)o)->op_last;
8458 if (!ourlast || ourlast->op_next != o)
8461 rv2av = ourmark->op_sibling;
8462 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
8463 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
8464 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
8465 /* We're just reversing a single array. */
8466 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
8467 enter->op_flags |= OPf_STACKED;
8470 /* We don't have control over who points to theirmark, so sacrifice
8472 theirmark->op_next = ourmark->op_next;
8473 theirmark->op_flags = ourmark->op_flags;
8474 ourlast->op_next = gvop ? gvop : (OP *) enter;
8477 enter->op_private |= OPpITER_REVERSED;
8478 iter->op_private |= OPpITER_REVERSED;
8485 UNOP *refgen, *rv2cv;
8488 if ((o->op_flags & OPf_WANT) != OPf_WANT_VOID)
8491 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
8494 rv2gv = ((BINOP *)o)->op_last;
8495 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
8498 refgen = (UNOP *)((BINOP *)o)->op_first;
8500 if (!refgen || refgen->op_type != OP_REFGEN)
8503 exlist = (LISTOP *)refgen->op_first;
8504 if (!exlist || exlist->op_type != OP_NULL
8505 || exlist->op_targ != OP_LIST)
8508 if (exlist->op_first->op_type != OP_PUSHMARK)
8511 rv2cv = (UNOP*)exlist->op_last;
8513 if (rv2cv->op_type != OP_RV2CV)
8516 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
8517 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
8518 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
8520 o->op_private |= OPpASSIGN_CV_TO_GV;
8521 rv2gv->op_private |= OPpDONT_INIT_GV;
8522 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
8530 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
8531 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
8541 Perl_custom_op_name(pTHX_ const OP* o)
8544 const IV index = PTR2IV(o->op_ppaddr);
8548 if (!PL_custom_op_names) /* This probably shouldn't happen */
8549 return (char *)PL_op_name[OP_CUSTOM];
8551 keysv = sv_2mortal(newSViv(index));
8553 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
8555 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
8557 return SvPV_nolen(HeVAL(he));
8561 Perl_custom_op_desc(pTHX_ const OP* o)
8564 const IV index = PTR2IV(o->op_ppaddr);
8568 if (!PL_custom_op_descs)
8569 return (char *)PL_op_desc[OP_CUSTOM];
8571 keysv = sv_2mortal(newSViv(index));
8573 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
8575 return (char *)PL_op_desc[OP_CUSTOM];
8577 return SvPV_nolen(HeVAL(he));
8582 /* Efficient sub that returns a constant scalar value. */
8584 const_sv_xsub(pTHX_ CV* cv)
8591 Perl_croak(aTHX_ "usage: %s::%s()",
8592 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
8596 ST(0) = (SV*)XSANY.any_ptr;
8602 * c-indentation-style: bsd
8604 * indent-tabs-mode: t
8607 * ex: set ts=8 sts=4 sw=4 noet: