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],
628 (SV*) SvREFCNT_inc_simple_NN(PL_regex_pad[(cPMOPo)->op_pmoffset]));
629 SvREADONLY_off(PL_regex_pad[(cPMOPo)->op_pmoffset]);
630 SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
631 PM_SETRE_OFFSET(cPMOPo, (cPMOPo)->op_pmoffset);
634 ReREFCNT_dec(PM_GETRE(cPMOPo));
635 PM_SETRE(cPMOPo, NULL);
641 if (o->op_targ > 0) {
642 pad_free(o->op_targ);
648 S_cop_free(pTHX_ COP* cop)
653 if (! specialWARN(cop->cop_warnings))
654 PerlMemShared_free(cop->cop_warnings);
655 Perl_refcounted_he_free(aTHX_ cop->cop_hints_hash);
659 S_forget_pmop(pTHX_ PMOP *const o
665 HV * const pmstash = PmopSTASH(o);
666 if (pmstash && !SvIS_FREED(pmstash)) {
667 MAGIC * const mg = mg_find((SV*)pmstash, PERL_MAGIC_symtab);
669 PMOP **const array = (PMOP**) mg->mg_ptr;
670 U32 count = mg->mg_len / sizeof(PMOP**);
675 /* Found it. Move the entry at the end to overwrite it. */
676 array[i] = array[--count];
677 mg->mg_len = count * sizeof(PMOP**);
678 /* Could realloc smaller at this point always, but probably
679 not worth it. Probably worth free()ing if we're the
682 Safefree(mg->mg_ptr);
699 S_find_and_forget_pmops(pTHX_ OP *o)
701 if (o->op_flags & OPf_KIDS) {
702 OP *kid = cUNOPo->op_first;
704 switch (kid->op_type) {
709 forget_pmop((PMOP*)kid, 0);
711 find_and_forget_pmops(kid);
712 kid = kid->op_sibling;
718 Perl_op_null(pTHX_ OP *o)
721 if (o->op_type == OP_NULL)
725 o->op_targ = o->op_type;
726 o->op_type = OP_NULL;
727 o->op_ppaddr = PL_ppaddr[OP_NULL];
731 Perl_op_refcnt_lock(pTHX)
739 Perl_op_refcnt_unlock(pTHX)
746 /* Contextualizers */
748 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
751 Perl_linklist(pTHX_ OP *o)
758 /* establish postfix order */
759 first = cUNOPo->op_first;
762 o->op_next = LINKLIST(first);
765 if (kid->op_sibling) {
766 kid->op_next = LINKLIST(kid->op_sibling);
767 kid = kid->op_sibling;
781 Perl_scalarkids(pTHX_ OP *o)
783 if (o && o->op_flags & OPf_KIDS) {
785 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
792 S_scalarboolean(pTHX_ OP *o)
795 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
796 if (ckWARN(WARN_SYNTAX)) {
797 const line_t oldline = CopLINE(PL_curcop);
799 if (PL_parser && PL_parser->copline != NOLINE)
800 CopLINE_set(PL_curcop, PL_parser->copline);
801 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
802 CopLINE_set(PL_curcop, oldline);
809 Perl_scalar(pTHX_ OP *o)
814 /* assumes no premature commitment */
815 if (!o || (PL_parser && PL_parser->error_count)
816 || (o->op_flags & OPf_WANT)
817 || o->op_type == OP_RETURN)
822 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
824 switch (o->op_type) {
826 scalar(cBINOPo->op_first);
831 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
835 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
836 if (!kPMOP->op_pmreplrootu.op_pmreplroot)
837 deprecate_old("implicit split to @_");
845 if (o->op_flags & OPf_KIDS) {
846 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
852 kid = cLISTOPo->op_first;
854 while ((kid = kid->op_sibling)) {
860 PL_curcop = &PL_compiling;
865 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
871 PL_curcop = &PL_compiling;
874 if (ckWARN(WARN_VOID))
875 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
881 Perl_scalarvoid(pTHX_ OP *o)
885 const char* useless = NULL;
889 /* trailing mad null ops don't count as "there" for void processing */
891 o->op_type != OP_NULL &&
893 o->op_sibling->op_type == OP_NULL)
896 for (sib = o->op_sibling;
897 sib && sib->op_type == OP_NULL;
898 sib = sib->op_sibling) ;
904 if (o->op_type == OP_NEXTSTATE
905 || o->op_type == OP_SETSTATE
906 || o->op_type == OP_DBSTATE
907 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
908 || o->op_targ == OP_SETSTATE
909 || o->op_targ == OP_DBSTATE)))
910 PL_curcop = (COP*)o; /* for warning below */
912 /* assumes no premature commitment */
913 want = o->op_flags & OPf_WANT;
914 if ((want && want != OPf_WANT_SCALAR)
915 || (PL_parser && PL_parser->error_count)
916 || o->op_type == OP_RETURN)
921 if ((o->op_private & OPpTARGET_MY)
922 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
924 return scalar(o); /* As if inside SASSIGN */
927 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
929 switch (o->op_type) {
931 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
935 if (o->op_flags & OPf_STACKED)
939 if (o->op_private == 4)
1012 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1013 /* Otherwise it's "Useless use of grep iterator" */
1014 useless = OP_DESC(o);
1018 kid = cUNOPo->op_first;
1019 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1020 kid->op_type != OP_TRANS) {
1023 useless = "negative pattern binding (!~)";
1030 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1031 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1032 useless = "a variable";
1037 if (cSVOPo->op_private & OPpCONST_STRICT)
1038 no_bareword_allowed(o);
1040 if (ckWARN(WARN_VOID)) {
1041 useless = "a constant";
1042 if (o->op_private & OPpCONST_ARYBASE)
1044 /* don't warn on optimised away booleans, eg
1045 * use constant Foo, 5; Foo || print; */
1046 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1048 /* the constants 0 and 1 are permitted as they are
1049 conventionally used as dummies in constructs like
1050 1 while some_condition_with_side_effects; */
1051 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1053 else if (SvPOK(sv)) {
1054 /* perl4's way of mixing documentation and code
1055 (before the invention of POD) was based on a
1056 trick to mix nroff and perl code. The trick was
1057 built upon these three nroff macros being used in
1058 void context. The pink camel has the details in
1059 the script wrapman near page 319. */
1060 const char * const maybe_macro = SvPVX_const(sv);
1061 if (strnEQ(maybe_macro, "di", 2) ||
1062 strnEQ(maybe_macro, "ds", 2) ||
1063 strnEQ(maybe_macro, "ig", 2))
1068 op_null(o); /* don't execute or even remember it */
1072 o->op_type = OP_PREINC; /* pre-increment is faster */
1073 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1077 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1078 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1082 o->op_type = OP_I_PREINC; /* pre-increment is faster */
1083 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1087 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
1088 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1097 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1102 if (o->op_flags & OPf_STACKED)
1109 if (!(o->op_flags & OPf_KIDS))
1120 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1127 /* all requires must return a boolean value */
1128 o->op_flags &= ~OPf_WANT;
1133 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
1134 if (!kPMOP->op_pmreplrootu.op_pmreplroot)
1135 deprecate_old("implicit split to @_");
1139 if (useless && ckWARN(WARN_VOID))
1140 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
1145 Perl_listkids(pTHX_ OP *o)
1147 if (o && o->op_flags & OPf_KIDS) {
1149 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1156 Perl_list(pTHX_ OP *o)
1161 /* assumes no premature commitment */
1162 if (!o || (o->op_flags & OPf_WANT)
1163 || (PL_parser && PL_parser->error_count)
1164 || o->op_type == OP_RETURN)
1169 if ((o->op_private & OPpTARGET_MY)
1170 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1172 return o; /* As if inside SASSIGN */
1175 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1177 switch (o->op_type) {
1180 list(cBINOPo->op_first);
1185 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1193 if (!(o->op_flags & OPf_KIDS))
1195 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1196 list(cBINOPo->op_first);
1197 return gen_constant_list(o);
1204 kid = cLISTOPo->op_first;
1206 while ((kid = kid->op_sibling)) {
1207 if (kid->op_sibling)
1212 PL_curcop = &PL_compiling;
1216 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1217 if (kid->op_sibling)
1222 PL_curcop = &PL_compiling;
1225 /* all requires must return a boolean value */
1226 o->op_flags &= ~OPf_WANT;
1233 Perl_scalarseq(pTHX_ OP *o)
1237 const OPCODE type = o->op_type;
1239 if (type == OP_LINESEQ || type == OP_SCOPE ||
1240 type == OP_LEAVE || type == OP_LEAVETRY)
1243 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1244 if (kid->op_sibling) {
1248 PL_curcop = &PL_compiling;
1250 o->op_flags &= ~OPf_PARENS;
1251 if (PL_hints & HINT_BLOCK_SCOPE)
1252 o->op_flags |= OPf_PARENS;
1255 o = newOP(OP_STUB, 0);
1260 S_modkids(pTHX_ OP *o, I32 type)
1262 if (o && o->op_flags & OPf_KIDS) {
1264 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1270 /* Propagate lvalue ("modifiable") context to an op and its children.
1271 * 'type' represents the context type, roughly based on the type of op that
1272 * would do the modifying, although local() is represented by OP_NULL.
1273 * It's responsible for detecting things that can't be modified, flag
1274 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
1275 * might have to vivify a reference in $x), and so on.
1277 * For example, "$a+1 = 2" would cause mod() to be called with o being
1278 * OP_ADD and type being OP_SASSIGN, and would output an error.
1282 Perl_mod(pTHX_ OP *o, I32 type)
1286 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1289 if (!o || (PL_parser && PL_parser->error_count))
1292 if ((o->op_private & OPpTARGET_MY)
1293 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1298 switch (o->op_type) {
1304 if (!(o->op_private & OPpCONST_ARYBASE))
1307 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1308 CopARYBASE_set(&PL_compiling,
1309 (I32)SvIV(cSVOPx(PL_eval_start)->op_sv));
1313 SAVECOPARYBASE(&PL_compiling);
1314 CopARYBASE_set(&PL_compiling, 0);
1316 else if (type == OP_REFGEN)
1319 Perl_croak(aTHX_ "That use of $[ is unsupported");
1322 if ((o->op_flags & OPf_PARENS) || PL_madskills)
1326 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1327 !(o->op_flags & OPf_STACKED)) {
1328 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1329 /* The default is to set op_private to the number of children,
1330 which for a UNOP such as RV2CV is always 1. And w're using
1331 the bit for a flag in RV2CV, so we need it clear. */
1332 o->op_private &= ~1;
1333 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1334 assert(cUNOPo->op_first->op_type == OP_NULL);
1335 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1338 else if (o->op_private & OPpENTERSUB_NOMOD)
1340 else { /* lvalue subroutine call */
1341 o->op_private |= OPpLVAL_INTRO;
1342 PL_modcount = RETURN_UNLIMITED_NUMBER;
1343 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1344 /* Backward compatibility mode: */
1345 o->op_private |= OPpENTERSUB_INARGS;
1348 else { /* Compile-time error message: */
1349 OP *kid = cUNOPo->op_first;
1353 if (kid->op_type != OP_PUSHMARK) {
1354 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1356 "panic: unexpected lvalue entersub "
1357 "args: type/targ %ld:%"UVuf,
1358 (long)kid->op_type, (UV)kid->op_targ);
1359 kid = kLISTOP->op_first;
1361 while (kid->op_sibling)
1362 kid = kid->op_sibling;
1363 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1365 if (kid->op_type == OP_METHOD_NAMED
1366 || kid->op_type == OP_METHOD)
1370 NewOp(1101, newop, 1, UNOP);
1371 newop->op_type = OP_RV2CV;
1372 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1373 newop->op_first = NULL;
1374 newop->op_next = (OP*)newop;
1375 kid->op_sibling = (OP*)newop;
1376 newop->op_private |= OPpLVAL_INTRO;
1377 newop->op_private &= ~1;
1381 if (kid->op_type != OP_RV2CV)
1383 "panic: unexpected lvalue entersub "
1384 "entry via type/targ %ld:%"UVuf,
1385 (long)kid->op_type, (UV)kid->op_targ);
1386 kid->op_private |= OPpLVAL_INTRO;
1387 break; /* Postpone until runtime */
1391 kid = kUNOP->op_first;
1392 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1393 kid = kUNOP->op_first;
1394 if (kid->op_type == OP_NULL)
1396 "Unexpected constant lvalue entersub "
1397 "entry via type/targ %ld:%"UVuf,
1398 (long)kid->op_type, (UV)kid->op_targ);
1399 if (kid->op_type != OP_GV) {
1400 /* Restore RV2CV to check lvalueness */
1402 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1403 okid->op_next = kid->op_next;
1404 kid->op_next = okid;
1407 okid->op_next = NULL;
1408 okid->op_type = OP_RV2CV;
1410 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1411 okid->op_private |= OPpLVAL_INTRO;
1412 okid->op_private &= ~1;
1416 cv = GvCV(kGVOP_gv);
1426 /* grep, foreach, subcalls, refgen */
1427 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1429 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1430 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1432 : (o->op_type == OP_ENTERSUB
1433 ? "non-lvalue subroutine call"
1435 type ? PL_op_desc[type] : "local"));
1449 case OP_RIGHT_SHIFT:
1458 if (!(o->op_flags & OPf_STACKED))
1465 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1471 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1472 PL_modcount = RETURN_UNLIMITED_NUMBER;
1473 return o; /* Treat \(@foo) like ordinary list. */
1477 if (scalar_mod_type(o, type))
1479 ref(cUNOPo->op_first, o->op_type);
1483 if (type == OP_LEAVESUBLV)
1484 o->op_private |= OPpMAYBE_LVSUB;
1490 PL_modcount = RETURN_UNLIMITED_NUMBER;
1493 ref(cUNOPo->op_first, o->op_type);
1498 PL_hints |= HINT_BLOCK_SCOPE;
1513 PL_modcount = RETURN_UNLIMITED_NUMBER;
1514 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1515 return o; /* Treat \(@foo) like ordinary list. */
1516 if (scalar_mod_type(o, type))
1518 if (type == OP_LEAVESUBLV)
1519 o->op_private |= OPpMAYBE_LVSUB;
1523 if (!type) /* local() */
1524 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1525 PAD_COMPNAME_PV(o->op_targ));
1533 if (type != OP_SASSIGN)
1537 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1542 if (type == OP_LEAVESUBLV)
1543 o->op_private |= OPpMAYBE_LVSUB;
1545 pad_free(o->op_targ);
1546 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1547 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1548 if (o->op_flags & OPf_KIDS)
1549 mod(cBINOPo->op_first->op_sibling, type);
1554 ref(cBINOPo->op_first, o->op_type);
1555 if (type == OP_ENTERSUB &&
1556 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1557 o->op_private |= OPpLVAL_DEFER;
1558 if (type == OP_LEAVESUBLV)
1559 o->op_private |= OPpMAYBE_LVSUB;
1569 if (o->op_flags & OPf_KIDS)
1570 mod(cLISTOPo->op_last, type);
1575 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1577 else if (!(o->op_flags & OPf_KIDS))
1579 if (o->op_targ != OP_LIST) {
1580 mod(cBINOPo->op_first, type);
1586 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1591 if (type != OP_LEAVESUBLV)
1593 break; /* mod()ing was handled by ck_return() */
1596 /* [20011101.069] File test operators interpret OPf_REF to mean that
1597 their argument is a filehandle; thus \stat(".") should not set
1599 if (type == OP_REFGEN &&
1600 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1603 if (type != OP_LEAVESUBLV)
1604 o->op_flags |= OPf_MOD;
1606 if (type == OP_AASSIGN || type == OP_SASSIGN)
1607 o->op_flags |= OPf_SPECIAL|OPf_REF;
1608 else if (!type) { /* local() */
1611 o->op_private |= OPpLVAL_INTRO;
1612 o->op_flags &= ~OPf_SPECIAL;
1613 PL_hints |= HINT_BLOCK_SCOPE;
1618 if (ckWARN(WARN_SYNTAX)) {
1619 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1620 "Useless localization of %s", OP_DESC(o));
1624 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1625 && type != OP_LEAVESUBLV)
1626 o->op_flags |= OPf_REF;
1631 S_scalar_mod_type(const OP *o, I32 type)
1635 if (o->op_type == OP_RV2GV)
1659 case OP_RIGHT_SHIFT:
1679 S_is_handle_constructor(const OP *o, I32 numargs)
1681 switch (o->op_type) {
1689 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1702 Perl_refkids(pTHX_ OP *o, I32 type)
1704 if (o && o->op_flags & OPf_KIDS) {
1706 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1713 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
1718 if (!o || (PL_parser && PL_parser->error_count))
1721 switch (o->op_type) {
1723 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1724 !(o->op_flags & OPf_STACKED)) {
1725 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1726 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1727 assert(cUNOPo->op_first->op_type == OP_NULL);
1728 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1729 o->op_flags |= OPf_SPECIAL;
1730 o->op_private &= ~1;
1735 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1736 doref(kid, type, set_op_ref);
1739 if (type == OP_DEFINED)
1740 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1741 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1744 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1745 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1746 : type == OP_RV2HV ? OPpDEREF_HV
1748 o->op_flags |= OPf_MOD;
1755 o->op_flags |= OPf_REF;
1758 if (type == OP_DEFINED)
1759 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1760 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1766 o->op_flags |= OPf_REF;
1771 if (!(o->op_flags & OPf_KIDS))
1773 doref(cBINOPo->op_first, type, set_op_ref);
1777 doref(cBINOPo->op_first, o->op_type, set_op_ref);
1778 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1779 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1780 : type == OP_RV2HV ? OPpDEREF_HV
1782 o->op_flags |= OPf_MOD;
1792 if (!(o->op_flags & OPf_KIDS))
1794 doref(cLISTOPo->op_last, type, set_op_ref);
1804 S_dup_attrlist(pTHX_ OP *o)
1809 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1810 * where the first kid is OP_PUSHMARK and the remaining ones
1811 * are OP_CONST. We need to push the OP_CONST values.
1813 if (o->op_type == OP_CONST)
1814 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
1816 else if (o->op_type == OP_NULL)
1820 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1822 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1823 if (o->op_type == OP_CONST)
1824 rop = append_elem(OP_LIST, rop,
1825 newSVOP(OP_CONST, o->op_flags,
1826 SvREFCNT_inc_NN(cSVOPo->op_sv)));
1833 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1838 /* fake up C<use attributes $pkg,$rv,@attrs> */
1839 ENTER; /* need to protect against side-effects of 'use' */
1840 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1842 #define ATTRSMODULE "attributes"
1843 #define ATTRSMODULE_PM "attributes.pm"
1846 /* Don't force the C<use> if we don't need it. */
1847 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
1848 if (svp && *svp != &PL_sv_undef)
1849 NOOP; /* already in %INC */
1851 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1852 newSVpvs(ATTRSMODULE), NULL);
1855 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1856 newSVpvs(ATTRSMODULE),
1858 prepend_elem(OP_LIST,
1859 newSVOP(OP_CONST, 0, stashsv),
1860 prepend_elem(OP_LIST,
1861 newSVOP(OP_CONST, 0,
1863 dup_attrlist(attrs))));
1869 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1872 OP *pack, *imop, *arg;
1878 assert(target->op_type == OP_PADSV ||
1879 target->op_type == OP_PADHV ||
1880 target->op_type == OP_PADAV);
1882 /* Ensure that attributes.pm is loaded. */
1883 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1885 /* Need package name for method call. */
1886 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
1888 /* Build up the real arg-list. */
1889 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1891 arg = newOP(OP_PADSV, 0);
1892 arg->op_targ = target->op_targ;
1893 arg = prepend_elem(OP_LIST,
1894 newSVOP(OP_CONST, 0, stashsv),
1895 prepend_elem(OP_LIST,
1896 newUNOP(OP_REFGEN, 0,
1897 mod(arg, OP_REFGEN)),
1898 dup_attrlist(attrs)));
1900 /* Fake up a method call to import */
1901 meth = newSVpvs_share("import");
1902 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1903 append_elem(OP_LIST,
1904 prepend_elem(OP_LIST, pack, list(arg)),
1905 newSVOP(OP_METHOD_NAMED, 0, meth)));
1906 imop->op_private |= OPpENTERSUB_NOMOD;
1908 /* Combine the ops. */
1909 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1913 =notfor apidoc apply_attrs_string
1915 Attempts to apply a list of attributes specified by the C<attrstr> and
1916 C<len> arguments to the subroutine identified by the C<cv> argument which
1917 is expected to be associated with the package identified by the C<stashpv>
1918 argument (see L<attributes>). It gets this wrong, though, in that it
1919 does not correctly identify the boundaries of the individual attribute
1920 specifications within C<attrstr>. This is not really intended for the
1921 public API, but has to be listed here for systems such as AIX which
1922 need an explicit export list for symbols. (It's called from XS code
1923 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1924 to respect attribute syntax properly would be welcome.
1930 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
1931 const char *attrstr, STRLEN len)
1936 len = strlen(attrstr);
1940 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1942 const char * const sstr = attrstr;
1943 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1944 attrs = append_elem(OP_LIST, attrs,
1945 newSVOP(OP_CONST, 0,
1946 newSVpvn(sstr, attrstr-sstr)));
1950 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1951 newSVpvs(ATTRSMODULE),
1952 NULL, prepend_elem(OP_LIST,
1953 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1954 prepend_elem(OP_LIST,
1955 newSVOP(OP_CONST, 0,
1961 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
1966 if (!o || (PL_parser && PL_parser->error_count))
1970 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
1971 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
1975 if (type == OP_LIST) {
1977 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1978 my_kid(kid, attrs, imopsp);
1979 } else if (type == OP_UNDEF
1985 } else if (type == OP_RV2SV || /* "our" declaration */
1987 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1988 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1989 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1991 PL_parser->in_my == KEY_our
1993 : PL_parser->in_my == KEY_state ? "state" : "my"));
1995 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
1996 PL_parser->in_my = FALSE;
1997 PL_parser->in_my_stash = NULL;
1998 apply_attrs(GvSTASH(gv),
1999 (type == OP_RV2SV ? GvSV(gv) :
2000 type == OP_RV2AV ? (SV*)GvAV(gv) :
2001 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
2004 o->op_private |= OPpOUR_INTRO;
2007 else if (type != OP_PADSV &&
2010 type != OP_PUSHMARK)
2012 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2014 PL_parser->in_my == KEY_our
2016 : PL_parser->in_my == KEY_state ? "state" : "my"));
2019 else if (attrs && type != OP_PUSHMARK) {
2022 PL_parser->in_my = FALSE;
2023 PL_parser->in_my_stash = NULL;
2025 /* check for C<my Dog $spot> when deciding package */
2026 stash = PAD_COMPNAME_TYPE(o->op_targ);
2028 stash = PL_curstash;
2029 apply_attrs_my(stash, o, attrs, imopsp);
2031 o->op_flags |= OPf_MOD;
2032 o->op_private |= OPpLVAL_INTRO;
2033 if (PL_parser->in_my == KEY_state)
2034 o->op_private |= OPpPAD_STATE;
2039 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2043 int maybe_scalar = 0;
2045 /* [perl #17376]: this appears to be premature, and results in code such as
2046 C< our(%x); > executing in list mode rather than void mode */
2048 if (o->op_flags & OPf_PARENS)
2058 o = my_kid(o, attrs, &rops);
2060 if (maybe_scalar && o->op_type == OP_PADSV) {
2061 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
2062 o->op_private |= OPpLVAL_INTRO;
2065 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
2067 PL_parser->in_my = FALSE;
2068 PL_parser->in_my_stash = NULL;
2073 Perl_my(pTHX_ OP *o)
2075 return my_attrs(o, NULL);
2079 Perl_sawparens(pTHX_ OP *o)
2081 PERL_UNUSED_CONTEXT;
2083 o->op_flags |= OPf_PARENS;
2088 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2092 const OPCODE ltype = left->op_type;
2093 const OPCODE rtype = right->op_type;
2095 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2096 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
2098 const char * const desc
2099 = PL_op_desc[(rtype == OP_SUBST || rtype == OP_TRANS)
2100 ? (int)rtype : OP_MATCH];
2101 const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV)
2102 ? "@array" : "%hash");
2103 Perl_warner(aTHX_ packWARN(WARN_MISC),
2104 "Applying %s to %s will act on scalar(%s)",
2105 desc, sample, sample);
2108 if (rtype == OP_CONST &&
2109 cSVOPx(right)->op_private & OPpCONST_BARE &&
2110 cSVOPx(right)->op_private & OPpCONST_STRICT)
2112 no_bareword_allowed(right);
2115 ismatchop = rtype == OP_MATCH ||
2116 rtype == OP_SUBST ||
2118 if (ismatchop && right->op_private & OPpTARGET_MY) {
2120 right->op_private &= ~OPpTARGET_MY;
2122 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
2125 right->op_flags |= OPf_STACKED;
2126 if (rtype != OP_MATCH &&
2127 ! (rtype == OP_TRANS &&
2128 right->op_private & OPpTRANS_IDENTICAL))
2129 newleft = mod(left, rtype);
2132 if (right->op_type == OP_TRANS)
2133 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
2135 o = prepend_elem(rtype, scalar(newleft), right);
2137 return newUNOP(OP_NOT, 0, scalar(o));
2141 return bind_match(type, left,
2142 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
2146 Perl_invert(pTHX_ OP *o)
2150 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2154 Perl_scope(pTHX_ OP *o)
2158 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2159 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2160 o->op_type = OP_LEAVE;
2161 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2163 else if (o->op_type == OP_LINESEQ) {
2165 o->op_type = OP_SCOPE;
2166 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2167 kid = ((LISTOP*)o)->op_first;
2168 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2171 /* The following deals with things like 'do {1 for 1}' */
2172 kid = kid->op_sibling;
2174 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2179 o = newLISTOP(OP_SCOPE, 0, o, NULL);
2185 Perl_block_start(pTHX_ int full)
2188 const int retval = PL_savestack_ix;
2189 pad_block_start(full);
2191 PL_hints &= ~HINT_BLOCK_SCOPE;
2192 SAVECOMPILEWARNINGS();
2193 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
2198 Perl_block_end(pTHX_ I32 floor, OP *seq)
2201 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2202 OP* const retval = scalarseq(seq);
2204 CopHINTS_set(&PL_compiling, PL_hints);
2206 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2215 const PADOFFSET offset = pad_findmy("$_");
2216 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
2217 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2220 OP * const o = newOP(OP_PADSV, 0);
2221 o->op_targ = offset;
2227 Perl_newPROG(pTHX_ OP *o)
2233 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2234 ((PL_in_eval & EVAL_KEEPERR)
2235 ? OPf_SPECIAL : 0), o);
2236 PL_eval_start = linklist(PL_eval_root);
2237 PL_eval_root->op_private |= OPpREFCOUNTED;
2238 OpREFCNT_set(PL_eval_root, 1);
2239 PL_eval_root->op_next = 0;
2240 CALL_PEEP(PL_eval_start);
2243 if (o->op_type == OP_STUB) {
2244 PL_comppad_name = 0;
2246 S_op_destroy(aTHX_ o);
2249 PL_main_root = scope(sawparens(scalarvoid(o)));
2250 PL_curcop = &PL_compiling;
2251 PL_main_start = LINKLIST(PL_main_root);
2252 PL_main_root->op_private |= OPpREFCOUNTED;
2253 OpREFCNT_set(PL_main_root, 1);
2254 PL_main_root->op_next = 0;
2255 CALL_PEEP(PL_main_start);
2258 /* Register with debugger */
2261 = Perl_get_cvn_flags(aTHX_ STR_WITH_LEN("DB::postponed"), 0);
2265 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2267 call_sv((SV*)cv, G_DISCARD);
2274 Perl_localize(pTHX_ OP *o, I32 lex)
2277 if (o->op_flags & OPf_PARENS)
2278 /* [perl #17376]: this appears to be premature, and results in code such as
2279 C< our(%x); > executing in list mode rather than void mode */
2286 if ( PL_parser->bufptr > PL_parser->oldbufptr
2287 && PL_parser->bufptr[-1] == ','
2288 && ckWARN(WARN_PARENTHESIS))
2290 char *s = PL_parser->bufptr;
2293 /* some heuristics to detect a potential error */
2294 while (*s && (strchr(", \t\n", *s)))
2298 if (*s && strchr("@$%*", *s) && *++s
2299 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2302 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2304 while (*s && (strchr(", \t\n", *s)))
2310 if (sigil && (*s == ';' || *s == '=')) {
2311 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2312 "Parentheses missing around \"%s\" list",
2314 ? (PL_parser->in_my == KEY_our
2316 : PL_parser->in_my == KEY_state
2326 o = mod(o, OP_NULL); /* a bit kludgey */
2327 PL_parser->in_my = FALSE;
2328 PL_parser->in_my_stash = NULL;
2333 Perl_jmaybe(pTHX_ OP *o)
2335 if (o->op_type == OP_LIST) {
2337 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2338 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2344 Perl_fold_constants(pTHX_ register OP *o)
2349 VOL I32 type = o->op_type;
2354 SV * const oldwarnhook = PL_warnhook;
2355 SV * const olddiehook = PL_diehook;
2358 if (PL_opargs[type] & OA_RETSCALAR)
2360 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2361 o->op_targ = pad_alloc(type, SVs_PADTMP);
2363 /* integerize op, unless it happens to be C<-foo>.
2364 * XXX should pp_i_negate() do magic string negation instead? */
2365 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2366 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2367 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2369 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2372 if (!(PL_opargs[type] & OA_FOLDCONST))
2377 /* XXX might want a ck_negate() for this */
2378 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2389 /* XXX what about the numeric ops? */
2390 if (PL_hints & HINT_LOCALE)
2394 if (PL_parser && PL_parser->error_count)
2395 goto nope; /* Don't try to run w/ errors */
2397 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2398 const OPCODE type = curop->op_type;
2399 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2401 type != OP_SCALAR &&
2403 type != OP_PUSHMARK)
2409 curop = LINKLIST(o);
2410 old_next = o->op_next;
2414 oldscope = PL_scopestack_ix;
2415 create_eval_scope(G_FAKINGEVAL);
2417 PL_warnhook = PERL_WARNHOOK_FATAL;
2424 sv = *(PL_stack_sp--);
2425 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2426 pad_swipe(o->op_targ, FALSE);
2427 else if (SvTEMP(sv)) { /* grab mortal temp? */
2428 SvREFCNT_inc_simple_void(sv);
2433 /* Something tried to die. Abandon constant folding. */
2434 /* Pretend the error never happened. */
2435 sv_setpvn(ERRSV,"",0);
2436 o->op_next = old_next;
2440 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
2441 PL_warnhook = oldwarnhook;
2442 PL_diehook = olddiehook;
2443 /* XXX note that this croak may fail as we've already blown away
2444 * the stack - eg any nested evals */
2445 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
2448 PL_warnhook = oldwarnhook;
2449 PL_diehook = olddiehook;
2451 if (PL_scopestack_ix > oldscope)
2452 delete_eval_scope();
2461 if (type == OP_RV2GV)
2462 newop = newGVOP(OP_GV, 0, (GV*)sv);
2464 newop = newSVOP(OP_CONST, 0, (SV*)sv);
2465 op_getmad(o,newop,'f');
2473 Perl_gen_constant_list(pTHX_ register OP *o)
2477 const I32 oldtmps_floor = PL_tmps_floor;
2480 if (PL_parser && PL_parser->error_count)
2481 return o; /* Don't attempt to run with errors */
2483 PL_op = curop = LINKLIST(o);
2489 assert (!(curop->op_flags & OPf_SPECIAL));
2490 assert(curop->op_type == OP_RANGE);
2492 PL_tmps_floor = oldtmps_floor;
2494 o->op_type = OP_RV2AV;
2495 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2496 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2497 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2498 o->op_opt = 0; /* needs to be revisited in peep() */
2499 curop = ((UNOP*)o)->op_first;
2500 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
2502 op_getmad(curop,o,'O');
2511 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2514 if (!o || o->op_type != OP_LIST)
2515 o = newLISTOP(OP_LIST, 0, o, NULL);
2517 o->op_flags &= ~OPf_WANT;
2519 if (!(PL_opargs[type] & OA_MARK))
2520 op_null(cLISTOPo->op_first);
2522 o->op_type = (OPCODE)type;
2523 o->op_ppaddr = PL_ppaddr[type];
2524 o->op_flags |= flags;
2526 o = CHECKOP(type, o);
2527 if (o->op_type != (unsigned)type)
2530 return fold_constants(o);
2533 /* List constructors */
2536 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2544 if (first->op_type != (unsigned)type
2545 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2547 return newLISTOP(type, 0, first, last);
2550 if (first->op_flags & OPf_KIDS)
2551 ((LISTOP*)first)->op_last->op_sibling = last;
2553 first->op_flags |= OPf_KIDS;
2554 ((LISTOP*)first)->op_first = last;
2556 ((LISTOP*)first)->op_last = last;
2561 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2569 if (first->op_type != (unsigned)type)
2570 return prepend_elem(type, (OP*)first, (OP*)last);
2572 if (last->op_type != (unsigned)type)
2573 return append_elem(type, (OP*)first, (OP*)last);
2575 first->op_last->op_sibling = last->op_first;
2576 first->op_last = last->op_last;
2577 first->op_flags |= (last->op_flags & OPf_KIDS);
2580 if (last->op_first && first->op_madprop) {
2581 MADPROP *mp = last->op_first->op_madprop;
2583 while (mp->mad_next)
2585 mp->mad_next = first->op_madprop;
2588 last->op_first->op_madprop = first->op_madprop;
2591 first->op_madprop = last->op_madprop;
2592 last->op_madprop = 0;
2595 S_op_destroy(aTHX_ (OP*)last);
2601 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2609 if (last->op_type == (unsigned)type) {
2610 if (type == OP_LIST) { /* already a PUSHMARK there */
2611 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2612 ((LISTOP*)last)->op_first->op_sibling = first;
2613 if (!(first->op_flags & OPf_PARENS))
2614 last->op_flags &= ~OPf_PARENS;
2617 if (!(last->op_flags & OPf_KIDS)) {
2618 ((LISTOP*)last)->op_last = first;
2619 last->op_flags |= OPf_KIDS;
2621 first->op_sibling = ((LISTOP*)last)->op_first;
2622 ((LISTOP*)last)->op_first = first;
2624 last->op_flags |= OPf_KIDS;
2628 return newLISTOP(type, 0, first, last);
2636 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2639 Newxz(tk, 1, TOKEN);
2640 tk->tk_type = (OPCODE)optype;
2641 tk->tk_type = 12345;
2643 tk->tk_mad = madprop;
2648 Perl_token_free(pTHX_ TOKEN* tk)
2650 if (tk->tk_type != 12345)
2652 mad_free(tk->tk_mad);
2657 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2661 if (tk->tk_type != 12345) {
2662 Perl_warner(aTHX_ packWARN(WARN_MISC),
2663 "Invalid TOKEN object ignored");
2670 /* faked up qw list? */
2672 tm->mad_type == MAD_SV &&
2673 SvPVX((SV*)tm->mad_val)[0] == 'q')
2680 /* pretend constant fold didn't happen? */
2681 if (mp->mad_key == 'f' &&
2682 (o->op_type == OP_CONST ||
2683 o->op_type == OP_GV) )
2685 token_getmad(tk,(OP*)mp->mad_val,slot);
2699 if (mp->mad_key == 'X')
2700 mp->mad_key = slot; /* just change the first one */
2710 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
2719 /* pretend constant fold didn't happen? */
2720 if (mp->mad_key == 'f' &&
2721 (o->op_type == OP_CONST ||
2722 o->op_type == OP_GV) )
2724 op_getmad(from,(OP*)mp->mad_val,slot);
2731 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
2734 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
2740 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
2749 /* pretend constant fold didn't happen? */
2750 if (mp->mad_key == 'f' &&
2751 (o->op_type == OP_CONST ||
2752 o->op_type == OP_GV) )
2754 op_getmad(from,(OP*)mp->mad_val,slot);
2761 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
2764 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
2768 PerlIO_printf(PerlIO_stderr(),
2769 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
2775 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
2793 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
2797 addmad(tm, &(o->op_madprop), slot);
2801 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
2822 Perl_newMADsv(pTHX_ char key, SV* sv)
2824 return newMADPROP(key, MAD_SV, sv, 0);
2828 Perl_newMADPROP(pTHX_ char key, char type, const void* val, I32 vlen)
2831 Newxz(mp, 1, MADPROP);
2834 mp->mad_vlen = vlen;
2835 mp->mad_type = type;
2837 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
2842 Perl_mad_free(pTHX_ MADPROP* mp)
2844 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
2848 mad_free(mp->mad_next);
2849 /* if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
2850 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
2851 switch (mp->mad_type) {
2855 Safefree((char*)mp->mad_val);
2858 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
2859 op_free((OP*)mp->mad_val);
2862 sv_free((SV*)mp->mad_val);
2865 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
2874 Perl_newNULLLIST(pTHX)
2876 return newOP(OP_STUB, 0);
2880 Perl_force_list(pTHX_ OP *o)
2882 if (!o || o->op_type != OP_LIST)
2883 o = newLISTOP(OP_LIST, 0, o, NULL);
2889 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2894 NewOp(1101, listop, 1, LISTOP);
2896 listop->op_type = (OPCODE)type;
2897 listop->op_ppaddr = PL_ppaddr[type];
2900 listop->op_flags = (U8)flags;
2904 else if (!first && last)
2907 first->op_sibling = last;
2908 listop->op_first = first;
2909 listop->op_last = last;
2910 if (type == OP_LIST) {
2911 OP* const pushop = newOP(OP_PUSHMARK, 0);
2912 pushop->op_sibling = first;
2913 listop->op_first = pushop;
2914 listop->op_flags |= OPf_KIDS;
2916 listop->op_last = pushop;
2919 return CHECKOP(type, listop);
2923 Perl_newOP(pTHX_ I32 type, I32 flags)
2927 NewOp(1101, o, 1, OP);
2928 o->op_type = (OPCODE)type;
2929 o->op_ppaddr = PL_ppaddr[type];
2930 o->op_flags = (U8)flags;
2932 o->op_latefreed = 0;
2936 o->op_private = (U8)(0 | (flags >> 8));
2937 if (PL_opargs[type] & OA_RETSCALAR)
2939 if (PL_opargs[type] & OA_TARGET)
2940 o->op_targ = pad_alloc(type, SVs_PADTMP);
2941 return CHECKOP(type, o);
2945 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2951 first = newOP(OP_STUB, 0);
2952 if (PL_opargs[type] & OA_MARK)
2953 first = force_list(first);
2955 NewOp(1101, unop, 1, UNOP);
2956 unop->op_type = (OPCODE)type;
2957 unop->op_ppaddr = PL_ppaddr[type];
2958 unop->op_first = first;
2959 unop->op_flags = (U8)(flags | OPf_KIDS);
2960 unop->op_private = (U8)(1 | (flags >> 8));
2961 unop = (UNOP*) CHECKOP(type, unop);
2965 return fold_constants((OP *) unop);
2969 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2973 NewOp(1101, binop, 1, BINOP);
2976 first = newOP(OP_NULL, 0);
2978 binop->op_type = (OPCODE)type;
2979 binop->op_ppaddr = PL_ppaddr[type];
2980 binop->op_first = first;
2981 binop->op_flags = (U8)(flags | OPf_KIDS);
2984 binop->op_private = (U8)(1 | (flags >> 8));
2987 binop->op_private = (U8)(2 | (flags >> 8));
2988 first->op_sibling = last;
2991 binop = (BINOP*)CHECKOP(type, binop);
2992 if (binop->op_next || binop->op_type != (OPCODE)type)
2995 binop->op_last = binop->op_first->op_sibling;
2997 return fold_constants((OP *)binop);
3000 static int uvcompare(const void *a, const void *b)
3001 __attribute__nonnull__(1)
3002 __attribute__nonnull__(2)
3003 __attribute__pure__;
3004 static int uvcompare(const void *a, const void *b)
3006 if (*((const UV *)a) < (*(const UV *)b))
3008 if (*((const UV *)a) > (*(const UV *)b))
3010 if (*((const UV *)a+1) < (*(const UV *)b+1))
3012 if (*((const UV *)a+1) > (*(const UV *)b+1))
3018 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
3021 SV * const tstr = ((SVOP*)expr)->op_sv;
3024 (repl->op_type == OP_NULL)
3025 ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
3027 ((SVOP*)repl)->op_sv;
3030 const U8 *t = (U8*)SvPV_const(tstr, tlen);
3031 const U8 *r = (U8*)SvPV_const(rstr, rlen);
3035 register short *tbl;
3037 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
3038 const I32 squash = o->op_private & OPpTRANS_SQUASH;
3039 I32 del = o->op_private & OPpTRANS_DELETE;
3041 PL_hints |= HINT_BLOCK_SCOPE;
3044 o->op_private |= OPpTRANS_FROM_UTF;
3047 o->op_private |= OPpTRANS_TO_UTF;
3049 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
3050 SV* const listsv = newSVpvs("# comment\n");
3052 const U8* tend = t + tlen;
3053 const U8* rend = r + rlen;
3067 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
3068 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
3071 const U32 flags = UTF8_ALLOW_DEFAULT;
3075 t = tsave = bytes_to_utf8(t, &len);
3078 if (!to_utf && rlen) {
3080 r = rsave = bytes_to_utf8(r, &len);
3084 /* There are several snags with this code on EBCDIC:
3085 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
3086 2. scan_const() in toke.c has encoded chars in native encoding which makes
3087 ranges at least in EBCDIC 0..255 range the bottom odd.
3091 U8 tmpbuf[UTF8_MAXBYTES+1];
3094 Newx(cp, 2*tlen, UV);
3096 transv = newSVpvs("");
3098 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3100 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
3102 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3106 cp[2*i+1] = cp[2*i];
3110 qsort(cp, i, 2*sizeof(UV), uvcompare);
3111 for (j = 0; j < i; j++) {
3113 diff = val - nextmin;
3115 t = uvuni_to_utf8(tmpbuf,nextmin);
3116 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3118 U8 range_mark = UTF_TO_NATIVE(0xff);
3119 t = uvuni_to_utf8(tmpbuf, val - 1);
3120 sv_catpvn(transv, (char *)&range_mark, 1);
3121 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3128 t = uvuni_to_utf8(tmpbuf,nextmin);
3129 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3131 U8 range_mark = UTF_TO_NATIVE(0xff);
3132 sv_catpvn(transv, (char *)&range_mark, 1);
3134 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
3135 UNICODE_ALLOW_SUPER);
3136 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3137 t = (const U8*)SvPVX_const(transv);
3138 tlen = SvCUR(transv);
3142 else if (!rlen && !del) {
3143 r = t; rlen = tlen; rend = tend;
3146 if ((!rlen && !del) || t == r ||
3147 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
3149 o->op_private |= OPpTRANS_IDENTICAL;
3153 while (t < tend || tfirst <= tlast) {
3154 /* see if we need more "t" chars */
3155 if (tfirst > tlast) {
3156 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3158 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
3160 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3167 /* now see if we need more "r" chars */
3168 if (rfirst > rlast) {
3170 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3172 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
3174 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3183 rfirst = rlast = 0xffffffff;
3187 /* now see which range will peter our first, if either. */
3188 tdiff = tlast - tfirst;
3189 rdiff = rlast - rfirst;
3196 if (rfirst == 0xffffffff) {
3197 diff = tdiff; /* oops, pretend rdiff is infinite */
3199 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
3200 (long)tfirst, (long)tlast);
3202 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
3206 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
3207 (long)tfirst, (long)(tfirst + diff),
3210 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3211 (long)tfirst, (long)rfirst);
3213 if (rfirst + diff > max)
3214 max = rfirst + diff;
3216 grows = (tfirst < rfirst &&
3217 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3229 else if (max > 0xff)
3234 PerlMemShared_free(cPVOPo->op_pv);
3235 cPVOPo->op_pv = NULL;
3237 swash = (SV*)swash_init("utf8", "", listsv, bits, none);
3239 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
3240 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
3241 PAD_SETSV(cPADOPo->op_padix, swash);
3244 cSVOPo->op_sv = swash;
3246 SvREFCNT_dec(listsv);
3247 SvREFCNT_dec(transv);
3249 if (!del && havefinal && rlen)
3250 (void)hv_store((HV*)SvRV(swash), "FINAL", 5,
3251 newSVuv((UV)final), 0);
3254 o->op_private |= OPpTRANS_GROWS;
3260 op_getmad(expr,o,'e');
3261 op_getmad(repl,o,'r');
3269 tbl = (short*)cPVOPo->op_pv;
3271 Zero(tbl, 256, short);
3272 for (i = 0; i < (I32)tlen; i++)
3274 for (i = 0, j = 0; i < 256; i++) {
3276 if (j >= (I32)rlen) {
3285 if (i < 128 && r[j] >= 128)
3295 o->op_private |= OPpTRANS_IDENTICAL;
3297 else if (j >= (I32)rlen)
3302 PerlMemShared_realloc(tbl,
3303 (0x101+rlen-j) * sizeof(short));
3304 cPVOPo->op_pv = (char*)tbl;
3306 tbl[0x100] = (short)(rlen - j);
3307 for (i=0; i < (I32)rlen - j; i++)
3308 tbl[0x101+i] = r[j+i];
3312 if (!rlen && !del) {
3315 o->op_private |= OPpTRANS_IDENTICAL;
3317 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3318 o->op_private |= OPpTRANS_IDENTICAL;
3320 for (i = 0; i < 256; i++)
3322 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3323 if (j >= (I32)rlen) {
3325 if (tbl[t[i]] == -1)
3331 if (tbl[t[i]] == -1) {
3332 if (t[i] < 128 && r[j] >= 128)
3339 o->op_private |= OPpTRANS_GROWS;
3341 op_getmad(expr,o,'e');
3342 op_getmad(repl,o,'r');
3352 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3357 NewOp(1101, pmop, 1, PMOP);
3358 pmop->op_type = (OPCODE)type;
3359 pmop->op_ppaddr = PL_ppaddr[type];
3360 pmop->op_flags = (U8)flags;
3361 pmop->op_private = (U8)(0 | (flags >> 8));
3363 if (PL_hints & HINT_RE_TAINT)
3364 pmop->op_pmflags |= PMf_RETAINT;
3365 if (PL_hints & HINT_LOCALE)
3366 pmop->op_pmflags |= PMf_LOCALE;
3370 if (av_len((AV*) PL_regex_pad[0]) > -1) {
3371 SV * const repointer = av_pop((AV*)PL_regex_pad[0]);
3372 pmop->op_pmoffset = SvIV(repointer);
3373 SvREPADTMP_off(repointer);
3374 sv_setiv(repointer,0);
3376 SV * const repointer = newSViv(0);
3377 av_push(PL_regex_padav, repointer);
3378 pmop->op_pmoffset = av_len(PL_regex_padav);
3379 PL_regex_pad = AvARRAY(PL_regex_padav);
3383 return CHECKOP(type, pmop);
3386 /* Given some sort of match op o, and an expression expr containing a
3387 * pattern, either compile expr into a regex and attach it to o (if it's
3388 * constant), or convert expr into a runtime regcomp op sequence (if it's
3391 * isreg indicates that the pattern is part of a regex construct, eg
3392 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3393 * split "pattern", which aren't. In the former case, expr will be a list
3394 * if the pattern contains more than one term (eg /a$b/) or if it contains
3395 * a replacement, ie s/// or tr///.
3399 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
3404 I32 repl_has_vars = 0;
3408 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
3409 /* last element in list is the replacement; pop it */
3411 repl = cLISTOPx(expr)->op_last;
3412 kid = cLISTOPx(expr)->op_first;
3413 while (kid->op_sibling != repl)
3414 kid = kid->op_sibling;
3415 kid->op_sibling = NULL;
3416 cLISTOPx(expr)->op_last = kid;
3419 if (isreg && expr->op_type == OP_LIST &&
3420 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3422 /* convert single element list to element */
3423 OP* const oe = expr;
3424 expr = cLISTOPx(oe)->op_first->op_sibling;
3425 cLISTOPx(oe)->op_first->op_sibling = NULL;
3426 cLISTOPx(oe)->op_last = NULL;
3430 if (o->op_type == OP_TRANS) {
3431 return pmtrans(o, expr, repl);
3434 reglist = isreg && expr->op_type == OP_LIST;
3438 PL_hints |= HINT_BLOCK_SCOPE;
3441 if (expr->op_type == OP_CONST) {
3442 SV *pat = ((SVOP*)expr)->op_sv;
3443 U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
3445 if (o->op_flags & OPf_SPECIAL)
3446 pm_flags |= RXf_SPLIT;
3449 assert (SvUTF8(pat));
3450 } else if (SvUTF8(pat)) {
3451 /* Not doing UTF-8, despite what the SV says. Is this only if we're
3452 trapped in use 'bytes'? */
3453 /* Make a copy of the octet sequence, but without the flag on, as
3454 the compiler now honours the SvUTF8 flag on pat. */
3456 const char *const p = SvPV(pat, len);
3457 pat = newSVpvn_flags(p, len, SVs_TEMP);
3460 PM_SETRE(pm, CALLREGCOMP(pat, pm_flags));
3463 op_getmad(expr,(OP*)pm,'e');
3469 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3470 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3472 : OP_REGCMAYBE),0,expr);
3474 NewOp(1101, rcop, 1, LOGOP);
3475 rcop->op_type = OP_REGCOMP;
3476 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3477 rcop->op_first = scalar(expr);
3478 rcop->op_flags |= OPf_KIDS
3479 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3480 | (reglist ? OPf_STACKED : 0);
3481 rcop->op_private = 1;
3484 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3486 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
3489 /* establish postfix order */
3490 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3492 rcop->op_next = expr;
3493 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3496 rcop->op_next = LINKLIST(expr);
3497 expr->op_next = (OP*)rcop;
3500 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3505 if (pm->op_pmflags & PMf_EVAL) {
3507 if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
3508 CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
3510 else if (repl->op_type == OP_CONST)
3514 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3515 if (curop->op_type == OP_SCOPE
3516 || curop->op_type == OP_LEAVE
3517 || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
3518 if (curop->op_type == OP_GV) {
3519 GV * const gv = cGVOPx_gv(curop);
3521 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3524 else if (curop->op_type == OP_RV2CV)
3526 else if (curop->op_type == OP_RV2SV ||
3527 curop->op_type == OP_RV2AV ||
3528 curop->op_type == OP_RV2HV ||
3529 curop->op_type == OP_RV2GV) {
3530 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3533 else if (curop->op_type == OP_PADSV ||
3534 curop->op_type == OP_PADAV ||
3535 curop->op_type == OP_PADHV ||
3536 curop->op_type == OP_PADANY)
3540 else if (curop->op_type == OP_PUSHRE)
3541 NOOP; /* Okay here, dangerous in newASSIGNOP */
3551 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
3553 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3554 prepend_elem(o->op_type, scalar(repl), o);
3557 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3558 pm->op_pmflags |= PMf_MAYBE_CONST;
3560 NewOp(1101, rcop, 1, LOGOP);
3561 rcop->op_type = OP_SUBSTCONT;
3562 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3563 rcop->op_first = scalar(repl);
3564 rcop->op_flags |= OPf_KIDS;
3565 rcop->op_private = 1;
3568 /* establish postfix order */
3569 rcop->op_next = LINKLIST(repl);
3570 repl->op_next = (OP*)rcop;
3572 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
3573 assert(!(pm->op_pmflags & PMf_ONCE));
3574 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
3583 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3587 NewOp(1101, svop, 1, SVOP);
3588 svop->op_type = (OPCODE)type;
3589 svop->op_ppaddr = PL_ppaddr[type];
3591 svop->op_next = (OP*)svop;
3592 svop->op_flags = (U8)flags;
3593 if (PL_opargs[type] & OA_RETSCALAR)
3595 if (PL_opargs[type] & OA_TARGET)
3596 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3597 return CHECKOP(type, svop);
3602 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3606 NewOp(1101, padop, 1, PADOP);
3607 padop->op_type = (OPCODE)type;
3608 padop->op_ppaddr = PL_ppaddr[type];
3609 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3610 SvREFCNT_dec(PAD_SVl(padop->op_padix));
3611 PAD_SETSV(padop->op_padix, sv);
3614 padop->op_next = (OP*)padop;
3615 padop->op_flags = (U8)flags;
3616 if (PL_opargs[type] & OA_RETSCALAR)
3618 if (PL_opargs[type] & OA_TARGET)
3619 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3620 return CHECKOP(type, padop);
3625 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3631 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3633 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3638 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3642 NewOp(1101, pvop, 1, PVOP);
3643 pvop->op_type = (OPCODE)type;
3644 pvop->op_ppaddr = PL_ppaddr[type];
3646 pvop->op_next = (OP*)pvop;
3647 pvop->op_flags = (U8)flags;
3648 if (PL_opargs[type] & OA_RETSCALAR)
3650 if (PL_opargs[type] & OA_TARGET)
3651 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3652 return CHECKOP(type, pvop);
3660 Perl_package(pTHX_ OP *o)
3663 SV *const sv = cSVOPo->op_sv;
3668 save_hptr(&PL_curstash);
3669 save_item(PL_curstname);
3671 PL_curstash = gv_stashsv(sv, GV_ADD);
3673 sv_setsv(PL_curstname, sv);
3675 PL_hints |= HINT_BLOCK_SCOPE;
3676 PL_parser->copline = NOLINE;
3677 PL_parser->expect = XSTATE;
3682 if (!PL_madskills) {
3687 pegop = newOP(OP_NULL,0);
3688 op_getmad(o,pegop,'P');
3698 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3705 OP *pegop = newOP(OP_NULL,0);
3708 if (idop->op_type != OP_CONST)
3709 Perl_croak(aTHX_ "Module name must be constant");
3712 op_getmad(idop,pegop,'U');
3717 SV * const vesv = ((SVOP*)version)->op_sv;
3720 op_getmad(version,pegop,'V');
3721 if (!arg && !SvNIOKp(vesv)) {
3728 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3729 Perl_croak(aTHX_ "Version number must be constant number");
3731 /* Make copy of idop so we don't free it twice */
3732 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3734 /* Fake up a method call to VERSION */
3735 meth = newSVpvs_share("VERSION");
3736 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3737 append_elem(OP_LIST,
3738 prepend_elem(OP_LIST, pack, list(version)),
3739 newSVOP(OP_METHOD_NAMED, 0, meth)));
3743 /* Fake up an import/unimport */
3744 if (arg && arg->op_type == OP_STUB) {
3746 op_getmad(arg,pegop,'S');
3747 imop = arg; /* no import on explicit () */
3749 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3750 imop = NULL; /* use 5.0; */
3752 idop->op_private |= OPpCONST_NOVER;
3758 op_getmad(arg,pegop,'A');
3760 /* Make copy of idop so we don't free it twice */
3761 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3763 /* Fake up a method call to import/unimport */
3765 ? newSVpvs_share("import") : newSVpvs_share("unimport");
3766 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3767 append_elem(OP_LIST,
3768 prepend_elem(OP_LIST, pack, list(arg)),
3769 newSVOP(OP_METHOD_NAMED, 0, meth)));
3772 /* Fake up the BEGIN {}, which does its thing immediately. */
3774 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
3777 append_elem(OP_LINESEQ,
3778 append_elem(OP_LINESEQ,
3779 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
3780 newSTATEOP(0, NULL, veop)),
3781 newSTATEOP(0, NULL, imop) ));
3783 /* The "did you use incorrect case?" warning used to be here.
3784 * The problem is that on case-insensitive filesystems one
3785 * might get false positives for "use" (and "require"):
3786 * "use Strict" or "require CARP" will work. This causes
3787 * portability problems for the script: in case-strict
3788 * filesystems the script will stop working.
3790 * The "incorrect case" warning checked whether "use Foo"
3791 * imported "Foo" to your namespace, but that is wrong, too:
3792 * there is no requirement nor promise in the language that
3793 * a Foo.pm should or would contain anything in package "Foo".
3795 * There is very little Configure-wise that can be done, either:
3796 * the case-sensitivity of the build filesystem of Perl does not
3797 * help in guessing the case-sensitivity of the runtime environment.
3800 PL_hints |= HINT_BLOCK_SCOPE;
3801 PL_parser->copline = NOLINE;
3802 PL_parser->expect = XSTATE;
3803 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3806 if (!PL_madskills) {
3807 /* FIXME - don't allocate pegop if !PL_madskills */
3816 =head1 Embedding Functions
3818 =for apidoc load_module
3820 Loads the module whose name is pointed to by the string part of name.
3821 Note that the actual module name, not its filename, should be given.
3822 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3823 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3824 (or 0 for no flags). ver, if specified, provides version semantics
3825 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3826 arguments can be used to specify arguments to the module's import()
3827 method, similar to C<use Foo::Bar VERSION LIST>.
3832 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3835 va_start(args, ver);
3836 vload_module(flags, name, ver, &args);
3840 #ifdef PERL_IMPLICIT_CONTEXT
3842 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3846 va_start(args, ver);
3847 vload_module(flags, name, ver, &args);
3853 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3858 OP * const modname = newSVOP(OP_CONST, 0, name);
3859 modname->op_private |= OPpCONST_BARE;
3861 veop = newSVOP(OP_CONST, 0, ver);
3865 if (flags & PERL_LOADMOD_NOIMPORT) {
3866 imop = sawparens(newNULLLIST());
3868 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3869 imop = va_arg(*args, OP*);
3874 sv = va_arg(*args, SV*);
3876 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3877 sv = va_arg(*args, SV*);
3881 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
3882 * that it has a PL_parser to play with while doing that, and also
3883 * that it doesn't mess with any existing parser, by creating a tmp
3884 * new parser with lex_start(). This won't actually be used for much,
3885 * since pp_require() will create another parser for the real work. */
3888 SAVEVPTR(PL_curcop);
3889 lex_start(NULL, NULL, FALSE);
3890 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3891 veop, modname, imop);
3896 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
3902 if (!force_builtin) {
3903 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
3904 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
3905 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
3906 gv = gvp ? *gvp : NULL;
3910 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3911 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3912 append_elem(OP_LIST, term,
3913 scalar(newUNOP(OP_RV2CV, 0,
3914 newGVOP(OP_GV, 0, gv))))));
3917 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3923 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3925 return newBINOP(OP_LSLICE, flags,
3926 list(force_list(subscript)),
3927 list(force_list(listval)) );
3931 S_is_list_assignment(pTHX_ register const OP *o)
3939 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
3940 o = cUNOPo->op_first;
3942 flags = o->op_flags;
3944 if (type == OP_COND_EXPR) {
3945 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
3946 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3951 yyerror("Assignment to both a list and a scalar");
3955 if (type == OP_LIST &&
3956 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
3957 o->op_private & OPpLVAL_INTRO)
3960 if (type == OP_LIST || flags & OPf_PARENS ||
3961 type == OP_RV2AV || type == OP_RV2HV ||
3962 type == OP_ASLICE || type == OP_HSLICE)
3965 if (type == OP_PADAV || type == OP_PADHV)
3968 if (type == OP_RV2SV)
3975 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3981 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3982 return newLOGOP(optype, 0,
3983 mod(scalar(left), optype),
3984 newUNOP(OP_SASSIGN, 0, scalar(right)));
3987 return newBINOP(optype, OPf_STACKED,
3988 mod(scalar(left), optype), scalar(right));
3992 if (is_list_assignment(left)) {
3993 static const char no_list_state[] = "Initialization of state variables"
3994 " in list context currently forbidden";
3996 bool maybe_common_vars = TRUE;
3999 /* Grandfathering $[ assignment here. Bletch.*/
4000 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
4001 PL_eval_start = (left->op_type == OP_CONST) ? right : NULL;
4002 left = mod(left, OP_AASSIGN);
4005 else if (left->op_type == OP_CONST) {
4007 /* Result of assignment is always 1 (or we'd be dead already) */
4008 return newSVOP(OP_CONST, 0, newSViv(1));
4010 curop = list(force_list(left));
4011 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
4012 o->op_private = (U8)(0 | (flags >> 8));
4014 if ((left->op_type == OP_LIST
4015 || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
4017 OP* lop = ((LISTOP*)left)->op_first;
4018 maybe_common_vars = FALSE;
4020 if (lop->op_type == OP_PADSV ||
4021 lop->op_type == OP_PADAV ||
4022 lop->op_type == OP_PADHV ||
4023 lop->op_type == OP_PADANY) {
4024 if (!(lop->op_private & OPpLVAL_INTRO))
4025 maybe_common_vars = TRUE;
4027 if (lop->op_private & OPpPAD_STATE) {
4028 if (left->op_private & OPpLVAL_INTRO) {
4029 /* Each variable in state($a, $b, $c) = ... */
4032 /* Each state variable in
4033 (state $a, my $b, our $c, $d, undef) = ... */
4035 yyerror(no_list_state);
4037 /* Each my variable in
4038 (state $a, my $b, our $c, $d, undef) = ... */
4040 } else if (lop->op_type == OP_UNDEF ||
4041 lop->op_type == OP_PUSHMARK) {
4042 /* undef may be interesting in
4043 (state $a, undef, state $c) */
4045 /* Other ops in the list. */
4046 maybe_common_vars = TRUE;
4048 lop = lop->op_sibling;
4051 else if ((left->op_private & OPpLVAL_INTRO)
4052 && ( left->op_type == OP_PADSV
4053 || left->op_type == OP_PADAV
4054 || left->op_type == OP_PADHV
4055 || left->op_type == OP_PADANY))
4057 maybe_common_vars = FALSE;
4058 if (left->op_private & OPpPAD_STATE) {
4059 /* All single variable list context state assignments, hence
4069 yyerror(no_list_state);
4073 /* PL_generation sorcery:
4074 * an assignment like ($a,$b) = ($c,$d) is easier than
4075 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
4076 * To detect whether there are common vars, the global var
4077 * PL_generation is incremented for each assign op we compile.
4078 * Then, while compiling the assign op, we run through all the
4079 * variables on both sides of the assignment, setting a spare slot
4080 * in each of them to PL_generation. If any of them already have
4081 * that value, we know we've got commonality. We could use a
4082 * single bit marker, but then we'd have to make 2 passes, first
4083 * to clear the flag, then to test and set it. To find somewhere
4084 * to store these values, evil chicanery is done with SvUVX().
4087 if (maybe_common_vars) {
4090 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4091 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
4092 if (curop->op_type == OP_GV) {
4093 GV *gv = cGVOPx_gv(curop);
4095 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4097 GvASSIGN_GENERATION_set(gv, PL_generation);
4099 else if (curop->op_type == OP_PADSV ||
4100 curop->op_type == OP_PADAV ||
4101 curop->op_type == OP_PADHV ||
4102 curop->op_type == OP_PADANY)
4104 if (PAD_COMPNAME_GEN(curop->op_targ)
4105 == (STRLEN)PL_generation)
4107 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
4110 else if (curop->op_type == OP_RV2CV)
4112 else if (curop->op_type == OP_RV2SV ||
4113 curop->op_type == OP_RV2AV ||
4114 curop->op_type == OP_RV2HV ||
4115 curop->op_type == OP_RV2GV) {
4116 if (lastop->op_type != OP_GV) /* funny deref? */
4119 else if (curop->op_type == OP_PUSHRE) {
4121 if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
4122 GV *const gv = (GV*)PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff);
4124 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4126 GvASSIGN_GENERATION_set(gv, PL_generation);
4130 = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
4133 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4135 GvASSIGN_GENERATION_set(gv, PL_generation);
4145 o->op_private |= OPpASSIGN_COMMON;
4148 if (right && right->op_type == OP_SPLIT && !PL_madskills) {
4149 OP* tmpop = ((LISTOP*)right)->op_first;
4150 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
4151 PMOP * const pm = (PMOP*)tmpop;
4152 if (left->op_type == OP_RV2AV &&
4153 !(left->op_private & OPpLVAL_INTRO) &&
4154 !(o->op_private & OPpASSIGN_COMMON) )
4156 tmpop = ((UNOP*)left)->op_first;
4157 if (tmpop->op_type == OP_GV
4159 && !pm->op_pmreplrootu.op_pmtargetoff
4161 && !pm->op_pmreplrootu.op_pmtargetgv
4165 pm->op_pmreplrootu.op_pmtargetoff
4166 = cPADOPx(tmpop)->op_padix;
4167 cPADOPx(tmpop)->op_padix = 0; /* steal it */
4169 pm->op_pmreplrootu.op_pmtargetgv
4170 = (GV*)cSVOPx(tmpop)->op_sv;
4171 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
4173 pm->op_pmflags |= PMf_ONCE;
4174 tmpop = cUNOPo->op_first; /* to list (nulled) */
4175 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
4176 tmpop->op_sibling = NULL; /* don't free split */
4177 right->op_next = tmpop->op_next; /* fix starting loc */
4178 op_free(o); /* blow off assign */
4179 right->op_flags &= ~OPf_WANT;
4180 /* "I don't know and I don't care." */
4185 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
4186 ((LISTOP*)right)->op_last->op_type == OP_CONST)
4188 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
4190 sv_setiv(sv, PL_modcount+1);
4198 right = newOP(OP_UNDEF, 0);
4199 if (right->op_type == OP_READLINE) {
4200 right->op_flags |= OPf_STACKED;
4201 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
4204 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
4205 o = newBINOP(OP_SASSIGN, flags,
4206 scalar(right), mod(scalar(left), OP_SASSIGN) );
4212 o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
4213 o->op_private |= OPpCONST_ARYBASE;
4220 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
4223 const U32 seq = intro_my();
4226 NewOp(1101, cop, 1, COP);
4227 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
4228 cop->op_type = OP_DBSTATE;
4229 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
4232 cop->op_type = OP_NEXTSTATE;
4233 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
4235 cop->op_flags = (U8)flags;
4236 CopHINTS_set(cop, PL_hints);
4238 cop->op_private |= NATIVE_HINTS;
4240 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
4241 cop->op_next = (OP*)cop;
4244 CopLABEL_set(cop, label);
4245 PL_hints |= HINT_BLOCK_SCOPE;
4248 /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
4249 CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
4251 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
4252 cop->cop_hints_hash = PL_curcop->cop_hints_hash;
4253 if (cop->cop_hints_hash) {
4255 cop->cop_hints_hash->refcounted_he_refcnt++;
4256 HINTS_REFCNT_UNLOCK;
4259 if (PL_parser && PL_parser->copline == NOLINE)
4260 CopLINE_set(cop, CopLINE(PL_curcop));
4262 CopLINE_set(cop, PL_parser->copline);
4264 PL_parser->copline = NOLINE;
4267 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
4269 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
4271 CopSTASH_set(cop, PL_curstash);
4273 if (PERLDB_LINE && PL_curstash != PL_debstash) {
4274 AV *av = CopFILEAVx(PL_curcop);
4276 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
4277 if (svp && *svp != &PL_sv_undef ) {
4278 (void)SvIOK_on(*svp);
4279 SvIV_set(*svp, PTR2IV(cop));
4284 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
4289 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
4292 return new_logop(type, flags, &first, &other);
4296 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
4301 OP *first = *firstp;
4302 OP * const other = *otherp;
4304 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
4305 return newBINOP(type, flags, scalar(first), scalar(other));
4307 scalarboolean(first);
4308 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
4309 if (first->op_type == OP_NOT
4310 && (first->op_flags & OPf_SPECIAL)
4311 && (first->op_flags & OPf_KIDS)
4313 if (type == OP_AND || type == OP_OR) {
4319 first = *firstp = cUNOPo->op_first;
4321 first->op_next = o->op_next;
4322 cUNOPo->op_first = NULL;
4326 if (first->op_type == OP_CONST) {
4327 if (first->op_private & OPpCONST_STRICT)
4328 no_bareword_allowed(first);
4329 else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
4330 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
4331 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
4332 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
4333 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
4335 if (other->op_type == OP_CONST)
4336 other->op_private |= OPpCONST_SHORTCIRCUIT;
4338 OP *newop = newUNOP(OP_NULL, 0, other);
4339 op_getmad(first, newop, '1');
4340 newop->op_targ = type; /* set "was" field */
4347 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
4348 const OP *o2 = other;
4349 if ( ! (o2->op_type == OP_LIST
4350 && (( o2 = cUNOPx(o2)->op_first))
4351 && o2->op_type == OP_PUSHMARK
4352 && (( o2 = o2->op_sibling)) )
4355 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
4356 || o2->op_type == OP_PADHV)
4357 && o2->op_private & OPpLVAL_INTRO
4358 && !(o2->op_private & OPpPAD_STATE)
4359 && ckWARN(WARN_DEPRECATED))
4361 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4362 "Deprecated use of my() in false conditional");
4366 if (first->op_type == OP_CONST)
4367 first->op_private |= OPpCONST_SHORTCIRCUIT;
4369 first = newUNOP(OP_NULL, 0, first);
4370 op_getmad(other, first, '2');
4371 first->op_targ = type; /* set "was" field */
4378 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
4379 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
4381 const OP * const k1 = ((UNOP*)first)->op_first;
4382 const OP * const k2 = k1->op_sibling;
4384 switch (first->op_type)
4387 if (k2 && k2->op_type == OP_READLINE
4388 && (k2->op_flags & OPf_STACKED)
4389 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4391 warnop = k2->op_type;
4396 if (k1->op_type == OP_READDIR
4397 || k1->op_type == OP_GLOB
4398 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4399 || k1->op_type == OP_EACH)
4401 warnop = ((k1->op_type == OP_NULL)
4402 ? (OPCODE)k1->op_targ : k1->op_type);
4407 const line_t oldline = CopLINE(PL_curcop);
4408 CopLINE_set(PL_curcop, PL_parser->copline);
4409 Perl_warner(aTHX_ packWARN(WARN_MISC),
4410 "Value of %s%s can be \"0\"; test with defined()",
4412 ((warnop == OP_READLINE || warnop == OP_GLOB)
4413 ? " construct" : "() operator"));
4414 CopLINE_set(PL_curcop, oldline);
4421 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
4422 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
4424 NewOp(1101, logop, 1, LOGOP);
4426 logop->op_type = (OPCODE)type;
4427 logop->op_ppaddr = PL_ppaddr[type];
4428 logop->op_first = first;
4429 logop->op_flags = (U8)(flags | OPf_KIDS);
4430 logop->op_other = LINKLIST(other);
4431 logop->op_private = (U8)(1 | (flags >> 8));
4433 /* establish postfix order */
4434 logop->op_next = LINKLIST(first);
4435 first->op_next = (OP*)logop;
4436 first->op_sibling = other;
4438 CHECKOP(type,logop);
4440 o = newUNOP(OP_NULL, 0, (OP*)logop);
4447 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
4455 return newLOGOP(OP_AND, 0, first, trueop);
4457 return newLOGOP(OP_OR, 0, first, falseop);
4459 scalarboolean(first);
4460 if (first->op_type == OP_CONST) {
4461 /* Left or right arm of the conditional? */
4462 const bool left = SvTRUE(((SVOP*)first)->op_sv);
4463 OP *live = left ? trueop : falseop;
4464 OP *const dead = left ? falseop : trueop;
4465 if (first->op_private & OPpCONST_BARE &&
4466 first->op_private & OPpCONST_STRICT) {
4467 no_bareword_allowed(first);
4470 /* This is all dead code when PERL_MAD is not defined. */
4471 live = newUNOP(OP_NULL, 0, live);
4472 op_getmad(first, live, 'C');
4473 op_getmad(dead, live, left ? 'e' : 't');
4480 NewOp(1101, logop, 1, LOGOP);
4481 logop->op_type = OP_COND_EXPR;
4482 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4483 logop->op_first = first;
4484 logop->op_flags = (U8)(flags | OPf_KIDS);
4485 logop->op_private = (U8)(1 | (flags >> 8));
4486 logop->op_other = LINKLIST(trueop);
4487 logop->op_next = LINKLIST(falseop);
4489 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
4492 /* establish postfix order */
4493 start = LINKLIST(first);
4494 first->op_next = (OP*)logop;
4496 first->op_sibling = trueop;
4497 trueop->op_sibling = falseop;
4498 o = newUNOP(OP_NULL, 0, (OP*)logop);
4500 trueop->op_next = falseop->op_next = o;
4507 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4516 NewOp(1101, range, 1, LOGOP);
4518 range->op_type = OP_RANGE;
4519 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4520 range->op_first = left;
4521 range->op_flags = OPf_KIDS;
4522 leftstart = LINKLIST(left);
4523 range->op_other = LINKLIST(right);
4524 range->op_private = (U8)(1 | (flags >> 8));
4526 left->op_sibling = right;
4528 range->op_next = (OP*)range;
4529 flip = newUNOP(OP_FLIP, flags, (OP*)range);
4530 flop = newUNOP(OP_FLOP, 0, flip);
4531 o = newUNOP(OP_NULL, 0, flop);
4533 range->op_next = leftstart;
4535 left->op_next = flip;
4536 right->op_next = flop;
4538 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4539 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4540 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4541 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4543 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4544 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4547 if (!flip->op_private || !flop->op_private)
4548 linklist(o); /* blow off optimizer unless constant */
4554 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4559 const bool once = block && block->op_flags & OPf_SPECIAL &&
4560 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4562 PERL_UNUSED_ARG(debuggable);
4565 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4566 return block; /* do {} while 0 does once */
4567 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4568 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4569 expr = newUNOP(OP_DEFINED, 0,
4570 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4571 } else if (expr->op_flags & OPf_KIDS) {
4572 const OP * const k1 = ((UNOP*)expr)->op_first;
4573 const OP * const k2 = k1 ? k1->op_sibling : NULL;
4574 switch (expr->op_type) {
4576 if (k2 && k2->op_type == OP_READLINE
4577 && (k2->op_flags & OPf_STACKED)
4578 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4579 expr = newUNOP(OP_DEFINED, 0, expr);
4583 if (k1 && (k1->op_type == OP_READDIR
4584 || k1->op_type == OP_GLOB
4585 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4586 || k1->op_type == OP_EACH))
4587 expr = newUNOP(OP_DEFINED, 0, expr);
4593 /* if block is null, the next append_elem() would put UNSTACK, a scalar
4594 * op, in listop. This is wrong. [perl #27024] */
4596 block = newOP(OP_NULL, 0);
4597 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4598 o = new_logop(OP_AND, 0, &expr, &listop);
4601 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4603 if (once && o != listop)
4604 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4607 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
4609 o->op_flags |= flags;
4611 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4616 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
4617 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
4626 PERL_UNUSED_ARG(debuggable);
4629 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4630 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4631 expr = newUNOP(OP_DEFINED, 0,
4632 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4633 } else if (expr->op_flags & OPf_KIDS) {
4634 const OP * const k1 = ((UNOP*)expr)->op_first;
4635 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
4636 switch (expr->op_type) {
4638 if (k2 && k2->op_type == OP_READLINE
4639 && (k2->op_flags & OPf_STACKED)
4640 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4641 expr = newUNOP(OP_DEFINED, 0, expr);
4645 if (k1 && (k1->op_type == OP_READDIR
4646 || k1->op_type == OP_GLOB
4647 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4648 || k1->op_type == OP_EACH))
4649 expr = newUNOP(OP_DEFINED, 0, expr);
4656 block = newOP(OP_NULL, 0);
4657 else if (cont || has_my) {
4658 block = scope(block);
4662 next = LINKLIST(cont);
4665 OP * const unstack = newOP(OP_UNSTACK, 0);
4668 cont = append_elem(OP_LINESEQ, cont, unstack);
4672 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4674 redo = LINKLIST(listop);
4677 PL_parser->copline = (line_t)whileline;
4679 o = new_logop(OP_AND, 0, &expr, &listop);
4680 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4681 op_free(expr); /* oops, it's a while (0) */
4683 return NULL; /* listop already freed by new_logop */
4686 ((LISTOP*)listop)->op_last->op_next =
4687 (o == listop ? redo : LINKLIST(o));
4693 NewOp(1101,loop,1,LOOP);
4694 loop->op_type = OP_ENTERLOOP;
4695 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4696 loop->op_private = 0;
4697 loop->op_next = (OP*)loop;
4700 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4702 loop->op_redoop = redo;
4703 loop->op_lastop = o;
4704 o->op_private |= loopflags;
4707 loop->op_nextop = next;
4709 loop->op_nextop = o;
4711 o->op_flags |= flags;
4712 o->op_private |= (flags >> 8);
4717 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
4722 PADOFFSET padoff = 0;
4728 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4729 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
4730 sv->op_type = OP_RV2GV;
4731 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4733 /* The op_type check is needed to prevent a possible segfault
4734 * if the loop variable is undeclared and 'strict vars' is in
4735 * effect. This is illegal but is nonetheless parsed, so we
4736 * may reach this point with an OP_CONST where we're expecting
4739 if (cUNOPx(sv)->op_first->op_type == OP_GV
4740 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
4741 iterpflags |= OPpITER_DEF;
4743 else if (sv->op_type == OP_PADSV) { /* private variable */
4744 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
4745 padoff = sv->op_targ;
4755 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4757 SV *const namesv = PAD_COMPNAME_SV(padoff);
4759 const char *const name = SvPV_const(namesv, len);
4761 if (len == 2 && name[0] == '$' && name[1] == '_')
4762 iterpflags |= OPpITER_DEF;
4766 const PADOFFSET offset = pad_findmy("$_");
4767 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
4768 sv = newGVOP(OP_GV, 0, PL_defgv);
4773 iterpflags |= OPpITER_DEF;
4775 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4776 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4777 iterflags |= OPf_STACKED;
4779 else if (expr->op_type == OP_NULL &&
4780 (expr->op_flags & OPf_KIDS) &&
4781 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4783 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4784 * set the STACKED flag to indicate that these values are to be
4785 * treated as min/max values by 'pp_iterinit'.
4787 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4788 LOGOP* const range = (LOGOP*) flip->op_first;
4789 OP* const left = range->op_first;
4790 OP* const right = left->op_sibling;
4793 range->op_flags &= ~OPf_KIDS;
4794 range->op_first = NULL;
4796 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4797 listop->op_first->op_next = range->op_next;
4798 left->op_next = range->op_other;
4799 right->op_next = (OP*)listop;
4800 listop->op_next = listop->op_first;
4803 op_getmad(expr,(OP*)listop,'O');
4807 expr = (OP*)(listop);
4809 iterflags |= OPf_STACKED;
4812 expr = mod(force_list(expr), OP_GREPSTART);
4815 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4816 append_elem(OP_LIST, expr, scalar(sv))));
4817 assert(!loop->op_next);
4818 /* for my $x () sets OPpLVAL_INTRO;
4819 * for our $x () sets OPpOUR_INTRO */
4820 loop->op_private = (U8)iterpflags;
4821 #ifdef PL_OP_SLAB_ALLOC
4824 NewOp(1234,tmp,1,LOOP);
4825 Copy(loop,tmp,1,LISTOP);
4826 S_op_destroy(aTHX_ (OP*)loop);
4830 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
4832 loop->op_targ = padoff;
4833 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
4835 op_getmad(madsv, (OP*)loop, 'v');
4836 PL_parser->copline = forline;
4837 return newSTATEOP(0, label, wop);
4841 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4846 if (type != OP_GOTO || label->op_type == OP_CONST) {
4847 /* "last()" means "last" */
4848 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4849 o = newOP(type, OPf_SPECIAL);
4851 o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
4852 ? SvPV_nolen_const(((SVOP*)label)->op_sv)
4856 op_getmad(label,o,'L');
4862 /* Check whether it's going to be a goto &function */
4863 if (label->op_type == OP_ENTERSUB
4864 && !(label->op_flags & OPf_STACKED))
4865 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4866 o = newUNOP(type, OPf_STACKED, label);
4868 PL_hints |= HINT_BLOCK_SCOPE;
4872 /* if the condition is a literal array or hash
4873 (or @{ ... } etc), make a reference to it.
4876 S_ref_array_or_hash(pTHX_ OP *cond)
4879 && (cond->op_type == OP_RV2AV
4880 || cond->op_type == OP_PADAV
4881 || cond->op_type == OP_RV2HV
4882 || cond->op_type == OP_PADHV))
4884 return newUNOP(OP_REFGEN,
4885 0, mod(cond, OP_REFGEN));
4891 /* These construct the optree fragments representing given()
4894 entergiven and enterwhen are LOGOPs; the op_other pointer
4895 points up to the associated leave op. We need this so we
4896 can put it in the context and make break/continue work.
4897 (Also, of course, pp_enterwhen will jump straight to
4898 op_other if the match fails.)
4902 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
4903 I32 enter_opcode, I32 leave_opcode,
4904 PADOFFSET entertarg)
4910 NewOp(1101, enterop, 1, LOGOP);
4911 enterop->op_type = enter_opcode;
4912 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
4913 enterop->op_flags = (U8) OPf_KIDS;
4914 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
4915 enterop->op_private = 0;
4917 o = newUNOP(leave_opcode, 0, (OP *) enterop);
4920 enterop->op_first = scalar(cond);
4921 cond->op_sibling = block;
4923 o->op_next = LINKLIST(cond);
4924 cond->op_next = (OP *) enterop;
4927 /* This is a default {} block */
4928 enterop->op_first = block;
4929 enterop->op_flags |= OPf_SPECIAL;
4931 o->op_next = (OP *) enterop;
4934 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
4935 entergiven and enterwhen both
4938 enterop->op_next = LINKLIST(block);
4939 block->op_next = enterop->op_other = o;
4944 /* Does this look like a boolean operation? For these purposes
4945 a boolean operation is:
4946 - a subroutine call [*]
4947 - a logical connective
4948 - a comparison operator
4949 - a filetest operator, with the exception of -s -M -A -C
4950 - defined(), exists() or eof()
4951 - /$re/ or $foo =~ /$re/
4953 [*] possibly surprising
4956 S_looks_like_bool(pTHX_ const OP *o)
4959 switch(o->op_type) {
4961 return looks_like_bool(cLOGOPo->op_first);
4965 looks_like_bool(cLOGOPo->op_first)
4966 && looks_like_bool(cLOGOPo->op_first->op_sibling));
4970 o->op_flags & OPf_KIDS
4971 && looks_like_bool(cUNOPo->op_first));
4975 case OP_NOT: case OP_XOR:
4976 /* Note that OP_DOR is not here */
4978 case OP_EQ: case OP_NE: case OP_LT:
4979 case OP_GT: case OP_LE: case OP_GE:
4981 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
4982 case OP_I_GT: case OP_I_LE: case OP_I_GE:
4984 case OP_SEQ: case OP_SNE: case OP_SLT:
4985 case OP_SGT: case OP_SLE: case OP_SGE:
4989 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
4990 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
4991 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
4992 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
4993 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
4994 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
4995 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
4996 case OP_FTTEXT: case OP_FTBINARY:
4998 case OP_DEFINED: case OP_EXISTS:
4999 case OP_MATCH: case OP_EOF:
5004 /* Detect comparisons that have been optimized away */
5005 if (cSVOPo->op_sv == &PL_sv_yes
5006 || cSVOPo->op_sv == &PL_sv_no)
5017 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
5021 return newGIVWHENOP(
5022 ref_array_or_hash(cond),
5024 OP_ENTERGIVEN, OP_LEAVEGIVEN,
5028 /* If cond is null, this is a default {} block */
5030 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
5032 const bool cond_llb = (!cond || looks_like_bool(cond));
5038 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
5040 scalar(ref_array_or_hash(cond)));
5043 return newGIVWHENOP(
5045 append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
5046 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
5050 =for apidoc cv_undef
5052 Clear out all the active components of a CV. This can happen either
5053 by an explicit C<undef &foo>, or by the reference count going to zero.
5054 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
5055 children can still follow the full lexical scope chain.
5061 Perl_cv_undef(pTHX_ CV *cv)
5065 DEBUG_X(PerlIO_printf(Perl_debug_log,
5066 "CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n",
5067 PTR2UV(cv), PTR2UV(PL_comppad))
5071 if (CvFILE(cv) && !CvISXSUB(cv)) {
5072 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
5073 Safefree(CvFILE(cv));
5078 if (!CvISXSUB(cv) && CvROOT(cv)) {
5079 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
5080 Perl_croak(aTHX_ "Can't undef active subroutine");
5083 PAD_SAVE_SETNULLPAD();
5085 op_free(CvROOT(cv));
5090 SvPOK_off((SV*)cv); /* forget prototype */
5095 /* remove CvOUTSIDE unless this is an undef rather than a free */
5096 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
5097 if (!CvWEAKOUTSIDE(cv))
5098 SvREFCNT_dec(CvOUTSIDE(cv));
5099 CvOUTSIDE(cv) = NULL;
5102 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
5105 if (CvISXSUB(cv) && CvXSUB(cv)) {
5108 /* delete all flags except WEAKOUTSIDE */
5109 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
5113 Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
5116 /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
5117 relying on SvCUR, and doubling up the buffer to hold CvFILE(). */
5118 if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
5119 || (p && (len != SvCUR(cv) /* Not the same length. */
5120 || memNE(p, SvPVX_const(cv), len))))
5121 && ckWARN_d(WARN_PROTOTYPE)) {
5122 SV* const msg = sv_newmortal();
5126 gv_efullname3(name = sv_newmortal(), gv, NULL);
5127 sv_setpvs(msg, "Prototype mismatch:");
5129 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
5131 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv));
5133 sv_catpvs(msg, ": none");
5134 sv_catpvs(msg, " vs ");
5136 Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
5138 sv_catpvs(msg, "none");
5139 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
5143 static void const_sv_xsub(pTHX_ CV* cv);
5147 =head1 Optree Manipulation Functions
5149 =for apidoc cv_const_sv
5151 If C<cv> is a constant sub eligible for inlining. returns the constant
5152 value returned by the sub. Otherwise, returns NULL.
5154 Constant subs can be created with C<newCONSTSUB> or as described in
5155 L<perlsub/"Constant Functions">.
5160 Perl_cv_const_sv(pTHX_ CV *cv)
5162 PERL_UNUSED_CONTEXT;
5165 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
5167 return CvCONST(cv) ? (SV*)CvXSUBANY(cv).any_ptr : NULL;
5170 /* op_const_sv: examine an optree to determine whether it's in-lineable.
5171 * Can be called in 3 ways:
5174 * look for a single OP_CONST with attached value: return the value
5176 * cv && CvCLONE(cv) && !CvCONST(cv)
5178 * examine the clone prototype, and if contains only a single
5179 * OP_CONST referencing a pad const, or a single PADSV referencing
5180 * an outer lexical, return a non-zero value to indicate the CV is
5181 * a candidate for "constizing" at clone time
5185 * We have just cloned an anon prototype that was marked as a const
5186 * candidiate. Try to grab the current value, and in the case of
5187 * PADSV, ignore it if it has multiple references. Return the value.
5191 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
5202 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
5203 o = cLISTOPo->op_first->op_sibling;
5205 for (; o; o = o->op_next) {
5206 const OPCODE type = o->op_type;
5208 if (sv && o->op_next == o)
5210 if (o->op_next != o) {
5211 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
5213 if (type == OP_DBSTATE)
5216 if (type == OP_LEAVESUB || type == OP_RETURN)
5220 if (type == OP_CONST && cSVOPo->op_sv)
5222 else if (cv && type == OP_CONST) {
5223 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5227 else if (cv && type == OP_PADSV) {
5228 if (CvCONST(cv)) { /* newly cloned anon */
5229 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5230 /* the candidate should have 1 ref from this pad and 1 ref
5231 * from the parent */
5232 if (!sv || SvREFCNT(sv) != 2)
5239 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
5240 sv = &PL_sv_undef; /* an arbitrary non-null value */
5255 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5258 /* This would be the return value, but the return cannot be reached. */
5259 OP* pegop = newOP(OP_NULL, 0);
5262 PERL_UNUSED_ARG(floor);
5272 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
5274 NORETURN_FUNCTION_END;
5279 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
5281 return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
5285 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5292 register CV *cv = NULL;
5294 /* If the subroutine has no body, no attributes, and no builtin attributes
5295 then it's just a sub declaration, and we may be able to get away with
5296 storing with a placeholder scalar in the symbol table, rather than a
5297 full GV and CV. If anything is present then it will take a full CV to
5299 const I32 gv_fetch_flags
5300 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5302 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
5303 const char * const name = o ? SvPV_nolen_const(cSVOPo->op_sv) : NULL;
5306 assert(proto->op_type == OP_CONST);
5307 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
5312 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
5313 SV * const sv = sv_newmortal();
5314 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
5315 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
5316 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
5317 aname = SvPVX_const(sv);
5322 gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
5323 : gv_fetchpv(aname ? aname
5324 : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5325 gv_fetch_flags, SVt_PVCV);
5327 if (!PL_madskills) {
5336 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
5337 maximum a prototype before. */
5338 if (SvTYPE(gv) > SVt_NULL) {
5339 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
5340 && ckWARN_d(WARN_PROTOTYPE))
5342 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
5344 cv_ckproto_len((CV*)gv, NULL, ps, ps_len);
5347 sv_setpvn((SV*)gv, ps, ps_len);
5349 sv_setiv((SV*)gv, -1);
5351 SvREFCNT_dec(PL_compcv);
5352 cv = PL_compcv = NULL;
5356 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
5358 #ifdef GV_UNIQUE_CHECK
5359 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
5360 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
5364 if (!block || !ps || *ps || attrs
5365 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5367 || block->op_type == OP_NULL
5372 const_sv = op_const_sv(block, NULL);
5375 const bool exists = CvROOT(cv) || CvXSUB(cv);
5377 #ifdef GV_UNIQUE_CHECK
5378 if (exists && GvUNIQUE(gv)) {
5379 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
5383 /* if the subroutine doesn't exist and wasn't pre-declared
5384 * with a prototype, assume it will be AUTOLOADed,
5385 * skipping the prototype check
5387 if (exists || SvPOK(cv))
5388 cv_ckproto_len(cv, gv, ps, ps_len);
5389 /* already defined (or promised)? */
5390 if (exists || GvASSUMECV(gv)) {
5393 || block->op_type == OP_NULL
5396 if (CvFLAGS(PL_compcv)) {
5397 /* might have had built-in attrs applied */
5398 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5400 /* just a "sub foo;" when &foo is already defined */
5401 SAVEFREESV(PL_compcv);
5406 && block->op_type != OP_NULL
5409 if (ckWARN(WARN_REDEFINE)
5411 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
5413 const line_t oldline = CopLINE(PL_curcop);
5414 if (PL_parser && PL_parser->copline != NOLINE)
5415 CopLINE_set(PL_curcop, PL_parser->copline);
5416 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5417 CvCONST(cv) ? "Constant subroutine %s redefined"
5418 : "Subroutine %s redefined", name);
5419 CopLINE_set(PL_curcop, oldline);
5422 if (!PL_minus_c) /* keep old one around for madskills */
5425 /* (PL_madskills unset in used file.) */
5433 SvREFCNT_inc_simple_void_NN(const_sv);
5435 assert(!CvROOT(cv) && !CvCONST(cv));
5436 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
5437 CvXSUBANY(cv).any_ptr = const_sv;
5438 CvXSUB(cv) = const_sv_xsub;
5444 cv = newCONSTSUB(NULL, name, const_sv);
5446 mro_method_changed_in( /* sub Foo::Bar () { 123 } */
5447 (CvGV(cv) && GvSTASH(CvGV(cv)))
5456 SvREFCNT_dec(PL_compcv);
5464 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
5465 * before we clobber PL_compcv.
5469 || block->op_type == OP_NULL
5473 /* Might have had built-in attributes applied -- propagate them. */
5474 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5475 if (CvGV(cv) && GvSTASH(CvGV(cv)))
5476 stash = GvSTASH(CvGV(cv));
5477 else if (CvSTASH(cv))
5478 stash = CvSTASH(cv);
5480 stash = PL_curstash;
5483 /* possibly about to re-define existing subr -- ignore old cv */
5484 rcv = (SV*)PL_compcv;
5485 if (name && GvSTASH(gv))
5486 stash = GvSTASH(gv);
5488 stash = PL_curstash;
5490 apply_attrs(stash, rcv, attrs, FALSE);
5492 if (cv) { /* must reuse cv if autoloaded */
5499 || block->op_type == OP_NULL) && !PL_madskills
5502 /* got here with just attrs -- work done, so bug out */
5503 SAVEFREESV(PL_compcv);
5506 /* transfer PL_compcv to cv */
5508 CvFLAGS(cv) = CvFLAGS(PL_compcv);
5509 if (!CvWEAKOUTSIDE(cv))
5510 SvREFCNT_dec(CvOUTSIDE(cv));
5511 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
5512 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
5513 CvOUTSIDE(PL_compcv) = 0;
5514 CvPADLIST(cv) = CvPADLIST(PL_compcv);
5515 CvPADLIST(PL_compcv) = 0;
5516 /* inner references to PL_compcv must be fixed up ... */
5517 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
5518 /* ... before we throw it away */
5519 SvREFCNT_dec(PL_compcv);
5521 if (PERLDB_INTER)/* Advice debugger on the new sub. */
5522 ++PL_sub_generation;
5529 if (strEQ(name, "import")) {
5530 PL_formfeed = (SV*)cv;
5531 Perl_warner(aTHX_ packWARN(WARN_VOID), "%lx\n", (long)cv);
5535 mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */
5539 CvFILE_set_from_cop(cv, PL_curcop);
5540 CvSTASH(cv) = PL_curstash;
5543 sv_setpvn((SV*)cv, ps, ps_len);
5545 if (PL_parser && PL_parser->error_count) {
5549 const char *s = strrchr(name, ':');
5551 if (strEQ(s, "BEGIN")) {
5552 const char not_safe[] =
5553 "BEGIN not safe after errors--compilation aborted";
5554 if (PL_in_eval & EVAL_KEEPERR)
5555 Perl_croak(aTHX_ not_safe);
5557 /* force display of errors found but not reported */
5558 sv_catpv(ERRSV, not_safe);
5559 Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
5569 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5570 mod(scalarseq(block), OP_LEAVESUBLV));
5571 block->op_attached = 1;
5574 /* This makes sub {}; work as expected. */
5575 if (block->op_type == OP_STUB) {
5576 OP* const newblock = newSTATEOP(0, NULL, 0);
5578 op_getmad(block,newblock,'B');
5585 block->op_attached = 1;
5586 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5588 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5589 OpREFCNT_set(CvROOT(cv), 1);
5590 CvSTART(cv) = LINKLIST(CvROOT(cv));
5591 CvROOT(cv)->op_next = 0;
5592 CALL_PEEP(CvSTART(cv));
5594 /* now that optimizer has done its work, adjust pad values */
5596 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
5599 assert(!CvCONST(cv));
5600 if (ps && !*ps && op_const_sv(block, cv))
5604 if (name || aname) {
5605 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5606 SV * const sv = newSV(0);
5607 SV * const tmpstr = sv_newmortal();
5608 GV * const db_postponed = gv_fetchpvs("DB::postponed",
5609 GV_ADDMULTI, SVt_PVHV);
5612 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5614 (long)PL_subline, (long)CopLINE(PL_curcop));
5615 gv_efullname3(tmpstr, gv, NULL);
5616 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
5617 SvCUR(tmpstr), sv, 0);
5618 hv = GvHVn(db_postponed);
5619 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
5620 CV * const pcv = GvCV(db_postponed);
5626 call_sv((SV*)pcv, G_DISCARD);
5631 if (name && ! (PL_parser && PL_parser->error_count))
5632 process_special_blocks(name, gv, cv);
5637 PL_parser->copline = NOLINE;
5643 S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
5646 const char *const colon = strrchr(fullname,':');
5647 const char *const name = colon ? colon + 1 : fullname;
5650 if (strEQ(name, "BEGIN")) {
5651 const I32 oldscope = PL_scopestack_ix;
5653 SAVECOPFILE(&PL_compiling);
5654 SAVECOPLINE(&PL_compiling);
5656 DEBUG_x( dump_sub(gv) );
5657 Perl_av_create_and_push(aTHX_ &PL_beginav, (SV*)cv);
5658 GvCV(gv) = 0; /* cv has been hijacked */
5659 call_list(oldscope, PL_beginav);
5661 PL_curcop = &PL_compiling;
5662 CopHINTS_set(&PL_compiling, PL_hints);
5669 if strEQ(name, "END") {
5670 DEBUG_x( dump_sub(gv) );
5671 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, (SV*)cv);
5674 } else if (*name == 'U') {
5675 if (strEQ(name, "UNITCHECK")) {
5676 /* It's never too late to run a unitcheck block */
5677 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, (SV*)cv);
5681 } else if (*name == 'C') {
5682 if (strEQ(name, "CHECK")) {
5683 if (PL_main_start && ckWARN(WARN_VOID))
5684 Perl_warner(aTHX_ packWARN(WARN_VOID),
5685 "Too late to run CHECK block");
5686 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, (SV*)cv);
5690 } else if (*name == 'I') {
5691 if (strEQ(name, "INIT")) {
5692 if (PL_main_start && ckWARN(WARN_VOID))
5693 Perl_warner(aTHX_ packWARN(WARN_VOID),
5694 "Too late to run INIT block");
5695 Perl_av_create_and_push(aTHX_ &PL_initav, (SV*)cv);
5701 DEBUG_x( dump_sub(gv) );
5702 GvCV(gv) = 0; /* cv has been hijacked */
5707 =for apidoc newCONSTSUB
5709 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5710 eligible for inlining at compile-time.
5716 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
5721 const char *const temp_p = CopFILE(PL_curcop);
5722 const STRLEN len = temp_p ? strlen(temp_p) : 0;
5724 SV *const temp_sv = CopFILESV(PL_curcop);
5726 const char *const temp_p = temp_sv ? SvPV_const(temp_sv, len) : NULL;
5728 char *const file = savepvn(temp_p, temp_p ? len : 0);
5732 if (IN_PERL_RUNTIME) {
5733 /* at runtime, it's not safe to manipulate PL_curcop: it may be
5734 * an op shared between threads. Use a non-shared COP for our
5736 SAVEVPTR(PL_curcop);
5737 PL_curcop = &PL_compiling;
5739 SAVECOPLINE(PL_curcop);
5740 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
5743 PL_hints &= ~HINT_BLOCK_SCOPE;
5746 SAVESPTR(PL_curstash);
5747 SAVECOPSTASH(PL_curcop);
5748 PL_curstash = stash;
5749 CopSTASH_set(PL_curcop,stash);
5752 /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
5753 and so doesn't get free()d. (It's expected to be from the C pre-
5754 processor __FILE__ directive). But we need a dynamically allocated one,
5755 and we need it to get freed. */
5756 cv = newXS_flags(name, const_sv_xsub, file, "", XS_DYNAMIC_FILENAME);
5757 CvXSUBANY(cv).any_ptr = sv;
5763 CopSTASH_free(PL_curcop);
5771 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
5772 const char *const filename, const char *const proto,
5775 CV *cv = newXS(name, subaddr, filename);
5777 if (flags & XS_DYNAMIC_FILENAME) {
5778 /* We need to "make arrangements" (ie cheat) to ensure that the
5779 filename lasts as long as the PVCV we just created, but also doesn't
5781 STRLEN filename_len = strlen(filename);
5782 STRLEN proto_and_file_len = filename_len;
5783 char *proto_and_file;
5787 proto_len = strlen(proto);
5788 proto_and_file_len += proto_len;
5790 Newx(proto_and_file, proto_and_file_len + 1, char);
5791 Copy(proto, proto_and_file, proto_len, char);
5792 Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
5795 proto_and_file = savepvn(filename, filename_len);
5798 /* This gets free()d. :-) */
5799 sv_usepvn_flags((SV*)cv, proto_and_file, proto_and_file_len,
5800 SV_HAS_TRAILING_NUL);
5802 /* This gives us the correct prototype, rather than one with the
5803 file name appended. */
5804 SvCUR_set(cv, proto_len);
5808 CvFILE(cv) = proto_and_file + proto_len;
5810 sv_setpv((SV *)cv, proto);
5816 =for apidoc U||newXS
5818 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
5819 static storage, as it is used directly as CvFILE(), without a copy being made.
5825 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
5828 GV * const gv = gv_fetchpv(name ? name :
5829 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5830 GV_ADDMULTI, SVt_PVCV);
5834 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
5836 if ((cv = (name ? GvCV(gv) : NULL))) {
5838 /* just a cached method */
5842 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5843 /* already defined (or promised) */
5844 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
5845 if (ckWARN(WARN_REDEFINE)) {
5846 GV * const gvcv = CvGV(cv);
5848 HV * const stash = GvSTASH(gvcv);
5850 const char *redefined_name = HvNAME_get(stash);
5851 if ( strEQ(redefined_name,"autouse") ) {
5852 const line_t oldline = CopLINE(PL_curcop);
5853 if (PL_parser && PL_parser->copline != NOLINE)
5854 CopLINE_set(PL_curcop, PL_parser->copline);
5855 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5856 CvCONST(cv) ? "Constant subroutine %s redefined"
5857 : "Subroutine %s redefined"
5859 CopLINE_set(PL_curcop, oldline);
5869 if (cv) /* must reuse cv if autoloaded */
5872 cv = (CV*)newSV_type(SVt_PVCV);
5876 mro_method_changed_in(GvSTASH(gv)); /* newXS */
5880 (void)gv_fetchfile(filename);
5881 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
5882 an external constant string */
5884 CvXSUB(cv) = subaddr;
5887 process_special_blocks(name, gv, cv);
5899 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5904 OP* pegop = newOP(OP_NULL, 0);
5908 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
5909 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
5911 #ifdef GV_UNIQUE_CHECK
5913 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5917 if ((cv = GvFORM(gv))) {
5918 if (ckWARN(WARN_REDEFINE)) {
5919 const line_t oldline = CopLINE(PL_curcop);
5920 if (PL_parser && PL_parser->copline != NOLINE)
5921 CopLINE_set(PL_curcop, PL_parser->copline);
5922 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5923 o ? "Format %"SVf" redefined"
5924 : "Format STDOUT redefined", SVfARG(cSVOPo->op_sv));
5925 CopLINE_set(PL_curcop, oldline);
5932 CvFILE_set_from_cop(cv, PL_curcop);
5935 pad_tidy(padtidy_FORMAT);
5936 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5937 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5938 OpREFCNT_set(CvROOT(cv), 1);
5939 CvSTART(cv) = LINKLIST(CvROOT(cv));
5940 CvROOT(cv)->op_next = 0;
5941 CALL_PEEP(CvSTART(cv));
5943 op_getmad(o,pegop,'n');
5944 op_getmad_weak(block, pegop, 'b');
5949 PL_parser->copline = NOLINE;
5957 Perl_newANONLIST(pTHX_ OP *o)
5959 return convert(OP_ANONLIST, OPf_SPECIAL, o);
5963 Perl_newANONHASH(pTHX_ OP *o)
5965 return convert(OP_ANONHASH, OPf_SPECIAL, o);
5969 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5971 return newANONATTRSUB(floor, proto, NULL, block);
5975 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5977 return newUNOP(OP_REFGEN, 0,
5978 newSVOP(OP_ANONCODE, 0,
5979 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5983 Perl_oopsAV(pTHX_ OP *o)
5986 switch (o->op_type) {
5988 o->op_type = OP_PADAV;
5989 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5990 return ref(o, OP_RV2AV);
5993 o->op_type = OP_RV2AV;
5994 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5999 if (ckWARN_d(WARN_INTERNAL))
6000 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
6007 Perl_oopsHV(pTHX_ OP *o)
6010 switch (o->op_type) {
6013 o->op_type = OP_PADHV;
6014 o->op_ppaddr = PL_ppaddr[OP_PADHV];
6015 return ref(o, OP_RV2HV);
6019 o->op_type = OP_RV2HV;
6020 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
6025 if (ckWARN_d(WARN_INTERNAL))
6026 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
6033 Perl_newAVREF(pTHX_ OP *o)
6036 if (o->op_type == OP_PADANY) {
6037 o->op_type = OP_PADAV;
6038 o->op_ppaddr = PL_ppaddr[OP_PADAV];
6041 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
6042 && ckWARN(WARN_DEPRECATED)) {
6043 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
6044 "Using an array as a reference is deprecated");
6046 return newUNOP(OP_RV2AV, 0, scalar(o));
6050 Perl_newGVREF(pTHX_ I32 type, OP *o)
6052 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
6053 return newUNOP(OP_NULL, 0, o);
6054 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
6058 Perl_newHVREF(pTHX_ OP *o)
6061 if (o->op_type == OP_PADANY) {
6062 o->op_type = OP_PADHV;
6063 o->op_ppaddr = PL_ppaddr[OP_PADHV];
6066 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
6067 && ckWARN(WARN_DEPRECATED)) {
6068 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
6069 "Using a hash as a reference is deprecated");
6071 return newUNOP(OP_RV2HV, 0, scalar(o));
6075 Perl_newCVREF(pTHX_ I32 flags, OP *o)
6077 return newUNOP(OP_RV2CV, flags, scalar(o));
6081 Perl_newSVREF(pTHX_ OP *o)
6084 if (o->op_type == OP_PADANY) {
6085 o->op_type = OP_PADSV;
6086 o->op_ppaddr = PL_ppaddr[OP_PADSV];
6089 return newUNOP(OP_RV2SV, 0, scalar(o));
6092 /* Check routines. See the comments at the top of this file for details
6093 * on when these are called */
6096 Perl_ck_anoncode(pTHX_ OP *o)
6098 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
6100 cSVOPo->op_sv = NULL;
6105 Perl_ck_bitop(pTHX_ OP *o)
6108 #define OP_IS_NUMCOMPARE(op) \
6109 ((op) == OP_LT || (op) == OP_I_LT || \
6110 (op) == OP_GT || (op) == OP_I_GT || \
6111 (op) == OP_LE || (op) == OP_I_LE || \
6112 (op) == OP_GE || (op) == OP_I_GE || \
6113 (op) == OP_EQ || (op) == OP_I_EQ || \
6114 (op) == OP_NE || (op) == OP_I_NE || \
6115 (op) == OP_NCMP || (op) == OP_I_NCMP)
6116 o->op_private = (U8)(PL_hints & HINT_INTEGER);
6117 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
6118 && (o->op_type == OP_BIT_OR
6119 || o->op_type == OP_BIT_AND
6120 || o->op_type == OP_BIT_XOR))
6122 const OP * const left = cBINOPo->op_first;
6123 const OP * const right = left->op_sibling;
6124 if ((OP_IS_NUMCOMPARE(left->op_type) &&
6125 (left->op_flags & OPf_PARENS) == 0) ||
6126 (OP_IS_NUMCOMPARE(right->op_type) &&
6127 (right->op_flags & OPf_PARENS) == 0))
6128 if (ckWARN(WARN_PRECEDENCE))
6129 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
6130 "Possible precedence problem on bitwise %c operator",
6131 o->op_type == OP_BIT_OR ? '|'
6132 : o->op_type == OP_BIT_AND ? '&' : '^'
6139 Perl_ck_concat(pTHX_ OP *o)
6141 const OP * const kid = cUNOPo->op_first;
6142 PERL_UNUSED_CONTEXT;
6143 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
6144 !(kUNOP->op_first->op_flags & OPf_MOD))
6145 o->op_flags |= OPf_STACKED;
6150 Perl_ck_spair(pTHX_ OP *o)
6153 if (o->op_flags & OPf_KIDS) {
6156 const OPCODE type = o->op_type;
6157 o = modkids(ck_fun(o), type);
6158 kid = cUNOPo->op_first;
6159 newop = kUNOP->op_first->op_sibling;
6161 const OPCODE type = newop->op_type;
6162 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
6163 type == OP_PADAV || type == OP_PADHV ||
6164 type == OP_RV2AV || type == OP_RV2HV)
6168 op_getmad(kUNOP->op_first,newop,'K');
6170 op_free(kUNOP->op_first);
6172 kUNOP->op_first = newop;
6174 o->op_ppaddr = PL_ppaddr[++o->op_type];
6179 Perl_ck_delete(pTHX_ OP *o)
6183 if (o->op_flags & OPf_KIDS) {
6184 OP * const kid = cUNOPo->op_first;
6185 switch (kid->op_type) {
6187 o->op_flags |= OPf_SPECIAL;
6190 o->op_private |= OPpSLICE;
6193 o->op_flags |= OPf_SPECIAL;
6198 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
6207 Perl_ck_die(pTHX_ OP *o)
6210 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6216 Perl_ck_eof(pTHX_ OP *o)
6220 if (o->op_flags & OPf_KIDS) {
6221 if (cLISTOPo->op_first->op_type == OP_STUB) {
6223 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
6225 op_getmad(o,newop,'O');
6237 Perl_ck_eval(pTHX_ OP *o)
6240 PL_hints |= HINT_BLOCK_SCOPE;
6241 if (o->op_flags & OPf_KIDS) {
6242 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6245 o->op_flags &= ~OPf_KIDS;
6248 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
6254 cUNOPo->op_first = 0;
6259 NewOp(1101, enter, 1, LOGOP);
6260 enter->op_type = OP_ENTERTRY;
6261 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
6262 enter->op_private = 0;
6264 /* establish postfix order */
6265 enter->op_next = (OP*)enter;
6267 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
6268 o->op_type = OP_LEAVETRY;
6269 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
6270 enter->op_other = o;
6271 op_getmad(oldo,o,'O');
6285 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
6286 op_getmad(oldo,o,'O');
6288 o->op_targ = (PADOFFSET)PL_hints;
6289 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
6290 /* Store a copy of %^H that pp_entereval can pick up.
6291 OPf_SPECIAL flags the opcode as being for this purpose,
6292 so that it in turn will return a copy at every
6294 OP *hhop = newSVOP(OP_CONST, OPf_SPECIAL,
6295 (SV*)Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv)));
6296 cUNOPo->op_first->op_sibling = hhop;
6297 o->op_private |= OPpEVAL_HAS_HH;
6303 Perl_ck_exit(pTHX_ OP *o)
6306 HV * const table = GvHV(PL_hintgv);
6308 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
6309 if (svp && *svp && SvTRUE(*svp))
6310 o->op_private |= OPpEXIT_VMSISH;
6312 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6318 Perl_ck_exec(pTHX_ OP *o)
6320 if (o->op_flags & OPf_STACKED) {
6323 kid = cUNOPo->op_first->op_sibling;
6324 if (kid->op_type == OP_RV2GV)
6333 Perl_ck_exists(pTHX_ OP *o)
6337 if (o->op_flags & OPf_KIDS) {
6338 OP * const kid = cUNOPo->op_first;
6339 if (kid->op_type == OP_ENTERSUB) {
6340 (void) ref(kid, o->op_type);
6341 if (kid->op_type != OP_RV2CV
6342 && !(PL_parser && PL_parser->error_count))
6343 Perl_croak(aTHX_ "%s argument is not a subroutine name",
6345 o->op_private |= OPpEXISTS_SUB;
6347 else if (kid->op_type == OP_AELEM)
6348 o->op_flags |= OPf_SPECIAL;
6349 else if (kid->op_type != OP_HELEM)
6350 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
6358 Perl_ck_rvconst(pTHX_ register OP *o)
6361 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6363 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6364 if (o->op_type == OP_RV2CV)
6365 o->op_private &= ~1;
6367 if (kid->op_type == OP_CONST) {
6370 SV * const kidsv = kid->op_sv;
6372 /* Is it a constant from cv_const_sv()? */
6373 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
6374 SV * const rsv = SvRV(kidsv);
6375 const svtype type = SvTYPE(rsv);
6376 const char *badtype = NULL;
6378 switch (o->op_type) {
6380 if (type > SVt_PVMG)
6381 badtype = "a SCALAR";
6384 if (type != SVt_PVAV)
6385 badtype = "an ARRAY";
6388 if (type != SVt_PVHV)
6392 if (type != SVt_PVCV)
6397 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
6400 else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
6401 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
6402 /* If this is an access to a stash, disable "strict refs", because
6403 * stashes aren't auto-vivified at compile-time (unless we store
6404 * symbols in them), and we don't want to produce a run-time
6405 * stricture error when auto-vivifying the stash. */
6406 const char *s = SvPV_nolen(kidsv);
6407 const STRLEN l = SvCUR(kidsv);
6408 if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
6409 o->op_private &= ~HINT_STRICT_REFS;
6411 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
6412 const char *badthing;
6413 switch (o->op_type) {
6415 badthing = "a SCALAR";
6418 badthing = "an ARRAY";
6421 badthing = "a HASH";
6429 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
6430 SVfARG(kidsv), badthing);
6433 * This is a little tricky. We only want to add the symbol if we
6434 * didn't add it in the lexer. Otherwise we get duplicate strict
6435 * warnings. But if we didn't add it in the lexer, we must at
6436 * least pretend like we wanted to add it even if it existed before,
6437 * or we get possible typo warnings. OPpCONST_ENTERED says
6438 * whether the lexer already added THIS instance of this symbol.
6440 iscv = (o->op_type == OP_RV2CV) * 2;
6442 gv = gv_fetchsv(kidsv,
6443 iscv | !(kid->op_private & OPpCONST_ENTERED),
6446 : o->op_type == OP_RV2SV
6448 : o->op_type == OP_RV2AV
6450 : o->op_type == OP_RV2HV
6453 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
6455 kid->op_type = OP_GV;
6456 SvREFCNT_dec(kid->op_sv);
6458 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
6459 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
6460 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
6462 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc_simple_NN(gv));
6464 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
6466 kid->op_private = 0;
6467 kid->op_ppaddr = PL_ppaddr[OP_GV];
6474 Perl_ck_ftst(pTHX_ OP *o)
6477 const I32 type = o->op_type;
6479 if (o->op_flags & OPf_REF) {
6482 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
6483 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6484 const OPCODE kidtype = kid->op_type;
6486 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6487 OP * const newop = newGVOP(type, OPf_REF,
6488 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
6490 op_getmad(o,newop,'O');
6496 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o))
6497 o->op_private |= OPpFT_ACCESS;
6498 if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst)
6499 && kidtype != OP_STAT && kidtype != OP_LSTAT)
6500 o->op_private |= OPpFT_STACKED;
6508 if (type == OP_FTTTY)
6509 o = newGVOP(type, OPf_REF, PL_stdingv);
6511 o = newUNOP(type, 0, newDEFSVOP());
6512 op_getmad(oldo,o,'O');
6518 Perl_ck_fun(pTHX_ OP *o)
6521 const int type = o->op_type;
6522 register I32 oa = PL_opargs[type] >> OASHIFT;
6524 if (o->op_flags & OPf_STACKED) {
6525 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
6528 return no_fh_allowed(o);
6531 if (o->op_flags & OPf_KIDS) {
6532 OP **tokid = &cLISTOPo->op_first;
6533 register OP *kid = cLISTOPo->op_first;
6537 if (kid->op_type == OP_PUSHMARK ||
6538 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
6540 tokid = &kid->op_sibling;
6541 kid = kid->op_sibling;
6543 if (!kid && PL_opargs[type] & OA_DEFGV)
6544 *tokid = kid = newDEFSVOP();
6548 sibl = kid->op_sibling;
6550 if (!sibl && kid->op_type == OP_STUB) {
6557 /* list seen where single (scalar) arg expected? */
6558 if (numargs == 1 && !(oa >> 4)
6559 && kid->op_type == OP_LIST && type != OP_SCALAR)
6561 return too_many_arguments(o,PL_op_desc[type]);
6574 if ((type == OP_PUSH || type == OP_UNSHIFT)
6575 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
6576 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6577 "Useless use of %s with no values",
6580 if (kid->op_type == OP_CONST &&
6581 (kid->op_private & OPpCONST_BARE))
6583 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
6584 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
6585 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6586 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6587 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
6588 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6590 op_getmad(kid,newop,'K');
6595 kid->op_sibling = sibl;
6598 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
6599 bad_type(numargs, "array", PL_op_desc[type], kid);
6603 if (kid->op_type == OP_CONST &&
6604 (kid->op_private & OPpCONST_BARE))
6606 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
6607 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
6608 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6609 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6610 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
6611 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6613 op_getmad(kid,newop,'K');
6618 kid->op_sibling = sibl;
6621 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
6622 bad_type(numargs, "hash", PL_op_desc[type], kid);
6627 OP * const newop = newUNOP(OP_NULL, 0, kid);
6628 kid->op_sibling = 0;
6630 newop->op_next = newop;
6632 kid->op_sibling = sibl;
6637 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
6638 if (kid->op_type == OP_CONST &&
6639 (kid->op_private & OPpCONST_BARE))
6641 OP * const newop = newGVOP(OP_GV, 0,
6642 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
6643 if (!(o->op_private & 1) && /* if not unop */
6644 kid == cLISTOPo->op_last)
6645 cLISTOPo->op_last = newop;
6647 op_getmad(kid,newop,'K');
6653 else if (kid->op_type == OP_READLINE) {
6654 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
6655 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
6658 I32 flags = OPf_SPECIAL;
6662 /* is this op a FH constructor? */
6663 if (is_handle_constructor(o,numargs)) {
6664 const char *name = NULL;
6668 /* Set a flag to tell rv2gv to vivify
6669 * need to "prove" flag does not mean something
6670 * else already - NI-S 1999/05/07
6673 if (kid->op_type == OP_PADSV) {
6675 = PAD_COMPNAME_SV(kid->op_targ);
6676 name = SvPV_const(namesv, len);
6678 else if (kid->op_type == OP_RV2SV
6679 && kUNOP->op_first->op_type == OP_GV)
6681 GV * const gv = cGVOPx_gv(kUNOP->op_first);
6683 len = GvNAMELEN(gv);
6685 else if (kid->op_type == OP_AELEM
6686 || kid->op_type == OP_HELEM)
6689 OP *op = ((BINOP*)kid)->op_first;
6693 const char * const a =
6694 kid->op_type == OP_AELEM ?
6696 if (((op->op_type == OP_RV2AV) ||
6697 (op->op_type == OP_RV2HV)) &&
6698 (firstop = ((UNOP*)op)->op_first) &&
6699 (firstop->op_type == OP_GV)) {
6700 /* packagevar $a[] or $h{} */
6701 GV * const gv = cGVOPx_gv(firstop);
6709 else if (op->op_type == OP_PADAV
6710 || op->op_type == OP_PADHV) {
6711 /* lexicalvar $a[] or $h{} */
6712 const char * const padname =
6713 PAD_COMPNAME_PV(op->op_targ);
6722 name = SvPV_const(tmpstr, len);
6727 name = "__ANONIO__";
6734 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
6735 namesv = PAD_SVl(targ);
6736 SvUPGRADE(namesv, SVt_PV);
6738 sv_setpvn(namesv, "$", 1);
6739 sv_catpvn(namesv, name, len);
6742 kid->op_sibling = 0;
6743 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
6744 kid->op_targ = targ;
6745 kid->op_private |= priv;
6747 kid->op_sibling = sibl;
6753 mod(scalar(kid), type);
6757 tokid = &kid->op_sibling;
6758 kid = kid->op_sibling;
6761 if (kid && kid->op_type != OP_STUB)
6762 return too_many_arguments(o,OP_DESC(o));
6763 o->op_private |= numargs;
6765 /* FIXME - should the numargs move as for the PERL_MAD case? */
6766 o->op_private |= numargs;
6768 return too_many_arguments(o,OP_DESC(o));
6772 else if (PL_opargs[type] & OA_DEFGV) {
6774 OP *newop = newUNOP(type, 0, newDEFSVOP());
6775 op_getmad(o,newop,'O');
6778 /* Ordering of these two is important to keep f_map.t passing. */
6780 return newUNOP(type, 0, newDEFSVOP());
6785 while (oa & OA_OPTIONAL)
6787 if (oa && oa != OA_LIST)
6788 return too_few_arguments(o,OP_DESC(o));
6794 Perl_ck_glob(pTHX_ OP *o)
6800 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
6801 append_elem(OP_GLOB, o, newDEFSVOP());
6803 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
6804 && GvCVu(gv) && GvIMPORTED_CV(gv)))
6806 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6809 #if !defined(PERL_EXTERNAL_GLOB)
6810 /* XXX this can be tightened up and made more failsafe. */
6811 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
6814 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
6815 newSVpvs("File::Glob"), NULL, NULL, NULL);
6816 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6817 glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
6818 GvCV(gv) = GvCV(glob_gv);
6819 SvREFCNT_inc_void((SV*)GvCV(gv));
6820 GvIMPORTED_CV_on(gv);
6823 #endif /* PERL_EXTERNAL_GLOB */
6825 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6826 append_elem(OP_GLOB, o,
6827 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
6828 o->op_type = OP_LIST;
6829 o->op_ppaddr = PL_ppaddr[OP_LIST];
6830 cLISTOPo->op_first->op_type = OP_PUSHMARK;
6831 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
6832 cLISTOPo->op_first->op_targ = 0;
6833 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
6834 append_elem(OP_LIST, o,
6835 scalar(newUNOP(OP_RV2CV, 0,
6836 newGVOP(OP_GV, 0, gv)))));
6837 o = newUNOP(OP_NULL, 0, ck_subr(o));
6838 o->op_targ = OP_GLOB; /* hint at what it used to be */
6841 gv = newGVgen("main");
6843 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
6849 Perl_ck_grep(pTHX_ OP *o)
6854 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
6857 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
6858 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
6860 if (o->op_flags & OPf_STACKED) {
6863 kid = cLISTOPo->op_first->op_sibling;
6864 if (!cUNOPx(kid)->op_next)
6865 Perl_croak(aTHX_ "panic: ck_grep");
6866 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
6869 NewOp(1101, gwop, 1, LOGOP);
6870 kid->op_next = (OP*)gwop;
6871 o->op_flags &= ~OPf_STACKED;
6873 kid = cLISTOPo->op_first->op_sibling;
6874 if (type == OP_MAPWHILE)
6879 if (PL_parser && PL_parser->error_count)
6881 kid = cLISTOPo->op_first->op_sibling;
6882 if (kid->op_type != OP_NULL)
6883 Perl_croak(aTHX_ "panic: ck_grep");
6884 kid = kUNOP->op_first;
6887 NewOp(1101, gwop, 1, LOGOP);
6888 gwop->op_type = type;
6889 gwop->op_ppaddr = PL_ppaddr[type];
6890 gwop->op_first = listkids(o);
6891 gwop->op_flags |= OPf_KIDS;
6892 gwop->op_other = LINKLIST(kid);
6893 kid->op_next = (OP*)gwop;
6894 offset = pad_findmy("$_");
6895 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
6896 o->op_private = gwop->op_private = 0;
6897 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
6900 o->op_private = gwop->op_private = OPpGREP_LEX;
6901 gwop->op_targ = o->op_targ = offset;
6904 kid = cLISTOPo->op_first->op_sibling;
6905 if (!kid || !kid->op_sibling)
6906 return too_few_arguments(o,OP_DESC(o));
6907 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
6908 mod(kid, OP_GREPSTART);
6914 Perl_ck_index(pTHX_ OP *o)
6916 if (o->op_flags & OPf_KIDS) {
6917 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6919 kid = kid->op_sibling; /* get past "big" */
6920 if (kid && kid->op_type == OP_CONST)
6921 fbm_compile(((SVOP*)kid)->op_sv, 0);
6927 Perl_ck_lengthconst(pTHX_ OP *o)
6929 /* XXX length optimization goes here */
6934 Perl_ck_lfun(pTHX_ OP *o)
6936 const OPCODE type = o->op_type;
6937 return modkids(ck_fun(o), type);
6941 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
6943 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
6944 switch (cUNOPo->op_first->op_type) {
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 case OP_AASSIGN: /* Is this a good idea? */
6953 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6954 "defined(@array) is deprecated");
6955 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6956 "\t(Maybe you should just omit the defined()?)\n");
6959 /* This is needed for
6960 if (defined %stash::)
6961 to work. Do not break Tk.
6963 break; /* Globals via GV can be undef */
6965 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6966 "defined(%%hash) is deprecated");
6967 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6968 "\t(Maybe you should just omit the defined()?)\n");
6979 Perl_ck_readline(pTHX_ OP *o)
6981 if (!(o->op_flags & OPf_KIDS)) {
6983 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
6985 op_getmad(o,newop,'O');
6995 Perl_ck_rfun(pTHX_ OP *o)
6997 const OPCODE type = o->op_type;
6998 return refkids(ck_fun(o), type);
7002 Perl_ck_listiob(pTHX_ OP *o)
7006 kid = cLISTOPo->op_first;
7009 kid = cLISTOPo->op_first;
7011 if (kid->op_type == OP_PUSHMARK)
7012 kid = kid->op_sibling;
7013 if (kid && o->op_flags & OPf_STACKED)
7014 kid = kid->op_sibling;
7015 else if (kid && !kid->op_sibling) { /* print HANDLE; */
7016 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
7017 o->op_flags |= OPf_STACKED; /* make it a filehandle */
7018 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
7019 cLISTOPo->op_first->op_sibling = kid;
7020 cLISTOPo->op_last = kid;
7021 kid = kid->op_sibling;
7026 append_elem(o->op_type, o, newDEFSVOP());
7032 Perl_ck_smartmatch(pTHX_ OP *o)
7035 if (0 == (o->op_flags & OPf_SPECIAL)) {
7036 OP *first = cBINOPo->op_first;
7037 OP *second = first->op_sibling;
7039 /* Implicitly take a reference to an array or hash */
7040 first->op_sibling = NULL;
7041 first = cBINOPo->op_first = ref_array_or_hash(first);
7042 second = first->op_sibling = ref_array_or_hash(second);
7044 /* Implicitly take a reference to a regular expression */
7045 if (first->op_type == OP_MATCH) {
7046 first->op_type = OP_QR;
7047 first->op_ppaddr = PL_ppaddr[OP_QR];
7049 if (second->op_type == OP_MATCH) {
7050 second->op_type = OP_QR;
7051 second->op_ppaddr = PL_ppaddr[OP_QR];
7060 Perl_ck_sassign(pTHX_ OP *o)
7063 OP * const kid = cLISTOPo->op_first;
7064 /* has a disposable target? */
7065 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
7066 && !(kid->op_flags & OPf_STACKED)
7067 /* Cannot steal the second time! */
7068 && !(kid->op_private & OPpTARGET_MY)
7069 /* Keep the full thing for madskills */
7073 OP * const kkid = kid->op_sibling;
7075 /* Can just relocate the target. */
7076 if (kkid && kkid->op_type == OP_PADSV
7077 && !(kkid->op_private & OPpLVAL_INTRO))
7079 kid->op_targ = kkid->op_targ;
7081 /* Now we do not need PADSV and SASSIGN. */
7082 kid->op_sibling = o->op_sibling; /* NULL */
7083 cLISTOPo->op_first = NULL;
7086 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
7090 if (kid->op_sibling) {
7091 OP *kkid = kid->op_sibling;
7092 if (kkid->op_type == OP_PADSV
7093 && (kkid->op_private & OPpLVAL_INTRO)
7094 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
7095 const PADOFFSET target = kkid->op_targ;
7096 OP *const other = newOP(OP_PADSV,
7098 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
7099 OP *const first = newOP(OP_NULL, 0);
7100 OP *const nullop = newCONDOP(0, first, o, other);
7101 OP *const condop = first->op_next;
7102 /* hijacking PADSTALE for uninitialized state variables */
7103 SvPADSTALE_on(PAD_SVl(target));
7105 condop->op_type = OP_ONCE;
7106 condop->op_ppaddr = PL_ppaddr[OP_ONCE];
7107 condop->op_targ = target;
7108 other->op_targ = target;
7110 /* Because we change the type of the op here, we will skip the
7111 assinment binop->op_last = binop->op_first->op_sibling; at the
7112 end of Perl_newBINOP(). So need to do it here. */
7113 cBINOPo->op_last = cBINOPo->op_first->op_sibling;
7122 Perl_ck_match(pTHX_ OP *o)
7125 if (o->op_type != OP_QR && PL_compcv) {
7126 const PADOFFSET offset = pad_findmy("$_");
7127 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
7128 o->op_targ = offset;
7129 o->op_private |= OPpTARGET_MY;
7132 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
7133 o->op_private |= OPpRUNTIME;
7138 Perl_ck_method(pTHX_ OP *o)
7140 OP * const kid = cUNOPo->op_first;
7141 if (kid->op_type == OP_CONST) {
7142 SV* sv = kSVOP->op_sv;
7143 const char * const method = SvPVX_const(sv);
7144 if (!(strchr(method, ':') || strchr(method, '\''))) {
7146 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
7147 sv = newSVpvn_share(method, SvCUR(sv), 0);
7150 kSVOP->op_sv = NULL;
7152 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
7154 op_getmad(o,cmop,'O');
7165 Perl_ck_null(pTHX_ OP *o)
7167 PERL_UNUSED_CONTEXT;
7172 Perl_ck_open(pTHX_ OP *o)
7175 HV * const table = GvHV(PL_hintgv);
7177 SV **svp = hv_fetchs(table, "open_IN", FALSE);
7179 const I32 mode = mode_from_discipline(*svp);
7180 if (mode & O_BINARY)
7181 o->op_private |= OPpOPEN_IN_RAW;
7182 else if (mode & O_TEXT)
7183 o->op_private |= OPpOPEN_IN_CRLF;
7186 svp = hv_fetchs(table, "open_OUT", FALSE);
7188 const I32 mode = mode_from_discipline(*svp);
7189 if (mode & O_BINARY)
7190 o->op_private |= OPpOPEN_OUT_RAW;
7191 else if (mode & O_TEXT)
7192 o->op_private |= OPpOPEN_OUT_CRLF;
7195 if (o->op_type == OP_BACKTICK) {
7196 if (!(o->op_flags & OPf_KIDS)) {
7197 OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
7199 op_getmad(o,newop,'O');
7208 /* In case of three-arg dup open remove strictness
7209 * from the last arg if it is a bareword. */
7210 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
7211 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
7215 if ((last->op_type == OP_CONST) && /* The bareword. */
7216 (last->op_private & OPpCONST_BARE) &&
7217 (last->op_private & OPpCONST_STRICT) &&
7218 (oa = first->op_sibling) && /* The fh. */
7219 (oa = oa->op_sibling) && /* The mode. */
7220 (oa->op_type == OP_CONST) &&
7221 SvPOK(((SVOP*)oa)->op_sv) &&
7222 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
7223 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
7224 (last == oa->op_sibling)) /* The bareword. */
7225 last->op_private &= ~OPpCONST_STRICT;
7231 Perl_ck_repeat(pTHX_ OP *o)
7233 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
7234 o->op_private |= OPpREPEAT_DOLIST;
7235 cBINOPo->op_first = force_list(cBINOPo->op_first);
7243 Perl_ck_require(pTHX_ OP *o)
7248 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
7249 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7251 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
7252 SV * const sv = kid->op_sv;
7253 U32 was_readonly = SvREADONLY(sv);
7260 sv_force_normal_flags(sv, 0);
7261 assert(!SvREADONLY(sv));
7271 for (; s < end; s++) {
7272 if (*s == ':' && s[1] == ':') {
7274 Move(s+2, s+1, end - s - 1, char);
7279 sv_catpvs(sv, ".pm");
7280 SvFLAGS(sv) |= was_readonly;
7284 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
7285 /* handle override, if any */
7286 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
7287 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7288 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
7289 gv = gvp ? *gvp : NULL;
7293 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7294 OP * const kid = cUNOPo->op_first;
7297 cUNOPo->op_first = 0;
7301 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
7302 append_elem(OP_LIST, kid,
7303 scalar(newUNOP(OP_RV2CV, 0,
7306 op_getmad(o,newop,'O');
7314 Perl_ck_return(pTHX_ OP *o)
7317 if (CvLVALUE(PL_compcv)) {
7319 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
7320 mod(kid, OP_LEAVESUBLV);
7326 Perl_ck_select(pTHX_ OP *o)
7330 if (o->op_flags & OPf_KIDS) {
7331 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7332 if (kid && kid->op_sibling) {
7333 o->op_type = OP_SSELECT;
7334 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
7336 return fold_constants(o);
7340 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7341 if (kid && kid->op_type == OP_RV2GV)
7342 kid->op_private &= ~HINT_STRICT_REFS;
7347 Perl_ck_shift(pTHX_ OP *o)
7350 const I32 type = o->op_type;
7352 if (!(o->op_flags & OPf_KIDS)) {
7354 /* FIXME - this can be refactored to reduce code in #ifdefs */
7356 OP * const oldo = o;
7360 argop = newUNOP(OP_RV2AV, 0,
7361 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
7363 o = newUNOP(type, 0, scalar(argop));
7364 op_getmad(oldo,o,'O');
7367 return newUNOP(type, 0, scalar(argop));
7370 return scalar(modkids(ck_fun(o), type));
7374 Perl_ck_sort(pTHX_ OP *o)
7379 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
7380 HV * const hinthv = GvHV(PL_hintgv);
7382 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
7384 const I32 sorthints = (I32)SvIV(*svp);
7385 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
7386 o->op_private |= OPpSORT_QSORT;
7387 if ((sorthints & HINT_SORT_STABLE) != 0)
7388 o->op_private |= OPpSORT_STABLE;
7393 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
7395 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7396 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
7398 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
7400 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
7402 if (kid->op_type == OP_SCOPE) {
7406 else if (kid->op_type == OP_LEAVE) {
7407 if (o->op_type == OP_SORT) {
7408 op_null(kid); /* wipe out leave */
7411 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
7412 if (k->op_next == kid)
7414 /* don't descend into loops */
7415 else if (k->op_type == OP_ENTERLOOP
7416 || k->op_type == OP_ENTERITER)
7418 k = cLOOPx(k)->op_lastop;
7423 kid->op_next = 0; /* just disconnect the leave */
7424 k = kLISTOP->op_first;
7429 if (o->op_type == OP_SORT) {
7430 /* provide scalar context for comparison function/block */
7436 o->op_flags |= OPf_SPECIAL;
7438 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
7441 firstkid = firstkid->op_sibling;
7444 /* provide list context for arguments */
7445 if (o->op_type == OP_SORT)
7452 S_simplify_sort(pTHX_ OP *o)
7455 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7460 if (!(o->op_flags & OPf_STACKED))
7462 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7463 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
7464 kid = kUNOP->op_first; /* get past null */
7465 if (kid->op_type != OP_SCOPE)
7467 kid = kLISTOP->op_last; /* get past scope */
7468 switch(kid->op_type) {
7476 k = kid; /* remember this node*/
7477 if (kBINOP->op_first->op_type != OP_RV2SV)
7479 kid = kBINOP->op_first; /* get past cmp */
7480 if (kUNOP->op_first->op_type != OP_GV)
7482 kid = kUNOP->op_first; /* get past rv2sv */
7484 if (GvSTASH(gv) != PL_curstash)
7486 gvname = GvNAME(gv);
7487 if (*gvname == 'a' && gvname[1] == '\0')
7489 else if (*gvname == 'b' && gvname[1] == '\0')
7494 kid = k; /* back to cmp */
7495 if (kBINOP->op_last->op_type != OP_RV2SV)
7497 kid = kBINOP->op_last; /* down to 2nd arg */
7498 if (kUNOP->op_first->op_type != OP_GV)
7500 kid = kUNOP->op_first; /* get past rv2sv */
7502 if (GvSTASH(gv) != PL_curstash)
7504 gvname = GvNAME(gv);
7506 ? !(*gvname == 'a' && gvname[1] == '\0')
7507 : !(*gvname == 'b' && gvname[1] == '\0'))
7509 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
7511 o->op_private |= OPpSORT_DESCEND;
7512 if (k->op_type == OP_NCMP)
7513 o->op_private |= OPpSORT_NUMERIC;
7514 if (k->op_type == OP_I_NCMP)
7515 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
7516 kid = cLISTOPo->op_first->op_sibling;
7517 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
7519 op_getmad(kid,o,'S'); /* then delete it */
7521 op_free(kid); /* then delete it */
7526 Perl_ck_split(pTHX_ OP *o)
7531 if (o->op_flags & OPf_STACKED)
7532 return no_fh_allowed(o);
7534 kid = cLISTOPo->op_first;
7535 if (kid->op_type != OP_NULL)
7536 Perl_croak(aTHX_ "panic: ck_split");
7537 kid = kid->op_sibling;
7538 op_free(cLISTOPo->op_first);
7539 cLISTOPo->op_first = kid;
7541 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
7542 cLISTOPo->op_last = kid; /* There was only one element previously */
7545 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
7546 OP * const sibl = kid->op_sibling;
7547 kid->op_sibling = 0;
7548 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
7549 if (cLISTOPo->op_first == cLISTOPo->op_last)
7550 cLISTOPo->op_last = kid;
7551 cLISTOPo->op_first = kid;
7552 kid->op_sibling = sibl;
7555 kid->op_type = OP_PUSHRE;
7556 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
7558 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
7559 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
7560 "Use of /g modifier is meaningless in split");
7563 if (!kid->op_sibling)
7564 append_elem(OP_SPLIT, o, newDEFSVOP());
7566 kid = kid->op_sibling;
7569 if (!kid->op_sibling)
7570 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
7571 assert(kid->op_sibling);
7573 kid = kid->op_sibling;
7576 if (kid->op_sibling)
7577 return too_many_arguments(o,OP_DESC(o));
7583 Perl_ck_join(pTHX_ OP *o)
7585 const OP * const kid = cLISTOPo->op_first->op_sibling;
7586 if (kid && kid->op_type == OP_MATCH) {
7587 if (ckWARN(WARN_SYNTAX)) {
7588 const REGEXP *re = PM_GETRE(kPMOP);
7589 const char *pmstr = re ? RX_PRECOMP(re) : "STRING";
7590 const STRLEN len = re ? RX_PRELEN(re) : 6;
7591 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7592 "/%.*s/ should probably be written as \"%.*s\"",
7593 (int)len, pmstr, (int)len, pmstr);
7600 Perl_ck_subr(pTHX_ OP *o)
7603 OP *prev = ((cUNOPo->op_first->op_sibling)
7604 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
7605 OP *o2 = prev->op_sibling;
7607 const char *proto = NULL;
7608 const char *proto_end = NULL;
7613 I32 contextclass = 0;
7614 const char *e = NULL;
7617 o->op_private |= OPpENTERSUB_HASTARG;
7618 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
7619 if (cvop->op_type == OP_RV2CV) {
7621 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
7622 op_null(cvop); /* disable rv2cv */
7623 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
7624 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
7625 GV *gv = cGVOPx_gv(tmpop);
7628 tmpop->op_private |= OPpEARLY_CV;
7632 namegv = CvANON(cv) ? gv : CvGV(cv);
7633 proto = SvPV((SV*)cv, len);
7634 proto_end = proto + len;
7639 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7640 if (o2->op_type == OP_CONST)
7641 o2->op_private &= ~OPpCONST_STRICT;
7642 else if (o2->op_type == OP_LIST) {
7643 OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
7644 if (sib && sib->op_type == OP_CONST)
7645 sib->op_private &= ~OPpCONST_STRICT;
7648 o->op_private |= (PL_hints & HINT_STRICT_REFS);
7649 if (PERLDB_SUB && PL_curstash != PL_debstash)
7650 o->op_private |= OPpENTERSUB_DB;
7651 while (o2 != cvop) {
7653 if (PL_madskills && o2->op_type == OP_STUB) {
7654 o2 = o2->op_sibling;
7657 if (PL_madskills && o2->op_type == OP_NULL)
7658 o3 = ((UNOP*)o2)->op_first;
7662 if (proto >= proto_end)
7663 return too_many_arguments(o, gv_ename(namegv));
7671 /* _ must be at the end */
7672 if (proto[1] && proto[1] != ';')
7687 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
7689 arg == 1 ? "block or sub {}" : "sub {}",
7690 gv_ename(namegv), o3);
7693 /* '*' allows any scalar type, including bareword */
7696 if (o3->op_type == OP_RV2GV)
7697 goto wrapref; /* autoconvert GLOB -> GLOBref */
7698 else if (o3->op_type == OP_CONST)
7699 o3->op_private &= ~OPpCONST_STRICT;
7700 else if (o3->op_type == OP_ENTERSUB) {
7701 /* accidental subroutine, revert to bareword */
7702 OP *gvop = ((UNOP*)o3)->op_first;
7703 if (gvop && gvop->op_type == OP_NULL) {
7704 gvop = ((UNOP*)gvop)->op_first;
7706 for (; gvop->op_sibling; gvop = gvop->op_sibling)
7709 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
7710 (gvop = ((UNOP*)gvop)->op_first) &&
7711 gvop->op_type == OP_GV)
7713 GV * const gv = cGVOPx_gv(gvop);
7714 OP * const sibling = o2->op_sibling;
7715 SV * const n = newSVpvs("");
7717 OP * const oldo2 = o2;
7721 gv_fullname4(n, gv, "", FALSE);
7722 o2 = newSVOP(OP_CONST, 0, n);
7723 op_getmad(oldo2,o2,'O');
7724 prev->op_sibling = o2;
7725 o2->op_sibling = sibling;
7741 if (contextclass++ == 0) {
7742 e = strchr(proto, ']');
7743 if (!e || e == proto)
7752 const char *p = proto;
7753 const char *const end = proto;
7755 while (*--p != '[');
7756 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
7758 gv_ename(namegv), o3);
7763 if (o3->op_type == OP_RV2GV)
7766 bad_type(arg, "symbol", gv_ename(namegv), o3);
7769 if (o3->op_type == OP_ENTERSUB)
7772 bad_type(arg, "subroutine entry", gv_ename(namegv),
7776 if (o3->op_type == OP_RV2SV ||
7777 o3->op_type == OP_PADSV ||
7778 o3->op_type == OP_HELEM ||
7779 o3->op_type == OP_AELEM)
7782 bad_type(arg, "scalar", gv_ename(namegv), o3);
7785 if (o3->op_type == OP_RV2AV ||
7786 o3->op_type == OP_PADAV)
7789 bad_type(arg, "array", gv_ename(namegv), o3);
7792 if (o3->op_type == OP_RV2HV ||
7793 o3->op_type == OP_PADHV)
7796 bad_type(arg, "hash", gv_ename(namegv), o3);
7801 OP* const sib = kid->op_sibling;
7802 kid->op_sibling = 0;
7803 o2 = newUNOP(OP_REFGEN, 0, kid);
7804 o2->op_sibling = sib;
7805 prev->op_sibling = o2;
7807 if (contextclass && e) {
7822 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
7823 gv_ename(namegv), SVfARG(cv));
7828 mod(o2, OP_ENTERSUB);
7830 o2 = o2->op_sibling;
7832 if (o2 == cvop && proto && *proto == '_') {
7833 /* generate an access to $_ */
7835 o2->op_sibling = prev->op_sibling;
7836 prev->op_sibling = o2; /* instead of cvop */
7838 if (proto && !optional && proto_end > proto &&
7839 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
7840 return too_few_arguments(o, gv_ename(namegv));
7843 OP * const oldo = o;
7847 o=newSVOP(OP_CONST, 0, newSViv(0));
7848 op_getmad(oldo,o,'O');
7854 Perl_ck_svconst(pTHX_ OP *o)
7856 PERL_UNUSED_CONTEXT;
7857 SvREADONLY_on(cSVOPo->op_sv);
7862 Perl_ck_chdir(pTHX_ OP *o)
7864 if (o->op_flags & OPf_KIDS) {
7865 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7867 if (kid && kid->op_type == OP_CONST &&
7868 (kid->op_private & OPpCONST_BARE))
7870 o->op_flags |= OPf_SPECIAL;
7871 kid->op_private &= ~OPpCONST_STRICT;
7878 Perl_ck_trunc(pTHX_ OP *o)
7880 if (o->op_flags & OPf_KIDS) {
7881 SVOP *kid = (SVOP*)cUNOPo->op_first;
7883 if (kid->op_type == OP_NULL)
7884 kid = (SVOP*)kid->op_sibling;
7885 if (kid && kid->op_type == OP_CONST &&
7886 (kid->op_private & OPpCONST_BARE))
7888 o->op_flags |= OPf_SPECIAL;
7889 kid->op_private &= ~OPpCONST_STRICT;
7896 Perl_ck_unpack(pTHX_ OP *o)
7898 OP *kid = cLISTOPo->op_first;
7899 if (kid->op_sibling) {
7900 kid = kid->op_sibling;
7901 if (!kid->op_sibling)
7902 kid->op_sibling = newDEFSVOP();
7908 Perl_ck_substr(pTHX_ OP *o)
7911 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
7912 OP *kid = cLISTOPo->op_first;
7914 if (kid->op_type == OP_NULL)
7915 kid = kid->op_sibling;
7917 kid->op_flags |= OPf_MOD;
7924 Perl_ck_each(pTHX_ OP *o)
7927 OP *kid = cLISTOPo->op_first;
7929 if (kid->op_type == OP_PADAV || kid->op_type == OP_RV2AV) {
7930 const unsigned new_type = o->op_type == OP_EACH ? OP_AEACH
7931 : o->op_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
7932 o->op_type = new_type;
7933 o->op_ppaddr = PL_ppaddr[new_type];
7935 else if (!(kid->op_type == OP_PADHV || kid->op_type == OP_RV2HV
7936 || (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE)
7938 bad_type(1, "hash or array", PL_op_desc[o->op_type], kid);
7944 /* A peephole optimizer. We visit the ops in the order they're to execute.
7945 * See the comments at the top of this file for more details about when
7946 * peep() is called */
7949 Perl_peep(pTHX_ register OP *o)
7952 register OP* oldop = NULL;
7954 if (!o || o->op_opt)
7958 SAVEVPTR(PL_curcop);
7959 for (; o; o = o->op_next) {
7962 /* By default, this op has now been optimised. A couple of cases below
7963 clear this again. */
7966 switch (o->op_type) {
7970 PL_curcop = ((COP*)o); /* for warnings */
7974 if (cSVOPo->op_private & OPpCONST_STRICT)
7975 no_bareword_allowed(o);
7977 case OP_METHOD_NAMED:
7978 /* Relocate sv to the pad for thread safety.
7979 * Despite being a "constant", the SV is written to,
7980 * for reference counts, sv_upgrade() etc. */
7982 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
7983 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
7984 /* If op_sv is already a PADTMP then it is being used by
7985 * some pad, so make a copy. */
7986 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
7987 SvREADONLY_on(PAD_SVl(ix));
7988 SvREFCNT_dec(cSVOPo->op_sv);
7990 else if (o->op_type == OP_CONST
7991 && cSVOPo->op_sv == &PL_sv_undef) {
7992 /* PL_sv_undef is hack - it's unsafe to store it in the
7993 AV that is the pad, because av_fetch treats values of
7994 PL_sv_undef as a "free" AV entry and will merrily
7995 replace them with a new SV, causing pad_alloc to think
7996 that this pad slot is free. (When, clearly, it is not)
7998 SvOK_off(PAD_SVl(ix));
7999 SvPADTMP_on(PAD_SVl(ix));
8000 SvREADONLY_on(PAD_SVl(ix));
8003 SvREFCNT_dec(PAD_SVl(ix));
8004 SvPADTMP_on(cSVOPo->op_sv);
8005 PAD_SETSV(ix, cSVOPo->op_sv);
8006 /* XXX I don't know how this isn't readonly already. */
8007 SvREADONLY_on(PAD_SVl(ix));
8009 cSVOPo->op_sv = NULL;
8016 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
8017 if (o->op_next->op_private & OPpTARGET_MY) {
8018 if (o->op_flags & OPf_STACKED) /* chained concats */
8019 break; /* ignore_optimization */
8021 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
8022 o->op_targ = o->op_next->op_targ;
8023 o->op_next->op_targ = 0;
8024 o->op_private |= OPpTARGET_MY;
8027 op_null(o->op_next);
8031 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
8032 break; /* Scalar stub must produce undef. List stub is noop */
8036 if (o->op_targ == OP_NEXTSTATE
8037 || o->op_targ == OP_DBSTATE
8038 || o->op_targ == OP_SETSTATE)
8040 PL_curcop = ((COP*)o);
8042 /* XXX: We avoid setting op_seq here to prevent later calls
8043 to peep() from mistakenly concluding that optimisation
8044 has already occurred. This doesn't fix the real problem,
8045 though (See 20010220.007). AMS 20010719 */
8046 /* op_seq functionality is now replaced by op_opt */
8053 if (oldop && o->op_next) {
8054 oldop->op_next = o->op_next;
8062 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
8063 OP* const pop = (o->op_type == OP_PADAV) ?
8064 o->op_next : o->op_next->op_next;
8066 if (pop && pop->op_type == OP_CONST &&
8067 ((PL_op = pop->op_next)) &&
8068 pop->op_next->op_type == OP_AELEM &&
8069 !(pop->op_next->op_private &
8070 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
8071 (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
8076 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
8077 no_bareword_allowed(pop);
8078 if (o->op_type == OP_GV)
8079 op_null(o->op_next);
8080 op_null(pop->op_next);
8082 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
8083 o->op_next = pop->op_next->op_next;
8084 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
8085 o->op_private = (U8)i;
8086 if (o->op_type == OP_GV) {
8091 o->op_flags |= OPf_SPECIAL;
8092 o->op_type = OP_AELEMFAST;
8097 if (o->op_next->op_type == OP_RV2SV) {
8098 if (!(o->op_next->op_private & OPpDEREF)) {
8099 op_null(o->op_next);
8100 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
8102 o->op_next = o->op_next->op_next;
8103 o->op_type = OP_GVSV;
8104 o->op_ppaddr = PL_ppaddr[OP_GVSV];
8107 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
8108 GV * const gv = cGVOPo_gv;
8109 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
8110 /* XXX could check prototype here instead of just carping */
8111 SV * const sv = sv_newmortal();
8112 gv_efullname3(sv, gv, NULL);
8113 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
8114 "%"SVf"() called too early to check prototype",
8118 else if (o->op_next->op_type == OP_READLINE
8119 && o->op_next->op_next->op_type == OP_CONCAT
8120 && (o->op_next->op_next->op_flags & OPf_STACKED))
8122 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
8123 o->op_type = OP_RCATLINE;
8124 o->op_flags |= OPf_STACKED;
8125 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
8126 op_null(o->op_next->op_next);
8127 op_null(o->op_next);
8143 while (cLOGOP->op_other->op_type == OP_NULL)
8144 cLOGOP->op_other = cLOGOP->op_other->op_next;
8145 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
8150 while (cLOOP->op_redoop->op_type == OP_NULL)
8151 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
8152 peep(cLOOP->op_redoop);
8153 while (cLOOP->op_nextop->op_type == OP_NULL)
8154 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
8155 peep(cLOOP->op_nextop);
8156 while (cLOOP->op_lastop->op_type == OP_NULL)
8157 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
8158 peep(cLOOP->op_lastop);
8162 assert(!(cPMOP->op_pmflags & PMf_ONCE));
8163 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
8164 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
8165 cPMOP->op_pmstashstartu.op_pmreplstart
8166 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
8167 peep(cPMOP->op_pmstashstartu.op_pmreplstart);
8171 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
8172 && ckWARN(WARN_SYNTAX))
8174 if (o->op_next->op_sibling) {
8175 const OPCODE type = o->op_next->op_sibling->op_type;
8176 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
8177 const line_t oldline = CopLINE(PL_curcop);
8178 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
8179 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8180 "Statement unlikely to be reached");
8181 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8182 "\t(Maybe you meant system() when you said exec()?)\n");
8183 CopLINE_set(PL_curcop, oldline);
8194 const char *key = NULL;
8197 if (((BINOP*)o)->op_last->op_type != OP_CONST)
8200 /* Make the CONST have a shared SV */
8201 svp = cSVOPx_svp(((BINOP*)o)->op_last);
8202 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
8203 key = SvPV_const(sv, keylen);
8204 lexname = newSVpvn_share(key,
8205 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
8211 if ((o->op_private & (OPpLVAL_INTRO)))
8214 rop = (UNOP*)((BINOP*)o)->op_first;
8215 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
8217 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
8218 if (!SvPAD_TYPED(lexname))
8220 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8221 if (!fields || !GvHV(*fields))
8223 key = SvPV_const(*svp, keylen);
8224 if (!hv_fetch(GvHV(*fields), key,
8225 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8227 Perl_croak(aTHX_ "No such class field \"%s\" "
8228 "in variable %s of type %s",
8229 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
8242 SVOP *first_key_op, *key_op;
8244 if ((o->op_private & (OPpLVAL_INTRO))
8245 /* I bet there's always a pushmark... */
8246 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
8247 /* hmmm, no optimization if list contains only one key. */
8249 rop = (UNOP*)((LISTOP*)o)->op_last;
8250 if (rop->op_type != OP_RV2HV)
8252 if (rop->op_first->op_type == OP_PADSV)
8253 /* @$hash{qw(keys here)} */
8254 rop = (UNOP*)rop->op_first;
8256 /* @{$hash}{qw(keys here)} */
8257 if (rop->op_first->op_type == OP_SCOPE
8258 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
8260 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
8266 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
8267 if (!SvPAD_TYPED(lexname))
8269 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8270 if (!fields || !GvHV(*fields))
8272 /* Again guessing that the pushmark can be jumped over.... */
8273 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
8274 ->op_first->op_sibling;
8275 for (key_op = first_key_op; key_op;
8276 key_op = (SVOP*)key_op->op_sibling) {
8277 if (key_op->op_type != OP_CONST)
8279 svp = cSVOPx_svp(key_op);
8280 key = SvPV_const(*svp, keylen);
8281 if (!hv_fetch(GvHV(*fields), key,
8282 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8284 Perl_croak(aTHX_ "No such class field \"%s\" "
8285 "in variable %s of type %s",
8286 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
8293 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
8297 /* check that RHS of sort is a single plain array */
8298 OP *oright = cUNOPo->op_first;
8299 if (!oright || oright->op_type != OP_PUSHMARK)
8302 /* reverse sort ... can be optimised. */
8303 if (!cUNOPo->op_sibling) {
8304 /* Nothing follows us on the list. */
8305 OP * const reverse = o->op_next;
8307 if (reverse->op_type == OP_REVERSE &&
8308 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
8309 OP * const pushmark = cUNOPx(reverse)->op_first;
8310 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
8311 && (cUNOPx(pushmark)->op_sibling == o)) {
8312 /* reverse -> pushmark -> sort */
8313 o->op_private |= OPpSORT_REVERSE;
8315 pushmark->op_next = oright->op_next;
8321 /* make @a = sort @a act in-place */
8323 oright = cUNOPx(oright)->op_sibling;
8326 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
8327 oright = cUNOPx(oright)->op_sibling;
8331 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
8332 || oright->op_next != o
8333 || (oright->op_private & OPpLVAL_INTRO)
8337 /* o2 follows the chain of op_nexts through the LHS of the
8338 * assign (if any) to the aassign op itself */
8340 if (!o2 || o2->op_type != OP_NULL)
8343 if (!o2 || o2->op_type != OP_PUSHMARK)
8346 if (o2 && o2->op_type == OP_GV)
8349 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
8350 || (o2->op_private & OPpLVAL_INTRO)
8355 if (!o2 || o2->op_type != OP_NULL)
8358 if (!o2 || o2->op_type != OP_AASSIGN
8359 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
8362 /* check that the sort is the first arg on RHS of assign */
8364 o2 = cUNOPx(o2)->op_first;
8365 if (!o2 || o2->op_type != OP_NULL)
8367 o2 = cUNOPx(o2)->op_first;
8368 if (!o2 || o2->op_type != OP_PUSHMARK)
8370 if (o2->op_sibling != o)
8373 /* check the array is the same on both sides */
8374 if (oleft->op_type == OP_RV2AV) {
8375 if (oright->op_type != OP_RV2AV
8376 || !cUNOPx(oright)->op_first
8377 || cUNOPx(oright)->op_first->op_type != OP_GV
8378 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
8379 cGVOPx_gv(cUNOPx(oright)->op_first)
8383 else if (oright->op_type != OP_PADAV
8384 || oright->op_targ != oleft->op_targ
8388 /* transfer MODishness etc from LHS arg to RHS arg */
8389 oright->op_flags = oleft->op_flags;
8390 o->op_private |= OPpSORT_INPLACE;
8392 /* excise push->gv->rv2av->null->aassign */
8393 o2 = o->op_next->op_next;
8394 op_null(o2); /* PUSHMARK */
8396 if (o2->op_type == OP_GV) {
8397 op_null(o2); /* GV */
8400 op_null(o2); /* RV2AV or PADAV */
8401 o2 = o2->op_next->op_next;
8402 op_null(o2); /* AASSIGN */
8404 o->op_next = o2->op_next;
8410 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
8412 LISTOP *enter, *exlist;
8414 enter = (LISTOP *) o->op_next;
8417 if (enter->op_type == OP_NULL) {
8418 enter = (LISTOP *) enter->op_next;
8422 /* for $a (...) will have OP_GV then OP_RV2GV here.
8423 for (...) just has an OP_GV. */
8424 if (enter->op_type == OP_GV) {
8425 gvop = (OP *) enter;
8426 enter = (LISTOP *) enter->op_next;
8429 if (enter->op_type == OP_RV2GV) {
8430 enter = (LISTOP *) enter->op_next;
8436 if (enter->op_type != OP_ENTERITER)
8439 iter = enter->op_next;
8440 if (!iter || iter->op_type != OP_ITER)
8443 expushmark = enter->op_first;
8444 if (!expushmark || expushmark->op_type != OP_NULL
8445 || expushmark->op_targ != OP_PUSHMARK)
8448 exlist = (LISTOP *) expushmark->op_sibling;
8449 if (!exlist || exlist->op_type != OP_NULL
8450 || exlist->op_targ != OP_LIST)
8453 if (exlist->op_last != o) {
8454 /* Mmm. Was expecting to point back to this op. */
8457 theirmark = exlist->op_first;
8458 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
8461 if (theirmark->op_sibling != o) {
8462 /* There's something between the mark and the reverse, eg
8463 for (1, reverse (...))
8468 ourmark = ((LISTOP *)o)->op_first;
8469 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
8472 ourlast = ((LISTOP *)o)->op_last;
8473 if (!ourlast || ourlast->op_next != o)
8476 rv2av = ourmark->op_sibling;
8477 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
8478 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
8479 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
8480 /* We're just reversing a single array. */
8481 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
8482 enter->op_flags |= OPf_STACKED;
8485 /* We don't have control over who points to theirmark, so sacrifice
8487 theirmark->op_next = ourmark->op_next;
8488 theirmark->op_flags = ourmark->op_flags;
8489 ourlast->op_next = gvop ? gvop : (OP *) enter;
8492 enter->op_private |= OPpITER_REVERSED;
8493 iter->op_private |= OPpITER_REVERSED;
8500 UNOP *refgen, *rv2cv;
8503 if ((o->op_flags & OPf_WANT) != OPf_WANT_VOID)
8506 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
8509 rv2gv = ((BINOP *)o)->op_last;
8510 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
8513 refgen = (UNOP *)((BINOP *)o)->op_first;
8515 if (!refgen || refgen->op_type != OP_REFGEN)
8518 exlist = (LISTOP *)refgen->op_first;
8519 if (!exlist || exlist->op_type != OP_NULL
8520 || exlist->op_targ != OP_LIST)
8523 if (exlist->op_first->op_type != OP_PUSHMARK)
8526 rv2cv = (UNOP*)exlist->op_last;
8528 if (rv2cv->op_type != OP_RV2CV)
8531 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
8532 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
8533 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
8535 o->op_private |= OPpASSIGN_CV_TO_GV;
8536 rv2gv->op_private |= OPpDONT_INIT_GV;
8537 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
8545 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
8546 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
8556 Perl_custom_op_name(pTHX_ const OP* o)
8559 const IV index = PTR2IV(o->op_ppaddr);
8563 if (!PL_custom_op_names) /* This probably shouldn't happen */
8564 return (char *)PL_op_name[OP_CUSTOM];
8566 keysv = sv_2mortal(newSViv(index));
8568 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
8570 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
8572 return SvPV_nolen(HeVAL(he));
8576 Perl_custom_op_desc(pTHX_ const OP* o)
8579 const IV index = PTR2IV(o->op_ppaddr);
8583 if (!PL_custom_op_descs)
8584 return (char *)PL_op_desc[OP_CUSTOM];
8586 keysv = sv_2mortal(newSViv(index));
8588 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
8590 return (char *)PL_op_desc[OP_CUSTOM];
8592 return SvPV_nolen(HeVAL(he));
8597 /* Efficient sub that returns a constant scalar value. */
8599 const_sv_xsub(pTHX_ CV* cv)
8606 Perl_croak(aTHX_ "usage: %s::%s()",
8607 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
8611 ST(0) = (SV*)XSANY.any_ptr;
8617 * c-indentation-style: bsd
8619 * indent-tabs-mode: t
8622 * ex: set ts=8 sts=4 sw=4 noet: