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 o->op_flags & OPf_KIDS
4943 && looks_like_bool(cUNOPo->op_first));
4947 case OP_NOT: case OP_XOR:
4948 /* Note that OP_DOR is not here */
4950 case OP_EQ: case OP_NE: case OP_LT:
4951 case OP_GT: case OP_LE: case OP_GE:
4953 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
4954 case OP_I_GT: case OP_I_LE: case OP_I_GE:
4956 case OP_SEQ: case OP_SNE: case OP_SLT:
4957 case OP_SGT: case OP_SLE: case OP_SGE:
4961 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
4962 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
4963 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
4964 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
4965 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
4966 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
4967 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
4968 case OP_FTTEXT: case OP_FTBINARY:
4970 case OP_DEFINED: case OP_EXISTS:
4971 case OP_MATCH: case OP_EOF:
4976 /* Detect comparisons that have been optimized away */
4977 if (cSVOPo->op_sv == &PL_sv_yes
4978 || cSVOPo->op_sv == &PL_sv_no)
4989 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
4993 return newGIVWHENOP(
4994 ref_array_or_hash(cond),
4996 OP_ENTERGIVEN, OP_LEAVEGIVEN,
5000 /* If cond is null, this is a default {} block */
5002 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
5004 const bool cond_llb = (!cond || looks_like_bool(cond));
5010 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
5012 scalar(ref_array_or_hash(cond)));
5015 return newGIVWHENOP(
5017 append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
5018 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
5022 =for apidoc cv_undef
5024 Clear out all the active components of a CV. This can happen either
5025 by an explicit C<undef &foo>, or by the reference count going to zero.
5026 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
5027 children can still follow the full lexical scope chain.
5033 Perl_cv_undef(pTHX_ CV *cv)
5037 DEBUG_X(PerlIO_printf(Perl_debug_log,
5038 "CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n",
5039 PTR2UV(cv), PTR2UV(PL_comppad))
5043 if (CvFILE(cv) && !CvISXSUB(cv)) {
5044 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
5045 Safefree(CvFILE(cv));
5050 if (!CvISXSUB(cv) && CvROOT(cv)) {
5051 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
5052 Perl_croak(aTHX_ "Can't undef active subroutine");
5055 PAD_SAVE_SETNULLPAD();
5057 op_free(CvROOT(cv));
5062 SvPOK_off((SV*)cv); /* forget prototype */
5067 /* remove CvOUTSIDE unless this is an undef rather than a free */
5068 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
5069 if (!CvWEAKOUTSIDE(cv))
5070 SvREFCNT_dec(CvOUTSIDE(cv));
5071 CvOUTSIDE(cv) = NULL;
5074 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
5077 if (CvISXSUB(cv) && CvXSUB(cv)) {
5080 /* delete all flags except WEAKOUTSIDE */
5081 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
5085 Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
5088 /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
5089 relying on SvCUR, and doubling up the buffer to hold CvFILE(). */
5090 if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
5091 || (p && (len != SvCUR(cv) /* Not the same length. */
5092 || memNE(p, SvPVX_const(cv), len))))
5093 && ckWARN_d(WARN_PROTOTYPE)) {
5094 SV* const msg = sv_newmortal();
5098 gv_efullname3(name = sv_newmortal(), gv, NULL);
5099 sv_setpvs(msg, "Prototype mismatch:");
5101 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
5103 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv));
5105 sv_catpvs(msg, ": none");
5106 sv_catpvs(msg, " vs ");
5108 Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
5110 sv_catpvs(msg, "none");
5111 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
5115 static void const_sv_xsub(pTHX_ CV* cv);
5119 =head1 Optree Manipulation Functions
5121 =for apidoc cv_const_sv
5123 If C<cv> is a constant sub eligible for inlining. returns the constant
5124 value returned by the sub. Otherwise, returns NULL.
5126 Constant subs can be created with C<newCONSTSUB> or as described in
5127 L<perlsub/"Constant Functions">.
5132 Perl_cv_const_sv(pTHX_ CV *cv)
5134 PERL_UNUSED_CONTEXT;
5137 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
5139 return CvCONST(cv) ? (SV*)CvXSUBANY(cv).any_ptr : NULL;
5142 /* op_const_sv: examine an optree to determine whether it's in-lineable.
5143 * Can be called in 3 ways:
5146 * look for a single OP_CONST with attached value: return the value
5148 * cv && CvCLONE(cv) && !CvCONST(cv)
5150 * examine the clone prototype, and if contains only a single
5151 * OP_CONST referencing a pad const, or a single PADSV referencing
5152 * an outer lexical, return a non-zero value to indicate the CV is
5153 * a candidate for "constizing" at clone time
5157 * We have just cloned an anon prototype that was marked as a const
5158 * candidiate. Try to grab the current value, and in the case of
5159 * PADSV, ignore it if it has multiple references. Return the value.
5163 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
5174 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
5175 o = cLISTOPo->op_first->op_sibling;
5177 for (; o; o = o->op_next) {
5178 const OPCODE type = o->op_type;
5180 if (sv && o->op_next == o)
5182 if (o->op_next != o) {
5183 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
5185 if (type == OP_DBSTATE)
5188 if (type == OP_LEAVESUB || type == OP_RETURN)
5192 if (type == OP_CONST && cSVOPo->op_sv)
5194 else if (cv && type == OP_CONST) {
5195 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5199 else if (cv && type == OP_PADSV) {
5200 if (CvCONST(cv)) { /* newly cloned anon */
5201 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5202 /* the candidate should have 1 ref from this pad and 1 ref
5203 * from the parent */
5204 if (!sv || SvREFCNT(sv) != 2)
5211 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
5212 sv = &PL_sv_undef; /* an arbitrary non-null value */
5227 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5230 /* This would be the return value, but the return cannot be reached. */
5231 OP* pegop = newOP(OP_NULL, 0);
5234 PERL_UNUSED_ARG(floor);
5244 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
5246 NORETURN_FUNCTION_END;
5251 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
5253 return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
5257 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5264 register CV *cv = NULL;
5266 /* If the subroutine has no body, no attributes, and no builtin attributes
5267 then it's just a sub declaration, and we may be able to get away with
5268 storing with a placeholder scalar in the symbol table, rather than a
5269 full GV and CV. If anything is present then it will take a full CV to
5271 const I32 gv_fetch_flags
5272 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5274 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
5275 const char * const name = o ? SvPV_nolen_const(cSVOPo->op_sv) : NULL;
5278 assert(proto->op_type == OP_CONST);
5279 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
5284 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
5285 SV * const sv = sv_newmortal();
5286 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
5287 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
5288 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
5289 aname = SvPVX_const(sv);
5294 gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
5295 : gv_fetchpv(aname ? aname
5296 : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5297 gv_fetch_flags, SVt_PVCV);
5299 if (!PL_madskills) {
5308 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
5309 maximum a prototype before. */
5310 if (SvTYPE(gv) > SVt_NULL) {
5311 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
5312 && ckWARN_d(WARN_PROTOTYPE))
5314 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
5316 cv_ckproto_len((CV*)gv, NULL, ps, ps_len);
5319 sv_setpvn((SV*)gv, ps, ps_len);
5321 sv_setiv((SV*)gv, -1);
5323 SvREFCNT_dec(PL_compcv);
5324 cv = PL_compcv = NULL;
5328 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
5330 #ifdef GV_UNIQUE_CHECK
5331 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
5332 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
5336 if (!block || !ps || *ps || attrs
5337 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5339 || block->op_type == OP_NULL
5344 const_sv = op_const_sv(block, NULL);
5347 const bool exists = CvROOT(cv) || CvXSUB(cv);
5349 #ifdef GV_UNIQUE_CHECK
5350 if (exists && GvUNIQUE(gv)) {
5351 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
5355 /* if the subroutine doesn't exist and wasn't pre-declared
5356 * with a prototype, assume it will be AUTOLOADed,
5357 * skipping the prototype check
5359 if (exists || SvPOK(cv))
5360 cv_ckproto_len(cv, gv, ps, ps_len);
5361 /* already defined (or promised)? */
5362 if (exists || GvASSUMECV(gv)) {
5365 || block->op_type == OP_NULL
5368 if (CvFLAGS(PL_compcv)) {
5369 /* might have had built-in attrs applied */
5370 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5372 /* just a "sub foo;" when &foo is already defined */
5373 SAVEFREESV(PL_compcv);
5378 && block->op_type != OP_NULL
5381 if (ckWARN(WARN_REDEFINE)
5383 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
5385 const line_t oldline = CopLINE(PL_curcop);
5386 if (PL_parser && PL_parser->copline != NOLINE)
5387 CopLINE_set(PL_curcop, PL_parser->copline);
5388 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5389 CvCONST(cv) ? "Constant subroutine %s redefined"
5390 : "Subroutine %s redefined", name);
5391 CopLINE_set(PL_curcop, oldline);
5394 if (!PL_minus_c) /* keep old one around for madskills */
5397 /* (PL_madskills unset in used file.) */
5405 SvREFCNT_inc_simple_void_NN(const_sv);
5407 assert(!CvROOT(cv) && !CvCONST(cv));
5408 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
5409 CvXSUBANY(cv).any_ptr = const_sv;
5410 CvXSUB(cv) = const_sv_xsub;
5416 cv = newCONSTSUB(NULL, name, const_sv);
5418 mro_method_changed_in( /* sub Foo::Bar () { 123 } */
5419 (CvGV(cv) && GvSTASH(CvGV(cv)))
5428 SvREFCNT_dec(PL_compcv);
5436 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
5437 * before we clobber PL_compcv.
5441 || block->op_type == OP_NULL
5445 /* Might have had built-in attributes applied -- propagate them. */
5446 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5447 if (CvGV(cv) && GvSTASH(CvGV(cv)))
5448 stash = GvSTASH(CvGV(cv));
5449 else if (CvSTASH(cv))
5450 stash = CvSTASH(cv);
5452 stash = PL_curstash;
5455 /* possibly about to re-define existing subr -- ignore old cv */
5456 rcv = (SV*)PL_compcv;
5457 if (name && GvSTASH(gv))
5458 stash = GvSTASH(gv);
5460 stash = PL_curstash;
5462 apply_attrs(stash, rcv, attrs, FALSE);
5464 if (cv) { /* must reuse cv if autoloaded */
5471 || block->op_type == OP_NULL) && !PL_madskills
5474 /* got here with just attrs -- work done, so bug out */
5475 SAVEFREESV(PL_compcv);
5478 /* transfer PL_compcv to cv */
5480 CvFLAGS(cv) = CvFLAGS(PL_compcv);
5481 if (!CvWEAKOUTSIDE(cv))
5482 SvREFCNT_dec(CvOUTSIDE(cv));
5483 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
5484 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
5485 CvOUTSIDE(PL_compcv) = 0;
5486 CvPADLIST(cv) = CvPADLIST(PL_compcv);
5487 CvPADLIST(PL_compcv) = 0;
5488 /* inner references to PL_compcv must be fixed up ... */
5489 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
5490 /* ... before we throw it away */
5491 SvREFCNT_dec(PL_compcv);
5493 if (PERLDB_INTER)/* Advice debugger on the new sub. */
5494 ++PL_sub_generation;
5501 if (strEQ(name, "import")) {
5502 PL_formfeed = (SV*)cv;
5503 Perl_warner(aTHX_ packWARN(WARN_VOID), "%lx\n", (long)cv);
5507 mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */
5511 CvFILE_set_from_cop(cv, PL_curcop);
5512 CvSTASH(cv) = PL_curstash;
5515 sv_setpvn((SV*)cv, ps, ps_len);
5517 if (PL_parser && PL_parser->error_count) {
5521 const char *s = strrchr(name, ':');
5523 if (strEQ(s, "BEGIN")) {
5524 const char not_safe[] =
5525 "BEGIN not safe after errors--compilation aborted";
5526 if (PL_in_eval & EVAL_KEEPERR)
5527 Perl_croak(aTHX_ not_safe);
5529 /* force display of errors found but not reported */
5530 sv_catpv(ERRSV, not_safe);
5531 Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
5541 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5542 mod(scalarseq(block), OP_LEAVESUBLV));
5543 block->op_attached = 1;
5546 /* This makes sub {}; work as expected. */
5547 if (block->op_type == OP_STUB) {
5548 OP* const newblock = newSTATEOP(0, NULL, 0);
5550 op_getmad(block,newblock,'B');
5557 block->op_attached = 1;
5558 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5560 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5561 OpREFCNT_set(CvROOT(cv), 1);
5562 CvSTART(cv) = LINKLIST(CvROOT(cv));
5563 CvROOT(cv)->op_next = 0;
5564 CALL_PEEP(CvSTART(cv));
5566 /* now that optimizer has done its work, adjust pad values */
5568 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
5571 assert(!CvCONST(cv));
5572 if (ps && !*ps && op_const_sv(block, cv))
5576 if (name || aname) {
5577 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5578 SV * const sv = newSV(0);
5579 SV * const tmpstr = sv_newmortal();
5580 GV * const db_postponed = gv_fetchpvs("DB::postponed",
5581 GV_ADDMULTI, SVt_PVHV);
5584 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5586 (long)PL_subline, (long)CopLINE(PL_curcop));
5587 gv_efullname3(tmpstr, gv, NULL);
5588 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
5589 SvCUR(tmpstr), sv, 0);
5590 hv = GvHVn(db_postponed);
5591 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
5592 CV * const pcv = GvCV(db_postponed);
5598 call_sv((SV*)pcv, G_DISCARD);
5603 if (name && ! (PL_parser && PL_parser->error_count))
5604 process_special_blocks(name, gv, cv);
5609 PL_parser->copline = NOLINE;
5615 S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
5618 const char *const colon = strrchr(fullname,':');
5619 const char *const name = colon ? colon + 1 : fullname;
5622 if (strEQ(name, "BEGIN")) {
5623 const I32 oldscope = PL_scopestack_ix;
5625 SAVECOPFILE(&PL_compiling);
5626 SAVECOPLINE(&PL_compiling);
5628 DEBUG_x( dump_sub(gv) );
5629 Perl_av_create_and_push(aTHX_ &PL_beginav, (SV*)cv);
5630 GvCV(gv) = 0; /* cv has been hijacked */
5631 call_list(oldscope, PL_beginav);
5633 PL_curcop = &PL_compiling;
5634 CopHINTS_set(&PL_compiling, PL_hints);
5641 if strEQ(name, "END") {
5642 DEBUG_x( dump_sub(gv) );
5643 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, (SV*)cv);
5646 } else if (*name == 'U') {
5647 if (strEQ(name, "UNITCHECK")) {
5648 /* It's never too late to run a unitcheck block */
5649 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, (SV*)cv);
5653 } else if (*name == 'C') {
5654 if (strEQ(name, "CHECK")) {
5655 if (PL_main_start && ckWARN(WARN_VOID))
5656 Perl_warner(aTHX_ packWARN(WARN_VOID),
5657 "Too late to run CHECK block");
5658 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, (SV*)cv);
5662 } else if (*name == 'I') {
5663 if (strEQ(name, "INIT")) {
5664 if (PL_main_start && ckWARN(WARN_VOID))
5665 Perl_warner(aTHX_ packWARN(WARN_VOID),
5666 "Too late to run INIT block");
5667 Perl_av_create_and_push(aTHX_ &PL_initav, (SV*)cv);
5673 DEBUG_x( dump_sub(gv) );
5674 GvCV(gv) = 0; /* cv has been hijacked */
5679 =for apidoc newCONSTSUB
5681 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5682 eligible for inlining at compile-time.
5688 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
5693 const char *const temp_p = CopFILE(PL_curcop);
5694 const STRLEN len = temp_p ? strlen(temp_p) : 0;
5696 SV *const temp_sv = CopFILESV(PL_curcop);
5698 const char *const temp_p = temp_sv ? SvPV_const(temp_sv, len) : NULL;
5700 char *const file = savepvn(temp_p, temp_p ? len : 0);
5704 if (IN_PERL_RUNTIME) {
5705 /* at runtime, it's not safe to manipulate PL_curcop: it may be
5706 * an op shared between threads. Use a non-shared COP for our
5708 SAVEVPTR(PL_curcop);
5709 PL_curcop = &PL_compiling;
5711 SAVECOPLINE(PL_curcop);
5712 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
5715 PL_hints &= ~HINT_BLOCK_SCOPE;
5718 SAVESPTR(PL_curstash);
5719 SAVECOPSTASH(PL_curcop);
5720 PL_curstash = stash;
5721 CopSTASH_set(PL_curcop,stash);
5724 /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
5725 and so doesn't get free()d. (It's expected to be from the C pre-
5726 processor __FILE__ directive). But we need a dynamically allocated one,
5727 and we need it to get freed. */
5728 cv = newXS_flags(name, const_sv_xsub, file, "", XS_DYNAMIC_FILENAME);
5729 CvXSUBANY(cv).any_ptr = sv;
5735 CopSTASH_free(PL_curcop);
5743 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
5744 const char *const filename, const char *const proto,
5747 CV *cv = newXS(name, subaddr, filename);
5749 if (flags & XS_DYNAMIC_FILENAME) {
5750 /* We need to "make arrangements" (ie cheat) to ensure that the
5751 filename lasts as long as the PVCV we just created, but also doesn't
5753 STRLEN filename_len = strlen(filename);
5754 STRLEN proto_and_file_len = filename_len;
5755 char *proto_and_file;
5759 proto_len = strlen(proto);
5760 proto_and_file_len += proto_len;
5762 Newx(proto_and_file, proto_and_file_len + 1, char);
5763 Copy(proto, proto_and_file, proto_len, char);
5764 Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
5767 proto_and_file = savepvn(filename, filename_len);
5770 /* This gets free()d. :-) */
5771 sv_usepvn_flags((SV*)cv, proto_and_file, proto_and_file_len,
5772 SV_HAS_TRAILING_NUL);
5774 /* This gives us the correct prototype, rather than one with the
5775 file name appended. */
5776 SvCUR_set(cv, proto_len);
5780 CvFILE(cv) = proto_and_file + proto_len;
5782 sv_setpv((SV *)cv, proto);
5788 =for apidoc U||newXS
5790 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
5791 static storage, as it is used directly as CvFILE(), without a copy being made.
5797 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
5800 GV * const gv = gv_fetchpv(name ? name :
5801 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5802 GV_ADDMULTI, SVt_PVCV);
5806 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
5808 if ((cv = (name ? GvCV(gv) : NULL))) {
5810 /* just a cached method */
5814 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5815 /* already defined (or promised) */
5816 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
5817 if (ckWARN(WARN_REDEFINE)) {
5818 GV * const gvcv = CvGV(cv);
5820 HV * const stash = GvSTASH(gvcv);
5822 const char *redefined_name = HvNAME_get(stash);
5823 if ( strEQ(redefined_name,"autouse") ) {
5824 const line_t oldline = CopLINE(PL_curcop);
5825 if (PL_parser && PL_parser->copline != NOLINE)
5826 CopLINE_set(PL_curcop, PL_parser->copline);
5827 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5828 CvCONST(cv) ? "Constant subroutine %s redefined"
5829 : "Subroutine %s redefined"
5831 CopLINE_set(PL_curcop, oldline);
5841 if (cv) /* must reuse cv if autoloaded */
5844 cv = (CV*)newSV_type(SVt_PVCV);
5848 mro_method_changed_in(GvSTASH(gv)); /* newXS */
5852 (void)gv_fetchfile(filename);
5853 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
5854 an external constant string */
5856 CvXSUB(cv) = subaddr;
5859 process_special_blocks(name, gv, cv);
5871 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5876 OP* pegop = newOP(OP_NULL, 0);
5880 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
5881 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
5883 #ifdef GV_UNIQUE_CHECK
5885 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5889 if ((cv = GvFORM(gv))) {
5890 if (ckWARN(WARN_REDEFINE)) {
5891 const line_t oldline = CopLINE(PL_curcop);
5892 if (PL_parser && PL_parser->copline != NOLINE)
5893 CopLINE_set(PL_curcop, PL_parser->copline);
5894 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5895 o ? "Format %"SVf" redefined"
5896 : "Format STDOUT redefined", SVfARG(cSVOPo->op_sv));
5897 CopLINE_set(PL_curcop, oldline);
5904 CvFILE_set_from_cop(cv, PL_curcop);
5907 pad_tidy(padtidy_FORMAT);
5908 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5909 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5910 OpREFCNT_set(CvROOT(cv), 1);
5911 CvSTART(cv) = LINKLIST(CvROOT(cv));
5912 CvROOT(cv)->op_next = 0;
5913 CALL_PEEP(CvSTART(cv));
5915 op_getmad(o,pegop,'n');
5916 op_getmad_weak(block, pegop, 'b');
5921 PL_parser->copline = NOLINE;
5929 Perl_newANONLIST(pTHX_ OP *o)
5931 return convert(OP_ANONLIST, OPf_SPECIAL, o);
5935 Perl_newANONHASH(pTHX_ OP *o)
5937 return convert(OP_ANONHASH, OPf_SPECIAL, o);
5941 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5943 return newANONATTRSUB(floor, proto, NULL, block);
5947 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5949 return newUNOP(OP_REFGEN, 0,
5950 newSVOP(OP_ANONCODE, 0,
5951 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5955 Perl_oopsAV(pTHX_ OP *o)
5958 switch (o->op_type) {
5960 o->op_type = OP_PADAV;
5961 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5962 return ref(o, OP_RV2AV);
5965 o->op_type = OP_RV2AV;
5966 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5971 if (ckWARN_d(WARN_INTERNAL))
5972 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
5979 Perl_oopsHV(pTHX_ OP *o)
5982 switch (o->op_type) {
5985 o->op_type = OP_PADHV;
5986 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5987 return ref(o, OP_RV2HV);
5991 o->op_type = OP_RV2HV;
5992 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5997 if (ckWARN_d(WARN_INTERNAL))
5998 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
6005 Perl_newAVREF(pTHX_ OP *o)
6008 if (o->op_type == OP_PADANY) {
6009 o->op_type = OP_PADAV;
6010 o->op_ppaddr = PL_ppaddr[OP_PADAV];
6013 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
6014 && ckWARN(WARN_DEPRECATED)) {
6015 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
6016 "Using an array as a reference is deprecated");
6018 return newUNOP(OP_RV2AV, 0, scalar(o));
6022 Perl_newGVREF(pTHX_ I32 type, OP *o)
6024 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
6025 return newUNOP(OP_NULL, 0, o);
6026 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
6030 Perl_newHVREF(pTHX_ OP *o)
6033 if (o->op_type == OP_PADANY) {
6034 o->op_type = OP_PADHV;
6035 o->op_ppaddr = PL_ppaddr[OP_PADHV];
6038 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
6039 && ckWARN(WARN_DEPRECATED)) {
6040 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
6041 "Using a hash as a reference is deprecated");
6043 return newUNOP(OP_RV2HV, 0, scalar(o));
6047 Perl_newCVREF(pTHX_ I32 flags, OP *o)
6049 return newUNOP(OP_RV2CV, flags, scalar(o));
6053 Perl_newSVREF(pTHX_ OP *o)
6056 if (o->op_type == OP_PADANY) {
6057 o->op_type = OP_PADSV;
6058 o->op_ppaddr = PL_ppaddr[OP_PADSV];
6061 return newUNOP(OP_RV2SV, 0, scalar(o));
6064 /* Check routines. See the comments at the top of this file for details
6065 * on when these are called */
6068 Perl_ck_anoncode(pTHX_ OP *o)
6070 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
6072 cSVOPo->op_sv = NULL;
6077 Perl_ck_bitop(pTHX_ OP *o)
6080 #define OP_IS_NUMCOMPARE(op) \
6081 ((op) == OP_LT || (op) == OP_I_LT || \
6082 (op) == OP_GT || (op) == OP_I_GT || \
6083 (op) == OP_LE || (op) == OP_I_LE || \
6084 (op) == OP_GE || (op) == OP_I_GE || \
6085 (op) == OP_EQ || (op) == OP_I_EQ || \
6086 (op) == OP_NE || (op) == OP_I_NE || \
6087 (op) == OP_NCMP || (op) == OP_I_NCMP)
6088 o->op_private = (U8)(PL_hints & HINT_INTEGER);
6089 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
6090 && (o->op_type == OP_BIT_OR
6091 || o->op_type == OP_BIT_AND
6092 || o->op_type == OP_BIT_XOR))
6094 const OP * const left = cBINOPo->op_first;
6095 const OP * const right = left->op_sibling;
6096 if ((OP_IS_NUMCOMPARE(left->op_type) &&
6097 (left->op_flags & OPf_PARENS) == 0) ||
6098 (OP_IS_NUMCOMPARE(right->op_type) &&
6099 (right->op_flags & OPf_PARENS) == 0))
6100 if (ckWARN(WARN_PRECEDENCE))
6101 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
6102 "Possible precedence problem on bitwise %c operator",
6103 o->op_type == OP_BIT_OR ? '|'
6104 : o->op_type == OP_BIT_AND ? '&' : '^'
6111 Perl_ck_concat(pTHX_ OP *o)
6113 const OP * const kid = cUNOPo->op_first;
6114 PERL_UNUSED_CONTEXT;
6115 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
6116 !(kUNOP->op_first->op_flags & OPf_MOD))
6117 o->op_flags |= OPf_STACKED;
6122 Perl_ck_spair(pTHX_ OP *o)
6125 if (o->op_flags & OPf_KIDS) {
6128 const OPCODE type = o->op_type;
6129 o = modkids(ck_fun(o), type);
6130 kid = cUNOPo->op_first;
6131 newop = kUNOP->op_first->op_sibling;
6133 const OPCODE type = newop->op_type;
6134 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
6135 type == OP_PADAV || type == OP_PADHV ||
6136 type == OP_RV2AV || type == OP_RV2HV)
6140 op_getmad(kUNOP->op_first,newop,'K');
6142 op_free(kUNOP->op_first);
6144 kUNOP->op_first = newop;
6146 o->op_ppaddr = PL_ppaddr[++o->op_type];
6151 Perl_ck_delete(pTHX_ OP *o)
6155 if (o->op_flags & OPf_KIDS) {
6156 OP * const kid = cUNOPo->op_first;
6157 switch (kid->op_type) {
6159 o->op_flags |= OPf_SPECIAL;
6162 o->op_private |= OPpSLICE;
6165 o->op_flags |= OPf_SPECIAL;
6170 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
6179 Perl_ck_die(pTHX_ OP *o)
6182 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6188 Perl_ck_eof(pTHX_ OP *o)
6192 if (o->op_flags & OPf_KIDS) {
6193 if (cLISTOPo->op_first->op_type == OP_STUB) {
6195 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
6197 op_getmad(o,newop,'O');
6209 Perl_ck_eval(pTHX_ OP *o)
6212 PL_hints |= HINT_BLOCK_SCOPE;
6213 if (o->op_flags & OPf_KIDS) {
6214 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6217 o->op_flags &= ~OPf_KIDS;
6220 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
6226 cUNOPo->op_first = 0;
6231 NewOp(1101, enter, 1, LOGOP);
6232 enter->op_type = OP_ENTERTRY;
6233 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
6234 enter->op_private = 0;
6236 /* establish postfix order */
6237 enter->op_next = (OP*)enter;
6239 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
6240 o->op_type = OP_LEAVETRY;
6241 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
6242 enter->op_other = o;
6243 op_getmad(oldo,o,'O');
6257 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
6258 op_getmad(oldo,o,'O');
6260 o->op_targ = (PADOFFSET)PL_hints;
6261 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
6262 /* Store a copy of %^H that pp_entereval can pick up.
6263 OPf_SPECIAL flags the opcode as being for this purpose,
6264 so that it in turn will return a copy at every
6266 OP *hhop = newSVOP(OP_CONST, OPf_SPECIAL,
6267 (SV*)Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv)));
6268 cUNOPo->op_first->op_sibling = hhop;
6269 o->op_private |= OPpEVAL_HAS_HH;
6275 Perl_ck_exit(pTHX_ OP *o)
6278 HV * const table = GvHV(PL_hintgv);
6280 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
6281 if (svp && *svp && SvTRUE(*svp))
6282 o->op_private |= OPpEXIT_VMSISH;
6284 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6290 Perl_ck_exec(pTHX_ OP *o)
6292 if (o->op_flags & OPf_STACKED) {
6295 kid = cUNOPo->op_first->op_sibling;
6296 if (kid->op_type == OP_RV2GV)
6305 Perl_ck_exists(pTHX_ OP *o)
6309 if (o->op_flags & OPf_KIDS) {
6310 OP * const kid = cUNOPo->op_first;
6311 if (kid->op_type == OP_ENTERSUB) {
6312 (void) ref(kid, o->op_type);
6313 if (kid->op_type != OP_RV2CV
6314 && !(PL_parser && PL_parser->error_count))
6315 Perl_croak(aTHX_ "%s argument is not a subroutine name",
6317 o->op_private |= OPpEXISTS_SUB;
6319 else if (kid->op_type == OP_AELEM)
6320 o->op_flags |= OPf_SPECIAL;
6321 else if (kid->op_type != OP_HELEM)
6322 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
6330 Perl_ck_rvconst(pTHX_ register OP *o)
6333 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6335 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6336 if (o->op_type == OP_RV2CV)
6337 o->op_private &= ~1;
6339 if (kid->op_type == OP_CONST) {
6342 SV * const kidsv = kid->op_sv;
6344 /* Is it a constant from cv_const_sv()? */
6345 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
6346 SV * const rsv = SvRV(kidsv);
6347 const svtype type = SvTYPE(rsv);
6348 const char *badtype = NULL;
6350 switch (o->op_type) {
6352 if (type > SVt_PVMG)
6353 badtype = "a SCALAR";
6356 if (type != SVt_PVAV)
6357 badtype = "an ARRAY";
6360 if (type != SVt_PVHV)
6364 if (type != SVt_PVCV)
6369 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
6372 else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
6373 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
6374 /* If this is an access to a stash, disable "strict refs", because
6375 * stashes aren't auto-vivified at compile-time (unless we store
6376 * symbols in them), and we don't want to produce a run-time
6377 * stricture error when auto-vivifying the stash. */
6378 const char *s = SvPV_nolen(kidsv);
6379 const STRLEN l = SvCUR(kidsv);
6380 if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
6381 o->op_private &= ~HINT_STRICT_REFS;
6383 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
6384 const char *badthing;
6385 switch (o->op_type) {
6387 badthing = "a SCALAR";
6390 badthing = "an ARRAY";
6393 badthing = "a HASH";
6401 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
6402 SVfARG(kidsv), badthing);
6405 * This is a little tricky. We only want to add the symbol if we
6406 * didn't add it in the lexer. Otherwise we get duplicate strict
6407 * warnings. But if we didn't add it in the lexer, we must at
6408 * least pretend like we wanted to add it even if it existed before,
6409 * or we get possible typo warnings. OPpCONST_ENTERED says
6410 * whether the lexer already added THIS instance of this symbol.
6412 iscv = (o->op_type == OP_RV2CV) * 2;
6414 gv = gv_fetchsv(kidsv,
6415 iscv | !(kid->op_private & OPpCONST_ENTERED),
6418 : o->op_type == OP_RV2SV
6420 : o->op_type == OP_RV2AV
6422 : o->op_type == OP_RV2HV
6425 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
6427 kid->op_type = OP_GV;
6428 SvREFCNT_dec(kid->op_sv);
6430 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
6431 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
6432 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
6434 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc_simple_NN(gv));
6436 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
6438 kid->op_private = 0;
6439 kid->op_ppaddr = PL_ppaddr[OP_GV];
6446 Perl_ck_ftst(pTHX_ OP *o)
6449 const I32 type = o->op_type;
6451 if (o->op_flags & OPf_REF) {
6454 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
6455 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6456 const OPCODE kidtype = kid->op_type;
6458 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6459 OP * const newop = newGVOP(type, OPf_REF,
6460 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
6462 op_getmad(o,newop,'O');
6468 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o))
6469 o->op_private |= OPpFT_ACCESS;
6470 if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst)
6471 && kidtype != OP_STAT && kidtype != OP_LSTAT)
6472 o->op_private |= OPpFT_STACKED;
6480 if (type == OP_FTTTY)
6481 o = newGVOP(type, OPf_REF, PL_stdingv);
6483 o = newUNOP(type, 0, newDEFSVOP());
6484 op_getmad(oldo,o,'O');
6490 Perl_ck_fun(pTHX_ OP *o)
6493 const int type = o->op_type;
6494 register I32 oa = PL_opargs[type] >> OASHIFT;
6496 if (o->op_flags & OPf_STACKED) {
6497 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
6500 return no_fh_allowed(o);
6503 if (o->op_flags & OPf_KIDS) {
6504 OP **tokid = &cLISTOPo->op_first;
6505 register OP *kid = cLISTOPo->op_first;
6509 if (kid->op_type == OP_PUSHMARK ||
6510 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
6512 tokid = &kid->op_sibling;
6513 kid = kid->op_sibling;
6515 if (!kid && PL_opargs[type] & OA_DEFGV)
6516 *tokid = kid = newDEFSVOP();
6520 sibl = kid->op_sibling;
6522 if (!sibl && kid->op_type == OP_STUB) {
6529 /* list seen where single (scalar) arg expected? */
6530 if (numargs == 1 && !(oa >> 4)
6531 && kid->op_type == OP_LIST && type != OP_SCALAR)
6533 return too_many_arguments(o,PL_op_desc[type]);
6546 if ((type == OP_PUSH || type == OP_UNSHIFT)
6547 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
6548 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6549 "Useless use of %s with no values",
6552 if (kid->op_type == OP_CONST &&
6553 (kid->op_private & OPpCONST_BARE))
6555 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
6556 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
6557 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6558 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6559 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
6560 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6562 op_getmad(kid,newop,'K');
6567 kid->op_sibling = sibl;
6570 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
6571 bad_type(numargs, "array", PL_op_desc[type], kid);
6575 if (kid->op_type == OP_CONST &&
6576 (kid->op_private & OPpCONST_BARE))
6578 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
6579 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
6580 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6581 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6582 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
6583 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6585 op_getmad(kid,newop,'K');
6590 kid->op_sibling = sibl;
6593 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
6594 bad_type(numargs, "hash", PL_op_desc[type], kid);
6599 OP * const newop = newUNOP(OP_NULL, 0, kid);
6600 kid->op_sibling = 0;
6602 newop->op_next = newop;
6604 kid->op_sibling = sibl;
6609 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
6610 if (kid->op_type == OP_CONST &&
6611 (kid->op_private & OPpCONST_BARE))
6613 OP * const newop = newGVOP(OP_GV, 0,
6614 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
6615 if (!(o->op_private & 1) && /* if not unop */
6616 kid == cLISTOPo->op_last)
6617 cLISTOPo->op_last = newop;
6619 op_getmad(kid,newop,'K');
6625 else if (kid->op_type == OP_READLINE) {
6626 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
6627 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
6630 I32 flags = OPf_SPECIAL;
6634 /* is this op a FH constructor? */
6635 if (is_handle_constructor(o,numargs)) {
6636 const char *name = NULL;
6640 /* Set a flag to tell rv2gv to vivify
6641 * need to "prove" flag does not mean something
6642 * else already - NI-S 1999/05/07
6645 if (kid->op_type == OP_PADSV) {
6647 = PAD_COMPNAME_SV(kid->op_targ);
6648 name = SvPV_const(namesv, len);
6650 else if (kid->op_type == OP_RV2SV
6651 && kUNOP->op_first->op_type == OP_GV)
6653 GV * const gv = cGVOPx_gv(kUNOP->op_first);
6655 len = GvNAMELEN(gv);
6657 else if (kid->op_type == OP_AELEM
6658 || kid->op_type == OP_HELEM)
6661 OP *op = ((BINOP*)kid)->op_first;
6665 const char * const a =
6666 kid->op_type == OP_AELEM ?
6668 if (((op->op_type == OP_RV2AV) ||
6669 (op->op_type == OP_RV2HV)) &&
6670 (firstop = ((UNOP*)op)->op_first) &&
6671 (firstop->op_type == OP_GV)) {
6672 /* packagevar $a[] or $h{} */
6673 GV * const gv = cGVOPx_gv(firstop);
6681 else if (op->op_type == OP_PADAV
6682 || op->op_type == OP_PADHV) {
6683 /* lexicalvar $a[] or $h{} */
6684 const char * const padname =
6685 PAD_COMPNAME_PV(op->op_targ);
6694 name = SvPV_const(tmpstr, len);
6699 name = "__ANONIO__";
6706 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
6707 namesv = PAD_SVl(targ);
6708 SvUPGRADE(namesv, SVt_PV);
6710 sv_setpvn(namesv, "$", 1);
6711 sv_catpvn(namesv, name, len);
6714 kid->op_sibling = 0;
6715 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
6716 kid->op_targ = targ;
6717 kid->op_private |= priv;
6719 kid->op_sibling = sibl;
6725 mod(scalar(kid), type);
6729 tokid = &kid->op_sibling;
6730 kid = kid->op_sibling;
6733 if (kid && kid->op_type != OP_STUB)
6734 return too_many_arguments(o,OP_DESC(o));
6735 o->op_private |= numargs;
6737 /* FIXME - should the numargs move as for the PERL_MAD case? */
6738 o->op_private |= numargs;
6740 return too_many_arguments(o,OP_DESC(o));
6744 else if (PL_opargs[type] & OA_DEFGV) {
6746 OP *newop = newUNOP(type, 0, newDEFSVOP());
6747 op_getmad(o,newop,'O');
6750 /* Ordering of these two is important to keep f_map.t passing. */
6752 return newUNOP(type, 0, newDEFSVOP());
6757 while (oa & OA_OPTIONAL)
6759 if (oa && oa != OA_LIST)
6760 return too_few_arguments(o,OP_DESC(o));
6766 Perl_ck_glob(pTHX_ OP *o)
6772 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
6773 append_elem(OP_GLOB, o, newDEFSVOP());
6775 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
6776 && GvCVu(gv) && GvIMPORTED_CV(gv)))
6778 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6781 #if !defined(PERL_EXTERNAL_GLOB)
6782 /* XXX this can be tightened up and made more failsafe. */
6783 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
6786 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
6787 newSVpvs("File::Glob"), NULL, NULL, NULL);
6788 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6789 glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
6790 GvCV(gv) = GvCV(glob_gv);
6791 SvREFCNT_inc_void((SV*)GvCV(gv));
6792 GvIMPORTED_CV_on(gv);
6795 #endif /* PERL_EXTERNAL_GLOB */
6797 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6798 append_elem(OP_GLOB, o,
6799 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
6800 o->op_type = OP_LIST;
6801 o->op_ppaddr = PL_ppaddr[OP_LIST];
6802 cLISTOPo->op_first->op_type = OP_PUSHMARK;
6803 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
6804 cLISTOPo->op_first->op_targ = 0;
6805 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
6806 append_elem(OP_LIST, o,
6807 scalar(newUNOP(OP_RV2CV, 0,
6808 newGVOP(OP_GV, 0, gv)))));
6809 o = newUNOP(OP_NULL, 0, ck_subr(o));
6810 o->op_targ = OP_GLOB; /* hint at what it used to be */
6813 gv = newGVgen("main");
6815 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
6821 Perl_ck_grep(pTHX_ OP *o)
6826 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
6829 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
6830 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
6832 if (o->op_flags & OPf_STACKED) {
6835 kid = cLISTOPo->op_first->op_sibling;
6836 if (!cUNOPx(kid)->op_next)
6837 Perl_croak(aTHX_ "panic: ck_grep");
6838 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
6841 NewOp(1101, gwop, 1, LOGOP);
6842 kid->op_next = (OP*)gwop;
6843 o->op_flags &= ~OPf_STACKED;
6845 kid = cLISTOPo->op_first->op_sibling;
6846 if (type == OP_MAPWHILE)
6851 if (PL_parser && PL_parser->error_count)
6853 kid = cLISTOPo->op_first->op_sibling;
6854 if (kid->op_type != OP_NULL)
6855 Perl_croak(aTHX_ "panic: ck_grep");
6856 kid = kUNOP->op_first;
6859 NewOp(1101, gwop, 1, LOGOP);
6860 gwop->op_type = type;
6861 gwop->op_ppaddr = PL_ppaddr[type];
6862 gwop->op_first = listkids(o);
6863 gwop->op_flags |= OPf_KIDS;
6864 gwop->op_other = LINKLIST(kid);
6865 kid->op_next = (OP*)gwop;
6866 offset = pad_findmy("$_");
6867 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
6868 o->op_private = gwop->op_private = 0;
6869 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
6872 o->op_private = gwop->op_private = OPpGREP_LEX;
6873 gwop->op_targ = o->op_targ = offset;
6876 kid = cLISTOPo->op_first->op_sibling;
6877 if (!kid || !kid->op_sibling)
6878 return too_few_arguments(o,OP_DESC(o));
6879 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
6880 mod(kid, OP_GREPSTART);
6886 Perl_ck_index(pTHX_ OP *o)
6888 if (o->op_flags & OPf_KIDS) {
6889 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6891 kid = kid->op_sibling; /* get past "big" */
6892 if (kid && kid->op_type == OP_CONST)
6893 fbm_compile(((SVOP*)kid)->op_sv, 0);
6899 Perl_ck_lengthconst(pTHX_ OP *o)
6901 /* XXX length optimization goes here */
6906 Perl_ck_lfun(pTHX_ OP *o)
6908 const OPCODE type = o->op_type;
6909 return modkids(ck_fun(o), type);
6913 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
6915 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
6916 switch (cUNOPo->op_first->op_type) {
6918 /* This is needed for
6919 if (defined %stash::)
6920 to work. Do not break Tk.
6922 break; /* Globals via GV can be undef */
6924 case OP_AASSIGN: /* Is this a good idea? */
6925 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6926 "defined(@array) is deprecated");
6927 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6928 "\t(Maybe you should just omit the defined()?)\n");
6931 /* This is needed for
6932 if (defined %stash::)
6933 to work. Do not break Tk.
6935 break; /* Globals via GV can be undef */
6937 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6938 "defined(%%hash) is deprecated");
6939 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6940 "\t(Maybe you should just omit the defined()?)\n");
6951 Perl_ck_readline(pTHX_ OP *o)
6953 if (!(o->op_flags & OPf_KIDS)) {
6955 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
6957 op_getmad(o,newop,'O');
6967 Perl_ck_rfun(pTHX_ OP *o)
6969 const OPCODE type = o->op_type;
6970 return refkids(ck_fun(o), type);
6974 Perl_ck_listiob(pTHX_ OP *o)
6978 kid = cLISTOPo->op_first;
6981 kid = cLISTOPo->op_first;
6983 if (kid->op_type == OP_PUSHMARK)
6984 kid = kid->op_sibling;
6985 if (kid && o->op_flags & OPf_STACKED)
6986 kid = kid->op_sibling;
6987 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6988 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6989 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6990 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6991 cLISTOPo->op_first->op_sibling = kid;
6992 cLISTOPo->op_last = kid;
6993 kid = kid->op_sibling;
6998 append_elem(o->op_type, o, newDEFSVOP());
7004 Perl_ck_smartmatch(pTHX_ OP *o)
7007 if (0 == (o->op_flags & OPf_SPECIAL)) {
7008 OP *first = cBINOPo->op_first;
7009 OP *second = first->op_sibling;
7011 /* Implicitly take a reference to an array or hash */
7012 first->op_sibling = NULL;
7013 first = cBINOPo->op_first = ref_array_or_hash(first);
7014 second = first->op_sibling = ref_array_or_hash(second);
7016 /* Implicitly take a reference to a regular expression */
7017 if (first->op_type == OP_MATCH) {
7018 first->op_type = OP_QR;
7019 first->op_ppaddr = PL_ppaddr[OP_QR];
7021 if (second->op_type == OP_MATCH) {
7022 second->op_type = OP_QR;
7023 second->op_ppaddr = PL_ppaddr[OP_QR];
7032 Perl_ck_sassign(pTHX_ OP *o)
7035 OP * const kid = cLISTOPo->op_first;
7036 /* has a disposable target? */
7037 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
7038 && !(kid->op_flags & OPf_STACKED)
7039 /* Cannot steal the second time! */
7040 && !(kid->op_private & OPpTARGET_MY)
7041 /* Keep the full thing for madskills */
7045 OP * const kkid = kid->op_sibling;
7047 /* Can just relocate the target. */
7048 if (kkid && kkid->op_type == OP_PADSV
7049 && !(kkid->op_private & OPpLVAL_INTRO))
7051 kid->op_targ = kkid->op_targ;
7053 /* Now we do not need PADSV and SASSIGN. */
7054 kid->op_sibling = o->op_sibling; /* NULL */
7055 cLISTOPo->op_first = NULL;
7058 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
7062 if (kid->op_sibling) {
7063 OP *kkid = kid->op_sibling;
7064 if (kkid->op_type == OP_PADSV
7065 && (kkid->op_private & OPpLVAL_INTRO)
7066 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
7067 const PADOFFSET target = kkid->op_targ;
7068 OP *const other = newOP(OP_PADSV,
7070 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
7071 OP *const first = newOP(OP_NULL, 0);
7072 OP *const nullop = newCONDOP(0, first, o, other);
7073 OP *const condop = first->op_next;
7074 /* hijacking PADSTALE for uninitialized state variables */
7075 SvPADSTALE_on(PAD_SVl(target));
7077 condop->op_type = OP_ONCE;
7078 condop->op_ppaddr = PL_ppaddr[OP_ONCE];
7079 condop->op_targ = target;
7080 other->op_targ = target;
7082 /* Because we change the type of the op here, we will skip the
7083 assinment binop->op_last = binop->op_first->op_sibling; at the
7084 end of Perl_newBINOP(). So need to do it here. */
7085 cBINOPo->op_last = cBINOPo->op_first->op_sibling;
7094 Perl_ck_match(pTHX_ OP *o)
7097 if (o->op_type != OP_QR && PL_compcv) {
7098 const PADOFFSET offset = pad_findmy("$_");
7099 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
7100 o->op_targ = offset;
7101 o->op_private |= OPpTARGET_MY;
7104 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
7105 o->op_private |= OPpRUNTIME;
7110 Perl_ck_method(pTHX_ OP *o)
7112 OP * const kid = cUNOPo->op_first;
7113 if (kid->op_type == OP_CONST) {
7114 SV* sv = kSVOP->op_sv;
7115 const char * const method = SvPVX_const(sv);
7116 if (!(strchr(method, ':') || strchr(method, '\''))) {
7118 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
7119 sv = newSVpvn_share(method, SvCUR(sv), 0);
7122 kSVOP->op_sv = NULL;
7124 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
7126 op_getmad(o,cmop,'O');
7137 Perl_ck_null(pTHX_ OP *o)
7139 PERL_UNUSED_CONTEXT;
7144 Perl_ck_open(pTHX_ OP *o)
7147 HV * const table = GvHV(PL_hintgv);
7149 SV **svp = hv_fetchs(table, "open_IN", FALSE);
7151 const I32 mode = mode_from_discipline(*svp);
7152 if (mode & O_BINARY)
7153 o->op_private |= OPpOPEN_IN_RAW;
7154 else if (mode & O_TEXT)
7155 o->op_private |= OPpOPEN_IN_CRLF;
7158 svp = hv_fetchs(table, "open_OUT", FALSE);
7160 const I32 mode = mode_from_discipline(*svp);
7161 if (mode & O_BINARY)
7162 o->op_private |= OPpOPEN_OUT_RAW;
7163 else if (mode & O_TEXT)
7164 o->op_private |= OPpOPEN_OUT_CRLF;
7167 if (o->op_type == OP_BACKTICK) {
7168 if (!(o->op_flags & OPf_KIDS)) {
7169 OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
7171 op_getmad(o,newop,'O');
7180 /* In case of three-arg dup open remove strictness
7181 * from the last arg if it is a bareword. */
7182 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
7183 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
7187 if ((last->op_type == OP_CONST) && /* The bareword. */
7188 (last->op_private & OPpCONST_BARE) &&
7189 (last->op_private & OPpCONST_STRICT) &&
7190 (oa = first->op_sibling) && /* The fh. */
7191 (oa = oa->op_sibling) && /* The mode. */
7192 (oa->op_type == OP_CONST) &&
7193 SvPOK(((SVOP*)oa)->op_sv) &&
7194 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
7195 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
7196 (last == oa->op_sibling)) /* The bareword. */
7197 last->op_private &= ~OPpCONST_STRICT;
7203 Perl_ck_repeat(pTHX_ OP *o)
7205 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
7206 o->op_private |= OPpREPEAT_DOLIST;
7207 cBINOPo->op_first = force_list(cBINOPo->op_first);
7215 Perl_ck_require(pTHX_ OP *o)
7220 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
7221 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7223 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
7224 SV * const sv = kid->op_sv;
7225 U32 was_readonly = SvREADONLY(sv);
7232 sv_force_normal_flags(sv, 0);
7233 assert(!SvREADONLY(sv));
7243 for (; s < end; s++) {
7244 if (*s == ':' && s[1] == ':') {
7246 Move(s+2, s+1, end - s - 1, char);
7251 sv_catpvs(sv, ".pm");
7252 SvFLAGS(sv) |= was_readonly;
7256 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
7257 /* handle override, if any */
7258 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
7259 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7260 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
7261 gv = gvp ? *gvp : NULL;
7265 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7266 OP * const kid = cUNOPo->op_first;
7269 cUNOPo->op_first = 0;
7273 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
7274 append_elem(OP_LIST, kid,
7275 scalar(newUNOP(OP_RV2CV, 0,
7278 op_getmad(o,newop,'O');
7286 Perl_ck_return(pTHX_ OP *o)
7289 if (CvLVALUE(PL_compcv)) {
7291 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
7292 mod(kid, OP_LEAVESUBLV);
7298 Perl_ck_select(pTHX_ OP *o)
7302 if (o->op_flags & OPf_KIDS) {
7303 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7304 if (kid && kid->op_sibling) {
7305 o->op_type = OP_SSELECT;
7306 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
7308 return fold_constants(o);
7312 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7313 if (kid && kid->op_type == OP_RV2GV)
7314 kid->op_private &= ~HINT_STRICT_REFS;
7319 Perl_ck_shift(pTHX_ OP *o)
7322 const I32 type = o->op_type;
7324 if (!(o->op_flags & OPf_KIDS)) {
7326 /* FIXME - this can be refactored to reduce code in #ifdefs */
7328 OP * const oldo = o;
7332 argop = newUNOP(OP_RV2AV, 0,
7333 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
7335 o = newUNOP(type, 0, scalar(argop));
7336 op_getmad(oldo,o,'O');
7339 return newUNOP(type, 0, scalar(argop));
7342 return scalar(modkids(ck_fun(o), type));
7346 Perl_ck_sort(pTHX_ OP *o)
7351 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
7352 HV * const hinthv = GvHV(PL_hintgv);
7354 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
7356 const I32 sorthints = (I32)SvIV(*svp);
7357 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
7358 o->op_private |= OPpSORT_QSORT;
7359 if ((sorthints & HINT_SORT_STABLE) != 0)
7360 o->op_private |= OPpSORT_STABLE;
7365 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
7367 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7368 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
7370 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
7372 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
7374 if (kid->op_type == OP_SCOPE) {
7378 else if (kid->op_type == OP_LEAVE) {
7379 if (o->op_type == OP_SORT) {
7380 op_null(kid); /* wipe out leave */
7383 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
7384 if (k->op_next == kid)
7386 /* don't descend into loops */
7387 else if (k->op_type == OP_ENTERLOOP
7388 || k->op_type == OP_ENTERITER)
7390 k = cLOOPx(k)->op_lastop;
7395 kid->op_next = 0; /* just disconnect the leave */
7396 k = kLISTOP->op_first;
7401 if (o->op_type == OP_SORT) {
7402 /* provide scalar context for comparison function/block */
7408 o->op_flags |= OPf_SPECIAL;
7410 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
7413 firstkid = firstkid->op_sibling;
7416 /* provide list context for arguments */
7417 if (o->op_type == OP_SORT)
7424 S_simplify_sort(pTHX_ OP *o)
7427 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7432 if (!(o->op_flags & OPf_STACKED))
7434 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7435 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
7436 kid = kUNOP->op_first; /* get past null */
7437 if (kid->op_type != OP_SCOPE)
7439 kid = kLISTOP->op_last; /* get past scope */
7440 switch(kid->op_type) {
7448 k = kid; /* remember this node*/
7449 if (kBINOP->op_first->op_type != OP_RV2SV)
7451 kid = kBINOP->op_first; /* get past cmp */
7452 if (kUNOP->op_first->op_type != OP_GV)
7454 kid = kUNOP->op_first; /* get past rv2sv */
7456 if (GvSTASH(gv) != PL_curstash)
7458 gvname = GvNAME(gv);
7459 if (*gvname == 'a' && gvname[1] == '\0')
7461 else if (*gvname == 'b' && gvname[1] == '\0')
7466 kid = k; /* back to cmp */
7467 if (kBINOP->op_last->op_type != OP_RV2SV)
7469 kid = kBINOP->op_last; /* down to 2nd arg */
7470 if (kUNOP->op_first->op_type != OP_GV)
7472 kid = kUNOP->op_first; /* get past rv2sv */
7474 if (GvSTASH(gv) != PL_curstash)
7476 gvname = GvNAME(gv);
7478 ? !(*gvname == 'a' && gvname[1] == '\0')
7479 : !(*gvname == 'b' && gvname[1] == '\0'))
7481 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
7483 o->op_private |= OPpSORT_DESCEND;
7484 if (k->op_type == OP_NCMP)
7485 o->op_private |= OPpSORT_NUMERIC;
7486 if (k->op_type == OP_I_NCMP)
7487 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
7488 kid = cLISTOPo->op_first->op_sibling;
7489 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
7491 op_getmad(kid,o,'S'); /* then delete it */
7493 op_free(kid); /* then delete it */
7498 Perl_ck_split(pTHX_ OP *o)
7503 if (o->op_flags & OPf_STACKED)
7504 return no_fh_allowed(o);
7506 kid = cLISTOPo->op_first;
7507 if (kid->op_type != OP_NULL)
7508 Perl_croak(aTHX_ "panic: ck_split");
7509 kid = kid->op_sibling;
7510 op_free(cLISTOPo->op_first);
7511 cLISTOPo->op_first = kid;
7513 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
7514 cLISTOPo->op_last = kid; /* There was only one element previously */
7517 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
7518 OP * const sibl = kid->op_sibling;
7519 kid->op_sibling = 0;
7520 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
7521 if (cLISTOPo->op_first == cLISTOPo->op_last)
7522 cLISTOPo->op_last = kid;
7523 cLISTOPo->op_first = kid;
7524 kid->op_sibling = sibl;
7527 kid->op_type = OP_PUSHRE;
7528 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
7530 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
7531 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
7532 "Use of /g modifier is meaningless in split");
7535 if (!kid->op_sibling)
7536 append_elem(OP_SPLIT, o, newDEFSVOP());
7538 kid = kid->op_sibling;
7541 if (!kid->op_sibling)
7542 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
7543 assert(kid->op_sibling);
7545 kid = kid->op_sibling;
7548 if (kid->op_sibling)
7549 return too_many_arguments(o,OP_DESC(o));
7555 Perl_ck_join(pTHX_ OP *o)
7557 const OP * const kid = cLISTOPo->op_first->op_sibling;
7558 if (kid && kid->op_type == OP_MATCH) {
7559 if (ckWARN(WARN_SYNTAX)) {
7560 const REGEXP *re = PM_GETRE(kPMOP);
7561 const char *pmstr = re ? RX_PRECOMP(re) : "STRING";
7562 const STRLEN len = re ? RX_PRELEN(re) : 6;
7563 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7564 "/%.*s/ should probably be written as \"%.*s\"",
7565 (int)len, pmstr, (int)len, pmstr);
7572 Perl_ck_subr(pTHX_ OP *o)
7575 OP *prev = ((cUNOPo->op_first->op_sibling)
7576 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
7577 OP *o2 = prev->op_sibling;
7579 const char *proto = NULL;
7580 const char *proto_end = NULL;
7585 I32 contextclass = 0;
7586 const char *e = NULL;
7589 o->op_private |= OPpENTERSUB_HASTARG;
7590 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
7591 if (cvop->op_type == OP_RV2CV) {
7593 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
7594 op_null(cvop); /* disable rv2cv */
7595 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
7596 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
7597 GV *gv = cGVOPx_gv(tmpop);
7600 tmpop->op_private |= OPpEARLY_CV;
7604 namegv = CvANON(cv) ? gv : CvGV(cv);
7605 proto = SvPV((SV*)cv, len);
7606 proto_end = proto + len;
7611 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7612 if (o2->op_type == OP_CONST)
7613 o2->op_private &= ~OPpCONST_STRICT;
7614 else if (o2->op_type == OP_LIST) {
7615 OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
7616 if (sib && sib->op_type == OP_CONST)
7617 sib->op_private &= ~OPpCONST_STRICT;
7620 o->op_private |= (PL_hints & HINT_STRICT_REFS);
7621 if (PERLDB_SUB && PL_curstash != PL_debstash)
7622 o->op_private |= OPpENTERSUB_DB;
7623 while (o2 != cvop) {
7625 if (PL_madskills && o2->op_type == OP_STUB) {
7626 o2 = o2->op_sibling;
7629 if (PL_madskills && o2->op_type == OP_NULL)
7630 o3 = ((UNOP*)o2)->op_first;
7634 if (proto >= proto_end)
7635 return too_many_arguments(o, gv_ename(namegv));
7643 /* _ must be at the end */
7644 if (proto[1] && proto[1] != ';')
7659 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
7661 arg == 1 ? "block or sub {}" : "sub {}",
7662 gv_ename(namegv), o3);
7665 /* '*' allows any scalar type, including bareword */
7668 if (o3->op_type == OP_RV2GV)
7669 goto wrapref; /* autoconvert GLOB -> GLOBref */
7670 else if (o3->op_type == OP_CONST)
7671 o3->op_private &= ~OPpCONST_STRICT;
7672 else if (o3->op_type == OP_ENTERSUB) {
7673 /* accidental subroutine, revert to bareword */
7674 OP *gvop = ((UNOP*)o3)->op_first;
7675 if (gvop && gvop->op_type == OP_NULL) {
7676 gvop = ((UNOP*)gvop)->op_first;
7678 for (; gvop->op_sibling; gvop = gvop->op_sibling)
7681 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
7682 (gvop = ((UNOP*)gvop)->op_first) &&
7683 gvop->op_type == OP_GV)
7685 GV * const gv = cGVOPx_gv(gvop);
7686 OP * const sibling = o2->op_sibling;
7687 SV * const n = newSVpvs("");
7689 OP * const oldo2 = o2;
7693 gv_fullname4(n, gv, "", FALSE);
7694 o2 = newSVOP(OP_CONST, 0, n);
7695 op_getmad(oldo2,o2,'O');
7696 prev->op_sibling = o2;
7697 o2->op_sibling = sibling;
7713 if (contextclass++ == 0) {
7714 e = strchr(proto, ']');
7715 if (!e || e == proto)
7724 const char *p = proto;
7725 const char *const end = proto;
7727 while (*--p != '[');
7728 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
7730 gv_ename(namegv), o3);
7735 if (o3->op_type == OP_RV2GV)
7738 bad_type(arg, "symbol", gv_ename(namegv), o3);
7741 if (o3->op_type == OP_ENTERSUB)
7744 bad_type(arg, "subroutine entry", gv_ename(namegv),
7748 if (o3->op_type == OP_RV2SV ||
7749 o3->op_type == OP_PADSV ||
7750 o3->op_type == OP_HELEM ||
7751 o3->op_type == OP_AELEM)
7754 bad_type(arg, "scalar", gv_ename(namegv), o3);
7757 if (o3->op_type == OP_RV2AV ||
7758 o3->op_type == OP_PADAV)
7761 bad_type(arg, "array", gv_ename(namegv), o3);
7764 if (o3->op_type == OP_RV2HV ||
7765 o3->op_type == OP_PADHV)
7768 bad_type(arg, "hash", gv_ename(namegv), o3);
7773 OP* const sib = kid->op_sibling;
7774 kid->op_sibling = 0;
7775 o2 = newUNOP(OP_REFGEN, 0, kid);
7776 o2->op_sibling = sib;
7777 prev->op_sibling = o2;
7779 if (contextclass && e) {
7794 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
7795 gv_ename(namegv), SVfARG(cv));
7800 mod(o2, OP_ENTERSUB);
7802 o2 = o2->op_sibling;
7804 if (o2 == cvop && proto && *proto == '_') {
7805 /* generate an access to $_ */
7807 o2->op_sibling = prev->op_sibling;
7808 prev->op_sibling = o2; /* instead of cvop */
7810 if (proto && !optional && proto_end > proto &&
7811 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
7812 return too_few_arguments(o, gv_ename(namegv));
7815 OP * const oldo = o;
7819 o=newSVOP(OP_CONST, 0, newSViv(0));
7820 op_getmad(oldo,o,'O');
7826 Perl_ck_svconst(pTHX_ OP *o)
7828 PERL_UNUSED_CONTEXT;
7829 SvREADONLY_on(cSVOPo->op_sv);
7834 Perl_ck_chdir(pTHX_ OP *o)
7836 if (o->op_flags & OPf_KIDS) {
7837 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7839 if (kid && kid->op_type == OP_CONST &&
7840 (kid->op_private & OPpCONST_BARE))
7842 o->op_flags |= OPf_SPECIAL;
7843 kid->op_private &= ~OPpCONST_STRICT;
7850 Perl_ck_trunc(pTHX_ OP *o)
7852 if (o->op_flags & OPf_KIDS) {
7853 SVOP *kid = (SVOP*)cUNOPo->op_first;
7855 if (kid->op_type == OP_NULL)
7856 kid = (SVOP*)kid->op_sibling;
7857 if (kid && kid->op_type == OP_CONST &&
7858 (kid->op_private & OPpCONST_BARE))
7860 o->op_flags |= OPf_SPECIAL;
7861 kid->op_private &= ~OPpCONST_STRICT;
7868 Perl_ck_unpack(pTHX_ OP *o)
7870 OP *kid = cLISTOPo->op_first;
7871 if (kid->op_sibling) {
7872 kid = kid->op_sibling;
7873 if (!kid->op_sibling)
7874 kid->op_sibling = newDEFSVOP();
7880 Perl_ck_substr(pTHX_ OP *o)
7883 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
7884 OP *kid = cLISTOPo->op_first;
7886 if (kid->op_type == OP_NULL)
7887 kid = kid->op_sibling;
7889 kid->op_flags |= OPf_MOD;
7896 Perl_ck_each(pTHX_ OP *o)
7899 OP *kid = cLISTOPo->op_first;
7901 if (kid->op_type == OP_PADAV || kid->op_type == OP_RV2AV) {
7902 const unsigned new_type = o->op_type == OP_EACH ? OP_AEACH
7903 : o->op_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
7904 o->op_type = new_type;
7905 o->op_ppaddr = PL_ppaddr[new_type];
7907 else if (!(kid->op_type == OP_PADHV || kid->op_type == OP_RV2HV
7908 || (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE)
7910 bad_type(1, "hash or array", PL_op_desc[o->op_type], kid);
7916 /* A peephole optimizer. We visit the ops in the order they're to execute.
7917 * See the comments at the top of this file for more details about when
7918 * peep() is called */
7921 Perl_peep(pTHX_ register OP *o)
7924 register OP* oldop = NULL;
7926 if (!o || o->op_opt)
7930 SAVEVPTR(PL_curcop);
7931 for (; o; o = o->op_next) {
7934 /* By default, this op has now been optimised. A couple of cases below
7935 clear this again. */
7938 switch (o->op_type) {
7942 PL_curcop = ((COP*)o); /* for warnings */
7946 if (cSVOPo->op_private & OPpCONST_STRICT)
7947 no_bareword_allowed(o);
7949 case OP_METHOD_NAMED:
7950 /* Relocate sv to the pad for thread safety.
7951 * Despite being a "constant", the SV is written to,
7952 * for reference counts, sv_upgrade() etc. */
7954 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
7955 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
7956 /* If op_sv is already a PADTMP then it is being used by
7957 * some pad, so make a copy. */
7958 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
7959 SvREADONLY_on(PAD_SVl(ix));
7960 SvREFCNT_dec(cSVOPo->op_sv);
7962 else if (o->op_type == OP_CONST
7963 && cSVOPo->op_sv == &PL_sv_undef) {
7964 /* PL_sv_undef is hack - it's unsafe to store it in the
7965 AV that is the pad, because av_fetch treats values of
7966 PL_sv_undef as a "free" AV entry and will merrily
7967 replace them with a new SV, causing pad_alloc to think
7968 that this pad slot is free. (When, clearly, it is not)
7970 SvOK_off(PAD_SVl(ix));
7971 SvPADTMP_on(PAD_SVl(ix));
7972 SvREADONLY_on(PAD_SVl(ix));
7975 SvREFCNT_dec(PAD_SVl(ix));
7976 SvPADTMP_on(cSVOPo->op_sv);
7977 PAD_SETSV(ix, cSVOPo->op_sv);
7978 /* XXX I don't know how this isn't readonly already. */
7979 SvREADONLY_on(PAD_SVl(ix));
7981 cSVOPo->op_sv = NULL;
7988 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
7989 if (o->op_next->op_private & OPpTARGET_MY) {
7990 if (o->op_flags & OPf_STACKED) /* chained concats */
7991 break; /* ignore_optimization */
7993 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
7994 o->op_targ = o->op_next->op_targ;
7995 o->op_next->op_targ = 0;
7996 o->op_private |= OPpTARGET_MY;
7999 op_null(o->op_next);
8003 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
8004 break; /* Scalar stub must produce undef. List stub is noop */
8008 if (o->op_targ == OP_NEXTSTATE
8009 || o->op_targ == OP_DBSTATE
8010 || o->op_targ == OP_SETSTATE)
8012 PL_curcop = ((COP*)o);
8014 /* XXX: We avoid setting op_seq here to prevent later calls
8015 to peep() from mistakenly concluding that optimisation
8016 has already occurred. This doesn't fix the real problem,
8017 though (See 20010220.007). AMS 20010719 */
8018 /* op_seq functionality is now replaced by op_opt */
8025 if (oldop && o->op_next) {
8026 oldop->op_next = o->op_next;
8034 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
8035 OP* const pop = (o->op_type == OP_PADAV) ?
8036 o->op_next : o->op_next->op_next;
8038 if (pop && pop->op_type == OP_CONST &&
8039 ((PL_op = pop->op_next)) &&
8040 pop->op_next->op_type == OP_AELEM &&
8041 !(pop->op_next->op_private &
8042 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
8043 (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
8048 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
8049 no_bareword_allowed(pop);
8050 if (o->op_type == OP_GV)
8051 op_null(o->op_next);
8052 op_null(pop->op_next);
8054 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
8055 o->op_next = pop->op_next->op_next;
8056 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
8057 o->op_private = (U8)i;
8058 if (o->op_type == OP_GV) {
8063 o->op_flags |= OPf_SPECIAL;
8064 o->op_type = OP_AELEMFAST;
8069 if (o->op_next->op_type == OP_RV2SV) {
8070 if (!(o->op_next->op_private & OPpDEREF)) {
8071 op_null(o->op_next);
8072 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
8074 o->op_next = o->op_next->op_next;
8075 o->op_type = OP_GVSV;
8076 o->op_ppaddr = PL_ppaddr[OP_GVSV];
8079 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
8080 GV * const gv = cGVOPo_gv;
8081 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
8082 /* XXX could check prototype here instead of just carping */
8083 SV * const sv = sv_newmortal();
8084 gv_efullname3(sv, gv, NULL);
8085 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
8086 "%"SVf"() called too early to check prototype",
8090 else if (o->op_next->op_type == OP_READLINE
8091 && o->op_next->op_next->op_type == OP_CONCAT
8092 && (o->op_next->op_next->op_flags & OPf_STACKED))
8094 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
8095 o->op_type = OP_RCATLINE;
8096 o->op_flags |= OPf_STACKED;
8097 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
8098 op_null(o->op_next->op_next);
8099 op_null(o->op_next);
8115 while (cLOGOP->op_other->op_type == OP_NULL)
8116 cLOGOP->op_other = cLOGOP->op_other->op_next;
8117 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
8122 while (cLOOP->op_redoop->op_type == OP_NULL)
8123 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
8124 peep(cLOOP->op_redoop);
8125 while (cLOOP->op_nextop->op_type == OP_NULL)
8126 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
8127 peep(cLOOP->op_nextop);
8128 while (cLOOP->op_lastop->op_type == OP_NULL)
8129 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
8130 peep(cLOOP->op_lastop);
8134 assert(!(cPMOP->op_pmflags & PMf_ONCE));
8135 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
8136 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
8137 cPMOP->op_pmstashstartu.op_pmreplstart
8138 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
8139 peep(cPMOP->op_pmstashstartu.op_pmreplstart);
8143 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
8144 && ckWARN(WARN_SYNTAX))
8146 if (o->op_next->op_sibling) {
8147 const OPCODE type = o->op_next->op_sibling->op_type;
8148 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
8149 const line_t oldline = CopLINE(PL_curcop);
8150 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
8151 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8152 "Statement unlikely to be reached");
8153 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8154 "\t(Maybe you meant system() when you said exec()?)\n");
8155 CopLINE_set(PL_curcop, oldline);
8166 const char *key = NULL;
8169 if (((BINOP*)o)->op_last->op_type != OP_CONST)
8172 /* Make the CONST have a shared SV */
8173 svp = cSVOPx_svp(((BINOP*)o)->op_last);
8174 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
8175 key = SvPV_const(sv, keylen);
8176 lexname = newSVpvn_share(key,
8177 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
8183 if ((o->op_private & (OPpLVAL_INTRO)))
8186 rop = (UNOP*)((BINOP*)o)->op_first;
8187 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
8189 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
8190 if (!SvPAD_TYPED(lexname))
8192 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8193 if (!fields || !GvHV(*fields))
8195 key = SvPV_const(*svp, keylen);
8196 if (!hv_fetch(GvHV(*fields), key,
8197 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8199 Perl_croak(aTHX_ "No such class field \"%s\" "
8200 "in variable %s of type %s",
8201 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
8214 SVOP *first_key_op, *key_op;
8216 if ((o->op_private & (OPpLVAL_INTRO))
8217 /* I bet there's always a pushmark... */
8218 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
8219 /* hmmm, no optimization if list contains only one key. */
8221 rop = (UNOP*)((LISTOP*)o)->op_last;
8222 if (rop->op_type != OP_RV2HV)
8224 if (rop->op_first->op_type == OP_PADSV)
8225 /* @$hash{qw(keys here)} */
8226 rop = (UNOP*)rop->op_first;
8228 /* @{$hash}{qw(keys here)} */
8229 if (rop->op_first->op_type == OP_SCOPE
8230 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
8232 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
8238 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
8239 if (!SvPAD_TYPED(lexname))
8241 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8242 if (!fields || !GvHV(*fields))
8244 /* Again guessing that the pushmark can be jumped over.... */
8245 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
8246 ->op_first->op_sibling;
8247 for (key_op = first_key_op; key_op;
8248 key_op = (SVOP*)key_op->op_sibling) {
8249 if (key_op->op_type != OP_CONST)
8251 svp = cSVOPx_svp(key_op);
8252 key = SvPV_const(*svp, keylen);
8253 if (!hv_fetch(GvHV(*fields), key,
8254 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8256 Perl_croak(aTHX_ "No such class field \"%s\" "
8257 "in variable %s of type %s",
8258 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
8265 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
8269 /* check that RHS of sort is a single plain array */
8270 OP *oright = cUNOPo->op_first;
8271 if (!oright || oright->op_type != OP_PUSHMARK)
8274 /* reverse sort ... can be optimised. */
8275 if (!cUNOPo->op_sibling) {
8276 /* Nothing follows us on the list. */
8277 OP * const reverse = o->op_next;
8279 if (reverse->op_type == OP_REVERSE &&
8280 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
8281 OP * const pushmark = cUNOPx(reverse)->op_first;
8282 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
8283 && (cUNOPx(pushmark)->op_sibling == o)) {
8284 /* reverse -> pushmark -> sort */
8285 o->op_private |= OPpSORT_REVERSE;
8287 pushmark->op_next = oright->op_next;
8293 /* make @a = sort @a act in-place */
8295 oright = cUNOPx(oright)->op_sibling;
8298 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
8299 oright = cUNOPx(oright)->op_sibling;
8303 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
8304 || oright->op_next != o
8305 || (oright->op_private & OPpLVAL_INTRO)
8309 /* o2 follows the chain of op_nexts through the LHS of the
8310 * assign (if any) to the aassign op itself */
8312 if (!o2 || o2->op_type != OP_NULL)
8315 if (!o2 || o2->op_type != OP_PUSHMARK)
8318 if (o2 && o2->op_type == OP_GV)
8321 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
8322 || (o2->op_private & OPpLVAL_INTRO)
8327 if (!o2 || o2->op_type != OP_NULL)
8330 if (!o2 || o2->op_type != OP_AASSIGN
8331 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
8334 /* check that the sort is the first arg on RHS of assign */
8336 o2 = cUNOPx(o2)->op_first;
8337 if (!o2 || o2->op_type != OP_NULL)
8339 o2 = cUNOPx(o2)->op_first;
8340 if (!o2 || o2->op_type != OP_PUSHMARK)
8342 if (o2->op_sibling != o)
8345 /* check the array is the same on both sides */
8346 if (oleft->op_type == OP_RV2AV) {
8347 if (oright->op_type != OP_RV2AV
8348 || !cUNOPx(oright)->op_first
8349 || cUNOPx(oright)->op_first->op_type != OP_GV
8350 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
8351 cGVOPx_gv(cUNOPx(oright)->op_first)
8355 else if (oright->op_type != OP_PADAV
8356 || oright->op_targ != oleft->op_targ
8360 /* transfer MODishness etc from LHS arg to RHS arg */
8361 oright->op_flags = oleft->op_flags;
8362 o->op_private |= OPpSORT_INPLACE;
8364 /* excise push->gv->rv2av->null->aassign */
8365 o2 = o->op_next->op_next;
8366 op_null(o2); /* PUSHMARK */
8368 if (o2->op_type == OP_GV) {
8369 op_null(o2); /* GV */
8372 op_null(o2); /* RV2AV or PADAV */
8373 o2 = o2->op_next->op_next;
8374 op_null(o2); /* AASSIGN */
8376 o->op_next = o2->op_next;
8382 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
8384 LISTOP *enter, *exlist;
8386 enter = (LISTOP *) o->op_next;
8389 if (enter->op_type == OP_NULL) {
8390 enter = (LISTOP *) enter->op_next;
8394 /* for $a (...) will have OP_GV then OP_RV2GV here.
8395 for (...) just has an OP_GV. */
8396 if (enter->op_type == OP_GV) {
8397 gvop = (OP *) enter;
8398 enter = (LISTOP *) enter->op_next;
8401 if (enter->op_type == OP_RV2GV) {
8402 enter = (LISTOP *) enter->op_next;
8408 if (enter->op_type != OP_ENTERITER)
8411 iter = enter->op_next;
8412 if (!iter || iter->op_type != OP_ITER)
8415 expushmark = enter->op_first;
8416 if (!expushmark || expushmark->op_type != OP_NULL
8417 || expushmark->op_targ != OP_PUSHMARK)
8420 exlist = (LISTOP *) expushmark->op_sibling;
8421 if (!exlist || exlist->op_type != OP_NULL
8422 || exlist->op_targ != OP_LIST)
8425 if (exlist->op_last != o) {
8426 /* Mmm. Was expecting to point back to this op. */
8429 theirmark = exlist->op_first;
8430 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
8433 if (theirmark->op_sibling != o) {
8434 /* There's something between the mark and the reverse, eg
8435 for (1, reverse (...))
8440 ourmark = ((LISTOP *)o)->op_first;
8441 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
8444 ourlast = ((LISTOP *)o)->op_last;
8445 if (!ourlast || ourlast->op_next != o)
8448 rv2av = ourmark->op_sibling;
8449 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
8450 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
8451 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
8452 /* We're just reversing a single array. */
8453 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
8454 enter->op_flags |= OPf_STACKED;
8457 /* We don't have control over who points to theirmark, so sacrifice
8459 theirmark->op_next = ourmark->op_next;
8460 theirmark->op_flags = ourmark->op_flags;
8461 ourlast->op_next = gvop ? gvop : (OP *) enter;
8464 enter->op_private |= OPpITER_REVERSED;
8465 iter->op_private |= OPpITER_REVERSED;
8472 UNOP *refgen, *rv2cv;
8475 if ((o->op_flags & OPf_WANT) != OPf_WANT_VOID)
8478 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
8481 rv2gv = ((BINOP *)o)->op_last;
8482 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
8485 refgen = (UNOP *)((BINOP *)o)->op_first;
8487 if (!refgen || refgen->op_type != OP_REFGEN)
8490 exlist = (LISTOP *)refgen->op_first;
8491 if (!exlist || exlist->op_type != OP_NULL
8492 || exlist->op_targ != OP_LIST)
8495 if (exlist->op_first->op_type != OP_PUSHMARK)
8498 rv2cv = (UNOP*)exlist->op_last;
8500 if (rv2cv->op_type != OP_RV2CV)
8503 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
8504 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
8505 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
8507 o->op_private |= OPpASSIGN_CV_TO_GV;
8508 rv2gv->op_private |= OPpDONT_INIT_GV;
8509 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
8517 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
8518 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
8528 Perl_custom_op_name(pTHX_ const OP* o)
8531 const IV index = PTR2IV(o->op_ppaddr);
8535 if (!PL_custom_op_names) /* This probably shouldn't happen */
8536 return (char *)PL_op_name[OP_CUSTOM];
8538 keysv = sv_2mortal(newSViv(index));
8540 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
8542 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
8544 return SvPV_nolen(HeVAL(he));
8548 Perl_custom_op_desc(pTHX_ const OP* o)
8551 const IV index = PTR2IV(o->op_ppaddr);
8555 if (!PL_custom_op_descs)
8556 return (char *)PL_op_desc[OP_CUSTOM];
8558 keysv = sv_2mortal(newSViv(index));
8560 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
8562 return (char *)PL_op_desc[OP_CUSTOM];
8564 return SvPV_nolen(HeVAL(he));
8569 /* Efficient sub that returns a constant scalar value. */
8571 const_sv_xsub(pTHX_ CV* cv)
8578 Perl_croak(aTHX_ "usage: %s::%s()",
8579 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
8583 ST(0) = (SV*)XSANY.any_ptr;
8589 * c-indentation-style: bsd
8591 * indent-tabs-mode: t
8594 * ex: set ts=8 sts=4 sw=4 noet: