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_OFFSET(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)
1011 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1012 /* Otherwise it's "Useless use of grep iterator" */
1013 useless = OP_DESC(o);
1017 kid = cUNOPo->op_first;
1018 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1019 kid->op_type != OP_TRANS) {
1022 useless = "negative pattern binding (!~)";
1029 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1030 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1031 useless = "a variable";
1036 if (cSVOPo->op_private & OPpCONST_STRICT)
1037 no_bareword_allowed(o);
1039 if (ckWARN(WARN_VOID)) {
1040 useless = "a constant";
1041 if (o->op_private & OPpCONST_ARYBASE)
1043 /* don't warn on optimised away booleans, eg
1044 * use constant Foo, 5; Foo || print; */
1045 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1047 /* the constants 0 and 1 are permitted as they are
1048 conventionally used as dummies in constructs like
1049 1 while some_condition_with_side_effects; */
1050 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1052 else if (SvPOK(sv)) {
1053 /* perl4's way of mixing documentation and code
1054 (before the invention of POD) was based on a
1055 trick to mix nroff and perl code. The trick was
1056 built upon these three nroff macros being used in
1057 void context. The pink camel has the details in
1058 the script wrapman near page 319. */
1059 const char * const maybe_macro = SvPVX_const(sv);
1060 if (strnEQ(maybe_macro, "di", 2) ||
1061 strnEQ(maybe_macro, "ds", 2) ||
1062 strnEQ(maybe_macro, "ig", 2))
1067 op_null(o); /* don't execute or even remember it */
1071 o->op_type = OP_PREINC; /* pre-increment is faster */
1072 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1076 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1077 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1081 o->op_type = OP_I_PREINC; /* pre-increment is faster */
1082 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1086 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
1087 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1096 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1101 if (o->op_flags & OPf_STACKED)
1108 if (!(o->op_flags & OPf_KIDS))
1119 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1126 /* all requires must return a boolean value */
1127 o->op_flags &= ~OPf_WANT;
1132 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
1133 if (!kPMOP->op_pmreplrootu.op_pmreplroot)
1134 deprecate_old("implicit split to @_");
1138 if (useless && ckWARN(WARN_VOID))
1139 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
1144 Perl_listkids(pTHX_ OP *o)
1146 if (o && o->op_flags & OPf_KIDS) {
1148 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1155 Perl_list(pTHX_ OP *o)
1160 /* assumes no premature commitment */
1161 if (!o || (o->op_flags & OPf_WANT)
1162 || (PL_parser && PL_parser->error_count)
1163 || o->op_type == OP_RETURN)
1168 if ((o->op_private & OPpTARGET_MY)
1169 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1171 return o; /* As if inside SASSIGN */
1174 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1176 switch (o->op_type) {
1179 list(cBINOPo->op_first);
1184 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1192 if (!(o->op_flags & OPf_KIDS))
1194 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1195 list(cBINOPo->op_first);
1196 return gen_constant_list(o);
1203 kid = cLISTOPo->op_first;
1205 while ((kid = kid->op_sibling)) {
1206 if (kid->op_sibling)
1211 PL_curcop = &PL_compiling;
1215 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1216 if (kid->op_sibling)
1221 PL_curcop = &PL_compiling;
1224 /* all requires must return a boolean value */
1225 o->op_flags &= ~OPf_WANT;
1232 Perl_scalarseq(pTHX_ OP *o)
1236 const OPCODE type = o->op_type;
1238 if (type == OP_LINESEQ || type == OP_SCOPE ||
1239 type == OP_LEAVE || type == OP_LEAVETRY)
1242 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1243 if (kid->op_sibling) {
1247 PL_curcop = &PL_compiling;
1249 o->op_flags &= ~OPf_PARENS;
1250 if (PL_hints & HINT_BLOCK_SCOPE)
1251 o->op_flags |= OPf_PARENS;
1254 o = newOP(OP_STUB, 0);
1259 S_modkids(pTHX_ OP *o, I32 type)
1261 if (o && o->op_flags & OPf_KIDS) {
1263 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1269 /* Propagate lvalue ("modifiable") context to an op and its children.
1270 * 'type' represents the context type, roughly based on the type of op that
1271 * would do the modifying, although local() is represented by OP_NULL.
1272 * It's responsible for detecting things that can't be modified, flag
1273 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
1274 * might have to vivify a reference in $x), and so on.
1276 * For example, "$a+1 = 2" would cause mod() to be called with o being
1277 * OP_ADD and type being OP_SASSIGN, and would output an error.
1281 Perl_mod(pTHX_ OP *o, I32 type)
1285 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1288 if (!o || (PL_parser && PL_parser->error_count))
1291 if ((o->op_private & OPpTARGET_MY)
1292 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1297 switch (o->op_type) {
1303 if (!(o->op_private & OPpCONST_ARYBASE))
1306 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1307 CopARYBASE_set(&PL_compiling,
1308 (I32)SvIV(cSVOPx(PL_eval_start)->op_sv));
1312 SAVECOPARYBASE(&PL_compiling);
1313 CopARYBASE_set(&PL_compiling, 0);
1315 else if (type == OP_REFGEN)
1318 Perl_croak(aTHX_ "That use of $[ is unsupported");
1321 if ((o->op_flags & OPf_PARENS) || PL_madskills)
1325 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1326 !(o->op_flags & OPf_STACKED)) {
1327 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1328 /* The default is to set op_private to the number of children,
1329 which for a UNOP such as RV2CV is always 1. And w're using
1330 the bit for a flag in RV2CV, so we need it clear. */
1331 o->op_private &= ~1;
1332 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1333 assert(cUNOPo->op_first->op_type == OP_NULL);
1334 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1337 else if (o->op_private & OPpENTERSUB_NOMOD)
1339 else { /* lvalue subroutine call */
1340 o->op_private |= OPpLVAL_INTRO;
1341 PL_modcount = RETURN_UNLIMITED_NUMBER;
1342 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1343 /* Backward compatibility mode: */
1344 o->op_private |= OPpENTERSUB_INARGS;
1347 else { /* Compile-time error message: */
1348 OP *kid = cUNOPo->op_first;
1352 if (kid->op_type != OP_PUSHMARK) {
1353 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1355 "panic: unexpected lvalue entersub "
1356 "args: type/targ %ld:%"UVuf,
1357 (long)kid->op_type, (UV)kid->op_targ);
1358 kid = kLISTOP->op_first;
1360 while (kid->op_sibling)
1361 kid = kid->op_sibling;
1362 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1364 if (kid->op_type == OP_METHOD_NAMED
1365 || kid->op_type == OP_METHOD)
1369 NewOp(1101, newop, 1, UNOP);
1370 newop->op_type = OP_RV2CV;
1371 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1372 newop->op_first = NULL;
1373 newop->op_next = (OP*)newop;
1374 kid->op_sibling = (OP*)newop;
1375 newop->op_private |= OPpLVAL_INTRO;
1376 newop->op_private &= ~1;
1380 if (kid->op_type != OP_RV2CV)
1382 "panic: unexpected lvalue entersub "
1383 "entry via type/targ %ld:%"UVuf,
1384 (long)kid->op_type, (UV)kid->op_targ);
1385 kid->op_private |= OPpLVAL_INTRO;
1386 break; /* Postpone until runtime */
1390 kid = kUNOP->op_first;
1391 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1392 kid = kUNOP->op_first;
1393 if (kid->op_type == OP_NULL)
1395 "Unexpected constant lvalue entersub "
1396 "entry via type/targ %ld:%"UVuf,
1397 (long)kid->op_type, (UV)kid->op_targ);
1398 if (kid->op_type != OP_GV) {
1399 /* Restore RV2CV to check lvalueness */
1401 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1402 okid->op_next = kid->op_next;
1403 kid->op_next = okid;
1406 okid->op_next = NULL;
1407 okid->op_type = OP_RV2CV;
1409 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1410 okid->op_private |= OPpLVAL_INTRO;
1411 okid->op_private &= ~1;
1415 cv = GvCV(kGVOP_gv);
1425 /* grep, foreach, subcalls, refgen */
1426 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1428 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1429 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1431 : (o->op_type == OP_ENTERSUB
1432 ? "non-lvalue subroutine call"
1434 type ? PL_op_desc[type] : "local"));
1448 case OP_RIGHT_SHIFT:
1457 if (!(o->op_flags & OPf_STACKED))
1464 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1470 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1471 PL_modcount = RETURN_UNLIMITED_NUMBER;
1472 return o; /* Treat \(@foo) like ordinary list. */
1476 if (scalar_mod_type(o, type))
1478 ref(cUNOPo->op_first, o->op_type);
1482 if (type == OP_LEAVESUBLV)
1483 o->op_private |= OPpMAYBE_LVSUB;
1489 PL_modcount = RETURN_UNLIMITED_NUMBER;
1492 ref(cUNOPo->op_first, o->op_type);
1497 PL_hints |= HINT_BLOCK_SCOPE;
1512 PL_modcount = RETURN_UNLIMITED_NUMBER;
1513 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1514 return o; /* Treat \(@foo) like ordinary list. */
1515 if (scalar_mod_type(o, type))
1517 if (type == OP_LEAVESUBLV)
1518 o->op_private |= OPpMAYBE_LVSUB;
1522 if (!type) /* local() */
1523 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1524 PAD_COMPNAME_PV(o->op_targ));
1532 if (type != OP_SASSIGN)
1536 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1541 if (type == OP_LEAVESUBLV)
1542 o->op_private |= OPpMAYBE_LVSUB;
1544 pad_free(o->op_targ);
1545 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1546 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1547 if (o->op_flags & OPf_KIDS)
1548 mod(cBINOPo->op_first->op_sibling, type);
1553 ref(cBINOPo->op_first, o->op_type);
1554 if (type == OP_ENTERSUB &&
1555 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1556 o->op_private |= OPpLVAL_DEFER;
1557 if (type == OP_LEAVESUBLV)
1558 o->op_private |= OPpMAYBE_LVSUB;
1568 if (o->op_flags & OPf_KIDS)
1569 mod(cLISTOPo->op_last, type);
1574 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1576 else if (!(o->op_flags & OPf_KIDS))
1578 if (o->op_targ != OP_LIST) {
1579 mod(cBINOPo->op_first, type);
1585 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1590 if (type != OP_LEAVESUBLV)
1592 break; /* mod()ing was handled by ck_return() */
1595 /* [20011101.069] File test operators interpret OPf_REF to mean that
1596 their argument is a filehandle; thus \stat(".") should not set
1598 if (type == OP_REFGEN &&
1599 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1602 if (type != OP_LEAVESUBLV)
1603 o->op_flags |= OPf_MOD;
1605 if (type == OP_AASSIGN || type == OP_SASSIGN)
1606 o->op_flags |= OPf_SPECIAL|OPf_REF;
1607 else if (!type) { /* local() */
1610 o->op_private |= OPpLVAL_INTRO;
1611 o->op_flags &= ~OPf_SPECIAL;
1612 PL_hints |= HINT_BLOCK_SCOPE;
1617 if (ckWARN(WARN_SYNTAX)) {
1618 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1619 "Useless localization of %s", OP_DESC(o));
1623 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1624 && type != OP_LEAVESUBLV)
1625 o->op_flags |= OPf_REF;
1630 S_scalar_mod_type(const OP *o, I32 type)
1634 if (o->op_type == OP_RV2GV)
1658 case OP_RIGHT_SHIFT:
1678 S_is_handle_constructor(const OP *o, I32 numargs)
1680 switch (o->op_type) {
1688 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1701 Perl_refkids(pTHX_ OP *o, I32 type)
1703 if (o && o->op_flags & OPf_KIDS) {
1705 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1712 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
1717 if (!o || (PL_parser && PL_parser->error_count))
1720 switch (o->op_type) {
1722 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1723 !(o->op_flags & OPf_STACKED)) {
1724 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1725 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1726 assert(cUNOPo->op_first->op_type == OP_NULL);
1727 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1728 o->op_flags |= OPf_SPECIAL;
1729 o->op_private &= ~1;
1734 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1735 doref(kid, type, set_op_ref);
1738 if (type == OP_DEFINED)
1739 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1740 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1743 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1744 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1745 : type == OP_RV2HV ? OPpDEREF_HV
1747 o->op_flags |= OPf_MOD;
1754 o->op_flags |= OPf_REF;
1757 if (type == OP_DEFINED)
1758 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1759 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1765 o->op_flags |= OPf_REF;
1770 if (!(o->op_flags & OPf_KIDS))
1772 doref(cBINOPo->op_first, type, set_op_ref);
1776 doref(cBINOPo->op_first, o->op_type, set_op_ref);
1777 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1778 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1779 : type == OP_RV2HV ? OPpDEREF_HV
1781 o->op_flags |= OPf_MOD;
1791 if (!(o->op_flags & OPf_KIDS))
1793 doref(cLISTOPo->op_last, type, set_op_ref);
1803 S_dup_attrlist(pTHX_ OP *o)
1808 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1809 * where the first kid is OP_PUSHMARK and the remaining ones
1810 * are OP_CONST. We need to push the OP_CONST values.
1812 if (o->op_type == OP_CONST)
1813 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
1815 else if (o->op_type == OP_NULL)
1819 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1821 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1822 if (o->op_type == OP_CONST)
1823 rop = append_elem(OP_LIST, rop,
1824 newSVOP(OP_CONST, o->op_flags,
1825 SvREFCNT_inc_NN(cSVOPo->op_sv)));
1832 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1837 /* fake up C<use attributes $pkg,$rv,@attrs> */
1838 ENTER; /* need to protect against side-effects of 'use' */
1839 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1841 #define ATTRSMODULE "attributes"
1842 #define ATTRSMODULE_PM "attributes.pm"
1845 /* Don't force the C<use> if we don't need it. */
1846 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
1847 if (svp && *svp != &PL_sv_undef)
1848 NOOP; /* already in %INC */
1850 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1851 newSVpvs(ATTRSMODULE), NULL);
1854 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1855 newSVpvs(ATTRSMODULE),
1857 prepend_elem(OP_LIST,
1858 newSVOP(OP_CONST, 0, stashsv),
1859 prepend_elem(OP_LIST,
1860 newSVOP(OP_CONST, 0,
1862 dup_attrlist(attrs))));
1868 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1871 OP *pack, *imop, *arg;
1877 assert(target->op_type == OP_PADSV ||
1878 target->op_type == OP_PADHV ||
1879 target->op_type == OP_PADAV);
1881 /* Ensure that attributes.pm is loaded. */
1882 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1884 /* Need package name for method call. */
1885 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
1887 /* Build up the real arg-list. */
1888 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1890 arg = newOP(OP_PADSV, 0);
1891 arg->op_targ = target->op_targ;
1892 arg = prepend_elem(OP_LIST,
1893 newSVOP(OP_CONST, 0, stashsv),
1894 prepend_elem(OP_LIST,
1895 newUNOP(OP_REFGEN, 0,
1896 mod(arg, OP_REFGEN)),
1897 dup_attrlist(attrs)));
1899 /* Fake up a method call to import */
1900 meth = newSVpvs_share("import");
1901 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1902 append_elem(OP_LIST,
1903 prepend_elem(OP_LIST, pack, list(arg)),
1904 newSVOP(OP_METHOD_NAMED, 0, meth)));
1905 imop->op_private |= OPpENTERSUB_NOMOD;
1907 /* Combine the ops. */
1908 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1912 =notfor apidoc apply_attrs_string
1914 Attempts to apply a list of attributes specified by the C<attrstr> and
1915 C<len> arguments to the subroutine identified by the C<cv> argument which
1916 is expected to be associated with the package identified by the C<stashpv>
1917 argument (see L<attributes>). It gets this wrong, though, in that it
1918 does not correctly identify the boundaries of the individual attribute
1919 specifications within C<attrstr>. This is not really intended for the
1920 public API, but has to be listed here for systems such as AIX which
1921 need an explicit export list for symbols. (It's called from XS code
1922 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1923 to respect attribute syntax properly would be welcome.
1929 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
1930 const char *attrstr, STRLEN len)
1935 len = strlen(attrstr);
1939 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1941 const char * const sstr = attrstr;
1942 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1943 attrs = append_elem(OP_LIST, attrs,
1944 newSVOP(OP_CONST, 0,
1945 newSVpvn(sstr, attrstr-sstr)));
1949 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1950 newSVpvs(ATTRSMODULE),
1951 NULL, prepend_elem(OP_LIST,
1952 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1953 prepend_elem(OP_LIST,
1954 newSVOP(OP_CONST, 0,
1960 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
1965 if (!o || (PL_parser && PL_parser->error_count))
1969 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
1970 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
1974 if (type == OP_LIST) {
1976 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1977 my_kid(kid, attrs, imopsp);
1978 } else if (type == OP_UNDEF
1984 } else if (type == OP_RV2SV || /* "our" declaration */
1986 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1987 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1988 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1990 PL_parser->in_my == KEY_our
1992 : PL_parser->in_my == KEY_state ? "state" : "my"));
1994 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
1995 PL_parser->in_my = FALSE;
1996 PL_parser->in_my_stash = NULL;
1997 apply_attrs(GvSTASH(gv),
1998 (type == OP_RV2SV ? GvSV(gv) :
1999 type == OP_RV2AV ? (SV*)GvAV(gv) :
2000 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
2003 o->op_private |= OPpOUR_INTRO;
2006 else if (type != OP_PADSV &&
2009 type != OP_PUSHMARK)
2011 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2013 PL_parser->in_my == KEY_our
2015 : PL_parser->in_my == KEY_state ? "state" : "my"));
2018 else if (attrs && type != OP_PUSHMARK) {
2021 PL_parser->in_my = FALSE;
2022 PL_parser->in_my_stash = NULL;
2024 /* check for C<my Dog $spot> when deciding package */
2025 stash = PAD_COMPNAME_TYPE(o->op_targ);
2027 stash = PL_curstash;
2028 apply_attrs_my(stash, o, attrs, imopsp);
2030 o->op_flags |= OPf_MOD;
2031 o->op_private |= OPpLVAL_INTRO;
2032 if (PL_parser->in_my == KEY_state)
2033 o->op_private |= OPpPAD_STATE;
2038 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2042 int maybe_scalar = 0;
2044 /* [perl #17376]: this appears to be premature, and results in code such as
2045 C< our(%x); > executing in list mode rather than void mode */
2047 if (o->op_flags & OPf_PARENS)
2057 o = my_kid(o, attrs, &rops);
2059 if (maybe_scalar && o->op_type == OP_PADSV) {
2060 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
2061 o->op_private |= OPpLVAL_INTRO;
2064 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
2066 PL_parser->in_my = FALSE;
2067 PL_parser->in_my_stash = NULL;
2072 Perl_my(pTHX_ OP *o)
2074 return my_attrs(o, NULL);
2078 Perl_sawparens(pTHX_ OP *o)
2080 PERL_UNUSED_CONTEXT;
2082 o->op_flags |= OPf_PARENS;
2087 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2091 const OPCODE ltype = left->op_type;
2092 const OPCODE rtype = right->op_type;
2094 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2095 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
2097 const char * const desc
2098 = PL_op_desc[(rtype == OP_SUBST || rtype == OP_TRANS)
2099 ? (int)rtype : OP_MATCH];
2100 const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV)
2101 ? "@array" : "%hash");
2102 Perl_warner(aTHX_ packWARN(WARN_MISC),
2103 "Applying %s to %s will act on scalar(%s)",
2104 desc, sample, sample);
2107 if (rtype == OP_CONST &&
2108 cSVOPx(right)->op_private & OPpCONST_BARE &&
2109 cSVOPx(right)->op_private & OPpCONST_STRICT)
2111 no_bareword_allowed(right);
2114 ismatchop = rtype == OP_MATCH ||
2115 rtype == OP_SUBST ||
2117 if (ismatchop && right->op_private & OPpTARGET_MY) {
2119 right->op_private &= ~OPpTARGET_MY;
2121 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
2124 right->op_flags |= OPf_STACKED;
2125 if (rtype != OP_MATCH &&
2126 ! (rtype == OP_TRANS &&
2127 right->op_private & OPpTRANS_IDENTICAL))
2128 newleft = mod(left, rtype);
2131 if (right->op_type == OP_TRANS)
2132 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
2134 o = prepend_elem(rtype, scalar(newleft), right);
2136 return newUNOP(OP_NOT, 0, scalar(o));
2140 return bind_match(type, left,
2141 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
2145 Perl_invert(pTHX_ OP *o)
2149 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2153 Perl_scope(pTHX_ OP *o)
2157 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2158 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2159 o->op_type = OP_LEAVE;
2160 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2162 else if (o->op_type == OP_LINESEQ) {
2164 o->op_type = OP_SCOPE;
2165 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2166 kid = ((LISTOP*)o)->op_first;
2167 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2170 /* The following deals with things like 'do {1 for 1}' */
2171 kid = kid->op_sibling;
2173 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2178 o = newLISTOP(OP_SCOPE, 0, o, NULL);
2184 Perl_block_start(pTHX_ int full)
2187 const int retval = PL_savestack_ix;
2188 pad_block_start(full);
2190 PL_hints &= ~HINT_BLOCK_SCOPE;
2191 SAVECOMPILEWARNINGS();
2192 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
2197 Perl_block_end(pTHX_ I32 floor, OP *seq)
2200 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2201 OP* const retval = scalarseq(seq);
2203 CopHINTS_set(&PL_compiling, PL_hints);
2205 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2214 const PADOFFSET offset = pad_findmy("$_");
2215 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
2216 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2219 OP * const o = newOP(OP_PADSV, 0);
2220 o->op_targ = offset;
2226 Perl_newPROG(pTHX_ OP *o)
2232 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2233 ((PL_in_eval & EVAL_KEEPERR)
2234 ? OPf_SPECIAL : 0), o);
2235 PL_eval_start = linklist(PL_eval_root);
2236 PL_eval_root->op_private |= OPpREFCOUNTED;
2237 OpREFCNT_set(PL_eval_root, 1);
2238 PL_eval_root->op_next = 0;
2239 CALL_PEEP(PL_eval_start);
2242 if (o->op_type == OP_STUB) {
2243 PL_comppad_name = 0;
2245 S_op_destroy(aTHX_ o);
2248 PL_main_root = scope(sawparens(scalarvoid(o)));
2249 PL_curcop = &PL_compiling;
2250 PL_main_start = LINKLIST(PL_main_root);
2251 PL_main_root->op_private |= OPpREFCOUNTED;
2252 OpREFCNT_set(PL_main_root, 1);
2253 PL_main_root->op_next = 0;
2254 CALL_PEEP(PL_main_start);
2257 /* Register with debugger */
2260 = Perl_get_cvn_flags(aTHX_ STR_WITH_LEN("DB::postponed"), 0);
2264 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2266 call_sv((SV*)cv, G_DISCARD);
2273 Perl_localize(pTHX_ OP *o, I32 lex)
2276 if (o->op_flags & OPf_PARENS)
2277 /* [perl #17376]: this appears to be premature, and results in code such as
2278 C< our(%x); > executing in list mode rather than void mode */
2285 if ( PL_parser->bufptr > PL_parser->oldbufptr
2286 && PL_parser->bufptr[-1] == ','
2287 && ckWARN(WARN_PARENTHESIS))
2289 char *s = PL_parser->bufptr;
2292 /* some heuristics to detect a potential error */
2293 while (*s && (strchr(", \t\n", *s)))
2297 if (*s && strchr("@$%*", *s) && *++s
2298 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2301 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2303 while (*s && (strchr(", \t\n", *s)))
2309 if (sigil && (*s == ';' || *s == '=')) {
2310 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2311 "Parentheses missing around \"%s\" list",
2313 ? (PL_parser->in_my == KEY_our
2315 : PL_parser->in_my == KEY_state
2325 o = mod(o, OP_NULL); /* a bit kludgey */
2326 PL_parser->in_my = FALSE;
2327 PL_parser->in_my_stash = NULL;
2332 Perl_jmaybe(pTHX_ OP *o)
2334 if (o->op_type == OP_LIST) {
2336 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2337 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2343 Perl_fold_constants(pTHX_ register OP *o)
2348 VOL I32 type = o->op_type;
2353 SV * const oldwarnhook = PL_warnhook;
2354 SV * const olddiehook = PL_diehook;
2357 if (PL_opargs[type] & OA_RETSCALAR)
2359 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2360 o->op_targ = pad_alloc(type, SVs_PADTMP);
2362 /* integerize op, unless it happens to be C<-foo>.
2363 * XXX should pp_i_negate() do magic string negation instead? */
2364 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2365 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2366 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2368 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2371 if (!(PL_opargs[type] & OA_FOLDCONST))
2376 /* XXX might want a ck_negate() for this */
2377 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2388 /* XXX what about the numeric ops? */
2389 if (PL_hints & HINT_LOCALE)
2393 if (PL_parser && PL_parser->error_count)
2394 goto nope; /* Don't try to run w/ errors */
2396 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2397 const OPCODE type = curop->op_type;
2398 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2400 type != OP_SCALAR &&
2402 type != OP_PUSHMARK)
2408 curop = LINKLIST(o);
2409 old_next = o->op_next;
2413 oldscope = PL_scopestack_ix;
2414 create_eval_scope(G_FAKINGEVAL);
2416 PL_warnhook = PERL_WARNHOOK_FATAL;
2423 sv = *(PL_stack_sp--);
2424 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2425 pad_swipe(o->op_targ, FALSE);
2426 else if (SvTEMP(sv)) { /* grab mortal temp? */
2427 SvREFCNT_inc_simple_void(sv);
2432 /* Something tried to die. Abandon constant folding. */
2433 /* Pretend the error never happened. */
2434 sv_setpvn(ERRSV,"",0);
2435 o->op_next = old_next;
2439 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
2440 PL_warnhook = oldwarnhook;
2441 PL_diehook = olddiehook;
2442 /* XXX note that this croak may fail as we've already blown away
2443 * the stack - eg any nested evals */
2444 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
2447 PL_warnhook = oldwarnhook;
2448 PL_diehook = olddiehook;
2450 if (PL_scopestack_ix > oldscope)
2451 delete_eval_scope();
2460 if (type == OP_RV2GV)
2461 newop = newGVOP(OP_GV, 0, (GV*)sv);
2463 newop = newSVOP(OP_CONST, 0, (SV*)sv);
2464 op_getmad(o,newop,'f');
2472 Perl_gen_constant_list(pTHX_ register OP *o)
2476 const I32 oldtmps_floor = PL_tmps_floor;
2479 if (PL_parser && PL_parser->error_count)
2480 return o; /* Don't attempt to run with errors */
2482 PL_op = curop = LINKLIST(o);
2488 assert (!(curop->op_flags & OPf_SPECIAL));
2489 assert(curop->op_type == OP_RANGE);
2491 PL_tmps_floor = oldtmps_floor;
2493 o->op_type = OP_RV2AV;
2494 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2495 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2496 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2497 o->op_opt = 0; /* needs to be revisited in peep() */
2498 curop = ((UNOP*)o)->op_first;
2499 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
2501 op_getmad(curop,o,'O');
2510 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2513 if (!o || o->op_type != OP_LIST)
2514 o = newLISTOP(OP_LIST, 0, o, NULL);
2516 o->op_flags &= ~OPf_WANT;
2518 if (!(PL_opargs[type] & OA_MARK))
2519 op_null(cLISTOPo->op_first);
2521 o->op_type = (OPCODE)type;
2522 o->op_ppaddr = PL_ppaddr[type];
2523 o->op_flags |= flags;
2525 o = CHECKOP(type, o);
2526 if (o->op_type != (unsigned)type)
2529 return fold_constants(o);
2532 /* List constructors */
2535 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2543 if (first->op_type != (unsigned)type
2544 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2546 return newLISTOP(type, 0, first, last);
2549 if (first->op_flags & OPf_KIDS)
2550 ((LISTOP*)first)->op_last->op_sibling = last;
2552 first->op_flags |= OPf_KIDS;
2553 ((LISTOP*)first)->op_first = last;
2555 ((LISTOP*)first)->op_last = last;
2560 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2568 if (first->op_type != (unsigned)type)
2569 return prepend_elem(type, (OP*)first, (OP*)last);
2571 if (last->op_type != (unsigned)type)
2572 return append_elem(type, (OP*)first, (OP*)last);
2574 first->op_last->op_sibling = last->op_first;
2575 first->op_last = last->op_last;
2576 first->op_flags |= (last->op_flags & OPf_KIDS);
2579 if (last->op_first && first->op_madprop) {
2580 MADPROP *mp = last->op_first->op_madprop;
2582 while (mp->mad_next)
2584 mp->mad_next = first->op_madprop;
2587 last->op_first->op_madprop = first->op_madprop;
2590 first->op_madprop = last->op_madprop;
2591 last->op_madprop = 0;
2594 S_op_destroy(aTHX_ (OP*)last);
2600 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2608 if (last->op_type == (unsigned)type) {
2609 if (type == OP_LIST) { /* already a PUSHMARK there */
2610 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2611 ((LISTOP*)last)->op_first->op_sibling = first;
2612 if (!(first->op_flags & OPf_PARENS))
2613 last->op_flags &= ~OPf_PARENS;
2616 if (!(last->op_flags & OPf_KIDS)) {
2617 ((LISTOP*)last)->op_last = first;
2618 last->op_flags |= OPf_KIDS;
2620 first->op_sibling = ((LISTOP*)last)->op_first;
2621 ((LISTOP*)last)->op_first = first;
2623 last->op_flags |= OPf_KIDS;
2627 return newLISTOP(type, 0, first, last);
2635 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2638 Newxz(tk, 1, TOKEN);
2639 tk->tk_type = (OPCODE)optype;
2640 tk->tk_type = 12345;
2642 tk->tk_mad = madprop;
2647 Perl_token_free(pTHX_ TOKEN* tk)
2649 if (tk->tk_type != 12345)
2651 mad_free(tk->tk_mad);
2656 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2660 if (tk->tk_type != 12345) {
2661 Perl_warner(aTHX_ packWARN(WARN_MISC),
2662 "Invalid TOKEN object ignored");
2669 /* faked up qw list? */
2671 tm->mad_type == MAD_SV &&
2672 SvPVX((SV*)tm->mad_val)[0] == 'q')
2679 /* pretend constant fold didn't happen? */
2680 if (mp->mad_key == 'f' &&
2681 (o->op_type == OP_CONST ||
2682 o->op_type == OP_GV) )
2684 token_getmad(tk,(OP*)mp->mad_val,slot);
2698 if (mp->mad_key == 'X')
2699 mp->mad_key = slot; /* just change the first one */
2709 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
2718 /* pretend constant fold didn't happen? */
2719 if (mp->mad_key == 'f' &&
2720 (o->op_type == OP_CONST ||
2721 o->op_type == OP_GV) )
2723 op_getmad(from,(OP*)mp->mad_val,slot);
2730 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
2733 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
2739 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
2748 /* pretend constant fold didn't happen? */
2749 if (mp->mad_key == 'f' &&
2750 (o->op_type == OP_CONST ||
2751 o->op_type == OP_GV) )
2753 op_getmad(from,(OP*)mp->mad_val,slot);
2760 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
2763 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
2767 PerlIO_printf(PerlIO_stderr(),
2768 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
2774 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
2792 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
2796 addmad(tm, &(o->op_madprop), slot);
2800 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
2821 Perl_newMADsv(pTHX_ char key, SV* sv)
2823 return newMADPROP(key, MAD_SV, sv, 0);
2827 Perl_newMADPROP(pTHX_ char key, char type, const void* val, I32 vlen)
2830 Newxz(mp, 1, MADPROP);
2833 mp->mad_vlen = vlen;
2834 mp->mad_type = type;
2836 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
2841 Perl_mad_free(pTHX_ MADPROP* mp)
2843 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
2847 mad_free(mp->mad_next);
2848 /* if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
2849 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
2850 switch (mp->mad_type) {
2854 Safefree((char*)mp->mad_val);
2857 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
2858 op_free((OP*)mp->mad_val);
2861 sv_free((SV*)mp->mad_val);
2864 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
2873 Perl_newNULLLIST(pTHX)
2875 return newOP(OP_STUB, 0);
2879 Perl_force_list(pTHX_ OP *o)
2881 if (!o || o->op_type != OP_LIST)
2882 o = newLISTOP(OP_LIST, 0, o, NULL);
2888 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2893 NewOp(1101, listop, 1, LISTOP);
2895 listop->op_type = (OPCODE)type;
2896 listop->op_ppaddr = PL_ppaddr[type];
2899 listop->op_flags = (U8)flags;
2903 else if (!first && last)
2906 first->op_sibling = last;
2907 listop->op_first = first;
2908 listop->op_last = last;
2909 if (type == OP_LIST) {
2910 OP* const pushop = newOP(OP_PUSHMARK, 0);
2911 pushop->op_sibling = first;
2912 listop->op_first = pushop;
2913 listop->op_flags |= OPf_KIDS;
2915 listop->op_last = pushop;
2918 return CHECKOP(type, listop);
2922 Perl_newOP(pTHX_ I32 type, I32 flags)
2926 NewOp(1101, o, 1, OP);
2927 o->op_type = (OPCODE)type;
2928 o->op_ppaddr = PL_ppaddr[type];
2929 o->op_flags = (U8)flags;
2931 o->op_latefreed = 0;
2935 o->op_private = (U8)(0 | (flags >> 8));
2936 if (PL_opargs[type] & OA_RETSCALAR)
2938 if (PL_opargs[type] & OA_TARGET)
2939 o->op_targ = pad_alloc(type, SVs_PADTMP);
2940 return CHECKOP(type, o);
2944 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2950 first = newOP(OP_STUB, 0);
2951 if (PL_opargs[type] & OA_MARK)
2952 first = force_list(first);
2954 NewOp(1101, unop, 1, UNOP);
2955 unop->op_type = (OPCODE)type;
2956 unop->op_ppaddr = PL_ppaddr[type];
2957 unop->op_first = first;
2958 unop->op_flags = (U8)(flags | OPf_KIDS);
2959 unop->op_private = (U8)(1 | (flags >> 8));
2960 unop = (UNOP*) CHECKOP(type, unop);
2964 return fold_constants((OP *) unop);
2968 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2972 NewOp(1101, binop, 1, BINOP);
2975 first = newOP(OP_NULL, 0);
2977 binop->op_type = (OPCODE)type;
2978 binop->op_ppaddr = PL_ppaddr[type];
2979 binop->op_first = first;
2980 binop->op_flags = (U8)(flags | OPf_KIDS);
2983 binop->op_private = (U8)(1 | (flags >> 8));
2986 binop->op_private = (U8)(2 | (flags >> 8));
2987 first->op_sibling = last;
2990 binop = (BINOP*)CHECKOP(type, binop);
2991 if (binop->op_next || binop->op_type != (OPCODE)type)
2994 binop->op_last = binop->op_first->op_sibling;
2996 return fold_constants((OP *)binop);
2999 static int uvcompare(const void *a, const void *b)
3000 __attribute__nonnull__(1)
3001 __attribute__nonnull__(2)
3002 __attribute__pure__;
3003 static int uvcompare(const void *a, const void *b)
3005 if (*((const UV *)a) < (*(const UV *)b))
3007 if (*((const UV *)a) > (*(const UV *)b))
3009 if (*((const UV *)a+1) < (*(const UV *)b+1))
3011 if (*((const UV *)a+1) > (*(const UV *)b+1))
3017 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
3020 SV * const tstr = ((SVOP*)expr)->op_sv;
3023 (repl->op_type == OP_NULL)
3024 ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
3026 ((SVOP*)repl)->op_sv;
3029 const U8 *t = (U8*)SvPV_const(tstr, tlen);
3030 const U8 *r = (U8*)SvPV_const(rstr, rlen);
3034 register short *tbl;
3036 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
3037 const I32 squash = o->op_private & OPpTRANS_SQUASH;
3038 I32 del = o->op_private & OPpTRANS_DELETE;
3040 PL_hints |= HINT_BLOCK_SCOPE;
3043 o->op_private |= OPpTRANS_FROM_UTF;
3046 o->op_private |= OPpTRANS_TO_UTF;
3048 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
3049 SV* const listsv = newSVpvs("# comment\n");
3051 const U8* tend = t + tlen;
3052 const U8* rend = r + rlen;
3066 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
3067 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
3070 const U32 flags = UTF8_ALLOW_DEFAULT;
3074 t = tsave = bytes_to_utf8(t, &len);
3077 if (!to_utf && rlen) {
3079 r = rsave = bytes_to_utf8(r, &len);
3083 /* There are several snags with this code on EBCDIC:
3084 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
3085 2. scan_const() in toke.c has encoded chars in native encoding which makes
3086 ranges at least in EBCDIC 0..255 range the bottom odd.
3090 U8 tmpbuf[UTF8_MAXBYTES+1];
3093 Newx(cp, 2*tlen, UV);
3095 transv = newSVpvs("");
3097 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3099 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
3101 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3105 cp[2*i+1] = cp[2*i];
3109 qsort(cp, i, 2*sizeof(UV), uvcompare);
3110 for (j = 0; j < i; j++) {
3112 diff = val - nextmin;
3114 t = uvuni_to_utf8(tmpbuf,nextmin);
3115 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3117 U8 range_mark = UTF_TO_NATIVE(0xff);
3118 t = uvuni_to_utf8(tmpbuf, val - 1);
3119 sv_catpvn(transv, (char *)&range_mark, 1);
3120 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3127 t = uvuni_to_utf8(tmpbuf,nextmin);
3128 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3130 U8 range_mark = UTF_TO_NATIVE(0xff);
3131 sv_catpvn(transv, (char *)&range_mark, 1);
3133 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
3134 UNICODE_ALLOW_SUPER);
3135 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3136 t = (const U8*)SvPVX_const(transv);
3137 tlen = SvCUR(transv);
3141 else if (!rlen && !del) {
3142 r = t; rlen = tlen; rend = tend;
3145 if ((!rlen && !del) || t == r ||
3146 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
3148 o->op_private |= OPpTRANS_IDENTICAL;
3152 while (t < tend || tfirst <= tlast) {
3153 /* see if we need more "t" chars */
3154 if (tfirst > tlast) {
3155 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3157 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
3159 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3166 /* now see if we need more "r" chars */
3167 if (rfirst > rlast) {
3169 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3171 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
3173 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3182 rfirst = rlast = 0xffffffff;
3186 /* now see which range will peter our first, if either. */
3187 tdiff = tlast - tfirst;
3188 rdiff = rlast - rfirst;
3195 if (rfirst == 0xffffffff) {
3196 diff = tdiff; /* oops, pretend rdiff is infinite */
3198 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
3199 (long)tfirst, (long)tlast);
3201 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
3205 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
3206 (long)tfirst, (long)(tfirst + diff),
3209 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3210 (long)tfirst, (long)rfirst);
3212 if (rfirst + diff > max)
3213 max = rfirst + diff;
3215 grows = (tfirst < rfirst &&
3216 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3228 else if (max > 0xff)
3233 PerlMemShared_free(cPVOPo->op_pv);
3234 cPVOPo->op_pv = NULL;
3236 swash = (SV*)swash_init("utf8", "", listsv, bits, none);
3238 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
3239 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
3240 PAD_SETSV(cPADOPo->op_padix, swash);
3243 cSVOPo->op_sv = swash;
3245 SvREFCNT_dec(listsv);
3246 SvREFCNT_dec(transv);
3248 if (!del && havefinal && rlen)
3249 (void)hv_store((HV*)SvRV(swash), "FINAL", 5,
3250 newSVuv((UV)final), 0);
3253 o->op_private |= OPpTRANS_GROWS;
3259 op_getmad(expr,o,'e');
3260 op_getmad(repl,o,'r');
3268 tbl = (short*)cPVOPo->op_pv;
3270 Zero(tbl, 256, short);
3271 for (i = 0; i < (I32)tlen; i++)
3273 for (i = 0, j = 0; i < 256; i++) {
3275 if (j >= (I32)rlen) {
3284 if (i < 128 && r[j] >= 128)
3294 o->op_private |= OPpTRANS_IDENTICAL;
3296 else if (j >= (I32)rlen)
3301 PerlMemShared_realloc(tbl,
3302 (0x101+rlen-j) * sizeof(short));
3303 cPVOPo->op_pv = (char*)tbl;
3305 tbl[0x100] = (short)(rlen - j);
3306 for (i=0; i < (I32)rlen - j; i++)
3307 tbl[0x101+i] = r[j+i];
3311 if (!rlen && !del) {
3314 o->op_private |= OPpTRANS_IDENTICAL;
3316 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3317 o->op_private |= OPpTRANS_IDENTICAL;
3319 for (i = 0; i < 256; i++)
3321 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3322 if (j >= (I32)rlen) {
3324 if (tbl[t[i]] == -1)
3330 if (tbl[t[i]] == -1) {
3331 if (t[i] < 128 && r[j] >= 128)
3338 o->op_private |= OPpTRANS_GROWS;
3340 op_getmad(expr,o,'e');
3341 op_getmad(repl,o,'r');
3351 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3356 NewOp(1101, pmop, 1, PMOP);
3357 pmop->op_type = (OPCODE)type;
3358 pmop->op_ppaddr = PL_ppaddr[type];
3359 pmop->op_flags = (U8)flags;
3360 pmop->op_private = (U8)(0 | (flags >> 8));
3362 if (PL_hints & HINT_RE_TAINT)
3363 pmop->op_pmflags |= PMf_RETAINT;
3364 if (PL_hints & HINT_LOCALE)
3365 pmop->op_pmflags |= PMf_LOCALE;
3369 if (av_len((AV*) PL_regex_pad[0]) > -1) {
3370 SV * const repointer = av_pop((AV*)PL_regex_pad[0]);
3371 pmop->op_pmoffset = SvIV(repointer);
3372 SvREPADTMP_off(repointer);
3373 sv_setiv(repointer,0);
3375 SV * const repointer = newSViv(0);
3376 av_push(PL_regex_padav, SvREFCNT_inc_simple_NN(repointer));
3377 pmop->op_pmoffset = av_len(PL_regex_padav);
3378 PL_regex_pad = AvARRAY(PL_regex_padav);
3382 return CHECKOP(type, pmop);
3385 /* Given some sort of match op o, and an expression expr containing a
3386 * pattern, either compile expr into a regex and attach it to o (if it's
3387 * constant), or convert expr into a runtime regcomp op sequence (if it's
3390 * isreg indicates that the pattern is part of a regex construct, eg
3391 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3392 * split "pattern", which aren't. In the former case, expr will be a list
3393 * if the pattern contains more than one term (eg /a$b/) or if it contains
3394 * a replacement, ie s/// or tr///.
3398 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
3403 I32 repl_has_vars = 0;
3407 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
3408 /* last element in list is the replacement; pop it */
3410 repl = cLISTOPx(expr)->op_last;
3411 kid = cLISTOPx(expr)->op_first;
3412 while (kid->op_sibling != repl)
3413 kid = kid->op_sibling;
3414 kid->op_sibling = NULL;
3415 cLISTOPx(expr)->op_last = kid;
3418 if (isreg && expr->op_type == OP_LIST &&
3419 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3421 /* convert single element list to element */
3422 OP* const oe = expr;
3423 expr = cLISTOPx(oe)->op_first->op_sibling;
3424 cLISTOPx(oe)->op_first->op_sibling = NULL;
3425 cLISTOPx(oe)->op_last = NULL;
3429 if (o->op_type == OP_TRANS) {
3430 return pmtrans(o, expr, repl);
3433 reglist = isreg && expr->op_type == OP_LIST;
3437 PL_hints |= HINT_BLOCK_SCOPE;
3440 if (expr->op_type == OP_CONST) {
3441 SV *pat = ((SVOP*)expr)->op_sv;
3442 U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
3444 if (o->op_flags & OPf_SPECIAL)
3445 pm_flags |= RXf_SPLIT;
3448 assert (SvUTF8(pat));
3449 } else if (SvUTF8(pat)) {
3450 /* Not doing UTF-8, despite what the SV says. Is this only if we're
3451 trapped in use 'bytes'? */
3452 /* Make a copy of the octet sequence, but without the flag on, as
3453 the compiler now honours the SvUTF8 flag on pat. */
3455 const char *const p = SvPV(pat, len);
3456 pat = newSVpvn_flags(p, len, SVs_TEMP);
3459 PM_SETRE(pm, CALLREGCOMP(pat, pm_flags));
3462 op_getmad(expr,(OP*)pm,'e');
3468 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3469 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3471 : OP_REGCMAYBE),0,expr);
3473 NewOp(1101, rcop, 1, LOGOP);
3474 rcop->op_type = OP_REGCOMP;
3475 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3476 rcop->op_first = scalar(expr);
3477 rcop->op_flags |= OPf_KIDS
3478 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3479 | (reglist ? OPf_STACKED : 0);
3480 rcop->op_private = 1;
3483 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3485 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
3488 /* establish postfix order */
3489 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3491 rcop->op_next = expr;
3492 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3495 rcop->op_next = LINKLIST(expr);
3496 expr->op_next = (OP*)rcop;
3499 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3504 if (pm->op_pmflags & PMf_EVAL) {
3506 if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
3507 CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
3509 else if (repl->op_type == OP_CONST)
3513 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3514 if (curop->op_type == OP_SCOPE
3515 || curop->op_type == OP_LEAVE
3516 || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
3517 if (curop->op_type == OP_GV) {
3518 GV * const gv = cGVOPx_gv(curop);
3520 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3523 else if (curop->op_type == OP_RV2CV)
3525 else if (curop->op_type == OP_RV2SV ||
3526 curop->op_type == OP_RV2AV ||
3527 curop->op_type == OP_RV2HV ||
3528 curop->op_type == OP_RV2GV) {
3529 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3532 else if (curop->op_type == OP_PADSV ||
3533 curop->op_type == OP_PADAV ||
3534 curop->op_type == OP_PADHV ||
3535 curop->op_type == OP_PADANY)
3539 else if (curop->op_type == OP_PUSHRE)
3540 NOOP; /* Okay here, dangerous in newASSIGNOP */
3550 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
3552 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3553 prepend_elem(o->op_type, scalar(repl), o);
3556 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3557 pm->op_pmflags |= PMf_MAYBE_CONST;
3559 NewOp(1101, rcop, 1, LOGOP);
3560 rcop->op_type = OP_SUBSTCONT;
3561 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3562 rcop->op_first = scalar(repl);
3563 rcop->op_flags |= OPf_KIDS;
3564 rcop->op_private = 1;
3567 /* establish postfix order */
3568 rcop->op_next = LINKLIST(repl);
3569 repl->op_next = (OP*)rcop;
3571 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
3572 assert(!(pm->op_pmflags & PMf_ONCE));
3573 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
3582 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3586 NewOp(1101, svop, 1, SVOP);
3587 svop->op_type = (OPCODE)type;
3588 svop->op_ppaddr = PL_ppaddr[type];
3590 svop->op_next = (OP*)svop;
3591 svop->op_flags = (U8)flags;
3592 if (PL_opargs[type] & OA_RETSCALAR)
3594 if (PL_opargs[type] & OA_TARGET)
3595 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3596 return CHECKOP(type, svop);
3601 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3605 NewOp(1101, padop, 1, PADOP);
3606 padop->op_type = (OPCODE)type;
3607 padop->op_ppaddr = PL_ppaddr[type];
3608 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3609 SvREFCNT_dec(PAD_SVl(padop->op_padix));
3610 PAD_SETSV(padop->op_padix, sv);
3613 padop->op_next = (OP*)padop;
3614 padop->op_flags = (U8)flags;
3615 if (PL_opargs[type] & OA_RETSCALAR)
3617 if (PL_opargs[type] & OA_TARGET)
3618 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3619 return CHECKOP(type, padop);
3624 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3630 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3632 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3637 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3641 NewOp(1101, pvop, 1, PVOP);
3642 pvop->op_type = (OPCODE)type;
3643 pvop->op_ppaddr = PL_ppaddr[type];
3645 pvop->op_next = (OP*)pvop;
3646 pvop->op_flags = (U8)flags;
3647 if (PL_opargs[type] & OA_RETSCALAR)
3649 if (PL_opargs[type] & OA_TARGET)
3650 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3651 return CHECKOP(type, pvop);
3659 Perl_package(pTHX_ OP *o)
3662 SV *const sv = cSVOPo->op_sv;
3667 save_hptr(&PL_curstash);
3668 save_item(PL_curstname);
3670 PL_curstash = gv_stashsv(sv, GV_ADD);
3672 sv_setsv(PL_curstname, sv);
3674 PL_hints |= HINT_BLOCK_SCOPE;
3675 PL_parser->copline = NOLINE;
3676 PL_parser->expect = XSTATE;
3681 if (!PL_madskills) {
3686 pegop = newOP(OP_NULL,0);
3687 op_getmad(o,pegop,'P');
3697 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3704 OP *pegop = newOP(OP_NULL,0);
3707 if (idop->op_type != OP_CONST)
3708 Perl_croak(aTHX_ "Module name must be constant");
3711 op_getmad(idop,pegop,'U');
3716 SV * const vesv = ((SVOP*)version)->op_sv;
3719 op_getmad(version,pegop,'V');
3720 if (!arg && !SvNIOKp(vesv)) {
3727 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3728 Perl_croak(aTHX_ "Version number must be constant number");
3730 /* Make copy of idop so we don't free it twice */
3731 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3733 /* Fake up a method call to VERSION */
3734 meth = newSVpvs_share("VERSION");
3735 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3736 append_elem(OP_LIST,
3737 prepend_elem(OP_LIST, pack, list(version)),
3738 newSVOP(OP_METHOD_NAMED, 0, meth)));
3742 /* Fake up an import/unimport */
3743 if (arg && arg->op_type == OP_STUB) {
3745 op_getmad(arg,pegop,'S');
3746 imop = arg; /* no import on explicit () */
3748 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3749 imop = NULL; /* use 5.0; */
3751 idop->op_private |= OPpCONST_NOVER;
3757 op_getmad(arg,pegop,'A');
3759 /* Make copy of idop so we don't free it twice */
3760 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3762 /* Fake up a method call to import/unimport */
3764 ? newSVpvs_share("import") : newSVpvs_share("unimport");
3765 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3766 append_elem(OP_LIST,
3767 prepend_elem(OP_LIST, pack, list(arg)),
3768 newSVOP(OP_METHOD_NAMED, 0, meth)));
3771 /* Fake up the BEGIN {}, which does its thing immediately. */
3773 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
3776 append_elem(OP_LINESEQ,
3777 append_elem(OP_LINESEQ,
3778 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
3779 newSTATEOP(0, NULL, veop)),
3780 newSTATEOP(0, NULL, imop) ));
3782 /* The "did you use incorrect case?" warning used to be here.
3783 * The problem is that on case-insensitive filesystems one
3784 * might get false positives for "use" (and "require"):
3785 * "use Strict" or "require CARP" will work. This causes
3786 * portability problems for the script: in case-strict
3787 * filesystems the script will stop working.
3789 * The "incorrect case" warning checked whether "use Foo"
3790 * imported "Foo" to your namespace, but that is wrong, too:
3791 * there is no requirement nor promise in the language that
3792 * a Foo.pm should or would contain anything in package "Foo".
3794 * There is very little Configure-wise that can be done, either:
3795 * the case-sensitivity of the build filesystem of Perl does not
3796 * help in guessing the case-sensitivity of the runtime environment.
3799 PL_hints |= HINT_BLOCK_SCOPE;
3800 PL_parser->copline = NOLINE;
3801 PL_parser->expect = XSTATE;
3802 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3805 if (!PL_madskills) {
3806 /* FIXME - don't allocate pegop if !PL_madskills */
3815 =head1 Embedding Functions
3817 =for apidoc load_module
3819 Loads the module whose name is pointed to by the string part of name.
3820 Note that the actual module name, not its filename, should be given.
3821 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3822 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3823 (or 0 for no flags). ver, if specified, provides version semantics
3824 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3825 arguments can be used to specify arguments to the module's import()
3826 method, similar to C<use Foo::Bar VERSION LIST>.
3831 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3834 va_start(args, ver);
3835 vload_module(flags, name, ver, &args);
3839 #ifdef PERL_IMPLICIT_CONTEXT
3841 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3845 va_start(args, ver);
3846 vload_module(flags, name, ver, &args);
3852 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3857 OP * const modname = newSVOP(OP_CONST, 0, name);
3858 modname->op_private |= OPpCONST_BARE;
3860 veop = newSVOP(OP_CONST, 0, ver);
3864 if (flags & PERL_LOADMOD_NOIMPORT) {
3865 imop = sawparens(newNULLLIST());
3867 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3868 imop = va_arg(*args, OP*);
3873 sv = va_arg(*args, SV*);
3875 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3876 sv = va_arg(*args, SV*);
3880 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
3881 * that it has a PL_parser to play with while doing that, and also
3882 * that it doesn't mess with any existing parser, by creating a tmp
3883 * new parser with lex_start(). This won't actually be used for much,
3884 * since pp_require() will create another parser for the real work. */
3887 SAVEVPTR(PL_curcop);
3888 lex_start(NULL, NULL, FALSE);
3889 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3890 veop, modname, imop);
3895 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
3901 if (!force_builtin) {
3902 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
3903 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
3904 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
3905 gv = gvp ? *gvp : NULL;
3909 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3910 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3911 append_elem(OP_LIST, term,
3912 scalar(newUNOP(OP_RV2CV, 0,
3913 newGVOP(OP_GV, 0, gv))))));
3916 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3922 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3924 return newBINOP(OP_LSLICE, flags,
3925 list(force_list(subscript)),
3926 list(force_list(listval)) );
3930 S_is_list_assignment(pTHX_ register const OP *o)
3938 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
3939 o = cUNOPo->op_first;
3941 flags = o->op_flags;
3943 if (type == OP_COND_EXPR) {
3944 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
3945 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3950 yyerror("Assignment to both a list and a scalar");
3954 if (type == OP_LIST &&
3955 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
3956 o->op_private & OPpLVAL_INTRO)
3959 if (type == OP_LIST || flags & OPf_PARENS ||
3960 type == OP_RV2AV || type == OP_RV2HV ||
3961 type == OP_ASLICE || type == OP_HSLICE)
3964 if (type == OP_PADAV || type == OP_PADHV)
3967 if (type == OP_RV2SV)
3974 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3980 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3981 return newLOGOP(optype, 0,
3982 mod(scalar(left), optype),
3983 newUNOP(OP_SASSIGN, 0, scalar(right)));
3986 return newBINOP(optype, OPf_STACKED,
3987 mod(scalar(left), optype), scalar(right));
3991 if (is_list_assignment(left)) {
3992 static const char no_list_state[] = "Initialization of state variables"
3993 " in list context currently forbidden";
3997 /* Grandfathering $[ assignment here. Bletch.*/
3998 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
3999 PL_eval_start = (left->op_type == OP_CONST) ? right : NULL;
4000 left = mod(left, OP_AASSIGN);
4003 else if (left->op_type == OP_CONST) {
4005 /* Result of assignment is always 1 (or we'd be dead already) */
4006 return newSVOP(OP_CONST, 0, newSViv(1));
4008 curop = list(force_list(left));
4009 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
4010 o->op_private = (U8)(0 | (flags >> 8));
4012 /* PL_generation sorcery:
4013 * an assignment like ($a,$b) = ($c,$d) is easier than
4014 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
4015 * To detect whether there are common vars, the global var
4016 * PL_generation is incremented for each assign op we compile.
4017 * Then, while compiling the assign op, we run through all the
4018 * variables on both sides of the assignment, setting a spare slot
4019 * in each of them to PL_generation. If any of them already have
4020 * that value, we know we've got commonality. We could use a
4021 * single bit marker, but then we'd have to make 2 passes, first
4022 * to clear the flag, then to test and set it. To find somewhere
4023 * to store these values, evil chicanery is done with SvUVX().
4029 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4030 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
4031 if (curop->op_type == OP_GV) {
4032 GV *gv = cGVOPx_gv(curop);
4034 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4036 GvASSIGN_GENERATION_set(gv, PL_generation);
4038 else if (curop->op_type == OP_PADSV ||
4039 curop->op_type == OP_PADAV ||
4040 curop->op_type == OP_PADHV ||
4041 curop->op_type == OP_PADANY)
4043 if (PAD_COMPNAME_GEN(curop->op_targ)
4044 == (STRLEN)PL_generation)
4046 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
4049 else if (curop->op_type == OP_RV2CV)
4051 else if (curop->op_type == OP_RV2SV ||
4052 curop->op_type == OP_RV2AV ||
4053 curop->op_type == OP_RV2HV ||
4054 curop->op_type == OP_RV2GV) {
4055 if (lastop->op_type != OP_GV) /* funny deref? */
4058 else if (curop->op_type == OP_PUSHRE) {
4060 if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
4061 GV *const gv = (GV*)PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff);
4063 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4065 GvASSIGN_GENERATION_set(gv, PL_generation);
4069 = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
4072 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4074 GvASSIGN_GENERATION_set(gv, PL_generation);
4084 o->op_private |= OPpASSIGN_COMMON;
4087 if ((left->op_type == OP_LIST
4088 || (left->op_type == OP_NULL && left->op_targ == OP_LIST))) {
4089 OP* lop = ((LISTOP*)left)->op_first;
4091 if (lop->op_type == OP_PADSV ||
4092 lop->op_type == OP_PADAV ||
4093 lop->op_type == OP_PADHV ||
4094 lop->op_type == OP_PADANY) {
4095 if (lop->op_private & OPpPAD_STATE) {
4096 if (left->op_private & OPpLVAL_INTRO) {
4097 /* Each variable in state($a, $b, $c) = ... */
4100 /* Each state variable in
4101 (state $a, my $b, our $c, $d, undef) = ... */
4103 yyerror(no_list_state);
4105 /* Each my variable in
4106 (state $a, my $b, our $c, $d, undef) = ... */
4109 /* Other ops in the list. undef may be interesting in
4110 (state $a, undef, state $c) */
4112 lop = lop->op_sibling;
4115 else if (((left->op_private & (OPpLVAL_INTRO | OPpPAD_STATE))
4116 == (OPpLVAL_INTRO | OPpPAD_STATE))
4117 && ( left->op_type == OP_PADSV
4118 || left->op_type == OP_PADAV
4119 || left->op_type == OP_PADHV
4120 || left->op_type == OP_PADANY))
4122 /* All single variable list context state assignments, hence
4132 yyerror(no_list_state);
4135 if (right && right->op_type == OP_SPLIT && !PL_madskills) {
4136 OP* tmpop = ((LISTOP*)right)->op_first;
4137 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
4138 PMOP * const pm = (PMOP*)tmpop;
4139 if (left->op_type == OP_RV2AV &&
4140 !(left->op_private & OPpLVAL_INTRO) &&
4141 !(o->op_private & OPpASSIGN_COMMON) )
4143 tmpop = ((UNOP*)left)->op_first;
4144 if (tmpop->op_type == OP_GV
4146 && !pm->op_pmreplrootu.op_pmtargetoff
4148 && !pm->op_pmreplrootu.op_pmtargetgv
4152 pm->op_pmreplrootu.op_pmtargetoff
4153 = cPADOPx(tmpop)->op_padix;
4154 cPADOPx(tmpop)->op_padix = 0; /* steal it */
4156 pm->op_pmreplrootu.op_pmtargetgv
4157 = (GV*)cSVOPx(tmpop)->op_sv;
4158 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
4160 pm->op_pmflags |= PMf_ONCE;
4161 tmpop = cUNOPo->op_first; /* to list (nulled) */
4162 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
4163 tmpop->op_sibling = NULL; /* don't free split */
4164 right->op_next = tmpop->op_next; /* fix starting loc */
4165 op_free(o); /* blow off assign */
4166 right->op_flags &= ~OPf_WANT;
4167 /* "I don't know and I don't care." */
4172 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
4173 ((LISTOP*)right)->op_last->op_type == OP_CONST)
4175 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
4177 sv_setiv(sv, PL_modcount+1);
4185 right = newOP(OP_UNDEF, 0);
4186 if (right->op_type == OP_READLINE) {
4187 right->op_flags |= OPf_STACKED;
4188 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
4191 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
4192 o = newBINOP(OP_SASSIGN, flags,
4193 scalar(right), mod(scalar(left), OP_SASSIGN) );
4199 o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
4200 o->op_private |= OPpCONST_ARYBASE;
4207 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
4210 const U32 seq = intro_my();
4213 NewOp(1101, cop, 1, COP);
4214 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
4215 cop->op_type = OP_DBSTATE;
4216 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
4219 cop->op_type = OP_NEXTSTATE;
4220 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
4222 cop->op_flags = (U8)flags;
4223 CopHINTS_set(cop, PL_hints);
4225 cop->op_private |= NATIVE_HINTS;
4227 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
4228 cop->op_next = (OP*)cop;
4231 CopLABEL_set(cop, label);
4232 PL_hints |= HINT_BLOCK_SCOPE;
4235 /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
4236 CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
4238 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
4239 cop->cop_hints_hash = PL_curcop->cop_hints_hash;
4240 if (cop->cop_hints_hash) {
4242 cop->cop_hints_hash->refcounted_he_refcnt++;
4243 HINTS_REFCNT_UNLOCK;
4246 if (PL_parser && PL_parser->copline == NOLINE)
4247 CopLINE_set(cop, CopLINE(PL_curcop));
4249 CopLINE_set(cop, PL_parser->copline);
4251 PL_parser->copline = NOLINE;
4254 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
4256 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
4258 CopSTASH_set(cop, PL_curstash);
4260 if (PERLDB_LINE && PL_curstash != PL_debstash) {
4261 AV *av = CopFILEAVx(PL_curcop);
4263 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
4264 if (svp && *svp != &PL_sv_undef ) {
4265 (void)SvIOK_on(*svp);
4266 SvIV_set(*svp, PTR2IV(cop));
4271 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
4276 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
4279 return new_logop(type, flags, &first, &other);
4283 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
4288 OP *first = *firstp;
4289 OP * const other = *otherp;
4291 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
4292 return newBINOP(type, flags, scalar(first), scalar(other));
4294 scalarboolean(first);
4295 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
4296 if (first->op_type == OP_NOT
4297 && (first->op_flags & OPf_SPECIAL)
4298 && (first->op_flags & OPf_KIDS)
4300 if (type == OP_AND || type == OP_OR) {
4306 first = *firstp = cUNOPo->op_first;
4308 first->op_next = o->op_next;
4309 cUNOPo->op_first = NULL;
4313 if (first->op_type == OP_CONST) {
4314 if (first->op_private & OPpCONST_STRICT)
4315 no_bareword_allowed(first);
4316 else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
4317 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
4318 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
4319 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
4320 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
4322 if (other->op_type == OP_CONST)
4323 other->op_private |= OPpCONST_SHORTCIRCUIT;
4325 OP *newop = newUNOP(OP_NULL, 0, other);
4326 op_getmad(first, newop, '1');
4327 newop->op_targ = type; /* set "was" field */
4334 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
4335 const OP *o2 = other;
4336 if ( ! (o2->op_type == OP_LIST
4337 && (( o2 = cUNOPx(o2)->op_first))
4338 && o2->op_type == OP_PUSHMARK
4339 && (( o2 = o2->op_sibling)) )
4342 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
4343 || o2->op_type == OP_PADHV)
4344 && o2->op_private & OPpLVAL_INTRO
4345 && !(o2->op_private & OPpPAD_STATE)
4346 && ckWARN(WARN_DEPRECATED))
4348 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4349 "Deprecated use of my() in false conditional");
4353 if (first->op_type == OP_CONST)
4354 first->op_private |= OPpCONST_SHORTCIRCUIT;
4356 first = newUNOP(OP_NULL, 0, first);
4357 op_getmad(other, first, '2');
4358 first->op_targ = type; /* set "was" field */
4365 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
4366 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
4368 const OP * const k1 = ((UNOP*)first)->op_first;
4369 const OP * const k2 = k1->op_sibling;
4371 switch (first->op_type)
4374 if (k2 && k2->op_type == OP_READLINE
4375 && (k2->op_flags & OPf_STACKED)
4376 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4378 warnop = k2->op_type;
4383 if (k1->op_type == OP_READDIR
4384 || k1->op_type == OP_GLOB
4385 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4386 || k1->op_type == OP_EACH)
4388 warnop = ((k1->op_type == OP_NULL)
4389 ? (OPCODE)k1->op_targ : k1->op_type);
4394 const line_t oldline = CopLINE(PL_curcop);
4395 CopLINE_set(PL_curcop, PL_parser->copline);
4396 Perl_warner(aTHX_ packWARN(WARN_MISC),
4397 "Value of %s%s can be \"0\"; test with defined()",
4399 ((warnop == OP_READLINE || warnop == OP_GLOB)
4400 ? " construct" : "() operator"));
4401 CopLINE_set(PL_curcop, oldline);
4408 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
4409 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
4411 NewOp(1101, logop, 1, LOGOP);
4413 logop->op_type = (OPCODE)type;
4414 logop->op_ppaddr = PL_ppaddr[type];
4415 logop->op_first = first;
4416 logop->op_flags = (U8)(flags | OPf_KIDS);
4417 logop->op_other = LINKLIST(other);
4418 logop->op_private = (U8)(1 | (flags >> 8));
4420 /* establish postfix order */
4421 logop->op_next = LINKLIST(first);
4422 first->op_next = (OP*)logop;
4423 first->op_sibling = other;
4425 CHECKOP(type,logop);
4427 o = newUNOP(OP_NULL, 0, (OP*)logop);
4434 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
4442 return newLOGOP(OP_AND, 0, first, trueop);
4444 return newLOGOP(OP_OR, 0, first, falseop);
4446 scalarboolean(first);
4447 if (first->op_type == OP_CONST) {
4448 /* Left or right arm of the conditional? */
4449 const bool left = SvTRUE(((SVOP*)first)->op_sv);
4450 OP *live = left ? trueop : falseop;
4451 OP *const dead = left ? falseop : trueop;
4452 if (first->op_private & OPpCONST_BARE &&
4453 first->op_private & OPpCONST_STRICT) {
4454 no_bareword_allowed(first);
4457 /* This is all dead code when PERL_MAD is not defined. */
4458 live = newUNOP(OP_NULL, 0, live);
4459 op_getmad(first, live, 'C');
4460 op_getmad(dead, live, left ? 'e' : 't');
4467 NewOp(1101, logop, 1, LOGOP);
4468 logop->op_type = OP_COND_EXPR;
4469 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4470 logop->op_first = first;
4471 logop->op_flags = (U8)(flags | OPf_KIDS);
4472 logop->op_private = (U8)(1 | (flags >> 8));
4473 logop->op_other = LINKLIST(trueop);
4474 logop->op_next = LINKLIST(falseop);
4476 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
4479 /* establish postfix order */
4480 start = LINKLIST(first);
4481 first->op_next = (OP*)logop;
4483 first->op_sibling = trueop;
4484 trueop->op_sibling = falseop;
4485 o = newUNOP(OP_NULL, 0, (OP*)logop);
4487 trueop->op_next = falseop->op_next = o;
4494 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4503 NewOp(1101, range, 1, LOGOP);
4505 range->op_type = OP_RANGE;
4506 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4507 range->op_first = left;
4508 range->op_flags = OPf_KIDS;
4509 leftstart = LINKLIST(left);
4510 range->op_other = LINKLIST(right);
4511 range->op_private = (U8)(1 | (flags >> 8));
4513 left->op_sibling = right;
4515 range->op_next = (OP*)range;
4516 flip = newUNOP(OP_FLIP, flags, (OP*)range);
4517 flop = newUNOP(OP_FLOP, 0, flip);
4518 o = newUNOP(OP_NULL, 0, flop);
4520 range->op_next = leftstart;
4522 left->op_next = flip;
4523 right->op_next = flop;
4525 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4526 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4527 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4528 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4530 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4531 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4534 if (!flip->op_private || !flop->op_private)
4535 linklist(o); /* blow off optimizer unless constant */
4541 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4546 const bool once = block && block->op_flags & OPf_SPECIAL &&
4547 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4549 PERL_UNUSED_ARG(debuggable);
4552 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4553 return block; /* do {} while 0 does once */
4554 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4555 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4556 expr = newUNOP(OP_DEFINED, 0,
4557 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4558 } else if (expr->op_flags & OPf_KIDS) {
4559 const OP * const k1 = ((UNOP*)expr)->op_first;
4560 const OP * const k2 = k1 ? k1->op_sibling : NULL;
4561 switch (expr->op_type) {
4563 if (k2 && k2->op_type == OP_READLINE
4564 && (k2->op_flags & OPf_STACKED)
4565 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4566 expr = newUNOP(OP_DEFINED, 0, expr);
4570 if (k1 && (k1->op_type == OP_READDIR
4571 || k1->op_type == OP_GLOB
4572 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4573 || k1->op_type == OP_EACH))
4574 expr = newUNOP(OP_DEFINED, 0, expr);
4580 /* if block is null, the next append_elem() would put UNSTACK, a scalar
4581 * op, in listop. This is wrong. [perl #27024] */
4583 block = newOP(OP_NULL, 0);
4584 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4585 o = new_logop(OP_AND, 0, &expr, &listop);
4588 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4590 if (once && o != listop)
4591 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4594 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
4596 o->op_flags |= flags;
4598 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4603 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
4604 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
4613 PERL_UNUSED_ARG(debuggable);
4616 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4617 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4618 expr = newUNOP(OP_DEFINED, 0,
4619 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4620 } else if (expr->op_flags & OPf_KIDS) {
4621 const OP * const k1 = ((UNOP*)expr)->op_first;
4622 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
4623 switch (expr->op_type) {
4625 if (k2 && k2->op_type == OP_READLINE
4626 && (k2->op_flags & OPf_STACKED)
4627 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4628 expr = newUNOP(OP_DEFINED, 0, expr);
4632 if (k1 && (k1->op_type == OP_READDIR
4633 || k1->op_type == OP_GLOB
4634 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4635 || k1->op_type == OP_EACH))
4636 expr = newUNOP(OP_DEFINED, 0, expr);
4643 block = newOP(OP_NULL, 0);
4644 else if (cont || has_my) {
4645 block = scope(block);
4649 next = LINKLIST(cont);
4652 OP * const unstack = newOP(OP_UNSTACK, 0);
4655 cont = append_elem(OP_LINESEQ, cont, unstack);
4659 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4661 redo = LINKLIST(listop);
4664 PL_parser->copline = (line_t)whileline;
4666 o = new_logop(OP_AND, 0, &expr, &listop);
4667 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4668 op_free(expr); /* oops, it's a while (0) */
4670 return NULL; /* listop already freed by new_logop */
4673 ((LISTOP*)listop)->op_last->op_next =
4674 (o == listop ? redo : LINKLIST(o));
4680 NewOp(1101,loop,1,LOOP);
4681 loop->op_type = OP_ENTERLOOP;
4682 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4683 loop->op_private = 0;
4684 loop->op_next = (OP*)loop;
4687 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4689 loop->op_redoop = redo;
4690 loop->op_lastop = o;
4691 o->op_private |= loopflags;
4694 loop->op_nextop = next;
4696 loop->op_nextop = o;
4698 o->op_flags |= flags;
4699 o->op_private |= (flags >> 8);
4704 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
4709 PADOFFSET padoff = 0;
4715 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4716 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
4717 sv->op_type = OP_RV2GV;
4718 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4720 /* The op_type check is needed to prevent a possible segfault
4721 * if the loop variable is undeclared and 'strict vars' is in
4722 * effect. This is illegal but is nonetheless parsed, so we
4723 * may reach this point with an OP_CONST where we're expecting
4726 if (cUNOPx(sv)->op_first->op_type == OP_GV
4727 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
4728 iterpflags |= OPpITER_DEF;
4730 else if (sv->op_type == OP_PADSV) { /* private variable */
4731 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
4732 padoff = sv->op_targ;
4742 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4744 SV *const namesv = PAD_COMPNAME_SV(padoff);
4746 const char *const name = SvPV_const(namesv, len);
4748 if (len == 2 && name[0] == '$' && name[1] == '_')
4749 iterpflags |= OPpITER_DEF;
4753 const PADOFFSET offset = pad_findmy("$_");
4754 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
4755 sv = newGVOP(OP_GV, 0, PL_defgv);
4760 iterpflags |= OPpITER_DEF;
4762 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4763 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4764 iterflags |= OPf_STACKED;
4766 else if (expr->op_type == OP_NULL &&
4767 (expr->op_flags & OPf_KIDS) &&
4768 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4770 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4771 * set the STACKED flag to indicate that these values are to be
4772 * treated as min/max values by 'pp_iterinit'.
4774 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4775 LOGOP* const range = (LOGOP*) flip->op_first;
4776 OP* const left = range->op_first;
4777 OP* const right = left->op_sibling;
4780 range->op_flags &= ~OPf_KIDS;
4781 range->op_first = NULL;
4783 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4784 listop->op_first->op_next = range->op_next;
4785 left->op_next = range->op_other;
4786 right->op_next = (OP*)listop;
4787 listop->op_next = listop->op_first;
4790 op_getmad(expr,(OP*)listop,'O');
4794 expr = (OP*)(listop);
4796 iterflags |= OPf_STACKED;
4799 expr = mod(force_list(expr), OP_GREPSTART);
4802 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4803 append_elem(OP_LIST, expr, scalar(sv))));
4804 assert(!loop->op_next);
4805 /* for my $x () sets OPpLVAL_INTRO;
4806 * for our $x () sets OPpOUR_INTRO */
4807 loop->op_private = (U8)iterpflags;
4808 #ifdef PL_OP_SLAB_ALLOC
4811 NewOp(1234,tmp,1,LOOP);
4812 Copy(loop,tmp,1,LISTOP);
4813 S_op_destroy(aTHX_ (OP*)loop);
4817 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
4819 loop->op_targ = padoff;
4820 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
4822 op_getmad(madsv, (OP*)loop, 'v');
4823 PL_parser->copline = forline;
4824 return newSTATEOP(0, label, wop);
4828 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4833 if (type != OP_GOTO || label->op_type == OP_CONST) {
4834 /* "last()" means "last" */
4835 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4836 o = newOP(type, OPf_SPECIAL);
4838 o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
4839 ? SvPV_nolen_const(((SVOP*)label)->op_sv)
4843 op_getmad(label,o,'L');
4849 /* Check whether it's going to be a goto &function */
4850 if (label->op_type == OP_ENTERSUB
4851 && !(label->op_flags & OPf_STACKED))
4852 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4853 o = newUNOP(type, OPf_STACKED, label);
4855 PL_hints |= HINT_BLOCK_SCOPE;
4859 /* if the condition is a literal array or hash
4860 (or @{ ... } etc), make a reference to it.
4863 S_ref_array_or_hash(pTHX_ OP *cond)
4866 && (cond->op_type == OP_RV2AV
4867 || cond->op_type == OP_PADAV
4868 || cond->op_type == OP_RV2HV
4869 || cond->op_type == OP_PADHV))
4871 return newUNOP(OP_REFGEN,
4872 0, mod(cond, OP_REFGEN));
4878 /* These construct the optree fragments representing given()
4881 entergiven and enterwhen are LOGOPs; the op_other pointer
4882 points up to the associated leave op. We need this so we
4883 can put it in the context and make break/continue work.
4884 (Also, of course, pp_enterwhen will jump straight to
4885 op_other if the match fails.)
4889 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
4890 I32 enter_opcode, I32 leave_opcode,
4891 PADOFFSET entertarg)
4897 NewOp(1101, enterop, 1, LOGOP);
4898 enterop->op_type = enter_opcode;
4899 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
4900 enterop->op_flags = (U8) OPf_KIDS;
4901 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
4902 enterop->op_private = 0;
4904 o = newUNOP(leave_opcode, 0, (OP *) enterop);
4907 enterop->op_first = scalar(cond);
4908 cond->op_sibling = block;
4910 o->op_next = LINKLIST(cond);
4911 cond->op_next = (OP *) enterop;
4914 /* This is a default {} block */
4915 enterop->op_first = block;
4916 enterop->op_flags |= OPf_SPECIAL;
4918 o->op_next = (OP *) enterop;
4921 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
4922 entergiven and enterwhen both
4925 enterop->op_next = LINKLIST(block);
4926 block->op_next = enterop->op_other = o;
4931 /* Does this look like a boolean operation? For these purposes
4932 a boolean operation is:
4933 - a subroutine call [*]
4934 - a logical connective
4935 - a comparison operator
4936 - a filetest operator, with the exception of -s -M -A -C
4937 - defined(), exists() or eof()
4938 - /$re/ or $foo =~ /$re/
4940 [*] possibly surprising
4943 S_looks_like_bool(pTHX_ const OP *o)
4946 switch(o->op_type) {
4948 return looks_like_bool(cLOGOPo->op_first);
4952 looks_like_bool(cLOGOPo->op_first)
4953 && looks_like_bool(cLOGOPo->op_first->op_sibling));
4957 o->op_flags & OPf_KIDS
4958 && looks_like_bool(cUNOPo->op_first));
4962 case OP_NOT: case OP_XOR:
4963 /* Note that OP_DOR is not here */
4965 case OP_EQ: case OP_NE: case OP_LT:
4966 case OP_GT: case OP_LE: case OP_GE:
4968 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
4969 case OP_I_GT: case OP_I_LE: case OP_I_GE:
4971 case OP_SEQ: case OP_SNE: case OP_SLT:
4972 case OP_SGT: case OP_SLE: case OP_SGE:
4976 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
4977 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
4978 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
4979 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
4980 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
4981 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
4982 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
4983 case OP_FTTEXT: case OP_FTBINARY:
4985 case OP_DEFINED: case OP_EXISTS:
4986 case OP_MATCH: case OP_EOF:
4991 /* Detect comparisons that have been optimized away */
4992 if (cSVOPo->op_sv == &PL_sv_yes
4993 || cSVOPo->op_sv == &PL_sv_no)
5004 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
5008 return newGIVWHENOP(
5009 ref_array_or_hash(cond),
5011 OP_ENTERGIVEN, OP_LEAVEGIVEN,
5015 /* If cond is null, this is a default {} block */
5017 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
5019 const bool cond_llb = (!cond || looks_like_bool(cond));
5025 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
5027 scalar(ref_array_or_hash(cond)));
5030 return newGIVWHENOP(
5032 append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
5033 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
5037 =for apidoc cv_undef
5039 Clear out all the active components of a CV. This can happen either
5040 by an explicit C<undef &foo>, or by the reference count going to zero.
5041 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
5042 children can still follow the full lexical scope chain.
5048 Perl_cv_undef(pTHX_ CV *cv)
5052 DEBUG_X(PerlIO_printf(Perl_debug_log,
5053 "CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n",
5054 PTR2UV(cv), PTR2UV(PL_comppad))
5058 if (CvFILE(cv) && !CvISXSUB(cv)) {
5059 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
5060 Safefree(CvFILE(cv));
5065 if (!CvISXSUB(cv) && CvROOT(cv)) {
5066 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
5067 Perl_croak(aTHX_ "Can't undef active subroutine");
5070 PAD_SAVE_SETNULLPAD();
5072 op_free(CvROOT(cv));
5077 SvPOK_off((SV*)cv); /* forget prototype */
5082 /* remove CvOUTSIDE unless this is an undef rather than a free */
5083 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
5084 if (!CvWEAKOUTSIDE(cv))
5085 SvREFCNT_dec(CvOUTSIDE(cv));
5086 CvOUTSIDE(cv) = NULL;
5089 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
5092 if (CvISXSUB(cv) && CvXSUB(cv)) {
5095 /* delete all flags except WEAKOUTSIDE */
5096 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
5100 Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
5103 /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
5104 relying on SvCUR, and doubling up the buffer to hold CvFILE(). */
5105 if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
5106 || (p && (len != SvCUR(cv) /* Not the same length. */
5107 || memNE(p, SvPVX_const(cv), len))))
5108 && ckWARN_d(WARN_PROTOTYPE)) {
5109 SV* const msg = sv_newmortal();
5113 gv_efullname3(name = sv_newmortal(), gv, NULL);
5114 sv_setpvs(msg, "Prototype mismatch:");
5116 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
5118 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv));
5120 sv_catpvs(msg, ": none");
5121 sv_catpvs(msg, " vs ");
5123 Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
5125 sv_catpvs(msg, "none");
5126 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
5130 static void const_sv_xsub(pTHX_ CV* cv);
5134 =head1 Optree Manipulation Functions
5136 =for apidoc cv_const_sv
5138 If C<cv> is a constant sub eligible for inlining. returns the constant
5139 value returned by the sub. Otherwise, returns NULL.
5141 Constant subs can be created with C<newCONSTSUB> or as described in
5142 L<perlsub/"Constant Functions">.
5147 Perl_cv_const_sv(pTHX_ CV *cv)
5149 PERL_UNUSED_CONTEXT;
5152 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
5154 return CvCONST(cv) ? (SV*)CvXSUBANY(cv).any_ptr : NULL;
5157 /* op_const_sv: examine an optree to determine whether it's in-lineable.
5158 * Can be called in 3 ways:
5161 * look for a single OP_CONST with attached value: return the value
5163 * cv && CvCLONE(cv) && !CvCONST(cv)
5165 * examine the clone prototype, and if contains only a single
5166 * OP_CONST referencing a pad const, or a single PADSV referencing
5167 * an outer lexical, return a non-zero value to indicate the CV is
5168 * a candidate for "constizing" at clone time
5172 * We have just cloned an anon prototype that was marked as a const
5173 * candidiate. Try to grab the current value, and in the case of
5174 * PADSV, ignore it if it has multiple references. Return the value.
5178 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
5189 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
5190 o = cLISTOPo->op_first->op_sibling;
5192 for (; o; o = o->op_next) {
5193 const OPCODE type = o->op_type;
5195 if (sv && o->op_next == o)
5197 if (o->op_next != o) {
5198 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
5200 if (type == OP_DBSTATE)
5203 if (type == OP_LEAVESUB || type == OP_RETURN)
5207 if (type == OP_CONST && cSVOPo->op_sv)
5209 else if (cv && type == OP_CONST) {
5210 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5214 else if (cv && type == OP_PADSV) {
5215 if (CvCONST(cv)) { /* newly cloned anon */
5216 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5217 /* the candidate should have 1 ref from this pad and 1 ref
5218 * from the parent */
5219 if (!sv || SvREFCNT(sv) != 2)
5226 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
5227 sv = &PL_sv_undef; /* an arbitrary non-null value */
5242 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5245 /* This would be the return value, but the return cannot be reached. */
5246 OP* pegop = newOP(OP_NULL, 0);
5249 PERL_UNUSED_ARG(floor);
5259 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
5261 NORETURN_FUNCTION_END;
5266 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
5268 return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
5272 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5279 register CV *cv = NULL;
5281 /* If the subroutine has no body, no attributes, and no builtin attributes
5282 then it's just a sub declaration, and we may be able to get away with
5283 storing with a placeholder scalar in the symbol table, rather than a
5284 full GV and CV. If anything is present then it will take a full CV to
5286 const I32 gv_fetch_flags
5287 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5289 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
5290 const char * const name = o ? SvPV_nolen_const(cSVOPo->op_sv) : NULL;
5293 assert(proto->op_type == OP_CONST);
5294 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
5299 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
5300 SV * const sv = sv_newmortal();
5301 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
5302 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
5303 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
5304 aname = SvPVX_const(sv);
5309 gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
5310 : gv_fetchpv(aname ? aname
5311 : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5312 gv_fetch_flags, SVt_PVCV);
5314 if (!PL_madskills) {
5323 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
5324 maximum a prototype before. */
5325 if (SvTYPE(gv) > SVt_NULL) {
5326 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
5327 && ckWARN_d(WARN_PROTOTYPE))
5329 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
5331 cv_ckproto_len((CV*)gv, NULL, ps, ps_len);
5334 sv_setpvn((SV*)gv, ps, ps_len);
5336 sv_setiv((SV*)gv, -1);
5338 SvREFCNT_dec(PL_compcv);
5339 cv = PL_compcv = NULL;
5343 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
5345 #ifdef GV_UNIQUE_CHECK
5346 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
5347 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
5351 if (!block || !ps || *ps || attrs
5352 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5354 || block->op_type == OP_NULL
5359 const_sv = op_const_sv(block, NULL);
5362 const bool exists = CvROOT(cv) || CvXSUB(cv);
5364 #ifdef GV_UNIQUE_CHECK
5365 if (exists && GvUNIQUE(gv)) {
5366 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
5370 /* if the subroutine doesn't exist and wasn't pre-declared
5371 * with a prototype, assume it will be AUTOLOADed,
5372 * skipping the prototype check
5374 if (exists || SvPOK(cv))
5375 cv_ckproto_len(cv, gv, ps, ps_len);
5376 /* already defined (or promised)? */
5377 if (exists || GvASSUMECV(gv)) {
5380 || block->op_type == OP_NULL
5383 if (CvFLAGS(PL_compcv)) {
5384 /* might have had built-in attrs applied */
5385 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5387 /* just a "sub foo;" when &foo is already defined */
5388 SAVEFREESV(PL_compcv);
5393 && block->op_type != OP_NULL
5396 if (ckWARN(WARN_REDEFINE)
5398 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
5400 const line_t oldline = CopLINE(PL_curcop);
5401 if (PL_parser && PL_parser->copline != NOLINE)
5402 CopLINE_set(PL_curcop, PL_parser->copline);
5403 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5404 CvCONST(cv) ? "Constant subroutine %s redefined"
5405 : "Subroutine %s redefined", name);
5406 CopLINE_set(PL_curcop, oldline);
5409 if (!PL_minus_c) /* keep old one around for madskills */
5412 /* (PL_madskills unset in used file.) */
5420 SvREFCNT_inc_simple_void_NN(const_sv);
5422 assert(!CvROOT(cv) && !CvCONST(cv));
5423 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
5424 CvXSUBANY(cv).any_ptr = const_sv;
5425 CvXSUB(cv) = const_sv_xsub;
5431 cv = newCONSTSUB(NULL, name, const_sv);
5433 mro_method_changed_in( /* sub Foo::Bar () { 123 } */
5434 (CvGV(cv) && GvSTASH(CvGV(cv)))
5443 SvREFCNT_dec(PL_compcv);
5451 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
5452 * before we clobber PL_compcv.
5456 || block->op_type == OP_NULL
5460 /* Might have had built-in attributes applied -- propagate them. */
5461 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5462 if (CvGV(cv) && GvSTASH(CvGV(cv)))
5463 stash = GvSTASH(CvGV(cv));
5464 else if (CvSTASH(cv))
5465 stash = CvSTASH(cv);
5467 stash = PL_curstash;
5470 /* possibly about to re-define existing subr -- ignore old cv */
5471 rcv = (SV*)PL_compcv;
5472 if (name && GvSTASH(gv))
5473 stash = GvSTASH(gv);
5475 stash = PL_curstash;
5477 apply_attrs(stash, rcv, attrs, FALSE);
5479 if (cv) { /* must reuse cv if autoloaded */
5486 || block->op_type == OP_NULL) && !PL_madskills
5489 /* got here with just attrs -- work done, so bug out */
5490 SAVEFREESV(PL_compcv);
5493 /* transfer PL_compcv to cv */
5495 CvFLAGS(cv) = CvFLAGS(PL_compcv);
5496 if (!CvWEAKOUTSIDE(cv))
5497 SvREFCNT_dec(CvOUTSIDE(cv));
5498 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
5499 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
5500 CvOUTSIDE(PL_compcv) = 0;
5501 CvPADLIST(cv) = CvPADLIST(PL_compcv);
5502 CvPADLIST(PL_compcv) = 0;
5503 /* inner references to PL_compcv must be fixed up ... */
5504 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
5505 /* ... before we throw it away */
5506 SvREFCNT_dec(PL_compcv);
5508 if (PERLDB_INTER)/* Advice debugger on the new sub. */
5509 ++PL_sub_generation;
5516 if (strEQ(name, "import")) {
5517 PL_formfeed = (SV*)cv;
5518 Perl_warner(aTHX_ packWARN(WARN_VOID), "%lx\n", (long)cv);
5522 mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */
5526 CvFILE_set_from_cop(cv, PL_curcop);
5527 CvSTASH(cv) = PL_curstash;
5530 sv_setpvn((SV*)cv, ps, ps_len);
5532 if (PL_parser && PL_parser->error_count) {
5536 const char *s = strrchr(name, ':');
5538 if (strEQ(s, "BEGIN")) {
5539 const char not_safe[] =
5540 "BEGIN not safe after errors--compilation aborted";
5541 if (PL_in_eval & EVAL_KEEPERR)
5542 Perl_croak(aTHX_ not_safe);
5544 /* force display of errors found but not reported */
5545 sv_catpv(ERRSV, not_safe);
5546 Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
5556 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5557 mod(scalarseq(block), OP_LEAVESUBLV));
5558 block->op_attached = 1;
5561 /* This makes sub {}; work as expected. */
5562 if (block->op_type == OP_STUB) {
5563 OP* const newblock = newSTATEOP(0, NULL, 0);
5565 op_getmad(block,newblock,'B');
5572 block->op_attached = 1;
5573 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5575 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5576 OpREFCNT_set(CvROOT(cv), 1);
5577 CvSTART(cv) = LINKLIST(CvROOT(cv));
5578 CvROOT(cv)->op_next = 0;
5579 CALL_PEEP(CvSTART(cv));
5581 /* now that optimizer has done its work, adjust pad values */
5583 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
5586 assert(!CvCONST(cv));
5587 if (ps && !*ps && op_const_sv(block, cv))
5591 if (name || aname) {
5592 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5593 SV * const sv = newSV(0);
5594 SV * const tmpstr = sv_newmortal();
5595 GV * const db_postponed = gv_fetchpvs("DB::postponed",
5596 GV_ADDMULTI, SVt_PVHV);
5599 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5601 (long)PL_subline, (long)CopLINE(PL_curcop));
5602 gv_efullname3(tmpstr, gv, NULL);
5603 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
5604 SvCUR(tmpstr), sv, 0);
5605 hv = GvHVn(db_postponed);
5606 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
5607 CV * const pcv = GvCV(db_postponed);
5613 call_sv((SV*)pcv, G_DISCARD);
5618 if (name && ! (PL_parser && PL_parser->error_count))
5619 process_special_blocks(name, gv, cv);
5624 PL_parser->copline = NOLINE;
5630 S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
5633 const char *const colon = strrchr(fullname,':');
5634 const char *const name = colon ? colon + 1 : fullname;
5637 if (strEQ(name, "BEGIN")) {
5638 const I32 oldscope = PL_scopestack_ix;
5640 SAVECOPFILE(&PL_compiling);
5641 SAVECOPLINE(&PL_compiling);
5643 DEBUG_x( dump_sub(gv) );
5644 Perl_av_create_and_push(aTHX_ &PL_beginav, (SV*)cv);
5645 GvCV(gv) = 0; /* cv has been hijacked */
5646 call_list(oldscope, PL_beginav);
5648 PL_curcop = &PL_compiling;
5649 CopHINTS_set(&PL_compiling, PL_hints);
5656 if strEQ(name, "END") {
5657 DEBUG_x( dump_sub(gv) );
5658 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, (SV*)cv);
5661 } else if (*name == 'U') {
5662 if (strEQ(name, "UNITCHECK")) {
5663 /* It's never too late to run a unitcheck block */
5664 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, (SV*)cv);
5668 } else if (*name == 'C') {
5669 if (strEQ(name, "CHECK")) {
5670 if (PL_main_start && ckWARN(WARN_VOID))
5671 Perl_warner(aTHX_ packWARN(WARN_VOID),
5672 "Too late to run CHECK block");
5673 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, (SV*)cv);
5677 } else if (*name == 'I') {
5678 if (strEQ(name, "INIT")) {
5679 if (PL_main_start && ckWARN(WARN_VOID))
5680 Perl_warner(aTHX_ packWARN(WARN_VOID),
5681 "Too late to run INIT block");
5682 Perl_av_create_and_push(aTHX_ &PL_initav, (SV*)cv);
5688 DEBUG_x( dump_sub(gv) );
5689 GvCV(gv) = 0; /* cv has been hijacked */
5694 =for apidoc newCONSTSUB
5696 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5697 eligible for inlining at compile-time.
5703 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
5708 const char *const temp_p = CopFILE(PL_curcop);
5709 const STRLEN len = temp_p ? strlen(temp_p) : 0;
5711 SV *const temp_sv = CopFILESV(PL_curcop);
5713 const char *const temp_p = temp_sv ? SvPV_const(temp_sv, len) : NULL;
5715 char *const file = savepvn(temp_p, temp_p ? len : 0);
5719 if (IN_PERL_RUNTIME) {
5720 /* at runtime, it's not safe to manipulate PL_curcop: it may be
5721 * an op shared between threads. Use a non-shared COP for our
5723 SAVEVPTR(PL_curcop);
5724 PL_curcop = &PL_compiling;
5726 SAVECOPLINE(PL_curcop);
5727 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
5730 PL_hints &= ~HINT_BLOCK_SCOPE;
5733 SAVESPTR(PL_curstash);
5734 SAVECOPSTASH(PL_curcop);
5735 PL_curstash = stash;
5736 CopSTASH_set(PL_curcop,stash);
5739 /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
5740 and so doesn't get free()d. (It's expected to be from the C pre-
5741 processor __FILE__ directive). But we need a dynamically allocated one,
5742 and we need it to get freed. */
5743 cv = newXS_flags(name, const_sv_xsub, file, "", XS_DYNAMIC_FILENAME);
5744 CvXSUBANY(cv).any_ptr = sv;
5750 CopSTASH_free(PL_curcop);
5758 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
5759 const char *const filename, const char *const proto,
5762 CV *cv = newXS(name, subaddr, filename);
5764 if (flags & XS_DYNAMIC_FILENAME) {
5765 /* We need to "make arrangements" (ie cheat) to ensure that the
5766 filename lasts as long as the PVCV we just created, but also doesn't
5768 STRLEN filename_len = strlen(filename);
5769 STRLEN proto_and_file_len = filename_len;
5770 char *proto_and_file;
5774 proto_len = strlen(proto);
5775 proto_and_file_len += proto_len;
5777 Newx(proto_and_file, proto_and_file_len + 1, char);
5778 Copy(proto, proto_and_file, proto_len, char);
5779 Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
5782 proto_and_file = savepvn(filename, filename_len);
5785 /* This gets free()d. :-) */
5786 sv_usepvn_flags((SV*)cv, proto_and_file, proto_and_file_len,
5787 SV_HAS_TRAILING_NUL);
5789 /* This gives us the correct prototype, rather than one with the
5790 file name appended. */
5791 SvCUR_set(cv, proto_len);
5795 CvFILE(cv) = proto_and_file + proto_len;
5797 sv_setpv((SV *)cv, proto);
5803 =for apidoc U||newXS
5805 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
5806 static storage, as it is used directly as CvFILE(), without a copy being made.
5812 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
5815 GV * const gv = gv_fetchpv(name ? name :
5816 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5817 GV_ADDMULTI, SVt_PVCV);
5821 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
5823 if ((cv = (name ? GvCV(gv) : NULL))) {
5825 /* just a cached method */
5829 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5830 /* already defined (or promised) */
5831 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
5832 if (ckWARN(WARN_REDEFINE)) {
5833 GV * const gvcv = CvGV(cv);
5835 HV * const stash = GvSTASH(gvcv);
5837 const char *redefined_name = HvNAME_get(stash);
5838 if ( strEQ(redefined_name,"autouse") ) {
5839 const line_t oldline = CopLINE(PL_curcop);
5840 if (PL_parser && PL_parser->copline != NOLINE)
5841 CopLINE_set(PL_curcop, PL_parser->copline);
5842 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5843 CvCONST(cv) ? "Constant subroutine %s redefined"
5844 : "Subroutine %s redefined"
5846 CopLINE_set(PL_curcop, oldline);
5856 if (cv) /* must reuse cv if autoloaded */
5859 cv = (CV*)newSV_type(SVt_PVCV);
5863 mro_method_changed_in(GvSTASH(gv)); /* newXS */
5867 (void)gv_fetchfile(filename);
5868 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
5869 an external constant string */
5871 CvXSUB(cv) = subaddr;
5874 process_special_blocks(name, gv, cv);
5886 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5891 OP* pegop = newOP(OP_NULL, 0);
5895 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
5896 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
5898 #ifdef GV_UNIQUE_CHECK
5900 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5904 if ((cv = GvFORM(gv))) {
5905 if (ckWARN(WARN_REDEFINE)) {
5906 const line_t oldline = CopLINE(PL_curcop);
5907 if (PL_parser && PL_parser->copline != NOLINE)
5908 CopLINE_set(PL_curcop, PL_parser->copline);
5909 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5910 o ? "Format %"SVf" redefined"
5911 : "Format STDOUT redefined", SVfARG(cSVOPo->op_sv));
5912 CopLINE_set(PL_curcop, oldline);
5919 CvFILE_set_from_cop(cv, PL_curcop);
5922 pad_tidy(padtidy_FORMAT);
5923 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5924 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5925 OpREFCNT_set(CvROOT(cv), 1);
5926 CvSTART(cv) = LINKLIST(CvROOT(cv));
5927 CvROOT(cv)->op_next = 0;
5928 CALL_PEEP(CvSTART(cv));
5930 op_getmad(o,pegop,'n');
5931 op_getmad_weak(block, pegop, 'b');
5936 PL_parser->copline = NOLINE;
5944 Perl_newANONLIST(pTHX_ OP *o)
5946 return convert(OP_ANONLIST, OPf_SPECIAL, o);
5950 Perl_newANONHASH(pTHX_ OP *o)
5952 return convert(OP_ANONHASH, OPf_SPECIAL, o);
5956 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5958 return newANONATTRSUB(floor, proto, NULL, block);
5962 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5964 return newUNOP(OP_REFGEN, 0,
5965 newSVOP(OP_ANONCODE, 0,
5966 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5970 Perl_oopsAV(pTHX_ OP *o)
5973 switch (o->op_type) {
5975 o->op_type = OP_PADAV;
5976 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5977 return ref(o, OP_RV2AV);
5980 o->op_type = OP_RV2AV;
5981 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5986 if (ckWARN_d(WARN_INTERNAL))
5987 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
5994 Perl_oopsHV(pTHX_ OP *o)
5997 switch (o->op_type) {
6000 o->op_type = OP_PADHV;
6001 o->op_ppaddr = PL_ppaddr[OP_PADHV];
6002 return ref(o, OP_RV2HV);
6006 o->op_type = OP_RV2HV;
6007 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
6012 if (ckWARN_d(WARN_INTERNAL))
6013 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
6020 Perl_newAVREF(pTHX_ OP *o)
6023 if (o->op_type == OP_PADANY) {
6024 o->op_type = OP_PADAV;
6025 o->op_ppaddr = PL_ppaddr[OP_PADAV];
6028 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
6029 && ckWARN(WARN_DEPRECATED)) {
6030 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
6031 "Using an array as a reference is deprecated");
6033 return newUNOP(OP_RV2AV, 0, scalar(o));
6037 Perl_newGVREF(pTHX_ I32 type, OP *o)
6039 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
6040 return newUNOP(OP_NULL, 0, o);
6041 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
6045 Perl_newHVREF(pTHX_ OP *o)
6048 if (o->op_type == OP_PADANY) {
6049 o->op_type = OP_PADHV;
6050 o->op_ppaddr = PL_ppaddr[OP_PADHV];
6053 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
6054 && ckWARN(WARN_DEPRECATED)) {
6055 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
6056 "Using a hash as a reference is deprecated");
6058 return newUNOP(OP_RV2HV, 0, scalar(o));
6062 Perl_newCVREF(pTHX_ I32 flags, OP *o)
6064 return newUNOP(OP_RV2CV, flags, scalar(o));
6068 Perl_newSVREF(pTHX_ OP *o)
6071 if (o->op_type == OP_PADANY) {
6072 o->op_type = OP_PADSV;
6073 o->op_ppaddr = PL_ppaddr[OP_PADSV];
6076 return newUNOP(OP_RV2SV, 0, scalar(o));
6079 /* Check routines. See the comments at the top of this file for details
6080 * on when these are called */
6083 Perl_ck_anoncode(pTHX_ OP *o)
6085 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
6087 cSVOPo->op_sv = NULL;
6092 Perl_ck_bitop(pTHX_ OP *o)
6095 #define OP_IS_NUMCOMPARE(op) \
6096 ((op) == OP_LT || (op) == OP_I_LT || \
6097 (op) == OP_GT || (op) == OP_I_GT || \
6098 (op) == OP_LE || (op) == OP_I_LE || \
6099 (op) == OP_GE || (op) == OP_I_GE || \
6100 (op) == OP_EQ || (op) == OP_I_EQ || \
6101 (op) == OP_NE || (op) == OP_I_NE || \
6102 (op) == OP_NCMP || (op) == OP_I_NCMP)
6103 o->op_private = (U8)(PL_hints & HINT_INTEGER);
6104 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
6105 && (o->op_type == OP_BIT_OR
6106 || o->op_type == OP_BIT_AND
6107 || o->op_type == OP_BIT_XOR))
6109 const OP * const left = cBINOPo->op_first;
6110 const OP * const right = left->op_sibling;
6111 if ((OP_IS_NUMCOMPARE(left->op_type) &&
6112 (left->op_flags & OPf_PARENS) == 0) ||
6113 (OP_IS_NUMCOMPARE(right->op_type) &&
6114 (right->op_flags & OPf_PARENS) == 0))
6115 if (ckWARN(WARN_PRECEDENCE))
6116 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
6117 "Possible precedence problem on bitwise %c operator",
6118 o->op_type == OP_BIT_OR ? '|'
6119 : o->op_type == OP_BIT_AND ? '&' : '^'
6126 Perl_ck_concat(pTHX_ OP *o)
6128 const OP * const kid = cUNOPo->op_first;
6129 PERL_UNUSED_CONTEXT;
6130 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
6131 !(kUNOP->op_first->op_flags & OPf_MOD))
6132 o->op_flags |= OPf_STACKED;
6137 Perl_ck_spair(pTHX_ OP *o)
6140 if (o->op_flags & OPf_KIDS) {
6143 const OPCODE type = o->op_type;
6144 o = modkids(ck_fun(o), type);
6145 kid = cUNOPo->op_first;
6146 newop = kUNOP->op_first->op_sibling;
6148 const OPCODE type = newop->op_type;
6149 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
6150 type == OP_PADAV || type == OP_PADHV ||
6151 type == OP_RV2AV || type == OP_RV2HV)
6155 op_getmad(kUNOP->op_first,newop,'K');
6157 op_free(kUNOP->op_first);
6159 kUNOP->op_first = newop;
6161 o->op_ppaddr = PL_ppaddr[++o->op_type];
6166 Perl_ck_delete(pTHX_ OP *o)
6170 if (o->op_flags & OPf_KIDS) {
6171 OP * const kid = cUNOPo->op_first;
6172 switch (kid->op_type) {
6174 o->op_flags |= OPf_SPECIAL;
6177 o->op_private |= OPpSLICE;
6180 o->op_flags |= OPf_SPECIAL;
6185 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
6194 Perl_ck_die(pTHX_ OP *o)
6197 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6203 Perl_ck_eof(pTHX_ OP *o)
6207 if (o->op_flags & OPf_KIDS) {
6208 if (cLISTOPo->op_first->op_type == OP_STUB) {
6210 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
6212 op_getmad(o,newop,'O');
6224 Perl_ck_eval(pTHX_ OP *o)
6227 PL_hints |= HINT_BLOCK_SCOPE;
6228 if (o->op_flags & OPf_KIDS) {
6229 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6232 o->op_flags &= ~OPf_KIDS;
6235 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
6241 cUNOPo->op_first = 0;
6246 NewOp(1101, enter, 1, LOGOP);
6247 enter->op_type = OP_ENTERTRY;
6248 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
6249 enter->op_private = 0;
6251 /* establish postfix order */
6252 enter->op_next = (OP*)enter;
6254 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
6255 o->op_type = OP_LEAVETRY;
6256 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
6257 enter->op_other = o;
6258 op_getmad(oldo,o,'O');
6272 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
6273 op_getmad(oldo,o,'O');
6275 o->op_targ = (PADOFFSET)PL_hints;
6276 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
6277 /* Store a copy of %^H that pp_entereval can pick up.
6278 OPf_SPECIAL flags the opcode as being for this purpose,
6279 so that it in turn will return a copy at every
6281 OP *hhop = newSVOP(OP_CONST, OPf_SPECIAL,
6282 (SV*)Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv)));
6283 cUNOPo->op_first->op_sibling = hhop;
6284 o->op_private |= OPpEVAL_HAS_HH;
6290 Perl_ck_exit(pTHX_ OP *o)
6293 HV * const table = GvHV(PL_hintgv);
6295 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
6296 if (svp && *svp && SvTRUE(*svp))
6297 o->op_private |= OPpEXIT_VMSISH;
6299 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6305 Perl_ck_exec(pTHX_ OP *o)
6307 if (o->op_flags & OPf_STACKED) {
6310 kid = cUNOPo->op_first->op_sibling;
6311 if (kid->op_type == OP_RV2GV)
6320 Perl_ck_exists(pTHX_ OP *o)
6324 if (o->op_flags & OPf_KIDS) {
6325 OP * const kid = cUNOPo->op_first;
6326 if (kid->op_type == OP_ENTERSUB) {
6327 (void) ref(kid, o->op_type);
6328 if (kid->op_type != OP_RV2CV
6329 && !(PL_parser && PL_parser->error_count))
6330 Perl_croak(aTHX_ "%s argument is not a subroutine name",
6332 o->op_private |= OPpEXISTS_SUB;
6334 else if (kid->op_type == OP_AELEM)
6335 o->op_flags |= OPf_SPECIAL;
6336 else if (kid->op_type != OP_HELEM)
6337 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
6345 Perl_ck_rvconst(pTHX_ register OP *o)
6348 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6350 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6351 if (o->op_type == OP_RV2CV)
6352 o->op_private &= ~1;
6354 if (kid->op_type == OP_CONST) {
6357 SV * const kidsv = kid->op_sv;
6359 /* Is it a constant from cv_const_sv()? */
6360 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
6361 SV * const rsv = SvRV(kidsv);
6362 const svtype type = SvTYPE(rsv);
6363 const char *badtype = NULL;
6365 switch (o->op_type) {
6367 if (type > SVt_PVMG)
6368 badtype = "a SCALAR";
6371 if (type != SVt_PVAV)
6372 badtype = "an ARRAY";
6375 if (type != SVt_PVHV)
6379 if (type != SVt_PVCV)
6384 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
6387 else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
6388 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
6389 /* If this is an access to a stash, disable "strict refs", because
6390 * stashes aren't auto-vivified at compile-time (unless we store
6391 * symbols in them), and we don't want to produce a run-time
6392 * stricture error when auto-vivifying the stash. */
6393 const char *s = SvPV_nolen(kidsv);
6394 const STRLEN l = SvCUR(kidsv);
6395 if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
6396 o->op_private &= ~HINT_STRICT_REFS;
6398 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
6399 const char *badthing;
6400 switch (o->op_type) {
6402 badthing = "a SCALAR";
6405 badthing = "an ARRAY";
6408 badthing = "a HASH";
6416 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
6417 SVfARG(kidsv), badthing);
6420 * This is a little tricky. We only want to add the symbol if we
6421 * didn't add it in the lexer. Otherwise we get duplicate strict
6422 * warnings. But if we didn't add it in the lexer, we must at
6423 * least pretend like we wanted to add it even if it existed before,
6424 * or we get possible typo warnings. OPpCONST_ENTERED says
6425 * whether the lexer already added THIS instance of this symbol.
6427 iscv = (o->op_type == OP_RV2CV) * 2;
6429 gv = gv_fetchsv(kidsv,
6430 iscv | !(kid->op_private & OPpCONST_ENTERED),
6433 : o->op_type == OP_RV2SV
6435 : o->op_type == OP_RV2AV
6437 : o->op_type == OP_RV2HV
6440 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
6442 kid->op_type = OP_GV;
6443 SvREFCNT_dec(kid->op_sv);
6445 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
6446 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
6447 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
6449 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc_simple_NN(gv));
6451 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
6453 kid->op_private = 0;
6454 kid->op_ppaddr = PL_ppaddr[OP_GV];
6461 Perl_ck_ftst(pTHX_ OP *o)
6464 const I32 type = o->op_type;
6466 if (o->op_flags & OPf_REF) {
6469 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
6470 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6471 const OPCODE kidtype = kid->op_type;
6473 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6474 OP * const newop = newGVOP(type, OPf_REF,
6475 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
6477 op_getmad(o,newop,'O');
6483 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o))
6484 o->op_private |= OPpFT_ACCESS;
6485 if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst)
6486 && kidtype != OP_STAT && kidtype != OP_LSTAT)
6487 o->op_private |= OPpFT_STACKED;
6495 if (type == OP_FTTTY)
6496 o = newGVOP(type, OPf_REF, PL_stdingv);
6498 o = newUNOP(type, 0, newDEFSVOP());
6499 op_getmad(oldo,o,'O');
6505 Perl_ck_fun(pTHX_ OP *o)
6508 const int type = o->op_type;
6509 register I32 oa = PL_opargs[type] >> OASHIFT;
6511 if (o->op_flags & OPf_STACKED) {
6512 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
6515 return no_fh_allowed(o);
6518 if (o->op_flags & OPf_KIDS) {
6519 OP **tokid = &cLISTOPo->op_first;
6520 register OP *kid = cLISTOPo->op_first;
6524 if (kid->op_type == OP_PUSHMARK ||
6525 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
6527 tokid = &kid->op_sibling;
6528 kid = kid->op_sibling;
6530 if (!kid && PL_opargs[type] & OA_DEFGV)
6531 *tokid = kid = newDEFSVOP();
6535 sibl = kid->op_sibling;
6537 if (!sibl && kid->op_type == OP_STUB) {
6544 /* list seen where single (scalar) arg expected? */
6545 if (numargs == 1 && !(oa >> 4)
6546 && kid->op_type == OP_LIST && type != OP_SCALAR)
6548 return too_many_arguments(o,PL_op_desc[type]);
6561 if ((type == OP_PUSH || type == OP_UNSHIFT)
6562 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
6563 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6564 "Useless use of %s with no values",
6567 if (kid->op_type == OP_CONST &&
6568 (kid->op_private & OPpCONST_BARE))
6570 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
6571 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
6572 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6573 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6574 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
6575 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6577 op_getmad(kid,newop,'K');
6582 kid->op_sibling = sibl;
6585 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
6586 bad_type(numargs, "array", PL_op_desc[type], kid);
6590 if (kid->op_type == OP_CONST &&
6591 (kid->op_private & OPpCONST_BARE))
6593 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
6594 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
6595 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6596 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6597 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
6598 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6600 op_getmad(kid,newop,'K');
6605 kid->op_sibling = sibl;
6608 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
6609 bad_type(numargs, "hash", PL_op_desc[type], kid);
6614 OP * const newop = newUNOP(OP_NULL, 0, kid);
6615 kid->op_sibling = 0;
6617 newop->op_next = newop;
6619 kid->op_sibling = sibl;
6624 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
6625 if (kid->op_type == OP_CONST &&
6626 (kid->op_private & OPpCONST_BARE))
6628 OP * const newop = newGVOP(OP_GV, 0,
6629 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
6630 if (!(o->op_private & 1) && /* if not unop */
6631 kid == cLISTOPo->op_last)
6632 cLISTOPo->op_last = newop;
6634 op_getmad(kid,newop,'K');
6640 else if (kid->op_type == OP_READLINE) {
6641 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
6642 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
6645 I32 flags = OPf_SPECIAL;
6649 /* is this op a FH constructor? */
6650 if (is_handle_constructor(o,numargs)) {
6651 const char *name = NULL;
6655 /* Set a flag to tell rv2gv to vivify
6656 * need to "prove" flag does not mean something
6657 * else already - NI-S 1999/05/07
6660 if (kid->op_type == OP_PADSV) {
6662 = PAD_COMPNAME_SV(kid->op_targ);
6663 name = SvPV_const(namesv, len);
6665 else if (kid->op_type == OP_RV2SV
6666 && kUNOP->op_first->op_type == OP_GV)
6668 GV * const gv = cGVOPx_gv(kUNOP->op_first);
6670 len = GvNAMELEN(gv);
6672 else if (kid->op_type == OP_AELEM
6673 || kid->op_type == OP_HELEM)
6676 OP *op = ((BINOP*)kid)->op_first;
6680 const char * const a =
6681 kid->op_type == OP_AELEM ?
6683 if (((op->op_type == OP_RV2AV) ||
6684 (op->op_type == OP_RV2HV)) &&
6685 (firstop = ((UNOP*)op)->op_first) &&
6686 (firstop->op_type == OP_GV)) {
6687 /* packagevar $a[] or $h{} */
6688 GV * const gv = cGVOPx_gv(firstop);
6696 else if (op->op_type == OP_PADAV
6697 || op->op_type == OP_PADHV) {
6698 /* lexicalvar $a[] or $h{} */
6699 const char * const padname =
6700 PAD_COMPNAME_PV(op->op_targ);
6709 name = SvPV_const(tmpstr, len);
6714 name = "__ANONIO__";
6721 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
6722 namesv = PAD_SVl(targ);
6723 SvUPGRADE(namesv, SVt_PV);
6725 sv_setpvn(namesv, "$", 1);
6726 sv_catpvn(namesv, name, len);
6729 kid->op_sibling = 0;
6730 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
6731 kid->op_targ = targ;
6732 kid->op_private |= priv;
6734 kid->op_sibling = sibl;
6740 mod(scalar(kid), type);
6744 tokid = &kid->op_sibling;
6745 kid = kid->op_sibling;
6748 if (kid && kid->op_type != OP_STUB)
6749 return too_many_arguments(o,OP_DESC(o));
6750 o->op_private |= numargs;
6752 /* FIXME - should the numargs move as for the PERL_MAD case? */
6753 o->op_private |= numargs;
6755 return too_many_arguments(o,OP_DESC(o));
6759 else if (PL_opargs[type] & OA_DEFGV) {
6761 OP *newop = newUNOP(type, 0, newDEFSVOP());
6762 op_getmad(o,newop,'O');
6765 /* Ordering of these two is important to keep f_map.t passing. */
6767 return newUNOP(type, 0, newDEFSVOP());
6772 while (oa & OA_OPTIONAL)
6774 if (oa && oa != OA_LIST)
6775 return too_few_arguments(o,OP_DESC(o));
6781 Perl_ck_glob(pTHX_ OP *o)
6787 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
6788 append_elem(OP_GLOB, o, newDEFSVOP());
6790 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
6791 && GvCVu(gv) && GvIMPORTED_CV(gv)))
6793 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6796 #if !defined(PERL_EXTERNAL_GLOB)
6797 /* XXX this can be tightened up and made more failsafe. */
6798 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
6801 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
6802 newSVpvs("File::Glob"), NULL, NULL, NULL);
6803 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6804 glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
6805 GvCV(gv) = GvCV(glob_gv);
6806 SvREFCNT_inc_void((SV*)GvCV(gv));
6807 GvIMPORTED_CV_on(gv);
6810 #endif /* PERL_EXTERNAL_GLOB */
6812 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6813 append_elem(OP_GLOB, o,
6814 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
6815 o->op_type = OP_LIST;
6816 o->op_ppaddr = PL_ppaddr[OP_LIST];
6817 cLISTOPo->op_first->op_type = OP_PUSHMARK;
6818 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
6819 cLISTOPo->op_first->op_targ = 0;
6820 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
6821 append_elem(OP_LIST, o,
6822 scalar(newUNOP(OP_RV2CV, 0,
6823 newGVOP(OP_GV, 0, gv)))));
6824 o = newUNOP(OP_NULL, 0, ck_subr(o));
6825 o->op_targ = OP_GLOB; /* hint at what it used to be */
6828 gv = newGVgen("main");
6830 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
6836 Perl_ck_grep(pTHX_ OP *o)
6841 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
6844 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
6845 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
6847 if (o->op_flags & OPf_STACKED) {
6850 kid = cLISTOPo->op_first->op_sibling;
6851 if (!cUNOPx(kid)->op_next)
6852 Perl_croak(aTHX_ "panic: ck_grep");
6853 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
6856 NewOp(1101, gwop, 1, LOGOP);
6857 kid->op_next = (OP*)gwop;
6858 o->op_flags &= ~OPf_STACKED;
6860 kid = cLISTOPo->op_first->op_sibling;
6861 if (type == OP_MAPWHILE)
6866 if (PL_parser && PL_parser->error_count)
6868 kid = cLISTOPo->op_first->op_sibling;
6869 if (kid->op_type != OP_NULL)
6870 Perl_croak(aTHX_ "panic: ck_grep");
6871 kid = kUNOP->op_first;
6874 NewOp(1101, gwop, 1, LOGOP);
6875 gwop->op_type = type;
6876 gwop->op_ppaddr = PL_ppaddr[type];
6877 gwop->op_first = listkids(o);
6878 gwop->op_flags |= OPf_KIDS;
6879 gwop->op_other = LINKLIST(kid);
6880 kid->op_next = (OP*)gwop;
6881 offset = pad_findmy("$_");
6882 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
6883 o->op_private = gwop->op_private = 0;
6884 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
6887 o->op_private = gwop->op_private = OPpGREP_LEX;
6888 gwop->op_targ = o->op_targ = offset;
6891 kid = cLISTOPo->op_first->op_sibling;
6892 if (!kid || !kid->op_sibling)
6893 return too_few_arguments(o,OP_DESC(o));
6894 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
6895 mod(kid, OP_GREPSTART);
6901 Perl_ck_index(pTHX_ OP *o)
6903 if (o->op_flags & OPf_KIDS) {
6904 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6906 kid = kid->op_sibling; /* get past "big" */
6907 if (kid && kid->op_type == OP_CONST)
6908 fbm_compile(((SVOP*)kid)->op_sv, 0);
6914 Perl_ck_lengthconst(pTHX_ OP *o)
6916 /* XXX length optimization goes here */
6921 Perl_ck_lfun(pTHX_ OP *o)
6923 const OPCODE type = o->op_type;
6924 return modkids(ck_fun(o), type);
6928 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
6930 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
6931 switch (cUNOPo->op_first->op_type) {
6933 /* This is needed for
6934 if (defined %stash::)
6935 to work. Do not break Tk.
6937 break; /* Globals via GV can be undef */
6939 case OP_AASSIGN: /* Is this a good idea? */
6940 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6941 "defined(@array) is deprecated");
6942 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6943 "\t(Maybe you should just omit the defined()?)\n");
6946 /* This is needed for
6947 if (defined %stash::)
6948 to work. Do not break Tk.
6950 break; /* Globals via GV can be undef */
6952 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6953 "defined(%%hash) is deprecated");
6954 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6955 "\t(Maybe you should just omit the defined()?)\n");
6966 Perl_ck_readline(pTHX_ OP *o)
6968 if (!(o->op_flags & OPf_KIDS)) {
6970 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
6972 op_getmad(o,newop,'O');
6982 Perl_ck_rfun(pTHX_ OP *o)
6984 const OPCODE type = o->op_type;
6985 return refkids(ck_fun(o), type);
6989 Perl_ck_listiob(pTHX_ OP *o)
6993 kid = cLISTOPo->op_first;
6996 kid = cLISTOPo->op_first;
6998 if (kid->op_type == OP_PUSHMARK)
6999 kid = kid->op_sibling;
7000 if (kid && o->op_flags & OPf_STACKED)
7001 kid = kid->op_sibling;
7002 else if (kid && !kid->op_sibling) { /* print HANDLE; */
7003 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
7004 o->op_flags |= OPf_STACKED; /* make it a filehandle */
7005 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
7006 cLISTOPo->op_first->op_sibling = kid;
7007 cLISTOPo->op_last = kid;
7008 kid = kid->op_sibling;
7013 append_elem(o->op_type, o, newDEFSVOP());
7019 Perl_ck_smartmatch(pTHX_ OP *o)
7022 if (0 == (o->op_flags & OPf_SPECIAL)) {
7023 OP *first = cBINOPo->op_first;
7024 OP *second = first->op_sibling;
7026 /* Implicitly take a reference to an array or hash */
7027 first->op_sibling = NULL;
7028 first = cBINOPo->op_first = ref_array_or_hash(first);
7029 second = first->op_sibling = ref_array_or_hash(second);
7031 /* Implicitly take a reference to a regular expression */
7032 if (first->op_type == OP_MATCH) {
7033 first->op_type = OP_QR;
7034 first->op_ppaddr = PL_ppaddr[OP_QR];
7036 if (second->op_type == OP_MATCH) {
7037 second->op_type = OP_QR;
7038 second->op_ppaddr = PL_ppaddr[OP_QR];
7047 Perl_ck_sassign(pTHX_ OP *o)
7050 OP * const kid = cLISTOPo->op_first;
7051 /* has a disposable target? */
7052 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
7053 && !(kid->op_flags & OPf_STACKED)
7054 /* Cannot steal the second time! */
7055 && !(kid->op_private & OPpTARGET_MY)
7056 /* Keep the full thing for madskills */
7060 OP * const kkid = kid->op_sibling;
7062 /* Can just relocate the target. */
7063 if (kkid && kkid->op_type == OP_PADSV
7064 && !(kkid->op_private & OPpLVAL_INTRO))
7066 kid->op_targ = kkid->op_targ;
7068 /* Now we do not need PADSV and SASSIGN. */
7069 kid->op_sibling = o->op_sibling; /* NULL */
7070 cLISTOPo->op_first = NULL;
7073 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
7077 if (kid->op_sibling) {
7078 OP *kkid = kid->op_sibling;
7079 if (kkid->op_type == OP_PADSV
7080 && (kkid->op_private & OPpLVAL_INTRO)
7081 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
7082 const PADOFFSET target = kkid->op_targ;
7083 OP *const other = newOP(OP_PADSV,
7085 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
7086 OP *const first = newOP(OP_NULL, 0);
7087 OP *const nullop = newCONDOP(0, first, o, other);
7088 OP *const condop = first->op_next;
7089 /* hijacking PADSTALE for uninitialized state variables */
7090 SvPADSTALE_on(PAD_SVl(target));
7092 condop->op_type = OP_ONCE;
7093 condop->op_ppaddr = PL_ppaddr[OP_ONCE];
7094 condop->op_targ = target;
7095 other->op_targ = target;
7097 /* Because we change the type of the op here, we will skip the
7098 assinment binop->op_last = binop->op_first->op_sibling; at the
7099 end of Perl_newBINOP(). So need to do it here. */
7100 cBINOPo->op_last = cBINOPo->op_first->op_sibling;
7109 Perl_ck_match(pTHX_ OP *o)
7112 if (o->op_type != OP_QR && PL_compcv) {
7113 const PADOFFSET offset = pad_findmy("$_");
7114 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
7115 o->op_targ = offset;
7116 o->op_private |= OPpTARGET_MY;
7119 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
7120 o->op_private |= OPpRUNTIME;
7125 Perl_ck_method(pTHX_ OP *o)
7127 OP * const kid = cUNOPo->op_first;
7128 if (kid->op_type == OP_CONST) {
7129 SV* sv = kSVOP->op_sv;
7130 const char * const method = SvPVX_const(sv);
7131 if (!(strchr(method, ':') || strchr(method, '\''))) {
7133 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
7134 sv = newSVpvn_share(method, SvCUR(sv), 0);
7137 kSVOP->op_sv = NULL;
7139 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
7141 op_getmad(o,cmop,'O');
7152 Perl_ck_null(pTHX_ OP *o)
7154 PERL_UNUSED_CONTEXT;
7159 Perl_ck_open(pTHX_ OP *o)
7162 HV * const table = GvHV(PL_hintgv);
7164 SV **svp = hv_fetchs(table, "open_IN", FALSE);
7166 const I32 mode = mode_from_discipline(*svp);
7167 if (mode & O_BINARY)
7168 o->op_private |= OPpOPEN_IN_RAW;
7169 else if (mode & O_TEXT)
7170 o->op_private |= OPpOPEN_IN_CRLF;
7173 svp = hv_fetchs(table, "open_OUT", FALSE);
7175 const I32 mode = mode_from_discipline(*svp);
7176 if (mode & O_BINARY)
7177 o->op_private |= OPpOPEN_OUT_RAW;
7178 else if (mode & O_TEXT)
7179 o->op_private |= OPpOPEN_OUT_CRLF;
7182 if (o->op_type == OP_BACKTICK) {
7183 if (!(o->op_flags & OPf_KIDS)) {
7184 OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
7186 op_getmad(o,newop,'O');
7195 /* In case of three-arg dup open remove strictness
7196 * from the last arg if it is a bareword. */
7197 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
7198 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
7202 if ((last->op_type == OP_CONST) && /* The bareword. */
7203 (last->op_private & OPpCONST_BARE) &&
7204 (last->op_private & OPpCONST_STRICT) &&
7205 (oa = first->op_sibling) && /* The fh. */
7206 (oa = oa->op_sibling) && /* The mode. */
7207 (oa->op_type == OP_CONST) &&
7208 SvPOK(((SVOP*)oa)->op_sv) &&
7209 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
7210 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
7211 (last == oa->op_sibling)) /* The bareword. */
7212 last->op_private &= ~OPpCONST_STRICT;
7218 Perl_ck_repeat(pTHX_ OP *o)
7220 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
7221 o->op_private |= OPpREPEAT_DOLIST;
7222 cBINOPo->op_first = force_list(cBINOPo->op_first);
7230 Perl_ck_require(pTHX_ OP *o)
7235 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
7236 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7238 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
7239 SV * const sv = kid->op_sv;
7240 U32 was_readonly = SvREADONLY(sv);
7247 sv_force_normal_flags(sv, 0);
7248 assert(!SvREADONLY(sv));
7258 for (; s < end; s++) {
7259 if (*s == ':' && s[1] == ':') {
7261 Move(s+2, s+1, end - s - 1, char);
7266 sv_catpvs(sv, ".pm");
7267 SvFLAGS(sv) |= was_readonly;
7271 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
7272 /* handle override, if any */
7273 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
7274 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7275 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
7276 gv = gvp ? *gvp : NULL;
7280 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7281 OP * const kid = cUNOPo->op_first;
7284 cUNOPo->op_first = 0;
7288 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
7289 append_elem(OP_LIST, kid,
7290 scalar(newUNOP(OP_RV2CV, 0,
7293 op_getmad(o,newop,'O');
7301 Perl_ck_return(pTHX_ OP *o)
7304 if (CvLVALUE(PL_compcv)) {
7306 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
7307 mod(kid, OP_LEAVESUBLV);
7313 Perl_ck_select(pTHX_ OP *o)
7317 if (o->op_flags & OPf_KIDS) {
7318 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7319 if (kid && kid->op_sibling) {
7320 o->op_type = OP_SSELECT;
7321 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
7323 return fold_constants(o);
7327 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7328 if (kid && kid->op_type == OP_RV2GV)
7329 kid->op_private &= ~HINT_STRICT_REFS;
7334 Perl_ck_shift(pTHX_ OP *o)
7337 const I32 type = o->op_type;
7339 if (!(o->op_flags & OPf_KIDS)) {
7341 /* FIXME - this can be refactored to reduce code in #ifdefs */
7343 OP * const oldo = o;
7347 argop = newUNOP(OP_RV2AV, 0,
7348 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
7350 o = newUNOP(type, 0, scalar(argop));
7351 op_getmad(oldo,o,'O');
7354 return newUNOP(type, 0, scalar(argop));
7357 return scalar(modkids(ck_fun(o), type));
7361 Perl_ck_sort(pTHX_ OP *o)
7366 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
7367 HV * const hinthv = GvHV(PL_hintgv);
7369 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
7371 const I32 sorthints = (I32)SvIV(*svp);
7372 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
7373 o->op_private |= OPpSORT_QSORT;
7374 if ((sorthints & HINT_SORT_STABLE) != 0)
7375 o->op_private |= OPpSORT_STABLE;
7380 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
7382 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7383 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
7385 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
7387 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
7389 if (kid->op_type == OP_SCOPE) {
7393 else if (kid->op_type == OP_LEAVE) {
7394 if (o->op_type == OP_SORT) {
7395 op_null(kid); /* wipe out leave */
7398 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
7399 if (k->op_next == kid)
7401 /* don't descend into loops */
7402 else if (k->op_type == OP_ENTERLOOP
7403 || k->op_type == OP_ENTERITER)
7405 k = cLOOPx(k)->op_lastop;
7410 kid->op_next = 0; /* just disconnect the leave */
7411 k = kLISTOP->op_first;
7416 if (o->op_type == OP_SORT) {
7417 /* provide scalar context for comparison function/block */
7423 o->op_flags |= OPf_SPECIAL;
7425 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
7428 firstkid = firstkid->op_sibling;
7431 /* provide list context for arguments */
7432 if (o->op_type == OP_SORT)
7439 S_simplify_sort(pTHX_ OP *o)
7442 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7447 if (!(o->op_flags & OPf_STACKED))
7449 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7450 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
7451 kid = kUNOP->op_first; /* get past null */
7452 if (kid->op_type != OP_SCOPE)
7454 kid = kLISTOP->op_last; /* get past scope */
7455 switch(kid->op_type) {
7463 k = kid; /* remember this node*/
7464 if (kBINOP->op_first->op_type != OP_RV2SV)
7466 kid = kBINOP->op_first; /* get past cmp */
7467 if (kUNOP->op_first->op_type != OP_GV)
7469 kid = kUNOP->op_first; /* get past rv2sv */
7471 if (GvSTASH(gv) != PL_curstash)
7473 gvname = GvNAME(gv);
7474 if (*gvname == 'a' && gvname[1] == '\0')
7476 else if (*gvname == 'b' && gvname[1] == '\0')
7481 kid = k; /* back to cmp */
7482 if (kBINOP->op_last->op_type != OP_RV2SV)
7484 kid = kBINOP->op_last; /* down to 2nd arg */
7485 if (kUNOP->op_first->op_type != OP_GV)
7487 kid = kUNOP->op_first; /* get past rv2sv */
7489 if (GvSTASH(gv) != PL_curstash)
7491 gvname = GvNAME(gv);
7493 ? !(*gvname == 'a' && gvname[1] == '\0')
7494 : !(*gvname == 'b' && gvname[1] == '\0'))
7496 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
7498 o->op_private |= OPpSORT_DESCEND;
7499 if (k->op_type == OP_NCMP)
7500 o->op_private |= OPpSORT_NUMERIC;
7501 if (k->op_type == OP_I_NCMP)
7502 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
7503 kid = cLISTOPo->op_first->op_sibling;
7504 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
7506 op_getmad(kid,o,'S'); /* then delete it */
7508 op_free(kid); /* then delete it */
7513 Perl_ck_split(pTHX_ OP *o)
7518 if (o->op_flags & OPf_STACKED)
7519 return no_fh_allowed(o);
7521 kid = cLISTOPo->op_first;
7522 if (kid->op_type != OP_NULL)
7523 Perl_croak(aTHX_ "panic: ck_split");
7524 kid = kid->op_sibling;
7525 op_free(cLISTOPo->op_first);
7526 cLISTOPo->op_first = kid;
7528 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
7529 cLISTOPo->op_last = kid; /* There was only one element previously */
7532 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
7533 OP * const sibl = kid->op_sibling;
7534 kid->op_sibling = 0;
7535 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
7536 if (cLISTOPo->op_first == cLISTOPo->op_last)
7537 cLISTOPo->op_last = kid;
7538 cLISTOPo->op_first = kid;
7539 kid->op_sibling = sibl;
7542 kid->op_type = OP_PUSHRE;
7543 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
7545 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
7546 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
7547 "Use of /g modifier is meaningless in split");
7550 if (!kid->op_sibling)
7551 append_elem(OP_SPLIT, o, newDEFSVOP());
7553 kid = kid->op_sibling;
7556 if (!kid->op_sibling)
7557 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
7558 assert(kid->op_sibling);
7560 kid = kid->op_sibling;
7563 if (kid->op_sibling)
7564 return too_many_arguments(o,OP_DESC(o));
7570 Perl_ck_join(pTHX_ OP *o)
7572 const OP * const kid = cLISTOPo->op_first->op_sibling;
7573 if (kid && kid->op_type == OP_MATCH) {
7574 if (ckWARN(WARN_SYNTAX)) {
7575 const REGEXP *re = PM_GETRE(kPMOP);
7576 const char *pmstr = re ? RX_PRECOMP(re) : "STRING";
7577 const STRLEN len = re ? RX_PRELEN(re) : 6;
7578 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7579 "/%.*s/ should probably be written as \"%.*s\"",
7580 (int)len, pmstr, (int)len, pmstr);
7587 Perl_ck_subr(pTHX_ OP *o)
7590 OP *prev = ((cUNOPo->op_first->op_sibling)
7591 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
7592 OP *o2 = prev->op_sibling;
7594 const char *proto = NULL;
7595 const char *proto_end = NULL;
7600 I32 contextclass = 0;
7601 const char *e = NULL;
7604 o->op_private |= OPpENTERSUB_HASTARG;
7605 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
7606 if (cvop->op_type == OP_RV2CV) {
7608 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
7609 op_null(cvop); /* disable rv2cv */
7610 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
7611 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
7612 GV *gv = cGVOPx_gv(tmpop);
7615 tmpop->op_private |= OPpEARLY_CV;
7619 namegv = CvANON(cv) ? gv : CvGV(cv);
7620 proto = SvPV((SV*)cv, len);
7621 proto_end = proto + len;
7626 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7627 if (o2->op_type == OP_CONST)
7628 o2->op_private &= ~OPpCONST_STRICT;
7629 else if (o2->op_type == OP_LIST) {
7630 OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
7631 if (sib && sib->op_type == OP_CONST)
7632 sib->op_private &= ~OPpCONST_STRICT;
7635 o->op_private |= (PL_hints & HINT_STRICT_REFS);
7636 if (PERLDB_SUB && PL_curstash != PL_debstash)
7637 o->op_private |= OPpENTERSUB_DB;
7638 while (o2 != cvop) {
7640 if (PL_madskills && o2->op_type == OP_STUB) {
7641 o2 = o2->op_sibling;
7644 if (PL_madskills && o2->op_type == OP_NULL)
7645 o3 = ((UNOP*)o2)->op_first;
7649 if (proto >= proto_end)
7650 return too_many_arguments(o, gv_ename(namegv));
7658 /* _ must be at the end */
7659 if (proto[1] && proto[1] != ';')
7674 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
7676 arg == 1 ? "block or sub {}" : "sub {}",
7677 gv_ename(namegv), o3);
7680 /* '*' allows any scalar type, including bareword */
7683 if (o3->op_type == OP_RV2GV)
7684 goto wrapref; /* autoconvert GLOB -> GLOBref */
7685 else if (o3->op_type == OP_CONST)
7686 o3->op_private &= ~OPpCONST_STRICT;
7687 else if (o3->op_type == OP_ENTERSUB) {
7688 /* accidental subroutine, revert to bareword */
7689 OP *gvop = ((UNOP*)o3)->op_first;
7690 if (gvop && gvop->op_type == OP_NULL) {
7691 gvop = ((UNOP*)gvop)->op_first;
7693 for (; gvop->op_sibling; gvop = gvop->op_sibling)
7696 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
7697 (gvop = ((UNOP*)gvop)->op_first) &&
7698 gvop->op_type == OP_GV)
7700 GV * const gv = cGVOPx_gv(gvop);
7701 OP * const sibling = o2->op_sibling;
7702 SV * const n = newSVpvs("");
7704 OP * const oldo2 = o2;
7708 gv_fullname4(n, gv, "", FALSE);
7709 o2 = newSVOP(OP_CONST, 0, n);
7710 op_getmad(oldo2,o2,'O');
7711 prev->op_sibling = o2;
7712 o2->op_sibling = sibling;
7728 if (contextclass++ == 0) {
7729 e = strchr(proto, ']');
7730 if (!e || e == proto)
7739 const char *p = proto;
7740 const char *const end = proto;
7742 while (*--p != '[');
7743 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
7745 gv_ename(namegv), o3);
7750 if (o3->op_type == OP_RV2GV)
7753 bad_type(arg, "symbol", gv_ename(namegv), o3);
7756 if (o3->op_type == OP_ENTERSUB)
7759 bad_type(arg, "subroutine entry", gv_ename(namegv),
7763 if (o3->op_type == OP_RV2SV ||
7764 o3->op_type == OP_PADSV ||
7765 o3->op_type == OP_HELEM ||
7766 o3->op_type == OP_AELEM)
7769 bad_type(arg, "scalar", gv_ename(namegv), o3);
7772 if (o3->op_type == OP_RV2AV ||
7773 o3->op_type == OP_PADAV)
7776 bad_type(arg, "array", gv_ename(namegv), o3);
7779 if (o3->op_type == OP_RV2HV ||
7780 o3->op_type == OP_PADHV)
7783 bad_type(arg, "hash", gv_ename(namegv), o3);
7788 OP* const sib = kid->op_sibling;
7789 kid->op_sibling = 0;
7790 o2 = newUNOP(OP_REFGEN, 0, kid);
7791 o2->op_sibling = sib;
7792 prev->op_sibling = o2;
7794 if (contextclass && e) {
7809 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
7810 gv_ename(namegv), SVfARG(cv));
7815 mod(o2, OP_ENTERSUB);
7817 o2 = o2->op_sibling;
7819 if (o2 == cvop && proto && *proto == '_') {
7820 /* generate an access to $_ */
7822 o2->op_sibling = prev->op_sibling;
7823 prev->op_sibling = o2; /* instead of cvop */
7825 if (proto && !optional && proto_end > proto &&
7826 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
7827 return too_few_arguments(o, gv_ename(namegv));
7830 OP * const oldo = o;
7834 o=newSVOP(OP_CONST, 0, newSViv(0));
7835 op_getmad(oldo,o,'O');
7841 Perl_ck_svconst(pTHX_ OP *o)
7843 PERL_UNUSED_CONTEXT;
7844 SvREADONLY_on(cSVOPo->op_sv);
7849 Perl_ck_chdir(pTHX_ OP *o)
7851 if (o->op_flags & OPf_KIDS) {
7852 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7854 if (kid && kid->op_type == OP_CONST &&
7855 (kid->op_private & OPpCONST_BARE))
7857 o->op_flags |= OPf_SPECIAL;
7858 kid->op_private &= ~OPpCONST_STRICT;
7865 Perl_ck_trunc(pTHX_ OP *o)
7867 if (o->op_flags & OPf_KIDS) {
7868 SVOP *kid = (SVOP*)cUNOPo->op_first;
7870 if (kid->op_type == OP_NULL)
7871 kid = (SVOP*)kid->op_sibling;
7872 if (kid && kid->op_type == OP_CONST &&
7873 (kid->op_private & OPpCONST_BARE))
7875 o->op_flags |= OPf_SPECIAL;
7876 kid->op_private &= ~OPpCONST_STRICT;
7883 Perl_ck_unpack(pTHX_ OP *o)
7885 OP *kid = cLISTOPo->op_first;
7886 if (kid->op_sibling) {
7887 kid = kid->op_sibling;
7888 if (!kid->op_sibling)
7889 kid->op_sibling = newDEFSVOP();
7895 Perl_ck_substr(pTHX_ OP *o)
7898 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
7899 OP *kid = cLISTOPo->op_first;
7901 if (kid->op_type == OP_NULL)
7902 kid = kid->op_sibling;
7904 kid->op_flags |= OPf_MOD;
7911 Perl_ck_each(pTHX_ OP *o)
7914 OP *kid = cLISTOPo->op_first;
7916 if (kid->op_type == OP_PADAV || kid->op_type == OP_RV2AV) {
7917 const unsigned new_type = o->op_type == OP_EACH ? OP_AEACH
7918 : o->op_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
7919 o->op_type = new_type;
7920 o->op_ppaddr = PL_ppaddr[new_type];
7922 else if (!(kid->op_type == OP_PADHV || kid->op_type == OP_RV2HV
7923 || (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE)
7925 bad_type(1, "hash or array", PL_op_desc[o->op_type], kid);
7931 /* A peephole optimizer. We visit the ops in the order they're to execute.
7932 * See the comments at the top of this file for more details about when
7933 * peep() is called */
7936 Perl_peep(pTHX_ register OP *o)
7939 register OP* oldop = NULL;
7941 if (!o || o->op_opt)
7945 SAVEVPTR(PL_curcop);
7946 for (; o; o = o->op_next) {
7949 /* By default, this op has now been optimised. A couple of cases below
7950 clear this again. */
7953 switch (o->op_type) {
7957 PL_curcop = ((COP*)o); /* for warnings */
7961 if (cSVOPo->op_private & OPpCONST_STRICT)
7962 no_bareword_allowed(o);
7964 case OP_METHOD_NAMED:
7965 /* Relocate sv to the pad for thread safety.
7966 * Despite being a "constant", the SV is written to,
7967 * for reference counts, sv_upgrade() etc. */
7969 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
7970 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
7971 /* If op_sv is already a PADTMP then it is being used by
7972 * some pad, so make a copy. */
7973 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
7974 SvREADONLY_on(PAD_SVl(ix));
7975 SvREFCNT_dec(cSVOPo->op_sv);
7977 else if (o->op_type == OP_CONST
7978 && cSVOPo->op_sv == &PL_sv_undef) {
7979 /* PL_sv_undef is hack - it's unsafe to store it in the
7980 AV that is the pad, because av_fetch treats values of
7981 PL_sv_undef as a "free" AV entry and will merrily
7982 replace them with a new SV, causing pad_alloc to think
7983 that this pad slot is free. (When, clearly, it is not)
7985 SvOK_off(PAD_SVl(ix));
7986 SvPADTMP_on(PAD_SVl(ix));
7987 SvREADONLY_on(PAD_SVl(ix));
7990 SvREFCNT_dec(PAD_SVl(ix));
7991 SvPADTMP_on(cSVOPo->op_sv);
7992 PAD_SETSV(ix, cSVOPo->op_sv);
7993 /* XXX I don't know how this isn't readonly already. */
7994 SvREADONLY_on(PAD_SVl(ix));
7996 cSVOPo->op_sv = NULL;
8003 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
8004 if (o->op_next->op_private & OPpTARGET_MY) {
8005 if (o->op_flags & OPf_STACKED) /* chained concats */
8006 break; /* ignore_optimization */
8008 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
8009 o->op_targ = o->op_next->op_targ;
8010 o->op_next->op_targ = 0;
8011 o->op_private |= OPpTARGET_MY;
8014 op_null(o->op_next);
8018 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
8019 break; /* Scalar stub must produce undef. List stub is noop */
8023 if (o->op_targ == OP_NEXTSTATE
8024 || o->op_targ == OP_DBSTATE
8025 || o->op_targ == OP_SETSTATE)
8027 PL_curcop = ((COP*)o);
8029 /* XXX: We avoid setting op_seq here to prevent later calls
8030 to peep() from mistakenly concluding that optimisation
8031 has already occurred. This doesn't fix the real problem,
8032 though (See 20010220.007). AMS 20010719 */
8033 /* op_seq functionality is now replaced by op_opt */
8040 if (oldop && o->op_next) {
8041 oldop->op_next = o->op_next;
8049 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
8050 OP* const pop = (o->op_type == OP_PADAV) ?
8051 o->op_next : o->op_next->op_next;
8053 if (pop && pop->op_type == OP_CONST &&
8054 ((PL_op = pop->op_next)) &&
8055 pop->op_next->op_type == OP_AELEM &&
8056 !(pop->op_next->op_private &
8057 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
8058 (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
8063 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
8064 no_bareword_allowed(pop);
8065 if (o->op_type == OP_GV)
8066 op_null(o->op_next);
8067 op_null(pop->op_next);
8069 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
8070 o->op_next = pop->op_next->op_next;
8071 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
8072 o->op_private = (U8)i;
8073 if (o->op_type == OP_GV) {
8078 o->op_flags |= OPf_SPECIAL;
8079 o->op_type = OP_AELEMFAST;
8084 if (o->op_next->op_type == OP_RV2SV) {
8085 if (!(o->op_next->op_private & OPpDEREF)) {
8086 op_null(o->op_next);
8087 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
8089 o->op_next = o->op_next->op_next;
8090 o->op_type = OP_GVSV;
8091 o->op_ppaddr = PL_ppaddr[OP_GVSV];
8094 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
8095 GV * const gv = cGVOPo_gv;
8096 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
8097 /* XXX could check prototype here instead of just carping */
8098 SV * const sv = sv_newmortal();
8099 gv_efullname3(sv, gv, NULL);
8100 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
8101 "%"SVf"() called too early to check prototype",
8105 else if (o->op_next->op_type == OP_READLINE
8106 && o->op_next->op_next->op_type == OP_CONCAT
8107 && (o->op_next->op_next->op_flags & OPf_STACKED))
8109 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
8110 o->op_type = OP_RCATLINE;
8111 o->op_flags |= OPf_STACKED;
8112 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
8113 op_null(o->op_next->op_next);
8114 op_null(o->op_next);
8130 while (cLOGOP->op_other->op_type == OP_NULL)
8131 cLOGOP->op_other = cLOGOP->op_other->op_next;
8132 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
8137 while (cLOOP->op_redoop->op_type == OP_NULL)
8138 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
8139 peep(cLOOP->op_redoop);
8140 while (cLOOP->op_nextop->op_type == OP_NULL)
8141 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
8142 peep(cLOOP->op_nextop);
8143 while (cLOOP->op_lastop->op_type == OP_NULL)
8144 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
8145 peep(cLOOP->op_lastop);
8149 assert(!(cPMOP->op_pmflags & PMf_ONCE));
8150 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
8151 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
8152 cPMOP->op_pmstashstartu.op_pmreplstart
8153 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
8154 peep(cPMOP->op_pmstashstartu.op_pmreplstart);
8158 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
8159 && ckWARN(WARN_SYNTAX))
8161 if (o->op_next->op_sibling) {
8162 const OPCODE type = o->op_next->op_sibling->op_type;
8163 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
8164 const line_t oldline = CopLINE(PL_curcop);
8165 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
8166 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8167 "Statement unlikely to be reached");
8168 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8169 "\t(Maybe you meant system() when you said exec()?)\n");
8170 CopLINE_set(PL_curcop, oldline);
8181 const char *key = NULL;
8184 if (((BINOP*)o)->op_last->op_type != OP_CONST)
8187 /* Make the CONST have a shared SV */
8188 svp = cSVOPx_svp(((BINOP*)o)->op_last);
8189 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
8190 key = SvPV_const(sv, keylen);
8191 lexname = newSVpvn_share(key,
8192 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
8198 if ((o->op_private & (OPpLVAL_INTRO)))
8201 rop = (UNOP*)((BINOP*)o)->op_first;
8202 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
8204 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
8205 if (!SvPAD_TYPED(lexname))
8207 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8208 if (!fields || !GvHV(*fields))
8210 key = SvPV_const(*svp, keylen);
8211 if (!hv_fetch(GvHV(*fields), key,
8212 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8214 Perl_croak(aTHX_ "No such class field \"%s\" "
8215 "in variable %s of type %s",
8216 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
8229 SVOP *first_key_op, *key_op;
8231 if ((o->op_private & (OPpLVAL_INTRO))
8232 /* I bet there's always a pushmark... */
8233 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
8234 /* hmmm, no optimization if list contains only one key. */
8236 rop = (UNOP*)((LISTOP*)o)->op_last;
8237 if (rop->op_type != OP_RV2HV)
8239 if (rop->op_first->op_type == OP_PADSV)
8240 /* @$hash{qw(keys here)} */
8241 rop = (UNOP*)rop->op_first;
8243 /* @{$hash}{qw(keys here)} */
8244 if (rop->op_first->op_type == OP_SCOPE
8245 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
8247 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
8253 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
8254 if (!SvPAD_TYPED(lexname))
8256 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8257 if (!fields || !GvHV(*fields))
8259 /* Again guessing that the pushmark can be jumped over.... */
8260 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
8261 ->op_first->op_sibling;
8262 for (key_op = first_key_op; key_op;
8263 key_op = (SVOP*)key_op->op_sibling) {
8264 if (key_op->op_type != OP_CONST)
8266 svp = cSVOPx_svp(key_op);
8267 key = SvPV_const(*svp, keylen);
8268 if (!hv_fetch(GvHV(*fields), key,
8269 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8271 Perl_croak(aTHX_ "No such class field \"%s\" "
8272 "in variable %s of type %s",
8273 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
8280 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
8284 /* check that RHS of sort is a single plain array */
8285 OP *oright = cUNOPo->op_first;
8286 if (!oright || oright->op_type != OP_PUSHMARK)
8289 /* reverse sort ... can be optimised. */
8290 if (!cUNOPo->op_sibling) {
8291 /* Nothing follows us on the list. */
8292 OP * const reverse = o->op_next;
8294 if (reverse->op_type == OP_REVERSE &&
8295 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
8296 OP * const pushmark = cUNOPx(reverse)->op_first;
8297 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
8298 && (cUNOPx(pushmark)->op_sibling == o)) {
8299 /* reverse -> pushmark -> sort */
8300 o->op_private |= OPpSORT_REVERSE;
8302 pushmark->op_next = oright->op_next;
8308 /* make @a = sort @a act in-place */
8310 oright = cUNOPx(oright)->op_sibling;
8313 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
8314 oright = cUNOPx(oright)->op_sibling;
8318 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
8319 || oright->op_next != o
8320 || (oright->op_private & OPpLVAL_INTRO)
8324 /* o2 follows the chain of op_nexts through the LHS of the
8325 * assign (if any) to the aassign op itself */
8327 if (!o2 || o2->op_type != OP_NULL)
8330 if (!o2 || o2->op_type != OP_PUSHMARK)
8333 if (o2 && o2->op_type == OP_GV)
8336 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
8337 || (o2->op_private & OPpLVAL_INTRO)
8342 if (!o2 || o2->op_type != OP_NULL)
8345 if (!o2 || o2->op_type != OP_AASSIGN
8346 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
8349 /* check that the sort is the first arg on RHS of assign */
8351 o2 = cUNOPx(o2)->op_first;
8352 if (!o2 || o2->op_type != OP_NULL)
8354 o2 = cUNOPx(o2)->op_first;
8355 if (!o2 || o2->op_type != OP_PUSHMARK)
8357 if (o2->op_sibling != o)
8360 /* check the array is the same on both sides */
8361 if (oleft->op_type == OP_RV2AV) {
8362 if (oright->op_type != OP_RV2AV
8363 || !cUNOPx(oright)->op_first
8364 || cUNOPx(oright)->op_first->op_type != OP_GV
8365 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
8366 cGVOPx_gv(cUNOPx(oright)->op_first)
8370 else if (oright->op_type != OP_PADAV
8371 || oright->op_targ != oleft->op_targ
8375 /* transfer MODishness etc from LHS arg to RHS arg */
8376 oright->op_flags = oleft->op_flags;
8377 o->op_private |= OPpSORT_INPLACE;
8379 /* excise push->gv->rv2av->null->aassign */
8380 o2 = o->op_next->op_next;
8381 op_null(o2); /* PUSHMARK */
8383 if (o2->op_type == OP_GV) {
8384 op_null(o2); /* GV */
8387 op_null(o2); /* RV2AV or PADAV */
8388 o2 = o2->op_next->op_next;
8389 op_null(o2); /* AASSIGN */
8391 o->op_next = o2->op_next;
8397 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
8399 LISTOP *enter, *exlist;
8401 enter = (LISTOP *) o->op_next;
8404 if (enter->op_type == OP_NULL) {
8405 enter = (LISTOP *) enter->op_next;
8409 /* for $a (...) will have OP_GV then OP_RV2GV here.
8410 for (...) just has an OP_GV. */
8411 if (enter->op_type == OP_GV) {
8412 gvop = (OP *) enter;
8413 enter = (LISTOP *) enter->op_next;
8416 if (enter->op_type == OP_RV2GV) {
8417 enter = (LISTOP *) enter->op_next;
8423 if (enter->op_type != OP_ENTERITER)
8426 iter = enter->op_next;
8427 if (!iter || iter->op_type != OP_ITER)
8430 expushmark = enter->op_first;
8431 if (!expushmark || expushmark->op_type != OP_NULL
8432 || expushmark->op_targ != OP_PUSHMARK)
8435 exlist = (LISTOP *) expushmark->op_sibling;
8436 if (!exlist || exlist->op_type != OP_NULL
8437 || exlist->op_targ != OP_LIST)
8440 if (exlist->op_last != o) {
8441 /* Mmm. Was expecting to point back to this op. */
8444 theirmark = exlist->op_first;
8445 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
8448 if (theirmark->op_sibling != o) {
8449 /* There's something between the mark and the reverse, eg
8450 for (1, reverse (...))
8455 ourmark = ((LISTOP *)o)->op_first;
8456 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
8459 ourlast = ((LISTOP *)o)->op_last;
8460 if (!ourlast || ourlast->op_next != o)
8463 rv2av = ourmark->op_sibling;
8464 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
8465 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
8466 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
8467 /* We're just reversing a single array. */
8468 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
8469 enter->op_flags |= OPf_STACKED;
8472 /* We don't have control over who points to theirmark, so sacrifice
8474 theirmark->op_next = ourmark->op_next;
8475 theirmark->op_flags = ourmark->op_flags;
8476 ourlast->op_next = gvop ? gvop : (OP *) enter;
8479 enter->op_private |= OPpITER_REVERSED;
8480 iter->op_private |= OPpITER_REVERSED;
8487 UNOP *refgen, *rv2cv;
8490 if ((o->op_flags & OPf_WANT) != OPf_WANT_VOID)
8493 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
8496 rv2gv = ((BINOP *)o)->op_last;
8497 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
8500 refgen = (UNOP *)((BINOP *)o)->op_first;
8502 if (!refgen || refgen->op_type != OP_REFGEN)
8505 exlist = (LISTOP *)refgen->op_first;
8506 if (!exlist || exlist->op_type != OP_NULL
8507 || exlist->op_targ != OP_LIST)
8510 if (exlist->op_first->op_type != OP_PUSHMARK)
8513 rv2cv = (UNOP*)exlist->op_last;
8515 if (rv2cv->op_type != OP_RV2CV)
8518 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
8519 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
8520 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
8522 o->op_private |= OPpASSIGN_CV_TO_GV;
8523 rv2gv->op_private |= OPpDONT_INIT_GV;
8524 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
8532 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
8533 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
8543 Perl_custom_op_name(pTHX_ const OP* o)
8546 const IV index = PTR2IV(o->op_ppaddr);
8550 if (!PL_custom_op_names) /* This probably shouldn't happen */
8551 return (char *)PL_op_name[OP_CUSTOM];
8553 keysv = sv_2mortal(newSViv(index));
8555 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
8557 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
8559 return SvPV_nolen(HeVAL(he));
8563 Perl_custom_op_desc(pTHX_ const OP* o)
8566 const IV index = PTR2IV(o->op_ppaddr);
8570 if (!PL_custom_op_descs)
8571 return (char *)PL_op_desc[OP_CUSTOM];
8573 keysv = sv_2mortal(newSViv(index));
8575 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
8577 return (char *)PL_op_desc[OP_CUSTOM];
8579 return SvPV_nolen(HeVAL(he));
8584 /* Efficient sub that returns a constant scalar value. */
8586 const_sv_xsub(pTHX_ CV* cv)
8593 Perl_croak(aTHX_ "usage: %s::%s()",
8594 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
8598 ST(0) = (SV*)XSANY.any_ptr;
8604 * c-indentation-style: bsd
8606 * indent-tabs-mode: t
8609 * ex: set ts=8 sts=4 sw=4 noet: