3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * "You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
13 * our Mr. Bilbo's first cousin on the mother's side (her mother being the
14 * youngest of the Old Took's daughters); and Mr. Drogo was his second
15 * cousin. So Mr. Frodo is his first *and* second cousin, once removed
16 * either way, as the saying is, if you follow me." --the Gaffer
19 /* This file contains the functions that create, manipulate and optimize
20 * the OP structures that hold a compiled perl program.
22 * A Perl program is compiled into a tree of OPs. Each op contains
23 * structural pointers (eg to its siblings and the next op in the
24 * execution sequence), a pointer to the function that would execute the
25 * op, plus any data specific to that op. For example, an OP_CONST op
26 * points to the pp_const() function and to an SV containing the constant
27 * value. When pp_const() is executed, its job is to push that SV onto the
30 * OPs are mainly created by the newFOO() functions, which are mainly
31 * called from the parser (in perly.y) as the code is parsed. For example
32 * the Perl code $a + $b * $c would cause the equivalent of the following
33 * to be called (oversimplifying a bit):
35 * newBINOP(OP_ADD, flags,
37 * newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
40 * Note that during the build of miniperl, a temporary copy of this file
41 * is made, called opmini.c.
45 Perl's compiler is essentially a 3-pass compiler with interleaved phases:
49 An execution-order pass
51 The bottom-up pass is represented by all the "newOP" routines and
52 the ck_ routines. The bottom-upness is actually driven by yacc.
53 So at the point that a ck_ routine fires, we have no idea what the
54 context is, either upward in the syntax tree, or either forward or
55 backward in the execution order. (The bottom-up parser builds that
56 part of the execution order it knows about, but if you follow the "next"
57 links around, you'll find it's actually a closed loop through the
60 Whenever the bottom-up parser gets to a node that supplies context to
61 its components, it invokes that portion of the top-down pass that applies
62 to that part of the subtree (and marks the top node as processed, so
63 if a node further up supplies context, it doesn't have to take the
64 plunge again). As a particular subcase of this, as the new node is
65 built, it takes all the closed execution loops of its subcomponents
66 and links them into a new closed loop for the higher level node. But
67 it's still not the real execution order.
69 The actual execution order is not known till we get a grammar reduction
70 to a top-level unit like a subroutine or file that will be called by
71 "name" rather than via a "next" pointer. At that point, we can call
72 into peep() to do that code's portion of the 3rd pass. It has to be
73 recursive, but it's recursive on basic blocks, not on tree nodes.
76 /* To implement user lexical pragmas, there needs to be a way at run time to
77 get the compile time state of %^H for that block. Storing %^H in every
78 block (or even COP) would be very expensive, so a different approach is
79 taken. The (running) state of %^H is serialised into a tree of HE-like
80 structs. Stores into %^H are chained onto the current leaf as a struct
81 refcounted_he * with the key and the value. Deletes from %^H are saved
82 with a value of PL_sv_placeholder. The state of %^H at any point can be
83 turned back into a regular HV by walking back up the tree from that point's
84 leaf, ignoring any key you've already seen (placeholder or not), storing
85 the rest into the HV structure, then removing the placeholders. Hence
86 memory is only used to store the %^H deltas from the enclosing COP, rather
87 than the entire %^H on each COP.
89 To cause actions on %^H to write out the serialisation records, it has
90 magic type 'H'. This magic (itself) does nothing, but its presence causes
91 the values to gain magic type 'h', which has entries for set and clear.
92 C<Perl_magic_sethint> updates C<PL_compiling.cop_hints_hash> with a store
93 record, with deletes written by C<Perl_magic_clearhint>. C<SAVEHINTS>
94 saves the current C<PL_compiling.cop_hints_hash> on the save stack, so that
95 it will be correctly restored when any inner compiling scope is exited.
101 #include "keywords.h"
103 #define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
105 #if defined(PL_OP_SLAB_ALLOC)
107 #ifdef PERL_DEBUG_READONLY_OPS
108 # define PERL_SLAB_SIZE 4096
109 # include <sys/mman.h>
112 #ifndef PERL_SLAB_SIZE
113 #define PERL_SLAB_SIZE 2048
117 Perl_Slab_Alloc(pTHX_ size_t sz)
121 * To make incrementing use count easy PL_OpSlab is an I32 *
122 * To make inserting the link to slab PL_OpPtr is I32 **
123 * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
124 * Add an overhead for pointer to slab and round up as a number of pointers
126 sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
127 if ((PL_OpSpace -= sz) < 0) {
128 #ifdef PERL_DEBUG_READONLY_OPS
129 /* We need to allocate chunk by chunk so that we can control the VM
131 PL_OpPtr = (I32**) mmap(0, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE,
132 MAP_ANON|MAP_PRIVATE, -1, 0);
134 DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
135 (unsigned long) PERL_SLAB_SIZE*sizeof(I32*),
137 if(PL_OpPtr == MAP_FAILED) {
138 perror("mmap failed");
143 PL_OpPtr = (I32 **) PerlMemShared_calloc(PERL_SLAB_SIZE,sizeof(I32*));
148 /* We reserve the 0'th I32 sized chunk as a use count */
149 PL_OpSlab = (I32 *) PL_OpPtr;
150 /* Reduce size by the use count word, and by the size we need.
151 * Latter is to mimic the '-=' in the if() above
153 PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
154 /* Allocation pointer starts at the top.
155 Theory: because we build leaves before trunk allocating at end
156 means that at run time access is cache friendly upward
158 PL_OpPtr += PERL_SLAB_SIZE;
160 #ifdef PERL_DEBUG_READONLY_OPS
161 /* We remember this slab. */
162 /* This implementation isn't efficient, but it is simple. */
163 PL_slabs = (I32**) realloc(PL_slabs, sizeof(I32**) * (PL_slab_count + 1));
164 PL_slabs[PL_slab_count++] = PL_OpSlab;
165 DEBUG_m(PerlIO_printf(Perl_debug_log, "Allocate %p\n", PL_OpSlab));
168 assert( PL_OpSpace >= 0 );
169 /* Move the allocation pointer down */
171 assert( PL_OpPtr > (I32 **) PL_OpSlab );
172 *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */
173 (*PL_OpSlab)++; /* Increment use count of slab */
174 assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
175 assert( *PL_OpSlab > 0 );
176 return (void *)(PL_OpPtr + 1);
179 #ifdef PERL_DEBUG_READONLY_OPS
181 Perl_pending_Slabs_to_ro(pTHX) {
182 /* Turn all the allocated op slabs read only. */
183 U32 count = PL_slab_count;
184 I32 **const slabs = PL_slabs;
186 /* Reset the array of pending OP slabs, as we're about to turn this lot
187 read only. Also, do it ahead of the loop in case the warn triggers,
188 and a warn handler has an eval */
193 /* Force a new slab for any further allocation. */
197 void *const start = slabs[count];
198 const size_t size = PERL_SLAB_SIZE* sizeof(I32*);
199 if(mprotect(start, size, PROT_READ)) {
200 Perl_warn(aTHX_ "mprotect for %p %lu failed with %d",
201 start, (unsigned long) size, errno);
209 S_Slab_to_rw(pTHX_ void *op)
211 I32 * const * const ptr = (I32 **) op;
212 I32 * const slab = ptr[-1];
214 PERL_ARGS_ASSERT_SLAB_TO_RW;
216 assert( ptr-1 > (I32 **) slab );
217 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
219 if(mprotect(slab, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE)) {
220 Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d",
221 slab, (unsigned long) PERL_SLAB_SIZE*sizeof(I32*), errno);
226 Perl_op_refcnt_inc(pTHX_ OP *o)
237 Perl_op_refcnt_dec(pTHX_ OP *o)
239 PERL_ARGS_ASSERT_OP_REFCNT_DEC;
244 # define Slab_to_rw(op)
248 Perl_Slab_Free(pTHX_ void *op)
250 I32 * const * const ptr = (I32 **) op;
251 I32 * const slab = ptr[-1];
252 PERL_ARGS_ASSERT_SLAB_FREE;
253 assert( ptr-1 > (I32 **) slab );
254 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
257 if (--(*slab) == 0) {
259 # define PerlMemShared PerlMem
262 #ifdef PERL_DEBUG_READONLY_OPS
263 U32 count = PL_slab_count;
264 /* Need to remove this slab from our list of slabs */
267 if (PL_slabs[count] == slab) {
269 /* Found it. Move the entry at the end to overwrite it. */
270 DEBUG_m(PerlIO_printf(Perl_debug_log,
271 "Deallocate %p by moving %p from %lu to %lu\n",
273 PL_slabs[PL_slab_count - 1],
274 PL_slab_count, count));
275 PL_slabs[count] = PL_slabs[--PL_slab_count];
276 /* Could realloc smaller at this point, but probably not
278 if(munmap(slab, PERL_SLAB_SIZE*sizeof(I32*))) {
279 perror("munmap failed");
287 PerlMemShared_free(slab);
289 if (slab == PL_OpSlab) {
296 * In the following definition, the ", (OP*)0" is just to make the compiler
297 * think the expression is of the right type: croak actually does a Siglongjmp.
299 #define CHECKOP(type,o) \
300 ((PL_op_mask && PL_op_mask[type]) \
301 ? ( op_free((OP*)o), \
302 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
304 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
306 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
309 S_gv_ename(pTHX_ GV *gv)
311 SV* const tmpsv = sv_newmortal();
313 PERL_ARGS_ASSERT_GV_ENAME;
315 gv_efullname3(tmpsv, gv, NULL);
316 return SvPV_nolen_const(tmpsv);
320 S_no_fh_allowed(pTHX_ OP *o)
322 PERL_ARGS_ASSERT_NO_FH_ALLOWED;
324 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
330 S_too_few_arguments(pTHX_ OP *o, const char *name)
332 PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS;
334 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
339 S_too_many_arguments(pTHX_ OP *o, const char *name)
341 PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS;
343 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
348 S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid)
350 PERL_ARGS_ASSERT_BAD_TYPE;
352 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
353 (int)n, name, t, OP_DESC(kid)));
357 S_no_bareword_allowed(pTHX_ const OP *o)
359 PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
362 return; /* various ok barewords are hidden in extra OP_NULL */
363 qerror(Perl_mess(aTHX_
364 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
368 /* "register" allocation */
371 Perl_allocmy(pTHX_ const char *const name)
375 const bool is_our = (PL_parser->in_my == KEY_our);
377 PERL_ARGS_ASSERT_ALLOCMY;
379 /* complain about "my $<special_var>" etc etc */
383 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
384 (name[1] == '_' && (*name == '$' || name[2]))))
386 /* name[2] is true if strlen(name) > 2 */
387 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
388 yyerror(Perl_form(aTHX_ "Can't use global %c^%c%s in \"%s\"",
389 name[0], toCTRL(name[1]), name + 2,
390 PL_parser->in_my == KEY_state ? "state" : "my"));
392 yyerror(Perl_form(aTHX_ "Can't use global %s in \"%s\"",name,
393 PL_parser->in_my == KEY_state ? "state" : "my"));
397 /* check for duplicate declaration */
398 pad_check_dup(name, is_our, (PL_curstash ? PL_curstash : PL_defstash));
400 if (PL_parser->in_my_stash && *name != '$') {
401 yyerror(Perl_form(aTHX_
402 "Can't declare class for non-scalar %s in \"%s\"",
405 : PL_parser->in_my == KEY_state ? "state" : "my"));
408 /* allocate a spare slot and store the name in that slot */
410 off = pad_add_name(name,
411 PL_parser->in_my_stash,
413 /* $_ is always in main::, even with our */
414 ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
418 PL_parser->in_my == KEY_state
420 /* anon sub prototypes contains state vars should always be cloned,
421 * otherwise the state var would be shared between anon subs */
423 if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
424 CvCLONE_on(PL_compcv);
429 /* free the body of an op without examining its contents.
430 * Always use this rather than FreeOp directly */
433 S_op_destroy(pTHX_ OP *o)
435 if (o->op_latefree) {
443 # define forget_pmop(a,b) S_forget_pmop(aTHX_ a,b)
445 # define forget_pmop(a,b) S_forget_pmop(aTHX_ a)
451 Perl_op_free(pTHX_ OP *o)
458 if (o->op_latefreed) {
465 if (o->op_private & OPpREFCOUNTED) {
476 refcnt = OpREFCNT_dec(o);
479 /* Need to find and remove any pattern match ops from the list
480 we maintain for reset(). */
481 find_and_forget_pmops(o);
491 if (o->op_flags & OPf_KIDS) {
492 register OP *kid, *nextkid;
493 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
494 nextkid = kid->op_sibling; /* Get before next freeing kid */
499 type = (OPCODE)o->op_targ;
501 #ifdef PERL_DEBUG_READONLY_OPS
505 /* COP* is not cleared by op_clear() so that we may track line
506 * numbers etc even after null() */
507 if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
512 if (o->op_latefree) {
518 #ifdef DEBUG_LEAKING_SCALARS
525 Perl_op_clear(pTHX_ OP *o)
530 PERL_ARGS_ASSERT_OP_CLEAR;
533 /* if (o->op_madprop && o->op_madprop->mad_next)
535 /* FIXME for MAD - if I uncomment these two lines t/op/pack.t fails with
536 "modification of a read only value" for a reason I can't fathom why.
537 It's the "" stringification of $_, where $_ was set to '' in a foreach
538 loop, but it defies simplification into a small test case.
539 However, commenting them out has caused ext/List/Util/t/weak.t to fail
542 mad_free(o->op_madprop);
548 switch (o->op_type) {
549 case OP_NULL: /* Was holding old type, if any. */
550 if (PL_madskills && o->op_targ != OP_NULL) {
551 o->op_type = (optype)o->op_targ;
555 case OP_ENTEREVAL: /* Was holding hints. */
559 if (!(o->op_flags & OPf_REF)
560 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
566 if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
567 /* not an OP_PADAV replacement */
569 if (cPADOPo->op_padix > 0) {
570 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
571 * may still exist on the pad */
572 pad_swipe(cPADOPo->op_padix, TRUE);
573 cPADOPo->op_padix = 0;
576 SvREFCNT_dec(cSVOPo->op_sv);
577 cSVOPo->op_sv = NULL;
581 case OP_METHOD_NAMED:
584 SvREFCNT_dec(cSVOPo->op_sv);
585 cSVOPo->op_sv = NULL;
588 Even if op_clear does a pad_free for the target of the op,
589 pad_free doesn't actually remove the sv that exists in the pad;
590 instead it lives on. This results in that it could be reused as
591 a target later on when the pad was reallocated.
594 pad_swipe(o->op_targ,1);
603 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
607 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
609 if (cPADOPo->op_padix > 0) {
610 pad_swipe(cPADOPo->op_padix, TRUE);
611 cPADOPo->op_padix = 0;
614 SvREFCNT_dec(cSVOPo->op_sv);
615 cSVOPo->op_sv = NULL;
619 PerlMemShared_free(cPVOPo->op_pv);
620 cPVOPo->op_pv = NULL;
624 op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
628 if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
629 /* No GvIN_PAD_off here, because other references may still
630 * exist on the pad */
631 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
634 SvREFCNT_dec((SV*)cPMOPo->op_pmreplrootu.op_pmtargetgv);
640 forget_pmop(cPMOPo, 1);
641 cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
642 /* we use the same protection as the "SAFE" version of the PM_ macros
643 * here since sv_clean_all might release some PMOPs
644 * after PL_regex_padav has been cleared
645 * and the clearing of PL_regex_padav needs to
646 * happen before sv_clean_all
649 if(PL_regex_pad) { /* We could be in destruction */
650 const IV offset = (cPMOPo)->op_pmoffset;
651 ReREFCNT_dec(PM_GETRE(cPMOPo));
652 PL_regex_pad[offset] = &PL_sv_undef;
653 sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
657 ReREFCNT_dec(PM_GETRE(cPMOPo));
658 PM_SETRE(cPMOPo, NULL);
664 if (o->op_targ > 0) {
665 pad_free(o->op_targ);
671 S_cop_free(pTHX_ COP* cop)
673 PERL_ARGS_ASSERT_COP_FREE;
677 if (! specialWARN(cop->cop_warnings))
678 PerlMemShared_free(cop->cop_warnings);
679 Perl_refcounted_he_free(aTHX_ cop->cop_hints_hash);
683 S_forget_pmop(pTHX_ PMOP *const o
689 HV * const pmstash = PmopSTASH(o);
691 PERL_ARGS_ASSERT_FORGET_PMOP;
693 if (pmstash && !SvIS_FREED(pmstash)) {
694 MAGIC * const mg = mg_find((SV*)pmstash, PERL_MAGIC_symtab);
696 PMOP **const array = (PMOP**) mg->mg_ptr;
697 U32 count = mg->mg_len / sizeof(PMOP**);
702 /* Found it. Move the entry at the end to overwrite it. */
703 array[i] = array[--count];
704 mg->mg_len = count * sizeof(PMOP**);
705 /* Could realloc smaller at this point always, but probably
706 not worth it. Probably worth free()ing if we're the
709 Safefree(mg->mg_ptr);
726 S_find_and_forget_pmops(pTHX_ OP *o)
728 PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
730 if (o->op_flags & OPf_KIDS) {
731 OP *kid = cUNOPo->op_first;
733 switch (kid->op_type) {
738 forget_pmop((PMOP*)kid, 0);
740 find_and_forget_pmops(kid);
741 kid = kid->op_sibling;
747 Perl_op_null(pTHX_ OP *o)
751 PERL_ARGS_ASSERT_OP_NULL;
753 if (o->op_type == OP_NULL)
757 o->op_targ = o->op_type;
758 o->op_type = OP_NULL;
759 o->op_ppaddr = PL_ppaddr[OP_NULL];
763 Perl_op_refcnt_lock(pTHX)
771 Perl_op_refcnt_unlock(pTHX)
778 /* Contextualizers */
780 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
783 Perl_linklist(pTHX_ OP *o)
787 PERL_ARGS_ASSERT_LINKLIST;
792 /* establish postfix order */
793 first = cUNOPo->op_first;
796 o->op_next = LINKLIST(first);
799 if (kid->op_sibling) {
800 kid->op_next = LINKLIST(kid->op_sibling);
801 kid = kid->op_sibling;
815 Perl_scalarkids(pTHX_ OP *o)
817 if (o && o->op_flags & OPf_KIDS) {
819 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
826 S_scalarboolean(pTHX_ OP *o)
830 PERL_ARGS_ASSERT_SCALARBOOLEAN;
832 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
833 if (ckWARN(WARN_SYNTAX)) {
834 const line_t oldline = CopLINE(PL_curcop);
836 if (PL_parser && PL_parser->copline != NOLINE)
837 CopLINE_set(PL_curcop, PL_parser->copline);
838 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
839 CopLINE_set(PL_curcop, oldline);
846 Perl_scalar(pTHX_ OP *o)
851 /* assumes no premature commitment */
852 if (!o || (PL_parser && PL_parser->error_count)
853 || (o->op_flags & OPf_WANT)
854 || o->op_type == OP_RETURN)
859 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
861 switch (o->op_type) {
863 scalar(cBINOPo->op_first);
868 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
872 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
873 if (!kPMOP->op_pmreplrootu.op_pmreplroot)
874 deprecate_old("implicit split to @_");
882 if (o->op_flags & OPf_KIDS) {
883 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
889 kid = cLISTOPo->op_first;
891 while ((kid = kid->op_sibling)) {
897 PL_curcop = &PL_compiling;
902 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
908 PL_curcop = &PL_compiling;
911 if (ckWARN(WARN_VOID))
912 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
919 Perl_scalarvoid(pTHX_ OP *o)
923 const char* useless = NULL;
927 PERL_ARGS_ASSERT_SCALARVOID;
929 /* trailing mad null ops don't count as "there" for void processing */
931 o->op_type != OP_NULL &&
933 o->op_sibling->op_type == OP_NULL)
936 for (sib = o->op_sibling;
937 sib && sib->op_type == OP_NULL;
938 sib = sib->op_sibling) ;
944 if (o->op_type == OP_NEXTSTATE
945 || o->op_type == OP_DBSTATE
946 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
947 || o->op_targ == OP_DBSTATE)))
948 PL_curcop = (COP*)o; /* for warning below */
950 /* assumes no premature commitment */
951 want = o->op_flags & OPf_WANT;
952 if ((want && want != OPf_WANT_SCALAR)
953 || (PL_parser && PL_parser->error_count)
954 || o->op_type == OP_RETURN)
959 if ((o->op_private & OPpTARGET_MY)
960 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
962 return scalar(o); /* As if inside SASSIGN */
965 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
967 switch (o->op_type) {
969 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
973 if (o->op_flags & OPf_STACKED)
977 if (o->op_private == 4)
1020 case OP_GETSOCKNAME:
1021 case OP_GETPEERNAME:
1026 case OP_GETPRIORITY:
1050 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1051 /* Otherwise it's "Useless use of grep iterator" */
1052 useless = OP_DESC(o);
1056 kid = cUNOPo->op_first;
1057 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1058 kid->op_type != OP_TRANS) {
1061 useless = "negative pattern binding (!~)";
1068 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1069 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1070 useless = "a variable";
1075 if (cSVOPo->op_private & OPpCONST_STRICT)
1076 no_bareword_allowed(o);
1078 if (ckWARN(WARN_VOID)) {
1080 SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_
1081 "a constant (%"SVf")", sv));
1082 useless = SvPV_nolen(msv);
1085 useless = "a constant (undef)";
1086 if (o->op_private & OPpCONST_ARYBASE)
1088 /* don't warn on optimised away booleans, eg
1089 * use constant Foo, 5; Foo || print; */
1090 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1092 /* the constants 0 and 1 are permitted as they are
1093 conventionally used as dummies in constructs like
1094 1 while some_condition_with_side_effects; */
1095 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1097 else if (SvPOK(sv)) {
1098 /* perl4's way of mixing documentation and code
1099 (before the invention of POD) was based on a
1100 trick to mix nroff and perl code. The trick was
1101 built upon these three nroff macros being used in
1102 void context. The pink camel has the details in
1103 the script wrapman near page 319. */
1104 const char * const maybe_macro = SvPVX_const(sv);
1105 if (strnEQ(maybe_macro, "di", 2) ||
1106 strnEQ(maybe_macro, "ds", 2) ||
1107 strnEQ(maybe_macro, "ig", 2))
1112 op_null(o); /* don't execute or even remember it */
1116 o->op_type = OP_PREINC; /* pre-increment is faster */
1117 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1121 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1122 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1126 o->op_type = OP_I_PREINC; /* pre-increment is faster */
1127 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1131 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
1132 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1141 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1146 if (o->op_flags & OPf_STACKED)
1153 if (!(o->op_flags & OPf_KIDS))
1164 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1171 /* all requires must return a boolean value */
1172 o->op_flags &= ~OPf_WANT;
1177 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
1178 if (!kPMOP->op_pmreplrootu.op_pmreplroot)
1179 deprecate_old("implicit split to @_");
1183 if (useless && ckWARN(WARN_VOID))
1184 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
1189 Perl_listkids(pTHX_ OP *o)
1191 if (o && o->op_flags & OPf_KIDS) {
1193 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1200 Perl_list(pTHX_ OP *o)
1205 /* assumes no premature commitment */
1206 if (!o || (o->op_flags & OPf_WANT)
1207 || (PL_parser && PL_parser->error_count)
1208 || o->op_type == OP_RETURN)
1213 if ((o->op_private & OPpTARGET_MY)
1214 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1216 return o; /* As if inside SASSIGN */
1219 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1221 switch (o->op_type) {
1224 list(cBINOPo->op_first);
1229 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1237 if (!(o->op_flags & OPf_KIDS))
1239 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1240 list(cBINOPo->op_first);
1241 return gen_constant_list(o);
1248 kid = cLISTOPo->op_first;
1250 while ((kid = kid->op_sibling)) {
1251 if (kid->op_sibling)
1256 PL_curcop = &PL_compiling;
1260 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1261 if (kid->op_sibling)
1266 PL_curcop = &PL_compiling;
1269 /* all requires must return a boolean value */
1270 o->op_flags &= ~OPf_WANT;
1277 Perl_scalarseq(pTHX_ OP *o)
1281 const OPCODE type = o->op_type;
1283 if (type == OP_LINESEQ || type == OP_SCOPE ||
1284 type == OP_LEAVE || type == OP_LEAVETRY)
1287 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1288 if (kid->op_sibling) {
1292 PL_curcop = &PL_compiling;
1294 o->op_flags &= ~OPf_PARENS;
1295 if (PL_hints & HINT_BLOCK_SCOPE)
1296 o->op_flags |= OPf_PARENS;
1299 o = newOP(OP_STUB, 0);
1304 S_modkids(pTHX_ OP *o, I32 type)
1306 if (o && o->op_flags & OPf_KIDS) {
1308 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1314 /* Propagate lvalue ("modifiable") context to an op and its children.
1315 * 'type' represents the context type, roughly based on the type of op that
1316 * would do the modifying, although local() is represented by OP_NULL.
1317 * It's responsible for detecting things that can't be modified, flag
1318 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
1319 * might have to vivify a reference in $x), and so on.
1321 * For example, "$a+1 = 2" would cause mod() to be called with o being
1322 * OP_ADD and type being OP_SASSIGN, and would output an error.
1326 Perl_mod(pTHX_ OP *o, I32 type)
1330 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1333 if (!o || (PL_parser && PL_parser->error_count))
1336 if ((o->op_private & OPpTARGET_MY)
1337 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1342 switch (o->op_type) {
1348 if (!(o->op_private & OPpCONST_ARYBASE))
1351 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1352 CopARYBASE_set(&PL_compiling,
1353 (I32)SvIV(cSVOPx(PL_eval_start)->op_sv));
1357 SAVECOPARYBASE(&PL_compiling);
1358 CopARYBASE_set(&PL_compiling, 0);
1360 else if (type == OP_REFGEN)
1363 Perl_croak(aTHX_ "That use of $[ is unsupported");
1366 if ((o->op_flags & OPf_PARENS) || PL_madskills)
1370 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1371 !(o->op_flags & OPf_STACKED)) {
1372 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1373 /* The default is to set op_private to the number of children,
1374 which for a UNOP such as RV2CV is always 1. And w're using
1375 the bit for a flag in RV2CV, so we need it clear. */
1376 o->op_private &= ~1;
1377 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1378 assert(cUNOPo->op_first->op_type == OP_NULL);
1379 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1382 else if (o->op_private & OPpENTERSUB_NOMOD)
1384 else { /* lvalue subroutine call */
1385 o->op_private |= OPpLVAL_INTRO;
1386 PL_modcount = RETURN_UNLIMITED_NUMBER;
1387 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1388 /* Backward compatibility mode: */
1389 o->op_private |= OPpENTERSUB_INARGS;
1392 else { /* Compile-time error message: */
1393 OP *kid = cUNOPo->op_first;
1397 if (kid->op_type != OP_PUSHMARK) {
1398 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1400 "panic: unexpected lvalue entersub "
1401 "args: type/targ %ld:%"UVuf,
1402 (long)kid->op_type, (UV)kid->op_targ);
1403 kid = kLISTOP->op_first;
1405 while (kid->op_sibling)
1406 kid = kid->op_sibling;
1407 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1409 if (kid->op_type == OP_METHOD_NAMED
1410 || kid->op_type == OP_METHOD)
1414 NewOp(1101, newop, 1, UNOP);
1415 newop->op_type = OP_RV2CV;
1416 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1417 newop->op_first = NULL;
1418 newop->op_next = (OP*)newop;
1419 kid->op_sibling = (OP*)newop;
1420 newop->op_private |= OPpLVAL_INTRO;
1421 newop->op_private &= ~1;
1425 if (kid->op_type != OP_RV2CV)
1427 "panic: unexpected lvalue entersub "
1428 "entry via type/targ %ld:%"UVuf,
1429 (long)kid->op_type, (UV)kid->op_targ);
1430 kid->op_private |= OPpLVAL_INTRO;
1431 break; /* Postpone until runtime */
1435 kid = kUNOP->op_first;
1436 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1437 kid = kUNOP->op_first;
1438 if (kid->op_type == OP_NULL)
1440 "Unexpected constant lvalue entersub "
1441 "entry via type/targ %ld:%"UVuf,
1442 (long)kid->op_type, (UV)kid->op_targ);
1443 if (kid->op_type != OP_GV) {
1444 /* Restore RV2CV to check lvalueness */
1446 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1447 okid->op_next = kid->op_next;
1448 kid->op_next = okid;
1451 okid->op_next = NULL;
1452 okid->op_type = OP_RV2CV;
1454 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1455 okid->op_private |= OPpLVAL_INTRO;
1456 okid->op_private &= ~1;
1460 cv = GvCV(kGVOP_gv);
1470 /* grep, foreach, subcalls, refgen */
1471 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1473 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1474 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1476 : (o->op_type == OP_ENTERSUB
1477 ? "non-lvalue subroutine call"
1479 type ? PL_op_desc[type] : "local"));
1493 case OP_RIGHT_SHIFT:
1502 if (!(o->op_flags & OPf_STACKED))
1509 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1515 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1516 PL_modcount = RETURN_UNLIMITED_NUMBER;
1517 return o; /* Treat \(@foo) like ordinary list. */
1521 if (scalar_mod_type(o, type))
1523 ref(cUNOPo->op_first, o->op_type);
1527 if (type == OP_LEAVESUBLV)
1528 o->op_private |= OPpMAYBE_LVSUB;
1534 PL_modcount = RETURN_UNLIMITED_NUMBER;
1537 ref(cUNOPo->op_first, o->op_type);
1542 PL_hints |= HINT_BLOCK_SCOPE;
1557 PL_modcount = RETURN_UNLIMITED_NUMBER;
1558 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1559 return o; /* Treat \(@foo) like ordinary list. */
1560 if (scalar_mod_type(o, type))
1562 if (type == OP_LEAVESUBLV)
1563 o->op_private |= OPpMAYBE_LVSUB;
1567 if (!type) /* local() */
1568 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1569 PAD_COMPNAME_PV(o->op_targ));
1577 if (type != OP_SASSIGN)
1581 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1586 if (type == OP_LEAVESUBLV)
1587 o->op_private |= OPpMAYBE_LVSUB;
1589 pad_free(o->op_targ);
1590 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1591 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1592 if (o->op_flags & OPf_KIDS)
1593 mod(cBINOPo->op_first->op_sibling, type);
1598 ref(cBINOPo->op_first, o->op_type);
1599 if (type == OP_ENTERSUB &&
1600 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1601 o->op_private |= OPpLVAL_DEFER;
1602 if (type == OP_LEAVESUBLV)
1603 o->op_private |= OPpMAYBE_LVSUB;
1613 if (o->op_flags & OPf_KIDS)
1614 mod(cLISTOPo->op_last, type);
1619 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1621 else if (!(o->op_flags & OPf_KIDS))
1623 if (o->op_targ != OP_LIST) {
1624 mod(cBINOPo->op_first, type);
1630 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1635 if (type != OP_LEAVESUBLV)
1637 break; /* mod()ing was handled by ck_return() */
1640 /* [20011101.069] File test operators interpret OPf_REF to mean that
1641 their argument is a filehandle; thus \stat(".") should not set
1643 if (type == OP_REFGEN &&
1644 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1647 if (type != OP_LEAVESUBLV)
1648 o->op_flags |= OPf_MOD;
1650 if (type == OP_AASSIGN || type == OP_SASSIGN)
1651 o->op_flags |= OPf_SPECIAL|OPf_REF;
1652 else if (!type) { /* local() */
1655 o->op_private |= OPpLVAL_INTRO;
1656 o->op_flags &= ~OPf_SPECIAL;
1657 PL_hints |= HINT_BLOCK_SCOPE;
1662 if (ckWARN(WARN_SYNTAX)) {
1663 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1664 "Useless localization of %s", OP_DESC(o));
1668 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1669 && type != OP_LEAVESUBLV)
1670 o->op_flags |= OPf_REF;
1675 S_scalar_mod_type(const OP *o, I32 type)
1677 PERL_ARGS_ASSERT_SCALAR_MOD_TYPE;
1681 if (o->op_type == OP_RV2GV)
1705 case OP_RIGHT_SHIFT:
1725 S_is_handle_constructor(const OP *o, I32 numargs)
1727 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
1729 switch (o->op_type) {
1737 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1750 Perl_refkids(pTHX_ OP *o, I32 type)
1752 if (o && o->op_flags & OPf_KIDS) {
1754 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1761 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
1766 PERL_ARGS_ASSERT_DOREF;
1768 if (!o || (PL_parser && PL_parser->error_count))
1771 switch (o->op_type) {
1773 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1774 !(o->op_flags & OPf_STACKED)) {
1775 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1776 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1777 assert(cUNOPo->op_first->op_type == OP_NULL);
1778 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1779 o->op_flags |= OPf_SPECIAL;
1780 o->op_private &= ~1;
1785 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1786 doref(kid, type, set_op_ref);
1789 if (type == OP_DEFINED)
1790 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1791 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1794 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1795 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1796 : type == OP_RV2HV ? OPpDEREF_HV
1798 o->op_flags |= OPf_MOD;
1805 o->op_flags |= OPf_REF;
1808 if (type == OP_DEFINED)
1809 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1810 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1816 o->op_flags |= OPf_REF;
1821 if (!(o->op_flags & OPf_KIDS))
1823 doref(cBINOPo->op_first, type, set_op_ref);
1827 doref(cBINOPo->op_first, o->op_type, set_op_ref);
1828 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1829 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1830 : type == OP_RV2HV ? OPpDEREF_HV
1832 o->op_flags |= OPf_MOD;
1842 if (!(o->op_flags & OPf_KIDS))
1844 doref(cLISTOPo->op_last, type, set_op_ref);
1854 S_dup_attrlist(pTHX_ OP *o)
1859 PERL_ARGS_ASSERT_DUP_ATTRLIST;
1861 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1862 * where the first kid is OP_PUSHMARK and the remaining ones
1863 * are OP_CONST. We need to push the OP_CONST values.
1865 if (o->op_type == OP_CONST)
1866 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
1868 else if (o->op_type == OP_NULL)
1872 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1874 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1875 if (o->op_type == OP_CONST)
1876 rop = append_elem(OP_LIST, rop,
1877 newSVOP(OP_CONST, o->op_flags,
1878 SvREFCNT_inc_NN(cSVOPo->op_sv)));
1885 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1890 PERL_ARGS_ASSERT_APPLY_ATTRS;
1892 /* fake up C<use attributes $pkg,$rv,@attrs> */
1893 ENTER; /* need to protect against side-effects of 'use' */
1894 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1896 #define ATTRSMODULE "attributes"
1897 #define ATTRSMODULE_PM "attributes.pm"
1900 /* Don't force the C<use> if we don't need it. */
1901 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
1902 if (svp && *svp != &PL_sv_undef)
1903 NOOP; /* already in %INC */
1905 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1906 newSVpvs(ATTRSMODULE), NULL);
1909 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1910 newSVpvs(ATTRSMODULE),
1912 prepend_elem(OP_LIST,
1913 newSVOP(OP_CONST, 0, stashsv),
1914 prepend_elem(OP_LIST,
1915 newSVOP(OP_CONST, 0,
1917 dup_attrlist(attrs))));
1923 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1926 OP *pack, *imop, *arg;
1929 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
1934 assert(target->op_type == OP_PADSV ||
1935 target->op_type == OP_PADHV ||
1936 target->op_type == OP_PADAV);
1938 /* Ensure that attributes.pm is loaded. */
1939 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1941 /* Need package name for method call. */
1942 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
1944 /* Build up the real arg-list. */
1945 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1947 arg = newOP(OP_PADSV, 0);
1948 arg->op_targ = target->op_targ;
1949 arg = prepend_elem(OP_LIST,
1950 newSVOP(OP_CONST, 0, stashsv),
1951 prepend_elem(OP_LIST,
1952 newUNOP(OP_REFGEN, 0,
1953 mod(arg, OP_REFGEN)),
1954 dup_attrlist(attrs)));
1956 /* Fake up a method call to import */
1957 meth = newSVpvs_share("import");
1958 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1959 append_elem(OP_LIST,
1960 prepend_elem(OP_LIST, pack, list(arg)),
1961 newSVOP(OP_METHOD_NAMED, 0, meth)));
1962 imop->op_private |= OPpENTERSUB_NOMOD;
1964 /* Combine the ops. */
1965 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1969 =notfor apidoc apply_attrs_string
1971 Attempts to apply a list of attributes specified by the C<attrstr> and
1972 C<len> arguments to the subroutine identified by the C<cv> argument which
1973 is expected to be associated with the package identified by the C<stashpv>
1974 argument (see L<attributes>). It gets this wrong, though, in that it
1975 does not correctly identify the boundaries of the individual attribute
1976 specifications within C<attrstr>. This is not really intended for the
1977 public API, but has to be listed here for systems such as AIX which
1978 need an explicit export list for symbols. (It's called from XS code
1979 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1980 to respect attribute syntax properly would be welcome.
1986 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
1987 const char *attrstr, STRLEN len)
1991 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
1994 len = strlen(attrstr);
1998 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2000 const char * const sstr = attrstr;
2001 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2002 attrs = append_elem(OP_LIST, attrs,
2003 newSVOP(OP_CONST, 0,
2004 newSVpvn(sstr, attrstr-sstr)));
2008 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2009 newSVpvs(ATTRSMODULE),
2010 NULL, prepend_elem(OP_LIST,
2011 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2012 prepend_elem(OP_LIST,
2013 newSVOP(OP_CONST, 0,
2019 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
2024 PERL_ARGS_ASSERT_MY_KID;
2026 if (!o || (PL_parser && PL_parser->error_count))
2030 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
2031 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
2035 if (type == OP_LIST) {
2037 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2038 my_kid(kid, attrs, imopsp);
2039 } else if (type == OP_UNDEF
2045 } else if (type == OP_RV2SV || /* "our" declaration */
2047 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
2048 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
2049 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2051 PL_parser->in_my == KEY_our
2053 : PL_parser->in_my == KEY_state ? "state" : "my"));
2055 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
2056 PL_parser->in_my = FALSE;
2057 PL_parser->in_my_stash = NULL;
2058 apply_attrs(GvSTASH(gv),
2059 (type == OP_RV2SV ? GvSV(gv) :
2060 type == OP_RV2AV ? (SV*)GvAV(gv) :
2061 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
2064 o->op_private |= OPpOUR_INTRO;
2067 else if (type != OP_PADSV &&
2070 type != OP_PUSHMARK)
2072 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2074 PL_parser->in_my == KEY_our
2076 : PL_parser->in_my == KEY_state ? "state" : "my"));
2079 else if (attrs && type != OP_PUSHMARK) {
2082 PL_parser->in_my = FALSE;
2083 PL_parser->in_my_stash = NULL;
2085 /* check for C<my Dog $spot> when deciding package */
2086 stash = PAD_COMPNAME_TYPE(o->op_targ);
2088 stash = PL_curstash;
2089 apply_attrs_my(stash, o, attrs, imopsp);
2091 o->op_flags |= OPf_MOD;
2092 o->op_private |= OPpLVAL_INTRO;
2093 if (PL_parser->in_my == KEY_state)
2094 o->op_private |= OPpPAD_STATE;
2099 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2103 int maybe_scalar = 0;
2105 PERL_ARGS_ASSERT_MY_ATTRS;
2107 /* [perl #17376]: this appears to be premature, and results in code such as
2108 C< our(%x); > executing in list mode rather than void mode */
2110 if (o->op_flags & OPf_PARENS)
2120 o = my_kid(o, attrs, &rops);
2122 if (maybe_scalar && o->op_type == OP_PADSV) {
2123 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
2124 o->op_private |= OPpLVAL_INTRO;
2127 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
2129 PL_parser->in_my = FALSE;
2130 PL_parser->in_my_stash = NULL;
2135 Perl_my(pTHX_ OP *o)
2137 PERL_ARGS_ASSERT_MY;
2139 return my_attrs(o, NULL);
2143 Perl_sawparens(pTHX_ OP *o)
2145 PERL_UNUSED_CONTEXT;
2147 o->op_flags |= OPf_PARENS;
2152 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2156 const OPCODE ltype = left->op_type;
2157 const OPCODE rtype = right->op_type;
2159 PERL_ARGS_ASSERT_BIND_MATCH;
2161 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2162 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
2164 const char * const desc
2165 = PL_op_desc[(rtype == OP_SUBST || rtype == OP_TRANS)
2166 ? (int)rtype : OP_MATCH];
2167 const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV)
2168 ? "@array" : "%hash");
2169 Perl_warner(aTHX_ packWARN(WARN_MISC),
2170 "Applying %s to %s will act on scalar(%s)",
2171 desc, sample, sample);
2174 if (rtype == OP_CONST &&
2175 cSVOPx(right)->op_private & OPpCONST_BARE &&
2176 cSVOPx(right)->op_private & OPpCONST_STRICT)
2178 no_bareword_allowed(right);
2181 ismatchop = rtype == OP_MATCH ||
2182 rtype == OP_SUBST ||
2184 if (ismatchop && right->op_private & OPpTARGET_MY) {
2186 right->op_private &= ~OPpTARGET_MY;
2188 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
2191 right->op_flags |= OPf_STACKED;
2192 if (rtype != OP_MATCH &&
2193 ! (rtype == OP_TRANS &&
2194 right->op_private & OPpTRANS_IDENTICAL))
2195 newleft = mod(left, rtype);
2198 if (right->op_type == OP_TRANS)
2199 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
2201 o = prepend_elem(rtype, scalar(newleft), right);
2203 return newUNOP(OP_NOT, 0, scalar(o));
2207 return bind_match(type, left,
2208 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
2212 Perl_invert(pTHX_ OP *o)
2216 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2220 Perl_scope(pTHX_ OP *o)
2224 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2225 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2226 o->op_type = OP_LEAVE;
2227 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2229 else if (o->op_type == OP_LINESEQ) {
2231 o->op_type = OP_SCOPE;
2232 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2233 kid = ((LISTOP*)o)->op_first;
2234 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2237 /* The following deals with things like 'do {1 for 1}' */
2238 kid = kid->op_sibling;
2240 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2245 o = newLISTOP(OP_SCOPE, 0, o, NULL);
2251 Perl_block_start(pTHX_ int full)
2254 const int retval = PL_savestack_ix;
2255 pad_block_start(full);
2257 PL_hints &= ~HINT_BLOCK_SCOPE;
2258 SAVECOMPILEWARNINGS();
2259 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
2264 Perl_block_end(pTHX_ I32 floor, OP *seq)
2267 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2268 OP* const retval = scalarseq(seq);
2270 CopHINTS_set(&PL_compiling, PL_hints);
2272 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2281 const PADOFFSET offset = pad_findmy("$_");
2282 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
2283 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2286 OP * const o = newOP(OP_PADSV, 0);
2287 o->op_targ = offset;
2293 Perl_newPROG(pTHX_ OP *o)
2297 PERL_ARGS_ASSERT_NEWPROG;
2302 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2303 ((PL_in_eval & EVAL_KEEPERR)
2304 ? OPf_SPECIAL : 0), o);
2305 PL_eval_start = linklist(PL_eval_root);
2306 PL_eval_root->op_private |= OPpREFCOUNTED;
2307 OpREFCNT_set(PL_eval_root, 1);
2308 PL_eval_root->op_next = 0;
2309 CALL_PEEP(PL_eval_start);
2312 if (o->op_type == OP_STUB) {
2313 PL_comppad_name = 0;
2315 S_op_destroy(aTHX_ o);
2318 PL_main_root = scope(sawparens(scalarvoid(o)));
2319 PL_curcop = &PL_compiling;
2320 PL_main_start = LINKLIST(PL_main_root);
2321 PL_main_root->op_private |= OPpREFCOUNTED;
2322 OpREFCNT_set(PL_main_root, 1);
2323 PL_main_root->op_next = 0;
2324 CALL_PEEP(PL_main_start);
2327 /* Register with debugger */
2330 = Perl_get_cvn_flags(aTHX_ STR_WITH_LEN("DB::postponed"), 0);
2334 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2336 call_sv((SV*)cv, G_DISCARD);
2343 Perl_localize(pTHX_ OP *o, I32 lex)
2347 PERL_ARGS_ASSERT_LOCALIZE;
2349 if (o->op_flags & OPf_PARENS)
2350 /* [perl #17376]: this appears to be premature, and results in code such as
2351 C< our(%x); > executing in list mode rather than void mode */
2358 if ( PL_parser->bufptr > PL_parser->oldbufptr
2359 && PL_parser->bufptr[-1] == ','
2360 && ckWARN(WARN_PARENTHESIS))
2362 char *s = PL_parser->bufptr;
2365 /* some heuristics to detect a potential error */
2366 while (*s && (strchr(", \t\n", *s)))
2370 if (*s && strchr("@$%*", *s) && *++s
2371 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2374 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2376 while (*s && (strchr(", \t\n", *s)))
2382 if (sigil && (*s == ';' || *s == '=')) {
2383 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2384 "Parentheses missing around \"%s\" list",
2386 ? (PL_parser->in_my == KEY_our
2388 : PL_parser->in_my == KEY_state
2398 o = mod(o, OP_NULL); /* a bit kludgey */
2399 PL_parser->in_my = FALSE;
2400 PL_parser->in_my_stash = NULL;
2405 Perl_jmaybe(pTHX_ OP *o)
2407 PERL_ARGS_ASSERT_JMAYBE;
2409 if (o->op_type == OP_LIST) {
2411 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2412 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2418 Perl_fold_constants(pTHX_ register OP *o)
2421 register OP * VOL curop;
2423 VOL I32 type = o->op_type;
2428 SV * const oldwarnhook = PL_warnhook;
2429 SV * const olddiehook = PL_diehook;
2433 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
2435 if (PL_opargs[type] & OA_RETSCALAR)
2437 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2438 o->op_targ = pad_alloc(type, SVs_PADTMP);
2440 /* integerize op, unless it happens to be C<-foo>.
2441 * XXX should pp_i_negate() do magic string negation instead? */
2442 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2443 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2444 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2446 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2449 if (!(PL_opargs[type] & OA_FOLDCONST))
2454 /* XXX might want a ck_negate() for this */
2455 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2466 /* XXX what about the numeric ops? */
2467 if (PL_hints & HINT_LOCALE)
2472 if (PL_parser && PL_parser->error_count)
2473 goto nope; /* Don't try to run w/ errors */
2475 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2476 const OPCODE type = curop->op_type;
2477 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2479 type != OP_SCALAR &&
2481 type != OP_PUSHMARK)
2487 curop = LINKLIST(o);
2488 old_next = o->op_next;
2492 oldscope = PL_scopestack_ix;
2493 create_eval_scope(G_FAKINGEVAL);
2495 /* Verify that we don't need to save it: */
2496 assert(PL_curcop == &PL_compiling);
2497 StructCopy(&PL_compiling, ¬_compiling, COP);
2498 PL_curcop = ¬_compiling;
2499 /* The above ensures that we run with all the correct hints of the
2500 currently compiling COP, but that IN_PERL_RUNTIME is not true. */
2501 assert(IN_PERL_RUNTIME);
2502 PL_warnhook = PERL_WARNHOOK_FATAL;
2509 sv = *(PL_stack_sp--);
2510 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2511 pad_swipe(o->op_targ, FALSE);
2512 else if (SvTEMP(sv)) { /* grab mortal temp? */
2513 SvREFCNT_inc_simple_void(sv);
2518 /* Something tried to die. Abandon constant folding. */
2519 /* Pretend the error never happened. */
2520 sv_setpvn(ERRSV,"",0);
2521 o->op_next = old_next;
2525 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
2526 PL_warnhook = oldwarnhook;
2527 PL_diehook = olddiehook;
2528 /* XXX note that this croak may fail as we've already blown away
2529 * the stack - eg any nested evals */
2530 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
2533 PL_warnhook = oldwarnhook;
2534 PL_diehook = olddiehook;
2535 PL_curcop = &PL_compiling;
2537 if (PL_scopestack_ix > oldscope)
2538 delete_eval_scope();
2547 if (type == OP_RV2GV)
2548 newop = newGVOP(OP_GV, 0, (GV*)sv);
2550 newop = newSVOP(OP_CONST, 0, (SV*)sv);
2551 op_getmad(o,newop,'f');
2559 Perl_gen_constant_list(pTHX_ register OP *o)
2563 const I32 oldtmps_floor = PL_tmps_floor;
2566 if (PL_parser && PL_parser->error_count)
2567 return o; /* Don't attempt to run with errors */
2569 PL_op = curop = LINKLIST(o);
2575 assert (!(curop->op_flags & OPf_SPECIAL));
2576 assert(curop->op_type == OP_RANGE);
2578 PL_tmps_floor = oldtmps_floor;
2580 o->op_type = OP_RV2AV;
2581 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2582 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2583 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2584 o->op_opt = 0; /* needs to be revisited in peep() */
2585 curop = ((UNOP*)o)->op_first;
2586 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
2588 op_getmad(curop,o,'O');
2597 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2600 if (!o || o->op_type != OP_LIST)
2601 o = newLISTOP(OP_LIST, 0, o, NULL);
2603 o->op_flags &= ~OPf_WANT;
2605 if (!(PL_opargs[type] & OA_MARK))
2606 op_null(cLISTOPo->op_first);
2608 o->op_type = (OPCODE)type;
2609 o->op_ppaddr = PL_ppaddr[type];
2610 o->op_flags |= flags;
2612 o = CHECKOP(type, o);
2613 if (o->op_type != (unsigned)type)
2616 return fold_constants(o);
2619 /* List constructors */
2622 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2630 if (first->op_type != (unsigned)type
2631 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2633 return newLISTOP(type, 0, first, last);
2636 if (first->op_flags & OPf_KIDS)
2637 ((LISTOP*)first)->op_last->op_sibling = last;
2639 first->op_flags |= OPf_KIDS;
2640 ((LISTOP*)first)->op_first = last;
2642 ((LISTOP*)first)->op_last = last;
2647 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2655 if (first->op_type != (unsigned)type)
2656 return prepend_elem(type, (OP*)first, (OP*)last);
2658 if (last->op_type != (unsigned)type)
2659 return append_elem(type, (OP*)first, (OP*)last);
2661 first->op_last->op_sibling = last->op_first;
2662 first->op_last = last->op_last;
2663 first->op_flags |= (last->op_flags & OPf_KIDS);
2666 if (last->op_first && first->op_madprop) {
2667 MADPROP *mp = last->op_first->op_madprop;
2669 while (mp->mad_next)
2671 mp->mad_next = first->op_madprop;
2674 last->op_first->op_madprop = first->op_madprop;
2677 first->op_madprop = last->op_madprop;
2678 last->op_madprop = 0;
2681 S_op_destroy(aTHX_ (OP*)last);
2687 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2695 if (last->op_type == (unsigned)type) {
2696 if (type == OP_LIST) { /* already a PUSHMARK there */
2697 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2698 ((LISTOP*)last)->op_first->op_sibling = first;
2699 if (!(first->op_flags & OPf_PARENS))
2700 last->op_flags &= ~OPf_PARENS;
2703 if (!(last->op_flags & OPf_KIDS)) {
2704 ((LISTOP*)last)->op_last = first;
2705 last->op_flags |= OPf_KIDS;
2707 first->op_sibling = ((LISTOP*)last)->op_first;
2708 ((LISTOP*)last)->op_first = first;
2710 last->op_flags |= OPf_KIDS;
2714 return newLISTOP(type, 0, first, last);
2722 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2725 Newxz(tk, 1, TOKEN);
2726 tk->tk_type = (OPCODE)optype;
2727 tk->tk_type = 12345;
2729 tk->tk_mad = madprop;
2734 Perl_token_free(pTHX_ TOKEN* tk)
2736 PERL_ARGS_ASSERT_TOKEN_FREE;
2738 if (tk->tk_type != 12345)
2740 mad_free(tk->tk_mad);
2745 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2750 PERL_ARGS_ASSERT_TOKEN_GETMAD;
2752 if (tk->tk_type != 12345) {
2753 Perl_warner(aTHX_ packWARN(WARN_MISC),
2754 "Invalid TOKEN object ignored");
2761 /* faked up qw list? */
2763 tm->mad_type == MAD_SV &&
2764 SvPVX((SV*)tm->mad_val)[0] == 'q')
2771 /* pretend constant fold didn't happen? */
2772 if (mp->mad_key == 'f' &&
2773 (o->op_type == OP_CONST ||
2774 o->op_type == OP_GV) )
2776 token_getmad(tk,(OP*)mp->mad_val,slot);
2790 if (mp->mad_key == 'X')
2791 mp->mad_key = slot; /* just change the first one */
2801 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
2810 /* pretend constant fold didn't happen? */
2811 if (mp->mad_key == 'f' &&
2812 (o->op_type == OP_CONST ||
2813 o->op_type == OP_GV) )
2815 op_getmad(from,(OP*)mp->mad_val,slot);
2822 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
2825 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
2831 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
2840 /* pretend constant fold didn't happen? */
2841 if (mp->mad_key == 'f' &&
2842 (o->op_type == OP_CONST ||
2843 o->op_type == OP_GV) )
2845 op_getmad(from,(OP*)mp->mad_val,slot);
2852 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
2855 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
2859 PerlIO_printf(PerlIO_stderr(),
2860 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
2866 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
2884 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
2888 addmad(tm, &(o->op_madprop), slot);
2892 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
2913 Perl_newMADsv(pTHX_ char key, SV* sv)
2915 PERL_ARGS_ASSERT_NEWMADSV;
2917 return newMADPROP(key, MAD_SV, sv, 0);
2921 Perl_newMADPROP(pTHX_ char key, char type, const void* val, I32 vlen)
2924 Newxz(mp, 1, MADPROP);
2927 mp->mad_vlen = vlen;
2928 mp->mad_type = type;
2930 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
2935 Perl_mad_free(pTHX_ MADPROP* mp)
2937 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
2941 mad_free(mp->mad_next);
2942 /* if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
2943 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
2944 switch (mp->mad_type) {
2948 Safefree((char*)mp->mad_val);
2951 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
2952 op_free((OP*)mp->mad_val);
2955 sv_free((SV*)mp->mad_val);
2958 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
2967 Perl_newNULLLIST(pTHX)
2969 return newOP(OP_STUB, 0);
2973 Perl_force_list(pTHX_ OP *o)
2975 if (!o || o->op_type != OP_LIST)
2976 o = newLISTOP(OP_LIST, 0, o, NULL);
2982 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2987 NewOp(1101, listop, 1, LISTOP);
2989 listop->op_type = (OPCODE)type;
2990 listop->op_ppaddr = PL_ppaddr[type];
2993 listop->op_flags = (U8)flags;
2997 else if (!first && last)
3000 first->op_sibling = last;
3001 listop->op_first = first;
3002 listop->op_last = last;
3003 if (type == OP_LIST) {
3004 OP* const pushop = newOP(OP_PUSHMARK, 0);
3005 pushop->op_sibling = first;
3006 listop->op_first = pushop;
3007 listop->op_flags |= OPf_KIDS;
3009 listop->op_last = pushop;
3012 return CHECKOP(type, listop);
3016 Perl_newOP(pTHX_ I32 type, I32 flags)
3020 NewOp(1101, o, 1, OP);
3021 o->op_type = (OPCODE)type;
3022 o->op_ppaddr = PL_ppaddr[type];
3023 o->op_flags = (U8)flags;
3025 o->op_latefreed = 0;
3029 o->op_private = (U8)(0 | (flags >> 8));
3030 if (PL_opargs[type] & OA_RETSCALAR)
3032 if (PL_opargs[type] & OA_TARGET)
3033 o->op_targ = pad_alloc(type, SVs_PADTMP);
3034 return CHECKOP(type, o);
3038 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
3044 first = newOP(OP_STUB, 0);
3045 if (PL_opargs[type] & OA_MARK)
3046 first = force_list(first);
3048 NewOp(1101, unop, 1, UNOP);
3049 unop->op_type = (OPCODE)type;
3050 unop->op_ppaddr = PL_ppaddr[type];
3051 unop->op_first = first;
3052 unop->op_flags = (U8)(flags | OPf_KIDS);
3053 unop->op_private = (U8)(1 | (flags >> 8));
3054 unop = (UNOP*) CHECKOP(type, unop);
3058 return fold_constants((OP *) unop);
3062 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3066 NewOp(1101, binop, 1, BINOP);
3069 first = newOP(OP_NULL, 0);
3071 binop->op_type = (OPCODE)type;
3072 binop->op_ppaddr = PL_ppaddr[type];
3073 binop->op_first = first;
3074 binop->op_flags = (U8)(flags | OPf_KIDS);
3077 binop->op_private = (U8)(1 | (flags >> 8));
3080 binop->op_private = (U8)(2 | (flags >> 8));
3081 first->op_sibling = last;
3084 binop = (BINOP*)CHECKOP(type, binop);
3085 if (binop->op_next || binop->op_type != (OPCODE)type)
3088 binop->op_last = binop->op_first->op_sibling;
3090 return fold_constants((OP *)binop);
3093 static int uvcompare(const void *a, const void *b)
3094 __attribute__nonnull__(1)
3095 __attribute__nonnull__(2)
3096 __attribute__pure__;
3097 static int uvcompare(const void *a, const void *b)
3099 if (*((const UV *)a) < (*(const UV *)b))
3101 if (*((const UV *)a) > (*(const UV *)b))
3103 if (*((const UV *)a+1) < (*(const UV *)b+1))
3105 if (*((const UV *)a+1) > (*(const UV *)b+1))
3111 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
3114 SV * const tstr = ((SVOP*)expr)->op_sv;
3117 (repl->op_type == OP_NULL)
3118 ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
3120 ((SVOP*)repl)->op_sv;
3123 const U8 *t = (U8*)SvPV_const(tstr, tlen);
3124 const U8 *r = (U8*)SvPV_const(rstr, rlen);
3128 register short *tbl;
3130 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
3131 const I32 squash = o->op_private & OPpTRANS_SQUASH;
3132 I32 del = o->op_private & OPpTRANS_DELETE;
3135 PERL_ARGS_ASSERT_PMTRANS;
3137 PL_hints |= HINT_BLOCK_SCOPE;
3140 o->op_private |= OPpTRANS_FROM_UTF;
3143 o->op_private |= OPpTRANS_TO_UTF;
3145 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
3146 SV* const listsv = newSVpvs("# comment\n");
3148 const U8* tend = t + tlen;
3149 const U8* rend = r + rlen;
3163 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
3164 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
3167 const U32 flags = UTF8_ALLOW_DEFAULT;
3171 t = tsave = bytes_to_utf8(t, &len);
3174 if (!to_utf && rlen) {
3176 r = rsave = bytes_to_utf8(r, &len);
3180 /* There are several snags with this code on EBCDIC:
3181 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
3182 2. scan_const() in toke.c has encoded chars in native encoding which makes
3183 ranges at least in EBCDIC 0..255 range the bottom odd.
3187 U8 tmpbuf[UTF8_MAXBYTES+1];
3190 Newx(cp, 2*tlen, UV);
3192 transv = newSVpvs("");
3194 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3196 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
3198 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3202 cp[2*i+1] = cp[2*i];
3206 qsort(cp, i, 2*sizeof(UV), uvcompare);
3207 for (j = 0; j < i; j++) {
3209 diff = val - nextmin;
3211 t = uvuni_to_utf8(tmpbuf,nextmin);
3212 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3214 U8 range_mark = UTF_TO_NATIVE(0xff);
3215 t = uvuni_to_utf8(tmpbuf, val - 1);
3216 sv_catpvn(transv, (char *)&range_mark, 1);
3217 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3224 t = uvuni_to_utf8(tmpbuf,nextmin);
3225 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3227 U8 range_mark = UTF_TO_NATIVE(0xff);
3228 sv_catpvn(transv, (char *)&range_mark, 1);
3230 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
3231 UNICODE_ALLOW_SUPER);
3232 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3233 t = (const U8*)SvPVX_const(transv);
3234 tlen = SvCUR(transv);
3238 else if (!rlen && !del) {
3239 r = t; rlen = tlen; rend = tend;
3242 if ((!rlen && !del) || t == r ||
3243 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
3245 o->op_private |= OPpTRANS_IDENTICAL;
3249 while (t < tend || tfirst <= tlast) {
3250 /* see if we need more "t" chars */
3251 if (tfirst > tlast) {
3252 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3254 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
3256 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3263 /* now see if we need more "r" chars */
3264 if (rfirst > rlast) {
3266 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3268 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
3270 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3279 rfirst = rlast = 0xffffffff;
3283 /* now see which range will peter our first, if either. */
3284 tdiff = tlast - tfirst;
3285 rdiff = rlast - rfirst;
3292 if (rfirst == 0xffffffff) {
3293 diff = tdiff; /* oops, pretend rdiff is infinite */
3295 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
3296 (long)tfirst, (long)tlast);
3298 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
3302 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
3303 (long)tfirst, (long)(tfirst + diff),
3306 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3307 (long)tfirst, (long)rfirst);
3309 if (rfirst + diff > max)
3310 max = rfirst + diff;
3312 grows = (tfirst < rfirst &&
3313 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3325 else if (max > 0xff)
3330 PerlMemShared_free(cPVOPo->op_pv);
3331 cPVOPo->op_pv = NULL;
3333 swash = (SV*)swash_init("utf8", "", listsv, bits, none);
3335 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
3336 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
3337 PAD_SETSV(cPADOPo->op_padix, swash);
3340 cSVOPo->op_sv = swash;
3342 SvREFCNT_dec(listsv);
3343 SvREFCNT_dec(transv);
3345 if (!del && havefinal && rlen)
3346 (void)hv_store((HV*)SvRV(swash), "FINAL", 5,
3347 newSVuv((UV)final), 0);
3350 o->op_private |= OPpTRANS_GROWS;
3356 op_getmad(expr,o,'e');
3357 op_getmad(repl,o,'r');
3365 tbl = (short*)cPVOPo->op_pv;
3367 Zero(tbl, 256, short);
3368 for (i = 0; i < (I32)tlen; i++)
3370 for (i = 0, j = 0; i < 256; i++) {
3372 if (j >= (I32)rlen) {
3381 if (i < 128 && r[j] >= 128)
3391 o->op_private |= OPpTRANS_IDENTICAL;
3393 else if (j >= (I32)rlen)
3398 PerlMemShared_realloc(tbl,
3399 (0x101+rlen-j) * sizeof(short));
3400 cPVOPo->op_pv = (char*)tbl;
3402 tbl[0x100] = (short)(rlen - j);
3403 for (i=0; i < (I32)rlen - j; i++)
3404 tbl[0x101+i] = r[j+i];
3408 if (!rlen && !del) {
3411 o->op_private |= OPpTRANS_IDENTICAL;
3413 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3414 o->op_private |= OPpTRANS_IDENTICAL;
3416 for (i = 0; i < 256; i++)
3418 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3419 if (j >= (I32)rlen) {
3421 if (tbl[t[i]] == -1)
3427 if (tbl[t[i]] == -1) {
3428 if (t[i] < 128 && r[j] >= 128)
3435 o->op_private |= OPpTRANS_GROWS;
3437 op_getmad(expr,o,'e');
3438 op_getmad(repl,o,'r');
3448 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3453 NewOp(1101, pmop, 1, PMOP);
3454 pmop->op_type = (OPCODE)type;
3455 pmop->op_ppaddr = PL_ppaddr[type];
3456 pmop->op_flags = (U8)flags;
3457 pmop->op_private = (U8)(0 | (flags >> 8));
3459 if (PL_hints & HINT_RE_TAINT)
3460 pmop->op_pmflags |= PMf_RETAINT;
3461 if (PL_hints & HINT_LOCALE)
3462 pmop->op_pmflags |= PMf_LOCALE;
3466 assert(SvPOK(PL_regex_pad[0]));
3467 if (SvCUR(PL_regex_pad[0])) {
3468 /* Pop off the "packed" IV from the end. */
3469 SV *const repointer_list = PL_regex_pad[0];
3470 const char *p = SvEND(repointer_list) - sizeof(IV);
3471 const IV offset = *((IV*)p);
3473 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
3475 SvEND_set(repointer_list, p);
3477 pmop->op_pmoffset = offset;
3478 /* This slot should be free, so assert this: */
3479 assert(PL_regex_pad[offset] == &PL_sv_undef);
3481 SV * const repointer = &PL_sv_undef;
3482 av_push(PL_regex_padav, repointer);
3483 pmop->op_pmoffset = av_len(PL_regex_padav);
3484 PL_regex_pad = AvARRAY(PL_regex_padav);
3488 return CHECKOP(type, pmop);
3491 /* Given some sort of match op o, and an expression expr containing a
3492 * pattern, either compile expr into a regex and attach it to o (if it's
3493 * constant), or convert expr into a runtime regcomp op sequence (if it's
3496 * isreg indicates that the pattern is part of a regex construct, eg
3497 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3498 * split "pattern", which aren't. In the former case, expr will be a list
3499 * if the pattern contains more than one term (eg /a$b/) or if it contains
3500 * a replacement, ie s/// or tr///.
3504 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
3509 I32 repl_has_vars = 0;
3513 PERL_ARGS_ASSERT_PMRUNTIME;
3515 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
3516 /* last element in list is the replacement; pop it */
3518 repl = cLISTOPx(expr)->op_last;
3519 kid = cLISTOPx(expr)->op_first;
3520 while (kid->op_sibling != repl)
3521 kid = kid->op_sibling;
3522 kid->op_sibling = NULL;
3523 cLISTOPx(expr)->op_last = kid;
3526 if (isreg && expr->op_type == OP_LIST &&
3527 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3529 /* convert single element list to element */
3530 OP* const oe = expr;
3531 expr = cLISTOPx(oe)->op_first->op_sibling;
3532 cLISTOPx(oe)->op_first->op_sibling = NULL;
3533 cLISTOPx(oe)->op_last = NULL;
3537 if (o->op_type == OP_TRANS) {
3538 return pmtrans(o, expr, repl);
3541 reglist = isreg && expr->op_type == OP_LIST;
3545 PL_hints |= HINT_BLOCK_SCOPE;
3548 if (expr->op_type == OP_CONST) {
3549 SV *pat = ((SVOP*)expr)->op_sv;
3550 U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
3552 if (o->op_flags & OPf_SPECIAL)
3553 pm_flags |= RXf_SPLIT;
3556 assert (SvUTF8(pat));
3557 } else if (SvUTF8(pat)) {
3558 /* Not doing UTF-8, despite what the SV says. Is this only if we're
3559 trapped in use 'bytes'? */
3560 /* Make a copy of the octet sequence, but without the flag on, as
3561 the compiler now honours the SvUTF8 flag on pat. */
3563 const char *const p = SvPV(pat, len);
3564 pat = newSVpvn_flags(p, len, SVs_TEMP);
3567 PM_SETRE(pm, CALLREGCOMP(pat, pm_flags));
3570 op_getmad(expr,(OP*)pm,'e');
3576 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3577 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3579 : OP_REGCMAYBE),0,expr);
3581 NewOp(1101, rcop, 1, LOGOP);
3582 rcop->op_type = OP_REGCOMP;
3583 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3584 rcop->op_first = scalar(expr);
3585 rcop->op_flags |= OPf_KIDS
3586 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3587 | (reglist ? OPf_STACKED : 0);
3588 rcop->op_private = 1;
3591 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3593 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
3596 /* establish postfix order */
3597 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3599 rcop->op_next = expr;
3600 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3603 rcop->op_next = LINKLIST(expr);
3604 expr->op_next = (OP*)rcop;
3607 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3612 if (pm->op_pmflags & PMf_EVAL) {
3614 if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
3615 CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
3617 else if (repl->op_type == OP_CONST)
3621 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3622 if (curop->op_type == OP_SCOPE
3623 || curop->op_type == OP_LEAVE
3624 || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
3625 if (curop->op_type == OP_GV) {
3626 GV * const gv = cGVOPx_gv(curop);
3628 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3631 else if (curop->op_type == OP_RV2CV)
3633 else if (curop->op_type == OP_RV2SV ||
3634 curop->op_type == OP_RV2AV ||
3635 curop->op_type == OP_RV2HV ||
3636 curop->op_type == OP_RV2GV) {
3637 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3640 else if (curop->op_type == OP_PADSV ||
3641 curop->op_type == OP_PADAV ||
3642 curop->op_type == OP_PADHV ||
3643 curop->op_type == OP_PADANY)
3647 else if (curop->op_type == OP_PUSHRE)
3648 NOOP; /* Okay here, dangerous in newASSIGNOP */
3658 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
3660 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3661 prepend_elem(o->op_type, scalar(repl), o);
3664 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3665 pm->op_pmflags |= PMf_MAYBE_CONST;
3667 NewOp(1101, rcop, 1, LOGOP);
3668 rcop->op_type = OP_SUBSTCONT;
3669 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3670 rcop->op_first = scalar(repl);
3671 rcop->op_flags |= OPf_KIDS;
3672 rcop->op_private = 1;
3675 /* establish postfix order */
3676 rcop->op_next = LINKLIST(repl);
3677 repl->op_next = (OP*)rcop;
3679 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
3680 assert(!(pm->op_pmflags & PMf_ONCE));
3681 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
3690 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3695 PERL_ARGS_ASSERT_NEWSVOP;
3697 NewOp(1101, svop, 1, SVOP);
3698 svop->op_type = (OPCODE)type;
3699 svop->op_ppaddr = PL_ppaddr[type];
3701 svop->op_next = (OP*)svop;
3702 svop->op_flags = (U8)flags;
3703 if (PL_opargs[type] & OA_RETSCALAR)
3705 if (PL_opargs[type] & OA_TARGET)
3706 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3707 return CHECKOP(type, svop);
3712 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3717 PERL_ARGS_ASSERT_NEWPADOP;
3719 NewOp(1101, padop, 1, PADOP);
3720 padop->op_type = (OPCODE)type;
3721 padop->op_ppaddr = PL_ppaddr[type];
3722 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3723 SvREFCNT_dec(PAD_SVl(padop->op_padix));
3724 PAD_SETSV(padop->op_padix, sv);
3727 padop->op_next = (OP*)padop;
3728 padop->op_flags = (U8)flags;
3729 if (PL_opargs[type] & OA_RETSCALAR)
3731 if (PL_opargs[type] & OA_TARGET)
3732 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3733 return CHECKOP(type, padop);
3738 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3742 PERL_ARGS_ASSERT_NEWGVOP;
3746 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3748 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3753 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3757 NewOp(1101, pvop, 1, PVOP);
3758 pvop->op_type = (OPCODE)type;
3759 pvop->op_ppaddr = PL_ppaddr[type];
3761 pvop->op_next = (OP*)pvop;
3762 pvop->op_flags = (U8)flags;
3763 if (PL_opargs[type] & OA_RETSCALAR)
3765 if (PL_opargs[type] & OA_TARGET)
3766 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3767 return CHECKOP(type, pvop);
3775 Perl_package(pTHX_ OP *o)
3778 SV *const sv = cSVOPo->op_sv;
3783 PERL_ARGS_ASSERT_PACKAGE;
3785 save_hptr(&PL_curstash);
3786 save_item(PL_curstname);
3788 PL_curstash = gv_stashsv(sv, GV_ADD);
3790 sv_setsv(PL_curstname, sv);
3792 PL_hints |= HINT_BLOCK_SCOPE;
3793 PL_parser->copline = NOLINE;
3794 PL_parser->expect = XSTATE;
3799 if (!PL_madskills) {
3804 pegop = newOP(OP_NULL,0);
3805 op_getmad(o,pegop,'P');
3815 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3822 OP *pegop = newOP(OP_NULL,0);
3825 PERL_ARGS_ASSERT_UTILIZE;
3827 if (idop->op_type != OP_CONST)
3828 Perl_croak(aTHX_ "Module name must be constant");
3831 op_getmad(idop,pegop,'U');
3836 SV * const vesv = ((SVOP*)version)->op_sv;
3839 op_getmad(version,pegop,'V');
3840 if (!arg && !SvNIOKp(vesv)) {
3847 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3848 Perl_croak(aTHX_ "Version number must be constant number");
3850 /* Make copy of idop so we don't free it twice */
3851 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3853 /* Fake up a method call to VERSION */
3854 meth = newSVpvs_share("VERSION");
3855 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3856 append_elem(OP_LIST,
3857 prepend_elem(OP_LIST, pack, list(version)),
3858 newSVOP(OP_METHOD_NAMED, 0, meth)));
3862 /* Fake up an import/unimport */
3863 if (arg && arg->op_type == OP_STUB) {
3865 op_getmad(arg,pegop,'S');
3866 imop = arg; /* no import on explicit () */
3868 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3869 imop = NULL; /* use 5.0; */
3871 idop->op_private |= OPpCONST_NOVER;
3877 op_getmad(arg,pegop,'A');
3879 /* Make copy of idop so we don't free it twice */
3880 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3882 /* Fake up a method call to import/unimport */
3884 ? newSVpvs_share("import") : newSVpvs_share("unimport");
3885 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3886 append_elem(OP_LIST,
3887 prepend_elem(OP_LIST, pack, list(arg)),
3888 newSVOP(OP_METHOD_NAMED, 0, meth)));
3891 /* Fake up the BEGIN {}, which does its thing immediately. */
3893 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
3896 append_elem(OP_LINESEQ,
3897 append_elem(OP_LINESEQ,
3898 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
3899 newSTATEOP(0, NULL, veop)),
3900 newSTATEOP(0, NULL, imop) ));
3902 /* The "did you use incorrect case?" warning used to be here.
3903 * The problem is that on case-insensitive filesystems one
3904 * might get false positives for "use" (and "require"):
3905 * "use Strict" or "require CARP" will work. This causes
3906 * portability problems for the script: in case-strict
3907 * filesystems the script will stop working.
3909 * The "incorrect case" warning checked whether "use Foo"
3910 * imported "Foo" to your namespace, but that is wrong, too:
3911 * there is no requirement nor promise in the language that
3912 * a Foo.pm should or would contain anything in package "Foo".
3914 * There is very little Configure-wise that can be done, either:
3915 * the case-sensitivity of the build filesystem of Perl does not
3916 * help in guessing the case-sensitivity of the runtime environment.
3919 PL_hints |= HINT_BLOCK_SCOPE;
3920 PL_parser->copline = NOLINE;
3921 PL_parser->expect = XSTATE;
3922 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3925 if (!PL_madskills) {
3926 /* FIXME - don't allocate pegop if !PL_madskills */
3935 =head1 Embedding Functions
3937 =for apidoc load_module
3939 Loads the module whose name is pointed to by the string part of name.
3940 Note that the actual module name, not its filename, should be given.
3941 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3942 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3943 (or 0 for no flags). ver, if specified, provides version semantics
3944 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3945 arguments can be used to specify arguments to the module's import()
3946 method, similar to C<use Foo::Bar VERSION LIST>.
3951 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3955 PERL_ARGS_ASSERT_LOAD_MODULE;
3957 va_start(args, ver);
3958 vload_module(flags, name, ver, &args);
3962 #ifdef PERL_IMPLICIT_CONTEXT
3964 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3968 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
3969 va_start(args, ver);
3970 vload_module(flags, name, ver, &args);
3976 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3980 OP * const modname = newSVOP(OP_CONST, 0, name);
3982 PERL_ARGS_ASSERT_VLOAD_MODULE;
3984 modname->op_private |= OPpCONST_BARE;
3986 veop = newSVOP(OP_CONST, 0, ver);
3990 if (flags & PERL_LOADMOD_NOIMPORT) {
3991 imop = sawparens(newNULLLIST());
3993 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3994 imop = va_arg(*args, OP*);
3999 sv = va_arg(*args, SV*);
4001 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
4002 sv = va_arg(*args, SV*);
4006 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
4007 * that it has a PL_parser to play with while doing that, and also
4008 * that it doesn't mess with any existing parser, by creating a tmp
4009 * new parser with lex_start(). This won't actually be used for much,
4010 * since pp_require() will create another parser for the real work. */
4013 SAVEVPTR(PL_curcop);
4014 lex_start(NULL, NULL, FALSE);
4015 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
4016 veop, modname, imop);
4021 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
4027 PERL_ARGS_ASSERT_DOFILE;
4029 if (!force_builtin) {
4030 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
4031 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
4032 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
4033 gv = gvp ? *gvp : NULL;
4037 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
4038 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
4039 append_elem(OP_LIST, term,
4040 scalar(newUNOP(OP_RV2CV, 0,
4041 newGVOP(OP_GV, 0, gv))))));
4044 doop = newUNOP(OP_DOFILE, 0, scalar(term));
4050 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
4052 return newBINOP(OP_LSLICE, flags,
4053 list(force_list(subscript)),
4054 list(force_list(listval)) );
4058 S_is_list_assignment(pTHX_ register const OP *o)
4066 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
4067 o = cUNOPo->op_first;
4069 flags = o->op_flags;
4071 if (type == OP_COND_EXPR) {
4072 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
4073 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
4078 yyerror("Assignment to both a list and a scalar");
4082 if (type == OP_LIST &&
4083 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
4084 o->op_private & OPpLVAL_INTRO)
4087 if (type == OP_LIST || flags & OPf_PARENS ||
4088 type == OP_RV2AV || type == OP_RV2HV ||
4089 type == OP_ASLICE || type == OP_HSLICE)
4092 if (type == OP_PADAV || type == OP_PADHV)
4095 if (type == OP_RV2SV)
4102 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
4108 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
4109 return newLOGOP(optype, 0,
4110 mod(scalar(left), optype),
4111 newUNOP(OP_SASSIGN, 0, scalar(right)));
4114 return newBINOP(optype, OPf_STACKED,
4115 mod(scalar(left), optype), scalar(right));
4119 if (is_list_assignment(left)) {
4120 static const char no_list_state[] = "Initialization of state variables"
4121 " in list context currently forbidden";
4123 bool maybe_common_vars = TRUE;
4126 /* Grandfathering $[ assignment here. Bletch.*/
4127 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
4128 PL_eval_start = (left->op_type == OP_CONST) ? right : NULL;
4129 left = mod(left, OP_AASSIGN);
4132 else if (left->op_type == OP_CONST) {
4134 /* Result of assignment is always 1 (or we'd be dead already) */
4135 return newSVOP(OP_CONST, 0, newSViv(1));
4137 curop = list(force_list(left));
4138 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
4139 o->op_private = (U8)(0 | (flags >> 8));
4141 if ((left->op_type == OP_LIST
4142 || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
4144 OP* lop = ((LISTOP*)left)->op_first;
4145 maybe_common_vars = FALSE;
4147 if (lop->op_type == OP_PADSV ||
4148 lop->op_type == OP_PADAV ||
4149 lop->op_type == OP_PADHV ||
4150 lop->op_type == OP_PADANY) {
4151 if (!(lop->op_private & OPpLVAL_INTRO))
4152 maybe_common_vars = TRUE;
4154 if (lop->op_private & OPpPAD_STATE) {
4155 if (left->op_private & OPpLVAL_INTRO) {
4156 /* Each variable in state($a, $b, $c) = ... */
4159 /* Each state variable in
4160 (state $a, my $b, our $c, $d, undef) = ... */
4162 yyerror(no_list_state);
4164 /* Each my variable in
4165 (state $a, my $b, our $c, $d, undef) = ... */
4167 } else if (lop->op_type == OP_UNDEF ||
4168 lop->op_type == OP_PUSHMARK) {
4169 /* undef may be interesting in
4170 (state $a, undef, state $c) */
4172 /* Other ops in the list. */
4173 maybe_common_vars = TRUE;
4175 lop = lop->op_sibling;
4178 else if ((left->op_private & OPpLVAL_INTRO)
4179 && ( left->op_type == OP_PADSV
4180 || left->op_type == OP_PADAV
4181 || left->op_type == OP_PADHV
4182 || left->op_type == OP_PADANY))
4184 maybe_common_vars = FALSE;
4185 if (left->op_private & OPpPAD_STATE) {
4186 /* All single variable list context state assignments, hence
4196 yyerror(no_list_state);
4200 /* PL_generation sorcery:
4201 * an assignment like ($a,$b) = ($c,$d) is easier than
4202 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
4203 * To detect whether there are common vars, the global var
4204 * PL_generation is incremented for each assign op we compile.
4205 * Then, while compiling the assign op, we run through all the
4206 * variables on both sides of the assignment, setting a spare slot
4207 * in each of them to PL_generation. If any of them already have
4208 * that value, we know we've got commonality. We could use a
4209 * single bit marker, but then we'd have to make 2 passes, first
4210 * to clear the flag, then to test and set it. To find somewhere
4211 * to store these values, evil chicanery is done with SvUVX().
4214 if (maybe_common_vars) {
4217 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4218 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
4219 if (curop->op_type == OP_GV) {
4220 GV *gv = cGVOPx_gv(curop);
4222 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4224 GvASSIGN_GENERATION_set(gv, PL_generation);
4226 else if (curop->op_type == OP_PADSV ||
4227 curop->op_type == OP_PADAV ||
4228 curop->op_type == OP_PADHV ||
4229 curop->op_type == OP_PADANY)
4231 if (PAD_COMPNAME_GEN(curop->op_targ)
4232 == (STRLEN)PL_generation)
4234 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
4237 else if (curop->op_type == OP_RV2CV)
4239 else if (curop->op_type == OP_RV2SV ||
4240 curop->op_type == OP_RV2AV ||
4241 curop->op_type == OP_RV2HV ||
4242 curop->op_type == OP_RV2GV) {
4243 if (lastop->op_type != OP_GV) /* funny deref? */
4246 else if (curop->op_type == OP_PUSHRE) {
4248 if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
4249 GV *const gv = (GV*)PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff);
4251 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4253 GvASSIGN_GENERATION_set(gv, PL_generation);
4257 = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
4260 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4262 GvASSIGN_GENERATION_set(gv, PL_generation);
4272 o->op_private |= OPpASSIGN_COMMON;
4275 if (right && right->op_type == OP_SPLIT && !PL_madskills) {
4276 OP* tmpop = ((LISTOP*)right)->op_first;
4277 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
4278 PMOP * const pm = (PMOP*)tmpop;
4279 if (left->op_type == OP_RV2AV &&
4280 !(left->op_private & OPpLVAL_INTRO) &&
4281 !(o->op_private & OPpASSIGN_COMMON) )
4283 tmpop = ((UNOP*)left)->op_first;
4284 if (tmpop->op_type == OP_GV
4286 && !pm->op_pmreplrootu.op_pmtargetoff
4288 && !pm->op_pmreplrootu.op_pmtargetgv
4292 pm->op_pmreplrootu.op_pmtargetoff
4293 = cPADOPx(tmpop)->op_padix;
4294 cPADOPx(tmpop)->op_padix = 0; /* steal it */
4296 pm->op_pmreplrootu.op_pmtargetgv
4297 = (GV*)cSVOPx(tmpop)->op_sv;
4298 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
4300 pm->op_pmflags |= PMf_ONCE;
4301 tmpop = cUNOPo->op_first; /* to list (nulled) */
4302 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
4303 tmpop->op_sibling = NULL; /* don't free split */
4304 right->op_next = tmpop->op_next; /* fix starting loc */
4305 op_free(o); /* blow off assign */
4306 right->op_flags &= ~OPf_WANT;
4307 /* "I don't know and I don't care." */
4312 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
4313 ((LISTOP*)right)->op_last->op_type == OP_CONST)
4315 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
4317 sv_setiv(sv, PL_modcount+1);
4325 right = newOP(OP_UNDEF, 0);
4326 if (right->op_type == OP_READLINE) {
4327 right->op_flags |= OPf_STACKED;
4328 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
4331 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
4332 o = newBINOP(OP_SASSIGN, flags,
4333 scalar(right), mod(scalar(left), OP_SASSIGN) );
4337 if (!PL_madskills) { /* assignment to $[ is ignored when making a mad dump */
4339 o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
4340 o->op_private |= OPpCONST_ARYBASE;
4348 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
4351 const U32 seq = intro_my();
4354 NewOp(1101, cop, 1, COP);
4355 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
4356 cop->op_type = OP_DBSTATE;
4357 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
4360 cop->op_type = OP_NEXTSTATE;
4361 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
4363 cop->op_flags = (U8)flags;
4364 CopHINTS_set(cop, PL_hints);
4366 cop->op_private |= NATIVE_HINTS;
4368 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
4369 cop->op_next = (OP*)cop;
4372 /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
4373 CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
4375 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
4376 cop->cop_hints_hash = PL_curcop->cop_hints_hash;
4377 if (cop->cop_hints_hash) {
4379 cop->cop_hints_hash->refcounted_he_refcnt++;
4380 HINTS_REFCNT_UNLOCK;
4384 = Perl_store_cop_label(aTHX_ cop->cop_hints_hash, label);
4386 PL_hints |= HINT_BLOCK_SCOPE;
4387 /* It seems that we need to defer freeing this pointer, as other parts
4388 of the grammar end up wanting to copy it after this op has been
4393 if (PL_parser && PL_parser->copline == NOLINE)
4394 CopLINE_set(cop, CopLINE(PL_curcop));
4396 CopLINE_set(cop, PL_parser->copline);
4398 PL_parser->copline = NOLINE;
4401 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
4403 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
4405 CopSTASH_set(cop, PL_curstash);
4407 if (PERLDB_LINE && PL_curstash != PL_debstash) {
4408 AV *av = CopFILEAVx(PL_curcop);
4410 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
4411 if (svp && *svp != &PL_sv_undef ) {
4412 (void)SvIOK_on(*svp);
4413 SvIV_set(*svp, PTR2IV(cop));
4418 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
4423 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
4427 PERL_ARGS_ASSERT_NEWLOGOP;
4429 return new_logop(type, flags, &first, &other);
4433 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
4438 OP *first = *firstp;
4439 OP * const other = *otherp;
4441 PERL_ARGS_ASSERT_NEW_LOGOP;
4443 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
4444 return newBINOP(type, flags, scalar(first), scalar(other));
4446 scalarboolean(first);
4447 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
4448 if (first->op_type == OP_NOT
4449 && (first->op_flags & OPf_SPECIAL)
4450 && (first->op_flags & OPf_KIDS)
4452 if (type == OP_AND || type == OP_OR) {
4458 first = *firstp = cUNOPo->op_first;
4460 first->op_next = o->op_next;
4461 cUNOPo->op_first = NULL;
4465 if (first->op_type == OP_CONST) {
4466 if (first->op_private & OPpCONST_STRICT)
4467 no_bareword_allowed(first);
4468 else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
4469 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
4470 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
4471 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
4472 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
4474 if (other->op_type == OP_CONST)
4475 other->op_private |= OPpCONST_SHORTCIRCUIT;
4477 OP *newop = newUNOP(OP_NULL, 0, other);
4478 op_getmad(first, newop, '1');
4479 newop->op_targ = type; /* set "was" field */
4486 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
4487 const OP *o2 = other;
4488 if ( ! (o2->op_type == OP_LIST
4489 && (( o2 = cUNOPx(o2)->op_first))
4490 && o2->op_type == OP_PUSHMARK
4491 && (( o2 = o2->op_sibling)) )
4494 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
4495 || o2->op_type == OP_PADHV)
4496 && o2->op_private & OPpLVAL_INTRO
4497 && !(o2->op_private & OPpPAD_STATE)
4498 && ckWARN(WARN_DEPRECATED))
4500 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4501 "Deprecated use of my() in false conditional");
4505 if (first->op_type == OP_CONST)
4506 first->op_private |= OPpCONST_SHORTCIRCUIT;
4508 first = newUNOP(OP_NULL, 0, first);
4509 op_getmad(other, first, '2');
4510 first->op_targ = type; /* set "was" field */
4517 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
4518 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
4520 const OP * const k1 = ((UNOP*)first)->op_first;
4521 const OP * const k2 = k1->op_sibling;
4523 switch (first->op_type)
4526 if (k2 && k2->op_type == OP_READLINE
4527 && (k2->op_flags & OPf_STACKED)
4528 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4530 warnop = k2->op_type;
4535 if (k1->op_type == OP_READDIR
4536 || k1->op_type == OP_GLOB
4537 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4538 || k1->op_type == OP_EACH)
4540 warnop = ((k1->op_type == OP_NULL)
4541 ? (OPCODE)k1->op_targ : k1->op_type);
4546 const line_t oldline = CopLINE(PL_curcop);
4547 CopLINE_set(PL_curcop, PL_parser->copline);
4548 Perl_warner(aTHX_ packWARN(WARN_MISC),
4549 "Value of %s%s can be \"0\"; test with defined()",
4551 ((warnop == OP_READLINE || warnop == OP_GLOB)
4552 ? " construct" : "() operator"));
4553 CopLINE_set(PL_curcop, oldline);
4560 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
4561 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
4563 NewOp(1101, logop, 1, LOGOP);
4565 logop->op_type = (OPCODE)type;
4566 logop->op_ppaddr = PL_ppaddr[type];
4567 logop->op_first = first;
4568 logop->op_flags = (U8)(flags | OPf_KIDS);
4569 logop->op_other = LINKLIST(other);
4570 logop->op_private = (U8)(1 | (flags >> 8));
4572 /* establish postfix order */
4573 logop->op_next = LINKLIST(first);
4574 first->op_next = (OP*)logop;
4575 first->op_sibling = other;
4577 CHECKOP(type,logop);
4579 o = newUNOP(OP_NULL, 0, (OP*)logop);
4586 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
4593 PERL_ARGS_ASSERT_NEWCONDOP;
4596 return newLOGOP(OP_AND, 0, first, trueop);
4598 return newLOGOP(OP_OR, 0, first, falseop);
4600 scalarboolean(first);
4601 if (first->op_type == OP_CONST) {
4602 /* Left or right arm of the conditional? */
4603 const bool left = SvTRUE(((SVOP*)first)->op_sv);
4604 OP *live = left ? trueop : falseop;
4605 OP *const dead = left ? falseop : trueop;
4606 if (first->op_private & OPpCONST_BARE &&
4607 first->op_private & OPpCONST_STRICT) {
4608 no_bareword_allowed(first);
4611 /* This is all dead code when PERL_MAD is not defined. */
4612 live = newUNOP(OP_NULL, 0, live);
4613 op_getmad(first, live, 'C');
4614 op_getmad(dead, live, left ? 'e' : 't');
4621 NewOp(1101, logop, 1, LOGOP);
4622 logop->op_type = OP_COND_EXPR;
4623 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4624 logop->op_first = first;
4625 logop->op_flags = (U8)(flags | OPf_KIDS);
4626 logop->op_private = (U8)(1 | (flags >> 8));
4627 logop->op_other = LINKLIST(trueop);
4628 logop->op_next = LINKLIST(falseop);
4630 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
4633 /* establish postfix order */
4634 start = LINKLIST(first);
4635 first->op_next = (OP*)logop;
4637 first->op_sibling = trueop;
4638 trueop->op_sibling = falseop;
4639 o = newUNOP(OP_NULL, 0, (OP*)logop);
4641 trueop->op_next = falseop->op_next = o;
4648 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4657 PERL_ARGS_ASSERT_NEWRANGE;
4659 NewOp(1101, range, 1, LOGOP);
4661 range->op_type = OP_RANGE;
4662 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4663 range->op_first = left;
4664 range->op_flags = OPf_KIDS;
4665 leftstart = LINKLIST(left);
4666 range->op_other = LINKLIST(right);
4667 range->op_private = (U8)(1 | (flags >> 8));
4669 left->op_sibling = right;
4671 range->op_next = (OP*)range;
4672 flip = newUNOP(OP_FLIP, flags, (OP*)range);
4673 flop = newUNOP(OP_FLOP, 0, flip);
4674 o = newUNOP(OP_NULL, 0, flop);
4676 range->op_next = leftstart;
4678 left->op_next = flip;
4679 right->op_next = flop;
4681 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4682 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4683 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4684 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4686 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4687 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4690 if (!flip->op_private || !flop->op_private)
4691 linklist(o); /* blow off optimizer unless constant */
4697 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4702 const bool once = block && block->op_flags & OPf_SPECIAL &&
4703 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4705 PERL_UNUSED_ARG(debuggable);
4708 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4709 return block; /* do {} while 0 does once */
4710 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4711 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4712 expr = newUNOP(OP_DEFINED, 0,
4713 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4714 } else if (expr->op_flags & OPf_KIDS) {
4715 const OP * const k1 = ((UNOP*)expr)->op_first;
4716 const OP * const k2 = k1 ? k1->op_sibling : NULL;
4717 switch (expr->op_type) {
4719 if (k2 && k2->op_type == OP_READLINE
4720 && (k2->op_flags & OPf_STACKED)
4721 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4722 expr = newUNOP(OP_DEFINED, 0, expr);
4726 if (k1 && (k1->op_type == OP_READDIR
4727 || k1->op_type == OP_GLOB
4728 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4729 || k1->op_type == OP_EACH))
4730 expr = newUNOP(OP_DEFINED, 0, expr);
4736 /* if block is null, the next append_elem() would put UNSTACK, a scalar
4737 * op, in listop. This is wrong. [perl #27024] */
4739 block = newOP(OP_NULL, 0);
4740 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4741 o = new_logop(OP_AND, 0, &expr, &listop);
4744 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4746 if (once && o != listop)
4747 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4750 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
4752 o->op_flags |= flags;
4754 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4759 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
4760 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
4769 PERL_UNUSED_ARG(debuggable);
4772 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4773 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4774 expr = newUNOP(OP_DEFINED, 0,
4775 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4776 } else if (expr->op_flags & OPf_KIDS) {
4777 const OP * const k1 = ((UNOP*)expr)->op_first;
4778 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
4779 switch (expr->op_type) {
4781 if (k2 && k2->op_type == OP_READLINE
4782 && (k2->op_flags & OPf_STACKED)
4783 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4784 expr = newUNOP(OP_DEFINED, 0, expr);
4788 if (k1 && (k1->op_type == OP_READDIR
4789 || k1->op_type == OP_GLOB
4790 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4791 || k1->op_type == OP_EACH))
4792 expr = newUNOP(OP_DEFINED, 0, expr);
4799 block = newOP(OP_NULL, 0);
4800 else if (cont || has_my) {
4801 block = scope(block);
4805 next = LINKLIST(cont);
4808 OP * const unstack = newOP(OP_UNSTACK, 0);
4811 cont = append_elem(OP_LINESEQ, cont, unstack);
4815 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4817 redo = LINKLIST(listop);
4820 PL_parser->copline = (line_t)whileline;
4822 o = new_logop(OP_AND, 0, &expr, &listop);
4823 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4824 op_free(expr); /* oops, it's a while (0) */
4826 return NULL; /* listop already freed by new_logop */
4829 ((LISTOP*)listop)->op_last->op_next =
4830 (o == listop ? redo : LINKLIST(o));
4836 NewOp(1101,loop,1,LOOP);
4837 loop->op_type = OP_ENTERLOOP;
4838 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4839 loop->op_private = 0;
4840 loop->op_next = (OP*)loop;
4843 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4845 loop->op_redoop = redo;
4846 loop->op_lastop = o;
4847 o->op_private |= loopflags;
4850 loop->op_nextop = next;
4852 loop->op_nextop = o;
4854 o->op_flags |= flags;
4855 o->op_private |= (flags >> 8);
4860 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
4865 PADOFFSET padoff = 0;
4870 PERL_ARGS_ASSERT_NEWFOROP;
4873 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4874 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
4875 sv->op_type = OP_RV2GV;
4876 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4878 /* The op_type check is needed to prevent a possible segfault
4879 * if the loop variable is undeclared and 'strict vars' is in
4880 * effect. This is illegal but is nonetheless parsed, so we
4881 * may reach this point with an OP_CONST where we're expecting
4884 if (cUNOPx(sv)->op_first->op_type == OP_GV
4885 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
4886 iterpflags |= OPpITER_DEF;
4888 else if (sv->op_type == OP_PADSV) { /* private variable */
4889 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
4890 padoff = sv->op_targ;
4900 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4902 SV *const namesv = PAD_COMPNAME_SV(padoff);
4904 const char *const name = SvPV_const(namesv, len);
4906 if (len == 2 && name[0] == '$' && name[1] == '_')
4907 iterpflags |= OPpITER_DEF;
4911 const PADOFFSET offset = pad_findmy("$_");
4912 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
4913 sv = newGVOP(OP_GV, 0, PL_defgv);
4918 iterpflags |= OPpITER_DEF;
4920 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4921 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4922 iterflags |= OPf_STACKED;
4924 else if (expr->op_type == OP_NULL &&
4925 (expr->op_flags & OPf_KIDS) &&
4926 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4928 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4929 * set the STACKED flag to indicate that these values are to be
4930 * treated as min/max values by 'pp_iterinit'.
4932 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4933 LOGOP* const range = (LOGOP*) flip->op_first;
4934 OP* const left = range->op_first;
4935 OP* const right = left->op_sibling;
4938 range->op_flags &= ~OPf_KIDS;
4939 range->op_first = NULL;
4941 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4942 listop->op_first->op_next = range->op_next;
4943 left->op_next = range->op_other;
4944 right->op_next = (OP*)listop;
4945 listop->op_next = listop->op_first;
4948 op_getmad(expr,(OP*)listop,'O');
4952 expr = (OP*)(listop);
4954 iterflags |= OPf_STACKED;
4957 expr = mod(force_list(expr), OP_GREPSTART);
4960 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4961 append_elem(OP_LIST, expr, scalar(sv))));
4962 assert(!loop->op_next);
4963 /* for my $x () sets OPpLVAL_INTRO;
4964 * for our $x () sets OPpOUR_INTRO */
4965 loop->op_private = (U8)iterpflags;
4966 #ifdef PL_OP_SLAB_ALLOC
4969 NewOp(1234,tmp,1,LOOP);
4970 Copy(loop,tmp,1,LISTOP);
4971 S_op_destroy(aTHX_ (OP*)loop);
4975 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
4977 loop->op_targ = padoff;
4978 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
4980 op_getmad(madsv, (OP*)loop, 'v');
4981 PL_parser->copline = forline;
4982 return newSTATEOP(0, label, wop);
4986 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4991 PERL_ARGS_ASSERT_NEWLOOPEX;
4993 if (type != OP_GOTO || label->op_type == OP_CONST) {
4994 /* "last()" means "last" */
4995 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4996 o = newOP(type, OPf_SPECIAL);
4998 o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
4999 ? SvPV_nolen_const(((SVOP*)label)->op_sv)
5003 op_getmad(label,o,'L');
5009 /* Check whether it's going to be a goto &function */
5010 if (label->op_type == OP_ENTERSUB
5011 && !(label->op_flags & OPf_STACKED))
5012 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
5013 o = newUNOP(type, OPf_STACKED, label);
5015 PL_hints |= HINT_BLOCK_SCOPE;
5019 /* if the condition is a literal array or hash
5020 (or @{ ... } etc), make a reference to it.
5023 S_ref_array_or_hash(pTHX_ OP *cond)
5026 && (cond->op_type == OP_RV2AV
5027 || cond->op_type == OP_PADAV
5028 || cond->op_type == OP_RV2HV
5029 || cond->op_type == OP_PADHV))
5031 return newUNOP(OP_REFGEN,
5032 0, mod(cond, OP_REFGEN));
5038 /* These construct the optree fragments representing given()
5041 entergiven and enterwhen are LOGOPs; the op_other pointer
5042 points up to the associated leave op. We need this so we
5043 can put it in the context and make break/continue work.
5044 (Also, of course, pp_enterwhen will jump straight to
5045 op_other if the match fails.)
5049 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
5050 I32 enter_opcode, I32 leave_opcode,
5051 PADOFFSET entertarg)
5057 PERL_ARGS_ASSERT_NEWGIVWHENOP;
5059 NewOp(1101, enterop, 1, LOGOP);
5060 enterop->op_type = (optype)enter_opcode;
5061 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
5062 enterop->op_flags = (U8) OPf_KIDS;
5063 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
5064 enterop->op_private = 0;
5066 o = newUNOP(leave_opcode, 0, (OP *) enterop);
5069 enterop->op_first = scalar(cond);
5070 cond->op_sibling = block;
5072 o->op_next = LINKLIST(cond);
5073 cond->op_next = (OP *) enterop;
5076 /* This is a default {} block */
5077 enterop->op_first = block;
5078 enterop->op_flags |= OPf_SPECIAL;
5080 o->op_next = (OP *) enterop;
5083 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
5084 entergiven and enterwhen both
5087 enterop->op_next = LINKLIST(block);
5088 block->op_next = enterop->op_other = o;
5093 /* Does this look like a boolean operation? For these purposes
5094 a boolean operation is:
5095 - a subroutine call [*]
5096 - a logical connective
5097 - a comparison operator
5098 - a filetest operator, with the exception of -s -M -A -C
5099 - defined(), exists() or eof()
5100 - /$re/ or $foo =~ /$re/
5102 [*] possibly surprising
5105 S_looks_like_bool(pTHX_ const OP *o)
5109 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
5111 switch(o->op_type) {
5113 return looks_like_bool(cLOGOPo->op_first);
5117 looks_like_bool(cLOGOPo->op_first)
5118 && looks_like_bool(cLOGOPo->op_first->op_sibling));
5122 o->op_flags & OPf_KIDS
5123 && looks_like_bool(cUNOPo->op_first));
5127 case OP_NOT: case OP_XOR:
5128 /* Note that OP_DOR is not here */
5130 case OP_EQ: case OP_NE: case OP_LT:
5131 case OP_GT: case OP_LE: case OP_GE:
5133 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
5134 case OP_I_GT: case OP_I_LE: case OP_I_GE:
5136 case OP_SEQ: case OP_SNE: case OP_SLT:
5137 case OP_SGT: case OP_SLE: case OP_SGE:
5141 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
5142 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
5143 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
5144 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
5145 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
5146 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
5147 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
5148 case OP_FTTEXT: case OP_FTBINARY:
5150 case OP_DEFINED: case OP_EXISTS:
5151 case OP_MATCH: case OP_EOF:
5156 /* Detect comparisons that have been optimized away */
5157 if (cSVOPo->op_sv == &PL_sv_yes
5158 || cSVOPo->op_sv == &PL_sv_no)
5169 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
5172 PERL_ARGS_ASSERT_NEWGIVENOP;
5173 return newGIVWHENOP(
5174 ref_array_or_hash(cond),
5176 OP_ENTERGIVEN, OP_LEAVEGIVEN,
5180 /* If cond is null, this is a default {} block */
5182 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
5184 const bool cond_llb = (!cond || looks_like_bool(cond));
5187 PERL_ARGS_ASSERT_NEWWHENOP;
5192 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
5194 scalar(ref_array_or_hash(cond)));
5197 return newGIVWHENOP(
5199 append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
5200 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
5204 =for apidoc cv_undef
5206 Clear out all the active components of a CV. This can happen either
5207 by an explicit C<undef &foo>, or by the reference count going to zero.
5208 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
5209 children can still follow the full lexical scope chain.
5215 Perl_cv_undef(pTHX_ CV *cv)
5219 PERL_ARGS_ASSERT_CV_UNDEF;
5221 DEBUG_X(PerlIO_printf(Perl_debug_log,
5222 "CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n",
5223 PTR2UV(cv), PTR2UV(PL_comppad))
5227 if (CvFILE(cv) && !CvISXSUB(cv)) {
5228 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
5229 Safefree(CvFILE(cv));
5234 if (!CvISXSUB(cv) && CvROOT(cv)) {
5235 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
5236 Perl_croak(aTHX_ "Can't undef active subroutine");
5239 PAD_SAVE_SETNULLPAD();
5241 op_free(CvROOT(cv));
5246 SvPOK_off((SV*)cv); /* forget prototype */
5251 /* remove CvOUTSIDE unless this is an undef rather than a free */
5252 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
5253 if (!CvWEAKOUTSIDE(cv))
5254 SvREFCNT_dec(CvOUTSIDE(cv));
5255 CvOUTSIDE(cv) = NULL;
5258 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
5261 if (CvISXSUB(cv) && CvXSUB(cv)) {
5264 /* delete all flags except WEAKOUTSIDE */
5265 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
5269 Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
5272 PERL_ARGS_ASSERT_CV_CKPROTO_LEN;
5274 /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
5275 relying on SvCUR, and doubling up the buffer to hold CvFILE(). */
5276 if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
5277 || (p && (len != SvCUR(cv) /* Not the same length. */
5278 || memNE(p, SvPVX_const(cv), len))))
5279 && ckWARN_d(WARN_PROTOTYPE)) {
5280 SV* const msg = sv_newmortal();
5284 gv_efullname3(name = sv_newmortal(), gv, NULL);
5285 sv_setpvs(msg, "Prototype mismatch:");
5287 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
5289 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv));
5291 sv_catpvs(msg, ": none");
5292 sv_catpvs(msg, " vs ");
5294 Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
5296 sv_catpvs(msg, "none");
5297 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
5301 static void const_sv_xsub(pTHX_ CV* cv);
5305 =head1 Optree Manipulation Functions
5307 =for apidoc cv_const_sv
5309 If C<cv> is a constant sub eligible for inlining. returns the constant
5310 value returned by the sub. Otherwise, returns NULL.
5312 Constant subs can be created with C<newCONSTSUB> or as described in
5313 L<perlsub/"Constant Functions">.
5318 Perl_cv_const_sv(pTHX_ CV *cv)
5320 PERL_UNUSED_CONTEXT;
5323 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
5325 return CvCONST(cv) ? (SV*)CvXSUBANY(cv).any_ptr : NULL;
5328 /* op_const_sv: examine an optree to determine whether it's in-lineable.
5329 * Can be called in 3 ways:
5332 * look for a single OP_CONST with attached value: return the value
5334 * cv && CvCLONE(cv) && !CvCONST(cv)
5336 * examine the clone prototype, and if contains only a single
5337 * OP_CONST referencing a pad const, or a single PADSV referencing
5338 * an outer lexical, return a non-zero value to indicate the CV is
5339 * a candidate for "constizing" at clone time
5343 * We have just cloned an anon prototype that was marked as a const
5344 * candidiate. Try to grab the current value, and in the case of
5345 * PADSV, ignore it if it has multiple references. Return the value.
5349 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
5360 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
5361 o = cLISTOPo->op_first->op_sibling;
5363 for (; o; o = o->op_next) {
5364 const OPCODE type = o->op_type;
5366 if (sv && o->op_next == o)
5368 if (o->op_next != o) {
5369 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
5371 if (type == OP_DBSTATE)
5374 if (type == OP_LEAVESUB || type == OP_RETURN)
5378 if (type == OP_CONST && cSVOPo->op_sv)
5380 else if (cv && type == OP_CONST) {
5381 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5385 else if (cv && type == OP_PADSV) {
5386 if (CvCONST(cv)) { /* newly cloned anon */
5387 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5388 /* the candidate should have 1 ref from this pad and 1 ref
5389 * from the parent */
5390 if (!sv || SvREFCNT(sv) != 2)
5397 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
5398 sv = &PL_sv_undef; /* an arbitrary non-null value */
5413 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5416 /* This would be the return value, but the return cannot be reached. */
5417 OP* pegop = newOP(OP_NULL, 0);
5420 PERL_UNUSED_ARG(floor);
5430 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
5432 NORETURN_FUNCTION_END;
5437 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
5439 return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
5443 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5450 register CV *cv = NULL;
5452 /* If the subroutine has no body, no attributes, and no builtin attributes
5453 then it's just a sub declaration, and we may be able to get away with
5454 storing with a placeholder scalar in the symbol table, rather than a
5455 full GV and CV. If anything is present then it will take a full CV to
5457 const I32 gv_fetch_flags
5458 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5460 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
5461 const char * const name = o ? SvPV_nolen_const(cSVOPo->op_sv) : NULL;
5464 assert(proto->op_type == OP_CONST);
5465 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
5470 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
5471 SV * const sv = sv_newmortal();
5472 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
5473 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
5474 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
5475 aname = SvPVX_const(sv);
5480 gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
5481 : gv_fetchpv(aname ? aname
5482 : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5483 gv_fetch_flags, SVt_PVCV);
5485 if (!PL_madskills) {
5494 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
5495 maximum a prototype before. */
5496 if (SvTYPE(gv) > SVt_NULL) {
5497 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
5498 && ckWARN_d(WARN_PROTOTYPE))
5500 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
5502 cv_ckproto_len((CV*)gv, NULL, ps, ps_len);
5505 sv_setpvn((SV*)gv, ps, ps_len);
5507 sv_setiv((SV*)gv, -1);
5509 SvREFCNT_dec(PL_compcv);
5510 cv = PL_compcv = NULL;
5514 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
5516 #ifdef GV_UNIQUE_CHECK
5517 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
5518 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
5522 if (!block || !ps || *ps || attrs
5523 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5525 || block->op_type == OP_NULL
5530 const_sv = op_const_sv(block, NULL);
5533 const bool exists = CvROOT(cv) || CvXSUB(cv);
5535 #ifdef GV_UNIQUE_CHECK
5536 if (exists && GvUNIQUE(gv)) {
5537 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
5541 /* if the subroutine doesn't exist and wasn't pre-declared
5542 * with a prototype, assume it will be AUTOLOADed,
5543 * skipping the prototype check
5545 if (exists || SvPOK(cv))
5546 cv_ckproto_len(cv, gv, ps, ps_len);
5547 /* already defined (or promised)? */
5548 if (exists || GvASSUMECV(gv)) {
5551 || block->op_type == OP_NULL
5554 if (CvFLAGS(PL_compcv)) {
5555 /* might have had built-in attrs applied */
5556 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5558 /* just a "sub foo;" when &foo is already defined */
5559 SAVEFREESV(PL_compcv);
5564 && block->op_type != OP_NULL
5567 if (ckWARN(WARN_REDEFINE)
5569 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
5571 const line_t oldline = CopLINE(PL_curcop);
5572 if (PL_parser && PL_parser->copline != NOLINE)
5573 CopLINE_set(PL_curcop, PL_parser->copline);
5574 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5575 CvCONST(cv) ? "Constant subroutine %s redefined"
5576 : "Subroutine %s redefined", name);
5577 CopLINE_set(PL_curcop, oldline);
5580 if (!PL_minus_c) /* keep old one around for madskills */
5583 /* (PL_madskills unset in used file.) */
5591 SvREFCNT_inc_simple_void_NN(const_sv);
5593 assert(!CvROOT(cv) && !CvCONST(cv));
5594 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
5595 CvXSUBANY(cv).any_ptr = const_sv;
5596 CvXSUB(cv) = const_sv_xsub;
5602 cv = newCONSTSUB(NULL, name, const_sv);
5604 mro_method_changed_in( /* sub Foo::Bar () { 123 } */
5605 (CvGV(cv) && GvSTASH(CvGV(cv)))
5614 SvREFCNT_dec(PL_compcv);
5622 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
5623 * before we clobber PL_compcv.
5627 || block->op_type == OP_NULL
5631 /* Might have had built-in attributes applied -- propagate them. */
5632 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5633 if (CvGV(cv) && GvSTASH(CvGV(cv)))
5634 stash = GvSTASH(CvGV(cv));
5635 else if (CvSTASH(cv))
5636 stash = CvSTASH(cv);
5638 stash = PL_curstash;
5641 /* possibly about to re-define existing subr -- ignore old cv */
5642 rcv = (SV*)PL_compcv;
5643 if (name && GvSTASH(gv))
5644 stash = GvSTASH(gv);
5646 stash = PL_curstash;
5648 apply_attrs(stash, rcv, attrs, FALSE);
5650 if (cv) { /* must reuse cv if autoloaded */
5657 || block->op_type == OP_NULL) && !PL_madskills
5660 /* got here with just attrs -- work done, so bug out */
5661 SAVEFREESV(PL_compcv);
5664 /* transfer PL_compcv to cv */
5666 CvFLAGS(cv) = CvFLAGS(PL_compcv);
5667 if (!CvWEAKOUTSIDE(cv))
5668 SvREFCNT_dec(CvOUTSIDE(cv));
5669 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
5670 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
5671 CvOUTSIDE(PL_compcv) = 0;
5672 CvPADLIST(cv) = CvPADLIST(PL_compcv);
5673 CvPADLIST(PL_compcv) = 0;
5674 /* inner references to PL_compcv must be fixed up ... */
5675 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
5676 /* ... before we throw it away */
5677 SvREFCNT_dec(PL_compcv);
5679 if (PERLDB_INTER)/* Advice debugger on the new sub. */
5680 ++PL_sub_generation;
5687 if (strEQ(name, "import")) {
5688 PL_formfeed = (SV*)cv;
5689 Perl_warner(aTHX_ packWARN(WARN_VOID), "%lx\n", (long)cv);
5693 mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */
5697 CvFILE_set_from_cop(cv, PL_curcop);
5698 CvSTASH(cv) = PL_curstash;
5701 sv_setpvn((SV*)cv, ps, ps_len);
5703 if (PL_parser && PL_parser->error_count) {
5707 const char *s = strrchr(name, ':');
5709 if (strEQ(s, "BEGIN")) {
5710 const char not_safe[] =
5711 "BEGIN not safe after errors--compilation aborted";
5712 if (PL_in_eval & EVAL_KEEPERR)
5713 Perl_croak(aTHX_ not_safe);
5715 /* force display of errors found but not reported */
5716 sv_catpv(ERRSV, not_safe);
5717 Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
5727 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5728 mod(scalarseq(block), OP_LEAVESUBLV));
5729 block->op_attached = 1;
5732 /* This makes sub {}; work as expected. */
5733 if (block->op_type == OP_STUB) {
5734 OP* const newblock = newSTATEOP(0, NULL, 0);
5736 op_getmad(block,newblock,'B');
5743 block->op_attached = 1;
5744 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5746 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5747 OpREFCNT_set(CvROOT(cv), 1);
5748 CvSTART(cv) = LINKLIST(CvROOT(cv));
5749 CvROOT(cv)->op_next = 0;
5750 CALL_PEEP(CvSTART(cv));
5752 /* now that optimizer has done its work, adjust pad values */
5754 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
5757 assert(!CvCONST(cv));
5758 if (ps && !*ps && op_const_sv(block, cv))
5762 if (name || aname) {
5763 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5764 SV * const sv = newSV(0);
5765 SV * const tmpstr = sv_newmortal();
5766 GV * const db_postponed = gv_fetchpvs("DB::postponed",
5767 GV_ADDMULTI, SVt_PVHV);
5770 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5772 (long)PL_subline, (long)CopLINE(PL_curcop));
5773 gv_efullname3(tmpstr, gv, NULL);
5774 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
5775 SvCUR(tmpstr), sv, 0);
5776 hv = GvHVn(db_postponed);
5777 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
5778 CV * const pcv = GvCV(db_postponed);
5784 call_sv((SV*)pcv, G_DISCARD);
5789 if (name && ! (PL_parser && PL_parser->error_count))
5790 process_special_blocks(name, gv, cv);
5795 PL_parser->copline = NOLINE;
5801 S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
5804 const char *const colon = strrchr(fullname,':');
5805 const char *const name = colon ? colon + 1 : fullname;
5807 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
5810 if (strEQ(name, "BEGIN")) {
5811 const I32 oldscope = PL_scopestack_ix;
5813 SAVECOPFILE(&PL_compiling);
5814 SAVECOPLINE(&PL_compiling);
5816 DEBUG_x( dump_sub(gv) );
5817 Perl_av_create_and_push(aTHX_ &PL_beginav, (SV*)cv);
5818 GvCV(gv) = 0; /* cv has been hijacked */
5819 call_list(oldscope, PL_beginav);
5821 PL_curcop = &PL_compiling;
5822 CopHINTS_set(&PL_compiling, PL_hints);
5829 if strEQ(name, "END") {
5830 DEBUG_x( dump_sub(gv) );
5831 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, (SV*)cv);
5834 } else if (*name == 'U') {
5835 if (strEQ(name, "UNITCHECK")) {
5836 /* It's never too late to run a unitcheck block */
5837 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, (SV*)cv);
5841 } else if (*name == 'C') {
5842 if (strEQ(name, "CHECK")) {
5843 if (PL_main_start && ckWARN(WARN_VOID))
5844 Perl_warner(aTHX_ packWARN(WARN_VOID),
5845 "Too late to run CHECK block");
5846 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, (SV*)cv);
5850 } else if (*name == 'I') {
5851 if (strEQ(name, "INIT")) {
5852 if (PL_main_start && ckWARN(WARN_VOID))
5853 Perl_warner(aTHX_ packWARN(WARN_VOID),
5854 "Too late to run INIT block");
5855 Perl_av_create_and_push(aTHX_ &PL_initav, (SV*)cv);
5861 DEBUG_x( dump_sub(gv) );
5862 GvCV(gv) = 0; /* cv has been hijacked */
5867 =for apidoc newCONSTSUB
5869 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5870 eligible for inlining at compile-time.
5876 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
5881 const char *const temp_p = CopFILE(PL_curcop);
5882 const STRLEN len = temp_p ? strlen(temp_p) : 0;
5884 SV *const temp_sv = CopFILESV(PL_curcop);
5886 const char *const temp_p = temp_sv ? SvPV_const(temp_sv, len) : NULL;
5888 char *const file = savepvn(temp_p, temp_p ? len : 0);
5892 if (IN_PERL_RUNTIME) {
5893 /* at runtime, it's not safe to manipulate PL_curcop: it may be
5894 * an op shared between threads. Use a non-shared COP for our
5896 SAVEVPTR(PL_curcop);
5897 PL_curcop = &PL_compiling;
5899 SAVECOPLINE(PL_curcop);
5900 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
5903 PL_hints &= ~HINT_BLOCK_SCOPE;
5906 SAVESPTR(PL_curstash);
5907 SAVECOPSTASH(PL_curcop);
5908 PL_curstash = stash;
5909 CopSTASH_set(PL_curcop,stash);
5912 /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
5913 and so doesn't get free()d. (It's expected to be from the C pre-
5914 processor __FILE__ directive). But we need a dynamically allocated one,
5915 and we need it to get freed. */
5916 cv = newXS_flags(name, const_sv_xsub, file, "", XS_DYNAMIC_FILENAME);
5917 CvXSUBANY(cv).any_ptr = sv;
5923 CopSTASH_free(PL_curcop);
5931 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
5932 const char *const filename, const char *const proto,
5935 CV *cv = newXS(name, subaddr, filename);
5937 PERL_ARGS_ASSERT_NEWXS_FLAGS;
5939 if (flags & XS_DYNAMIC_FILENAME) {
5940 /* We need to "make arrangements" (ie cheat) to ensure that the
5941 filename lasts as long as the PVCV we just created, but also doesn't
5943 STRLEN filename_len = strlen(filename);
5944 STRLEN proto_and_file_len = filename_len;
5945 char *proto_and_file;
5949 proto_len = strlen(proto);
5950 proto_and_file_len += proto_len;
5952 Newx(proto_and_file, proto_and_file_len + 1, char);
5953 Copy(proto, proto_and_file, proto_len, char);
5954 Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
5957 proto_and_file = savepvn(filename, filename_len);
5960 /* This gets free()d. :-) */
5961 sv_usepvn_flags((SV*)cv, proto_and_file, proto_and_file_len,
5962 SV_HAS_TRAILING_NUL);
5964 /* This gives us the correct prototype, rather than one with the
5965 file name appended. */
5966 SvCUR_set(cv, proto_len);
5970 CvFILE(cv) = proto_and_file + proto_len;
5972 sv_setpv((SV *)cv, proto);
5978 =for apidoc U||newXS
5980 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
5981 static storage, as it is used directly as CvFILE(), without a copy being made.
5987 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
5990 GV * const gv = gv_fetchpv(name ? name :
5991 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5992 GV_ADDMULTI, SVt_PVCV);
5995 PERL_ARGS_ASSERT_NEWXS;
5998 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
6000 if ((cv = (name ? GvCV(gv) : NULL))) {
6002 /* just a cached method */
6006 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
6007 /* already defined (or promised) */
6008 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
6009 if (ckWARN(WARN_REDEFINE)) {
6010 GV * const gvcv = CvGV(cv);
6012 HV * const stash = GvSTASH(gvcv);
6014 const char *redefined_name = HvNAME_get(stash);
6015 if ( strEQ(redefined_name,"autouse") ) {
6016 const line_t oldline = CopLINE(PL_curcop);
6017 if (PL_parser && PL_parser->copline != NOLINE)
6018 CopLINE_set(PL_curcop, PL_parser->copline);
6019 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6020 CvCONST(cv) ? "Constant subroutine %s redefined"
6021 : "Subroutine %s redefined"
6023 CopLINE_set(PL_curcop, oldline);
6033 if (cv) /* must reuse cv if autoloaded */
6036 cv = (CV*)newSV_type(SVt_PVCV);
6040 mro_method_changed_in(GvSTASH(gv)); /* newXS */
6044 (void)gv_fetchfile(filename);
6045 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
6046 an external constant string */
6048 CvXSUB(cv) = subaddr;
6051 process_special_blocks(name, gv, cv);
6063 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
6068 OP* pegop = newOP(OP_NULL, 0);
6072 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
6073 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
6075 #ifdef GV_UNIQUE_CHECK
6077 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
6081 if ((cv = GvFORM(gv))) {
6082 if (ckWARN(WARN_REDEFINE)) {
6083 const line_t oldline = CopLINE(PL_curcop);
6084 if (PL_parser && PL_parser->copline != NOLINE)
6085 CopLINE_set(PL_curcop, PL_parser->copline);
6086 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6087 o ? "Format %"SVf" redefined"
6088 : "Format STDOUT redefined", SVfARG(cSVOPo->op_sv));
6089 CopLINE_set(PL_curcop, oldline);
6096 CvFILE_set_from_cop(cv, PL_curcop);
6099 pad_tidy(padtidy_FORMAT);
6100 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
6101 CvROOT(cv)->op_private |= OPpREFCOUNTED;
6102 OpREFCNT_set(CvROOT(cv), 1);
6103 CvSTART(cv) = LINKLIST(CvROOT(cv));
6104 CvROOT(cv)->op_next = 0;
6105 CALL_PEEP(CvSTART(cv));
6107 op_getmad(o,pegop,'n');
6108 op_getmad_weak(block, pegop, 'b');
6113 PL_parser->copline = NOLINE;
6121 Perl_newANONLIST(pTHX_ OP *o)
6123 return convert(OP_ANONLIST, OPf_SPECIAL, o);
6127 Perl_newANONHASH(pTHX_ OP *o)
6129 return convert(OP_ANONHASH, OPf_SPECIAL, o);
6133 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
6135 return newANONATTRSUB(floor, proto, NULL, block);
6139 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
6141 return newUNOP(OP_REFGEN, 0,
6142 newSVOP(OP_ANONCODE, 0,
6143 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
6147 Perl_oopsAV(pTHX_ OP *o)
6151 PERL_ARGS_ASSERT_OOPSAV;
6153 switch (o->op_type) {
6155 o->op_type = OP_PADAV;
6156 o->op_ppaddr = PL_ppaddr[OP_PADAV];
6157 return ref(o, OP_RV2AV);
6160 o->op_type = OP_RV2AV;
6161 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
6166 if (ckWARN_d(WARN_INTERNAL))
6167 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
6174 Perl_oopsHV(pTHX_ OP *o)
6178 PERL_ARGS_ASSERT_OOPSHV;
6180 switch (o->op_type) {
6183 o->op_type = OP_PADHV;
6184 o->op_ppaddr = PL_ppaddr[OP_PADHV];
6185 return ref(o, OP_RV2HV);
6189 o->op_type = OP_RV2HV;
6190 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
6195 if (ckWARN_d(WARN_INTERNAL))
6196 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
6203 Perl_newAVREF(pTHX_ OP *o)
6207 PERL_ARGS_ASSERT_NEWAVREF;
6209 if (o->op_type == OP_PADANY) {
6210 o->op_type = OP_PADAV;
6211 o->op_ppaddr = PL_ppaddr[OP_PADAV];
6214 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
6215 && ckWARN(WARN_DEPRECATED)) {
6216 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
6217 "Using an array as a reference is deprecated");
6219 return newUNOP(OP_RV2AV, 0, scalar(o));
6223 Perl_newGVREF(pTHX_ I32 type, OP *o)
6225 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
6226 return newUNOP(OP_NULL, 0, o);
6227 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
6231 Perl_newHVREF(pTHX_ OP *o)
6235 PERL_ARGS_ASSERT_NEWHVREF;
6237 if (o->op_type == OP_PADANY) {
6238 o->op_type = OP_PADHV;
6239 o->op_ppaddr = PL_ppaddr[OP_PADHV];
6242 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
6243 && ckWARN(WARN_DEPRECATED)) {
6244 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
6245 "Using a hash as a reference is deprecated");
6247 return newUNOP(OP_RV2HV, 0, scalar(o));
6251 Perl_newCVREF(pTHX_ I32 flags, OP *o)
6253 return newUNOP(OP_RV2CV, flags, scalar(o));
6257 Perl_newSVREF(pTHX_ OP *o)
6261 PERL_ARGS_ASSERT_NEWSVREF;
6263 if (o->op_type == OP_PADANY) {
6264 o->op_type = OP_PADSV;
6265 o->op_ppaddr = PL_ppaddr[OP_PADSV];
6268 return newUNOP(OP_RV2SV, 0, scalar(o));
6271 /* Check routines. See the comments at the top of this file for details
6272 * on when these are called */
6275 Perl_ck_anoncode(pTHX_ OP *o)
6277 PERL_ARGS_ASSERT_CK_ANONCODE;
6279 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
6281 cSVOPo->op_sv = NULL;
6286 Perl_ck_bitop(pTHX_ OP *o)
6290 PERL_ARGS_ASSERT_CK_BITOP;
6292 #define OP_IS_NUMCOMPARE(op) \
6293 ((op) == OP_LT || (op) == OP_I_LT || \
6294 (op) == OP_GT || (op) == OP_I_GT || \
6295 (op) == OP_LE || (op) == OP_I_LE || \
6296 (op) == OP_GE || (op) == OP_I_GE || \
6297 (op) == OP_EQ || (op) == OP_I_EQ || \
6298 (op) == OP_NE || (op) == OP_I_NE || \
6299 (op) == OP_NCMP || (op) == OP_I_NCMP)
6300 o->op_private = (U8)(PL_hints & HINT_INTEGER);
6301 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
6302 && (o->op_type == OP_BIT_OR
6303 || o->op_type == OP_BIT_AND
6304 || o->op_type == OP_BIT_XOR))
6306 const OP * const left = cBINOPo->op_first;
6307 const OP * const right = left->op_sibling;
6308 if ((OP_IS_NUMCOMPARE(left->op_type) &&
6309 (left->op_flags & OPf_PARENS) == 0) ||
6310 (OP_IS_NUMCOMPARE(right->op_type) &&
6311 (right->op_flags & OPf_PARENS) == 0))
6312 if (ckWARN(WARN_PRECEDENCE))
6313 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
6314 "Possible precedence problem on bitwise %c operator",
6315 o->op_type == OP_BIT_OR ? '|'
6316 : o->op_type == OP_BIT_AND ? '&' : '^'
6323 Perl_ck_concat(pTHX_ OP *o)
6325 const OP * const kid = cUNOPo->op_first;
6327 PERL_ARGS_ASSERT_CK_CONCAT;
6328 PERL_UNUSED_CONTEXT;
6330 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
6331 !(kUNOP->op_first->op_flags & OPf_MOD))
6332 o->op_flags |= OPf_STACKED;
6337 Perl_ck_spair(pTHX_ OP *o)
6341 PERL_ARGS_ASSERT_CK_SPAIR;
6343 if (o->op_flags & OPf_KIDS) {
6346 const OPCODE type = o->op_type;
6347 o = modkids(ck_fun(o), type);
6348 kid = cUNOPo->op_first;
6349 newop = kUNOP->op_first->op_sibling;
6351 const OPCODE type = newop->op_type;
6352 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
6353 type == OP_PADAV || type == OP_PADHV ||
6354 type == OP_RV2AV || type == OP_RV2HV)
6358 op_getmad(kUNOP->op_first,newop,'K');
6360 op_free(kUNOP->op_first);
6362 kUNOP->op_first = newop;
6364 o->op_ppaddr = PL_ppaddr[++o->op_type];
6369 Perl_ck_delete(pTHX_ OP *o)
6371 PERL_ARGS_ASSERT_CK_DELETE;
6375 if (o->op_flags & OPf_KIDS) {
6376 OP * const kid = cUNOPo->op_first;
6377 switch (kid->op_type) {
6379 o->op_flags |= OPf_SPECIAL;
6382 o->op_private |= OPpSLICE;
6385 o->op_flags |= OPf_SPECIAL;
6390 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
6399 Perl_ck_die(pTHX_ OP *o)
6401 PERL_ARGS_ASSERT_CK_DIE;
6404 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6410 Perl_ck_eof(pTHX_ OP *o)
6414 PERL_ARGS_ASSERT_CK_EOF;
6416 if (o->op_flags & OPf_KIDS) {
6417 if (cLISTOPo->op_first->op_type == OP_STUB) {
6419 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
6421 op_getmad(o,newop,'O');
6433 Perl_ck_eval(pTHX_ OP *o)
6437 PERL_ARGS_ASSERT_CK_EVAL;
6439 PL_hints |= HINT_BLOCK_SCOPE;
6440 if (o->op_flags & OPf_KIDS) {
6441 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6444 o->op_flags &= ~OPf_KIDS;
6447 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
6453 cUNOPo->op_first = 0;
6458 NewOp(1101, enter, 1, LOGOP);
6459 enter->op_type = OP_ENTERTRY;
6460 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
6461 enter->op_private = 0;
6463 /* establish postfix order */
6464 enter->op_next = (OP*)enter;
6466 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
6467 o->op_type = OP_LEAVETRY;
6468 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
6469 enter->op_other = o;
6470 op_getmad(oldo,o,'O');
6484 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
6485 op_getmad(oldo,o,'O');
6487 o->op_targ = (PADOFFSET)PL_hints;
6488 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
6489 /* Store a copy of %^H that pp_entereval can pick up. */
6490 OP *hhop = newSVOP(OP_HINTSEVAL, 0,
6491 (SV*)Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv)));
6492 cUNOPo->op_first->op_sibling = hhop;
6493 o->op_private |= OPpEVAL_HAS_HH;
6499 Perl_ck_exit(pTHX_ OP *o)
6501 PERL_ARGS_ASSERT_CK_EXIT;
6504 HV * const table = GvHV(PL_hintgv);
6506 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
6507 if (svp && *svp && SvTRUE(*svp))
6508 o->op_private |= OPpEXIT_VMSISH;
6510 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6516 Perl_ck_exec(pTHX_ OP *o)
6518 PERL_ARGS_ASSERT_CK_EXEC;
6520 if (o->op_flags & OPf_STACKED) {
6523 kid = cUNOPo->op_first->op_sibling;
6524 if (kid->op_type == OP_RV2GV)
6533 Perl_ck_exists(pTHX_ OP *o)
6537 PERL_ARGS_ASSERT_CK_EXISTS;
6540 if (o->op_flags & OPf_KIDS) {
6541 OP * const kid = cUNOPo->op_first;
6542 if (kid->op_type == OP_ENTERSUB) {
6543 (void) ref(kid, o->op_type);
6544 if (kid->op_type != OP_RV2CV
6545 && !(PL_parser && PL_parser->error_count))
6546 Perl_croak(aTHX_ "%s argument is not a subroutine name",
6548 o->op_private |= OPpEXISTS_SUB;
6550 else if (kid->op_type == OP_AELEM)
6551 o->op_flags |= OPf_SPECIAL;
6552 else if (kid->op_type != OP_HELEM)
6553 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
6561 Perl_ck_rvconst(pTHX_ register OP *o)
6564 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6566 PERL_ARGS_ASSERT_CK_RVCONST;
6568 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6569 if (o->op_type == OP_RV2CV)
6570 o->op_private &= ~1;
6572 if (kid->op_type == OP_CONST) {
6575 SV * const kidsv = kid->op_sv;
6577 /* Is it a constant from cv_const_sv()? */
6578 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
6579 SV * const rsv = SvRV(kidsv);
6580 const svtype type = SvTYPE(rsv);
6581 const char *badtype = NULL;
6583 switch (o->op_type) {
6585 if (type > SVt_PVMG)
6586 badtype = "a SCALAR";
6589 if (type != SVt_PVAV)
6590 badtype = "an ARRAY";
6593 if (type != SVt_PVHV)
6597 if (type != SVt_PVCV)
6602 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
6605 else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
6606 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
6607 /* If this is an access to a stash, disable "strict refs", because
6608 * stashes aren't auto-vivified at compile-time (unless we store
6609 * symbols in them), and we don't want to produce a run-time
6610 * stricture error when auto-vivifying the stash. */
6611 const char *s = SvPV_nolen(kidsv);
6612 const STRLEN l = SvCUR(kidsv);
6613 if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
6614 o->op_private &= ~HINT_STRICT_REFS;
6616 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
6617 const char *badthing;
6618 switch (o->op_type) {
6620 badthing = "a SCALAR";
6623 badthing = "an ARRAY";
6626 badthing = "a HASH";
6634 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
6635 SVfARG(kidsv), badthing);
6638 * This is a little tricky. We only want to add the symbol if we
6639 * didn't add it in the lexer. Otherwise we get duplicate strict
6640 * warnings. But if we didn't add it in the lexer, we must at
6641 * least pretend like we wanted to add it even if it existed before,
6642 * or we get possible typo warnings. OPpCONST_ENTERED says
6643 * whether the lexer already added THIS instance of this symbol.
6645 iscv = (o->op_type == OP_RV2CV) * 2;
6647 gv = gv_fetchsv(kidsv,
6648 iscv | !(kid->op_private & OPpCONST_ENTERED),
6651 : o->op_type == OP_RV2SV
6653 : o->op_type == OP_RV2AV
6655 : o->op_type == OP_RV2HV
6658 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
6660 kid->op_type = OP_GV;
6661 SvREFCNT_dec(kid->op_sv);
6663 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
6664 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
6665 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
6667 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc_simple_NN(gv));
6669 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
6671 kid->op_private = 0;
6672 kid->op_ppaddr = PL_ppaddr[OP_GV];
6679 Perl_ck_ftst(pTHX_ OP *o)
6682 const I32 type = o->op_type;
6684 PERL_ARGS_ASSERT_CK_FTST;
6686 if (o->op_flags & OPf_REF) {
6689 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
6690 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6691 const OPCODE kidtype = kid->op_type;
6693 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6694 OP * const newop = newGVOP(type, OPf_REF,
6695 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
6697 op_getmad(o,newop,'O');
6703 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
6704 o->op_private |= OPpFT_ACCESS;
6705 if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst)
6706 && kidtype != OP_STAT && kidtype != OP_LSTAT)
6707 o->op_private |= OPpFT_STACKED;
6715 if (type == OP_FTTTY)
6716 o = newGVOP(type, OPf_REF, PL_stdingv);
6718 o = newUNOP(type, 0, newDEFSVOP());
6719 op_getmad(oldo,o,'O');
6725 Perl_ck_fun(pTHX_ OP *o)
6728 const int type = o->op_type;
6729 register I32 oa = PL_opargs[type] >> OASHIFT;
6731 PERL_ARGS_ASSERT_CK_FUN;
6733 if (o->op_flags & OPf_STACKED) {
6734 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
6737 return no_fh_allowed(o);
6740 if (o->op_flags & OPf_KIDS) {
6741 OP **tokid = &cLISTOPo->op_first;
6742 register OP *kid = cLISTOPo->op_first;
6746 if (kid->op_type == OP_PUSHMARK ||
6747 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
6749 tokid = &kid->op_sibling;
6750 kid = kid->op_sibling;
6752 if (!kid && PL_opargs[type] & OA_DEFGV)
6753 *tokid = kid = newDEFSVOP();
6757 sibl = kid->op_sibling;
6759 if (!sibl && kid->op_type == OP_STUB) {
6766 /* list seen where single (scalar) arg expected? */
6767 if (numargs == 1 && !(oa >> 4)
6768 && kid->op_type == OP_LIST && type != OP_SCALAR)
6770 return too_many_arguments(o,PL_op_desc[type]);
6783 if ((type == OP_PUSH || type == OP_UNSHIFT)
6784 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
6785 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6786 "Useless use of %s with no values",
6789 if (kid->op_type == OP_CONST &&
6790 (kid->op_private & OPpCONST_BARE))
6792 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
6793 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
6794 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6795 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6796 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
6797 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6799 op_getmad(kid,newop,'K');
6804 kid->op_sibling = sibl;
6807 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
6808 bad_type(numargs, "array", PL_op_desc[type], kid);
6812 if (kid->op_type == OP_CONST &&
6813 (kid->op_private & OPpCONST_BARE))
6815 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
6816 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
6817 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6818 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6819 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
6820 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6822 op_getmad(kid,newop,'K');
6827 kid->op_sibling = sibl;
6830 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
6831 bad_type(numargs, "hash", PL_op_desc[type], kid);
6836 OP * const newop = newUNOP(OP_NULL, 0, kid);
6837 kid->op_sibling = 0;
6839 newop->op_next = newop;
6841 kid->op_sibling = sibl;
6846 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
6847 if (kid->op_type == OP_CONST &&
6848 (kid->op_private & OPpCONST_BARE))
6850 OP * const newop = newGVOP(OP_GV, 0,
6851 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
6852 if (!(o->op_private & 1) && /* if not unop */
6853 kid == cLISTOPo->op_last)
6854 cLISTOPo->op_last = newop;
6856 op_getmad(kid,newop,'K');
6862 else if (kid->op_type == OP_READLINE) {
6863 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
6864 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
6867 I32 flags = OPf_SPECIAL;
6871 /* is this op a FH constructor? */
6872 if (is_handle_constructor(o,numargs)) {
6873 const char *name = NULL;
6877 /* Set a flag to tell rv2gv to vivify
6878 * need to "prove" flag does not mean something
6879 * else already - NI-S 1999/05/07
6882 if (kid->op_type == OP_PADSV) {
6884 = PAD_COMPNAME_SV(kid->op_targ);
6885 name = SvPV_const(namesv, len);
6887 else if (kid->op_type == OP_RV2SV
6888 && kUNOP->op_first->op_type == OP_GV)
6890 GV * const gv = cGVOPx_gv(kUNOP->op_first);
6892 len = GvNAMELEN(gv);
6894 else if (kid->op_type == OP_AELEM
6895 || kid->op_type == OP_HELEM)
6898 OP *op = ((BINOP*)kid)->op_first;
6902 const char * const a =
6903 kid->op_type == OP_AELEM ?
6905 if (((op->op_type == OP_RV2AV) ||
6906 (op->op_type == OP_RV2HV)) &&
6907 (firstop = ((UNOP*)op)->op_first) &&
6908 (firstop->op_type == OP_GV)) {
6909 /* packagevar $a[] or $h{} */
6910 GV * const gv = cGVOPx_gv(firstop);
6918 else if (op->op_type == OP_PADAV
6919 || op->op_type == OP_PADHV) {
6920 /* lexicalvar $a[] or $h{} */
6921 const char * const padname =
6922 PAD_COMPNAME_PV(op->op_targ);
6931 name = SvPV_const(tmpstr, len);
6936 name = "__ANONIO__";
6943 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
6944 namesv = PAD_SVl(targ);
6945 SvUPGRADE(namesv, SVt_PV);
6947 sv_setpvn(namesv, "$", 1);
6948 sv_catpvn(namesv, name, len);
6951 kid->op_sibling = 0;
6952 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
6953 kid->op_targ = targ;
6954 kid->op_private |= priv;
6956 kid->op_sibling = sibl;
6962 mod(scalar(kid), type);
6966 tokid = &kid->op_sibling;
6967 kid = kid->op_sibling;
6970 if (kid && kid->op_type != OP_STUB)
6971 return too_many_arguments(o,OP_DESC(o));
6972 o->op_private |= numargs;
6974 /* FIXME - should the numargs move as for the PERL_MAD case? */
6975 o->op_private |= numargs;
6977 return too_many_arguments(o,OP_DESC(o));
6981 else if (PL_opargs[type] & OA_DEFGV) {
6983 OP *newop = newUNOP(type, 0, newDEFSVOP());
6984 op_getmad(o,newop,'O');
6987 /* Ordering of these two is important to keep f_map.t passing. */
6989 return newUNOP(type, 0, newDEFSVOP());
6994 while (oa & OA_OPTIONAL)
6996 if (oa && oa != OA_LIST)
6997 return too_few_arguments(o,OP_DESC(o));
7003 Perl_ck_glob(pTHX_ OP *o)
7008 PERL_ARGS_ASSERT_CK_GLOB;
7011 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
7012 append_elem(OP_GLOB, o, newDEFSVOP());
7014 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
7015 && GvCVu(gv) && GvIMPORTED_CV(gv)))
7017 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7020 #if !defined(PERL_EXTERNAL_GLOB)
7021 /* XXX this can be tightened up and made more failsafe. */
7022 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7025 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
7026 newSVpvs("File::Glob"), NULL, NULL, NULL);
7027 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7028 glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
7029 GvCV(gv) = GvCV(glob_gv);
7030 SvREFCNT_inc_void((SV*)GvCV(gv));
7031 GvIMPORTED_CV_on(gv);
7034 #endif /* PERL_EXTERNAL_GLOB */
7036 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7037 append_elem(OP_GLOB, o,
7038 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
7039 o->op_type = OP_LIST;
7040 o->op_ppaddr = PL_ppaddr[OP_LIST];
7041 cLISTOPo->op_first->op_type = OP_PUSHMARK;
7042 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
7043 cLISTOPo->op_first->op_targ = 0;
7044 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
7045 append_elem(OP_LIST, o,
7046 scalar(newUNOP(OP_RV2CV, 0,
7047 newGVOP(OP_GV, 0, gv)))));
7048 o = newUNOP(OP_NULL, 0, ck_subr(o));
7049 o->op_targ = OP_GLOB; /* hint at what it used to be */
7052 gv = newGVgen("main");
7054 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
7060 Perl_ck_grep(pTHX_ OP *o)
7065 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
7068 PERL_ARGS_ASSERT_CK_GREP;
7070 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
7071 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
7073 if (o->op_flags & OPf_STACKED) {
7076 kid = cLISTOPo->op_first->op_sibling;
7077 if (!cUNOPx(kid)->op_next)
7078 Perl_croak(aTHX_ "panic: ck_grep");
7079 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
7082 NewOp(1101, gwop, 1, LOGOP);
7083 kid->op_next = (OP*)gwop;
7084 o->op_flags &= ~OPf_STACKED;
7086 kid = cLISTOPo->op_first->op_sibling;
7087 if (type == OP_MAPWHILE)
7092 if (PL_parser && PL_parser->error_count)
7094 kid = cLISTOPo->op_first->op_sibling;
7095 if (kid->op_type != OP_NULL)
7096 Perl_croak(aTHX_ "panic: ck_grep");
7097 kid = kUNOP->op_first;
7100 NewOp(1101, gwop, 1, LOGOP);
7101 gwop->op_type = type;
7102 gwop->op_ppaddr = PL_ppaddr[type];
7103 gwop->op_first = listkids(o);
7104 gwop->op_flags |= OPf_KIDS;
7105 gwop->op_other = LINKLIST(kid);
7106 kid->op_next = (OP*)gwop;
7107 offset = pad_findmy("$_");
7108 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
7109 o->op_private = gwop->op_private = 0;
7110 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
7113 o->op_private = gwop->op_private = OPpGREP_LEX;
7114 gwop->op_targ = o->op_targ = offset;
7117 kid = cLISTOPo->op_first->op_sibling;
7118 if (!kid || !kid->op_sibling)
7119 return too_few_arguments(o,OP_DESC(o));
7120 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
7121 mod(kid, OP_GREPSTART);
7127 Perl_ck_index(pTHX_ OP *o)
7129 PERL_ARGS_ASSERT_CK_INDEX;
7131 if (o->op_flags & OPf_KIDS) {
7132 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7134 kid = kid->op_sibling; /* get past "big" */
7135 if (kid && kid->op_type == OP_CONST)
7136 fbm_compile(((SVOP*)kid)->op_sv, 0);
7142 Perl_ck_lfun(pTHX_ OP *o)
7144 const OPCODE type = o->op_type;
7146 PERL_ARGS_ASSERT_CK_LFUN;
7148 return modkids(ck_fun(o), type);
7152 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
7154 PERL_ARGS_ASSERT_CK_DEFINED;
7156 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
7157 switch (cUNOPo->op_first->op_type) {
7159 /* This is needed for
7160 if (defined %stash::)
7161 to work. Do not break Tk.
7163 break; /* Globals via GV can be undef */
7165 case OP_AASSIGN: /* Is this a good idea? */
7166 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
7167 "defined(@array) is deprecated");
7168 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
7169 "\t(Maybe you should just omit the defined()?)\n");
7172 /* This is needed for
7173 if (defined %stash::)
7174 to work. Do not break Tk.
7176 break; /* Globals via GV can be undef */
7178 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
7179 "defined(%%hash) is deprecated");
7180 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
7181 "\t(Maybe you should just omit the defined()?)\n");
7192 Perl_ck_readline(pTHX_ OP *o)
7194 PERL_ARGS_ASSERT_CK_READLINE;
7196 if (!(o->op_flags & OPf_KIDS)) {
7198 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
7200 op_getmad(o,newop,'O');
7210 Perl_ck_rfun(pTHX_ OP *o)
7212 const OPCODE type = o->op_type;
7214 PERL_ARGS_ASSERT_CK_RFUN;
7216 return refkids(ck_fun(o), type);
7220 Perl_ck_listiob(pTHX_ OP *o)
7224 PERL_ARGS_ASSERT_CK_LISTIOB;
7226 kid = cLISTOPo->op_first;
7229 kid = cLISTOPo->op_first;
7231 if (kid->op_type == OP_PUSHMARK)
7232 kid = kid->op_sibling;
7233 if (kid && o->op_flags & OPf_STACKED)
7234 kid = kid->op_sibling;
7235 else if (kid && !kid->op_sibling) { /* print HANDLE; */
7236 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
7237 o->op_flags |= OPf_STACKED; /* make it a filehandle */
7238 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
7239 cLISTOPo->op_first->op_sibling = kid;
7240 cLISTOPo->op_last = kid;
7241 kid = kid->op_sibling;
7246 append_elem(o->op_type, o, newDEFSVOP());
7252 Perl_ck_smartmatch(pTHX_ OP *o)
7255 if (0 == (o->op_flags & OPf_SPECIAL)) {
7256 OP *first = cBINOPo->op_first;
7257 OP *second = first->op_sibling;
7259 /* Implicitly take a reference to an array or hash */
7260 first->op_sibling = NULL;
7261 first = cBINOPo->op_first = ref_array_or_hash(first);
7262 second = first->op_sibling = ref_array_or_hash(second);
7264 /* Implicitly take a reference to a regular expression */
7265 if (first->op_type == OP_MATCH) {
7266 first->op_type = OP_QR;
7267 first->op_ppaddr = PL_ppaddr[OP_QR];
7269 if (second->op_type == OP_MATCH) {
7270 second->op_type = OP_QR;
7271 second->op_ppaddr = PL_ppaddr[OP_QR];
7280 Perl_ck_sassign(pTHX_ OP *o)
7283 OP * const kid = cLISTOPo->op_first;
7285 PERL_ARGS_ASSERT_CK_SASSIGN;
7287 /* has a disposable target? */
7288 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
7289 && !(kid->op_flags & OPf_STACKED)
7290 /* Cannot steal the second time! */
7291 && !(kid->op_private & OPpTARGET_MY)
7292 /* Keep the full thing for madskills */
7296 OP * const kkid = kid->op_sibling;
7298 /* Can just relocate the target. */
7299 if (kkid && kkid->op_type == OP_PADSV
7300 && !(kkid->op_private & OPpLVAL_INTRO))
7302 kid->op_targ = kkid->op_targ;
7304 /* Now we do not need PADSV and SASSIGN. */
7305 kid->op_sibling = o->op_sibling; /* NULL */
7306 cLISTOPo->op_first = NULL;
7309 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
7313 if (kid->op_sibling) {
7314 OP *kkid = kid->op_sibling;
7315 if (kkid->op_type == OP_PADSV
7316 && (kkid->op_private & OPpLVAL_INTRO)
7317 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
7318 const PADOFFSET target = kkid->op_targ;
7319 OP *const other = newOP(OP_PADSV,
7321 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
7322 OP *const first = newOP(OP_NULL, 0);
7323 OP *const nullop = newCONDOP(0, first, o, other);
7324 OP *const condop = first->op_next;
7325 /* hijacking PADSTALE for uninitialized state variables */
7326 SvPADSTALE_on(PAD_SVl(target));
7328 condop->op_type = OP_ONCE;
7329 condop->op_ppaddr = PL_ppaddr[OP_ONCE];
7330 condop->op_targ = target;
7331 other->op_targ = target;
7333 /* Because we change the type of the op here, we will skip the
7334 assinment binop->op_last = binop->op_first->op_sibling; at the
7335 end of Perl_newBINOP(). So need to do it here. */
7336 cBINOPo->op_last = cBINOPo->op_first->op_sibling;
7345 Perl_ck_match(pTHX_ OP *o)
7349 PERL_ARGS_ASSERT_CK_MATCH;
7351 if (o->op_type != OP_QR && PL_compcv) {
7352 const PADOFFSET offset = pad_findmy("$_");
7353 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
7354 o->op_targ = offset;
7355 o->op_private |= OPpTARGET_MY;
7358 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
7359 o->op_private |= OPpRUNTIME;
7364 Perl_ck_method(pTHX_ OP *o)
7366 OP * const kid = cUNOPo->op_first;
7368 PERL_ARGS_ASSERT_CK_METHOD;
7370 if (kid->op_type == OP_CONST) {
7371 SV* sv = kSVOP->op_sv;
7372 const char * const method = SvPVX_const(sv);
7373 if (!(strchr(method, ':') || strchr(method, '\''))) {
7375 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
7376 sv = newSVpvn_share(method, SvCUR(sv), 0);
7379 kSVOP->op_sv = NULL;
7381 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
7383 op_getmad(o,cmop,'O');
7394 Perl_ck_null(pTHX_ OP *o)
7396 PERL_ARGS_ASSERT_CK_NULL;
7397 PERL_UNUSED_CONTEXT;
7402 Perl_ck_open(pTHX_ OP *o)
7405 HV * const table = GvHV(PL_hintgv);
7407 PERL_ARGS_ASSERT_CK_OPEN;
7410 SV **svp = hv_fetchs(table, "open_IN", FALSE);
7412 const I32 mode = mode_from_discipline(*svp);
7413 if (mode & O_BINARY)
7414 o->op_private |= OPpOPEN_IN_RAW;
7415 else if (mode & O_TEXT)
7416 o->op_private |= OPpOPEN_IN_CRLF;
7419 svp = hv_fetchs(table, "open_OUT", FALSE);
7421 const I32 mode = mode_from_discipline(*svp);
7422 if (mode & O_BINARY)
7423 o->op_private |= OPpOPEN_OUT_RAW;
7424 else if (mode & O_TEXT)
7425 o->op_private |= OPpOPEN_OUT_CRLF;
7428 if (o->op_type == OP_BACKTICK) {
7429 if (!(o->op_flags & OPf_KIDS)) {
7430 OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
7432 op_getmad(o,newop,'O');
7441 /* In case of three-arg dup open remove strictness
7442 * from the last arg if it is a bareword. */
7443 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
7444 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
7448 if ((last->op_type == OP_CONST) && /* The bareword. */
7449 (last->op_private & OPpCONST_BARE) &&
7450 (last->op_private & OPpCONST_STRICT) &&
7451 (oa = first->op_sibling) && /* The fh. */
7452 (oa = oa->op_sibling) && /* The mode. */
7453 (oa->op_type == OP_CONST) &&
7454 SvPOK(((SVOP*)oa)->op_sv) &&
7455 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
7456 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
7457 (last == oa->op_sibling)) /* The bareword. */
7458 last->op_private &= ~OPpCONST_STRICT;
7464 Perl_ck_repeat(pTHX_ OP *o)
7466 PERL_ARGS_ASSERT_CK_REPEAT;
7468 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
7469 o->op_private |= OPpREPEAT_DOLIST;
7470 cBINOPo->op_first = force_list(cBINOPo->op_first);
7478 Perl_ck_require(pTHX_ OP *o)
7483 PERL_ARGS_ASSERT_CK_REQUIRE;
7485 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
7486 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7488 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
7489 SV * const sv = kid->op_sv;
7490 U32 was_readonly = SvREADONLY(sv);
7497 sv_force_normal_flags(sv, 0);
7498 assert(!SvREADONLY(sv));
7508 for (; s < end; s++) {
7509 if (*s == ':' && s[1] == ':') {
7511 Move(s+2, s+1, end - s - 1, char);
7516 sv_catpvs(sv, ".pm");
7517 SvFLAGS(sv) |= was_readonly;
7521 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
7522 /* handle override, if any */
7523 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
7524 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7525 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
7526 gv = gvp ? *gvp : NULL;
7530 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7531 OP * const kid = cUNOPo->op_first;
7534 cUNOPo->op_first = 0;
7538 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
7539 append_elem(OP_LIST, kid,
7540 scalar(newUNOP(OP_RV2CV, 0,
7543 op_getmad(o,newop,'O');
7551 Perl_ck_return(pTHX_ OP *o)
7555 PERL_ARGS_ASSERT_CK_RETURN;
7557 if (CvLVALUE(PL_compcv)) {
7559 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
7560 mod(kid, OP_LEAVESUBLV);
7566 Perl_ck_select(pTHX_ OP *o)
7571 PERL_ARGS_ASSERT_CK_SELECT;
7573 if (o->op_flags & OPf_KIDS) {
7574 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7575 if (kid && kid->op_sibling) {
7576 o->op_type = OP_SSELECT;
7577 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
7579 return fold_constants(o);
7583 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7584 if (kid && kid->op_type == OP_RV2GV)
7585 kid->op_private &= ~HINT_STRICT_REFS;
7590 Perl_ck_shift(pTHX_ OP *o)
7593 const I32 type = o->op_type;
7595 PERL_ARGS_ASSERT_CK_SHIFT;
7597 if (!(o->op_flags & OPf_KIDS)) {
7599 /* FIXME - this can be refactored to reduce code in #ifdefs */
7601 OP * const oldo = o;
7605 argop = newUNOP(OP_RV2AV, 0,
7606 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
7608 o = newUNOP(type, 0, scalar(argop));
7609 op_getmad(oldo,o,'O');
7612 return newUNOP(type, 0, scalar(argop));
7615 return scalar(modkids(ck_fun(o), type));
7619 Perl_ck_sort(pTHX_ OP *o)
7624 PERL_ARGS_ASSERT_CK_SORT;
7626 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
7627 HV * const hinthv = GvHV(PL_hintgv);
7629 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
7631 const I32 sorthints = (I32)SvIV(*svp);
7632 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
7633 o->op_private |= OPpSORT_QSORT;
7634 if ((sorthints & HINT_SORT_STABLE) != 0)
7635 o->op_private |= OPpSORT_STABLE;
7640 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
7642 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7643 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
7645 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
7647 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
7649 if (kid->op_type == OP_SCOPE) {
7653 else if (kid->op_type == OP_LEAVE) {
7654 if (o->op_type == OP_SORT) {
7655 op_null(kid); /* wipe out leave */
7658 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
7659 if (k->op_next == kid)
7661 /* don't descend into loops */
7662 else if (k->op_type == OP_ENTERLOOP
7663 || k->op_type == OP_ENTERITER)
7665 k = cLOOPx(k)->op_lastop;
7670 kid->op_next = 0; /* just disconnect the leave */
7671 k = kLISTOP->op_first;
7676 if (o->op_type == OP_SORT) {
7677 /* provide scalar context for comparison function/block */
7683 o->op_flags |= OPf_SPECIAL;
7685 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
7688 firstkid = firstkid->op_sibling;
7691 /* provide list context for arguments */
7692 if (o->op_type == OP_SORT)
7699 S_simplify_sort(pTHX_ OP *o)
7702 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7708 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
7710 if (!(o->op_flags & OPf_STACKED))
7712 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7713 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
7714 kid = kUNOP->op_first; /* get past null */
7715 if (kid->op_type != OP_SCOPE)
7717 kid = kLISTOP->op_last; /* get past scope */
7718 switch(kid->op_type) {
7726 k = kid; /* remember this node*/
7727 if (kBINOP->op_first->op_type != OP_RV2SV)
7729 kid = kBINOP->op_first; /* get past cmp */
7730 if (kUNOP->op_first->op_type != OP_GV)
7732 kid = kUNOP->op_first; /* get past rv2sv */
7734 if (GvSTASH(gv) != PL_curstash)
7736 gvname = GvNAME(gv);
7737 if (*gvname == 'a' && gvname[1] == '\0')
7739 else if (*gvname == 'b' && gvname[1] == '\0')
7744 kid = k; /* back to cmp */
7745 if (kBINOP->op_last->op_type != OP_RV2SV)
7747 kid = kBINOP->op_last; /* down to 2nd arg */
7748 if (kUNOP->op_first->op_type != OP_GV)
7750 kid = kUNOP->op_first; /* get past rv2sv */
7752 if (GvSTASH(gv) != PL_curstash)
7754 gvname = GvNAME(gv);
7756 ? !(*gvname == 'a' && gvname[1] == '\0')
7757 : !(*gvname == 'b' && gvname[1] == '\0'))
7759 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
7761 o->op_private |= OPpSORT_DESCEND;
7762 if (k->op_type == OP_NCMP)
7763 o->op_private |= OPpSORT_NUMERIC;
7764 if (k->op_type == OP_I_NCMP)
7765 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
7766 kid = cLISTOPo->op_first->op_sibling;
7767 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
7769 op_getmad(kid,o,'S'); /* then delete it */
7771 op_free(kid); /* then delete it */
7776 Perl_ck_split(pTHX_ OP *o)
7781 PERL_ARGS_ASSERT_CK_SPLIT;
7783 if (o->op_flags & OPf_STACKED)
7784 return no_fh_allowed(o);
7786 kid = cLISTOPo->op_first;
7787 if (kid->op_type != OP_NULL)
7788 Perl_croak(aTHX_ "panic: ck_split");
7789 kid = kid->op_sibling;
7790 op_free(cLISTOPo->op_first);
7791 cLISTOPo->op_first = kid;
7793 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
7794 cLISTOPo->op_last = kid; /* There was only one element previously */
7797 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
7798 OP * const sibl = kid->op_sibling;
7799 kid->op_sibling = 0;
7800 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
7801 if (cLISTOPo->op_first == cLISTOPo->op_last)
7802 cLISTOPo->op_last = kid;
7803 cLISTOPo->op_first = kid;
7804 kid->op_sibling = sibl;
7807 kid->op_type = OP_PUSHRE;
7808 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
7810 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
7811 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
7812 "Use of /g modifier is meaningless in split");
7815 if (!kid->op_sibling)
7816 append_elem(OP_SPLIT, o, newDEFSVOP());
7818 kid = kid->op_sibling;
7821 if (!kid->op_sibling)
7822 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
7823 assert(kid->op_sibling);
7825 kid = kid->op_sibling;
7828 if (kid->op_sibling)
7829 return too_many_arguments(o,OP_DESC(o));
7835 Perl_ck_join(pTHX_ OP *o)
7837 const OP * const kid = cLISTOPo->op_first->op_sibling;
7839 PERL_ARGS_ASSERT_CK_JOIN;
7841 if (kid && kid->op_type == OP_MATCH) {
7842 if (ckWARN(WARN_SYNTAX)) {
7843 const REGEXP *re = PM_GETRE(kPMOP);
7844 const char *pmstr = re ? RX_PRECOMP(re) : "STRING";
7845 const STRLEN len = re ? RX_PRELEN(re) : 6;
7846 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7847 "/%.*s/ should probably be written as \"%.*s\"",
7848 (int)len, pmstr, (int)len, pmstr);
7855 Perl_ck_subr(pTHX_ OP *o)
7858 OP *prev = ((cUNOPo->op_first->op_sibling)
7859 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
7860 OP *o2 = prev->op_sibling;
7862 const char *proto = NULL;
7863 const char *proto_end = NULL;
7868 I32 contextclass = 0;
7869 const char *e = NULL;
7872 PERL_ARGS_ASSERT_CK_SUBR;
7874 o->op_private |= OPpENTERSUB_HASTARG;
7875 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
7876 if (cvop->op_type == OP_RV2CV) {
7878 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
7879 op_null(cvop); /* disable rv2cv */
7880 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
7881 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
7882 GV *gv = cGVOPx_gv(tmpop);
7885 tmpop->op_private |= OPpEARLY_CV;
7889 namegv = CvANON(cv) ? gv : CvGV(cv);
7890 proto = SvPV((SV*)cv, len);
7891 proto_end = proto + len;
7896 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7897 if (o2->op_type == OP_CONST)
7898 o2->op_private &= ~OPpCONST_STRICT;
7899 else if (o2->op_type == OP_LIST) {
7900 OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
7901 if (sib && sib->op_type == OP_CONST)
7902 sib->op_private &= ~OPpCONST_STRICT;
7905 o->op_private |= (PL_hints & HINT_STRICT_REFS);
7906 if (PERLDB_SUB && PL_curstash != PL_debstash)
7907 o->op_private |= OPpENTERSUB_DB;
7908 while (o2 != cvop) {
7910 if (PL_madskills && o2->op_type == OP_STUB) {
7911 o2 = o2->op_sibling;
7914 if (PL_madskills && o2->op_type == OP_NULL)
7915 o3 = ((UNOP*)o2)->op_first;
7919 if (proto >= proto_end)
7920 return too_many_arguments(o, gv_ename(namegv));
7928 /* _ must be at the end */
7929 if (proto[1] && proto[1] != ';')
7944 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
7946 arg == 1 ? "block or sub {}" : "sub {}",
7947 gv_ename(namegv), o3);
7950 /* '*' allows any scalar type, including bareword */
7953 if (o3->op_type == OP_RV2GV)
7954 goto wrapref; /* autoconvert GLOB -> GLOBref */
7955 else if (o3->op_type == OP_CONST)
7956 o3->op_private &= ~OPpCONST_STRICT;
7957 else if (o3->op_type == OP_ENTERSUB) {
7958 /* accidental subroutine, revert to bareword */
7959 OP *gvop = ((UNOP*)o3)->op_first;
7960 if (gvop && gvop->op_type == OP_NULL) {
7961 gvop = ((UNOP*)gvop)->op_first;
7963 for (; gvop->op_sibling; gvop = gvop->op_sibling)
7966 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
7967 (gvop = ((UNOP*)gvop)->op_first) &&
7968 gvop->op_type == OP_GV)
7970 GV * const gv = cGVOPx_gv(gvop);
7971 OP * const sibling = o2->op_sibling;
7972 SV * const n = newSVpvs("");
7974 OP * const oldo2 = o2;
7978 gv_fullname4(n, gv, "", FALSE);
7979 o2 = newSVOP(OP_CONST, 0, n);
7980 op_getmad(oldo2,o2,'O');
7981 prev->op_sibling = o2;
7982 o2->op_sibling = sibling;
7998 if (contextclass++ == 0) {
7999 e = strchr(proto, ']');
8000 if (!e || e == proto)
8009 const char *p = proto;
8010 const char *const end = proto;
8012 while (*--p != '[');
8013 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
8015 gv_ename(namegv), o3);
8020 if (o3->op_type == OP_RV2GV)
8023 bad_type(arg, "symbol", gv_ename(namegv), o3);
8026 if (o3->op_type == OP_ENTERSUB)
8029 bad_type(arg, "subroutine entry", gv_ename(namegv),
8033 if (o3->op_type == OP_RV2SV ||
8034 o3->op_type == OP_PADSV ||
8035 o3->op_type == OP_HELEM ||
8036 o3->op_type == OP_AELEM)
8039 bad_type(arg, "scalar", gv_ename(namegv), o3);
8042 if (o3->op_type == OP_RV2AV ||
8043 o3->op_type == OP_PADAV)
8046 bad_type(arg, "array", gv_ename(namegv), o3);
8049 if (o3->op_type == OP_RV2HV ||
8050 o3->op_type == OP_PADHV)
8053 bad_type(arg, "hash", gv_ename(namegv), o3);
8058 OP* const sib = kid->op_sibling;
8059 kid->op_sibling = 0;
8060 o2 = newUNOP(OP_REFGEN, 0, kid);
8061 o2->op_sibling = sib;
8062 prev->op_sibling = o2;
8064 if (contextclass && e) {
8079 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
8080 gv_ename(namegv), SVfARG(cv));
8085 mod(o2, OP_ENTERSUB);
8087 o2 = o2->op_sibling;
8089 if (o2 == cvop && proto && *proto == '_') {
8090 /* generate an access to $_ */
8092 o2->op_sibling = prev->op_sibling;
8093 prev->op_sibling = o2; /* instead of cvop */
8095 if (proto && !optional && proto_end > proto &&
8096 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
8097 return too_few_arguments(o, gv_ename(namegv));
8100 OP * const oldo = o;
8104 o=newSVOP(OP_CONST, 0, newSViv(0));
8105 op_getmad(oldo,o,'O');
8111 Perl_ck_svconst(pTHX_ OP *o)
8113 PERL_ARGS_ASSERT_CK_SVCONST;
8114 PERL_UNUSED_CONTEXT;
8115 SvREADONLY_on(cSVOPo->op_sv);
8120 Perl_ck_chdir(pTHX_ OP *o)
8122 if (o->op_flags & OPf_KIDS) {
8123 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8125 if (kid && kid->op_type == OP_CONST &&
8126 (kid->op_private & OPpCONST_BARE))
8128 o->op_flags |= OPf_SPECIAL;
8129 kid->op_private &= ~OPpCONST_STRICT;
8136 Perl_ck_trunc(pTHX_ OP *o)
8138 PERL_ARGS_ASSERT_CK_TRUNC;
8140 if (o->op_flags & OPf_KIDS) {
8141 SVOP *kid = (SVOP*)cUNOPo->op_first;
8143 if (kid->op_type == OP_NULL)
8144 kid = (SVOP*)kid->op_sibling;
8145 if (kid && kid->op_type == OP_CONST &&
8146 (kid->op_private & OPpCONST_BARE))
8148 o->op_flags |= OPf_SPECIAL;
8149 kid->op_private &= ~OPpCONST_STRICT;
8156 Perl_ck_unpack(pTHX_ OP *o)
8158 OP *kid = cLISTOPo->op_first;
8160 PERL_ARGS_ASSERT_CK_UNPACK;
8162 if (kid->op_sibling) {
8163 kid = kid->op_sibling;
8164 if (!kid->op_sibling)
8165 kid->op_sibling = newDEFSVOP();
8171 Perl_ck_substr(pTHX_ OP *o)
8173 PERL_ARGS_ASSERT_CK_SUBSTR;
8176 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
8177 OP *kid = cLISTOPo->op_first;
8179 if (kid->op_type == OP_NULL)
8180 kid = kid->op_sibling;
8182 kid->op_flags |= OPf_MOD;
8189 Perl_ck_each(pTHX_ OP *o)
8192 OP *kid = cLISTOPo->op_first;
8194 PERL_ARGS_ASSERT_CK_EACH;
8196 if (kid->op_type == OP_PADAV || kid->op_type == OP_RV2AV) {
8197 const unsigned new_type = o->op_type == OP_EACH ? OP_AEACH
8198 : o->op_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
8199 o->op_type = new_type;
8200 o->op_ppaddr = PL_ppaddr[new_type];
8202 else if (!(kid->op_type == OP_PADHV || kid->op_type == OP_RV2HV
8203 || (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE)
8205 bad_type(1, "hash or array", PL_op_desc[o->op_type], kid);
8211 /* A peephole optimizer. We visit the ops in the order they're to execute.
8212 * See the comments at the top of this file for more details about when
8213 * peep() is called */
8216 Perl_peep(pTHX_ register OP *o)
8219 register OP* oldop = NULL;
8221 if (!o || o->op_opt)
8225 SAVEVPTR(PL_curcop);
8226 for (; o; o = o->op_next) {
8229 /* By default, this op has now been optimised. A couple of cases below
8230 clear this again. */
8233 switch (o->op_type) {
8236 PL_curcop = ((COP*)o); /* for warnings */
8240 if (cSVOPo->op_private & OPpCONST_STRICT)
8241 no_bareword_allowed(o);
8244 case OP_METHOD_NAMED:
8245 /* Relocate sv to the pad for thread safety.
8246 * Despite being a "constant", the SV is written to,
8247 * for reference counts, sv_upgrade() etc. */
8249 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
8250 if (o->op_type != OP_METHOD_NAMED && SvPADTMP(cSVOPo->op_sv)) {
8251 /* If op_sv is already a PADTMP then it is being used by
8252 * some pad, so make a copy. */
8253 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
8254 SvREADONLY_on(PAD_SVl(ix));
8255 SvREFCNT_dec(cSVOPo->op_sv);
8257 else if (o->op_type != OP_METHOD_NAMED
8258 && cSVOPo->op_sv == &PL_sv_undef) {
8259 /* PL_sv_undef is hack - it's unsafe to store it in the
8260 AV that is the pad, because av_fetch treats values of
8261 PL_sv_undef as a "free" AV entry and will merrily
8262 replace them with a new SV, causing pad_alloc to think
8263 that this pad slot is free. (When, clearly, it is not)
8265 SvOK_off(PAD_SVl(ix));
8266 SvPADTMP_on(PAD_SVl(ix));
8267 SvREADONLY_on(PAD_SVl(ix));
8270 SvREFCNT_dec(PAD_SVl(ix));
8271 SvPADTMP_on(cSVOPo->op_sv);
8272 PAD_SETSV(ix, cSVOPo->op_sv);
8273 /* XXX I don't know how this isn't readonly already. */
8274 SvREADONLY_on(PAD_SVl(ix));
8276 cSVOPo->op_sv = NULL;
8283 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
8284 if (o->op_next->op_private & OPpTARGET_MY) {
8285 if (o->op_flags & OPf_STACKED) /* chained concats */
8286 break; /* ignore_optimization */
8288 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
8289 o->op_targ = o->op_next->op_targ;
8290 o->op_next->op_targ = 0;
8291 o->op_private |= OPpTARGET_MY;
8294 op_null(o->op_next);
8298 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
8299 break; /* Scalar stub must produce undef. List stub is noop */
8303 if (o->op_targ == OP_NEXTSTATE
8304 || o->op_targ == OP_DBSTATE)
8306 PL_curcop = ((COP*)o);
8308 /* XXX: We avoid setting op_seq here to prevent later calls
8309 to peep() from mistakenly concluding that optimisation
8310 has already occurred. This doesn't fix the real problem,
8311 though (See 20010220.007). AMS 20010719 */
8312 /* op_seq functionality is now replaced by op_opt */
8319 if (oldop && o->op_next) {
8320 oldop->op_next = o->op_next;
8328 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
8329 OP* const pop = (o->op_type == OP_PADAV) ?
8330 o->op_next : o->op_next->op_next;
8332 if (pop && pop->op_type == OP_CONST &&
8333 ((PL_op = pop->op_next)) &&
8334 pop->op_next->op_type == OP_AELEM &&
8335 !(pop->op_next->op_private &
8336 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
8337 (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
8342 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
8343 no_bareword_allowed(pop);
8344 if (o->op_type == OP_GV)
8345 op_null(o->op_next);
8346 op_null(pop->op_next);
8348 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
8349 o->op_next = pop->op_next->op_next;
8350 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
8351 o->op_private = (U8)i;
8352 if (o->op_type == OP_GV) {
8357 o->op_flags |= OPf_SPECIAL;
8358 o->op_type = OP_AELEMFAST;
8363 if (o->op_next->op_type == OP_RV2SV) {
8364 if (!(o->op_next->op_private & OPpDEREF)) {
8365 op_null(o->op_next);
8366 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
8368 o->op_next = o->op_next->op_next;
8369 o->op_type = OP_GVSV;
8370 o->op_ppaddr = PL_ppaddr[OP_GVSV];
8373 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
8374 GV * const gv = cGVOPo_gv;
8375 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
8376 /* XXX could check prototype here instead of just carping */
8377 SV * const sv = sv_newmortal();
8378 gv_efullname3(sv, gv, NULL);
8379 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
8380 "%"SVf"() called too early to check prototype",
8384 else if (o->op_next->op_type == OP_READLINE
8385 && o->op_next->op_next->op_type == OP_CONCAT
8386 && (o->op_next->op_next->op_flags & OPf_STACKED))
8388 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
8389 o->op_type = OP_RCATLINE;
8390 o->op_flags |= OPf_STACKED;
8391 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
8392 op_null(o->op_next->op_next);
8393 op_null(o->op_next);
8409 while (cLOGOP->op_other->op_type == OP_NULL)
8410 cLOGOP->op_other = cLOGOP->op_other->op_next;
8411 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
8416 while (cLOOP->op_redoop->op_type == OP_NULL)
8417 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
8418 peep(cLOOP->op_redoop);
8419 while (cLOOP->op_nextop->op_type == OP_NULL)
8420 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
8421 peep(cLOOP->op_nextop);
8422 while (cLOOP->op_lastop->op_type == OP_NULL)
8423 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
8424 peep(cLOOP->op_lastop);
8428 assert(!(cPMOP->op_pmflags & PMf_ONCE));
8429 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
8430 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
8431 cPMOP->op_pmstashstartu.op_pmreplstart
8432 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
8433 peep(cPMOP->op_pmstashstartu.op_pmreplstart);
8437 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
8438 && ckWARN(WARN_SYNTAX))
8440 if (o->op_next->op_sibling) {
8441 const OPCODE type = o->op_next->op_sibling->op_type;
8442 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
8443 const line_t oldline = CopLINE(PL_curcop);
8444 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
8445 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8446 "Statement unlikely to be reached");
8447 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8448 "\t(Maybe you meant system() when you said exec()?)\n");
8449 CopLINE_set(PL_curcop, oldline);
8460 const char *key = NULL;
8463 if (((BINOP*)o)->op_last->op_type != OP_CONST)
8466 /* Make the CONST have a shared SV */
8467 svp = cSVOPx_svp(((BINOP*)o)->op_last);
8468 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
8469 key = SvPV_const(sv, keylen);
8470 lexname = newSVpvn_share(key,
8471 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
8477 if ((o->op_private & (OPpLVAL_INTRO)))
8480 rop = (UNOP*)((BINOP*)o)->op_first;
8481 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
8483 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
8484 if (!SvPAD_TYPED(lexname))
8486 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8487 if (!fields || !GvHV(*fields))
8489 key = SvPV_const(*svp, keylen);
8490 if (!hv_fetch(GvHV(*fields), key,
8491 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8493 Perl_croak(aTHX_ "No such class field \"%s\" "
8494 "in variable %s of type %s",
8495 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
8508 SVOP *first_key_op, *key_op;
8510 if ((o->op_private & (OPpLVAL_INTRO))
8511 /* I bet there's always a pushmark... */
8512 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
8513 /* hmmm, no optimization if list contains only one key. */
8515 rop = (UNOP*)((LISTOP*)o)->op_last;
8516 if (rop->op_type != OP_RV2HV)
8518 if (rop->op_first->op_type == OP_PADSV)
8519 /* @$hash{qw(keys here)} */
8520 rop = (UNOP*)rop->op_first;
8522 /* @{$hash}{qw(keys here)} */
8523 if (rop->op_first->op_type == OP_SCOPE
8524 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
8526 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
8532 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
8533 if (!SvPAD_TYPED(lexname))
8535 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8536 if (!fields || !GvHV(*fields))
8538 /* Again guessing that the pushmark can be jumped over.... */
8539 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
8540 ->op_first->op_sibling;
8541 for (key_op = first_key_op; key_op;
8542 key_op = (SVOP*)key_op->op_sibling) {
8543 if (key_op->op_type != OP_CONST)
8545 svp = cSVOPx_svp(key_op);
8546 key = SvPV_const(*svp, keylen);
8547 if (!hv_fetch(GvHV(*fields), key,
8548 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8550 Perl_croak(aTHX_ "No such class field \"%s\" "
8551 "in variable %s of type %s",
8552 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
8559 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
8563 /* check that RHS of sort is a single plain array */
8564 OP *oright = cUNOPo->op_first;
8565 if (!oright || oright->op_type != OP_PUSHMARK)
8568 /* reverse sort ... can be optimised. */
8569 if (!cUNOPo->op_sibling) {
8570 /* Nothing follows us on the list. */
8571 OP * const reverse = o->op_next;
8573 if (reverse->op_type == OP_REVERSE &&
8574 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
8575 OP * const pushmark = cUNOPx(reverse)->op_first;
8576 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
8577 && (cUNOPx(pushmark)->op_sibling == o)) {
8578 /* reverse -> pushmark -> sort */
8579 o->op_private |= OPpSORT_REVERSE;
8581 pushmark->op_next = oright->op_next;
8587 /* make @a = sort @a act in-place */
8589 oright = cUNOPx(oright)->op_sibling;
8592 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
8593 oright = cUNOPx(oright)->op_sibling;
8597 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
8598 || oright->op_next != o
8599 || (oright->op_private & OPpLVAL_INTRO)
8603 /* o2 follows the chain of op_nexts through the LHS of the
8604 * assign (if any) to the aassign op itself */
8606 if (!o2 || o2->op_type != OP_NULL)
8609 if (!o2 || o2->op_type != OP_PUSHMARK)
8612 if (o2 && o2->op_type == OP_GV)
8615 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
8616 || (o2->op_private & OPpLVAL_INTRO)
8621 if (!o2 || o2->op_type != OP_NULL)
8624 if (!o2 || o2->op_type != OP_AASSIGN
8625 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
8628 /* check that the sort is the first arg on RHS of assign */
8630 o2 = cUNOPx(o2)->op_first;
8631 if (!o2 || o2->op_type != OP_NULL)
8633 o2 = cUNOPx(o2)->op_first;
8634 if (!o2 || o2->op_type != OP_PUSHMARK)
8636 if (o2->op_sibling != o)
8639 /* check the array is the same on both sides */
8640 if (oleft->op_type == OP_RV2AV) {
8641 if (oright->op_type != OP_RV2AV
8642 || !cUNOPx(oright)->op_first
8643 || cUNOPx(oright)->op_first->op_type != OP_GV
8644 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
8645 cGVOPx_gv(cUNOPx(oright)->op_first)
8649 else if (oright->op_type != OP_PADAV
8650 || oright->op_targ != oleft->op_targ
8654 /* transfer MODishness etc from LHS arg to RHS arg */
8655 oright->op_flags = oleft->op_flags;
8656 o->op_private |= OPpSORT_INPLACE;
8658 /* excise push->gv->rv2av->null->aassign */
8659 o2 = o->op_next->op_next;
8660 op_null(o2); /* PUSHMARK */
8662 if (o2->op_type == OP_GV) {
8663 op_null(o2); /* GV */
8666 op_null(o2); /* RV2AV or PADAV */
8667 o2 = o2->op_next->op_next;
8668 op_null(o2); /* AASSIGN */
8670 o->op_next = o2->op_next;
8676 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
8678 LISTOP *enter, *exlist;
8680 enter = (LISTOP *) o->op_next;
8683 if (enter->op_type == OP_NULL) {
8684 enter = (LISTOP *) enter->op_next;
8688 /* for $a (...) will have OP_GV then OP_RV2GV here.
8689 for (...) just has an OP_GV. */
8690 if (enter->op_type == OP_GV) {
8691 gvop = (OP *) enter;
8692 enter = (LISTOP *) enter->op_next;
8695 if (enter->op_type == OP_RV2GV) {
8696 enter = (LISTOP *) enter->op_next;
8702 if (enter->op_type != OP_ENTERITER)
8705 iter = enter->op_next;
8706 if (!iter || iter->op_type != OP_ITER)
8709 expushmark = enter->op_first;
8710 if (!expushmark || expushmark->op_type != OP_NULL
8711 || expushmark->op_targ != OP_PUSHMARK)
8714 exlist = (LISTOP *) expushmark->op_sibling;
8715 if (!exlist || exlist->op_type != OP_NULL
8716 || exlist->op_targ != OP_LIST)
8719 if (exlist->op_last != o) {
8720 /* Mmm. Was expecting to point back to this op. */
8723 theirmark = exlist->op_first;
8724 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
8727 if (theirmark->op_sibling != o) {
8728 /* There's something between the mark and the reverse, eg
8729 for (1, reverse (...))
8734 ourmark = ((LISTOP *)o)->op_first;
8735 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
8738 ourlast = ((LISTOP *)o)->op_last;
8739 if (!ourlast || ourlast->op_next != o)
8742 rv2av = ourmark->op_sibling;
8743 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
8744 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
8745 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
8746 /* We're just reversing a single array. */
8747 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
8748 enter->op_flags |= OPf_STACKED;
8751 /* We don't have control over who points to theirmark, so sacrifice
8753 theirmark->op_next = ourmark->op_next;
8754 theirmark->op_flags = ourmark->op_flags;
8755 ourlast->op_next = gvop ? gvop : (OP *) enter;
8758 enter->op_private |= OPpITER_REVERSED;
8759 iter->op_private |= OPpITER_REVERSED;
8766 UNOP *refgen, *rv2cv;
8769 if ((o->op_flags & OPf_WANT) != OPf_WANT_VOID)
8772 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
8775 rv2gv = ((BINOP *)o)->op_last;
8776 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
8779 refgen = (UNOP *)((BINOP *)o)->op_first;
8781 if (!refgen || refgen->op_type != OP_REFGEN)
8784 exlist = (LISTOP *)refgen->op_first;
8785 if (!exlist || exlist->op_type != OP_NULL
8786 || exlist->op_targ != OP_LIST)
8789 if (exlist->op_first->op_type != OP_PUSHMARK)
8792 rv2cv = (UNOP*)exlist->op_last;
8794 if (rv2cv->op_type != OP_RV2CV)
8797 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
8798 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
8799 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
8801 o->op_private |= OPpASSIGN_CV_TO_GV;
8802 rv2gv->op_private |= OPpDONT_INIT_GV;
8803 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
8811 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
8812 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
8822 Perl_custom_op_name(pTHX_ const OP* o)
8825 const IV index = PTR2IV(o->op_ppaddr);
8829 PERL_ARGS_ASSERT_CUSTOM_OP_NAME;
8831 if (!PL_custom_op_names) /* This probably shouldn't happen */
8832 return (char *)PL_op_name[OP_CUSTOM];
8834 keysv = sv_2mortal(newSViv(index));
8836 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
8838 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
8840 return SvPV_nolen(HeVAL(he));
8844 Perl_custom_op_desc(pTHX_ const OP* o)
8847 const IV index = PTR2IV(o->op_ppaddr);
8851 PERL_ARGS_ASSERT_CUSTOM_OP_DESC;
8853 if (!PL_custom_op_descs)
8854 return (char *)PL_op_desc[OP_CUSTOM];
8856 keysv = sv_2mortal(newSViv(index));
8858 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
8860 return (char *)PL_op_desc[OP_CUSTOM];
8862 return SvPV_nolen(HeVAL(he));
8867 /* Efficient sub that returns a constant scalar value. */
8869 const_sv_xsub(pTHX_ CV* cv)
8876 Perl_croak(aTHX_ "usage: %s::%s()",
8877 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
8881 ST(0) = (SV*)XSANY.any_ptr;
8887 * c-indentation-style: bsd
8889 * indent-tabs-mode: t
8892 * ex: set ts=8 sts=4 sw=4 noet: