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
398 /* anon sub prototypes contains state vars should always be cloned,
399 * otherwise the state var would be shared between anon subs */
401 if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
402 CvCLONE_on(PL_compcv);
407 /* free the body of an op without examining its contents.
408 * Always use this rather than FreeOp directly */
411 S_op_destroy(pTHX_ OP *o)
413 if (o->op_latefree) {
421 # define forget_pmop(a,b) S_forget_pmop(aTHX_ a,b)
423 # define forget_pmop(a,b) S_forget_pmop(aTHX_ a)
429 Perl_op_free(pTHX_ OP *o)
436 if (o->op_latefreed) {
443 if (o->op_private & OPpREFCOUNTED) {
454 refcnt = OpREFCNT_dec(o);
457 /* Need to find and remove any pattern match ops from the list
458 we maintain for reset(). */
459 find_and_forget_pmops(o);
469 if (o->op_flags & OPf_KIDS) {
470 register OP *kid, *nextkid;
471 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
472 nextkid = kid->op_sibling; /* Get before next freeing kid */
477 type = (OPCODE)o->op_targ;
479 #ifdef PERL_DEBUG_READONLY_OPS
483 /* COP* is not cleared by op_clear() so that we may track line
484 * numbers etc even after null() */
485 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE) {
490 if (o->op_latefree) {
496 #ifdef DEBUG_LEAKING_SCALARS
503 Perl_op_clear(pTHX_ OP *o)
508 /* if (o->op_madprop && o->op_madprop->mad_next)
510 /* FIXME for MAD - if I uncomment these two lines t/op/pack.t fails with
511 "modification of a read only value" for a reason I can't fathom why.
512 It's the "" stringification of $_, where $_ was set to '' in a foreach
513 loop, but it defies simplification into a small test case.
514 However, commenting them out has caused ext/List/Util/t/weak.t to fail
517 mad_free(o->op_madprop);
523 switch (o->op_type) {
524 case OP_NULL: /* Was holding old type, if any. */
525 if (PL_madskills && o->op_targ != OP_NULL) {
526 o->op_type = o->op_targ;
530 case OP_ENTEREVAL: /* Was holding hints. */
534 if (!(o->op_flags & OPf_REF)
535 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
541 if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
542 /* not an OP_PADAV replacement */
544 if (cPADOPo->op_padix > 0) {
545 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
546 * may still exist on the pad */
547 pad_swipe(cPADOPo->op_padix, TRUE);
548 cPADOPo->op_padix = 0;
551 SvREFCNT_dec(cSVOPo->op_sv);
552 cSVOPo->op_sv = NULL;
556 case OP_METHOD_NAMED:
558 SvREFCNT_dec(cSVOPo->op_sv);
559 cSVOPo->op_sv = NULL;
562 Even if op_clear does a pad_free for the target of the op,
563 pad_free doesn't actually remove the sv that exists in the pad;
564 instead it lives on. This results in that it could be reused as
565 a target later on when the pad was reallocated.
568 pad_swipe(o->op_targ,1);
577 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
581 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
583 if (cPADOPo->op_padix > 0) {
584 pad_swipe(cPADOPo->op_padix, TRUE);
585 cPADOPo->op_padix = 0;
588 SvREFCNT_dec(cSVOPo->op_sv);
589 cSVOPo->op_sv = NULL;
593 PerlMemShared_free(cPVOPo->op_pv);
594 cPVOPo->op_pv = NULL;
598 op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
602 if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
603 /* No GvIN_PAD_off here, because other references may still
604 * exist on the pad */
605 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
608 SvREFCNT_dec((SV*)cPMOPo->op_pmreplrootu.op_pmtargetgv);
614 forget_pmop(cPMOPo, 1);
615 cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
616 /* we use the "SAFE" version of the PM_ macros here
617 * since sv_clean_all might release some PMOPs
618 * after PL_regex_padav has been cleared
619 * and the clearing of PL_regex_padav needs to
620 * happen before sv_clean_all
622 ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
623 PM_SETRE_SAFE(cPMOPo, NULL);
625 if(PL_regex_pad) { /* We could be in destruction */
626 av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
627 SvREADONLY_off(PL_regex_pad[(cPMOPo)->op_pmoffset]);
628 SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
629 PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
636 if (o->op_targ > 0) {
637 pad_free(o->op_targ);
643 S_cop_free(pTHX_ COP* cop)
648 if (! specialWARN(cop->cop_warnings))
649 PerlMemShared_free(cop->cop_warnings);
650 Perl_refcounted_he_free(aTHX_ cop->cop_hints_hash);
654 S_forget_pmop(pTHX_ PMOP *const o
660 HV * const pmstash = PmopSTASH(o);
661 if (pmstash && !SvIS_FREED(pmstash)) {
662 MAGIC * const mg = mg_find((SV*)pmstash, PERL_MAGIC_symtab);
664 PMOP **const array = (PMOP**) mg->mg_ptr;
665 U32 count = mg->mg_len / sizeof(PMOP**);
670 /* Found it. Move the entry at the end to overwrite it. */
671 array[i] = array[--count];
672 mg->mg_len = count * sizeof(PMOP**);
673 /* Could realloc smaller at this point always, but probably
674 not worth it. Probably worth free()ing if we're the
677 Safefree(mg->mg_ptr);
694 S_find_and_forget_pmops(pTHX_ OP *o)
696 if (o->op_flags & OPf_KIDS) {
697 OP *kid = cUNOPo->op_first;
699 switch (kid->op_type) {
704 forget_pmop((PMOP*)kid, 0);
706 find_and_forget_pmops(kid);
707 kid = kid->op_sibling;
713 Perl_op_null(pTHX_ OP *o)
716 if (o->op_type == OP_NULL)
720 o->op_targ = o->op_type;
721 o->op_type = OP_NULL;
722 o->op_ppaddr = PL_ppaddr[OP_NULL];
726 Perl_op_refcnt_lock(pTHX)
734 Perl_op_refcnt_unlock(pTHX)
741 /* Contextualizers */
743 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
746 Perl_linklist(pTHX_ OP *o)
753 /* establish postfix order */
754 first = cUNOPo->op_first;
757 o->op_next = LINKLIST(first);
760 if (kid->op_sibling) {
761 kid->op_next = LINKLIST(kid->op_sibling);
762 kid = kid->op_sibling;
776 Perl_scalarkids(pTHX_ OP *o)
778 if (o && o->op_flags & OPf_KIDS) {
780 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
787 S_scalarboolean(pTHX_ OP *o)
790 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
791 if (ckWARN(WARN_SYNTAX)) {
792 const line_t oldline = CopLINE(PL_curcop);
794 if (PL_parser && PL_parser->copline != NOLINE)
795 CopLINE_set(PL_curcop, PL_parser->copline);
796 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
797 CopLINE_set(PL_curcop, oldline);
804 Perl_scalar(pTHX_ OP *o)
809 /* assumes no premature commitment */
810 if (!o || (PL_parser && PL_parser->error_count)
811 || (o->op_flags & OPf_WANT)
812 || o->op_type == OP_RETURN)
817 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
819 switch (o->op_type) {
821 scalar(cBINOPo->op_first);
826 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
830 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
831 if (!kPMOP->op_pmreplrootu.op_pmreplroot)
832 deprecate_old("implicit split to @_");
840 if (o->op_flags & OPf_KIDS) {
841 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
847 kid = cLISTOPo->op_first;
849 while ((kid = kid->op_sibling)) {
855 PL_curcop = &PL_compiling;
860 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
866 PL_curcop = &PL_compiling;
869 if (ckWARN(WARN_VOID))
870 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
876 Perl_scalarvoid(pTHX_ OP *o)
880 const char* useless = NULL;
884 /* trailing mad null ops don't count as "there" for void processing */
886 o->op_type != OP_NULL &&
888 o->op_sibling->op_type == OP_NULL)
891 for (sib = o->op_sibling;
892 sib && sib->op_type == OP_NULL;
893 sib = sib->op_sibling) ;
899 if (o->op_type == OP_NEXTSTATE
900 || o->op_type == OP_SETSTATE
901 || o->op_type == OP_DBSTATE
902 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
903 || o->op_targ == OP_SETSTATE
904 || o->op_targ == OP_DBSTATE)))
905 PL_curcop = (COP*)o; /* for warning below */
907 /* assumes no premature commitment */
908 want = o->op_flags & OPf_WANT;
909 if ((want && want != OPf_WANT_SCALAR)
910 || (PL_parser && PL_parser->error_count)
911 || o->op_type == OP_RETURN)
916 if ((o->op_private & OPpTARGET_MY)
917 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
919 return scalar(o); /* As if inside SASSIGN */
922 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
924 switch (o->op_type) {
926 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
930 if (o->op_flags & OPf_STACKED)
934 if (o->op_private == 4)
1006 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1007 useless = OP_DESC(o);
1011 kid = cUNOPo->op_first;
1012 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1013 kid->op_type != OP_TRANS) {
1016 useless = "negative pattern binding (!~)";
1023 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1024 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1025 useless = "a variable";
1030 if (cSVOPo->op_private & OPpCONST_STRICT)
1031 no_bareword_allowed(o);
1033 if (ckWARN(WARN_VOID)) {
1034 useless = "a constant";
1035 if (o->op_private & OPpCONST_ARYBASE)
1037 /* don't warn on optimised away booleans, eg
1038 * use constant Foo, 5; Foo || print; */
1039 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1041 /* the constants 0 and 1 are permitted as they are
1042 conventionally used as dummies in constructs like
1043 1 while some_condition_with_side_effects; */
1044 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1046 else if (SvPOK(sv)) {
1047 /* perl4's way of mixing documentation and code
1048 (before the invention of POD) was based on a
1049 trick to mix nroff and perl code. The trick was
1050 built upon these three nroff macros being used in
1051 void context. The pink camel has the details in
1052 the script wrapman near page 319. */
1053 const char * const maybe_macro = SvPVX_const(sv);
1054 if (strnEQ(maybe_macro, "di", 2) ||
1055 strnEQ(maybe_macro, "ds", 2) ||
1056 strnEQ(maybe_macro, "ig", 2))
1061 op_null(o); /* don't execute or even remember it */
1065 o->op_type = OP_PREINC; /* pre-increment is faster */
1066 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1070 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1071 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1075 o->op_type = OP_I_PREINC; /* pre-increment is faster */
1076 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1080 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
1081 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1090 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1095 if (o->op_flags & OPf_STACKED)
1102 if (!(o->op_flags & OPf_KIDS))
1113 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1120 /* all requires must return a boolean value */
1121 o->op_flags &= ~OPf_WANT;
1126 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
1127 if (!kPMOP->op_pmreplrootu.op_pmreplroot)
1128 deprecate_old("implicit split to @_");
1132 if (useless && ckWARN(WARN_VOID))
1133 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
1138 Perl_listkids(pTHX_ OP *o)
1140 if (o && o->op_flags & OPf_KIDS) {
1142 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1149 Perl_list(pTHX_ OP *o)
1154 /* assumes no premature commitment */
1155 if (!o || (o->op_flags & OPf_WANT)
1156 || (PL_parser && PL_parser->error_count)
1157 || o->op_type == OP_RETURN)
1162 if ((o->op_private & OPpTARGET_MY)
1163 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1165 return o; /* As if inside SASSIGN */
1168 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1170 switch (o->op_type) {
1173 list(cBINOPo->op_first);
1178 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1186 if (!(o->op_flags & OPf_KIDS))
1188 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1189 list(cBINOPo->op_first);
1190 return gen_constant_list(o);
1197 kid = cLISTOPo->op_first;
1199 while ((kid = kid->op_sibling)) {
1200 if (kid->op_sibling)
1205 PL_curcop = &PL_compiling;
1209 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1210 if (kid->op_sibling)
1215 PL_curcop = &PL_compiling;
1218 /* all requires must return a boolean value */
1219 o->op_flags &= ~OPf_WANT;
1226 Perl_scalarseq(pTHX_ OP *o)
1230 const OPCODE type = o->op_type;
1232 if (type == OP_LINESEQ || type == OP_SCOPE ||
1233 type == OP_LEAVE || type == OP_LEAVETRY)
1236 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1237 if (kid->op_sibling) {
1241 PL_curcop = &PL_compiling;
1243 o->op_flags &= ~OPf_PARENS;
1244 if (PL_hints & HINT_BLOCK_SCOPE)
1245 o->op_flags |= OPf_PARENS;
1248 o = newOP(OP_STUB, 0);
1253 S_modkids(pTHX_ OP *o, I32 type)
1255 if (o && o->op_flags & OPf_KIDS) {
1257 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1263 /* Propagate lvalue ("modifiable") context to an op and its children.
1264 * 'type' represents the context type, roughly based on the type of op that
1265 * would do the modifying, although local() is represented by OP_NULL.
1266 * It's responsible for detecting things that can't be modified, flag
1267 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
1268 * might have to vivify a reference in $x), and so on.
1270 * For example, "$a+1 = 2" would cause mod() to be called with o being
1271 * OP_ADD and type being OP_SASSIGN, and would output an error.
1275 Perl_mod(pTHX_ OP *o, I32 type)
1279 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1282 if (!o || (PL_parser && PL_parser->error_count))
1285 if ((o->op_private & OPpTARGET_MY)
1286 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1291 switch (o->op_type) {
1297 if (!(o->op_private & OPpCONST_ARYBASE))
1300 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1301 CopARYBASE_set(&PL_compiling,
1302 (I32)SvIV(cSVOPx(PL_eval_start)->op_sv));
1306 SAVECOPARYBASE(&PL_compiling);
1307 CopARYBASE_set(&PL_compiling, 0);
1309 else if (type == OP_REFGEN)
1312 Perl_croak(aTHX_ "That use of $[ is unsupported");
1315 if ((o->op_flags & OPf_PARENS) || PL_madskills)
1319 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1320 !(o->op_flags & OPf_STACKED)) {
1321 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1322 /* The default is to set op_private to the number of children,
1323 which for a UNOP such as RV2CV is always 1. And w're using
1324 the bit for a flag in RV2CV, so we need it clear. */
1325 o->op_private &= ~1;
1326 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1327 assert(cUNOPo->op_first->op_type == OP_NULL);
1328 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1331 else if (o->op_private & OPpENTERSUB_NOMOD)
1333 else { /* lvalue subroutine call */
1334 o->op_private |= OPpLVAL_INTRO;
1335 PL_modcount = RETURN_UNLIMITED_NUMBER;
1336 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1337 /* Backward compatibility mode: */
1338 o->op_private |= OPpENTERSUB_INARGS;
1341 else { /* Compile-time error message: */
1342 OP *kid = cUNOPo->op_first;
1346 if (kid->op_type != OP_PUSHMARK) {
1347 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1349 "panic: unexpected lvalue entersub "
1350 "args: type/targ %ld:%"UVuf,
1351 (long)kid->op_type, (UV)kid->op_targ);
1352 kid = kLISTOP->op_first;
1354 while (kid->op_sibling)
1355 kid = kid->op_sibling;
1356 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1358 if (kid->op_type == OP_METHOD_NAMED
1359 || kid->op_type == OP_METHOD)
1363 NewOp(1101, newop, 1, UNOP);
1364 newop->op_type = OP_RV2CV;
1365 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1366 newop->op_first = NULL;
1367 newop->op_next = (OP*)newop;
1368 kid->op_sibling = (OP*)newop;
1369 newop->op_private |= OPpLVAL_INTRO;
1370 newop->op_private &= ~1;
1374 if (kid->op_type != OP_RV2CV)
1376 "panic: unexpected lvalue entersub "
1377 "entry via type/targ %ld:%"UVuf,
1378 (long)kid->op_type, (UV)kid->op_targ);
1379 kid->op_private |= OPpLVAL_INTRO;
1380 break; /* Postpone until runtime */
1384 kid = kUNOP->op_first;
1385 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1386 kid = kUNOP->op_first;
1387 if (kid->op_type == OP_NULL)
1389 "Unexpected constant lvalue entersub "
1390 "entry via type/targ %ld:%"UVuf,
1391 (long)kid->op_type, (UV)kid->op_targ);
1392 if (kid->op_type != OP_GV) {
1393 /* Restore RV2CV to check lvalueness */
1395 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1396 okid->op_next = kid->op_next;
1397 kid->op_next = okid;
1400 okid->op_next = NULL;
1401 okid->op_type = OP_RV2CV;
1403 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1404 okid->op_private |= OPpLVAL_INTRO;
1405 okid->op_private &= ~1;
1409 cv = GvCV(kGVOP_gv);
1419 /* grep, foreach, subcalls, refgen */
1420 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1422 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1423 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1425 : (o->op_type == OP_ENTERSUB
1426 ? "non-lvalue subroutine call"
1428 type ? PL_op_desc[type] : "local"));
1442 case OP_RIGHT_SHIFT:
1451 if (!(o->op_flags & OPf_STACKED))
1458 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1464 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1465 PL_modcount = RETURN_UNLIMITED_NUMBER;
1466 return o; /* Treat \(@foo) like ordinary list. */
1470 if (scalar_mod_type(o, type))
1472 ref(cUNOPo->op_first, o->op_type);
1476 if (type == OP_LEAVESUBLV)
1477 o->op_private |= OPpMAYBE_LVSUB;
1483 PL_modcount = RETURN_UNLIMITED_NUMBER;
1486 ref(cUNOPo->op_first, o->op_type);
1491 PL_hints |= HINT_BLOCK_SCOPE;
1506 PL_modcount = RETURN_UNLIMITED_NUMBER;
1507 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1508 return o; /* Treat \(@foo) like ordinary list. */
1509 if (scalar_mod_type(o, type))
1511 if (type == OP_LEAVESUBLV)
1512 o->op_private |= OPpMAYBE_LVSUB;
1516 if (!type) /* local() */
1517 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1518 PAD_COMPNAME_PV(o->op_targ));
1526 if (type != OP_SASSIGN)
1530 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1535 if (type == OP_LEAVESUBLV)
1536 o->op_private |= OPpMAYBE_LVSUB;
1538 pad_free(o->op_targ);
1539 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1540 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1541 if (o->op_flags & OPf_KIDS)
1542 mod(cBINOPo->op_first->op_sibling, type);
1547 ref(cBINOPo->op_first, o->op_type);
1548 if (type == OP_ENTERSUB &&
1549 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1550 o->op_private |= OPpLVAL_DEFER;
1551 if (type == OP_LEAVESUBLV)
1552 o->op_private |= OPpMAYBE_LVSUB;
1562 if (o->op_flags & OPf_KIDS)
1563 mod(cLISTOPo->op_last, type);
1568 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1570 else if (!(o->op_flags & OPf_KIDS))
1572 if (o->op_targ != OP_LIST) {
1573 mod(cBINOPo->op_first, type);
1579 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1584 if (type != OP_LEAVESUBLV)
1586 break; /* mod()ing was handled by ck_return() */
1589 /* [20011101.069] File test operators interpret OPf_REF to mean that
1590 their argument is a filehandle; thus \stat(".") should not set
1592 if (type == OP_REFGEN &&
1593 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1596 if (type != OP_LEAVESUBLV)
1597 o->op_flags |= OPf_MOD;
1599 if (type == OP_AASSIGN || type == OP_SASSIGN)
1600 o->op_flags |= OPf_SPECIAL|OPf_REF;
1601 else if (!type) { /* local() */
1604 o->op_private |= OPpLVAL_INTRO;
1605 o->op_flags &= ~OPf_SPECIAL;
1606 PL_hints |= HINT_BLOCK_SCOPE;
1611 if (ckWARN(WARN_SYNTAX)) {
1612 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1613 "Useless localization of %s", OP_DESC(o));
1617 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1618 && type != OP_LEAVESUBLV)
1619 o->op_flags |= OPf_REF;
1624 S_scalar_mod_type(const OP *o, I32 type)
1628 if (o->op_type == OP_RV2GV)
1652 case OP_RIGHT_SHIFT:
1672 S_is_handle_constructor(const OP *o, I32 numargs)
1674 switch (o->op_type) {
1682 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1695 Perl_refkids(pTHX_ OP *o, I32 type)
1697 if (o && o->op_flags & OPf_KIDS) {
1699 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1706 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
1711 if (!o || (PL_parser && PL_parser->error_count))
1714 switch (o->op_type) {
1716 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1717 !(o->op_flags & OPf_STACKED)) {
1718 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1719 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1720 assert(cUNOPo->op_first->op_type == OP_NULL);
1721 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1722 o->op_flags |= OPf_SPECIAL;
1723 o->op_private &= ~1;
1728 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1729 doref(kid, type, set_op_ref);
1732 if (type == OP_DEFINED)
1733 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1734 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1737 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1738 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1739 : type == OP_RV2HV ? OPpDEREF_HV
1741 o->op_flags |= OPf_MOD;
1748 o->op_flags |= OPf_REF;
1751 if (type == OP_DEFINED)
1752 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1753 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1759 o->op_flags |= OPf_REF;
1764 if (!(o->op_flags & OPf_KIDS))
1766 doref(cBINOPo->op_first, type, set_op_ref);
1770 doref(cBINOPo->op_first, o->op_type, set_op_ref);
1771 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1772 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1773 : type == OP_RV2HV ? OPpDEREF_HV
1775 o->op_flags |= OPf_MOD;
1785 if (!(o->op_flags & OPf_KIDS))
1787 doref(cLISTOPo->op_last, type, set_op_ref);
1797 S_dup_attrlist(pTHX_ OP *o)
1802 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1803 * where the first kid is OP_PUSHMARK and the remaining ones
1804 * are OP_CONST. We need to push the OP_CONST values.
1806 if (o->op_type == OP_CONST)
1807 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
1809 else if (o->op_type == OP_NULL)
1813 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1815 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1816 if (o->op_type == OP_CONST)
1817 rop = append_elem(OP_LIST, rop,
1818 newSVOP(OP_CONST, o->op_flags,
1819 SvREFCNT_inc_NN(cSVOPo->op_sv)));
1826 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1831 /* fake up C<use attributes $pkg,$rv,@attrs> */
1832 ENTER; /* need to protect against side-effects of 'use' */
1833 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1835 #define ATTRSMODULE "attributes"
1836 #define ATTRSMODULE_PM "attributes.pm"
1839 /* Don't force the C<use> if we don't need it. */
1840 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
1841 if (svp && *svp != &PL_sv_undef)
1842 NOOP; /* already in %INC */
1844 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1845 newSVpvs(ATTRSMODULE), NULL);
1848 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1849 newSVpvs(ATTRSMODULE),
1851 prepend_elem(OP_LIST,
1852 newSVOP(OP_CONST, 0, stashsv),
1853 prepend_elem(OP_LIST,
1854 newSVOP(OP_CONST, 0,
1856 dup_attrlist(attrs))));
1862 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1865 OP *pack, *imop, *arg;
1871 assert(target->op_type == OP_PADSV ||
1872 target->op_type == OP_PADHV ||
1873 target->op_type == OP_PADAV);
1875 /* Ensure that attributes.pm is loaded. */
1876 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1878 /* Need package name for method call. */
1879 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
1881 /* Build up the real arg-list. */
1882 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1884 arg = newOP(OP_PADSV, 0);
1885 arg->op_targ = target->op_targ;
1886 arg = prepend_elem(OP_LIST,
1887 newSVOP(OP_CONST, 0, stashsv),
1888 prepend_elem(OP_LIST,
1889 newUNOP(OP_REFGEN, 0,
1890 mod(arg, OP_REFGEN)),
1891 dup_attrlist(attrs)));
1893 /* Fake up a method call to import */
1894 meth = newSVpvs_share("import");
1895 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1896 append_elem(OP_LIST,
1897 prepend_elem(OP_LIST, pack, list(arg)),
1898 newSVOP(OP_METHOD_NAMED, 0, meth)));
1899 imop->op_private |= OPpENTERSUB_NOMOD;
1901 /* Combine the ops. */
1902 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1906 =notfor apidoc apply_attrs_string
1908 Attempts to apply a list of attributes specified by the C<attrstr> and
1909 C<len> arguments to the subroutine identified by the C<cv> argument which
1910 is expected to be associated with the package identified by the C<stashpv>
1911 argument (see L<attributes>). It gets this wrong, though, in that it
1912 does not correctly identify the boundaries of the individual attribute
1913 specifications within C<attrstr>. This is not really intended for the
1914 public API, but has to be listed here for systems such as AIX which
1915 need an explicit export list for symbols. (It's called from XS code
1916 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1917 to respect attribute syntax properly would be welcome.
1923 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
1924 const char *attrstr, STRLEN len)
1929 len = strlen(attrstr);
1933 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1935 const char * const sstr = attrstr;
1936 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1937 attrs = append_elem(OP_LIST, attrs,
1938 newSVOP(OP_CONST, 0,
1939 newSVpvn(sstr, attrstr-sstr)));
1943 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1944 newSVpvs(ATTRSMODULE),
1945 NULL, prepend_elem(OP_LIST,
1946 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1947 prepend_elem(OP_LIST,
1948 newSVOP(OP_CONST, 0,
1954 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
1959 if (!o || (PL_parser && PL_parser->error_count))
1963 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
1964 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
1968 if (type == OP_LIST) {
1970 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1971 my_kid(kid, attrs, imopsp);
1972 } else if (type == OP_UNDEF
1978 } else if (type == OP_RV2SV || /* "our" declaration */
1980 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1981 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1982 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1984 PL_parser->in_my == KEY_our
1986 : PL_parser->in_my == KEY_state ? "state" : "my"));
1988 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
1989 PL_parser->in_my = FALSE;
1990 PL_parser->in_my_stash = NULL;
1991 apply_attrs(GvSTASH(gv),
1992 (type == OP_RV2SV ? GvSV(gv) :
1993 type == OP_RV2AV ? (SV*)GvAV(gv) :
1994 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1997 o->op_private |= OPpOUR_INTRO;
2000 else if (type != OP_PADSV &&
2003 type != OP_PUSHMARK)
2005 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2007 PL_parser->in_my == KEY_our
2009 : PL_parser->in_my == KEY_state ? "state" : "my"));
2012 else if (attrs && type != OP_PUSHMARK) {
2015 PL_parser->in_my = FALSE;
2016 PL_parser->in_my_stash = NULL;
2018 /* check for C<my Dog $spot> when deciding package */
2019 stash = PAD_COMPNAME_TYPE(o->op_targ);
2021 stash = PL_curstash;
2022 apply_attrs_my(stash, o, attrs, imopsp);
2024 o->op_flags |= OPf_MOD;
2025 o->op_private |= OPpLVAL_INTRO;
2026 if (PL_parser->in_my == KEY_state)
2027 o->op_private |= OPpPAD_STATE;
2032 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2036 int maybe_scalar = 0;
2038 /* [perl #17376]: this appears to be premature, and results in code such as
2039 C< our(%x); > executing in list mode rather than void mode */
2041 if (o->op_flags & OPf_PARENS)
2051 o = my_kid(o, attrs, &rops);
2053 if (maybe_scalar && o->op_type == OP_PADSV) {
2054 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
2055 o->op_private |= OPpLVAL_INTRO;
2058 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
2060 PL_parser->in_my = FALSE;
2061 PL_parser->in_my_stash = NULL;
2066 Perl_my(pTHX_ OP *o)
2068 return my_attrs(o, NULL);
2072 Perl_sawparens(pTHX_ OP *o)
2074 PERL_UNUSED_CONTEXT;
2076 o->op_flags |= OPf_PARENS;
2081 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2085 const OPCODE ltype = left->op_type;
2086 const OPCODE rtype = right->op_type;
2088 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2089 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
2091 const char * const desc
2092 = PL_op_desc[(rtype == OP_SUBST || rtype == OP_TRANS)
2093 ? (int)rtype : OP_MATCH];
2094 const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV)
2095 ? "@array" : "%hash");
2096 Perl_warner(aTHX_ packWARN(WARN_MISC),
2097 "Applying %s to %s will act on scalar(%s)",
2098 desc, sample, sample);
2101 if (rtype == OP_CONST &&
2102 cSVOPx(right)->op_private & OPpCONST_BARE &&
2103 cSVOPx(right)->op_private & OPpCONST_STRICT)
2105 no_bareword_allowed(right);
2108 ismatchop = rtype == OP_MATCH ||
2109 rtype == OP_SUBST ||
2111 if (ismatchop && right->op_private & OPpTARGET_MY) {
2113 right->op_private &= ~OPpTARGET_MY;
2115 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
2118 right->op_flags |= OPf_STACKED;
2119 if (rtype != OP_MATCH &&
2120 ! (rtype == OP_TRANS &&
2121 right->op_private & OPpTRANS_IDENTICAL))
2122 newleft = mod(left, rtype);
2125 if (right->op_type == OP_TRANS)
2126 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
2128 o = prepend_elem(rtype, scalar(newleft), right);
2130 return newUNOP(OP_NOT, 0, scalar(o));
2134 return bind_match(type, left,
2135 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
2139 Perl_invert(pTHX_ OP *o)
2143 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2147 Perl_scope(pTHX_ OP *o)
2151 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2152 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2153 o->op_type = OP_LEAVE;
2154 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2156 else if (o->op_type == OP_LINESEQ) {
2158 o->op_type = OP_SCOPE;
2159 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2160 kid = ((LISTOP*)o)->op_first;
2161 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2164 /* The following deals with things like 'do {1 for 1}' */
2165 kid = kid->op_sibling;
2167 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2172 o = newLISTOP(OP_SCOPE, 0, o, NULL);
2178 Perl_block_start(pTHX_ int full)
2181 const int retval = PL_savestack_ix;
2182 pad_block_start(full);
2184 PL_hints &= ~HINT_BLOCK_SCOPE;
2185 SAVECOMPILEWARNINGS();
2186 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
2191 Perl_block_end(pTHX_ I32 floor, OP *seq)
2194 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2195 OP* const retval = scalarseq(seq);
2197 CopHINTS_set(&PL_compiling, PL_hints);
2199 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2208 const PADOFFSET offset = pad_findmy("$_");
2209 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
2210 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2213 OP * const o = newOP(OP_PADSV, 0);
2214 o->op_targ = offset;
2220 Perl_newPROG(pTHX_ OP *o)
2226 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2227 ((PL_in_eval & EVAL_KEEPERR)
2228 ? OPf_SPECIAL : 0), o);
2229 PL_eval_start = linklist(PL_eval_root);
2230 PL_eval_root->op_private |= OPpREFCOUNTED;
2231 OpREFCNT_set(PL_eval_root, 1);
2232 PL_eval_root->op_next = 0;
2233 CALL_PEEP(PL_eval_start);
2236 if (o->op_type == OP_STUB) {
2237 PL_comppad_name = 0;
2239 S_op_destroy(aTHX_ o);
2242 PL_main_root = scope(sawparens(scalarvoid(o)));
2243 PL_curcop = &PL_compiling;
2244 PL_main_start = LINKLIST(PL_main_root);
2245 PL_main_root->op_private |= OPpREFCOUNTED;
2246 OpREFCNT_set(PL_main_root, 1);
2247 PL_main_root->op_next = 0;
2248 CALL_PEEP(PL_main_start);
2251 /* Register with debugger */
2254 = Perl_get_cvn_flags(aTHX_ STR_WITH_LEN("DB::postponed"), 0);
2258 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2260 call_sv((SV*)cv, G_DISCARD);
2267 Perl_localize(pTHX_ OP *o, I32 lex)
2270 if (o->op_flags & OPf_PARENS)
2271 /* [perl #17376]: this appears to be premature, and results in code such as
2272 C< our(%x); > executing in list mode rather than void mode */
2279 if ( PL_parser->bufptr > PL_parser->oldbufptr
2280 && PL_parser->bufptr[-1] == ','
2281 && ckWARN(WARN_PARENTHESIS))
2283 char *s = PL_parser->bufptr;
2286 /* some heuristics to detect a potential error */
2287 while (*s && (strchr(", \t\n", *s)))
2291 if (*s && strchr("@$%*", *s) && *++s
2292 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2295 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2297 while (*s && (strchr(", \t\n", *s)))
2303 if (sigil && (*s == ';' || *s == '=')) {
2304 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2305 "Parentheses missing around \"%s\" list",
2307 ? (PL_parser->in_my == KEY_our
2309 : PL_parser->in_my == KEY_state
2319 o = mod(o, OP_NULL); /* a bit kludgey */
2320 PL_parser->in_my = FALSE;
2321 PL_parser->in_my_stash = NULL;
2326 Perl_jmaybe(pTHX_ OP *o)
2328 if (o->op_type == OP_LIST) {
2330 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2331 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2337 Perl_fold_constants(pTHX_ register OP *o)
2342 VOL I32 type = o->op_type;
2347 SV * const oldwarnhook = PL_warnhook;
2348 SV * const olddiehook = PL_diehook;
2351 if (PL_opargs[type] & OA_RETSCALAR)
2353 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2354 o->op_targ = pad_alloc(type, SVs_PADTMP);
2356 /* integerize op, unless it happens to be C<-foo>.
2357 * XXX should pp_i_negate() do magic string negation instead? */
2358 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2359 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2360 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2362 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2365 if (!(PL_opargs[type] & OA_FOLDCONST))
2370 /* XXX might want a ck_negate() for this */
2371 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2382 /* XXX what about the numeric ops? */
2383 if (PL_hints & HINT_LOCALE)
2387 if (PL_parser && PL_parser->error_count)
2388 goto nope; /* Don't try to run w/ errors */
2390 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2391 const OPCODE type = curop->op_type;
2392 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2394 type != OP_SCALAR &&
2396 type != OP_PUSHMARK)
2402 curop = LINKLIST(o);
2403 old_next = o->op_next;
2407 oldscope = PL_scopestack_ix;
2408 create_eval_scope(G_FAKINGEVAL);
2410 PL_warnhook = PERL_WARNHOOK_FATAL;
2417 sv = *(PL_stack_sp--);
2418 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2419 pad_swipe(o->op_targ, FALSE);
2420 else if (SvTEMP(sv)) { /* grab mortal temp? */
2421 SvREFCNT_inc_simple_void(sv);
2426 /* Something tried to die. Abandon constant folding. */
2427 /* Pretend the error never happened. */
2428 sv_setpvn(ERRSV,"",0);
2429 o->op_next = old_next;
2433 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
2434 PL_warnhook = oldwarnhook;
2435 PL_diehook = olddiehook;
2436 /* XXX note that this croak may fail as we've already blown away
2437 * the stack - eg any nested evals */
2438 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
2441 PL_warnhook = oldwarnhook;
2442 PL_diehook = olddiehook;
2444 if (PL_scopestack_ix > oldscope)
2445 delete_eval_scope();
2454 if (type == OP_RV2GV)
2455 newop = newGVOP(OP_GV, 0, (GV*)sv);
2457 newop = newSVOP(OP_CONST, 0, (SV*)sv);
2458 op_getmad(o,newop,'f');
2466 Perl_gen_constant_list(pTHX_ register OP *o)
2470 const I32 oldtmps_floor = PL_tmps_floor;
2473 if (PL_parser && PL_parser->error_count)
2474 return o; /* Don't attempt to run with errors */
2476 PL_op = curop = LINKLIST(o);
2482 assert (!(curop->op_flags & OPf_SPECIAL));
2483 assert(curop->op_type == OP_RANGE);
2485 PL_tmps_floor = oldtmps_floor;
2487 o->op_type = OP_RV2AV;
2488 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2489 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2490 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2491 o->op_opt = 0; /* needs to be revisited in peep() */
2492 curop = ((UNOP*)o)->op_first;
2493 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
2495 op_getmad(curop,o,'O');
2504 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2507 if (!o || o->op_type != OP_LIST)
2508 o = newLISTOP(OP_LIST, 0, o, NULL);
2510 o->op_flags &= ~OPf_WANT;
2512 if (!(PL_opargs[type] & OA_MARK))
2513 op_null(cLISTOPo->op_first);
2515 o->op_type = (OPCODE)type;
2516 o->op_ppaddr = PL_ppaddr[type];
2517 o->op_flags |= flags;
2519 o = CHECKOP(type, o);
2520 if (o->op_type != (unsigned)type)
2523 return fold_constants(o);
2526 /* List constructors */
2529 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2537 if (first->op_type != (unsigned)type
2538 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2540 return newLISTOP(type, 0, first, last);
2543 if (first->op_flags & OPf_KIDS)
2544 ((LISTOP*)first)->op_last->op_sibling = last;
2546 first->op_flags |= OPf_KIDS;
2547 ((LISTOP*)first)->op_first = last;
2549 ((LISTOP*)first)->op_last = last;
2554 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2562 if (first->op_type != (unsigned)type)
2563 return prepend_elem(type, (OP*)first, (OP*)last);
2565 if (last->op_type != (unsigned)type)
2566 return append_elem(type, (OP*)first, (OP*)last);
2568 first->op_last->op_sibling = last->op_first;
2569 first->op_last = last->op_last;
2570 first->op_flags |= (last->op_flags & OPf_KIDS);
2573 if (last->op_first && first->op_madprop) {
2574 MADPROP *mp = last->op_first->op_madprop;
2576 while (mp->mad_next)
2578 mp->mad_next = first->op_madprop;
2581 last->op_first->op_madprop = first->op_madprop;
2584 first->op_madprop = last->op_madprop;
2585 last->op_madprop = 0;
2588 S_op_destroy(aTHX_ (OP*)last);
2594 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2602 if (last->op_type == (unsigned)type) {
2603 if (type == OP_LIST) { /* already a PUSHMARK there */
2604 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2605 ((LISTOP*)last)->op_first->op_sibling = first;
2606 if (!(first->op_flags & OPf_PARENS))
2607 last->op_flags &= ~OPf_PARENS;
2610 if (!(last->op_flags & OPf_KIDS)) {
2611 ((LISTOP*)last)->op_last = first;
2612 last->op_flags |= OPf_KIDS;
2614 first->op_sibling = ((LISTOP*)last)->op_first;
2615 ((LISTOP*)last)->op_first = first;
2617 last->op_flags |= OPf_KIDS;
2621 return newLISTOP(type, 0, first, last);
2629 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2632 Newxz(tk, 1, TOKEN);
2633 tk->tk_type = (OPCODE)optype;
2634 tk->tk_type = 12345;
2636 tk->tk_mad = madprop;
2641 Perl_token_free(pTHX_ TOKEN* tk)
2643 if (tk->tk_type != 12345)
2645 mad_free(tk->tk_mad);
2650 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2654 if (tk->tk_type != 12345) {
2655 Perl_warner(aTHX_ packWARN(WARN_MISC),
2656 "Invalid TOKEN object ignored");
2663 /* faked up qw list? */
2665 tm->mad_type == MAD_SV &&
2666 SvPVX((SV*)tm->mad_val)[0] == 'q')
2673 /* pretend constant fold didn't happen? */
2674 if (mp->mad_key == 'f' &&
2675 (o->op_type == OP_CONST ||
2676 o->op_type == OP_GV) )
2678 token_getmad(tk,(OP*)mp->mad_val,slot);
2692 if (mp->mad_key == 'X')
2693 mp->mad_key = slot; /* just change the first one */
2703 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
2712 /* pretend constant fold didn't happen? */
2713 if (mp->mad_key == 'f' &&
2714 (o->op_type == OP_CONST ||
2715 o->op_type == OP_GV) )
2717 op_getmad(from,(OP*)mp->mad_val,slot);
2724 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
2727 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
2733 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
2742 /* pretend constant fold didn't happen? */
2743 if (mp->mad_key == 'f' &&
2744 (o->op_type == OP_CONST ||
2745 o->op_type == OP_GV) )
2747 op_getmad(from,(OP*)mp->mad_val,slot);
2754 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
2757 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
2761 PerlIO_printf(PerlIO_stderr(),
2762 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
2768 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
2786 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
2790 addmad(tm, &(o->op_madprop), slot);
2794 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
2815 Perl_newMADsv(pTHX_ char key, SV* sv)
2817 return newMADPROP(key, MAD_SV, sv, 0);
2821 Perl_newMADPROP(pTHX_ char key, char type, const void* val, I32 vlen)
2824 Newxz(mp, 1, MADPROP);
2827 mp->mad_vlen = vlen;
2828 mp->mad_type = type;
2830 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
2835 Perl_mad_free(pTHX_ MADPROP* mp)
2837 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
2841 mad_free(mp->mad_next);
2842 /* if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
2843 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
2844 switch (mp->mad_type) {
2848 Safefree((char*)mp->mad_val);
2851 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
2852 op_free((OP*)mp->mad_val);
2855 sv_free((SV*)mp->mad_val);
2858 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
2867 Perl_newNULLLIST(pTHX)
2869 return newOP(OP_STUB, 0);
2873 Perl_force_list(pTHX_ OP *o)
2875 if (!o || o->op_type != OP_LIST)
2876 o = newLISTOP(OP_LIST, 0, o, NULL);
2882 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2887 NewOp(1101, listop, 1, LISTOP);
2889 listop->op_type = (OPCODE)type;
2890 listop->op_ppaddr = PL_ppaddr[type];
2893 listop->op_flags = (U8)flags;
2897 else if (!first && last)
2900 first->op_sibling = last;
2901 listop->op_first = first;
2902 listop->op_last = last;
2903 if (type == OP_LIST) {
2904 OP* const pushop = newOP(OP_PUSHMARK, 0);
2905 pushop->op_sibling = first;
2906 listop->op_first = pushop;
2907 listop->op_flags |= OPf_KIDS;
2909 listop->op_last = pushop;
2912 return CHECKOP(type, listop);
2916 Perl_newOP(pTHX_ I32 type, I32 flags)
2920 NewOp(1101, o, 1, OP);
2921 o->op_type = (OPCODE)type;
2922 o->op_ppaddr = PL_ppaddr[type];
2923 o->op_flags = (U8)flags;
2925 o->op_latefreed = 0;
2929 o->op_private = (U8)(0 | (flags >> 8));
2930 if (PL_opargs[type] & OA_RETSCALAR)
2932 if (PL_opargs[type] & OA_TARGET)
2933 o->op_targ = pad_alloc(type, SVs_PADTMP);
2934 return CHECKOP(type, o);
2938 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2944 first = newOP(OP_STUB, 0);
2945 if (PL_opargs[type] & OA_MARK)
2946 first = force_list(first);
2948 NewOp(1101, unop, 1, UNOP);
2949 unop->op_type = (OPCODE)type;
2950 unop->op_ppaddr = PL_ppaddr[type];
2951 unop->op_first = first;
2952 unop->op_flags = (U8)(flags | OPf_KIDS);
2953 unop->op_private = (U8)(1 | (flags >> 8));
2954 unop = (UNOP*) CHECKOP(type, unop);
2958 return fold_constants((OP *) unop);
2962 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2966 NewOp(1101, binop, 1, BINOP);
2969 first = newOP(OP_NULL, 0);
2971 binop->op_type = (OPCODE)type;
2972 binop->op_ppaddr = PL_ppaddr[type];
2973 binop->op_first = first;
2974 binop->op_flags = (U8)(flags | OPf_KIDS);
2977 binop->op_private = (U8)(1 | (flags >> 8));
2980 binop->op_private = (U8)(2 | (flags >> 8));
2981 first->op_sibling = last;
2984 binop = (BINOP*)CHECKOP(type, binop);
2985 if (binop->op_next || binop->op_type != (OPCODE)type)
2988 binop->op_last = binop->op_first->op_sibling;
2990 return fold_constants((OP *)binop);
2993 static int uvcompare(const void *a, const void *b)
2994 __attribute__nonnull__(1)
2995 __attribute__nonnull__(2)
2996 __attribute__pure__;
2997 static int uvcompare(const void *a, const void *b)
2999 if (*((const UV *)a) < (*(const UV *)b))
3001 if (*((const UV *)a) > (*(const UV *)b))
3003 if (*((const UV *)a+1) < (*(const UV *)b+1))
3005 if (*((const UV *)a+1) > (*(const UV *)b+1))
3011 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
3014 SV * const tstr = ((SVOP*)expr)->op_sv;
3017 (repl->op_type == OP_NULL)
3018 ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
3020 ((SVOP*)repl)->op_sv;
3023 const U8 *t = (U8*)SvPV_const(tstr, tlen);
3024 const U8 *r = (U8*)SvPV_const(rstr, rlen);
3028 register short *tbl;
3030 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
3031 const I32 squash = o->op_private & OPpTRANS_SQUASH;
3032 I32 del = o->op_private & OPpTRANS_DELETE;
3034 PL_hints |= HINT_BLOCK_SCOPE;
3037 o->op_private |= OPpTRANS_FROM_UTF;
3040 o->op_private |= OPpTRANS_TO_UTF;
3042 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
3043 SV* const listsv = newSVpvs("# comment\n");
3045 const U8* tend = t + tlen;
3046 const U8* rend = r + rlen;
3060 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
3061 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
3064 const U32 flags = UTF8_ALLOW_DEFAULT;
3068 t = tsave = bytes_to_utf8(t, &len);
3071 if (!to_utf && rlen) {
3073 r = rsave = bytes_to_utf8(r, &len);
3077 /* There are several snags with this code on EBCDIC:
3078 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
3079 2. scan_const() in toke.c has encoded chars in native encoding which makes
3080 ranges at least in EBCDIC 0..255 range the bottom odd.
3084 U8 tmpbuf[UTF8_MAXBYTES+1];
3087 Newx(cp, 2*tlen, UV);
3089 transv = newSVpvs("");
3091 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3093 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
3095 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3099 cp[2*i+1] = cp[2*i];
3103 qsort(cp, i, 2*sizeof(UV), uvcompare);
3104 for (j = 0; j < i; j++) {
3106 diff = val - nextmin;
3108 t = uvuni_to_utf8(tmpbuf,nextmin);
3109 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3111 U8 range_mark = UTF_TO_NATIVE(0xff);
3112 t = uvuni_to_utf8(tmpbuf, val - 1);
3113 sv_catpvn(transv, (char *)&range_mark, 1);
3114 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3121 t = uvuni_to_utf8(tmpbuf,nextmin);
3122 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3124 U8 range_mark = UTF_TO_NATIVE(0xff);
3125 sv_catpvn(transv, (char *)&range_mark, 1);
3127 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
3128 UNICODE_ALLOW_SUPER);
3129 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3130 t = (const U8*)SvPVX_const(transv);
3131 tlen = SvCUR(transv);
3135 else if (!rlen && !del) {
3136 r = t; rlen = tlen; rend = tend;
3139 if ((!rlen && !del) || t == r ||
3140 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
3142 o->op_private |= OPpTRANS_IDENTICAL;
3146 while (t < tend || tfirst <= tlast) {
3147 /* see if we need more "t" chars */
3148 if (tfirst > tlast) {
3149 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3151 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
3153 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3160 /* now see if we need more "r" chars */
3161 if (rfirst > rlast) {
3163 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3165 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
3167 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3176 rfirst = rlast = 0xffffffff;
3180 /* now see which range will peter our first, if either. */
3181 tdiff = tlast - tfirst;
3182 rdiff = rlast - rfirst;
3189 if (rfirst == 0xffffffff) {
3190 diff = tdiff; /* oops, pretend rdiff is infinite */
3192 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
3193 (long)tfirst, (long)tlast);
3195 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
3199 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
3200 (long)tfirst, (long)(tfirst + diff),
3203 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3204 (long)tfirst, (long)rfirst);
3206 if (rfirst + diff > max)
3207 max = rfirst + diff;
3209 grows = (tfirst < rfirst &&
3210 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3222 else if (max > 0xff)
3227 PerlMemShared_free(cPVOPo->op_pv);
3228 cPVOPo->op_pv = NULL;
3230 swash = (SV*)swash_init("utf8", "", listsv, bits, none);
3232 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
3233 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
3234 PAD_SETSV(cPADOPo->op_padix, swash);
3237 cSVOPo->op_sv = swash;
3239 SvREFCNT_dec(listsv);
3240 SvREFCNT_dec(transv);
3242 if (!del && havefinal && rlen)
3243 (void)hv_store((HV*)SvRV(swash), "FINAL", 5,
3244 newSVuv((UV)final), 0);
3247 o->op_private |= OPpTRANS_GROWS;
3253 op_getmad(expr,o,'e');
3254 op_getmad(repl,o,'r');
3262 tbl = (short*)cPVOPo->op_pv;
3264 Zero(tbl, 256, short);
3265 for (i = 0; i < (I32)tlen; i++)
3267 for (i = 0, j = 0; i < 256; i++) {
3269 if (j >= (I32)rlen) {
3278 if (i < 128 && r[j] >= 128)
3288 o->op_private |= OPpTRANS_IDENTICAL;
3290 else if (j >= (I32)rlen)
3295 PerlMemShared_realloc(tbl,
3296 (0x101+rlen-j) * sizeof(short));
3297 cPVOPo->op_pv = (char*)tbl;
3299 tbl[0x100] = (short)(rlen - j);
3300 for (i=0; i < (I32)rlen - j; i++)
3301 tbl[0x101+i] = r[j+i];
3305 if (!rlen && !del) {
3308 o->op_private |= OPpTRANS_IDENTICAL;
3310 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3311 o->op_private |= OPpTRANS_IDENTICAL;
3313 for (i = 0; i < 256; i++)
3315 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3316 if (j >= (I32)rlen) {
3318 if (tbl[t[i]] == -1)
3324 if (tbl[t[i]] == -1) {
3325 if (t[i] < 128 && r[j] >= 128)
3332 o->op_private |= OPpTRANS_GROWS;
3334 op_getmad(expr,o,'e');
3335 op_getmad(repl,o,'r');
3345 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3350 NewOp(1101, pmop, 1, PMOP);
3351 pmop->op_type = (OPCODE)type;
3352 pmop->op_ppaddr = PL_ppaddr[type];
3353 pmop->op_flags = (U8)flags;
3354 pmop->op_private = (U8)(0 | (flags >> 8));
3356 if (PL_hints & HINT_RE_TAINT)
3357 pmop->op_pmflags |= PMf_RETAINT;
3358 if (PL_hints & HINT_LOCALE)
3359 pmop->op_pmflags |= PMf_LOCALE;
3363 if (av_len((AV*) PL_regex_pad[0]) > -1) {
3364 SV * const repointer = av_pop((AV*)PL_regex_pad[0]);
3365 pmop->op_pmoffset = SvIV(repointer);
3366 SvREPADTMP_off(repointer);
3367 sv_setiv(repointer,0);
3369 SV * const repointer = newSViv(0);
3370 av_push(PL_regex_padav, SvREFCNT_inc_simple_NN(repointer));
3371 pmop->op_pmoffset = av_len(PL_regex_padav);
3372 PL_regex_pad = AvARRAY(PL_regex_padav);
3376 return CHECKOP(type, pmop);
3379 /* Given some sort of match op o, and an expression expr containing a
3380 * pattern, either compile expr into a regex and attach it to o (if it's
3381 * constant), or convert expr into a runtime regcomp op sequence (if it's
3384 * isreg indicates that the pattern is part of a regex construct, eg
3385 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3386 * split "pattern", which aren't. In the former case, expr will be a list
3387 * if the pattern contains more than one term (eg /a$b/) or if it contains
3388 * a replacement, ie s/// or tr///.
3392 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
3397 I32 repl_has_vars = 0;
3401 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
3402 /* last element in list is the replacement; pop it */
3404 repl = cLISTOPx(expr)->op_last;
3405 kid = cLISTOPx(expr)->op_first;
3406 while (kid->op_sibling != repl)
3407 kid = kid->op_sibling;
3408 kid->op_sibling = NULL;
3409 cLISTOPx(expr)->op_last = kid;
3412 if (isreg && expr->op_type == OP_LIST &&
3413 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3415 /* convert single element list to element */
3416 OP* const oe = expr;
3417 expr = cLISTOPx(oe)->op_first->op_sibling;
3418 cLISTOPx(oe)->op_first->op_sibling = NULL;
3419 cLISTOPx(oe)->op_last = NULL;
3423 if (o->op_type == OP_TRANS) {
3424 return pmtrans(o, expr, repl);
3427 reglist = isreg && expr->op_type == OP_LIST;
3431 PL_hints |= HINT_BLOCK_SCOPE;
3434 if (expr->op_type == OP_CONST) {
3435 SV * const pat = ((SVOP*)expr)->op_sv;
3436 U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
3438 if (o->op_flags & OPf_SPECIAL)
3439 pm_flags |= RXf_SPLIT;
3442 pm_flags |= RXf_UTF8;
3444 PM_SETRE(pm, CALLREGCOMP(pat, pm_flags));
3447 op_getmad(expr,(OP*)pm,'e');
3453 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3454 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3456 : OP_REGCMAYBE),0,expr);
3458 NewOp(1101, rcop, 1, LOGOP);
3459 rcop->op_type = OP_REGCOMP;
3460 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3461 rcop->op_first = scalar(expr);
3462 rcop->op_flags |= OPf_KIDS
3463 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3464 | (reglist ? OPf_STACKED : 0);
3465 rcop->op_private = 1;
3468 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3470 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
3473 /* establish postfix order */
3474 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3476 rcop->op_next = expr;
3477 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3480 rcop->op_next = LINKLIST(expr);
3481 expr->op_next = (OP*)rcop;
3484 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3489 if (pm->op_pmflags & PMf_EVAL) {
3491 if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
3492 CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
3494 else if (repl->op_type == OP_CONST)
3498 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3499 if (curop->op_type == OP_SCOPE
3500 || curop->op_type == OP_LEAVE
3501 || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
3502 if (curop->op_type == OP_GV) {
3503 GV * const gv = cGVOPx_gv(curop);
3505 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3508 else if (curop->op_type == OP_RV2CV)
3510 else if (curop->op_type == OP_RV2SV ||
3511 curop->op_type == OP_RV2AV ||
3512 curop->op_type == OP_RV2HV ||
3513 curop->op_type == OP_RV2GV) {
3514 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3517 else if (curop->op_type == OP_PADSV ||
3518 curop->op_type == OP_PADAV ||
3519 curop->op_type == OP_PADHV ||
3520 curop->op_type == OP_PADANY)
3524 else if (curop->op_type == OP_PUSHRE)
3525 NOOP; /* Okay here, dangerous in newASSIGNOP */
3535 || PM_GETRE(pm)->extflags & RXf_EVAL_SEEN)))
3537 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3538 prepend_elem(o->op_type, scalar(repl), o);
3541 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3542 pm->op_pmflags |= PMf_MAYBE_CONST;
3544 NewOp(1101, rcop, 1, LOGOP);
3545 rcop->op_type = OP_SUBSTCONT;
3546 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3547 rcop->op_first = scalar(repl);
3548 rcop->op_flags |= OPf_KIDS;
3549 rcop->op_private = 1;
3552 /* establish postfix order */
3553 rcop->op_next = LINKLIST(repl);
3554 repl->op_next = (OP*)rcop;
3556 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
3557 assert(!(pm->op_pmflags & PMf_ONCE));
3558 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
3567 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3571 NewOp(1101, svop, 1, SVOP);
3572 svop->op_type = (OPCODE)type;
3573 svop->op_ppaddr = PL_ppaddr[type];
3575 svop->op_next = (OP*)svop;
3576 svop->op_flags = (U8)flags;
3577 if (PL_opargs[type] & OA_RETSCALAR)
3579 if (PL_opargs[type] & OA_TARGET)
3580 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3581 return CHECKOP(type, svop);
3586 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3590 NewOp(1101, padop, 1, PADOP);
3591 padop->op_type = (OPCODE)type;
3592 padop->op_ppaddr = PL_ppaddr[type];
3593 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3594 SvREFCNT_dec(PAD_SVl(padop->op_padix));
3595 PAD_SETSV(padop->op_padix, sv);
3598 padop->op_next = (OP*)padop;
3599 padop->op_flags = (U8)flags;
3600 if (PL_opargs[type] & OA_RETSCALAR)
3602 if (PL_opargs[type] & OA_TARGET)
3603 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3604 return CHECKOP(type, padop);
3609 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3615 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3617 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3622 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3626 NewOp(1101, pvop, 1, PVOP);
3627 pvop->op_type = (OPCODE)type;
3628 pvop->op_ppaddr = PL_ppaddr[type];
3630 pvop->op_next = (OP*)pvop;
3631 pvop->op_flags = (U8)flags;
3632 if (PL_opargs[type] & OA_RETSCALAR)
3634 if (PL_opargs[type] & OA_TARGET)
3635 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3636 return CHECKOP(type, pvop);
3644 Perl_package(pTHX_ OP *o)
3647 SV *const sv = cSVOPo->op_sv;
3652 save_hptr(&PL_curstash);
3653 save_item(PL_curstname);
3655 PL_curstash = gv_stashsv(sv, GV_ADD);
3657 sv_setsv(PL_curstname, sv);
3659 PL_hints |= HINT_BLOCK_SCOPE;
3660 PL_parser->copline = NOLINE;
3661 PL_parser->expect = XSTATE;
3666 if (!PL_madskills) {
3671 pegop = newOP(OP_NULL,0);
3672 op_getmad(o,pegop,'P');
3682 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3689 OP *pegop = newOP(OP_NULL,0);
3692 if (idop->op_type != OP_CONST)
3693 Perl_croak(aTHX_ "Module name must be constant");
3696 op_getmad(idop,pegop,'U');
3701 SV * const vesv = ((SVOP*)version)->op_sv;
3704 op_getmad(version,pegop,'V');
3705 if (!arg && !SvNIOKp(vesv)) {
3712 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3713 Perl_croak(aTHX_ "Version number must be constant number");
3715 /* Make copy of idop so we don't free it twice */
3716 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3718 /* Fake up a method call to VERSION */
3719 meth = newSVpvs_share("VERSION");
3720 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3721 append_elem(OP_LIST,
3722 prepend_elem(OP_LIST, pack, list(version)),
3723 newSVOP(OP_METHOD_NAMED, 0, meth)));
3727 /* Fake up an import/unimport */
3728 if (arg && arg->op_type == OP_STUB) {
3730 op_getmad(arg,pegop,'S');
3731 imop = arg; /* no import on explicit () */
3733 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3734 imop = NULL; /* use 5.0; */
3736 idop->op_private |= OPpCONST_NOVER;
3742 op_getmad(arg,pegop,'A');
3744 /* Make copy of idop so we don't free it twice */
3745 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3747 /* Fake up a method call to import/unimport */
3749 ? newSVpvs_share("import") : newSVpvs_share("unimport");
3750 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3751 append_elem(OP_LIST,
3752 prepend_elem(OP_LIST, pack, list(arg)),
3753 newSVOP(OP_METHOD_NAMED, 0, meth)));
3756 /* Fake up the BEGIN {}, which does its thing immediately. */
3758 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
3761 append_elem(OP_LINESEQ,
3762 append_elem(OP_LINESEQ,
3763 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
3764 newSTATEOP(0, NULL, veop)),
3765 newSTATEOP(0, NULL, imop) ));
3767 /* The "did you use incorrect case?" warning used to be here.
3768 * The problem is that on case-insensitive filesystems one
3769 * might get false positives for "use" (and "require"):
3770 * "use Strict" or "require CARP" will work. This causes
3771 * portability problems for the script: in case-strict
3772 * filesystems the script will stop working.
3774 * The "incorrect case" warning checked whether "use Foo"
3775 * imported "Foo" to your namespace, but that is wrong, too:
3776 * there is no requirement nor promise in the language that
3777 * a Foo.pm should or would contain anything in package "Foo".
3779 * There is very little Configure-wise that can be done, either:
3780 * the case-sensitivity of the build filesystem of Perl does not
3781 * help in guessing the case-sensitivity of the runtime environment.
3784 PL_hints |= HINT_BLOCK_SCOPE;
3785 PL_parser->copline = NOLINE;
3786 PL_parser->expect = XSTATE;
3787 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3790 if (!PL_madskills) {
3791 /* FIXME - don't allocate pegop if !PL_madskills */
3800 =head1 Embedding Functions
3802 =for apidoc load_module
3804 Loads the module whose name is pointed to by the string part of name.
3805 Note that the actual module name, not its filename, should be given.
3806 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3807 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3808 (or 0 for no flags). ver, if specified, provides version semantics
3809 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3810 arguments can be used to specify arguments to the module's import()
3811 method, similar to C<use Foo::Bar VERSION LIST>.
3816 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3819 va_start(args, ver);
3820 vload_module(flags, name, ver, &args);
3824 #ifdef PERL_IMPLICIT_CONTEXT
3826 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3830 va_start(args, ver);
3831 vload_module(flags, name, ver, &args);
3837 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3842 OP * const modname = newSVOP(OP_CONST, 0, name);
3843 modname->op_private |= OPpCONST_BARE;
3845 veop = newSVOP(OP_CONST, 0, ver);
3849 if (flags & PERL_LOADMOD_NOIMPORT) {
3850 imop = sawparens(newNULLLIST());
3852 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3853 imop = va_arg(*args, OP*);
3858 sv = va_arg(*args, SV*);
3860 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3861 sv = va_arg(*args, SV*);
3865 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
3866 * that it has a PL_parser to play with while doing that, and also
3867 * that it doesn't mess with any existing parser, by creating a tmp
3868 * new parser with lex_start(). This won't actually be used for much,
3869 * since pp_require() will create another parser for the real work. */
3872 SAVEVPTR(PL_curcop);
3873 lex_start(NULL, NULL, FALSE);
3874 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3875 veop, modname, imop);
3880 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
3886 if (!force_builtin) {
3887 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
3888 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
3889 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
3890 gv = gvp ? *gvp : NULL;
3894 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3895 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3896 append_elem(OP_LIST, term,
3897 scalar(newUNOP(OP_RV2CV, 0,
3898 newGVOP(OP_GV, 0, gv))))));
3901 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3907 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3909 return newBINOP(OP_LSLICE, flags,
3910 list(force_list(subscript)),
3911 list(force_list(listval)) );
3915 S_is_list_assignment(pTHX_ register const OP *o)
3923 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
3924 o = cUNOPo->op_first;
3926 flags = o->op_flags;
3928 if (type == OP_COND_EXPR) {
3929 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
3930 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3935 yyerror("Assignment to both a list and a scalar");
3939 if (type == OP_LIST &&
3940 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
3941 o->op_private & OPpLVAL_INTRO)
3944 if (type == OP_LIST || flags & OPf_PARENS ||
3945 type == OP_RV2AV || type == OP_RV2HV ||
3946 type == OP_ASLICE || type == OP_HSLICE)
3949 if (type == OP_PADAV || type == OP_PADHV)
3952 if (type == OP_RV2SV)
3959 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3965 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3966 return newLOGOP(optype, 0,
3967 mod(scalar(left), optype),
3968 newUNOP(OP_SASSIGN, 0, scalar(right)));
3971 return newBINOP(optype, OPf_STACKED,
3972 mod(scalar(left), optype), scalar(right));
3976 if (is_list_assignment(left)) {
3977 static const char no_list_state[] = "Initialization of state variables"
3978 " in list context currently forbidden";
3982 /* Grandfathering $[ assignment here. Bletch.*/
3983 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
3984 PL_eval_start = (left->op_type == OP_CONST) ? right : NULL;
3985 left = mod(left, OP_AASSIGN);
3988 else if (left->op_type == OP_CONST) {
3990 /* Result of assignment is always 1 (or we'd be dead already) */
3991 return newSVOP(OP_CONST, 0, newSViv(1));
3993 curop = list(force_list(left));
3994 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3995 o->op_private = (U8)(0 | (flags >> 8));
3997 /* PL_generation sorcery:
3998 * an assignment like ($a,$b) = ($c,$d) is easier than
3999 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
4000 * To detect whether there are common vars, the global var
4001 * PL_generation is incremented for each assign op we compile.
4002 * Then, while compiling the assign op, we run through all the
4003 * variables on both sides of the assignment, setting a spare slot
4004 * in each of them to PL_generation. If any of them already have
4005 * that value, we know we've got commonality. We could use a
4006 * single bit marker, but then we'd have to make 2 passes, first
4007 * to clear the flag, then to test and set it. To find somewhere
4008 * to store these values, evil chicanery is done with SvUVX().
4014 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4015 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
4016 if (curop->op_type == OP_GV) {
4017 GV *gv = cGVOPx_gv(curop);
4019 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4021 GvASSIGN_GENERATION_set(gv, PL_generation);
4023 else if (curop->op_type == OP_PADSV ||
4024 curop->op_type == OP_PADAV ||
4025 curop->op_type == OP_PADHV ||
4026 curop->op_type == OP_PADANY)
4028 if (PAD_COMPNAME_GEN(curop->op_targ)
4029 == (STRLEN)PL_generation)
4031 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
4034 else if (curop->op_type == OP_RV2CV)
4036 else if (curop->op_type == OP_RV2SV ||
4037 curop->op_type == OP_RV2AV ||
4038 curop->op_type == OP_RV2HV ||
4039 curop->op_type == OP_RV2GV) {
4040 if (lastop->op_type != OP_GV) /* funny deref? */
4043 else if (curop->op_type == OP_PUSHRE) {
4045 if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
4046 GV *const gv = (GV*)PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff);
4048 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4050 GvASSIGN_GENERATION_set(gv, PL_generation);
4054 = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
4057 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4059 GvASSIGN_GENERATION_set(gv, PL_generation);
4069 o->op_private |= OPpASSIGN_COMMON;
4072 if ((left->op_type == OP_LIST
4073 || (left->op_type == OP_NULL && left->op_targ == OP_LIST))) {
4074 OP* lop = ((LISTOP*)left)->op_first;
4076 if (lop->op_type == OP_PADSV ||
4077 lop->op_type == OP_PADAV ||
4078 lop->op_type == OP_PADHV ||
4079 lop->op_type == OP_PADANY) {
4080 if (lop->op_private & OPpPAD_STATE) {
4081 if (left->op_private & OPpLVAL_INTRO) {
4082 /* Each variable in state($a, $b, $c) = ... */
4085 /* Each state variable in
4086 (state $a, my $b, our $c, $d, undef) = ... */
4088 yyerror(no_list_state);
4090 /* Each my variable in
4091 (state $a, my $b, our $c, $d, undef) = ... */
4094 /* Other ops in the list. undef may be interesting in
4095 (state $a, undef, state $c) */
4097 lop = lop->op_sibling;
4100 else if (((left->op_private & (OPpLVAL_INTRO | OPpPAD_STATE))
4101 == (OPpLVAL_INTRO | OPpPAD_STATE))
4102 && ( left->op_type == OP_PADSV
4103 || left->op_type == OP_PADAV
4104 || left->op_type == OP_PADHV
4105 || left->op_type == OP_PADANY))
4107 /* All single variable list context state assignments, hence
4117 yyerror(no_list_state);
4120 if (right && right->op_type == OP_SPLIT && !PL_madskills) {
4121 OP* tmpop = ((LISTOP*)right)->op_first;
4122 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
4123 PMOP * const pm = (PMOP*)tmpop;
4124 if (left->op_type == OP_RV2AV &&
4125 !(left->op_private & OPpLVAL_INTRO) &&
4126 !(o->op_private & OPpASSIGN_COMMON) )
4128 tmpop = ((UNOP*)left)->op_first;
4129 if (tmpop->op_type == OP_GV
4131 && !pm->op_pmreplrootu.op_pmtargetoff
4133 && !pm->op_pmreplrootu.op_pmtargetgv
4137 pm->op_pmreplrootu.op_pmtargetoff
4138 = cPADOPx(tmpop)->op_padix;
4139 cPADOPx(tmpop)->op_padix = 0; /* steal it */
4141 pm->op_pmreplrootu.op_pmtargetgv
4142 = (GV*)cSVOPx(tmpop)->op_sv;
4143 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
4145 pm->op_pmflags |= PMf_ONCE;
4146 tmpop = cUNOPo->op_first; /* to list (nulled) */
4147 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
4148 tmpop->op_sibling = NULL; /* don't free split */
4149 right->op_next = tmpop->op_next; /* fix starting loc */
4150 op_free(o); /* blow off assign */
4151 right->op_flags &= ~OPf_WANT;
4152 /* "I don't know and I don't care." */
4157 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
4158 ((LISTOP*)right)->op_last->op_type == OP_CONST)
4160 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
4162 sv_setiv(sv, PL_modcount+1);
4170 right = newOP(OP_UNDEF, 0);
4171 if (right->op_type == OP_READLINE) {
4172 right->op_flags |= OPf_STACKED;
4173 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
4176 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
4177 o = newBINOP(OP_SASSIGN, flags,
4178 scalar(right), mod(scalar(left), OP_SASSIGN) );
4184 o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
4185 o->op_private |= OPpCONST_ARYBASE;
4192 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
4195 const U32 seq = intro_my();
4198 NewOp(1101, cop, 1, COP);
4199 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
4200 cop->op_type = OP_DBSTATE;
4201 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
4204 cop->op_type = OP_NEXTSTATE;
4205 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
4207 cop->op_flags = (U8)flags;
4208 CopHINTS_set(cop, PL_hints);
4210 cop->op_private |= NATIVE_HINTS;
4212 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
4213 cop->op_next = (OP*)cop;
4216 CopLABEL_set(cop, label);
4217 PL_hints |= HINT_BLOCK_SCOPE;
4220 /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
4221 CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
4223 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
4224 cop->cop_hints_hash = PL_curcop->cop_hints_hash;
4225 if (cop->cop_hints_hash) {
4227 cop->cop_hints_hash->refcounted_he_refcnt++;
4228 HINTS_REFCNT_UNLOCK;
4231 if (PL_parser && PL_parser->copline == NOLINE)
4232 CopLINE_set(cop, CopLINE(PL_curcop));
4234 CopLINE_set(cop, PL_parser->copline);
4236 PL_parser->copline = NOLINE;
4239 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
4241 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
4243 CopSTASH_set(cop, PL_curstash);
4245 if (PERLDB_LINE && PL_curstash != PL_debstash) {
4246 AV *av = CopFILEAVx(PL_curcop);
4248 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
4249 if (svp && *svp != &PL_sv_undef ) {
4250 (void)SvIOK_on(*svp);
4251 SvIV_set(*svp, PTR2IV(cop));
4256 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
4261 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
4264 return new_logop(type, flags, &first, &other);
4268 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
4273 OP *first = *firstp;
4274 OP * const other = *otherp;
4276 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
4277 return newBINOP(type, flags, scalar(first), scalar(other));
4279 scalarboolean(first);
4280 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
4281 if (first->op_type == OP_NOT
4282 && (first->op_flags & OPf_SPECIAL)
4283 && (first->op_flags & OPf_KIDS)
4285 if (type == OP_AND || type == OP_OR) {
4291 first = *firstp = cUNOPo->op_first;
4293 first->op_next = o->op_next;
4294 cUNOPo->op_first = NULL;
4298 if (first->op_type == OP_CONST) {
4299 if (first->op_private & OPpCONST_STRICT)
4300 no_bareword_allowed(first);
4301 else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
4302 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
4303 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
4304 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
4305 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
4307 if (other->op_type == OP_CONST)
4308 other->op_private |= OPpCONST_SHORTCIRCUIT;
4310 OP *newop = newUNOP(OP_NULL, 0, other);
4311 op_getmad(first, newop, '1');
4312 newop->op_targ = type; /* set "was" field */
4319 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
4320 const OP *o2 = other;
4321 if ( ! (o2->op_type == OP_LIST
4322 && (( o2 = cUNOPx(o2)->op_first))
4323 && o2->op_type == OP_PUSHMARK
4324 && (( o2 = o2->op_sibling)) )
4327 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
4328 || o2->op_type == OP_PADHV)
4329 && o2->op_private & OPpLVAL_INTRO
4330 && !(o2->op_private & OPpPAD_STATE)
4331 && ckWARN(WARN_DEPRECATED))
4333 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4334 "Deprecated use of my() in false conditional");
4338 if (first->op_type == OP_CONST)
4339 first->op_private |= OPpCONST_SHORTCIRCUIT;
4341 first = newUNOP(OP_NULL, 0, first);
4342 op_getmad(other, first, '2');
4343 first->op_targ = type; /* set "was" field */
4350 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
4351 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
4353 const OP * const k1 = ((UNOP*)first)->op_first;
4354 const OP * const k2 = k1->op_sibling;
4356 switch (first->op_type)
4359 if (k2 && k2->op_type == OP_READLINE
4360 && (k2->op_flags & OPf_STACKED)
4361 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4363 warnop = k2->op_type;
4368 if (k1->op_type == OP_READDIR
4369 || k1->op_type == OP_GLOB
4370 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4371 || k1->op_type == OP_EACH)
4373 warnop = ((k1->op_type == OP_NULL)
4374 ? (OPCODE)k1->op_targ : k1->op_type);
4379 const line_t oldline = CopLINE(PL_curcop);
4380 CopLINE_set(PL_curcop, PL_parser->copline);
4381 Perl_warner(aTHX_ packWARN(WARN_MISC),
4382 "Value of %s%s can be \"0\"; test with defined()",
4384 ((warnop == OP_READLINE || warnop == OP_GLOB)
4385 ? " construct" : "() operator"));
4386 CopLINE_set(PL_curcop, oldline);
4393 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
4394 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
4396 NewOp(1101, logop, 1, LOGOP);
4398 logop->op_type = (OPCODE)type;
4399 logop->op_ppaddr = PL_ppaddr[type];
4400 logop->op_first = first;
4401 logop->op_flags = (U8)(flags | OPf_KIDS);
4402 logop->op_other = LINKLIST(other);
4403 logop->op_private = (U8)(1 | (flags >> 8));
4405 /* establish postfix order */
4406 logop->op_next = LINKLIST(first);
4407 first->op_next = (OP*)logop;
4408 first->op_sibling = other;
4410 CHECKOP(type,logop);
4412 o = newUNOP(OP_NULL, 0, (OP*)logop);
4419 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
4427 return newLOGOP(OP_AND, 0, first, trueop);
4429 return newLOGOP(OP_OR, 0, first, falseop);
4431 scalarboolean(first);
4432 if (first->op_type == OP_CONST) {
4433 /* Left or right arm of the conditional? */
4434 const bool left = SvTRUE(((SVOP*)first)->op_sv);
4435 OP *live = left ? trueop : falseop;
4436 OP *const dead = left ? falseop : trueop;
4437 if (first->op_private & OPpCONST_BARE &&
4438 first->op_private & OPpCONST_STRICT) {
4439 no_bareword_allowed(first);
4442 /* This is all dead code when PERL_MAD is not defined. */
4443 live = newUNOP(OP_NULL, 0, live);
4444 op_getmad(first, live, 'C');
4445 op_getmad(dead, live, left ? 'e' : 't');
4452 NewOp(1101, logop, 1, LOGOP);
4453 logop->op_type = OP_COND_EXPR;
4454 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4455 logop->op_first = first;
4456 logop->op_flags = (U8)(flags | OPf_KIDS);
4457 logop->op_private = (U8)(1 | (flags >> 8));
4458 logop->op_other = LINKLIST(trueop);
4459 logop->op_next = LINKLIST(falseop);
4461 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
4464 /* establish postfix order */
4465 start = LINKLIST(first);
4466 first->op_next = (OP*)logop;
4468 first->op_sibling = trueop;
4469 trueop->op_sibling = falseop;
4470 o = newUNOP(OP_NULL, 0, (OP*)logop);
4472 trueop->op_next = falseop->op_next = o;
4479 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4488 NewOp(1101, range, 1, LOGOP);
4490 range->op_type = OP_RANGE;
4491 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4492 range->op_first = left;
4493 range->op_flags = OPf_KIDS;
4494 leftstart = LINKLIST(left);
4495 range->op_other = LINKLIST(right);
4496 range->op_private = (U8)(1 | (flags >> 8));
4498 left->op_sibling = right;
4500 range->op_next = (OP*)range;
4501 flip = newUNOP(OP_FLIP, flags, (OP*)range);
4502 flop = newUNOP(OP_FLOP, 0, flip);
4503 o = newUNOP(OP_NULL, 0, flop);
4505 range->op_next = leftstart;
4507 left->op_next = flip;
4508 right->op_next = flop;
4510 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4511 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4512 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4513 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4515 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4516 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4519 if (!flip->op_private || !flop->op_private)
4520 linklist(o); /* blow off optimizer unless constant */
4526 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4531 const bool once = block && block->op_flags & OPf_SPECIAL &&
4532 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4534 PERL_UNUSED_ARG(debuggable);
4537 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4538 return block; /* do {} while 0 does once */
4539 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4540 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4541 expr = newUNOP(OP_DEFINED, 0,
4542 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4543 } else if (expr->op_flags & OPf_KIDS) {
4544 const OP * const k1 = ((UNOP*)expr)->op_first;
4545 const OP * const k2 = k1 ? k1->op_sibling : NULL;
4546 switch (expr->op_type) {
4548 if (k2 && k2->op_type == OP_READLINE
4549 && (k2->op_flags & OPf_STACKED)
4550 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4551 expr = newUNOP(OP_DEFINED, 0, expr);
4555 if (k1 && (k1->op_type == OP_READDIR
4556 || k1->op_type == OP_GLOB
4557 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4558 || k1->op_type == OP_EACH))
4559 expr = newUNOP(OP_DEFINED, 0, expr);
4565 /* if block is null, the next append_elem() would put UNSTACK, a scalar
4566 * op, in listop. This is wrong. [perl #27024] */
4568 block = newOP(OP_NULL, 0);
4569 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4570 o = new_logop(OP_AND, 0, &expr, &listop);
4573 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4575 if (once && o != listop)
4576 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4579 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
4581 o->op_flags |= flags;
4583 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4588 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
4589 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
4598 PERL_UNUSED_ARG(debuggable);
4601 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4602 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4603 expr = newUNOP(OP_DEFINED, 0,
4604 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4605 } else if (expr->op_flags & OPf_KIDS) {
4606 const OP * const k1 = ((UNOP*)expr)->op_first;
4607 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
4608 switch (expr->op_type) {
4610 if (k2 && k2->op_type == OP_READLINE
4611 && (k2->op_flags & OPf_STACKED)
4612 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4613 expr = newUNOP(OP_DEFINED, 0, expr);
4617 if (k1 && (k1->op_type == OP_READDIR
4618 || k1->op_type == OP_GLOB
4619 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4620 || k1->op_type == OP_EACH))
4621 expr = newUNOP(OP_DEFINED, 0, expr);
4628 block = newOP(OP_NULL, 0);
4629 else if (cont || has_my) {
4630 block = scope(block);
4634 next = LINKLIST(cont);
4637 OP * const unstack = newOP(OP_UNSTACK, 0);
4640 cont = append_elem(OP_LINESEQ, cont, unstack);
4644 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4646 redo = LINKLIST(listop);
4649 PL_parser->copline = (line_t)whileline;
4651 o = new_logop(OP_AND, 0, &expr, &listop);
4652 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4653 op_free(expr); /* oops, it's a while (0) */
4655 return NULL; /* listop already freed by new_logop */
4658 ((LISTOP*)listop)->op_last->op_next =
4659 (o == listop ? redo : LINKLIST(o));
4665 NewOp(1101,loop,1,LOOP);
4666 loop->op_type = OP_ENTERLOOP;
4667 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4668 loop->op_private = 0;
4669 loop->op_next = (OP*)loop;
4672 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4674 loop->op_redoop = redo;
4675 loop->op_lastop = o;
4676 o->op_private |= loopflags;
4679 loop->op_nextop = next;
4681 loop->op_nextop = o;
4683 o->op_flags |= flags;
4684 o->op_private |= (flags >> 8);
4689 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
4694 PADOFFSET padoff = 0;
4700 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4701 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
4702 sv->op_type = OP_RV2GV;
4703 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4705 /* The op_type check is needed to prevent a possible segfault
4706 * if the loop variable is undeclared and 'strict vars' is in
4707 * effect. This is illegal but is nonetheless parsed, so we
4708 * may reach this point with an OP_CONST where we're expecting
4711 if (cUNOPx(sv)->op_first->op_type == OP_GV
4712 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
4713 iterpflags |= OPpITER_DEF;
4715 else if (sv->op_type == OP_PADSV) { /* private variable */
4716 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
4717 padoff = sv->op_targ;
4727 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4729 SV *const namesv = PAD_COMPNAME_SV(padoff);
4731 const char *const name = SvPV_const(namesv, len);
4733 if (len == 2 && name[0] == '$' && name[1] == '_')
4734 iterpflags |= OPpITER_DEF;
4738 const PADOFFSET offset = pad_findmy("$_");
4739 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
4740 sv = newGVOP(OP_GV, 0, PL_defgv);
4745 iterpflags |= OPpITER_DEF;
4747 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4748 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4749 iterflags |= OPf_STACKED;
4751 else if (expr->op_type == OP_NULL &&
4752 (expr->op_flags & OPf_KIDS) &&
4753 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4755 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4756 * set the STACKED flag to indicate that these values are to be
4757 * treated as min/max values by 'pp_iterinit'.
4759 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4760 LOGOP* const range = (LOGOP*) flip->op_first;
4761 OP* const left = range->op_first;
4762 OP* const right = left->op_sibling;
4765 range->op_flags &= ~OPf_KIDS;
4766 range->op_first = NULL;
4768 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4769 listop->op_first->op_next = range->op_next;
4770 left->op_next = range->op_other;
4771 right->op_next = (OP*)listop;
4772 listop->op_next = listop->op_first;
4775 op_getmad(expr,(OP*)listop,'O');
4779 expr = (OP*)(listop);
4781 iterflags |= OPf_STACKED;
4784 expr = mod(force_list(expr), OP_GREPSTART);
4787 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4788 append_elem(OP_LIST, expr, scalar(sv))));
4789 assert(!loop->op_next);
4790 /* for my $x () sets OPpLVAL_INTRO;
4791 * for our $x () sets OPpOUR_INTRO */
4792 loop->op_private = (U8)iterpflags;
4793 #ifdef PL_OP_SLAB_ALLOC
4796 NewOp(1234,tmp,1,LOOP);
4797 Copy(loop,tmp,1,LISTOP);
4798 S_op_destroy(aTHX_ (OP*)loop);
4802 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
4804 loop->op_targ = padoff;
4805 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
4807 op_getmad(madsv, (OP*)loop, 'v');
4808 PL_parser->copline = forline;
4809 return newSTATEOP(0, label, wop);
4813 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4818 if (type != OP_GOTO || label->op_type == OP_CONST) {
4819 /* "last()" means "last" */
4820 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4821 o = newOP(type, OPf_SPECIAL);
4823 o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
4824 ? SvPV_nolen_const(((SVOP*)label)->op_sv)
4828 op_getmad(label,o,'L');
4834 /* Check whether it's going to be a goto &function */
4835 if (label->op_type == OP_ENTERSUB
4836 && !(label->op_flags & OPf_STACKED))
4837 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4838 o = newUNOP(type, OPf_STACKED, label);
4840 PL_hints |= HINT_BLOCK_SCOPE;
4844 /* if the condition is a literal array or hash
4845 (or @{ ... } etc), make a reference to it.
4848 S_ref_array_or_hash(pTHX_ OP *cond)
4851 && (cond->op_type == OP_RV2AV
4852 || cond->op_type == OP_PADAV
4853 || cond->op_type == OP_RV2HV
4854 || cond->op_type == OP_PADHV))
4856 return newUNOP(OP_REFGEN,
4857 0, mod(cond, OP_REFGEN));
4863 /* These construct the optree fragments representing given()
4866 entergiven and enterwhen are LOGOPs; the op_other pointer
4867 points up to the associated leave op. We need this so we
4868 can put it in the context and make break/continue work.
4869 (Also, of course, pp_enterwhen will jump straight to
4870 op_other if the match fails.)
4874 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
4875 I32 enter_opcode, I32 leave_opcode,
4876 PADOFFSET entertarg)
4882 NewOp(1101, enterop, 1, LOGOP);
4883 enterop->op_type = enter_opcode;
4884 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
4885 enterop->op_flags = (U8) OPf_KIDS;
4886 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
4887 enterop->op_private = 0;
4889 o = newUNOP(leave_opcode, 0, (OP *) enterop);
4892 enterop->op_first = scalar(cond);
4893 cond->op_sibling = block;
4895 o->op_next = LINKLIST(cond);
4896 cond->op_next = (OP *) enterop;
4899 /* This is a default {} block */
4900 enterop->op_first = block;
4901 enterop->op_flags |= OPf_SPECIAL;
4903 o->op_next = (OP *) enterop;
4906 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
4907 entergiven and enterwhen both
4910 enterop->op_next = LINKLIST(block);
4911 block->op_next = enterop->op_other = o;
4916 /* Does this look like a boolean operation? For these purposes
4917 a boolean operation is:
4918 - a subroutine call [*]
4919 - a logical connective
4920 - a comparison operator
4921 - a filetest operator, with the exception of -s -M -A -C
4922 - defined(), exists() or eof()
4923 - /$re/ or $foo =~ /$re/
4925 [*] possibly surprising
4928 S_looks_like_bool(pTHX_ const OP *o)
4931 switch(o->op_type) {
4933 return looks_like_bool(cLOGOPo->op_first);
4937 looks_like_bool(cLOGOPo->op_first)
4938 && looks_like_bool(cLOGOPo->op_first->op_sibling));
4942 case OP_NOT: case OP_XOR:
4943 /* Note that OP_DOR is not here */
4945 case OP_EQ: case OP_NE: case OP_LT:
4946 case OP_GT: case OP_LE: case OP_GE:
4948 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
4949 case OP_I_GT: case OP_I_LE: case OP_I_GE:
4951 case OP_SEQ: case OP_SNE: case OP_SLT:
4952 case OP_SGT: case OP_SLE: case OP_SGE:
4956 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
4957 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
4958 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
4959 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
4960 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
4961 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
4962 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
4963 case OP_FTTEXT: case OP_FTBINARY:
4965 case OP_DEFINED: case OP_EXISTS:
4966 case OP_MATCH: case OP_EOF:
4971 /* Detect comparisons that have been optimized away */
4972 if (cSVOPo->op_sv == &PL_sv_yes
4973 || cSVOPo->op_sv == &PL_sv_no)
4984 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
4988 return newGIVWHENOP(
4989 ref_array_or_hash(cond),
4991 OP_ENTERGIVEN, OP_LEAVEGIVEN,
4995 /* If cond is null, this is a default {} block */
4997 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
4999 const bool cond_llb = (!cond || looks_like_bool(cond));
5005 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
5007 scalar(ref_array_or_hash(cond)));
5010 return newGIVWHENOP(
5012 append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
5013 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
5017 =for apidoc cv_undef
5019 Clear out all the active components of a CV. This can happen either
5020 by an explicit C<undef &foo>, or by the reference count going to zero.
5021 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
5022 children can still follow the full lexical scope chain.
5028 Perl_cv_undef(pTHX_ CV *cv)
5032 DEBUG_X(PerlIO_printf(Perl_debug_log,
5033 "CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n",
5034 PTR2UV(cv), PTR2UV(PL_comppad))
5038 if (CvFILE(cv) && !CvISXSUB(cv)) {
5039 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
5040 Safefree(CvFILE(cv));
5045 if (!CvISXSUB(cv) && CvROOT(cv)) {
5046 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
5047 Perl_croak(aTHX_ "Can't undef active subroutine");
5050 PAD_SAVE_SETNULLPAD();
5052 op_free(CvROOT(cv));
5057 SvPOK_off((SV*)cv); /* forget prototype */
5062 /* remove CvOUTSIDE unless this is an undef rather than a free */
5063 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
5064 if (!CvWEAKOUTSIDE(cv))
5065 SvREFCNT_dec(CvOUTSIDE(cv));
5066 CvOUTSIDE(cv) = NULL;
5069 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
5072 if (CvISXSUB(cv) && CvXSUB(cv)) {
5075 /* delete all flags except WEAKOUTSIDE */
5076 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
5080 Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
5083 /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
5084 relying on SvCUR, and doubling up the buffer to hold CvFILE(). */
5085 if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
5086 || (p && (len != SvCUR(cv) /* Not the same length. */
5087 || memNE(p, SvPVX_const(cv), len))))
5088 && ckWARN_d(WARN_PROTOTYPE)) {
5089 SV* const msg = sv_newmortal();
5093 gv_efullname3(name = sv_newmortal(), gv, NULL);
5094 sv_setpvs(msg, "Prototype mismatch:");
5096 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
5098 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv));
5100 sv_catpvs(msg, ": none");
5101 sv_catpvs(msg, " vs ");
5103 Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
5105 sv_catpvs(msg, "none");
5106 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
5110 static void const_sv_xsub(pTHX_ CV* cv);
5114 =head1 Optree Manipulation Functions
5116 =for apidoc cv_const_sv
5118 If C<cv> is a constant sub eligible for inlining. returns the constant
5119 value returned by the sub. Otherwise, returns NULL.
5121 Constant subs can be created with C<newCONSTSUB> or as described in
5122 L<perlsub/"Constant Functions">.
5127 Perl_cv_const_sv(pTHX_ CV *cv)
5129 PERL_UNUSED_CONTEXT;
5132 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
5134 return CvCONST(cv) ? (SV*)CvXSUBANY(cv).any_ptr : NULL;
5137 /* op_const_sv: examine an optree to determine whether it's in-lineable.
5138 * Can be called in 3 ways:
5141 * look for a single OP_CONST with attached value: return the value
5143 * cv && CvCLONE(cv) && !CvCONST(cv)
5145 * examine the clone prototype, and if contains only a single
5146 * OP_CONST referencing a pad const, or a single PADSV referencing
5147 * an outer lexical, return a non-zero value to indicate the CV is
5148 * a candidate for "constizing" at clone time
5152 * We have just cloned an anon prototype that was marked as a const
5153 * candidiate. Try to grab the current value, and in the case of
5154 * PADSV, ignore it if it has multiple references. Return the value.
5158 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
5169 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
5170 o = cLISTOPo->op_first->op_sibling;
5172 for (; o; o = o->op_next) {
5173 const OPCODE type = o->op_type;
5175 if (sv && o->op_next == o)
5177 if (o->op_next != o) {
5178 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
5180 if (type == OP_DBSTATE)
5183 if (type == OP_LEAVESUB || type == OP_RETURN)
5187 if (type == OP_CONST && cSVOPo->op_sv)
5189 else if (cv && type == OP_CONST) {
5190 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5194 else if (cv && type == OP_PADSV) {
5195 if (CvCONST(cv)) { /* newly cloned anon */
5196 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5197 /* the candidate should have 1 ref from this pad and 1 ref
5198 * from the parent */
5199 if (!sv || SvREFCNT(sv) != 2)
5206 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
5207 sv = &PL_sv_undef; /* an arbitrary non-null value */
5222 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5225 /* This would be the return value, but the return cannot be reached. */
5226 OP* pegop = newOP(OP_NULL, 0);
5229 PERL_UNUSED_ARG(floor);
5239 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
5241 NORETURN_FUNCTION_END;
5246 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
5248 return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
5252 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5259 register CV *cv = NULL;
5261 /* If the subroutine has no body, no attributes, and no builtin attributes
5262 then it's just a sub declaration, and we may be able to get away with
5263 storing with a placeholder scalar in the symbol table, rather than a
5264 full GV and CV. If anything is present then it will take a full CV to
5266 const I32 gv_fetch_flags
5267 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5269 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
5270 const char * const name = o ? SvPV_nolen_const(cSVOPo->op_sv) : NULL;
5273 assert(proto->op_type == OP_CONST);
5274 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
5279 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
5280 SV * const sv = sv_newmortal();
5281 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
5282 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
5283 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
5284 aname = SvPVX_const(sv);
5289 gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
5290 : gv_fetchpv(aname ? aname
5291 : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5292 gv_fetch_flags, SVt_PVCV);
5294 if (!PL_madskills) {
5303 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
5304 maximum a prototype before. */
5305 if (SvTYPE(gv) > SVt_NULL) {
5306 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
5307 && ckWARN_d(WARN_PROTOTYPE))
5309 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
5311 cv_ckproto_len((CV*)gv, NULL, ps, ps_len);
5314 sv_setpvn((SV*)gv, ps, ps_len);
5316 sv_setiv((SV*)gv, -1);
5318 SvREFCNT_dec(PL_compcv);
5319 cv = PL_compcv = NULL;
5323 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
5325 #ifdef GV_UNIQUE_CHECK
5326 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
5327 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
5331 if (!block || !ps || *ps || attrs
5332 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5334 || block->op_type == OP_NULL
5339 const_sv = op_const_sv(block, NULL);
5342 const bool exists = CvROOT(cv) || CvXSUB(cv);
5344 #ifdef GV_UNIQUE_CHECK
5345 if (exists && GvUNIQUE(gv)) {
5346 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
5350 /* if the subroutine doesn't exist and wasn't pre-declared
5351 * with a prototype, assume it will be AUTOLOADed,
5352 * skipping the prototype check
5354 if (exists || SvPOK(cv))
5355 cv_ckproto_len(cv, gv, ps, ps_len);
5356 /* already defined (or promised)? */
5357 if (exists || GvASSUMECV(gv)) {
5360 || block->op_type == OP_NULL
5363 if (CvFLAGS(PL_compcv)) {
5364 /* might have had built-in attrs applied */
5365 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5367 /* just a "sub foo;" when &foo is already defined */
5368 SAVEFREESV(PL_compcv);
5373 && block->op_type != OP_NULL
5376 if (ckWARN(WARN_REDEFINE)
5378 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
5380 const line_t oldline = CopLINE(PL_curcop);
5381 if (PL_parser && PL_parser->copline != NOLINE)
5382 CopLINE_set(PL_curcop, PL_parser->copline);
5383 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5384 CvCONST(cv) ? "Constant subroutine %s redefined"
5385 : "Subroutine %s redefined", name);
5386 CopLINE_set(PL_curcop, oldline);
5389 if (!PL_minus_c) /* keep old one around for madskills */
5392 /* (PL_madskills unset in used file.) */
5400 SvREFCNT_inc_simple_void_NN(const_sv);
5402 assert(!CvROOT(cv) && !CvCONST(cv));
5403 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
5404 CvXSUBANY(cv).any_ptr = const_sv;
5405 CvXSUB(cv) = const_sv_xsub;
5411 cv = newCONSTSUB(NULL, name, const_sv);
5413 mro_method_changed_in( /* sub Foo::Bar () { 123 } */
5414 (CvGV(cv) && GvSTASH(CvGV(cv)))
5423 SvREFCNT_dec(PL_compcv);
5431 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
5432 * before we clobber PL_compcv.
5436 || block->op_type == OP_NULL
5440 /* Might have had built-in attributes applied -- propagate them. */
5441 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5442 if (CvGV(cv) && GvSTASH(CvGV(cv)))
5443 stash = GvSTASH(CvGV(cv));
5444 else if (CvSTASH(cv))
5445 stash = CvSTASH(cv);
5447 stash = PL_curstash;
5450 /* possibly about to re-define existing subr -- ignore old cv */
5451 rcv = (SV*)PL_compcv;
5452 if (name && GvSTASH(gv))
5453 stash = GvSTASH(gv);
5455 stash = PL_curstash;
5457 apply_attrs(stash, rcv, attrs, FALSE);
5459 if (cv) { /* must reuse cv if autoloaded */
5466 || block->op_type == OP_NULL) && !PL_madskills
5469 /* got here with just attrs -- work done, so bug out */
5470 SAVEFREESV(PL_compcv);
5473 /* transfer PL_compcv to cv */
5475 CvFLAGS(cv) = CvFLAGS(PL_compcv);
5476 if (!CvWEAKOUTSIDE(cv))
5477 SvREFCNT_dec(CvOUTSIDE(cv));
5478 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
5479 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
5480 CvOUTSIDE(PL_compcv) = 0;
5481 CvPADLIST(cv) = CvPADLIST(PL_compcv);
5482 CvPADLIST(PL_compcv) = 0;
5483 /* inner references to PL_compcv must be fixed up ... */
5484 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
5485 /* ... before we throw it away */
5486 SvREFCNT_dec(PL_compcv);
5488 if (PERLDB_INTER)/* Advice debugger on the new sub. */
5489 ++PL_sub_generation;
5496 if (strEQ(name, "import")) {
5497 PL_formfeed = (SV*)cv;
5498 Perl_warner(aTHX_ packWARN(WARN_VOID), "%lx\n", (long)cv);
5502 mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */
5506 CvFILE_set_from_cop(cv, PL_curcop);
5507 CvSTASH(cv) = PL_curstash;
5510 sv_setpvn((SV*)cv, ps, ps_len);
5512 if (PL_parser && PL_parser->error_count) {
5516 const char *s = strrchr(name, ':');
5518 if (strEQ(s, "BEGIN")) {
5519 const char not_safe[] =
5520 "BEGIN not safe after errors--compilation aborted";
5521 if (PL_in_eval & EVAL_KEEPERR)
5522 Perl_croak(aTHX_ not_safe);
5524 /* force display of errors found but not reported */
5525 sv_catpv(ERRSV, not_safe);
5526 Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
5536 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5537 mod(scalarseq(block), OP_LEAVESUBLV));
5538 block->op_attached = 1;
5541 /* This makes sub {}; work as expected. */
5542 if (block->op_type == OP_STUB) {
5543 OP* const newblock = newSTATEOP(0, NULL, 0);
5545 op_getmad(block,newblock,'B');
5552 block->op_attached = 1;
5553 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5555 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5556 OpREFCNT_set(CvROOT(cv), 1);
5557 CvSTART(cv) = LINKLIST(CvROOT(cv));
5558 CvROOT(cv)->op_next = 0;
5559 CALL_PEEP(CvSTART(cv));
5561 /* now that optimizer has done its work, adjust pad values */
5563 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
5566 assert(!CvCONST(cv));
5567 if (ps && !*ps && op_const_sv(block, cv))
5571 if (name || aname) {
5572 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5573 SV * const sv = newSV(0);
5574 SV * const tmpstr = sv_newmortal();
5575 GV * const db_postponed = gv_fetchpvs("DB::postponed",
5576 GV_ADDMULTI, SVt_PVHV);
5579 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5581 (long)PL_subline, (long)CopLINE(PL_curcop));
5582 gv_efullname3(tmpstr, gv, NULL);
5583 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
5584 SvCUR(tmpstr), sv, 0);
5585 hv = GvHVn(db_postponed);
5586 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
5587 CV * const pcv = GvCV(db_postponed);
5593 call_sv((SV*)pcv, G_DISCARD);
5598 if (name && ! (PL_parser && PL_parser->error_count))
5599 process_special_blocks(name, gv, cv);
5604 PL_parser->copline = NOLINE;
5610 S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
5613 const char *const colon = strrchr(fullname,':');
5614 const char *const name = colon ? colon + 1 : fullname;
5617 if (strEQ(name, "BEGIN")) {
5618 const I32 oldscope = PL_scopestack_ix;
5620 SAVECOPFILE(&PL_compiling);
5621 SAVECOPLINE(&PL_compiling);
5623 DEBUG_x( dump_sub(gv) );
5624 Perl_av_create_and_push(aTHX_ &PL_beginav, (SV*)cv);
5625 GvCV(gv) = 0; /* cv has been hijacked */
5626 call_list(oldscope, PL_beginav);
5628 PL_curcop = &PL_compiling;
5629 CopHINTS_set(&PL_compiling, PL_hints);
5636 if strEQ(name, "END") {
5637 DEBUG_x( dump_sub(gv) );
5638 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, (SV*)cv);
5641 } else if (*name == 'U') {
5642 if (strEQ(name, "UNITCHECK")) {
5643 /* It's never too late to run a unitcheck block */
5644 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, (SV*)cv);
5648 } else if (*name == 'C') {
5649 if (strEQ(name, "CHECK")) {
5650 if (PL_main_start && ckWARN(WARN_VOID))
5651 Perl_warner(aTHX_ packWARN(WARN_VOID),
5652 "Too late to run CHECK block");
5653 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, (SV*)cv);
5657 } else if (*name == 'I') {
5658 if (strEQ(name, "INIT")) {
5659 if (PL_main_start && ckWARN(WARN_VOID))
5660 Perl_warner(aTHX_ packWARN(WARN_VOID),
5661 "Too late to run INIT block");
5662 Perl_av_create_and_push(aTHX_ &PL_initav, (SV*)cv);
5668 DEBUG_x( dump_sub(gv) );
5669 GvCV(gv) = 0; /* cv has been hijacked */
5674 =for apidoc newCONSTSUB
5676 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5677 eligible for inlining at compile-time.
5683 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
5688 const char *const temp_p = CopFILE(PL_curcop);
5689 const STRLEN len = temp_p ? strlen(temp_p) : 0;
5691 SV *const temp_sv = CopFILESV(PL_curcop);
5693 const char *const temp_p = temp_sv ? SvPV_const(temp_sv, len) : NULL;
5695 char *const file = savepvn(temp_p, temp_p ? len : 0);
5699 if (IN_PERL_RUNTIME) {
5700 /* at runtime, it's not safe to manipulate PL_curcop: it may be
5701 * an op shared between threads. Use a non-shared COP for our
5703 SAVEVPTR(PL_curcop);
5704 PL_curcop = &PL_compiling;
5706 SAVECOPLINE(PL_curcop);
5707 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
5710 PL_hints &= ~HINT_BLOCK_SCOPE;
5713 SAVESPTR(PL_curstash);
5714 SAVECOPSTASH(PL_curcop);
5715 PL_curstash = stash;
5716 CopSTASH_set(PL_curcop,stash);
5719 /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
5720 and so doesn't get free()d. (It's expected to be from the C pre-
5721 processor __FILE__ directive). But we need a dynamically allocated one,
5722 and we need it to get freed. */
5723 cv = newXS_flags(name, const_sv_xsub, file, "", XS_DYNAMIC_FILENAME);
5724 CvXSUBANY(cv).any_ptr = sv;
5730 CopSTASH_free(PL_curcop);
5738 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
5739 const char *const filename, const char *const proto,
5742 CV *cv = newXS(name, subaddr, filename);
5744 if (flags & XS_DYNAMIC_FILENAME) {
5745 /* We need to "make arrangements" (ie cheat) to ensure that the
5746 filename lasts as long as the PVCV we just created, but also doesn't
5748 STRLEN filename_len = strlen(filename);
5749 STRLEN proto_and_file_len = filename_len;
5750 char *proto_and_file;
5754 proto_len = strlen(proto);
5755 proto_and_file_len += proto_len;
5757 Newx(proto_and_file, proto_and_file_len + 1, char);
5758 Copy(proto, proto_and_file, proto_len, char);
5759 Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
5762 proto_and_file = savepvn(filename, filename_len);
5765 /* This gets free()d. :-) */
5766 sv_usepvn_flags((SV*)cv, proto_and_file, proto_and_file_len,
5767 SV_HAS_TRAILING_NUL);
5769 /* This gives us the correct prototype, rather than one with the
5770 file name appended. */
5771 SvCUR_set(cv, proto_len);
5775 CvFILE(cv) = proto_and_file + proto_len;
5777 sv_setpv((SV *)cv, proto);
5783 =for apidoc U||newXS
5785 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
5786 static storage, as it is used directly as CvFILE(), without a copy being made.
5792 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
5795 GV * const gv = gv_fetchpv(name ? name :
5796 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5797 GV_ADDMULTI, SVt_PVCV);
5801 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
5803 if ((cv = (name ? GvCV(gv) : NULL))) {
5805 /* just a cached method */
5809 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5810 /* already defined (or promised) */
5811 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
5812 if (ckWARN(WARN_REDEFINE)) {
5813 GV * const gvcv = CvGV(cv);
5815 HV * const stash = GvSTASH(gvcv);
5817 const char *redefined_name = HvNAME_get(stash);
5818 if ( strEQ(redefined_name,"autouse") ) {
5819 const line_t oldline = CopLINE(PL_curcop);
5820 if (PL_parser && PL_parser->copline != NOLINE)
5821 CopLINE_set(PL_curcop, PL_parser->copline);
5822 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5823 CvCONST(cv) ? "Constant subroutine %s redefined"
5824 : "Subroutine %s redefined"
5826 CopLINE_set(PL_curcop, oldline);
5836 if (cv) /* must reuse cv if autoloaded */
5839 cv = (CV*)newSV_type(SVt_PVCV);
5843 mro_method_changed_in(GvSTASH(gv)); /* newXS */
5847 (void)gv_fetchfile(filename);
5848 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
5849 an external constant string */
5851 CvXSUB(cv) = subaddr;
5854 process_special_blocks(name, gv, cv);
5866 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5871 OP* pegop = newOP(OP_NULL, 0);
5875 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
5876 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
5878 #ifdef GV_UNIQUE_CHECK
5880 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5884 if ((cv = GvFORM(gv))) {
5885 if (ckWARN(WARN_REDEFINE)) {
5886 const line_t oldline = CopLINE(PL_curcop);
5887 if (PL_parser && PL_parser->copline != NOLINE)
5888 CopLINE_set(PL_curcop, PL_parser->copline);
5889 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5890 o ? "Format %"SVf" redefined"
5891 : "Format STDOUT redefined", SVfARG(cSVOPo->op_sv));
5892 CopLINE_set(PL_curcop, oldline);
5899 CvFILE_set_from_cop(cv, PL_curcop);
5902 pad_tidy(padtidy_FORMAT);
5903 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5904 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5905 OpREFCNT_set(CvROOT(cv), 1);
5906 CvSTART(cv) = LINKLIST(CvROOT(cv));
5907 CvROOT(cv)->op_next = 0;
5908 CALL_PEEP(CvSTART(cv));
5910 op_getmad(o,pegop,'n');
5911 op_getmad_weak(block, pegop, 'b');
5916 PL_parser->copline = NOLINE;
5924 Perl_newANONLIST(pTHX_ OP *o)
5926 return convert(OP_ANONLIST, OPf_SPECIAL, o);
5930 Perl_newANONHASH(pTHX_ OP *o)
5932 return convert(OP_ANONHASH, OPf_SPECIAL, o);
5936 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5938 return newANONATTRSUB(floor, proto, NULL, block);
5942 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5944 return newUNOP(OP_REFGEN, 0,
5945 newSVOP(OP_ANONCODE, 0,
5946 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5950 Perl_oopsAV(pTHX_ OP *o)
5953 switch (o->op_type) {
5955 o->op_type = OP_PADAV;
5956 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5957 return ref(o, OP_RV2AV);
5960 o->op_type = OP_RV2AV;
5961 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5966 if (ckWARN_d(WARN_INTERNAL))
5967 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
5974 Perl_oopsHV(pTHX_ OP *o)
5977 switch (o->op_type) {
5980 o->op_type = OP_PADHV;
5981 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5982 return ref(o, OP_RV2HV);
5986 o->op_type = OP_RV2HV;
5987 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5992 if (ckWARN_d(WARN_INTERNAL))
5993 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
6000 Perl_newAVREF(pTHX_ OP *o)
6003 if (o->op_type == OP_PADANY) {
6004 o->op_type = OP_PADAV;
6005 o->op_ppaddr = PL_ppaddr[OP_PADAV];
6008 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
6009 && ckWARN(WARN_DEPRECATED)) {
6010 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
6011 "Using an array as a reference is deprecated");
6013 return newUNOP(OP_RV2AV, 0, scalar(o));
6017 Perl_newGVREF(pTHX_ I32 type, OP *o)
6019 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
6020 return newUNOP(OP_NULL, 0, o);
6021 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
6025 Perl_newHVREF(pTHX_ OP *o)
6028 if (o->op_type == OP_PADANY) {
6029 o->op_type = OP_PADHV;
6030 o->op_ppaddr = PL_ppaddr[OP_PADHV];
6033 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
6034 && ckWARN(WARN_DEPRECATED)) {
6035 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
6036 "Using a hash as a reference is deprecated");
6038 return newUNOP(OP_RV2HV, 0, scalar(o));
6042 Perl_newCVREF(pTHX_ I32 flags, OP *o)
6044 return newUNOP(OP_RV2CV, flags, scalar(o));
6048 Perl_newSVREF(pTHX_ OP *o)
6051 if (o->op_type == OP_PADANY) {
6052 o->op_type = OP_PADSV;
6053 o->op_ppaddr = PL_ppaddr[OP_PADSV];
6056 return newUNOP(OP_RV2SV, 0, scalar(o));
6059 /* Check routines. See the comments at the top of this file for details
6060 * on when these are called */
6063 Perl_ck_anoncode(pTHX_ OP *o)
6065 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
6067 cSVOPo->op_sv = NULL;
6072 Perl_ck_bitop(pTHX_ OP *o)
6075 #define OP_IS_NUMCOMPARE(op) \
6076 ((op) == OP_LT || (op) == OP_I_LT || \
6077 (op) == OP_GT || (op) == OP_I_GT || \
6078 (op) == OP_LE || (op) == OP_I_LE || \
6079 (op) == OP_GE || (op) == OP_I_GE || \
6080 (op) == OP_EQ || (op) == OP_I_EQ || \
6081 (op) == OP_NE || (op) == OP_I_NE || \
6082 (op) == OP_NCMP || (op) == OP_I_NCMP)
6083 o->op_private = (U8)(PL_hints & HINT_INTEGER);
6084 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
6085 && (o->op_type == OP_BIT_OR
6086 || o->op_type == OP_BIT_AND
6087 || o->op_type == OP_BIT_XOR))
6089 const OP * const left = cBINOPo->op_first;
6090 const OP * const right = left->op_sibling;
6091 if ((OP_IS_NUMCOMPARE(left->op_type) &&
6092 (left->op_flags & OPf_PARENS) == 0) ||
6093 (OP_IS_NUMCOMPARE(right->op_type) &&
6094 (right->op_flags & OPf_PARENS) == 0))
6095 if (ckWARN(WARN_PRECEDENCE))
6096 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
6097 "Possible precedence problem on bitwise %c operator",
6098 o->op_type == OP_BIT_OR ? '|'
6099 : o->op_type == OP_BIT_AND ? '&' : '^'
6106 Perl_ck_concat(pTHX_ OP *o)
6108 const OP * const kid = cUNOPo->op_first;
6109 PERL_UNUSED_CONTEXT;
6110 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
6111 !(kUNOP->op_first->op_flags & OPf_MOD))
6112 o->op_flags |= OPf_STACKED;
6117 Perl_ck_spair(pTHX_ OP *o)
6120 if (o->op_flags & OPf_KIDS) {
6123 const OPCODE type = o->op_type;
6124 o = modkids(ck_fun(o), type);
6125 kid = cUNOPo->op_first;
6126 newop = kUNOP->op_first->op_sibling;
6128 const OPCODE type = newop->op_type;
6129 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
6130 type == OP_PADAV || type == OP_PADHV ||
6131 type == OP_RV2AV || type == OP_RV2HV)
6135 op_getmad(kUNOP->op_first,newop,'K');
6137 op_free(kUNOP->op_first);
6139 kUNOP->op_first = newop;
6141 o->op_ppaddr = PL_ppaddr[++o->op_type];
6146 Perl_ck_delete(pTHX_ OP *o)
6150 if (o->op_flags & OPf_KIDS) {
6151 OP * const kid = cUNOPo->op_first;
6152 switch (kid->op_type) {
6154 o->op_flags |= OPf_SPECIAL;
6157 o->op_private |= OPpSLICE;
6160 o->op_flags |= OPf_SPECIAL;
6165 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
6174 Perl_ck_die(pTHX_ OP *o)
6177 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6183 Perl_ck_eof(pTHX_ OP *o)
6187 if (o->op_flags & OPf_KIDS) {
6188 if (cLISTOPo->op_first->op_type == OP_STUB) {
6190 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
6192 op_getmad(o,newop,'O');
6204 Perl_ck_eval(pTHX_ OP *o)
6207 PL_hints |= HINT_BLOCK_SCOPE;
6208 if (o->op_flags & OPf_KIDS) {
6209 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6212 o->op_flags &= ~OPf_KIDS;
6215 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
6221 cUNOPo->op_first = 0;
6226 NewOp(1101, enter, 1, LOGOP);
6227 enter->op_type = OP_ENTERTRY;
6228 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
6229 enter->op_private = 0;
6231 /* establish postfix order */
6232 enter->op_next = (OP*)enter;
6234 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
6235 o->op_type = OP_LEAVETRY;
6236 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
6237 enter->op_other = o;
6238 op_getmad(oldo,o,'O');
6252 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
6253 op_getmad(oldo,o,'O');
6255 o->op_targ = (PADOFFSET)PL_hints;
6256 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
6257 /* Store a copy of %^H that pp_entereval can pick up.
6258 OPf_SPECIAL flags the opcode as being for this purpose,
6259 so that it in turn will return a copy at every
6261 OP *hhop = newSVOP(OP_CONST, OPf_SPECIAL,
6262 (SV*)Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv)));
6263 cUNOPo->op_first->op_sibling = hhop;
6264 o->op_private |= OPpEVAL_HAS_HH;
6270 Perl_ck_exit(pTHX_ OP *o)
6273 HV * const table = GvHV(PL_hintgv);
6275 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
6276 if (svp && *svp && SvTRUE(*svp))
6277 o->op_private |= OPpEXIT_VMSISH;
6279 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6285 Perl_ck_exec(pTHX_ OP *o)
6287 if (o->op_flags & OPf_STACKED) {
6290 kid = cUNOPo->op_first->op_sibling;
6291 if (kid->op_type == OP_RV2GV)
6300 Perl_ck_exists(pTHX_ OP *o)
6304 if (o->op_flags & OPf_KIDS) {
6305 OP * const kid = cUNOPo->op_first;
6306 if (kid->op_type == OP_ENTERSUB) {
6307 (void) ref(kid, o->op_type);
6308 if (kid->op_type != OP_RV2CV
6309 && !(PL_parser && PL_parser->error_count))
6310 Perl_croak(aTHX_ "%s argument is not a subroutine name",
6312 o->op_private |= OPpEXISTS_SUB;
6314 else if (kid->op_type == OP_AELEM)
6315 o->op_flags |= OPf_SPECIAL;
6316 else if (kid->op_type != OP_HELEM)
6317 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
6325 Perl_ck_rvconst(pTHX_ register OP *o)
6328 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6330 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6331 if (o->op_type == OP_RV2CV)
6332 o->op_private &= ~1;
6334 if (kid->op_type == OP_CONST) {
6337 SV * const kidsv = kid->op_sv;
6339 /* Is it a constant from cv_const_sv()? */
6340 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
6341 SV * const rsv = SvRV(kidsv);
6342 const svtype type = SvTYPE(rsv);
6343 const char *badtype = NULL;
6345 switch (o->op_type) {
6347 if (type > SVt_PVMG)
6348 badtype = "a SCALAR";
6351 if (type != SVt_PVAV)
6352 badtype = "an ARRAY";
6355 if (type != SVt_PVHV)
6359 if (type != SVt_PVCV)
6364 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
6367 else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
6368 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
6369 /* If this is an access to a stash, disable "strict refs", because
6370 * stashes aren't auto-vivified at compile-time (unless we store
6371 * symbols in them), and we don't want to produce a run-time
6372 * stricture error when auto-vivifying the stash. */
6373 const char *s = SvPV_nolen(kidsv);
6374 const STRLEN l = SvCUR(kidsv);
6375 if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
6376 o->op_private &= ~HINT_STRICT_REFS;
6378 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
6379 const char *badthing;
6380 switch (o->op_type) {
6382 badthing = "a SCALAR";
6385 badthing = "an ARRAY";
6388 badthing = "a HASH";
6396 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
6397 SVfARG(kidsv), badthing);
6400 * This is a little tricky. We only want to add the symbol if we
6401 * didn't add it in the lexer. Otherwise we get duplicate strict
6402 * warnings. But if we didn't add it in the lexer, we must at
6403 * least pretend like we wanted to add it even if it existed before,
6404 * or we get possible typo warnings. OPpCONST_ENTERED says
6405 * whether the lexer already added THIS instance of this symbol.
6407 iscv = (o->op_type == OP_RV2CV) * 2;
6409 gv = gv_fetchsv(kidsv,
6410 iscv | !(kid->op_private & OPpCONST_ENTERED),
6413 : o->op_type == OP_RV2SV
6415 : o->op_type == OP_RV2AV
6417 : o->op_type == OP_RV2HV
6420 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
6422 kid->op_type = OP_GV;
6423 SvREFCNT_dec(kid->op_sv);
6425 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
6426 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
6427 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
6429 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc_simple_NN(gv));
6431 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
6433 kid->op_private = 0;
6434 kid->op_ppaddr = PL_ppaddr[OP_GV];
6441 Perl_ck_ftst(pTHX_ OP *o)
6444 const I32 type = o->op_type;
6446 if (o->op_flags & OPf_REF) {
6449 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
6450 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6451 const OPCODE kidtype = kid->op_type;
6453 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6454 OP * const newop = newGVOP(type, OPf_REF,
6455 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
6457 op_getmad(o,newop,'O');
6463 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o))
6464 o->op_private |= OPpFT_ACCESS;
6465 if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst)
6466 && kidtype != OP_STAT && kidtype != OP_LSTAT)
6467 o->op_private |= OPpFT_STACKED;
6475 if (type == OP_FTTTY)
6476 o = newGVOP(type, OPf_REF, PL_stdingv);
6478 o = newUNOP(type, 0, newDEFSVOP());
6479 op_getmad(oldo,o,'O');
6485 Perl_ck_fun(pTHX_ OP *o)
6488 const int type = o->op_type;
6489 register I32 oa = PL_opargs[type] >> OASHIFT;
6491 if (o->op_flags & OPf_STACKED) {
6492 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
6495 return no_fh_allowed(o);
6498 if (o->op_flags & OPf_KIDS) {
6499 OP **tokid = &cLISTOPo->op_first;
6500 register OP *kid = cLISTOPo->op_first;
6504 if (kid->op_type == OP_PUSHMARK ||
6505 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
6507 tokid = &kid->op_sibling;
6508 kid = kid->op_sibling;
6510 if (!kid && PL_opargs[type] & OA_DEFGV)
6511 *tokid = kid = newDEFSVOP();
6515 sibl = kid->op_sibling;
6517 if (!sibl && kid->op_type == OP_STUB) {
6524 /* list seen where single (scalar) arg expected? */
6525 if (numargs == 1 && !(oa >> 4)
6526 && kid->op_type == OP_LIST && type != OP_SCALAR)
6528 return too_many_arguments(o,PL_op_desc[type]);
6541 if ((type == OP_PUSH || type == OP_UNSHIFT)
6542 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
6543 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6544 "Useless use of %s with no values",
6547 if (kid->op_type == OP_CONST &&
6548 (kid->op_private & OPpCONST_BARE))
6550 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
6551 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
6552 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6553 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6554 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
6555 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6557 op_getmad(kid,newop,'K');
6562 kid->op_sibling = sibl;
6565 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
6566 bad_type(numargs, "array", PL_op_desc[type], kid);
6570 if (kid->op_type == OP_CONST &&
6571 (kid->op_private & OPpCONST_BARE))
6573 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
6574 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
6575 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6576 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6577 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
6578 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6580 op_getmad(kid,newop,'K');
6585 kid->op_sibling = sibl;
6588 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
6589 bad_type(numargs, "hash", PL_op_desc[type], kid);
6594 OP * const newop = newUNOP(OP_NULL, 0, kid);
6595 kid->op_sibling = 0;
6597 newop->op_next = newop;
6599 kid->op_sibling = sibl;
6604 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
6605 if (kid->op_type == OP_CONST &&
6606 (kid->op_private & OPpCONST_BARE))
6608 OP * const newop = newGVOP(OP_GV, 0,
6609 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
6610 if (!(o->op_private & 1) && /* if not unop */
6611 kid == cLISTOPo->op_last)
6612 cLISTOPo->op_last = newop;
6614 op_getmad(kid,newop,'K');
6620 else if (kid->op_type == OP_READLINE) {
6621 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
6622 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
6625 I32 flags = OPf_SPECIAL;
6629 /* is this op a FH constructor? */
6630 if (is_handle_constructor(o,numargs)) {
6631 const char *name = NULL;
6635 /* Set a flag to tell rv2gv to vivify
6636 * need to "prove" flag does not mean something
6637 * else already - NI-S 1999/05/07
6640 if (kid->op_type == OP_PADSV) {
6642 = PAD_COMPNAME_SV(kid->op_targ);
6643 name = SvPV_const(namesv, len);
6645 else if (kid->op_type == OP_RV2SV
6646 && kUNOP->op_first->op_type == OP_GV)
6648 GV * const gv = cGVOPx_gv(kUNOP->op_first);
6650 len = GvNAMELEN(gv);
6652 else if (kid->op_type == OP_AELEM
6653 || kid->op_type == OP_HELEM)
6656 OP *op = ((BINOP*)kid)->op_first;
6660 const char * const a =
6661 kid->op_type == OP_AELEM ?
6663 if (((op->op_type == OP_RV2AV) ||
6664 (op->op_type == OP_RV2HV)) &&
6665 (firstop = ((UNOP*)op)->op_first) &&
6666 (firstop->op_type == OP_GV)) {
6667 /* packagevar $a[] or $h{} */
6668 GV * const gv = cGVOPx_gv(firstop);
6676 else if (op->op_type == OP_PADAV
6677 || op->op_type == OP_PADHV) {
6678 /* lexicalvar $a[] or $h{} */
6679 const char * const padname =
6680 PAD_COMPNAME_PV(op->op_targ);
6689 name = SvPV_const(tmpstr, len);
6694 name = "__ANONIO__";
6701 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
6702 namesv = PAD_SVl(targ);
6703 SvUPGRADE(namesv, SVt_PV);
6705 sv_setpvn(namesv, "$", 1);
6706 sv_catpvn(namesv, name, len);
6709 kid->op_sibling = 0;
6710 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
6711 kid->op_targ = targ;
6712 kid->op_private |= priv;
6714 kid->op_sibling = sibl;
6720 mod(scalar(kid), type);
6724 tokid = &kid->op_sibling;
6725 kid = kid->op_sibling;
6728 if (kid && kid->op_type != OP_STUB)
6729 return too_many_arguments(o,OP_DESC(o));
6730 o->op_private |= numargs;
6732 /* FIXME - should the numargs move as for the PERL_MAD case? */
6733 o->op_private |= numargs;
6735 return too_many_arguments(o,OP_DESC(o));
6739 else if (PL_opargs[type] & OA_DEFGV) {
6741 OP *newop = newUNOP(type, 0, newDEFSVOP());
6742 op_getmad(o,newop,'O');
6745 /* Ordering of these two is important to keep f_map.t passing. */
6747 return newUNOP(type, 0, newDEFSVOP());
6752 while (oa & OA_OPTIONAL)
6754 if (oa && oa != OA_LIST)
6755 return too_few_arguments(o,OP_DESC(o));
6761 Perl_ck_glob(pTHX_ OP *o)
6767 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
6768 append_elem(OP_GLOB, o, newDEFSVOP());
6770 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
6771 && GvCVu(gv) && GvIMPORTED_CV(gv)))
6773 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6776 #if !defined(PERL_EXTERNAL_GLOB)
6777 /* XXX this can be tightened up and made more failsafe. */
6778 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
6781 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
6782 newSVpvs("File::Glob"), NULL, NULL, NULL);
6783 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6784 glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
6785 GvCV(gv) = GvCV(glob_gv);
6786 SvREFCNT_inc_void((SV*)GvCV(gv));
6787 GvIMPORTED_CV_on(gv);
6790 #endif /* PERL_EXTERNAL_GLOB */
6792 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6793 append_elem(OP_GLOB, o,
6794 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
6795 o->op_type = OP_LIST;
6796 o->op_ppaddr = PL_ppaddr[OP_LIST];
6797 cLISTOPo->op_first->op_type = OP_PUSHMARK;
6798 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
6799 cLISTOPo->op_first->op_targ = 0;
6800 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
6801 append_elem(OP_LIST, o,
6802 scalar(newUNOP(OP_RV2CV, 0,
6803 newGVOP(OP_GV, 0, gv)))));
6804 o = newUNOP(OP_NULL, 0, ck_subr(o));
6805 o->op_targ = OP_GLOB; /* hint at what it used to be */
6808 gv = newGVgen("main");
6810 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
6816 Perl_ck_grep(pTHX_ OP *o)
6821 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
6824 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
6825 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
6827 if (o->op_flags & OPf_STACKED) {
6830 kid = cLISTOPo->op_first->op_sibling;
6831 if (!cUNOPx(kid)->op_next)
6832 Perl_croak(aTHX_ "panic: ck_grep");
6833 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
6836 NewOp(1101, gwop, 1, LOGOP);
6837 kid->op_next = (OP*)gwop;
6838 o->op_flags &= ~OPf_STACKED;
6840 kid = cLISTOPo->op_first->op_sibling;
6841 if (type == OP_MAPWHILE)
6846 if (PL_parser && PL_parser->error_count)
6848 kid = cLISTOPo->op_first->op_sibling;
6849 if (kid->op_type != OP_NULL)
6850 Perl_croak(aTHX_ "panic: ck_grep");
6851 kid = kUNOP->op_first;
6854 NewOp(1101, gwop, 1, LOGOP);
6855 gwop->op_type = type;
6856 gwop->op_ppaddr = PL_ppaddr[type];
6857 gwop->op_first = listkids(o);
6858 gwop->op_flags |= OPf_KIDS;
6859 gwop->op_other = LINKLIST(kid);
6860 kid->op_next = (OP*)gwop;
6861 offset = pad_findmy("$_");
6862 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
6863 o->op_private = gwop->op_private = 0;
6864 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
6867 o->op_private = gwop->op_private = OPpGREP_LEX;
6868 gwop->op_targ = o->op_targ = offset;
6871 kid = cLISTOPo->op_first->op_sibling;
6872 if (!kid || !kid->op_sibling)
6873 return too_few_arguments(o,OP_DESC(o));
6874 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
6875 mod(kid, OP_GREPSTART);
6881 Perl_ck_index(pTHX_ OP *o)
6883 if (o->op_flags & OPf_KIDS) {
6884 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6886 kid = kid->op_sibling; /* get past "big" */
6887 if (kid && kid->op_type == OP_CONST)
6888 fbm_compile(((SVOP*)kid)->op_sv, 0);
6894 Perl_ck_lengthconst(pTHX_ OP *o)
6896 /* XXX length optimization goes here */
6901 Perl_ck_lfun(pTHX_ OP *o)
6903 const OPCODE type = o->op_type;
6904 return modkids(ck_fun(o), type);
6908 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
6910 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
6911 switch (cUNOPo->op_first->op_type) {
6913 /* This is needed for
6914 if (defined %stash::)
6915 to work. Do not break Tk.
6917 break; /* Globals via GV can be undef */
6919 case OP_AASSIGN: /* Is this a good idea? */
6920 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6921 "defined(@array) is deprecated");
6922 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6923 "\t(Maybe you should just omit the defined()?)\n");
6926 /* This is needed for
6927 if (defined %stash::)
6928 to work. Do not break Tk.
6930 break; /* Globals via GV can be undef */
6932 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6933 "defined(%%hash) is deprecated");
6934 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6935 "\t(Maybe you should just omit the defined()?)\n");
6946 Perl_ck_readline(pTHX_ OP *o)
6948 if (!(o->op_flags & OPf_KIDS)) {
6950 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
6952 op_getmad(o,newop,'O');
6962 Perl_ck_rfun(pTHX_ OP *o)
6964 const OPCODE type = o->op_type;
6965 return refkids(ck_fun(o), type);
6969 Perl_ck_listiob(pTHX_ OP *o)
6973 kid = cLISTOPo->op_first;
6976 kid = cLISTOPo->op_first;
6978 if (kid->op_type == OP_PUSHMARK)
6979 kid = kid->op_sibling;
6980 if (kid && o->op_flags & OPf_STACKED)
6981 kid = kid->op_sibling;
6982 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6983 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6984 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6985 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6986 cLISTOPo->op_first->op_sibling = kid;
6987 cLISTOPo->op_last = kid;
6988 kid = kid->op_sibling;
6993 append_elem(o->op_type, o, newDEFSVOP());
6999 Perl_ck_smartmatch(pTHX_ OP *o)
7002 if (0 == (o->op_flags & OPf_SPECIAL)) {
7003 OP *first = cBINOPo->op_first;
7004 OP *second = first->op_sibling;
7006 /* Implicitly take a reference to an array or hash */
7007 first->op_sibling = NULL;
7008 first = cBINOPo->op_first = ref_array_or_hash(first);
7009 second = first->op_sibling = ref_array_or_hash(second);
7011 /* Implicitly take a reference to a regular expression */
7012 if (first->op_type == OP_MATCH) {
7013 first->op_type = OP_QR;
7014 first->op_ppaddr = PL_ppaddr[OP_QR];
7016 if (second->op_type == OP_MATCH) {
7017 second->op_type = OP_QR;
7018 second->op_ppaddr = PL_ppaddr[OP_QR];
7027 Perl_ck_sassign(pTHX_ OP *o)
7029 OP * const kid = cLISTOPo->op_first;
7030 /* has a disposable target? */
7031 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
7032 && !(kid->op_flags & OPf_STACKED)
7033 /* Cannot steal the second time! */
7034 && !(kid->op_private & OPpTARGET_MY)
7035 /* Keep the full thing for madskills */
7039 OP * const kkid = kid->op_sibling;
7041 /* Can just relocate the target. */
7042 if (kkid && kkid->op_type == OP_PADSV
7043 && !(kkid->op_private & OPpLVAL_INTRO))
7045 kid->op_targ = kkid->op_targ;
7047 /* Now we do not need PADSV and SASSIGN. */
7048 kid->op_sibling = o->op_sibling; /* NULL */
7049 cLISTOPo->op_first = NULL;
7052 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
7056 if (kid->op_sibling) {
7057 OP *kkid = kid->op_sibling;
7058 if (kkid->op_type == OP_PADSV
7059 && (kkid->op_private & OPpLVAL_INTRO)
7060 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
7061 const PADOFFSET target = kkid->op_targ;
7062 OP *const other = newOP(OP_PADSV,
7064 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
7065 OP *const first = newOP(OP_NULL, 0);
7066 OP *const nullop = newCONDOP(0, first, o, other);
7067 OP *const condop = first->op_next;
7068 /* hijacking PADSTALE for uninitialized state variables */
7069 SvPADSTALE_on(PAD_SVl(target));
7071 condop->op_type = OP_ONCE;
7072 condop->op_ppaddr = PL_ppaddr[OP_ONCE];
7073 condop->op_targ = target;
7074 other->op_targ = target;
7076 /* Because we change the type of the op here, we will skip the
7077 assinment binop->op_last = binop->op_first->op_sibling; at the
7078 end of Perl_newBINOP(). So need to do it here. */
7079 cBINOPo->op_last = cBINOPo->op_first->op_sibling;
7088 Perl_ck_match(pTHX_ OP *o)
7091 if (o->op_type != OP_QR && PL_compcv) {
7092 const PADOFFSET offset = pad_findmy("$_");
7093 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
7094 o->op_targ = offset;
7095 o->op_private |= OPpTARGET_MY;
7098 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
7099 o->op_private |= OPpRUNTIME;
7104 Perl_ck_method(pTHX_ OP *o)
7106 OP * const kid = cUNOPo->op_first;
7107 if (kid->op_type == OP_CONST) {
7108 SV* sv = kSVOP->op_sv;
7109 const char * const method = SvPVX_const(sv);
7110 if (!(strchr(method, ':') || strchr(method, '\''))) {
7112 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
7113 sv = newSVpvn_share(method, SvCUR(sv), 0);
7116 kSVOP->op_sv = NULL;
7118 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
7120 op_getmad(o,cmop,'O');
7131 Perl_ck_null(pTHX_ OP *o)
7133 PERL_UNUSED_CONTEXT;
7138 Perl_ck_open(pTHX_ OP *o)
7141 HV * const table = GvHV(PL_hintgv);
7143 SV **svp = hv_fetchs(table, "open_IN", FALSE);
7145 const I32 mode = mode_from_discipline(*svp);
7146 if (mode & O_BINARY)
7147 o->op_private |= OPpOPEN_IN_RAW;
7148 else if (mode & O_TEXT)
7149 o->op_private |= OPpOPEN_IN_CRLF;
7152 svp = hv_fetchs(table, "open_OUT", FALSE);
7154 const I32 mode = mode_from_discipline(*svp);
7155 if (mode & O_BINARY)
7156 o->op_private |= OPpOPEN_OUT_RAW;
7157 else if (mode & O_TEXT)
7158 o->op_private |= OPpOPEN_OUT_CRLF;
7161 if (o->op_type == OP_BACKTICK) {
7162 if (!(o->op_flags & OPf_KIDS)) {
7163 OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
7165 op_getmad(o,newop,'O');
7174 /* In case of three-arg dup open remove strictness
7175 * from the last arg if it is a bareword. */
7176 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
7177 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
7181 if ((last->op_type == OP_CONST) && /* The bareword. */
7182 (last->op_private & OPpCONST_BARE) &&
7183 (last->op_private & OPpCONST_STRICT) &&
7184 (oa = first->op_sibling) && /* The fh. */
7185 (oa = oa->op_sibling) && /* The mode. */
7186 (oa->op_type == OP_CONST) &&
7187 SvPOK(((SVOP*)oa)->op_sv) &&
7188 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
7189 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
7190 (last == oa->op_sibling)) /* The bareword. */
7191 last->op_private &= ~OPpCONST_STRICT;
7197 Perl_ck_repeat(pTHX_ OP *o)
7199 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
7200 o->op_private |= OPpREPEAT_DOLIST;
7201 cBINOPo->op_first = force_list(cBINOPo->op_first);
7209 Perl_ck_require(pTHX_ OP *o)
7214 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
7215 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7217 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
7218 SV * const sv = kid->op_sv;
7219 U32 was_readonly = SvREADONLY(sv);
7226 sv_force_normal_flags(sv, 0);
7227 assert(!SvREADONLY(sv));
7237 for (; s < end; s++) {
7238 if (*s == ':' && s[1] == ':') {
7240 Move(s+2, s+1, end - s, char);
7245 sv_catpvs(sv, ".pm");
7246 SvFLAGS(sv) |= was_readonly;
7250 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
7251 /* handle override, if any */
7252 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
7253 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7254 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
7255 gv = gvp ? *gvp : NULL;
7259 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7260 OP * const kid = cUNOPo->op_first;
7263 cUNOPo->op_first = 0;
7267 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
7268 append_elem(OP_LIST, kid,
7269 scalar(newUNOP(OP_RV2CV, 0,
7272 op_getmad(o,newop,'O');
7280 Perl_ck_return(pTHX_ OP *o)
7283 if (CvLVALUE(PL_compcv)) {
7285 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
7286 mod(kid, OP_LEAVESUBLV);
7292 Perl_ck_select(pTHX_ OP *o)
7296 if (o->op_flags & OPf_KIDS) {
7297 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7298 if (kid && kid->op_sibling) {
7299 o->op_type = OP_SSELECT;
7300 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
7302 return fold_constants(o);
7306 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7307 if (kid && kid->op_type == OP_RV2GV)
7308 kid->op_private &= ~HINT_STRICT_REFS;
7313 Perl_ck_shift(pTHX_ OP *o)
7316 const I32 type = o->op_type;
7318 if (!(o->op_flags & OPf_KIDS)) {
7320 /* FIXME - this can be refactored to reduce code in #ifdefs */
7322 OP * const oldo = o;
7326 argop = newUNOP(OP_RV2AV, 0,
7327 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
7329 o = newUNOP(type, 0, scalar(argop));
7330 op_getmad(oldo,o,'O');
7333 return newUNOP(type, 0, scalar(argop));
7336 return scalar(modkids(ck_fun(o), type));
7340 Perl_ck_sort(pTHX_ OP *o)
7345 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
7346 HV * const hinthv = GvHV(PL_hintgv);
7348 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
7350 const I32 sorthints = (I32)SvIV(*svp);
7351 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
7352 o->op_private |= OPpSORT_QSORT;
7353 if ((sorthints & HINT_SORT_STABLE) != 0)
7354 o->op_private |= OPpSORT_STABLE;
7359 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
7361 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7362 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
7364 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
7366 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
7368 if (kid->op_type == OP_SCOPE) {
7372 else if (kid->op_type == OP_LEAVE) {
7373 if (o->op_type == OP_SORT) {
7374 op_null(kid); /* wipe out leave */
7377 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
7378 if (k->op_next == kid)
7380 /* don't descend into loops */
7381 else if (k->op_type == OP_ENTERLOOP
7382 || k->op_type == OP_ENTERITER)
7384 k = cLOOPx(k)->op_lastop;
7389 kid->op_next = 0; /* just disconnect the leave */
7390 k = kLISTOP->op_first;
7395 if (o->op_type == OP_SORT) {
7396 /* provide scalar context for comparison function/block */
7402 o->op_flags |= OPf_SPECIAL;
7404 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
7407 firstkid = firstkid->op_sibling;
7410 /* provide list context for arguments */
7411 if (o->op_type == OP_SORT)
7418 S_simplify_sort(pTHX_ OP *o)
7421 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7426 if (!(o->op_flags & OPf_STACKED))
7428 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7429 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
7430 kid = kUNOP->op_first; /* get past null */
7431 if (kid->op_type != OP_SCOPE)
7433 kid = kLISTOP->op_last; /* get past scope */
7434 switch(kid->op_type) {
7442 k = kid; /* remember this node*/
7443 if (kBINOP->op_first->op_type != OP_RV2SV)
7445 kid = kBINOP->op_first; /* get past cmp */
7446 if (kUNOP->op_first->op_type != OP_GV)
7448 kid = kUNOP->op_first; /* get past rv2sv */
7450 if (GvSTASH(gv) != PL_curstash)
7452 gvname = GvNAME(gv);
7453 if (*gvname == 'a' && gvname[1] == '\0')
7455 else if (*gvname == 'b' && gvname[1] == '\0')
7460 kid = k; /* back to cmp */
7461 if (kBINOP->op_last->op_type != OP_RV2SV)
7463 kid = kBINOP->op_last; /* down to 2nd arg */
7464 if (kUNOP->op_first->op_type != OP_GV)
7466 kid = kUNOP->op_first; /* get past rv2sv */
7468 if (GvSTASH(gv) != PL_curstash)
7470 gvname = GvNAME(gv);
7472 ? !(*gvname == 'a' && gvname[1] == '\0')
7473 : !(*gvname == 'b' && gvname[1] == '\0'))
7475 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
7477 o->op_private |= OPpSORT_DESCEND;
7478 if (k->op_type == OP_NCMP)
7479 o->op_private |= OPpSORT_NUMERIC;
7480 if (k->op_type == OP_I_NCMP)
7481 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
7482 kid = cLISTOPo->op_first->op_sibling;
7483 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
7485 op_getmad(kid,o,'S'); /* then delete it */
7487 op_free(kid); /* then delete it */
7492 Perl_ck_split(pTHX_ OP *o)
7497 if (o->op_flags & OPf_STACKED)
7498 return no_fh_allowed(o);
7500 kid = cLISTOPo->op_first;
7501 if (kid->op_type != OP_NULL)
7502 Perl_croak(aTHX_ "panic: ck_split");
7503 kid = kid->op_sibling;
7504 op_free(cLISTOPo->op_first);
7505 cLISTOPo->op_first = kid;
7507 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
7508 cLISTOPo->op_last = kid; /* There was only one element previously */
7511 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
7512 OP * const sibl = kid->op_sibling;
7513 kid->op_sibling = 0;
7514 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
7515 if (cLISTOPo->op_first == cLISTOPo->op_last)
7516 cLISTOPo->op_last = kid;
7517 cLISTOPo->op_first = kid;
7518 kid->op_sibling = sibl;
7521 kid->op_type = OP_PUSHRE;
7522 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
7524 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
7525 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
7526 "Use of /g modifier is meaningless in split");
7529 if (!kid->op_sibling)
7530 append_elem(OP_SPLIT, o, newDEFSVOP());
7532 kid = kid->op_sibling;
7535 if (!kid->op_sibling)
7536 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
7537 assert(kid->op_sibling);
7539 kid = kid->op_sibling;
7542 if (kid->op_sibling)
7543 return too_many_arguments(o,OP_DESC(o));
7549 Perl_ck_join(pTHX_ OP *o)
7551 const OP * const kid = cLISTOPo->op_first->op_sibling;
7552 if (kid && kid->op_type == OP_MATCH) {
7553 if (ckWARN(WARN_SYNTAX)) {
7554 const REGEXP *re = PM_GETRE(kPMOP);
7555 const char *pmstr = re ? re->precomp : "STRING";
7556 const STRLEN len = re ? re->prelen : 6;
7557 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7558 "/%.*s/ should probably be written as \"%.*s\"",
7559 (int)len, pmstr, (int)len, pmstr);
7566 Perl_ck_subr(pTHX_ OP *o)
7569 OP *prev = ((cUNOPo->op_first->op_sibling)
7570 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
7571 OP *o2 = prev->op_sibling;
7573 const char *proto = NULL;
7574 const char *proto_end = NULL;
7579 I32 contextclass = 0;
7580 const char *e = NULL;
7583 o->op_private |= OPpENTERSUB_HASTARG;
7584 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
7585 if (cvop->op_type == OP_RV2CV) {
7587 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
7588 op_null(cvop); /* disable rv2cv */
7589 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
7590 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
7591 GV *gv = cGVOPx_gv(tmpop);
7594 tmpop->op_private |= OPpEARLY_CV;
7598 namegv = CvANON(cv) ? gv : CvGV(cv);
7599 proto = SvPV((SV*)cv, len);
7600 proto_end = proto + len;
7605 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7606 if (o2->op_type == OP_CONST)
7607 o2->op_private &= ~OPpCONST_STRICT;
7608 else if (o2->op_type == OP_LIST) {
7609 OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
7610 if (sib && sib->op_type == OP_CONST)
7611 sib->op_private &= ~OPpCONST_STRICT;
7614 o->op_private |= (PL_hints & HINT_STRICT_REFS);
7615 if (PERLDB_SUB && PL_curstash != PL_debstash)
7616 o->op_private |= OPpENTERSUB_DB;
7617 while (o2 != cvop) {
7619 if (PL_madskills && o2->op_type == OP_STUB) {
7620 o2 = o2->op_sibling;
7623 if (PL_madskills && o2->op_type == OP_NULL)
7624 o3 = ((UNOP*)o2)->op_first;
7628 if (proto >= proto_end)
7629 return too_many_arguments(o, gv_ename(namegv));
7637 /* _ must be at the end */
7638 if (proto[1] && proto[1] != ';')
7653 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
7655 arg == 1 ? "block or sub {}" : "sub {}",
7656 gv_ename(namegv), o3);
7659 /* '*' allows any scalar type, including bareword */
7662 if (o3->op_type == OP_RV2GV)
7663 goto wrapref; /* autoconvert GLOB -> GLOBref */
7664 else if (o3->op_type == OP_CONST)
7665 o3->op_private &= ~OPpCONST_STRICT;
7666 else if (o3->op_type == OP_ENTERSUB) {
7667 /* accidental subroutine, revert to bareword */
7668 OP *gvop = ((UNOP*)o3)->op_first;
7669 if (gvop && gvop->op_type == OP_NULL) {
7670 gvop = ((UNOP*)gvop)->op_first;
7672 for (; gvop->op_sibling; gvop = gvop->op_sibling)
7675 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
7676 (gvop = ((UNOP*)gvop)->op_first) &&
7677 gvop->op_type == OP_GV)
7679 GV * const gv = cGVOPx_gv(gvop);
7680 OP * const sibling = o2->op_sibling;
7681 SV * const n = newSVpvs("");
7683 OP * const oldo2 = o2;
7687 gv_fullname4(n, gv, "", FALSE);
7688 o2 = newSVOP(OP_CONST, 0, n);
7689 op_getmad(oldo2,o2,'O');
7690 prev->op_sibling = o2;
7691 o2->op_sibling = sibling;
7707 if (contextclass++ == 0) {
7708 e = strchr(proto, ']');
7709 if (!e || e == proto)
7718 const char *p = proto;
7719 const char *const end = proto;
7721 while (*--p != '[');
7722 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
7724 gv_ename(namegv), o3);
7729 if (o3->op_type == OP_RV2GV)
7732 bad_type(arg, "symbol", gv_ename(namegv), o3);
7735 if (o3->op_type == OP_ENTERSUB)
7738 bad_type(arg, "subroutine entry", gv_ename(namegv),
7742 if (o3->op_type == OP_RV2SV ||
7743 o3->op_type == OP_PADSV ||
7744 o3->op_type == OP_HELEM ||
7745 o3->op_type == OP_AELEM)
7748 bad_type(arg, "scalar", gv_ename(namegv), o3);
7751 if (o3->op_type == OP_RV2AV ||
7752 o3->op_type == OP_PADAV)
7755 bad_type(arg, "array", gv_ename(namegv), o3);
7758 if (o3->op_type == OP_RV2HV ||
7759 o3->op_type == OP_PADHV)
7762 bad_type(arg, "hash", gv_ename(namegv), o3);
7767 OP* const sib = kid->op_sibling;
7768 kid->op_sibling = 0;
7769 o2 = newUNOP(OP_REFGEN, 0, kid);
7770 o2->op_sibling = sib;
7771 prev->op_sibling = o2;
7773 if (contextclass && e) {
7788 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
7789 gv_ename(namegv), SVfARG(cv));
7794 mod(o2, OP_ENTERSUB);
7796 o2 = o2->op_sibling;
7798 if (o2 == cvop && proto && *proto == '_') {
7799 /* generate an access to $_ */
7801 o2->op_sibling = prev->op_sibling;
7802 prev->op_sibling = o2; /* instead of cvop */
7804 if (proto && !optional && proto_end > proto &&
7805 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
7806 return too_few_arguments(o, gv_ename(namegv));
7809 OP * const oldo = o;
7813 o=newSVOP(OP_CONST, 0, newSViv(0));
7814 op_getmad(oldo,o,'O');
7820 Perl_ck_svconst(pTHX_ OP *o)
7822 PERL_UNUSED_CONTEXT;
7823 SvREADONLY_on(cSVOPo->op_sv);
7828 Perl_ck_chdir(pTHX_ OP *o)
7830 if (o->op_flags & OPf_KIDS) {
7831 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7833 if (kid && kid->op_type == OP_CONST &&
7834 (kid->op_private & OPpCONST_BARE))
7836 o->op_flags |= OPf_SPECIAL;
7837 kid->op_private &= ~OPpCONST_STRICT;
7844 Perl_ck_trunc(pTHX_ OP *o)
7846 if (o->op_flags & OPf_KIDS) {
7847 SVOP *kid = (SVOP*)cUNOPo->op_first;
7849 if (kid->op_type == OP_NULL)
7850 kid = (SVOP*)kid->op_sibling;
7851 if (kid && kid->op_type == OP_CONST &&
7852 (kid->op_private & OPpCONST_BARE))
7854 o->op_flags |= OPf_SPECIAL;
7855 kid->op_private &= ~OPpCONST_STRICT;
7862 Perl_ck_unpack(pTHX_ OP *o)
7864 OP *kid = cLISTOPo->op_first;
7865 if (kid->op_sibling) {
7866 kid = kid->op_sibling;
7867 if (!kid->op_sibling)
7868 kid->op_sibling = newDEFSVOP();
7874 Perl_ck_substr(pTHX_ OP *o)
7877 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
7878 OP *kid = cLISTOPo->op_first;
7880 if (kid->op_type == OP_NULL)
7881 kid = kid->op_sibling;
7883 kid->op_flags |= OPf_MOD;
7889 /* A peephole optimizer. We visit the ops in the order they're to execute.
7890 * See the comments at the top of this file for more details about when
7891 * peep() is called */
7894 Perl_peep(pTHX_ register OP *o)
7897 register OP* oldop = NULL;
7899 if (!o || o->op_opt)
7903 SAVEVPTR(PL_curcop);
7904 for (; o; o = o->op_next) {
7907 /* By default, this op has now been optimised. A couple of cases below
7908 clear this again. */
7911 switch (o->op_type) {
7915 PL_curcop = ((COP*)o); /* for warnings */
7919 if (cSVOPo->op_private & OPpCONST_STRICT)
7920 no_bareword_allowed(o);
7922 case OP_METHOD_NAMED:
7923 /* Relocate sv to the pad for thread safety.
7924 * Despite being a "constant", the SV is written to,
7925 * for reference counts, sv_upgrade() etc. */
7927 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
7928 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
7929 /* If op_sv is already a PADTMP then it is being used by
7930 * some pad, so make a copy. */
7931 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
7932 SvREADONLY_on(PAD_SVl(ix));
7933 SvREFCNT_dec(cSVOPo->op_sv);
7935 else if (o->op_type == OP_CONST
7936 && cSVOPo->op_sv == &PL_sv_undef) {
7937 /* PL_sv_undef is hack - it's unsafe to store it in the
7938 AV that is the pad, because av_fetch treats values of
7939 PL_sv_undef as a "free" AV entry and will merrily
7940 replace them with a new SV, causing pad_alloc to think
7941 that this pad slot is free. (When, clearly, it is not)
7943 SvOK_off(PAD_SVl(ix));
7944 SvPADTMP_on(PAD_SVl(ix));
7945 SvREADONLY_on(PAD_SVl(ix));
7948 SvREFCNT_dec(PAD_SVl(ix));
7949 SvPADTMP_on(cSVOPo->op_sv);
7950 PAD_SETSV(ix, cSVOPo->op_sv);
7951 /* XXX I don't know how this isn't readonly already. */
7952 SvREADONLY_on(PAD_SVl(ix));
7954 cSVOPo->op_sv = NULL;
7961 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
7962 if (o->op_next->op_private & OPpTARGET_MY) {
7963 if (o->op_flags & OPf_STACKED) /* chained concats */
7964 break; /* ignore_optimization */
7966 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
7967 o->op_targ = o->op_next->op_targ;
7968 o->op_next->op_targ = 0;
7969 o->op_private |= OPpTARGET_MY;
7972 op_null(o->op_next);
7976 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
7977 break; /* Scalar stub must produce undef. List stub is noop */
7981 if (o->op_targ == OP_NEXTSTATE
7982 || o->op_targ == OP_DBSTATE
7983 || o->op_targ == OP_SETSTATE)
7985 PL_curcop = ((COP*)o);
7987 /* XXX: We avoid setting op_seq here to prevent later calls
7988 to peep() from mistakenly concluding that optimisation
7989 has already occurred. This doesn't fix the real problem,
7990 though (See 20010220.007). AMS 20010719 */
7991 /* op_seq functionality is now replaced by op_opt */
7998 if (oldop && o->op_next) {
7999 oldop->op_next = o->op_next;
8007 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
8008 OP* const pop = (o->op_type == OP_PADAV) ?
8009 o->op_next : o->op_next->op_next;
8011 if (pop && pop->op_type == OP_CONST &&
8012 ((PL_op = pop->op_next)) &&
8013 pop->op_next->op_type == OP_AELEM &&
8014 !(pop->op_next->op_private &
8015 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
8016 (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
8021 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
8022 no_bareword_allowed(pop);
8023 if (o->op_type == OP_GV)
8024 op_null(o->op_next);
8025 op_null(pop->op_next);
8027 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
8028 o->op_next = pop->op_next->op_next;
8029 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
8030 o->op_private = (U8)i;
8031 if (o->op_type == OP_GV) {
8036 o->op_flags |= OPf_SPECIAL;
8037 o->op_type = OP_AELEMFAST;
8042 if (o->op_next->op_type == OP_RV2SV) {
8043 if (!(o->op_next->op_private & OPpDEREF)) {
8044 op_null(o->op_next);
8045 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
8047 o->op_next = o->op_next->op_next;
8048 o->op_type = OP_GVSV;
8049 o->op_ppaddr = PL_ppaddr[OP_GVSV];
8052 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
8053 GV * const gv = cGVOPo_gv;
8054 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
8055 /* XXX could check prototype here instead of just carping */
8056 SV * const sv = sv_newmortal();
8057 gv_efullname3(sv, gv, NULL);
8058 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
8059 "%"SVf"() called too early to check prototype",
8063 else if (o->op_next->op_type == OP_READLINE
8064 && o->op_next->op_next->op_type == OP_CONCAT
8065 && (o->op_next->op_next->op_flags & OPf_STACKED))
8067 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
8068 o->op_type = OP_RCATLINE;
8069 o->op_flags |= OPf_STACKED;
8070 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
8071 op_null(o->op_next->op_next);
8072 op_null(o->op_next);
8088 while (cLOGOP->op_other->op_type == OP_NULL)
8089 cLOGOP->op_other = cLOGOP->op_other->op_next;
8090 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
8095 while (cLOOP->op_redoop->op_type == OP_NULL)
8096 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
8097 peep(cLOOP->op_redoop);
8098 while (cLOOP->op_nextop->op_type == OP_NULL)
8099 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
8100 peep(cLOOP->op_nextop);
8101 while (cLOOP->op_lastop->op_type == OP_NULL)
8102 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
8103 peep(cLOOP->op_lastop);
8107 assert(!(cPMOP->op_pmflags & PMf_ONCE));
8108 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
8109 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
8110 cPMOP->op_pmstashstartu.op_pmreplstart
8111 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
8112 peep(cPMOP->op_pmstashstartu.op_pmreplstart);
8116 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
8117 && ckWARN(WARN_SYNTAX))
8119 if (o->op_next->op_sibling) {
8120 const OPCODE type = o->op_next->op_sibling->op_type;
8121 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
8122 const line_t oldline = CopLINE(PL_curcop);
8123 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
8124 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8125 "Statement unlikely to be reached");
8126 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8127 "\t(Maybe you meant system() when you said exec()?)\n");
8128 CopLINE_set(PL_curcop, oldline);
8139 const char *key = NULL;
8142 if (((BINOP*)o)->op_last->op_type != OP_CONST)
8145 /* Make the CONST have a shared SV */
8146 svp = cSVOPx_svp(((BINOP*)o)->op_last);
8147 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
8148 key = SvPV_const(sv, keylen);
8149 lexname = newSVpvn_share(key,
8150 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
8156 if ((o->op_private & (OPpLVAL_INTRO)))
8159 rop = (UNOP*)((BINOP*)o)->op_first;
8160 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
8162 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
8163 if (!SvPAD_TYPED(lexname))
8165 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8166 if (!fields || !GvHV(*fields))
8168 key = SvPV_const(*svp, keylen);
8169 if (!hv_fetch(GvHV(*fields), key,
8170 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8172 Perl_croak(aTHX_ "No such class field \"%s\" "
8173 "in variable %s of type %s",
8174 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
8187 SVOP *first_key_op, *key_op;
8189 if ((o->op_private & (OPpLVAL_INTRO))
8190 /* I bet there's always a pushmark... */
8191 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
8192 /* hmmm, no optimization if list contains only one key. */
8194 rop = (UNOP*)((LISTOP*)o)->op_last;
8195 if (rop->op_type != OP_RV2HV)
8197 if (rop->op_first->op_type == OP_PADSV)
8198 /* @$hash{qw(keys here)} */
8199 rop = (UNOP*)rop->op_first;
8201 /* @{$hash}{qw(keys here)} */
8202 if (rop->op_first->op_type == OP_SCOPE
8203 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
8205 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
8211 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
8212 if (!SvPAD_TYPED(lexname))
8214 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8215 if (!fields || !GvHV(*fields))
8217 /* Again guessing that the pushmark can be jumped over.... */
8218 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
8219 ->op_first->op_sibling;
8220 for (key_op = first_key_op; key_op;
8221 key_op = (SVOP*)key_op->op_sibling) {
8222 if (key_op->op_type != OP_CONST)
8224 svp = cSVOPx_svp(key_op);
8225 key = SvPV_const(*svp, keylen);
8226 if (!hv_fetch(GvHV(*fields), key,
8227 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8229 Perl_croak(aTHX_ "No such class field \"%s\" "
8230 "in variable %s of type %s",
8231 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
8238 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
8242 /* check that RHS of sort is a single plain array */
8243 OP *oright = cUNOPo->op_first;
8244 if (!oright || oright->op_type != OP_PUSHMARK)
8247 /* reverse sort ... can be optimised. */
8248 if (!cUNOPo->op_sibling) {
8249 /* Nothing follows us on the list. */
8250 OP * const reverse = o->op_next;
8252 if (reverse->op_type == OP_REVERSE &&
8253 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
8254 OP * const pushmark = cUNOPx(reverse)->op_first;
8255 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
8256 && (cUNOPx(pushmark)->op_sibling == o)) {
8257 /* reverse -> pushmark -> sort */
8258 o->op_private |= OPpSORT_REVERSE;
8260 pushmark->op_next = oright->op_next;
8266 /* make @a = sort @a act in-place */
8268 oright = cUNOPx(oright)->op_sibling;
8271 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
8272 oright = cUNOPx(oright)->op_sibling;
8276 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
8277 || oright->op_next != o
8278 || (oright->op_private & OPpLVAL_INTRO)
8282 /* o2 follows the chain of op_nexts through the LHS of the
8283 * assign (if any) to the aassign op itself */
8285 if (!o2 || o2->op_type != OP_NULL)
8288 if (!o2 || o2->op_type != OP_PUSHMARK)
8291 if (o2 && o2->op_type == OP_GV)
8294 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
8295 || (o2->op_private & OPpLVAL_INTRO)
8300 if (!o2 || o2->op_type != OP_NULL)
8303 if (!o2 || o2->op_type != OP_AASSIGN
8304 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
8307 /* check that the sort is the first arg on RHS of assign */
8309 o2 = cUNOPx(o2)->op_first;
8310 if (!o2 || o2->op_type != OP_NULL)
8312 o2 = cUNOPx(o2)->op_first;
8313 if (!o2 || o2->op_type != OP_PUSHMARK)
8315 if (o2->op_sibling != o)
8318 /* check the array is the same on both sides */
8319 if (oleft->op_type == OP_RV2AV) {
8320 if (oright->op_type != OP_RV2AV
8321 || !cUNOPx(oright)->op_first
8322 || cUNOPx(oright)->op_first->op_type != OP_GV
8323 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
8324 cGVOPx_gv(cUNOPx(oright)->op_first)
8328 else if (oright->op_type != OP_PADAV
8329 || oright->op_targ != oleft->op_targ
8333 /* transfer MODishness etc from LHS arg to RHS arg */
8334 oright->op_flags = oleft->op_flags;
8335 o->op_private |= OPpSORT_INPLACE;
8337 /* excise push->gv->rv2av->null->aassign */
8338 o2 = o->op_next->op_next;
8339 op_null(o2); /* PUSHMARK */
8341 if (o2->op_type == OP_GV) {
8342 op_null(o2); /* GV */
8345 op_null(o2); /* RV2AV or PADAV */
8346 o2 = o2->op_next->op_next;
8347 op_null(o2); /* AASSIGN */
8349 o->op_next = o2->op_next;
8355 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
8357 LISTOP *enter, *exlist;
8359 enter = (LISTOP *) o->op_next;
8362 if (enter->op_type == OP_NULL) {
8363 enter = (LISTOP *) enter->op_next;
8367 /* for $a (...) will have OP_GV then OP_RV2GV here.
8368 for (...) just has an OP_GV. */
8369 if (enter->op_type == OP_GV) {
8370 gvop = (OP *) enter;
8371 enter = (LISTOP *) enter->op_next;
8374 if (enter->op_type == OP_RV2GV) {
8375 enter = (LISTOP *) enter->op_next;
8381 if (enter->op_type != OP_ENTERITER)
8384 iter = enter->op_next;
8385 if (!iter || iter->op_type != OP_ITER)
8388 expushmark = enter->op_first;
8389 if (!expushmark || expushmark->op_type != OP_NULL
8390 || expushmark->op_targ != OP_PUSHMARK)
8393 exlist = (LISTOP *) expushmark->op_sibling;
8394 if (!exlist || exlist->op_type != OP_NULL
8395 || exlist->op_targ != OP_LIST)
8398 if (exlist->op_last != o) {
8399 /* Mmm. Was expecting to point back to this op. */
8402 theirmark = exlist->op_first;
8403 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
8406 if (theirmark->op_sibling != o) {
8407 /* There's something between the mark and the reverse, eg
8408 for (1, reverse (...))
8413 ourmark = ((LISTOP *)o)->op_first;
8414 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
8417 ourlast = ((LISTOP *)o)->op_last;
8418 if (!ourlast || ourlast->op_next != o)
8421 rv2av = ourmark->op_sibling;
8422 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
8423 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
8424 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
8425 /* We're just reversing a single array. */
8426 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
8427 enter->op_flags |= OPf_STACKED;
8430 /* We don't have control over who points to theirmark, so sacrifice
8432 theirmark->op_next = ourmark->op_next;
8433 theirmark->op_flags = ourmark->op_flags;
8434 ourlast->op_next = gvop ? gvop : (OP *) enter;
8437 enter->op_private |= OPpITER_REVERSED;
8438 iter->op_private |= OPpITER_REVERSED;
8445 UNOP *refgen, *rv2cv;
8448 if ((o->op_flags && OPf_WANT) != OPf_WANT_VOID)
8451 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
8454 rv2gv = ((BINOP *)o)->op_last;
8455 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
8458 refgen = (UNOP *)((BINOP *)o)->op_first;
8460 if (!refgen || refgen->op_type != OP_REFGEN)
8463 exlist = (LISTOP *)refgen->op_first;
8464 if (!exlist || exlist->op_type != OP_NULL
8465 || exlist->op_targ != OP_LIST)
8468 if (exlist->op_first->op_type != OP_PUSHMARK)
8471 rv2cv = (UNOP*)exlist->op_last;
8473 if (rv2cv->op_type != OP_RV2CV)
8476 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
8477 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
8478 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
8480 o->op_private |= OPpASSIGN_CV_TO_GV;
8481 rv2gv->op_private |= OPpDONT_INIT_GV;
8482 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
8490 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
8491 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
8501 Perl_custom_op_name(pTHX_ const OP* o)
8504 const IV index = PTR2IV(o->op_ppaddr);
8508 if (!PL_custom_op_names) /* This probably shouldn't happen */
8509 return (char *)PL_op_name[OP_CUSTOM];
8511 keysv = sv_2mortal(newSViv(index));
8513 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
8515 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
8517 return SvPV_nolen(HeVAL(he));
8521 Perl_custom_op_desc(pTHX_ const OP* o)
8524 const IV index = PTR2IV(o->op_ppaddr);
8528 if (!PL_custom_op_descs)
8529 return (char *)PL_op_desc[OP_CUSTOM];
8531 keysv = sv_2mortal(newSViv(index));
8533 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
8535 return (char *)PL_op_desc[OP_CUSTOM];
8537 return SvPV_nolen(HeVAL(he));
8542 /* Efficient sub that returns a constant scalar value. */
8544 const_sv_xsub(pTHX_ CV* cv)
8551 Perl_croak(aTHX_ "usage: %s::%s()",
8552 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
8556 ST(0) = (SV*)XSANY.any_ptr;
8562 * c-indentation-style: bsd
8564 * indent-tabs-mode: t
8567 * ex: set ts=8 sts=4 sw=4 noet: