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)
120 * To make incrementing use count easy PL_OpSlab is an I32 *
121 * To make inserting the link to slab PL_OpPtr is I32 **
122 * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
123 * Add an overhead for pointer to slab and round up as a number of pointers
125 sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
126 if ((PL_OpSpace -= sz) < 0) {
127 #ifdef PERL_DEBUG_READONLY_OPS
128 /* We need to allocate chunk by chunk so that we can control the VM
130 PL_OpPtr = mmap(0, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE,
131 MAP_ANON|MAP_PRIVATE, -1, 0);
133 DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
134 (unsigned long) PERL_SLAB_SIZE*sizeof(I32*),
136 if(PL_OpPtr == MAP_FAILED) {
137 perror("mmap failed");
142 PL_OpPtr = (I32 **) PerlMemShared_calloc(PERL_SLAB_SIZE,sizeof(I32*));
147 /* We reserve the 0'th I32 sized chunk as a use count */
148 PL_OpSlab = (I32 *) PL_OpPtr;
149 /* Reduce size by the use count word, and by the size we need.
150 * Latter is to mimic the '-=' in the if() above
152 PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
153 /* Allocation pointer starts at the top.
154 Theory: because we build leaves before trunk allocating at end
155 means that at run time access is cache friendly upward
157 PL_OpPtr += PERL_SLAB_SIZE;
159 #ifdef PERL_DEBUG_READONLY_OPS
160 /* We remember this slab. */
161 /* This implementation isn't efficient, but it is simple. */
162 PL_slabs = realloc(PL_slabs, sizeof(I32**) * (PL_slab_count + 1));
163 PL_slabs[PL_slab_count++] = PL_OpSlab;
164 DEBUG_m(PerlIO_printf(Perl_debug_log, "Allocate %p\n", PL_OpSlab));
167 assert( PL_OpSpace >= 0 );
168 /* Move the allocation pointer down */
170 assert( PL_OpPtr > (I32 **) PL_OpSlab );
171 *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */
172 (*PL_OpSlab)++; /* Increment use count of slab */
173 assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
174 assert( *PL_OpSlab > 0 );
175 return (void *)(PL_OpPtr + 1);
178 #ifdef PERL_DEBUG_READONLY_OPS
180 Perl_pending_Slabs_to_ro(pTHX) {
181 /* Turn all the allocated op slabs read only. */
182 U32 count = PL_slab_count;
183 I32 **const slabs = PL_slabs;
185 /* Reset the array of pending OP slabs, as we're about to turn this lot
186 read only. Also, do it ahead of the loop in case the warn triggers,
187 and a warn handler has an eval */
192 /* Force a new slab for any further allocation. */
196 void *const start = slabs[count];
197 const size_t size = PERL_SLAB_SIZE* sizeof(I32*);
198 if(mprotect(start, size, PROT_READ)) {
199 Perl_warn(aTHX_ "mprotect for %p %lu failed with %d",
200 start, (unsigned long) size, errno);
208 S_Slab_to_rw(pTHX_ void *op)
210 I32 * const * const ptr = (I32 **) op;
211 I32 * const slab = ptr[-1];
212 assert( ptr-1 > (I32 **) slab );
213 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
215 if(mprotect(slab, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE)) {
216 Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d",
217 slab, (unsigned long) PERL_SLAB_SIZE*sizeof(I32*), errno);
222 Perl_op_refcnt_inc(pTHX_ OP *o)
233 Perl_op_refcnt_dec(pTHX_ OP *o)
239 # define Slab_to_rw(op)
243 Perl_Slab_Free(pTHX_ void *op)
245 I32 * const * const ptr = (I32 **) op;
246 I32 * const slab = ptr[-1];
247 assert( ptr-1 > (I32 **) slab );
248 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
251 if (--(*slab) == 0) {
253 # define PerlMemShared PerlMem
256 #ifdef PERL_DEBUG_READONLY_OPS
257 U32 count = PL_slab_count;
258 /* Need to remove this slab from our list of slabs */
261 if (PL_slabs[count] == slab) {
262 /* Found it. Move the entry at the end to overwrite it. */
263 DEBUG_m(PerlIO_printf(Perl_debug_log,
264 "Deallocate %p by moving %p from %lu to %lu\n",
266 PL_slabs[PL_slab_count - 1],
267 PL_slab_count, count));
268 PL_slabs[count] = PL_slabs[--PL_slab_count];
269 /* Could realloc smaller at this point, but probably not
271 if(munmap(slab, PERL_SLAB_SIZE*sizeof(I32*))) {
272 perror("munmap failed");
280 PerlMemShared_free(slab);
282 if (slab == PL_OpSlab) {
289 * In the following definition, the ", (OP*)0" is just to make the compiler
290 * think the expression is of the right type: croak actually does a Siglongjmp.
292 #define CHECKOP(type,o) \
293 ((PL_op_mask && PL_op_mask[type]) \
294 ? ( op_free((OP*)o), \
295 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
297 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
299 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
302 S_gv_ename(pTHX_ GV *gv)
304 SV* const tmpsv = sv_newmortal();
305 gv_efullname3(tmpsv, gv, NULL);
306 return SvPV_nolen_const(tmpsv);
310 S_no_fh_allowed(pTHX_ OP *o)
312 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
318 S_too_few_arguments(pTHX_ OP *o, const char *name)
320 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
325 S_too_many_arguments(pTHX_ OP *o, const char *name)
327 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
332 S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid)
334 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
335 (int)n, name, t, OP_DESC(kid)));
339 S_no_bareword_allowed(pTHX_ const OP *o)
342 return; /* various ok barewords are hidden in extra OP_NULL */
343 qerror(Perl_mess(aTHX_
344 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
348 /* "register" allocation */
351 Perl_allocmy(pTHX_ const char *const name)
355 const bool is_our = (PL_parser->in_my == KEY_our);
357 /* complain about "my $<special_var>" etc etc */
361 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
362 (name[1] == '_' && (*name == '$' || name[2]))))
364 /* name[2] is true if strlen(name) > 2 */
365 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
366 yyerror(Perl_form(aTHX_ "Can't use global %c^%c%s in \"%s\"",
367 name[0], toCTRL(name[1]), name + 2,
368 PL_parser->in_my == KEY_state ? "state" : "my"));
370 yyerror(Perl_form(aTHX_ "Can't use global %s in \"%s\"",name,
371 PL_parser->in_my == KEY_state ? "state" : "my"));
375 /* check for duplicate declaration */
376 pad_check_dup(name, is_our, (PL_curstash ? PL_curstash : PL_defstash));
378 if (PL_parser->in_my_stash && *name != '$') {
379 yyerror(Perl_form(aTHX_
380 "Can't declare class for non-scalar %s in \"%s\"",
383 : PL_parser->in_my == KEY_state ? "state" : "my"));
386 /* allocate a spare slot and store the name in that slot */
388 off = pad_add_name(name,
389 PL_parser->in_my_stash,
391 /* $_ is always in main::, even with our */
392 ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
396 PL_parser->in_my == KEY_state
401 /* free the body of an op without examining its contents.
402 * Always use this rather than FreeOp directly */
405 S_op_destroy(pTHX_ OP *o)
407 if (o->op_latefree) {
415 # define forget_pmop(a,b) S_forget_pmop(aTHX_ a,b)
417 # define forget_pmop(a,b) S_forget_pmop(aTHX_ a)
423 Perl_op_free(pTHX_ OP *o)
430 if (o->op_latefreed) {
437 if (o->op_private & OPpREFCOUNTED) {
448 refcnt = OpREFCNT_dec(o);
451 /* Need to find and remove any pattern match ops from the list
452 we maintain for reset(). */
453 find_and_forget_pmops(o);
463 if (o->op_flags & OPf_KIDS) {
464 register OP *kid, *nextkid;
465 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
466 nextkid = kid->op_sibling; /* Get before next freeing kid */
471 type = (OPCODE)o->op_targ;
473 #ifdef PERL_DEBUG_READONLY_OPS
477 /* COP* is not cleared by op_clear() so that we may track line
478 * numbers etc even after null() */
479 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE) {
484 if (o->op_latefree) {
490 #ifdef DEBUG_LEAKING_SCALARS
497 Perl_op_clear(pTHX_ OP *o)
502 /* if (o->op_madprop && o->op_madprop->mad_next)
504 /* FIXME for MAD - if I uncomment these two lines t/op/pack.t fails with
505 "modification of a read only value" for a reason I can't fathom why.
506 It's the "" stringification of $_, where $_ was set to '' in a foreach
507 loop, but it defies simplification into a small test case.
508 However, commenting them out has caused ext/List/Util/t/weak.t to fail
511 mad_free(o->op_madprop);
517 switch (o->op_type) {
518 case OP_NULL: /* Was holding old type, if any. */
519 if (PL_madskills && o->op_targ != OP_NULL) {
520 o->op_type = o->op_targ;
524 case OP_ENTEREVAL: /* Was holding hints. */
528 if (!(o->op_flags & OPf_REF)
529 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
535 if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
536 /* not an OP_PADAV replacement */
538 if (cPADOPo->op_padix > 0) {
539 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
540 * may still exist on the pad */
541 pad_swipe(cPADOPo->op_padix, TRUE);
542 cPADOPo->op_padix = 0;
545 SvREFCNT_dec(cSVOPo->op_sv);
546 cSVOPo->op_sv = NULL;
550 case OP_METHOD_NAMED:
552 SvREFCNT_dec(cSVOPo->op_sv);
553 cSVOPo->op_sv = NULL;
556 Even if op_clear does a pad_free for the target of the op,
557 pad_free doesn't actually remove the sv that exists in the pad;
558 instead it lives on. This results in that it could be reused as
559 a target later on when the pad was reallocated.
562 pad_swipe(o->op_targ,1);
571 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
575 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
577 if (cPADOPo->op_padix > 0) {
578 pad_swipe(cPADOPo->op_padix, TRUE);
579 cPADOPo->op_padix = 0;
582 SvREFCNT_dec(cSVOPo->op_sv);
583 cSVOPo->op_sv = NULL;
587 PerlMemShared_free(cPVOPo->op_pv);
588 cPVOPo->op_pv = NULL;
592 op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
596 if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
597 /* No GvIN_PAD_off here, because other references may still
598 * exist on the pad */
599 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
602 SvREFCNT_dec((SV*)cPMOPo->op_pmreplrootu.op_pmtargetgv);
608 forget_pmop(cPMOPo, 1);
609 cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
610 /* we use the "SAFE" version of the PM_ macros here
611 * since sv_clean_all might release some PMOPs
612 * after PL_regex_padav has been cleared
613 * and the clearing of PL_regex_padav needs to
614 * happen before sv_clean_all
616 ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
617 PM_SETRE_SAFE(cPMOPo, NULL);
619 if(PL_regex_pad) { /* We could be in destruction */
620 av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
621 SvREADONLY_off(PL_regex_pad[(cPMOPo)->op_pmoffset]);
622 SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
623 PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
630 if (o->op_targ > 0) {
631 pad_free(o->op_targ);
637 S_cop_free(pTHX_ COP* cop)
642 if (! specialWARN(cop->cop_warnings))
643 PerlMemShared_free(cop->cop_warnings);
644 Perl_refcounted_he_free(aTHX_ cop->cop_hints_hash);
648 S_forget_pmop(pTHX_ PMOP *const o
654 HV * const pmstash = PmopSTASH(o);
655 if (pmstash && !SvIS_FREED(pmstash)) {
656 MAGIC * const mg = mg_find((SV*)pmstash, PERL_MAGIC_symtab);
658 PMOP **const array = (PMOP**) mg->mg_ptr;
659 U32 count = mg->mg_len / sizeof(PMOP**);
664 /* Found it. Move the entry at the end to overwrite it. */
665 array[i] = array[--count];
666 mg->mg_len = count * sizeof(PMOP**);
667 /* Could realloc smaller at this point always, but probably
668 not worth it. Probably worth free()ing if we're the
671 Safefree(mg->mg_ptr);
688 S_find_and_forget_pmops(pTHX_ OP *o)
690 if (o->op_flags & OPf_KIDS) {
691 OP *kid = cUNOPo->op_first;
693 switch (kid->op_type) {
698 forget_pmop((PMOP*)kid, 0);
700 find_and_forget_pmops(kid);
701 kid = kid->op_sibling;
707 Perl_op_null(pTHX_ OP *o)
710 if (o->op_type == OP_NULL)
714 o->op_targ = o->op_type;
715 o->op_type = OP_NULL;
716 o->op_ppaddr = PL_ppaddr[OP_NULL];
720 Perl_op_refcnt_lock(pTHX)
728 Perl_op_refcnt_unlock(pTHX)
735 /* Contextualizers */
737 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
740 Perl_linklist(pTHX_ OP *o)
747 /* establish postfix order */
748 first = cUNOPo->op_first;
751 o->op_next = LINKLIST(first);
754 if (kid->op_sibling) {
755 kid->op_next = LINKLIST(kid->op_sibling);
756 kid = kid->op_sibling;
770 Perl_scalarkids(pTHX_ OP *o)
772 if (o && o->op_flags & OPf_KIDS) {
774 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
781 S_scalarboolean(pTHX_ OP *o)
784 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
785 if (ckWARN(WARN_SYNTAX)) {
786 const line_t oldline = CopLINE(PL_curcop);
788 if (PL_parser && PL_parser->copline != NOLINE)
789 CopLINE_set(PL_curcop, PL_parser->copline);
790 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
791 CopLINE_set(PL_curcop, oldline);
798 Perl_scalar(pTHX_ OP *o)
803 /* assumes no premature commitment */
804 if (!o || (PL_parser && PL_parser->error_count)
805 || (o->op_flags & OPf_WANT)
806 || o->op_type == OP_RETURN)
811 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
813 switch (o->op_type) {
815 scalar(cBINOPo->op_first);
820 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
824 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
825 if (!kPMOP->op_pmreplrootu.op_pmreplroot)
826 deprecate_old("implicit split to @_");
834 if (o->op_flags & OPf_KIDS) {
835 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
841 kid = cLISTOPo->op_first;
843 while ((kid = kid->op_sibling)) {
849 PL_curcop = &PL_compiling;
854 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
860 PL_curcop = &PL_compiling;
863 if (ckWARN(WARN_VOID))
864 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
870 Perl_scalarvoid(pTHX_ OP *o)
874 const char* useless = NULL;
878 /* trailing mad null ops don't count as "there" for void processing */
880 o->op_type != OP_NULL &&
882 o->op_sibling->op_type == OP_NULL)
885 for (sib = o->op_sibling;
886 sib && sib->op_type == OP_NULL;
887 sib = sib->op_sibling) ;
893 if (o->op_type == OP_NEXTSTATE
894 || o->op_type == OP_SETSTATE
895 || o->op_type == OP_DBSTATE
896 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
897 || o->op_targ == OP_SETSTATE
898 || o->op_targ == OP_DBSTATE)))
899 PL_curcop = (COP*)o; /* for warning below */
901 /* assumes no premature commitment */
902 want = o->op_flags & OPf_WANT;
903 if ((want && want != OPf_WANT_SCALAR)
904 || (PL_parser && PL_parser->error_count)
905 || o->op_type == OP_RETURN)
910 if ((o->op_private & OPpTARGET_MY)
911 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
913 return scalar(o); /* As if inside SASSIGN */
916 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
918 switch (o->op_type) {
920 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
924 if (o->op_flags & OPf_STACKED)
928 if (o->op_private == 4)
1000 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1001 useless = OP_DESC(o);
1005 kid = cUNOPo->op_first;
1006 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1007 kid->op_type != OP_TRANS) {
1010 useless = "negative pattern binding (!~)";
1017 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1018 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1019 useless = "a variable";
1024 if (cSVOPo->op_private & OPpCONST_STRICT)
1025 no_bareword_allowed(o);
1027 if (ckWARN(WARN_VOID)) {
1028 useless = "a constant";
1029 if (o->op_private & OPpCONST_ARYBASE)
1031 /* don't warn on optimised away booleans, eg
1032 * use constant Foo, 5; Foo || print; */
1033 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1035 /* the constants 0 and 1 are permitted as they are
1036 conventionally used as dummies in constructs like
1037 1 while some_condition_with_side_effects; */
1038 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1040 else if (SvPOK(sv)) {
1041 /* perl4's way of mixing documentation and code
1042 (before the invention of POD) was based on a
1043 trick to mix nroff and perl code. The trick was
1044 built upon these three nroff macros being used in
1045 void context. The pink camel has the details in
1046 the script wrapman near page 319. */
1047 const char * const maybe_macro = SvPVX_const(sv);
1048 if (strnEQ(maybe_macro, "di", 2) ||
1049 strnEQ(maybe_macro, "ds", 2) ||
1050 strnEQ(maybe_macro, "ig", 2))
1055 op_null(o); /* don't execute or even remember it */
1059 o->op_type = OP_PREINC; /* pre-increment is faster */
1060 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1064 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1065 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1069 o->op_type = OP_I_PREINC; /* pre-increment is faster */
1070 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1074 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
1075 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1084 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1089 if (o->op_flags & OPf_STACKED)
1096 if (!(o->op_flags & OPf_KIDS))
1107 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1114 /* all requires must return a boolean value */
1115 o->op_flags &= ~OPf_WANT;
1120 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
1121 if (!kPMOP->op_pmreplrootu.op_pmreplroot)
1122 deprecate_old("implicit split to @_");
1126 if (useless && ckWARN(WARN_VOID))
1127 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
1132 Perl_listkids(pTHX_ OP *o)
1134 if (o && o->op_flags & OPf_KIDS) {
1136 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1143 Perl_list(pTHX_ OP *o)
1148 /* assumes no premature commitment */
1149 if (!o || (o->op_flags & OPf_WANT)
1150 || (PL_parser && PL_parser->error_count)
1151 || o->op_type == OP_RETURN)
1156 if ((o->op_private & OPpTARGET_MY)
1157 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1159 return o; /* As if inside SASSIGN */
1162 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1164 switch (o->op_type) {
1167 list(cBINOPo->op_first);
1172 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1180 if (!(o->op_flags & OPf_KIDS))
1182 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1183 list(cBINOPo->op_first);
1184 return gen_constant_list(o);
1191 kid = cLISTOPo->op_first;
1193 while ((kid = kid->op_sibling)) {
1194 if (kid->op_sibling)
1199 PL_curcop = &PL_compiling;
1203 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1204 if (kid->op_sibling)
1209 PL_curcop = &PL_compiling;
1212 /* all requires must return a boolean value */
1213 o->op_flags &= ~OPf_WANT;
1220 Perl_scalarseq(pTHX_ OP *o)
1224 const OPCODE type = o->op_type;
1226 if (type == OP_LINESEQ || type == OP_SCOPE ||
1227 type == OP_LEAVE || type == OP_LEAVETRY)
1230 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1231 if (kid->op_sibling) {
1235 PL_curcop = &PL_compiling;
1237 o->op_flags &= ~OPf_PARENS;
1238 if (PL_hints & HINT_BLOCK_SCOPE)
1239 o->op_flags |= OPf_PARENS;
1242 o = newOP(OP_STUB, 0);
1247 S_modkids(pTHX_ OP *o, I32 type)
1249 if (o && o->op_flags & OPf_KIDS) {
1251 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1257 /* Propagate lvalue ("modifiable") context to an op and its children.
1258 * 'type' represents the context type, roughly based on the type of op that
1259 * would do the modifying, although local() is represented by OP_NULL.
1260 * It's responsible for detecting things that can't be modified, flag
1261 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
1262 * might have to vivify a reference in $x), and so on.
1264 * For example, "$a+1 = 2" would cause mod() to be called with o being
1265 * OP_ADD and type being OP_SASSIGN, and would output an error.
1269 Perl_mod(pTHX_ OP *o, I32 type)
1273 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1276 if (!o || (PL_parser && PL_parser->error_count))
1279 if ((o->op_private & OPpTARGET_MY)
1280 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1285 switch (o->op_type) {
1291 if (!(o->op_private & OPpCONST_ARYBASE))
1294 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1295 CopARYBASE_set(&PL_compiling,
1296 (I32)SvIV(cSVOPx(PL_eval_start)->op_sv));
1300 SAVECOPARYBASE(&PL_compiling);
1301 CopARYBASE_set(&PL_compiling, 0);
1303 else if (type == OP_REFGEN)
1306 Perl_croak(aTHX_ "That use of $[ is unsupported");
1309 if ((o->op_flags & OPf_PARENS) || PL_madskills)
1313 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1314 !(o->op_flags & OPf_STACKED)) {
1315 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1316 /* The default is to set op_private to the number of children,
1317 which for a UNOP such as RV2CV is always 1. And w're using
1318 the bit for a flag in RV2CV, so we need it clear. */
1319 o->op_private &= ~1;
1320 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1321 assert(cUNOPo->op_first->op_type == OP_NULL);
1322 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1325 else if (o->op_private & OPpENTERSUB_NOMOD)
1327 else { /* lvalue subroutine call */
1328 o->op_private |= OPpLVAL_INTRO;
1329 PL_modcount = RETURN_UNLIMITED_NUMBER;
1330 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1331 /* Backward compatibility mode: */
1332 o->op_private |= OPpENTERSUB_INARGS;
1335 else { /* Compile-time error message: */
1336 OP *kid = cUNOPo->op_first;
1340 if (kid->op_type != OP_PUSHMARK) {
1341 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1343 "panic: unexpected lvalue entersub "
1344 "args: type/targ %ld:%"UVuf,
1345 (long)kid->op_type, (UV)kid->op_targ);
1346 kid = kLISTOP->op_first;
1348 while (kid->op_sibling)
1349 kid = kid->op_sibling;
1350 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1352 if (kid->op_type == OP_METHOD_NAMED
1353 || kid->op_type == OP_METHOD)
1357 NewOp(1101, newop, 1, UNOP);
1358 newop->op_type = OP_RV2CV;
1359 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1360 newop->op_first = NULL;
1361 newop->op_next = (OP*)newop;
1362 kid->op_sibling = (OP*)newop;
1363 newop->op_private |= OPpLVAL_INTRO;
1364 newop->op_private &= ~1;
1368 if (kid->op_type != OP_RV2CV)
1370 "panic: unexpected lvalue entersub "
1371 "entry via type/targ %ld:%"UVuf,
1372 (long)kid->op_type, (UV)kid->op_targ);
1373 kid->op_private |= OPpLVAL_INTRO;
1374 break; /* Postpone until runtime */
1378 kid = kUNOP->op_first;
1379 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1380 kid = kUNOP->op_first;
1381 if (kid->op_type == OP_NULL)
1383 "Unexpected constant lvalue entersub "
1384 "entry via type/targ %ld:%"UVuf,
1385 (long)kid->op_type, (UV)kid->op_targ);
1386 if (kid->op_type != OP_GV) {
1387 /* Restore RV2CV to check lvalueness */
1389 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1390 okid->op_next = kid->op_next;
1391 kid->op_next = okid;
1394 okid->op_next = NULL;
1395 okid->op_type = OP_RV2CV;
1397 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1398 okid->op_private |= OPpLVAL_INTRO;
1399 okid->op_private &= ~1;
1403 cv = GvCV(kGVOP_gv);
1413 /* grep, foreach, subcalls, refgen */
1414 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1416 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1417 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1419 : (o->op_type == OP_ENTERSUB
1420 ? "non-lvalue subroutine call"
1422 type ? PL_op_desc[type] : "local"));
1436 case OP_RIGHT_SHIFT:
1445 if (!(o->op_flags & OPf_STACKED))
1452 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1458 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1459 PL_modcount = RETURN_UNLIMITED_NUMBER;
1460 return o; /* Treat \(@foo) like ordinary list. */
1464 if (scalar_mod_type(o, type))
1466 ref(cUNOPo->op_first, o->op_type);
1470 if (type == OP_LEAVESUBLV)
1471 o->op_private |= OPpMAYBE_LVSUB;
1477 PL_modcount = RETURN_UNLIMITED_NUMBER;
1480 ref(cUNOPo->op_first, o->op_type);
1485 PL_hints |= HINT_BLOCK_SCOPE;
1500 PL_modcount = RETURN_UNLIMITED_NUMBER;
1501 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1502 return o; /* Treat \(@foo) like ordinary list. */
1503 if (scalar_mod_type(o, type))
1505 if (type == OP_LEAVESUBLV)
1506 o->op_private |= OPpMAYBE_LVSUB;
1510 if (!type) /* local() */
1511 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1512 PAD_COMPNAME_PV(o->op_targ));
1520 if (type != OP_SASSIGN)
1524 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1529 if (type == OP_LEAVESUBLV)
1530 o->op_private |= OPpMAYBE_LVSUB;
1532 pad_free(o->op_targ);
1533 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1534 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1535 if (o->op_flags & OPf_KIDS)
1536 mod(cBINOPo->op_first->op_sibling, type);
1541 ref(cBINOPo->op_first, o->op_type);
1542 if (type == OP_ENTERSUB &&
1543 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1544 o->op_private |= OPpLVAL_DEFER;
1545 if (type == OP_LEAVESUBLV)
1546 o->op_private |= OPpMAYBE_LVSUB;
1556 if (o->op_flags & OPf_KIDS)
1557 mod(cLISTOPo->op_last, type);
1562 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1564 else if (!(o->op_flags & OPf_KIDS))
1566 if (o->op_targ != OP_LIST) {
1567 mod(cBINOPo->op_first, type);
1573 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1578 if (type != OP_LEAVESUBLV)
1580 break; /* mod()ing was handled by ck_return() */
1583 /* [20011101.069] File test operators interpret OPf_REF to mean that
1584 their argument is a filehandle; thus \stat(".") should not set
1586 if (type == OP_REFGEN &&
1587 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1590 if (type != OP_LEAVESUBLV)
1591 o->op_flags |= OPf_MOD;
1593 if (type == OP_AASSIGN || type == OP_SASSIGN)
1594 o->op_flags |= OPf_SPECIAL|OPf_REF;
1595 else if (!type) { /* local() */
1598 o->op_private |= OPpLVAL_INTRO;
1599 o->op_flags &= ~OPf_SPECIAL;
1600 PL_hints |= HINT_BLOCK_SCOPE;
1605 if (ckWARN(WARN_SYNTAX)) {
1606 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1607 "Useless localization of %s", OP_DESC(o));
1611 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1612 && type != OP_LEAVESUBLV)
1613 o->op_flags |= OPf_REF;
1618 S_scalar_mod_type(const OP *o, I32 type)
1622 if (o->op_type == OP_RV2GV)
1646 case OP_RIGHT_SHIFT:
1666 S_is_handle_constructor(const OP *o, I32 numargs)
1668 switch (o->op_type) {
1676 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1689 Perl_refkids(pTHX_ OP *o, I32 type)
1691 if (o && o->op_flags & OPf_KIDS) {
1693 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1700 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
1705 if (!o || (PL_parser && PL_parser->error_count))
1708 switch (o->op_type) {
1710 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1711 !(o->op_flags & OPf_STACKED)) {
1712 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1713 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1714 assert(cUNOPo->op_first->op_type == OP_NULL);
1715 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1716 o->op_flags |= OPf_SPECIAL;
1717 o->op_private &= ~1;
1722 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1723 doref(kid, type, set_op_ref);
1726 if (type == OP_DEFINED)
1727 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1728 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1731 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1732 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1733 : type == OP_RV2HV ? OPpDEREF_HV
1735 o->op_flags |= OPf_MOD;
1742 o->op_flags |= OPf_REF;
1745 if (type == OP_DEFINED)
1746 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1747 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1753 o->op_flags |= OPf_REF;
1758 if (!(o->op_flags & OPf_KIDS))
1760 doref(cBINOPo->op_first, type, set_op_ref);
1764 doref(cBINOPo->op_first, o->op_type, set_op_ref);
1765 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1766 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1767 : type == OP_RV2HV ? OPpDEREF_HV
1769 o->op_flags |= OPf_MOD;
1779 if (!(o->op_flags & OPf_KIDS))
1781 doref(cLISTOPo->op_last, type, set_op_ref);
1791 S_dup_attrlist(pTHX_ OP *o)
1796 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1797 * where the first kid is OP_PUSHMARK and the remaining ones
1798 * are OP_CONST. We need to push the OP_CONST values.
1800 if (o->op_type == OP_CONST)
1801 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
1803 else if (o->op_type == OP_NULL)
1807 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1809 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1810 if (o->op_type == OP_CONST)
1811 rop = append_elem(OP_LIST, rop,
1812 newSVOP(OP_CONST, o->op_flags,
1813 SvREFCNT_inc_NN(cSVOPo->op_sv)));
1820 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1825 /* fake up C<use attributes $pkg,$rv,@attrs> */
1826 ENTER; /* need to protect against side-effects of 'use' */
1827 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1829 #define ATTRSMODULE "attributes"
1830 #define ATTRSMODULE_PM "attributes.pm"
1833 /* Don't force the C<use> if we don't need it. */
1834 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
1835 if (svp && *svp != &PL_sv_undef)
1836 NOOP; /* already in %INC */
1838 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1839 newSVpvs(ATTRSMODULE), NULL);
1842 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1843 newSVpvs(ATTRSMODULE),
1845 prepend_elem(OP_LIST,
1846 newSVOP(OP_CONST, 0, stashsv),
1847 prepend_elem(OP_LIST,
1848 newSVOP(OP_CONST, 0,
1850 dup_attrlist(attrs))));
1856 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1859 OP *pack, *imop, *arg;
1865 assert(target->op_type == OP_PADSV ||
1866 target->op_type == OP_PADHV ||
1867 target->op_type == OP_PADAV);
1869 /* Ensure that attributes.pm is loaded. */
1870 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1872 /* Need package name for method call. */
1873 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
1875 /* Build up the real arg-list. */
1876 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1878 arg = newOP(OP_PADSV, 0);
1879 arg->op_targ = target->op_targ;
1880 arg = prepend_elem(OP_LIST,
1881 newSVOP(OP_CONST, 0, stashsv),
1882 prepend_elem(OP_LIST,
1883 newUNOP(OP_REFGEN, 0,
1884 mod(arg, OP_REFGEN)),
1885 dup_attrlist(attrs)));
1887 /* Fake up a method call to import */
1888 meth = newSVpvs_share("import");
1889 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1890 append_elem(OP_LIST,
1891 prepend_elem(OP_LIST, pack, list(arg)),
1892 newSVOP(OP_METHOD_NAMED, 0, meth)));
1893 imop->op_private |= OPpENTERSUB_NOMOD;
1895 /* Combine the ops. */
1896 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1900 =notfor apidoc apply_attrs_string
1902 Attempts to apply a list of attributes specified by the C<attrstr> and
1903 C<len> arguments to the subroutine identified by the C<cv> argument which
1904 is expected to be associated with the package identified by the C<stashpv>
1905 argument (see L<attributes>). It gets this wrong, though, in that it
1906 does not correctly identify the boundaries of the individual attribute
1907 specifications within C<attrstr>. This is not really intended for the
1908 public API, but has to be listed here for systems such as AIX which
1909 need an explicit export list for symbols. (It's called from XS code
1910 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1911 to respect attribute syntax properly would be welcome.
1917 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
1918 const char *attrstr, STRLEN len)
1923 len = strlen(attrstr);
1927 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1929 const char * const sstr = attrstr;
1930 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1931 attrs = append_elem(OP_LIST, attrs,
1932 newSVOP(OP_CONST, 0,
1933 newSVpvn(sstr, attrstr-sstr)));
1937 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1938 newSVpvs(ATTRSMODULE),
1939 NULL, prepend_elem(OP_LIST,
1940 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1941 prepend_elem(OP_LIST,
1942 newSVOP(OP_CONST, 0,
1948 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
1953 if (!o || (PL_parser && PL_parser->error_count))
1957 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
1958 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
1962 if (type == OP_LIST) {
1964 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1965 my_kid(kid, attrs, imopsp);
1966 } else if (type == OP_UNDEF
1972 } else if (type == OP_RV2SV || /* "our" declaration */
1974 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1975 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1976 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1978 PL_parser->in_my == KEY_our
1980 : PL_parser->in_my == KEY_state ? "state" : "my"));
1982 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
1983 PL_parser->in_my = FALSE;
1984 PL_parser->in_my_stash = NULL;
1985 apply_attrs(GvSTASH(gv),
1986 (type == OP_RV2SV ? GvSV(gv) :
1987 type == OP_RV2AV ? (SV*)GvAV(gv) :
1988 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1991 o->op_private |= OPpOUR_INTRO;
1994 else if (type != OP_PADSV &&
1997 type != OP_PUSHMARK)
1999 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2001 PL_parser->in_my == KEY_our
2003 : PL_parser->in_my == KEY_state ? "state" : "my"));
2006 else if (attrs && type != OP_PUSHMARK) {
2009 PL_parser->in_my = FALSE;
2010 PL_parser->in_my_stash = NULL;
2012 /* check for C<my Dog $spot> when deciding package */
2013 stash = PAD_COMPNAME_TYPE(o->op_targ);
2015 stash = PL_curstash;
2016 apply_attrs_my(stash, o, attrs, imopsp);
2018 o->op_flags |= OPf_MOD;
2019 o->op_private |= OPpLVAL_INTRO;
2020 if (PL_parser->in_my == KEY_state)
2021 o->op_private |= OPpPAD_STATE;
2026 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2030 int maybe_scalar = 0;
2032 /* [perl #17376]: this appears to be premature, and results in code such as
2033 C< our(%x); > executing in list mode rather than void mode */
2035 if (o->op_flags & OPf_PARENS)
2045 o = my_kid(o, attrs, &rops);
2047 if (maybe_scalar && o->op_type == OP_PADSV) {
2048 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
2049 o->op_private |= OPpLVAL_INTRO;
2052 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
2054 PL_parser->in_my = FALSE;
2055 PL_parser->in_my_stash = NULL;
2060 Perl_my(pTHX_ OP *o)
2062 return my_attrs(o, NULL);
2066 Perl_sawparens(pTHX_ OP *o)
2068 PERL_UNUSED_CONTEXT;
2070 o->op_flags |= OPf_PARENS;
2075 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2079 const OPCODE ltype = left->op_type;
2080 const OPCODE rtype = right->op_type;
2082 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2083 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
2085 const char * const desc
2086 = PL_op_desc[(rtype == OP_SUBST || rtype == OP_TRANS)
2087 ? (int)rtype : OP_MATCH];
2088 const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV)
2089 ? "@array" : "%hash");
2090 Perl_warner(aTHX_ packWARN(WARN_MISC),
2091 "Applying %s to %s will act on scalar(%s)",
2092 desc, sample, sample);
2095 if (rtype == OP_CONST &&
2096 cSVOPx(right)->op_private & OPpCONST_BARE &&
2097 cSVOPx(right)->op_private & OPpCONST_STRICT)
2099 no_bareword_allowed(right);
2102 ismatchop = rtype == OP_MATCH ||
2103 rtype == OP_SUBST ||
2105 if (ismatchop && right->op_private & OPpTARGET_MY) {
2107 right->op_private &= ~OPpTARGET_MY;
2109 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
2112 right->op_flags |= OPf_STACKED;
2113 if (rtype != OP_MATCH &&
2114 ! (rtype == OP_TRANS &&
2115 right->op_private & OPpTRANS_IDENTICAL))
2116 newleft = mod(left, rtype);
2119 if (right->op_type == OP_TRANS)
2120 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
2122 o = prepend_elem(rtype, scalar(newleft), right);
2124 return newUNOP(OP_NOT, 0, scalar(o));
2128 return bind_match(type, left,
2129 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
2133 Perl_invert(pTHX_ OP *o)
2137 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2141 Perl_scope(pTHX_ OP *o)
2145 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2146 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2147 o->op_type = OP_LEAVE;
2148 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2150 else if (o->op_type == OP_LINESEQ) {
2152 o->op_type = OP_SCOPE;
2153 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2154 kid = ((LISTOP*)o)->op_first;
2155 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2158 /* The following deals with things like 'do {1 for 1}' */
2159 kid = kid->op_sibling;
2161 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2166 o = newLISTOP(OP_SCOPE, 0, o, NULL);
2172 Perl_block_start(pTHX_ int full)
2175 const int retval = PL_savestack_ix;
2176 pad_block_start(full);
2178 PL_hints &= ~HINT_BLOCK_SCOPE;
2179 SAVECOMPILEWARNINGS();
2180 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
2185 Perl_block_end(pTHX_ I32 floor, OP *seq)
2188 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2189 OP* const retval = scalarseq(seq);
2191 CopHINTS_set(&PL_compiling, PL_hints);
2193 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2202 const PADOFFSET offset = pad_findmy("$_");
2203 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
2204 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2207 OP * const o = newOP(OP_PADSV, 0);
2208 o->op_targ = offset;
2214 Perl_newPROG(pTHX_ OP *o)
2220 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2221 ((PL_in_eval & EVAL_KEEPERR)
2222 ? OPf_SPECIAL : 0), o);
2223 PL_eval_start = linklist(PL_eval_root);
2224 PL_eval_root->op_private |= OPpREFCOUNTED;
2225 OpREFCNT_set(PL_eval_root, 1);
2226 PL_eval_root->op_next = 0;
2227 CALL_PEEP(PL_eval_start);
2230 if (o->op_type == OP_STUB) {
2231 PL_comppad_name = 0;
2233 S_op_destroy(aTHX_ o);
2236 PL_main_root = scope(sawparens(scalarvoid(o)));
2237 PL_curcop = &PL_compiling;
2238 PL_main_start = LINKLIST(PL_main_root);
2239 PL_main_root->op_private |= OPpREFCOUNTED;
2240 OpREFCNT_set(PL_main_root, 1);
2241 PL_main_root->op_next = 0;
2242 CALL_PEEP(PL_main_start);
2245 /* Register with debugger */
2248 = Perl_get_cvn_flags(aTHX_ STR_WITH_LEN("DB::postponed"), 0);
2252 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2254 call_sv((SV*)cv, G_DISCARD);
2261 Perl_localize(pTHX_ OP *o, I32 lex)
2264 if (o->op_flags & OPf_PARENS)
2265 /* [perl #17376]: this appears to be premature, and results in code such as
2266 C< our(%x); > executing in list mode rather than void mode */
2273 if ( PL_parser->bufptr > PL_parser->oldbufptr
2274 && PL_parser->bufptr[-1] == ','
2275 && ckWARN(WARN_PARENTHESIS))
2277 char *s = PL_parser->bufptr;
2280 /* some heuristics to detect a potential error */
2281 while (*s && (strchr(", \t\n", *s)))
2285 if (*s && strchr("@$%*", *s) && *++s
2286 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2289 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2291 while (*s && (strchr(", \t\n", *s)))
2297 if (sigil && (*s == ';' || *s == '=')) {
2298 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2299 "Parentheses missing around \"%s\" list",
2301 ? (PL_parser->in_my == KEY_our
2303 : PL_parser->in_my == KEY_state
2313 o = mod(o, OP_NULL); /* a bit kludgey */
2314 PL_parser->in_my = FALSE;
2315 PL_parser->in_my_stash = NULL;
2320 Perl_jmaybe(pTHX_ OP *o)
2322 if (o->op_type == OP_LIST) {
2324 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2325 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2331 Perl_fold_constants(pTHX_ register OP *o)
2336 VOL I32 type = o->op_type;
2341 SV * const oldwarnhook = PL_warnhook;
2342 SV * const olddiehook = PL_diehook;
2345 if (PL_opargs[type] & OA_RETSCALAR)
2347 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2348 o->op_targ = pad_alloc(type, SVs_PADTMP);
2350 /* integerize op, unless it happens to be C<-foo>.
2351 * XXX should pp_i_negate() do magic string negation instead? */
2352 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2353 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2354 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2356 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2359 if (!(PL_opargs[type] & OA_FOLDCONST))
2364 /* XXX might want a ck_negate() for this */
2365 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2376 /* XXX what about the numeric ops? */
2377 if (PL_hints & HINT_LOCALE)
2381 if (PL_parser && PL_parser->error_count)
2382 goto nope; /* Don't try to run w/ errors */
2384 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2385 const OPCODE type = curop->op_type;
2386 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2388 type != OP_SCALAR &&
2390 type != OP_PUSHMARK)
2396 curop = LINKLIST(o);
2397 old_next = o->op_next;
2401 oldscope = PL_scopestack_ix;
2402 create_eval_scope(G_FAKINGEVAL);
2404 PL_warnhook = PERL_WARNHOOK_FATAL;
2411 sv = *(PL_stack_sp--);
2412 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2413 pad_swipe(o->op_targ, FALSE);
2414 else if (SvTEMP(sv)) { /* grab mortal temp? */
2415 SvREFCNT_inc_simple_void(sv);
2420 /* Something tried to die. Abandon constant folding. */
2421 /* Pretend the error never happened. */
2422 sv_setpvn(ERRSV,"",0);
2423 o->op_next = old_next;
2427 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
2428 PL_warnhook = oldwarnhook;
2429 PL_diehook = olddiehook;
2430 /* XXX note that this croak may fail as we've already blown away
2431 * the stack - eg any nested evals */
2432 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
2435 PL_warnhook = oldwarnhook;
2436 PL_diehook = olddiehook;
2438 if (PL_scopestack_ix > oldscope)
2439 delete_eval_scope();
2448 if (type == OP_RV2GV)
2449 newop = newGVOP(OP_GV, 0, (GV*)sv);
2451 newop = newSVOP(OP_CONST, 0, (SV*)sv);
2452 op_getmad(o,newop,'f');
2460 Perl_gen_constant_list(pTHX_ register OP *o)
2464 const I32 oldtmps_floor = PL_tmps_floor;
2467 if (PL_parser && PL_parser->error_count)
2468 return o; /* Don't attempt to run with errors */
2470 PL_op = curop = LINKLIST(o);
2476 assert (!(curop->op_flags & OPf_SPECIAL));
2477 assert(curop->op_type == OP_RANGE);
2479 PL_tmps_floor = oldtmps_floor;
2481 o->op_type = OP_RV2AV;
2482 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2483 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2484 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2485 o->op_opt = 0; /* needs to be revisited in peep() */
2486 curop = ((UNOP*)o)->op_first;
2487 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
2489 op_getmad(curop,o,'O');
2498 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2501 if (!o || o->op_type != OP_LIST)
2502 o = newLISTOP(OP_LIST, 0, o, NULL);
2504 o->op_flags &= ~OPf_WANT;
2506 if (!(PL_opargs[type] & OA_MARK))
2507 op_null(cLISTOPo->op_first);
2509 o->op_type = (OPCODE)type;
2510 o->op_ppaddr = PL_ppaddr[type];
2511 o->op_flags |= flags;
2513 o = CHECKOP(type, o);
2514 if (o->op_type != (unsigned)type)
2517 return fold_constants(o);
2520 /* List constructors */
2523 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2531 if (first->op_type != (unsigned)type
2532 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2534 return newLISTOP(type, 0, first, last);
2537 if (first->op_flags & OPf_KIDS)
2538 ((LISTOP*)first)->op_last->op_sibling = last;
2540 first->op_flags |= OPf_KIDS;
2541 ((LISTOP*)first)->op_first = last;
2543 ((LISTOP*)first)->op_last = last;
2548 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2556 if (first->op_type != (unsigned)type)
2557 return prepend_elem(type, (OP*)first, (OP*)last);
2559 if (last->op_type != (unsigned)type)
2560 return append_elem(type, (OP*)first, (OP*)last);
2562 first->op_last->op_sibling = last->op_first;
2563 first->op_last = last->op_last;
2564 first->op_flags |= (last->op_flags & OPf_KIDS);
2567 if (last->op_first && first->op_madprop) {
2568 MADPROP *mp = last->op_first->op_madprop;
2570 while (mp->mad_next)
2572 mp->mad_next = first->op_madprop;
2575 last->op_first->op_madprop = first->op_madprop;
2578 first->op_madprop = last->op_madprop;
2579 last->op_madprop = 0;
2582 S_op_destroy(aTHX_ (OP*)last);
2588 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2596 if (last->op_type == (unsigned)type) {
2597 if (type == OP_LIST) { /* already a PUSHMARK there */
2598 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2599 ((LISTOP*)last)->op_first->op_sibling = first;
2600 if (!(first->op_flags & OPf_PARENS))
2601 last->op_flags &= ~OPf_PARENS;
2604 if (!(last->op_flags & OPf_KIDS)) {
2605 ((LISTOP*)last)->op_last = first;
2606 last->op_flags |= OPf_KIDS;
2608 first->op_sibling = ((LISTOP*)last)->op_first;
2609 ((LISTOP*)last)->op_first = first;
2611 last->op_flags |= OPf_KIDS;
2615 return newLISTOP(type, 0, first, last);
2623 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2626 Newxz(tk, 1, TOKEN);
2627 tk->tk_type = (OPCODE)optype;
2628 tk->tk_type = 12345;
2630 tk->tk_mad = madprop;
2635 Perl_token_free(pTHX_ TOKEN* tk)
2637 if (tk->tk_type != 12345)
2639 mad_free(tk->tk_mad);
2644 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2648 if (tk->tk_type != 12345) {
2649 Perl_warner(aTHX_ packWARN(WARN_MISC),
2650 "Invalid TOKEN object ignored");
2657 /* faked up qw list? */
2659 tm->mad_type == MAD_SV &&
2660 SvPVX((SV*)tm->mad_val)[0] == 'q')
2667 /* pretend constant fold didn't happen? */
2668 if (mp->mad_key == 'f' &&
2669 (o->op_type == OP_CONST ||
2670 o->op_type == OP_GV) )
2672 token_getmad(tk,(OP*)mp->mad_val,slot);
2686 if (mp->mad_key == 'X')
2687 mp->mad_key = slot; /* just change the first one */
2697 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
2706 /* pretend constant fold didn't happen? */
2707 if (mp->mad_key == 'f' &&
2708 (o->op_type == OP_CONST ||
2709 o->op_type == OP_GV) )
2711 op_getmad(from,(OP*)mp->mad_val,slot);
2718 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
2721 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
2727 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
2736 /* pretend constant fold didn't happen? */
2737 if (mp->mad_key == 'f' &&
2738 (o->op_type == OP_CONST ||
2739 o->op_type == OP_GV) )
2741 op_getmad(from,(OP*)mp->mad_val,slot);
2748 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
2751 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
2755 PerlIO_printf(PerlIO_stderr(),
2756 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
2762 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
2780 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
2784 addmad(tm, &(o->op_madprop), slot);
2788 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
2809 Perl_newMADsv(pTHX_ char key, SV* sv)
2811 return newMADPROP(key, MAD_SV, sv, 0);
2815 Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
2818 Newxz(mp, 1, MADPROP);
2821 mp->mad_vlen = vlen;
2822 mp->mad_type = type;
2824 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
2829 Perl_mad_free(pTHX_ MADPROP* mp)
2831 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
2835 mad_free(mp->mad_next);
2836 /* if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
2837 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
2838 switch (mp->mad_type) {
2842 Safefree((char*)mp->mad_val);
2845 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
2846 op_free((OP*)mp->mad_val);
2849 sv_free((SV*)mp->mad_val);
2852 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
2861 Perl_newNULLLIST(pTHX)
2863 return newOP(OP_STUB, 0);
2867 Perl_force_list(pTHX_ OP *o)
2869 if (!o || o->op_type != OP_LIST)
2870 o = newLISTOP(OP_LIST, 0, o, NULL);
2876 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2881 NewOp(1101, listop, 1, LISTOP);
2883 listop->op_type = (OPCODE)type;
2884 listop->op_ppaddr = PL_ppaddr[type];
2887 listop->op_flags = (U8)flags;
2891 else if (!first && last)
2894 first->op_sibling = last;
2895 listop->op_first = first;
2896 listop->op_last = last;
2897 if (type == OP_LIST) {
2898 OP* const pushop = newOP(OP_PUSHMARK, 0);
2899 pushop->op_sibling = first;
2900 listop->op_first = pushop;
2901 listop->op_flags |= OPf_KIDS;
2903 listop->op_last = pushop;
2906 return CHECKOP(type, listop);
2910 Perl_newOP(pTHX_ I32 type, I32 flags)
2914 NewOp(1101, o, 1, OP);
2915 o->op_type = (OPCODE)type;
2916 o->op_ppaddr = PL_ppaddr[type];
2917 o->op_flags = (U8)flags;
2919 o->op_latefreed = 0;
2923 o->op_private = (U8)(0 | (flags >> 8));
2924 if (PL_opargs[type] & OA_RETSCALAR)
2926 if (PL_opargs[type] & OA_TARGET)
2927 o->op_targ = pad_alloc(type, SVs_PADTMP);
2928 return CHECKOP(type, o);
2932 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2938 first = newOP(OP_STUB, 0);
2939 if (PL_opargs[type] & OA_MARK)
2940 first = force_list(first);
2942 NewOp(1101, unop, 1, UNOP);
2943 unop->op_type = (OPCODE)type;
2944 unop->op_ppaddr = PL_ppaddr[type];
2945 unop->op_first = first;
2946 unop->op_flags = (U8)(flags | OPf_KIDS);
2947 unop->op_private = (U8)(1 | (flags >> 8));
2948 unop = (UNOP*) CHECKOP(type, unop);
2952 return fold_constants((OP *) unop);
2956 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2960 NewOp(1101, binop, 1, BINOP);
2963 first = newOP(OP_NULL, 0);
2965 binop->op_type = (OPCODE)type;
2966 binop->op_ppaddr = PL_ppaddr[type];
2967 binop->op_first = first;
2968 binop->op_flags = (U8)(flags | OPf_KIDS);
2971 binop->op_private = (U8)(1 | (flags >> 8));
2974 binop->op_private = (U8)(2 | (flags >> 8));
2975 first->op_sibling = last;
2978 binop = (BINOP*)CHECKOP(type, binop);
2979 if (binop->op_next || binop->op_type != (OPCODE)type)
2982 binop->op_last = binop->op_first->op_sibling;
2984 return fold_constants((OP *)binop);
2987 static int uvcompare(const void *a, const void *b)
2988 __attribute__nonnull__(1)
2989 __attribute__nonnull__(2)
2990 __attribute__pure__;
2991 static int uvcompare(const void *a, const void *b)
2993 if (*((const UV *)a) < (*(const UV *)b))
2995 if (*((const UV *)a) > (*(const UV *)b))
2997 if (*((const UV *)a+1) < (*(const UV *)b+1))
2999 if (*((const UV *)a+1) > (*(const UV *)b+1))
3005 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
3008 SV * const tstr = ((SVOP*)expr)->op_sv;
3011 (repl->op_type == OP_NULL)
3012 ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
3014 ((SVOP*)repl)->op_sv;
3017 const U8 *t = (U8*)SvPV_const(tstr, tlen);
3018 const U8 *r = (U8*)SvPV_const(rstr, rlen);
3022 register short *tbl;
3024 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
3025 const I32 squash = o->op_private & OPpTRANS_SQUASH;
3026 I32 del = o->op_private & OPpTRANS_DELETE;
3028 PL_hints |= HINT_BLOCK_SCOPE;
3031 o->op_private |= OPpTRANS_FROM_UTF;
3034 o->op_private |= OPpTRANS_TO_UTF;
3036 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
3037 SV* const listsv = newSVpvs("# comment\n");
3039 const U8* tend = t + tlen;
3040 const U8* rend = r + rlen;
3054 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
3055 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
3058 const U32 flags = UTF8_ALLOW_DEFAULT;
3062 t = tsave = bytes_to_utf8(t, &len);
3065 if (!to_utf && rlen) {
3067 r = rsave = bytes_to_utf8(r, &len);
3071 /* There are several snags with this code on EBCDIC:
3072 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
3073 2. scan_const() in toke.c has encoded chars in native encoding which makes
3074 ranges at least in EBCDIC 0..255 range the bottom odd.
3078 U8 tmpbuf[UTF8_MAXBYTES+1];
3081 Newx(cp, 2*tlen, UV);
3083 transv = newSVpvs("");
3085 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3087 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
3089 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3093 cp[2*i+1] = cp[2*i];
3097 qsort(cp, i, 2*sizeof(UV), uvcompare);
3098 for (j = 0; j < i; j++) {
3100 diff = val - nextmin;
3102 t = uvuni_to_utf8(tmpbuf,nextmin);
3103 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3105 U8 range_mark = UTF_TO_NATIVE(0xff);
3106 t = uvuni_to_utf8(tmpbuf, val - 1);
3107 sv_catpvn(transv, (char *)&range_mark, 1);
3108 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3115 t = uvuni_to_utf8(tmpbuf,nextmin);
3116 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3118 U8 range_mark = UTF_TO_NATIVE(0xff);
3119 sv_catpvn(transv, (char *)&range_mark, 1);
3121 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
3122 UNICODE_ALLOW_SUPER);
3123 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3124 t = (const U8*)SvPVX_const(transv);
3125 tlen = SvCUR(transv);
3129 else if (!rlen && !del) {
3130 r = t; rlen = tlen; rend = tend;
3133 if ((!rlen && !del) || t == r ||
3134 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
3136 o->op_private |= OPpTRANS_IDENTICAL;
3140 while (t < tend || tfirst <= tlast) {
3141 /* see if we need more "t" chars */
3142 if (tfirst > tlast) {
3143 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3145 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
3147 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3154 /* now see if we need more "r" chars */
3155 if (rfirst > rlast) {
3157 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3159 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
3161 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3170 rfirst = rlast = 0xffffffff;
3174 /* now see which range will peter our first, if either. */
3175 tdiff = tlast - tfirst;
3176 rdiff = rlast - rfirst;
3183 if (rfirst == 0xffffffff) {
3184 diff = tdiff; /* oops, pretend rdiff is infinite */
3186 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
3187 (long)tfirst, (long)tlast);
3189 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
3193 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
3194 (long)tfirst, (long)(tfirst + diff),
3197 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3198 (long)tfirst, (long)rfirst);
3200 if (rfirst + diff > max)
3201 max = rfirst + diff;
3203 grows = (tfirst < rfirst &&
3204 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3216 else if (max > 0xff)
3221 PerlMemShared_free(cPVOPo->op_pv);
3222 cPVOPo->op_pv = NULL;
3224 swash = (SV*)swash_init("utf8", "", listsv, bits, none);
3226 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
3227 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
3228 PAD_SETSV(cPADOPo->op_padix, swash);
3231 cSVOPo->op_sv = swash;
3233 SvREFCNT_dec(listsv);
3234 SvREFCNT_dec(transv);
3236 if (!del && havefinal && rlen)
3237 (void)hv_store((HV*)SvRV(swash), "FINAL", 5,
3238 newSVuv((UV)final), 0);
3241 o->op_private |= OPpTRANS_GROWS;
3247 op_getmad(expr,o,'e');
3248 op_getmad(repl,o,'r');
3256 tbl = (short*)cPVOPo->op_pv;
3258 Zero(tbl, 256, short);
3259 for (i = 0; i < (I32)tlen; i++)
3261 for (i = 0, j = 0; i < 256; i++) {
3263 if (j >= (I32)rlen) {
3272 if (i < 128 && r[j] >= 128)
3282 o->op_private |= OPpTRANS_IDENTICAL;
3284 else if (j >= (I32)rlen)
3289 PerlMemShared_realloc(tbl,
3290 (0x101+rlen-j) * sizeof(short));
3291 cPVOPo->op_pv = (char*)tbl;
3293 tbl[0x100] = (short)(rlen - j);
3294 for (i=0; i < (I32)rlen - j; i++)
3295 tbl[0x101+i] = r[j+i];
3299 if (!rlen && !del) {
3302 o->op_private |= OPpTRANS_IDENTICAL;
3304 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3305 o->op_private |= OPpTRANS_IDENTICAL;
3307 for (i = 0; i < 256; i++)
3309 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3310 if (j >= (I32)rlen) {
3312 if (tbl[t[i]] == -1)
3318 if (tbl[t[i]] == -1) {
3319 if (t[i] < 128 && r[j] >= 128)
3326 o->op_private |= OPpTRANS_GROWS;
3328 op_getmad(expr,o,'e');
3329 op_getmad(repl,o,'r');
3339 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3344 NewOp(1101, pmop, 1, PMOP);
3345 pmop->op_type = (OPCODE)type;
3346 pmop->op_ppaddr = PL_ppaddr[type];
3347 pmop->op_flags = (U8)flags;
3348 pmop->op_private = (U8)(0 | (flags >> 8));
3350 if (PL_hints & HINT_RE_TAINT)
3351 pmop->op_pmflags |= PMf_RETAINT;
3352 if (PL_hints & HINT_LOCALE)
3353 pmop->op_pmflags |= PMf_LOCALE;
3357 if (av_len((AV*) PL_regex_pad[0]) > -1) {
3358 SV * const repointer = av_pop((AV*)PL_regex_pad[0]);
3359 pmop->op_pmoffset = SvIV(repointer);
3360 SvREPADTMP_off(repointer);
3361 sv_setiv(repointer,0);
3363 SV * const repointer = newSViv(0);
3364 av_push(PL_regex_padav, SvREFCNT_inc_simple_NN(repointer));
3365 pmop->op_pmoffset = av_len(PL_regex_padav);
3366 PL_regex_pad = AvARRAY(PL_regex_padav);
3370 return CHECKOP(type, pmop);
3373 /* Given some sort of match op o, and an expression expr containing a
3374 * pattern, either compile expr into a regex and attach it to o (if it's
3375 * constant), or convert expr into a runtime regcomp op sequence (if it's
3378 * isreg indicates that the pattern is part of a regex construct, eg
3379 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3380 * split "pattern", which aren't. In the former case, expr will be a list
3381 * if the pattern contains more than one term (eg /a$b/) or if it contains
3382 * a replacement, ie s/// or tr///.
3386 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
3391 I32 repl_has_vars = 0;
3395 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
3396 /* last element in list is the replacement; pop it */
3398 repl = cLISTOPx(expr)->op_last;
3399 kid = cLISTOPx(expr)->op_first;
3400 while (kid->op_sibling != repl)
3401 kid = kid->op_sibling;
3402 kid->op_sibling = NULL;
3403 cLISTOPx(expr)->op_last = kid;
3406 if (isreg && expr->op_type == OP_LIST &&
3407 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3409 /* convert single element list to element */
3410 OP* const oe = expr;
3411 expr = cLISTOPx(oe)->op_first->op_sibling;
3412 cLISTOPx(oe)->op_first->op_sibling = NULL;
3413 cLISTOPx(oe)->op_last = NULL;
3417 if (o->op_type == OP_TRANS) {
3418 return pmtrans(o, expr, repl);
3421 reglist = isreg && expr->op_type == OP_LIST;
3425 PL_hints |= HINT_BLOCK_SCOPE;
3428 if (expr->op_type == OP_CONST) {
3429 SV * const pat = ((SVOP*)expr)->op_sv;
3430 U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
3432 if (o->op_flags & OPf_SPECIAL)
3433 pm_flags |= RXf_SPLIT;
3436 pm_flags |= RXf_UTF8;
3438 PM_SETRE(pm, CALLREGCOMP(pat, pm_flags));
3441 op_getmad(expr,(OP*)pm,'e');
3447 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3448 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3450 : OP_REGCMAYBE),0,expr);
3452 NewOp(1101, rcop, 1, LOGOP);
3453 rcop->op_type = OP_REGCOMP;
3454 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3455 rcop->op_first = scalar(expr);
3456 rcop->op_flags |= OPf_KIDS
3457 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3458 | (reglist ? OPf_STACKED : 0);
3459 rcop->op_private = 1;
3462 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3464 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
3467 /* establish postfix order */
3468 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3470 rcop->op_next = expr;
3471 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3474 rcop->op_next = LINKLIST(expr);
3475 expr->op_next = (OP*)rcop;
3478 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3483 if (pm->op_pmflags & PMf_EVAL) {
3485 if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
3486 CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
3488 else if (repl->op_type == OP_CONST)
3492 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3493 if (curop->op_type == OP_SCOPE
3494 || curop->op_type == OP_LEAVE
3495 || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
3496 if (curop->op_type == OP_GV) {
3497 GV * const gv = cGVOPx_gv(curop);
3499 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3502 else if (curop->op_type == OP_RV2CV)
3504 else if (curop->op_type == OP_RV2SV ||
3505 curop->op_type == OP_RV2AV ||
3506 curop->op_type == OP_RV2HV ||
3507 curop->op_type == OP_RV2GV) {
3508 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3511 else if (curop->op_type == OP_PADSV ||
3512 curop->op_type == OP_PADAV ||
3513 curop->op_type == OP_PADHV ||
3514 curop->op_type == OP_PADANY)
3518 else if (curop->op_type == OP_PUSHRE)
3519 NOOP; /* Okay here, dangerous in newASSIGNOP */
3529 || PM_GETRE(pm)->extflags & RXf_EVAL_SEEN)))
3531 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3532 prepend_elem(o->op_type, scalar(repl), o);
3535 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3536 pm->op_pmflags |= PMf_MAYBE_CONST;
3538 NewOp(1101, rcop, 1, LOGOP);
3539 rcop->op_type = OP_SUBSTCONT;
3540 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3541 rcop->op_first = scalar(repl);
3542 rcop->op_flags |= OPf_KIDS;
3543 rcop->op_private = 1;
3546 /* establish postfix order */
3547 rcop->op_next = LINKLIST(repl);
3548 repl->op_next = (OP*)rcop;
3550 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
3551 assert(!(pm->op_pmflags & PMf_ONCE));
3552 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
3561 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3565 NewOp(1101, svop, 1, SVOP);
3566 svop->op_type = (OPCODE)type;
3567 svop->op_ppaddr = PL_ppaddr[type];
3569 svop->op_next = (OP*)svop;
3570 svop->op_flags = (U8)flags;
3571 if (PL_opargs[type] & OA_RETSCALAR)
3573 if (PL_opargs[type] & OA_TARGET)
3574 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3575 return CHECKOP(type, svop);
3580 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3584 NewOp(1101, padop, 1, PADOP);
3585 padop->op_type = (OPCODE)type;
3586 padop->op_ppaddr = PL_ppaddr[type];
3587 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3588 SvREFCNT_dec(PAD_SVl(padop->op_padix));
3589 PAD_SETSV(padop->op_padix, sv);
3592 padop->op_next = (OP*)padop;
3593 padop->op_flags = (U8)flags;
3594 if (PL_opargs[type] & OA_RETSCALAR)
3596 if (PL_opargs[type] & OA_TARGET)
3597 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3598 return CHECKOP(type, padop);
3603 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3609 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3611 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3616 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3620 NewOp(1101, pvop, 1, PVOP);
3621 pvop->op_type = (OPCODE)type;
3622 pvop->op_ppaddr = PL_ppaddr[type];
3624 pvop->op_next = (OP*)pvop;
3625 pvop->op_flags = (U8)flags;
3626 if (PL_opargs[type] & OA_RETSCALAR)
3628 if (PL_opargs[type] & OA_TARGET)
3629 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3630 return CHECKOP(type, pvop);
3638 Perl_package(pTHX_ OP *o)
3641 SV *const sv = cSVOPo->op_sv;
3646 save_hptr(&PL_curstash);
3647 save_item(PL_curstname);
3649 PL_curstash = gv_stashsv(sv, GV_ADD);
3651 sv_setsv(PL_curstname, sv);
3653 PL_hints |= HINT_BLOCK_SCOPE;
3654 PL_parser->copline = NOLINE;
3655 PL_parser->expect = XSTATE;
3660 if (!PL_madskills) {
3665 pegop = newOP(OP_NULL,0);
3666 op_getmad(o,pegop,'P');
3676 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3683 OP *pegop = newOP(OP_NULL,0);
3686 if (idop->op_type != OP_CONST)
3687 Perl_croak(aTHX_ "Module name must be constant");
3690 op_getmad(idop,pegop,'U');
3695 SV * const vesv = ((SVOP*)version)->op_sv;
3698 op_getmad(version,pegop,'V');
3699 if (!arg && !SvNIOKp(vesv)) {
3706 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3707 Perl_croak(aTHX_ "Version number must be constant number");
3709 /* Make copy of idop so we don't free it twice */
3710 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3712 /* Fake up a method call to VERSION */
3713 meth = newSVpvs_share("VERSION");
3714 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3715 append_elem(OP_LIST,
3716 prepend_elem(OP_LIST, pack, list(version)),
3717 newSVOP(OP_METHOD_NAMED, 0, meth)));
3721 /* Fake up an import/unimport */
3722 if (arg && arg->op_type == OP_STUB) {
3724 op_getmad(arg,pegop,'S');
3725 imop = arg; /* no import on explicit () */
3727 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3728 imop = NULL; /* use 5.0; */
3730 idop->op_private |= OPpCONST_NOVER;
3736 op_getmad(arg,pegop,'A');
3738 /* Make copy of idop so we don't free it twice */
3739 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3741 /* Fake up a method call to import/unimport */
3743 ? newSVpvs_share("import") : newSVpvs_share("unimport");
3744 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3745 append_elem(OP_LIST,
3746 prepend_elem(OP_LIST, pack, list(arg)),
3747 newSVOP(OP_METHOD_NAMED, 0, meth)));
3750 /* Fake up the BEGIN {}, which does its thing immediately. */
3752 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
3755 append_elem(OP_LINESEQ,
3756 append_elem(OP_LINESEQ,
3757 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
3758 newSTATEOP(0, NULL, veop)),
3759 newSTATEOP(0, NULL, imop) ));
3761 /* The "did you use incorrect case?" warning used to be here.
3762 * The problem is that on case-insensitive filesystems one
3763 * might get false positives for "use" (and "require"):
3764 * "use Strict" or "require CARP" will work. This causes
3765 * portability problems for the script: in case-strict
3766 * filesystems the script will stop working.
3768 * The "incorrect case" warning checked whether "use Foo"
3769 * imported "Foo" to your namespace, but that is wrong, too:
3770 * there is no requirement nor promise in the language that
3771 * a Foo.pm should or would contain anything in package "Foo".
3773 * There is very little Configure-wise that can be done, either:
3774 * the case-sensitivity of the build filesystem of Perl does not
3775 * help in guessing the case-sensitivity of the runtime environment.
3778 PL_hints |= HINT_BLOCK_SCOPE;
3779 PL_parser->copline = NOLINE;
3780 PL_parser->expect = XSTATE;
3781 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3784 if (!PL_madskills) {
3785 /* FIXME - don't allocate pegop if !PL_madskills */
3794 =head1 Embedding Functions
3796 =for apidoc load_module
3798 Loads the module whose name is pointed to by the string part of name.
3799 Note that the actual module name, not its filename, should be given.
3800 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3801 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3802 (or 0 for no flags). ver, if specified, provides version semantics
3803 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3804 arguments can be used to specify arguments to the module's import()
3805 method, similar to C<use Foo::Bar VERSION LIST>.
3810 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3813 va_start(args, ver);
3814 vload_module(flags, name, ver, &args);
3818 #ifdef PERL_IMPLICIT_CONTEXT
3820 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3824 va_start(args, ver);
3825 vload_module(flags, name, ver, &args);
3831 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3836 OP * const modname = newSVOP(OP_CONST, 0, name);
3837 modname->op_private |= OPpCONST_BARE;
3839 veop = newSVOP(OP_CONST, 0, ver);
3843 if (flags & PERL_LOADMOD_NOIMPORT) {
3844 imop = sawparens(newNULLLIST());
3846 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3847 imop = va_arg(*args, OP*);
3852 sv = va_arg(*args, SV*);
3854 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3855 sv = va_arg(*args, SV*);
3859 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
3860 * that it has a PL_parser to play with while doing that, and also
3861 * that it doesn't mess with any existing parser, by creating a tmp
3862 * new parser with lex_start(). This won't actually be used for much,
3863 * since pp_require() will create another parser for the real work. */
3866 SAVEVPTR(PL_curcop);
3867 lex_start(NULL, NULL, FALSE);
3868 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3869 veop, modname, imop);
3874 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
3880 if (!force_builtin) {
3881 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
3882 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
3883 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
3884 gv = gvp ? *gvp : NULL;
3888 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3889 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3890 append_elem(OP_LIST, term,
3891 scalar(newUNOP(OP_RV2CV, 0,
3892 newGVOP(OP_GV, 0, gv))))));
3895 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3901 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3903 return newBINOP(OP_LSLICE, flags,
3904 list(force_list(subscript)),
3905 list(force_list(listval)) );
3909 S_is_list_assignment(pTHX_ register const OP *o)
3917 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
3918 o = cUNOPo->op_first;
3920 flags = o->op_flags;
3922 if (type == OP_COND_EXPR) {
3923 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
3924 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3929 yyerror("Assignment to both a list and a scalar");
3933 if (type == OP_LIST &&
3934 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
3935 o->op_private & OPpLVAL_INTRO)
3938 if (type == OP_LIST || flags & OPf_PARENS ||
3939 type == OP_RV2AV || type == OP_RV2HV ||
3940 type == OP_ASLICE || type == OP_HSLICE)
3943 if (type == OP_PADAV || type == OP_PADHV)
3946 if (type == OP_RV2SV)
3953 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3959 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3960 return newLOGOP(optype, 0,
3961 mod(scalar(left), optype),
3962 newUNOP(OP_SASSIGN, 0, scalar(right)));
3965 return newBINOP(optype, OPf_STACKED,
3966 mod(scalar(left), optype), scalar(right));
3970 if (is_list_assignment(left)) {
3971 static const char no_list_state[] = "Initialization of state variables"
3972 " in list context currently forbidden";
3976 /* Grandfathering $[ assignment here. Bletch.*/
3977 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
3978 PL_eval_start = (left->op_type == OP_CONST) ? right : NULL;
3979 left = mod(left, OP_AASSIGN);
3982 else if (left->op_type == OP_CONST) {
3984 /* Result of assignment is always 1 (or we'd be dead already) */
3985 return newSVOP(OP_CONST, 0, newSViv(1));
3987 curop = list(force_list(left));
3988 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3989 o->op_private = (U8)(0 | (flags >> 8));
3991 /* PL_generation sorcery:
3992 * an assignment like ($a,$b) = ($c,$d) is easier than
3993 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3994 * To detect whether there are common vars, the global var
3995 * PL_generation is incremented for each assign op we compile.
3996 * Then, while compiling the assign op, we run through all the
3997 * variables on both sides of the assignment, setting a spare slot
3998 * in each of them to PL_generation. If any of them already have
3999 * that value, we know we've got commonality. We could use a
4000 * single bit marker, but then we'd have to make 2 passes, first
4001 * to clear the flag, then to test and set it. To find somewhere
4002 * to store these values, evil chicanery is done with SvUVX().
4008 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4009 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
4010 if (curop->op_type == OP_GV) {
4011 GV *gv = cGVOPx_gv(curop);
4013 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4015 GvASSIGN_GENERATION_set(gv, PL_generation);
4017 else if (curop->op_type == OP_PADSV ||
4018 curop->op_type == OP_PADAV ||
4019 curop->op_type == OP_PADHV ||
4020 curop->op_type == OP_PADANY)
4022 if (PAD_COMPNAME_GEN(curop->op_targ)
4023 == (STRLEN)PL_generation)
4025 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
4028 else if (curop->op_type == OP_RV2CV)
4030 else if (curop->op_type == OP_RV2SV ||
4031 curop->op_type == OP_RV2AV ||
4032 curop->op_type == OP_RV2HV ||
4033 curop->op_type == OP_RV2GV) {
4034 if (lastop->op_type != OP_GV) /* funny deref? */
4037 else if (curop->op_type == OP_PUSHRE) {
4039 if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
4040 GV *const gv = (GV*)PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff);
4042 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4044 GvASSIGN_GENERATION_set(gv, PL_generation);
4048 = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
4051 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4053 GvASSIGN_GENERATION_set(gv, PL_generation);
4063 o->op_private |= OPpASSIGN_COMMON;
4066 if ((left->op_type == OP_LIST
4067 || (left->op_type == OP_NULL && left->op_targ == OP_LIST))) {
4068 OP* lop = ((LISTOP*)left)->op_first;
4070 if (lop->op_type == OP_PADSV ||
4071 lop->op_type == OP_PADAV ||
4072 lop->op_type == OP_PADHV ||
4073 lop->op_type == OP_PADANY) {
4074 if (lop->op_private & OPpPAD_STATE) {
4075 if (left->op_private & OPpLVAL_INTRO) {
4076 /* Each variable in state($a, $b, $c) = ... */
4079 /* Each state variable in
4080 (state $a, my $b, our $c, $d, undef) = ... */
4082 yyerror(no_list_state);
4084 /* Each my variable in
4085 (state $a, my $b, our $c, $d, undef) = ... */
4088 /* Other ops in the list. undef may be interesting in
4089 (state $a, undef, state $c) */
4091 lop = lop->op_sibling;
4094 else if (((left->op_private & (OPpLVAL_INTRO | OPpPAD_STATE))
4095 == (OPpLVAL_INTRO | OPpPAD_STATE))
4096 && ( left->op_type == OP_PADSV
4097 || left->op_type == OP_PADAV
4098 || left->op_type == OP_PADHV
4099 || left->op_type == OP_PADANY))
4101 /* All single variable list context state assignments, hence
4111 yyerror(no_list_state);
4114 if (right && right->op_type == OP_SPLIT && !PL_madskills) {
4115 OP* tmpop = ((LISTOP*)right)->op_first;
4116 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
4117 PMOP * const pm = (PMOP*)tmpop;
4118 if (left->op_type == OP_RV2AV &&
4119 !(left->op_private & OPpLVAL_INTRO) &&
4120 !(o->op_private & OPpASSIGN_COMMON) )
4122 tmpop = ((UNOP*)left)->op_first;
4123 if (tmpop->op_type == OP_GV
4125 && !pm->op_pmreplrootu.op_pmtargetoff
4127 && !pm->op_pmreplrootu.op_pmtargetgv
4131 pm->op_pmreplrootu.op_pmtargetoff
4132 = cPADOPx(tmpop)->op_padix;
4133 cPADOPx(tmpop)->op_padix = 0; /* steal it */
4135 pm->op_pmreplrootu.op_pmtargetgv
4136 = (GV*)cSVOPx(tmpop)->op_sv;
4137 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
4139 pm->op_pmflags |= PMf_ONCE;
4140 tmpop = cUNOPo->op_first; /* to list (nulled) */
4141 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
4142 tmpop->op_sibling = NULL; /* don't free split */
4143 right->op_next = tmpop->op_next; /* fix starting loc */
4144 op_free(o); /* blow off assign */
4145 right->op_flags &= ~OPf_WANT;
4146 /* "I don't know and I don't care." */
4151 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
4152 ((LISTOP*)right)->op_last->op_type == OP_CONST)
4154 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
4156 sv_setiv(sv, PL_modcount+1);
4164 right = newOP(OP_UNDEF, 0);
4165 if (right->op_type == OP_READLINE) {
4166 right->op_flags |= OPf_STACKED;
4167 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
4170 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
4171 o = newBINOP(OP_SASSIGN, flags,
4172 scalar(right), mod(scalar(left), OP_SASSIGN) );
4178 o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
4179 o->op_private |= OPpCONST_ARYBASE;
4186 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
4189 const U32 seq = intro_my();
4192 NewOp(1101, cop, 1, COP);
4193 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
4194 cop->op_type = OP_DBSTATE;
4195 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
4198 cop->op_type = OP_NEXTSTATE;
4199 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
4201 cop->op_flags = (U8)flags;
4202 CopHINTS_set(cop, PL_hints);
4204 cop->op_private |= NATIVE_HINTS;
4206 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
4207 cop->op_next = (OP*)cop;
4210 CopLABEL_set(cop, label);
4211 PL_hints |= HINT_BLOCK_SCOPE;
4214 /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
4215 CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
4217 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
4218 cop->cop_hints_hash = PL_curcop->cop_hints_hash;
4219 if (cop->cop_hints_hash) {
4221 cop->cop_hints_hash->refcounted_he_refcnt++;
4222 HINTS_REFCNT_UNLOCK;
4225 if (PL_parser && PL_parser->copline == NOLINE)
4226 CopLINE_set(cop, CopLINE(PL_curcop));
4228 CopLINE_set(cop, PL_parser->copline);
4230 PL_parser->copline = NOLINE;
4233 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
4235 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
4237 CopSTASH_set(cop, PL_curstash);
4239 if (PERLDB_LINE && PL_curstash != PL_debstash) {
4240 AV *av = CopFILEAVx(PL_curcop);
4242 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
4243 if (svp && *svp != &PL_sv_undef ) {
4244 (void)SvIOK_on(*svp);
4245 SvIV_set(*svp, PTR2IV(cop));
4250 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
4255 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
4258 return new_logop(type, flags, &first, &other);
4262 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
4267 OP *first = *firstp;
4268 OP * const other = *otherp;
4270 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
4271 return newBINOP(type, flags, scalar(first), scalar(other));
4273 scalarboolean(first);
4274 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
4275 if (first->op_type == OP_NOT
4276 && (first->op_flags & OPf_SPECIAL)
4277 && (first->op_flags & OPf_KIDS)
4279 if (type == OP_AND || type == OP_OR) {
4285 first = *firstp = cUNOPo->op_first;
4287 first->op_next = o->op_next;
4288 cUNOPo->op_first = NULL;
4292 if (first->op_type == OP_CONST) {
4293 if (first->op_private & OPpCONST_STRICT)
4294 no_bareword_allowed(first);
4295 else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
4296 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
4297 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
4298 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
4299 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
4301 if (other->op_type == OP_CONST)
4302 other->op_private |= OPpCONST_SHORTCIRCUIT;
4304 OP *newop = newUNOP(OP_NULL, 0, other);
4305 op_getmad(first, newop, '1');
4306 newop->op_targ = type; /* set "was" field */
4313 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
4314 const OP *o2 = other;
4315 if ( ! (o2->op_type == OP_LIST
4316 && (( o2 = cUNOPx(o2)->op_first))
4317 && o2->op_type == OP_PUSHMARK
4318 && (( o2 = o2->op_sibling)) )
4321 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
4322 || o2->op_type == OP_PADHV)
4323 && o2->op_private & OPpLVAL_INTRO
4324 && !(o2->op_private & OPpPAD_STATE)
4325 && ckWARN(WARN_DEPRECATED))
4327 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4328 "Deprecated use of my() in false conditional");
4332 if (first->op_type == OP_CONST)
4333 first->op_private |= OPpCONST_SHORTCIRCUIT;
4335 first = newUNOP(OP_NULL, 0, first);
4336 op_getmad(other, first, '2');
4337 first->op_targ = type; /* set "was" field */
4344 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
4345 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
4347 const OP * const k1 = ((UNOP*)first)->op_first;
4348 const OP * const k2 = k1->op_sibling;
4350 switch (first->op_type)
4353 if (k2 && k2->op_type == OP_READLINE
4354 && (k2->op_flags & OPf_STACKED)
4355 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4357 warnop = k2->op_type;
4362 if (k1->op_type == OP_READDIR
4363 || k1->op_type == OP_GLOB
4364 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4365 || k1->op_type == OP_EACH)
4367 warnop = ((k1->op_type == OP_NULL)
4368 ? (OPCODE)k1->op_targ : k1->op_type);
4373 const line_t oldline = CopLINE(PL_curcop);
4374 CopLINE_set(PL_curcop, PL_parser->copline);
4375 Perl_warner(aTHX_ packWARN(WARN_MISC),
4376 "Value of %s%s can be \"0\"; test with defined()",
4378 ((warnop == OP_READLINE || warnop == OP_GLOB)
4379 ? " construct" : "() operator"));
4380 CopLINE_set(PL_curcop, oldline);
4387 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
4388 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
4390 NewOp(1101, logop, 1, LOGOP);
4392 logop->op_type = (OPCODE)type;
4393 logop->op_ppaddr = PL_ppaddr[type];
4394 logop->op_first = first;
4395 logop->op_flags = (U8)(flags | OPf_KIDS);
4396 logop->op_other = LINKLIST(other);
4397 logop->op_private = (U8)(1 | (flags >> 8));
4399 /* establish postfix order */
4400 logop->op_next = LINKLIST(first);
4401 first->op_next = (OP*)logop;
4402 first->op_sibling = other;
4404 CHECKOP(type,logop);
4406 o = newUNOP(OP_NULL, 0, (OP*)logop);
4413 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
4421 return newLOGOP(OP_AND, 0, first, trueop);
4423 return newLOGOP(OP_OR, 0, first, falseop);
4425 scalarboolean(first);
4426 if (first->op_type == OP_CONST) {
4427 /* Left or right arm of the conditional? */
4428 const bool left = SvTRUE(((SVOP*)first)->op_sv);
4429 OP *live = left ? trueop : falseop;
4430 OP *const dead = left ? falseop : trueop;
4431 if (first->op_private & OPpCONST_BARE &&
4432 first->op_private & OPpCONST_STRICT) {
4433 no_bareword_allowed(first);
4436 /* This is all dead code when PERL_MAD is not defined. */
4437 live = newUNOP(OP_NULL, 0, live);
4438 op_getmad(first, live, 'C');
4439 op_getmad(dead, live, left ? 'e' : 't');
4446 NewOp(1101, logop, 1, LOGOP);
4447 logop->op_type = OP_COND_EXPR;
4448 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4449 logop->op_first = first;
4450 logop->op_flags = (U8)(flags | OPf_KIDS);
4451 logop->op_private = (U8)(1 | (flags >> 8));
4452 logop->op_other = LINKLIST(trueop);
4453 logop->op_next = LINKLIST(falseop);
4455 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
4458 /* establish postfix order */
4459 start = LINKLIST(first);
4460 first->op_next = (OP*)logop;
4462 first->op_sibling = trueop;
4463 trueop->op_sibling = falseop;
4464 o = newUNOP(OP_NULL, 0, (OP*)logop);
4466 trueop->op_next = falseop->op_next = o;
4473 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4482 NewOp(1101, range, 1, LOGOP);
4484 range->op_type = OP_RANGE;
4485 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4486 range->op_first = left;
4487 range->op_flags = OPf_KIDS;
4488 leftstart = LINKLIST(left);
4489 range->op_other = LINKLIST(right);
4490 range->op_private = (U8)(1 | (flags >> 8));
4492 left->op_sibling = right;
4494 range->op_next = (OP*)range;
4495 flip = newUNOP(OP_FLIP, flags, (OP*)range);
4496 flop = newUNOP(OP_FLOP, 0, flip);
4497 o = newUNOP(OP_NULL, 0, flop);
4499 range->op_next = leftstart;
4501 left->op_next = flip;
4502 right->op_next = flop;
4504 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4505 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4506 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4507 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4509 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4510 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4513 if (!flip->op_private || !flop->op_private)
4514 linklist(o); /* blow off optimizer unless constant */
4520 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4525 const bool once = block && block->op_flags & OPf_SPECIAL &&
4526 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4528 PERL_UNUSED_ARG(debuggable);
4531 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4532 return block; /* do {} while 0 does once */
4533 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4534 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4535 expr = newUNOP(OP_DEFINED, 0,
4536 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4537 } else if (expr->op_flags & OPf_KIDS) {
4538 const OP * const k1 = ((UNOP*)expr)->op_first;
4539 const OP * const k2 = k1 ? k1->op_sibling : NULL;
4540 switch (expr->op_type) {
4542 if (k2 && k2->op_type == OP_READLINE
4543 && (k2->op_flags & OPf_STACKED)
4544 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4545 expr = newUNOP(OP_DEFINED, 0, expr);
4549 if (k1 && (k1->op_type == OP_READDIR
4550 || k1->op_type == OP_GLOB
4551 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4552 || k1->op_type == OP_EACH))
4553 expr = newUNOP(OP_DEFINED, 0, expr);
4559 /* if block is null, the next append_elem() would put UNSTACK, a scalar
4560 * op, in listop. This is wrong. [perl #27024] */
4562 block = newOP(OP_NULL, 0);
4563 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4564 o = new_logop(OP_AND, 0, &expr, &listop);
4567 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4569 if (once && o != listop)
4570 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4573 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
4575 o->op_flags |= flags;
4577 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4582 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
4583 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
4592 PERL_UNUSED_ARG(debuggable);
4595 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4596 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4597 expr = newUNOP(OP_DEFINED, 0,
4598 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4599 } else if (expr->op_flags & OPf_KIDS) {
4600 const OP * const k1 = ((UNOP*)expr)->op_first;
4601 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
4602 switch (expr->op_type) {
4604 if (k2 && k2->op_type == OP_READLINE
4605 && (k2->op_flags & OPf_STACKED)
4606 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4607 expr = newUNOP(OP_DEFINED, 0, expr);
4611 if (k1 && (k1->op_type == OP_READDIR
4612 || k1->op_type == OP_GLOB
4613 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4614 || k1->op_type == OP_EACH))
4615 expr = newUNOP(OP_DEFINED, 0, expr);
4622 block = newOP(OP_NULL, 0);
4623 else if (cont || has_my) {
4624 block = scope(block);
4628 next = LINKLIST(cont);
4631 OP * const unstack = newOP(OP_UNSTACK, 0);
4634 cont = append_elem(OP_LINESEQ, cont, unstack);
4638 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4640 redo = LINKLIST(listop);
4643 PL_parser->copline = (line_t)whileline;
4645 o = new_logop(OP_AND, 0, &expr, &listop);
4646 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4647 op_free(expr); /* oops, it's a while (0) */
4649 return NULL; /* listop already freed by new_logop */
4652 ((LISTOP*)listop)->op_last->op_next =
4653 (o == listop ? redo : LINKLIST(o));
4659 NewOp(1101,loop,1,LOOP);
4660 loop->op_type = OP_ENTERLOOP;
4661 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4662 loop->op_private = 0;
4663 loop->op_next = (OP*)loop;
4666 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4668 loop->op_redoop = redo;
4669 loop->op_lastop = o;
4670 o->op_private |= loopflags;
4673 loop->op_nextop = next;
4675 loop->op_nextop = o;
4677 o->op_flags |= flags;
4678 o->op_private |= (flags >> 8);
4683 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
4688 PADOFFSET padoff = 0;
4694 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4695 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
4696 sv->op_type = OP_RV2GV;
4697 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4699 /* The op_type check is needed to prevent a possible segfault
4700 * if the loop variable is undeclared and 'strict vars' is in
4701 * effect. This is illegal but is nonetheless parsed, so we
4702 * may reach this point with an OP_CONST where we're expecting
4705 if (cUNOPx(sv)->op_first->op_type == OP_GV
4706 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
4707 iterpflags |= OPpITER_DEF;
4709 else if (sv->op_type == OP_PADSV) { /* private variable */
4710 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
4711 padoff = sv->op_targ;
4721 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4723 SV *const namesv = PAD_COMPNAME_SV(padoff);
4725 const char *const name = SvPV_const(namesv, len);
4727 if (len == 2 && name[0] == '$' && name[1] == '_')
4728 iterpflags |= OPpITER_DEF;
4732 const PADOFFSET offset = pad_findmy("$_");
4733 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
4734 sv = newGVOP(OP_GV, 0, PL_defgv);
4739 iterpflags |= OPpITER_DEF;
4741 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4742 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4743 iterflags |= OPf_STACKED;
4745 else if (expr->op_type == OP_NULL &&
4746 (expr->op_flags & OPf_KIDS) &&
4747 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4749 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4750 * set the STACKED flag to indicate that these values are to be
4751 * treated as min/max values by 'pp_iterinit'.
4753 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4754 LOGOP* const range = (LOGOP*) flip->op_first;
4755 OP* const left = range->op_first;
4756 OP* const right = left->op_sibling;
4759 range->op_flags &= ~OPf_KIDS;
4760 range->op_first = NULL;
4762 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4763 listop->op_first->op_next = range->op_next;
4764 left->op_next = range->op_other;
4765 right->op_next = (OP*)listop;
4766 listop->op_next = listop->op_first;
4769 op_getmad(expr,(OP*)listop,'O');
4773 expr = (OP*)(listop);
4775 iterflags |= OPf_STACKED;
4778 expr = mod(force_list(expr), OP_GREPSTART);
4781 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4782 append_elem(OP_LIST, expr, scalar(sv))));
4783 assert(!loop->op_next);
4784 /* for my $x () sets OPpLVAL_INTRO;
4785 * for our $x () sets OPpOUR_INTRO */
4786 loop->op_private = (U8)iterpflags;
4787 #ifdef PL_OP_SLAB_ALLOC
4790 NewOp(1234,tmp,1,LOOP);
4791 Copy(loop,tmp,1,LISTOP);
4792 S_op_destroy(aTHX_ (OP*)loop);
4796 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
4798 loop->op_targ = padoff;
4799 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
4801 op_getmad(madsv, (OP*)loop, 'v');
4802 PL_parser->copline = forline;
4803 return newSTATEOP(0, label, wop);
4807 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4812 if (type != OP_GOTO || label->op_type == OP_CONST) {
4813 /* "last()" means "last" */
4814 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4815 o = newOP(type, OPf_SPECIAL);
4817 o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
4818 ? SvPV_nolen_const(((SVOP*)label)->op_sv)
4822 op_getmad(label,o,'L');
4828 /* Check whether it's going to be a goto &function */
4829 if (label->op_type == OP_ENTERSUB
4830 && !(label->op_flags & OPf_STACKED))
4831 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4832 o = newUNOP(type, OPf_STACKED, label);
4834 PL_hints |= HINT_BLOCK_SCOPE;
4838 /* if the condition is a literal array or hash
4839 (or @{ ... } etc), make a reference to it.
4842 S_ref_array_or_hash(pTHX_ OP *cond)
4845 && (cond->op_type == OP_RV2AV
4846 || cond->op_type == OP_PADAV
4847 || cond->op_type == OP_RV2HV
4848 || cond->op_type == OP_PADHV))
4850 return newUNOP(OP_REFGEN,
4851 0, mod(cond, OP_REFGEN));
4857 /* These construct the optree fragments representing given()
4860 entergiven and enterwhen are LOGOPs; the op_other pointer
4861 points up to the associated leave op. We need this so we
4862 can put it in the context and make break/continue work.
4863 (Also, of course, pp_enterwhen will jump straight to
4864 op_other if the match fails.)
4868 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
4869 I32 enter_opcode, I32 leave_opcode,
4870 PADOFFSET entertarg)
4876 NewOp(1101, enterop, 1, LOGOP);
4877 enterop->op_type = enter_opcode;
4878 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
4879 enterop->op_flags = (U8) OPf_KIDS;
4880 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
4881 enterop->op_private = 0;
4883 o = newUNOP(leave_opcode, 0, (OP *) enterop);
4886 enterop->op_first = scalar(cond);
4887 cond->op_sibling = block;
4889 o->op_next = LINKLIST(cond);
4890 cond->op_next = (OP *) enterop;
4893 /* This is a default {} block */
4894 enterop->op_first = block;
4895 enterop->op_flags |= OPf_SPECIAL;
4897 o->op_next = (OP *) enterop;
4900 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
4901 entergiven and enterwhen both
4904 enterop->op_next = LINKLIST(block);
4905 block->op_next = enterop->op_other = o;
4910 /* Does this look like a boolean operation? For these purposes
4911 a boolean operation is:
4912 - a subroutine call [*]
4913 - a logical connective
4914 - a comparison operator
4915 - a filetest operator, with the exception of -s -M -A -C
4916 - defined(), exists() or eof()
4917 - /$re/ or $foo =~ /$re/
4919 [*] possibly surprising
4922 S_looks_like_bool(pTHX_ const OP *o)
4925 switch(o->op_type) {
4927 return looks_like_bool(cLOGOPo->op_first);
4931 looks_like_bool(cLOGOPo->op_first)
4932 && looks_like_bool(cLOGOPo->op_first->op_sibling));
4936 case OP_NOT: case OP_XOR:
4937 /* Note that OP_DOR is not here */
4939 case OP_EQ: case OP_NE: case OP_LT:
4940 case OP_GT: case OP_LE: case OP_GE:
4942 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
4943 case OP_I_GT: case OP_I_LE: case OP_I_GE:
4945 case OP_SEQ: case OP_SNE: case OP_SLT:
4946 case OP_SGT: case OP_SLE: case OP_SGE:
4950 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
4951 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
4952 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
4953 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
4954 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
4955 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
4956 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
4957 case OP_FTTEXT: case OP_FTBINARY:
4959 case OP_DEFINED: case OP_EXISTS:
4960 case OP_MATCH: case OP_EOF:
4965 /* Detect comparisons that have been optimized away */
4966 if (cSVOPo->op_sv == &PL_sv_yes
4967 || cSVOPo->op_sv == &PL_sv_no)
4978 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
4982 return newGIVWHENOP(
4983 ref_array_or_hash(cond),
4985 OP_ENTERGIVEN, OP_LEAVEGIVEN,
4989 /* If cond is null, this is a default {} block */
4991 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
4993 const bool cond_llb = (!cond || looks_like_bool(cond));
4999 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
5001 scalar(ref_array_or_hash(cond)));
5004 return newGIVWHENOP(
5006 append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
5007 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
5011 =for apidoc cv_undef
5013 Clear out all the active components of a CV. This can happen either
5014 by an explicit C<undef &foo>, or by the reference count going to zero.
5015 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
5016 children can still follow the full lexical scope chain.
5022 Perl_cv_undef(pTHX_ CV *cv)
5026 DEBUG_X(PerlIO_printf(Perl_debug_log,
5027 "CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n",
5028 PTR2UV(cv), PTR2UV(PL_comppad))
5032 if (CvFILE(cv) && !CvISXSUB(cv)) {
5033 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
5034 Safefree(CvFILE(cv));
5039 if (!CvISXSUB(cv) && CvROOT(cv)) {
5040 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
5041 Perl_croak(aTHX_ "Can't undef active subroutine");
5044 PAD_SAVE_SETNULLPAD();
5046 op_free(CvROOT(cv));
5051 SvPOK_off((SV*)cv); /* forget prototype */
5056 /* remove CvOUTSIDE unless this is an undef rather than a free */
5057 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
5058 if (!CvWEAKOUTSIDE(cv))
5059 SvREFCNT_dec(CvOUTSIDE(cv));
5060 CvOUTSIDE(cv) = NULL;
5063 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
5066 if (CvISXSUB(cv) && CvXSUB(cv)) {
5069 /* delete all flags except WEAKOUTSIDE */
5070 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
5074 Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
5077 /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
5078 relying on SvCUR, and doubling up the buffer to hold CvFILE(). */
5079 if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
5080 || (p && (len != SvCUR(cv) /* Not the same length. */
5081 || memNE(p, SvPVX_const(cv), len))))
5082 && ckWARN_d(WARN_PROTOTYPE)) {
5083 SV* const msg = sv_newmortal();
5087 gv_efullname3(name = sv_newmortal(), gv, NULL);
5088 sv_setpvs(msg, "Prototype mismatch:");
5090 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
5092 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv));
5094 sv_catpvs(msg, ": none");
5095 sv_catpvs(msg, " vs ");
5097 Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
5099 sv_catpvs(msg, "none");
5100 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
5104 static void const_sv_xsub(pTHX_ CV* cv);
5108 =head1 Optree Manipulation Functions
5110 =for apidoc cv_const_sv
5112 If C<cv> is a constant sub eligible for inlining. returns the constant
5113 value returned by the sub. Otherwise, returns NULL.
5115 Constant subs can be created with C<newCONSTSUB> or as described in
5116 L<perlsub/"Constant Functions">.
5121 Perl_cv_const_sv(pTHX_ CV *cv)
5123 PERL_UNUSED_CONTEXT;
5126 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
5128 return CvCONST(cv) ? (SV*)CvXSUBANY(cv).any_ptr : NULL;
5131 /* op_const_sv: examine an optree to determine whether it's in-lineable.
5132 * Can be called in 3 ways:
5135 * look for a single OP_CONST with attached value: return the value
5137 * cv && CvCLONE(cv) && !CvCONST(cv)
5139 * examine the clone prototype, and if contains only a single
5140 * OP_CONST referencing a pad const, or a single PADSV referencing
5141 * an outer lexical, return a non-zero value to indicate the CV is
5142 * a candidate for "constizing" at clone time
5146 * We have just cloned an anon prototype that was marked as a const
5147 * candidiate. Try to grab the current value, and in the case of
5148 * PADSV, ignore it if it has multiple references. Return the value.
5152 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
5163 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
5164 o = cLISTOPo->op_first->op_sibling;
5166 for (; o; o = o->op_next) {
5167 const OPCODE type = o->op_type;
5169 if (sv && o->op_next == o)
5171 if (o->op_next != o) {
5172 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
5174 if (type == OP_DBSTATE)
5177 if (type == OP_LEAVESUB || type == OP_RETURN)
5181 if (type == OP_CONST && cSVOPo->op_sv)
5183 else if (cv && type == OP_CONST) {
5184 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5188 else if (cv && type == OP_PADSV) {
5189 if (CvCONST(cv)) { /* newly cloned anon */
5190 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5191 /* the candidate should have 1 ref from this pad and 1 ref
5192 * from the parent */
5193 if (!sv || SvREFCNT(sv) != 2)
5200 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
5201 sv = &PL_sv_undef; /* an arbitrary non-null value */
5216 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5219 /* This would be the return value, but the return cannot be reached. */
5220 OP* pegop = newOP(OP_NULL, 0);
5223 PERL_UNUSED_ARG(floor);
5233 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
5235 NORETURN_FUNCTION_END;
5240 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
5242 return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
5246 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5253 register CV *cv = NULL;
5255 /* If the subroutine has no body, no attributes, and no builtin attributes
5256 then it's just a sub declaration, and we may be able to get away with
5257 storing with a placeholder scalar in the symbol table, rather than a
5258 full GV and CV. If anything is present then it will take a full CV to
5260 const I32 gv_fetch_flags
5261 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5263 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
5264 const char * const name = o ? SvPV_nolen_const(cSVOPo->op_sv) : NULL;
5267 assert(proto->op_type == OP_CONST);
5268 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
5273 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
5274 SV * const sv = sv_newmortal();
5275 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
5276 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
5277 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
5278 aname = SvPVX_const(sv);
5283 gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
5284 : gv_fetchpv(aname ? aname
5285 : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5286 gv_fetch_flags, SVt_PVCV);
5288 if (!PL_madskills) {
5297 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
5298 maximum a prototype before. */
5299 if (SvTYPE(gv) > SVt_NULL) {
5300 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
5301 && ckWARN_d(WARN_PROTOTYPE))
5303 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
5305 cv_ckproto_len((CV*)gv, NULL, ps, ps_len);
5308 sv_setpvn((SV*)gv, ps, ps_len);
5310 sv_setiv((SV*)gv, -1);
5312 SvREFCNT_dec(PL_compcv);
5313 cv = PL_compcv = NULL;
5317 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
5319 #ifdef GV_UNIQUE_CHECK
5320 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
5321 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
5325 if (!block || !ps || *ps || attrs
5326 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5328 || block->op_type == OP_NULL
5333 const_sv = op_const_sv(block, NULL);
5336 const bool exists = CvROOT(cv) || CvXSUB(cv);
5338 #ifdef GV_UNIQUE_CHECK
5339 if (exists && GvUNIQUE(gv)) {
5340 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
5344 /* if the subroutine doesn't exist and wasn't pre-declared
5345 * with a prototype, assume it will be AUTOLOADed,
5346 * skipping the prototype check
5348 if (exists || SvPOK(cv))
5349 cv_ckproto_len(cv, gv, ps, ps_len);
5350 /* already defined (or promised)? */
5351 if (exists || GvASSUMECV(gv)) {
5354 || block->op_type == OP_NULL
5357 if (CvFLAGS(PL_compcv)) {
5358 /* might have had built-in attrs applied */
5359 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5361 /* just a "sub foo;" when &foo is already defined */
5362 SAVEFREESV(PL_compcv);
5367 && block->op_type != OP_NULL
5370 if (ckWARN(WARN_REDEFINE)
5372 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
5374 const line_t oldline = CopLINE(PL_curcop);
5375 if (PL_parser && PL_parser->copline != NOLINE)
5376 CopLINE_set(PL_curcop, PL_parser->copline);
5377 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5378 CvCONST(cv) ? "Constant subroutine %s redefined"
5379 : "Subroutine %s redefined", name);
5380 CopLINE_set(PL_curcop, oldline);
5383 if (!PL_minus_c) /* keep old one around for madskills */
5386 /* (PL_madskills unset in used file.) */
5394 SvREFCNT_inc_simple_void_NN(const_sv);
5396 assert(!CvROOT(cv) && !CvCONST(cv));
5397 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
5398 CvXSUBANY(cv).any_ptr = const_sv;
5399 CvXSUB(cv) = const_sv_xsub;
5405 cv = newCONSTSUB(NULL, name, const_sv);
5407 mro_method_changed_in( /* sub Foo::Bar () { 123 } */
5408 (CvGV(cv) && GvSTASH(CvGV(cv)))
5417 SvREFCNT_dec(PL_compcv);
5425 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
5426 * before we clobber PL_compcv.
5430 || block->op_type == OP_NULL
5434 /* Might have had built-in attributes applied -- propagate them. */
5435 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5436 if (CvGV(cv) && GvSTASH(CvGV(cv)))
5437 stash = GvSTASH(CvGV(cv));
5438 else if (CvSTASH(cv))
5439 stash = CvSTASH(cv);
5441 stash = PL_curstash;
5444 /* possibly about to re-define existing subr -- ignore old cv */
5445 rcv = (SV*)PL_compcv;
5446 if (name && GvSTASH(gv))
5447 stash = GvSTASH(gv);
5449 stash = PL_curstash;
5451 apply_attrs(stash, rcv, attrs, FALSE);
5453 if (cv) { /* must reuse cv if autoloaded */
5460 || block->op_type == OP_NULL) && !PL_madskills
5463 /* got here with just attrs -- work done, so bug out */
5464 SAVEFREESV(PL_compcv);
5467 /* transfer PL_compcv to cv */
5469 CvFLAGS(cv) = CvFLAGS(PL_compcv);
5470 if (!CvWEAKOUTSIDE(cv))
5471 SvREFCNT_dec(CvOUTSIDE(cv));
5472 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
5473 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
5474 CvOUTSIDE(PL_compcv) = 0;
5475 CvPADLIST(cv) = CvPADLIST(PL_compcv);
5476 CvPADLIST(PL_compcv) = 0;
5477 /* inner references to PL_compcv must be fixed up ... */
5478 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
5479 /* ... before we throw it away */
5480 SvREFCNT_dec(PL_compcv);
5482 if (PERLDB_INTER)/* Advice debugger on the new sub. */
5483 ++PL_sub_generation;
5490 if (strEQ(name, "import")) {
5491 PL_formfeed = (SV*)cv;
5492 Perl_warner(aTHX_ packWARN(WARN_VOID), "%lx\n", (long)cv);
5496 mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */
5500 CvFILE_set_from_cop(cv, PL_curcop);
5501 CvSTASH(cv) = PL_curstash;
5504 sv_setpvn((SV*)cv, ps, ps_len);
5506 if (PL_parser && PL_parser->error_count) {
5510 const char *s = strrchr(name, ':');
5512 if (strEQ(s, "BEGIN")) {
5513 const char not_safe[] =
5514 "BEGIN not safe after errors--compilation aborted";
5515 if (PL_in_eval & EVAL_KEEPERR)
5516 Perl_croak(aTHX_ not_safe);
5518 /* force display of errors found but not reported */
5519 sv_catpv(ERRSV, not_safe);
5520 Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
5530 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5531 mod(scalarseq(block), OP_LEAVESUBLV));
5532 block->op_attached = 1;
5535 /* This makes sub {}; work as expected. */
5536 if (block->op_type == OP_STUB) {
5537 OP* const newblock = newSTATEOP(0, NULL, 0);
5539 op_getmad(block,newblock,'B');
5546 block->op_attached = 1;
5547 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5549 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5550 OpREFCNT_set(CvROOT(cv), 1);
5551 CvSTART(cv) = LINKLIST(CvROOT(cv));
5552 CvROOT(cv)->op_next = 0;
5553 CALL_PEEP(CvSTART(cv));
5555 /* now that optimizer has done its work, adjust pad values */
5557 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
5560 assert(!CvCONST(cv));
5561 if (ps && !*ps && op_const_sv(block, cv))
5565 if (name || aname) {
5566 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5567 SV * const sv = newSV(0);
5568 SV * const tmpstr = sv_newmortal();
5569 GV * const db_postponed = gv_fetchpvs("DB::postponed",
5570 GV_ADDMULTI, SVt_PVHV);
5573 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5575 (long)PL_subline, (long)CopLINE(PL_curcop));
5576 gv_efullname3(tmpstr, gv, NULL);
5577 hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0);
5578 hv = GvHVn(db_postponed);
5579 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
5580 CV * const pcv = GvCV(db_postponed);
5586 call_sv((SV*)pcv, G_DISCARD);
5591 if (name && ! (PL_parser && PL_parser->error_count))
5592 process_special_blocks(name, gv, cv);
5597 PL_parser->copline = NOLINE;
5603 S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
5606 const char *const colon = strrchr(fullname,':');
5607 const char *const name = colon ? colon + 1 : fullname;
5610 if (strEQ(name, "BEGIN")) {
5611 const I32 oldscope = PL_scopestack_ix;
5613 SAVECOPFILE(&PL_compiling);
5614 SAVECOPLINE(&PL_compiling);
5616 DEBUG_x( dump_sub(gv) );
5617 Perl_av_create_and_push(aTHX_ &PL_beginav, (SV*)cv);
5618 GvCV(gv) = 0; /* cv has been hijacked */
5619 call_list(oldscope, PL_beginav);
5621 PL_curcop = &PL_compiling;
5622 CopHINTS_set(&PL_compiling, PL_hints);
5629 if strEQ(name, "END") {
5630 DEBUG_x( dump_sub(gv) );
5631 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, (SV*)cv);
5634 } else if (*name == 'U') {
5635 if (strEQ(name, "UNITCHECK")) {
5636 /* It's never too late to run a unitcheck block */
5637 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, (SV*)cv);
5641 } else if (*name == 'C') {
5642 if (strEQ(name, "CHECK")) {
5643 if (PL_main_start && ckWARN(WARN_VOID))
5644 Perl_warner(aTHX_ packWARN(WARN_VOID),
5645 "Too late to run CHECK block");
5646 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, (SV*)cv);
5650 } else if (*name == 'I') {
5651 if (strEQ(name, "INIT")) {
5652 if (PL_main_start && ckWARN(WARN_VOID))
5653 Perl_warner(aTHX_ packWARN(WARN_VOID),
5654 "Too late to run INIT block");
5655 Perl_av_create_and_push(aTHX_ &PL_initav, (SV*)cv);
5661 DEBUG_x( dump_sub(gv) );
5662 GvCV(gv) = 0; /* cv has been hijacked */
5667 =for apidoc newCONSTSUB
5669 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5670 eligible for inlining at compile-time.
5676 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
5681 const char *const temp_p = CopFILE(PL_curcop);
5682 const STRLEN len = temp_p ? strlen(temp_p) : 0;
5684 SV *const temp_sv = CopFILESV(PL_curcop);
5686 const char *const temp_p = temp_sv ? SvPV_const(temp_sv, len) : NULL;
5688 char *const file = savepvn(temp_p, temp_p ? len : 0);
5692 SAVECOPLINE(PL_curcop);
5693 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
5696 PL_hints &= ~HINT_BLOCK_SCOPE;
5699 SAVESPTR(PL_curstash);
5700 SAVECOPSTASH(PL_curcop);
5701 PL_curstash = stash;
5702 CopSTASH_set(PL_curcop,stash);
5705 /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
5706 and so doesn't get free()d. (It's expected to be from the C pre-
5707 processor __FILE__ directive). But we need a dynamically allocated one,
5708 and we need it to get freed. */
5709 cv = newXS_flags(name, const_sv_xsub, file, "", XS_DYNAMIC_FILENAME);
5710 CvXSUBANY(cv).any_ptr = sv;
5716 CopSTASH_free(PL_curcop);
5724 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
5725 const char *const filename, const char *const proto,
5728 CV *cv = newXS(name, subaddr, filename);
5730 if (flags & XS_DYNAMIC_FILENAME) {
5731 /* We need to "make arrangements" (ie cheat) to ensure that the
5732 filename lasts as long as the PVCV we just created, but also doesn't
5734 STRLEN filename_len = strlen(filename);
5735 STRLEN proto_and_file_len = filename_len;
5736 char *proto_and_file;
5740 proto_len = strlen(proto);
5741 proto_and_file_len += proto_len;
5743 Newx(proto_and_file, proto_and_file_len + 1, char);
5744 Copy(proto, proto_and_file, proto_len, char);
5745 Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
5748 proto_and_file = savepvn(filename, filename_len);
5751 /* This gets free()d. :-) */
5752 sv_usepvn_flags((SV*)cv, proto_and_file, proto_and_file_len,
5753 SV_HAS_TRAILING_NUL);
5755 /* This gives us the correct prototype, rather than one with the
5756 file name appended. */
5757 SvCUR_set(cv, proto_len);
5761 CvFILE(cv) = proto_and_file + proto_len;
5763 sv_setpv((SV *)cv, proto);
5769 =for apidoc U||newXS
5771 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
5772 static storage, as it is used directly as CvFILE(), without a copy being made.
5778 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
5781 GV * const gv = gv_fetchpv(name ? name :
5782 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5783 GV_ADDMULTI, SVt_PVCV);
5787 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
5789 if ((cv = (name ? GvCV(gv) : NULL))) {
5791 /* just a cached method */
5795 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5796 /* already defined (or promised) */
5797 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
5798 if (ckWARN(WARN_REDEFINE)) {
5799 GV * const gvcv = CvGV(cv);
5801 HV * const stash = GvSTASH(gvcv);
5803 const char *redefined_name = HvNAME_get(stash);
5804 if ( strEQ(redefined_name,"autouse") ) {
5805 const line_t oldline = CopLINE(PL_curcop);
5806 if (PL_parser && PL_parser->copline != NOLINE)
5807 CopLINE_set(PL_curcop, PL_parser->copline);
5808 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5809 CvCONST(cv) ? "Constant subroutine %s redefined"
5810 : "Subroutine %s redefined"
5812 CopLINE_set(PL_curcop, oldline);
5822 if (cv) /* must reuse cv if autoloaded */
5825 cv = (CV*)newSV_type(SVt_PVCV);
5829 mro_method_changed_in(GvSTASH(gv)); /* newXS */
5833 (void)gv_fetchfile(filename);
5834 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
5835 an external constant string */
5837 CvXSUB(cv) = subaddr;
5840 process_special_blocks(name, gv, cv);
5852 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5857 OP* pegop = newOP(OP_NULL, 0);
5861 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
5862 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
5864 #ifdef GV_UNIQUE_CHECK
5866 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5870 if ((cv = GvFORM(gv))) {
5871 if (ckWARN(WARN_REDEFINE)) {
5872 const line_t oldline = CopLINE(PL_curcop);
5873 if (PL_parser && PL_parser->copline != NOLINE)
5874 CopLINE_set(PL_curcop, PL_parser->copline);
5875 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5876 o ? "Format %"SVf" redefined"
5877 : "Format STDOUT redefined", SVfARG(cSVOPo->op_sv));
5878 CopLINE_set(PL_curcop, oldline);
5885 CvFILE_set_from_cop(cv, PL_curcop);
5888 pad_tidy(padtidy_FORMAT);
5889 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5890 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5891 OpREFCNT_set(CvROOT(cv), 1);
5892 CvSTART(cv) = LINKLIST(CvROOT(cv));
5893 CvROOT(cv)->op_next = 0;
5894 CALL_PEEP(CvSTART(cv));
5896 op_getmad(o,pegop,'n');
5897 op_getmad_weak(block, pegop, 'b');
5902 PL_parser->copline = NOLINE;
5910 Perl_newANONLIST(pTHX_ OP *o)
5912 return convert(OP_ANONLIST, OPf_SPECIAL, o);
5916 Perl_newANONHASH(pTHX_ OP *o)
5918 return convert(OP_ANONHASH, OPf_SPECIAL, o);
5922 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5924 return newANONATTRSUB(floor, proto, NULL, block);
5928 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5930 return newUNOP(OP_REFGEN, 0,
5931 newSVOP(OP_ANONCODE, 0,
5932 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5936 Perl_oopsAV(pTHX_ OP *o)
5939 switch (o->op_type) {
5941 o->op_type = OP_PADAV;
5942 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5943 return ref(o, OP_RV2AV);
5946 o->op_type = OP_RV2AV;
5947 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5952 if (ckWARN_d(WARN_INTERNAL))
5953 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
5960 Perl_oopsHV(pTHX_ OP *o)
5963 switch (o->op_type) {
5966 o->op_type = OP_PADHV;
5967 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5968 return ref(o, OP_RV2HV);
5972 o->op_type = OP_RV2HV;
5973 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5978 if (ckWARN_d(WARN_INTERNAL))
5979 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
5986 Perl_newAVREF(pTHX_ OP *o)
5989 if (o->op_type == OP_PADANY) {
5990 o->op_type = OP_PADAV;
5991 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5994 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5995 && ckWARN(WARN_DEPRECATED)) {
5996 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5997 "Using an array as a reference is deprecated");
5999 return newUNOP(OP_RV2AV, 0, scalar(o));
6003 Perl_newGVREF(pTHX_ I32 type, OP *o)
6005 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
6006 return newUNOP(OP_NULL, 0, o);
6007 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
6011 Perl_newHVREF(pTHX_ OP *o)
6014 if (o->op_type == OP_PADANY) {
6015 o->op_type = OP_PADHV;
6016 o->op_ppaddr = PL_ppaddr[OP_PADHV];
6019 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
6020 && ckWARN(WARN_DEPRECATED)) {
6021 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
6022 "Using a hash as a reference is deprecated");
6024 return newUNOP(OP_RV2HV, 0, scalar(o));
6028 Perl_newCVREF(pTHX_ I32 flags, OP *o)
6030 return newUNOP(OP_RV2CV, flags, scalar(o));
6034 Perl_newSVREF(pTHX_ OP *o)
6037 if (o->op_type == OP_PADANY) {
6038 o->op_type = OP_PADSV;
6039 o->op_ppaddr = PL_ppaddr[OP_PADSV];
6042 return newUNOP(OP_RV2SV, 0, scalar(o));
6045 /* Check routines. See the comments at the top of this file for details
6046 * on when these are called */
6049 Perl_ck_anoncode(pTHX_ OP *o)
6051 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
6053 cSVOPo->op_sv = NULL;
6058 Perl_ck_bitop(pTHX_ OP *o)
6061 #define OP_IS_NUMCOMPARE(op) \
6062 ((op) == OP_LT || (op) == OP_I_LT || \
6063 (op) == OP_GT || (op) == OP_I_GT || \
6064 (op) == OP_LE || (op) == OP_I_LE || \
6065 (op) == OP_GE || (op) == OP_I_GE || \
6066 (op) == OP_EQ || (op) == OP_I_EQ || \
6067 (op) == OP_NE || (op) == OP_I_NE || \
6068 (op) == OP_NCMP || (op) == OP_I_NCMP)
6069 o->op_private = (U8)(PL_hints & HINT_INTEGER);
6070 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
6071 && (o->op_type == OP_BIT_OR
6072 || o->op_type == OP_BIT_AND
6073 || o->op_type == OP_BIT_XOR))
6075 const OP * const left = cBINOPo->op_first;
6076 const OP * const right = left->op_sibling;
6077 if ((OP_IS_NUMCOMPARE(left->op_type) &&
6078 (left->op_flags & OPf_PARENS) == 0) ||
6079 (OP_IS_NUMCOMPARE(right->op_type) &&
6080 (right->op_flags & OPf_PARENS) == 0))
6081 if (ckWARN(WARN_PRECEDENCE))
6082 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
6083 "Possible precedence problem on bitwise %c operator",
6084 o->op_type == OP_BIT_OR ? '|'
6085 : o->op_type == OP_BIT_AND ? '&' : '^'
6092 Perl_ck_concat(pTHX_ OP *o)
6094 const OP * const kid = cUNOPo->op_first;
6095 PERL_UNUSED_CONTEXT;
6096 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
6097 !(kUNOP->op_first->op_flags & OPf_MOD))
6098 o->op_flags |= OPf_STACKED;
6103 Perl_ck_spair(pTHX_ OP *o)
6106 if (o->op_flags & OPf_KIDS) {
6109 const OPCODE type = o->op_type;
6110 o = modkids(ck_fun(o), type);
6111 kid = cUNOPo->op_first;
6112 newop = kUNOP->op_first->op_sibling;
6114 const OPCODE type = newop->op_type;
6115 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
6116 type == OP_PADAV || type == OP_PADHV ||
6117 type == OP_RV2AV || type == OP_RV2HV)
6121 op_getmad(kUNOP->op_first,newop,'K');
6123 op_free(kUNOP->op_first);
6125 kUNOP->op_first = newop;
6127 o->op_ppaddr = PL_ppaddr[++o->op_type];
6132 Perl_ck_delete(pTHX_ OP *o)
6136 if (o->op_flags & OPf_KIDS) {
6137 OP * const kid = cUNOPo->op_first;
6138 switch (kid->op_type) {
6140 o->op_flags |= OPf_SPECIAL;
6143 o->op_private |= OPpSLICE;
6146 o->op_flags |= OPf_SPECIAL;
6151 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
6160 Perl_ck_die(pTHX_ OP *o)
6163 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6169 Perl_ck_eof(pTHX_ OP *o)
6173 if (o->op_flags & OPf_KIDS) {
6174 if (cLISTOPo->op_first->op_type == OP_STUB) {
6176 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
6178 op_getmad(o,newop,'O');
6190 Perl_ck_eval(pTHX_ OP *o)
6193 PL_hints |= HINT_BLOCK_SCOPE;
6194 if (o->op_flags & OPf_KIDS) {
6195 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6198 o->op_flags &= ~OPf_KIDS;
6201 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
6207 cUNOPo->op_first = 0;
6212 NewOp(1101, enter, 1, LOGOP);
6213 enter->op_type = OP_ENTERTRY;
6214 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
6215 enter->op_private = 0;
6217 /* establish postfix order */
6218 enter->op_next = (OP*)enter;
6220 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
6221 o->op_type = OP_LEAVETRY;
6222 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
6223 enter->op_other = o;
6224 op_getmad(oldo,o,'O');
6238 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
6239 op_getmad(oldo,o,'O');
6241 o->op_targ = (PADOFFSET)PL_hints;
6242 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
6243 /* Store a copy of %^H that pp_entereval can pick up.
6244 OPf_SPECIAL flags the opcode as being for this purpose,
6245 so that it in turn will return a copy at every
6247 OP *hhop = newSVOP(OP_CONST, OPf_SPECIAL,
6248 (SV*)Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv)));
6249 cUNOPo->op_first->op_sibling = hhop;
6250 o->op_private |= OPpEVAL_HAS_HH;
6256 Perl_ck_exit(pTHX_ OP *o)
6259 HV * const table = GvHV(PL_hintgv);
6261 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
6262 if (svp && *svp && SvTRUE(*svp))
6263 o->op_private |= OPpEXIT_VMSISH;
6265 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6271 Perl_ck_exec(pTHX_ OP *o)
6273 if (o->op_flags & OPf_STACKED) {
6276 kid = cUNOPo->op_first->op_sibling;
6277 if (kid->op_type == OP_RV2GV)
6286 Perl_ck_exists(pTHX_ OP *o)
6290 if (o->op_flags & OPf_KIDS) {
6291 OP * const kid = cUNOPo->op_first;
6292 if (kid->op_type == OP_ENTERSUB) {
6293 (void) ref(kid, o->op_type);
6294 if (kid->op_type != OP_RV2CV
6295 && !(PL_parser && PL_parser->error_count))
6296 Perl_croak(aTHX_ "%s argument is not a subroutine name",
6298 o->op_private |= OPpEXISTS_SUB;
6300 else if (kid->op_type == OP_AELEM)
6301 o->op_flags |= OPf_SPECIAL;
6302 else if (kid->op_type != OP_HELEM)
6303 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
6311 Perl_ck_rvconst(pTHX_ register OP *o)
6314 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6316 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6317 if (o->op_type == OP_RV2CV)
6318 o->op_private &= ~1;
6320 if (kid->op_type == OP_CONST) {
6323 SV * const kidsv = kid->op_sv;
6325 /* Is it a constant from cv_const_sv()? */
6326 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
6327 SV * const rsv = SvRV(kidsv);
6328 const svtype type = SvTYPE(rsv);
6329 const char *badtype = NULL;
6331 switch (o->op_type) {
6333 if (type > SVt_PVMG)
6334 badtype = "a SCALAR";
6337 if (type != SVt_PVAV)
6338 badtype = "an ARRAY";
6341 if (type != SVt_PVHV)
6345 if (type != SVt_PVCV)
6350 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
6353 else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
6354 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
6355 /* If this is an access to a stash, disable "strict refs", because
6356 * stashes aren't auto-vivified at compile-time (unless we store
6357 * symbols in them), and we don't want to produce a run-time
6358 * stricture error when auto-vivifying the stash. */
6359 const char *s = SvPV_nolen(kidsv);
6360 const STRLEN l = SvCUR(kidsv);
6361 if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
6362 o->op_private &= ~HINT_STRICT_REFS;
6364 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
6365 const char *badthing;
6366 switch (o->op_type) {
6368 badthing = "a SCALAR";
6371 badthing = "an ARRAY";
6374 badthing = "a HASH";
6382 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
6383 SVfARG(kidsv), badthing);
6386 * This is a little tricky. We only want to add the symbol if we
6387 * didn't add it in the lexer. Otherwise we get duplicate strict
6388 * warnings. But if we didn't add it in the lexer, we must at
6389 * least pretend like we wanted to add it even if it existed before,
6390 * or we get possible typo warnings. OPpCONST_ENTERED says
6391 * whether the lexer already added THIS instance of this symbol.
6393 iscv = (o->op_type == OP_RV2CV) * 2;
6395 gv = gv_fetchsv(kidsv,
6396 iscv | !(kid->op_private & OPpCONST_ENTERED),
6399 : o->op_type == OP_RV2SV
6401 : o->op_type == OP_RV2AV
6403 : o->op_type == OP_RV2HV
6406 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
6408 kid->op_type = OP_GV;
6409 SvREFCNT_dec(kid->op_sv);
6411 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
6412 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
6413 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
6415 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc_simple_NN(gv));
6417 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
6419 kid->op_private = 0;
6420 kid->op_ppaddr = PL_ppaddr[OP_GV];
6427 Perl_ck_ftst(pTHX_ OP *o)
6430 const I32 type = o->op_type;
6432 if (o->op_flags & OPf_REF) {
6435 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
6436 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6437 const OPCODE kidtype = kid->op_type;
6439 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6440 OP * const newop = newGVOP(type, OPf_REF,
6441 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
6443 op_getmad(o,newop,'O');
6449 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o))
6450 o->op_private |= OPpFT_ACCESS;
6451 if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst)
6452 && kidtype != OP_STAT && kidtype != OP_LSTAT)
6453 o->op_private |= OPpFT_STACKED;
6461 if (type == OP_FTTTY)
6462 o = newGVOP(type, OPf_REF, PL_stdingv);
6464 o = newUNOP(type, 0, newDEFSVOP());
6465 op_getmad(oldo,o,'O');
6471 Perl_ck_fun(pTHX_ OP *o)
6474 const int type = o->op_type;
6475 register I32 oa = PL_opargs[type] >> OASHIFT;
6477 if (o->op_flags & OPf_STACKED) {
6478 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
6481 return no_fh_allowed(o);
6484 if (o->op_flags & OPf_KIDS) {
6485 OP **tokid = &cLISTOPo->op_first;
6486 register OP *kid = cLISTOPo->op_first;
6490 if (kid->op_type == OP_PUSHMARK ||
6491 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
6493 tokid = &kid->op_sibling;
6494 kid = kid->op_sibling;
6496 if (!kid && PL_opargs[type] & OA_DEFGV)
6497 *tokid = kid = newDEFSVOP();
6501 sibl = kid->op_sibling;
6503 if (!sibl && kid->op_type == OP_STUB) {
6510 /* list seen where single (scalar) arg expected? */
6511 if (numargs == 1 && !(oa >> 4)
6512 && kid->op_type == OP_LIST && type != OP_SCALAR)
6514 return too_many_arguments(o,PL_op_desc[type]);
6527 if ((type == OP_PUSH || type == OP_UNSHIFT)
6528 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
6529 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6530 "Useless use of %s with no values",
6533 if (kid->op_type == OP_CONST &&
6534 (kid->op_private & OPpCONST_BARE))
6536 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
6537 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
6538 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6539 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6540 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
6541 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6543 op_getmad(kid,newop,'K');
6548 kid->op_sibling = sibl;
6551 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
6552 bad_type(numargs, "array", PL_op_desc[type], kid);
6556 if (kid->op_type == OP_CONST &&
6557 (kid->op_private & OPpCONST_BARE))
6559 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
6560 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
6561 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6562 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6563 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
6564 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6566 op_getmad(kid,newop,'K');
6571 kid->op_sibling = sibl;
6574 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
6575 bad_type(numargs, "hash", PL_op_desc[type], kid);
6580 OP * const newop = newUNOP(OP_NULL, 0, kid);
6581 kid->op_sibling = 0;
6583 newop->op_next = newop;
6585 kid->op_sibling = sibl;
6590 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
6591 if (kid->op_type == OP_CONST &&
6592 (kid->op_private & OPpCONST_BARE))
6594 OP * const newop = newGVOP(OP_GV, 0,
6595 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
6596 if (!(o->op_private & 1) && /* if not unop */
6597 kid == cLISTOPo->op_last)
6598 cLISTOPo->op_last = newop;
6600 op_getmad(kid,newop,'K');
6606 else if (kid->op_type == OP_READLINE) {
6607 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
6608 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
6611 I32 flags = OPf_SPECIAL;
6615 /* is this op a FH constructor? */
6616 if (is_handle_constructor(o,numargs)) {
6617 const char *name = NULL;
6621 /* Set a flag to tell rv2gv to vivify
6622 * need to "prove" flag does not mean something
6623 * else already - NI-S 1999/05/07
6626 if (kid->op_type == OP_PADSV) {
6628 = PAD_COMPNAME_SV(kid->op_targ);
6629 name = SvPV_const(namesv, len);
6631 else if (kid->op_type == OP_RV2SV
6632 && kUNOP->op_first->op_type == OP_GV)
6634 GV * const gv = cGVOPx_gv(kUNOP->op_first);
6636 len = GvNAMELEN(gv);
6638 else if (kid->op_type == OP_AELEM
6639 || kid->op_type == OP_HELEM)
6642 OP *op = ((BINOP*)kid)->op_first;
6646 const char * const a =
6647 kid->op_type == OP_AELEM ?
6649 if (((op->op_type == OP_RV2AV) ||
6650 (op->op_type == OP_RV2HV)) &&
6651 (firstop = ((UNOP*)op)->op_first) &&
6652 (firstop->op_type == OP_GV)) {
6653 /* packagevar $a[] or $h{} */
6654 GV * const gv = cGVOPx_gv(firstop);
6662 else if (op->op_type == OP_PADAV
6663 || op->op_type == OP_PADHV) {
6664 /* lexicalvar $a[] or $h{} */
6665 const char * const padname =
6666 PAD_COMPNAME_PV(op->op_targ);
6675 name = SvPV_const(tmpstr, len);
6680 name = "__ANONIO__";
6687 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
6688 namesv = PAD_SVl(targ);
6689 SvUPGRADE(namesv, SVt_PV);
6691 sv_setpvn(namesv, "$", 1);
6692 sv_catpvn(namesv, name, len);
6695 kid->op_sibling = 0;
6696 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
6697 kid->op_targ = targ;
6698 kid->op_private |= priv;
6700 kid->op_sibling = sibl;
6706 mod(scalar(kid), type);
6710 tokid = &kid->op_sibling;
6711 kid = kid->op_sibling;
6714 if (kid && kid->op_type != OP_STUB)
6715 return too_many_arguments(o,OP_DESC(o));
6716 o->op_private |= numargs;
6718 /* FIXME - should the numargs move as for the PERL_MAD case? */
6719 o->op_private |= numargs;
6721 return too_many_arguments(o,OP_DESC(o));
6725 else if (PL_opargs[type] & OA_DEFGV) {
6727 OP *newop = newUNOP(type, 0, newDEFSVOP());
6728 op_getmad(o,newop,'O');
6731 /* Ordering of these two is important to keep f_map.t passing. */
6733 return newUNOP(type, 0, newDEFSVOP());
6738 while (oa & OA_OPTIONAL)
6740 if (oa && oa != OA_LIST)
6741 return too_few_arguments(o,OP_DESC(o));
6747 Perl_ck_glob(pTHX_ OP *o)
6753 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
6754 append_elem(OP_GLOB, o, newDEFSVOP());
6756 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
6757 && GvCVu(gv) && GvIMPORTED_CV(gv)))
6759 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6762 #if !defined(PERL_EXTERNAL_GLOB)
6763 /* XXX this can be tightened up and made more failsafe. */
6764 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
6767 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
6768 newSVpvs("File::Glob"), NULL, NULL, NULL);
6769 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6770 glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
6771 GvCV(gv) = GvCV(glob_gv);
6772 SvREFCNT_inc_void((SV*)GvCV(gv));
6773 GvIMPORTED_CV_on(gv);
6776 #endif /* PERL_EXTERNAL_GLOB */
6778 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6779 append_elem(OP_GLOB, o,
6780 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
6781 o->op_type = OP_LIST;
6782 o->op_ppaddr = PL_ppaddr[OP_LIST];
6783 cLISTOPo->op_first->op_type = OP_PUSHMARK;
6784 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
6785 cLISTOPo->op_first->op_targ = 0;
6786 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
6787 append_elem(OP_LIST, o,
6788 scalar(newUNOP(OP_RV2CV, 0,
6789 newGVOP(OP_GV, 0, gv)))));
6790 o = newUNOP(OP_NULL, 0, ck_subr(o));
6791 o->op_targ = OP_GLOB; /* hint at what it used to be */
6794 gv = newGVgen("main");
6796 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
6802 Perl_ck_grep(pTHX_ OP *o)
6807 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
6810 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
6811 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
6813 if (o->op_flags & OPf_STACKED) {
6816 kid = cLISTOPo->op_first->op_sibling;
6817 if (!cUNOPx(kid)->op_next)
6818 Perl_croak(aTHX_ "panic: ck_grep");
6819 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
6822 NewOp(1101, gwop, 1, LOGOP);
6823 kid->op_next = (OP*)gwop;
6824 o->op_flags &= ~OPf_STACKED;
6826 kid = cLISTOPo->op_first->op_sibling;
6827 if (type == OP_MAPWHILE)
6832 if (PL_parser && PL_parser->error_count)
6834 kid = cLISTOPo->op_first->op_sibling;
6835 if (kid->op_type != OP_NULL)
6836 Perl_croak(aTHX_ "panic: ck_grep");
6837 kid = kUNOP->op_first;
6840 NewOp(1101, gwop, 1, LOGOP);
6841 gwop->op_type = type;
6842 gwop->op_ppaddr = PL_ppaddr[type];
6843 gwop->op_first = listkids(o);
6844 gwop->op_flags |= OPf_KIDS;
6845 gwop->op_other = LINKLIST(kid);
6846 kid->op_next = (OP*)gwop;
6847 offset = pad_findmy("$_");
6848 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
6849 o->op_private = gwop->op_private = 0;
6850 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
6853 o->op_private = gwop->op_private = OPpGREP_LEX;
6854 gwop->op_targ = o->op_targ = offset;
6857 kid = cLISTOPo->op_first->op_sibling;
6858 if (!kid || !kid->op_sibling)
6859 return too_few_arguments(o,OP_DESC(o));
6860 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
6861 mod(kid, OP_GREPSTART);
6867 Perl_ck_index(pTHX_ OP *o)
6869 if (o->op_flags & OPf_KIDS) {
6870 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6872 kid = kid->op_sibling; /* get past "big" */
6873 if (kid && kid->op_type == OP_CONST)
6874 fbm_compile(((SVOP*)kid)->op_sv, 0);
6880 Perl_ck_lengthconst(pTHX_ OP *o)
6882 /* XXX length optimization goes here */
6887 Perl_ck_lfun(pTHX_ OP *o)
6889 const OPCODE type = o->op_type;
6890 return modkids(ck_fun(o), type);
6894 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
6896 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
6897 switch (cUNOPo->op_first->op_type) {
6899 /* This is needed for
6900 if (defined %stash::)
6901 to work. Do not break Tk.
6903 break; /* Globals via GV can be undef */
6905 case OP_AASSIGN: /* Is this a good idea? */
6906 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6907 "defined(@array) is deprecated");
6908 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6909 "\t(Maybe you should just omit the defined()?)\n");
6912 /* This is needed for
6913 if (defined %stash::)
6914 to work. Do not break Tk.
6916 break; /* Globals via GV can be undef */
6918 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6919 "defined(%%hash) is deprecated");
6920 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6921 "\t(Maybe you should just omit the defined()?)\n");
6932 Perl_ck_readline(pTHX_ OP *o)
6934 if (!(o->op_flags & OPf_KIDS)) {
6936 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
6938 op_getmad(o,newop,'O');
6948 Perl_ck_rfun(pTHX_ OP *o)
6950 const OPCODE type = o->op_type;
6951 return refkids(ck_fun(o), type);
6955 Perl_ck_listiob(pTHX_ OP *o)
6959 kid = cLISTOPo->op_first;
6962 kid = cLISTOPo->op_first;
6964 if (kid->op_type == OP_PUSHMARK)
6965 kid = kid->op_sibling;
6966 if (kid && o->op_flags & OPf_STACKED)
6967 kid = kid->op_sibling;
6968 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6969 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6970 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6971 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6972 cLISTOPo->op_first->op_sibling = kid;
6973 cLISTOPo->op_last = kid;
6974 kid = kid->op_sibling;
6979 append_elem(o->op_type, o, newDEFSVOP());
6985 Perl_ck_smartmatch(pTHX_ OP *o)
6988 if (0 == (o->op_flags & OPf_SPECIAL)) {
6989 OP *first = cBINOPo->op_first;
6990 OP *second = first->op_sibling;
6992 /* Implicitly take a reference to an array or hash */
6993 first->op_sibling = NULL;
6994 first = cBINOPo->op_first = ref_array_or_hash(first);
6995 second = first->op_sibling = ref_array_or_hash(second);
6997 /* Implicitly take a reference to a regular expression */
6998 if (first->op_type == OP_MATCH) {
6999 first->op_type = OP_QR;
7000 first->op_ppaddr = PL_ppaddr[OP_QR];
7002 if (second->op_type == OP_MATCH) {
7003 second->op_type = OP_QR;
7004 second->op_ppaddr = PL_ppaddr[OP_QR];
7013 Perl_ck_sassign(pTHX_ OP *o)
7015 OP * const kid = cLISTOPo->op_first;
7016 /* has a disposable target? */
7017 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
7018 && !(kid->op_flags & OPf_STACKED)
7019 /* Cannot steal the second time! */
7020 && !(kid->op_private & OPpTARGET_MY)
7021 /* Keep the full thing for madskills */
7025 OP * const kkid = kid->op_sibling;
7027 /* Can just relocate the target. */
7028 if (kkid && kkid->op_type == OP_PADSV
7029 && !(kkid->op_private & OPpLVAL_INTRO))
7031 kid->op_targ = kkid->op_targ;
7033 /* Now we do not need PADSV and SASSIGN. */
7034 kid->op_sibling = o->op_sibling; /* NULL */
7035 cLISTOPo->op_first = NULL;
7038 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
7042 if (kid->op_sibling) {
7043 OP *kkid = kid->op_sibling;
7044 if (kkid->op_type == OP_PADSV
7045 && (kkid->op_private & OPpLVAL_INTRO)
7046 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
7047 const PADOFFSET target = kkid->op_targ;
7048 OP *const other = newOP(OP_PADSV,
7050 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
7051 OP *const first = newOP(OP_NULL, 0);
7052 OP *const nullop = newCONDOP(0, first, o, other);
7053 OP *const condop = first->op_next;
7054 /* hijacking PADSTALE for uninitialized state variables */
7055 SvPADSTALE_on(PAD_SVl(target));
7057 condop->op_type = OP_ONCE;
7058 condop->op_ppaddr = PL_ppaddr[OP_ONCE];
7059 condop->op_targ = target;
7060 other->op_targ = target;
7069 Perl_ck_match(pTHX_ OP *o)
7072 if (o->op_type != OP_QR && PL_compcv) {
7073 const PADOFFSET offset = pad_findmy("$_");
7074 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
7075 o->op_targ = offset;
7076 o->op_private |= OPpTARGET_MY;
7079 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
7080 o->op_private |= OPpRUNTIME;
7085 Perl_ck_method(pTHX_ OP *o)
7087 OP * const kid = cUNOPo->op_first;
7088 if (kid->op_type == OP_CONST) {
7089 SV* sv = kSVOP->op_sv;
7090 const char * const method = SvPVX_const(sv);
7091 if (!(strchr(method, ':') || strchr(method, '\''))) {
7093 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
7094 sv = newSVpvn_share(method, SvCUR(sv), 0);
7097 kSVOP->op_sv = NULL;
7099 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
7101 op_getmad(o,cmop,'O');
7112 Perl_ck_null(pTHX_ OP *o)
7114 PERL_UNUSED_CONTEXT;
7119 Perl_ck_open(pTHX_ OP *o)
7122 HV * const table = GvHV(PL_hintgv);
7124 SV **svp = hv_fetchs(table, "open_IN", FALSE);
7126 const I32 mode = mode_from_discipline(*svp);
7127 if (mode & O_BINARY)
7128 o->op_private |= OPpOPEN_IN_RAW;
7129 else if (mode & O_TEXT)
7130 o->op_private |= OPpOPEN_IN_CRLF;
7133 svp = hv_fetchs(table, "open_OUT", FALSE);
7135 const I32 mode = mode_from_discipline(*svp);
7136 if (mode & O_BINARY)
7137 o->op_private |= OPpOPEN_OUT_RAW;
7138 else if (mode & O_TEXT)
7139 o->op_private |= OPpOPEN_OUT_CRLF;
7142 if (o->op_type == OP_BACKTICK) {
7143 if (!(o->op_flags & OPf_KIDS)) {
7144 OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
7146 op_getmad(o,newop,'O');
7155 /* In case of three-arg dup open remove strictness
7156 * from the last arg if it is a bareword. */
7157 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
7158 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
7162 if ((last->op_type == OP_CONST) && /* The bareword. */
7163 (last->op_private & OPpCONST_BARE) &&
7164 (last->op_private & OPpCONST_STRICT) &&
7165 (oa = first->op_sibling) && /* The fh. */
7166 (oa = oa->op_sibling) && /* The mode. */
7167 (oa->op_type == OP_CONST) &&
7168 SvPOK(((SVOP*)oa)->op_sv) &&
7169 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
7170 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
7171 (last == oa->op_sibling)) /* The bareword. */
7172 last->op_private &= ~OPpCONST_STRICT;
7178 Perl_ck_repeat(pTHX_ OP *o)
7180 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
7181 o->op_private |= OPpREPEAT_DOLIST;
7182 cBINOPo->op_first = force_list(cBINOPo->op_first);
7190 Perl_ck_require(pTHX_ OP *o)
7195 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
7196 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7198 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
7199 SV * const sv = kid->op_sv;
7200 U32 was_readonly = SvREADONLY(sv);
7205 sv_force_normal_flags(sv, 0);
7206 assert(!SvREADONLY(sv));
7213 for (s = SvPVX(sv); *s; s++) {
7214 if (*s == ':' && s[1] == ':') {
7215 const STRLEN len = strlen(s+2)+1;
7217 Move(s+2, s+1, len, char);
7218 SvCUR_set(sv, SvCUR(sv) - 1);
7221 sv_catpvs(sv, ".pm");
7222 SvFLAGS(sv) |= was_readonly;
7226 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
7227 /* handle override, if any */
7228 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
7229 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7230 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
7231 gv = gvp ? *gvp : NULL;
7235 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7236 OP * const kid = cUNOPo->op_first;
7239 cUNOPo->op_first = 0;
7243 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
7244 append_elem(OP_LIST, kid,
7245 scalar(newUNOP(OP_RV2CV, 0,
7248 op_getmad(o,newop,'O');
7256 Perl_ck_return(pTHX_ OP *o)
7259 if (CvLVALUE(PL_compcv)) {
7261 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
7262 mod(kid, OP_LEAVESUBLV);
7268 Perl_ck_select(pTHX_ OP *o)
7272 if (o->op_flags & OPf_KIDS) {
7273 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7274 if (kid && kid->op_sibling) {
7275 o->op_type = OP_SSELECT;
7276 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
7278 return fold_constants(o);
7282 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7283 if (kid && kid->op_type == OP_RV2GV)
7284 kid->op_private &= ~HINT_STRICT_REFS;
7289 Perl_ck_shift(pTHX_ OP *o)
7292 const I32 type = o->op_type;
7294 if (!(o->op_flags & OPf_KIDS)) {
7296 /* FIXME - this can be refactored to reduce code in #ifdefs */
7298 OP * const oldo = o;
7302 argop = newUNOP(OP_RV2AV, 0,
7303 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
7305 o = newUNOP(type, 0, scalar(argop));
7306 op_getmad(oldo,o,'O');
7309 return newUNOP(type, 0, scalar(argop));
7312 return scalar(modkids(ck_fun(o), type));
7316 Perl_ck_sort(pTHX_ OP *o)
7321 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
7322 HV * const hinthv = GvHV(PL_hintgv);
7324 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
7326 const I32 sorthints = (I32)SvIV(*svp);
7327 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
7328 o->op_private |= OPpSORT_QSORT;
7329 if ((sorthints & HINT_SORT_STABLE) != 0)
7330 o->op_private |= OPpSORT_STABLE;
7335 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
7337 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7338 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
7340 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
7342 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
7344 if (kid->op_type == OP_SCOPE) {
7348 else if (kid->op_type == OP_LEAVE) {
7349 if (o->op_type == OP_SORT) {
7350 op_null(kid); /* wipe out leave */
7353 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
7354 if (k->op_next == kid)
7356 /* don't descend into loops */
7357 else if (k->op_type == OP_ENTERLOOP
7358 || k->op_type == OP_ENTERITER)
7360 k = cLOOPx(k)->op_lastop;
7365 kid->op_next = 0; /* just disconnect the leave */
7366 k = kLISTOP->op_first;
7371 if (o->op_type == OP_SORT) {
7372 /* provide scalar context for comparison function/block */
7378 o->op_flags |= OPf_SPECIAL;
7380 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
7383 firstkid = firstkid->op_sibling;
7386 /* provide list context for arguments */
7387 if (o->op_type == OP_SORT)
7394 S_simplify_sort(pTHX_ OP *o)
7397 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7402 if (!(o->op_flags & OPf_STACKED))
7404 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7405 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
7406 kid = kUNOP->op_first; /* get past null */
7407 if (kid->op_type != OP_SCOPE)
7409 kid = kLISTOP->op_last; /* get past scope */
7410 switch(kid->op_type) {
7418 k = kid; /* remember this node*/
7419 if (kBINOP->op_first->op_type != OP_RV2SV)
7421 kid = kBINOP->op_first; /* get past cmp */
7422 if (kUNOP->op_first->op_type != OP_GV)
7424 kid = kUNOP->op_first; /* get past rv2sv */
7426 if (GvSTASH(gv) != PL_curstash)
7428 gvname = GvNAME(gv);
7429 if (*gvname == 'a' && gvname[1] == '\0')
7431 else if (*gvname == 'b' && gvname[1] == '\0')
7436 kid = k; /* back to cmp */
7437 if (kBINOP->op_last->op_type != OP_RV2SV)
7439 kid = kBINOP->op_last; /* down to 2nd arg */
7440 if (kUNOP->op_first->op_type != OP_GV)
7442 kid = kUNOP->op_first; /* get past rv2sv */
7444 if (GvSTASH(gv) != PL_curstash)
7446 gvname = GvNAME(gv);
7448 ? !(*gvname == 'a' && gvname[1] == '\0')
7449 : !(*gvname == 'b' && gvname[1] == '\0'))
7451 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
7453 o->op_private |= OPpSORT_DESCEND;
7454 if (k->op_type == OP_NCMP)
7455 o->op_private |= OPpSORT_NUMERIC;
7456 if (k->op_type == OP_I_NCMP)
7457 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
7458 kid = cLISTOPo->op_first->op_sibling;
7459 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
7461 op_getmad(kid,o,'S'); /* then delete it */
7463 op_free(kid); /* then delete it */
7468 Perl_ck_split(pTHX_ OP *o)
7473 if (o->op_flags & OPf_STACKED)
7474 return no_fh_allowed(o);
7476 kid = cLISTOPo->op_first;
7477 if (kid->op_type != OP_NULL)
7478 Perl_croak(aTHX_ "panic: ck_split");
7479 kid = kid->op_sibling;
7480 op_free(cLISTOPo->op_first);
7481 cLISTOPo->op_first = kid;
7483 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
7484 cLISTOPo->op_last = kid; /* There was only one element previously */
7487 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
7488 OP * const sibl = kid->op_sibling;
7489 kid->op_sibling = 0;
7490 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
7491 if (cLISTOPo->op_first == cLISTOPo->op_last)
7492 cLISTOPo->op_last = kid;
7493 cLISTOPo->op_first = kid;
7494 kid->op_sibling = sibl;
7497 kid->op_type = OP_PUSHRE;
7498 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
7500 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
7501 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
7502 "Use of /g modifier is meaningless in split");
7505 if (!kid->op_sibling)
7506 append_elem(OP_SPLIT, o, newDEFSVOP());
7508 kid = kid->op_sibling;
7511 if (!kid->op_sibling)
7512 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
7513 assert(kid->op_sibling);
7515 kid = kid->op_sibling;
7518 if (kid->op_sibling)
7519 return too_many_arguments(o,OP_DESC(o));
7525 Perl_ck_join(pTHX_ OP *o)
7527 const OP * const kid = cLISTOPo->op_first->op_sibling;
7528 if (kid && kid->op_type == OP_MATCH) {
7529 if (ckWARN(WARN_SYNTAX)) {
7530 const REGEXP *re = PM_GETRE(kPMOP);
7531 const char *pmstr = re ? re->precomp : "STRING";
7532 const STRLEN len = re ? re->prelen : 6;
7533 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7534 "/%.*s/ should probably be written as \"%.*s\"",
7535 (int)len, pmstr, (int)len, pmstr);
7542 Perl_ck_subr(pTHX_ OP *o)
7545 OP *prev = ((cUNOPo->op_first->op_sibling)
7546 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
7547 OP *o2 = prev->op_sibling;
7549 const char *proto = NULL;
7550 const char *proto_end = NULL;
7555 I32 contextclass = 0;
7556 const char *e = NULL;
7559 o->op_private |= OPpENTERSUB_HASTARG;
7560 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
7561 if (cvop->op_type == OP_RV2CV) {
7563 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
7564 op_null(cvop); /* disable rv2cv */
7565 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
7566 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
7567 GV *gv = cGVOPx_gv(tmpop);
7570 tmpop->op_private |= OPpEARLY_CV;
7574 namegv = CvANON(cv) ? gv : CvGV(cv);
7575 proto = SvPV((SV*)cv, len);
7576 proto_end = proto + len;
7581 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7582 if (o2->op_type == OP_CONST)
7583 o2->op_private &= ~OPpCONST_STRICT;
7584 else if (o2->op_type == OP_LIST) {
7585 OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
7586 if (sib && sib->op_type == OP_CONST)
7587 sib->op_private &= ~OPpCONST_STRICT;
7590 o->op_private |= (PL_hints & HINT_STRICT_REFS);
7591 if (PERLDB_SUB && PL_curstash != PL_debstash)
7592 o->op_private |= OPpENTERSUB_DB;
7593 while (o2 != cvop) {
7595 if (PL_madskills && o2->op_type == OP_STUB) {
7596 o2 = o2->op_sibling;
7599 if (PL_madskills && o2->op_type == OP_NULL)
7600 o3 = ((UNOP*)o2)->op_first;
7604 if (proto >= proto_end)
7605 return too_many_arguments(o, gv_ename(namegv));
7613 /* _ must be at the end */
7614 if (proto[1] && proto[1] != ';')
7629 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
7631 arg == 1 ? "block or sub {}" : "sub {}",
7632 gv_ename(namegv), o3);
7635 /* '*' allows any scalar type, including bareword */
7638 if (o3->op_type == OP_RV2GV)
7639 goto wrapref; /* autoconvert GLOB -> GLOBref */
7640 else if (o3->op_type == OP_CONST)
7641 o3->op_private &= ~OPpCONST_STRICT;
7642 else if (o3->op_type == OP_ENTERSUB) {
7643 /* accidental subroutine, revert to bareword */
7644 OP *gvop = ((UNOP*)o3)->op_first;
7645 if (gvop && gvop->op_type == OP_NULL) {
7646 gvop = ((UNOP*)gvop)->op_first;
7648 for (; gvop->op_sibling; gvop = gvop->op_sibling)
7651 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
7652 (gvop = ((UNOP*)gvop)->op_first) &&
7653 gvop->op_type == OP_GV)
7655 GV * const gv = cGVOPx_gv(gvop);
7656 OP * const sibling = o2->op_sibling;
7657 SV * const n = newSVpvs("");
7659 OP * const oldo2 = o2;
7663 gv_fullname4(n, gv, "", FALSE);
7664 o2 = newSVOP(OP_CONST, 0, n);
7665 op_getmad(oldo2,o2,'O');
7666 prev->op_sibling = o2;
7667 o2->op_sibling = sibling;
7683 if (contextclass++ == 0) {
7684 e = strchr(proto, ']');
7685 if (!e || e == proto)
7694 const char *p = proto;
7695 const char *const end = proto;
7697 while (*--p != '[');
7698 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
7700 gv_ename(namegv), o3);
7705 if (o3->op_type == OP_RV2GV)
7708 bad_type(arg, "symbol", gv_ename(namegv), o3);
7711 if (o3->op_type == OP_ENTERSUB)
7714 bad_type(arg, "subroutine entry", gv_ename(namegv),
7718 if (o3->op_type == OP_RV2SV ||
7719 o3->op_type == OP_PADSV ||
7720 o3->op_type == OP_HELEM ||
7721 o3->op_type == OP_AELEM)
7724 bad_type(arg, "scalar", gv_ename(namegv), o3);
7727 if (o3->op_type == OP_RV2AV ||
7728 o3->op_type == OP_PADAV)
7731 bad_type(arg, "array", gv_ename(namegv), o3);
7734 if (o3->op_type == OP_RV2HV ||
7735 o3->op_type == OP_PADHV)
7738 bad_type(arg, "hash", gv_ename(namegv), o3);
7743 OP* const sib = kid->op_sibling;
7744 kid->op_sibling = 0;
7745 o2 = newUNOP(OP_REFGEN, 0, kid);
7746 o2->op_sibling = sib;
7747 prev->op_sibling = o2;
7749 if (contextclass && e) {
7764 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
7765 gv_ename(namegv), SVfARG(cv));
7770 mod(o2, OP_ENTERSUB);
7772 o2 = o2->op_sibling;
7774 if (o2 == cvop && proto && *proto == '_') {
7775 /* generate an access to $_ */
7777 o2->op_sibling = prev->op_sibling;
7778 prev->op_sibling = o2; /* instead of cvop */
7780 if (proto && !optional && proto_end > proto &&
7781 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
7782 return too_few_arguments(o, gv_ename(namegv));
7785 OP * const oldo = o;
7789 o=newSVOP(OP_CONST, 0, newSViv(0));
7790 op_getmad(oldo,o,'O');
7796 Perl_ck_svconst(pTHX_ OP *o)
7798 PERL_UNUSED_CONTEXT;
7799 SvREADONLY_on(cSVOPo->op_sv);
7804 Perl_ck_chdir(pTHX_ OP *o)
7806 if (o->op_flags & OPf_KIDS) {
7807 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7809 if (kid && kid->op_type == OP_CONST &&
7810 (kid->op_private & OPpCONST_BARE))
7812 o->op_flags |= OPf_SPECIAL;
7813 kid->op_private &= ~OPpCONST_STRICT;
7820 Perl_ck_trunc(pTHX_ OP *o)
7822 if (o->op_flags & OPf_KIDS) {
7823 SVOP *kid = (SVOP*)cUNOPo->op_first;
7825 if (kid->op_type == OP_NULL)
7826 kid = (SVOP*)kid->op_sibling;
7827 if (kid && kid->op_type == OP_CONST &&
7828 (kid->op_private & OPpCONST_BARE))
7830 o->op_flags |= OPf_SPECIAL;
7831 kid->op_private &= ~OPpCONST_STRICT;
7838 Perl_ck_unpack(pTHX_ OP *o)
7840 OP *kid = cLISTOPo->op_first;
7841 if (kid->op_sibling) {
7842 kid = kid->op_sibling;
7843 if (!kid->op_sibling)
7844 kid->op_sibling = newDEFSVOP();
7850 Perl_ck_substr(pTHX_ OP *o)
7853 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
7854 OP *kid = cLISTOPo->op_first;
7856 if (kid->op_type == OP_NULL)
7857 kid = kid->op_sibling;
7859 kid->op_flags |= OPf_MOD;
7865 /* A peephole optimizer. We visit the ops in the order they're to execute.
7866 * See the comments at the top of this file for more details about when
7867 * peep() is called */
7870 Perl_peep(pTHX_ register OP *o)
7873 register OP* oldop = NULL;
7875 if (!o || o->op_opt)
7879 SAVEVPTR(PL_curcop);
7880 for (; o; o = o->op_next) {
7883 /* By default, this op has now been optimised. A couple of cases below
7884 clear this again. */
7887 switch (o->op_type) {
7891 PL_curcop = ((COP*)o); /* for warnings */
7895 if (cSVOPo->op_private & OPpCONST_STRICT)
7896 no_bareword_allowed(o);
7898 case OP_METHOD_NAMED:
7899 /* Relocate sv to the pad for thread safety.
7900 * Despite being a "constant", the SV is written to,
7901 * for reference counts, sv_upgrade() etc. */
7903 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
7904 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
7905 /* If op_sv is already a PADTMP then it is being used by
7906 * some pad, so make a copy. */
7907 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
7908 SvREADONLY_on(PAD_SVl(ix));
7909 SvREFCNT_dec(cSVOPo->op_sv);
7911 else if (o->op_type == OP_CONST
7912 && cSVOPo->op_sv == &PL_sv_undef) {
7913 /* PL_sv_undef is hack - it's unsafe to store it in the
7914 AV that is the pad, because av_fetch treats values of
7915 PL_sv_undef as a "free" AV entry and will merrily
7916 replace them with a new SV, causing pad_alloc to think
7917 that this pad slot is free. (When, clearly, it is not)
7919 SvOK_off(PAD_SVl(ix));
7920 SvPADTMP_on(PAD_SVl(ix));
7921 SvREADONLY_on(PAD_SVl(ix));
7924 SvREFCNT_dec(PAD_SVl(ix));
7925 SvPADTMP_on(cSVOPo->op_sv);
7926 PAD_SETSV(ix, cSVOPo->op_sv);
7927 /* XXX I don't know how this isn't readonly already. */
7928 SvREADONLY_on(PAD_SVl(ix));
7930 cSVOPo->op_sv = NULL;
7937 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
7938 if (o->op_next->op_private & OPpTARGET_MY) {
7939 if (o->op_flags & OPf_STACKED) /* chained concats */
7940 break; /* ignore_optimization */
7942 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
7943 o->op_targ = o->op_next->op_targ;
7944 o->op_next->op_targ = 0;
7945 o->op_private |= OPpTARGET_MY;
7948 op_null(o->op_next);
7952 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
7953 break; /* Scalar stub must produce undef. List stub is noop */
7957 if (o->op_targ == OP_NEXTSTATE
7958 || o->op_targ == OP_DBSTATE
7959 || o->op_targ == OP_SETSTATE)
7961 PL_curcop = ((COP*)o);
7963 /* XXX: We avoid setting op_seq here to prevent later calls
7964 to peep() from mistakenly concluding that optimisation
7965 has already occurred. This doesn't fix the real problem,
7966 though (See 20010220.007). AMS 20010719 */
7967 /* op_seq functionality is now replaced by op_opt */
7974 if (oldop && o->op_next) {
7975 oldop->op_next = o->op_next;
7983 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
7984 OP* const pop = (o->op_type == OP_PADAV) ?
7985 o->op_next : o->op_next->op_next;
7987 if (pop && pop->op_type == OP_CONST &&
7988 ((PL_op = pop->op_next)) &&
7989 pop->op_next->op_type == OP_AELEM &&
7990 !(pop->op_next->op_private &
7991 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
7992 (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
7997 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
7998 no_bareword_allowed(pop);
7999 if (o->op_type == OP_GV)
8000 op_null(o->op_next);
8001 op_null(pop->op_next);
8003 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
8004 o->op_next = pop->op_next->op_next;
8005 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
8006 o->op_private = (U8)i;
8007 if (o->op_type == OP_GV) {
8012 o->op_flags |= OPf_SPECIAL;
8013 o->op_type = OP_AELEMFAST;
8018 if (o->op_next->op_type == OP_RV2SV) {
8019 if (!(o->op_next->op_private & OPpDEREF)) {
8020 op_null(o->op_next);
8021 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
8023 o->op_next = o->op_next->op_next;
8024 o->op_type = OP_GVSV;
8025 o->op_ppaddr = PL_ppaddr[OP_GVSV];
8028 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
8029 GV * const gv = cGVOPo_gv;
8030 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
8031 /* XXX could check prototype here instead of just carping */
8032 SV * const sv = sv_newmortal();
8033 gv_efullname3(sv, gv, NULL);
8034 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
8035 "%"SVf"() called too early to check prototype",
8039 else if (o->op_next->op_type == OP_READLINE
8040 && o->op_next->op_next->op_type == OP_CONCAT
8041 && (o->op_next->op_next->op_flags & OPf_STACKED))
8043 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
8044 o->op_type = OP_RCATLINE;
8045 o->op_flags |= OPf_STACKED;
8046 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
8047 op_null(o->op_next->op_next);
8048 op_null(o->op_next);
8064 while (cLOGOP->op_other->op_type == OP_NULL)
8065 cLOGOP->op_other = cLOGOP->op_other->op_next;
8066 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
8071 while (cLOOP->op_redoop->op_type == OP_NULL)
8072 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
8073 peep(cLOOP->op_redoop);
8074 while (cLOOP->op_nextop->op_type == OP_NULL)
8075 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
8076 peep(cLOOP->op_nextop);
8077 while (cLOOP->op_lastop->op_type == OP_NULL)
8078 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
8079 peep(cLOOP->op_lastop);
8083 assert(!(cPMOP->op_pmflags & PMf_ONCE));
8084 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
8085 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
8086 cPMOP->op_pmstashstartu.op_pmreplstart
8087 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
8088 peep(cPMOP->op_pmstashstartu.op_pmreplstart);
8092 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
8093 && ckWARN(WARN_SYNTAX))
8095 if (o->op_next->op_sibling) {
8096 const OPCODE type = o->op_next->op_sibling->op_type;
8097 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
8098 const line_t oldline = CopLINE(PL_curcop);
8099 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
8100 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8101 "Statement unlikely to be reached");
8102 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8103 "\t(Maybe you meant system() when you said exec()?)\n");
8104 CopLINE_set(PL_curcop, oldline);
8115 const char *key = NULL;
8118 if (((BINOP*)o)->op_last->op_type != OP_CONST)
8121 /* Make the CONST have a shared SV */
8122 svp = cSVOPx_svp(((BINOP*)o)->op_last);
8123 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
8124 key = SvPV_const(sv, keylen);
8125 lexname = newSVpvn_share(key,
8126 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
8132 if ((o->op_private & (OPpLVAL_INTRO)))
8135 rop = (UNOP*)((BINOP*)o)->op_first;
8136 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
8138 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
8139 if (!SvPAD_TYPED(lexname))
8141 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8142 if (!fields || !GvHV(*fields))
8144 key = SvPV_const(*svp, keylen);
8145 if (!hv_fetch(GvHV(*fields), key,
8146 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8148 Perl_croak(aTHX_ "No such class field \"%s\" "
8149 "in variable %s of type %s",
8150 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
8163 SVOP *first_key_op, *key_op;
8165 if ((o->op_private & (OPpLVAL_INTRO))
8166 /* I bet there's always a pushmark... */
8167 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
8168 /* hmmm, no optimization if list contains only one key. */
8170 rop = (UNOP*)((LISTOP*)o)->op_last;
8171 if (rop->op_type != OP_RV2HV)
8173 if (rop->op_first->op_type == OP_PADSV)
8174 /* @$hash{qw(keys here)} */
8175 rop = (UNOP*)rop->op_first;
8177 /* @{$hash}{qw(keys here)} */
8178 if (rop->op_first->op_type == OP_SCOPE
8179 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
8181 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
8187 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
8188 if (!SvPAD_TYPED(lexname))
8190 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8191 if (!fields || !GvHV(*fields))
8193 /* Again guessing that the pushmark can be jumped over.... */
8194 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
8195 ->op_first->op_sibling;
8196 for (key_op = first_key_op; key_op;
8197 key_op = (SVOP*)key_op->op_sibling) {
8198 if (key_op->op_type != OP_CONST)
8200 svp = cSVOPx_svp(key_op);
8201 key = SvPV_const(*svp, keylen);
8202 if (!hv_fetch(GvHV(*fields), key,
8203 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8205 Perl_croak(aTHX_ "No such class field \"%s\" "
8206 "in variable %s of type %s",
8207 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
8214 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
8218 /* check that RHS of sort is a single plain array */
8219 OP *oright = cUNOPo->op_first;
8220 if (!oright || oright->op_type != OP_PUSHMARK)
8223 /* reverse sort ... can be optimised. */
8224 if (!cUNOPo->op_sibling) {
8225 /* Nothing follows us on the list. */
8226 OP * const reverse = o->op_next;
8228 if (reverse->op_type == OP_REVERSE &&
8229 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
8230 OP * const pushmark = cUNOPx(reverse)->op_first;
8231 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
8232 && (cUNOPx(pushmark)->op_sibling == o)) {
8233 /* reverse -> pushmark -> sort */
8234 o->op_private |= OPpSORT_REVERSE;
8236 pushmark->op_next = oright->op_next;
8242 /* make @a = sort @a act in-place */
8244 oright = cUNOPx(oright)->op_sibling;
8247 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
8248 oright = cUNOPx(oright)->op_sibling;
8252 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
8253 || oright->op_next != o
8254 || (oright->op_private & OPpLVAL_INTRO)
8258 /* o2 follows the chain of op_nexts through the LHS of the
8259 * assign (if any) to the aassign op itself */
8261 if (!o2 || o2->op_type != OP_NULL)
8264 if (!o2 || o2->op_type != OP_PUSHMARK)
8267 if (o2 && o2->op_type == OP_GV)
8270 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
8271 || (o2->op_private & OPpLVAL_INTRO)
8276 if (!o2 || o2->op_type != OP_NULL)
8279 if (!o2 || o2->op_type != OP_AASSIGN
8280 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
8283 /* check that the sort is the first arg on RHS of assign */
8285 o2 = cUNOPx(o2)->op_first;
8286 if (!o2 || o2->op_type != OP_NULL)
8288 o2 = cUNOPx(o2)->op_first;
8289 if (!o2 || o2->op_type != OP_PUSHMARK)
8291 if (o2->op_sibling != o)
8294 /* check the array is the same on both sides */
8295 if (oleft->op_type == OP_RV2AV) {
8296 if (oright->op_type != OP_RV2AV
8297 || !cUNOPx(oright)->op_first
8298 || cUNOPx(oright)->op_first->op_type != OP_GV
8299 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
8300 cGVOPx_gv(cUNOPx(oright)->op_first)
8304 else if (oright->op_type != OP_PADAV
8305 || oright->op_targ != oleft->op_targ
8309 /* transfer MODishness etc from LHS arg to RHS arg */
8310 oright->op_flags = oleft->op_flags;
8311 o->op_private |= OPpSORT_INPLACE;
8313 /* excise push->gv->rv2av->null->aassign */
8314 o2 = o->op_next->op_next;
8315 op_null(o2); /* PUSHMARK */
8317 if (o2->op_type == OP_GV) {
8318 op_null(o2); /* GV */
8321 op_null(o2); /* RV2AV or PADAV */
8322 o2 = o2->op_next->op_next;
8323 op_null(o2); /* AASSIGN */
8325 o->op_next = o2->op_next;
8331 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
8333 LISTOP *enter, *exlist;
8335 enter = (LISTOP *) o->op_next;
8338 if (enter->op_type == OP_NULL) {
8339 enter = (LISTOP *) enter->op_next;
8343 /* for $a (...) will have OP_GV then OP_RV2GV here.
8344 for (...) just has an OP_GV. */
8345 if (enter->op_type == OP_GV) {
8346 gvop = (OP *) enter;
8347 enter = (LISTOP *) enter->op_next;
8350 if (enter->op_type == OP_RV2GV) {
8351 enter = (LISTOP *) enter->op_next;
8357 if (enter->op_type != OP_ENTERITER)
8360 iter = enter->op_next;
8361 if (!iter || iter->op_type != OP_ITER)
8364 expushmark = enter->op_first;
8365 if (!expushmark || expushmark->op_type != OP_NULL
8366 || expushmark->op_targ != OP_PUSHMARK)
8369 exlist = (LISTOP *) expushmark->op_sibling;
8370 if (!exlist || exlist->op_type != OP_NULL
8371 || exlist->op_targ != OP_LIST)
8374 if (exlist->op_last != o) {
8375 /* Mmm. Was expecting to point back to this op. */
8378 theirmark = exlist->op_first;
8379 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
8382 if (theirmark->op_sibling != o) {
8383 /* There's something between the mark and the reverse, eg
8384 for (1, reverse (...))
8389 ourmark = ((LISTOP *)o)->op_first;
8390 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
8393 ourlast = ((LISTOP *)o)->op_last;
8394 if (!ourlast || ourlast->op_next != o)
8397 rv2av = ourmark->op_sibling;
8398 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
8399 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
8400 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
8401 /* We're just reversing a single array. */
8402 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
8403 enter->op_flags |= OPf_STACKED;
8406 /* We don't have control over who points to theirmark, so sacrifice
8408 theirmark->op_next = ourmark->op_next;
8409 theirmark->op_flags = ourmark->op_flags;
8410 ourlast->op_next = gvop ? gvop : (OP *) enter;
8413 enter->op_private |= OPpITER_REVERSED;
8414 iter->op_private |= OPpITER_REVERSED;
8421 UNOP *refgen, *rv2cv;
8424 if ((o->op_flags && OPf_WANT) != OPf_WANT_VOID)
8427 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
8430 rv2gv = ((BINOP *)o)->op_last;
8431 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
8434 refgen = (UNOP *)((BINOP *)o)->op_first;
8436 if (!refgen || refgen->op_type != OP_REFGEN)
8439 exlist = (LISTOP *)refgen->op_first;
8440 if (!exlist || exlist->op_type != OP_NULL
8441 || exlist->op_targ != OP_LIST)
8444 if (exlist->op_first->op_type != OP_PUSHMARK)
8447 rv2cv = (UNOP*)exlist->op_last;
8449 if (rv2cv->op_type != OP_RV2CV)
8452 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
8453 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
8454 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
8456 o->op_private |= OPpASSIGN_CV_TO_GV;
8457 rv2gv->op_private |= OPpDONT_INIT_GV;
8458 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
8466 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
8467 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
8477 Perl_custom_op_name(pTHX_ const OP* o)
8480 const IV index = PTR2IV(o->op_ppaddr);
8484 if (!PL_custom_op_names) /* This probably shouldn't happen */
8485 return (char *)PL_op_name[OP_CUSTOM];
8487 keysv = sv_2mortal(newSViv(index));
8489 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
8491 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
8493 return SvPV_nolen(HeVAL(he));
8497 Perl_custom_op_desc(pTHX_ const OP* o)
8500 const IV index = PTR2IV(o->op_ppaddr);
8504 if (!PL_custom_op_descs)
8505 return (char *)PL_op_desc[OP_CUSTOM];
8507 keysv = sv_2mortal(newSViv(index));
8509 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
8511 return (char *)PL_op_desc[OP_CUSTOM];
8513 return SvPV_nolen(HeVAL(he));
8518 /* Efficient sub that returns a constant scalar value. */
8520 const_sv_xsub(pTHX_ CV* cv)
8527 Perl_croak(aTHX_ "usage: %s::%s()",
8528 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
8532 ST(0) = (SV*)XSANY.any_ptr;
8538 * c-indentation-style: bsd
8540 * indent-tabs-mode: t
8543 * ex: set ts=8 sts=4 sw=4 noet: