4 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
5 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
7 * You may distribute under the terms of either the GNU General Public
8 * License or the Artistic License, as specified in the README file.
13 * 'You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
14 * our Mr. Bilbo's first cousin on the mother's side (her mother being the
15 * youngest of the Old Took's daughters); and Mr. Drogo was his second
16 * cousin. So Mr. Frodo is his first *and* second cousin, once removed
17 * either way, as the saying is, if you follow me.' --the Gaffer
19 * [p.23 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
22 /* This file contains the functions that create, manipulate and optimize
23 * the OP structures that hold a compiled perl program.
25 * A Perl program is compiled into a tree of OPs. Each op contains
26 * structural pointers (eg to its siblings and the next op in the
27 * execution sequence), a pointer to the function that would execute the
28 * op, plus any data specific to that op. For example, an OP_CONST op
29 * points to the pp_const() function and to an SV containing the constant
30 * value. When pp_const() is executed, its job is to push that SV onto the
33 * OPs are mainly created by the newFOO() functions, which are mainly
34 * called from the parser (in perly.y) as the code is parsed. For example
35 * the Perl code $a + $b * $c would cause the equivalent of the following
36 * to be called (oversimplifying a bit):
38 * newBINOP(OP_ADD, flags,
40 * newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
43 * Note that during the build of miniperl, a temporary copy of this file
44 * is made, called opmini.c.
48 Perl's compiler is essentially a 3-pass compiler with interleaved phases:
52 An execution-order pass
54 The bottom-up pass is represented by all the "newOP" routines and
55 the ck_ routines. The bottom-upness is actually driven by yacc.
56 So at the point that a ck_ routine fires, we have no idea what the
57 context is, either upward in the syntax tree, or either forward or
58 backward in the execution order. (The bottom-up parser builds that
59 part of the execution order it knows about, but if you follow the "next"
60 links around, you'll find it's actually a closed loop through the
63 Whenever the bottom-up parser gets to a node that supplies context to
64 its components, it invokes that portion of the top-down pass that applies
65 to that part of the subtree (and marks the top node as processed, so
66 if a node further up supplies context, it doesn't have to take the
67 plunge again). As a particular subcase of this, as the new node is
68 built, it takes all the closed execution loops of its subcomponents
69 and links them into a new closed loop for the higher level node. But
70 it's still not the real execution order.
72 The actual execution order is not known till we get a grammar reduction
73 to a top-level unit like a subroutine or file that will be called by
74 "name" rather than via a "next" pointer. At that point, we can call
75 into peep() to do that code's portion of the 3rd pass. It has to be
76 recursive, but it's recursive on basic blocks, not on tree nodes.
79 /* To implement user lexical pragmas, there needs to be a way at run time to
80 get the compile time state of %^H for that block. Storing %^H in every
81 block (or even COP) would be very expensive, so a different approach is
82 taken. The (running) state of %^H is serialised into a tree of HE-like
83 structs. Stores into %^H are chained onto the current leaf as a struct
84 refcounted_he * with the key and the value. Deletes from %^H are saved
85 with a value of PL_sv_placeholder. The state of %^H at any point can be
86 turned back into a regular HV by walking back up the tree from that point's
87 leaf, ignoring any key you've already seen (placeholder or not), storing
88 the rest into the HV structure, then removing the placeholders. Hence
89 memory is only used to store the %^H deltas from the enclosing COP, rather
90 than the entire %^H on each COP.
92 To cause actions on %^H to write out the serialisation records, it has
93 magic type 'H'. This magic (itself) does nothing, but its presence causes
94 the values to gain magic type 'h', which has entries for set and clear.
95 C<Perl_magic_sethint> updates C<PL_compiling.cop_hints_hash> with a store
96 record, with deletes written by C<Perl_magic_clearhint>. C<SAVEHINTS>
97 saves the current C<PL_compiling.cop_hints_hash> on the save stack, so that
98 it will be correctly restored when any inner compiling scope is exited.
104 #include "keywords.h"
106 #define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
107 #define CALL_OPFREEHOOK(o) if (PL_opfreehook) CALL_FPTR(PL_opfreehook)(aTHX_ o)
109 #if defined(PL_OP_SLAB_ALLOC)
111 #ifdef PERL_DEBUG_READONLY_OPS
112 # define PERL_SLAB_SIZE 4096
113 # include <sys/mman.h>
116 #ifndef PERL_SLAB_SIZE
117 #define PERL_SLAB_SIZE 2048
121 Perl_Slab_Alloc(pTHX_ size_t sz)
125 * To make incrementing use count easy PL_OpSlab is an I32 *
126 * To make inserting the link to slab PL_OpPtr is I32 **
127 * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
128 * Add an overhead for pointer to slab and round up as a number of pointers
130 sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
131 if ((PL_OpSpace -= sz) < 0) {
132 #ifdef PERL_DEBUG_READONLY_OPS
133 /* We need to allocate chunk by chunk so that we can control the VM
135 PL_OpPtr = (I32**) mmap(0, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE,
136 MAP_ANON|MAP_PRIVATE, -1, 0);
138 DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
139 (unsigned long) PERL_SLAB_SIZE*sizeof(I32*),
141 if(PL_OpPtr == MAP_FAILED) {
142 perror("mmap failed");
147 PL_OpPtr = (I32 **) PerlMemShared_calloc(PERL_SLAB_SIZE,sizeof(I32*));
152 /* We reserve the 0'th I32 sized chunk as a use count */
153 PL_OpSlab = (I32 *) PL_OpPtr;
154 /* Reduce size by the use count word, and by the size we need.
155 * Latter is to mimic the '-=' in the if() above
157 PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
158 /* Allocation pointer starts at the top.
159 Theory: because we build leaves before trunk allocating at end
160 means that at run time access is cache friendly upward
162 PL_OpPtr += PERL_SLAB_SIZE;
164 #ifdef PERL_DEBUG_READONLY_OPS
165 /* We remember this slab. */
166 /* This implementation isn't efficient, but it is simple. */
167 PL_slabs = (I32**) realloc(PL_slabs, sizeof(I32**) * (PL_slab_count + 1));
168 PL_slabs[PL_slab_count++] = PL_OpSlab;
169 DEBUG_m(PerlIO_printf(Perl_debug_log, "Allocate %p\n", PL_OpSlab));
172 assert( PL_OpSpace >= 0 );
173 /* Move the allocation pointer down */
175 assert( PL_OpPtr > (I32 **) PL_OpSlab );
176 *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */
177 (*PL_OpSlab)++; /* Increment use count of slab */
178 assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
179 assert( *PL_OpSlab > 0 );
180 return (void *)(PL_OpPtr + 1);
183 #ifdef PERL_DEBUG_READONLY_OPS
185 Perl_pending_Slabs_to_ro(pTHX) {
186 /* Turn all the allocated op slabs read only. */
187 U32 count = PL_slab_count;
188 I32 **const slabs = PL_slabs;
190 /* Reset the array of pending OP slabs, as we're about to turn this lot
191 read only. Also, do it ahead of the loop in case the warn triggers,
192 and a warn handler has an eval */
197 /* Force a new slab for any further allocation. */
201 void *const start = slabs[count];
202 const size_t size = PERL_SLAB_SIZE* sizeof(I32*);
203 if(mprotect(start, size, PROT_READ)) {
204 Perl_warn(aTHX_ "mprotect for %p %lu failed with %d",
205 start, (unsigned long) size, errno);
213 S_Slab_to_rw(pTHX_ void *op)
215 I32 * const * const ptr = (I32 **) op;
216 I32 * const slab = ptr[-1];
218 PERL_ARGS_ASSERT_SLAB_TO_RW;
220 assert( ptr-1 > (I32 **) slab );
221 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
223 if(mprotect(slab, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE)) {
224 Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d",
225 slab, (unsigned long) PERL_SLAB_SIZE*sizeof(I32*), errno);
230 Perl_op_refcnt_inc(pTHX_ OP *o)
241 Perl_op_refcnt_dec(pTHX_ OP *o)
243 PERL_ARGS_ASSERT_OP_REFCNT_DEC;
248 # define Slab_to_rw(op)
252 Perl_Slab_Free(pTHX_ void *op)
254 I32 * const * const ptr = (I32 **) op;
255 I32 * const slab = ptr[-1];
256 PERL_ARGS_ASSERT_SLAB_FREE;
257 assert( ptr-1 > (I32 **) slab );
258 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
261 if (--(*slab) == 0) {
263 # define PerlMemShared PerlMem
266 #ifdef PERL_DEBUG_READONLY_OPS
267 U32 count = PL_slab_count;
268 /* Need to remove this slab from our list of slabs */
271 if (PL_slabs[count] == slab) {
273 /* Found it. Move the entry at the end to overwrite it. */
274 DEBUG_m(PerlIO_printf(Perl_debug_log,
275 "Deallocate %p by moving %p from %lu to %lu\n",
277 PL_slabs[PL_slab_count - 1],
278 PL_slab_count, count));
279 PL_slabs[count] = PL_slabs[--PL_slab_count];
280 /* Could realloc smaller at this point, but probably not
282 if(munmap(slab, PERL_SLAB_SIZE*sizeof(I32*))) {
283 perror("munmap failed");
291 PerlMemShared_free(slab);
293 if (slab == PL_OpSlab) {
300 * In the following definition, the ", (OP*)0" is just to make the compiler
301 * think the expression is of the right type: croak actually does a Siglongjmp.
303 #define CHECKOP(type,o) \
304 ((PL_op_mask && PL_op_mask[type]) \
305 ? ( op_free((OP*)o), \
306 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
308 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
310 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
313 S_gv_ename(pTHX_ GV *gv)
315 SV* const tmpsv = sv_newmortal();
317 PERL_ARGS_ASSERT_GV_ENAME;
319 gv_efullname3(tmpsv, gv, NULL);
320 return SvPV_nolen_const(tmpsv);
324 S_no_fh_allowed(pTHX_ OP *o)
326 PERL_ARGS_ASSERT_NO_FH_ALLOWED;
328 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
334 S_too_few_arguments(pTHX_ OP *o, const char *name)
336 PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS;
338 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
343 S_too_many_arguments(pTHX_ OP *o, const char *name)
345 PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS;
347 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
352 S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid)
354 PERL_ARGS_ASSERT_BAD_TYPE;
356 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
357 (int)n, name, t, OP_DESC(kid)));
361 S_no_bareword_allowed(pTHX_ const OP *o)
363 PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
366 return; /* various ok barewords are hidden in extra OP_NULL */
367 qerror(Perl_mess(aTHX_
368 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
372 /* "register" allocation */
375 Perl_allocmy(pTHX_ const char *const name)
379 const bool is_our = (PL_parser->in_my == KEY_our);
381 PERL_ARGS_ASSERT_ALLOCMY;
383 /* complain about "my $<special_var>" etc etc */
387 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
388 (name[1] == '_' && (*name == '$' || name[2]))))
390 /* name[2] is true if strlen(name) > 2 */
391 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
392 yyerror(Perl_form(aTHX_ "Can't use global %c^%c%s in \"%s\"",
393 name[0], toCTRL(name[1]), name + 2,
394 PL_parser->in_my == KEY_state ? "state" : "my"));
396 yyerror(Perl_form(aTHX_ "Can't use global %s in \"%s\"",name,
397 PL_parser->in_my == KEY_state ? "state" : "my"));
401 /* check for duplicate declaration */
402 pad_check_dup(name, is_our, (PL_curstash ? PL_curstash : PL_defstash));
404 /* allocate a spare slot and store the name in that slot */
406 off = pad_add_name(name,
407 PL_parser->in_my_stash,
409 /* $_ is always in main::, even with our */
410 ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
414 PL_parser->in_my == KEY_state
416 /* anon sub prototypes contains state vars should always be cloned,
417 * otherwise the state var would be shared between anon subs */
419 if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
420 CvCLONE_on(PL_compcv);
425 /* free the body of an op without examining its contents.
426 * Always use this rather than FreeOp directly */
429 S_op_destroy(pTHX_ OP *o)
431 if (o->op_latefree) {
439 # define forget_pmop(a,b) S_forget_pmop(aTHX_ a,b)
441 # define forget_pmop(a,b) S_forget_pmop(aTHX_ a)
447 Perl_op_free(pTHX_ OP *o)
454 if (o->op_latefreed) {
461 if (o->op_private & OPpREFCOUNTED) {
472 refcnt = OpREFCNT_dec(o);
475 /* Need to find and remove any pattern match ops from the list
476 we maintain for reset(). */
477 find_and_forget_pmops(o);
487 /* Call the op_free hook if it has been set. Do it now so that it's called
488 * at the right time for refcounted ops, but still before all of the kids
492 if (o->op_flags & OPf_KIDS) {
493 register OP *kid, *nextkid;
494 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
495 nextkid = kid->op_sibling; /* Get before next freeing kid */
500 #ifdef PERL_DEBUG_READONLY_OPS
504 /* COP* is not cleared by op_clear() so that we may track line
505 * numbers etc even after null() */
506 if (type == OP_NEXTSTATE || type == OP_DBSTATE
507 || (type == OP_NULL /* the COP might have been null'ed */
508 && ((OPCODE)o->op_targ == OP_NEXTSTATE
509 || (OPCODE)o->op_targ == OP_DBSTATE))) {
514 type = (OPCODE)o->op_targ;
517 if (o->op_latefree) {
523 #ifdef DEBUG_LEAKING_SCALARS
530 Perl_op_clear(pTHX_ OP *o)
535 PERL_ARGS_ASSERT_OP_CLEAR;
538 /* if (o->op_madprop && o->op_madprop->mad_next)
540 /* FIXME for MAD - if I uncomment these two lines t/op/pack.t fails with
541 "modification of a read only value" for a reason I can't fathom why.
542 It's the "" stringification of $_, where $_ was set to '' in a foreach
543 loop, but it defies simplification into a small test case.
544 However, commenting them out has caused ext/List/Util/t/weak.t to fail
547 mad_free(o->op_madprop);
553 switch (o->op_type) {
554 case OP_NULL: /* Was holding old type, if any. */
555 if (PL_madskills && o->op_targ != OP_NULL) {
556 o->op_type = (Optype)o->op_targ;
560 case OP_ENTEREVAL: /* Was holding hints. */
564 if (!(o->op_flags & OPf_REF)
565 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
571 if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
572 /* not an OP_PADAV replacement */
573 GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV)
578 /* It's possible during global destruction that the GV is freed
579 before the optree. Whilst the SvREFCNT_inc is happy to bump from
580 0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
581 will trigger an assertion failure, because the entry to sv_clear
582 checks that the scalar is not already freed. A check of for
583 !SvIS_FREED(gv) turns out to be invalid, because during global
584 destruction the reference count can be forced down to zero
585 (with SVf_BREAK set). In which case raising to 1 and then
586 dropping to 0 triggers cleanup before it should happen. I
587 *think* that this might actually be a general, systematic,
588 weakness of the whole idea of SVf_BREAK, in that code *is*
589 allowed to raise and lower references during global destruction,
590 so any *valid* code that happens to do this during global
591 destruction might well trigger premature cleanup. */
592 bool still_valid = gv && SvREFCNT(gv);
595 SvREFCNT_inc_simple_void(gv);
597 if (cPADOPo->op_padix > 0) {
598 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
599 * may still exist on the pad */
600 pad_swipe(cPADOPo->op_padix, TRUE);
601 cPADOPo->op_padix = 0;
604 SvREFCNT_dec(cSVOPo->op_sv);
605 cSVOPo->op_sv = NULL;
608 int try_downgrade = SvREFCNT(gv) == 2;
611 gv_try_downgrade(gv);
615 case OP_METHOD_NAMED:
618 SvREFCNT_dec(cSVOPo->op_sv);
619 cSVOPo->op_sv = NULL;
622 Even if op_clear does a pad_free for the target of the op,
623 pad_free doesn't actually remove the sv that exists in the pad;
624 instead it lives on. This results in that it could be reused as
625 a target later on when the pad was reallocated.
628 pad_swipe(o->op_targ,1);
637 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
641 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
643 if (cPADOPo->op_padix > 0) {
644 pad_swipe(cPADOPo->op_padix, TRUE);
645 cPADOPo->op_padix = 0;
648 SvREFCNT_dec(cSVOPo->op_sv);
649 cSVOPo->op_sv = NULL;
653 PerlMemShared_free(cPVOPo->op_pv);
654 cPVOPo->op_pv = NULL;
658 op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
662 if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
663 /* No GvIN_PAD_off here, because other references may still
664 * exist on the pad */
665 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
668 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
674 forget_pmop(cPMOPo, 1);
675 cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
676 /* we use the same protection as the "SAFE" version of the PM_ macros
677 * here since sv_clean_all might release some PMOPs
678 * after PL_regex_padav has been cleared
679 * and the clearing of PL_regex_padav needs to
680 * happen before sv_clean_all
683 if(PL_regex_pad) { /* We could be in destruction */
684 const IV offset = (cPMOPo)->op_pmoffset;
685 ReREFCNT_dec(PM_GETRE(cPMOPo));
686 PL_regex_pad[offset] = &PL_sv_undef;
687 sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
691 ReREFCNT_dec(PM_GETRE(cPMOPo));
692 PM_SETRE(cPMOPo, NULL);
698 if (o->op_targ > 0) {
699 pad_free(o->op_targ);
705 S_cop_free(pTHX_ COP* cop)
707 PERL_ARGS_ASSERT_COP_FREE;
711 if (! specialWARN(cop->cop_warnings))
712 PerlMemShared_free(cop->cop_warnings);
713 Perl_refcounted_he_free(aTHX_ cop->cop_hints_hash);
717 S_forget_pmop(pTHX_ PMOP *const o
723 HV * const pmstash = PmopSTASH(o);
725 PERL_ARGS_ASSERT_FORGET_PMOP;
727 if (pmstash && !SvIS_FREED(pmstash)) {
728 MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
730 PMOP **const array = (PMOP**) mg->mg_ptr;
731 U32 count = mg->mg_len / sizeof(PMOP**);
736 /* Found it. Move the entry at the end to overwrite it. */
737 array[i] = array[--count];
738 mg->mg_len = count * sizeof(PMOP**);
739 /* Could realloc smaller at this point always, but probably
740 not worth it. Probably worth free()ing if we're the
743 Safefree(mg->mg_ptr);
760 S_find_and_forget_pmops(pTHX_ OP *o)
762 PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
764 if (o->op_flags & OPf_KIDS) {
765 OP *kid = cUNOPo->op_first;
767 switch (kid->op_type) {
772 forget_pmop((PMOP*)kid, 0);
774 find_and_forget_pmops(kid);
775 kid = kid->op_sibling;
781 Perl_op_null(pTHX_ OP *o)
785 PERL_ARGS_ASSERT_OP_NULL;
787 if (o->op_type == OP_NULL)
791 o->op_targ = o->op_type;
792 o->op_type = OP_NULL;
793 o->op_ppaddr = PL_ppaddr[OP_NULL];
797 Perl_op_refcnt_lock(pTHX)
805 Perl_op_refcnt_unlock(pTHX)
812 /* Contextualizers */
814 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
817 S_linklist(pTHX_ OP *o)
821 PERL_ARGS_ASSERT_LINKLIST;
826 /* establish postfix order */
827 first = cUNOPo->op_first;
830 o->op_next = LINKLIST(first);
833 if (kid->op_sibling) {
834 kid->op_next = LINKLIST(kid->op_sibling);
835 kid = kid->op_sibling;
849 S_scalarkids(pTHX_ OP *o)
851 if (o && o->op_flags & OPf_KIDS) {
853 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
860 S_scalarboolean(pTHX_ OP *o)
864 PERL_ARGS_ASSERT_SCALARBOOLEAN;
866 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
867 if (ckWARN(WARN_SYNTAX)) {
868 const line_t oldline = CopLINE(PL_curcop);
870 if (PL_parser && PL_parser->copline != NOLINE)
871 CopLINE_set(PL_curcop, PL_parser->copline);
872 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
873 CopLINE_set(PL_curcop, oldline);
880 Perl_scalar(pTHX_ OP *o)
885 /* assumes no premature commitment */
886 if (!o || (PL_parser && PL_parser->error_count)
887 || (o->op_flags & OPf_WANT)
888 || o->op_type == OP_RETURN)
893 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
895 switch (o->op_type) {
897 scalar(cBINOPo->op_first);
902 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
912 if (o->op_flags & OPf_KIDS) {
913 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
919 kid = cLISTOPo->op_first;
921 while ((kid = kid->op_sibling)) {
927 PL_curcop = &PL_compiling;
932 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
938 PL_curcop = &PL_compiling;
941 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
948 Perl_scalarvoid(pTHX_ OP *o)
952 const char* useless = NULL;
956 PERL_ARGS_ASSERT_SCALARVOID;
958 /* trailing mad null ops don't count as "there" for void processing */
960 o->op_type != OP_NULL &&
962 o->op_sibling->op_type == OP_NULL)
965 for (sib = o->op_sibling;
966 sib && sib->op_type == OP_NULL;
967 sib = sib->op_sibling) ;
973 if (o->op_type == OP_NEXTSTATE
974 || o->op_type == OP_DBSTATE
975 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
976 || o->op_targ == OP_DBSTATE)))
977 PL_curcop = (COP*)o; /* for warning below */
979 /* assumes no premature commitment */
980 want = o->op_flags & OPf_WANT;
981 if ((want && want != OPf_WANT_SCALAR)
982 || (PL_parser && PL_parser->error_count)
983 || o->op_type == OP_RETURN)
988 if ((o->op_private & OPpTARGET_MY)
989 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
991 return scalar(o); /* As if inside SASSIGN */
994 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
996 switch (o->op_type) {
998 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1002 if (o->op_flags & OPf_STACKED)
1006 if (o->op_private == 4)
1049 case OP_GETSOCKNAME:
1050 case OP_GETPEERNAME:
1055 case OP_GETPRIORITY:
1079 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1080 /* Otherwise it's "Useless use of grep iterator" */
1081 useless = OP_DESC(o);
1085 kid = cUNOPo->op_first;
1086 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1087 kid->op_type != OP_TRANS) {
1090 useless = "negative pattern binding (!~)";
1097 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1098 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1099 useless = "a variable";
1104 if (cSVOPo->op_private & OPpCONST_STRICT)
1105 no_bareword_allowed(o);
1107 if (ckWARN(WARN_VOID)) {
1109 SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_
1110 "a constant (%"SVf")", sv));
1111 useless = SvPV_nolen(msv);
1114 useless = "a constant (undef)";
1115 if (o->op_private & OPpCONST_ARYBASE)
1117 /* don't warn on optimised away booleans, eg
1118 * use constant Foo, 5; Foo || print; */
1119 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1121 /* the constants 0 and 1 are permitted as they are
1122 conventionally used as dummies in constructs like
1123 1 while some_condition_with_side_effects; */
1124 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1126 else if (SvPOK(sv)) {
1127 /* perl4's way of mixing documentation and code
1128 (before the invention of POD) was based on a
1129 trick to mix nroff and perl code. The trick was
1130 built upon these three nroff macros being used in
1131 void context. The pink camel has the details in
1132 the script wrapman near page 319. */
1133 const char * const maybe_macro = SvPVX_const(sv);
1134 if (strnEQ(maybe_macro, "di", 2) ||
1135 strnEQ(maybe_macro, "ds", 2) ||
1136 strnEQ(maybe_macro, "ig", 2))
1141 op_null(o); /* don't execute or even remember it */
1145 o->op_type = OP_PREINC; /* pre-increment is faster */
1146 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1150 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1151 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1155 o->op_type = OP_I_PREINC; /* pre-increment is faster */
1156 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1160 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
1161 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1166 kid = cLOGOPo->op_first;
1167 if (kid->op_type == OP_NOT
1168 && (kid->op_flags & OPf_KIDS)
1170 if (o->op_type == OP_AND) {
1172 o->op_ppaddr = PL_ppaddr[OP_OR];
1174 o->op_type = OP_AND;
1175 o->op_ppaddr = PL_ppaddr[OP_AND];
1184 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1189 if (o->op_flags & OPf_STACKED)
1196 if (!(o->op_flags & OPf_KIDS))
1207 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1214 /* all requires must return a boolean value */
1215 o->op_flags &= ~OPf_WANT;
1221 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
1226 S_listkids(pTHX_ OP *o)
1228 if (o && o->op_flags & OPf_KIDS) {
1230 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1237 Perl_list(pTHX_ OP *o)
1242 /* assumes no premature commitment */
1243 if (!o || (o->op_flags & OPf_WANT)
1244 || (PL_parser && PL_parser->error_count)
1245 || o->op_type == OP_RETURN)
1250 if ((o->op_private & OPpTARGET_MY)
1251 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1253 return o; /* As if inside SASSIGN */
1256 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1258 switch (o->op_type) {
1261 list(cBINOPo->op_first);
1266 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1274 if (!(o->op_flags & OPf_KIDS))
1276 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1277 list(cBINOPo->op_first);
1278 return gen_constant_list(o);
1285 kid = cLISTOPo->op_first;
1287 while ((kid = kid->op_sibling)) {
1288 if (kid->op_sibling)
1293 PL_curcop = &PL_compiling;
1297 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1298 if (kid->op_sibling)
1303 PL_curcop = &PL_compiling;
1306 /* all requires must return a boolean value */
1307 o->op_flags &= ~OPf_WANT;
1314 S_scalarseq(pTHX_ OP *o)
1318 const OPCODE type = o->op_type;
1320 if (type == OP_LINESEQ || type == OP_SCOPE ||
1321 type == OP_LEAVE || type == OP_LEAVETRY)
1324 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1325 if (kid->op_sibling) {
1329 PL_curcop = &PL_compiling;
1331 o->op_flags &= ~OPf_PARENS;
1332 if (PL_hints & HINT_BLOCK_SCOPE)
1333 o->op_flags |= OPf_PARENS;
1336 o = newOP(OP_STUB, 0);
1341 S_modkids(pTHX_ OP *o, I32 type)
1343 if (o && o->op_flags & OPf_KIDS) {
1345 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1351 /* Propagate lvalue ("modifiable") context to an op and its children.
1352 * 'type' represents the context type, roughly based on the type of op that
1353 * would do the modifying, although local() is represented by OP_NULL.
1354 * It's responsible for detecting things that can't be modified, flag
1355 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
1356 * might have to vivify a reference in $x), and so on.
1358 * For example, "$a+1 = 2" would cause mod() to be called with o being
1359 * OP_ADD and type being OP_SASSIGN, and would output an error.
1363 Perl_mod(pTHX_ OP *o, I32 type)
1367 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1370 if (!o || (PL_parser && PL_parser->error_count))
1373 if ((o->op_private & OPpTARGET_MY)
1374 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1379 switch (o->op_type) {
1385 if (!(o->op_private & OPpCONST_ARYBASE))
1388 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1389 CopARYBASE_set(&PL_compiling,
1390 (I32)SvIV(cSVOPx(PL_eval_start)->op_sv));
1394 SAVECOPARYBASE(&PL_compiling);
1395 CopARYBASE_set(&PL_compiling, 0);
1397 else if (type == OP_REFGEN)
1400 Perl_croak(aTHX_ "That use of $[ is unsupported");
1403 if ((o->op_flags & OPf_PARENS) || PL_madskills)
1407 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1408 !(o->op_flags & OPf_STACKED)) {
1409 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1410 /* The default is to set op_private to the number of children,
1411 which for a UNOP such as RV2CV is always 1. And w're using
1412 the bit for a flag in RV2CV, so we need it clear. */
1413 o->op_private &= ~1;
1414 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1415 assert(cUNOPo->op_first->op_type == OP_NULL);
1416 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1419 else if (o->op_private & OPpENTERSUB_NOMOD)
1421 else { /* lvalue subroutine call */
1422 o->op_private |= OPpLVAL_INTRO;
1423 PL_modcount = RETURN_UNLIMITED_NUMBER;
1424 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1425 /* Backward compatibility mode: */
1426 o->op_private |= OPpENTERSUB_INARGS;
1429 else { /* Compile-time error message: */
1430 OP *kid = cUNOPo->op_first;
1434 if (kid->op_type != OP_PUSHMARK) {
1435 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1437 "panic: unexpected lvalue entersub "
1438 "args: type/targ %ld:%"UVuf,
1439 (long)kid->op_type, (UV)kid->op_targ);
1440 kid = kLISTOP->op_first;
1442 while (kid->op_sibling)
1443 kid = kid->op_sibling;
1444 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1446 if (kid->op_type == OP_METHOD_NAMED
1447 || kid->op_type == OP_METHOD)
1451 NewOp(1101, newop, 1, UNOP);
1452 newop->op_type = OP_RV2CV;
1453 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1454 newop->op_first = NULL;
1455 newop->op_next = (OP*)newop;
1456 kid->op_sibling = (OP*)newop;
1457 newop->op_private |= OPpLVAL_INTRO;
1458 newop->op_private &= ~1;
1462 if (kid->op_type != OP_RV2CV)
1464 "panic: unexpected lvalue entersub "
1465 "entry via type/targ %ld:%"UVuf,
1466 (long)kid->op_type, (UV)kid->op_targ);
1467 kid->op_private |= OPpLVAL_INTRO;
1468 break; /* Postpone until runtime */
1472 kid = kUNOP->op_first;
1473 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1474 kid = kUNOP->op_first;
1475 if (kid->op_type == OP_NULL)
1477 "Unexpected constant lvalue entersub "
1478 "entry via type/targ %ld:%"UVuf,
1479 (long)kid->op_type, (UV)kid->op_targ);
1480 if (kid->op_type != OP_GV) {
1481 /* Restore RV2CV to check lvalueness */
1483 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1484 okid->op_next = kid->op_next;
1485 kid->op_next = okid;
1488 okid->op_next = NULL;
1489 okid->op_type = OP_RV2CV;
1491 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1492 okid->op_private |= OPpLVAL_INTRO;
1493 okid->op_private &= ~1;
1497 cv = GvCV(kGVOP_gv);
1507 /* grep, foreach, subcalls, refgen */
1508 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1510 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1511 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1513 : (o->op_type == OP_ENTERSUB
1514 ? "non-lvalue subroutine call"
1516 type ? PL_op_desc[type] : "local"));
1530 case OP_RIGHT_SHIFT:
1539 if (!(o->op_flags & OPf_STACKED))
1546 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1552 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1553 PL_modcount = RETURN_UNLIMITED_NUMBER;
1554 return o; /* Treat \(@foo) like ordinary list. */
1558 if (scalar_mod_type(o, type))
1560 ref(cUNOPo->op_first, o->op_type);
1564 if (type == OP_LEAVESUBLV)
1565 o->op_private |= OPpMAYBE_LVSUB;
1571 PL_modcount = RETURN_UNLIMITED_NUMBER;
1574 PL_hints |= HINT_BLOCK_SCOPE;
1575 if (type == OP_LEAVESUBLV)
1576 o->op_private |= OPpMAYBE_LVSUB;
1580 ref(cUNOPo->op_first, o->op_type);
1584 PL_hints |= HINT_BLOCK_SCOPE;
1599 PL_modcount = RETURN_UNLIMITED_NUMBER;
1600 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1601 return o; /* Treat \(@foo) like ordinary list. */
1602 if (scalar_mod_type(o, type))
1604 if (type == OP_LEAVESUBLV)
1605 o->op_private |= OPpMAYBE_LVSUB;
1609 if (!type) /* local() */
1610 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1611 PAD_COMPNAME_PV(o->op_targ));
1619 if (type != OP_SASSIGN)
1623 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1628 if (type == OP_LEAVESUBLV)
1629 o->op_private |= OPpMAYBE_LVSUB;
1631 pad_free(o->op_targ);
1632 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1633 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1634 if (o->op_flags & OPf_KIDS)
1635 mod(cBINOPo->op_first->op_sibling, type);
1640 ref(cBINOPo->op_first, o->op_type);
1641 if (type == OP_ENTERSUB &&
1642 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1643 o->op_private |= OPpLVAL_DEFER;
1644 if (type == OP_LEAVESUBLV)
1645 o->op_private |= OPpMAYBE_LVSUB;
1655 if (o->op_flags & OPf_KIDS)
1656 mod(cLISTOPo->op_last, type);
1661 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1663 else if (!(o->op_flags & OPf_KIDS))
1665 if (o->op_targ != OP_LIST) {
1666 mod(cBINOPo->op_first, type);
1672 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1677 if (type != OP_LEAVESUBLV)
1679 break; /* mod()ing was handled by ck_return() */
1682 /* [20011101.069] File test operators interpret OPf_REF to mean that
1683 their argument is a filehandle; thus \stat(".") should not set
1685 if (type == OP_REFGEN &&
1686 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1689 if (type != OP_LEAVESUBLV)
1690 o->op_flags |= OPf_MOD;
1692 if (type == OP_AASSIGN || type == OP_SASSIGN)
1693 o->op_flags |= OPf_SPECIAL|OPf_REF;
1694 else if (!type) { /* local() */
1697 o->op_private |= OPpLVAL_INTRO;
1698 o->op_flags &= ~OPf_SPECIAL;
1699 PL_hints |= HINT_BLOCK_SCOPE;
1704 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
1705 "Useless localization of %s", OP_DESC(o));
1708 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1709 && type != OP_LEAVESUBLV)
1710 o->op_flags |= OPf_REF;
1715 S_scalar_mod_type(const OP *o, I32 type)
1717 PERL_ARGS_ASSERT_SCALAR_MOD_TYPE;
1721 if (o->op_type == OP_RV2GV)
1745 case OP_RIGHT_SHIFT:
1765 S_is_handle_constructor(const OP *o, I32 numargs)
1767 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
1769 switch (o->op_type) {
1777 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1790 S_refkids(pTHX_ OP *o, I32 type)
1792 if (o && o->op_flags & OPf_KIDS) {
1794 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1801 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
1806 PERL_ARGS_ASSERT_DOREF;
1808 if (!o || (PL_parser && PL_parser->error_count))
1811 switch (o->op_type) {
1813 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1814 !(o->op_flags & OPf_STACKED)) {
1815 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1816 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1817 assert(cUNOPo->op_first->op_type == OP_NULL);
1818 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1819 o->op_flags |= OPf_SPECIAL;
1820 o->op_private &= ~1;
1825 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1826 doref(kid, type, set_op_ref);
1829 if (type == OP_DEFINED)
1830 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1831 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1834 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1835 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1836 : type == OP_RV2HV ? OPpDEREF_HV
1838 o->op_flags |= OPf_MOD;
1845 o->op_flags |= OPf_REF;
1848 if (type == OP_DEFINED)
1849 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1850 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1856 o->op_flags |= OPf_REF;
1861 if (!(o->op_flags & OPf_KIDS))
1863 doref(cBINOPo->op_first, type, set_op_ref);
1867 doref(cBINOPo->op_first, o->op_type, set_op_ref);
1868 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1869 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1870 : type == OP_RV2HV ? OPpDEREF_HV
1872 o->op_flags |= OPf_MOD;
1882 if (!(o->op_flags & OPf_KIDS))
1884 doref(cLISTOPo->op_last, type, set_op_ref);
1894 S_dup_attrlist(pTHX_ OP *o)
1899 PERL_ARGS_ASSERT_DUP_ATTRLIST;
1901 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1902 * where the first kid is OP_PUSHMARK and the remaining ones
1903 * are OP_CONST. We need to push the OP_CONST values.
1905 if (o->op_type == OP_CONST)
1906 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
1908 else if (o->op_type == OP_NULL)
1912 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1914 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1915 if (o->op_type == OP_CONST)
1916 rop = append_elem(OP_LIST, rop,
1917 newSVOP(OP_CONST, o->op_flags,
1918 SvREFCNT_inc_NN(cSVOPo->op_sv)));
1925 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1930 PERL_ARGS_ASSERT_APPLY_ATTRS;
1932 /* fake up C<use attributes $pkg,$rv,@attrs> */
1933 ENTER; /* need to protect against side-effects of 'use' */
1934 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1936 #define ATTRSMODULE "attributes"
1937 #define ATTRSMODULE_PM "attributes.pm"
1940 /* Don't force the C<use> if we don't need it. */
1941 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
1942 if (svp && *svp != &PL_sv_undef)
1943 NOOP; /* already in %INC */
1945 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1946 newSVpvs(ATTRSMODULE), NULL);
1949 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1950 newSVpvs(ATTRSMODULE),
1952 prepend_elem(OP_LIST,
1953 newSVOP(OP_CONST, 0, stashsv),
1954 prepend_elem(OP_LIST,
1955 newSVOP(OP_CONST, 0,
1957 dup_attrlist(attrs))));
1963 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1966 OP *pack, *imop, *arg;
1969 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
1974 assert(target->op_type == OP_PADSV ||
1975 target->op_type == OP_PADHV ||
1976 target->op_type == OP_PADAV);
1978 /* Ensure that attributes.pm is loaded. */
1979 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1981 /* Need package name for method call. */
1982 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
1984 /* Build up the real arg-list. */
1985 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1987 arg = newOP(OP_PADSV, 0);
1988 arg->op_targ = target->op_targ;
1989 arg = prepend_elem(OP_LIST,
1990 newSVOP(OP_CONST, 0, stashsv),
1991 prepend_elem(OP_LIST,
1992 newUNOP(OP_REFGEN, 0,
1993 mod(arg, OP_REFGEN)),
1994 dup_attrlist(attrs)));
1996 /* Fake up a method call to import */
1997 meth = newSVpvs_share("import");
1998 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1999 append_elem(OP_LIST,
2000 prepend_elem(OP_LIST, pack, list(arg)),
2001 newSVOP(OP_METHOD_NAMED, 0, meth)));
2002 imop->op_private |= OPpENTERSUB_NOMOD;
2004 /* Combine the ops. */
2005 *imopsp = append_elem(OP_LIST, *imopsp, imop);
2009 =notfor apidoc apply_attrs_string
2011 Attempts to apply a list of attributes specified by the C<attrstr> and
2012 C<len> arguments to the subroutine identified by the C<cv> argument which
2013 is expected to be associated with the package identified by the C<stashpv>
2014 argument (see L<attributes>). It gets this wrong, though, in that it
2015 does not correctly identify the boundaries of the individual attribute
2016 specifications within C<attrstr>. This is not really intended for the
2017 public API, but has to be listed here for systems such as AIX which
2018 need an explicit export list for symbols. (It's called from XS code
2019 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
2020 to respect attribute syntax properly would be welcome.
2026 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
2027 const char *attrstr, STRLEN len)
2031 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
2034 len = strlen(attrstr);
2038 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2040 const char * const sstr = attrstr;
2041 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2042 attrs = append_elem(OP_LIST, attrs,
2043 newSVOP(OP_CONST, 0,
2044 newSVpvn(sstr, attrstr-sstr)));
2048 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2049 newSVpvs(ATTRSMODULE),
2050 NULL, prepend_elem(OP_LIST,
2051 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2052 prepend_elem(OP_LIST,
2053 newSVOP(OP_CONST, 0,
2054 newRV(MUTABLE_SV(cv))),
2059 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
2064 PERL_ARGS_ASSERT_MY_KID;
2066 if (!o || (PL_parser && PL_parser->error_count))
2070 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
2071 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
2075 if (type == OP_LIST) {
2077 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2078 my_kid(kid, attrs, imopsp);
2079 } else if (type == OP_UNDEF
2085 } else if (type == OP_RV2SV || /* "our" declaration */
2087 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
2088 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
2089 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2091 PL_parser->in_my == KEY_our
2093 : PL_parser->in_my == KEY_state ? "state" : "my"));
2095 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
2096 PL_parser->in_my = FALSE;
2097 PL_parser->in_my_stash = NULL;
2098 apply_attrs(GvSTASH(gv),
2099 (type == OP_RV2SV ? GvSV(gv) :
2100 type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
2101 type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
2104 o->op_private |= OPpOUR_INTRO;
2107 else if (type != OP_PADSV &&
2110 type != OP_PUSHMARK)
2112 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2114 PL_parser->in_my == KEY_our
2116 : PL_parser->in_my == KEY_state ? "state" : "my"));
2119 else if (attrs && type != OP_PUSHMARK) {
2122 PL_parser->in_my = FALSE;
2123 PL_parser->in_my_stash = NULL;
2125 /* check for C<my Dog $spot> when deciding package */
2126 stash = PAD_COMPNAME_TYPE(o->op_targ);
2128 stash = PL_curstash;
2129 apply_attrs_my(stash, o, attrs, imopsp);
2131 o->op_flags |= OPf_MOD;
2132 o->op_private |= OPpLVAL_INTRO;
2133 if (PL_parser->in_my == KEY_state)
2134 o->op_private |= OPpPAD_STATE;
2139 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2143 int maybe_scalar = 0;
2145 PERL_ARGS_ASSERT_MY_ATTRS;
2147 /* [perl #17376]: this appears to be premature, and results in code such as
2148 C< our(%x); > executing in list mode rather than void mode */
2150 if (o->op_flags & OPf_PARENS)
2160 o = my_kid(o, attrs, &rops);
2162 if (maybe_scalar && o->op_type == OP_PADSV) {
2163 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
2164 o->op_private |= OPpLVAL_INTRO;
2167 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
2169 PL_parser->in_my = FALSE;
2170 PL_parser->in_my_stash = NULL;
2175 Perl_sawparens(pTHX_ OP *o)
2177 PERL_UNUSED_CONTEXT;
2179 o->op_flags |= OPf_PARENS;
2184 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2188 const OPCODE ltype = left->op_type;
2189 const OPCODE rtype = right->op_type;
2191 PERL_ARGS_ASSERT_BIND_MATCH;
2193 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2194 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
2196 const char * const desc
2197 = PL_op_desc[(rtype == OP_SUBST || rtype == OP_TRANS)
2198 ? (int)rtype : OP_MATCH];
2199 const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV)
2200 ? "@array" : "%hash");
2201 Perl_warner(aTHX_ packWARN(WARN_MISC),
2202 "Applying %s to %s will act on scalar(%s)",
2203 desc, sample, sample);
2206 if (rtype == OP_CONST &&
2207 cSVOPx(right)->op_private & OPpCONST_BARE &&
2208 cSVOPx(right)->op_private & OPpCONST_STRICT)
2210 no_bareword_allowed(right);
2213 ismatchop = rtype == OP_MATCH ||
2214 rtype == OP_SUBST ||
2216 if (ismatchop && right->op_private & OPpTARGET_MY) {
2218 right->op_private &= ~OPpTARGET_MY;
2220 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
2223 right->op_flags |= OPf_STACKED;
2224 if (rtype != OP_MATCH &&
2225 ! (rtype == OP_TRANS &&
2226 right->op_private & OPpTRANS_IDENTICAL))
2227 newleft = mod(left, rtype);
2230 if (right->op_type == OP_TRANS)
2231 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
2233 o = prepend_elem(rtype, scalar(newleft), right);
2235 return newUNOP(OP_NOT, 0, scalar(o));
2239 return bind_match(type, left,
2240 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
2244 Perl_invert(pTHX_ OP *o)
2248 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2252 Perl_scope(pTHX_ OP *o)
2256 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2257 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2258 o->op_type = OP_LEAVE;
2259 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2261 else if (o->op_type == OP_LINESEQ) {
2263 o->op_type = OP_SCOPE;
2264 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2265 kid = ((LISTOP*)o)->op_first;
2266 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2269 /* The following deals with things like 'do {1 for 1}' */
2270 kid = kid->op_sibling;
2272 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2277 o = newLISTOP(OP_SCOPE, 0, o, NULL);
2283 Perl_block_start(pTHX_ int full)
2286 const int retval = PL_savestack_ix;
2287 pad_block_start(full);
2289 PL_hints &= ~HINT_BLOCK_SCOPE;
2290 SAVECOMPILEWARNINGS();
2291 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
2296 Perl_block_end(pTHX_ I32 floor, OP *seq)
2299 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2300 OP* const retval = scalarseq(seq);
2302 CopHINTS_set(&PL_compiling, PL_hints);
2304 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2313 const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
2314 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
2315 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2318 OP * const o = newOP(OP_PADSV, 0);
2319 o->op_targ = offset;
2325 Perl_newPROG(pTHX_ OP *o)
2329 PERL_ARGS_ASSERT_NEWPROG;
2334 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2335 ((PL_in_eval & EVAL_KEEPERR)
2336 ? OPf_SPECIAL : 0), o);
2337 PL_eval_start = linklist(PL_eval_root);
2338 PL_eval_root->op_private |= OPpREFCOUNTED;
2339 OpREFCNT_set(PL_eval_root, 1);
2340 PL_eval_root->op_next = 0;
2341 CALL_PEEP(PL_eval_start);
2344 if (o->op_type == OP_STUB) {
2345 PL_comppad_name = 0;
2347 S_op_destroy(aTHX_ o);
2350 PL_main_root = scope(sawparens(scalarvoid(o)));
2351 PL_curcop = &PL_compiling;
2352 PL_main_start = LINKLIST(PL_main_root);
2353 PL_main_root->op_private |= OPpREFCOUNTED;
2354 OpREFCNT_set(PL_main_root, 1);
2355 PL_main_root->op_next = 0;
2356 CALL_PEEP(PL_main_start);
2359 /* Register with debugger */
2361 CV * const cv = get_cvs("DB::postponed", 0);
2365 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
2367 call_sv(MUTABLE_SV(cv), G_DISCARD);
2374 Perl_localize(pTHX_ OP *o, I32 lex)
2378 PERL_ARGS_ASSERT_LOCALIZE;
2380 if (o->op_flags & OPf_PARENS)
2381 /* [perl #17376]: this appears to be premature, and results in code such as
2382 C< our(%x); > executing in list mode rather than void mode */
2389 if ( PL_parser->bufptr > PL_parser->oldbufptr
2390 && PL_parser->bufptr[-1] == ','
2391 && ckWARN(WARN_PARENTHESIS))
2393 char *s = PL_parser->bufptr;
2396 /* some heuristics to detect a potential error */
2397 while (*s && (strchr(", \t\n", *s)))
2401 if (*s && strchr("@$%*", *s) && *++s
2402 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2405 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2407 while (*s && (strchr(", \t\n", *s)))
2413 if (sigil && (*s == ';' || *s == '=')) {
2414 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2415 "Parentheses missing around \"%s\" list",
2417 ? (PL_parser->in_my == KEY_our
2419 : PL_parser->in_my == KEY_state
2429 o = mod(o, OP_NULL); /* a bit kludgey */
2430 PL_parser->in_my = FALSE;
2431 PL_parser->in_my_stash = NULL;
2436 Perl_jmaybe(pTHX_ OP *o)
2438 PERL_ARGS_ASSERT_JMAYBE;
2440 if (o->op_type == OP_LIST) {
2442 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2443 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2449 S_fold_constants(pTHX_ register OP *o)
2452 register OP * VOL curop;
2454 VOL I32 type = o->op_type;
2459 SV * const oldwarnhook = PL_warnhook;
2460 SV * const olddiehook = PL_diehook;
2464 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
2466 if (PL_opargs[type] & OA_RETSCALAR)
2468 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2469 o->op_targ = pad_alloc(type, SVs_PADTMP);
2471 /* integerize op, unless it happens to be C<-foo>.
2472 * XXX should pp_i_negate() do magic string negation instead? */
2473 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2474 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2475 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2477 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2480 if (!(PL_opargs[type] & OA_FOLDCONST))
2485 /* XXX might want a ck_negate() for this */
2486 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2497 /* XXX what about the numeric ops? */
2498 if (PL_hints & HINT_LOCALE)
2503 if (PL_parser && PL_parser->error_count)
2504 goto nope; /* Don't try to run w/ errors */
2506 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2507 const OPCODE type = curop->op_type;
2508 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2510 type != OP_SCALAR &&
2512 type != OP_PUSHMARK)
2518 curop = LINKLIST(o);
2519 old_next = o->op_next;
2523 oldscope = PL_scopestack_ix;
2524 create_eval_scope(G_FAKINGEVAL);
2526 /* Verify that we don't need to save it: */
2527 assert(PL_curcop == &PL_compiling);
2528 StructCopy(&PL_compiling, ¬_compiling, COP);
2529 PL_curcop = ¬_compiling;
2530 /* The above ensures that we run with all the correct hints of the
2531 currently compiling COP, but that IN_PERL_RUNTIME is not true. */
2532 assert(IN_PERL_RUNTIME);
2533 PL_warnhook = PERL_WARNHOOK_FATAL;
2540 sv = *(PL_stack_sp--);
2541 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2542 pad_swipe(o->op_targ, FALSE);
2543 else if (SvTEMP(sv)) { /* grab mortal temp? */
2544 SvREFCNT_inc_simple_void(sv);
2549 /* Something tried to die. Abandon constant folding. */
2550 /* Pretend the error never happened. */
2552 o->op_next = old_next;
2556 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
2557 PL_warnhook = oldwarnhook;
2558 PL_diehook = olddiehook;
2559 /* XXX note that this croak may fail as we've already blown away
2560 * the stack - eg any nested evals */
2561 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
2564 PL_warnhook = oldwarnhook;
2565 PL_diehook = olddiehook;
2566 PL_curcop = &PL_compiling;
2568 if (PL_scopestack_ix > oldscope)
2569 delete_eval_scope();
2578 if (type == OP_RV2GV)
2579 newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
2581 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
2582 op_getmad(o,newop,'f');
2590 S_gen_constant_list(pTHX_ register OP *o)
2594 const I32 oldtmps_floor = PL_tmps_floor;
2597 if (PL_parser && PL_parser->error_count)
2598 return o; /* Don't attempt to run with errors */
2600 PL_op = curop = LINKLIST(o);
2606 assert (!(curop->op_flags & OPf_SPECIAL));
2607 assert(curop->op_type == OP_RANGE);
2609 PL_tmps_floor = oldtmps_floor;
2611 o->op_type = OP_RV2AV;
2612 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2613 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2614 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2615 o->op_opt = 0; /* needs to be revisited in peep() */
2616 curop = ((UNOP*)o)->op_first;
2617 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
2619 op_getmad(curop,o,'O');
2628 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2631 if (!o || o->op_type != OP_LIST)
2632 o = newLISTOP(OP_LIST, 0, o, NULL);
2634 o->op_flags &= ~OPf_WANT;
2636 if (!(PL_opargs[type] & OA_MARK))
2637 op_null(cLISTOPo->op_first);
2639 o->op_type = (OPCODE)type;
2640 o->op_ppaddr = PL_ppaddr[type];
2641 o->op_flags |= flags;
2643 o = CHECKOP(type, o);
2644 if (o->op_type != (unsigned)type)
2647 return fold_constants(o);
2650 /* List constructors */
2653 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2661 if (first->op_type != (unsigned)type
2662 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2664 return newLISTOP(type, 0, first, last);
2667 if (first->op_flags & OPf_KIDS)
2668 ((LISTOP*)first)->op_last->op_sibling = last;
2670 first->op_flags |= OPf_KIDS;
2671 ((LISTOP*)first)->op_first = last;
2673 ((LISTOP*)first)->op_last = last;
2678 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2686 if (first->op_type != (unsigned)type)
2687 return prepend_elem(type, (OP*)first, (OP*)last);
2689 if (last->op_type != (unsigned)type)
2690 return append_elem(type, (OP*)first, (OP*)last);
2692 first->op_last->op_sibling = last->op_first;
2693 first->op_last = last->op_last;
2694 first->op_flags |= (last->op_flags & OPf_KIDS);
2697 if (last->op_first && first->op_madprop) {
2698 MADPROP *mp = last->op_first->op_madprop;
2700 while (mp->mad_next)
2702 mp->mad_next = first->op_madprop;
2705 last->op_first->op_madprop = first->op_madprop;
2708 first->op_madprop = last->op_madprop;
2709 last->op_madprop = 0;
2712 S_op_destroy(aTHX_ (OP*)last);
2718 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2726 if (last->op_type == (unsigned)type) {
2727 if (type == OP_LIST) { /* already a PUSHMARK there */
2728 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2729 ((LISTOP*)last)->op_first->op_sibling = first;
2730 if (!(first->op_flags & OPf_PARENS))
2731 last->op_flags &= ~OPf_PARENS;
2734 if (!(last->op_flags & OPf_KIDS)) {
2735 ((LISTOP*)last)->op_last = first;
2736 last->op_flags |= OPf_KIDS;
2738 first->op_sibling = ((LISTOP*)last)->op_first;
2739 ((LISTOP*)last)->op_first = first;
2741 last->op_flags |= OPf_KIDS;
2745 return newLISTOP(type, 0, first, last);
2753 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2756 Newxz(tk, 1, TOKEN);
2757 tk->tk_type = (OPCODE)optype;
2758 tk->tk_type = 12345;
2760 tk->tk_mad = madprop;
2765 Perl_token_free(pTHX_ TOKEN* tk)
2767 PERL_ARGS_ASSERT_TOKEN_FREE;
2769 if (tk->tk_type != 12345)
2771 mad_free(tk->tk_mad);
2776 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2781 PERL_ARGS_ASSERT_TOKEN_GETMAD;
2783 if (tk->tk_type != 12345) {
2784 Perl_warner(aTHX_ packWARN(WARN_MISC),
2785 "Invalid TOKEN object ignored");
2792 /* faked up qw list? */
2794 tm->mad_type == MAD_SV &&
2795 SvPVX((SV *)tm->mad_val)[0] == 'q')
2802 /* pretend constant fold didn't happen? */
2803 if (mp->mad_key == 'f' &&
2804 (o->op_type == OP_CONST ||
2805 o->op_type == OP_GV) )
2807 token_getmad(tk,(OP*)mp->mad_val,slot);
2821 if (mp->mad_key == 'X')
2822 mp->mad_key = slot; /* just change the first one */
2832 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
2841 /* pretend constant fold didn't happen? */
2842 if (mp->mad_key == 'f' &&
2843 (o->op_type == OP_CONST ||
2844 o->op_type == OP_GV) )
2846 op_getmad(from,(OP*)mp->mad_val,slot);
2853 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
2856 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
2862 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
2871 /* pretend constant fold didn't happen? */
2872 if (mp->mad_key == 'f' &&
2873 (o->op_type == OP_CONST ||
2874 o->op_type == OP_GV) )
2876 op_getmad(from,(OP*)mp->mad_val,slot);
2883 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
2886 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
2890 PerlIO_printf(PerlIO_stderr(),
2891 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
2897 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
2915 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
2919 addmad(tm, &(o->op_madprop), slot);
2923 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
2944 Perl_newMADsv(pTHX_ char key, SV* sv)
2946 PERL_ARGS_ASSERT_NEWMADSV;
2948 return newMADPROP(key, MAD_SV, sv, 0);
2952 Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
2955 Newxz(mp, 1, MADPROP);
2958 mp->mad_vlen = vlen;
2959 mp->mad_type = type;
2961 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
2966 Perl_mad_free(pTHX_ MADPROP* mp)
2968 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
2972 mad_free(mp->mad_next);
2973 /* if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
2974 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
2975 switch (mp->mad_type) {
2979 Safefree((char*)mp->mad_val);
2982 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
2983 op_free((OP*)mp->mad_val);
2986 sv_free(MUTABLE_SV(mp->mad_val));
2989 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
2998 Perl_newNULLLIST(pTHX)
3000 return newOP(OP_STUB, 0);
3004 S_force_list(pTHX_ OP *o)
3006 if (!o || o->op_type != OP_LIST)
3007 o = newLISTOP(OP_LIST, 0, o, NULL);
3013 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3018 NewOp(1101, listop, 1, LISTOP);
3020 listop->op_type = (OPCODE)type;
3021 listop->op_ppaddr = PL_ppaddr[type];
3024 listop->op_flags = (U8)flags;
3028 else if (!first && last)
3031 first->op_sibling = last;
3032 listop->op_first = first;
3033 listop->op_last = last;
3034 if (type == OP_LIST) {
3035 OP* const pushop = newOP(OP_PUSHMARK, 0);
3036 pushop->op_sibling = first;
3037 listop->op_first = pushop;
3038 listop->op_flags |= OPf_KIDS;
3040 listop->op_last = pushop;
3043 return CHECKOP(type, listop);
3047 Perl_newOP(pTHX_ I32 type, I32 flags)
3051 NewOp(1101, o, 1, OP);
3052 o->op_type = (OPCODE)type;
3053 o->op_ppaddr = PL_ppaddr[type];
3054 o->op_flags = (U8)flags;
3056 o->op_latefreed = 0;
3060 o->op_private = (U8)(0 | (flags >> 8));
3061 if (PL_opargs[type] & OA_RETSCALAR)
3063 if (PL_opargs[type] & OA_TARGET)
3064 o->op_targ = pad_alloc(type, SVs_PADTMP);
3065 return CHECKOP(type, o);
3069 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
3075 first = newOP(OP_STUB, 0);
3076 if (PL_opargs[type] & OA_MARK)
3077 first = force_list(first);
3079 NewOp(1101, unop, 1, UNOP);
3080 unop->op_type = (OPCODE)type;
3081 unop->op_ppaddr = PL_ppaddr[type];
3082 unop->op_first = first;
3083 unop->op_flags = (U8)(flags | OPf_KIDS);
3084 unop->op_private = (U8)(1 | (flags >> 8));
3085 unop = (UNOP*) CHECKOP(type, unop);
3089 return fold_constants((OP *) unop);
3093 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3097 NewOp(1101, binop, 1, BINOP);
3100 first = newOP(OP_NULL, 0);
3102 binop->op_type = (OPCODE)type;
3103 binop->op_ppaddr = PL_ppaddr[type];
3104 binop->op_first = first;
3105 binop->op_flags = (U8)(flags | OPf_KIDS);
3108 binop->op_private = (U8)(1 | (flags >> 8));
3111 binop->op_private = (U8)(2 | (flags >> 8));
3112 first->op_sibling = last;
3115 binop = (BINOP*)CHECKOP(type, binop);
3116 if (binop->op_next || binop->op_type != (OPCODE)type)
3119 binop->op_last = binop->op_first->op_sibling;
3121 return fold_constants((OP *)binop);
3124 static int uvcompare(const void *a, const void *b)
3125 __attribute__nonnull__(1)
3126 __attribute__nonnull__(2)
3127 __attribute__pure__;
3128 static int uvcompare(const void *a, const void *b)
3130 if (*((const UV *)a) < (*(const UV *)b))
3132 if (*((const UV *)a) > (*(const UV *)b))
3134 if (*((const UV *)a+1) < (*(const UV *)b+1))
3136 if (*((const UV *)a+1) > (*(const UV *)b+1))
3142 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
3145 SV * const tstr = ((SVOP*)expr)->op_sv;
3148 (repl->op_type == OP_NULL)
3149 ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
3151 ((SVOP*)repl)->op_sv;
3154 const U8 *t = (U8*)SvPV_const(tstr, tlen);
3155 const U8 *r = (U8*)SvPV_const(rstr, rlen);
3159 register short *tbl;
3161 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
3162 const I32 squash = o->op_private & OPpTRANS_SQUASH;
3163 I32 del = o->op_private & OPpTRANS_DELETE;
3166 PERL_ARGS_ASSERT_PMTRANS;
3168 PL_hints |= HINT_BLOCK_SCOPE;
3171 o->op_private |= OPpTRANS_FROM_UTF;
3174 o->op_private |= OPpTRANS_TO_UTF;
3176 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
3177 SV* const listsv = newSVpvs("# comment\n");
3179 const U8* tend = t + tlen;
3180 const U8* rend = r + rlen;
3194 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
3195 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
3198 const U32 flags = UTF8_ALLOW_DEFAULT;
3202 t = tsave = bytes_to_utf8(t, &len);
3205 if (!to_utf && rlen) {
3207 r = rsave = bytes_to_utf8(r, &len);
3211 /* There are several snags with this code on EBCDIC:
3212 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
3213 2. scan_const() in toke.c has encoded chars in native encoding which makes
3214 ranges at least in EBCDIC 0..255 range the bottom odd.
3218 U8 tmpbuf[UTF8_MAXBYTES+1];
3221 Newx(cp, 2*tlen, UV);
3223 transv = newSVpvs("");
3225 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3227 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
3229 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3233 cp[2*i+1] = cp[2*i];
3237 qsort(cp, i, 2*sizeof(UV), uvcompare);
3238 for (j = 0; j < i; j++) {
3240 diff = val - nextmin;
3242 t = uvuni_to_utf8(tmpbuf,nextmin);
3243 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3245 U8 range_mark = UTF_TO_NATIVE(0xff);
3246 t = uvuni_to_utf8(tmpbuf, val - 1);
3247 sv_catpvn(transv, (char *)&range_mark, 1);
3248 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3255 t = uvuni_to_utf8(tmpbuf,nextmin);
3256 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3258 U8 range_mark = UTF_TO_NATIVE(0xff);
3259 sv_catpvn(transv, (char *)&range_mark, 1);
3261 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
3262 UNICODE_ALLOW_SUPER);
3263 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3264 t = (const U8*)SvPVX_const(transv);
3265 tlen = SvCUR(transv);
3269 else if (!rlen && !del) {
3270 r = t; rlen = tlen; rend = tend;
3273 if ((!rlen && !del) || t == r ||
3274 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
3276 o->op_private |= OPpTRANS_IDENTICAL;
3280 while (t < tend || tfirst <= tlast) {
3281 /* see if we need more "t" chars */
3282 if (tfirst > tlast) {
3283 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3285 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
3287 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3294 /* now see if we need more "r" chars */
3295 if (rfirst > rlast) {
3297 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3299 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
3301 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3310 rfirst = rlast = 0xffffffff;
3314 /* now see which range will peter our first, if either. */
3315 tdiff = tlast - tfirst;
3316 rdiff = rlast - rfirst;
3323 if (rfirst == 0xffffffff) {
3324 diff = tdiff; /* oops, pretend rdiff is infinite */
3326 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
3327 (long)tfirst, (long)tlast);
3329 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
3333 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
3334 (long)tfirst, (long)(tfirst + diff),
3337 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3338 (long)tfirst, (long)rfirst);
3340 if (rfirst + diff > max)
3341 max = rfirst + diff;
3343 grows = (tfirst < rfirst &&
3344 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3356 else if (max > 0xff)
3361 PerlMemShared_free(cPVOPo->op_pv);
3362 cPVOPo->op_pv = NULL;
3364 swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
3366 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
3367 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
3368 PAD_SETSV(cPADOPo->op_padix, swash);
3370 SvREADONLY_on(swash);
3372 cSVOPo->op_sv = swash;
3374 SvREFCNT_dec(listsv);
3375 SvREFCNT_dec(transv);
3377 if (!del && havefinal && rlen)
3378 (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
3379 newSVuv((UV)final), 0);
3382 o->op_private |= OPpTRANS_GROWS;
3388 op_getmad(expr,o,'e');
3389 op_getmad(repl,o,'r');
3397 tbl = (short*)cPVOPo->op_pv;
3399 Zero(tbl, 256, short);
3400 for (i = 0; i < (I32)tlen; i++)
3402 for (i = 0, j = 0; i < 256; i++) {
3404 if (j >= (I32)rlen) {
3413 if (i < 128 && r[j] >= 128)
3423 o->op_private |= OPpTRANS_IDENTICAL;
3425 else if (j >= (I32)rlen)
3430 PerlMemShared_realloc(tbl,
3431 (0x101+rlen-j) * sizeof(short));
3432 cPVOPo->op_pv = (char*)tbl;
3434 tbl[0x100] = (short)(rlen - j);
3435 for (i=0; i < (I32)rlen - j; i++)
3436 tbl[0x101+i] = r[j+i];
3440 if (!rlen && !del) {
3443 o->op_private |= OPpTRANS_IDENTICAL;
3445 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3446 o->op_private |= OPpTRANS_IDENTICAL;
3448 for (i = 0; i < 256; i++)
3450 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3451 if (j >= (I32)rlen) {
3453 if (tbl[t[i]] == -1)
3459 if (tbl[t[i]] == -1) {
3460 if (t[i] < 128 && r[j] >= 128)
3467 if(del && rlen == tlen) {
3468 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
3469 } else if(rlen > tlen) {
3470 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
3474 o->op_private |= OPpTRANS_GROWS;
3476 op_getmad(expr,o,'e');
3477 op_getmad(repl,o,'r');
3487 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3492 NewOp(1101, pmop, 1, PMOP);
3493 pmop->op_type = (OPCODE)type;
3494 pmop->op_ppaddr = PL_ppaddr[type];
3495 pmop->op_flags = (U8)flags;
3496 pmop->op_private = (U8)(0 | (flags >> 8));
3498 if (PL_hints & HINT_RE_TAINT)
3499 pmop->op_pmflags |= PMf_RETAINT;
3500 if (PL_hints & HINT_LOCALE)
3501 pmop->op_pmflags |= PMf_LOCALE;
3505 assert(SvPOK(PL_regex_pad[0]));
3506 if (SvCUR(PL_regex_pad[0])) {
3507 /* Pop off the "packed" IV from the end. */
3508 SV *const repointer_list = PL_regex_pad[0];
3509 const char *p = SvEND(repointer_list) - sizeof(IV);
3510 const IV offset = *((IV*)p);
3512 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
3514 SvEND_set(repointer_list, p);
3516 pmop->op_pmoffset = offset;
3517 /* This slot should be free, so assert this: */
3518 assert(PL_regex_pad[offset] == &PL_sv_undef);
3520 SV * const repointer = &PL_sv_undef;
3521 av_push(PL_regex_padav, repointer);
3522 pmop->op_pmoffset = av_len(PL_regex_padav);
3523 PL_regex_pad = AvARRAY(PL_regex_padav);
3527 return CHECKOP(type, pmop);
3530 /* Given some sort of match op o, and an expression expr containing a
3531 * pattern, either compile expr into a regex and attach it to o (if it's
3532 * constant), or convert expr into a runtime regcomp op sequence (if it's
3535 * isreg indicates that the pattern is part of a regex construct, eg
3536 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3537 * split "pattern", which aren't. In the former case, expr will be a list
3538 * if the pattern contains more than one term (eg /a$b/) or if it contains
3539 * a replacement, ie s/// or tr///.
3543 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
3548 I32 repl_has_vars = 0;
3552 PERL_ARGS_ASSERT_PMRUNTIME;
3554 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
3555 /* last element in list is the replacement; pop it */
3557 repl = cLISTOPx(expr)->op_last;
3558 kid = cLISTOPx(expr)->op_first;
3559 while (kid->op_sibling != repl)
3560 kid = kid->op_sibling;
3561 kid->op_sibling = NULL;
3562 cLISTOPx(expr)->op_last = kid;
3565 if (isreg && expr->op_type == OP_LIST &&
3566 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3568 /* convert single element list to element */
3569 OP* const oe = expr;
3570 expr = cLISTOPx(oe)->op_first->op_sibling;
3571 cLISTOPx(oe)->op_first->op_sibling = NULL;
3572 cLISTOPx(oe)->op_last = NULL;
3576 if (o->op_type == OP_TRANS) {
3577 return pmtrans(o, expr, repl);
3580 reglist = isreg && expr->op_type == OP_LIST;
3584 PL_hints |= HINT_BLOCK_SCOPE;
3587 if (expr->op_type == OP_CONST) {
3588 SV *pat = ((SVOP*)expr)->op_sv;
3589 U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
3591 if (o->op_flags & OPf_SPECIAL)
3592 pm_flags |= RXf_SPLIT;
3595 assert (SvUTF8(pat));
3596 } else if (SvUTF8(pat)) {
3597 /* Not doing UTF-8, despite what the SV says. Is this only if we're
3598 trapped in use 'bytes'? */
3599 /* Make a copy of the octet sequence, but without the flag on, as
3600 the compiler now honours the SvUTF8 flag on pat. */
3602 const char *const p = SvPV(pat, len);
3603 pat = newSVpvn_flags(p, len, SVs_TEMP);
3606 PM_SETRE(pm, CALLREGCOMP(pat, pm_flags));
3609 op_getmad(expr,(OP*)pm,'e');
3615 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3616 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3618 : OP_REGCMAYBE),0,expr);
3620 NewOp(1101, rcop, 1, LOGOP);
3621 rcop->op_type = OP_REGCOMP;
3622 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3623 rcop->op_first = scalar(expr);
3624 rcop->op_flags |= OPf_KIDS
3625 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3626 | (reglist ? OPf_STACKED : 0);
3627 rcop->op_private = 1;
3630 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3632 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
3635 /* establish postfix order */
3636 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3638 rcop->op_next = expr;
3639 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3642 rcop->op_next = LINKLIST(expr);
3643 expr->op_next = (OP*)rcop;
3646 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3651 if (pm->op_pmflags & PMf_EVAL) {
3653 if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
3654 CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
3656 else if (repl->op_type == OP_CONST)
3660 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3661 if (curop->op_type == OP_SCOPE
3662 || curop->op_type == OP_LEAVE
3663 || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
3664 if (curop->op_type == OP_GV) {
3665 GV * const gv = cGVOPx_gv(curop);
3667 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3670 else if (curop->op_type == OP_RV2CV)
3672 else if (curop->op_type == OP_RV2SV ||
3673 curop->op_type == OP_RV2AV ||
3674 curop->op_type == OP_RV2HV ||
3675 curop->op_type == OP_RV2GV) {
3676 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3679 else if (curop->op_type == OP_PADSV ||
3680 curop->op_type == OP_PADAV ||
3681 curop->op_type == OP_PADHV ||
3682 curop->op_type == OP_PADANY)
3686 else if (curop->op_type == OP_PUSHRE)
3687 NOOP; /* Okay here, dangerous in newASSIGNOP */
3697 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
3699 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3700 prepend_elem(o->op_type, scalar(repl), o);
3703 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3704 pm->op_pmflags |= PMf_MAYBE_CONST;
3706 NewOp(1101, rcop, 1, LOGOP);
3707 rcop->op_type = OP_SUBSTCONT;
3708 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3709 rcop->op_first = scalar(repl);
3710 rcop->op_flags |= OPf_KIDS;
3711 rcop->op_private = 1;
3714 /* establish postfix order */
3715 rcop->op_next = LINKLIST(repl);
3716 repl->op_next = (OP*)rcop;
3718 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
3719 assert(!(pm->op_pmflags & PMf_ONCE));
3720 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
3729 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3734 PERL_ARGS_ASSERT_NEWSVOP;
3736 NewOp(1101, svop, 1, SVOP);
3737 svop->op_type = (OPCODE)type;
3738 svop->op_ppaddr = PL_ppaddr[type];
3740 svop->op_next = (OP*)svop;
3741 svop->op_flags = (U8)flags;
3742 if (PL_opargs[type] & OA_RETSCALAR)
3744 if (PL_opargs[type] & OA_TARGET)
3745 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3746 return CHECKOP(type, svop);
3751 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3756 PERL_ARGS_ASSERT_NEWPADOP;
3758 NewOp(1101, padop, 1, PADOP);
3759 padop->op_type = (OPCODE)type;
3760 padop->op_ppaddr = PL_ppaddr[type];
3761 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3762 SvREFCNT_dec(PAD_SVl(padop->op_padix));
3763 PAD_SETSV(padop->op_padix, sv);
3766 padop->op_next = (OP*)padop;
3767 padop->op_flags = (U8)flags;
3768 if (PL_opargs[type] & OA_RETSCALAR)
3770 if (PL_opargs[type] & OA_TARGET)
3771 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3772 return CHECKOP(type, padop);
3777 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3781 PERL_ARGS_ASSERT_NEWGVOP;
3785 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3787 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3792 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3796 NewOp(1101, pvop, 1, PVOP);
3797 pvop->op_type = (OPCODE)type;
3798 pvop->op_ppaddr = PL_ppaddr[type];
3800 pvop->op_next = (OP*)pvop;
3801 pvop->op_flags = (U8)flags;
3802 if (PL_opargs[type] & OA_RETSCALAR)
3804 if (PL_opargs[type] & OA_TARGET)
3805 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3806 return CHECKOP(type, pvop);
3814 Perl_package(pTHX_ OP *o)
3817 SV *const sv = cSVOPo->op_sv;
3822 PERL_ARGS_ASSERT_PACKAGE;
3824 save_hptr(&PL_curstash);
3825 save_item(PL_curstname);
3827 PL_curstash = gv_stashsv(sv, GV_ADD);
3829 sv_setsv(PL_curstname, sv);
3831 PL_hints |= HINT_BLOCK_SCOPE;
3832 PL_parser->copline = NOLINE;
3833 PL_parser->expect = XSTATE;
3838 if (!PL_madskills) {
3843 pegop = newOP(OP_NULL,0);
3844 op_getmad(o,pegop,'P');
3850 Perl_package_version( pTHX_ OP *v )
3853 U32 savehints = PL_hints;
3854 PERL_ARGS_ASSERT_PACKAGE_VERSION;
3855 PL_hints &= ~HINT_STRICT_VARS;
3856 sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
3857 PL_hints = savehints;
3866 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3873 OP *pegop = newOP(OP_NULL,0);
3876 PERL_ARGS_ASSERT_UTILIZE;
3878 if (idop->op_type != OP_CONST)
3879 Perl_croak(aTHX_ "Module name must be constant");
3882 op_getmad(idop,pegop,'U');
3887 SV * const vesv = ((SVOP*)version)->op_sv;
3890 op_getmad(version,pegop,'V');
3891 if (!arg && !SvNIOKp(vesv)) {
3898 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3899 Perl_croak(aTHX_ "Version number must be a constant number");
3901 /* Make copy of idop so we don't free it twice */
3902 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3904 /* Fake up a method call to VERSION */
3905 meth = newSVpvs_share("VERSION");
3906 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3907 append_elem(OP_LIST,
3908 prepend_elem(OP_LIST, pack, list(version)),
3909 newSVOP(OP_METHOD_NAMED, 0, meth)));
3913 /* Fake up an import/unimport */
3914 if (arg && arg->op_type == OP_STUB) {
3916 op_getmad(arg,pegop,'S');
3917 imop = arg; /* no import on explicit () */
3919 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3920 imop = NULL; /* use 5.0; */
3922 idop->op_private |= OPpCONST_NOVER;
3928 op_getmad(arg,pegop,'A');
3930 /* Make copy of idop so we don't free it twice */
3931 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3933 /* Fake up a method call to import/unimport */
3935 ? newSVpvs_share("import") : newSVpvs_share("unimport");
3936 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3937 append_elem(OP_LIST,
3938 prepend_elem(OP_LIST, pack, list(arg)),
3939 newSVOP(OP_METHOD_NAMED, 0, meth)));
3942 /* Fake up the BEGIN {}, which does its thing immediately. */
3944 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
3947 append_elem(OP_LINESEQ,
3948 append_elem(OP_LINESEQ,
3949 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
3950 newSTATEOP(0, NULL, veop)),
3951 newSTATEOP(0, NULL, imop) ));
3953 /* The "did you use incorrect case?" warning used to be here.
3954 * The problem is that on case-insensitive filesystems one
3955 * might get false positives for "use" (and "require"):
3956 * "use Strict" or "require CARP" will work. This causes
3957 * portability problems for the script: in case-strict
3958 * filesystems the script will stop working.
3960 * The "incorrect case" warning checked whether "use Foo"
3961 * imported "Foo" to your namespace, but that is wrong, too:
3962 * there is no requirement nor promise in the language that
3963 * a Foo.pm should or would contain anything in package "Foo".
3965 * There is very little Configure-wise that can be done, either:
3966 * the case-sensitivity of the build filesystem of Perl does not
3967 * help in guessing the case-sensitivity of the runtime environment.
3970 PL_hints |= HINT_BLOCK_SCOPE;
3971 PL_parser->copline = NOLINE;
3972 PL_parser->expect = XSTATE;
3973 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3976 if (!PL_madskills) {
3977 /* FIXME - don't allocate pegop if !PL_madskills */
3986 =head1 Embedding Functions
3988 =for apidoc load_module
3990 Loads the module whose name is pointed to by the string part of name.
3991 Note that the actual module name, not its filename, should be given.
3992 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3993 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3994 (or 0 for no flags). ver, if specified, provides version semantics
3995 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3996 arguments can be used to specify arguments to the module's import()
3997 method, similar to C<use Foo::Bar VERSION LIST>. They must be
3998 terminated with a final NULL pointer. Note that this list can only
3999 be omitted when the PERL_LOADMOD_NOIMPORT flag has been used.
4000 Otherwise at least a single NULL pointer to designate the default
4001 import list is required.
4006 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
4010 PERL_ARGS_ASSERT_LOAD_MODULE;
4012 va_start(args, ver);
4013 vload_module(flags, name, ver, &args);
4017 #ifdef PERL_IMPLICIT_CONTEXT
4019 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
4023 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
4024 va_start(args, ver);
4025 vload_module(flags, name, ver, &args);
4031 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
4035 OP * const modname = newSVOP(OP_CONST, 0, name);
4037 PERL_ARGS_ASSERT_VLOAD_MODULE;
4039 modname->op_private |= OPpCONST_BARE;
4041 veop = newSVOP(OP_CONST, 0, ver);
4045 if (flags & PERL_LOADMOD_NOIMPORT) {
4046 imop = sawparens(newNULLLIST());
4048 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
4049 imop = va_arg(*args, OP*);
4054 sv = va_arg(*args, SV*);
4056 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
4057 sv = va_arg(*args, SV*);
4061 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
4062 * that it has a PL_parser to play with while doing that, and also
4063 * that it doesn't mess with any existing parser, by creating a tmp
4064 * new parser with lex_start(). This won't actually be used for much,
4065 * since pp_require() will create another parser for the real work. */
4068 SAVEVPTR(PL_curcop);
4069 lex_start(NULL, NULL, FALSE);
4070 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
4071 veop, modname, imop);
4076 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
4082 PERL_ARGS_ASSERT_DOFILE;
4084 if (!force_builtin) {
4085 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
4086 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
4087 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
4088 gv = gvp ? *gvp : NULL;
4092 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
4093 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
4094 append_elem(OP_LIST, term,
4095 scalar(newUNOP(OP_RV2CV, 0,
4096 newGVOP(OP_GV, 0, gv))))));
4099 doop = newUNOP(OP_DOFILE, 0, scalar(term));
4105 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
4107 return newBINOP(OP_LSLICE, flags,
4108 list(force_list(subscript)),
4109 list(force_list(listval)) );
4113 S_is_list_assignment(pTHX_ register const OP *o)
4121 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
4122 o = cUNOPo->op_first;
4124 flags = o->op_flags;
4126 if (type == OP_COND_EXPR) {
4127 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
4128 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
4133 yyerror("Assignment to both a list and a scalar");
4137 if (type == OP_LIST &&
4138 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
4139 o->op_private & OPpLVAL_INTRO)
4142 if (type == OP_LIST || flags & OPf_PARENS ||
4143 type == OP_RV2AV || type == OP_RV2HV ||
4144 type == OP_ASLICE || type == OP_HSLICE)
4147 if (type == OP_PADAV || type == OP_PADHV)
4150 if (type == OP_RV2SV)
4157 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
4163 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
4164 return newLOGOP(optype, 0,
4165 mod(scalar(left), optype),
4166 newUNOP(OP_SASSIGN, 0, scalar(right)));
4169 return newBINOP(optype, OPf_STACKED,
4170 mod(scalar(left), optype), scalar(right));
4174 if (is_list_assignment(left)) {
4175 static const char no_list_state[] = "Initialization of state variables"
4176 " in list context currently forbidden";
4178 bool maybe_common_vars = TRUE;
4181 /* Grandfathering $[ assignment here. Bletch.*/
4182 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
4183 PL_eval_start = (left->op_type == OP_CONST) ? right : NULL;
4184 left = mod(left, OP_AASSIGN);
4187 else if (left->op_type == OP_CONST) {
4189 /* Result of assignment is always 1 (or we'd be dead already) */
4190 return newSVOP(OP_CONST, 0, newSViv(1));
4192 curop = list(force_list(left));
4193 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
4194 o->op_private = (U8)(0 | (flags >> 8));
4196 if ((left->op_type == OP_LIST
4197 || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
4199 OP* lop = ((LISTOP*)left)->op_first;
4200 maybe_common_vars = FALSE;
4202 if (lop->op_type == OP_PADSV ||
4203 lop->op_type == OP_PADAV ||
4204 lop->op_type == OP_PADHV ||
4205 lop->op_type == OP_PADANY) {
4206 if (!(lop->op_private & OPpLVAL_INTRO))
4207 maybe_common_vars = TRUE;
4209 if (lop->op_private & OPpPAD_STATE) {
4210 if (left->op_private & OPpLVAL_INTRO) {
4211 /* Each variable in state($a, $b, $c) = ... */
4214 /* Each state variable in
4215 (state $a, my $b, our $c, $d, undef) = ... */
4217 yyerror(no_list_state);
4219 /* Each my variable in
4220 (state $a, my $b, our $c, $d, undef) = ... */
4222 } else if (lop->op_type == OP_UNDEF ||
4223 lop->op_type == OP_PUSHMARK) {
4224 /* undef may be interesting in
4225 (state $a, undef, state $c) */
4227 /* Other ops in the list. */
4228 maybe_common_vars = TRUE;
4230 lop = lop->op_sibling;
4233 else if ((left->op_private & OPpLVAL_INTRO)
4234 && ( left->op_type == OP_PADSV
4235 || left->op_type == OP_PADAV
4236 || left->op_type == OP_PADHV
4237 || left->op_type == OP_PADANY))
4239 maybe_common_vars = FALSE;
4240 if (left->op_private & OPpPAD_STATE) {
4241 /* All single variable list context state assignments, hence
4251 yyerror(no_list_state);
4255 /* PL_generation sorcery:
4256 * an assignment like ($a,$b) = ($c,$d) is easier than
4257 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
4258 * To detect whether there are common vars, the global var
4259 * PL_generation is incremented for each assign op we compile.
4260 * Then, while compiling the assign op, we run through all the
4261 * variables on both sides of the assignment, setting a spare slot
4262 * in each of them to PL_generation. If any of them already have
4263 * that value, we know we've got commonality. We could use a
4264 * single bit marker, but then we'd have to make 2 passes, first
4265 * to clear the flag, then to test and set it. To find somewhere
4266 * to store these values, evil chicanery is done with SvUVX().
4269 if (maybe_common_vars) {
4272 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4273 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
4274 if (curop->op_type == OP_GV) {
4275 GV *gv = cGVOPx_gv(curop);
4277 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4279 GvASSIGN_GENERATION_set(gv, PL_generation);
4281 else if (curop->op_type == OP_PADSV ||
4282 curop->op_type == OP_PADAV ||
4283 curop->op_type == OP_PADHV ||
4284 curop->op_type == OP_PADANY)
4286 if (PAD_COMPNAME_GEN(curop->op_targ)
4287 == (STRLEN)PL_generation)
4289 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
4292 else if (curop->op_type == OP_RV2CV)
4294 else if (curop->op_type == OP_RV2SV ||
4295 curop->op_type == OP_RV2AV ||
4296 curop->op_type == OP_RV2HV ||
4297 curop->op_type == OP_RV2GV) {
4298 if (lastop->op_type != OP_GV) /* funny deref? */
4301 else if (curop->op_type == OP_PUSHRE) {
4303 if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
4304 GV *const gv = MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff));
4306 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4308 GvASSIGN_GENERATION_set(gv, PL_generation);
4312 = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
4315 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4317 GvASSIGN_GENERATION_set(gv, PL_generation);
4327 o->op_private |= OPpASSIGN_COMMON;
4330 if (right && right->op_type == OP_SPLIT && !PL_madskills) {
4331 OP* tmpop = ((LISTOP*)right)->op_first;
4332 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
4333 PMOP * const pm = (PMOP*)tmpop;
4334 if (left->op_type == OP_RV2AV &&
4335 !(left->op_private & OPpLVAL_INTRO) &&
4336 !(o->op_private & OPpASSIGN_COMMON) )
4338 tmpop = ((UNOP*)left)->op_first;
4339 if (tmpop->op_type == OP_GV
4341 && !pm->op_pmreplrootu.op_pmtargetoff
4343 && !pm->op_pmreplrootu.op_pmtargetgv
4347 pm->op_pmreplrootu.op_pmtargetoff
4348 = cPADOPx(tmpop)->op_padix;
4349 cPADOPx(tmpop)->op_padix = 0; /* steal it */
4351 pm->op_pmreplrootu.op_pmtargetgv
4352 = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
4353 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
4355 pm->op_pmflags |= PMf_ONCE;
4356 tmpop = cUNOPo->op_first; /* to list (nulled) */
4357 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
4358 tmpop->op_sibling = NULL; /* don't free split */
4359 right->op_next = tmpop->op_next; /* fix starting loc */
4360 op_free(o); /* blow off assign */
4361 right->op_flags &= ~OPf_WANT;
4362 /* "I don't know and I don't care." */
4367 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
4368 ((LISTOP*)right)->op_last->op_type == OP_CONST)
4370 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
4371 if (SvIOK(sv) && SvIVX(sv) == 0)
4372 sv_setiv(sv, PL_modcount+1);
4380 right = newOP(OP_UNDEF, 0);
4381 if (right->op_type == OP_READLINE) {
4382 right->op_flags |= OPf_STACKED;
4383 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
4386 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
4387 o = newBINOP(OP_SASSIGN, flags,
4388 scalar(right), mod(scalar(left), OP_SASSIGN) );
4392 if (!PL_madskills) { /* assignment to $[ is ignored when making a mad dump */
4393 deprecate("assignment to $[");
4395 o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
4396 o->op_private |= OPpCONST_ARYBASE;
4404 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
4407 const U32 seq = intro_my();
4410 NewOp(1101, cop, 1, COP);
4411 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
4412 cop->op_type = OP_DBSTATE;
4413 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
4416 cop->op_type = OP_NEXTSTATE;
4417 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
4419 cop->op_flags = (U8)flags;
4420 CopHINTS_set(cop, PL_hints);
4422 cop->op_private |= NATIVE_HINTS;
4424 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
4425 cop->op_next = (OP*)cop;
4428 /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
4429 CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
4431 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
4432 cop->cop_hints_hash = PL_curcop->cop_hints_hash;
4433 if (cop->cop_hints_hash) {
4435 cop->cop_hints_hash->refcounted_he_refcnt++;
4436 HINTS_REFCNT_UNLOCK;
4440 = Perl_store_cop_label(aTHX_ cop->cop_hints_hash, label);
4442 PL_hints |= HINT_BLOCK_SCOPE;
4443 /* It seems that we need to defer freeing this pointer, as other parts
4444 of the grammar end up wanting to copy it after this op has been
4449 if (PL_parser && PL_parser->copline == NOLINE)
4450 CopLINE_set(cop, CopLINE(PL_curcop));
4452 CopLINE_set(cop, PL_parser->copline);
4454 PL_parser->copline = NOLINE;
4457 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
4459 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
4461 CopSTASH_set(cop, PL_curstash);
4463 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash) {
4464 /* this line can have a breakpoint - store the cop in IV */
4465 AV *av = CopFILEAVx(PL_curcop);
4467 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
4468 if (svp && *svp != &PL_sv_undef ) {
4469 (void)SvIOK_on(*svp);
4470 SvIV_set(*svp, PTR2IV(cop));
4475 if (flags & OPf_SPECIAL)
4477 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
4482 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
4486 PERL_ARGS_ASSERT_NEWLOGOP;
4488 return new_logop(type, flags, &first, &other);
4492 S_search_const(pTHX_ OP *o)
4494 PERL_ARGS_ASSERT_SEARCH_CONST;
4496 switch (o->op_type) {
4500 if (o->op_flags & OPf_KIDS)
4501 return search_const(cUNOPo->op_first);
4508 if (!(o->op_flags & OPf_KIDS))
4510 kid = cLISTOPo->op_first;
4512 switch (kid->op_type) {
4516 kid = kid->op_sibling;
4519 if (kid != cLISTOPo->op_last)
4525 kid = cLISTOPo->op_last;
4527 return search_const(kid);
4535 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
4543 int prepend_not = 0;
4545 PERL_ARGS_ASSERT_NEW_LOGOP;
4550 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
4551 return newBINOP(type, flags, scalar(first), scalar(other));
4553 scalarboolean(first);
4554 /* optimize AND and OR ops that have NOTs as children */
4555 if (first->op_type == OP_NOT
4556 && (first->op_flags & OPf_KIDS)
4557 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
4558 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
4560 if (type == OP_AND || type == OP_OR) {
4566 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
4568 prepend_not = 1; /* prepend a NOT op later */
4572 /* search for a constant op that could let us fold the test */
4573 if ((cstop = search_const(first))) {
4574 if (cstop->op_private & OPpCONST_STRICT)
4575 no_bareword_allowed(cstop);
4576 else if ((cstop->op_private & OPpCONST_BARE))
4577 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
4578 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
4579 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
4580 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
4582 if (other->op_type == OP_CONST)
4583 other->op_private |= OPpCONST_SHORTCIRCUIT;
4585 OP *newop = newUNOP(OP_NULL, 0, other);
4586 op_getmad(first, newop, '1');
4587 newop->op_targ = type; /* set "was" field */
4591 if (other->op_type == OP_LEAVE)
4592 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
4596 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
4597 const OP *o2 = other;
4598 if ( ! (o2->op_type == OP_LIST
4599 && (( o2 = cUNOPx(o2)->op_first))
4600 && o2->op_type == OP_PUSHMARK
4601 && (( o2 = o2->op_sibling)) )
4604 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
4605 || o2->op_type == OP_PADHV)
4606 && o2->op_private & OPpLVAL_INTRO
4607 && !(o2->op_private & OPpPAD_STATE))
4609 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
4610 "Deprecated use of my() in false conditional");
4614 if (first->op_type == OP_CONST)
4615 first->op_private |= OPpCONST_SHORTCIRCUIT;
4617 first = newUNOP(OP_NULL, 0, first);
4618 op_getmad(other, first, '2');
4619 first->op_targ = type; /* set "was" field */
4626 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
4627 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
4629 const OP * const k1 = ((UNOP*)first)->op_first;
4630 const OP * const k2 = k1->op_sibling;
4632 switch (first->op_type)
4635 if (k2 && k2->op_type == OP_READLINE
4636 && (k2->op_flags & OPf_STACKED)
4637 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4639 warnop = k2->op_type;
4644 if (k1->op_type == OP_READDIR
4645 || k1->op_type == OP_GLOB
4646 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4647 || k1->op_type == OP_EACH)
4649 warnop = ((k1->op_type == OP_NULL)
4650 ? (OPCODE)k1->op_targ : k1->op_type);
4655 const line_t oldline = CopLINE(PL_curcop);
4656 CopLINE_set(PL_curcop, PL_parser->copline);
4657 Perl_warner(aTHX_ packWARN(WARN_MISC),
4658 "Value of %s%s can be \"0\"; test with defined()",
4660 ((warnop == OP_READLINE || warnop == OP_GLOB)
4661 ? " construct" : "() operator"));
4662 CopLINE_set(PL_curcop, oldline);
4669 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
4670 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
4672 NewOp(1101, logop, 1, LOGOP);
4674 logop->op_type = (OPCODE)type;
4675 logop->op_ppaddr = PL_ppaddr[type];
4676 logop->op_first = first;
4677 logop->op_flags = (U8)(flags | OPf_KIDS);
4678 logop->op_other = LINKLIST(other);
4679 logop->op_private = (U8)(1 | (flags >> 8));
4681 /* establish postfix order */
4682 logop->op_next = LINKLIST(first);
4683 first->op_next = (OP*)logop;
4684 first->op_sibling = other;
4686 CHECKOP(type,logop);
4688 o = newUNOP(prepend_not ? OP_NOT : OP_NULL, 0, (OP*)logop);
4695 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
4703 PERL_ARGS_ASSERT_NEWCONDOP;
4706 return newLOGOP(OP_AND, 0, first, trueop);
4708 return newLOGOP(OP_OR, 0, first, falseop);
4710 scalarboolean(first);
4711 if ((cstop = search_const(first))) {
4712 /* Left or right arm of the conditional? */
4713 const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
4714 OP *live = left ? trueop : falseop;
4715 OP *const dead = left ? falseop : trueop;
4716 if (cstop->op_private & OPpCONST_BARE &&
4717 cstop->op_private & OPpCONST_STRICT) {
4718 no_bareword_allowed(cstop);
4721 /* This is all dead code when PERL_MAD is not defined. */
4722 live = newUNOP(OP_NULL, 0, live);
4723 op_getmad(first, live, 'C');
4724 op_getmad(dead, live, left ? 'e' : 't');
4729 if (live->op_type == OP_LEAVE)
4730 live = newUNOP(OP_NULL, OPf_SPECIAL, live);
4733 NewOp(1101, logop, 1, LOGOP);
4734 logop->op_type = OP_COND_EXPR;
4735 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4736 logop->op_first = first;
4737 logop->op_flags = (U8)(flags | OPf_KIDS);
4738 logop->op_private = (U8)(1 | (flags >> 8));
4739 logop->op_other = LINKLIST(trueop);
4740 logop->op_next = LINKLIST(falseop);
4742 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
4745 /* establish postfix order */
4746 start = LINKLIST(first);
4747 first->op_next = (OP*)logop;
4749 first->op_sibling = trueop;
4750 trueop->op_sibling = falseop;
4751 o = newUNOP(OP_NULL, 0, (OP*)logop);
4753 trueop->op_next = falseop->op_next = o;
4760 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4769 PERL_ARGS_ASSERT_NEWRANGE;
4771 NewOp(1101, range, 1, LOGOP);
4773 range->op_type = OP_RANGE;
4774 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4775 range->op_first = left;
4776 range->op_flags = OPf_KIDS;
4777 leftstart = LINKLIST(left);
4778 range->op_other = LINKLIST(right);
4779 range->op_private = (U8)(1 | (flags >> 8));
4781 left->op_sibling = right;
4783 range->op_next = (OP*)range;
4784 flip = newUNOP(OP_FLIP, flags, (OP*)range);
4785 flop = newUNOP(OP_FLOP, 0, flip);
4786 o = newUNOP(OP_NULL, 0, flop);
4788 range->op_next = leftstart;
4790 left->op_next = flip;
4791 right->op_next = flop;
4793 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4794 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4795 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4796 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4798 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4799 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4802 if (!flip->op_private || !flop->op_private)
4803 linklist(o); /* blow off optimizer unless constant */
4809 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4814 const bool once = block && block->op_flags & OPf_SPECIAL &&
4815 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4817 PERL_UNUSED_ARG(debuggable);
4820 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4821 return block; /* do {} while 0 does once */
4822 if (expr->op_type == OP_READLINE
4823 || expr->op_type == OP_READDIR
4824 || expr->op_type == OP_GLOB
4825 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4826 expr = newUNOP(OP_DEFINED, 0,
4827 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4828 } else if (expr->op_flags & OPf_KIDS) {
4829 const OP * const k1 = ((UNOP*)expr)->op_first;
4830 const OP * const k2 = k1 ? k1->op_sibling : NULL;
4831 switch (expr->op_type) {
4833 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
4834 && (k2->op_flags & OPf_STACKED)
4835 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4836 expr = newUNOP(OP_DEFINED, 0, expr);
4840 if (k1 && (k1->op_type == OP_READDIR
4841 || k1->op_type == OP_GLOB
4842 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4843 || k1->op_type == OP_EACH))
4844 expr = newUNOP(OP_DEFINED, 0, expr);
4850 /* if block is null, the next append_elem() would put UNSTACK, a scalar
4851 * op, in listop. This is wrong. [perl #27024] */
4853 block = newOP(OP_NULL, 0);
4854 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4855 o = new_logop(OP_AND, 0, &expr, &listop);
4858 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4860 if (once && o != listop)
4861 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4864 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
4866 o->op_flags |= flags;
4868 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4873 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
4874 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
4883 PERL_UNUSED_ARG(debuggable);
4886 if (expr->op_type == OP_READLINE
4887 || expr->op_type == OP_READDIR
4888 || expr->op_type == OP_GLOB
4889 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4890 expr = newUNOP(OP_DEFINED, 0,
4891 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4892 } else if (expr->op_flags & OPf_KIDS) {
4893 const OP * const k1 = ((UNOP*)expr)->op_first;
4894 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
4895 switch (expr->op_type) {
4897 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
4898 && (k2->op_flags & OPf_STACKED)
4899 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4900 expr = newUNOP(OP_DEFINED, 0, expr);
4904 if (k1 && (k1->op_type == OP_READDIR
4905 || k1->op_type == OP_GLOB
4906 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4907 || k1->op_type == OP_EACH))
4908 expr = newUNOP(OP_DEFINED, 0, expr);
4915 block = newOP(OP_NULL, 0);
4916 else if (cont || has_my) {
4917 block = scope(block);
4921 next = LINKLIST(cont);
4924 OP * const unstack = newOP(OP_UNSTACK, 0);
4927 cont = append_elem(OP_LINESEQ, cont, unstack);
4931 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4933 redo = LINKLIST(listop);
4936 PL_parser->copline = (line_t)whileline;
4938 o = new_logop(OP_AND, 0, &expr, &listop);
4939 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4940 op_free(expr); /* oops, it's a while (0) */
4942 return NULL; /* listop already freed by new_logop */
4945 ((LISTOP*)listop)->op_last->op_next =
4946 (o == listop ? redo : LINKLIST(o));
4952 NewOp(1101,loop,1,LOOP);
4953 loop->op_type = OP_ENTERLOOP;
4954 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4955 loop->op_private = 0;
4956 loop->op_next = (OP*)loop;
4959 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4961 loop->op_redoop = redo;
4962 loop->op_lastop = o;
4963 o->op_private |= loopflags;
4966 loop->op_nextop = next;
4968 loop->op_nextop = o;
4970 o->op_flags |= flags;
4971 o->op_private |= (flags >> 8);
4976 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
4981 PADOFFSET padoff = 0;
4986 PERL_ARGS_ASSERT_NEWFOROP;
4989 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4990 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
4991 sv->op_type = OP_RV2GV;
4992 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4994 /* The op_type check is needed to prevent a possible segfault
4995 * if the loop variable is undeclared and 'strict vars' is in
4996 * effect. This is illegal but is nonetheless parsed, so we
4997 * may reach this point with an OP_CONST where we're expecting
5000 if (cUNOPx(sv)->op_first->op_type == OP_GV
5001 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
5002 iterpflags |= OPpITER_DEF;
5004 else if (sv->op_type == OP_PADSV) { /* private variable */
5005 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
5006 padoff = sv->op_targ;
5016 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
5018 SV *const namesv = PAD_COMPNAME_SV(padoff);
5020 const char *const name = SvPV_const(namesv, len);
5022 if (len == 2 && name[0] == '$' && name[1] == '_')
5023 iterpflags |= OPpITER_DEF;
5027 const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
5028 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
5029 sv = newGVOP(OP_GV, 0, PL_defgv);
5034 iterpflags |= OPpITER_DEF;
5036 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
5037 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
5038 iterflags |= OPf_STACKED;
5040 else if (expr->op_type == OP_NULL &&
5041 (expr->op_flags & OPf_KIDS) &&
5042 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
5044 /* Basically turn for($x..$y) into the same as for($x,$y), but we
5045 * set the STACKED flag to indicate that these values are to be
5046 * treated as min/max values by 'pp_iterinit'.
5048 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
5049 LOGOP* const range = (LOGOP*) flip->op_first;
5050 OP* const left = range->op_first;
5051 OP* const right = left->op_sibling;
5054 range->op_flags &= ~OPf_KIDS;
5055 range->op_first = NULL;
5057 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
5058 listop->op_first->op_next = range->op_next;
5059 left->op_next = range->op_other;
5060 right->op_next = (OP*)listop;
5061 listop->op_next = listop->op_first;
5064 op_getmad(expr,(OP*)listop,'O');
5068 expr = (OP*)(listop);
5070 iterflags |= OPf_STACKED;
5073 expr = mod(force_list(expr), OP_GREPSTART);
5076 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
5077 append_elem(OP_LIST, expr, scalar(sv))));
5078 assert(!loop->op_next);
5079 /* for my $x () sets OPpLVAL_INTRO;
5080 * for our $x () sets OPpOUR_INTRO */
5081 loop->op_private = (U8)iterpflags;
5082 #ifdef PL_OP_SLAB_ALLOC
5085 NewOp(1234,tmp,1,LOOP);
5086 Copy(loop,tmp,1,LISTOP);
5087 S_op_destroy(aTHX_ (OP*)loop);
5091 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
5093 loop->op_targ = padoff;
5094 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
5096 op_getmad(madsv, (OP*)loop, 'v');
5097 PL_parser->copline = forline;
5098 return newSTATEOP(0, label, wop);
5102 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
5107 PERL_ARGS_ASSERT_NEWLOOPEX;
5109 if (type != OP_GOTO || label->op_type == OP_CONST) {
5110 /* "last()" means "last" */
5111 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
5112 o = newOP(type, OPf_SPECIAL);
5114 o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
5115 ? SvPV_nolen_const(((SVOP*)label)->op_sv)
5119 op_getmad(label,o,'L');
5125 /* Check whether it's going to be a goto &function */
5126 if (label->op_type == OP_ENTERSUB
5127 && !(label->op_flags & OPf_STACKED))
5128 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
5129 o = newUNOP(type, OPf_STACKED, label);
5131 PL_hints |= HINT_BLOCK_SCOPE;
5135 /* if the condition is a literal array or hash
5136 (or @{ ... } etc), make a reference to it.
5139 S_ref_array_or_hash(pTHX_ OP *cond)
5142 && (cond->op_type == OP_RV2AV
5143 || cond->op_type == OP_PADAV
5144 || cond->op_type == OP_RV2HV
5145 || cond->op_type == OP_PADHV))
5147 return newUNOP(OP_REFGEN,
5148 0, mod(cond, OP_REFGEN));
5154 /* These construct the optree fragments representing given()
5157 entergiven and enterwhen are LOGOPs; the op_other pointer
5158 points up to the associated leave op. We need this so we
5159 can put it in the context and make break/continue work.
5160 (Also, of course, pp_enterwhen will jump straight to
5161 op_other if the match fails.)
5165 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
5166 I32 enter_opcode, I32 leave_opcode,
5167 PADOFFSET entertarg)
5173 PERL_ARGS_ASSERT_NEWGIVWHENOP;
5175 NewOp(1101, enterop, 1, LOGOP);
5176 enterop->op_type = (Optype)enter_opcode;
5177 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
5178 enterop->op_flags = (U8) OPf_KIDS;
5179 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
5180 enterop->op_private = 0;
5182 o = newUNOP(leave_opcode, 0, (OP *) enterop);
5185 enterop->op_first = scalar(cond);
5186 cond->op_sibling = block;
5188 o->op_next = LINKLIST(cond);
5189 cond->op_next = (OP *) enterop;
5192 /* This is a default {} block */
5193 enterop->op_first = block;
5194 enterop->op_flags |= OPf_SPECIAL;
5196 o->op_next = (OP *) enterop;
5199 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
5200 entergiven and enterwhen both
5203 enterop->op_next = LINKLIST(block);
5204 block->op_next = enterop->op_other = o;
5209 /* Does this look like a boolean operation? For these purposes
5210 a boolean operation is:
5211 - a subroutine call [*]
5212 - a logical connective
5213 - a comparison operator
5214 - a filetest operator, with the exception of -s -M -A -C
5215 - defined(), exists() or eof()
5216 - /$re/ or $foo =~ /$re/
5218 [*] possibly surprising
5221 S_looks_like_bool(pTHX_ const OP *o)
5225 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
5227 switch(o->op_type) {
5230 return looks_like_bool(cLOGOPo->op_first);
5234 looks_like_bool(cLOGOPo->op_first)
5235 && looks_like_bool(cLOGOPo->op_first->op_sibling));
5239 o->op_flags & OPf_KIDS
5240 && looks_like_bool(cUNOPo->op_first));
5243 return looks_like_bool(cUNOPo->op_first);
5248 case OP_NOT: case OP_XOR:
5250 case OP_EQ: case OP_NE: case OP_LT:
5251 case OP_GT: case OP_LE: case OP_GE:
5253 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
5254 case OP_I_GT: case OP_I_LE: case OP_I_GE:
5256 case OP_SEQ: case OP_SNE: case OP_SLT:
5257 case OP_SGT: case OP_SLE: case OP_SGE:
5261 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
5262 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
5263 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
5264 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
5265 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
5266 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
5267 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
5268 case OP_FTTEXT: case OP_FTBINARY:
5270 case OP_DEFINED: case OP_EXISTS:
5271 case OP_MATCH: case OP_EOF:
5278 /* Detect comparisons that have been optimized away */
5279 if (cSVOPo->op_sv == &PL_sv_yes
5280 || cSVOPo->op_sv == &PL_sv_no)
5293 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
5296 PERL_ARGS_ASSERT_NEWGIVENOP;
5297 return newGIVWHENOP(
5298 ref_array_or_hash(cond),
5300 OP_ENTERGIVEN, OP_LEAVEGIVEN,
5304 /* If cond is null, this is a default {} block */
5306 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
5308 const bool cond_llb = (!cond || looks_like_bool(cond));
5311 PERL_ARGS_ASSERT_NEWWHENOP;
5316 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
5318 scalar(ref_array_or_hash(cond)));
5321 return newGIVWHENOP(
5323 append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
5324 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
5328 =for apidoc cv_undef
5330 Clear out all the active components of a CV. This can happen either
5331 by an explicit C<undef &foo>, or by the reference count going to zero.
5332 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
5333 children can still follow the full lexical scope chain.
5339 Perl_cv_undef(pTHX_ CV *cv)
5343 PERL_ARGS_ASSERT_CV_UNDEF;
5345 DEBUG_X(PerlIO_printf(Perl_debug_log,
5346 "CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n",
5347 PTR2UV(cv), PTR2UV(PL_comppad))
5351 if (CvFILE(cv) && !CvISXSUB(cv)) {
5352 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
5353 Safefree(CvFILE(cv));
5358 if (!CvISXSUB(cv) && CvROOT(cv)) {
5359 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
5360 Perl_croak(aTHX_ "Can't undef active subroutine");
5363 PAD_SAVE_SETNULLPAD();
5365 op_free(CvROOT(cv));
5370 SvPOK_off(MUTABLE_SV(cv)); /* forget prototype */
5375 /* remove CvOUTSIDE unless this is an undef rather than a free */
5376 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
5377 if (!CvWEAKOUTSIDE(cv))
5378 SvREFCNT_dec(CvOUTSIDE(cv));
5379 CvOUTSIDE(cv) = NULL;
5382 SvREFCNT_dec(MUTABLE_SV(CvXSUBANY(cv).any_ptr));
5385 if (CvISXSUB(cv) && CvXSUB(cv)) {
5388 /* delete all flags except WEAKOUTSIDE */
5389 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
5393 Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
5396 PERL_ARGS_ASSERT_CV_CKPROTO_LEN;
5398 /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
5399 relying on SvCUR, and doubling up the buffer to hold CvFILE(). */
5400 if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
5401 || (p && (len != SvCUR(cv) /* Not the same length. */
5402 || memNE(p, SvPVX_const(cv), len))))
5403 && ckWARN_d(WARN_PROTOTYPE)) {
5404 SV* const msg = sv_newmortal();
5408 gv_efullname3(name = sv_newmortal(), gv, NULL);
5409 sv_setpvs(msg, "Prototype mismatch:");
5411 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
5413 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv));
5415 sv_catpvs(msg, ": none");
5416 sv_catpvs(msg, " vs ");
5418 Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
5420 sv_catpvs(msg, "none");
5421 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
5425 static void const_sv_xsub(pTHX_ CV* cv);
5429 =head1 Optree Manipulation Functions
5431 =for apidoc cv_const_sv
5433 If C<cv> is a constant sub eligible for inlining. returns the constant
5434 value returned by the sub. Otherwise, returns NULL.
5436 Constant subs can be created with C<newCONSTSUB> or as described in
5437 L<perlsub/"Constant Functions">.
5442 Perl_cv_const_sv(pTHX_ const CV *const cv)
5444 PERL_UNUSED_CONTEXT;
5447 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
5449 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
5452 /* op_const_sv: examine an optree to determine whether it's in-lineable.
5453 * Can be called in 3 ways:
5456 * look for a single OP_CONST with attached value: return the value
5458 * cv && CvCLONE(cv) && !CvCONST(cv)
5460 * examine the clone prototype, and if contains only a single
5461 * OP_CONST referencing a pad const, or a single PADSV referencing
5462 * an outer lexical, return a non-zero value to indicate the CV is
5463 * a candidate for "constizing" at clone time
5467 * We have just cloned an anon prototype that was marked as a const
5468 * candidiate. Try to grab the current value, and in the case of
5469 * PADSV, ignore it if it has multiple references. Return the value.
5473 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
5484 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
5485 o = cLISTOPo->op_first->op_sibling;
5487 for (; o; o = o->op_next) {
5488 const OPCODE type = o->op_type;
5490 if (sv && o->op_next == o)
5492 if (o->op_next != o) {
5493 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
5495 if (type == OP_DBSTATE)
5498 if (type == OP_LEAVESUB || type == OP_RETURN)
5502 if (type == OP_CONST && cSVOPo->op_sv)
5504 else if (cv && type == OP_CONST) {
5505 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5509 else if (cv && type == OP_PADSV) {
5510 if (CvCONST(cv)) { /* newly cloned anon */
5511 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5512 /* the candidate should have 1 ref from this pad and 1 ref
5513 * from the parent */
5514 if (!sv || SvREFCNT(sv) != 2)
5521 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
5522 sv = &PL_sv_undef; /* an arbitrary non-null value */
5537 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5540 /* This would be the return value, but the return cannot be reached. */
5541 OP* pegop = newOP(OP_NULL, 0);
5544 PERL_UNUSED_ARG(floor);
5554 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
5556 NORETURN_FUNCTION_END;
5561 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
5563 return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
5567 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5573 register CV *cv = NULL;
5575 /* If the subroutine has no body, no attributes, and no builtin attributes
5576 then it's just a sub declaration, and we may be able to get away with
5577 storing with a placeholder scalar in the symbol table, rather than a
5578 full GV and CV. If anything is present then it will take a full CV to
5580 const I32 gv_fetch_flags
5581 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5583 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
5584 const char * const name = o ? SvPV_nolen_const(cSVOPo->op_sv) : NULL;
5588 assert(proto->op_type == OP_CONST);
5589 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
5595 gv = gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV);
5597 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
5598 SV * const sv = sv_newmortal();
5599 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
5600 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
5601 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
5602 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
5604 } else if (PL_curstash) {
5605 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
5608 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
5612 if (!PL_madskills) {
5621 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
5622 maximum a prototype before. */
5623 if (SvTYPE(gv) > SVt_NULL) {
5624 if (!SvPOK((const SV *)gv)
5625 && !(SvIOK((const SV *)gv) && SvIVX((const SV *)gv) == -1))
5627 Perl_ck_warner_d(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
5629 cv_ckproto_len((const CV *)gv, NULL, ps, ps_len);
5632 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
5634 sv_setiv(MUTABLE_SV(gv), -1);
5636 SvREFCNT_dec(PL_compcv);
5637 cv = PL_compcv = NULL;
5641 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
5643 if (!block || !ps || *ps || attrs
5644 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5646 || block->op_type == OP_NULL
5651 const_sv = op_const_sv(block, NULL);
5654 const bool exists = CvROOT(cv) || CvXSUB(cv);
5656 /* if the subroutine doesn't exist and wasn't pre-declared
5657 * with a prototype, assume it will be AUTOLOADed,
5658 * skipping the prototype check
5660 if (exists || SvPOK(cv))
5661 cv_ckproto_len(cv, gv, ps, ps_len);
5662 /* already defined (or promised)? */
5663 if (exists || GvASSUMECV(gv)) {
5666 || block->op_type == OP_NULL
5669 if (CvFLAGS(PL_compcv)) {
5670 /* might have had built-in attrs applied */
5671 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5673 /* just a "sub foo;" when &foo is already defined */
5674 SAVEFREESV(PL_compcv);
5679 && block->op_type != OP_NULL
5682 if (ckWARN(WARN_REDEFINE)
5684 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
5686 const line_t oldline = CopLINE(PL_curcop);
5687 if (PL_parser && PL_parser->copline != NOLINE)
5688 CopLINE_set(PL_curcop, PL_parser->copline);
5689 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5690 CvCONST(cv) ? "Constant subroutine %s redefined"
5691 : "Subroutine %s redefined", name);
5692 CopLINE_set(PL_curcop, oldline);
5695 if (!PL_minus_c) /* keep old one around for madskills */
5698 /* (PL_madskills unset in used file.) */
5706 SvREFCNT_inc_simple_void_NN(const_sv);
5708 assert(!CvROOT(cv) && !CvCONST(cv));
5709 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
5710 CvXSUBANY(cv).any_ptr = const_sv;
5711 CvXSUB(cv) = const_sv_xsub;
5717 cv = newCONSTSUB(NULL, name, const_sv);
5719 mro_method_changed_in( /* sub Foo::Bar () { 123 } */
5720 (CvGV(cv) && GvSTASH(CvGV(cv)))
5729 SvREFCNT_dec(PL_compcv);
5733 if (cv) { /* must reuse cv if autoloaded */
5734 /* transfer PL_compcv to cv */
5737 && block->op_type != OP_NULL
5741 CvFLAGS(cv) = CvFLAGS(PL_compcv);
5742 if (!CvWEAKOUTSIDE(cv))
5743 SvREFCNT_dec(CvOUTSIDE(cv));
5744 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
5745 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
5746 CvOUTSIDE(PL_compcv) = 0;
5747 CvPADLIST(cv) = CvPADLIST(PL_compcv);
5748 CvPADLIST(PL_compcv) = 0;
5749 /* inner references to PL_compcv must be fixed up ... */
5750 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
5751 if (PERLDB_INTER)/* Advice debugger on the new sub. */
5752 ++PL_sub_generation;
5755 /* Might have had built-in attributes applied -- propagate them. */
5756 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5758 /* ... before we throw it away */
5759 SvREFCNT_dec(PL_compcv);
5767 if (strEQ(name, "import")) {
5768 PL_formfeed = MUTABLE_SV(cv);
5769 Perl_warner(aTHX_ packWARN(WARN_VOID), "%lx\n", (long)cv);
5773 mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */
5778 CvFILE_set_from_cop(cv, PL_curcop);
5779 CvSTASH(cv) = PL_curstash;
5782 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
5783 HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash;
5784 apply_attrs(stash, MUTABLE_SV(cv), attrs, FALSE);
5788 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
5790 if (PL_parser && PL_parser->error_count) {
5794 const char *s = strrchr(name, ':');
5796 if (strEQ(s, "BEGIN")) {
5797 const char not_safe[] =
5798 "BEGIN not safe after errors--compilation aborted";
5799 if (PL_in_eval & EVAL_KEEPERR)
5800 Perl_croak(aTHX_ not_safe);
5802 /* force display of errors found but not reported */
5803 sv_catpv(ERRSV, not_safe);
5804 Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
5813 /* If we assign an optree to a PVCV, then we've defined a subroutine that
5814 the debugger could be able to set a breakpoint in, so signal to
5815 pp_entereval that it should not throw away any saved lines at scope
5818 PL_breakable_sub_gen++;
5820 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5821 mod(scalarseq(block), OP_LEAVESUBLV));
5822 block->op_attached = 1;
5825 /* This makes sub {}; work as expected. */
5826 if (block->op_type == OP_STUB) {
5827 OP* const newblock = newSTATEOP(0, NULL, 0);
5829 op_getmad(block,newblock,'B');
5836 block->op_attached = 1;
5837 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5839 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5840 OpREFCNT_set(CvROOT(cv), 1);
5841 CvSTART(cv) = LINKLIST(CvROOT(cv));
5842 CvROOT(cv)->op_next = 0;
5843 CALL_PEEP(CvSTART(cv));
5845 /* now that optimizer has done its work, adjust pad values */
5847 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
5850 assert(!CvCONST(cv));
5851 if (ps && !*ps && op_const_sv(block, cv))
5856 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5857 SV * const sv = newSV(0);
5858 SV * const tmpstr = sv_newmortal();
5859 GV * const db_postponed = gv_fetchpvs("DB::postponed",
5860 GV_ADDMULTI, SVt_PVHV);
5863 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5865 (long)PL_subline, (long)CopLINE(PL_curcop));
5866 gv_efullname3(tmpstr, gv, NULL);
5867 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
5868 SvCUR(tmpstr), sv, 0);
5869 hv = GvHVn(db_postponed);
5870 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
5871 CV * const pcv = GvCV(db_postponed);
5877 call_sv(MUTABLE_SV(pcv), G_DISCARD);
5882 if (name && ! (PL_parser && PL_parser->error_count))
5883 process_special_blocks(name, gv, cv);
5888 PL_parser->copline = NOLINE;
5894 S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
5897 const char *const colon = strrchr(fullname,':');
5898 const char *const name = colon ? colon + 1 : fullname;
5900 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
5903 if (strEQ(name, "BEGIN")) {
5904 const I32 oldscope = PL_scopestack_ix;
5906 SAVECOPFILE(&PL_compiling);
5907 SAVECOPLINE(&PL_compiling);
5909 DEBUG_x( dump_sub(gv) );
5910 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
5911 GvCV(gv) = 0; /* cv has been hijacked */
5912 call_list(oldscope, PL_beginav);
5914 PL_curcop = &PL_compiling;
5915 CopHINTS_set(&PL_compiling, PL_hints);
5922 if strEQ(name, "END") {
5923 DEBUG_x( dump_sub(gv) );
5924 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
5927 } else if (*name == 'U') {
5928 if (strEQ(name, "UNITCHECK")) {
5929 /* It's never too late to run a unitcheck block */
5930 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
5934 } else if (*name == 'C') {
5935 if (strEQ(name, "CHECK")) {
5937 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
5938 "Too late to run CHECK block");
5939 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
5943 } else if (*name == 'I') {
5944 if (strEQ(name, "INIT")) {
5946 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
5947 "Too late to run INIT block");
5948 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
5954 DEBUG_x( dump_sub(gv) );
5955 GvCV(gv) = 0; /* cv has been hijacked */
5960 =for apidoc newCONSTSUB
5962 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5963 eligible for inlining at compile-time.
5965 Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>,
5966 which won't be called if used as a destructor, but will suppress the overhead
5967 of a call to C<AUTOLOAD>. (This form, however, isn't eligible for inlining at
5974 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
5979 const char *const file = CopFILE(PL_curcop);
5981 SV *const temp_sv = CopFILESV(PL_curcop);
5982 const char *const file = temp_sv ? SvPV_nolen_const(temp_sv) : NULL;
5987 if (IN_PERL_RUNTIME) {
5988 /* at runtime, it's not safe to manipulate PL_curcop: it may be
5989 * an op shared between threads. Use a non-shared COP for our
5991 SAVEVPTR(PL_curcop);
5992 PL_curcop = &PL_compiling;
5994 SAVECOPLINE(PL_curcop);
5995 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
5998 PL_hints &= ~HINT_BLOCK_SCOPE;
6001 SAVESPTR(PL_curstash);
6002 SAVECOPSTASH(PL_curcop);
6003 PL_curstash = stash;
6004 CopSTASH_set(PL_curcop,stash);
6007 /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
6008 and so doesn't get free()d. (It's expected to be from the C pre-
6009 processor __FILE__ directive). But we need a dynamically allocated one,
6010 and we need it to get freed. */
6011 cv = newXS_flags(name, const_sv_xsub, file ? file : "", "",
6012 XS_DYNAMIC_FILENAME);
6013 CvXSUBANY(cv).any_ptr = sv;
6018 CopSTASH_free(PL_curcop);
6026 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
6027 const char *const filename, const char *const proto,
6030 CV *cv = newXS(name, subaddr, filename);
6032 PERL_ARGS_ASSERT_NEWXS_FLAGS;
6034 if (flags & XS_DYNAMIC_FILENAME) {
6035 /* We need to "make arrangements" (ie cheat) to ensure that the
6036 filename lasts as long as the PVCV we just created, but also doesn't
6038 STRLEN filename_len = strlen(filename);
6039 STRLEN proto_and_file_len = filename_len;
6040 char *proto_and_file;
6044 proto_len = strlen(proto);
6045 proto_and_file_len += proto_len;
6047 Newx(proto_and_file, proto_and_file_len + 1, char);
6048 Copy(proto, proto_and_file, proto_len, char);
6049 Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
6052 proto_and_file = savepvn(filename, filename_len);
6055 /* This gets free()d. :-) */
6056 sv_usepvn_flags(MUTABLE_SV(cv), proto_and_file, proto_and_file_len,
6057 SV_HAS_TRAILING_NUL);
6059 /* This gives us the correct prototype, rather than one with the
6060 file name appended. */
6061 SvCUR_set(cv, proto_len);
6065 CvFILE(cv) = proto_and_file + proto_len;
6067 sv_setpv(MUTABLE_SV(cv), proto);
6073 =for apidoc U||newXS
6075 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
6076 static storage, as it is used directly as CvFILE(), without a copy being made.
6082 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
6085 GV * const gv = gv_fetchpv(name ? name :
6086 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
6087 GV_ADDMULTI, SVt_PVCV);
6090 PERL_ARGS_ASSERT_NEWXS;
6093 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
6095 if ((cv = (name ? GvCV(gv) : NULL))) {
6097 /* just a cached method */
6101 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
6102 /* already defined (or promised) */
6103 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
6104 if (ckWARN(WARN_REDEFINE)) {
6105 GV * const gvcv = CvGV(cv);
6107 HV * const stash = GvSTASH(gvcv);
6109 const char *redefined_name = HvNAME_get(stash);
6110 if ( strEQ(redefined_name,"autouse") ) {
6111 const line_t oldline = CopLINE(PL_curcop);
6112 if (PL_parser && PL_parser->copline != NOLINE)
6113 CopLINE_set(PL_curcop, PL_parser->copline);
6114 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6115 CvCONST(cv) ? "Constant subroutine %s redefined"
6116 : "Subroutine %s redefined"
6118 CopLINE_set(PL_curcop, oldline);
6128 if (cv) /* must reuse cv if autoloaded */
6131 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
6135 mro_method_changed_in(GvSTASH(gv)); /* newXS */
6139 (void)gv_fetchfile(filename);
6140 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
6141 an external constant string */
6143 CvXSUB(cv) = subaddr;
6146 process_special_blocks(name, gv, cv);
6158 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
6163 OP* pegop = newOP(OP_NULL, 0);
6167 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
6168 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
6171 if ((cv = GvFORM(gv))) {
6172 if (ckWARN(WARN_REDEFINE)) {
6173 const line_t oldline = CopLINE(PL_curcop);
6174 if (PL_parser && PL_parser->copline != NOLINE)
6175 CopLINE_set(PL_curcop, PL_parser->copline);
6177 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6178 "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
6180 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6181 "Format STDOUT redefined");
6183 CopLINE_set(PL_curcop, oldline);
6190 CvFILE_set_from_cop(cv, PL_curcop);
6193 pad_tidy(padtidy_FORMAT);
6194 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
6195 CvROOT(cv)->op_private |= OPpREFCOUNTED;
6196 OpREFCNT_set(CvROOT(cv), 1);
6197 CvSTART(cv) = LINKLIST(CvROOT(cv));
6198 CvROOT(cv)->op_next = 0;
6199 CALL_PEEP(CvSTART(cv));
6201 op_getmad(o,pegop,'n');
6202 op_getmad_weak(block, pegop, 'b');
6207 PL_parser->copline = NOLINE;
6215 Perl_newANONLIST(pTHX_ OP *o)
6217 return convert(OP_ANONLIST, OPf_SPECIAL, o);
6221 Perl_newANONHASH(pTHX_ OP *o)
6223 return convert(OP_ANONHASH, OPf_SPECIAL, o);
6227 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
6229 return newANONATTRSUB(floor, proto, NULL, block);
6233 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
6235 return newUNOP(OP_REFGEN, 0,
6236 newSVOP(OP_ANONCODE, 0,
6237 MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block))));
6241 Perl_oopsAV(pTHX_ OP *o)
6245 PERL_ARGS_ASSERT_OOPSAV;
6247 switch (o->op_type) {
6249 o->op_type = OP_PADAV;
6250 o->op_ppaddr = PL_ppaddr[OP_PADAV];
6251 return ref(o, OP_RV2AV);
6254 o->op_type = OP_RV2AV;
6255 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
6260 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
6267 Perl_oopsHV(pTHX_ OP *o)
6271 PERL_ARGS_ASSERT_OOPSHV;
6273 switch (o->op_type) {
6276 o->op_type = OP_PADHV;
6277 o->op_ppaddr = PL_ppaddr[OP_PADHV];
6278 return ref(o, OP_RV2HV);
6282 o->op_type = OP_RV2HV;
6283 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
6288 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
6295 Perl_newAVREF(pTHX_ OP *o)
6299 PERL_ARGS_ASSERT_NEWAVREF;
6301 if (o->op_type == OP_PADANY) {
6302 o->op_type = OP_PADAV;
6303 o->op_ppaddr = PL_ppaddr[OP_PADAV];
6306 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
6307 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6308 "Using an array as a reference is deprecated");
6310 return newUNOP(OP_RV2AV, 0, scalar(o));
6314 Perl_newGVREF(pTHX_ I32 type, OP *o)
6316 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
6317 return newUNOP(OP_NULL, 0, o);
6318 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
6322 Perl_newHVREF(pTHX_ OP *o)
6326 PERL_ARGS_ASSERT_NEWHVREF;
6328 if (o->op_type == OP_PADANY) {
6329 o->op_type = OP_PADHV;
6330 o->op_ppaddr = PL_ppaddr[OP_PADHV];
6333 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
6334 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6335 "Using a hash as a reference is deprecated");
6337 return newUNOP(OP_RV2HV, 0, scalar(o));
6341 Perl_newCVREF(pTHX_ I32 flags, OP *o)
6343 return newUNOP(OP_RV2CV, flags, scalar(o));
6347 Perl_newSVREF(pTHX_ OP *o)
6351 PERL_ARGS_ASSERT_NEWSVREF;
6353 if (o->op_type == OP_PADANY) {
6354 o->op_type = OP_PADSV;
6355 o->op_ppaddr = PL_ppaddr[OP_PADSV];
6358 return newUNOP(OP_RV2SV, 0, scalar(o));
6361 /* Check routines. See the comments at the top of this file for details
6362 * on when these are called */
6365 Perl_ck_anoncode(pTHX_ OP *o)
6367 PERL_ARGS_ASSERT_CK_ANONCODE;
6369 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
6371 cSVOPo->op_sv = NULL;
6376 Perl_ck_bitop(pTHX_ OP *o)
6380 PERL_ARGS_ASSERT_CK_BITOP;
6382 #define OP_IS_NUMCOMPARE(op) \
6383 ((op) == OP_LT || (op) == OP_I_LT || \
6384 (op) == OP_GT || (op) == OP_I_GT || \
6385 (op) == OP_LE || (op) == OP_I_LE || \
6386 (op) == OP_GE || (op) == OP_I_GE || \
6387 (op) == OP_EQ || (op) == OP_I_EQ || \
6388 (op) == OP_NE || (op) == OP_I_NE || \
6389 (op) == OP_NCMP || (op) == OP_I_NCMP)
6390 o->op_private = (U8)(PL_hints & HINT_INTEGER);
6391 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
6392 && (o->op_type == OP_BIT_OR
6393 || o->op_type == OP_BIT_AND
6394 || o->op_type == OP_BIT_XOR))
6396 const OP * const left = cBINOPo->op_first;
6397 const OP * const right = left->op_sibling;
6398 if ((OP_IS_NUMCOMPARE(left->op_type) &&
6399 (left->op_flags & OPf_PARENS) == 0) ||
6400 (OP_IS_NUMCOMPARE(right->op_type) &&
6401 (right->op_flags & OPf_PARENS) == 0))
6402 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
6403 "Possible precedence problem on bitwise %c operator",
6404 o->op_type == OP_BIT_OR ? '|'
6405 : o->op_type == OP_BIT_AND ? '&' : '^'
6412 Perl_ck_concat(pTHX_ OP *o)
6414 const OP * const kid = cUNOPo->op_first;
6416 PERL_ARGS_ASSERT_CK_CONCAT;
6417 PERL_UNUSED_CONTEXT;
6419 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
6420 !(kUNOP->op_first->op_flags & OPf_MOD))
6421 o->op_flags |= OPf_STACKED;
6426 Perl_ck_spair(pTHX_ OP *o)
6430 PERL_ARGS_ASSERT_CK_SPAIR;
6432 if (o->op_flags & OPf_KIDS) {
6435 const OPCODE type = o->op_type;
6436 o = modkids(ck_fun(o), type);
6437 kid = cUNOPo->op_first;
6438 newop = kUNOP->op_first->op_sibling;
6440 const OPCODE type = newop->op_type;
6441 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
6442 type == OP_PADAV || type == OP_PADHV ||
6443 type == OP_RV2AV || type == OP_RV2HV)
6447 op_getmad(kUNOP->op_first,newop,'K');
6449 op_free(kUNOP->op_first);
6451 kUNOP->op_first = newop;
6453 o->op_ppaddr = PL_ppaddr[++o->op_type];
6458 Perl_ck_delete(pTHX_ OP *o)
6460 PERL_ARGS_ASSERT_CK_DELETE;
6464 if (o->op_flags & OPf_KIDS) {
6465 OP * const kid = cUNOPo->op_first;
6466 switch (kid->op_type) {
6468 o->op_flags |= OPf_SPECIAL;
6471 o->op_private |= OPpSLICE;
6474 o->op_flags |= OPf_SPECIAL;
6479 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
6482 if (kid->op_private & OPpLVAL_INTRO)
6483 o->op_private |= OPpLVAL_INTRO;
6490 Perl_ck_die(pTHX_ OP *o)
6492 PERL_ARGS_ASSERT_CK_DIE;
6495 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6501 Perl_ck_eof(pTHX_ OP *o)
6505 PERL_ARGS_ASSERT_CK_EOF;
6507 if (o->op_flags & OPf_KIDS) {
6508 if (cLISTOPo->op_first->op_type == OP_STUB) {
6510 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
6512 op_getmad(o,newop,'O');
6524 Perl_ck_eval(pTHX_ OP *o)
6528 PERL_ARGS_ASSERT_CK_EVAL;
6530 PL_hints |= HINT_BLOCK_SCOPE;
6531 if (o->op_flags & OPf_KIDS) {
6532 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6535 o->op_flags &= ~OPf_KIDS;
6538 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
6544 cUNOPo->op_first = 0;
6549 NewOp(1101, enter, 1, LOGOP);
6550 enter->op_type = OP_ENTERTRY;
6551 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
6552 enter->op_private = 0;
6554 /* establish postfix order */
6555 enter->op_next = (OP*)enter;
6557 CHECKOP(OP_ENTERTRY, enter);
6559 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
6560 o->op_type = OP_LEAVETRY;
6561 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
6562 enter->op_other = o;
6563 op_getmad(oldo,o,'O');
6577 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
6578 op_getmad(oldo,o,'O');
6580 o->op_targ = (PADOFFSET)PL_hints;
6581 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
6582 /* Store a copy of %^H that pp_entereval can pick up. */
6583 OP *hhop = newSVOP(OP_HINTSEVAL, 0,
6584 MUTABLE_SV(Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv))));
6585 cUNOPo->op_first->op_sibling = hhop;
6586 o->op_private |= OPpEVAL_HAS_HH;
6592 Perl_ck_exit(pTHX_ OP *o)
6594 PERL_ARGS_ASSERT_CK_EXIT;
6597 HV * const table = GvHV(PL_hintgv);
6599 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
6600 if (svp && *svp && SvTRUE(*svp))
6601 o->op_private |= OPpEXIT_VMSISH;
6603 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6609 Perl_ck_exec(pTHX_ OP *o)
6611 PERL_ARGS_ASSERT_CK_EXEC;
6613 if (o->op_flags & OPf_STACKED) {
6616 kid = cUNOPo->op_first->op_sibling;
6617 if (kid->op_type == OP_RV2GV)
6626 Perl_ck_exists(pTHX_ OP *o)
6630 PERL_ARGS_ASSERT_CK_EXISTS;
6633 if (o->op_flags & OPf_KIDS) {
6634 OP * const kid = cUNOPo->op_first;
6635 if (kid->op_type == OP_ENTERSUB) {
6636 (void) ref(kid, o->op_type);
6637 if (kid->op_type != OP_RV2CV
6638 && !(PL_parser && PL_parser->error_count))
6639 Perl_croak(aTHX_ "%s argument is not a subroutine name",
6641 o->op_private |= OPpEXISTS_SUB;
6643 else if (kid->op_type == OP_AELEM)
6644 o->op_flags |= OPf_SPECIAL;
6645 else if (kid->op_type != OP_HELEM)
6646 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or a subroutine",
6654 Perl_ck_rvconst(pTHX_ register OP *o)
6657 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6659 PERL_ARGS_ASSERT_CK_RVCONST;
6661 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6662 if (o->op_type == OP_RV2CV)
6663 o->op_private &= ~1;
6665 if (kid->op_type == OP_CONST) {
6668 SV * const kidsv = kid->op_sv;
6670 /* Is it a constant from cv_const_sv()? */
6671 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
6672 SV * const rsv = SvRV(kidsv);
6673 const svtype type = SvTYPE(rsv);
6674 const char *badtype = NULL;
6676 switch (o->op_type) {
6678 if (type > SVt_PVMG)
6679 badtype = "a SCALAR";
6682 if (type != SVt_PVAV)
6683 badtype = "an ARRAY";
6686 if (type != SVt_PVHV)
6690 if (type != SVt_PVCV)
6695 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
6698 else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
6699 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
6700 /* If this is an access to a stash, disable "strict refs", because
6701 * stashes aren't auto-vivified at compile-time (unless we store
6702 * symbols in them), and we don't want to produce a run-time
6703 * stricture error when auto-vivifying the stash. */
6704 const char *s = SvPV_nolen(kidsv);
6705 const STRLEN l = SvCUR(kidsv);
6706 if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
6707 o->op_private &= ~HINT_STRICT_REFS;
6709 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
6710 const char *badthing;
6711 switch (o->op_type) {
6713 badthing = "a SCALAR";
6716 badthing = "an ARRAY";
6719 badthing = "a HASH";
6727 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
6728 SVfARG(kidsv), badthing);
6731 * This is a little tricky. We only want to add the symbol if we
6732 * didn't add it in the lexer. Otherwise we get duplicate strict
6733 * warnings. But if we didn't add it in the lexer, we must at
6734 * least pretend like we wanted to add it even if it existed before,
6735 * or we get possible typo warnings. OPpCONST_ENTERED says
6736 * whether the lexer already added THIS instance of this symbol.
6738 iscv = (o->op_type == OP_RV2CV) * 2;
6740 gv = gv_fetchsv(kidsv,
6741 iscv | !(kid->op_private & OPpCONST_ENTERED),
6744 : o->op_type == OP_RV2SV
6746 : o->op_type == OP_RV2AV
6748 : o->op_type == OP_RV2HV
6751 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
6753 kid->op_type = OP_GV;
6754 SvREFCNT_dec(kid->op_sv);
6756 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
6757 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
6758 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
6760 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
6762 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
6764 kid->op_private = 0;
6765 kid->op_ppaddr = PL_ppaddr[OP_GV];
6772 Perl_ck_ftst(pTHX_ OP *o)
6775 const I32 type = o->op_type;
6777 PERL_ARGS_ASSERT_CK_FTST;
6779 if (o->op_flags & OPf_REF) {
6782 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
6783 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6784 const OPCODE kidtype = kid->op_type;
6786 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6787 OP * const newop = newGVOP(type, OPf_REF,
6788 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
6790 op_getmad(o,newop,'O');
6796 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
6797 o->op_private |= OPpFT_ACCESS;
6798 if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst)
6799 && kidtype != OP_STAT && kidtype != OP_LSTAT)
6800 o->op_private |= OPpFT_STACKED;
6808 if (type == OP_FTTTY)
6809 o = newGVOP(type, OPf_REF, PL_stdingv);
6811 o = newUNOP(type, 0, newDEFSVOP());
6812 op_getmad(oldo,o,'O');
6818 Perl_ck_fun(pTHX_ OP *o)
6821 const int type = o->op_type;
6822 register I32 oa = PL_opargs[type] >> OASHIFT;
6824 PERL_ARGS_ASSERT_CK_FUN;
6826 if (o->op_flags & OPf_STACKED) {
6827 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
6830 return no_fh_allowed(o);
6833 if (o->op_flags & OPf_KIDS) {
6834 OP **tokid = &cLISTOPo->op_first;
6835 register OP *kid = cLISTOPo->op_first;
6839 if (kid->op_type == OP_PUSHMARK ||
6840 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
6842 tokid = &kid->op_sibling;
6843 kid = kid->op_sibling;
6845 if (!kid && PL_opargs[type] & OA_DEFGV)
6846 *tokid = kid = newDEFSVOP();
6850 sibl = kid->op_sibling;
6852 if (!sibl && kid->op_type == OP_STUB) {
6859 /* list seen where single (scalar) arg expected? */
6860 if (numargs == 1 && !(oa >> 4)
6861 && kid->op_type == OP_LIST && type != OP_SCALAR)
6863 return too_many_arguments(o,PL_op_desc[type]);
6876 if ((type == OP_PUSH || type == OP_UNSHIFT)
6877 && !kid->op_sibling)
6878 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
6879 "Useless use of %s with no values",
6882 if (kid->op_type == OP_CONST &&
6883 (kid->op_private & OPpCONST_BARE))
6885 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
6886 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
6887 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6888 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
6889 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6891 op_getmad(kid,newop,'K');
6896 kid->op_sibling = sibl;
6899 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
6900 bad_type(numargs, "array", PL_op_desc[type], kid);
6904 if (kid->op_type == OP_CONST &&
6905 (kid->op_private & OPpCONST_BARE))
6907 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
6908 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
6909 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6910 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
6911 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6913 op_getmad(kid,newop,'K');
6918 kid->op_sibling = sibl;
6921 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
6922 bad_type(numargs, "hash", PL_op_desc[type], kid);
6927 OP * const newop = newUNOP(OP_NULL, 0, kid);
6928 kid->op_sibling = 0;
6930 newop->op_next = newop;
6932 kid->op_sibling = sibl;
6937 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
6938 if (kid->op_type == OP_CONST &&
6939 (kid->op_private & OPpCONST_BARE))
6941 OP * const newop = newGVOP(OP_GV, 0,
6942 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
6943 if (!(o->op_private & 1) && /* if not unop */
6944 kid == cLISTOPo->op_last)
6945 cLISTOPo->op_last = newop;
6947 op_getmad(kid,newop,'K');
6953 else if (kid->op_type == OP_READLINE) {
6954 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
6955 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
6958 I32 flags = OPf_SPECIAL;
6962 /* is this op a FH constructor? */
6963 if (is_handle_constructor(o,numargs)) {
6964 const char *name = NULL;
6968 /* Set a flag to tell rv2gv to vivify
6969 * need to "prove" flag does not mean something
6970 * else already - NI-S 1999/05/07
6973 if (kid->op_type == OP_PADSV) {
6975 = PAD_COMPNAME_SV(kid->op_targ);
6976 name = SvPV_const(namesv, len);
6978 else if (kid->op_type == OP_RV2SV
6979 && kUNOP->op_first->op_type == OP_GV)
6981 GV * const gv = cGVOPx_gv(kUNOP->op_first);
6983 len = GvNAMELEN(gv);
6985 else if (kid->op_type == OP_AELEM
6986 || kid->op_type == OP_HELEM)
6989 OP *op = ((BINOP*)kid)->op_first;
6993 const char * const a =
6994 kid->op_type == OP_AELEM ?
6996 if (((op->op_type == OP_RV2AV) ||
6997 (op->op_type == OP_RV2HV)) &&
6998 (firstop = ((UNOP*)op)->op_first) &&
6999 (firstop->op_type == OP_GV)) {
7000 /* packagevar $a[] or $h{} */
7001 GV * const gv = cGVOPx_gv(firstop);
7009 else if (op->op_type == OP_PADAV
7010 || op->op_type == OP_PADHV) {
7011 /* lexicalvar $a[] or $h{} */
7012 const char * const padname =
7013 PAD_COMPNAME_PV(op->op_targ);
7022 name = SvPV_const(tmpstr, len);
7027 name = "__ANONIO__";
7034 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
7035 namesv = PAD_SVl(targ);
7036 SvUPGRADE(namesv, SVt_PV);
7038 sv_setpvs(namesv, "$");
7039 sv_catpvn(namesv, name, len);
7042 kid->op_sibling = 0;
7043 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
7044 kid->op_targ = targ;
7045 kid->op_private |= priv;
7047 kid->op_sibling = sibl;
7053 mod(scalar(kid), type);
7057 tokid = &kid->op_sibling;
7058 kid = kid->op_sibling;
7061 if (kid && kid->op_type != OP_STUB)
7062 return too_many_arguments(o,OP_DESC(o));
7063 o->op_private |= numargs;
7065 /* FIXME - should the numargs move as for the PERL_MAD case? */
7066 o->op_private |= numargs;
7068 return too_many_arguments(o,OP_DESC(o));
7072 else if (PL_opargs[type] & OA_DEFGV) {
7074 OP *newop = newUNOP(type, 0, newDEFSVOP());
7075 op_getmad(o,newop,'O');
7078 /* Ordering of these two is important to keep f_map.t passing. */
7080 return newUNOP(type, 0, newDEFSVOP());
7085 while (oa & OA_OPTIONAL)
7087 if (oa && oa != OA_LIST)
7088 return too_few_arguments(o,OP_DESC(o));
7094 Perl_ck_glob(pTHX_ OP *o)
7099 PERL_ARGS_ASSERT_CK_GLOB;
7102 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
7103 append_elem(OP_GLOB, o, newDEFSVOP());
7105 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
7106 && GvCVu(gv) && GvIMPORTED_CV(gv)))
7108 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7111 #if !defined(PERL_EXTERNAL_GLOB)
7112 /* XXX this can be tightened up and made more failsafe. */
7113 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7116 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
7117 newSVpvs("File::Glob"), NULL, NULL, NULL);
7118 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7119 glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
7120 GvCV(gv) = GvCV(glob_gv);
7121 SvREFCNT_inc_void(MUTABLE_SV(GvCV(gv)));
7122 GvIMPORTED_CV_on(gv);
7125 #endif /* PERL_EXTERNAL_GLOB */
7127 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7128 append_elem(OP_GLOB, o,
7129 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
7130 o->op_type = OP_LIST;
7131 o->op_ppaddr = PL_ppaddr[OP_LIST];
7132 cLISTOPo->op_first->op_type = OP_PUSHMARK;
7133 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
7134 cLISTOPo->op_first->op_targ = 0;
7135 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
7136 append_elem(OP_LIST, o,
7137 scalar(newUNOP(OP_RV2CV, 0,
7138 newGVOP(OP_GV, 0, gv)))));
7139 o = newUNOP(OP_NULL, 0, ck_subr(o));
7140 o->op_targ = OP_GLOB; /* hint at what it used to be */
7143 gv = newGVgen("main");
7145 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
7151 Perl_ck_grep(pTHX_ OP *o)
7156 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
7159 PERL_ARGS_ASSERT_CK_GREP;
7161 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
7162 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
7164 if (o->op_flags & OPf_STACKED) {
7167 kid = cLISTOPo->op_first->op_sibling;
7168 if (!cUNOPx(kid)->op_next)
7169 Perl_croak(aTHX_ "panic: ck_grep");
7170 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
7173 NewOp(1101, gwop, 1, LOGOP);
7174 kid->op_next = (OP*)gwop;
7175 o->op_flags &= ~OPf_STACKED;
7177 kid = cLISTOPo->op_first->op_sibling;
7178 if (type == OP_MAPWHILE)
7183 if (PL_parser && PL_parser->error_count)
7185 kid = cLISTOPo->op_first->op_sibling;
7186 if (kid->op_type != OP_NULL)
7187 Perl_croak(aTHX_ "panic: ck_grep");
7188 kid = kUNOP->op_first;
7191 NewOp(1101, gwop, 1, LOGOP);
7192 gwop->op_type = type;
7193 gwop->op_ppaddr = PL_ppaddr[type];
7194 gwop->op_first = listkids(o);
7195 gwop->op_flags |= OPf_KIDS;
7196 gwop->op_other = LINKLIST(kid);
7197 kid->op_next = (OP*)gwop;
7198 offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
7199 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
7200 o->op_private = gwop->op_private = 0;
7201 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
7204 o->op_private = gwop->op_private = OPpGREP_LEX;
7205 gwop->op_targ = o->op_targ = offset;
7208 kid = cLISTOPo->op_first->op_sibling;
7209 if (!kid || !kid->op_sibling)
7210 return too_few_arguments(o,OP_DESC(o));
7211 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
7212 mod(kid, OP_GREPSTART);
7218 Perl_ck_index(pTHX_ OP *o)
7220 PERL_ARGS_ASSERT_CK_INDEX;
7222 if (o->op_flags & OPf_KIDS) {
7223 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7225 kid = kid->op_sibling; /* get past "big" */
7226 if (kid && kid->op_type == OP_CONST)
7227 fbm_compile(((SVOP*)kid)->op_sv, 0);
7233 Perl_ck_lfun(pTHX_ OP *o)
7235 const OPCODE type = o->op_type;
7237 PERL_ARGS_ASSERT_CK_LFUN;
7239 return modkids(ck_fun(o), type);
7243 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
7245 PERL_ARGS_ASSERT_CK_DEFINED;
7247 if ((o->op_flags & OPf_KIDS)) {
7248 switch (cUNOPo->op_first->op_type) {
7250 /* This is needed for
7251 if (defined %stash::)
7252 to work. Do not break Tk.
7254 break; /* Globals via GV can be undef */
7256 case OP_AASSIGN: /* Is this a good idea? */
7257 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7258 "defined(@array) is deprecated");
7259 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7260 "\t(Maybe you should just omit the defined()?)\n");
7264 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7265 "defined(%%hash) is deprecated");
7266 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7267 "\t(Maybe you should just omit the defined()?)\n");
7278 Perl_ck_readline(pTHX_ OP *o)
7280 PERL_ARGS_ASSERT_CK_READLINE;
7282 if (!(o->op_flags & OPf_KIDS)) {
7284 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
7286 op_getmad(o,newop,'O');
7296 Perl_ck_rfun(pTHX_ OP *o)
7298 const OPCODE type = o->op_type;
7300 PERL_ARGS_ASSERT_CK_RFUN;
7302 return refkids(ck_fun(o), type);
7306 Perl_ck_listiob(pTHX_ OP *o)
7310 PERL_ARGS_ASSERT_CK_LISTIOB;
7312 kid = cLISTOPo->op_first;
7315 kid = cLISTOPo->op_first;
7317 if (kid->op_type == OP_PUSHMARK)
7318 kid = kid->op_sibling;
7319 if (kid && o->op_flags & OPf_STACKED)
7320 kid = kid->op_sibling;
7321 else if (kid && !kid->op_sibling) { /* print HANDLE; */
7322 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
7323 o->op_flags |= OPf_STACKED; /* make it a filehandle */
7324 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
7325 cLISTOPo->op_first->op_sibling = kid;
7326 cLISTOPo->op_last = kid;
7327 kid = kid->op_sibling;
7332 append_elem(o->op_type, o, newDEFSVOP());
7338 Perl_ck_smartmatch(pTHX_ OP *o)
7341 if (0 == (o->op_flags & OPf_SPECIAL)) {
7342 OP *first = cBINOPo->op_first;
7343 OP *second = first->op_sibling;
7345 /* Implicitly take a reference to an array or hash */
7346 first->op_sibling = NULL;
7347 first = cBINOPo->op_first = ref_array_or_hash(first);
7348 second = first->op_sibling = ref_array_or_hash(second);
7350 /* Implicitly take a reference to a regular expression */
7351 if (first->op_type == OP_MATCH) {
7352 first->op_type = OP_QR;
7353 first->op_ppaddr = PL_ppaddr[OP_QR];
7355 if (second->op_type == OP_MATCH) {
7356 second->op_type = OP_QR;
7357 second->op_ppaddr = PL_ppaddr[OP_QR];
7366 Perl_ck_sassign(pTHX_ OP *o)
7369 OP * const kid = cLISTOPo->op_first;
7371 PERL_ARGS_ASSERT_CK_SASSIGN;
7373 /* has a disposable target? */
7374 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
7375 && !(kid->op_flags & OPf_STACKED)
7376 /* Cannot steal the second time! */
7377 && !(kid->op_private & OPpTARGET_MY)
7378 /* Keep the full thing for madskills */
7382 OP * const kkid = kid->op_sibling;
7384 /* Can just relocate the target. */
7385 if (kkid && kkid->op_type == OP_PADSV
7386 && !(kkid->op_private & OPpLVAL_INTRO))
7388 kid->op_targ = kkid->op_targ;
7390 /* Now we do not need PADSV and SASSIGN. */
7391 kid->op_sibling = o->op_sibling; /* NULL */
7392 cLISTOPo->op_first = NULL;
7395 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
7399 if (kid->op_sibling) {
7400 OP *kkid = kid->op_sibling;
7401 if (kkid->op_type == OP_PADSV
7402 && (kkid->op_private & OPpLVAL_INTRO)
7403 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
7404 const PADOFFSET target = kkid->op_targ;
7405 OP *const other = newOP(OP_PADSV,
7407 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
7408 OP *const first = newOP(OP_NULL, 0);
7409 OP *const nullop = newCONDOP(0, first, o, other);
7410 OP *const condop = first->op_next;
7411 /* hijacking PADSTALE for uninitialized state variables */
7412 SvPADSTALE_on(PAD_SVl(target));
7414 condop->op_type = OP_ONCE;
7415 condop->op_ppaddr = PL_ppaddr[OP_ONCE];
7416 condop->op_targ = target;
7417 other->op_targ = target;
7419 /* Because we change the type of the op here, we will skip the
7420 assinment binop->op_last = binop->op_first->op_sibling; at the
7421 end of Perl_newBINOP(). So need to do it here. */
7422 cBINOPo->op_last = cBINOPo->op_first->op_sibling;
7431 Perl_ck_match(pTHX_ OP *o)
7435 PERL_ARGS_ASSERT_CK_MATCH;
7437 if (o->op_type != OP_QR && PL_compcv) {
7438 const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
7439 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
7440 o->op_targ = offset;
7441 o->op_private |= OPpTARGET_MY;
7444 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
7445 o->op_private |= OPpRUNTIME;
7450 Perl_ck_method(pTHX_ OP *o)
7452 OP * const kid = cUNOPo->op_first;
7454 PERL_ARGS_ASSERT_CK_METHOD;
7456 if (kid->op_type == OP_CONST) {
7457 SV* sv = kSVOP->op_sv;
7458 const char * const method = SvPVX_const(sv);
7459 if (!(strchr(method, ':') || strchr(method, '\''))) {
7461 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
7462 sv = newSVpvn_share(method, SvCUR(sv), 0);
7465 kSVOP->op_sv = NULL;
7467 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
7469 op_getmad(o,cmop,'O');
7480 Perl_ck_null(pTHX_ OP *o)
7482 PERL_ARGS_ASSERT_CK_NULL;
7483 PERL_UNUSED_CONTEXT;
7488 Perl_ck_open(pTHX_ OP *o)
7491 HV * const table = GvHV(PL_hintgv);
7493 PERL_ARGS_ASSERT_CK_OPEN;
7496 SV **svp = hv_fetchs(table, "open_IN", FALSE);
7499 const char *d = SvPV_const(*svp, len);
7500 const I32 mode = mode_from_discipline(d, len);
7501 if (mode & O_BINARY)
7502 o->op_private |= OPpOPEN_IN_RAW;
7503 else if (mode & O_TEXT)
7504 o->op_private |= OPpOPEN_IN_CRLF;
7507 svp = hv_fetchs(table, "open_OUT", FALSE);
7510 const char *d = SvPV_const(*svp, len);
7511 const I32 mode = mode_from_discipline(d, len);
7512 if (mode & O_BINARY)
7513 o->op_private |= OPpOPEN_OUT_RAW;
7514 else if (mode & O_TEXT)
7515 o->op_private |= OPpOPEN_OUT_CRLF;
7518 if (o->op_type == OP_BACKTICK) {
7519 if (!(o->op_flags & OPf_KIDS)) {
7520 OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
7522 op_getmad(o,newop,'O');
7531 /* In case of three-arg dup open remove strictness
7532 * from the last arg if it is a bareword. */
7533 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
7534 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
7538 if ((last->op_type == OP_CONST) && /* The bareword. */
7539 (last->op_private & OPpCONST_BARE) &&
7540 (last->op_private & OPpCONST_STRICT) &&
7541 (oa = first->op_sibling) && /* The fh. */
7542 (oa = oa->op_sibling) && /* The mode. */
7543 (oa->op_type == OP_CONST) &&
7544 SvPOK(((SVOP*)oa)->op_sv) &&
7545 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
7546 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
7547 (last == oa->op_sibling)) /* The bareword. */
7548 last->op_private &= ~OPpCONST_STRICT;
7554 Perl_ck_repeat(pTHX_ OP *o)
7556 PERL_ARGS_ASSERT_CK_REPEAT;
7558 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
7559 o->op_private |= OPpREPEAT_DOLIST;
7560 cBINOPo->op_first = force_list(cBINOPo->op_first);
7568 Perl_ck_require(pTHX_ OP *o)
7573 PERL_ARGS_ASSERT_CK_REQUIRE;
7575 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
7576 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7578 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
7579 SV * const sv = kid->op_sv;
7580 U32 was_readonly = SvREADONLY(sv);
7587 sv_force_normal_flags(sv, 0);
7588 assert(!SvREADONLY(sv));
7598 for (; s < end; s++) {
7599 if (*s == ':' && s[1] == ':') {
7601 Move(s+2, s+1, end - s - 1, char);
7606 sv_catpvs(sv, ".pm");
7607 SvFLAGS(sv) |= was_readonly;
7611 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
7612 /* handle override, if any */
7613 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
7614 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7615 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
7616 gv = gvp ? *gvp : NULL;
7620 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7621 OP * const kid = cUNOPo->op_first;
7624 cUNOPo->op_first = 0;
7628 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
7629 append_elem(OP_LIST, kid,
7630 scalar(newUNOP(OP_RV2CV, 0,
7633 op_getmad(o,newop,'O');
7641 Perl_ck_return(pTHX_ OP *o)
7646 PERL_ARGS_ASSERT_CK_RETURN;
7648 kid = cLISTOPo->op_first->op_sibling;
7649 if (CvLVALUE(PL_compcv)) {
7650 for (; kid; kid = kid->op_sibling)
7651 mod(kid, OP_LEAVESUBLV);
7653 for (; kid; kid = kid->op_sibling)
7654 if ((kid->op_type == OP_NULL)
7655 && ((kid->op_flags & (OPf_SPECIAL|OPf_KIDS)) == (OPf_SPECIAL|OPf_KIDS))) {
7656 /* This is a do block */
7657 OP *op = kUNOP->op_first;
7658 if (op->op_type == OP_LEAVE && op->op_flags & OPf_KIDS) {
7659 op = cUNOPx(op)->op_first;
7660 assert(op->op_type == OP_ENTER && !(op->op_flags & OPf_SPECIAL));
7661 /* Force the use of the caller's context */
7662 op->op_flags |= OPf_SPECIAL;
7671 Perl_ck_select(pTHX_ OP *o)
7676 PERL_ARGS_ASSERT_CK_SELECT;
7678 if (o->op_flags & OPf_KIDS) {
7679 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7680 if (kid && kid->op_sibling) {
7681 o->op_type = OP_SSELECT;
7682 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
7684 return fold_constants(o);
7688 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7689 if (kid && kid->op_type == OP_RV2GV)
7690 kid->op_private &= ~HINT_STRICT_REFS;
7695 Perl_ck_shift(pTHX_ OP *o)
7698 const I32 type = o->op_type;
7700 PERL_ARGS_ASSERT_CK_SHIFT;
7702 if (!(o->op_flags & OPf_KIDS)) {
7703 OP *argop = newUNOP(OP_RV2AV, 0,
7704 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
7706 OP * const oldo = o;
7707 o = newUNOP(type, 0, scalar(argop));
7708 op_getmad(oldo,o,'O');
7712 return newUNOP(type, 0, scalar(argop));
7715 return scalar(modkids(ck_fun(o), type));
7719 Perl_ck_sort(pTHX_ OP *o)
7724 PERL_ARGS_ASSERT_CK_SORT;
7726 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
7727 HV * const hinthv = GvHV(PL_hintgv);
7729 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
7731 const I32 sorthints = (I32)SvIV(*svp);
7732 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
7733 o->op_private |= OPpSORT_QSORT;
7734 if ((sorthints & HINT_SORT_STABLE) != 0)
7735 o->op_private |= OPpSORT_STABLE;
7740 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
7742 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7743 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
7745 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
7747 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
7749 if (kid->op_type == OP_SCOPE) {
7753 else if (kid->op_type == OP_LEAVE) {
7754 if (o->op_type == OP_SORT) {
7755 op_null(kid); /* wipe out leave */
7758 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
7759 if (k->op_next == kid)
7761 /* don't descend into loops */
7762 else if (k->op_type == OP_ENTERLOOP
7763 || k->op_type == OP_ENTERITER)
7765 k = cLOOPx(k)->op_lastop;
7770 kid->op_next = 0; /* just disconnect the leave */
7771 k = kLISTOP->op_first;
7776 if (o->op_type == OP_SORT) {
7777 /* provide scalar context for comparison function/block */
7783 o->op_flags |= OPf_SPECIAL;
7785 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
7788 firstkid = firstkid->op_sibling;
7791 /* provide list context for arguments */
7792 if (o->op_type == OP_SORT)
7799 S_simplify_sort(pTHX_ OP *o)
7802 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7808 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
7810 if (!(o->op_flags & OPf_STACKED))
7812 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7813 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
7814 kid = kUNOP->op_first; /* get past null */
7815 if (kid->op_type != OP_SCOPE)
7817 kid = kLISTOP->op_last; /* get past scope */
7818 switch(kid->op_type) {
7826 k = kid; /* remember this node*/
7827 if (kBINOP->op_first->op_type != OP_RV2SV)
7829 kid = kBINOP->op_first; /* get past cmp */
7830 if (kUNOP->op_first->op_type != OP_GV)
7832 kid = kUNOP->op_first; /* get past rv2sv */
7834 if (GvSTASH(gv) != PL_curstash)
7836 gvname = GvNAME(gv);
7837 if (*gvname == 'a' && gvname[1] == '\0')
7839 else if (*gvname == 'b' && gvname[1] == '\0')
7844 kid = k; /* back to cmp */
7845 if (kBINOP->op_last->op_type != OP_RV2SV)
7847 kid = kBINOP->op_last; /* down to 2nd arg */
7848 if (kUNOP->op_first->op_type != OP_GV)
7850 kid = kUNOP->op_first; /* get past rv2sv */
7852 if (GvSTASH(gv) != PL_curstash)
7854 gvname = GvNAME(gv);
7856 ? !(*gvname == 'a' && gvname[1] == '\0')
7857 : !(*gvname == 'b' && gvname[1] == '\0'))
7859 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
7861 o->op_private |= OPpSORT_DESCEND;
7862 if (k->op_type == OP_NCMP)
7863 o->op_private |= OPpSORT_NUMERIC;
7864 if (k->op_type == OP_I_NCMP)
7865 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
7866 kid = cLISTOPo->op_first->op_sibling;
7867 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
7869 op_getmad(kid,o,'S'); /* then delete it */
7871 op_free(kid); /* then delete it */
7876 Perl_ck_split(pTHX_ OP *o)
7881 PERL_ARGS_ASSERT_CK_SPLIT;
7883 if (o->op_flags & OPf_STACKED)
7884 return no_fh_allowed(o);
7886 kid = cLISTOPo->op_first;
7887 if (kid->op_type != OP_NULL)
7888 Perl_croak(aTHX_ "panic: ck_split");
7889 kid = kid->op_sibling;
7890 op_free(cLISTOPo->op_first);
7891 cLISTOPo->op_first = kid;
7893 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
7894 cLISTOPo->op_last = kid; /* There was only one element previously */
7897 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
7898 OP * const sibl = kid->op_sibling;
7899 kid->op_sibling = 0;
7900 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
7901 if (cLISTOPo->op_first == cLISTOPo->op_last)
7902 cLISTOPo->op_last = kid;
7903 cLISTOPo->op_first = kid;
7904 kid->op_sibling = sibl;
7907 kid->op_type = OP_PUSHRE;
7908 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
7910 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
7911 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
7912 "Use of /g modifier is meaningless in split");
7915 if (!kid->op_sibling)
7916 append_elem(OP_SPLIT, o, newDEFSVOP());
7918 kid = kid->op_sibling;
7921 if (!kid->op_sibling)
7922 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
7923 assert(kid->op_sibling);
7925 kid = kid->op_sibling;
7928 if (kid->op_sibling)
7929 return too_many_arguments(o,OP_DESC(o));
7935 Perl_ck_join(pTHX_ OP *o)
7937 const OP * const kid = cLISTOPo->op_first->op_sibling;
7939 PERL_ARGS_ASSERT_CK_JOIN;
7941 if (kid && kid->op_type == OP_MATCH) {
7942 if (ckWARN(WARN_SYNTAX)) {
7943 const REGEXP *re = PM_GETRE(kPMOP);
7944 const char *pmstr = re ? RX_PRECOMP_const(re) : "STRING";
7945 const STRLEN len = re ? RX_PRELEN(re) : 6;
7946 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7947 "/%.*s/ should probably be written as \"%.*s\"",
7948 (int)len, pmstr, (int)len, pmstr);
7955 Perl_ck_subr(pTHX_ OP *o)
7958 OP *prev = ((cUNOPo->op_first->op_sibling)
7959 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
7960 OP *o2 = prev->op_sibling;
7962 const char *proto = NULL;
7963 const char *proto_end = NULL;
7968 I32 contextclass = 0;
7969 const char *e = NULL;
7972 PERL_ARGS_ASSERT_CK_SUBR;
7974 o->op_private |= OPpENTERSUB_HASTARG;
7975 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
7976 if (cvop->op_type == OP_RV2CV) {
7977 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
7978 op_null(cvop); /* disable rv2cv */
7979 if (!(o->op_private & OPpENTERSUB_AMPER)) {
7980 SVOP *tmpop = (SVOP*)((UNOP*)cvop)->op_first;
7982 switch (tmpop->op_type) {
7984 gv = cGVOPx_gv(tmpop);
7987 tmpop->op_private |= OPpEARLY_CV;
7990 SV *sv = cSVOPx_sv(tmpop);
7991 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV)
7995 if (cv && SvPOK(cv)) {
7997 namegv = gv && CvANON(cv) ? gv : CvGV(cv);
7998 proto = SvPV(MUTABLE_SV(cv), len);
7999 proto_end = proto + len;
8003 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
8004 if (o2->op_type == OP_CONST)
8005 o2->op_private &= ~OPpCONST_STRICT;
8006 else if (o2->op_type == OP_LIST) {
8007 OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
8008 if (sib && sib->op_type == OP_CONST)
8009 sib->op_private &= ~OPpCONST_STRICT;
8012 o->op_private |= (PL_hints & HINT_STRICT_REFS);
8013 if (PERLDB_SUB && PL_curstash != PL_debstash)
8014 o->op_private |= OPpENTERSUB_DB;
8015 while (o2 != cvop) {
8017 if (PL_madskills && o2->op_type == OP_STUB) {
8018 o2 = o2->op_sibling;
8021 if (PL_madskills && o2->op_type == OP_NULL)
8022 o3 = ((UNOP*)o2)->op_first;
8026 if (proto >= proto_end)
8027 return too_many_arguments(o, gv_ename(namegv));
8035 /* _ must be at the end */
8036 if (proto[1] && proto[1] != ';')
8051 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
8053 arg == 1 ? "block or sub {}" : "sub {}",
8054 gv_ename(namegv), o3);
8057 /* '*' allows any scalar type, including bareword */
8060 if (o3->op_type == OP_RV2GV)
8061 goto wrapref; /* autoconvert GLOB -> GLOBref */
8062 else if (o3->op_type == OP_CONST)
8063 o3->op_private &= ~OPpCONST_STRICT;
8064 else if (o3->op_type == OP_ENTERSUB) {
8065 /* accidental subroutine, revert to bareword */
8066 OP *gvop = ((UNOP*)o3)->op_first;
8067 if (gvop && gvop->op_type == OP_NULL) {
8068 gvop = ((UNOP*)gvop)->op_first;
8070 for (; gvop->op_sibling; gvop = gvop->op_sibling)
8073 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
8074 (gvop = ((UNOP*)gvop)->op_first) &&
8075 gvop->op_type == OP_GV)
8077 GV * const gv = cGVOPx_gv(gvop);
8078 OP * const sibling = o2->op_sibling;
8079 SV * const n = newSVpvs("");
8081 OP * const oldo2 = o2;
8085 gv_fullname4(n, gv, "", FALSE);
8086 o2 = newSVOP(OP_CONST, 0, n);
8087 op_getmad(oldo2,o2,'O');
8088 prev->op_sibling = o2;
8089 o2->op_sibling = sibling;
8105 if (contextclass++ == 0) {
8106 e = strchr(proto, ']');
8107 if (!e || e == proto)
8116 const char *p = proto;
8117 const char *const end = proto;
8119 while (*--p != '[') {}
8120 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
8122 gv_ename(namegv), o3);
8127 if (o3->op_type == OP_RV2GV)
8130 bad_type(arg, "symbol", gv_ename(namegv), o3);
8133 if (o3->op_type == OP_ENTERSUB)
8136 bad_type(arg, "subroutine entry", gv_ename(namegv),
8140 if (o3->op_type == OP_RV2SV ||
8141 o3->op_type == OP_PADSV ||
8142 o3->op_type == OP_HELEM ||
8143 o3->op_type == OP_AELEM)
8146 bad_type(arg, "scalar", gv_ename(namegv), o3);
8149 if (o3->op_type == OP_RV2AV ||
8150 o3->op_type == OP_PADAV)
8153 bad_type(arg, "array", gv_ename(namegv), o3);
8156 if (o3->op_type == OP_RV2HV ||
8157 o3->op_type == OP_PADHV)
8160 bad_type(arg, "hash", gv_ename(namegv), o3);
8165 OP* const sib = kid->op_sibling;
8166 kid->op_sibling = 0;
8167 o2 = newUNOP(OP_REFGEN, 0, kid);
8168 o2->op_sibling = sib;
8169 prev->op_sibling = o2;
8171 if (contextclass && e) {
8186 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
8187 gv_ename(namegv), SVfARG(cv));
8192 mod(o2, OP_ENTERSUB);
8194 o2 = o2->op_sibling;
8196 if (o2 == cvop && proto && *proto == '_') {
8197 /* generate an access to $_ */
8199 o2->op_sibling = prev->op_sibling;
8200 prev->op_sibling = o2; /* instead of cvop */
8202 if (proto && !optional && proto_end > proto &&
8203 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
8204 return too_few_arguments(o, gv_ename(namegv));
8207 OP * const oldo = o;
8211 o=newSVOP(OP_CONST, 0, newSViv(0));
8212 op_getmad(oldo,o,'O');
8218 Perl_ck_svconst(pTHX_ OP *o)
8220 PERL_ARGS_ASSERT_CK_SVCONST;
8221 PERL_UNUSED_CONTEXT;
8222 SvREADONLY_on(cSVOPo->op_sv);
8227 Perl_ck_chdir(pTHX_ OP *o)
8229 if (o->op_flags & OPf_KIDS) {
8230 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8232 if (kid && kid->op_type == OP_CONST &&
8233 (kid->op_private & OPpCONST_BARE))
8235 o->op_flags |= OPf_SPECIAL;
8236 kid->op_private &= ~OPpCONST_STRICT;
8243 Perl_ck_trunc(pTHX_ OP *o)
8245 PERL_ARGS_ASSERT_CK_TRUNC;
8247 if (o->op_flags & OPf_KIDS) {
8248 SVOP *kid = (SVOP*)cUNOPo->op_first;
8250 if (kid->op_type == OP_NULL)
8251 kid = (SVOP*)kid->op_sibling;
8252 if (kid && kid->op_type == OP_CONST &&
8253 (kid->op_private & OPpCONST_BARE))
8255 o->op_flags |= OPf_SPECIAL;
8256 kid->op_private &= ~OPpCONST_STRICT;
8263 Perl_ck_unpack(pTHX_ OP *o)
8265 OP *kid = cLISTOPo->op_first;
8267 PERL_ARGS_ASSERT_CK_UNPACK;
8269 if (kid->op_sibling) {
8270 kid = kid->op_sibling;
8271 if (!kid->op_sibling)
8272 kid->op_sibling = newDEFSVOP();
8278 Perl_ck_substr(pTHX_ OP *o)
8280 PERL_ARGS_ASSERT_CK_SUBSTR;
8283 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
8284 OP *kid = cLISTOPo->op_first;
8286 if (kid->op_type == OP_NULL)
8287 kid = kid->op_sibling;
8289 kid->op_flags |= OPf_MOD;
8296 Perl_ck_each(pTHX_ OP *o)
8299 OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
8301 PERL_ARGS_ASSERT_CK_EACH;
8304 if (kid->op_type == OP_PADAV || kid->op_type == OP_RV2AV) {
8305 const unsigned new_type = o->op_type == OP_EACH ? OP_AEACH
8306 : o->op_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
8307 o->op_type = new_type;
8308 o->op_ppaddr = PL_ppaddr[new_type];
8310 else if (!(kid->op_type == OP_PADHV || kid->op_type == OP_RV2HV
8311 || (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE)
8313 bad_type(1, "hash or array", PL_op_desc[o->op_type], kid);
8320 /* caller is supposed to assign the return to the
8321 container of the rep_op var */
8323 S_opt_scalarhv(pTHX_ OP *rep_op) {
8326 PERL_ARGS_ASSERT_OPT_SCALARHV;
8328 NewOp(1101, unop, 1, UNOP);
8329 unop->op_type = (OPCODE)OP_BOOLKEYS;
8330 unop->op_ppaddr = PL_ppaddr[OP_BOOLKEYS];
8331 unop->op_flags = (U8)(OPf_WANT_SCALAR | OPf_KIDS );
8332 unop->op_private = (U8)(1 | ((OPf_WANT_SCALAR | OPf_KIDS) >> 8));
8333 unop->op_first = rep_op;
8334 unop->op_next = rep_op->op_next;
8335 rep_op->op_next = (OP*)unop;
8336 rep_op->op_flags|=(OPf_REF | OPf_MOD);
8337 unop->op_sibling = rep_op->op_sibling;
8338 rep_op->op_sibling = NULL;
8339 /* unop->op_targ = pad_alloc(OP_BOOLKEYS, SVs_PADTMP); */
8340 if (rep_op->op_type == OP_PADHV) {
8341 rep_op->op_flags &= ~OPf_WANT_SCALAR;
8342 rep_op->op_flags |= OPf_WANT_LIST;
8347 /* A peephole optimizer. We visit the ops in the order they're to execute.
8348 * See the comments at the top of this file for more details about when
8349 * peep() is called */
8352 Perl_peep(pTHX_ register OP *o)
8355 register OP* oldop = NULL;
8357 if (!o || o->op_opt)
8361 SAVEVPTR(PL_curcop);
8362 for (; o; o = o->op_next) {
8365 /* By default, this op has now been optimised. A couple of cases below
8366 clear this again. */
8369 switch (o->op_type) {
8372 PL_curcop = ((COP*)o); /* for warnings */
8376 if (cSVOPo->op_private & OPpCONST_STRICT)
8377 no_bareword_allowed(o);
8380 case OP_METHOD_NAMED:
8381 /* Relocate sv to the pad for thread safety.
8382 * Despite being a "constant", the SV is written to,
8383 * for reference counts, sv_upgrade() etc. */
8385 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
8386 if (o->op_type != OP_METHOD_NAMED && SvPADTMP(cSVOPo->op_sv)) {
8387 /* If op_sv is already a PADTMP then it is being used by
8388 * some pad, so make a copy. */
8389 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
8390 SvREADONLY_on(PAD_SVl(ix));
8391 SvREFCNT_dec(cSVOPo->op_sv);
8393 else if (o->op_type != OP_METHOD_NAMED
8394 && cSVOPo->op_sv == &PL_sv_undef) {
8395 /* PL_sv_undef is hack - it's unsafe to store it in the
8396 AV that is the pad, because av_fetch treats values of
8397 PL_sv_undef as a "free" AV entry and will merrily
8398 replace them with a new SV, causing pad_alloc to think
8399 that this pad slot is free. (When, clearly, it is not)
8401 SvOK_off(PAD_SVl(ix));
8402 SvPADTMP_on(PAD_SVl(ix));
8403 SvREADONLY_on(PAD_SVl(ix));
8406 SvREFCNT_dec(PAD_SVl(ix));
8407 SvPADTMP_on(cSVOPo->op_sv);
8408 PAD_SETSV(ix, cSVOPo->op_sv);
8409 /* XXX I don't know how this isn't readonly already. */
8410 SvREADONLY_on(PAD_SVl(ix));
8412 cSVOPo->op_sv = NULL;
8419 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
8420 if (o->op_next->op_private & OPpTARGET_MY) {
8421 if (o->op_flags & OPf_STACKED) /* chained concats */
8422 break; /* ignore_optimization */
8424 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
8425 o->op_targ = o->op_next->op_targ;
8426 o->op_next->op_targ = 0;
8427 o->op_private |= OPpTARGET_MY;
8430 op_null(o->op_next);
8434 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
8435 break; /* Scalar stub must produce undef. List stub is noop */
8439 if (o->op_targ == OP_NEXTSTATE
8440 || o->op_targ == OP_DBSTATE)
8442 PL_curcop = ((COP*)o);
8444 /* XXX: We avoid setting op_seq here to prevent later calls
8445 to peep() from mistakenly concluding that optimisation
8446 has already occurred. This doesn't fix the real problem,
8447 though (See 20010220.007). AMS 20010719 */
8448 /* op_seq functionality is now replaced by op_opt */
8455 if (oldop && o->op_next) {
8456 oldop->op_next = o->op_next;
8464 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
8465 OP* const pop = (o->op_type == OP_PADAV) ?
8466 o->op_next : o->op_next->op_next;
8468 if (pop && pop->op_type == OP_CONST &&
8469 ((PL_op = pop->op_next)) &&
8470 pop->op_next->op_type == OP_AELEM &&
8471 !(pop->op_next->op_private &
8472 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
8473 (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
8478 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
8479 no_bareword_allowed(pop);
8480 if (o->op_type == OP_GV)
8481 op_null(o->op_next);
8482 op_null(pop->op_next);
8484 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
8485 o->op_next = pop->op_next->op_next;
8486 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
8487 o->op_private = (U8)i;
8488 if (o->op_type == OP_GV) {
8493 o->op_flags |= OPf_SPECIAL;
8494 o->op_type = OP_AELEMFAST;
8499 if (o->op_next->op_type == OP_RV2SV) {
8500 if (!(o->op_next->op_private & OPpDEREF)) {
8501 op_null(o->op_next);
8502 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
8504 o->op_next = o->op_next->op_next;
8505 o->op_type = OP_GVSV;
8506 o->op_ppaddr = PL_ppaddr[OP_GVSV];
8509 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
8510 GV * const gv = cGVOPo_gv;
8511 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
8512 /* XXX could check prototype here instead of just carping */
8513 SV * const sv = sv_newmortal();
8514 gv_efullname3(sv, gv, NULL);
8515 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
8516 "%"SVf"() called too early to check prototype",
8520 else if (o->op_next->op_type == OP_READLINE
8521 && o->op_next->op_next->op_type == OP_CONCAT
8522 && (o->op_next->op_next->op_flags & OPf_STACKED))
8524 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
8525 o->op_type = OP_RCATLINE;
8526 o->op_flags |= OPf_STACKED;
8527 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
8528 op_null(o->op_next->op_next);
8529 op_null(o->op_next);
8539 fop = cUNOP->op_first;
8547 fop = cLOGOP->op_first;
8548 sop = fop->op_sibling;
8549 while (cLOGOP->op_other->op_type == OP_NULL)
8550 cLOGOP->op_other = cLOGOP->op_other->op_next;
8551 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
8555 if ((fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
8557 (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV)
8562 if (!(nop->op_flags && OPf_WANT_VOID)) {
8563 while (nop && nop->op_next) {
8564 switch (nop->op_next->op_type) {
8569 lop = nop = nop->op_next;
8580 if (lop->op_flags && OPf_WANT_VOID) {
8581 if (fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
8582 cLOGOP->op_first = opt_scalarhv(fop);
8583 if (sop && (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV))
8584 cLOGOP->op_first->op_sibling = opt_scalarhv(sop);
8600 while (cLOGOP->op_other->op_type == OP_NULL)
8601 cLOGOP->op_other = cLOGOP->op_other->op_next;
8602 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
8607 while (cLOOP->op_redoop->op_type == OP_NULL)
8608 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
8609 peep(cLOOP->op_redoop);
8610 while (cLOOP->op_nextop->op_type == OP_NULL)
8611 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
8612 peep(cLOOP->op_nextop);
8613 while (cLOOP->op_lastop->op_type == OP_NULL)
8614 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
8615 peep(cLOOP->op_lastop);
8619 assert(!(cPMOP->op_pmflags & PMf_ONCE));
8620 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
8621 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
8622 cPMOP->op_pmstashstartu.op_pmreplstart
8623 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
8624 peep(cPMOP->op_pmstashstartu.op_pmreplstart);
8628 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
8629 && ckWARN(WARN_SYNTAX))
8631 if (o->op_next->op_sibling) {
8632 const OPCODE type = o->op_next->op_sibling->op_type;
8633 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
8634 const line_t oldline = CopLINE(PL_curcop);
8635 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
8636 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8637 "Statement unlikely to be reached");
8638 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8639 "\t(Maybe you meant system() when you said exec()?)\n");
8640 CopLINE_set(PL_curcop, oldline);
8651 const char *key = NULL;
8654 if (((BINOP*)o)->op_last->op_type != OP_CONST)
8657 /* Make the CONST have a shared SV */
8658 svp = cSVOPx_svp(((BINOP*)o)->op_last);
8659 if (!SvFAKE(sv = *svp) || !SvREADONLY(sv)) {
8660 key = SvPV_const(sv, keylen);
8661 lexname = newSVpvn_share(key,
8662 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
8668 if ((o->op_private & (OPpLVAL_INTRO)))
8671 rop = (UNOP*)((BINOP*)o)->op_first;
8672 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
8674 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
8675 if (!SvPAD_TYPED(lexname))
8677 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8678 if (!fields || !GvHV(*fields))
8680 key = SvPV_const(*svp, keylen);
8681 if (!hv_fetch(GvHV(*fields), key,
8682 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8684 Perl_croak(aTHX_ "No such class field \"%s\" "
8685 "in variable %s of type %s",
8686 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
8699 SVOP *first_key_op, *key_op;
8701 if ((o->op_private & (OPpLVAL_INTRO))
8702 /* I bet there's always a pushmark... */
8703 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
8704 /* hmmm, no optimization if list contains only one key. */
8706 rop = (UNOP*)((LISTOP*)o)->op_last;
8707 if (rop->op_type != OP_RV2HV)
8709 if (rop->op_first->op_type == OP_PADSV)
8710 /* @$hash{qw(keys here)} */
8711 rop = (UNOP*)rop->op_first;
8713 /* @{$hash}{qw(keys here)} */
8714 if (rop->op_first->op_type == OP_SCOPE
8715 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
8717 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
8723 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
8724 if (!SvPAD_TYPED(lexname))
8726 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8727 if (!fields || !GvHV(*fields))
8729 /* Again guessing that the pushmark can be jumped over.... */
8730 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
8731 ->op_first->op_sibling;
8732 for (key_op = first_key_op; key_op;
8733 key_op = (SVOP*)key_op->op_sibling) {
8734 if (key_op->op_type != OP_CONST)
8736 svp = cSVOPx_svp(key_op);
8737 key = SvPV_const(*svp, keylen);
8738 if (!hv_fetch(GvHV(*fields), key,
8739 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8741 Perl_croak(aTHX_ "No such class field \"%s\" "
8742 "in variable %s of type %s",
8743 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
8750 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
8754 /* check that RHS of sort is a single plain array */
8755 OP *oright = cUNOPo->op_first;
8756 if (!oright || oright->op_type != OP_PUSHMARK)
8759 /* reverse sort ... can be optimised. */
8760 if (!cUNOPo->op_sibling) {
8761 /* Nothing follows us on the list. */
8762 OP * const reverse = o->op_next;
8764 if (reverse->op_type == OP_REVERSE &&
8765 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
8766 OP * const pushmark = cUNOPx(reverse)->op_first;
8767 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
8768 && (cUNOPx(pushmark)->op_sibling == o)) {
8769 /* reverse -> pushmark -> sort */
8770 o->op_private |= OPpSORT_REVERSE;
8772 pushmark->op_next = oright->op_next;
8778 /* make @a = sort @a act in-place */
8780 oright = cUNOPx(oright)->op_sibling;
8783 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
8784 oright = cUNOPx(oright)->op_sibling;
8788 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
8789 || oright->op_next != o
8790 || (oright->op_private & OPpLVAL_INTRO)
8794 /* o2 follows the chain of op_nexts through the LHS of the
8795 * assign (if any) to the aassign op itself */
8797 if (!o2 || o2->op_type != OP_NULL)
8800 if (!o2 || o2->op_type != OP_PUSHMARK)
8803 if (o2 && o2->op_type == OP_GV)
8806 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
8807 || (o2->op_private & OPpLVAL_INTRO)
8812 if (!o2 || o2->op_type != OP_NULL)
8815 if (!o2 || o2->op_type != OP_AASSIGN
8816 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
8819 /* check that the sort is the first arg on RHS of assign */
8821 o2 = cUNOPx(o2)->op_first;
8822 if (!o2 || o2->op_type != OP_NULL)
8824 o2 = cUNOPx(o2)->op_first;
8825 if (!o2 || o2->op_type != OP_PUSHMARK)
8827 if (o2->op_sibling != o)
8830 /* check the array is the same on both sides */
8831 if (oleft->op_type == OP_RV2AV) {
8832 if (oright->op_type != OP_RV2AV
8833 || !cUNOPx(oright)->op_first
8834 || cUNOPx(oright)->op_first->op_type != OP_GV
8835 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
8836 cGVOPx_gv(cUNOPx(oright)->op_first)
8840 else if (oright->op_type != OP_PADAV
8841 || oright->op_targ != oleft->op_targ
8845 /* transfer MODishness etc from LHS arg to RHS arg */
8846 oright->op_flags = oleft->op_flags;
8847 o->op_private |= OPpSORT_INPLACE;
8849 /* excise push->gv->rv2av->null->aassign */
8850 o2 = o->op_next->op_next;
8851 op_null(o2); /* PUSHMARK */
8853 if (o2->op_type == OP_GV) {
8854 op_null(o2); /* GV */
8857 op_null(o2); /* RV2AV or PADAV */
8858 o2 = o2->op_next->op_next;
8859 op_null(o2); /* AASSIGN */
8861 o->op_next = o2->op_next;
8867 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
8869 LISTOP *enter, *exlist;
8871 enter = (LISTOP *) o->op_next;
8874 if (enter->op_type == OP_NULL) {
8875 enter = (LISTOP *) enter->op_next;
8879 /* for $a (...) will have OP_GV then OP_RV2GV here.
8880 for (...) just has an OP_GV. */
8881 if (enter->op_type == OP_GV) {
8882 gvop = (OP *) enter;
8883 enter = (LISTOP *) enter->op_next;
8886 if (enter->op_type == OP_RV2GV) {
8887 enter = (LISTOP *) enter->op_next;
8893 if (enter->op_type != OP_ENTERITER)
8896 iter = enter->op_next;
8897 if (!iter || iter->op_type != OP_ITER)
8900 expushmark = enter->op_first;
8901 if (!expushmark || expushmark->op_type != OP_NULL
8902 || expushmark->op_targ != OP_PUSHMARK)
8905 exlist = (LISTOP *) expushmark->op_sibling;
8906 if (!exlist || exlist->op_type != OP_NULL
8907 || exlist->op_targ != OP_LIST)
8910 if (exlist->op_last != o) {
8911 /* Mmm. Was expecting to point back to this op. */
8914 theirmark = exlist->op_first;
8915 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
8918 if (theirmark->op_sibling != o) {
8919 /* There's something between the mark and the reverse, eg
8920 for (1, reverse (...))
8925 ourmark = ((LISTOP *)o)->op_first;
8926 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
8929 ourlast = ((LISTOP *)o)->op_last;
8930 if (!ourlast || ourlast->op_next != o)
8933 rv2av = ourmark->op_sibling;
8934 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
8935 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
8936 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
8937 /* We're just reversing a single array. */
8938 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
8939 enter->op_flags |= OPf_STACKED;
8942 /* We don't have control over who points to theirmark, so sacrifice
8944 theirmark->op_next = ourmark->op_next;
8945 theirmark->op_flags = ourmark->op_flags;
8946 ourlast->op_next = gvop ? gvop : (OP *) enter;
8949 enter->op_private |= OPpITER_REVERSED;
8950 iter->op_private |= OPpITER_REVERSED;
8957 UNOP *refgen, *rv2cv;
8960 if ((o->op_flags & OPf_WANT) != OPf_WANT_VOID)
8963 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
8966 rv2gv = ((BINOP *)o)->op_last;
8967 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
8970 refgen = (UNOP *)((BINOP *)o)->op_first;
8972 if (!refgen || refgen->op_type != OP_REFGEN)
8975 exlist = (LISTOP *)refgen->op_first;
8976 if (!exlist || exlist->op_type != OP_NULL
8977 || exlist->op_targ != OP_LIST)
8980 if (exlist->op_first->op_type != OP_PUSHMARK)
8983 rv2cv = (UNOP*)exlist->op_last;
8985 if (rv2cv->op_type != OP_RV2CV)
8988 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
8989 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
8990 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
8992 o->op_private |= OPpASSIGN_CV_TO_GV;
8993 rv2gv->op_private |= OPpDONT_INIT_GV;
8994 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
9002 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
9003 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
9013 Perl_custom_op_name(pTHX_ const OP* o)
9016 const IV index = PTR2IV(o->op_ppaddr);
9020 PERL_ARGS_ASSERT_CUSTOM_OP_NAME;
9022 if (!PL_custom_op_names) /* This probably shouldn't happen */
9023 return (char *)PL_op_name[OP_CUSTOM];
9025 keysv = sv_2mortal(newSViv(index));
9027 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
9029 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
9031 return SvPV_nolen(HeVAL(he));
9035 Perl_custom_op_desc(pTHX_ const OP* o)
9038 const IV index = PTR2IV(o->op_ppaddr);
9042 PERL_ARGS_ASSERT_CUSTOM_OP_DESC;
9044 if (!PL_custom_op_descs)
9045 return (char *)PL_op_desc[OP_CUSTOM];
9047 keysv = sv_2mortal(newSViv(index));
9049 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
9051 return (char *)PL_op_desc[OP_CUSTOM];
9053 return SvPV_nolen(HeVAL(he));
9058 /* Efficient sub that returns a constant scalar value. */
9060 const_sv_xsub(pTHX_ CV* cv)
9064 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
9068 /* diag_listed_as: SKIPME */
9069 Perl_croak(aTHX_ "usage: %s::%s()",
9070 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
9083 * c-indentation-style: bsd
9085 * indent-tabs-mode: t
9088 * ex: set ts=8 sts=4 sw=4 noet: