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 */
574 if (cPADOPo->op_padix > 0) {
575 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
576 * may still exist on the pad */
577 pad_swipe(cPADOPo->op_padix, TRUE);
578 cPADOPo->op_padix = 0;
581 SvREFCNT_dec(cSVOPo->op_sv);
582 cSVOPo->op_sv = NULL;
586 case OP_METHOD_NAMED:
589 SvREFCNT_dec(cSVOPo->op_sv);
590 cSVOPo->op_sv = NULL;
593 Even if op_clear does a pad_free for the target of the op,
594 pad_free doesn't actually remove the sv that exists in the pad;
595 instead it lives on. This results in that it could be reused as
596 a target later on when the pad was reallocated.
599 pad_swipe(o->op_targ,1);
608 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
612 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
614 if (cPADOPo->op_padix > 0) {
615 pad_swipe(cPADOPo->op_padix, TRUE);
616 cPADOPo->op_padix = 0;
619 SvREFCNT_dec(cSVOPo->op_sv);
620 cSVOPo->op_sv = NULL;
624 PerlMemShared_free(cPVOPo->op_pv);
625 cPVOPo->op_pv = NULL;
629 op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
633 if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
634 /* No GvIN_PAD_off here, because other references may still
635 * exist on the pad */
636 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
639 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
645 forget_pmop(cPMOPo, 1);
646 cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
647 /* we use the same protection as the "SAFE" version of the PM_ macros
648 * here since sv_clean_all might release some PMOPs
649 * after PL_regex_padav has been cleared
650 * and the clearing of PL_regex_padav needs to
651 * happen before sv_clean_all
654 if(PL_regex_pad) { /* We could be in destruction */
655 const IV offset = (cPMOPo)->op_pmoffset;
656 ReREFCNT_dec(PM_GETRE(cPMOPo));
657 PL_regex_pad[offset] = &PL_sv_undef;
658 sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
662 ReREFCNT_dec(PM_GETRE(cPMOPo));
663 PM_SETRE(cPMOPo, NULL);
669 if (o->op_targ > 0) {
670 pad_free(o->op_targ);
676 S_cop_free(pTHX_ COP* cop)
678 PERL_ARGS_ASSERT_COP_FREE;
682 if (! specialWARN(cop->cop_warnings))
683 PerlMemShared_free(cop->cop_warnings);
684 Perl_refcounted_he_free(aTHX_ cop->cop_hints_hash);
688 S_forget_pmop(pTHX_ PMOP *const o
694 HV * const pmstash = PmopSTASH(o);
696 PERL_ARGS_ASSERT_FORGET_PMOP;
698 if (pmstash && !SvIS_FREED(pmstash)) {
699 MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
701 PMOP **const array = (PMOP**) mg->mg_ptr;
702 U32 count = mg->mg_len / sizeof(PMOP**);
707 /* Found it. Move the entry at the end to overwrite it. */
708 array[i] = array[--count];
709 mg->mg_len = count * sizeof(PMOP**);
710 /* Could realloc smaller at this point always, but probably
711 not worth it. Probably worth free()ing if we're the
714 Safefree(mg->mg_ptr);
731 S_find_and_forget_pmops(pTHX_ OP *o)
733 PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
735 if (o->op_flags & OPf_KIDS) {
736 OP *kid = cUNOPo->op_first;
738 switch (kid->op_type) {
743 forget_pmop((PMOP*)kid, 0);
745 find_and_forget_pmops(kid);
746 kid = kid->op_sibling;
752 Perl_op_null(pTHX_ OP *o)
756 PERL_ARGS_ASSERT_OP_NULL;
758 if (o->op_type == OP_NULL)
762 o->op_targ = o->op_type;
763 o->op_type = OP_NULL;
764 o->op_ppaddr = PL_ppaddr[OP_NULL];
768 Perl_op_refcnt_lock(pTHX)
776 Perl_op_refcnt_unlock(pTHX)
783 /* Contextualizers */
785 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
788 S_linklist(pTHX_ OP *o)
792 PERL_ARGS_ASSERT_LINKLIST;
797 /* establish postfix order */
798 first = cUNOPo->op_first;
801 o->op_next = LINKLIST(first);
804 if (kid->op_sibling) {
805 kid->op_next = LINKLIST(kid->op_sibling);
806 kid = kid->op_sibling;
820 S_scalarkids(pTHX_ OP *o)
822 if (o && o->op_flags & OPf_KIDS) {
824 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
831 S_scalarboolean(pTHX_ OP *o)
835 PERL_ARGS_ASSERT_SCALARBOOLEAN;
837 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
838 if (ckWARN(WARN_SYNTAX)) {
839 const line_t oldline = CopLINE(PL_curcop);
841 if (PL_parser && PL_parser->copline != NOLINE)
842 CopLINE_set(PL_curcop, PL_parser->copline);
843 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
844 CopLINE_set(PL_curcop, oldline);
851 Perl_scalar(pTHX_ OP *o)
856 /* assumes no premature commitment */
857 if (!o || (PL_parser && PL_parser->error_count)
858 || (o->op_flags & OPf_WANT)
859 || o->op_type == OP_RETURN)
864 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
866 switch (o->op_type) {
868 scalar(cBINOPo->op_first);
873 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
883 if (o->op_flags & OPf_KIDS) {
884 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
890 kid = cLISTOPo->op_first;
892 while ((kid = kid->op_sibling)) {
898 PL_curcop = &PL_compiling;
903 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
909 PL_curcop = &PL_compiling;
912 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
919 Perl_scalarvoid(pTHX_ OP *o)
923 const char* useless = NULL;
927 PERL_ARGS_ASSERT_SCALARVOID;
929 /* trailing mad null ops don't count as "there" for void processing */
931 o->op_type != OP_NULL &&
933 o->op_sibling->op_type == OP_NULL)
936 for (sib = o->op_sibling;
937 sib && sib->op_type == OP_NULL;
938 sib = sib->op_sibling) ;
944 if (o->op_type == OP_NEXTSTATE
945 || o->op_type == OP_DBSTATE
946 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
947 || o->op_targ == OP_DBSTATE)))
948 PL_curcop = (COP*)o; /* for warning below */
950 /* assumes no premature commitment */
951 want = o->op_flags & OPf_WANT;
952 if ((want && want != OPf_WANT_SCALAR)
953 || (PL_parser && PL_parser->error_count)
954 || o->op_type == OP_RETURN)
959 if ((o->op_private & OPpTARGET_MY)
960 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
962 return scalar(o); /* As if inside SASSIGN */
965 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
967 switch (o->op_type) {
969 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
973 if (o->op_flags & OPf_STACKED)
977 if (o->op_private == 4)
1020 case OP_GETSOCKNAME:
1021 case OP_GETPEERNAME:
1026 case OP_GETPRIORITY:
1050 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1051 /* Otherwise it's "Useless use of grep iterator" */
1052 useless = OP_DESC(o);
1056 kid = cUNOPo->op_first;
1057 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1058 kid->op_type != OP_TRANS) {
1061 useless = "negative pattern binding (!~)";
1068 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1069 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1070 useless = "a variable";
1075 if (cSVOPo->op_private & OPpCONST_STRICT)
1076 no_bareword_allowed(o);
1078 if (ckWARN(WARN_VOID)) {
1080 SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_
1081 "a constant (%"SVf")", sv));
1082 useless = SvPV_nolen(msv);
1085 useless = "a constant (undef)";
1086 if (o->op_private & OPpCONST_ARYBASE)
1088 /* don't warn on optimised away booleans, eg
1089 * use constant Foo, 5; Foo || print; */
1090 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1092 /* the constants 0 and 1 are permitted as they are
1093 conventionally used as dummies in constructs like
1094 1 while some_condition_with_side_effects; */
1095 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1097 else if (SvPOK(sv)) {
1098 /* perl4's way of mixing documentation and code
1099 (before the invention of POD) was based on a
1100 trick to mix nroff and perl code. The trick was
1101 built upon these three nroff macros being used in
1102 void context. The pink camel has the details in
1103 the script wrapman near page 319. */
1104 const char * const maybe_macro = SvPVX_const(sv);
1105 if (strnEQ(maybe_macro, "di", 2) ||
1106 strnEQ(maybe_macro, "ds", 2) ||
1107 strnEQ(maybe_macro, "ig", 2))
1112 op_null(o); /* don't execute or even remember it */
1116 o->op_type = OP_PREINC; /* pre-increment is faster */
1117 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1121 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1122 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1126 o->op_type = OP_I_PREINC; /* pre-increment is faster */
1127 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1131 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
1132 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1137 kid = cLOGOPo->op_first;
1138 if (kid->op_type == OP_NOT
1139 && (kid->op_flags & OPf_KIDS)
1141 if (o->op_type == OP_AND) {
1143 o->op_ppaddr = PL_ppaddr[OP_OR];
1145 o->op_type = OP_AND;
1146 o->op_ppaddr = PL_ppaddr[OP_AND];
1155 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1160 if (o->op_flags & OPf_STACKED)
1167 if (!(o->op_flags & OPf_KIDS))
1178 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1185 /* all requires must return a boolean value */
1186 o->op_flags &= ~OPf_WANT;
1192 Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
1197 S_listkids(pTHX_ OP *o)
1199 if (o && o->op_flags & OPf_KIDS) {
1201 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1208 Perl_list(pTHX_ OP *o)
1213 /* assumes no premature commitment */
1214 if (!o || (o->op_flags & OPf_WANT)
1215 || (PL_parser && PL_parser->error_count)
1216 || o->op_type == OP_RETURN)
1221 if ((o->op_private & OPpTARGET_MY)
1222 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1224 return o; /* As if inside SASSIGN */
1227 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1229 switch (o->op_type) {
1232 list(cBINOPo->op_first);
1237 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1245 if (!(o->op_flags & OPf_KIDS))
1247 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1248 list(cBINOPo->op_first);
1249 return gen_constant_list(o);
1256 kid = cLISTOPo->op_first;
1258 while ((kid = kid->op_sibling)) {
1259 if (kid->op_sibling)
1264 PL_curcop = &PL_compiling;
1268 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1269 if (kid->op_sibling)
1274 PL_curcop = &PL_compiling;
1277 /* all requires must return a boolean value */
1278 o->op_flags &= ~OPf_WANT;
1285 S_scalarseq(pTHX_ OP *o)
1289 const OPCODE type = o->op_type;
1291 if (type == OP_LINESEQ || type == OP_SCOPE ||
1292 type == OP_LEAVE || type == OP_LEAVETRY)
1295 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1296 if (kid->op_sibling) {
1300 PL_curcop = &PL_compiling;
1302 o->op_flags &= ~OPf_PARENS;
1303 if (PL_hints & HINT_BLOCK_SCOPE)
1304 o->op_flags |= OPf_PARENS;
1307 o = newOP(OP_STUB, 0);
1312 S_modkids(pTHX_ OP *o, I32 type)
1314 if (o && o->op_flags & OPf_KIDS) {
1316 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1322 /* Propagate lvalue ("modifiable") context to an op and its children.
1323 * 'type' represents the context type, roughly based on the type of op that
1324 * would do the modifying, although local() is represented by OP_NULL.
1325 * It's responsible for detecting things that can't be modified, flag
1326 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
1327 * might have to vivify a reference in $x), and so on.
1329 * For example, "$a+1 = 2" would cause mod() to be called with o being
1330 * OP_ADD and type being OP_SASSIGN, and would output an error.
1334 Perl_mod(pTHX_ OP *o, I32 type)
1338 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1341 if (!o || (PL_parser && PL_parser->error_count))
1344 if ((o->op_private & OPpTARGET_MY)
1345 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1350 switch (o->op_type) {
1356 if (!(o->op_private & OPpCONST_ARYBASE))
1359 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1360 CopARYBASE_set(&PL_compiling,
1361 (I32)SvIV(cSVOPx(PL_eval_start)->op_sv));
1365 SAVECOPARYBASE(&PL_compiling);
1366 CopARYBASE_set(&PL_compiling, 0);
1368 else if (type == OP_REFGEN)
1371 Perl_croak(aTHX_ "That use of $[ is unsupported");
1374 if ((o->op_flags & OPf_PARENS) || PL_madskills)
1378 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1379 !(o->op_flags & OPf_STACKED)) {
1380 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1381 /* The default is to set op_private to the number of children,
1382 which for a UNOP such as RV2CV is always 1. And w're using
1383 the bit for a flag in RV2CV, so we need it clear. */
1384 o->op_private &= ~1;
1385 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1386 assert(cUNOPo->op_first->op_type == OP_NULL);
1387 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1390 else if (o->op_private & OPpENTERSUB_NOMOD)
1392 else { /* lvalue subroutine call */
1393 o->op_private |= OPpLVAL_INTRO;
1394 PL_modcount = RETURN_UNLIMITED_NUMBER;
1395 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1396 /* Backward compatibility mode: */
1397 o->op_private |= OPpENTERSUB_INARGS;
1400 else { /* Compile-time error message: */
1401 OP *kid = cUNOPo->op_first;
1405 if (kid->op_type != OP_PUSHMARK) {
1406 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1408 "panic: unexpected lvalue entersub "
1409 "args: type/targ %ld:%"UVuf,
1410 (long)kid->op_type, (UV)kid->op_targ);
1411 kid = kLISTOP->op_first;
1413 while (kid->op_sibling)
1414 kid = kid->op_sibling;
1415 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1417 if (kid->op_type == OP_METHOD_NAMED
1418 || kid->op_type == OP_METHOD)
1422 NewOp(1101, newop, 1, UNOP);
1423 newop->op_type = OP_RV2CV;
1424 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1425 newop->op_first = NULL;
1426 newop->op_next = (OP*)newop;
1427 kid->op_sibling = (OP*)newop;
1428 newop->op_private |= OPpLVAL_INTRO;
1429 newop->op_private &= ~1;
1433 if (kid->op_type != OP_RV2CV)
1435 "panic: unexpected lvalue entersub "
1436 "entry via type/targ %ld:%"UVuf,
1437 (long)kid->op_type, (UV)kid->op_targ);
1438 kid->op_private |= OPpLVAL_INTRO;
1439 break; /* Postpone until runtime */
1443 kid = kUNOP->op_first;
1444 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1445 kid = kUNOP->op_first;
1446 if (kid->op_type == OP_NULL)
1448 "Unexpected constant lvalue entersub "
1449 "entry via type/targ %ld:%"UVuf,
1450 (long)kid->op_type, (UV)kid->op_targ);
1451 if (kid->op_type != OP_GV) {
1452 /* Restore RV2CV to check lvalueness */
1454 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1455 okid->op_next = kid->op_next;
1456 kid->op_next = okid;
1459 okid->op_next = NULL;
1460 okid->op_type = OP_RV2CV;
1462 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1463 okid->op_private |= OPpLVAL_INTRO;
1464 okid->op_private &= ~1;
1468 cv = GvCV(kGVOP_gv);
1478 /* grep, foreach, subcalls, refgen */
1479 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1481 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1482 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1484 : (o->op_type == OP_ENTERSUB
1485 ? "non-lvalue subroutine call"
1487 type ? PL_op_desc[type] : "local"));
1501 case OP_RIGHT_SHIFT:
1510 if (!(o->op_flags & OPf_STACKED))
1517 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1523 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1524 PL_modcount = RETURN_UNLIMITED_NUMBER;
1525 return o; /* Treat \(@foo) like ordinary list. */
1529 if (scalar_mod_type(o, type))
1531 ref(cUNOPo->op_first, o->op_type);
1535 if (type == OP_LEAVESUBLV)
1536 o->op_private |= OPpMAYBE_LVSUB;
1542 PL_modcount = RETURN_UNLIMITED_NUMBER;
1545 PL_hints |= HINT_BLOCK_SCOPE;
1546 if (type == OP_LEAVESUBLV)
1547 o->op_private |= OPpMAYBE_LVSUB;
1551 ref(cUNOPo->op_first, o->op_type);
1555 PL_hints |= HINT_BLOCK_SCOPE;
1570 PL_modcount = RETURN_UNLIMITED_NUMBER;
1571 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1572 return o; /* Treat \(@foo) like ordinary list. */
1573 if (scalar_mod_type(o, type))
1575 if (type == OP_LEAVESUBLV)
1576 o->op_private |= OPpMAYBE_LVSUB;
1580 if (!type) /* local() */
1581 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1582 PAD_COMPNAME_PV(o->op_targ));
1590 if (type != OP_SASSIGN)
1594 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1599 if (type == OP_LEAVESUBLV)
1600 o->op_private |= OPpMAYBE_LVSUB;
1602 pad_free(o->op_targ);
1603 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1604 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1605 if (o->op_flags & OPf_KIDS)
1606 mod(cBINOPo->op_first->op_sibling, type);
1611 ref(cBINOPo->op_first, o->op_type);
1612 if (type == OP_ENTERSUB &&
1613 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1614 o->op_private |= OPpLVAL_DEFER;
1615 if (type == OP_LEAVESUBLV)
1616 o->op_private |= OPpMAYBE_LVSUB;
1626 if (o->op_flags & OPf_KIDS)
1627 mod(cLISTOPo->op_last, type);
1632 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1634 else if (!(o->op_flags & OPf_KIDS))
1636 if (o->op_targ != OP_LIST) {
1637 mod(cBINOPo->op_first, type);
1643 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1648 if (type != OP_LEAVESUBLV)
1650 break; /* mod()ing was handled by ck_return() */
1653 /* [20011101.069] File test operators interpret OPf_REF to mean that
1654 their argument is a filehandle; thus \stat(".") should not set
1656 if (type == OP_REFGEN &&
1657 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1660 if (type != OP_LEAVESUBLV)
1661 o->op_flags |= OPf_MOD;
1663 if (type == OP_AASSIGN || type == OP_SASSIGN)
1664 o->op_flags |= OPf_SPECIAL|OPf_REF;
1665 else if (!type) { /* local() */
1668 o->op_private |= OPpLVAL_INTRO;
1669 o->op_flags &= ~OPf_SPECIAL;
1670 PL_hints |= HINT_BLOCK_SCOPE;
1675 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
1676 "Useless localization of %s", OP_DESC(o));
1679 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1680 && type != OP_LEAVESUBLV)
1681 o->op_flags |= OPf_REF;
1686 S_scalar_mod_type(const OP *o, I32 type)
1688 PERL_ARGS_ASSERT_SCALAR_MOD_TYPE;
1692 if (o->op_type == OP_RV2GV)
1716 case OP_RIGHT_SHIFT:
1736 S_is_handle_constructor(const OP *o, I32 numargs)
1738 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
1740 switch (o->op_type) {
1748 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1761 S_refkids(pTHX_ OP *o, I32 type)
1763 if (o && o->op_flags & OPf_KIDS) {
1765 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1772 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
1777 PERL_ARGS_ASSERT_DOREF;
1779 if (!o || (PL_parser && PL_parser->error_count))
1782 switch (o->op_type) {
1784 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1785 !(o->op_flags & OPf_STACKED)) {
1786 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1787 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1788 assert(cUNOPo->op_first->op_type == OP_NULL);
1789 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1790 o->op_flags |= OPf_SPECIAL;
1791 o->op_private &= ~1;
1796 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1797 doref(kid, type, set_op_ref);
1800 if (type == OP_DEFINED)
1801 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1802 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1805 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1806 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1807 : type == OP_RV2HV ? OPpDEREF_HV
1809 o->op_flags |= OPf_MOD;
1816 o->op_flags |= OPf_REF;
1819 if (type == OP_DEFINED)
1820 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1821 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1827 o->op_flags |= OPf_REF;
1832 if (!(o->op_flags & OPf_KIDS))
1834 doref(cBINOPo->op_first, type, set_op_ref);
1838 doref(cBINOPo->op_first, o->op_type, set_op_ref);
1839 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1840 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1841 : type == OP_RV2HV ? OPpDEREF_HV
1843 o->op_flags |= OPf_MOD;
1853 if (!(o->op_flags & OPf_KIDS))
1855 doref(cLISTOPo->op_last, type, set_op_ref);
1865 S_dup_attrlist(pTHX_ OP *o)
1870 PERL_ARGS_ASSERT_DUP_ATTRLIST;
1872 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1873 * where the first kid is OP_PUSHMARK and the remaining ones
1874 * are OP_CONST. We need to push the OP_CONST values.
1876 if (o->op_type == OP_CONST)
1877 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
1879 else if (o->op_type == OP_NULL)
1883 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1885 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1886 if (o->op_type == OP_CONST)
1887 rop = append_elem(OP_LIST, rop,
1888 newSVOP(OP_CONST, o->op_flags,
1889 SvREFCNT_inc_NN(cSVOPo->op_sv)));
1896 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1901 PERL_ARGS_ASSERT_APPLY_ATTRS;
1903 /* fake up C<use attributes $pkg,$rv,@attrs> */
1904 ENTER; /* need to protect against side-effects of 'use' */
1905 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1907 #define ATTRSMODULE "attributes"
1908 #define ATTRSMODULE_PM "attributes.pm"
1911 /* Don't force the C<use> if we don't need it. */
1912 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
1913 if (svp && *svp != &PL_sv_undef)
1914 NOOP; /* already in %INC */
1916 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1917 newSVpvs(ATTRSMODULE), NULL);
1920 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1921 newSVpvs(ATTRSMODULE),
1923 prepend_elem(OP_LIST,
1924 newSVOP(OP_CONST, 0, stashsv),
1925 prepend_elem(OP_LIST,
1926 newSVOP(OP_CONST, 0,
1928 dup_attrlist(attrs))));
1934 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1937 OP *pack, *imop, *arg;
1940 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
1945 assert(target->op_type == OP_PADSV ||
1946 target->op_type == OP_PADHV ||
1947 target->op_type == OP_PADAV);
1949 /* Ensure that attributes.pm is loaded. */
1950 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1952 /* Need package name for method call. */
1953 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
1955 /* Build up the real arg-list. */
1956 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1958 arg = newOP(OP_PADSV, 0);
1959 arg->op_targ = target->op_targ;
1960 arg = prepend_elem(OP_LIST,
1961 newSVOP(OP_CONST, 0, stashsv),
1962 prepend_elem(OP_LIST,
1963 newUNOP(OP_REFGEN, 0,
1964 mod(arg, OP_REFGEN)),
1965 dup_attrlist(attrs)));
1967 /* Fake up a method call to import */
1968 meth = newSVpvs_share("import");
1969 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1970 append_elem(OP_LIST,
1971 prepend_elem(OP_LIST, pack, list(arg)),
1972 newSVOP(OP_METHOD_NAMED, 0, meth)));
1973 imop->op_private |= OPpENTERSUB_NOMOD;
1975 /* Combine the ops. */
1976 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1980 =notfor apidoc apply_attrs_string
1982 Attempts to apply a list of attributes specified by the C<attrstr> and
1983 C<len> arguments to the subroutine identified by the C<cv> argument which
1984 is expected to be associated with the package identified by the C<stashpv>
1985 argument (see L<attributes>). It gets this wrong, though, in that it
1986 does not correctly identify the boundaries of the individual attribute
1987 specifications within C<attrstr>. This is not really intended for the
1988 public API, but has to be listed here for systems such as AIX which
1989 need an explicit export list for symbols. (It's called from XS code
1990 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1991 to respect attribute syntax properly would be welcome.
1997 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
1998 const char *attrstr, STRLEN len)
2002 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
2005 len = strlen(attrstr);
2009 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2011 const char * const sstr = attrstr;
2012 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2013 attrs = append_elem(OP_LIST, attrs,
2014 newSVOP(OP_CONST, 0,
2015 newSVpvn(sstr, attrstr-sstr)));
2019 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2020 newSVpvs(ATTRSMODULE),
2021 NULL, prepend_elem(OP_LIST,
2022 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2023 prepend_elem(OP_LIST,
2024 newSVOP(OP_CONST, 0,
2025 newRV(MUTABLE_SV(cv))),
2030 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
2035 PERL_ARGS_ASSERT_MY_KID;
2037 if (!o || (PL_parser && PL_parser->error_count))
2041 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
2042 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
2046 if (type == OP_LIST) {
2048 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2049 my_kid(kid, attrs, imopsp);
2050 } else if (type == OP_UNDEF
2056 } else if (type == OP_RV2SV || /* "our" declaration */
2058 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
2059 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
2060 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2062 PL_parser->in_my == KEY_our
2064 : PL_parser->in_my == KEY_state ? "state" : "my"));
2066 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
2067 PL_parser->in_my = FALSE;
2068 PL_parser->in_my_stash = NULL;
2069 apply_attrs(GvSTASH(gv),
2070 (type == OP_RV2SV ? GvSV(gv) :
2071 type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
2072 type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
2075 o->op_private |= OPpOUR_INTRO;
2078 else if (type != OP_PADSV &&
2081 type != OP_PUSHMARK)
2083 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2085 PL_parser->in_my == KEY_our
2087 : PL_parser->in_my == KEY_state ? "state" : "my"));
2090 else if (attrs && type != OP_PUSHMARK) {
2093 PL_parser->in_my = FALSE;
2094 PL_parser->in_my_stash = NULL;
2096 /* check for C<my Dog $spot> when deciding package */
2097 stash = PAD_COMPNAME_TYPE(o->op_targ);
2099 stash = PL_curstash;
2100 apply_attrs_my(stash, o, attrs, imopsp);
2102 o->op_flags |= OPf_MOD;
2103 o->op_private |= OPpLVAL_INTRO;
2104 if (PL_parser->in_my == KEY_state)
2105 o->op_private |= OPpPAD_STATE;
2110 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2114 int maybe_scalar = 0;
2116 PERL_ARGS_ASSERT_MY_ATTRS;
2118 /* [perl #17376]: this appears to be premature, and results in code such as
2119 C< our(%x); > executing in list mode rather than void mode */
2121 if (o->op_flags & OPf_PARENS)
2131 o = my_kid(o, attrs, &rops);
2133 if (maybe_scalar && o->op_type == OP_PADSV) {
2134 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
2135 o->op_private |= OPpLVAL_INTRO;
2138 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
2140 PL_parser->in_my = FALSE;
2141 PL_parser->in_my_stash = NULL;
2146 Perl_sawparens(pTHX_ OP *o)
2148 PERL_UNUSED_CONTEXT;
2150 o->op_flags |= OPf_PARENS;
2155 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2159 const OPCODE ltype = left->op_type;
2160 const OPCODE rtype = right->op_type;
2162 PERL_ARGS_ASSERT_BIND_MATCH;
2164 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2165 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
2167 const char * const desc
2168 = PL_op_desc[(rtype == OP_SUBST || rtype == OP_TRANS)
2169 ? (int)rtype : OP_MATCH];
2170 const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV)
2171 ? "@array" : "%hash");
2172 Perl_warner(aTHX_ packWARN(WARN_MISC),
2173 "Applying %s to %s will act on scalar(%s)",
2174 desc, sample, sample);
2177 if (rtype == OP_CONST &&
2178 cSVOPx(right)->op_private & OPpCONST_BARE &&
2179 cSVOPx(right)->op_private & OPpCONST_STRICT)
2181 no_bareword_allowed(right);
2184 ismatchop = rtype == OP_MATCH ||
2185 rtype == OP_SUBST ||
2187 if (ismatchop && right->op_private & OPpTARGET_MY) {
2189 right->op_private &= ~OPpTARGET_MY;
2191 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
2194 right->op_flags |= OPf_STACKED;
2195 if (rtype != OP_MATCH &&
2196 ! (rtype == OP_TRANS &&
2197 right->op_private & OPpTRANS_IDENTICAL))
2198 newleft = mod(left, rtype);
2201 if (right->op_type == OP_TRANS)
2202 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
2204 o = prepend_elem(rtype, scalar(newleft), right);
2206 return newUNOP(OP_NOT, 0, scalar(o));
2210 return bind_match(type, left,
2211 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
2215 Perl_invert(pTHX_ OP *o)
2219 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2223 Perl_scope(pTHX_ OP *o)
2227 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2228 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2229 o->op_type = OP_LEAVE;
2230 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2232 else if (o->op_type == OP_LINESEQ) {
2234 o->op_type = OP_SCOPE;
2235 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2236 kid = ((LISTOP*)o)->op_first;
2237 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2240 /* The following deals with things like 'do {1 for 1}' */
2241 kid = kid->op_sibling;
2243 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2248 o = newLISTOP(OP_SCOPE, 0, o, NULL);
2254 Perl_block_start(pTHX_ int full)
2257 const int retval = PL_savestack_ix;
2258 pad_block_start(full);
2260 PL_hints &= ~HINT_BLOCK_SCOPE;
2261 SAVECOMPILEWARNINGS();
2262 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
2267 Perl_block_end(pTHX_ I32 floor, OP *seq)
2270 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2271 OP* const retval = scalarseq(seq);
2273 CopHINTS_set(&PL_compiling, PL_hints);
2275 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2284 const PADOFFSET offset = pad_findmy("$_");
2285 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
2286 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2289 OP * const o = newOP(OP_PADSV, 0);
2290 o->op_targ = offset;
2296 Perl_newPROG(pTHX_ OP *o)
2300 PERL_ARGS_ASSERT_NEWPROG;
2305 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2306 ((PL_in_eval & EVAL_KEEPERR)
2307 ? OPf_SPECIAL : 0), o);
2308 PL_eval_start = linklist(PL_eval_root);
2309 PL_eval_root->op_private |= OPpREFCOUNTED;
2310 OpREFCNT_set(PL_eval_root, 1);
2311 PL_eval_root->op_next = 0;
2312 CALL_PEEP(PL_eval_start);
2315 if (o->op_type == OP_STUB) {
2316 PL_comppad_name = 0;
2318 S_op_destroy(aTHX_ o);
2321 PL_main_root = scope(sawparens(scalarvoid(o)));
2322 PL_curcop = &PL_compiling;
2323 PL_main_start = LINKLIST(PL_main_root);
2324 PL_main_root->op_private |= OPpREFCOUNTED;
2325 OpREFCNT_set(PL_main_root, 1);
2326 PL_main_root->op_next = 0;
2327 CALL_PEEP(PL_main_start);
2330 /* Register with debugger */
2332 CV * const cv = get_cvs("DB::postponed", 0);
2336 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
2338 call_sv(MUTABLE_SV(cv), G_DISCARD);
2345 Perl_localize(pTHX_ OP *o, I32 lex)
2349 PERL_ARGS_ASSERT_LOCALIZE;
2351 if (o->op_flags & OPf_PARENS)
2352 /* [perl #17376]: this appears to be premature, and results in code such as
2353 C< our(%x); > executing in list mode rather than void mode */
2360 if ( PL_parser->bufptr > PL_parser->oldbufptr
2361 && PL_parser->bufptr[-1] == ','
2362 && ckWARN(WARN_PARENTHESIS))
2364 char *s = PL_parser->bufptr;
2367 /* some heuristics to detect a potential error */
2368 while (*s && (strchr(", \t\n", *s)))
2372 if (*s && strchr("@$%*", *s) && *++s
2373 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2376 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2378 while (*s && (strchr(", \t\n", *s)))
2384 if (sigil && (*s == ';' || *s == '=')) {
2385 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2386 "Parentheses missing around \"%s\" list",
2388 ? (PL_parser->in_my == KEY_our
2390 : PL_parser->in_my == KEY_state
2400 o = mod(o, OP_NULL); /* a bit kludgey */
2401 PL_parser->in_my = FALSE;
2402 PL_parser->in_my_stash = NULL;
2407 Perl_jmaybe(pTHX_ OP *o)
2409 PERL_ARGS_ASSERT_JMAYBE;
2411 if (o->op_type == OP_LIST) {
2413 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2414 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2420 S_fold_constants(pTHX_ register OP *o)
2423 register OP * VOL curop;
2425 VOL I32 type = o->op_type;
2430 SV * const oldwarnhook = PL_warnhook;
2431 SV * const olddiehook = PL_diehook;
2435 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
2437 if (PL_opargs[type] & OA_RETSCALAR)
2439 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2440 o->op_targ = pad_alloc(type, SVs_PADTMP);
2442 /* integerize op, unless it happens to be C<-foo>.
2443 * XXX should pp_i_negate() do magic string negation instead? */
2444 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2445 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2446 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2448 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2451 if (!(PL_opargs[type] & OA_FOLDCONST))
2456 /* XXX might want a ck_negate() for this */
2457 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2468 /* XXX what about the numeric ops? */
2469 if (PL_hints & HINT_LOCALE)
2474 if (PL_parser && PL_parser->error_count)
2475 goto nope; /* Don't try to run w/ errors */
2477 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2478 const OPCODE type = curop->op_type;
2479 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2481 type != OP_SCALAR &&
2483 type != OP_PUSHMARK)
2489 curop = LINKLIST(o);
2490 old_next = o->op_next;
2494 oldscope = PL_scopestack_ix;
2495 create_eval_scope(G_FAKINGEVAL);
2497 /* Verify that we don't need to save it: */
2498 assert(PL_curcop == &PL_compiling);
2499 StructCopy(&PL_compiling, ¬_compiling, COP);
2500 PL_curcop = ¬_compiling;
2501 /* The above ensures that we run with all the correct hints of the
2502 currently compiling COP, but that IN_PERL_RUNTIME is not true. */
2503 assert(IN_PERL_RUNTIME);
2504 PL_warnhook = PERL_WARNHOOK_FATAL;
2511 sv = *(PL_stack_sp--);
2512 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2513 pad_swipe(o->op_targ, FALSE);
2514 else if (SvTEMP(sv)) { /* grab mortal temp? */
2515 SvREFCNT_inc_simple_void(sv);
2520 /* Something tried to die. Abandon constant folding. */
2521 /* Pretend the error never happened. */
2523 o->op_next = old_next;
2527 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
2528 PL_warnhook = oldwarnhook;
2529 PL_diehook = olddiehook;
2530 /* XXX note that this croak may fail as we've already blown away
2531 * the stack - eg any nested evals */
2532 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
2535 PL_warnhook = oldwarnhook;
2536 PL_diehook = olddiehook;
2537 PL_curcop = &PL_compiling;
2539 if (PL_scopestack_ix > oldscope)
2540 delete_eval_scope();
2549 if (type == OP_RV2GV)
2550 newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
2552 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
2553 op_getmad(o,newop,'f');
2561 S_gen_constant_list(pTHX_ register OP *o)
2565 const I32 oldtmps_floor = PL_tmps_floor;
2568 if (PL_parser && PL_parser->error_count)
2569 return o; /* Don't attempt to run with errors */
2571 PL_op = curop = LINKLIST(o);
2577 assert (!(curop->op_flags & OPf_SPECIAL));
2578 assert(curop->op_type == OP_RANGE);
2580 PL_tmps_floor = oldtmps_floor;
2582 o->op_type = OP_RV2AV;
2583 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2584 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2585 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2586 o->op_opt = 0; /* needs to be revisited in peep() */
2587 curop = ((UNOP*)o)->op_first;
2588 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
2590 op_getmad(curop,o,'O');
2599 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2602 if (!o || o->op_type != OP_LIST)
2603 o = newLISTOP(OP_LIST, 0, o, NULL);
2605 o->op_flags &= ~OPf_WANT;
2607 if (!(PL_opargs[type] & OA_MARK))
2608 op_null(cLISTOPo->op_first);
2610 o->op_type = (OPCODE)type;
2611 o->op_ppaddr = PL_ppaddr[type];
2612 o->op_flags |= flags;
2614 o = CHECKOP(type, o);
2615 if (o->op_type != (unsigned)type)
2618 return fold_constants(o);
2621 /* List constructors */
2624 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2632 if (first->op_type != (unsigned)type
2633 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2635 return newLISTOP(type, 0, first, last);
2638 if (first->op_flags & OPf_KIDS)
2639 ((LISTOP*)first)->op_last->op_sibling = last;
2641 first->op_flags |= OPf_KIDS;
2642 ((LISTOP*)first)->op_first = last;
2644 ((LISTOP*)first)->op_last = last;
2649 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2657 if (first->op_type != (unsigned)type)
2658 return prepend_elem(type, (OP*)first, (OP*)last);
2660 if (last->op_type != (unsigned)type)
2661 return append_elem(type, (OP*)first, (OP*)last);
2663 first->op_last->op_sibling = last->op_first;
2664 first->op_last = last->op_last;
2665 first->op_flags |= (last->op_flags & OPf_KIDS);
2668 if (last->op_first && first->op_madprop) {
2669 MADPROP *mp = last->op_first->op_madprop;
2671 while (mp->mad_next)
2673 mp->mad_next = first->op_madprop;
2676 last->op_first->op_madprop = first->op_madprop;
2679 first->op_madprop = last->op_madprop;
2680 last->op_madprop = 0;
2683 S_op_destroy(aTHX_ (OP*)last);
2689 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2697 if (last->op_type == (unsigned)type) {
2698 if (type == OP_LIST) { /* already a PUSHMARK there */
2699 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2700 ((LISTOP*)last)->op_first->op_sibling = first;
2701 if (!(first->op_flags & OPf_PARENS))
2702 last->op_flags &= ~OPf_PARENS;
2705 if (!(last->op_flags & OPf_KIDS)) {
2706 ((LISTOP*)last)->op_last = first;
2707 last->op_flags |= OPf_KIDS;
2709 first->op_sibling = ((LISTOP*)last)->op_first;
2710 ((LISTOP*)last)->op_first = first;
2712 last->op_flags |= OPf_KIDS;
2716 return newLISTOP(type, 0, first, last);
2724 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2727 Newxz(tk, 1, TOKEN);
2728 tk->tk_type = (OPCODE)optype;
2729 tk->tk_type = 12345;
2731 tk->tk_mad = madprop;
2736 Perl_token_free(pTHX_ TOKEN* tk)
2738 PERL_ARGS_ASSERT_TOKEN_FREE;
2740 if (tk->tk_type != 12345)
2742 mad_free(tk->tk_mad);
2747 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2752 PERL_ARGS_ASSERT_TOKEN_GETMAD;
2754 if (tk->tk_type != 12345) {
2755 Perl_warner(aTHX_ packWARN(WARN_MISC),
2756 "Invalid TOKEN object ignored");
2763 /* faked up qw list? */
2765 tm->mad_type == MAD_SV &&
2766 SvPVX((SV *)tm->mad_val)[0] == 'q')
2773 /* pretend constant fold didn't happen? */
2774 if (mp->mad_key == 'f' &&
2775 (o->op_type == OP_CONST ||
2776 o->op_type == OP_GV) )
2778 token_getmad(tk,(OP*)mp->mad_val,slot);
2792 if (mp->mad_key == 'X')
2793 mp->mad_key = slot; /* just change the first one */
2803 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
2812 /* pretend constant fold didn't happen? */
2813 if (mp->mad_key == 'f' &&
2814 (o->op_type == OP_CONST ||
2815 o->op_type == OP_GV) )
2817 op_getmad(from,(OP*)mp->mad_val,slot);
2824 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
2827 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
2833 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
2842 /* pretend constant fold didn't happen? */
2843 if (mp->mad_key == 'f' &&
2844 (o->op_type == OP_CONST ||
2845 o->op_type == OP_GV) )
2847 op_getmad(from,(OP*)mp->mad_val,slot);
2854 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
2857 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
2861 PerlIO_printf(PerlIO_stderr(),
2862 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
2868 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
2886 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
2890 addmad(tm, &(o->op_madprop), slot);
2894 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
2915 Perl_newMADsv(pTHX_ char key, SV* sv)
2917 PERL_ARGS_ASSERT_NEWMADSV;
2919 return newMADPROP(key, MAD_SV, sv, 0);
2923 Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
2926 Newxz(mp, 1, MADPROP);
2929 mp->mad_vlen = vlen;
2930 mp->mad_type = type;
2932 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
2937 Perl_mad_free(pTHX_ MADPROP* mp)
2939 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
2943 mad_free(mp->mad_next);
2944 /* if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
2945 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
2946 switch (mp->mad_type) {
2950 Safefree((char*)mp->mad_val);
2953 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
2954 op_free((OP*)mp->mad_val);
2957 sv_free(MUTABLE_SV(mp->mad_val));
2960 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
2969 Perl_newNULLLIST(pTHX)
2971 return newOP(OP_STUB, 0);
2975 S_force_list(pTHX_ OP *o)
2977 if (!o || o->op_type != OP_LIST)
2978 o = newLISTOP(OP_LIST, 0, o, NULL);
2984 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2989 NewOp(1101, listop, 1, LISTOP);
2991 listop->op_type = (OPCODE)type;
2992 listop->op_ppaddr = PL_ppaddr[type];
2995 listop->op_flags = (U8)flags;
2999 else if (!first && last)
3002 first->op_sibling = last;
3003 listop->op_first = first;
3004 listop->op_last = last;
3005 if (type == OP_LIST) {
3006 OP* const pushop = newOP(OP_PUSHMARK, 0);
3007 pushop->op_sibling = first;
3008 listop->op_first = pushop;
3009 listop->op_flags |= OPf_KIDS;
3011 listop->op_last = pushop;
3014 return CHECKOP(type, listop);
3018 Perl_newOP(pTHX_ I32 type, I32 flags)
3022 NewOp(1101, o, 1, OP);
3023 o->op_type = (OPCODE)type;
3024 o->op_ppaddr = PL_ppaddr[type];
3025 o->op_flags = (U8)flags;
3027 o->op_latefreed = 0;
3031 o->op_private = (U8)(0 | (flags >> 8));
3032 if (PL_opargs[type] & OA_RETSCALAR)
3034 if (PL_opargs[type] & OA_TARGET)
3035 o->op_targ = pad_alloc(type, SVs_PADTMP);
3036 return CHECKOP(type, o);
3040 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
3046 first = newOP(OP_STUB, 0);
3047 if (PL_opargs[type] & OA_MARK)
3048 first = force_list(first);
3050 NewOp(1101, unop, 1, UNOP);
3051 unop->op_type = (OPCODE)type;
3052 unop->op_ppaddr = PL_ppaddr[type];
3053 unop->op_first = first;
3054 unop->op_flags = (U8)(flags | OPf_KIDS);
3055 unop->op_private = (U8)(1 | (flags >> 8));
3056 unop = (UNOP*) CHECKOP(type, unop);
3060 return fold_constants((OP *) unop);
3064 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3068 NewOp(1101, binop, 1, BINOP);
3071 first = newOP(OP_NULL, 0);
3073 binop->op_type = (OPCODE)type;
3074 binop->op_ppaddr = PL_ppaddr[type];
3075 binop->op_first = first;
3076 binop->op_flags = (U8)(flags | OPf_KIDS);
3079 binop->op_private = (U8)(1 | (flags >> 8));
3082 binop->op_private = (U8)(2 | (flags >> 8));
3083 first->op_sibling = last;
3086 binop = (BINOP*)CHECKOP(type, binop);
3087 if (binop->op_next || binop->op_type != (OPCODE)type)
3090 binop->op_last = binop->op_first->op_sibling;
3092 return fold_constants((OP *)binop);
3095 static int uvcompare(const void *a, const void *b)
3096 __attribute__nonnull__(1)
3097 __attribute__nonnull__(2)
3098 __attribute__pure__;
3099 static int uvcompare(const void *a, const void *b)
3101 if (*((const UV *)a) < (*(const UV *)b))
3103 if (*((const UV *)a) > (*(const UV *)b))
3105 if (*((const UV *)a+1) < (*(const UV *)b+1))
3107 if (*((const UV *)a+1) > (*(const UV *)b+1))
3113 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
3116 SV * const tstr = ((SVOP*)expr)->op_sv;
3119 (repl->op_type == OP_NULL)
3120 ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
3122 ((SVOP*)repl)->op_sv;
3125 const U8 *t = (U8*)SvPV_const(tstr, tlen);
3126 const U8 *r = (U8*)SvPV_const(rstr, rlen);
3130 register short *tbl;
3132 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
3133 const I32 squash = o->op_private & OPpTRANS_SQUASH;
3134 I32 del = o->op_private & OPpTRANS_DELETE;
3137 PERL_ARGS_ASSERT_PMTRANS;
3139 PL_hints |= HINT_BLOCK_SCOPE;
3142 o->op_private |= OPpTRANS_FROM_UTF;
3145 o->op_private |= OPpTRANS_TO_UTF;
3147 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
3148 SV* const listsv = newSVpvs("# comment\n");
3150 const U8* tend = t + tlen;
3151 const U8* rend = r + rlen;
3165 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
3166 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
3169 const U32 flags = UTF8_ALLOW_DEFAULT;
3173 t = tsave = bytes_to_utf8(t, &len);
3176 if (!to_utf && rlen) {
3178 r = rsave = bytes_to_utf8(r, &len);
3182 /* There are several snags with this code on EBCDIC:
3183 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
3184 2. scan_const() in toke.c has encoded chars in native encoding which makes
3185 ranges at least in EBCDIC 0..255 range the bottom odd.
3189 U8 tmpbuf[UTF8_MAXBYTES+1];
3192 Newx(cp, 2*tlen, UV);
3194 transv = newSVpvs("");
3196 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3198 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
3200 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3204 cp[2*i+1] = cp[2*i];
3208 qsort(cp, i, 2*sizeof(UV), uvcompare);
3209 for (j = 0; j < i; j++) {
3211 diff = val - nextmin;
3213 t = uvuni_to_utf8(tmpbuf,nextmin);
3214 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3216 U8 range_mark = UTF_TO_NATIVE(0xff);
3217 t = uvuni_to_utf8(tmpbuf, val - 1);
3218 sv_catpvn(transv, (char *)&range_mark, 1);
3219 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3226 t = uvuni_to_utf8(tmpbuf,nextmin);
3227 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3229 U8 range_mark = UTF_TO_NATIVE(0xff);
3230 sv_catpvn(transv, (char *)&range_mark, 1);
3232 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
3233 UNICODE_ALLOW_SUPER);
3234 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3235 t = (const U8*)SvPVX_const(transv);
3236 tlen = SvCUR(transv);
3240 else if (!rlen && !del) {
3241 r = t; rlen = tlen; rend = tend;
3244 if ((!rlen && !del) || t == r ||
3245 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
3247 o->op_private |= OPpTRANS_IDENTICAL;
3251 while (t < tend || tfirst <= tlast) {
3252 /* see if we need more "t" chars */
3253 if (tfirst > tlast) {
3254 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3256 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
3258 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3265 /* now see if we need more "r" chars */
3266 if (rfirst > rlast) {
3268 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3270 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
3272 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3281 rfirst = rlast = 0xffffffff;
3285 /* now see which range will peter our first, if either. */
3286 tdiff = tlast - tfirst;
3287 rdiff = rlast - rfirst;
3294 if (rfirst == 0xffffffff) {
3295 diff = tdiff; /* oops, pretend rdiff is infinite */
3297 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
3298 (long)tfirst, (long)tlast);
3300 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
3304 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
3305 (long)tfirst, (long)(tfirst + diff),
3308 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3309 (long)tfirst, (long)rfirst);
3311 if (rfirst + diff > max)
3312 max = rfirst + diff;
3314 grows = (tfirst < rfirst &&
3315 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3327 else if (max > 0xff)
3332 PerlMemShared_free(cPVOPo->op_pv);
3333 cPVOPo->op_pv = NULL;
3335 swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
3337 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
3338 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
3339 PAD_SETSV(cPADOPo->op_padix, swash);
3341 SvREADONLY_on(swash);
3343 cSVOPo->op_sv = swash;
3345 SvREFCNT_dec(listsv);
3346 SvREFCNT_dec(transv);
3348 if (!del && havefinal && rlen)
3349 (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
3350 newSVuv((UV)final), 0);
3353 o->op_private |= OPpTRANS_GROWS;
3359 op_getmad(expr,o,'e');
3360 op_getmad(repl,o,'r');
3368 tbl = (short*)cPVOPo->op_pv;
3370 Zero(tbl, 256, short);
3371 for (i = 0; i < (I32)tlen; i++)
3373 for (i = 0, j = 0; i < 256; i++) {
3375 if (j >= (I32)rlen) {
3384 if (i < 128 && r[j] >= 128)
3394 o->op_private |= OPpTRANS_IDENTICAL;
3396 else if (j >= (I32)rlen)
3401 PerlMemShared_realloc(tbl,
3402 (0x101+rlen-j) * sizeof(short));
3403 cPVOPo->op_pv = (char*)tbl;
3405 tbl[0x100] = (short)(rlen - j);
3406 for (i=0; i < (I32)rlen - j; i++)
3407 tbl[0x101+i] = r[j+i];
3411 if (!rlen && !del) {
3414 o->op_private |= OPpTRANS_IDENTICAL;
3416 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3417 o->op_private |= OPpTRANS_IDENTICAL;
3419 for (i = 0; i < 256; i++)
3421 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3422 if (j >= (I32)rlen) {
3424 if (tbl[t[i]] == -1)
3430 if (tbl[t[i]] == -1) {
3431 if (t[i] < 128 && r[j] >= 128)
3438 if(del && rlen == tlen) {
3439 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
3440 } else if(rlen > tlen) {
3441 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
3445 o->op_private |= OPpTRANS_GROWS;
3447 op_getmad(expr,o,'e');
3448 op_getmad(repl,o,'r');
3458 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3463 NewOp(1101, pmop, 1, PMOP);
3464 pmop->op_type = (OPCODE)type;
3465 pmop->op_ppaddr = PL_ppaddr[type];
3466 pmop->op_flags = (U8)flags;
3467 pmop->op_private = (U8)(0 | (flags >> 8));
3469 if (PL_hints & HINT_RE_TAINT)
3470 pmop->op_pmflags |= PMf_RETAINT;
3471 if (PL_hints & HINT_LOCALE)
3472 pmop->op_pmflags |= PMf_LOCALE;
3476 assert(SvPOK(PL_regex_pad[0]));
3477 if (SvCUR(PL_regex_pad[0])) {
3478 /* Pop off the "packed" IV from the end. */
3479 SV *const repointer_list = PL_regex_pad[0];
3480 const char *p = SvEND(repointer_list) - sizeof(IV);
3481 const IV offset = *((IV*)p);
3483 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
3485 SvEND_set(repointer_list, p);
3487 pmop->op_pmoffset = offset;
3488 /* This slot should be free, so assert this: */
3489 assert(PL_regex_pad[offset] == &PL_sv_undef);
3491 SV * const repointer = &PL_sv_undef;
3492 av_push(PL_regex_padav, repointer);
3493 pmop->op_pmoffset = av_len(PL_regex_padav);
3494 PL_regex_pad = AvARRAY(PL_regex_padav);
3498 return CHECKOP(type, pmop);
3501 /* Given some sort of match op o, and an expression expr containing a
3502 * pattern, either compile expr into a regex and attach it to o (if it's
3503 * constant), or convert expr into a runtime regcomp op sequence (if it's
3506 * isreg indicates that the pattern is part of a regex construct, eg
3507 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3508 * split "pattern", which aren't. In the former case, expr will be a list
3509 * if the pattern contains more than one term (eg /a$b/) or if it contains
3510 * a replacement, ie s/// or tr///.
3514 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
3519 I32 repl_has_vars = 0;
3523 PERL_ARGS_ASSERT_PMRUNTIME;
3525 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
3526 /* last element in list is the replacement; pop it */
3528 repl = cLISTOPx(expr)->op_last;
3529 kid = cLISTOPx(expr)->op_first;
3530 while (kid->op_sibling != repl)
3531 kid = kid->op_sibling;
3532 kid->op_sibling = NULL;
3533 cLISTOPx(expr)->op_last = kid;
3536 if (isreg && expr->op_type == OP_LIST &&
3537 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3539 /* convert single element list to element */
3540 OP* const oe = expr;
3541 expr = cLISTOPx(oe)->op_first->op_sibling;
3542 cLISTOPx(oe)->op_first->op_sibling = NULL;
3543 cLISTOPx(oe)->op_last = NULL;
3547 if (o->op_type == OP_TRANS) {
3548 return pmtrans(o, expr, repl);
3551 reglist = isreg && expr->op_type == OP_LIST;
3555 PL_hints |= HINT_BLOCK_SCOPE;
3558 if (expr->op_type == OP_CONST) {
3559 SV *pat = ((SVOP*)expr)->op_sv;
3560 U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
3562 if (o->op_flags & OPf_SPECIAL)
3563 pm_flags |= RXf_SPLIT;
3566 assert (SvUTF8(pat));
3567 } else if (SvUTF8(pat)) {
3568 /* Not doing UTF-8, despite what the SV says. Is this only if we're
3569 trapped in use 'bytes'? */
3570 /* Make a copy of the octet sequence, but without the flag on, as
3571 the compiler now honours the SvUTF8 flag on pat. */
3573 const char *const p = SvPV(pat, len);
3574 pat = newSVpvn_flags(p, len, SVs_TEMP);
3577 PM_SETRE(pm, CALLREGCOMP(pat, pm_flags));
3580 op_getmad(expr,(OP*)pm,'e');
3586 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3587 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3589 : OP_REGCMAYBE),0,expr);
3591 NewOp(1101, rcop, 1, LOGOP);
3592 rcop->op_type = OP_REGCOMP;
3593 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3594 rcop->op_first = scalar(expr);
3595 rcop->op_flags |= OPf_KIDS
3596 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3597 | (reglist ? OPf_STACKED : 0);
3598 rcop->op_private = 1;
3601 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3603 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
3606 /* establish postfix order */
3607 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3609 rcop->op_next = expr;
3610 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3613 rcop->op_next = LINKLIST(expr);
3614 expr->op_next = (OP*)rcop;
3617 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3622 if (pm->op_pmflags & PMf_EVAL) {
3624 if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
3625 CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
3627 else if (repl->op_type == OP_CONST)
3631 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3632 if (curop->op_type == OP_SCOPE
3633 || curop->op_type == OP_LEAVE
3634 || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
3635 if (curop->op_type == OP_GV) {
3636 GV * const gv = cGVOPx_gv(curop);
3638 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3641 else if (curop->op_type == OP_RV2CV)
3643 else if (curop->op_type == OP_RV2SV ||
3644 curop->op_type == OP_RV2AV ||
3645 curop->op_type == OP_RV2HV ||
3646 curop->op_type == OP_RV2GV) {
3647 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3650 else if (curop->op_type == OP_PADSV ||
3651 curop->op_type == OP_PADAV ||
3652 curop->op_type == OP_PADHV ||
3653 curop->op_type == OP_PADANY)
3657 else if (curop->op_type == OP_PUSHRE)
3658 NOOP; /* Okay here, dangerous in newASSIGNOP */
3668 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
3670 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3671 prepend_elem(o->op_type, scalar(repl), o);
3674 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3675 pm->op_pmflags |= PMf_MAYBE_CONST;
3677 NewOp(1101, rcop, 1, LOGOP);
3678 rcop->op_type = OP_SUBSTCONT;
3679 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3680 rcop->op_first = scalar(repl);
3681 rcop->op_flags |= OPf_KIDS;
3682 rcop->op_private = 1;
3685 /* establish postfix order */
3686 rcop->op_next = LINKLIST(repl);
3687 repl->op_next = (OP*)rcop;
3689 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
3690 assert(!(pm->op_pmflags & PMf_ONCE));
3691 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
3700 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3705 PERL_ARGS_ASSERT_NEWSVOP;
3707 NewOp(1101, svop, 1, SVOP);
3708 svop->op_type = (OPCODE)type;
3709 svop->op_ppaddr = PL_ppaddr[type];
3711 svop->op_next = (OP*)svop;
3712 svop->op_flags = (U8)flags;
3713 if (PL_opargs[type] & OA_RETSCALAR)
3715 if (PL_opargs[type] & OA_TARGET)
3716 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3717 return CHECKOP(type, svop);
3722 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3727 PERL_ARGS_ASSERT_NEWPADOP;
3729 NewOp(1101, padop, 1, PADOP);
3730 padop->op_type = (OPCODE)type;
3731 padop->op_ppaddr = PL_ppaddr[type];
3732 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3733 SvREFCNT_dec(PAD_SVl(padop->op_padix));
3734 PAD_SETSV(padop->op_padix, sv);
3737 padop->op_next = (OP*)padop;
3738 padop->op_flags = (U8)flags;
3739 if (PL_opargs[type] & OA_RETSCALAR)
3741 if (PL_opargs[type] & OA_TARGET)
3742 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3743 return CHECKOP(type, padop);
3748 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3752 PERL_ARGS_ASSERT_NEWGVOP;
3756 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3758 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3763 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3767 NewOp(1101, pvop, 1, PVOP);
3768 pvop->op_type = (OPCODE)type;
3769 pvop->op_ppaddr = PL_ppaddr[type];
3771 pvop->op_next = (OP*)pvop;
3772 pvop->op_flags = (U8)flags;
3773 if (PL_opargs[type] & OA_RETSCALAR)
3775 if (PL_opargs[type] & OA_TARGET)
3776 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3777 return CHECKOP(type, pvop);
3785 Perl_package(pTHX_ OP *o)
3788 SV *const sv = cSVOPo->op_sv;
3793 PERL_ARGS_ASSERT_PACKAGE;
3795 save_hptr(&PL_curstash);
3796 save_item(PL_curstname);
3798 PL_curstash = gv_stashsv(sv, GV_ADD);
3800 sv_setsv(PL_curstname, sv);
3802 PL_hints |= HINT_BLOCK_SCOPE;
3803 PL_parser->copline = NOLINE;
3804 PL_parser->expect = XSTATE;
3809 if (!PL_madskills) {
3814 pegop = newOP(OP_NULL,0);
3815 op_getmad(o,pegop,'P');
3821 Perl_package_version( pTHX_ OP *v )
3824 U32 savehints = PL_hints;
3825 PERL_ARGS_ASSERT_PACKAGE_VERSION;
3826 PL_hints &= ~HINT_STRICT_VARS;
3827 sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
3828 PL_hints = savehints;
3837 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3844 OP *pegop = newOP(OP_NULL,0);
3847 PERL_ARGS_ASSERT_UTILIZE;
3849 if (idop->op_type != OP_CONST)
3850 Perl_croak(aTHX_ "Module name must be constant");
3853 op_getmad(idop,pegop,'U');
3858 SV * const vesv = ((SVOP*)version)->op_sv;
3861 op_getmad(version,pegop,'V');
3862 if (!arg && !SvNIOKp(vesv)) {
3869 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3870 Perl_croak(aTHX_ "Version number must be a constant number");
3872 /* Make copy of idop so we don't free it twice */
3873 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3875 /* Fake up a method call to VERSION */
3876 meth = newSVpvs_share("VERSION");
3877 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3878 append_elem(OP_LIST,
3879 prepend_elem(OP_LIST, pack, list(version)),
3880 newSVOP(OP_METHOD_NAMED, 0, meth)));
3884 /* Fake up an import/unimport */
3885 if (arg && arg->op_type == OP_STUB) {
3887 op_getmad(arg,pegop,'S');
3888 imop = arg; /* no import on explicit () */
3890 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3891 imop = NULL; /* use 5.0; */
3893 idop->op_private |= OPpCONST_NOVER;
3899 op_getmad(arg,pegop,'A');
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 import/unimport */
3906 ? newSVpvs_share("import") : newSVpvs_share("unimport");
3907 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3908 append_elem(OP_LIST,
3909 prepend_elem(OP_LIST, pack, list(arg)),
3910 newSVOP(OP_METHOD_NAMED, 0, meth)));
3913 /* Fake up the BEGIN {}, which does its thing immediately. */
3915 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
3918 append_elem(OP_LINESEQ,
3919 append_elem(OP_LINESEQ,
3920 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
3921 newSTATEOP(0, NULL, veop)),
3922 newSTATEOP(0, NULL, imop) ));
3924 /* The "did you use incorrect case?" warning used to be here.
3925 * The problem is that on case-insensitive filesystems one
3926 * might get false positives for "use" (and "require"):
3927 * "use Strict" or "require CARP" will work. This causes
3928 * portability problems for the script: in case-strict
3929 * filesystems the script will stop working.
3931 * The "incorrect case" warning checked whether "use Foo"
3932 * imported "Foo" to your namespace, but that is wrong, too:
3933 * there is no requirement nor promise in the language that
3934 * a Foo.pm should or would contain anything in package "Foo".
3936 * There is very little Configure-wise that can be done, either:
3937 * the case-sensitivity of the build filesystem of Perl does not
3938 * help in guessing the case-sensitivity of the runtime environment.
3941 PL_hints |= HINT_BLOCK_SCOPE;
3942 PL_parser->copline = NOLINE;
3943 PL_parser->expect = XSTATE;
3944 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3947 if (!PL_madskills) {
3948 /* FIXME - don't allocate pegop if !PL_madskills */
3957 =head1 Embedding Functions
3959 =for apidoc load_module
3961 Loads the module whose name is pointed to by the string part of name.
3962 Note that the actual module name, not its filename, should be given.
3963 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3964 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3965 (or 0 for no flags). ver, if specified, provides version semantics
3966 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3967 arguments can be used to specify arguments to the module's import()
3968 method, similar to C<use Foo::Bar VERSION LIST>. They must be
3969 terminated with a final NULL pointer. Note that this list can only
3970 be omitted when the PERL_LOADMOD_NOIMPORT flag has been used.
3971 Otherwise at least a single NULL pointer to designate the default
3972 import list is required.
3977 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3981 PERL_ARGS_ASSERT_LOAD_MODULE;
3983 va_start(args, ver);
3984 vload_module(flags, name, ver, &args);
3988 #ifdef PERL_IMPLICIT_CONTEXT
3990 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3994 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
3995 va_start(args, ver);
3996 vload_module(flags, name, ver, &args);
4002 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
4006 OP * const modname = newSVOP(OP_CONST, 0, name);
4008 PERL_ARGS_ASSERT_VLOAD_MODULE;
4010 modname->op_private |= OPpCONST_BARE;
4012 veop = newSVOP(OP_CONST, 0, ver);
4016 if (flags & PERL_LOADMOD_NOIMPORT) {
4017 imop = sawparens(newNULLLIST());
4019 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
4020 imop = va_arg(*args, OP*);
4025 sv = va_arg(*args, SV*);
4027 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
4028 sv = va_arg(*args, SV*);
4032 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
4033 * that it has a PL_parser to play with while doing that, and also
4034 * that it doesn't mess with any existing parser, by creating a tmp
4035 * new parser with lex_start(). This won't actually be used for much,
4036 * since pp_require() will create another parser for the real work. */
4039 SAVEVPTR(PL_curcop);
4040 lex_start(NULL, NULL, FALSE);
4041 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
4042 veop, modname, imop);
4047 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
4053 PERL_ARGS_ASSERT_DOFILE;
4055 if (!force_builtin) {
4056 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
4057 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
4058 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
4059 gv = gvp ? *gvp : NULL;
4063 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
4064 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
4065 append_elem(OP_LIST, term,
4066 scalar(newUNOP(OP_RV2CV, 0,
4067 newGVOP(OP_GV, 0, gv))))));
4070 doop = newUNOP(OP_DOFILE, 0, scalar(term));
4076 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
4078 return newBINOP(OP_LSLICE, flags,
4079 list(force_list(subscript)),
4080 list(force_list(listval)) );
4084 S_is_list_assignment(pTHX_ register const OP *o)
4092 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
4093 o = cUNOPo->op_first;
4095 flags = o->op_flags;
4097 if (type == OP_COND_EXPR) {
4098 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
4099 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
4104 yyerror("Assignment to both a list and a scalar");
4108 if (type == OP_LIST &&
4109 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
4110 o->op_private & OPpLVAL_INTRO)
4113 if (type == OP_LIST || flags & OPf_PARENS ||
4114 type == OP_RV2AV || type == OP_RV2HV ||
4115 type == OP_ASLICE || type == OP_HSLICE)
4118 if (type == OP_PADAV || type == OP_PADHV)
4121 if (type == OP_RV2SV)
4128 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
4134 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
4135 return newLOGOP(optype, 0,
4136 mod(scalar(left), optype),
4137 newUNOP(OP_SASSIGN, 0, scalar(right)));
4140 return newBINOP(optype, OPf_STACKED,
4141 mod(scalar(left), optype), scalar(right));
4145 if (is_list_assignment(left)) {
4146 static const char no_list_state[] = "Initialization of state variables"
4147 " in list context currently forbidden";
4149 bool maybe_common_vars = TRUE;
4152 /* Grandfathering $[ assignment here. Bletch.*/
4153 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
4154 PL_eval_start = (left->op_type == OP_CONST) ? right : NULL;
4155 left = mod(left, OP_AASSIGN);
4158 else if (left->op_type == OP_CONST) {
4160 /* Result of assignment is always 1 (or we'd be dead already) */
4161 return newSVOP(OP_CONST, 0, newSViv(1));
4163 curop = list(force_list(left));
4164 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
4165 o->op_private = (U8)(0 | (flags >> 8));
4167 if ((left->op_type == OP_LIST
4168 || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
4170 OP* lop = ((LISTOP*)left)->op_first;
4171 maybe_common_vars = FALSE;
4173 if (lop->op_type == OP_PADSV ||
4174 lop->op_type == OP_PADAV ||
4175 lop->op_type == OP_PADHV ||
4176 lop->op_type == OP_PADANY) {
4177 if (!(lop->op_private & OPpLVAL_INTRO))
4178 maybe_common_vars = TRUE;
4180 if (lop->op_private & OPpPAD_STATE) {
4181 if (left->op_private & OPpLVAL_INTRO) {
4182 /* Each variable in state($a, $b, $c) = ... */
4185 /* Each state variable in
4186 (state $a, my $b, our $c, $d, undef) = ... */
4188 yyerror(no_list_state);
4190 /* Each my variable in
4191 (state $a, my $b, our $c, $d, undef) = ... */
4193 } else if (lop->op_type == OP_UNDEF ||
4194 lop->op_type == OP_PUSHMARK) {
4195 /* undef may be interesting in
4196 (state $a, undef, state $c) */
4198 /* Other ops in the list. */
4199 maybe_common_vars = TRUE;
4201 lop = lop->op_sibling;
4204 else if ((left->op_private & OPpLVAL_INTRO)
4205 && ( left->op_type == OP_PADSV
4206 || left->op_type == OP_PADAV
4207 || left->op_type == OP_PADHV
4208 || left->op_type == OP_PADANY))
4210 maybe_common_vars = FALSE;
4211 if (left->op_private & OPpPAD_STATE) {
4212 /* All single variable list context state assignments, hence
4222 yyerror(no_list_state);
4226 /* PL_generation sorcery:
4227 * an assignment like ($a,$b) = ($c,$d) is easier than
4228 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
4229 * To detect whether there are common vars, the global var
4230 * PL_generation is incremented for each assign op we compile.
4231 * Then, while compiling the assign op, we run through all the
4232 * variables on both sides of the assignment, setting a spare slot
4233 * in each of them to PL_generation. If any of them already have
4234 * that value, we know we've got commonality. We could use a
4235 * single bit marker, but then we'd have to make 2 passes, first
4236 * to clear the flag, then to test and set it. To find somewhere
4237 * to store these values, evil chicanery is done with SvUVX().
4240 if (maybe_common_vars) {
4243 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4244 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
4245 if (curop->op_type == OP_GV) {
4246 GV *gv = cGVOPx_gv(curop);
4248 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4250 GvASSIGN_GENERATION_set(gv, PL_generation);
4252 else if (curop->op_type == OP_PADSV ||
4253 curop->op_type == OP_PADAV ||
4254 curop->op_type == OP_PADHV ||
4255 curop->op_type == OP_PADANY)
4257 if (PAD_COMPNAME_GEN(curop->op_targ)
4258 == (STRLEN)PL_generation)
4260 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
4263 else if (curop->op_type == OP_RV2CV)
4265 else if (curop->op_type == OP_RV2SV ||
4266 curop->op_type == OP_RV2AV ||
4267 curop->op_type == OP_RV2HV ||
4268 curop->op_type == OP_RV2GV) {
4269 if (lastop->op_type != OP_GV) /* funny deref? */
4272 else if (curop->op_type == OP_PUSHRE) {
4274 if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
4275 GV *const gv = MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff));
4277 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4279 GvASSIGN_GENERATION_set(gv, PL_generation);
4283 = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
4286 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4288 GvASSIGN_GENERATION_set(gv, PL_generation);
4298 o->op_private |= OPpASSIGN_COMMON;
4301 if (right && right->op_type == OP_SPLIT && !PL_madskills) {
4302 OP* tmpop = ((LISTOP*)right)->op_first;
4303 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
4304 PMOP * const pm = (PMOP*)tmpop;
4305 if (left->op_type == OP_RV2AV &&
4306 !(left->op_private & OPpLVAL_INTRO) &&
4307 !(o->op_private & OPpASSIGN_COMMON) )
4309 tmpop = ((UNOP*)left)->op_first;
4310 if (tmpop->op_type == OP_GV
4312 && !pm->op_pmreplrootu.op_pmtargetoff
4314 && !pm->op_pmreplrootu.op_pmtargetgv
4318 pm->op_pmreplrootu.op_pmtargetoff
4319 = cPADOPx(tmpop)->op_padix;
4320 cPADOPx(tmpop)->op_padix = 0; /* steal it */
4322 pm->op_pmreplrootu.op_pmtargetgv
4323 = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
4324 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
4326 pm->op_pmflags |= PMf_ONCE;
4327 tmpop = cUNOPo->op_first; /* to list (nulled) */
4328 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
4329 tmpop->op_sibling = NULL; /* don't free split */
4330 right->op_next = tmpop->op_next; /* fix starting loc */
4331 op_free(o); /* blow off assign */
4332 right->op_flags &= ~OPf_WANT;
4333 /* "I don't know and I don't care." */
4338 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
4339 ((LISTOP*)right)->op_last->op_type == OP_CONST)
4341 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
4342 if (SvIOK(sv) && SvIVX(sv) == 0)
4343 sv_setiv(sv, PL_modcount+1);
4351 right = newOP(OP_UNDEF, 0);
4352 if (right->op_type == OP_READLINE) {
4353 right->op_flags |= OPf_STACKED;
4354 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
4357 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
4358 o = newBINOP(OP_SASSIGN, flags,
4359 scalar(right), mod(scalar(left), OP_SASSIGN) );
4363 if (!PL_madskills) { /* assignment to $[ is ignored when making a mad dump */
4364 deprecate("assignment to $[");
4366 o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
4367 o->op_private |= OPpCONST_ARYBASE;
4375 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
4378 const U32 seq = intro_my();
4381 NewOp(1101, cop, 1, COP);
4382 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
4383 cop->op_type = OP_DBSTATE;
4384 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
4387 cop->op_type = OP_NEXTSTATE;
4388 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
4390 cop->op_flags = (U8)flags;
4391 CopHINTS_set(cop, PL_hints);
4393 cop->op_private |= NATIVE_HINTS;
4395 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
4396 cop->op_next = (OP*)cop;
4399 /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
4400 CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
4402 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
4403 cop->cop_hints_hash = PL_curcop->cop_hints_hash;
4404 if (cop->cop_hints_hash) {
4406 cop->cop_hints_hash->refcounted_he_refcnt++;
4407 HINTS_REFCNT_UNLOCK;
4411 = Perl_store_cop_label(aTHX_ cop->cop_hints_hash, label);
4413 PL_hints |= HINT_BLOCK_SCOPE;
4414 /* It seems that we need to defer freeing this pointer, as other parts
4415 of the grammar end up wanting to copy it after this op has been
4420 if (PL_parser && PL_parser->copline == NOLINE)
4421 CopLINE_set(cop, CopLINE(PL_curcop));
4423 CopLINE_set(cop, PL_parser->copline);
4425 PL_parser->copline = NOLINE;
4428 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
4430 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
4432 CopSTASH_set(cop, PL_curstash);
4434 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash) {
4435 /* this line can have a breakpoint - store the cop in IV */
4436 AV *av = CopFILEAVx(PL_curcop);
4438 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
4439 if (svp && *svp != &PL_sv_undef ) {
4440 (void)SvIOK_on(*svp);
4441 SvIV_set(*svp, PTR2IV(cop));
4446 if (flags & OPf_SPECIAL)
4448 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
4453 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
4457 PERL_ARGS_ASSERT_NEWLOGOP;
4459 return new_logop(type, flags, &first, &other);
4463 S_search_const(pTHX_ OP *o)
4465 PERL_ARGS_ASSERT_SEARCH_CONST;
4467 switch (o->op_type) {
4471 if (o->op_flags & OPf_KIDS)
4472 return search_const(cUNOPo->op_first);
4479 if (!(o->op_flags & OPf_KIDS))
4481 kid = cLISTOPo->op_first;
4483 switch (kid->op_type) {
4487 kid = kid->op_sibling;
4490 if (kid != cLISTOPo->op_last)
4496 kid = cLISTOPo->op_last;
4498 return search_const(kid);
4506 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
4514 int prepend_not = 0;
4516 PERL_ARGS_ASSERT_NEW_LOGOP;
4521 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
4522 return newBINOP(type, flags, scalar(first), scalar(other));
4524 scalarboolean(first);
4525 /* optimize AND and OR ops that have NOTs as children */
4526 if (first->op_type == OP_NOT
4527 && (first->op_flags & OPf_KIDS)
4528 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
4529 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
4531 if (type == OP_AND || type == OP_OR) {
4537 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
4539 prepend_not = 1; /* prepend a NOT op later */
4543 /* search for a constant op that could let us fold the test */
4544 if ((cstop = search_const(first))) {
4545 if (cstop->op_private & OPpCONST_STRICT)
4546 no_bareword_allowed(cstop);
4547 else if ((cstop->op_private & OPpCONST_BARE))
4548 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
4549 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
4550 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
4551 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
4553 if (other->op_type == OP_CONST)
4554 other->op_private |= OPpCONST_SHORTCIRCUIT;
4556 OP *newop = newUNOP(OP_NULL, 0, other);
4557 op_getmad(first, newop, '1');
4558 newop->op_targ = type; /* set "was" field */
4562 if (other->op_type == OP_LEAVE)
4563 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
4567 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
4568 const OP *o2 = other;
4569 if ( ! (o2->op_type == OP_LIST
4570 && (( o2 = cUNOPx(o2)->op_first))
4571 && o2->op_type == OP_PUSHMARK
4572 && (( o2 = o2->op_sibling)) )
4575 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
4576 || o2->op_type == OP_PADHV)
4577 && o2->op_private & OPpLVAL_INTRO
4578 && !(o2->op_private & OPpPAD_STATE))
4580 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
4581 "Deprecated use of my() in false conditional");
4585 if (first->op_type == OP_CONST)
4586 first->op_private |= OPpCONST_SHORTCIRCUIT;
4588 first = newUNOP(OP_NULL, 0, first);
4589 op_getmad(other, first, '2');
4590 first->op_targ = type; /* set "was" field */
4597 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
4598 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
4600 const OP * const k1 = ((UNOP*)first)->op_first;
4601 const OP * const k2 = k1->op_sibling;
4603 switch (first->op_type)
4606 if (k2 && k2->op_type == OP_READLINE
4607 && (k2->op_flags & OPf_STACKED)
4608 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4610 warnop = k2->op_type;
4615 if (k1->op_type == OP_READDIR
4616 || k1->op_type == OP_GLOB
4617 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4618 || k1->op_type == OP_EACH)
4620 warnop = ((k1->op_type == OP_NULL)
4621 ? (OPCODE)k1->op_targ : k1->op_type);
4626 const line_t oldline = CopLINE(PL_curcop);
4627 CopLINE_set(PL_curcop, PL_parser->copline);
4628 Perl_warner(aTHX_ packWARN(WARN_MISC),
4629 "Value of %s%s can be \"0\"; test with defined()",
4631 ((warnop == OP_READLINE || warnop == OP_GLOB)
4632 ? " construct" : "() operator"));
4633 CopLINE_set(PL_curcop, oldline);
4640 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
4641 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
4643 NewOp(1101, logop, 1, LOGOP);
4645 logop->op_type = (OPCODE)type;
4646 logop->op_ppaddr = PL_ppaddr[type];
4647 logop->op_first = first;
4648 logop->op_flags = (U8)(flags | OPf_KIDS);
4649 logop->op_other = LINKLIST(other);
4650 logop->op_private = (U8)(1 | (flags >> 8));
4652 /* establish postfix order */
4653 logop->op_next = LINKLIST(first);
4654 first->op_next = (OP*)logop;
4655 first->op_sibling = other;
4657 CHECKOP(type,logop);
4659 o = newUNOP(prepend_not ? OP_NOT : OP_NULL, 0, (OP*)logop);
4666 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
4674 PERL_ARGS_ASSERT_NEWCONDOP;
4677 return newLOGOP(OP_AND, 0, first, trueop);
4679 return newLOGOP(OP_OR, 0, first, falseop);
4681 scalarboolean(first);
4682 if ((cstop = search_const(first))) {
4683 /* Left or right arm of the conditional? */
4684 const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
4685 OP *live = left ? trueop : falseop;
4686 OP *const dead = left ? falseop : trueop;
4687 if (cstop->op_private & OPpCONST_BARE &&
4688 cstop->op_private & OPpCONST_STRICT) {
4689 no_bareword_allowed(cstop);
4692 /* This is all dead code when PERL_MAD is not defined. */
4693 live = newUNOP(OP_NULL, 0, live);
4694 op_getmad(first, live, 'C');
4695 op_getmad(dead, live, left ? 'e' : 't');
4700 if (live->op_type == OP_LEAVE)
4701 live = newUNOP(OP_NULL, OPf_SPECIAL, live);
4704 NewOp(1101, logop, 1, LOGOP);
4705 logop->op_type = OP_COND_EXPR;
4706 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4707 logop->op_first = first;
4708 logop->op_flags = (U8)(flags | OPf_KIDS);
4709 logop->op_private = (U8)(1 | (flags >> 8));
4710 logop->op_other = LINKLIST(trueop);
4711 logop->op_next = LINKLIST(falseop);
4713 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
4716 /* establish postfix order */
4717 start = LINKLIST(first);
4718 first->op_next = (OP*)logop;
4720 first->op_sibling = trueop;
4721 trueop->op_sibling = falseop;
4722 o = newUNOP(OP_NULL, 0, (OP*)logop);
4724 trueop->op_next = falseop->op_next = o;
4731 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4740 PERL_ARGS_ASSERT_NEWRANGE;
4742 NewOp(1101, range, 1, LOGOP);
4744 range->op_type = OP_RANGE;
4745 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4746 range->op_first = left;
4747 range->op_flags = OPf_KIDS;
4748 leftstart = LINKLIST(left);
4749 range->op_other = LINKLIST(right);
4750 range->op_private = (U8)(1 | (flags >> 8));
4752 left->op_sibling = right;
4754 range->op_next = (OP*)range;
4755 flip = newUNOP(OP_FLIP, flags, (OP*)range);
4756 flop = newUNOP(OP_FLOP, 0, flip);
4757 o = newUNOP(OP_NULL, 0, flop);
4759 range->op_next = leftstart;
4761 left->op_next = flip;
4762 right->op_next = flop;
4764 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4765 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4766 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4767 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4769 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4770 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4773 if (!flip->op_private || !flop->op_private)
4774 linklist(o); /* blow off optimizer unless constant */
4780 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4785 const bool once = block && block->op_flags & OPf_SPECIAL &&
4786 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4788 PERL_UNUSED_ARG(debuggable);
4791 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4792 return block; /* do {} while 0 does once */
4793 if (expr->op_type == OP_READLINE
4794 || expr->op_type == OP_READDIR
4795 || expr->op_type == OP_GLOB
4796 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4797 expr = newUNOP(OP_DEFINED, 0,
4798 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4799 } else if (expr->op_flags & OPf_KIDS) {
4800 const OP * const k1 = ((UNOP*)expr)->op_first;
4801 const OP * const k2 = k1 ? k1->op_sibling : NULL;
4802 switch (expr->op_type) {
4804 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
4805 && (k2->op_flags & OPf_STACKED)
4806 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4807 expr = newUNOP(OP_DEFINED, 0, expr);
4811 if (k1 && (k1->op_type == OP_READDIR
4812 || k1->op_type == OP_GLOB
4813 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4814 || k1->op_type == OP_EACH))
4815 expr = newUNOP(OP_DEFINED, 0, expr);
4821 /* if block is null, the next append_elem() would put UNSTACK, a scalar
4822 * op, in listop. This is wrong. [perl #27024] */
4824 block = newOP(OP_NULL, 0);
4825 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4826 o = new_logop(OP_AND, 0, &expr, &listop);
4829 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4831 if (once && o != listop)
4832 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4835 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
4837 o->op_flags |= flags;
4839 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4844 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
4845 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
4854 PERL_UNUSED_ARG(debuggable);
4857 if (expr->op_type == OP_READLINE
4858 || expr->op_type == OP_READDIR
4859 || expr->op_type == OP_GLOB
4860 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4861 expr = newUNOP(OP_DEFINED, 0,
4862 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4863 } else if (expr->op_flags & OPf_KIDS) {
4864 const OP * const k1 = ((UNOP*)expr)->op_first;
4865 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
4866 switch (expr->op_type) {
4868 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
4869 && (k2->op_flags & OPf_STACKED)
4870 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4871 expr = newUNOP(OP_DEFINED, 0, expr);
4875 if (k1 && (k1->op_type == OP_READDIR
4876 || k1->op_type == OP_GLOB
4877 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4878 || k1->op_type == OP_EACH))
4879 expr = newUNOP(OP_DEFINED, 0, expr);
4886 block = newOP(OP_NULL, 0);
4887 else if (cont || has_my) {
4888 block = scope(block);
4892 next = LINKLIST(cont);
4895 OP * const unstack = newOP(OP_UNSTACK, 0);
4898 cont = append_elem(OP_LINESEQ, cont, unstack);
4902 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4904 redo = LINKLIST(listop);
4907 PL_parser->copline = (line_t)whileline;
4909 o = new_logop(OP_AND, 0, &expr, &listop);
4910 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4911 op_free(expr); /* oops, it's a while (0) */
4913 return NULL; /* listop already freed by new_logop */
4916 ((LISTOP*)listop)->op_last->op_next =
4917 (o == listop ? redo : LINKLIST(o));
4923 NewOp(1101,loop,1,LOOP);
4924 loop->op_type = OP_ENTERLOOP;
4925 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4926 loop->op_private = 0;
4927 loop->op_next = (OP*)loop;
4930 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4932 loop->op_redoop = redo;
4933 loop->op_lastop = o;
4934 o->op_private |= loopflags;
4937 loop->op_nextop = next;
4939 loop->op_nextop = o;
4941 o->op_flags |= flags;
4942 o->op_private |= (flags >> 8);
4947 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
4952 PADOFFSET padoff = 0;
4957 PERL_ARGS_ASSERT_NEWFOROP;
4960 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4961 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
4962 sv->op_type = OP_RV2GV;
4963 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4965 /* The op_type check is needed to prevent a possible segfault
4966 * if the loop variable is undeclared and 'strict vars' is in
4967 * effect. This is illegal but is nonetheless parsed, so we
4968 * may reach this point with an OP_CONST where we're expecting
4971 if (cUNOPx(sv)->op_first->op_type == OP_GV
4972 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
4973 iterpflags |= OPpITER_DEF;
4975 else if (sv->op_type == OP_PADSV) { /* private variable */
4976 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
4977 padoff = sv->op_targ;
4987 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4989 SV *const namesv = PAD_COMPNAME_SV(padoff);
4991 const char *const name = SvPV_const(namesv, len);
4993 if (len == 2 && name[0] == '$' && name[1] == '_')
4994 iterpflags |= OPpITER_DEF;
4998 const PADOFFSET offset = pad_findmy("$_");
4999 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
5000 sv = newGVOP(OP_GV, 0, PL_defgv);
5005 iterpflags |= OPpITER_DEF;
5007 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
5008 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
5009 iterflags |= OPf_STACKED;
5011 else if (expr->op_type == OP_NULL &&
5012 (expr->op_flags & OPf_KIDS) &&
5013 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
5015 /* Basically turn for($x..$y) into the same as for($x,$y), but we
5016 * set the STACKED flag to indicate that these values are to be
5017 * treated as min/max values by 'pp_iterinit'.
5019 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
5020 LOGOP* const range = (LOGOP*) flip->op_first;
5021 OP* const left = range->op_first;
5022 OP* const right = left->op_sibling;
5025 range->op_flags &= ~OPf_KIDS;
5026 range->op_first = NULL;
5028 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
5029 listop->op_first->op_next = range->op_next;
5030 left->op_next = range->op_other;
5031 right->op_next = (OP*)listop;
5032 listop->op_next = listop->op_first;
5035 op_getmad(expr,(OP*)listop,'O');
5039 expr = (OP*)(listop);
5041 iterflags |= OPf_STACKED;
5044 expr = mod(force_list(expr), OP_GREPSTART);
5047 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
5048 append_elem(OP_LIST, expr, scalar(sv))));
5049 assert(!loop->op_next);
5050 /* for my $x () sets OPpLVAL_INTRO;
5051 * for our $x () sets OPpOUR_INTRO */
5052 loop->op_private = (U8)iterpflags;
5053 #ifdef PL_OP_SLAB_ALLOC
5056 NewOp(1234,tmp,1,LOOP);
5057 Copy(loop,tmp,1,LISTOP);
5058 S_op_destroy(aTHX_ (OP*)loop);
5062 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
5064 loop->op_targ = padoff;
5065 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
5067 op_getmad(madsv, (OP*)loop, 'v');
5068 PL_parser->copline = forline;
5069 return newSTATEOP(0, label, wop);
5073 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
5078 PERL_ARGS_ASSERT_NEWLOOPEX;
5080 if (type != OP_GOTO || label->op_type == OP_CONST) {
5081 /* "last()" means "last" */
5082 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
5083 o = newOP(type, OPf_SPECIAL);
5085 o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
5086 ? SvPV_nolen_const(((SVOP*)label)->op_sv)
5090 op_getmad(label,o,'L');
5096 /* Check whether it's going to be a goto &function */
5097 if (label->op_type == OP_ENTERSUB
5098 && !(label->op_flags & OPf_STACKED))
5099 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
5100 o = newUNOP(type, OPf_STACKED, label);
5102 PL_hints |= HINT_BLOCK_SCOPE;
5106 /* if the condition is a literal array or hash
5107 (or @{ ... } etc), make a reference to it.
5110 S_ref_array_or_hash(pTHX_ OP *cond)
5113 && (cond->op_type == OP_RV2AV
5114 || cond->op_type == OP_PADAV
5115 || cond->op_type == OP_RV2HV
5116 || cond->op_type == OP_PADHV))
5118 return newUNOP(OP_REFGEN,
5119 0, mod(cond, OP_REFGEN));
5125 /* These construct the optree fragments representing given()
5128 entergiven and enterwhen are LOGOPs; the op_other pointer
5129 points up to the associated leave op. We need this so we
5130 can put it in the context and make break/continue work.
5131 (Also, of course, pp_enterwhen will jump straight to
5132 op_other if the match fails.)
5136 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
5137 I32 enter_opcode, I32 leave_opcode,
5138 PADOFFSET entertarg)
5144 PERL_ARGS_ASSERT_NEWGIVWHENOP;
5146 NewOp(1101, enterop, 1, LOGOP);
5147 enterop->op_type = (Optype)enter_opcode;
5148 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
5149 enterop->op_flags = (U8) OPf_KIDS;
5150 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
5151 enterop->op_private = 0;
5153 o = newUNOP(leave_opcode, 0, (OP *) enterop);
5156 enterop->op_first = scalar(cond);
5157 cond->op_sibling = block;
5159 o->op_next = LINKLIST(cond);
5160 cond->op_next = (OP *) enterop;
5163 /* This is a default {} block */
5164 enterop->op_first = block;
5165 enterop->op_flags |= OPf_SPECIAL;
5167 o->op_next = (OP *) enterop;
5170 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
5171 entergiven and enterwhen both
5174 enterop->op_next = LINKLIST(block);
5175 block->op_next = enterop->op_other = o;
5180 /* Does this look like a boolean operation? For these purposes
5181 a boolean operation is:
5182 - a subroutine call [*]
5183 - a logical connective
5184 - a comparison operator
5185 - a filetest operator, with the exception of -s -M -A -C
5186 - defined(), exists() or eof()
5187 - /$re/ or $foo =~ /$re/
5189 [*] possibly surprising
5192 S_looks_like_bool(pTHX_ const OP *o)
5196 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
5198 switch(o->op_type) {
5201 return looks_like_bool(cLOGOPo->op_first);
5205 looks_like_bool(cLOGOPo->op_first)
5206 && looks_like_bool(cLOGOPo->op_first->op_sibling));
5210 o->op_flags & OPf_KIDS
5211 && looks_like_bool(cUNOPo->op_first));
5214 return looks_like_bool(cUNOPo->op_first);
5219 case OP_NOT: case OP_XOR:
5221 case OP_EQ: case OP_NE: case OP_LT:
5222 case OP_GT: case OP_LE: case OP_GE:
5224 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
5225 case OP_I_GT: case OP_I_LE: case OP_I_GE:
5227 case OP_SEQ: case OP_SNE: case OP_SLT:
5228 case OP_SGT: case OP_SLE: case OP_SGE:
5232 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
5233 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
5234 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
5235 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
5236 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
5237 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
5238 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
5239 case OP_FTTEXT: case OP_FTBINARY:
5241 case OP_DEFINED: case OP_EXISTS:
5242 case OP_MATCH: case OP_EOF:
5249 /* Detect comparisons that have been optimized away */
5250 if (cSVOPo->op_sv == &PL_sv_yes
5251 || cSVOPo->op_sv == &PL_sv_no)
5264 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
5267 PERL_ARGS_ASSERT_NEWGIVENOP;
5268 return newGIVWHENOP(
5269 ref_array_or_hash(cond),
5271 OP_ENTERGIVEN, OP_LEAVEGIVEN,
5275 /* If cond is null, this is a default {} block */
5277 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
5279 const bool cond_llb = (!cond || looks_like_bool(cond));
5282 PERL_ARGS_ASSERT_NEWWHENOP;
5287 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
5289 scalar(ref_array_or_hash(cond)));
5292 return newGIVWHENOP(
5294 append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
5295 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
5299 =for apidoc cv_undef
5301 Clear out all the active components of a CV. This can happen either
5302 by an explicit C<undef &foo>, or by the reference count going to zero.
5303 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
5304 children can still follow the full lexical scope chain.
5310 Perl_cv_undef(pTHX_ CV *cv)
5314 PERL_ARGS_ASSERT_CV_UNDEF;
5316 DEBUG_X(PerlIO_printf(Perl_debug_log,
5317 "CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n",
5318 PTR2UV(cv), PTR2UV(PL_comppad))
5322 if (CvFILE(cv) && !CvISXSUB(cv)) {
5323 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
5324 Safefree(CvFILE(cv));
5329 if (!CvISXSUB(cv) && CvROOT(cv)) {
5330 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
5331 Perl_croak(aTHX_ "Can't undef active subroutine");
5334 PAD_SAVE_SETNULLPAD();
5336 op_free(CvROOT(cv));
5341 SvPOK_off(MUTABLE_SV(cv)); /* forget prototype */
5346 /* remove CvOUTSIDE unless this is an undef rather than a free */
5347 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
5348 if (!CvWEAKOUTSIDE(cv))
5349 SvREFCNT_dec(CvOUTSIDE(cv));
5350 CvOUTSIDE(cv) = NULL;
5353 SvREFCNT_dec(MUTABLE_SV(CvXSUBANY(cv).any_ptr));
5356 if (CvISXSUB(cv) && CvXSUB(cv)) {
5359 /* delete all flags except WEAKOUTSIDE */
5360 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
5364 Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
5367 PERL_ARGS_ASSERT_CV_CKPROTO_LEN;
5369 /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
5370 relying on SvCUR, and doubling up the buffer to hold CvFILE(). */
5371 if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
5372 || (p && (len != SvCUR(cv) /* Not the same length. */
5373 || memNE(p, SvPVX_const(cv), len))))
5374 && ckWARN_d(WARN_PROTOTYPE)) {
5375 SV* const msg = sv_newmortal();
5379 gv_efullname3(name = sv_newmortal(), gv, NULL);
5380 sv_setpvs(msg, "Prototype mismatch:");
5382 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
5384 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv));
5386 sv_catpvs(msg, ": none");
5387 sv_catpvs(msg, " vs ");
5389 Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
5391 sv_catpvs(msg, "none");
5392 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
5396 static void const_sv_xsub(pTHX_ CV* cv);
5400 =head1 Optree Manipulation Functions
5402 =for apidoc cv_const_sv
5404 If C<cv> is a constant sub eligible for inlining. returns the constant
5405 value returned by the sub. Otherwise, returns NULL.
5407 Constant subs can be created with C<newCONSTSUB> or as described in
5408 L<perlsub/"Constant Functions">.
5413 Perl_cv_const_sv(pTHX_ const CV *const cv)
5415 PERL_UNUSED_CONTEXT;
5418 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
5420 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
5423 /* op_const_sv: examine an optree to determine whether it's in-lineable.
5424 * Can be called in 3 ways:
5427 * look for a single OP_CONST with attached value: return the value
5429 * cv && CvCLONE(cv) && !CvCONST(cv)
5431 * examine the clone prototype, and if contains only a single
5432 * OP_CONST referencing a pad const, or a single PADSV referencing
5433 * an outer lexical, return a non-zero value to indicate the CV is
5434 * a candidate for "constizing" at clone time
5438 * We have just cloned an anon prototype that was marked as a const
5439 * candidiate. Try to grab the current value, and in the case of
5440 * PADSV, ignore it if it has multiple references. Return the value.
5444 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
5455 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
5456 o = cLISTOPo->op_first->op_sibling;
5458 for (; o; o = o->op_next) {
5459 const OPCODE type = o->op_type;
5461 if (sv && o->op_next == o)
5463 if (o->op_next != o) {
5464 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
5466 if (type == OP_DBSTATE)
5469 if (type == OP_LEAVESUB || type == OP_RETURN)
5473 if (type == OP_CONST && cSVOPo->op_sv)
5475 else if (cv && type == OP_CONST) {
5476 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5480 else if (cv && type == OP_PADSV) {
5481 if (CvCONST(cv)) { /* newly cloned anon */
5482 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5483 /* the candidate should have 1 ref from this pad and 1 ref
5484 * from the parent */
5485 if (!sv || SvREFCNT(sv) != 2)
5492 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
5493 sv = &PL_sv_undef; /* an arbitrary non-null value */
5508 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5511 /* This would be the return value, but the return cannot be reached. */
5512 OP* pegop = newOP(OP_NULL, 0);
5515 PERL_UNUSED_ARG(floor);
5525 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
5527 NORETURN_FUNCTION_END;
5532 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
5534 return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
5538 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5544 register CV *cv = NULL;
5546 /* If the subroutine has no body, no attributes, and no builtin attributes
5547 then it's just a sub declaration, and we may be able to get away with
5548 storing with a placeholder scalar in the symbol table, rather than a
5549 full GV and CV. If anything is present then it will take a full CV to
5551 const I32 gv_fetch_flags
5552 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5554 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
5555 const char * const name = o ? SvPV_nolen_const(cSVOPo->op_sv) : NULL;
5559 assert(proto->op_type == OP_CONST);
5560 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
5566 gv = gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV);
5568 } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) {
5569 SV * const sv = sv_newmortal();
5570 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
5571 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
5572 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
5573 gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV);
5575 } else if (PL_curstash) {
5576 gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV);
5579 gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV);
5583 if (!PL_madskills) {
5592 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
5593 maximum a prototype before. */
5594 if (SvTYPE(gv) > SVt_NULL) {
5595 if (!SvPOK((const SV *)gv)
5596 && !(SvIOK((const SV *)gv) && SvIVX((const SV *)gv) == -1))
5598 Perl_ck_warner_d(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
5600 cv_ckproto_len((const CV *)gv, NULL, ps, ps_len);
5603 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
5605 sv_setiv(MUTABLE_SV(gv), -1);
5607 SvREFCNT_dec(PL_compcv);
5608 cv = PL_compcv = NULL;
5612 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
5614 if (!block || !ps || *ps || attrs
5615 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5617 || block->op_type == OP_NULL
5622 const_sv = op_const_sv(block, NULL);
5625 const bool exists = CvROOT(cv) || CvXSUB(cv);
5627 /* if the subroutine doesn't exist and wasn't pre-declared
5628 * with a prototype, assume it will be AUTOLOADed,
5629 * skipping the prototype check
5631 if (exists || SvPOK(cv))
5632 cv_ckproto_len(cv, gv, ps, ps_len);
5633 /* already defined (or promised)? */
5634 if (exists || GvASSUMECV(gv)) {
5637 || block->op_type == OP_NULL
5640 if (CvFLAGS(PL_compcv)) {
5641 /* might have had built-in attrs applied */
5642 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5644 /* just a "sub foo;" when &foo is already defined */
5645 SAVEFREESV(PL_compcv);
5650 && block->op_type != OP_NULL
5653 if (ckWARN(WARN_REDEFINE)
5655 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
5657 const line_t oldline = CopLINE(PL_curcop);
5658 if (PL_parser && PL_parser->copline != NOLINE)
5659 CopLINE_set(PL_curcop, PL_parser->copline);
5660 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5661 CvCONST(cv) ? "Constant subroutine %s redefined"
5662 : "Subroutine %s redefined", name);
5663 CopLINE_set(PL_curcop, oldline);
5666 if (!PL_minus_c) /* keep old one around for madskills */
5669 /* (PL_madskills unset in used file.) */
5677 SvREFCNT_inc_simple_void_NN(const_sv);
5679 assert(!CvROOT(cv) && !CvCONST(cv));
5680 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
5681 CvXSUBANY(cv).any_ptr = const_sv;
5682 CvXSUB(cv) = const_sv_xsub;
5688 cv = newCONSTSUB(NULL, name, const_sv);
5690 mro_method_changed_in( /* sub Foo::Bar () { 123 } */
5691 (CvGV(cv) && GvSTASH(CvGV(cv)))
5700 SvREFCNT_dec(PL_compcv);
5704 if (cv) { /* must reuse cv if autoloaded */
5705 /* transfer PL_compcv to cv */
5708 && block->op_type != OP_NULL
5712 CvFLAGS(cv) = CvFLAGS(PL_compcv);
5713 if (!CvWEAKOUTSIDE(cv))
5714 SvREFCNT_dec(CvOUTSIDE(cv));
5715 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
5716 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
5717 CvOUTSIDE(PL_compcv) = 0;
5718 CvPADLIST(cv) = CvPADLIST(PL_compcv);
5719 CvPADLIST(PL_compcv) = 0;
5720 /* inner references to PL_compcv must be fixed up ... */
5721 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
5722 if (PERLDB_INTER)/* Advice debugger on the new sub. */
5723 ++PL_sub_generation;
5726 /* Might have had built-in attributes applied -- propagate them. */
5727 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5729 /* ... before we throw it away */
5730 SvREFCNT_dec(PL_compcv);
5738 if (strEQ(name, "import")) {
5739 PL_formfeed = MUTABLE_SV(cv);
5740 Perl_warner(aTHX_ packWARN(WARN_VOID), "%lx\n", (long)cv);
5744 mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */
5749 CvFILE_set_from_cop(cv, PL_curcop);
5750 CvSTASH(cv) = PL_curstash;
5753 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
5754 HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash;
5755 apply_attrs(stash, MUTABLE_SV(cv), attrs, FALSE);
5759 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
5761 if (PL_parser && PL_parser->error_count) {
5765 const char *s = strrchr(name, ':');
5767 if (strEQ(s, "BEGIN")) {
5768 const char not_safe[] =
5769 "BEGIN not safe after errors--compilation aborted";
5770 if (PL_in_eval & EVAL_KEEPERR)
5771 Perl_croak(aTHX_ not_safe);
5773 /* force display of errors found but not reported */
5774 sv_catpv(ERRSV, not_safe);
5775 Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
5784 /* If we assign an optree to a PVCV, then we've defined a subroutine that
5785 the debugger could be able to set a breakpoint in, so signal to
5786 pp_entereval that it should not throw away any saved lines at scope
5789 PL_breakable_sub_gen++;
5791 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5792 mod(scalarseq(block), OP_LEAVESUBLV));
5793 block->op_attached = 1;
5796 /* This makes sub {}; work as expected. */
5797 if (block->op_type == OP_STUB) {
5798 OP* const newblock = newSTATEOP(0, NULL, 0);
5800 op_getmad(block,newblock,'B');
5807 block->op_attached = 1;
5808 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5810 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5811 OpREFCNT_set(CvROOT(cv), 1);
5812 CvSTART(cv) = LINKLIST(CvROOT(cv));
5813 CvROOT(cv)->op_next = 0;
5814 CALL_PEEP(CvSTART(cv));
5816 /* now that optimizer has done its work, adjust pad values */
5818 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
5821 assert(!CvCONST(cv));
5822 if (ps && !*ps && op_const_sv(block, cv))
5827 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5828 SV * const sv = newSV(0);
5829 SV * const tmpstr = sv_newmortal();
5830 GV * const db_postponed = gv_fetchpvs("DB::postponed",
5831 GV_ADDMULTI, SVt_PVHV);
5834 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5836 (long)PL_subline, (long)CopLINE(PL_curcop));
5837 gv_efullname3(tmpstr, gv, NULL);
5838 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
5839 SvCUR(tmpstr), sv, 0);
5840 hv = GvHVn(db_postponed);
5841 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
5842 CV * const pcv = GvCV(db_postponed);
5848 call_sv(MUTABLE_SV(pcv), G_DISCARD);
5853 if (name && ! (PL_parser && PL_parser->error_count))
5854 process_special_blocks(name, gv, cv);
5859 PL_parser->copline = NOLINE;
5865 S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
5868 const char *const colon = strrchr(fullname,':');
5869 const char *const name = colon ? colon + 1 : fullname;
5871 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
5874 if (strEQ(name, "BEGIN")) {
5875 const I32 oldscope = PL_scopestack_ix;
5877 SAVECOPFILE(&PL_compiling);
5878 SAVECOPLINE(&PL_compiling);
5880 DEBUG_x( dump_sub(gv) );
5881 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
5882 GvCV(gv) = 0; /* cv has been hijacked */
5883 call_list(oldscope, PL_beginav);
5885 PL_curcop = &PL_compiling;
5886 CopHINTS_set(&PL_compiling, PL_hints);
5893 if strEQ(name, "END") {
5894 DEBUG_x( dump_sub(gv) );
5895 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
5898 } else if (*name == 'U') {
5899 if (strEQ(name, "UNITCHECK")) {
5900 /* It's never too late to run a unitcheck block */
5901 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
5905 } else if (*name == 'C') {
5906 if (strEQ(name, "CHECK")) {
5908 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
5909 "Too late to run CHECK block");
5910 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
5914 } else if (*name == 'I') {
5915 if (strEQ(name, "INIT")) {
5917 Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
5918 "Too late to run INIT block");
5919 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
5925 DEBUG_x( dump_sub(gv) );
5926 GvCV(gv) = 0; /* cv has been hijacked */
5931 =for apidoc newCONSTSUB
5933 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5934 eligible for inlining at compile-time.
5936 Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>,
5937 which won't be called if used as a destructor, but will suppress the overhead
5938 of a call to C<AUTOLOAD>. (This form, however, isn't eligible for inlining at
5945 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
5950 const char *const file = CopFILE(PL_curcop);
5952 SV *const temp_sv = CopFILESV(PL_curcop);
5953 const char *const file = temp_sv ? SvPV_nolen_const(temp_sv) : NULL;
5958 if (IN_PERL_RUNTIME) {
5959 /* at runtime, it's not safe to manipulate PL_curcop: it may be
5960 * an op shared between threads. Use a non-shared COP for our
5962 SAVEVPTR(PL_curcop);
5963 PL_curcop = &PL_compiling;
5965 SAVECOPLINE(PL_curcop);
5966 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
5969 PL_hints &= ~HINT_BLOCK_SCOPE;
5972 SAVESPTR(PL_curstash);
5973 SAVECOPSTASH(PL_curcop);
5974 PL_curstash = stash;
5975 CopSTASH_set(PL_curcop,stash);
5978 /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
5979 and so doesn't get free()d. (It's expected to be from the C pre-
5980 processor __FILE__ directive). But we need a dynamically allocated one,
5981 and we need it to get freed. */
5982 cv = newXS_flags(name, const_sv_xsub, file ? file : "", "",
5983 XS_DYNAMIC_FILENAME);
5984 CvXSUBANY(cv).any_ptr = sv;
5989 CopSTASH_free(PL_curcop);
5997 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
5998 const char *const filename, const char *const proto,
6001 CV *cv = newXS(name, subaddr, filename);
6003 PERL_ARGS_ASSERT_NEWXS_FLAGS;
6005 if (flags & XS_DYNAMIC_FILENAME) {
6006 /* We need to "make arrangements" (ie cheat) to ensure that the
6007 filename lasts as long as the PVCV we just created, but also doesn't
6009 STRLEN filename_len = strlen(filename);
6010 STRLEN proto_and_file_len = filename_len;
6011 char *proto_and_file;
6015 proto_len = strlen(proto);
6016 proto_and_file_len += proto_len;
6018 Newx(proto_and_file, proto_and_file_len + 1, char);
6019 Copy(proto, proto_and_file, proto_len, char);
6020 Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
6023 proto_and_file = savepvn(filename, filename_len);
6026 /* This gets free()d. :-) */
6027 sv_usepvn_flags(MUTABLE_SV(cv), proto_and_file, proto_and_file_len,
6028 SV_HAS_TRAILING_NUL);
6030 /* This gives us the correct prototype, rather than one with the
6031 file name appended. */
6032 SvCUR_set(cv, proto_len);
6036 CvFILE(cv) = proto_and_file + proto_len;
6038 sv_setpv(MUTABLE_SV(cv), proto);
6044 =for apidoc U||newXS
6046 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
6047 static storage, as it is used directly as CvFILE(), without a copy being made.
6053 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
6056 GV * const gv = gv_fetchpv(name ? name :
6057 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
6058 GV_ADDMULTI, SVt_PVCV);
6061 PERL_ARGS_ASSERT_NEWXS;
6064 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
6066 if ((cv = (name ? GvCV(gv) : NULL))) {
6068 /* just a cached method */
6072 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
6073 /* already defined (or promised) */
6074 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
6075 if (ckWARN(WARN_REDEFINE)) {
6076 GV * const gvcv = CvGV(cv);
6078 HV * const stash = GvSTASH(gvcv);
6080 const char *redefined_name = HvNAME_get(stash);
6081 if ( strEQ(redefined_name,"autouse") ) {
6082 const line_t oldline = CopLINE(PL_curcop);
6083 if (PL_parser && PL_parser->copline != NOLINE)
6084 CopLINE_set(PL_curcop, PL_parser->copline);
6085 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6086 CvCONST(cv) ? "Constant subroutine %s redefined"
6087 : "Subroutine %s redefined"
6089 CopLINE_set(PL_curcop, oldline);
6099 if (cv) /* must reuse cv if autoloaded */
6102 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
6106 mro_method_changed_in(GvSTASH(gv)); /* newXS */
6110 (void)gv_fetchfile(filename);
6111 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
6112 an external constant string */
6114 CvXSUB(cv) = subaddr;
6117 process_special_blocks(name, gv, cv);
6129 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
6134 OP* pegop = newOP(OP_NULL, 0);
6138 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
6139 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
6142 if ((cv = GvFORM(gv))) {
6143 if (ckWARN(WARN_REDEFINE)) {
6144 const line_t oldline = CopLINE(PL_curcop);
6145 if (PL_parser && PL_parser->copline != NOLINE)
6146 CopLINE_set(PL_curcop, PL_parser->copline);
6148 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6149 "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
6151 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6152 "Format STDOUT redefined");
6154 CopLINE_set(PL_curcop, oldline);
6161 CvFILE_set_from_cop(cv, PL_curcop);
6164 pad_tidy(padtidy_FORMAT);
6165 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
6166 CvROOT(cv)->op_private |= OPpREFCOUNTED;
6167 OpREFCNT_set(CvROOT(cv), 1);
6168 CvSTART(cv) = LINKLIST(CvROOT(cv));
6169 CvROOT(cv)->op_next = 0;
6170 CALL_PEEP(CvSTART(cv));
6172 op_getmad(o,pegop,'n');
6173 op_getmad_weak(block, pegop, 'b');
6178 PL_parser->copline = NOLINE;
6186 Perl_newANONLIST(pTHX_ OP *o)
6188 return convert(OP_ANONLIST, OPf_SPECIAL, o);
6192 Perl_newANONHASH(pTHX_ OP *o)
6194 return convert(OP_ANONHASH, OPf_SPECIAL, o);
6198 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
6200 return newANONATTRSUB(floor, proto, NULL, block);
6204 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
6206 return newUNOP(OP_REFGEN, 0,
6207 newSVOP(OP_ANONCODE, 0,
6208 MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block))));
6212 Perl_oopsAV(pTHX_ OP *o)
6216 PERL_ARGS_ASSERT_OOPSAV;
6218 switch (o->op_type) {
6220 o->op_type = OP_PADAV;
6221 o->op_ppaddr = PL_ppaddr[OP_PADAV];
6222 return ref(o, OP_RV2AV);
6225 o->op_type = OP_RV2AV;
6226 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
6231 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
6238 Perl_oopsHV(pTHX_ OP *o)
6242 PERL_ARGS_ASSERT_OOPSHV;
6244 switch (o->op_type) {
6247 o->op_type = OP_PADHV;
6248 o->op_ppaddr = PL_ppaddr[OP_PADHV];
6249 return ref(o, OP_RV2HV);
6253 o->op_type = OP_RV2HV;
6254 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
6259 Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
6266 Perl_newAVREF(pTHX_ OP *o)
6270 PERL_ARGS_ASSERT_NEWAVREF;
6272 if (o->op_type == OP_PADANY) {
6273 o->op_type = OP_PADAV;
6274 o->op_ppaddr = PL_ppaddr[OP_PADAV];
6277 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
6278 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6279 "Using an array as a reference is deprecated");
6281 return newUNOP(OP_RV2AV, 0, scalar(o));
6285 Perl_newGVREF(pTHX_ I32 type, OP *o)
6287 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
6288 return newUNOP(OP_NULL, 0, o);
6289 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
6293 Perl_newHVREF(pTHX_ OP *o)
6297 PERL_ARGS_ASSERT_NEWHVREF;
6299 if (o->op_type == OP_PADANY) {
6300 o->op_type = OP_PADHV;
6301 o->op_ppaddr = PL_ppaddr[OP_PADHV];
6304 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
6305 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6306 "Using a hash as a reference is deprecated");
6308 return newUNOP(OP_RV2HV, 0, scalar(o));
6312 Perl_newCVREF(pTHX_ I32 flags, OP *o)
6314 return newUNOP(OP_RV2CV, flags, scalar(o));
6318 Perl_newSVREF(pTHX_ OP *o)
6322 PERL_ARGS_ASSERT_NEWSVREF;
6324 if (o->op_type == OP_PADANY) {
6325 o->op_type = OP_PADSV;
6326 o->op_ppaddr = PL_ppaddr[OP_PADSV];
6329 return newUNOP(OP_RV2SV, 0, scalar(o));
6332 /* Check routines. See the comments at the top of this file for details
6333 * on when these are called */
6336 Perl_ck_anoncode(pTHX_ OP *o)
6338 PERL_ARGS_ASSERT_CK_ANONCODE;
6340 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
6342 cSVOPo->op_sv = NULL;
6347 Perl_ck_bitop(pTHX_ OP *o)
6351 PERL_ARGS_ASSERT_CK_BITOP;
6353 #define OP_IS_NUMCOMPARE(op) \
6354 ((op) == OP_LT || (op) == OP_I_LT || \
6355 (op) == OP_GT || (op) == OP_I_GT || \
6356 (op) == OP_LE || (op) == OP_I_LE || \
6357 (op) == OP_GE || (op) == OP_I_GE || \
6358 (op) == OP_EQ || (op) == OP_I_EQ || \
6359 (op) == OP_NE || (op) == OP_I_NE || \
6360 (op) == OP_NCMP || (op) == OP_I_NCMP)
6361 o->op_private = (U8)(PL_hints & HINT_INTEGER);
6362 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
6363 && (o->op_type == OP_BIT_OR
6364 || o->op_type == OP_BIT_AND
6365 || o->op_type == OP_BIT_XOR))
6367 const OP * const left = cBINOPo->op_first;
6368 const OP * const right = left->op_sibling;
6369 if ((OP_IS_NUMCOMPARE(left->op_type) &&
6370 (left->op_flags & OPf_PARENS) == 0) ||
6371 (OP_IS_NUMCOMPARE(right->op_type) &&
6372 (right->op_flags & OPf_PARENS) == 0))
6373 Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE),
6374 "Possible precedence problem on bitwise %c operator",
6375 o->op_type == OP_BIT_OR ? '|'
6376 : o->op_type == OP_BIT_AND ? '&' : '^'
6383 Perl_ck_concat(pTHX_ OP *o)
6385 const OP * const kid = cUNOPo->op_first;
6387 PERL_ARGS_ASSERT_CK_CONCAT;
6388 PERL_UNUSED_CONTEXT;
6390 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
6391 !(kUNOP->op_first->op_flags & OPf_MOD))
6392 o->op_flags |= OPf_STACKED;
6397 Perl_ck_spair(pTHX_ OP *o)
6401 PERL_ARGS_ASSERT_CK_SPAIR;
6403 if (o->op_flags & OPf_KIDS) {
6406 const OPCODE type = o->op_type;
6407 o = modkids(ck_fun(o), type);
6408 kid = cUNOPo->op_first;
6409 newop = kUNOP->op_first->op_sibling;
6411 const OPCODE type = newop->op_type;
6412 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
6413 type == OP_PADAV || type == OP_PADHV ||
6414 type == OP_RV2AV || type == OP_RV2HV)
6418 op_getmad(kUNOP->op_first,newop,'K');
6420 op_free(kUNOP->op_first);
6422 kUNOP->op_first = newop;
6424 o->op_ppaddr = PL_ppaddr[++o->op_type];
6429 Perl_ck_delete(pTHX_ OP *o)
6431 PERL_ARGS_ASSERT_CK_DELETE;
6435 if (o->op_flags & OPf_KIDS) {
6436 OP * const kid = cUNOPo->op_first;
6437 switch (kid->op_type) {
6439 o->op_flags |= OPf_SPECIAL;
6442 o->op_private |= OPpSLICE;
6445 o->op_flags |= OPf_SPECIAL;
6450 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
6453 if (kid->op_private & OPpLVAL_INTRO)
6454 o->op_private |= OPpLVAL_INTRO;
6461 Perl_ck_die(pTHX_ OP *o)
6463 PERL_ARGS_ASSERT_CK_DIE;
6466 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6472 Perl_ck_eof(pTHX_ OP *o)
6476 PERL_ARGS_ASSERT_CK_EOF;
6478 if (o->op_flags & OPf_KIDS) {
6479 if (cLISTOPo->op_first->op_type == OP_STUB) {
6481 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
6483 op_getmad(o,newop,'O');
6495 Perl_ck_eval(pTHX_ OP *o)
6499 PERL_ARGS_ASSERT_CK_EVAL;
6501 PL_hints |= HINT_BLOCK_SCOPE;
6502 if (o->op_flags & OPf_KIDS) {
6503 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6506 o->op_flags &= ~OPf_KIDS;
6509 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
6515 cUNOPo->op_first = 0;
6520 NewOp(1101, enter, 1, LOGOP);
6521 enter->op_type = OP_ENTERTRY;
6522 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
6523 enter->op_private = 0;
6525 /* establish postfix order */
6526 enter->op_next = (OP*)enter;
6528 CHECKOP(OP_ENTERTRY, enter);
6530 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
6531 o->op_type = OP_LEAVETRY;
6532 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
6533 enter->op_other = o;
6534 op_getmad(oldo,o,'O');
6548 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
6549 op_getmad(oldo,o,'O');
6551 o->op_targ = (PADOFFSET)PL_hints;
6552 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
6553 /* Store a copy of %^H that pp_entereval can pick up. */
6554 OP *hhop = newSVOP(OP_HINTSEVAL, 0,
6555 MUTABLE_SV(Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv))));
6556 cUNOPo->op_first->op_sibling = hhop;
6557 o->op_private |= OPpEVAL_HAS_HH;
6563 Perl_ck_exit(pTHX_ OP *o)
6565 PERL_ARGS_ASSERT_CK_EXIT;
6568 HV * const table = GvHV(PL_hintgv);
6570 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
6571 if (svp && *svp && SvTRUE(*svp))
6572 o->op_private |= OPpEXIT_VMSISH;
6574 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6580 Perl_ck_exec(pTHX_ OP *o)
6582 PERL_ARGS_ASSERT_CK_EXEC;
6584 if (o->op_flags & OPf_STACKED) {
6587 kid = cUNOPo->op_first->op_sibling;
6588 if (kid->op_type == OP_RV2GV)
6597 Perl_ck_exists(pTHX_ OP *o)
6601 PERL_ARGS_ASSERT_CK_EXISTS;
6604 if (o->op_flags & OPf_KIDS) {
6605 OP * const kid = cUNOPo->op_first;
6606 if (kid->op_type == OP_ENTERSUB) {
6607 (void) ref(kid, o->op_type);
6608 if (kid->op_type != OP_RV2CV
6609 && !(PL_parser && PL_parser->error_count))
6610 Perl_croak(aTHX_ "%s argument is not a subroutine name",
6612 o->op_private |= OPpEXISTS_SUB;
6614 else if (kid->op_type == OP_AELEM)
6615 o->op_flags |= OPf_SPECIAL;
6616 else if (kid->op_type != OP_HELEM)
6617 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or a subroutine",
6625 Perl_ck_rvconst(pTHX_ register OP *o)
6628 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6630 PERL_ARGS_ASSERT_CK_RVCONST;
6632 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6633 if (o->op_type == OP_RV2CV)
6634 o->op_private &= ~1;
6636 if (kid->op_type == OP_CONST) {
6639 SV * const kidsv = kid->op_sv;
6641 /* Is it a constant from cv_const_sv()? */
6642 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
6643 SV * const rsv = SvRV(kidsv);
6644 const svtype type = SvTYPE(rsv);
6645 const char *badtype = NULL;
6647 switch (o->op_type) {
6649 if (type > SVt_PVMG)
6650 badtype = "a SCALAR";
6653 if (type != SVt_PVAV)
6654 badtype = "an ARRAY";
6657 if (type != SVt_PVHV)
6661 if (type != SVt_PVCV)
6666 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
6669 else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
6670 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
6671 /* If this is an access to a stash, disable "strict refs", because
6672 * stashes aren't auto-vivified at compile-time (unless we store
6673 * symbols in them), and we don't want to produce a run-time
6674 * stricture error when auto-vivifying the stash. */
6675 const char *s = SvPV_nolen(kidsv);
6676 const STRLEN l = SvCUR(kidsv);
6677 if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
6678 o->op_private &= ~HINT_STRICT_REFS;
6680 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
6681 const char *badthing;
6682 switch (o->op_type) {
6684 badthing = "a SCALAR";
6687 badthing = "an ARRAY";
6690 badthing = "a HASH";
6698 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
6699 SVfARG(kidsv), badthing);
6702 * This is a little tricky. We only want to add the symbol if we
6703 * didn't add it in the lexer. Otherwise we get duplicate strict
6704 * warnings. But if we didn't add it in the lexer, we must at
6705 * least pretend like we wanted to add it even if it existed before,
6706 * or we get possible typo warnings. OPpCONST_ENTERED says
6707 * whether the lexer already added THIS instance of this symbol.
6709 iscv = (o->op_type == OP_RV2CV) * 2;
6711 gv = gv_fetchsv(kidsv,
6712 iscv | !(kid->op_private & OPpCONST_ENTERED),
6715 : o->op_type == OP_RV2SV
6717 : o->op_type == OP_RV2AV
6719 : o->op_type == OP_RV2HV
6722 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
6724 kid->op_type = OP_GV;
6725 SvREFCNT_dec(kid->op_sv);
6727 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
6728 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
6729 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
6731 PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
6733 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
6735 kid->op_private = 0;
6736 kid->op_ppaddr = PL_ppaddr[OP_GV];
6743 Perl_ck_ftst(pTHX_ OP *o)
6746 const I32 type = o->op_type;
6748 PERL_ARGS_ASSERT_CK_FTST;
6750 if (o->op_flags & OPf_REF) {
6753 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
6754 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6755 const OPCODE kidtype = kid->op_type;
6757 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6758 OP * const newop = newGVOP(type, OPf_REF,
6759 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
6761 op_getmad(o,newop,'O');
6767 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
6768 o->op_private |= OPpFT_ACCESS;
6769 if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst)
6770 && kidtype != OP_STAT && kidtype != OP_LSTAT)
6771 o->op_private |= OPpFT_STACKED;
6779 if (type == OP_FTTTY)
6780 o = newGVOP(type, OPf_REF, PL_stdingv);
6782 o = newUNOP(type, 0, newDEFSVOP());
6783 op_getmad(oldo,o,'O');
6789 Perl_ck_fun(pTHX_ OP *o)
6792 const int type = o->op_type;
6793 register I32 oa = PL_opargs[type] >> OASHIFT;
6795 PERL_ARGS_ASSERT_CK_FUN;
6797 if (o->op_flags & OPf_STACKED) {
6798 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
6801 return no_fh_allowed(o);
6804 if (o->op_flags & OPf_KIDS) {
6805 OP **tokid = &cLISTOPo->op_first;
6806 register OP *kid = cLISTOPo->op_first;
6810 if (kid->op_type == OP_PUSHMARK ||
6811 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
6813 tokid = &kid->op_sibling;
6814 kid = kid->op_sibling;
6816 if (!kid && PL_opargs[type] & OA_DEFGV)
6817 *tokid = kid = newDEFSVOP();
6821 sibl = kid->op_sibling;
6823 if (!sibl && kid->op_type == OP_STUB) {
6830 /* list seen where single (scalar) arg expected? */
6831 if (numargs == 1 && !(oa >> 4)
6832 && kid->op_type == OP_LIST && type != OP_SCALAR)
6834 return too_many_arguments(o,PL_op_desc[type]);
6847 if ((type == OP_PUSH || type == OP_UNSHIFT)
6848 && !kid->op_sibling)
6849 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
6850 "Useless use of %s with no values",
6853 if (kid->op_type == OP_CONST &&
6854 (kid->op_private & OPpCONST_BARE))
6856 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
6857 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
6858 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6859 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
6860 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6862 op_getmad(kid,newop,'K');
6867 kid->op_sibling = sibl;
6870 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
6871 bad_type(numargs, "array", PL_op_desc[type], kid);
6875 if (kid->op_type == OP_CONST &&
6876 (kid->op_private & OPpCONST_BARE))
6878 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
6879 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
6880 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
6881 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
6882 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6884 op_getmad(kid,newop,'K');
6889 kid->op_sibling = sibl;
6892 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
6893 bad_type(numargs, "hash", PL_op_desc[type], kid);
6898 OP * const newop = newUNOP(OP_NULL, 0, kid);
6899 kid->op_sibling = 0;
6901 newop->op_next = newop;
6903 kid->op_sibling = sibl;
6908 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
6909 if (kid->op_type == OP_CONST &&
6910 (kid->op_private & OPpCONST_BARE))
6912 OP * const newop = newGVOP(OP_GV, 0,
6913 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
6914 if (!(o->op_private & 1) && /* if not unop */
6915 kid == cLISTOPo->op_last)
6916 cLISTOPo->op_last = newop;
6918 op_getmad(kid,newop,'K');
6924 else if (kid->op_type == OP_READLINE) {
6925 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
6926 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
6929 I32 flags = OPf_SPECIAL;
6933 /* is this op a FH constructor? */
6934 if (is_handle_constructor(o,numargs)) {
6935 const char *name = NULL;
6939 /* Set a flag to tell rv2gv to vivify
6940 * need to "prove" flag does not mean something
6941 * else already - NI-S 1999/05/07
6944 if (kid->op_type == OP_PADSV) {
6946 = PAD_COMPNAME_SV(kid->op_targ);
6947 name = SvPV_const(namesv, len);
6949 else if (kid->op_type == OP_RV2SV
6950 && kUNOP->op_first->op_type == OP_GV)
6952 GV * const gv = cGVOPx_gv(kUNOP->op_first);
6954 len = GvNAMELEN(gv);
6956 else if (kid->op_type == OP_AELEM
6957 || kid->op_type == OP_HELEM)
6960 OP *op = ((BINOP*)kid)->op_first;
6964 const char * const a =
6965 kid->op_type == OP_AELEM ?
6967 if (((op->op_type == OP_RV2AV) ||
6968 (op->op_type == OP_RV2HV)) &&
6969 (firstop = ((UNOP*)op)->op_first) &&
6970 (firstop->op_type == OP_GV)) {
6971 /* packagevar $a[] or $h{} */
6972 GV * const gv = cGVOPx_gv(firstop);
6980 else if (op->op_type == OP_PADAV
6981 || op->op_type == OP_PADHV) {
6982 /* lexicalvar $a[] or $h{} */
6983 const char * const padname =
6984 PAD_COMPNAME_PV(op->op_targ);
6993 name = SvPV_const(tmpstr, len);
6998 name = "__ANONIO__";
7005 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
7006 namesv = PAD_SVl(targ);
7007 SvUPGRADE(namesv, SVt_PV);
7009 sv_setpvs(namesv, "$");
7010 sv_catpvn(namesv, name, len);
7013 kid->op_sibling = 0;
7014 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
7015 kid->op_targ = targ;
7016 kid->op_private |= priv;
7018 kid->op_sibling = sibl;
7024 mod(scalar(kid), type);
7028 tokid = &kid->op_sibling;
7029 kid = kid->op_sibling;
7032 if (kid && kid->op_type != OP_STUB)
7033 return too_many_arguments(o,OP_DESC(o));
7034 o->op_private |= numargs;
7036 /* FIXME - should the numargs move as for the PERL_MAD case? */
7037 o->op_private |= numargs;
7039 return too_many_arguments(o,OP_DESC(o));
7043 else if (PL_opargs[type] & OA_DEFGV) {
7045 OP *newop = newUNOP(type, 0, newDEFSVOP());
7046 op_getmad(o,newop,'O');
7049 /* Ordering of these two is important to keep f_map.t passing. */
7051 return newUNOP(type, 0, newDEFSVOP());
7056 while (oa & OA_OPTIONAL)
7058 if (oa && oa != OA_LIST)
7059 return too_few_arguments(o,OP_DESC(o));
7065 Perl_ck_glob(pTHX_ OP *o)
7070 PERL_ARGS_ASSERT_CK_GLOB;
7073 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
7074 append_elem(OP_GLOB, o, newDEFSVOP());
7076 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
7077 && GvCVu(gv) && GvIMPORTED_CV(gv)))
7079 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7082 #if !defined(PERL_EXTERNAL_GLOB)
7083 /* XXX this can be tightened up and made more failsafe. */
7084 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7087 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
7088 newSVpvs("File::Glob"), NULL, NULL, NULL);
7089 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7090 glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
7091 GvCV(gv) = GvCV(glob_gv);
7092 SvREFCNT_inc_void(MUTABLE_SV(GvCV(gv)));
7093 GvIMPORTED_CV_on(gv);
7096 #endif /* PERL_EXTERNAL_GLOB */
7098 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7099 append_elem(OP_GLOB, o,
7100 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
7101 o->op_type = OP_LIST;
7102 o->op_ppaddr = PL_ppaddr[OP_LIST];
7103 cLISTOPo->op_first->op_type = OP_PUSHMARK;
7104 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
7105 cLISTOPo->op_first->op_targ = 0;
7106 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
7107 append_elem(OP_LIST, o,
7108 scalar(newUNOP(OP_RV2CV, 0,
7109 newGVOP(OP_GV, 0, gv)))));
7110 o = newUNOP(OP_NULL, 0, ck_subr(o));
7111 o->op_targ = OP_GLOB; /* hint at what it used to be */
7114 gv = newGVgen("main");
7116 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
7122 Perl_ck_grep(pTHX_ OP *o)
7127 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
7130 PERL_ARGS_ASSERT_CK_GREP;
7132 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
7133 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
7135 if (o->op_flags & OPf_STACKED) {
7138 kid = cLISTOPo->op_first->op_sibling;
7139 if (!cUNOPx(kid)->op_next)
7140 Perl_croak(aTHX_ "panic: ck_grep");
7141 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
7144 NewOp(1101, gwop, 1, LOGOP);
7145 kid->op_next = (OP*)gwop;
7146 o->op_flags &= ~OPf_STACKED;
7148 kid = cLISTOPo->op_first->op_sibling;
7149 if (type == OP_MAPWHILE)
7154 if (PL_parser && PL_parser->error_count)
7156 kid = cLISTOPo->op_first->op_sibling;
7157 if (kid->op_type != OP_NULL)
7158 Perl_croak(aTHX_ "panic: ck_grep");
7159 kid = kUNOP->op_first;
7162 NewOp(1101, gwop, 1, LOGOP);
7163 gwop->op_type = type;
7164 gwop->op_ppaddr = PL_ppaddr[type];
7165 gwop->op_first = listkids(o);
7166 gwop->op_flags |= OPf_KIDS;
7167 gwop->op_other = LINKLIST(kid);
7168 kid->op_next = (OP*)gwop;
7169 offset = pad_findmy("$_");
7170 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
7171 o->op_private = gwop->op_private = 0;
7172 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
7175 o->op_private = gwop->op_private = OPpGREP_LEX;
7176 gwop->op_targ = o->op_targ = offset;
7179 kid = cLISTOPo->op_first->op_sibling;
7180 if (!kid || !kid->op_sibling)
7181 return too_few_arguments(o,OP_DESC(o));
7182 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
7183 mod(kid, OP_GREPSTART);
7189 Perl_ck_index(pTHX_ OP *o)
7191 PERL_ARGS_ASSERT_CK_INDEX;
7193 if (o->op_flags & OPf_KIDS) {
7194 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7196 kid = kid->op_sibling; /* get past "big" */
7197 if (kid && kid->op_type == OP_CONST)
7198 fbm_compile(((SVOP*)kid)->op_sv, 0);
7204 Perl_ck_lfun(pTHX_ OP *o)
7206 const OPCODE type = o->op_type;
7208 PERL_ARGS_ASSERT_CK_LFUN;
7210 return modkids(ck_fun(o), type);
7214 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
7216 PERL_ARGS_ASSERT_CK_DEFINED;
7218 if ((o->op_flags & OPf_KIDS)) {
7219 switch (cUNOPo->op_first->op_type) {
7221 /* This is needed for
7222 if (defined %stash::)
7223 to work. Do not break Tk.
7225 break; /* Globals via GV can be undef */
7227 case OP_AASSIGN: /* Is this a good idea? */
7228 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7229 "defined(@array) is deprecated");
7230 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7231 "\t(Maybe you should just omit the defined()?)\n");
7235 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7236 "defined(%%hash) is deprecated");
7237 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
7238 "\t(Maybe you should just omit the defined()?)\n");
7249 Perl_ck_readline(pTHX_ OP *o)
7251 PERL_ARGS_ASSERT_CK_READLINE;
7253 if (!(o->op_flags & OPf_KIDS)) {
7255 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
7257 op_getmad(o,newop,'O');
7267 Perl_ck_rfun(pTHX_ OP *o)
7269 const OPCODE type = o->op_type;
7271 PERL_ARGS_ASSERT_CK_RFUN;
7273 return refkids(ck_fun(o), type);
7277 Perl_ck_listiob(pTHX_ OP *o)
7281 PERL_ARGS_ASSERT_CK_LISTIOB;
7283 kid = cLISTOPo->op_first;
7286 kid = cLISTOPo->op_first;
7288 if (kid->op_type == OP_PUSHMARK)
7289 kid = kid->op_sibling;
7290 if (kid && o->op_flags & OPf_STACKED)
7291 kid = kid->op_sibling;
7292 else if (kid && !kid->op_sibling) { /* print HANDLE; */
7293 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
7294 o->op_flags |= OPf_STACKED; /* make it a filehandle */
7295 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
7296 cLISTOPo->op_first->op_sibling = kid;
7297 cLISTOPo->op_last = kid;
7298 kid = kid->op_sibling;
7303 append_elem(o->op_type, o, newDEFSVOP());
7309 Perl_ck_smartmatch(pTHX_ OP *o)
7312 if (0 == (o->op_flags & OPf_SPECIAL)) {
7313 OP *first = cBINOPo->op_first;
7314 OP *second = first->op_sibling;
7316 /* Implicitly take a reference to an array or hash */
7317 first->op_sibling = NULL;
7318 first = cBINOPo->op_first = ref_array_or_hash(first);
7319 second = first->op_sibling = ref_array_or_hash(second);
7321 /* Implicitly take a reference to a regular expression */
7322 if (first->op_type == OP_MATCH) {
7323 first->op_type = OP_QR;
7324 first->op_ppaddr = PL_ppaddr[OP_QR];
7326 if (second->op_type == OP_MATCH) {
7327 second->op_type = OP_QR;
7328 second->op_ppaddr = PL_ppaddr[OP_QR];
7337 Perl_ck_sassign(pTHX_ OP *o)
7340 OP * const kid = cLISTOPo->op_first;
7342 PERL_ARGS_ASSERT_CK_SASSIGN;
7344 /* has a disposable target? */
7345 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
7346 && !(kid->op_flags & OPf_STACKED)
7347 /* Cannot steal the second time! */
7348 && !(kid->op_private & OPpTARGET_MY)
7349 /* Keep the full thing for madskills */
7353 OP * const kkid = kid->op_sibling;
7355 /* Can just relocate the target. */
7356 if (kkid && kkid->op_type == OP_PADSV
7357 && !(kkid->op_private & OPpLVAL_INTRO))
7359 kid->op_targ = kkid->op_targ;
7361 /* Now we do not need PADSV and SASSIGN. */
7362 kid->op_sibling = o->op_sibling; /* NULL */
7363 cLISTOPo->op_first = NULL;
7366 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
7370 if (kid->op_sibling) {
7371 OP *kkid = kid->op_sibling;
7372 if (kkid->op_type == OP_PADSV
7373 && (kkid->op_private & OPpLVAL_INTRO)
7374 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
7375 const PADOFFSET target = kkid->op_targ;
7376 OP *const other = newOP(OP_PADSV,
7378 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
7379 OP *const first = newOP(OP_NULL, 0);
7380 OP *const nullop = newCONDOP(0, first, o, other);
7381 OP *const condop = first->op_next;
7382 /* hijacking PADSTALE for uninitialized state variables */
7383 SvPADSTALE_on(PAD_SVl(target));
7385 condop->op_type = OP_ONCE;
7386 condop->op_ppaddr = PL_ppaddr[OP_ONCE];
7387 condop->op_targ = target;
7388 other->op_targ = target;
7390 /* Because we change the type of the op here, we will skip the
7391 assinment binop->op_last = binop->op_first->op_sibling; at the
7392 end of Perl_newBINOP(). So need to do it here. */
7393 cBINOPo->op_last = cBINOPo->op_first->op_sibling;
7402 Perl_ck_match(pTHX_ OP *o)
7406 PERL_ARGS_ASSERT_CK_MATCH;
7408 if (o->op_type != OP_QR && PL_compcv) {
7409 const PADOFFSET offset = pad_findmy("$_");
7410 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
7411 o->op_targ = offset;
7412 o->op_private |= OPpTARGET_MY;
7415 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
7416 o->op_private |= OPpRUNTIME;
7421 Perl_ck_method(pTHX_ OP *o)
7423 OP * const kid = cUNOPo->op_first;
7425 PERL_ARGS_ASSERT_CK_METHOD;
7427 if (kid->op_type == OP_CONST) {
7428 SV* sv = kSVOP->op_sv;
7429 const char * const method = SvPVX_const(sv);
7430 if (!(strchr(method, ':') || strchr(method, '\''))) {
7432 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
7433 sv = newSVpvn_share(method, SvCUR(sv), 0);
7436 kSVOP->op_sv = NULL;
7438 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
7440 op_getmad(o,cmop,'O');
7451 Perl_ck_null(pTHX_ OP *o)
7453 PERL_ARGS_ASSERT_CK_NULL;
7454 PERL_UNUSED_CONTEXT;
7459 Perl_ck_open(pTHX_ OP *o)
7462 HV * const table = GvHV(PL_hintgv);
7464 PERL_ARGS_ASSERT_CK_OPEN;
7467 SV **svp = hv_fetchs(table, "open_IN", FALSE);
7470 const char *d = SvPV_const(*svp, len);
7471 const I32 mode = mode_from_discipline(d, len);
7472 if (mode & O_BINARY)
7473 o->op_private |= OPpOPEN_IN_RAW;
7474 else if (mode & O_TEXT)
7475 o->op_private |= OPpOPEN_IN_CRLF;
7478 svp = hv_fetchs(table, "open_OUT", FALSE);
7481 const char *d = SvPV_const(*svp, len);
7482 const I32 mode = mode_from_discipline(d, len);
7483 if (mode & O_BINARY)
7484 o->op_private |= OPpOPEN_OUT_RAW;
7485 else if (mode & O_TEXT)
7486 o->op_private |= OPpOPEN_OUT_CRLF;
7489 if (o->op_type == OP_BACKTICK) {
7490 if (!(o->op_flags & OPf_KIDS)) {
7491 OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
7493 op_getmad(o,newop,'O');
7502 /* In case of three-arg dup open remove strictness
7503 * from the last arg if it is a bareword. */
7504 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
7505 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
7509 if ((last->op_type == OP_CONST) && /* The bareword. */
7510 (last->op_private & OPpCONST_BARE) &&
7511 (last->op_private & OPpCONST_STRICT) &&
7512 (oa = first->op_sibling) && /* The fh. */
7513 (oa = oa->op_sibling) && /* The mode. */
7514 (oa->op_type == OP_CONST) &&
7515 SvPOK(((SVOP*)oa)->op_sv) &&
7516 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
7517 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
7518 (last == oa->op_sibling)) /* The bareword. */
7519 last->op_private &= ~OPpCONST_STRICT;
7525 Perl_ck_repeat(pTHX_ OP *o)
7527 PERL_ARGS_ASSERT_CK_REPEAT;
7529 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
7530 o->op_private |= OPpREPEAT_DOLIST;
7531 cBINOPo->op_first = force_list(cBINOPo->op_first);
7539 Perl_ck_require(pTHX_ OP *o)
7544 PERL_ARGS_ASSERT_CK_REQUIRE;
7546 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
7547 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7549 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
7550 SV * const sv = kid->op_sv;
7551 U32 was_readonly = SvREADONLY(sv);
7558 sv_force_normal_flags(sv, 0);
7559 assert(!SvREADONLY(sv));
7569 for (; s < end; s++) {
7570 if (*s == ':' && s[1] == ':') {
7572 Move(s+2, s+1, end - s - 1, char);
7577 sv_catpvs(sv, ".pm");
7578 SvFLAGS(sv) |= was_readonly;
7582 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
7583 /* handle override, if any */
7584 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
7585 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7586 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
7587 gv = gvp ? *gvp : NULL;
7591 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7592 OP * const kid = cUNOPo->op_first;
7595 cUNOPo->op_first = 0;
7599 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
7600 append_elem(OP_LIST, kid,
7601 scalar(newUNOP(OP_RV2CV, 0,
7604 op_getmad(o,newop,'O');
7612 Perl_ck_return(pTHX_ OP *o)
7617 PERL_ARGS_ASSERT_CK_RETURN;
7619 kid = cLISTOPo->op_first->op_sibling;
7620 if (CvLVALUE(PL_compcv)) {
7621 for (; kid; kid = kid->op_sibling)
7622 mod(kid, OP_LEAVESUBLV);
7624 for (; kid; kid = kid->op_sibling)
7625 if ((kid->op_type == OP_NULL)
7626 && ((kid->op_flags & (OPf_SPECIAL|OPf_KIDS)) == (OPf_SPECIAL|OPf_KIDS))) {
7627 /* This is a do block */
7628 OP *op = kUNOP->op_first;
7629 if (op->op_type == OP_LEAVE && op->op_flags & OPf_KIDS) {
7630 op = cUNOPx(op)->op_first;
7631 assert(op->op_type == OP_ENTER && !(op->op_flags & OPf_SPECIAL));
7632 /* Force the use of the caller's context */
7633 op->op_flags |= OPf_SPECIAL;
7642 Perl_ck_select(pTHX_ OP *o)
7647 PERL_ARGS_ASSERT_CK_SELECT;
7649 if (o->op_flags & OPf_KIDS) {
7650 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7651 if (kid && kid->op_sibling) {
7652 o->op_type = OP_SSELECT;
7653 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
7655 return fold_constants(o);
7659 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7660 if (kid && kid->op_type == OP_RV2GV)
7661 kid->op_private &= ~HINT_STRICT_REFS;
7666 Perl_ck_shift(pTHX_ OP *o)
7669 const I32 type = o->op_type;
7671 PERL_ARGS_ASSERT_CK_SHIFT;
7673 if (!(o->op_flags & OPf_KIDS)) {
7674 OP *argop = newUNOP(OP_RV2AV, 0,
7675 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
7677 OP * const oldo = o;
7678 o = newUNOP(type, 0, scalar(argop));
7679 op_getmad(oldo,o,'O');
7683 return newUNOP(type, 0, scalar(argop));
7686 return scalar(modkids(ck_fun(o), type));
7690 Perl_ck_sort(pTHX_ OP *o)
7695 PERL_ARGS_ASSERT_CK_SORT;
7697 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
7698 HV * const hinthv = GvHV(PL_hintgv);
7700 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
7702 const I32 sorthints = (I32)SvIV(*svp);
7703 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
7704 o->op_private |= OPpSORT_QSORT;
7705 if ((sorthints & HINT_SORT_STABLE) != 0)
7706 o->op_private |= OPpSORT_STABLE;
7711 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
7713 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7714 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
7716 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
7718 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
7720 if (kid->op_type == OP_SCOPE) {
7724 else if (kid->op_type == OP_LEAVE) {
7725 if (o->op_type == OP_SORT) {
7726 op_null(kid); /* wipe out leave */
7729 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
7730 if (k->op_next == kid)
7732 /* don't descend into loops */
7733 else if (k->op_type == OP_ENTERLOOP
7734 || k->op_type == OP_ENTERITER)
7736 k = cLOOPx(k)->op_lastop;
7741 kid->op_next = 0; /* just disconnect the leave */
7742 k = kLISTOP->op_first;
7747 if (o->op_type == OP_SORT) {
7748 /* provide scalar context for comparison function/block */
7754 o->op_flags |= OPf_SPECIAL;
7756 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
7759 firstkid = firstkid->op_sibling;
7762 /* provide list context for arguments */
7763 if (o->op_type == OP_SORT)
7770 S_simplify_sort(pTHX_ OP *o)
7773 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7779 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
7781 if (!(o->op_flags & OPf_STACKED))
7783 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7784 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
7785 kid = kUNOP->op_first; /* get past null */
7786 if (kid->op_type != OP_SCOPE)
7788 kid = kLISTOP->op_last; /* get past scope */
7789 switch(kid->op_type) {
7797 k = kid; /* remember this node*/
7798 if (kBINOP->op_first->op_type != OP_RV2SV)
7800 kid = kBINOP->op_first; /* get past cmp */
7801 if (kUNOP->op_first->op_type != OP_GV)
7803 kid = kUNOP->op_first; /* get past rv2sv */
7805 if (GvSTASH(gv) != PL_curstash)
7807 gvname = GvNAME(gv);
7808 if (*gvname == 'a' && gvname[1] == '\0')
7810 else if (*gvname == 'b' && gvname[1] == '\0')
7815 kid = k; /* back to cmp */
7816 if (kBINOP->op_last->op_type != OP_RV2SV)
7818 kid = kBINOP->op_last; /* down to 2nd arg */
7819 if (kUNOP->op_first->op_type != OP_GV)
7821 kid = kUNOP->op_first; /* get past rv2sv */
7823 if (GvSTASH(gv) != PL_curstash)
7825 gvname = GvNAME(gv);
7827 ? !(*gvname == 'a' && gvname[1] == '\0')
7828 : !(*gvname == 'b' && gvname[1] == '\0'))
7830 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
7832 o->op_private |= OPpSORT_DESCEND;
7833 if (k->op_type == OP_NCMP)
7834 o->op_private |= OPpSORT_NUMERIC;
7835 if (k->op_type == OP_I_NCMP)
7836 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
7837 kid = cLISTOPo->op_first->op_sibling;
7838 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
7840 op_getmad(kid,o,'S'); /* then delete it */
7842 op_free(kid); /* then delete it */
7847 Perl_ck_split(pTHX_ OP *o)
7852 PERL_ARGS_ASSERT_CK_SPLIT;
7854 if (o->op_flags & OPf_STACKED)
7855 return no_fh_allowed(o);
7857 kid = cLISTOPo->op_first;
7858 if (kid->op_type != OP_NULL)
7859 Perl_croak(aTHX_ "panic: ck_split");
7860 kid = kid->op_sibling;
7861 op_free(cLISTOPo->op_first);
7862 cLISTOPo->op_first = kid;
7864 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
7865 cLISTOPo->op_last = kid; /* There was only one element previously */
7868 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
7869 OP * const sibl = kid->op_sibling;
7870 kid->op_sibling = 0;
7871 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
7872 if (cLISTOPo->op_first == cLISTOPo->op_last)
7873 cLISTOPo->op_last = kid;
7874 cLISTOPo->op_first = kid;
7875 kid->op_sibling = sibl;
7878 kid->op_type = OP_PUSHRE;
7879 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
7881 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
7882 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
7883 "Use of /g modifier is meaningless in split");
7886 if (!kid->op_sibling)
7887 append_elem(OP_SPLIT, o, newDEFSVOP());
7889 kid = kid->op_sibling;
7892 if (!kid->op_sibling)
7893 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
7894 assert(kid->op_sibling);
7896 kid = kid->op_sibling;
7899 if (kid->op_sibling)
7900 return too_many_arguments(o,OP_DESC(o));
7906 Perl_ck_join(pTHX_ OP *o)
7908 const OP * const kid = cLISTOPo->op_first->op_sibling;
7910 PERL_ARGS_ASSERT_CK_JOIN;
7912 if (kid && kid->op_type == OP_MATCH) {
7913 if (ckWARN(WARN_SYNTAX)) {
7914 const REGEXP *re = PM_GETRE(kPMOP);
7915 const char *pmstr = re ? RX_PRECOMP_const(re) : "STRING";
7916 const STRLEN len = re ? RX_PRELEN(re) : 6;
7917 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7918 "/%.*s/ should probably be written as \"%.*s\"",
7919 (int)len, pmstr, (int)len, pmstr);
7926 Perl_ck_subr(pTHX_ OP *o)
7929 OP *prev = ((cUNOPo->op_first->op_sibling)
7930 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
7931 OP *o2 = prev->op_sibling;
7933 const char *proto = NULL;
7934 const char *proto_end = NULL;
7939 I32 contextclass = 0;
7940 const char *e = NULL;
7943 PERL_ARGS_ASSERT_CK_SUBR;
7945 o->op_private |= OPpENTERSUB_HASTARG;
7946 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
7947 if (cvop->op_type == OP_RV2CV) {
7949 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
7950 op_null(cvop); /* disable rv2cv */
7951 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
7952 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
7953 GV *gv = cGVOPx_gv(tmpop);
7956 tmpop->op_private |= OPpEARLY_CV;
7960 namegv = CvANON(cv) ? gv : CvGV(cv);
7961 proto = SvPV(MUTABLE_SV(cv), len);
7962 proto_end = proto + len;
7967 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7968 if (o2->op_type == OP_CONST)
7969 o2->op_private &= ~OPpCONST_STRICT;
7970 else if (o2->op_type == OP_LIST) {
7971 OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
7972 if (sib && sib->op_type == OP_CONST)
7973 sib->op_private &= ~OPpCONST_STRICT;
7976 o->op_private |= (PL_hints & HINT_STRICT_REFS);
7977 if (PERLDB_SUB && PL_curstash != PL_debstash)
7978 o->op_private |= OPpENTERSUB_DB;
7979 while (o2 != cvop) {
7981 if (PL_madskills && o2->op_type == OP_STUB) {
7982 o2 = o2->op_sibling;
7985 if (PL_madskills && o2->op_type == OP_NULL)
7986 o3 = ((UNOP*)o2)->op_first;
7990 if (proto >= proto_end)
7991 return too_many_arguments(o, gv_ename(namegv));
7999 /* _ must be at the end */
8000 if (proto[1] && proto[1] != ';')
8015 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
8017 arg == 1 ? "block or sub {}" : "sub {}",
8018 gv_ename(namegv), o3);
8021 /* '*' allows any scalar type, including bareword */
8024 if (o3->op_type == OP_RV2GV)
8025 goto wrapref; /* autoconvert GLOB -> GLOBref */
8026 else if (o3->op_type == OP_CONST)
8027 o3->op_private &= ~OPpCONST_STRICT;
8028 else if (o3->op_type == OP_ENTERSUB) {
8029 /* accidental subroutine, revert to bareword */
8030 OP *gvop = ((UNOP*)o3)->op_first;
8031 if (gvop && gvop->op_type == OP_NULL) {
8032 gvop = ((UNOP*)gvop)->op_first;
8034 for (; gvop->op_sibling; gvop = gvop->op_sibling)
8037 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
8038 (gvop = ((UNOP*)gvop)->op_first) &&
8039 gvop->op_type == OP_GV)
8041 GV * const gv = cGVOPx_gv(gvop);
8042 OP * const sibling = o2->op_sibling;
8043 SV * const n = newSVpvs("");
8045 OP * const oldo2 = o2;
8049 gv_fullname4(n, gv, "", FALSE);
8050 o2 = newSVOP(OP_CONST, 0, n);
8051 op_getmad(oldo2,o2,'O');
8052 prev->op_sibling = o2;
8053 o2->op_sibling = sibling;
8069 if (contextclass++ == 0) {
8070 e = strchr(proto, ']');
8071 if (!e || e == proto)
8080 const char *p = proto;
8081 const char *const end = proto;
8083 while (*--p != '[') {}
8084 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
8086 gv_ename(namegv), o3);
8091 if (o3->op_type == OP_RV2GV)
8094 bad_type(arg, "symbol", gv_ename(namegv), o3);
8097 if (o3->op_type == OP_ENTERSUB)
8100 bad_type(arg, "subroutine entry", gv_ename(namegv),
8104 if (o3->op_type == OP_RV2SV ||
8105 o3->op_type == OP_PADSV ||
8106 o3->op_type == OP_HELEM ||
8107 o3->op_type == OP_AELEM)
8110 bad_type(arg, "scalar", gv_ename(namegv), o3);
8113 if (o3->op_type == OP_RV2AV ||
8114 o3->op_type == OP_PADAV)
8117 bad_type(arg, "array", gv_ename(namegv), o3);
8120 if (o3->op_type == OP_RV2HV ||
8121 o3->op_type == OP_PADHV)
8124 bad_type(arg, "hash", gv_ename(namegv), o3);
8129 OP* const sib = kid->op_sibling;
8130 kid->op_sibling = 0;
8131 o2 = newUNOP(OP_REFGEN, 0, kid);
8132 o2->op_sibling = sib;
8133 prev->op_sibling = o2;
8135 if (contextclass && e) {
8150 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
8151 gv_ename(namegv), SVfARG(cv));
8156 mod(o2, OP_ENTERSUB);
8158 o2 = o2->op_sibling;
8160 if (o2 == cvop && proto && *proto == '_') {
8161 /* generate an access to $_ */
8163 o2->op_sibling = prev->op_sibling;
8164 prev->op_sibling = o2; /* instead of cvop */
8166 if (proto && !optional && proto_end > proto &&
8167 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
8168 return too_few_arguments(o, gv_ename(namegv));
8171 OP * const oldo = o;
8175 o=newSVOP(OP_CONST, 0, newSViv(0));
8176 op_getmad(oldo,o,'O');
8182 Perl_ck_svconst(pTHX_ OP *o)
8184 PERL_ARGS_ASSERT_CK_SVCONST;
8185 PERL_UNUSED_CONTEXT;
8186 SvREADONLY_on(cSVOPo->op_sv);
8191 Perl_ck_chdir(pTHX_ OP *o)
8193 if (o->op_flags & OPf_KIDS) {
8194 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8196 if (kid && kid->op_type == OP_CONST &&
8197 (kid->op_private & OPpCONST_BARE))
8199 o->op_flags |= OPf_SPECIAL;
8200 kid->op_private &= ~OPpCONST_STRICT;
8207 Perl_ck_trunc(pTHX_ OP *o)
8209 PERL_ARGS_ASSERT_CK_TRUNC;
8211 if (o->op_flags & OPf_KIDS) {
8212 SVOP *kid = (SVOP*)cUNOPo->op_first;
8214 if (kid->op_type == OP_NULL)
8215 kid = (SVOP*)kid->op_sibling;
8216 if (kid && kid->op_type == OP_CONST &&
8217 (kid->op_private & OPpCONST_BARE))
8219 o->op_flags |= OPf_SPECIAL;
8220 kid->op_private &= ~OPpCONST_STRICT;
8227 Perl_ck_unpack(pTHX_ OP *o)
8229 OP *kid = cLISTOPo->op_first;
8231 PERL_ARGS_ASSERT_CK_UNPACK;
8233 if (kid->op_sibling) {
8234 kid = kid->op_sibling;
8235 if (!kid->op_sibling)
8236 kid->op_sibling = newDEFSVOP();
8242 Perl_ck_substr(pTHX_ OP *o)
8244 PERL_ARGS_ASSERT_CK_SUBSTR;
8247 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
8248 OP *kid = cLISTOPo->op_first;
8250 if (kid->op_type == OP_NULL)
8251 kid = kid->op_sibling;
8253 kid->op_flags |= OPf_MOD;
8260 Perl_ck_each(pTHX_ OP *o)
8263 OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
8265 PERL_ARGS_ASSERT_CK_EACH;
8268 if (kid->op_type == OP_PADAV || kid->op_type == OP_RV2AV) {
8269 const unsigned new_type = o->op_type == OP_EACH ? OP_AEACH
8270 : o->op_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
8271 o->op_type = new_type;
8272 o->op_ppaddr = PL_ppaddr[new_type];
8274 else if (!(kid->op_type == OP_PADHV || kid->op_type == OP_RV2HV
8275 || (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE)
8277 bad_type(1, "hash or array", PL_op_desc[o->op_type], kid);
8284 /* caller is supposed to assign the return to the
8285 container of the rep_op var */
8287 S_opt_scalarhv(pTHX_ OP *rep_op) {
8290 PERL_ARGS_ASSERT_OPT_SCALARHV;
8292 NewOp(1101, unop, 1, UNOP);
8293 unop->op_type = (OPCODE)OP_BOOLKEYS;
8294 unop->op_ppaddr = PL_ppaddr[OP_BOOLKEYS];
8295 unop->op_flags = (U8)(OPf_WANT_SCALAR | OPf_KIDS );
8296 unop->op_private = (U8)(1 | ((OPf_WANT_SCALAR | OPf_KIDS) >> 8));
8297 unop->op_first = rep_op;
8298 unop->op_next = rep_op->op_next;
8299 rep_op->op_next = (OP*)unop;
8300 rep_op->op_flags|=(OPf_REF | OPf_MOD);
8301 unop->op_sibling = rep_op->op_sibling;
8302 rep_op->op_sibling = NULL;
8303 /* unop->op_targ = pad_alloc(OP_BOOLKEYS, SVs_PADTMP); */
8304 if (rep_op->op_type == OP_PADHV) {
8305 rep_op->op_flags &= ~OPf_WANT_SCALAR;
8306 rep_op->op_flags |= OPf_WANT_LIST;
8311 /* A peephole optimizer. We visit the ops in the order they're to execute.
8312 * See the comments at the top of this file for more details about when
8313 * peep() is called */
8316 Perl_peep(pTHX_ register OP *o)
8319 register OP* oldop = NULL;
8321 if (!o || o->op_opt)
8325 SAVEVPTR(PL_curcop);
8326 for (; o; o = o->op_next) {
8329 /* By default, this op has now been optimised. A couple of cases below
8330 clear this again. */
8333 switch (o->op_type) {
8336 PL_curcop = ((COP*)o); /* for warnings */
8340 if (cSVOPo->op_private & OPpCONST_STRICT)
8341 no_bareword_allowed(o);
8344 case OP_METHOD_NAMED:
8345 /* Relocate sv to the pad for thread safety.
8346 * Despite being a "constant", the SV is written to,
8347 * for reference counts, sv_upgrade() etc. */
8349 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
8350 if (o->op_type != OP_METHOD_NAMED && SvPADTMP(cSVOPo->op_sv)) {
8351 /* If op_sv is already a PADTMP then it is being used by
8352 * some pad, so make a copy. */
8353 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
8354 SvREADONLY_on(PAD_SVl(ix));
8355 SvREFCNT_dec(cSVOPo->op_sv);
8357 else if (o->op_type != OP_METHOD_NAMED
8358 && cSVOPo->op_sv == &PL_sv_undef) {
8359 /* PL_sv_undef is hack - it's unsafe to store it in the
8360 AV that is the pad, because av_fetch treats values of
8361 PL_sv_undef as a "free" AV entry and will merrily
8362 replace them with a new SV, causing pad_alloc to think
8363 that this pad slot is free. (When, clearly, it is not)
8365 SvOK_off(PAD_SVl(ix));
8366 SvPADTMP_on(PAD_SVl(ix));
8367 SvREADONLY_on(PAD_SVl(ix));
8370 SvREFCNT_dec(PAD_SVl(ix));
8371 SvPADTMP_on(cSVOPo->op_sv);
8372 PAD_SETSV(ix, cSVOPo->op_sv);
8373 /* XXX I don't know how this isn't readonly already. */
8374 SvREADONLY_on(PAD_SVl(ix));
8376 cSVOPo->op_sv = NULL;
8383 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
8384 if (o->op_next->op_private & OPpTARGET_MY) {
8385 if (o->op_flags & OPf_STACKED) /* chained concats */
8386 break; /* ignore_optimization */
8388 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
8389 o->op_targ = o->op_next->op_targ;
8390 o->op_next->op_targ = 0;
8391 o->op_private |= OPpTARGET_MY;
8394 op_null(o->op_next);
8398 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
8399 break; /* Scalar stub must produce undef. List stub is noop */
8403 if (o->op_targ == OP_NEXTSTATE
8404 || o->op_targ == OP_DBSTATE)
8406 PL_curcop = ((COP*)o);
8408 /* XXX: We avoid setting op_seq here to prevent later calls
8409 to peep() from mistakenly concluding that optimisation
8410 has already occurred. This doesn't fix the real problem,
8411 though (See 20010220.007). AMS 20010719 */
8412 /* op_seq functionality is now replaced by op_opt */
8419 if (oldop && o->op_next) {
8420 oldop->op_next = o->op_next;
8428 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
8429 OP* const pop = (o->op_type == OP_PADAV) ?
8430 o->op_next : o->op_next->op_next;
8432 if (pop && pop->op_type == OP_CONST &&
8433 ((PL_op = pop->op_next)) &&
8434 pop->op_next->op_type == OP_AELEM &&
8435 !(pop->op_next->op_private &
8436 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
8437 (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
8442 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
8443 no_bareword_allowed(pop);
8444 if (o->op_type == OP_GV)
8445 op_null(o->op_next);
8446 op_null(pop->op_next);
8448 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
8449 o->op_next = pop->op_next->op_next;
8450 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
8451 o->op_private = (U8)i;
8452 if (o->op_type == OP_GV) {
8457 o->op_flags |= OPf_SPECIAL;
8458 o->op_type = OP_AELEMFAST;
8463 if (o->op_next->op_type == OP_RV2SV) {
8464 if (!(o->op_next->op_private & OPpDEREF)) {
8465 op_null(o->op_next);
8466 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
8468 o->op_next = o->op_next->op_next;
8469 o->op_type = OP_GVSV;
8470 o->op_ppaddr = PL_ppaddr[OP_GVSV];
8473 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
8474 GV * const gv = cGVOPo_gv;
8475 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
8476 /* XXX could check prototype here instead of just carping */
8477 SV * const sv = sv_newmortal();
8478 gv_efullname3(sv, gv, NULL);
8479 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
8480 "%"SVf"() called too early to check prototype",
8484 else if (o->op_next->op_type == OP_READLINE
8485 && o->op_next->op_next->op_type == OP_CONCAT
8486 && (o->op_next->op_next->op_flags & OPf_STACKED))
8488 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
8489 o->op_type = OP_RCATLINE;
8490 o->op_flags |= OPf_STACKED;
8491 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
8492 op_null(o->op_next->op_next);
8493 op_null(o->op_next);
8503 fop = cUNOP->op_first;
8511 fop = cLOGOP->op_first;
8512 sop = fop->op_sibling;
8513 while (cLOGOP->op_other->op_type == OP_NULL)
8514 cLOGOP->op_other = cLOGOP->op_other->op_next;
8515 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
8519 if ((fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
8521 (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV)
8526 if (!(nop->op_flags && OPf_WANT_VOID)) {
8527 while (nop && nop->op_next) {
8528 switch (nop->op_next->op_type) {
8533 lop = nop = nop->op_next;
8544 if (lop->op_flags && OPf_WANT_VOID) {
8545 if (fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
8546 cLOGOP->op_first = opt_scalarhv(fop);
8547 if (sop && (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV))
8548 cLOGOP->op_first->op_sibling = opt_scalarhv(sop);
8564 while (cLOGOP->op_other->op_type == OP_NULL)
8565 cLOGOP->op_other = cLOGOP->op_other->op_next;
8566 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
8571 while (cLOOP->op_redoop->op_type == OP_NULL)
8572 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
8573 peep(cLOOP->op_redoop);
8574 while (cLOOP->op_nextop->op_type == OP_NULL)
8575 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
8576 peep(cLOOP->op_nextop);
8577 while (cLOOP->op_lastop->op_type == OP_NULL)
8578 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
8579 peep(cLOOP->op_lastop);
8583 assert(!(cPMOP->op_pmflags & PMf_ONCE));
8584 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
8585 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
8586 cPMOP->op_pmstashstartu.op_pmreplstart
8587 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
8588 peep(cPMOP->op_pmstashstartu.op_pmreplstart);
8592 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
8593 && ckWARN(WARN_SYNTAX))
8595 if (o->op_next->op_sibling) {
8596 const OPCODE type = o->op_next->op_sibling->op_type;
8597 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
8598 const line_t oldline = CopLINE(PL_curcop);
8599 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
8600 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8601 "Statement unlikely to be reached");
8602 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8603 "\t(Maybe you meant system() when you said exec()?)\n");
8604 CopLINE_set(PL_curcop, oldline);
8615 const char *key = NULL;
8618 if (((BINOP*)o)->op_last->op_type != OP_CONST)
8621 /* Make the CONST have a shared SV */
8622 svp = cSVOPx_svp(((BINOP*)o)->op_last);
8623 if (!SvFAKE(sv = *svp) || !SvREADONLY(sv)) {
8624 key = SvPV_const(sv, keylen);
8625 lexname = newSVpvn_share(key,
8626 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
8632 if ((o->op_private & (OPpLVAL_INTRO)))
8635 rop = (UNOP*)((BINOP*)o)->op_first;
8636 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
8638 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
8639 if (!SvPAD_TYPED(lexname))
8641 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8642 if (!fields || !GvHV(*fields))
8644 key = SvPV_const(*svp, keylen);
8645 if (!hv_fetch(GvHV(*fields), key,
8646 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8648 Perl_croak(aTHX_ "No such class field \"%s\" "
8649 "in variable %s of type %s",
8650 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
8663 SVOP *first_key_op, *key_op;
8665 if ((o->op_private & (OPpLVAL_INTRO))
8666 /* I bet there's always a pushmark... */
8667 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
8668 /* hmmm, no optimization if list contains only one key. */
8670 rop = (UNOP*)((LISTOP*)o)->op_last;
8671 if (rop->op_type != OP_RV2HV)
8673 if (rop->op_first->op_type == OP_PADSV)
8674 /* @$hash{qw(keys here)} */
8675 rop = (UNOP*)rop->op_first;
8677 /* @{$hash}{qw(keys here)} */
8678 if (rop->op_first->op_type == OP_SCOPE
8679 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
8681 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
8687 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
8688 if (!SvPAD_TYPED(lexname))
8690 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8691 if (!fields || !GvHV(*fields))
8693 /* Again guessing that the pushmark can be jumped over.... */
8694 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
8695 ->op_first->op_sibling;
8696 for (key_op = first_key_op; key_op;
8697 key_op = (SVOP*)key_op->op_sibling) {
8698 if (key_op->op_type != OP_CONST)
8700 svp = cSVOPx_svp(key_op);
8701 key = SvPV_const(*svp, keylen);
8702 if (!hv_fetch(GvHV(*fields), key,
8703 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8705 Perl_croak(aTHX_ "No such class field \"%s\" "
8706 "in variable %s of type %s",
8707 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
8714 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
8718 /* check that RHS of sort is a single plain array */
8719 OP *oright = cUNOPo->op_first;
8720 if (!oright || oright->op_type != OP_PUSHMARK)
8723 /* reverse sort ... can be optimised. */
8724 if (!cUNOPo->op_sibling) {
8725 /* Nothing follows us on the list. */
8726 OP * const reverse = o->op_next;
8728 if (reverse->op_type == OP_REVERSE &&
8729 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
8730 OP * const pushmark = cUNOPx(reverse)->op_first;
8731 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
8732 && (cUNOPx(pushmark)->op_sibling == o)) {
8733 /* reverse -> pushmark -> sort */
8734 o->op_private |= OPpSORT_REVERSE;
8736 pushmark->op_next = oright->op_next;
8742 /* make @a = sort @a act in-place */
8744 oright = cUNOPx(oright)->op_sibling;
8747 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
8748 oright = cUNOPx(oright)->op_sibling;
8752 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
8753 || oright->op_next != o
8754 || (oright->op_private & OPpLVAL_INTRO)
8758 /* o2 follows the chain of op_nexts through the LHS of the
8759 * assign (if any) to the aassign op itself */
8761 if (!o2 || o2->op_type != OP_NULL)
8764 if (!o2 || o2->op_type != OP_PUSHMARK)
8767 if (o2 && o2->op_type == OP_GV)
8770 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
8771 || (o2->op_private & OPpLVAL_INTRO)
8776 if (!o2 || o2->op_type != OP_NULL)
8779 if (!o2 || o2->op_type != OP_AASSIGN
8780 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
8783 /* check that the sort is the first arg on RHS of assign */
8785 o2 = cUNOPx(o2)->op_first;
8786 if (!o2 || o2->op_type != OP_NULL)
8788 o2 = cUNOPx(o2)->op_first;
8789 if (!o2 || o2->op_type != OP_PUSHMARK)
8791 if (o2->op_sibling != o)
8794 /* check the array is the same on both sides */
8795 if (oleft->op_type == OP_RV2AV) {
8796 if (oright->op_type != OP_RV2AV
8797 || !cUNOPx(oright)->op_first
8798 || cUNOPx(oright)->op_first->op_type != OP_GV
8799 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
8800 cGVOPx_gv(cUNOPx(oright)->op_first)
8804 else if (oright->op_type != OP_PADAV
8805 || oright->op_targ != oleft->op_targ
8809 /* transfer MODishness etc from LHS arg to RHS arg */
8810 oright->op_flags = oleft->op_flags;
8811 o->op_private |= OPpSORT_INPLACE;
8813 /* excise push->gv->rv2av->null->aassign */
8814 o2 = o->op_next->op_next;
8815 op_null(o2); /* PUSHMARK */
8817 if (o2->op_type == OP_GV) {
8818 op_null(o2); /* GV */
8821 op_null(o2); /* RV2AV or PADAV */
8822 o2 = o2->op_next->op_next;
8823 op_null(o2); /* AASSIGN */
8825 o->op_next = o2->op_next;
8831 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
8833 LISTOP *enter, *exlist;
8835 enter = (LISTOP *) o->op_next;
8838 if (enter->op_type == OP_NULL) {
8839 enter = (LISTOP *) enter->op_next;
8843 /* for $a (...) will have OP_GV then OP_RV2GV here.
8844 for (...) just has an OP_GV. */
8845 if (enter->op_type == OP_GV) {
8846 gvop = (OP *) enter;
8847 enter = (LISTOP *) enter->op_next;
8850 if (enter->op_type == OP_RV2GV) {
8851 enter = (LISTOP *) enter->op_next;
8857 if (enter->op_type != OP_ENTERITER)
8860 iter = enter->op_next;
8861 if (!iter || iter->op_type != OP_ITER)
8864 expushmark = enter->op_first;
8865 if (!expushmark || expushmark->op_type != OP_NULL
8866 || expushmark->op_targ != OP_PUSHMARK)
8869 exlist = (LISTOP *) expushmark->op_sibling;
8870 if (!exlist || exlist->op_type != OP_NULL
8871 || exlist->op_targ != OP_LIST)
8874 if (exlist->op_last != o) {
8875 /* Mmm. Was expecting to point back to this op. */
8878 theirmark = exlist->op_first;
8879 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
8882 if (theirmark->op_sibling != o) {
8883 /* There's something between the mark and the reverse, eg
8884 for (1, reverse (...))
8889 ourmark = ((LISTOP *)o)->op_first;
8890 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
8893 ourlast = ((LISTOP *)o)->op_last;
8894 if (!ourlast || ourlast->op_next != o)
8897 rv2av = ourmark->op_sibling;
8898 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
8899 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
8900 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
8901 /* We're just reversing a single array. */
8902 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
8903 enter->op_flags |= OPf_STACKED;
8906 /* We don't have control over who points to theirmark, so sacrifice
8908 theirmark->op_next = ourmark->op_next;
8909 theirmark->op_flags = ourmark->op_flags;
8910 ourlast->op_next = gvop ? gvop : (OP *) enter;
8913 enter->op_private |= OPpITER_REVERSED;
8914 iter->op_private |= OPpITER_REVERSED;
8921 UNOP *refgen, *rv2cv;
8924 if ((o->op_flags & OPf_WANT) != OPf_WANT_VOID)
8927 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
8930 rv2gv = ((BINOP *)o)->op_last;
8931 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
8934 refgen = (UNOP *)((BINOP *)o)->op_first;
8936 if (!refgen || refgen->op_type != OP_REFGEN)
8939 exlist = (LISTOP *)refgen->op_first;
8940 if (!exlist || exlist->op_type != OP_NULL
8941 || exlist->op_targ != OP_LIST)
8944 if (exlist->op_first->op_type != OP_PUSHMARK)
8947 rv2cv = (UNOP*)exlist->op_last;
8949 if (rv2cv->op_type != OP_RV2CV)
8952 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
8953 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
8954 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
8956 o->op_private |= OPpASSIGN_CV_TO_GV;
8957 rv2gv->op_private |= OPpDONT_INIT_GV;
8958 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
8966 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
8967 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
8977 Perl_custom_op_name(pTHX_ const OP* o)
8980 const IV index = PTR2IV(o->op_ppaddr);
8984 PERL_ARGS_ASSERT_CUSTOM_OP_NAME;
8986 if (!PL_custom_op_names) /* This probably shouldn't happen */
8987 return (char *)PL_op_name[OP_CUSTOM];
8989 keysv = sv_2mortal(newSViv(index));
8991 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
8993 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
8995 return SvPV_nolen(HeVAL(he));
8999 Perl_custom_op_desc(pTHX_ const OP* o)
9002 const IV index = PTR2IV(o->op_ppaddr);
9006 PERL_ARGS_ASSERT_CUSTOM_OP_DESC;
9008 if (!PL_custom_op_descs)
9009 return (char *)PL_op_desc[OP_CUSTOM];
9011 keysv = sv_2mortal(newSViv(index));
9013 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
9015 return (char *)PL_op_desc[OP_CUSTOM];
9017 return SvPV_nolen(HeVAL(he));
9022 /* Efficient sub that returns a constant scalar value. */
9024 const_sv_xsub(pTHX_ CV* cv)
9028 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
9032 /* diag_listed_as: SKIPME */
9033 Perl_croak(aTHX_ "usage: %s::%s()",
9034 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
9047 * c-indentation-style: bsd
9049 * indent-tabs-mode: t
9052 * ex: set ts=8 sts=4 sw=4 noet: