3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * 'You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
13 * our Mr. Bilbo's first cousin on the mother's side (her mother being the
14 * youngest of the Old Took's daughters); and Mr. Drogo was his second
15 * cousin. So Mr. Frodo is his first *and* second cousin, once removed
16 * either way, as the saying is, if you follow me.' --the Gaffer
18 * [p.23 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
21 /* This file contains the functions that create, manipulate and optimize
22 * the OP structures that hold a compiled perl program.
24 * A Perl program is compiled into a tree of OPs. Each op contains
25 * structural pointers (eg to its siblings and the next op in the
26 * execution sequence), a pointer to the function that would execute the
27 * op, plus any data specific to that op. For example, an OP_CONST op
28 * points to the pp_const() function and to an SV containing the constant
29 * value. When pp_const() is executed, its job is to push that SV onto the
32 * OPs are mainly created by the newFOO() functions, which are mainly
33 * called from the parser (in perly.y) as the code is parsed. For example
34 * the Perl code $a + $b * $c would cause the equivalent of the following
35 * to be called (oversimplifying a bit):
37 * newBINOP(OP_ADD, flags,
39 * newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
42 * Note that during the build of miniperl, a temporary copy of this file
43 * is made, called opmini.c.
47 Perl's compiler is essentially a 3-pass compiler with interleaved phases:
51 An execution-order pass
53 The bottom-up pass is represented by all the "newOP" routines and
54 the ck_ routines. The bottom-upness is actually driven by yacc.
55 So at the point that a ck_ routine fires, we have no idea what the
56 context is, either upward in the syntax tree, or either forward or
57 backward in the execution order. (The bottom-up parser builds that
58 part of the execution order it knows about, but if you follow the "next"
59 links around, you'll find it's actually a closed loop through the
62 Whenever the bottom-up parser gets to a node that supplies context to
63 its components, it invokes that portion of the top-down pass that applies
64 to that part of the subtree (and marks the top node as processed, so
65 if a node further up supplies context, it doesn't have to take the
66 plunge again). As a particular subcase of this, as the new node is
67 built, it takes all the closed execution loops of its subcomponents
68 and links them into a new closed loop for the higher level node. But
69 it's still not the real execution order.
71 The actual execution order is not known till we get a grammar reduction
72 to a top-level unit like a subroutine or file that will be called by
73 "name" rather than via a "next" pointer. At that point, we can call
74 into peep() to do that code's portion of the 3rd pass. It has to be
75 recursive, but it's recursive on basic blocks, not on tree nodes.
78 /* To implement user lexical pragmas, there needs to be a way at run time to
79 get the compile time state of %^H for that block. Storing %^H in every
80 block (or even COP) would be very expensive, so a different approach is
81 taken. The (running) state of %^H is serialised into a tree of HE-like
82 structs. Stores into %^H are chained onto the current leaf as a struct
83 refcounted_he * with the key and the value. Deletes from %^H are saved
84 with a value of PL_sv_placeholder. The state of %^H at any point can be
85 turned back into a regular HV by walking back up the tree from that point's
86 leaf, ignoring any key you've already seen (placeholder or not), storing
87 the rest into the HV structure, then removing the placeholders. Hence
88 memory is only used to store the %^H deltas from the enclosing COP, rather
89 than the entire %^H on each COP.
91 To cause actions on %^H to write out the serialisation records, it has
92 magic type 'H'. This magic (itself) does nothing, but its presence causes
93 the values to gain magic type 'h', which has entries for set and clear.
94 C<Perl_magic_sethint> updates C<PL_compiling.cop_hints_hash> with a store
95 record, with deletes written by C<Perl_magic_clearhint>. C<SAVEHINTS>
96 saves the current C<PL_compiling.cop_hints_hash> on the save stack, so that
97 it will be correctly restored when any inner compiling scope is exited.
103 #include "keywords.h"
105 #define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
107 #if defined(PL_OP_SLAB_ALLOC)
109 #ifdef PERL_DEBUG_READONLY_OPS
110 # define PERL_SLAB_SIZE 4096
111 # include <sys/mman.h>
114 #ifndef PERL_SLAB_SIZE
115 #define PERL_SLAB_SIZE 2048
119 Perl_Slab_Alloc(pTHX_ size_t sz)
123 * To make incrementing use count easy PL_OpSlab is an I32 *
124 * To make inserting the link to slab PL_OpPtr is I32 **
125 * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
126 * Add an overhead for pointer to slab and round up as a number of pointers
128 sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
129 if ((PL_OpSpace -= sz) < 0) {
130 #ifdef PERL_DEBUG_READONLY_OPS
131 /* We need to allocate chunk by chunk so that we can control the VM
133 PL_OpPtr = (I32**) mmap(0, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE,
134 MAP_ANON|MAP_PRIVATE, -1, 0);
136 DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
137 (unsigned long) PERL_SLAB_SIZE*sizeof(I32*),
139 if(PL_OpPtr == MAP_FAILED) {
140 perror("mmap failed");
145 PL_OpPtr = (I32 **) PerlMemShared_calloc(PERL_SLAB_SIZE,sizeof(I32*));
150 /* We reserve the 0'th I32 sized chunk as a use count */
151 PL_OpSlab = (I32 *) PL_OpPtr;
152 /* Reduce size by the use count word, and by the size we need.
153 * Latter is to mimic the '-=' in the if() above
155 PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
156 /* Allocation pointer starts at the top.
157 Theory: because we build leaves before trunk allocating at end
158 means that at run time access is cache friendly upward
160 PL_OpPtr += PERL_SLAB_SIZE;
162 #ifdef PERL_DEBUG_READONLY_OPS
163 /* We remember this slab. */
164 /* This implementation isn't efficient, but it is simple. */
165 PL_slabs = (I32**) realloc(PL_slabs, sizeof(I32**) * (PL_slab_count + 1));
166 PL_slabs[PL_slab_count++] = PL_OpSlab;
167 DEBUG_m(PerlIO_printf(Perl_debug_log, "Allocate %p\n", PL_OpSlab));
170 assert( PL_OpSpace >= 0 );
171 /* Move the allocation pointer down */
173 assert( PL_OpPtr > (I32 **) PL_OpSlab );
174 *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */
175 (*PL_OpSlab)++; /* Increment use count of slab */
176 assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
177 assert( *PL_OpSlab > 0 );
178 return (void *)(PL_OpPtr + 1);
181 #ifdef PERL_DEBUG_READONLY_OPS
183 Perl_pending_Slabs_to_ro(pTHX) {
184 /* Turn all the allocated op slabs read only. */
185 U32 count = PL_slab_count;
186 I32 **const slabs = PL_slabs;
188 /* Reset the array of pending OP slabs, as we're about to turn this lot
189 read only. Also, do it ahead of the loop in case the warn triggers,
190 and a warn handler has an eval */
195 /* Force a new slab for any further allocation. */
199 void *const start = slabs[count];
200 const size_t size = PERL_SLAB_SIZE* sizeof(I32*);
201 if(mprotect(start, size, PROT_READ)) {
202 Perl_warn(aTHX_ "mprotect for %p %lu failed with %d",
203 start, (unsigned long) size, errno);
211 S_Slab_to_rw(pTHX_ void *op)
213 I32 * const * const ptr = (I32 **) op;
214 I32 * const slab = ptr[-1];
216 PERL_ARGS_ASSERT_SLAB_TO_RW;
218 assert( ptr-1 > (I32 **) slab );
219 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
221 if(mprotect(slab, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE)) {
222 Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d",
223 slab, (unsigned long) PERL_SLAB_SIZE*sizeof(I32*), errno);
228 Perl_op_refcnt_inc(pTHX_ OP *o)
239 Perl_op_refcnt_dec(pTHX_ OP *o)
241 PERL_ARGS_ASSERT_OP_REFCNT_DEC;
246 # define Slab_to_rw(op)
250 Perl_Slab_Free(pTHX_ void *op)
252 I32 * const * const ptr = (I32 **) op;
253 I32 * const slab = ptr[-1];
254 PERL_ARGS_ASSERT_SLAB_FREE;
255 assert( ptr-1 > (I32 **) slab );
256 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
259 if (--(*slab) == 0) {
261 # define PerlMemShared PerlMem
264 #ifdef PERL_DEBUG_READONLY_OPS
265 U32 count = PL_slab_count;
266 /* Need to remove this slab from our list of slabs */
269 if (PL_slabs[count] == slab) {
271 /* Found it. Move the entry at the end to overwrite it. */
272 DEBUG_m(PerlIO_printf(Perl_debug_log,
273 "Deallocate %p by moving %p from %lu to %lu\n",
275 PL_slabs[PL_slab_count - 1],
276 PL_slab_count, count));
277 PL_slabs[count] = PL_slabs[--PL_slab_count];
278 /* Could realloc smaller at this point, but probably not
280 if(munmap(slab, PERL_SLAB_SIZE*sizeof(I32*))) {
281 perror("munmap failed");
289 PerlMemShared_free(slab);
291 if (slab == PL_OpSlab) {
298 * In the following definition, the ", (OP*)0" is just to make the compiler
299 * think the expression is of the right type: croak actually does a Siglongjmp.
301 #define CHECKOP(type,o) \
302 ((PL_op_mask && PL_op_mask[type]) \
303 ? ( op_free((OP*)o), \
304 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
306 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
308 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
311 S_gv_ename(pTHX_ GV *gv)
313 SV* const tmpsv = sv_newmortal();
315 PERL_ARGS_ASSERT_GV_ENAME;
317 gv_efullname3(tmpsv, gv, NULL);
318 return SvPV_nolen_const(tmpsv);
322 S_no_fh_allowed(pTHX_ OP *o)
324 PERL_ARGS_ASSERT_NO_FH_ALLOWED;
326 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
332 S_too_few_arguments(pTHX_ OP *o, const char *name)
334 PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS;
336 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
341 S_too_many_arguments(pTHX_ OP *o, const char *name)
343 PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS;
345 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
350 S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid)
352 PERL_ARGS_ASSERT_BAD_TYPE;
354 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
355 (int)n, name, t, OP_DESC(kid)));
359 S_no_bareword_allowed(pTHX_ const OP *o)
361 PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
364 return; /* various ok barewords are hidden in extra OP_NULL */
365 qerror(Perl_mess(aTHX_
366 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
370 /* "register" allocation */
373 Perl_allocmy(pTHX_ const char *const name)
377 const bool is_our = (PL_parser->in_my == KEY_our);
379 PERL_ARGS_ASSERT_ALLOCMY;
381 /* complain about "my $<special_var>" etc etc */
385 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
386 (name[1] == '_' && (*name == '$' || name[2]))))
388 /* name[2] is true if strlen(name) > 2 */
389 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
390 yyerror(Perl_form(aTHX_ "Can't use global %c^%c%s in \"%s\"",
391 name[0], toCTRL(name[1]), name + 2,
392 PL_parser->in_my == KEY_state ? "state" : "my"));
394 yyerror(Perl_form(aTHX_ "Can't use global %s in \"%s\"",name,
395 PL_parser->in_my == KEY_state ? "state" : "my"));
399 /* check for duplicate declaration */
400 pad_check_dup(name, is_our, (PL_curstash ? PL_curstash : PL_defstash));
402 /* allocate a spare slot and store the name in that slot */
404 off = pad_add_name(name,
405 PL_parser->in_my_stash,
407 /* $_ is always in main::, even with our */
408 ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
412 PL_parser->in_my == KEY_state
414 /* anon sub prototypes contains state vars should always be cloned,
415 * otherwise the state var would be shared between anon subs */
417 if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
418 CvCLONE_on(PL_compcv);
423 /* free the body of an op without examining its contents.
424 * Always use this rather than FreeOp directly */
427 S_op_destroy(pTHX_ OP *o)
429 if (o->op_latefree) {
437 # define forget_pmop(a,b) S_forget_pmop(aTHX_ a,b)
439 # define forget_pmop(a,b) S_forget_pmop(aTHX_ a)
445 Perl_op_free(pTHX_ OP *o)
452 if (o->op_latefreed) {
459 if (o->op_private & OPpREFCOUNTED) {
470 refcnt = OpREFCNT_dec(o);
473 /* Need to find and remove any pattern match ops from the list
474 we maintain for reset(). */
475 find_and_forget_pmops(o);
485 if (o->op_flags & OPf_KIDS) {
486 register OP *kid, *nextkid;
487 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
488 nextkid = kid->op_sibling; /* Get before next freeing kid */
493 #ifdef PERL_DEBUG_READONLY_OPS
497 /* COP* is not cleared by op_clear() so that we may track line
498 * numbers etc even after null() */
499 if (type == OP_NEXTSTATE || type == OP_DBSTATE
500 || (type == OP_NULL /* the COP might have been null'ed */
501 && ((OPCODE)o->op_targ == OP_NEXTSTATE
502 || (OPCODE)o->op_targ == OP_DBSTATE))) {
507 type = (OPCODE)o->op_targ;
510 if (o->op_latefree) {
516 #ifdef DEBUG_LEAKING_SCALARS
523 Perl_op_clear(pTHX_ OP *o)
528 PERL_ARGS_ASSERT_OP_CLEAR;
531 /* if (o->op_madprop && o->op_madprop->mad_next)
533 /* FIXME for MAD - if I uncomment these two lines t/op/pack.t fails with
534 "modification of a read only value" for a reason I can't fathom why.
535 It's the "" stringification of $_, where $_ was set to '' in a foreach
536 loop, but it defies simplification into a small test case.
537 However, commenting them out has caused ext/List/Util/t/weak.t to fail
540 mad_free(o->op_madprop);
546 switch (o->op_type) {
547 case OP_NULL: /* Was holding old type, if any. */
548 if (PL_madskills && o->op_targ != OP_NULL) {
549 o->op_type = (Optype)o->op_targ;
553 case OP_ENTEREVAL: /* Was holding hints. */
557 if (!(o->op_flags & OPf_REF)
558 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
564 if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
565 /* not an OP_PADAV replacement */
567 if (cPADOPo->op_padix > 0) {
568 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
569 * may still exist on the pad */
570 pad_swipe(cPADOPo->op_padix, TRUE);
571 cPADOPo->op_padix = 0;
574 SvREFCNT_dec(cSVOPo->op_sv);
575 cSVOPo->op_sv = NULL;
579 case OP_METHOD_NAMED:
582 SvREFCNT_dec(cSVOPo->op_sv);
583 cSVOPo->op_sv = NULL;
586 Even if op_clear does a pad_free for the target of the op,
587 pad_free doesn't actually remove the sv that exists in the pad;
588 instead it lives on. This results in that it could be reused as
589 a target later on when the pad was reallocated.
592 pad_swipe(o->op_targ,1);
601 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
605 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
607 if (cPADOPo->op_padix > 0) {
608 pad_swipe(cPADOPo->op_padix, TRUE);
609 cPADOPo->op_padix = 0;
612 SvREFCNT_dec(cSVOPo->op_sv);
613 cSVOPo->op_sv = NULL;
617 PerlMemShared_free(cPVOPo->op_pv);
618 cPVOPo->op_pv = NULL;
622 op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
626 if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
627 /* No GvIN_PAD_off here, because other references may still
628 * exist on the pad */
629 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
632 SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
638 forget_pmop(cPMOPo, 1);
639 cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
640 /* we use the same protection as the "SAFE" version of the PM_ macros
641 * here since sv_clean_all might release some PMOPs
642 * after PL_regex_padav has been cleared
643 * and the clearing of PL_regex_padav needs to
644 * happen before sv_clean_all
647 if(PL_regex_pad) { /* We could be in destruction */
648 const IV offset = (cPMOPo)->op_pmoffset;
649 ReREFCNT_dec(PM_GETRE(cPMOPo));
650 PL_regex_pad[offset] = &PL_sv_undef;
651 sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
655 ReREFCNT_dec(PM_GETRE(cPMOPo));
656 PM_SETRE(cPMOPo, NULL);
662 if (o->op_targ > 0) {
663 pad_free(o->op_targ);
669 S_cop_free(pTHX_ COP* cop)
671 PERL_ARGS_ASSERT_COP_FREE;
675 if (! specialWARN(cop->cop_warnings))
676 PerlMemShared_free(cop->cop_warnings);
677 Perl_refcounted_he_free(aTHX_ cop->cop_hints_hash);
681 S_forget_pmop(pTHX_ PMOP *const o
687 HV * const pmstash = PmopSTASH(o);
689 PERL_ARGS_ASSERT_FORGET_PMOP;
691 if (pmstash && !SvIS_FREED(pmstash)) {
692 MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
694 PMOP **const array = (PMOP**) mg->mg_ptr;
695 U32 count = mg->mg_len / sizeof(PMOP**);
700 /* Found it. Move the entry at the end to overwrite it. */
701 array[i] = array[--count];
702 mg->mg_len = count * sizeof(PMOP**);
703 /* Could realloc smaller at this point always, but probably
704 not worth it. Probably worth free()ing if we're the
707 Safefree(mg->mg_ptr);
724 S_find_and_forget_pmops(pTHX_ OP *o)
726 PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
728 if (o->op_flags & OPf_KIDS) {
729 OP *kid = cUNOPo->op_first;
731 switch (kid->op_type) {
736 forget_pmop((PMOP*)kid, 0);
738 find_and_forget_pmops(kid);
739 kid = kid->op_sibling;
745 Perl_op_null(pTHX_ OP *o)
749 PERL_ARGS_ASSERT_OP_NULL;
751 if (o->op_type == OP_NULL)
755 o->op_targ = o->op_type;
756 o->op_type = OP_NULL;
757 o->op_ppaddr = PL_ppaddr[OP_NULL];
761 Perl_op_refcnt_lock(pTHX)
769 Perl_op_refcnt_unlock(pTHX)
776 /* Contextualizers */
778 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
781 S_linklist(pTHX_ OP *o)
785 PERL_ARGS_ASSERT_LINKLIST;
790 /* establish postfix order */
791 first = cUNOPo->op_first;
794 o->op_next = LINKLIST(first);
797 if (kid->op_sibling) {
798 kid->op_next = LINKLIST(kid->op_sibling);
799 kid = kid->op_sibling;
813 S_scalarkids(pTHX_ OP *o)
815 if (o && o->op_flags & OPf_KIDS) {
817 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
824 S_scalarboolean(pTHX_ OP *o)
828 PERL_ARGS_ASSERT_SCALARBOOLEAN;
830 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
831 if (ckWARN(WARN_SYNTAX)) {
832 const line_t oldline = CopLINE(PL_curcop);
834 if (PL_parser && PL_parser->copline != NOLINE)
835 CopLINE_set(PL_curcop, PL_parser->copline);
836 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
837 CopLINE_set(PL_curcop, oldline);
844 Perl_scalar(pTHX_ OP *o)
849 /* assumes no premature commitment */
850 if (!o || (PL_parser && PL_parser->error_count)
851 || (o->op_flags & OPf_WANT)
852 || o->op_type == OP_RETURN)
857 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
859 switch (o->op_type) {
861 scalar(cBINOPo->op_first);
866 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
870 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
871 if (!kPMOP->op_pmreplrootu.op_pmreplroot)
872 deprecate_old("implicit split to @_");
880 if (o->op_flags & OPf_KIDS) {
881 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
887 kid = cLISTOPo->op_first;
889 while ((kid = kid->op_sibling)) {
895 PL_curcop = &PL_compiling;
900 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
906 PL_curcop = &PL_compiling;
909 if (ckWARN(WARN_VOID))
910 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
917 Perl_scalarvoid(pTHX_ OP *o)
921 const char* useless = NULL;
925 PERL_ARGS_ASSERT_SCALARVOID;
927 /* trailing mad null ops don't count as "there" for void processing */
929 o->op_type != OP_NULL &&
931 o->op_sibling->op_type == OP_NULL)
934 for (sib = o->op_sibling;
935 sib && sib->op_type == OP_NULL;
936 sib = sib->op_sibling) ;
942 if (o->op_type == OP_NEXTSTATE
943 || o->op_type == OP_DBSTATE
944 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
945 || o->op_targ == OP_DBSTATE)))
946 PL_curcop = (COP*)o; /* for warning below */
948 /* assumes no premature commitment */
949 want = o->op_flags & OPf_WANT;
950 if ((want && want != OPf_WANT_SCALAR)
951 || (PL_parser && PL_parser->error_count)
952 || o->op_type == OP_RETURN)
957 if ((o->op_private & OPpTARGET_MY)
958 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
960 return scalar(o); /* As if inside SASSIGN */
963 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
965 switch (o->op_type) {
967 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
971 if (o->op_flags & OPf_STACKED)
975 if (o->op_private == 4)
1018 case OP_GETSOCKNAME:
1019 case OP_GETPEERNAME:
1024 case OP_GETPRIORITY:
1048 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1049 /* Otherwise it's "Useless use of grep iterator" */
1050 useless = OP_DESC(o);
1054 kid = cUNOPo->op_first;
1055 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1056 kid->op_type != OP_TRANS) {
1059 useless = "negative pattern binding (!~)";
1066 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1067 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1068 useless = "a variable";
1073 if (cSVOPo->op_private & OPpCONST_STRICT)
1074 no_bareword_allowed(o);
1076 if (ckWARN(WARN_VOID)) {
1078 SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_
1079 "a constant (%"SVf")", sv));
1080 useless = SvPV_nolen(msv);
1083 useless = "a constant (undef)";
1084 if (o->op_private & OPpCONST_ARYBASE)
1086 /* don't warn on optimised away booleans, eg
1087 * use constant Foo, 5; Foo || print; */
1088 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1090 /* the constants 0 and 1 are permitted as they are
1091 conventionally used as dummies in constructs like
1092 1 while some_condition_with_side_effects; */
1093 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1095 else if (SvPOK(sv)) {
1096 /* perl4's way of mixing documentation and code
1097 (before the invention of POD) was based on a
1098 trick to mix nroff and perl code. The trick was
1099 built upon these three nroff macros being used in
1100 void context. The pink camel has the details in
1101 the script wrapman near page 319. */
1102 const char * const maybe_macro = SvPVX_const(sv);
1103 if (strnEQ(maybe_macro, "di", 2) ||
1104 strnEQ(maybe_macro, "ds", 2) ||
1105 strnEQ(maybe_macro, "ig", 2))
1110 op_null(o); /* don't execute or even remember it */
1114 o->op_type = OP_PREINC; /* pre-increment is faster */
1115 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1119 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1120 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1124 o->op_type = OP_I_PREINC; /* pre-increment is faster */
1125 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1129 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
1130 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1135 kid = cLOGOPo->op_first;
1136 if (kid->op_type == OP_NOT
1137 && (kid->op_flags & OPf_KIDS)
1139 if (o->op_type == OP_AND) {
1141 o->op_ppaddr = PL_ppaddr[OP_OR];
1143 o->op_type = OP_AND;
1144 o->op_ppaddr = PL_ppaddr[OP_AND];
1153 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1158 if (o->op_flags & OPf_STACKED)
1165 if (!(o->op_flags & OPf_KIDS))
1176 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1183 /* all requires must return a boolean value */
1184 o->op_flags &= ~OPf_WANT;
1189 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
1190 if (!kPMOP->op_pmreplrootu.op_pmreplroot)
1191 deprecate_old("implicit split to @_");
1195 if (useless && ckWARN(WARN_VOID))
1196 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
1201 S_listkids(pTHX_ OP *o)
1203 if (o && o->op_flags & OPf_KIDS) {
1205 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1212 Perl_list(pTHX_ OP *o)
1217 /* assumes no premature commitment */
1218 if (!o || (o->op_flags & OPf_WANT)
1219 || (PL_parser && PL_parser->error_count)
1220 || o->op_type == OP_RETURN)
1225 if ((o->op_private & OPpTARGET_MY)
1226 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1228 return o; /* As if inside SASSIGN */
1231 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1233 switch (o->op_type) {
1236 list(cBINOPo->op_first);
1241 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1249 if (!(o->op_flags & OPf_KIDS))
1251 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1252 list(cBINOPo->op_first);
1253 return gen_constant_list(o);
1260 kid = cLISTOPo->op_first;
1262 while ((kid = kid->op_sibling)) {
1263 if (kid->op_sibling)
1268 PL_curcop = &PL_compiling;
1272 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1273 if (kid->op_sibling)
1278 PL_curcop = &PL_compiling;
1281 /* all requires must return a boolean value */
1282 o->op_flags &= ~OPf_WANT;
1289 S_scalarseq(pTHX_ OP *o)
1293 const OPCODE type = o->op_type;
1295 if (type == OP_LINESEQ || type == OP_SCOPE ||
1296 type == OP_LEAVE || type == OP_LEAVETRY)
1299 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1300 if (kid->op_sibling) {
1304 PL_curcop = &PL_compiling;
1306 o->op_flags &= ~OPf_PARENS;
1307 if (PL_hints & HINT_BLOCK_SCOPE)
1308 o->op_flags |= OPf_PARENS;
1311 o = newOP(OP_STUB, 0);
1316 S_modkids(pTHX_ OP *o, I32 type)
1318 if (o && o->op_flags & OPf_KIDS) {
1320 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1326 /* Propagate lvalue ("modifiable") context to an op and its children.
1327 * 'type' represents the context type, roughly based on the type of op that
1328 * would do the modifying, although local() is represented by OP_NULL.
1329 * It's responsible for detecting things that can't be modified, flag
1330 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
1331 * might have to vivify a reference in $x), and so on.
1333 * For example, "$a+1 = 2" would cause mod() to be called with o being
1334 * OP_ADD and type being OP_SASSIGN, and would output an error.
1338 Perl_mod(pTHX_ OP *o, I32 type)
1342 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1345 if (!o || (PL_parser && PL_parser->error_count))
1348 if ((o->op_private & OPpTARGET_MY)
1349 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1354 switch (o->op_type) {
1360 if (!(o->op_private & OPpCONST_ARYBASE))
1363 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1364 CopARYBASE_set(&PL_compiling,
1365 (I32)SvIV(cSVOPx(PL_eval_start)->op_sv));
1369 SAVECOPARYBASE(&PL_compiling);
1370 CopARYBASE_set(&PL_compiling, 0);
1372 else if (type == OP_REFGEN)
1375 Perl_croak(aTHX_ "That use of $[ is unsupported");
1378 if ((o->op_flags & OPf_PARENS) || PL_madskills)
1382 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1383 !(o->op_flags & OPf_STACKED)) {
1384 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1385 /* The default is to set op_private to the number of children,
1386 which for a UNOP such as RV2CV is always 1. And w're using
1387 the bit for a flag in RV2CV, so we need it clear. */
1388 o->op_private &= ~1;
1389 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1390 assert(cUNOPo->op_first->op_type == OP_NULL);
1391 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1394 else if (o->op_private & OPpENTERSUB_NOMOD)
1396 else { /* lvalue subroutine call */
1397 o->op_private |= OPpLVAL_INTRO;
1398 PL_modcount = RETURN_UNLIMITED_NUMBER;
1399 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1400 /* Backward compatibility mode: */
1401 o->op_private |= OPpENTERSUB_INARGS;
1404 else { /* Compile-time error message: */
1405 OP *kid = cUNOPo->op_first;
1409 if (kid->op_type != OP_PUSHMARK) {
1410 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1412 "panic: unexpected lvalue entersub "
1413 "args: type/targ %ld:%"UVuf,
1414 (long)kid->op_type, (UV)kid->op_targ);
1415 kid = kLISTOP->op_first;
1417 while (kid->op_sibling)
1418 kid = kid->op_sibling;
1419 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1421 if (kid->op_type == OP_METHOD_NAMED
1422 || kid->op_type == OP_METHOD)
1426 NewOp(1101, newop, 1, UNOP);
1427 newop->op_type = OP_RV2CV;
1428 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1429 newop->op_first = NULL;
1430 newop->op_next = (OP*)newop;
1431 kid->op_sibling = (OP*)newop;
1432 newop->op_private |= OPpLVAL_INTRO;
1433 newop->op_private &= ~1;
1437 if (kid->op_type != OP_RV2CV)
1439 "panic: unexpected lvalue entersub "
1440 "entry via type/targ %ld:%"UVuf,
1441 (long)kid->op_type, (UV)kid->op_targ);
1442 kid->op_private |= OPpLVAL_INTRO;
1443 break; /* Postpone until runtime */
1447 kid = kUNOP->op_first;
1448 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1449 kid = kUNOP->op_first;
1450 if (kid->op_type == OP_NULL)
1452 "Unexpected constant lvalue entersub "
1453 "entry via type/targ %ld:%"UVuf,
1454 (long)kid->op_type, (UV)kid->op_targ);
1455 if (kid->op_type != OP_GV) {
1456 /* Restore RV2CV to check lvalueness */
1458 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1459 okid->op_next = kid->op_next;
1460 kid->op_next = okid;
1463 okid->op_next = NULL;
1464 okid->op_type = OP_RV2CV;
1466 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1467 okid->op_private |= OPpLVAL_INTRO;
1468 okid->op_private &= ~1;
1472 cv = GvCV(kGVOP_gv);
1482 /* grep, foreach, subcalls, refgen */
1483 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1485 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1486 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1488 : (o->op_type == OP_ENTERSUB
1489 ? "non-lvalue subroutine call"
1491 type ? PL_op_desc[type] : "local"));
1505 case OP_RIGHT_SHIFT:
1514 if (!(o->op_flags & OPf_STACKED))
1521 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1527 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1528 PL_modcount = RETURN_UNLIMITED_NUMBER;
1529 return o; /* Treat \(@foo) like ordinary list. */
1533 if (scalar_mod_type(o, type))
1535 ref(cUNOPo->op_first, o->op_type);
1539 if (type == OP_LEAVESUBLV)
1540 o->op_private |= OPpMAYBE_LVSUB;
1546 PL_modcount = RETURN_UNLIMITED_NUMBER;
1549 ref(cUNOPo->op_first, o->op_type);
1554 PL_hints |= HINT_BLOCK_SCOPE;
1569 PL_modcount = RETURN_UNLIMITED_NUMBER;
1570 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1571 return o; /* Treat \(@foo) like ordinary list. */
1572 if (scalar_mod_type(o, type))
1574 if (type == OP_LEAVESUBLV)
1575 o->op_private |= OPpMAYBE_LVSUB;
1579 if (!type) /* local() */
1580 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1581 PAD_COMPNAME_PV(o->op_targ));
1589 if (type != OP_SASSIGN)
1593 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1598 if (type == OP_LEAVESUBLV)
1599 o->op_private |= OPpMAYBE_LVSUB;
1601 pad_free(o->op_targ);
1602 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1603 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1604 if (o->op_flags & OPf_KIDS)
1605 mod(cBINOPo->op_first->op_sibling, type);
1610 ref(cBINOPo->op_first, o->op_type);
1611 if (type == OP_ENTERSUB &&
1612 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1613 o->op_private |= OPpLVAL_DEFER;
1614 if (type == OP_LEAVESUBLV)
1615 o->op_private |= OPpMAYBE_LVSUB;
1625 if (o->op_flags & OPf_KIDS)
1626 mod(cLISTOPo->op_last, type);
1631 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1633 else if (!(o->op_flags & OPf_KIDS))
1635 if (o->op_targ != OP_LIST) {
1636 mod(cBINOPo->op_first, type);
1642 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1647 if (type != OP_LEAVESUBLV)
1649 break; /* mod()ing was handled by ck_return() */
1652 /* [20011101.069] File test operators interpret OPf_REF to mean that
1653 their argument is a filehandle; thus \stat(".") should not set
1655 if (type == OP_REFGEN &&
1656 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1659 if (type != OP_LEAVESUBLV)
1660 o->op_flags |= OPf_MOD;
1662 if (type == OP_AASSIGN || type == OP_SASSIGN)
1663 o->op_flags |= OPf_SPECIAL|OPf_REF;
1664 else if (!type) { /* local() */
1667 o->op_private |= OPpLVAL_INTRO;
1668 o->op_flags &= ~OPf_SPECIAL;
1669 PL_hints |= HINT_BLOCK_SCOPE;
1674 if (ckWARN(WARN_SYNTAX)) {
1675 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1676 "Useless localization of %s", OP_DESC(o));
1680 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1681 && type != OP_LEAVESUBLV)
1682 o->op_flags |= OPf_REF;
1687 S_scalar_mod_type(const OP *o, I32 type)
1689 PERL_ARGS_ASSERT_SCALAR_MOD_TYPE;
1693 if (o->op_type == OP_RV2GV)
1717 case OP_RIGHT_SHIFT:
1737 S_is_handle_constructor(const OP *o, I32 numargs)
1739 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
1741 switch (o->op_type) {
1749 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1762 S_refkids(pTHX_ OP *o, I32 type)
1764 if (o && o->op_flags & OPf_KIDS) {
1766 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1773 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
1778 PERL_ARGS_ASSERT_DOREF;
1780 if (!o || (PL_parser && PL_parser->error_count))
1783 switch (o->op_type) {
1785 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1786 !(o->op_flags & OPf_STACKED)) {
1787 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1788 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1789 assert(cUNOPo->op_first->op_type == OP_NULL);
1790 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1791 o->op_flags |= OPf_SPECIAL;
1792 o->op_private &= ~1;
1797 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1798 doref(kid, type, set_op_ref);
1801 if (type == OP_DEFINED)
1802 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1803 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1806 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1807 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1808 : type == OP_RV2HV ? OPpDEREF_HV
1810 o->op_flags |= OPf_MOD;
1817 o->op_flags |= OPf_REF;
1820 if (type == OP_DEFINED)
1821 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1822 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1828 o->op_flags |= OPf_REF;
1833 if (!(o->op_flags & OPf_KIDS))
1835 doref(cBINOPo->op_first, type, set_op_ref);
1839 doref(cBINOPo->op_first, o->op_type, set_op_ref);
1840 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1841 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1842 : type == OP_RV2HV ? OPpDEREF_HV
1844 o->op_flags |= OPf_MOD;
1854 if (!(o->op_flags & OPf_KIDS))
1856 doref(cLISTOPo->op_last, type, set_op_ref);
1866 S_dup_attrlist(pTHX_ OP *o)
1871 PERL_ARGS_ASSERT_DUP_ATTRLIST;
1873 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1874 * where the first kid is OP_PUSHMARK and the remaining ones
1875 * are OP_CONST. We need to push the OP_CONST values.
1877 if (o->op_type == OP_CONST)
1878 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
1880 else if (o->op_type == OP_NULL)
1884 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1886 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1887 if (o->op_type == OP_CONST)
1888 rop = append_elem(OP_LIST, rop,
1889 newSVOP(OP_CONST, o->op_flags,
1890 SvREFCNT_inc_NN(cSVOPo->op_sv)));
1897 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1902 PERL_ARGS_ASSERT_APPLY_ATTRS;
1904 /* fake up C<use attributes $pkg,$rv,@attrs> */
1905 ENTER; /* need to protect against side-effects of 'use' */
1906 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1908 #define ATTRSMODULE "attributes"
1909 #define ATTRSMODULE_PM "attributes.pm"
1912 /* Don't force the C<use> if we don't need it. */
1913 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
1914 if (svp && *svp != &PL_sv_undef)
1915 NOOP; /* already in %INC */
1917 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1918 newSVpvs(ATTRSMODULE), NULL);
1921 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1922 newSVpvs(ATTRSMODULE),
1924 prepend_elem(OP_LIST,
1925 newSVOP(OP_CONST, 0, stashsv),
1926 prepend_elem(OP_LIST,
1927 newSVOP(OP_CONST, 0,
1929 dup_attrlist(attrs))));
1935 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1938 OP *pack, *imop, *arg;
1941 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
1946 assert(target->op_type == OP_PADSV ||
1947 target->op_type == OP_PADHV ||
1948 target->op_type == OP_PADAV);
1950 /* Ensure that attributes.pm is loaded. */
1951 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1953 /* Need package name for method call. */
1954 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
1956 /* Build up the real arg-list. */
1957 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1959 arg = newOP(OP_PADSV, 0);
1960 arg->op_targ = target->op_targ;
1961 arg = prepend_elem(OP_LIST,
1962 newSVOP(OP_CONST, 0, stashsv),
1963 prepend_elem(OP_LIST,
1964 newUNOP(OP_REFGEN, 0,
1965 mod(arg, OP_REFGEN)),
1966 dup_attrlist(attrs)));
1968 /* Fake up a method call to import */
1969 meth = newSVpvs_share("import");
1970 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1971 append_elem(OP_LIST,
1972 prepend_elem(OP_LIST, pack, list(arg)),
1973 newSVOP(OP_METHOD_NAMED, 0, meth)));
1974 imop->op_private |= OPpENTERSUB_NOMOD;
1976 /* Combine the ops. */
1977 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1981 =notfor apidoc apply_attrs_string
1983 Attempts to apply a list of attributes specified by the C<attrstr> and
1984 C<len> arguments to the subroutine identified by the C<cv> argument which
1985 is expected to be associated with the package identified by the C<stashpv>
1986 argument (see L<attributes>). It gets this wrong, though, in that it
1987 does not correctly identify the boundaries of the individual attribute
1988 specifications within C<attrstr>. This is not really intended for the
1989 public API, but has to be listed here for systems such as AIX which
1990 need an explicit export list for symbols. (It's called from XS code
1991 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1992 to respect attribute syntax properly would be welcome.
1998 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
1999 const char *attrstr, STRLEN len)
2003 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
2006 len = strlen(attrstr);
2010 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2012 const char * const sstr = attrstr;
2013 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2014 attrs = append_elem(OP_LIST, attrs,
2015 newSVOP(OP_CONST, 0,
2016 newSVpvn(sstr, attrstr-sstr)));
2020 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2021 newSVpvs(ATTRSMODULE),
2022 NULL, prepend_elem(OP_LIST,
2023 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2024 prepend_elem(OP_LIST,
2025 newSVOP(OP_CONST, 0,
2026 newRV(MUTABLE_SV(cv))),
2031 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
2036 PERL_ARGS_ASSERT_MY_KID;
2038 if (!o || (PL_parser && PL_parser->error_count))
2042 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
2043 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
2047 if (type == OP_LIST) {
2049 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2050 my_kid(kid, attrs, imopsp);
2051 } else if (type == OP_UNDEF
2057 } else if (type == OP_RV2SV || /* "our" declaration */
2059 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
2060 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
2061 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2063 PL_parser->in_my == KEY_our
2065 : PL_parser->in_my == KEY_state ? "state" : "my"));
2067 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
2068 PL_parser->in_my = FALSE;
2069 PL_parser->in_my_stash = NULL;
2070 apply_attrs(GvSTASH(gv),
2071 (type == OP_RV2SV ? GvSV(gv) :
2072 type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
2073 type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
2076 o->op_private |= OPpOUR_INTRO;
2079 else if (type != OP_PADSV &&
2082 type != OP_PUSHMARK)
2084 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2086 PL_parser->in_my == KEY_our
2088 : PL_parser->in_my == KEY_state ? "state" : "my"));
2091 else if (attrs && type != OP_PUSHMARK) {
2094 PL_parser->in_my = FALSE;
2095 PL_parser->in_my_stash = NULL;
2097 /* check for C<my Dog $spot> when deciding package */
2098 stash = PAD_COMPNAME_TYPE(o->op_targ);
2100 stash = PL_curstash;
2101 apply_attrs_my(stash, o, attrs, imopsp);
2103 o->op_flags |= OPf_MOD;
2104 o->op_private |= OPpLVAL_INTRO;
2105 if (PL_parser->in_my == KEY_state)
2106 o->op_private |= OPpPAD_STATE;
2111 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2115 int maybe_scalar = 0;
2117 PERL_ARGS_ASSERT_MY_ATTRS;
2119 /* [perl #17376]: this appears to be premature, and results in code such as
2120 C< our(%x); > executing in list mode rather than void mode */
2122 if (o->op_flags & OPf_PARENS)
2132 o = my_kid(o, attrs, &rops);
2134 if (maybe_scalar && o->op_type == OP_PADSV) {
2135 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
2136 o->op_private |= OPpLVAL_INTRO;
2139 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
2141 PL_parser->in_my = FALSE;
2142 PL_parser->in_my_stash = NULL;
2147 Perl_sawparens(pTHX_ OP *o)
2149 PERL_UNUSED_CONTEXT;
2151 o->op_flags |= OPf_PARENS;
2156 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2160 const OPCODE ltype = left->op_type;
2161 const OPCODE rtype = right->op_type;
2163 PERL_ARGS_ASSERT_BIND_MATCH;
2165 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2166 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
2168 const char * const desc
2169 = PL_op_desc[(rtype == OP_SUBST || rtype == OP_TRANS)
2170 ? (int)rtype : OP_MATCH];
2171 const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV)
2172 ? "@array" : "%hash");
2173 Perl_warner(aTHX_ packWARN(WARN_MISC),
2174 "Applying %s to %s will act on scalar(%s)",
2175 desc, sample, sample);
2178 if (rtype == OP_CONST &&
2179 cSVOPx(right)->op_private & OPpCONST_BARE &&
2180 cSVOPx(right)->op_private & OPpCONST_STRICT)
2182 no_bareword_allowed(right);
2185 ismatchop = rtype == OP_MATCH ||
2186 rtype == OP_SUBST ||
2188 if (ismatchop && right->op_private & OPpTARGET_MY) {
2190 right->op_private &= ~OPpTARGET_MY;
2192 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
2195 right->op_flags |= OPf_STACKED;
2196 if (rtype != OP_MATCH &&
2197 ! (rtype == OP_TRANS &&
2198 right->op_private & OPpTRANS_IDENTICAL))
2199 newleft = mod(left, rtype);
2202 if (right->op_type == OP_TRANS)
2203 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
2205 o = prepend_elem(rtype, scalar(newleft), right);
2207 return newUNOP(OP_NOT, 0, scalar(o));
2211 return bind_match(type, left,
2212 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
2216 Perl_invert(pTHX_ OP *o)
2220 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2224 Perl_scope(pTHX_ OP *o)
2228 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2229 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2230 o->op_type = OP_LEAVE;
2231 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2233 else if (o->op_type == OP_LINESEQ) {
2235 o->op_type = OP_SCOPE;
2236 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2237 kid = ((LISTOP*)o)->op_first;
2238 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2241 /* The following deals with things like 'do {1 for 1}' */
2242 kid = kid->op_sibling;
2244 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2249 o = newLISTOP(OP_SCOPE, 0, o, NULL);
2255 Perl_block_start(pTHX_ int full)
2258 const int retval = PL_savestack_ix;
2259 pad_block_start(full);
2261 PL_hints &= ~HINT_BLOCK_SCOPE;
2262 SAVECOMPILEWARNINGS();
2263 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
2268 Perl_block_end(pTHX_ I32 floor, OP *seq)
2271 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2272 OP* const retval = scalarseq(seq);
2274 CopHINTS_set(&PL_compiling, PL_hints);
2276 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2285 const PADOFFSET offset = pad_findmy("$_");
2286 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
2287 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2290 OP * const o = newOP(OP_PADSV, 0);
2291 o->op_targ = offset;
2297 Perl_newPROG(pTHX_ OP *o)
2301 PERL_ARGS_ASSERT_NEWPROG;
2306 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2307 ((PL_in_eval & EVAL_KEEPERR)
2308 ? OPf_SPECIAL : 0), o);
2309 PL_eval_start = linklist(PL_eval_root);
2310 PL_eval_root->op_private |= OPpREFCOUNTED;
2311 OpREFCNT_set(PL_eval_root, 1);
2312 PL_eval_root->op_next = 0;
2313 CALL_PEEP(PL_eval_start);
2316 if (o->op_type == OP_STUB) {
2317 PL_comppad_name = 0;
2319 S_op_destroy(aTHX_ o);
2322 PL_main_root = scope(sawparens(scalarvoid(o)));
2323 PL_curcop = &PL_compiling;
2324 PL_main_start = LINKLIST(PL_main_root);
2325 PL_main_root->op_private |= OPpREFCOUNTED;
2326 OpREFCNT_set(PL_main_root, 1);
2327 PL_main_root->op_next = 0;
2328 CALL_PEEP(PL_main_start);
2331 /* Register with debugger */
2333 CV * const cv = get_cvs("DB::postponed", 0);
2337 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
2339 call_sv(MUTABLE_SV(cv), G_DISCARD);
2346 Perl_localize(pTHX_ OP *o, I32 lex)
2350 PERL_ARGS_ASSERT_LOCALIZE;
2352 if (o->op_flags & OPf_PARENS)
2353 /* [perl #17376]: this appears to be premature, and results in code such as
2354 C< our(%x); > executing in list mode rather than void mode */
2361 if ( PL_parser->bufptr > PL_parser->oldbufptr
2362 && PL_parser->bufptr[-1] == ','
2363 && ckWARN(WARN_PARENTHESIS))
2365 char *s = PL_parser->bufptr;
2368 /* some heuristics to detect a potential error */
2369 while (*s && (strchr(", \t\n", *s)))
2373 if (*s && strchr("@$%*", *s) && *++s
2374 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2377 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2379 while (*s && (strchr(", \t\n", *s)))
2385 if (sigil && (*s == ';' || *s == '=')) {
2386 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2387 "Parentheses missing around \"%s\" list",
2389 ? (PL_parser->in_my == KEY_our
2391 : PL_parser->in_my == KEY_state
2401 o = mod(o, OP_NULL); /* a bit kludgey */
2402 PL_parser->in_my = FALSE;
2403 PL_parser->in_my_stash = NULL;
2408 Perl_jmaybe(pTHX_ OP *o)
2410 PERL_ARGS_ASSERT_JMAYBE;
2412 if (o->op_type == OP_LIST) {
2414 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2415 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2421 S_fold_constants(pTHX_ register OP *o)
2424 register OP * VOL curop;
2426 VOL I32 type = o->op_type;
2431 SV * const oldwarnhook = PL_warnhook;
2432 SV * const olddiehook = PL_diehook;
2436 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
2438 if (PL_opargs[type] & OA_RETSCALAR)
2440 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2441 o->op_targ = pad_alloc(type, SVs_PADTMP);
2443 /* integerize op, unless it happens to be C<-foo>.
2444 * XXX should pp_i_negate() do magic string negation instead? */
2445 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2446 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2447 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2449 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2452 if (!(PL_opargs[type] & OA_FOLDCONST))
2457 /* XXX might want a ck_negate() for this */
2458 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2469 /* XXX what about the numeric ops? */
2470 if (PL_hints & HINT_LOCALE)
2475 if (PL_parser && PL_parser->error_count)
2476 goto nope; /* Don't try to run w/ errors */
2478 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2479 const OPCODE type = curop->op_type;
2480 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2482 type != OP_SCALAR &&
2484 type != OP_PUSHMARK)
2490 curop = LINKLIST(o);
2491 old_next = o->op_next;
2495 oldscope = PL_scopestack_ix;
2496 create_eval_scope(G_FAKINGEVAL);
2498 /* Verify that we don't need to save it: */
2499 assert(PL_curcop == &PL_compiling);
2500 StructCopy(&PL_compiling, ¬_compiling, COP);
2501 PL_curcop = ¬_compiling;
2502 /* The above ensures that we run with all the correct hints of the
2503 currently compiling COP, but that IN_PERL_RUNTIME is not true. */
2504 assert(IN_PERL_RUNTIME);
2505 PL_warnhook = PERL_WARNHOOK_FATAL;
2512 sv = *(PL_stack_sp--);
2513 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2514 pad_swipe(o->op_targ, FALSE);
2515 else if (SvTEMP(sv)) { /* grab mortal temp? */
2516 SvREFCNT_inc_simple_void(sv);
2521 /* Something tried to die. Abandon constant folding. */
2522 /* Pretend the error never happened. */
2524 o->op_next = old_next;
2528 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
2529 PL_warnhook = oldwarnhook;
2530 PL_diehook = olddiehook;
2531 /* XXX note that this croak may fail as we've already blown away
2532 * the stack - eg any nested evals */
2533 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
2536 PL_warnhook = oldwarnhook;
2537 PL_diehook = olddiehook;
2538 PL_curcop = &PL_compiling;
2540 if (PL_scopestack_ix > oldscope)
2541 delete_eval_scope();
2550 if (type == OP_RV2GV)
2551 newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
2553 newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
2554 op_getmad(o,newop,'f');
2562 S_gen_constant_list(pTHX_ register OP *o)
2566 const I32 oldtmps_floor = PL_tmps_floor;
2569 if (PL_parser && PL_parser->error_count)
2570 return o; /* Don't attempt to run with errors */
2572 PL_op = curop = LINKLIST(o);
2578 assert (!(curop->op_flags & OPf_SPECIAL));
2579 assert(curop->op_type == OP_RANGE);
2581 PL_tmps_floor = oldtmps_floor;
2583 o->op_type = OP_RV2AV;
2584 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2585 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2586 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2587 o->op_opt = 0; /* needs to be revisited in peep() */
2588 curop = ((UNOP*)o)->op_first;
2589 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
2591 op_getmad(curop,o,'O');
2600 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2603 if (!o || o->op_type != OP_LIST)
2604 o = newLISTOP(OP_LIST, 0, o, NULL);
2606 o->op_flags &= ~OPf_WANT;
2608 if (!(PL_opargs[type] & OA_MARK))
2609 op_null(cLISTOPo->op_first);
2611 o->op_type = (OPCODE)type;
2612 o->op_ppaddr = PL_ppaddr[type];
2613 o->op_flags |= flags;
2615 o = CHECKOP(type, o);
2616 if (o->op_type != (unsigned)type)
2619 return fold_constants(o);
2622 /* List constructors */
2625 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2633 if (first->op_type != (unsigned)type
2634 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2636 return newLISTOP(type, 0, first, last);
2639 if (first->op_flags & OPf_KIDS)
2640 ((LISTOP*)first)->op_last->op_sibling = last;
2642 first->op_flags |= OPf_KIDS;
2643 ((LISTOP*)first)->op_first = last;
2645 ((LISTOP*)first)->op_last = last;
2650 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2658 if (first->op_type != (unsigned)type)
2659 return prepend_elem(type, (OP*)first, (OP*)last);
2661 if (last->op_type != (unsigned)type)
2662 return append_elem(type, (OP*)first, (OP*)last);
2664 first->op_last->op_sibling = last->op_first;
2665 first->op_last = last->op_last;
2666 first->op_flags |= (last->op_flags & OPf_KIDS);
2669 if (last->op_first && first->op_madprop) {
2670 MADPROP *mp = last->op_first->op_madprop;
2672 while (mp->mad_next)
2674 mp->mad_next = first->op_madprop;
2677 last->op_first->op_madprop = first->op_madprop;
2680 first->op_madprop = last->op_madprop;
2681 last->op_madprop = 0;
2684 S_op_destroy(aTHX_ (OP*)last);
2690 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2698 if (last->op_type == (unsigned)type) {
2699 if (type == OP_LIST) { /* already a PUSHMARK there */
2700 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2701 ((LISTOP*)last)->op_first->op_sibling = first;
2702 if (!(first->op_flags & OPf_PARENS))
2703 last->op_flags &= ~OPf_PARENS;
2706 if (!(last->op_flags & OPf_KIDS)) {
2707 ((LISTOP*)last)->op_last = first;
2708 last->op_flags |= OPf_KIDS;
2710 first->op_sibling = ((LISTOP*)last)->op_first;
2711 ((LISTOP*)last)->op_first = first;
2713 last->op_flags |= OPf_KIDS;
2717 return newLISTOP(type, 0, first, last);
2725 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2728 Newxz(tk, 1, TOKEN);
2729 tk->tk_type = (OPCODE)optype;
2730 tk->tk_type = 12345;
2732 tk->tk_mad = madprop;
2737 Perl_token_free(pTHX_ TOKEN* tk)
2739 PERL_ARGS_ASSERT_TOKEN_FREE;
2741 if (tk->tk_type != 12345)
2743 mad_free(tk->tk_mad);
2748 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2753 PERL_ARGS_ASSERT_TOKEN_GETMAD;
2755 if (tk->tk_type != 12345) {
2756 Perl_warner(aTHX_ packWARN(WARN_MISC),
2757 "Invalid TOKEN object ignored");
2764 /* faked up qw list? */
2766 tm->mad_type == MAD_SV &&
2767 SvPVX((const SV *)tm->mad_val)[0] == 'q')
2774 /* pretend constant fold didn't happen? */
2775 if (mp->mad_key == 'f' &&
2776 (o->op_type == OP_CONST ||
2777 o->op_type == OP_GV) )
2779 token_getmad(tk,(OP*)mp->mad_val,slot);
2793 if (mp->mad_key == 'X')
2794 mp->mad_key = slot; /* just change the first one */
2804 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
2813 /* pretend constant fold didn't happen? */
2814 if (mp->mad_key == 'f' &&
2815 (o->op_type == OP_CONST ||
2816 o->op_type == OP_GV) )
2818 op_getmad(from,(OP*)mp->mad_val,slot);
2825 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
2828 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
2834 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
2843 /* pretend constant fold didn't happen? */
2844 if (mp->mad_key == 'f' &&
2845 (o->op_type == OP_CONST ||
2846 o->op_type == OP_GV) )
2848 op_getmad(from,(OP*)mp->mad_val,slot);
2855 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
2858 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
2862 PerlIO_printf(PerlIO_stderr(),
2863 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
2869 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
2887 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
2891 addmad(tm, &(o->op_madprop), slot);
2895 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
2916 Perl_newMADsv(pTHX_ char key, SV* sv)
2918 PERL_ARGS_ASSERT_NEWMADSV;
2920 return newMADPROP(key, MAD_SV, sv, 0);
2924 Perl_newMADPROP(pTHX_ char key, char type, const void* val, I32 vlen)
2927 Newxz(mp, 1, MADPROP);
2930 mp->mad_vlen = vlen;
2931 mp->mad_type = type;
2933 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
2938 Perl_mad_free(pTHX_ MADPROP* mp)
2940 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
2944 mad_free(mp->mad_next);
2945 /* if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
2946 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
2947 switch (mp->mad_type) {
2951 Safefree((char*)mp->mad_val);
2954 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
2955 op_free((OP*)mp->mad_val);
2958 sv_free(MUTABLE_SV(mp->mad_val));
2961 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
2970 Perl_newNULLLIST(pTHX)
2972 return newOP(OP_STUB, 0);
2976 S_force_list(pTHX_ OP *o)
2978 if (!o || o->op_type != OP_LIST)
2979 o = newLISTOP(OP_LIST, 0, o, NULL);
2985 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2990 NewOp(1101, listop, 1, LISTOP);
2992 listop->op_type = (OPCODE)type;
2993 listop->op_ppaddr = PL_ppaddr[type];
2996 listop->op_flags = (U8)flags;
3000 else if (!first && last)
3003 first->op_sibling = last;
3004 listop->op_first = first;
3005 listop->op_last = last;
3006 if (type == OP_LIST) {
3007 OP* const pushop = newOP(OP_PUSHMARK, 0);
3008 pushop->op_sibling = first;
3009 listop->op_first = pushop;
3010 listop->op_flags |= OPf_KIDS;
3012 listop->op_last = pushop;
3015 return CHECKOP(type, listop);
3019 Perl_newOP(pTHX_ I32 type, I32 flags)
3023 NewOp(1101, o, 1, OP);
3024 o->op_type = (OPCODE)type;
3025 o->op_ppaddr = PL_ppaddr[type];
3026 o->op_flags = (U8)flags;
3028 o->op_latefreed = 0;
3032 o->op_private = (U8)(0 | (flags >> 8));
3033 if (PL_opargs[type] & OA_RETSCALAR)
3035 if (PL_opargs[type] & OA_TARGET)
3036 o->op_targ = pad_alloc(type, SVs_PADTMP);
3037 return CHECKOP(type, o);
3041 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
3047 first = newOP(OP_STUB, 0);
3048 if (PL_opargs[type] & OA_MARK)
3049 first = force_list(first);
3051 NewOp(1101, unop, 1, UNOP);
3052 unop->op_type = (OPCODE)type;
3053 unop->op_ppaddr = PL_ppaddr[type];
3054 unop->op_first = first;
3055 unop->op_flags = (U8)(flags | OPf_KIDS);
3056 unop->op_private = (U8)(1 | (flags >> 8));
3057 unop = (UNOP*) CHECKOP(type, unop);
3061 return fold_constants((OP *) unop);
3065 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3069 NewOp(1101, binop, 1, BINOP);
3072 first = newOP(OP_NULL, 0);
3074 binop->op_type = (OPCODE)type;
3075 binop->op_ppaddr = PL_ppaddr[type];
3076 binop->op_first = first;
3077 binop->op_flags = (U8)(flags | OPf_KIDS);
3080 binop->op_private = (U8)(1 | (flags >> 8));
3083 binop->op_private = (U8)(2 | (flags >> 8));
3084 first->op_sibling = last;
3087 binop = (BINOP*)CHECKOP(type, binop);
3088 if (binop->op_next || binop->op_type != (OPCODE)type)
3091 binop->op_last = binop->op_first->op_sibling;
3093 return fold_constants((OP *)binop);
3096 static int uvcompare(const void *a, const void *b)
3097 __attribute__nonnull__(1)
3098 __attribute__nonnull__(2)
3099 __attribute__pure__;
3100 static int uvcompare(const void *a, const void *b)
3102 if (*((const UV *)a) < (*(const UV *)b))
3104 if (*((const UV *)a) > (*(const UV *)b))
3106 if (*((const UV *)a+1) < (*(const UV *)b+1))
3108 if (*((const UV *)a+1) > (*(const UV *)b+1))
3114 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
3117 SV * const tstr = ((SVOP*)expr)->op_sv;
3120 (repl->op_type == OP_NULL)
3121 ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
3123 ((SVOP*)repl)->op_sv;
3126 const U8 *t = (U8*)SvPV_const(tstr, tlen);
3127 const U8 *r = (U8*)SvPV_const(rstr, rlen);
3131 register short *tbl;
3133 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
3134 const I32 squash = o->op_private & OPpTRANS_SQUASH;
3135 I32 del = o->op_private & OPpTRANS_DELETE;
3138 PERL_ARGS_ASSERT_PMTRANS;
3140 PL_hints |= HINT_BLOCK_SCOPE;
3143 o->op_private |= OPpTRANS_FROM_UTF;
3146 o->op_private |= OPpTRANS_TO_UTF;
3148 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
3149 SV* const listsv = newSVpvs("# comment\n");
3151 const U8* tend = t + tlen;
3152 const U8* rend = r + rlen;
3166 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
3167 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
3170 const U32 flags = UTF8_ALLOW_DEFAULT;
3174 t = tsave = bytes_to_utf8(t, &len);
3177 if (!to_utf && rlen) {
3179 r = rsave = bytes_to_utf8(r, &len);
3183 /* There are several snags with this code on EBCDIC:
3184 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
3185 2. scan_const() in toke.c has encoded chars in native encoding which makes
3186 ranges at least in EBCDIC 0..255 range the bottom odd.
3190 U8 tmpbuf[UTF8_MAXBYTES+1];
3193 Newx(cp, 2*tlen, UV);
3195 transv = newSVpvs("");
3197 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3199 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
3201 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3205 cp[2*i+1] = cp[2*i];
3209 qsort(cp, i, 2*sizeof(UV), uvcompare);
3210 for (j = 0; j < i; j++) {
3212 diff = val - nextmin;
3214 t = uvuni_to_utf8(tmpbuf,nextmin);
3215 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3217 U8 range_mark = UTF_TO_NATIVE(0xff);
3218 t = uvuni_to_utf8(tmpbuf, val - 1);
3219 sv_catpvn(transv, (char *)&range_mark, 1);
3220 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3227 t = uvuni_to_utf8(tmpbuf,nextmin);
3228 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3230 U8 range_mark = UTF_TO_NATIVE(0xff);
3231 sv_catpvn(transv, (char *)&range_mark, 1);
3233 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
3234 UNICODE_ALLOW_SUPER);
3235 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3236 t = (const U8*)SvPVX_const(transv);
3237 tlen = SvCUR(transv);
3241 else if (!rlen && !del) {
3242 r = t; rlen = tlen; rend = tend;
3245 if ((!rlen && !del) || t == r ||
3246 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
3248 o->op_private |= OPpTRANS_IDENTICAL;
3252 while (t < tend || tfirst <= tlast) {
3253 /* see if we need more "t" chars */
3254 if (tfirst > tlast) {
3255 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3257 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
3259 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3266 /* now see if we need more "r" chars */
3267 if (rfirst > rlast) {
3269 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3271 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
3273 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3282 rfirst = rlast = 0xffffffff;
3286 /* now see which range will peter our first, if either. */
3287 tdiff = tlast - tfirst;
3288 rdiff = rlast - rfirst;
3295 if (rfirst == 0xffffffff) {
3296 diff = tdiff; /* oops, pretend rdiff is infinite */
3298 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
3299 (long)tfirst, (long)tlast);
3301 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
3305 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
3306 (long)tfirst, (long)(tfirst + diff),
3309 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3310 (long)tfirst, (long)rfirst);
3312 if (rfirst + diff > max)
3313 max = rfirst + diff;
3315 grows = (tfirst < rfirst &&
3316 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3328 else if (max > 0xff)
3333 PerlMemShared_free(cPVOPo->op_pv);
3334 cPVOPo->op_pv = NULL;
3336 swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
3338 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
3339 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
3340 PAD_SETSV(cPADOPo->op_padix, 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(ckWARN(WARN_MISC)) {
3439 if(del && rlen == tlen) {
3440 Perl_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
3441 } else if(rlen > tlen) {
3442 Perl_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
3447 o->op_private |= OPpTRANS_GROWS;
3449 op_getmad(expr,o,'e');
3450 op_getmad(repl,o,'r');
3460 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3465 NewOp(1101, pmop, 1, PMOP);
3466 pmop->op_type = (OPCODE)type;
3467 pmop->op_ppaddr = PL_ppaddr[type];
3468 pmop->op_flags = (U8)flags;
3469 pmop->op_private = (U8)(0 | (flags >> 8));
3471 if (PL_hints & HINT_RE_TAINT)
3472 pmop->op_pmflags |= PMf_RETAINT;
3473 if (PL_hints & HINT_LOCALE)
3474 pmop->op_pmflags |= PMf_LOCALE;
3478 assert(SvPOK(PL_regex_pad[0]));
3479 if (SvCUR(PL_regex_pad[0])) {
3480 /* Pop off the "packed" IV from the end. */
3481 SV *const repointer_list = PL_regex_pad[0];
3482 const char *p = SvEND(repointer_list) - sizeof(IV);
3483 const IV offset = *((IV*)p);
3485 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
3487 SvEND_set(repointer_list, p);
3489 pmop->op_pmoffset = offset;
3490 /* This slot should be free, so assert this: */
3491 assert(PL_regex_pad[offset] == &PL_sv_undef);
3493 SV * const repointer = &PL_sv_undef;
3494 av_push(PL_regex_padav, repointer);
3495 pmop->op_pmoffset = av_len(PL_regex_padav);
3496 PL_regex_pad = AvARRAY(PL_regex_padav);
3500 return CHECKOP(type, pmop);
3503 /* Given some sort of match op o, and an expression expr containing a
3504 * pattern, either compile expr into a regex and attach it to o (if it's
3505 * constant), or convert expr into a runtime regcomp op sequence (if it's
3508 * isreg indicates that the pattern is part of a regex construct, eg
3509 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3510 * split "pattern", which aren't. In the former case, expr will be a list
3511 * if the pattern contains more than one term (eg /a$b/) or if it contains
3512 * a replacement, ie s/// or tr///.
3516 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
3521 I32 repl_has_vars = 0;
3525 PERL_ARGS_ASSERT_PMRUNTIME;
3527 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
3528 /* last element in list is the replacement; pop it */
3530 repl = cLISTOPx(expr)->op_last;
3531 kid = cLISTOPx(expr)->op_first;
3532 while (kid->op_sibling != repl)
3533 kid = kid->op_sibling;
3534 kid->op_sibling = NULL;
3535 cLISTOPx(expr)->op_last = kid;
3538 if (isreg && expr->op_type == OP_LIST &&
3539 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3541 /* convert single element list to element */
3542 OP* const oe = expr;
3543 expr = cLISTOPx(oe)->op_first->op_sibling;
3544 cLISTOPx(oe)->op_first->op_sibling = NULL;
3545 cLISTOPx(oe)->op_last = NULL;
3549 if (o->op_type == OP_TRANS) {
3550 return pmtrans(o, expr, repl);
3553 reglist = isreg && expr->op_type == OP_LIST;
3557 PL_hints |= HINT_BLOCK_SCOPE;
3560 if (expr->op_type == OP_CONST) {
3561 SV *pat = ((SVOP*)expr)->op_sv;
3562 U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
3564 if (o->op_flags & OPf_SPECIAL)
3565 pm_flags |= RXf_SPLIT;
3568 assert (SvUTF8(pat));
3569 } else if (SvUTF8(pat)) {
3570 /* Not doing UTF-8, despite what the SV says. Is this only if we're
3571 trapped in use 'bytes'? */
3572 /* Make a copy of the octet sequence, but without the flag on, as
3573 the compiler now honours the SvUTF8 flag on pat. */
3575 const char *const p = SvPV(pat, len);
3576 pat = newSVpvn_flags(p, len, SVs_TEMP);
3579 PM_SETRE(pm, CALLREGCOMP(pat, pm_flags));
3582 op_getmad(expr,(OP*)pm,'e');
3588 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3589 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3591 : OP_REGCMAYBE),0,expr);
3593 NewOp(1101, rcop, 1, LOGOP);
3594 rcop->op_type = OP_REGCOMP;
3595 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3596 rcop->op_first = scalar(expr);
3597 rcop->op_flags |= OPf_KIDS
3598 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3599 | (reglist ? OPf_STACKED : 0);
3600 rcop->op_private = 1;
3603 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3605 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
3608 /* establish postfix order */
3609 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3611 rcop->op_next = expr;
3612 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3615 rcop->op_next = LINKLIST(expr);
3616 expr->op_next = (OP*)rcop;
3619 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3624 if (pm->op_pmflags & PMf_EVAL) {
3626 if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
3627 CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
3629 else if (repl->op_type == OP_CONST)
3633 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3634 if (curop->op_type == OP_SCOPE
3635 || curop->op_type == OP_LEAVE
3636 || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
3637 if (curop->op_type == OP_GV) {
3638 GV * const gv = cGVOPx_gv(curop);
3640 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3643 else if (curop->op_type == OP_RV2CV)
3645 else if (curop->op_type == OP_RV2SV ||
3646 curop->op_type == OP_RV2AV ||
3647 curop->op_type == OP_RV2HV ||
3648 curop->op_type == OP_RV2GV) {
3649 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3652 else if (curop->op_type == OP_PADSV ||
3653 curop->op_type == OP_PADAV ||
3654 curop->op_type == OP_PADHV ||
3655 curop->op_type == OP_PADANY)
3659 else if (curop->op_type == OP_PUSHRE)
3660 NOOP; /* Okay here, dangerous in newASSIGNOP */
3670 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
3672 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3673 prepend_elem(o->op_type, scalar(repl), o);
3676 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3677 pm->op_pmflags |= PMf_MAYBE_CONST;
3679 NewOp(1101, rcop, 1, LOGOP);
3680 rcop->op_type = OP_SUBSTCONT;
3681 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3682 rcop->op_first = scalar(repl);
3683 rcop->op_flags |= OPf_KIDS;
3684 rcop->op_private = 1;
3687 /* establish postfix order */
3688 rcop->op_next = LINKLIST(repl);
3689 repl->op_next = (OP*)rcop;
3691 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
3692 assert(!(pm->op_pmflags & PMf_ONCE));
3693 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
3702 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3707 PERL_ARGS_ASSERT_NEWSVOP;
3709 NewOp(1101, svop, 1, SVOP);
3710 svop->op_type = (OPCODE)type;
3711 svop->op_ppaddr = PL_ppaddr[type];
3713 svop->op_next = (OP*)svop;
3714 svop->op_flags = (U8)flags;
3715 if (PL_opargs[type] & OA_RETSCALAR)
3717 if (PL_opargs[type] & OA_TARGET)
3718 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3719 return CHECKOP(type, svop);
3724 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3729 PERL_ARGS_ASSERT_NEWPADOP;
3731 NewOp(1101, padop, 1, PADOP);
3732 padop->op_type = (OPCODE)type;
3733 padop->op_ppaddr = PL_ppaddr[type];
3734 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3735 SvREFCNT_dec(PAD_SVl(padop->op_padix));
3736 PAD_SETSV(padop->op_padix, sv);
3739 padop->op_next = (OP*)padop;
3740 padop->op_flags = (U8)flags;
3741 if (PL_opargs[type] & OA_RETSCALAR)
3743 if (PL_opargs[type] & OA_TARGET)
3744 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3745 return CHECKOP(type, padop);
3750 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3754 PERL_ARGS_ASSERT_NEWGVOP;
3758 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3760 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3765 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3769 NewOp(1101, pvop, 1, PVOP);
3770 pvop->op_type = (OPCODE)type;
3771 pvop->op_ppaddr = PL_ppaddr[type];
3773 pvop->op_next = (OP*)pvop;
3774 pvop->op_flags = (U8)flags;
3775 if (PL_opargs[type] & OA_RETSCALAR)
3777 if (PL_opargs[type] & OA_TARGET)
3778 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3779 return CHECKOP(type, pvop);
3787 Perl_package(pTHX_ OP *o)
3790 SV *const sv = cSVOPo->op_sv;
3795 PERL_ARGS_ASSERT_PACKAGE;
3797 save_hptr(&PL_curstash);
3798 save_item(PL_curstname);
3800 PL_curstash = gv_stashsv(sv, GV_ADD);
3802 sv_setsv(PL_curstname, sv);
3804 PL_hints |= HINT_BLOCK_SCOPE;
3805 PL_parser->copline = NOLINE;
3806 PL_parser->expect = XSTATE;
3811 if (!PL_madskills) {
3816 pegop = newOP(OP_NULL,0);
3817 op_getmad(o,pegop,'P');
3827 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3834 OP *pegop = newOP(OP_NULL,0);
3837 PERL_ARGS_ASSERT_UTILIZE;
3839 if (idop->op_type != OP_CONST)
3840 Perl_croak(aTHX_ "Module name must be constant");
3843 op_getmad(idop,pegop,'U');
3848 SV * const vesv = ((SVOP*)version)->op_sv;
3851 op_getmad(version,pegop,'V');
3852 if (!arg && !SvNIOKp(vesv)) {
3859 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3860 Perl_croak(aTHX_ "Version number must be constant number");
3862 /* Make copy of idop so we don't free it twice */
3863 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3865 /* Fake up a method call to VERSION */
3866 meth = newSVpvs_share("VERSION");
3867 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3868 append_elem(OP_LIST,
3869 prepend_elem(OP_LIST, pack, list(version)),
3870 newSVOP(OP_METHOD_NAMED, 0, meth)));
3874 /* Fake up an import/unimport */
3875 if (arg && arg->op_type == OP_STUB) {
3877 op_getmad(arg,pegop,'S');
3878 imop = arg; /* no import on explicit () */
3880 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3881 imop = NULL; /* use 5.0; */
3883 idop->op_private |= OPpCONST_NOVER;
3889 op_getmad(arg,pegop,'A');
3891 /* Make copy of idop so we don't free it twice */
3892 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3894 /* Fake up a method call to import/unimport */
3896 ? newSVpvs_share("import") : newSVpvs_share("unimport");
3897 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3898 append_elem(OP_LIST,
3899 prepend_elem(OP_LIST, pack, list(arg)),
3900 newSVOP(OP_METHOD_NAMED, 0, meth)));
3903 /* Fake up the BEGIN {}, which does its thing immediately. */
3905 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
3908 append_elem(OP_LINESEQ,
3909 append_elem(OP_LINESEQ,
3910 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
3911 newSTATEOP(0, NULL, veop)),
3912 newSTATEOP(0, NULL, imop) ));
3914 /* The "did you use incorrect case?" warning used to be here.
3915 * The problem is that on case-insensitive filesystems one
3916 * might get false positives for "use" (and "require"):
3917 * "use Strict" or "require CARP" will work. This causes
3918 * portability problems for the script: in case-strict
3919 * filesystems the script will stop working.
3921 * The "incorrect case" warning checked whether "use Foo"
3922 * imported "Foo" to your namespace, but that is wrong, too:
3923 * there is no requirement nor promise in the language that
3924 * a Foo.pm should or would contain anything in package "Foo".
3926 * There is very little Configure-wise that can be done, either:
3927 * the case-sensitivity of the build filesystem of Perl does not
3928 * help in guessing the case-sensitivity of the runtime environment.
3931 PL_hints |= HINT_BLOCK_SCOPE;
3932 PL_parser->copline = NOLINE;
3933 PL_parser->expect = XSTATE;
3934 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3937 if (!PL_madskills) {
3938 /* FIXME - don't allocate pegop if !PL_madskills */
3947 =head1 Embedding Functions
3949 =for apidoc load_module
3951 Loads the module whose name is pointed to by the string part of name.
3952 Note that the actual module name, not its filename, should be given.
3953 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3954 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3955 (or 0 for no flags). ver, if specified, provides version semantics
3956 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3957 arguments can be used to specify arguments to the module's import()
3958 method, similar to C<use Foo::Bar VERSION LIST>.
3963 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3967 PERL_ARGS_ASSERT_LOAD_MODULE;
3969 va_start(args, ver);
3970 vload_module(flags, name, ver, &args);
3974 #ifdef PERL_IMPLICIT_CONTEXT
3976 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3980 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
3981 va_start(args, ver);
3982 vload_module(flags, name, ver, &args);
3988 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3992 OP * const modname = newSVOP(OP_CONST, 0, name);
3994 PERL_ARGS_ASSERT_VLOAD_MODULE;
3996 modname->op_private |= OPpCONST_BARE;
3998 veop = newSVOP(OP_CONST, 0, ver);
4002 if (flags & PERL_LOADMOD_NOIMPORT) {
4003 imop = sawparens(newNULLLIST());
4005 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
4006 imop = va_arg(*args, OP*);
4011 sv = va_arg(*args, SV*);
4013 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
4014 sv = va_arg(*args, SV*);
4018 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
4019 * that it has a PL_parser to play with while doing that, and also
4020 * that it doesn't mess with any existing parser, by creating a tmp
4021 * new parser with lex_start(). This won't actually be used for much,
4022 * since pp_require() will create another parser for the real work. */
4025 SAVEVPTR(PL_curcop);
4026 lex_start(NULL, NULL, FALSE);
4027 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
4028 veop, modname, imop);
4033 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
4039 PERL_ARGS_ASSERT_DOFILE;
4041 if (!force_builtin) {
4042 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
4043 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
4044 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
4045 gv = gvp ? *gvp : NULL;
4049 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
4050 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
4051 append_elem(OP_LIST, term,
4052 scalar(newUNOP(OP_RV2CV, 0,
4053 newGVOP(OP_GV, 0, gv))))));
4056 doop = newUNOP(OP_DOFILE, 0, scalar(term));
4062 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
4064 return newBINOP(OP_LSLICE, flags,
4065 list(force_list(subscript)),
4066 list(force_list(listval)) );
4070 S_is_list_assignment(pTHX_ register const OP *o)
4078 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
4079 o = cUNOPo->op_first;
4081 flags = o->op_flags;
4083 if (type == OP_COND_EXPR) {
4084 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
4085 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
4090 yyerror("Assignment to both a list and a scalar");
4094 if (type == OP_LIST &&
4095 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
4096 o->op_private & OPpLVAL_INTRO)
4099 if (type == OP_LIST || flags & OPf_PARENS ||
4100 type == OP_RV2AV || type == OP_RV2HV ||
4101 type == OP_ASLICE || type == OP_HSLICE)
4104 if (type == OP_PADAV || type == OP_PADHV)
4107 if (type == OP_RV2SV)
4114 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
4120 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
4121 return newLOGOP(optype, 0,
4122 mod(scalar(left), optype),
4123 newUNOP(OP_SASSIGN, 0, scalar(right)));
4126 return newBINOP(optype, OPf_STACKED,
4127 mod(scalar(left), optype), scalar(right));
4131 if (is_list_assignment(left)) {
4132 static const char no_list_state[] = "Initialization of state variables"
4133 " in list context currently forbidden";
4135 bool maybe_common_vars = TRUE;
4138 /* Grandfathering $[ assignment here. Bletch.*/
4139 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
4140 PL_eval_start = (left->op_type == OP_CONST) ? right : NULL;
4141 left = mod(left, OP_AASSIGN);
4144 else if (left->op_type == OP_CONST) {
4146 /* Result of assignment is always 1 (or we'd be dead already) */
4147 return newSVOP(OP_CONST, 0, newSViv(1));
4149 curop = list(force_list(left));
4150 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
4151 o->op_private = (U8)(0 | (flags >> 8));
4153 if ((left->op_type == OP_LIST
4154 || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
4156 OP* lop = ((LISTOP*)left)->op_first;
4157 maybe_common_vars = FALSE;
4159 if (lop->op_type == OP_PADSV ||
4160 lop->op_type == OP_PADAV ||
4161 lop->op_type == OP_PADHV ||
4162 lop->op_type == OP_PADANY) {
4163 if (!(lop->op_private & OPpLVAL_INTRO))
4164 maybe_common_vars = TRUE;
4166 if (lop->op_private & OPpPAD_STATE) {
4167 if (left->op_private & OPpLVAL_INTRO) {
4168 /* Each variable in state($a, $b, $c) = ... */
4171 /* Each state variable in
4172 (state $a, my $b, our $c, $d, undef) = ... */
4174 yyerror(no_list_state);
4176 /* Each my variable in
4177 (state $a, my $b, our $c, $d, undef) = ... */
4179 } else if (lop->op_type == OP_UNDEF ||
4180 lop->op_type == OP_PUSHMARK) {
4181 /* undef may be interesting in
4182 (state $a, undef, state $c) */
4184 /* Other ops in the list. */
4185 maybe_common_vars = TRUE;
4187 lop = lop->op_sibling;
4190 else if ((left->op_private & OPpLVAL_INTRO)
4191 && ( left->op_type == OP_PADSV
4192 || left->op_type == OP_PADAV
4193 || left->op_type == OP_PADHV
4194 || left->op_type == OP_PADANY))
4196 maybe_common_vars = FALSE;
4197 if (left->op_private & OPpPAD_STATE) {
4198 /* All single variable list context state assignments, hence
4208 yyerror(no_list_state);
4212 /* PL_generation sorcery:
4213 * an assignment like ($a,$b) = ($c,$d) is easier than
4214 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
4215 * To detect whether there are common vars, the global var
4216 * PL_generation is incremented for each assign op we compile.
4217 * Then, while compiling the assign op, we run through all the
4218 * variables on both sides of the assignment, setting a spare slot
4219 * in each of them to PL_generation. If any of them already have
4220 * that value, we know we've got commonality. We could use a
4221 * single bit marker, but then we'd have to make 2 passes, first
4222 * to clear the flag, then to test and set it. To find somewhere
4223 * to store these values, evil chicanery is done with SvUVX().
4226 if (maybe_common_vars) {
4229 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4230 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
4231 if (curop->op_type == OP_GV) {
4232 GV *gv = cGVOPx_gv(curop);
4234 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4236 GvASSIGN_GENERATION_set(gv, PL_generation);
4238 else if (curop->op_type == OP_PADSV ||
4239 curop->op_type == OP_PADAV ||
4240 curop->op_type == OP_PADHV ||
4241 curop->op_type == OP_PADANY)
4243 if (PAD_COMPNAME_GEN(curop->op_targ)
4244 == (STRLEN)PL_generation)
4246 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
4249 else if (curop->op_type == OP_RV2CV)
4251 else if (curop->op_type == OP_RV2SV ||
4252 curop->op_type == OP_RV2AV ||
4253 curop->op_type == OP_RV2HV ||
4254 curop->op_type == OP_RV2GV) {
4255 if (lastop->op_type != OP_GV) /* funny deref? */
4258 else if (curop->op_type == OP_PUSHRE) {
4260 if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
4261 GV *const gv = MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff));
4263 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4265 GvASSIGN_GENERATION_set(gv, PL_generation);
4269 = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
4272 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4274 GvASSIGN_GENERATION_set(gv, PL_generation);
4284 o->op_private |= OPpASSIGN_COMMON;
4287 if (right && right->op_type == OP_SPLIT && !PL_madskills) {
4288 OP* tmpop = ((LISTOP*)right)->op_first;
4289 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
4290 PMOP * const pm = (PMOP*)tmpop;
4291 if (left->op_type == OP_RV2AV &&
4292 !(left->op_private & OPpLVAL_INTRO) &&
4293 !(o->op_private & OPpASSIGN_COMMON) )
4295 tmpop = ((UNOP*)left)->op_first;
4296 if (tmpop->op_type == OP_GV
4298 && !pm->op_pmreplrootu.op_pmtargetoff
4300 && !pm->op_pmreplrootu.op_pmtargetgv
4304 pm->op_pmreplrootu.op_pmtargetoff
4305 = cPADOPx(tmpop)->op_padix;
4306 cPADOPx(tmpop)->op_padix = 0; /* steal it */
4308 pm->op_pmreplrootu.op_pmtargetgv
4309 = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
4310 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
4312 pm->op_pmflags |= PMf_ONCE;
4313 tmpop = cUNOPo->op_first; /* to list (nulled) */
4314 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
4315 tmpop->op_sibling = NULL; /* don't free split */
4316 right->op_next = tmpop->op_next; /* fix starting loc */
4317 op_free(o); /* blow off assign */
4318 right->op_flags &= ~OPf_WANT;
4319 /* "I don't know and I don't care." */
4324 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
4325 ((LISTOP*)right)->op_last->op_type == OP_CONST)
4327 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
4329 sv_setiv(sv, PL_modcount+1);
4337 right = newOP(OP_UNDEF, 0);
4338 if (right->op_type == OP_READLINE) {
4339 right->op_flags |= OPf_STACKED;
4340 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
4343 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
4344 o = newBINOP(OP_SASSIGN, flags,
4345 scalar(right), mod(scalar(left), OP_SASSIGN) );
4349 if (!PL_madskills) { /* assignment to $[ is ignored when making a mad dump */
4350 deprecate("assignment to $[");
4352 o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
4353 o->op_private |= OPpCONST_ARYBASE;
4361 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
4364 const U32 seq = intro_my();
4367 NewOp(1101, cop, 1, COP);
4368 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
4369 cop->op_type = OP_DBSTATE;
4370 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
4373 cop->op_type = OP_NEXTSTATE;
4374 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
4376 cop->op_flags = (U8)flags;
4377 CopHINTS_set(cop, PL_hints);
4379 cop->op_private |= NATIVE_HINTS;
4381 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
4382 cop->op_next = (OP*)cop;
4385 /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
4386 CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
4388 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
4389 cop->cop_hints_hash = PL_curcop->cop_hints_hash;
4390 if (cop->cop_hints_hash) {
4392 cop->cop_hints_hash->refcounted_he_refcnt++;
4393 HINTS_REFCNT_UNLOCK;
4397 = Perl_store_cop_label(aTHX_ cop->cop_hints_hash, label);
4399 PL_hints |= HINT_BLOCK_SCOPE;
4400 /* It seems that we need to defer freeing this pointer, as other parts
4401 of the grammar end up wanting to copy it after this op has been
4406 if (PL_parser && PL_parser->copline == NOLINE)
4407 CopLINE_set(cop, CopLINE(PL_curcop));
4409 CopLINE_set(cop, PL_parser->copline);
4411 PL_parser->copline = NOLINE;
4414 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
4416 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
4418 CopSTASH_set(cop, PL_curstash);
4420 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash) {
4421 /* this line can have a breakpoint - store the cop in IV */
4422 AV *av = CopFILEAVx(PL_curcop);
4424 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
4425 if (svp && *svp != &PL_sv_undef ) {
4426 (void)SvIOK_on(*svp);
4427 SvIV_set(*svp, PTR2IV(cop));
4432 if (flags & OPf_SPECIAL)
4434 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
4439 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
4443 PERL_ARGS_ASSERT_NEWLOGOP;
4445 return new_logop(type, flags, &first, &other);
4449 S_search_const(pTHX_ OP *o)
4451 PERL_ARGS_ASSERT_SEARCH_CONST;
4453 switch (o->op_type) {
4457 if (o->op_flags & OPf_KIDS)
4458 return search_const(cUNOPo->op_first);
4465 if (!(o->op_flags & OPf_KIDS))
4467 kid = cLISTOPo->op_first;
4469 switch (kid->op_type) {
4473 kid = kid->op_sibling;
4476 if (kid != cLISTOPo->op_last)
4482 kid = cLISTOPo->op_last;
4484 return search_const(kid);
4492 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
4500 int prepend_not = 0;
4502 PERL_ARGS_ASSERT_NEW_LOGOP;
4507 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
4508 return newBINOP(type, flags, scalar(first), scalar(other));
4510 scalarboolean(first);
4511 /* optimize AND and OR ops that have NOTs as children */
4512 if (first->op_type == OP_NOT
4513 && (first->op_flags & OPf_KIDS)
4514 && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
4515 || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
4517 if (type == OP_AND || type == OP_OR) {
4523 if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
4525 prepend_not = 1; /* prepend a NOT op later */
4529 /* search for a constant op that could let us fold the test */
4530 if ((cstop = search_const(first))) {
4531 if (cstop->op_private & OPpCONST_STRICT)
4532 no_bareword_allowed(cstop);
4533 else if ((cstop->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
4534 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
4535 if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) ||
4536 (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
4537 (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
4539 if (other->op_type == OP_CONST)
4540 other->op_private |= OPpCONST_SHORTCIRCUIT;
4542 OP *newop = newUNOP(OP_NULL, 0, other);
4543 op_getmad(first, newop, '1');
4544 newop->op_targ = type; /* set "was" field */
4551 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
4552 const OP *o2 = other;
4553 if ( ! (o2->op_type == OP_LIST
4554 && (( o2 = cUNOPx(o2)->op_first))
4555 && o2->op_type == OP_PUSHMARK
4556 && (( o2 = o2->op_sibling)) )
4559 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
4560 || o2->op_type == OP_PADHV)
4561 && o2->op_private & OPpLVAL_INTRO
4562 && !(o2->op_private & OPpPAD_STATE)
4563 && ckWARN(WARN_DEPRECATED))
4565 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4566 "Deprecated use of my() in false conditional");
4570 if (first->op_type == OP_CONST)
4571 first->op_private |= OPpCONST_SHORTCIRCUIT;
4573 first = newUNOP(OP_NULL, 0, first);
4574 op_getmad(other, first, '2');
4575 first->op_targ = type; /* set "was" field */
4582 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
4583 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
4585 const OP * const k1 = ((UNOP*)first)->op_first;
4586 const OP * const k2 = k1->op_sibling;
4588 switch (first->op_type)
4591 if (k2 && k2->op_type == OP_READLINE
4592 && (k2->op_flags & OPf_STACKED)
4593 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4595 warnop = k2->op_type;
4600 if (k1->op_type == OP_READDIR
4601 || k1->op_type == OP_GLOB
4602 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4603 || k1->op_type == OP_EACH)
4605 warnop = ((k1->op_type == OP_NULL)
4606 ? (OPCODE)k1->op_targ : k1->op_type);
4611 const line_t oldline = CopLINE(PL_curcop);
4612 CopLINE_set(PL_curcop, PL_parser->copline);
4613 Perl_warner(aTHX_ packWARN(WARN_MISC),
4614 "Value of %s%s can be \"0\"; test with defined()",
4616 ((warnop == OP_READLINE || warnop == OP_GLOB)
4617 ? " construct" : "() operator"));
4618 CopLINE_set(PL_curcop, oldline);
4625 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
4626 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
4628 NewOp(1101, logop, 1, LOGOP);
4630 logop->op_type = (OPCODE)type;
4631 logop->op_ppaddr = PL_ppaddr[type];
4632 logop->op_first = first;
4633 logop->op_flags = (U8)(flags | OPf_KIDS);
4634 logop->op_other = LINKLIST(other);
4635 logop->op_private = (U8)(1 | (flags >> 8));
4637 /* establish postfix order */
4638 logop->op_next = LINKLIST(first);
4639 first->op_next = (OP*)logop;
4640 first->op_sibling = other;
4642 CHECKOP(type,logop);
4644 o = newUNOP(prepend_not ? OP_NOT : OP_NULL, 0, (OP*)logop);
4651 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
4659 PERL_ARGS_ASSERT_NEWCONDOP;
4662 return newLOGOP(OP_AND, 0, first, trueop);
4664 return newLOGOP(OP_OR, 0, first, falseop);
4666 scalarboolean(first);
4667 if ((cstop = search_const(first))) {
4668 /* Left or right arm of the conditional? */
4669 const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
4670 OP *live = left ? trueop : falseop;
4671 OP *const dead = left ? falseop : trueop;
4672 if (cstop->op_private & OPpCONST_BARE &&
4673 cstop->op_private & OPpCONST_STRICT) {
4674 no_bareword_allowed(cstop);
4677 /* This is all dead code when PERL_MAD is not defined. */
4678 live = newUNOP(OP_NULL, 0, live);
4679 op_getmad(first, live, 'C');
4680 op_getmad(dead, live, left ? 'e' : 't');
4687 NewOp(1101, logop, 1, LOGOP);
4688 logop->op_type = OP_COND_EXPR;
4689 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4690 logop->op_first = first;
4691 logop->op_flags = (U8)(flags | OPf_KIDS);
4692 logop->op_private = (U8)(1 | (flags >> 8));
4693 logop->op_other = LINKLIST(trueop);
4694 logop->op_next = LINKLIST(falseop);
4696 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
4699 /* establish postfix order */
4700 start = LINKLIST(first);
4701 first->op_next = (OP*)logop;
4703 first->op_sibling = trueop;
4704 trueop->op_sibling = falseop;
4705 o = newUNOP(OP_NULL, 0, (OP*)logop);
4707 trueop->op_next = falseop->op_next = o;
4714 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4723 PERL_ARGS_ASSERT_NEWRANGE;
4725 NewOp(1101, range, 1, LOGOP);
4727 range->op_type = OP_RANGE;
4728 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4729 range->op_first = left;
4730 range->op_flags = OPf_KIDS;
4731 leftstart = LINKLIST(left);
4732 range->op_other = LINKLIST(right);
4733 range->op_private = (U8)(1 | (flags >> 8));
4735 left->op_sibling = right;
4737 range->op_next = (OP*)range;
4738 flip = newUNOP(OP_FLIP, flags, (OP*)range);
4739 flop = newUNOP(OP_FLOP, 0, flip);
4740 o = newUNOP(OP_NULL, 0, flop);
4742 range->op_next = leftstart;
4744 left->op_next = flip;
4745 right->op_next = flop;
4747 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4748 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4749 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4750 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4752 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4753 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4756 if (!flip->op_private || !flop->op_private)
4757 linklist(o); /* blow off optimizer unless constant */
4763 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4768 const bool once = block && block->op_flags & OPf_SPECIAL &&
4769 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4771 PERL_UNUSED_ARG(debuggable);
4774 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4775 return block; /* do {} while 0 does once */
4776 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4777 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4778 expr = newUNOP(OP_DEFINED, 0,
4779 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4780 } else if (expr->op_flags & OPf_KIDS) {
4781 const OP * const k1 = ((UNOP*)expr)->op_first;
4782 const OP * const k2 = k1 ? k1->op_sibling : NULL;
4783 switch (expr->op_type) {
4785 if (k2 && k2->op_type == OP_READLINE
4786 && (k2->op_flags & OPf_STACKED)
4787 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4788 expr = newUNOP(OP_DEFINED, 0, expr);
4792 if (k1 && (k1->op_type == OP_READDIR
4793 || k1->op_type == OP_GLOB
4794 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4795 || k1->op_type == OP_EACH))
4796 expr = newUNOP(OP_DEFINED, 0, expr);
4802 /* if block is null, the next append_elem() would put UNSTACK, a scalar
4803 * op, in listop. This is wrong. [perl #27024] */
4805 block = newOP(OP_NULL, 0);
4806 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4807 o = new_logop(OP_AND, 0, &expr, &listop);
4810 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4812 if (once && o != listop)
4813 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4816 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
4818 o->op_flags |= flags;
4820 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4825 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
4826 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
4835 PERL_UNUSED_ARG(debuggable);
4838 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4839 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4840 expr = newUNOP(OP_DEFINED, 0,
4841 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4842 } else if (expr->op_flags & OPf_KIDS) {
4843 const OP * const k1 = ((UNOP*)expr)->op_first;
4844 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
4845 switch (expr->op_type) {
4847 if (k2 && k2->op_type == OP_READLINE
4848 && (k2->op_flags & OPf_STACKED)
4849 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4850 expr = newUNOP(OP_DEFINED, 0, expr);
4854 if (k1 && (k1->op_type == OP_READDIR
4855 || k1->op_type == OP_GLOB
4856 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4857 || k1->op_type == OP_EACH))
4858 expr = newUNOP(OP_DEFINED, 0, expr);
4865 block = newOP(OP_NULL, 0);
4866 else if (cont || has_my) {
4867 block = scope(block);
4871 next = LINKLIST(cont);
4874 OP * const unstack = newOP(OP_UNSTACK, 0);
4877 cont = append_elem(OP_LINESEQ, cont, unstack);
4881 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4883 redo = LINKLIST(listop);
4886 PL_parser->copline = (line_t)whileline;
4888 o = new_logop(OP_AND, 0, &expr, &listop);
4889 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4890 op_free(expr); /* oops, it's a while (0) */
4892 return NULL; /* listop already freed by new_logop */
4895 ((LISTOP*)listop)->op_last->op_next =
4896 (o == listop ? redo : LINKLIST(o));
4902 NewOp(1101,loop,1,LOOP);
4903 loop->op_type = OP_ENTERLOOP;
4904 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4905 loop->op_private = 0;
4906 loop->op_next = (OP*)loop;
4909 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4911 loop->op_redoop = redo;
4912 loop->op_lastop = o;
4913 o->op_private |= loopflags;
4916 loop->op_nextop = next;
4918 loop->op_nextop = o;
4920 o->op_flags |= flags;
4921 o->op_private |= (flags >> 8);
4926 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
4931 PADOFFSET padoff = 0;
4936 PERL_ARGS_ASSERT_NEWFOROP;
4939 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4940 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
4941 sv->op_type = OP_RV2GV;
4942 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4944 /* The op_type check is needed to prevent a possible segfault
4945 * if the loop variable is undeclared and 'strict vars' is in
4946 * effect. This is illegal but is nonetheless parsed, so we
4947 * may reach this point with an OP_CONST where we're expecting
4950 if (cUNOPx(sv)->op_first->op_type == OP_GV
4951 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
4952 iterpflags |= OPpITER_DEF;
4954 else if (sv->op_type == OP_PADSV) { /* private variable */
4955 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
4956 padoff = sv->op_targ;
4966 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4968 SV *const namesv = PAD_COMPNAME_SV(padoff);
4970 const char *const name = SvPV_const(namesv, len);
4972 if (len == 2 && name[0] == '$' && name[1] == '_')
4973 iterpflags |= OPpITER_DEF;
4977 const PADOFFSET offset = pad_findmy("$_");
4978 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
4979 sv = newGVOP(OP_GV, 0, PL_defgv);
4984 iterpflags |= OPpITER_DEF;
4986 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4987 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4988 iterflags |= OPf_STACKED;
4990 else if (expr->op_type == OP_NULL &&
4991 (expr->op_flags & OPf_KIDS) &&
4992 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4994 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4995 * set the STACKED flag to indicate that these values are to be
4996 * treated as min/max values by 'pp_iterinit'.
4998 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4999 LOGOP* const range = (LOGOP*) flip->op_first;
5000 OP* const left = range->op_first;
5001 OP* const right = left->op_sibling;
5004 range->op_flags &= ~OPf_KIDS;
5005 range->op_first = NULL;
5007 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
5008 listop->op_first->op_next = range->op_next;
5009 left->op_next = range->op_other;
5010 right->op_next = (OP*)listop;
5011 listop->op_next = listop->op_first;
5014 op_getmad(expr,(OP*)listop,'O');
5018 expr = (OP*)(listop);
5020 iterflags |= OPf_STACKED;
5023 expr = mod(force_list(expr), OP_GREPSTART);
5026 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
5027 append_elem(OP_LIST, expr, scalar(sv))));
5028 assert(!loop->op_next);
5029 /* for my $x () sets OPpLVAL_INTRO;
5030 * for our $x () sets OPpOUR_INTRO */
5031 loop->op_private = (U8)iterpflags;
5032 #ifdef PL_OP_SLAB_ALLOC
5035 NewOp(1234,tmp,1,LOOP);
5036 Copy(loop,tmp,1,LISTOP);
5037 S_op_destroy(aTHX_ (OP*)loop);
5041 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
5043 loop->op_targ = padoff;
5044 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
5046 op_getmad(madsv, (OP*)loop, 'v');
5047 PL_parser->copline = forline;
5048 return newSTATEOP(0, label, wop);
5052 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
5057 PERL_ARGS_ASSERT_NEWLOOPEX;
5059 if (type != OP_GOTO || label->op_type == OP_CONST) {
5060 /* "last()" means "last" */
5061 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
5062 o = newOP(type, OPf_SPECIAL);
5064 o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
5065 ? SvPV_nolen_const(((SVOP*)label)->op_sv)
5069 op_getmad(label,o,'L');
5075 /* Check whether it's going to be a goto &function */
5076 if (label->op_type == OP_ENTERSUB
5077 && !(label->op_flags & OPf_STACKED))
5078 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
5079 o = newUNOP(type, OPf_STACKED, label);
5081 PL_hints |= HINT_BLOCK_SCOPE;
5085 /* if the condition is a literal array or hash
5086 (or @{ ... } etc), make a reference to it.
5089 S_ref_array_or_hash(pTHX_ OP *cond)
5092 && (cond->op_type == OP_RV2AV
5093 || cond->op_type == OP_PADAV
5094 || cond->op_type == OP_RV2HV
5095 || cond->op_type == OP_PADHV))
5097 return newUNOP(OP_REFGEN,
5098 0, mod(cond, OP_REFGEN));
5104 /* These construct the optree fragments representing given()
5107 entergiven and enterwhen are LOGOPs; the op_other pointer
5108 points up to the associated leave op. We need this so we
5109 can put it in the context and make break/continue work.
5110 (Also, of course, pp_enterwhen will jump straight to
5111 op_other if the match fails.)
5115 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
5116 I32 enter_opcode, I32 leave_opcode,
5117 PADOFFSET entertarg)
5123 PERL_ARGS_ASSERT_NEWGIVWHENOP;
5125 NewOp(1101, enterop, 1, LOGOP);
5126 enterop->op_type = (Optype)enter_opcode;
5127 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
5128 enterop->op_flags = (U8) OPf_KIDS;
5129 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
5130 enterop->op_private = 0;
5132 o = newUNOP(leave_opcode, 0, (OP *) enterop);
5135 enterop->op_first = scalar(cond);
5136 cond->op_sibling = block;
5138 o->op_next = LINKLIST(cond);
5139 cond->op_next = (OP *) enterop;
5142 /* This is a default {} block */
5143 enterop->op_first = block;
5144 enterop->op_flags |= OPf_SPECIAL;
5146 o->op_next = (OP *) enterop;
5149 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
5150 entergiven and enterwhen both
5153 enterop->op_next = LINKLIST(block);
5154 block->op_next = enterop->op_other = o;
5159 /* Does this look like a boolean operation? For these purposes
5160 a boolean operation is:
5161 - a subroutine call [*]
5162 - a logical connective
5163 - a comparison operator
5164 - a filetest operator, with the exception of -s -M -A -C
5165 - defined(), exists() or eof()
5166 - /$re/ or $foo =~ /$re/
5168 [*] possibly surprising
5171 S_looks_like_bool(pTHX_ const OP *o)
5175 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
5177 switch(o->op_type) {
5179 return looks_like_bool(cLOGOPo->op_first);
5183 looks_like_bool(cLOGOPo->op_first)
5184 && looks_like_bool(cLOGOPo->op_first->op_sibling));
5188 o->op_flags & OPf_KIDS
5189 && looks_like_bool(cUNOPo->op_first));
5193 case OP_NOT: case OP_XOR:
5194 /* Note that OP_DOR is not here */
5196 case OP_EQ: case OP_NE: case OP_LT:
5197 case OP_GT: case OP_LE: case OP_GE:
5199 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
5200 case OP_I_GT: case OP_I_LE: case OP_I_GE:
5202 case OP_SEQ: case OP_SNE: case OP_SLT:
5203 case OP_SGT: case OP_SLE: case OP_SGE:
5207 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
5208 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
5209 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
5210 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
5211 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
5212 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
5213 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
5214 case OP_FTTEXT: case OP_FTBINARY:
5216 case OP_DEFINED: case OP_EXISTS:
5217 case OP_MATCH: case OP_EOF:
5222 /* Detect comparisons that have been optimized away */
5223 if (cSVOPo->op_sv == &PL_sv_yes
5224 || cSVOPo->op_sv == &PL_sv_no)
5235 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
5238 PERL_ARGS_ASSERT_NEWGIVENOP;
5239 return newGIVWHENOP(
5240 ref_array_or_hash(cond),
5242 OP_ENTERGIVEN, OP_LEAVEGIVEN,
5246 /* If cond is null, this is a default {} block */
5248 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
5250 const bool cond_llb = (!cond || looks_like_bool(cond));
5253 PERL_ARGS_ASSERT_NEWWHENOP;
5258 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
5260 scalar(ref_array_or_hash(cond)));
5263 return newGIVWHENOP(
5265 append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
5266 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
5270 =for apidoc cv_undef
5272 Clear out all the active components of a CV. This can happen either
5273 by an explicit C<undef &foo>, or by the reference count going to zero.
5274 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
5275 children can still follow the full lexical scope chain.
5281 Perl_cv_undef(pTHX_ CV *cv)
5285 PERL_ARGS_ASSERT_CV_UNDEF;
5287 DEBUG_X(PerlIO_printf(Perl_debug_log,
5288 "CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n",
5289 PTR2UV(cv), PTR2UV(PL_comppad))
5293 if (CvFILE(cv) && !CvISXSUB(cv)) {
5294 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
5295 Safefree(CvFILE(cv));
5300 if (!CvISXSUB(cv) && CvROOT(cv)) {
5301 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
5302 Perl_croak(aTHX_ "Can't undef active subroutine");
5305 PAD_SAVE_SETNULLPAD();
5307 op_free(CvROOT(cv));
5312 SvPOK_off(MUTABLE_SV(cv)); /* forget prototype */
5317 /* remove CvOUTSIDE unless this is an undef rather than a free */
5318 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
5319 if (!CvWEAKOUTSIDE(cv))
5320 SvREFCNT_dec(CvOUTSIDE(cv));
5321 CvOUTSIDE(cv) = NULL;
5324 SvREFCNT_dec(MUTABLE_SV(CvXSUBANY(cv).any_ptr));
5327 if (CvISXSUB(cv) && CvXSUB(cv)) {
5330 /* delete all flags except WEAKOUTSIDE */
5331 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
5335 Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
5338 PERL_ARGS_ASSERT_CV_CKPROTO_LEN;
5340 /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
5341 relying on SvCUR, and doubling up the buffer to hold CvFILE(). */
5342 if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
5343 || (p && (len != SvCUR(cv) /* Not the same length. */
5344 || memNE(p, SvPVX_const(cv), len))))
5345 && ckWARN_d(WARN_PROTOTYPE)) {
5346 SV* const msg = sv_newmortal();
5350 gv_efullname3(name = sv_newmortal(), gv, NULL);
5351 sv_setpvs(msg, "Prototype mismatch:");
5353 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
5355 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv));
5357 sv_catpvs(msg, ": none");
5358 sv_catpvs(msg, " vs ");
5360 Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
5362 sv_catpvs(msg, "none");
5363 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
5367 static void const_sv_xsub(pTHX_ CV* cv);
5371 =head1 Optree Manipulation Functions
5373 =for apidoc cv_const_sv
5375 If C<cv> is a constant sub eligible for inlining. returns the constant
5376 value returned by the sub. Otherwise, returns NULL.
5378 Constant subs can be created with C<newCONSTSUB> or as described in
5379 L<perlsub/"Constant Functions">.
5384 Perl_cv_const_sv(pTHX_ const CV *const cv)
5386 PERL_UNUSED_CONTEXT;
5389 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
5391 return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
5394 /* op_const_sv: examine an optree to determine whether it's in-lineable.
5395 * Can be called in 3 ways:
5398 * look for a single OP_CONST with attached value: return the value
5400 * cv && CvCLONE(cv) && !CvCONST(cv)
5402 * examine the clone prototype, and if contains only a single
5403 * OP_CONST referencing a pad const, or a single PADSV referencing
5404 * an outer lexical, return a non-zero value to indicate the CV is
5405 * a candidate for "constizing" at clone time
5409 * We have just cloned an anon prototype that was marked as a const
5410 * candidiate. Try to grab the current value, and in the case of
5411 * PADSV, ignore it if it has multiple references. Return the value.
5415 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
5426 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
5427 o = cLISTOPo->op_first->op_sibling;
5429 for (; o; o = o->op_next) {
5430 const OPCODE type = o->op_type;
5432 if (sv && o->op_next == o)
5434 if (o->op_next != o) {
5435 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
5437 if (type == OP_DBSTATE)
5440 if (type == OP_LEAVESUB || type == OP_RETURN)
5444 if (type == OP_CONST && cSVOPo->op_sv)
5446 else if (cv && type == OP_CONST) {
5447 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5451 else if (cv && type == OP_PADSV) {
5452 if (CvCONST(cv)) { /* newly cloned anon */
5453 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5454 /* the candidate should have 1 ref from this pad and 1 ref
5455 * from the parent */
5456 if (!sv || SvREFCNT(sv) != 2)
5463 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
5464 sv = &PL_sv_undef; /* an arbitrary non-null value */
5479 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5482 /* This would be the return value, but the return cannot be reached. */
5483 OP* pegop = newOP(OP_NULL, 0);
5486 PERL_UNUSED_ARG(floor);
5496 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
5498 NORETURN_FUNCTION_END;
5503 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
5505 return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
5509 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5516 register CV *cv = NULL;
5518 /* If the subroutine has no body, no attributes, and no builtin attributes
5519 then it's just a sub declaration, and we may be able to get away with
5520 storing with a placeholder scalar in the symbol table, rather than a
5521 full GV and CV. If anything is present then it will take a full CV to
5523 const I32 gv_fetch_flags
5524 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5526 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
5527 const char * const name = o ? SvPV_nolen_const(cSVOPo->op_sv) : NULL;
5530 assert(proto->op_type == OP_CONST);
5531 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
5536 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
5537 SV * const sv = sv_newmortal();
5538 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
5539 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
5540 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
5541 aname = SvPVX_const(sv);
5546 gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
5547 : gv_fetchpv(aname ? aname
5548 : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5549 gv_fetch_flags, SVt_PVCV);
5551 if (!PL_madskills) {
5560 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
5561 maximum a prototype before. */
5562 if (SvTYPE(gv) > SVt_NULL) {
5563 if (!SvPOK((const SV *)gv)
5564 && !(SvIOK((const SV *)gv) && SvIVX((const SV *)gv) == -1)
5565 && ckWARN_d(WARN_PROTOTYPE))
5567 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
5569 cv_ckproto_len((const CV *)gv, NULL, ps, ps_len);
5572 sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
5574 sv_setiv(MUTABLE_SV(gv), -1);
5576 SvREFCNT_dec(PL_compcv);
5577 cv = PL_compcv = NULL;
5581 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
5583 if (!block || !ps || *ps || attrs
5584 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5586 || block->op_type == OP_NULL
5591 const_sv = op_const_sv(block, NULL);
5594 const bool exists = CvROOT(cv) || CvXSUB(cv);
5596 /* if the subroutine doesn't exist and wasn't pre-declared
5597 * with a prototype, assume it will be AUTOLOADed,
5598 * skipping the prototype check
5600 if (exists || SvPOK(cv))
5601 cv_ckproto_len(cv, gv, ps, ps_len);
5602 /* already defined (or promised)? */
5603 if (exists || GvASSUMECV(gv)) {
5606 || block->op_type == OP_NULL
5609 if (CvFLAGS(PL_compcv)) {
5610 /* might have had built-in attrs applied */
5611 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5613 /* just a "sub foo;" when &foo is already defined */
5614 SAVEFREESV(PL_compcv);
5619 && block->op_type != OP_NULL
5622 if (ckWARN(WARN_REDEFINE)
5624 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
5626 const line_t oldline = CopLINE(PL_curcop);
5627 if (PL_parser && PL_parser->copline != NOLINE)
5628 CopLINE_set(PL_curcop, PL_parser->copline);
5629 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5630 CvCONST(cv) ? "Constant subroutine %s redefined"
5631 : "Subroutine %s redefined", name);
5632 CopLINE_set(PL_curcop, oldline);
5635 if (!PL_minus_c) /* keep old one around for madskills */
5638 /* (PL_madskills unset in used file.) */
5646 SvREFCNT_inc_simple_void_NN(const_sv);
5648 assert(!CvROOT(cv) && !CvCONST(cv));
5649 sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */
5650 CvXSUBANY(cv).any_ptr = const_sv;
5651 CvXSUB(cv) = const_sv_xsub;
5657 cv = newCONSTSUB(NULL, name, const_sv);
5659 mro_method_changed_in( /* sub Foo::Bar () { 123 } */
5660 (CvGV(cv) && GvSTASH(CvGV(cv)))
5669 SvREFCNT_dec(PL_compcv);
5677 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
5678 * before we clobber PL_compcv.
5682 || block->op_type == OP_NULL
5685 rcv = MUTABLE_SV(cv);
5686 /* Might have had built-in attributes applied -- propagate them. */
5687 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5688 if (CvGV(cv) && GvSTASH(CvGV(cv)))
5689 stash = GvSTASH(CvGV(cv));
5690 else if (CvSTASH(cv))
5691 stash = CvSTASH(cv);
5693 stash = PL_curstash;
5696 /* possibly about to re-define existing subr -- ignore old cv */
5697 rcv = MUTABLE_SV(PL_compcv);
5698 if (name && GvSTASH(gv))
5699 stash = GvSTASH(gv);
5701 stash = PL_curstash;
5703 apply_attrs(stash, rcv, attrs, FALSE);
5705 if (cv) { /* must reuse cv if autoloaded */
5712 || block->op_type == OP_NULL) && !PL_madskills
5715 /* got here with just attrs -- work done, so bug out */
5716 SAVEFREESV(PL_compcv);
5719 /* transfer PL_compcv to cv */
5721 CvFLAGS(cv) = CvFLAGS(PL_compcv);
5722 if (!CvWEAKOUTSIDE(cv))
5723 SvREFCNT_dec(CvOUTSIDE(cv));
5724 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
5725 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
5726 CvOUTSIDE(PL_compcv) = 0;
5727 CvPADLIST(cv) = CvPADLIST(PL_compcv);
5728 CvPADLIST(PL_compcv) = 0;
5729 /* inner references to PL_compcv must be fixed up ... */
5730 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
5731 /* ... before we throw it away */
5732 SvREFCNT_dec(PL_compcv);
5734 if (PERLDB_INTER)/* Advice debugger on the new sub. */
5735 ++PL_sub_generation;
5742 if (strEQ(name, "import")) {
5743 PL_formfeed = MUTABLE_SV(cv);
5744 Perl_warner(aTHX_ packWARN(WARN_VOID), "%lx\n", (long)cv);
5748 mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */
5752 CvFILE_set_from_cop(cv, PL_curcop);
5753 CvSTASH(cv) = PL_curstash;
5756 sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
5758 if (PL_parser && PL_parser->error_count) {
5762 const char *s = strrchr(name, ':');
5764 if (strEQ(s, "BEGIN")) {
5765 const char not_safe[] =
5766 "BEGIN not safe after errors--compilation aborted";
5767 if (PL_in_eval & EVAL_KEEPERR)
5768 Perl_croak(aTHX_ not_safe);
5770 /* force display of errors found but not reported */
5771 sv_catpv(ERRSV, not_safe);
5772 Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
5781 /* If we assign an optree to a PVCV, then we've defined a subroutine that
5782 the debugger could be able to set a breakpoint in, so signal to
5783 pp_entereval that it should not throw away any saved lines at scope
5786 PL_breakable_sub_gen++;
5788 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5789 mod(scalarseq(block), OP_LEAVESUBLV));
5790 block->op_attached = 1;
5793 /* This makes sub {}; work as expected. */
5794 if (block->op_type == OP_STUB) {
5795 OP* const newblock = newSTATEOP(0, NULL, 0);
5797 op_getmad(block,newblock,'B');
5804 block->op_attached = 1;
5805 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5807 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5808 OpREFCNT_set(CvROOT(cv), 1);
5809 CvSTART(cv) = LINKLIST(CvROOT(cv));
5810 CvROOT(cv)->op_next = 0;
5811 CALL_PEEP(CvSTART(cv));
5813 /* now that optimizer has done its work, adjust pad values */
5815 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
5818 assert(!CvCONST(cv));
5819 if (ps && !*ps && op_const_sv(block, cv))
5823 if (name || aname) {
5824 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5825 SV * const sv = newSV(0);
5826 SV * const tmpstr = sv_newmortal();
5827 GV * const db_postponed = gv_fetchpvs("DB::postponed",
5828 GV_ADDMULTI, SVt_PVHV);
5831 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5833 (long)PL_subline, (long)CopLINE(PL_curcop));
5834 gv_efullname3(tmpstr, gv, NULL);
5835 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
5836 SvCUR(tmpstr), sv, 0);
5837 hv = GvHVn(db_postponed);
5838 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
5839 CV * const pcv = GvCV(db_postponed);
5845 call_sv(MUTABLE_SV(pcv), G_DISCARD);
5850 if (name && ! (PL_parser && PL_parser->error_count))
5851 process_special_blocks(name, gv, cv);
5856 PL_parser->copline = NOLINE;
5862 S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
5865 const char *const colon = strrchr(fullname,':');
5866 const char *const name = colon ? colon + 1 : fullname;
5868 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
5871 if (strEQ(name, "BEGIN")) {
5872 const I32 oldscope = PL_scopestack_ix;
5874 SAVECOPFILE(&PL_compiling);
5875 SAVECOPLINE(&PL_compiling);
5877 DEBUG_x( dump_sub(gv) );
5878 Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
5879 GvCV(gv) = 0; /* cv has been hijacked */
5880 call_list(oldscope, PL_beginav);
5882 PL_curcop = &PL_compiling;
5883 CopHINTS_set(&PL_compiling, PL_hints);
5890 if strEQ(name, "END") {
5891 DEBUG_x( dump_sub(gv) );
5892 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
5895 } else if (*name == 'U') {
5896 if (strEQ(name, "UNITCHECK")) {
5897 /* It's never too late to run a unitcheck block */
5898 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
5902 } else if (*name == 'C') {
5903 if (strEQ(name, "CHECK")) {
5904 if (PL_main_start && ckWARN(WARN_VOID))
5905 Perl_warner(aTHX_ packWARN(WARN_VOID),
5906 "Too late to run CHECK block");
5907 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
5911 } else if (*name == 'I') {
5912 if (strEQ(name, "INIT")) {
5913 if (PL_main_start && ckWARN(WARN_VOID))
5914 Perl_warner(aTHX_ packWARN(WARN_VOID),
5915 "Too late to run INIT block");
5916 Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
5922 DEBUG_x( dump_sub(gv) );
5923 GvCV(gv) = 0; /* cv has been hijacked */
5928 =for apidoc newCONSTSUB
5930 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5931 eligible for inlining at compile-time.
5933 Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>,
5934 which won't be called if used as a destructor, but will suppress the overhead
5935 of a call to C<AUTOLOAD>. (This form, however, isn't eligible for inlining at
5942 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
5947 const char *const file = CopFILE(PL_curcop);
5949 SV *const temp_sv = CopFILESV(PL_curcop);
5950 const char *const file = temp_sv ? SvPV_nolen_const(temp_sv) : NULL;
5955 if (IN_PERL_RUNTIME) {
5956 /* at runtime, it's not safe to manipulate PL_curcop: it may be
5957 * an op shared between threads. Use a non-shared COP for our
5959 SAVEVPTR(PL_curcop);
5960 PL_curcop = &PL_compiling;
5962 SAVECOPLINE(PL_curcop);
5963 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
5966 PL_hints &= ~HINT_BLOCK_SCOPE;
5969 SAVESPTR(PL_curstash);
5970 SAVECOPSTASH(PL_curcop);
5971 PL_curstash = stash;
5972 CopSTASH_set(PL_curcop,stash);
5975 /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
5976 and so doesn't get free()d. (It's expected to be from the C pre-
5977 processor __FILE__ directive). But we need a dynamically allocated one,
5978 and we need it to get freed. */
5979 cv = newXS_flags(name, const_sv_xsub, file ? file : "", "",
5980 XS_DYNAMIC_FILENAME);
5981 CvXSUBANY(cv).any_ptr = sv;
5986 CopSTASH_free(PL_curcop);
5994 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
5995 const char *const filename, const char *const proto,
5998 CV *cv = newXS(name, subaddr, filename);
6000 PERL_ARGS_ASSERT_NEWXS_FLAGS;
6002 if (flags & XS_DYNAMIC_FILENAME) {
6003 /* We need to "make arrangements" (ie cheat) to ensure that the
6004 filename lasts as long as the PVCV we just created, but also doesn't
6006 STRLEN filename_len = strlen(filename);
6007 STRLEN proto_and_file_len = filename_len;
6008 char *proto_and_file;
6012 proto_len = strlen(proto);
6013 proto_and_file_len += proto_len;
6015 Newx(proto_and_file, proto_and_file_len + 1, char);
6016 Copy(proto, proto_and_file, proto_len, char);
6017 Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
6020 proto_and_file = savepvn(filename, filename_len);
6023 /* This gets free()d. :-) */
6024 sv_usepvn_flags(MUTABLE_SV(cv), proto_and_file, proto_and_file_len,
6025 SV_HAS_TRAILING_NUL);
6027 /* This gives us the correct prototype, rather than one with the
6028 file name appended. */
6029 SvCUR_set(cv, proto_len);
6033 CvFILE(cv) = proto_and_file + proto_len;
6035 sv_setpv(MUTABLE_SV(cv), proto);
6041 =for apidoc U||newXS
6043 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
6044 static storage, as it is used directly as CvFILE(), without a copy being made.
6050 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
6053 GV * const gv = gv_fetchpv(name ? name :
6054 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
6055 GV_ADDMULTI, SVt_PVCV);
6058 PERL_ARGS_ASSERT_NEWXS;
6061 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
6063 if ((cv = (name ? GvCV(gv) : NULL))) {
6065 /* just a cached method */
6069 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
6070 /* already defined (or promised) */
6071 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
6072 if (ckWARN(WARN_REDEFINE)) {
6073 GV * const gvcv = CvGV(cv);
6075 HV * const stash = GvSTASH(gvcv);
6077 const char *redefined_name = HvNAME_get(stash);
6078 if ( strEQ(redefined_name,"autouse") ) {
6079 const line_t oldline = CopLINE(PL_curcop);
6080 if (PL_parser && PL_parser->copline != NOLINE)
6081 CopLINE_set(PL_curcop, PL_parser->copline);
6082 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6083 CvCONST(cv) ? "Constant subroutine %s redefined"
6084 : "Subroutine %s redefined"
6086 CopLINE_set(PL_curcop, oldline);
6096 if (cv) /* must reuse cv if autoloaded */
6099 cv = MUTABLE_CV(newSV_type(SVt_PVCV));
6103 mro_method_changed_in(GvSTASH(gv)); /* newXS */
6107 (void)gv_fetchfile(filename);
6108 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
6109 an external constant string */
6111 CvXSUB(cv) = subaddr;
6114 process_special_blocks(name, gv, cv);
6126 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
6131 OP* pegop = newOP(OP_NULL, 0);
6135 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
6136 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
6139 if ((cv = GvFORM(gv))) {
6140 if (ckWARN(WARN_REDEFINE)) {
6141 const line_t oldline = CopLINE(PL_curcop);
6142 if (PL_parser && PL_parser->copline != NOLINE)
6143 CopLINE_set(PL_curcop, PL_parser->copline);
6145 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6146 "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
6148 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6149 "Format STDOUT redefined");
6151 CopLINE_set(PL_curcop, oldline);
6158 CvFILE_set_from_cop(cv, PL_curcop);
6161 pad_tidy(padtidy_FORMAT);
6162 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
6163 CvROOT(cv)->op_private |= OPpREFCOUNTED;
6164 OpREFCNT_set(CvROOT(cv), 1);
6165 CvSTART(cv) = LINKLIST(CvROOT(cv));
6166 CvROOT(cv)->op_next = 0;
6167 CALL_PEEP(CvSTART(cv));
6169 op_getmad(o,pegop,'n');
6170 op_getmad_weak(block, pegop, 'b');
6175 PL_parser->copline = NOLINE;
6183 Perl_newANONLIST(pTHX_ OP *o)
6185 return convert(OP_ANONLIST, OPf_SPECIAL, o);
6189 Perl_newANONHASH(pTHX_ OP *o)
6191 return convert(OP_ANONHASH, OPf_SPECIAL, o);
6195 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
6197 return newANONATTRSUB(floor, proto, NULL, block);
6201 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
6203 return newUNOP(OP_REFGEN, 0,
6204 newSVOP(OP_ANONCODE, 0,
6205 MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block))));
6209 Perl_oopsAV(pTHX_ OP *o)
6213 PERL_ARGS_ASSERT_OOPSAV;
6215 switch (o->op_type) {
6217 o->op_type = OP_PADAV;
6218 o->op_ppaddr = PL_ppaddr[OP_PADAV];
6219 return ref(o, OP_RV2AV);
6222 o->op_type = OP_RV2AV;
6223 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
6228 if (ckWARN_d(WARN_INTERNAL))
6229 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
6236 Perl_oopsHV(pTHX_ OP *o)
6240 PERL_ARGS_ASSERT_OOPSHV;
6242 switch (o->op_type) {
6245 o->op_type = OP_PADHV;
6246 o->op_ppaddr = PL_ppaddr[OP_PADHV];
6247 return ref(o, OP_RV2HV);
6251 o->op_type = OP_RV2HV;
6252 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
6257 if (ckWARN_d(WARN_INTERNAL))
6258 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
6265 Perl_newAVREF(pTHX_ OP *o)
6269 PERL_ARGS_ASSERT_NEWAVREF;
6271 if (o->op_type == OP_PADANY) {
6272 o->op_type = OP_PADAV;
6273 o->op_ppaddr = PL_ppaddr[OP_PADAV];
6276 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
6277 && ckWARN(WARN_DEPRECATED)) {
6278 Perl_warner(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 && ckWARN(WARN_DEPRECATED)) {
6306 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
6307 "Using a hash as a reference is deprecated");
6309 return newUNOP(OP_RV2HV, 0, scalar(o));
6313 Perl_newCVREF(pTHX_ I32 flags, OP *o)
6315 return newUNOP(OP_RV2CV, flags, scalar(o));
6319 Perl_newSVREF(pTHX_ OP *o)
6323 PERL_ARGS_ASSERT_NEWSVREF;
6325 if (o->op_type == OP_PADANY) {
6326 o->op_type = OP_PADSV;
6327 o->op_ppaddr = PL_ppaddr[OP_PADSV];
6330 return newUNOP(OP_RV2SV, 0, scalar(o));
6333 /* Check routines. See the comments at the top of this file for details
6334 * on when these are called */
6337 Perl_ck_anoncode(pTHX_ OP *o)
6339 PERL_ARGS_ASSERT_CK_ANONCODE;
6341 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
6343 cSVOPo->op_sv = NULL;
6348 Perl_ck_bitop(pTHX_ OP *o)
6352 PERL_ARGS_ASSERT_CK_BITOP;
6354 #define OP_IS_NUMCOMPARE(op) \
6355 ((op) == OP_LT || (op) == OP_I_LT || \
6356 (op) == OP_GT || (op) == OP_I_GT || \
6357 (op) == OP_LE || (op) == OP_I_LE || \
6358 (op) == OP_GE || (op) == OP_I_GE || \
6359 (op) == OP_EQ || (op) == OP_I_EQ || \
6360 (op) == OP_NE || (op) == OP_I_NE || \
6361 (op) == OP_NCMP || (op) == OP_I_NCMP)
6362 o->op_private = (U8)(PL_hints & HINT_INTEGER);
6363 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
6364 && (o->op_type == OP_BIT_OR
6365 || o->op_type == OP_BIT_AND
6366 || o->op_type == OP_BIT_XOR))
6368 const OP * const left = cBINOPo->op_first;
6369 const OP * const right = left->op_sibling;
6370 if ((OP_IS_NUMCOMPARE(left->op_type) &&
6371 (left->op_flags & OPf_PARENS) == 0) ||
6372 (OP_IS_NUMCOMPARE(right->op_type) &&
6373 (right->op_flags & OPf_PARENS) == 0))
6374 if (ckWARN(WARN_PRECEDENCE))
6375 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
6376 "Possible precedence problem on bitwise %c operator",
6377 o->op_type == OP_BIT_OR ? '|'
6378 : o->op_type == OP_BIT_AND ? '&' : '^'
6385 Perl_ck_concat(pTHX_ OP *o)
6387 const OP * const kid = cUNOPo->op_first;
6389 PERL_ARGS_ASSERT_CK_CONCAT;
6390 PERL_UNUSED_CONTEXT;
6392 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
6393 !(kUNOP->op_first->op_flags & OPf_MOD))
6394 o->op_flags |= OPf_STACKED;
6399 Perl_ck_spair(pTHX_ OP *o)
6403 PERL_ARGS_ASSERT_CK_SPAIR;
6405 if (o->op_flags & OPf_KIDS) {
6408 const OPCODE type = o->op_type;
6409 o = modkids(ck_fun(o), type);
6410 kid = cUNOPo->op_first;
6411 newop = kUNOP->op_first->op_sibling;
6413 const OPCODE type = newop->op_type;
6414 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
6415 type == OP_PADAV || type == OP_PADHV ||
6416 type == OP_RV2AV || type == OP_RV2HV)
6420 op_getmad(kUNOP->op_first,newop,'K');
6422 op_free(kUNOP->op_first);
6424 kUNOP->op_first = newop;
6426 o->op_ppaddr = PL_ppaddr[++o->op_type];
6431 Perl_ck_delete(pTHX_ OP *o)
6433 PERL_ARGS_ASSERT_CK_DELETE;
6437 if (o->op_flags & OPf_KIDS) {
6438 OP * const kid = cUNOPo->op_first;
6439 switch (kid->op_type) {
6441 o->op_flags |= OPf_SPECIAL;
6444 o->op_private |= OPpSLICE;
6447 o->op_flags |= OPf_SPECIAL;
6452 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
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 && ckWARN(WARN_SYNTAX))
6849 Perl_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 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6859 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6860 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
6861 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6863 op_getmad(kid,newop,'K');
6868 kid->op_sibling = sibl;
6871 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
6872 bad_type(numargs, "array", PL_op_desc[type], kid);
6876 if (kid->op_type == OP_CONST &&
6877 (kid->op_private & OPpCONST_BARE))
6879 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
6880 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
6881 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6882 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6883 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
6884 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6886 op_getmad(kid,newop,'K');
6891 kid->op_sibling = sibl;
6894 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
6895 bad_type(numargs, "hash", PL_op_desc[type], kid);
6900 OP * const newop = newUNOP(OP_NULL, 0, kid);
6901 kid->op_sibling = 0;
6903 newop->op_next = newop;
6905 kid->op_sibling = sibl;
6910 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
6911 if (kid->op_type == OP_CONST &&
6912 (kid->op_private & OPpCONST_BARE))
6914 OP * const newop = newGVOP(OP_GV, 0,
6915 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
6916 if (!(o->op_private & 1) && /* if not unop */
6917 kid == cLISTOPo->op_last)
6918 cLISTOPo->op_last = newop;
6920 op_getmad(kid,newop,'K');
6926 else if (kid->op_type == OP_READLINE) {
6927 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
6928 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
6931 I32 flags = OPf_SPECIAL;
6935 /* is this op a FH constructor? */
6936 if (is_handle_constructor(o,numargs)) {
6937 const char *name = NULL;
6941 /* Set a flag to tell rv2gv to vivify
6942 * need to "prove" flag does not mean something
6943 * else already - NI-S 1999/05/07
6946 if (kid->op_type == OP_PADSV) {
6948 = PAD_COMPNAME_SV(kid->op_targ);
6949 name = SvPV_const(namesv, len);
6951 else if (kid->op_type == OP_RV2SV
6952 && kUNOP->op_first->op_type == OP_GV)
6954 GV * const gv = cGVOPx_gv(kUNOP->op_first);
6956 len = GvNAMELEN(gv);
6958 else if (kid->op_type == OP_AELEM
6959 || kid->op_type == OP_HELEM)
6962 OP *op = ((BINOP*)kid)->op_first;
6966 const char * const a =
6967 kid->op_type == OP_AELEM ?
6969 if (((op->op_type == OP_RV2AV) ||
6970 (op->op_type == OP_RV2HV)) &&
6971 (firstop = ((UNOP*)op)->op_first) &&
6972 (firstop->op_type == OP_GV)) {
6973 /* packagevar $a[] or $h{} */
6974 GV * const gv = cGVOPx_gv(firstop);
6982 else if (op->op_type == OP_PADAV
6983 || op->op_type == OP_PADHV) {
6984 /* lexicalvar $a[] or $h{} */
6985 const char * const padname =
6986 PAD_COMPNAME_PV(op->op_targ);
6995 name = SvPV_const(tmpstr, len);
7000 name = "__ANONIO__";
7007 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
7008 namesv = PAD_SVl(targ);
7009 SvUPGRADE(namesv, SVt_PV);
7011 sv_setpvs(namesv, "$");
7012 sv_catpvn(namesv, name, len);
7015 kid->op_sibling = 0;
7016 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
7017 kid->op_targ = targ;
7018 kid->op_private |= priv;
7020 kid->op_sibling = sibl;
7026 mod(scalar(kid), type);
7030 tokid = &kid->op_sibling;
7031 kid = kid->op_sibling;
7034 if (kid && kid->op_type != OP_STUB)
7035 return too_many_arguments(o,OP_DESC(o));
7036 o->op_private |= numargs;
7038 /* FIXME - should the numargs move as for the PERL_MAD case? */
7039 o->op_private |= numargs;
7041 return too_many_arguments(o,OP_DESC(o));
7045 else if (PL_opargs[type] & OA_DEFGV) {
7047 OP *newop = newUNOP(type, 0, newDEFSVOP());
7048 op_getmad(o,newop,'O');
7051 /* Ordering of these two is important to keep f_map.t passing. */
7053 return newUNOP(type, 0, newDEFSVOP());
7058 while (oa & OA_OPTIONAL)
7060 if (oa && oa != OA_LIST)
7061 return too_few_arguments(o,OP_DESC(o));
7067 Perl_ck_glob(pTHX_ OP *o)
7072 PERL_ARGS_ASSERT_CK_GLOB;
7075 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
7076 append_elem(OP_GLOB, o, newDEFSVOP());
7078 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
7079 && GvCVu(gv) && GvIMPORTED_CV(gv)))
7081 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7084 #if !defined(PERL_EXTERNAL_GLOB)
7085 /* XXX this can be tightened up and made more failsafe. */
7086 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7089 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
7090 newSVpvs("File::Glob"), NULL, NULL, NULL);
7091 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7092 glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
7093 GvCV(gv) = GvCV(glob_gv);
7094 SvREFCNT_inc_void(MUTABLE_SV(GvCV(gv)));
7095 GvIMPORTED_CV_on(gv);
7098 #endif /* PERL_EXTERNAL_GLOB */
7100 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7101 append_elem(OP_GLOB, o,
7102 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
7103 o->op_type = OP_LIST;
7104 o->op_ppaddr = PL_ppaddr[OP_LIST];
7105 cLISTOPo->op_first->op_type = OP_PUSHMARK;
7106 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
7107 cLISTOPo->op_first->op_targ = 0;
7108 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
7109 append_elem(OP_LIST, o,
7110 scalar(newUNOP(OP_RV2CV, 0,
7111 newGVOP(OP_GV, 0, gv)))));
7112 o = newUNOP(OP_NULL, 0, ck_subr(o));
7113 o->op_targ = OP_GLOB; /* hint at what it used to be */
7116 gv = newGVgen("main");
7118 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
7124 Perl_ck_grep(pTHX_ OP *o)
7129 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
7132 PERL_ARGS_ASSERT_CK_GREP;
7134 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
7135 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
7137 if (o->op_flags & OPf_STACKED) {
7140 kid = cLISTOPo->op_first->op_sibling;
7141 if (!cUNOPx(kid)->op_next)
7142 Perl_croak(aTHX_ "panic: ck_grep");
7143 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
7146 NewOp(1101, gwop, 1, LOGOP);
7147 kid->op_next = (OP*)gwop;
7148 o->op_flags &= ~OPf_STACKED;
7150 kid = cLISTOPo->op_first->op_sibling;
7151 if (type == OP_MAPWHILE)
7156 if (PL_parser && PL_parser->error_count)
7158 kid = cLISTOPo->op_first->op_sibling;
7159 if (kid->op_type != OP_NULL)
7160 Perl_croak(aTHX_ "panic: ck_grep");
7161 kid = kUNOP->op_first;
7164 NewOp(1101, gwop, 1, LOGOP);
7165 gwop->op_type = type;
7166 gwop->op_ppaddr = PL_ppaddr[type];
7167 gwop->op_first = listkids(o);
7168 gwop->op_flags |= OPf_KIDS;
7169 gwop->op_other = LINKLIST(kid);
7170 kid->op_next = (OP*)gwop;
7171 offset = pad_findmy("$_");
7172 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
7173 o->op_private = gwop->op_private = 0;
7174 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
7177 o->op_private = gwop->op_private = OPpGREP_LEX;
7178 gwop->op_targ = o->op_targ = offset;
7181 kid = cLISTOPo->op_first->op_sibling;
7182 if (!kid || !kid->op_sibling)
7183 return too_few_arguments(o,OP_DESC(o));
7184 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
7185 mod(kid, OP_GREPSTART);
7191 Perl_ck_index(pTHX_ OP *o)
7193 PERL_ARGS_ASSERT_CK_INDEX;
7195 if (o->op_flags & OPf_KIDS) {
7196 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7198 kid = kid->op_sibling; /* get past "big" */
7199 if (kid && kid->op_type == OP_CONST)
7200 fbm_compile(((SVOP*)kid)->op_sv, 0);
7206 Perl_ck_lfun(pTHX_ OP *o)
7208 const OPCODE type = o->op_type;
7210 PERL_ARGS_ASSERT_CK_LFUN;
7212 return modkids(ck_fun(o), type);
7216 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
7218 PERL_ARGS_ASSERT_CK_DEFINED;
7220 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
7221 switch (cUNOPo->op_first->op_type) {
7223 /* This is needed for
7224 if (defined %stash::)
7225 to work. Do not break Tk.
7227 break; /* Globals via GV can be undef */
7229 case OP_AASSIGN: /* Is this a good idea? */
7230 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
7231 "defined(@array) is deprecated");
7232 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
7233 "\t(Maybe you should just omit the defined()?)\n");
7236 /* This is needed for
7237 if (defined %stash::)
7238 to work. Do not break Tk.
7240 break; /* Globals via GV can be undef */
7242 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
7243 "defined(%%hash) is deprecated");
7244 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
7245 "\t(Maybe you should just omit the defined()?)\n");
7256 Perl_ck_readline(pTHX_ OP *o)
7258 PERL_ARGS_ASSERT_CK_READLINE;
7260 if (!(o->op_flags & OPf_KIDS)) {
7262 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
7264 op_getmad(o,newop,'O');
7274 Perl_ck_rfun(pTHX_ OP *o)
7276 const OPCODE type = o->op_type;
7278 PERL_ARGS_ASSERT_CK_RFUN;
7280 return refkids(ck_fun(o), type);
7284 Perl_ck_listiob(pTHX_ OP *o)
7288 PERL_ARGS_ASSERT_CK_LISTIOB;
7290 kid = cLISTOPo->op_first;
7293 kid = cLISTOPo->op_first;
7295 if (kid->op_type == OP_PUSHMARK)
7296 kid = kid->op_sibling;
7297 if (kid && o->op_flags & OPf_STACKED)
7298 kid = kid->op_sibling;
7299 else if (kid && !kid->op_sibling) { /* print HANDLE; */
7300 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
7301 o->op_flags |= OPf_STACKED; /* make it a filehandle */
7302 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
7303 cLISTOPo->op_first->op_sibling = kid;
7304 cLISTOPo->op_last = kid;
7305 kid = kid->op_sibling;
7310 append_elem(o->op_type, o, newDEFSVOP());
7316 Perl_ck_smartmatch(pTHX_ OP *o)
7319 if (0 == (o->op_flags & OPf_SPECIAL)) {
7320 OP *first = cBINOPo->op_first;
7321 OP *second = first->op_sibling;
7323 /* Implicitly take a reference to an array or hash */
7324 first->op_sibling = NULL;
7325 first = cBINOPo->op_first = ref_array_or_hash(first);
7326 second = first->op_sibling = ref_array_or_hash(second);
7328 /* Implicitly take a reference to a regular expression */
7329 if (first->op_type == OP_MATCH) {
7330 first->op_type = OP_QR;
7331 first->op_ppaddr = PL_ppaddr[OP_QR];
7333 if (second->op_type == OP_MATCH) {
7334 second->op_type = OP_QR;
7335 second->op_ppaddr = PL_ppaddr[OP_QR];
7344 Perl_ck_sassign(pTHX_ OP *o)
7347 OP * const kid = cLISTOPo->op_first;
7349 PERL_ARGS_ASSERT_CK_SASSIGN;
7351 /* has a disposable target? */
7352 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
7353 && !(kid->op_flags & OPf_STACKED)
7354 /* Cannot steal the second time! */
7355 && !(kid->op_private & OPpTARGET_MY)
7356 /* Keep the full thing for madskills */
7360 OP * const kkid = kid->op_sibling;
7362 /* Can just relocate the target. */
7363 if (kkid && kkid->op_type == OP_PADSV
7364 && !(kkid->op_private & OPpLVAL_INTRO))
7366 kid->op_targ = kkid->op_targ;
7368 /* Now we do not need PADSV and SASSIGN. */
7369 kid->op_sibling = o->op_sibling; /* NULL */
7370 cLISTOPo->op_first = NULL;
7373 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
7377 if (kid->op_sibling) {
7378 OP *kkid = kid->op_sibling;
7379 if (kkid->op_type == OP_PADSV
7380 && (kkid->op_private & OPpLVAL_INTRO)
7381 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
7382 const PADOFFSET target = kkid->op_targ;
7383 OP *const other = newOP(OP_PADSV,
7385 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
7386 OP *const first = newOP(OP_NULL, 0);
7387 OP *const nullop = newCONDOP(0, first, o, other);
7388 OP *const condop = first->op_next;
7389 /* hijacking PADSTALE for uninitialized state variables */
7390 SvPADSTALE_on(PAD_SVl(target));
7392 condop->op_type = OP_ONCE;
7393 condop->op_ppaddr = PL_ppaddr[OP_ONCE];
7394 condop->op_targ = target;
7395 other->op_targ = target;
7397 /* Because we change the type of the op here, we will skip the
7398 assinment binop->op_last = binop->op_first->op_sibling; at the
7399 end of Perl_newBINOP(). So need to do it here. */
7400 cBINOPo->op_last = cBINOPo->op_first->op_sibling;
7409 Perl_ck_match(pTHX_ OP *o)
7413 PERL_ARGS_ASSERT_CK_MATCH;
7415 if (o->op_type != OP_QR && PL_compcv) {
7416 const PADOFFSET offset = pad_findmy("$_");
7417 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
7418 o->op_targ = offset;
7419 o->op_private |= OPpTARGET_MY;
7422 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
7423 o->op_private |= OPpRUNTIME;
7428 Perl_ck_method(pTHX_ OP *o)
7430 OP * const kid = cUNOPo->op_first;
7432 PERL_ARGS_ASSERT_CK_METHOD;
7434 if (kid->op_type == OP_CONST) {
7435 SV* sv = kSVOP->op_sv;
7436 const char * const method = SvPVX_const(sv);
7437 if (!(strchr(method, ':') || strchr(method, '\''))) {
7439 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
7440 sv = newSVpvn_share(method, SvCUR(sv), 0);
7443 kSVOP->op_sv = NULL;
7445 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
7447 op_getmad(o,cmop,'O');
7458 Perl_ck_null(pTHX_ OP *o)
7460 PERL_ARGS_ASSERT_CK_NULL;
7461 PERL_UNUSED_CONTEXT;
7466 Perl_ck_open(pTHX_ OP *o)
7469 HV * const table = GvHV(PL_hintgv);
7471 PERL_ARGS_ASSERT_CK_OPEN;
7474 SV **svp = hv_fetchs(table, "open_IN", FALSE);
7477 const char *d = SvPV_const(*svp, len);
7478 const I32 mode = mode_from_discipline(d, len);
7479 if (mode & O_BINARY)
7480 o->op_private |= OPpOPEN_IN_RAW;
7481 else if (mode & O_TEXT)
7482 o->op_private |= OPpOPEN_IN_CRLF;
7485 svp = hv_fetchs(table, "open_OUT", FALSE);
7488 const char *d = SvPV_const(*svp, len);
7489 const I32 mode = mode_from_discipline(d, len);
7490 if (mode & O_BINARY)
7491 o->op_private |= OPpOPEN_OUT_RAW;
7492 else if (mode & O_TEXT)
7493 o->op_private |= OPpOPEN_OUT_CRLF;
7496 if (o->op_type == OP_BACKTICK) {
7497 if (!(o->op_flags & OPf_KIDS)) {
7498 OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
7500 op_getmad(o,newop,'O');
7509 /* In case of three-arg dup open remove strictness
7510 * from the last arg if it is a bareword. */
7511 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
7512 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
7516 if ((last->op_type == OP_CONST) && /* The bareword. */
7517 (last->op_private & OPpCONST_BARE) &&
7518 (last->op_private & OPpCONST_STRICT) &&
7519 (oa = first->op_sibling) && /* The fh. */
7520 (oa = oa->op_sibling) && /* The mode. */
7521 (oa->op_type == OP_CONST) &&
7522 SvPOK(((SVOP*)oa)->op_sv) &&
7523 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
7524 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
7525 (last == oa->op_sibling)) /* The bareword. */
7526 last->op_private &= ~OPpCONST_STRICT;
7532 Perl_ck_repeat(pTHX_ OP *o)
7534 PERL_ARGS_ASSERT_CK_REPEAT;
7536 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
7537 o->op_private |= OPpREPEAT_DOLIST;
7538 cBINOPo->op_first = force_list(cBINOPo->op_first);
7546 Perl_ck_require(pTHX_ OP *o)
7551 PERL_ARGS_ASSERT_CK_REQUIRE;
7553 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
7554 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7556 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
7557 SV * const sv = kid->op_sv;
7558 U32 was_readonly = SvREADONLY(sv);
7565 sv_force_normal_flags(sv, 0);
7566 assert(!SvREADONLY(sv));
7576 for (; s < end; s++) {
7577 if (*s == ':' && s[1] == ':') {
7579 Move(s+2, s+1, end - s - 1, char);
7584 sv_catpvs(sv, ".pm");
7585 SvFLAGS(sv) |= was_readonly;
7589 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
7590 /* handle override, if any */
7591 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
7592 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7593 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
7594 gv = gvp ? *gvp : NULL;
7598 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7599 OP * const kid = cUNOPo->op_first;
7602 cUNOPo->op_first = 0;
7606 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
7607 append_elem(OP_LIST, kid,
7608 scalar(newUNOP(OP_RV2CV, 0,
7611 op_getmad(o,newop,'O');
7619 Perl_ck_return(pTHX_ OP *o)
7624 PERL_ARGS_ASSERT_CK_RETURN;
7626 kid = cLISTOPo->op_first->op_sibling;
7627 if (CvLVALUE(PL_compcv)) {
7628 for (; kid; kid = kid->op_sibling)
7629 mod(kid, OP_LEAVESUBLV);
7631 for (; kid; kid = kid->op_sibling)
7632 if ((kid->op_type == OP_NULL)
7633 && ((kid->op_flags & (OPf_SPECIAL|OPf_KIDS)) == (OPf_SPECIAL|OPf_KIDS))) {
7634 /* This is a do block */
7635 OP *op = kUNOP->op_first;
7636 if (op->op_type == OP_LEAVE && op->op_flags & OPf_KIDS) {
7637 op = cUNOPx(op)->op_first;
7638 assert(op->op_type == OP_ENTER && !(op->op_flags & OPf_SPECIAL));
7639 /* Force the use of the caller's context */
7640 op->op_flags |= OPf_SPECIAL;
7649 Perl_ck_select(pTHX_ OP *o)
7654 PERL_ARGS_ASSERT_CK_SELECT;
7656 if (o->op_flags & OPf_KIDS) {
7657 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7658 if (kid && kid->op_sibling) {
7659 o->op_type = OP_SSELECT;
7660 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
7662 return fold_constants(o);
7666 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7667 if (kid && kid->op_type == OP_RV2GV)
7668 kid->op_private &= ~HINT_STRICT_REFS;
7673 Perl_ck_shift(pTHX_ OP *o)
7676 const I32 type = o->op_type;
7678 PERL_ARGS_ASSERT_CK_SHIFT;
7680 if (!(o->op_flags & OPf_KIDS)) {
7682 /* FIXME - this can be refactored to reduce code in #ifdefs */
7684 OP * const oldo = o;
7688 argop = newUNOP(OP_RV2AV, 0,
7689 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
7691 o = newUNOP(type, 0, scalar(argop));
7692 op_getmad(oldo,o,'O');
7695 return newUNOP(type, 0, scalar(argop));
7698 return scalar(modkids(ck_fun(o), type));
7702 Perl_ck_sort(pTHX_ OP *o)
7707 PERL_ARGS_ASSERT_CK_SORT;
7709 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
7710 HV * const hinthv = GvHV(PL_hintgv);
7712 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
7714 const I32 sorthints = (I32)SvIV(*svp);
7715 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
7716 o->op_private |= OPpSORT_QSORT;
7717 if ((sorthints & HINT_SORT_STABLE) != 0)
7718 o->op_private |= OPpSORT_STABLE;
7723 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
7725 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7726 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
7728 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
7730 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
7732 if (kid->op_type == OP_SCOPE) {
7736 else if (kid->op_type == OP_LEAVE) {
7737 if (o->op_type == OP_SORT) {
7738 op_null(kid); /* wipe out leave */
7741 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
7742 if (k->op_next == kid)
7744 /* don't descend into loops */
7745 else if (k->op_type == OP_ENTERLOOP
7746 || k->op_type == OP_ENTERITER)
7748 k = cLOOPx(k)->op_lastop;
7753 kid->op_next = 0; /* just disconnect the leave */
7754 k = kLISTOP->op_first;
7759 if (o->op_type == OP_SORT) {
7760 /* provide scalar context for comparison function/block */
7766 o->op_flags |= OPf_SPECIAL;
7768 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
7771 firstkid = firstkid->op_sibling;
7774 /* provide list context for arguments */
7775 if (o->op_type == OP_SORT)
7782 S_simplify_sort(pTHX_ OP *o)
7785 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7791 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
7793 if (!(o->op_flags & OPf_STACKED))
7795 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7796 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
7797 kid = kUNOP->op_first; /* get past null */
7798 if (kid->op_type != OP_SCOPE)
7800 kid = kLISTOP->op_last; /* get past scope */
7801 switch(kid->op_type) {
7809 k = kid; /* remember this node*/
7810 if (kBINOP->op_first->op_type != OP_RV2SV)
7812 kid = kBINOP->op_first; /* get past cmp */
7813 if (kUNOP->op_first->op_type != OP_GV)
7815 kid = kUNOP->op_first; /* get past rv2sv */
7817 if (GvSTASH(gv) != PL_curstash)
7819 gvname = GvNAME(gv);
7820 if (*gvname == 'a' && gvname[1] == '\0')
7822 else if (*gvname == 'b' && gvname[1] == '\0')
7827 kid = k; /* back to cmp */
7828 if (kBINOP->op_last->op_type != OP_RV2SV)
7830 kid = kBINOP->op_last; /* down to 2nd arg */
7831 if (kUNOP->op_first->op_type != OP_GV)
7833 kid = kUNOP->op_first; /* get past rv2sv */
7835 if (GvSTASH(gv) != PL_curstash)
7837 gvname = GvNAME(gv);
7839 ? !(*gvname == 'a' && gvname[1] == '\0')
7840 : !(*gvname == 'b' && gvname[1] == '\0'))
7842 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
7844 o->op_private |= OPpSORT_DESCEND;
7845 if (k->op_type == OP_NCMP)
7846 o->op_private |= OPpSORT_NUMERIC;
7847 if (k->op_type == OP_I_NCMP)
7848 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
7849 kid = cLISTOPo->op_first->op_sibling;
7850 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
7852 op_getmad(kid,o,'S'); /* then delete it */
7854 op_free(kid); /* then delete it */
7859 Perl_ck_split(pTHX_ OP *o)
7864 PERL_ARGS_ASSERT_CK_SPLIT;
7866 if (o->op_flags & OPf_STACKED)
7867 return no_fh_allowed(o);
7869 kid = cLISTOPo->op_first;
7870 if (kid->op_type != OP_NULL)
7871 Perl_croak(aTHX_ "panic: ck_split");
7872 kid = kid->op_sibling;
7873 op_free(cLISTOPo->op_first);
7874 cLISTOPo->op_first = kid;
7876 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
7877 cLISTOPo->op_last = kid; /* There was only one element previously */
7880 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
7881 OP * const sibl = kid->op_sibling;
7882 kid->op_sibling = 0;
7883 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
7884 if (cLISTOPo->op_first == cLISTOPo->op_last)
7885 cLISTOPo->op_last = kid;
7886 cLISTOPo->op_first = kid;
7887 kid->op_sibling = sibl;
7890 kid->op_type = OP_PUSHRE;
7891 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
7893 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
7894 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
7895 "Use of /g modifier is meaningless in split");
7898 if (!kid->op_sibling)
7899 append_elem(OP_SPLIT, o, newDEFSVOP());
7901 kid = kid->op_sibling;
7904 if (!kid->op_sibling)
7905 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
7906 assert(kid->op_sibling);
7908 kid = kid->op_sibling;
7911 if (kid->op_sibling)
7912 return too_many_arguments(o,OP_DESC(o));
7918 Perl_ck_join(pTHX_ OP *o)
7920 const OP * const kid = cLISTOPo->op_first->op_sibling;
7922 PERL_ARGS_ASSERT_CK_JOIN;
7924 if (kid && kid->op_type == OP_MATCH) {
7925 if (ckWARN(WARN_SYNTAX)) {
7926 const REGEXP *re = PM_GETRE(kPMOP);
7927 const char *pmstr = re ? RX_PRECOMP_const(re) : "STRING";
7928 const STRLEN len = re ? RX_PRELEN(re) : 6;
7929 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7930 "/%.*s/ should probably be written as \"%.*s\"",
7931 (int)len, pmstr, (int)len, pmstr);
7938 Perl_ck_subr(pTHX_ OP *o)
7941 OP *prev = ((cUNOPo->op_first->op_sibling)
7942 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
7943 OP *o2 = prev->op_sibling;
7945 const char *proto = NULL;
7946 const char *proto_end = NULL;
7951 I32 contextclass = 0;
7952 const char *e = NULL;
7955 PERL_ARGS_ASSERT_CK_SUBR;
7957 o->op_private |= OPpENTERSUB_HASTARG;
7958 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
7959 if (cvop->op_type == OP_RV2CV) {
7961 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
7962 op_null(cvop); /* disable rv2cv */
7963 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
7964 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
7965 GV *gv = cGVOPx_gv(tmpop);
7968 tmpop->op_private |= OPpEARLY_CV;
7972 namegv = CvANON(cv) ? gv : CvGV(cv);
7973 proto = SvPV(MUTABLE_SV(cv), len);
7974 proto_end = proto + len;
7979 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7980 if (o2->op_type == OP_CONST)
7981 o2->op_private &= ~OPpCONST_STRICT;
7982 else if (o2->op_type == OP_LIST) {
7983 OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
7984 if (sib && sib->op_type == OP_CONST)
7985 sib->op_private &= ~OPpCONST_STRICT;
7988 o->op_private |= (PL_hints & HINT_STRICT_REFS);
7989 if (PERLDB_SUB && PL_curstash != PL_debstash)
7990 o->op_private |= OPpENTERSUB_DB;
7991 while (o2 != cvop) {
7993 if (PL_madskills && o2->op_type == OP_STUB) {
7994 o2 = o2->op_sibling;
7997 if (PL_madskills && o2->op_type == OP_NULL)
7998 o3 = ((UNOP*)o2)->op_first;
8002 if (proto >= proto_end)
8003 return too_many_arguments(o, gv_ename(namegv));
8011 /* _ must be at the end */
8012 if (proto[1] && proto[1] != ';')
8027 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
8029 arg == 1 ? "block or sub {}" : "sub {}",
8030 gv_ename(namegv), o3);
8033 /* '*' allows any scalar type, including bareword */
8036 if (o3->op_type == OP_RV2GV)
8037 goto wrapref; /* autoconvert GLOB -> GLOBref */
8038 else if (o3->op_type == OP_CONST)
8039 o3->op_private &= ~OPpCONST_STRICT;
8040 else if (o3->op_type == OP_ENTERSUB) {
8041 /* accidental subroutine, revert to bareword */
8042 OP *gvop = ((UNOP*)o3)->op_first;
8043 if (gvop && gvop->op_type == OP_NULL) {
8044 gvop = ((UNOP*)gvop)->op_first;
8046 for (; gvop->op_sibling; gvop = gvop->op_sibling)
8049 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
8050 (gvop = ((UNOP*)gvop)->op_first) &&
8051 gvop->op_type == OP_GV)
8053 GV * const gv = cGVOPx_gv(gvop);
8054 OP * const sibling = o2->op_sibling;
8055 SV * const n = newSVpvs("");
8057 OP * const oldo2 = o2;
8061 gv_fullname4(n, gv, "", FALSE);
8062 o2 = newSVOP(OP_CONST, 0, n);
8063 op_getmad(oldo2,o2,'O');
8064 prev->op_sibling = o2;
8065 o2->op_sibling = sibling;
8081 if (contextclass++ == 0) {
8082 e = strchr(proto, ']');
8083 if (!e || e == proto)
8092 const char *p = proto;
8093 const char *const end = proto;
8095 while (*--p != '[') {}
8096 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
8098 gv_ename(namegv), o3);
8103 if (o3->op_type == OP_RV2GV)
8106 bad_type(arg, "symbol", gv_ename(namegv), o3);
8109 if (o3->op_type == OP_ENTERSUB)
8112 bad_type(arg, "subroutine entry", gv_ename(namegv),
8116 if (o3->op_type == OP_RV2SV ||
8117 o3->op_type == OP_PADSV ||
8118 o3->op_type == OP_HELEM ||
8119 o3->op_type == OP_AELEM)
8122 bad_type(arg, "scalar", gv_ename(namegv), o3);
8125 if (o3->op_type == OP_RV2AV ||
8126 o3->op_type == OP_PADAV)
8129 bad_type(arg, "array", gv_ename(namegv), o3);
8132 if (o3->op_type == OP_RV2HV ||
8133 o3->op_type == OP_PADHV)
8136 bad_type(arg, "hash", gv_ename(namegv), o3);
8141 OP* const sib = kid->op_sibling;
8142 kid->op_sibling = 0;
8143 o2 = newUNOP(OP_REFGEN, 0, kid);
8144 o2->op_sibling = sib;
8145 prev->op_sibling = o2;
8147 if (contextclass && e) {
8162 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
8163 gv_ename(namegv), SVfARG(cv));
8168 mod(o2, OP_ENTERSUB);
8170 o2 = o2->op_sibling;
8172 if (o2 == cvop && proto && *proto == '_') {
8173 /* generate an access to $_ */
8175 o2->op_sibling = prev->op_sibling;
8176 prev->op_sibling = o2; /* instead of cvop */
8178 if (proto && !optional && proto_end > proto &&
8179 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
8180 return too_few_arguments(o, gv_ename(namegv));
8183 OP * const oldo = o;
8187 o=newSVOP(OP_CONST, 0, newSViv(0));
8188 op_getmad(oldo,o,'O');
8194 Perl_ck_svconst(pTHX_ OP *o)
8196 PERL_ARGS_ASSERT_CK_SVCONST;
8197 PERL_UNUSED_CONTEXT;
8198 SvREADONLY_on(cSVOPo->op_sv);
8203 Perl_ck_chdir(pTHX_ OP *o)
8205 if (o->op_flags & OPf_KIDS) {
8206 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8208 if (kid && kid->op_type == OP_CONST &&
8209 (kid->op_private & OPpCONST_BARE))
8211 o->op_flags |= OPf_SPECIAL;
8212 kid->op_private &= ~OPpCONST_STRICT;
8219 Perl_ck_trunc(pTHX_ OP *o)
8221 PERL_ARGS_ASSERT_CK_TRUNC;
8223 if (o->op_flags & OPf_KIDS) {
8224 SVOP *kid = (SVOP*)cUNOPo->op_first;
8226 if (kid->op_type == OP_NULL)
8227 kid = (SVOP*)kid->op_sibling;
8228 if (kid && kid->op_type == OP_CONST &&
8229 (kid->op_private & OPpCONST_BARE))
8231 o->op_flags |= OPf_SPECIAL;
8232 kid->op_private &= ~OPpCONST_STRICT;
8239 Perl_ck_unpack(pTHX_ OP *o)
8241 OP *kid = cLISTOPo->op_first;
8243 PERL_ARGS_ASSERT_CK_UNPACK;
8245 if (kid->op_sibling) {
8246 kid = kid->op_sibling;
8247 if (!kid->op_sibling)
8248 kid->op_sibling = newDEFSVOP();
8254 Perl_ck_substr(pTHX_ OP *o)
8256 PERL_ARGS_ASSERT_CK_SUBSTR;
8259 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
8260 OP *kid = cLISTOPo->op_first;
8262 if (kid->op_type == OP_NULL)
8263 kid = kid->op_sibling;
8265 kid->op_flags |= OPf_MOD;
8272 Perl_ck_each(pTHX_ OP *o)
8275 OP *kid = cLISTOPo->op_first;
8277 PERL_ARGS_ASSERT_CK_EACH;
8279 if (kid->op_type == OP_PADAV || kid->op_type == OP_RV2AV) {
8280 const unsigned new_type = o->op_type == OP_EACH ? OP_AEACH
8281 : o->op_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
8282 o->op_type = new_type;
8283 o->op_ppaddr = PL_ppaddr[new_type];
8285 else if (!(kid->op_type == OP_PADHV || kid->op_type == OP_RV2HV
8286 || (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE)
8288 bad_type(1, "hash or array", PL_op_desc[o->op_type], kid);
8294 /* A peephole optimizer. We visit the ops in the order they're to execute.
8295 * See the comments at the top of this file for more details about when
8296 * peep() is called */
8299 Perl_peep(pTHX_ register OP *o)
8302 register OP* oldop = NULL;
8304 if (!o || o->op_opt)
8308 SAVEVPTR(PL_curcop);
8309 for (; o; o = o->op_next) {
8312 /* By default, this op has now been optimised. A couple of cases below
8313 clear this again. */
8316 switch (o->op_type) {
8319 PL_curcop = ((COP*)o); /* for warnings */
8323 if (cSVOPo->op_private & OPpCONST_STRICT)
8324 no_bareword_allowed(o);
8327 case OP_METHOD_NAMED:
8328 /* Relocate sv to the pad for thread safety.
8329 * Despite being a "constant", the SV is written to,
8330 * for reference counts, sv_upgrade() etc. */
8332 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
8333 if (o->op_type != OP_METHOD_NAMED && SvPADTMP(cSVOPo->op_sv)) {
8334 /* If op_sv is already a PADTMP then it is being used by
8335 * some pad, so make a copy. */
8336 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
8337 SvREADONLY_on(PAD_SVl(ix));
8338 SvREFCNT_dec(cSVOPo->op_sv);
8340 else if (o->op_type != OP_METHOD_NAMED
8341 && cSVOPo->op_sv == &PL_sv_undef) {
8342 /* PL_sv_undef is hack - it's unsafe to store it in the
8343 AV that is the pad, because av_fetch treats values of
8344 PL_sv_undef as a "free" AV entry and will merrily
8345 replace them with a new SV, causing pad_alloc to think
8346 that this pad slot is free. (When, clearly, it is not)
8348 SvOK_off(PAD_SVl(ix));
8349 SvPADTMP_on(PAD_SVl(ix));
8350 SvREADONLY_on(PAD_SVl(ix));
8353 SvREFCNT_dec(PAD_SVl(ix));
8354 SvPADTMP_on(cSVOPo->op_sv);
8355 PAD_SETSV(ix, cSVOPo->op_sv);
8356 /* XXX I don't know how this isn't readonly already. */
8357 SvREADONLY_on(PAD_SVl(ix));
8359 cSVOPo->op_sv = NULL;
8366 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
8367 if (o->op_next->op_private & OPpTARGET_MY) {
8368 if (o->op_flags & OPf_STACKED) /* chained concats */
8369 break; /* ignore_optimization */
8371 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
8372 o->op_targ = o->op_next->op_targ;
8373 o->op_next->op_targ = 0;
8374 o->op_private |= OPpTARGET_MY;
8377 op_null(o->op_next);
8381 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
8382 break; /* Scalar stub must produce undef. List stub is noop */
8386 if (o->op_targ == OP_NEXTSTATE
8387 || o->op_targ == OP_DBSTATE)
8389 PL_curcop = ((COP*)o);
8391 /* XXX: We avoid setting op_seq here to prevent later calls
8392 to peep() from mistakenly concluding that optimisation
8393 has already occurred. This doesn't fix the real problem,
8394 though (See 20010220.007). AMS 20010719 */
8395 /* op_seq functionality is now replaced by op_opt */
8402 if (oldop && o->op_next) {
8403 oldop->op_next = o->op_next;
8411 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
8412 OP* const pop = (o->op_type == OP_PADAV) ?
8413 o->op_next : o->op_next->op_next;
8415 if (pop && pop->op_type == OP_CONST &&
8416 ((PL_op = pop->op_next)) &&
8417 pop->op_next->op_type == OP_AELEM &&
8418 !(pop->op_next->op_private &
8419 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
8420 (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
8425 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
8426 no_bareword_allowed(pop);
8427 if (o->op_type == OP_GV)
8428 op_null(o->op_next);
8429 op_null(pop->op_next);
8431 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
8432 o->op_next = pop->op_next->op_next;
8433 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
8434 o->op_private = (U8)i;
8435 if (o->op_type == OP_GV) {
8440 o->op_flags |= OPf_SPECIAL;
8441 o->op_type = OP_AELEMFAST;
8446 if (o->op_next->op_type == OP_RV2SV) {
8447 if (!(o->op_next->op_private & OPpDEREF)) {
8448 op_null(o->op_next);
8449 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
8451 o->op_next = o->op_next->op_next;
8452 o->op_type = OP_GVSV;
8453 o->op_ppaddr = PL_ppaddr[OP_GVSV];
8456 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
8457 GV * const gv = cGVOPo_gv;
8458 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
8459 /* XXX could check prototype here instead of just carping */
8460 SV * const sv = sv_newmortal();
8461 gv_efullname3(sv, gv, NULL);
8462 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
8463 "%"SVf"() called too early to check prototype",
8467 else if (o->op_next->op_type == OP_READLINE
8468 && o->op_next->op_next->op_type == OP_CONCAT
8469 && (o->op_next->op_next->op_flags & OPf_STACKED))
8471 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
8472 o->op_type = OP_RCATLINE;
8473 o->op_flags |= OPf_STACKED;
8474 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
8475 op_null(o->op_next->op_next);
8476 op_null(o->op_next);
8492 while (cLOGOP->op_other->op_type == OP_NULL)
8493 cLOGOP->op_other = cLOGOP->op_other->op_next;
8494 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
8499 while (cLOOP->op_redoop->op_type == OP_NULL)
8500 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
8501 peep(cLOOP->op_redoop);
8502 while (cLOOP->op_nextop->op_type == OP_NULL)
8503 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
8504 peep(cLOOP->op_nextop);
8505 while (cLOOP->op_lastop->op_type == OP_NULL)
8506 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
8507 peep(cLOOP->op_lastop);
8511 assert(!(cPMOP->op_pmflags & PMf_ONCE));
8512 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
8513 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
8514 cPMOP->op_pmstashstartu.op_pmreplstart
8515 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
8516 peep(cPMOP->op_pmstashstartu.op_pmreplstart);
8520 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
8521 && ckWARN(WARN_SYNTAX))
8523 if (o->op_next->op_sibling) {
8524 const OPCODE type = o->op_next->op_sibling->op_type;
8525 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
8526 const line_t oldline = CopLINE(PL_curcop);
8527 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
8528 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8529 "Statement unlikely to be reached");
8530 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8531 "\t(Maybe you meant system() when you said exec()?)\n");
8532 CopLINE_set(PL_curcop, oldline);
8543 const char *key = NULL;
8546 if (((BINOP*)o)->op_last->op_type != OP_CONST)
8549 /* Make the CONST have a shared SV */
8550 svp = cSVOPx_svp(((BINOP*)o)->op_last);
8551 if (!SvFAKE(sv = *svp) || !SvREADONLY(sv)) {
8552 key = SvPV_const(sv, keylen);
8553 lexname = newSVpvn_share(key,
8554 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
8560 if ((o->op_private & (OPpLVAL_INTRO)))
8563 rop = (UNOP*)((BINOP*)o)->op_first;
8564 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
8566 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
8567 if (!SvPAD_TYPED(lexname))
8569 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8570 if (!fields || !GvHV(*fields))
8572 key = SvPV_const(*svp, keylen);
8573 if (!hv_fetch(GvHV(*fields), key,
8574 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8576 Perl_croak(aTHX_ "No such class field \"%s\" "
8577 "in variable %s of type %s",
8578 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
8591 SVOP *first_key_op, *key_op;
8593 if ((o->op_private & (OPpLVAL_INTRO))
8594 /* I bet there's always a pushmark... */
8595 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
8596 /* hmmm, no optimization if list contains only one key. */
8598 rop = (UNOP*)((LISTOP*)o)->op_last;
8599 if (rop->op_type != OP_RV2HV)
8601 if (rop->op_first->op_type == OP_PADSV)
8602 /* @$hash{qw(keys here)} */
8603 rop = (UNOP*)rop->op_first;
8605 /* @{$hash}{qw(keys here)} */
8606 if (rop->op_first->op_type == OP_SCOPE
8607 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
8609 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
8615 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
8616 if (!SvPAD_TYPED(lexname))
8618 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8619 if (!fields || !GvHV(*fields))
8621 /* Again guessing that the pushmark can be jumped over.... */
8622 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
8623 ->op_first->op_sibling;
8624 for (key_op = first_key_op; key_op;
8625 key_op = (SVOP*)key_op->op_sibling) {
8626 if (key_op->op_type != OP_CONST)
8628 svp = cSVOPx_svp(key_op);
8629 key = SvPV_const(*svp, keylen);
8630 if (!hv_fetch(GvHV(*fields), key,
8631 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8633 Perl_croak(aTHX_ "No such class field \"%s\" "
8634 "in variable %s of type %s",
8635 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
8642 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
8646 /* check that RHS of sort is a single plain array */
8647 OP *oright = cUNOPo->op_first;
8648 if (!oright || oright->op_type != OP_PUSHMARK)
8651 /* reverse sort ... can be optimised. */
8652 if (!cUNOPo->op_sibling) {
8653 /* Nothing follows us on the list. */
8654 OP * const reverse = o->op_next;
8656 if (reverse->op_type == OP_REVERSE &&
8657 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
8658 OP * const pushmark = cUNOPx(reverse)->op_first;
8659 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
8660 && (cUNOPx(pushmark)->op_sibling == o)) {
8661 /* reverse -> pushmark -> sort */
8662 o->op_private |= OPpSORT_REVERSE;
8664 pushmark->op_next = oright->op_next;
8670 /* make @a = sort @a act in-place */
8672 oright = cUNOPx(oright)->op_sibling;
8675 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
8676 oright = cUNOPx(oright)->op_sibling;
8680 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
8681 || oright->op_next != o
8682 || (oright->op_private & OPpLVAL_INTRO)
8686 /* o2 follows the chain of op_nexts through the LHS of the
8687 * assign (if any) to the aassign op itself */
8689 if (!o2 || o2->op_type != OP_NULL)
8692 if (!o2 || o2->op_type != OP_PUSHMARK)
8695 if (o2 && o2->op_type == OP_GV)
8698 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
8699 || (o2->op_private & OPpLVAL_INTRO)
8704 if (!o2 || o2->op_type != OP_NULL)
8707 if (!o2 || o2->op_type != OP_AASSIGN
8708 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
8711 /* check that the sort is the first arg on RHS of assign */
8713 o2 = cUNOPx(o2)->op_first;
8714 if (!o2 || o2->op_type != OP_NULL)
8716 o2 = cUNOPx(o2)->op_first;
8717 if (!o2 || o2->op_type != OP_PUSHMARK)
8719 if (o2->op_sibling != o)
8722 /* check the array is the same on both sides */
8723 if (oleft->op_type == OP_RV2AV) {
8724 if (oright->op_type != OP_RV2AV
8725 || !cUNOPx(oright)->op_first
8726 || cUNOPx(oright)->op_first->op_type != OP_GV
8727 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
8728 cGVOPx_gv(cUNOPx(oright)->op_first)
8732 else if (oright->op_type != OP_PADAV
8733 || oright->op_targ != oleft->op_targ
8737 /* transfer MODishness etc from LHS arg to RHS arg */
8738 oright->op_flags = oleft->op_flags;
8739 o->op_private |= OPpSORT_INPLACE;
8741 /* excise push->gv->rv2av->null->aassign */
8742 o2 = o->op_next->op_next;
8743 op_null(o2); /* PUSHMARK */
8745 if (o2->op_type == OP_GV) {
8746 op_null(o2); /* GV */
8749 op_null(o2); /* RV2AV or PADAV */
8750 o2 = o2->op_next->op_next;
8751 op_null(o2); /* AASSIGN */
8753 o->op_next = o2->op_next;
8759 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
8761 LISTOP *enter, *exlist;
8763 enter = (LISTOP *) o->op_next;
8766 if (enter->op_type == OP_NULL) {
8767 enter = (LISTOP *) enter->op_next;
8771 /* for $a (...) will have OP_GV then OP_RV2GV here.
8772 for (...) just has an OP_GV. */
8773 if (enter->op_type == OP_GV) {
8774 gvop = (OP *) enter;
8775 enter = (LISTOP *) enter->op_next;
8778 if (enter->op_type == OP_RV2GV) {
8779 enter = (LISTOP *) enter->op_next;
8785 if (enter->op_type != OP_ENTERITER)
8788 iter = enter->op_next;
8789 if (!iter || iter->op_type != OP_ITER)
8792 expushmark = enter->op_first;
8793 if (!expushmark || expushmark->op_type != OP_NULL
8794 || expushmark->op_targ != OP_PUSHMARK)
8797 exlist = (LISTOP *) expushmark->op_sibling;
8798 if (!exlist || exlist->op_type != OP_NULL
8799 || exlist->op_targ != OP_LIST)
8802 if (exlist->op_last != o) {
8803 /* Mmm. Was expecting to point back to this op. */
8806 theirmark = exlist->op_first;
8807 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
8810 if (theirmark->op_sibling != o) {
8811 /* There's something between the mark and the reverse, eg
8812 for (1, reverse (...))
8817 ourmark = ((LISTOP *)o)->op_first;
8818 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
8821 ourlast = ((LISTOP *)o)->op_last;
8822 if (!ourlast || ourlast->op_next != o)
8825 rv2av = ourmark->op_sibling;
8826 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
8827 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
8828 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
8829 /* We're just reversing a single array. */
8830 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
8831 enter->op_flags |= OPf_STACKED;
8834 /* We don't have control over who points to theirmark, so sacrifice
8836 theirmark->op_next = ourmark->op_next;
8837 theirmark->op_flags = ourmark->op_flags;
8838 ourlast->op_next = gvop ? gvop : (OP *) enter;
8841 enter->op_private |= OPpITER_REVERSED;
8842 iter->op_private |= OPpITER_REVERSED;
8849 UNOP *refgen, *rv2cv;
8852 if ((o->op_flags & OPf_WANT) != OPf_WANT_VOID)
8855 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
8858 rv2gv = ((BINOP *)o)->op_last;
8859 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
8862 refgen = (UNOP *)((BINOP *)o)->op_first;
8864 if (!refgen || refgen->op_type != OP_REFGEN)
8867 exlist = (LISTOP *)refgen->op_first;
8868 if (!exlist || exlist->op_type != OP_NULL
8869 || exlist->op_targ != OP_LIST)
8872 if (exlist->op_first->op_type != OP_PUSHMARK)
8875 rv2cv = (UNOP*)exlist->op_last;
8877 if (rv2cv->op_type != OP_RV2CV)
8880 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
8881 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
8882 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
8884 o->op_private |= OPpASSIGN_CV_TO_GV;
8885 rv2gv->op_private |= OPpDONT_INIT_GV;
8886 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
8894 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
8895 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
8905 Perl_custom_op_name(pTHX_ const OP* o)
8908 const IV index = PTR2IV(o->op_ppaddr);
8912 PERL_ARGS_ASSERT_CUSTOM_OP_NAME;
8914 if (!PL_custom_op_names) /* This probably shouldn't happen */
8915 return (char *)PL_op_name[OP_CUSTOM];
8917 keysv = sv_2mortal(newSViv(index));
8919 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
8921 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
8923 return SvPV_nolen(HeVAL(he));
8927 Perl_custom_op_desc(pTHX_ const OP* o)
8930 const IV index = PTR2IV(o->op_ppaddr);
8934 PERL_ARGS_ASSERT_CUSTOM_OP_DESC;
8936 if (!PL_custom_op_descs)
8937 return (char *)PL_op_desc[OP_CUSTOM];
8939 keysv = sv_2mortal(newSViv(index));
8941 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
8943 return (char *)PL_op_desc[OP_CUSTOM];
8945 return SvPV_nolen(HeVAL(he));
8950 /* Efficient sub that returns a constant scalar value. */
8952 const_sv_xsub(pTHX_ CV* cv)
8956 SV *const sv = MUTABLE_SV(XSANY.any_ptr);
8960 Perl_croak(aTHX_ "usage: %s::%s()",
8961 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
8974 * c-indentation-style: bsd
8976 * indent-tabs-mode: t
8979 * ex: set ts=8 sts=4 sw=4 noet: