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;
678 if (! specialWARN(cop->cop_warnings))
679 PerlMemShared_free(cop->cop_warnings);
680 Perl_refcounted_he_free(aTHX_ cop->cop_hints_hash);
684 S_forget_pmop(pTHX_ PMOP *const o
690 HV * const pmstash = PmopSTASH(o);
692 PERL_ARGS_ASSERT_FORGET_PMOP;
694 if (pmstash && !SvIS_FREED(pmstash)) {
695 MAGIC * const mg = mg_find((SV*)pmstash, PERL_MAGIC_symtab);
697 PMOP **const array = (PMOP**) mg->mg_ptr;
698 U32 count = mg->mg_len / sizeof(PMOP**);
703 /* Found it. Move the entry at the end to overwrite it. */
704 array[i] = array[--count];
705 mg->mg_len = count * sizeof(PMOP**);
706 /* Could realloc smaller at this point always, but probably
707 not worth it. Probably worth free()ing if we're the
710 Safefree(mg->mg_ptr);
727 S_find_and_forget_pmops(pTHX_ OP *o)
729 PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
731 if (o->op_flags & OPf_KIDS) {
732 OP *kid = cUNOPo->op_first;
734 switch (kid->op_type) {
739 forget_pmop((PMOP*)kid, 0);
741 find_and_forget_pmops(kid);
742 kid = kid->op_sibling;
748 Perl_op_null(pTHX_ OP *o)
752 PERL_ARGS_ASSERT_OP_NULL;
754 if (o->op_type == OP_NULL)
758 o->op_targ = o->op_type;
759 o->op_type = OP_NULL;
760 o->op_ppaddr = PL_ppaddr[OP_NULL];
764 Perl_op_refcnt_lock(pTHX)
772 Perl_op_refcnt_unlock(pTHX)
779 /* Contextualizers */
781 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
784 Perl_linklist(pTHX_ OP *o)
788 PERL_ARGS_ASSERT_LINKLIST;
793 /* establish postfix order */
794 first = cUNOPo->op_first;
797 o->op_next = LINKLIST(first);
800 if (kid->op_sibling) {
801 kid->op_next = LINKLIST(kid->op_sibling);
802 kid = kid->op_sibling;
816 Perl_scalarkids(pTHX_ OP *o)
818 if (o && o->op_flags & OPf_KIDS) {
820 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
827 S_scalarboolean(pTHX_ OP *o)
831 PERL_ARGS_ASSERT_SCALARBOOLEAN;
833 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
834 if (ckWARN(WARN_SYNTAX)) {
835 const line_t oldline = CopLINE(PL_curcop);
837 if (PL_parser && PL_parser->copline != NOLINE)
838 CopLINE_set(PL_curcop, PL_parser->copline);
839 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
840 CopLINE_set(PL_curcop, oldline);
847 Perl_scalar(pTHX_ OP *o)
852 /* assumes no premature commitment */
853 if (!o || (PL_parser && PL_parser->error_count)
854 || (o->op_flags & OPf_WANT)
855 || o->op_type == OP_RETURN)
860 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
862 switch (o->op_type) {
864 scalar(cBINOPo->op_first);
869 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
873 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
874 if (!kPMOP->op_pmreplrootu.op_pmreplroot)
875 deprecate_old("implicit split to @_");
883 if (o->op_flags & OPf_KIDS) {
884 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
890 kid = cLISTOPo->op_first;
892 while ((kid = kid->op_sibling)) {
898 PL_curcop = &PL_compiling;
903 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
909 PL_curcop = &PL_compiling;
912 if (ckWARN(WARN_VOID))
913 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
920 Perl_scalarvoid(pTHX_ OP *o)
924 const char* useless = NULL;
928 PERL_ARGS_ASSERT_SCALARVOID;
930 /* trailing mad null ops don't count as "there" for void processing */
932 o->op_type != OP_NULL &&
934 o->op_sibling->op_type == OP_NULL)
937 for (sib = o->op_sibling;
938 sib && sib->op_type == OP_NULL;
939 sib = sib->op_sibling) ;
945 if (o->op_type == OP_NEXTSTATE
946 || o->op_type == OP_DBSTATE
947 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
948 || o->op_targ == OP_DBSTATE)))
949 PL_curcop = (COP*)o; /* for warning below */
951 /* assumes no premature commitment */
952 want = o->op_flags & OPf_WANT;
953 if ((want && want != OPf_WANT_SCALAR)
954 || (PL_parser && PL_parser->error_count)
955 || o->op_type == OP_RETURN)
960 if ((o->op_private & OPpTARGET_MY)
961 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
963 return scalar(o); /* As if inside SASSIGN */
966 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
968 switch (o->op_type) {
970 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
974 if (o->op_flags & OPf_STACKED)
978 if (o->op_private == 4)
1021 case OP_GETSOCKNAME:
1022 case OP_GETPEERNAME:
1027 case OP_GETPRIORITY:
1051 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1052 /* Otherwise it's "Useless use of grep iterator" */
1053 useless = OP_DESC(o);
1057 kid = cUNOPo->op_first;
1058 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1059 kid->op_type != OP_TRANS) {
1062 useless = "negative pattern binding (!~)";
1069 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1070 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1071 useless = "a variable";
1076 if (cSVOPo->op_private & OPpCONST_STRICT)
1077 no_bareword_allowed(o);
1079 if (ckWARN(WARN_VOID)) {
1081 SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_
1082 "a constant (%"SVf")", sv));
1083 useless = SvPV_nolen(msv);
1086 useless = "a constant (undef)";
1087 if (o->op_private & OPpCONST_ARYBASE)
1089 /* don't warn on optimised away booleans, eg
1090 * use constant Foo, 5; Foo || print; */
1091 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1093 /* the constants 0 and 1 are permitted as they are
1094 conventionally used as dummies in constructs like
1095 1 while some_condition_with_side_effects; */
1096 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1098 else if (SvPOK(sv)) {
1099 /* perl4's way of mixing documentation and code
1100 (before the invention of POD) was based on a
1101 trick to mix nroff and perl code. The trick was
1102 built upon these three nroff macros being used in
1103 void context. The pink camel has the details in
1104 the script wrapman near page 319. */
1105 const char * const maybe_macro = SvPVX_const(sv);
1106 if (strnEQ(maybe_macro, "di", 2) ||
1107 strnEQ(maybe_macro, "ds", 2) ||
1108 strnEQ(maybe_macro, "ig", 2))
1113 op_null(o); /* don't execute or even remember it */
1117 o->op_type = OP_PREINC; /* pre-increment is faster */
1118 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1122 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1123 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1127 o->op_type = OP_I_PREINC; /* pre-increment is faster */
1128 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1132 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
1133 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1142 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1147 if (o->op_flags & OPf_STACKED)
1154 if (!(o->op_flags & OPf_KIDS))
1165 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1172 /* all requires must return a boolean value */
1173 o->op_flags &= ~OPf_WANT;
1178 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
1179 if (!kPMOP->op_pmreplrootu.op_pmreplroot)
1180 deprecate_old("implicit split to @_");
1184 if (useless && ckWARN(WARN_VOID))
1185 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
1190 Perl_listkids(pTHX_ OP *o)
1192 if (o && o->op_flags & OPf_KIDS) {
1194 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1201 Perl_list(pTHX_ OP *o)
1206 /* assumes no premature commitment */
1207 if (!o || (o->op_flags & OPf_WANT)
1208 || (PL_parser && PL_parser->error_count)
1209 || o->op_type == OP_RETURN)
1214 if ((o->op_private & OPpTARGET_MY)
1215 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1217 return o; /* As if inside SASSIGN */
1220 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1222 switch (o->op_type) {
1225 list(cBINOPo->op_first);
1230 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1238 if (!(o->op_flags & OPf_KIDS))
1240 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1241 list(cBINOPo->op_first);
1242 return gen_constant_list(o);
1249 kid = cLISTOPo->op_first;
1251 while ((kid = kid->op_sibling)) {
1252 if (kid->op_sibling)
1257 PL_curcop = &PL_compiling;
1261 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1262 if (kid->op_sibling)
1267 PL_curcop = &PL_compiling;
1270 /* all requires must return a boolean value */
1271 o->op_flags &= ~OPf_WANT;
1278 Perl_scalarseq(pTHX_ OP *o)
1282 const OPCODE type = o->op_type;
1284 if (type == OP_LINESEQ || type == OP_SCOPE ||
1285 type == OP_LEAVE || type == OP_LEAVETRY)
1288 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1289 if (kid->op_sibling) {
1293 PL_curcop = &PL_compiling;
1295 o->op_flags &= ~OPf_PARENS;
1296 if (PL_hints & HINT_BLOCK_SCOPE)
1297 o->op_flags |= OPf_PARENS;
1300 o = newOP(OP_STUB, 0);
1305 S_modkids(pTHX_ OP *o, I32 type)
1307 if (o && o->op_flags & OPf_KIDS) {
1309 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1315 /* Propagate lvalue ("modifiable") context to an op and its children.
1316 * 'type' represents the context type, roughly based on the type of op that
1317 * would do the modifying, although local() is represented by OP_NULL.
1318 * It's responsible for detecting things that can't be modified, flag
1319 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
1320 * might have to vivify a reference in $x), and so on.
1322 * For example, "$a+1 = 2" would cause mod() to be called with o being
1323 * OP_ADD and type being OP_SASSIGN, and would output an error.
1327 Perl_mod(pTHX_ OP *o, I32 type)
1331 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1334 if (!o || (PL_parser && PL_parser->error_count))
1337 if ((o->op_private & OPpTARGET_MY)
1338 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1343 switch (o->op_type) {
1349 if (!(o->op_private & OPpCONST_ARYBASE))
1352 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1353 CopARYBASE_set(&PL_compiling,
1354 (I32)SvIV(cSVOPx(PL_eval_start)->op_sv));
1358 SAVECOPARYBASE(&PL_compiling);
1359 CopARYBASE_set(&PL_compiling, 0);
1361 else if (type == OP_REFGEN)
1364 Perl_croak(aTHX_ "That use of $[ is unsupported");
1367 if ((o->op_flags & OPf_PARENS) || PL_madskills)
1371 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1372 !(o->op_flags & OPf_STACKED)) {
1373 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1374 /* The default is to set op_private to the number of children,
1375 which for a UNOP such as RV2CV is always 1. And w're using
1376 the bit for a flag in RV2CV, so we need it clear. */
1377 o->op_private &= ~1;
1378 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1379 assert(cUNOPo->op_first->op_type == OP_NULL);
1380 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1383 else if (o->op_private & OPpENTERSUB_NOMOD)
1385 else { /* lvalue subroutine call */
1386 o->op_private |= OPpLVAL_INTRO;
1387 PL_modcount = RETURN_UNLIMITED_NUMBER;
1388 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1389 /* Backward compatibility mode: */
1390 o->op_private |= OPpENTERSUB_INARGS;
1393 else { /* Compile-time error message: */
1394 OP *kid = cUNOPo->op_first;
1398 if (kid->op_type != OP_PUSHMARK) {
1399 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1401 "panic: unexpected lvalue entersub "
1402 "args: type/targ %ld:%"UVuf,
1403 (long)kid->op_type, (UV)kid->op_targ);
1404 kid = kLISTOP->op_first;
1406 while (kid->op_sibling)
1407 kid = kid->op_sibling;
1408 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1410 if (kid->op_type == OP_METHOD_NAMED
1411 || kid->op_type == OP_METHOD)
1415 NewOp(1101, newop, 1, UNOP);
1416 newop->op_type = OP_RV2CV;
1417 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1418 newop->op_first = NULL;
1419 newop->op_next = (OP*)newop;
1420 kid->op_sibling = (OP*)newop;
1421 newop->op_private |= OPpLVAL_INTRO;
1422 newop->op_private &= ~1;
1426 if (kid->op_type != OP_RV2CV)
1428 "panic: unexpected lvalue entersub "
1429 "entry via type/targ %ld:%"UVuf,
1430 (long)kid->op_type, (UV)kid->op_targ);
1431 kid->op_private |= OPpLVAL_INTRO;
1432 break; /* Postpone until runtime */
1436 kid = kUNOP->op_first;
1437 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1438 kid = kUNOP->op_first;
1439 if (kid->op_type == OP_NULL)
1441 "Unexpected constant lvalue entersub "
1442 "entry via type/targ %ld:%"UVuf,
1443 (long)kid->op_type, (UV)kid->op_targ);
1444 if (kid->op_type != OP_GV) {
1445 /* Restore RV2CV to check lvalueness */
1447 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1448 okid->op_next = kid->op_next;
1449 kid->op_next = okid;
1452 okid->op_next = NULL;
1453 okid->op_type = OP_RV2CV;
1455 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1456 okid->op_private |= OPpLVAL_INTRO;
1457 okid->op_private &= ~1;
1461 cv = GvCV(kGVOP_gv);
1471 /* grep, foreach, subcalls, refgen */
1472 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1474 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1475 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1477 : (o->op_type == OP_ENTERSUB
1478 ? "non-lvalue subroutine call"
1480 type ? PL_op_desc[type] : "local"));
1494 case OP_RIGHT_SHIFT:
1503 if (!(o->op_flags & OPf_STACKED))
1510 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1516 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1517 PL_modcount = RETURN_UNLIMITED_NUMBER;
1518 return o; /* Treat \(@foo) like ordinary list. */
1522 if (scalar_mod_type(o, type))
1524 ref(cUNOPo->op_first, o->op_type);
1528 if (type == OP_LEAVESUBLV)
1529 o->op_private |= OPpMAYBE_LVSUB;
1535 PL_modcount = RETURN_UNLIMITED_NUMBER;
1538 ref(cUNOPo->op_first, o->op_type);
1543 PL_hints |= HINT_BLOCK_SCOPE;
1558 PL_modcount = RETURN_UNLIMITED_NUMBER;
1559 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1560 return o; /* Treat \(@foo) like ordinary list. */
1561 if (scalar_mod_type(o, type))
1563 if (type == OP_LEAVESUBLV)
1564 o->op_private |= OPpMAYBE_LVSUB;
1568 if (!type) /* local() */
1569 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1570 PAD_COMPNAME_PV(o->op_targ));
1578 if (type != OP_SASSIGN)
1582 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1587 if (type == OP_LEAVESUBLV)
1588 o->op_private |= OPpMAYBE_LVSUB;
1590 pad_free(o->op_targ);
1591 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1592 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1593 if (o->op_flags & OPf_KIDS)
1594 mod(cBINOPo->op_first->op_sibling, type);
1599 ref(cBINOPo->op_first, o->op_type);
1600 if (type == OP_ENTERSUB &&
1601 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1602 o->op_private |= OPpLVAL_DEFER;
1603 if (type == OP_LEAVESUBLV)
1604 o->op_private |= OPpMAYBE_LVSUB;
1614 if (o->op_flags & OPf_KIDS)
1615 mod(cLISTOPo->op_last, type);
1620 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1622 else if (!(o->op_flags & OPf_KIDS))
1624 if (o->op_targ != OP_LIST) {
1625 mod(cBINOPo->op_first, type);
1631 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1636 if (type != OP_LEAVESUBLV)
1638 break; /* mod()ing was handled by ck_return() */
1641 /* [20011101.069] File test operators interpret OPf_REF to mean that
1642 their argument is a filehandle; thus \stat(".") should not set
1644 if (type == OP_REFGEN &&
1645 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1648 if (type != OP_LEAVESUBLV)
1649 o->op_flags |= OPf_MOD;
1651 if (type == OP_AASSIGN || type == OP_SASSIGN)
1652 o->op_flags |= OPf_SPECIAL|OPf_REF;
1653 else if (!type) { /* local() */
1656 o->op_private |= OPpLVAL_INTRO;
1657 o->op_flags &= ~OPf_SPECIAL;
1658 PL_hints |= HINT_BLOCK_SCOPE;
1663 if (ckWARN(WARN_SYNTAX)) {
1664 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1665 "Useless localization of %s", OP_DESC(o));
1669 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1670 && type != OP_LEAVESUBLV)
1671 o->op_flags |= OPf_REF;
1676 S_scalar_mod_type(const OP *o, I32 type)
1678 PERL_ARGS_ASSERT_SCALAR_MOD_TYPE;
1682 if (o->op_type == OP_RV2GV)
1706 case OP_RIGHT_SHIFT:
1726 S_is_handle_constructor(const OP *o, I32 numargs)
1728 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
1730 switch (o->op_type) {
1738 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1751 Perl_refkids(pTHX_ OP *o, I32 type)
1753 if (o && o->op_flags & OPf_KIDS) {
1755 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1762 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
1767 PERL_ARGS_ASSERT_DOREF;
1769 if (!o || (PL_parser && PL_parser->error_count))
1772 switch (o->op_type) {
1774 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1775 !(o->op_flags & OPf_STACKED)) {
1776 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1777 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1778 assert(cUNOPo->op_first->op_type == OP_NULL);
1779 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1780 o->op_flags |= OPf_SPECIAL;
1781 o->op_private &= ~1;
1786 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1787 doref(kid, type, set_op_ref);
1790 if (type == OP_DEFINED)
1791 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1792 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1795 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1796 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1797 : type == OP_RV2HV ? OPpDEREF_HV
1799 o->op_flags |= OPf_MOD;
1806 o->op_flags |= OPf_REF;
1809 if (type == OP_DEFINED)
1810 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1811 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1817 o->op_flags |= OPf_REF;
1822 if (!(o->op_flags & OPf_KIDS))
1824 doref(cBINOPo->op_first, type, set_op_ref);
1828 doref(cBINOPo->op_first, o->op_type, set_op_ref);
1829 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1830 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1831 : type == OP_RV2HV ? OPpDEREF_HV
1833 o->op_flags |= OPf_MOD;
1843 if (!(o->op_flags & OPf_KIDS))
1845 doref(cLISTOPo->op_last, type, set_op_ref);
1855 S_dup_attrlist(pTHX_ OP *o)
1860 PERL_ARGS_ASSERT_DUP_ATTRLIST;
1862 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1863 * where the first kid is OP_PUSHMARK and the remaining ones
1864 * are OP_CONST. We need to push the OP_CONST values.
1866 if (o->op_type == OP_CONST)
1867 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
1869 else if (o->op_type == OP_NULL)
1873 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1875 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1876 if (o->op_type == OP_CONST)
1877 rop = append_elem(OP_LIST, rop,
1878 newSVOP(OP_CONST, o->op_flags,
1879 SvREFCNT_inc_NN(cSVOPo->op_sv)));
1886 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1891 PERL_ARGS_ASSERT_APPLY_ATTRS;
1893 /* fake up C<use attributes $pkg,$rv,@attrs> */
1894 ENTER; /* need to protect against side-effects of 'use' */
1895 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1897 #define ATTRSMODULE "attributes"
1898 #define ATTRSMODULE_PM "attributes.pm"
1901 /* Don't force the C<use> if we don't need it. */
1902 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
1903 if (svp && *svp != &PL_sv_undef)
1904 NOOP; /* already in %INC */
1906 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1907 newSVpvs(ATTRSMODULE), NULL);
1910 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1911 newSVpvs(ATTRSMODULE),
1913 prepend_elem(OP_LIST,
1914 newSVOP(OP_CONST, 0, stashsv),
1915 prepend_elem(OP_LIST,
1916 newSVOP(OP_CONST, 0,
1918 dup_attrlist(attrs))));
1924 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1927 OP *pack, *imop, *arg;
1930 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
1935 assert(target->op_type == OP_PADSV ||
1936 target->op_type == OP_PADHV ||
1937 target->op_type == OP_PADAV);
1939 /* Ensure that attributes.pm is loaded. */
1940 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1942 /* Need package name for method call. */
1943 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
1945 /* Build up the real arg-list. */
1946 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1948 arg = newOP(OP_PADSV, 0);
1949 arg->op_targ = target->op_targ;
1950 arg = prepend_elem(OP_LIST,
1951 newSVOP(OP_CONST, 0, stashsv),
1952 prepend_elem(OP_LIST,
1953 newUNOP(OP_REFGEN, 0,
1954 mod(arg, OP_REFGEN)),
1955 dup_attrlist(attrs)));
1957 /* Fake up a method call to import */
1958 meth = newSVpvs_share("import");
1959 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1960 append_elem(OP_LIST,
1961 prepend_elem(OP_LIST, pack, list(arg)),
1962 newSVOP(OP_METHOD_NAMED, 0, meth)));
1963 imop->op_private |= OPpENTERSUB_NOMOD;
1965 /* Combine the ops. */
1966 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1970 =notfor apidoc apply_attrs_string
1972 Attempts to apply a list of attributes specified by the C<attrstr> and
1973 C<len> arguments to the subroutine identified by the C<cv> argument which
1974 is expected to be associated with the package identified by the C<stashpv>
1975 argument (see L<attributes>). It gets this wrong, though, in that it
1976 does not correctly identify the boundaries of the individual attribute
1977 specifications within C<attrstr>. This is not really intended for the
1978 public API, but has to be listed here for systems such as AIX which
1979 need an explicit export list for symbols. (It's called from XS code
1980 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1981 to respect attribute syntax properly would be welcome.
1987 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
1988 const char *attrstr, STRLEN len)
1992 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
1995 len = strlen(attrstr);
1999 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2001 const char * const sstr = attrstr;
2002 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2003 attrs = append_elem(OP_LIST, attrs,
2004 newSVOP(OP_CONST, 0,
2005 newSVpvn(sstr, attrstr-sstr)));
2009 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2010 newSVpvs(ATTRSMODULE),
2011 NULL, prepend_elem(OP_LIST,
2012 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2013 prepend_elem(OP_LIST,
2014 newSVOP(OP_CONST, 0,
2020 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
2025 PERL_ARGS_ASSERT_MY_KID;
2027 if (!o || (PL_parser && PL_parser->error_count))
2031 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
2032 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
2036 if (type == OP_LIST) {
2038 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2039 my_kid(kid, attrs, imopsp);
2040 } else if (type == OP_UNDEF
2046 } else if (type == OP_RV2SV || /* "our" declaration */
2048 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
2049 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
2050 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2052 PL_parser->in_my == KEY_our
2054 : PL_parser->in_my == KEY_state ? "state" : "my"));
2056 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
2057 PL_parser->in_my = FALSE;
2058 PL_parser->in_my_stash = NULL;
2059 apply_attrs(GvSTASH(gv),
2060 (type == OP_RV2SV ? GvSV(gv) :
2061 type == OP_RV2AV ? (SV*)GvAV(gv) :
2062 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
2065 o->op_private |= OPpOUR_INTRO;
2068 else if (type != OP_PADSV &&
2071 type != OP_PUSHMARK)
2073 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2075 PL_parser->in_my == KEY_our
2077 : PL_parser->in_my == KEY_state ? "state" : "my"));
2080 else if (attrs && type != OP_PUSHMARK) {
2083 PL_parser->in_my = FALSE;
2084 PL_parser->in_my_stash = NULL;
2086 /* check for C<my Dog $spot> when deciding package */
2087 stash = PAD_COMPNAME_TYPE(o->op_targ);
2089 stash = PL_curstash;
2090 apply_attrs_my(stash, o, attrs, imopsp);
2092 o->op_flags |= OPf_MOD;
2093 o->op_private |= OPpLVAL_INTRO;
2094 if (PL_parser->in_my == KEY_state)
2095 o->op_private |= OPpPAD_STATE;
2100 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2104 int maybe_scalar = 0;
2106 PERL_ARGS_ASSERT_MY_ATTRS;
2108 /* [perl #17376]: this appears to be premature, and results in code such as
2109 C< our(%x); > executing in list mode rather than void mode */
2111 if (o->op_flags & OPf_PARENS)
2121 o = my_kid(o, attrs, &rops);
2123 if (maybe_scalar && o->op_type == OP_PADSV) {
2124 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
2125 o->op_private |= OPpLVAL_INTRO;
2128 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
2130 PL_parser->in_my = FALSE;
2131 PL_parser->in_my_stash = NULL;
2136 Perl_my(pTHX_ OP *o)
2138 PERL_ARGS_ASSERT_MY;
2140 return my_attrs(o, NULL);
2144 Perl_sawparens(pTHX_ OP *o)
2146 PERL_UNUSED_CONTEXT;
2148 o->op_flags |= OPf_PARENS;
2153 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2157 const OPCODE ltype = left->op_type;
2158 const OPCODE rtype = right->op_type;
2160 PERL_ARGS_ASSERT_BIND_MATCH;
2162 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2163 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
2165 const char * const desc
2166 = PL_op_desc[(rtype == OP_SUBST || rtype == OP_TRANS)
2167 ? (int)rtype : OP_MATCH];
2168 const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV)
2169 ? "@array" : "%hash");
2170 Perl_warner(aTHX_ packWARN(WARN_MISC),
2171 "Applying %s to %s will act on scalar(%s)",
2172 desc, sample, sample);
2175 if (rtype == OP_CONST &&
2176 cSVOPx(right)->op_private & OPpCONST_BARE &&
2177 cSVOPx(right)->op_private & OPpCONST_STRICT)
2179 no_bareword_allowed(right);
2182 ismatchop = rtype == OP_MATCH ||
2183 rtype == OP_SUBST ||
2185 if (ismatchop && right->op_private & OPpTARGET_MY) {
2187 right->op_private &= ~OPpTARGET_MY;
2189 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
2192 right->op_flags |= OPf_STACKED;
2193 if (rtype != OP_MATCH &&
2194 ! (rtype == OP_TRANS &&
2195 right->op_private & OPpTRANS_IDENTICAL))
2196 newleft = mod(left, rtype);
2199 if (right->op_type == OP_TRANS)
2200 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
2202 o = prepend_elem(rtype, scalar(newleft), right);
2204 return newUNOP(OP_NOT, 0, scalar(o));
2208 return bind_match(type, left,
2209 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
2213 Perl_invert(pTHX_ OP *o)
2217 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2221 Perl_scope(pTHX_ OP *o)
2225 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2226 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2227 o->op_type = OP_LEAVE;
2228 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2230 else if (o->op_type == OP_LINESEQ) {
2232 o->op_type = OP_SCOPE;
2233 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2234 kid = ((LISTOP*)o)->op_first;
2235 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2238 /* The following deals with things like 'do {1 for 1}' */
2239 kid = kid->op_sibling;
2241 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2246 o = newLISTOP(OP_SCOPE, 0, o, NULL);
2252 Perl_block_start(pTHX_ int full)
2255 const int retval = PL_savestack_ix;
2256 pad_block_start(full);
2258 PL_hints &= ~HINT_BLOCK_SCOPE;
2259 SAVECOMPILEWARNINGS();
2260 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
2265 Perl_block_end(pTHX_ I32 floor, OP *seq)
2268 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2269 OP* const retval = scalarseq(seq);
2271 CopHINTS_set(&PL_compiling, PL_hints);
2273 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2282 const PADOFFSET offset = pad_findmy("$_");
2283 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
2284 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2287 OP * const o = newOP(OP_PADSV, 0);
2288 o->op_targ = offset;
2294 Perl_newPROG(pTHX_ OP *o)
2298 PERL_ARGS_ASSERT_NEWPROG;
2303 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2304 ((PL_in_eval & EVAL_KEEPERR)
2305 ? OPf_SPECIAL : 0), o);
2306 PL_eval_start = linklist(PL_eval_root);
2307 PL_eval_root->op_private |= OPpREFCOUNTED;
2308 OpREFCNT_set(PL_eval_root, 1);
2309 PL_eval_root->op_next = 0;
2310 CALL_PEEP(PL_eval_start);
2313 if (o->op_type == OP_STUB) {
2314 PL_comppad_name = 0;
2316 S_op_destroy(aTHX_ o);
2319 PL_main_root = scope(sawparens(scalarvoid(o)));
2320 PL_curcop = &PL_compiling;
2321 PL_main_start = LINKLIST(PL_main_root);
2322 PL_main_root->op_private |= OPpREFCOUNTED;
2323 OpREFCNT_set(PL_main_root, 1);
2324 PL_main_root->op_next = 0;
2325 CALL_PEEP(PL_main_start);
2328 /* Register with debugger */
2331 = Perl_get_cvn_flags(aTHX_ STR_WITH_LEN("DB::postponed"), 0);
2335 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2337 call_sv((SV*)cv, G_DISCARD);
2344 Perl_localize(pTHX_ OP *o, I32 lex)
2348 PERL_ARGS_ASSERT_LOCALIZE;
2350 if (o->op_flags & OPf_PARENS)
2351 /* [perl #17376]: this appears to be premature, and results in code such as
2352 C< our(%x); > executing in list mode rather than void mode */
2359 if ( PL_parser->bufptr > PL_parser->oldbufptr
2360 && PL_parser->bufptr[-1] == ','
2361 && ckWARN(WARN_PARENTHESIS))
2363 char *s = PL_parser->bufptr;
2366 /* some heuristics to detect a potential error */
2367 while (*s && (strchr(", \t\n", *s)))
2371 if (*s && strchr("@$%*", *s) && *++s
2372 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2375 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2377 while (*s && (strchr(", \t\n", *s)))
2383 if (sigil && (*s == ';' || *s == '=')) {
2384 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2385 "Parentheses missing around \"%s\" list",
2387 ? (PL_parser->in_my == KEY_our
2389 : PL_parser->in_my == KEY_state
2399 o = mod(o, OP_NULL); /* a bit kludgey */
2400 PL_parser->in_my = FALSE;
2401 PL_parser->in_my_stash = NULL;
2406 Perl_jmaybe(pTHX_ OP *o)
2408 PERL_ARGS_ASSERT_JMAYBE;
2410 if (o->op_type == OP_LIST) {
2412 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2413 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2419 Perl_fold_constants(pTHX_ register OP *o)
2422 register OP * VOL curop;
2424 VOL I32 type = o->op_type;
2429 SV * const oldwarnhook = PL_warnhook;
2430 SV * const olddiehook = PL_diehook;
2434 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
2436 if (PL_opargs[type] & OA_RETSCALAR)
2438 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2439 o->op_targ = pad_alloc(type, SVs_PADTMP);
2441 /* integerize op, unless it happens to be C<-foo>.
2442 * XXX should pp_i_negate() do magic string negation instead? */
2443 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2444 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2445 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2447 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2450 if (!(PL_opargs[type] & OA_FOLDCONST))
2455 /* XXX might want a ck_negate() for this */
2456 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2467 /* XXX what about the numeric ops? */
2468 if (PL_hints & HINT_LOCALE)
2473 if (PL_parser && PL_parser->error_count)
2474 goto nope; /* Don't try to run w/ errors */
2476 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2477 const OPCODE type = curop->op_type;
2478 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2480 type != OP_SCALAR &&
2482 type != OP_PUSHMARK)
2488 curop = LINKLIST(o);
2489 old_next = o->op_next;
2493 oldscope = PL_scopestack_ix;
2494 create_eval_scope(G_FAKINGEVAL);
2496 /* Verify that we don't need to save it: */
2497 assert(PL_curcop == &PL_compiling);
2498 StructCopy(&PL_compiling, ¬_compiling, COP);
2499 PL_curcop = ¬_compiling;
2500 /* The above ensures that we run with all the correct hints of the
2501 currently compiling COP, but that IN_PERL_RUNTIME is not true. */
2502 assert(IN_PERL_RUNTIME);
2503 PL_warnhook = PERL_WARNHOOK_FATAL;
2510 sv = *(PL_stack_sp--);
2511 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2512 pad_swipe(o->op_targ, FALSE);
2513 else if (SvTEMP(sv)) { /* grab mortal temp? */
2514 SvREFCNT_inc_simple_void(sv);
2519 /* Something tried to die. Abandon constant folding. */
2520 /* Pretend the error never happened. */
2521 sv_setpvn(ERRSV,"",0);
2522 o->op_next = old_next;
2526 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
2527 PL_warnhook = oldwarnhook;
2528 PL_diehook = olddiehook;
2529 /* XXX note that this croak may fail as we've already blown away
2530 * the stack - eg any nested evals */
2531 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
2534 PL_warnhook = oldwarnhook;
2535 PL_diehook = olddiehook;
2536 PL_curcop = &PL_compiling;
2538 if (PL_scopestack_ix > oldscope)
2539 delete_eval_scope();
2548 if (type == OP_RV2GV)
2549 newop = newGVOP(OP_GV, 0, (GV*)sv);
2551 newop = newSVOP(OP_CONST, 0, (SV*)sv);
2552 op_getmad(o,newop,'f');
2560 Perl_gen_constant_list(pTHX_ register OP *o)
2564 const I32 oldtmps_floor = PL_tmps_floor;
2567 if (PL_parser && PL_parser->error_count)
2568 return o; /* Don't attempt to run with errors */
2570 PL_op = curop = LINKLIST(o);
2576 assert (!(curop->op_flags & OPf_SPECIAL));
2577 assert(curop->op_type == OP_RANGE);
2579 PL_tmps_floor = oldtmps_floor;
2581 o->op_type = OP_RV2AV;
2582 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2583 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2584 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2585 o->op_opt = 0; /* needs to be revisited in peep() */
2586 curop = ((UNOP*)o)->op_first;
2587 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
2589 op_getmad(curop,o,'O');
2598 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2601 if (!o || o->op_type != OP_LIST)
2602 o = newLISTOP(OP_LIST, 0, o, NULL);
2604 o->op_flags &= ~OPf_WANT;
2606 if (!(PL_opargs[type] & OA_MARK))
2607 op_null(cLISTOPo->op_first);
2609 o->op_type = (OPCODE)type;
2610 o->op_ppaddr = PL_ppaddr[type];
2611 o->op_flags |= flags;
2613 o = CHECKOP(type, o);
2614 if (o->op_type != (unsigned)type)
2617 return fold_constants(o);
2620 /* List constructors */
2623 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2631 if (first->op_type != (unsigned)type
2632 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2634 return newLISTOP(type, 0, first, last);
2637 if (first->op_flags & OPf_KIDS)
2638 ((LISTOP*)first)->op_last->op_sibling = last;
2640 first->op_flags |= OPf_KIDS;
2641 ((LISTOP*)first)->op_first = last;
2643 ((LISTOP*)first)->op_last = last;
2648 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2656 if (first->op_type != (unsigned)type)
2657 return prepend_elem(type, (OP*)first, (OP*)last);
2659 if (last->op_type != (unsigned)type)
2660 return append_elem(type, (OP*)first, (OP*)last);
2662 first->op_last->op_sibling = last->op_first;
2663 first->op_last = last->op_last;
2664 first->op_flags |= (last->op_flags & OPf_KIDS);
2667 if (last->op_first && first->op_madprop) {
2668 MADPROP *mp = last->op_first->op_madprop;
2670 while (mp->mad_next)
2672 mp->mad_next = first->op_madprop;
2675 last->op_first->op_madprop = first->op_madprop;
2678 first->op_madprop = last->op_madprop;
2679 last->op_madprop = 0;
2682 S_op_destroy(aTHX_ (OP*)last);
2688 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2696 if (last->op_type == (unsigned)type) {
2697 if (type == OP_LIST) { /* already a PUSHMARK there */
2698 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2699 ((LISTOP*)last)->op_first->op_sibling = first;
2700 if (!(first->op_flags & OPf_PARENS))
2701 last->op_flags &= ~OPf_PARENS;
2704 if (!(last->op_flags & OPf_KIDS)) {
2705 ((LISTOP*)last)->op_last = first;
2706 last->op_flags |= OPf_KIDS;
2708 first->op_sibling = ((LISTOP*)last)->op_first;
2709 ((LISTOP*)last)->op_first = first;
2711 last->op_flags |= OPf_KIDS;
2715 return newLISTOP(type, 0, first, last);
2723 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2726 Newxz(tk, 1, TOKEN);
2727 tk->tk_type = (OPCODE)optype;
2728 tk->tk_type = 12345;
2730 tk->tk_mad = madprop;
2735 Perl_token_free(pTHX_ TOKEN* tk)
2737 PERL_ARGS_ASSERT_TOKEN_FREE;
2739 if (tk->tk_type != 12345)
2741 mad_free(tk->tk_mad);
2746 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2751 PERL_ARGS_ASSERT_TOKEN_GETMAD;
2753 if (tk->tk_type != 12345) {
2754 Perl_warner(aTHX_ packWARN(WARN_MISC),
2755 "Invalid TOKEN object ignored");
2762 /* faked up qw list? */
2764 tm->mad_type == MAD_SV &&
2765 SvPVX((SV*)tm->mad_val)[0] == 'q')
2772 /* pretend constant fold didn't happen? */
2773 if (mp->mad_key == 'f' &&
2774 (o->op_type == OP_CONST ||
2775 o->op_type == OP_GV) )
2777 token_getmad(tk,(OP*)mp->mad_val,slot);
2791 if (mp->mad_key == 'X')
2792 mp->mad_key = slot; /* just change the first one */
2802 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
2811 /* pretend constant fold didn't happen? */
2812 if (mp->mad_key == 'f' &&
2813 (o->op_type == OP_CONST ||
2814 o->op_type == OP_GV) )
2816 op_getmad(from,(OP*)mp->mad_val,slot);
2823 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
2826 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
2832 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
2841 /* pretend constant fold didn't happen? */
2842 if (mp->mad_key == 'f' &&
2843 (o->op_type == OP_CONST ||
2844 o->op_type == OP_GV) )
2846 op_getmad(from,(OP*)mp->mad_val,slot);
2853 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
2856 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
2860 PerlIO_printf(PerlIO_stderr(),
2861 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
2867 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
2885 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
2889 addmad(tm, &(o->op_madprop), slot);
2893 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
2914 Perl_newMADsv(pTHX_ char key, SV* sv)
2916 PERL_ARGS_ASSERT_NEWMADSV;
2918 return newMADPROP(key, MAD_SV, sv, 0);
2922 Perl_newMADPROP(pTHX_ char key, char type, const void* val, I32 vlen)
2925 Newxz(mp, 1, MADPROP);
2928 mp->mad_vlen = vlen;
2929 mp->mad_type = type;
2931 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
2936 Perl_mad_free(pTHX_ MADPROP* mp)
2938 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
2942 mad_free(mp->mad_next);
2943 /* if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
2944 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
2945 switch (mp->mad_type) {
2949 Safefree((char*)mp->mad_val);
2952 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
2953 op_free((OP*)mp->mad_val);
2956 sv_free((SV*)mp->mad_val);
2959 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
2968 Perl_newNULLLIST(pTHX)
2970 return newOP(OP_STUB, 0);
2974 Perl_force_list(pTHX_ OP *o)
2976 if (!o || o->op_type != OP_LIST)
2977 o = newLISTOP(OP_LIST, 0, o, NULL);
2983 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2988 NewOp(1101, listop, 1, LISTOP);
2990 listop->op_type = (OPCODE)type;
2991 listop->op_ppaddr = PL_ppaddr[type];
2994 listop->op_flags = (U8)flags;
2998 else if (!first && last)
3001 first->op_sibling = last;
3002 listop->op_first = first;
3003 listop->op_last = last;
3004 if (type == OP_LIST) {
3005 OP* const pushop = newOP(OP_PUSHMARK, 0);
3006 pushop->op_sibling = first;
3007 listop->op_first = pushop;
3008 listop->op_flags |= OPf_KIDS;
3010 listop->op_last = pushop;
3013 return CHECKOP(type, listop);
3017 Perl_newOP(pTHX_ I32 type, I32 flags)
3021 NewOp(1101, o, 1, OP);
3022 o->op_type = (OPCODE)type;
3023 o->op_ppaddr = PL_ppaddr[type];
3024 o->op_flags = (U8)flags;
3026 o->op_latefreed = 0;
3030 o->op_private = (U8)(0 | (flags >> 8));
3031 if (PL_opargs[type] & OA_RETSCALAR)
3033 if (PL_opargs[type] & OA_TARGET)
3034 o->op_targ = pad_alloc(type, SVs_PADTMP);
3035 return CHECKOP(type, o);
3039 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
3045 first = newOP(OP_STUB, 0);
3046 if (PL_opargs[type] & OA_MARK)
3047 first = force_list(first);
3049 NewOp(1101, unop, 1, UNOP);
3050 unop->op_type = (OPCODE)type;
3051 unop->op_ppaddr = PL_ppaddr[type];
3052 unop->op_first = first;
3053 unop->op_flags = (U8)(flags | OPf_KIDS);
3054 unop->op_private = (U8)(1 | (flags >> 8));
3055 unop = (UNOP*) CHECKOP(type, unop);
3059 return fold_constants((OP *) unop);
3063 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3067 NewOp(1101, binop, 1, BINOP);
3070 first = newOP(OP_NULL, 0);
3072 binop->op_type = (OPCODE)type;
3073 binop->op_ppaddr = PL_ppaddr[type];
3074 binop->op_first = first;
3075 binop->op_flags = (U8)(flags | OPf_KIDS);
3078 binop->op_private = (U8)(1 | (flags >> 8));
3081 binop->op_private = (U8)(2 | (flags >> 8));
3082 first->op_sibling = last;
3085 binop = (BINOP*)CHECKOP(type, binop);
3086 if (binop->op_next || binop->op_type != (OPCODE)type)
3089 binop->op_last = binop->op_first->op_sibling;
3091 return fold_constants((OP *)binop);
3094 static int uvcompare(const void *a, const void *b)
3095 __attribute__nonnull__(1)
3096 __attribute__nonnull__(2)
3097 __attribute__pure__;
3098 static int uvcompare(const void *a, const void *b)
3100 if (*((const UV *)a) < (*(const UV *)b))
3102 if (*((const UV *)a) > (*(const UV *)b))
3104 if (*((const UV *)a+1) < (*(const UV *)b+1))
3106 if (*((const UV *)a+1) > (*(const UV *)b+1))
3112 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
3115 SV * const tstr = ((SVOP*)expr)->op_sv;
3118 (repl->op_type == OP_NULL)
3119 ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
3121 ((SVOP*)repl)->op_sv;
3124 const U8 *t = (U8*)SvPV_const(tstr, tlen);
3125 const U8 *r = (U8*)SvPV_const(rstr, rlen);
3129 register short *tbl;
3131 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
3132 const I32 squash = o->op_private & OPpTRANS_SQUASH;
3133 I32 del = o->op_private & OPpTRANS_DELETE;
3136 PERL_ARGS_ASSERT_PMTRANS;
3138 PL_hints |= HINT_BLOCK_SCOPE;
3141 o->op_private |= OPpTRANS_FROM_UTF;
3144 o->op_private |= OPpTRANS_TO_UTF;
3146 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
3147 SV* const listsv = newSVpvs("# comment\n");
3149 const U8* tend = t + tlen;
3150 const U8* rend = r + rlen;
3164 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
3165 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
3168 const U32 flags = UTF8_ALLOW_DEFAULT;
3172 t = tsave = bytes_to_utf8(t, &len);
3175 if (!to_utf && rlen) {
3177 r = rsave = bytes_to_utf8(r, &len);
3181 /* There are several snags with this code on EBCDIC:
3182 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
3183 2. scan_const() in toke.c has encoded chars in native encoding which makes
3184 ranges at least in EBCDIC 0..255 range the bottom odd.
3188 U8 tmpbuf[UTF8_MAXBYTES+1];
3191 Newx(cp, 2*tlen, UV);
3193 transv = newSVpvs("");
3195 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3197 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
3199 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3203 cp[2*i+1] = cp[2*i];
3207 qsort(cp, i, 2*sizeof(UV), uvcompare);
3208 for (j = 0; j < i; j++) {
3210 diff = val - nextmin;
3212 t = uvuni_to_utf8(tmpbuf,nextmin);
3213 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3215 U8 range_mark = UTF_TO_NATIVE(0xff);
3216 t = uvuni_to_utf8(tmpbuf, val - 1);
3217 sv_catpvn(transv, (char *)&range_mark, 1);
3218 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3225 t = uvuni_to_utf8(tmpbuf,nextmin);
3226 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3228 U8 range_mark = UTF_TO_NATIVE(0xff);
3229 sv_catpvn(transv, (char *)&range_mark, 1);
3231 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
3232 UNICODE_ALLOW_SUPER);
3233 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3234 t = (const U8*)SvPVX_const(transv);
3235 tlen = SvCUR(transv);
3239 else if (!rlen && !del) {
3240 r = t; rlen = tlen; rend = tend;
3243 if ((!rlen && !del) || t == r ||
3244 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
3246 o->op_private |= OPpTRANS_IDENTICAL;
3250 while (t < tend || tfirst <= tlast) {
3251 /* see if we need more "t" chars */
3252 if (tfirst > tlast) {
3253 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3255 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
3257 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3264 /* now see if we need more "r" chars */
3265 if (rfirst > rlast) {
3267 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3269 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
3271 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3280 rfirst = rlast = 0xffffffff;
3284 /* now see which range will peter our first, if either. */
3285 tdiff = tlast - tfirst;
3286 rdiff = rlast - rfirst;
3293 if (rfirst == 0xffffffff) {
3294 diff = tdiff; /* oops, pretend rdiff is infinite */
3296 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
3297 (long)tfirst, (long)tlast);
3299 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
3303 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
3304 (long)tfirst, (long)(tfirst + diff),
3307 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3308 (long)tfirst, (long)rfirst);
3310 if (rfirst + diff > max)
3311 max = rfirst + diff;
3313 grows = (tfirst < rfirst &&
3314 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3326 else if (max > 0xff)
3331 PerlMemShared_free(cPVOPo->op_pv);
3332 cPVOPo->op_pv = NULL;
3334 swash = (SV*)swash_init("utf8", "", listsv, bits, none);
3336 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
3337 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
3338 PAD_SETSV(cPADOPo->op_padix, swash);
3341 cSVOPo->op_sv = swash;
3343 SvREFCNT_dec(listsv);
3344 SvREFCNT_dec(transv);
3346 if (!del && havefinal && rlen)
3347 (void)hv_store((HV*)SvRV(swash), "FINAL", 5,
3348 newSVuv((UV)final), 0);
3351 o->op_private |= OPpTRANS_GROWS;
3357 op_getmad(expr,o,'e');
3358 op_getmad(repl,o,'r');
3366 tbl = (short*)cPVOPo->op_pv;
3368 Zero(tbl, 256, short);
3369 for (i = 0; i < (I32)tlen; i++)
3371 for (i = 0, j = 0; i < 256; i++) {
3373 if (j >= (I32)rlen) {
3382 if (i < 128 && r[j] >= 128)
3392 o->op_private |= OPpTRANS_IDENTICAL;
3394 else if (j >= (I32)rlen)
3399 PerlMemShared_realloc(tbl,
3400 (0x101+rlen-j) * sizeof(short));
3401 cPVOPo->op_pv = (char*)tbl;
3403 tbl[0x100] = (short)(rlen - j);
3404 for (i=0; i < (I32)rlen - j; i++)
3405 tbl[0x101+i] = r[j+i];
3409 if (!rlen && !del) {
3412 o->op_private |= OPpTRANS_IDENTICAL;
3414 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3415 o->op_private |= OPpTRANS_IDENTICAL;
3417 for (i = 0; i < 256; i++)
3419 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3420 if (j >= (I32)rlen) {
3422 if (tbl[t[i]] == -1)
3428 if (tbl[t[i]] == -1) {
3429 if (t[i] < 128 && r[j] >= 128)
3436 o->op_private |= OPpTRANS_GROWS;
3438 op_getmad(expr,o,'e');
3439 op_getmad(repl,o,'r');
3449 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3454 NewOp(1101, pmop, 1, PMOP);
3455 pmop->op_type = (OPCODE)type;
3456 pmop->op_ppaddr = PL_ppaddr[type];
3457 pmop->op_flags = (U8)flags;
3458 pmop->op_private = (U8)(0 | (flags >> 8));
3460 if (PL_hints & HINT_RE_TAINT)
3461 pmop->op_pmflags |= PMf_RETAINT;
3462 if (PL_hints & HINT_LOCALE)
3463 pmop->op_pmflags |= PMf_LOCALE;
3467 assert(SvPOK(PL_regex_pad[0]));
3468 if (SvCUR(PL_regex_pad[0])) {
3469 /* Pop off the "packed" IV from the end. */
3470 SV *const repointer_list = PL_regex_pad[0];
3471 const char *p = SvEND(repointer_list) - sizeof(IV);
3472 const IV offset = *((IV*)p);
3474 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
3476 SvEND_set(repointer_list, p);
3478 pmop->op_pmoffset = offset;
3479 /* This slot should be free, so assert this: */
3480 assert(PL_regex_pad[offset] == &PL_sv_undef);
3482 SV * const repointer = &PL_sv_undef;
3483 av_push(PL_regex_padav, repointer);
3484 pmop->op_pmoffset = av_len(PL_regex_padav);
3485 PL_regex_pad = AvARRAY(PL_regex_padav);
3489 return CHECKOP(type, pmop);
3492 /* Given some sort of match op o, and an expression expr containing a
3493 * pattern, either compile expr into a regex and attach it to o (if it's
3494 * constant), or convert expr into a runtime regcomp op sequence (if it's
3497 * isreg indicates that the pattern is part of a regex construct, eg
3498 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3499 * split "pattern", which aren't. In the former case, expr will be a list
3500 * if the pattern contains more than one term (eg /a$b/) or if it contains
3501 * a replacement, ie s/// or tr///.
3505 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
3510 I32 repl_has_vars = 0;
3514 PERL_ARGS_ASSERT_PMRUNTIME;
3516 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
3517 /* last element in list is the replacement; pop it */
3519 repl = cLISTOPx(expr)->op_last;
3520 kid = cLISTOPx(expr)->op_first;
3521 while (kid->op_sibling != repl)
3522 kid = kid->op_sibling;
3523 kid->op_sibling = NULL;
3524 cLISTOPx(expr)->op_last = kid;
3527 if (isreg && expr->op_type == OP_LIST &&
3528 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3530 /* convert single element list to element */
3531 OP* const oe = expr;
3532 expr = cLISTOPx(oe)->op_first->op_sibling;
3533 cLISTOPx(oe)->op_first->op_sibling = NULL;
3534 cLISTOPx(oe)->op_last = NULL;
3538 if (o->op_type == OP_TRANS) {
3539 return pmtrans(o, expr, repl);
3542 reglist = isreg && expr->op_type == OP_LIST;
3546 PL_hints |= HINT_BLOCK_SCOPE;
3549 if (expr->op_type == OP_CONST) {
3550 SV *pat = ((SVOP*)expr)->op_sv;
3551 U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
3553 if (o->op_flags & OPf_SPECIAL)
3554 pm_flags |= RXf_SPLIT;
3557 assert (SvUTF8(pat));
3558 } else if (SvUTF8(pat)) {
3559 /* Not doing UTF-8, despite what the SV says. Is this only if we're
3560 trapped in use 'bytes'? */
3561 /* Make a copy of the octet sequence, but without the flag on, as
3562 the compiler now honours the SvUTF8 flag on pat. */
3564 const char *const p = SvPV(pat, len);
3565 pat = newSVpvn_flags(p, len, SVs_TEMP);
3568 PM_SETRE(pm, CALLREGCOMP(pat, pm_flags));
3571 op_getmad(expr,(OP*)pm,'e');
3577 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3578 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3580 : OP_REGCMAYBE),0,expr);
3582 NewOp(1101, rcop, 1, LOGOP);
3583 rcop->op_type = OP_REGCOMP;
3584 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3585 rcop->op_first = scalar(expr);
3586 rcop->op_flags |= OPf_KIDS
3587 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3588 | (reglist ? OPf_STACKED : 0);
3589 rcop->op_private = 1;
3592 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3594 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
3597 /* establish postfix order */
3598 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3600 rcop->op_next = expr;
3601 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3604 rcop->op_next = LINKLIST(expr);
3605 expr->op_next = (OP*)rcop;
3608 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3613 if (pm->op_pmflags & PMf_EVAL) {
3615 if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
3616 CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
3618 else if (repl->op_type == OP_CONST)
3622 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3623 if (curop->op_type == OP_SCOPE
3624 || curop->op_type == OP_LEAVE
3625 || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
3626 if (curop->op_type == OP_GV) {
3627 GV * const gv = cGVOPx_gv(curop);
3629 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3632 else if (curop->op_type == OP_RV2CV)
3634 else if (curop->op_type == OP_RV2SV ||
3635 curop->op_type == OP_RV2AV ||
3636 curop->op_type == OP_RV2HV ||
3637 curop->op_type == OP_RV2GV) {
3638 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3641 else if (curop->op_type == OP_PADSV ||
3642 curop->op_type == OP_PADAV ||
3643 curop->op_type == OP_PADHV ||
3644 curop->op_type == OP_PADANY)
3648 else if (curop->op_type == OP_PUSHRE)
3649 NOOP; /* Okay here, dangerous in newASSIGNOP */
3659 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
3661 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3662 prepend_elem(o->op_type, scalar(repl), o);
3665 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3666 pm->op_pmflags |= PMf_MAYBE_CONST;
3668 NewOp(1101, rcop, 1, LOGOP);
3669 rcop->op_type = OP_SUBSTCONT;
3670 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3671 rcop->op_first = scalar(repl);
3672 rcop->op_flags |= OPf_KIDS;
3673 rcop->op_private = 1;
3676 /* establish postfix order */
3677 rcop->op_next = LINKLIST(repl);
3678 repl->op_next = (OP*)rcop;
3680 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
3681 assert(!(pm->op_pmflags & PMf_ONCE));
3682 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
3691 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3696 PERL_ARGS_ASSERT_NEWSVOP;
3698 NewOp(1101, svop, 1, SVOP);
3699 svop->op_type = (OPCODE)type;
3700 svop->op_ppaddr = PL_ppaddr[type];
3702 svop->op_next = (OP*)svop;
3703 svop->op_flags = (U8)flags;
3704 if (PL_opargs[type] & OA_RETSCALAR)
3706 if (PL_opargs[type] & OA_TARGET)
3707 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3708 return CHECKOP(type, svop);
3713 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3718 PERL_ARGS_ASSERT_NEWPADOP;
3720 NewOp(1101, padop, 1, PADOP);
3721 padop->op_type = (OPCODE)type;
3722 padop->op_ppaddr = PL_ppaddr[type];
3723 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3724 SvREFCNT_dec(PAD_SVl(padop->op_padix));
3725 PAD_SETSV(padop->op_padix, sv);
3728 padop->op_next = (OP*)padop;
3729 padop->op_flags = (U8)flags;
3730 if (PL_opargs[type] & OA_RETSCALAR)
3732 if (PL_opargs[type] & OA_TARGET)
3733 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3734 return CHECKOP(type, padop);
3739 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3743 PERL_ARGS_ASSERT_NEWGVOP;
3747 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3749 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3754 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3758 NewOp(1101, pvop, 1, PVOP);
3759 pvop->op_type = (OPCODE)type;
3760 pvop->op_ppaddr = PL_ppaddr[type];
3762 pvop->op_next = (OP*)pvop;
3763 pvop->op_flags = (U8)flags;
3764 if (PL_opargs[type] & OA_RETSCALAR)
3766 if (PL_opargs[type] & OA_TARGET)
3767 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3768 return CHECKOP(type, pvop);
3776 Perl_package(pTHX_ OP *o)
3779 SV *const sv = cSVOPo->op_sv;
3784 PERL_ARGS_ASSERT_PACKAGE;
3786 save_hptr(&PL_curstash);
3787 save_item(PL_curstname);
3789 PL_curstash = gv_stashsv(sv, GV_ADD);
3791 sv_setsv(PL_curstname, sv);
3793 PL_hints |= HINT_BLOCK_SCOPE;
3794 PL_parser->copline = NOLINE;
3795 PL_parser->expect = XSTATE;
3800 if (!PL_madskills) {
3805 pegop = newOP(OP_NULL,0);
3806 op_getmad(o,pegop,'P');
3816 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3823 OP *pegop = newOP(OP_NULL,0);
3826 PERL_ARGS_ASSERT_UTILIZE;
3828 if (idop->op_type != OP_CONST)
3829 Perl_croak(aTHX_ "Module name must be constant");
3832 op_getmad(idop,pegop,'U');
3837 SV * const vesv = ((SVOP*)version)->op_sv;
3840 op_getmad(version,pegop,'V');
3841 if (!arg && !SvNIOKp(vesv)) {
3848 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3849 Perl_croak(aTHX_ "Version number must be constant number");
3851 /* Make copy of idop so we don't free it twice */
3852 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3854 /* Fake up a method call to VERSION */
3855 meth = newSVpvs_share("VERSION");
3856 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3857 append_elem(OP_LIST,
3858 prepend_elem(OP_LIST, pack, list(version)),
3859 newSVOP(OP_METHOD_NAMED, 0, meth)));
3863 /* Fake up an import/unimport */
3864 if (arg && arg->op_type == OP_STUB) {
3866 op_getmad(arg,pegop,'S');
3867 imop = arg; /* no import on explicit () */
3869 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3870 imop = NULL; /* use 5.0; */
3872 idop->op_private |= OPpCONST_NOVER;
3878 op_getmad(arg,pegop,'A');
3880 /* Make copy of idop so we don't free it twice */
3881 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3883 /* Fake up a method call to import/unimport */
3885 ? newSVpvs_share("import") : newSVpvs_share("unimport");
3886 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3887 append_elem(OP_LIST,
3888 prepend_elem(OP_LIST, pack, list(arg)),
3889 newSVOP(OP_METHOD_NAMED, 0, meth)));
3892 /* Fake up the BEGIN {}, which does its thing immediately. */
3894 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
3897 append_elem(OP_LINESEQ,
3898 append_elem(OP_LINESEQ,
3899 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
3900 newSTATEOP(0, NULL, veop)),
3901 newSTATEOP(0, NULL, imop) ));
3903 /* The "did you use incorrect case?" warning used to be here.
3904 * The problem is that on case-insensitive filesystems one
3905 * might get false positives for "use" (and "require"):
3906 * "use Strict" or "require CARP" will work. This causes
3907 * portability problems for the script: in case-strict
3908 * filesystems the script will stop working.
3910 * The "incorrect case" warning checked whether "use Foo"
3911 * imported "Foo" to your namespace, but that is wrong, too:
3912 * there is no requirement nor promise in the language that
3913 * a Foo.pm should or would contain anything in package "Foo".
3915 * There is very little Configure-wise that can be done, either:
3916 * the case-sensitivity of the build filesystem of Perl does not
3917 * help in guessing the case-sensitivity of the runtime environment.
3920 PL_hints |= HINT_BLOCK_SCOPE;
3921 PL_parser->copline = NOLINE;
3922 PL_parser->expect = XSTATE;
3923 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3926 if (!PL_madskills) {
3927 /* FIXME - don't allocate pegop if !PL_madskills */
3936 =head1 Embedding Functions
3938 =for apidoc load_module
3940 Loads the module whose name is pointed to by the string part of name.
3941 Note that the actual module name, not its filename, should be given.
3942 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3943 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3944 (or 0 for no flags). ver, if specified, provides version semantics
3945 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3946 arguments can be used to specify arguments to the module's import()
3947 method, similar to C<use Foo::Bar VERSION LIST>.
3952 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3956 PERL_ARGS_ASSERT_LOAD_MODULE;
3958 va_start(args, ver);
3959 vload_module(flags, name, ver, &args);
3963 #ifdef PERL_IMPLICIT_CONTEXT
3965 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3969 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
3970 va_start(args, ver);
3971 vload_module(flags, name, ver, &args);
3977 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3981 OP * const modname = newSVOP(OP_CONST, 0, name);
3983 PERL_ARGS_ASSERT_VLOAD_MODULE;
3985 modname->op_private |= OPpCONST_BARE;
3987 veop = newSVOP(OP_CONST, 0, ver);
3991 if (flags & PERL_LOADMOD_NOIMPORT) {
3992 imop = sawparens(newNULLLIST());
3994 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3995 imop = va_arg(*args, OP*);
4000 sv = va_arg(*args, SV*);
4002 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
4003 sv = va_arg(*args, SV*);
4007 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
4008 * that it has a PL_parser to play with while doing that, and also
4009 * that it doesn't mess with any existing parser, by creating a tmp
4010 * new parser with lex_start(). This won't actually be used for much,
4011 * since pp_require() will create another parser for the real work. */
4014 SAVEVPTR(PL_curcop);
4015 lex_start(NULL, NULL, FALSE);
4016 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
4017 veop, modname, imop);
4022 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
4028 PERL_ARGS_ASSERT_DOFILE;
4030 if (!force_builtin) {
4031 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
4032 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
4033 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
4034 gv = gvp ? *gvp : NULL;
4038 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
4039 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
4040 append_elem(OP_LIST, term,
4041 scalar(newUNOP(OP_RV2CV, 0,
4042 newGVOP(OP_GV, 0, gv))))));
4045 doop = newUNOP(OP_DOFILE, 0, scalar(term));
4051 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
4053 return newBINOP(OP_LSLICE, flags,
4054 list(force_list(subscript)),
4055 list(force_list(listval)) );
4059 S_is_list_assignment(pTHX_ register const OP *o)
4067 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
4068 o = cUNOPo->op_first;
4070 flags = o->op_flags;
4072 if (type == OP_COND_EXPR) {
4073 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
4074 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
4079 yyerror("Assignment to both a list and a scalar");
4083 if (type == OP_LIST &&
4084 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
4085 o->op_private & OPpLVAL_INTRO)
4088 if (type == OP_LIST || flags & OPf_PARENS ||
4089 type == OP_RV2AV || type == OP_RV2HV ||
4090 type == OP_ASLICE || type == OP_HSLICE)
4093 if (type == OP_PADAV || type == OP_PADHV)
4096 if (type == OP_RV2SV)
4103 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
4109 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
4110 return newLOGOP(optype, 0,
4111 mod(scalar(left), optype),
4112 newUNOP(OP_SASSIGN, 0, scalar(right)));
4115 return newBINOP(optype, OPf_STACKED,
4116 mod(scalar(left), optype), scalar(right));
4120 if (is_list_assignment(left)) {
4121 static const char no_list_state[] = "Initialization of state variables"
4122 " in list context currently forbidden";
4124 bool maybe_common_vars = TRUE;
4127 /* Grandfathering $[ assignment here. Bletch.*/
4128 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
4129 PL_eval_start = (left->op_type == OP_CONST) ? right : NULL;
4130 left = mod(left, OP_AASSIGN);
4133 else if (left->op_type == OP_CONST) {
4135 /* Result of assignment is always 1 (or we'd be dead already) */
4136 return newSVOP(OP_CONST, 0, newSViv(1));
4138 curop = list(force_list(left));
4139 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
4140 o->op_private = (U8)(0 | (flags >> 8));
4142 if ((left->op_type == OP_LIST
4143 || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
4145 OP* lop = ((LISTOP*)left)->op_first;
4146 maybe_common_vars = FALSE;
4148 if (lop->op_type == OP_PADSV ||
4149 lop->op_type == OP_PADAV ||
4150 lop->op_type == OP_PADHV ||
4151 lop->op_type == OP_PADANY) {
4152 if (!(lop->op_private & OPpLVAL_INTRO))
4153 maybe_common_vars = TRUE;
4155 if (lop->op_private & OPpPAD_STATE) {
4156 if (left->op_private & OPpLVAL_INTRO) {
4157 /* Each variable in state($a, $b, $c) = ... */
4160 /* Each state variable in
4161 (state $a, my $b, our $c, $d, undef) = ... */
4163 yyerror(no_list_state);
4165 /* Each my variable in
4166 (state $a, my $b, our $c, $d, undef) = ... */
4168 } else if (lop->op_type == OP_UNDEF ||
4169 lop->op_type == OP_PUSHMARK) {
4170 /* undef may be interesting in
4171 (state $a, undef, state $c) */
4173 /* Other ops in the list. */
4174 maybe_common_vars = TRUE;
4176 lop = lop->op_sibling;
4179 else if ((left->op_private & OPpLVAL_INTRO)
4180 && ( left->op_type == OP_PADSV
4181 || left->op_type == OP_PADAV
4182 || left->op_type == OP_PADHV
4183 || left->op_type == OP_PADANY))
4185 maybe_common_vars = FALSE;
4186 if (left->op_private & OPpPAD_STATE) {
4187 /* All single variable list context state assignments, hence
4197 yyerror(no_list_state);
4201 /* PL_generation sorcery:
4202 * an assignment like ($a,$b) = ($c,$d) is easier than
4203 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
4204 * To detect whether there are common vars, the global var
4205 * PL_generation is incremented for each assign op we compile.
4206 * Then, while compiling the assign op, we run through all the
4207 * variables on both sides of the assignment, setting a spare slot
4208 * in each of them to PL_generation. If any of them already have
4209 * that value, we know we've got commonality. We could use a
4210 * single bit marker, but then we'd have to make 2 passes, first
4211 * to clear the flag, then to test and set it. To find somewhere
4212 * to store these values, evil chicanery is done with SvUVX().
4215 if (maybe_common_vars) {
4218 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4219 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
4220 if (curop->op_type == OP_GV) {
4221 GV *gv = cGVOPx_gv(curop);
4223 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4225 GvASSIGN_GENERATION_set(gv, PL_generation);
4227 else if (curop->op_type == OP_PADSV ||
4228 curop->op_type == OP_PADAV ||
4229 curop->op_type == OP_PADHV ||
4230 curop->op_type == OP_PADANY)
4232 if (PAD_COMPNAME_GEN(curop->op_targ)
4233 == (STRLEN)PL_generation)
4235 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
4238 else if (curop->op_type == OP_RV2CV)
4240 else if (curop->op_type == OP_RV2SV ||
4241 curop->op_type == OP_RV2AV ||
4242 curop->op_type == OP_RV2HV ||
4243 curop->op_type == OP_RV2GV) {
4244 if (lastop->op_type != OP_GV) /* funny deref? */
4247 else if (curop->op_type == OP_PUSHRE) {
4249 if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
4250 GV *const gv = (GV*)PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff);
4252 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4254 GvASSIGN_GENERATION_set(gv, PL_generation);
4258 = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
4261 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4263 GvASSIGN_GENERATION_set(gv, PL_generation);
4273 o->op_private |= OPpASSIGN_COMMON;
4276 if (right && right->op_type == OP_SPLIT && !PL_madskills) {
4277 OP* tmpop = ((LISTOP*)right)->op_first;
4278 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
4279 PMOP * const pm = (PMOP*)tmpop;
4280 if (left->op_type == OP_RV2AV &&
4281 !(left->op_private & OPpLVAL_INTRO) &&
4282 !(o->op_private & OPpASSIGN_COMMON) )
4284 tmpop = ((UNOP*)left)->op_first;
4285 if (tmpop->op_type == OP_GV
4287 && !pm->op_pmreplrootu.op_pmtargetoff
4289 && !pm->op_pmreplrootu.op_pmtargetgv
4293 pm->op_pmreplrootu.op_pmtargetoff
4294 = cPADOPx(tmpop)->op_padix;
4295 cPADOPx(tmpop)->op_padix = 0; /* steal it */
4297 pm->op_pmreplrootu.op_pmtargetgv
4298 = (GV*)cSVOPx(tmpop)->op_sv;
4299 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
4301 pm->op_pmflags |= PMf_ONCE;
4302 tmpop = cUNOPo->op_first; /* to list (nulled) */
4303 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
4304 tmpop->op_sibling = NULL; /* don't free split */
4305 right->op_next = tmpop->op_next; /* fix starting loc */
4306 op_free(o); /* blow off assign */
4307 right->op_flags &= ~OPf_WANT;
4308 /* "I don't know and I don't care." */
4313 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
4314 ((LISTOP*)right)->op_last->op_type == OP_CONST)
4316 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
4318 sv_setiv(sv, PL_modcount+1);
4326 right = newOP(OP_UNDEF, 0);
4327 if (right->op_type == OP_READLINE) {
4328 right->op_flags |= OPf_STACKED;
4329 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
4332 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
4333 o = newBINOP(OP_SASSIGN, flags,
4334 scalar(right), mod(scalar(left), OP_SASSIGN) );
4340 o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
4341 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 CopLABEL_set(cop, label);
4373 PL_hints |= HINT_BLOCK_SCOPE;
4376 /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
4377 CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
4379 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
4380 cop->cop_hints_hash = PL_curcop->cop_hints_hash;
4381 if (cop->cop_hints_hash) {
4383 cop->cop_hints_hash->refcounted_he_refcnt++;
4384 HINTS_REFCNT_UNLOCK;
4387 if (PL_parser && PL_parser->copline == NOLINE)
4388 CopLINE_set(cop, CopLINE(PL_curcop));
4390 CopLINE_set(cop, PL_parser->copline);
4392 PL_parser->copline = NOLINE;
4395 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
4397 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
4399 CopSTASH_set(cop, PL_curstash);
4401 if (PERLDB_LINE && PL_curstash != PL_debstash) {
4402 AV *av = CopFILEAVx(PL_curcop);
4404 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
4405 if (svp && *svp != &PL_sv_undef ) {
4406 (void)SvIOK_on(*svp);
4407 SvIV_set(*svp, PTR2IV(cop));
4412 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
4417 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
4421 PERL_ARGS_ASSERT_NEWLOGOP;
4423 return new_logop(type, flags, &first, &other);
4427 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
4432 OP *first = *firstp;
4433 OP * const other = *otherp;
4435 PERL_ARGS_ASSERT_NEW_LOGOP;
4437 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
4438 return newBINOP(type, flags, scalar(first), scalar(other));
4440 scalarboolean(first);
4441 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
4442 if (first->op_type == OP_NOT
4443 && (first->op_flags & OPf_SPECIAL)
4444 && (first->op_flags & OPf_KIDS)
4446 if (type == OP_AND || type == OP_OR) {
4452 first = *firstp = cUNOPo->op_first;
4454 first->op_next = o->op_next;
4455 cUNOPo->op_first = NULL;
4459 if (first->op_type == OP_CONST) {
4460 if (first->op_private & OPpCONST_STRICT)
4461 no_bareword_allowed(first);
4462 else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
4463 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
4464 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
4465 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
4466 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
4468 if (other->op_type == OP_CONST)
4469 other->op_private |= OPpCONST_SHORTCIRCUIT;
4471 OP *newop = newUNOP(OP_NULL, 0, other);
4472 op_getmad(first, newop, '1');
4473 newop->op_targ = type; /* set "was" field */
4480 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
4481 const OP *o2 = other;
4482 if ( ! (o2->op_type == OP_LIST
4483 && (( o2 = cUNOPx(o2)->op_first))
4484 && o2->op_type == OP_PUSHMARK
4485 && (( o2 = o2->op_sibling)) )
4488 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
4489 || o2->op_type == OP_PADHV)
4490 && o2->op_private & OPpLVAL_INTRO
4491 && !(o2->op_private & OPpPAD_STATE)
4492 && ckWARN(WARN_DEPRECATED))
4494 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4495 "Deprecated use of my() in false conditional");
4499 if (first->op_type == OP_CONST)
4500 first->op_private |= OPpCONST_SHORTCIRCUIT;
4502 first = newUNOP(OP_NULL, 0, first);
4503 op_getmad(other, first, '2');
4504 first->op_targ = type; /* set "was" field */
4511 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
4512 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
4514 const OP * const k1 = ((UNOP*)first)->op_first;
4515 const OP * const k2 = k1->op_sibling;
4517 switch (first->op_type)
4520 if (k2 && k2->op_type == OP_READLINE
4521 && (k2->op_flags & OPf_STACKED)
4522 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4524 warnop = k2->op_type;
4529 if (k1->op_type == OP_READDIR
4530 || k1->op_type == OP_GLOB
4531 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4532 || k1->op_type == OP_EACH)
4534 warnop = ((k1->op_type == OP_NULL)
4535 ? (OPCODE)k1->op_targ : k1->op_type);
4540 const line_t oldline = CopLINE(PL_curcop);
4541 CopLINE_set(PL_curcop, PL_parser->copline);
4542 Perl_warner(aTHX_ packWARN(WARN_MISC),
4543 "Value of %s%s can be \"0\"; test with defined()",
4545 ((warnop == OP_READLINE || warnop == OP_GLOB)
4546 ? " construct" : "() operator"));
4547 CopLINE_set(PL_curcop, oldline);
4554 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
4555 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
4557 NewOp(1101, logop, 1, LOGOP);
4559 logop->op_type = (OPCODE)type;
4560 logop->op_ppaddr = PL_ppaddr[type];
4561 logop->op_first = first;
4562 logop->op_flags = (U8)(flags | OPf_KIDS);
4563 logop->op_other = LINKLIST(other);
4564 logop->op_private = (U8)(1 | (flags >> 8));
4566 /* establish postfix order */
4567 logop->op_next = LINKLIST(first);
4568 first->op_next = (OP*)logop;
4569 first->op_sibling = other;
4571 CHECKOP(type,logop);
4573 o = newUNOP(OP_NULL, 0, (OP*)logop);
4580 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
4587 PERL_ARGS_ASSERT_NEWCONDOP;
4590 return newLOGOP(OP_AND, 0, first, trueop);
4592 return newLOGOP(OP_OR, 0, first, falseop);
4594 scalarboolean(first);
4595 if (first->op_type == OP_CONST) {
4596 /* Left or right arm of the conditional? */
4597 const bool left = SvTRUE(((SVOP*)first)->op_sv);
4598 OP *live = left ? trueop : falseop;
4599 OP *const dead = left ? falseop : trueop;
4600 if (first->op_private & OPpCONST_BARE &&
4601 first->op_private & OPpCONST_STRICT) {
4602 no_bareword_allowed(first);
4605 /* This is all dead code when PERL_MAD is not defined. */
4606 live = newUNOP(OP_NULL, 0, live);
4607 op_getmad(first, live, 'C');
4608 op_getmad(dead, live, left ? 'e' : 't');
4615 NewOp(1101, logop, 1, LOGOP);
4616 logop->op_type = OP_COND_EXPR;
4617 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4618 logop->op_first = first;
4619 logop->op_flags = (U8)(flags | OPf_KIDS);
4620 logop->op_private = (U8)(1 | (flags >> 8));
4621 logop->op_other = LINKLIST(trueop);
4622 logop->op_next = LINKLIST(falseop);
4624 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
4627 /* establish postfix order */
4628 start = LINKLIST(first);
4629 first->op_next = (OP*)logop;
4631 first->op_sibling = trueop;
4632 trueop->op_sibling = falseop;
4633 o = newUNOP(OP_NULL, 0, (OP*)logop);
4635 trueop->op_next = falseop->op_next = o;
4642 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4651 PERL_ARGS_ASSERT_NEWRANGE;
4653 NewOp(1101, range, 1, LOGOP);
4655 range->op_type = OP_RANGE;
4656 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4657 range->op_first = left;
4658 range->op_flags = OPf_KIDS;
4659 leftstart = LINKLIST(left);
4660 range->op_other = LINKLIST(right);
4661 range->op_private = (U8)(1 | (flags >> 8));
4663 left->op_sibling = right;
4665 range->op_next = (OP*)range;
4666 flip = newUNOP(OP_FLIP, flags, (OP*)range);
4667 flop = newUNOP(OP_FLOP, 0, flip);
4668 o = newUNOP(OP_NULL, 0, flop);
4670 range->op_next = leftstart;
4672 left->op_next = flip;
4673 right->op_next = flop;
4675 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4676 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4677 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4678 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4680 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4681 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4684 if (!flip->op_private || !flop->op_private)
4685 linklist(o); /* blow off optimizer unless constant */
4691 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4696 const bool once = block && block->op_flags & OPf_SPECIAL &&
4697 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4699 PERL_UNUSED_ARG(debuggable);
4702 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4703 return block; /* do {} while 0 does once */
4704 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4705 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4706 expr = newUNOP(OP_DEFINED, 0,
4707 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4708 } else if (expr->op_flags & OPf_KIDS) {
4709 const OP * const k1 = ((UNOP*)expr)->op_first;
4710 const OP * const k2 = k1 ? k1->op_sibling : NULL;
4711 switch (expr->op_type) {
4713 if (k2 && k2->op_type == OP_READLINE
4714 && (k2->op_flags & OPf_STACKED)
4715 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4716 expr = newUNOP(OP_DEFINED, 0, expr);
4720 if (k1 && (k1->op_type == OP_READDIR
4721 || k1->op_type == OP_GLOB
4722 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4723 || k1->op_type == OP_EACH))
4724 expr = newUNOP(OP_DEFINED, 0, expr);
4730 /* if block is null, the next append_elem() would put UNSTACK, a scalar
4731 * op, in listop. This is wrong. [perl #27024] */
4733 block = newOP(OP_NULL, 0);
4734 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4735 o = new_logop(OP_AND, 0, &expr, &listop);
4738 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4740 if (once && o != listop)
4741 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4744 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
4746 o->op_flags |= flags;
4748 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4753 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
4754 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
4763 PERL_UNUSED_ARG(debuggable);
4766 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4767 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4768 expr = newUNOP(OP_DEFINED, 0,
4769 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4770 } else if (expr->op_flags & OPf_KIDS) {
4771 const OP * const k1 = ((UNOP*)expr)->op_first;
4772 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
4773 switch (expr->op_type) {
4775 if (k2 && k2->op_type == OP_READLINE
4776 && (k2->op_flags & OPf_STACKED)
4777 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4778 expr = newUNOP(OP_DEFINED, 0, expr);
4782 if (k1 && (k1->op_type == OP_READDIR
4783 || k1->op_type == OP_GLOB
4784 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4785 || k1->op_type == OP_EACH))
4786 expr = newUNOP(OP_DEFINED, 0, expr);
4793 block = newOP(OP_NULL, 0);
4794 else if (cont || has_my) {
4795 block = scope(block);
4799 next = LINKLIST(cont);
4802 OP * const unstack = newOP(OP_UNSTACK, 0);
4805 cont = append_elem(OP_LINESEQ, cont, unstack);
4809 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4811 redo = LINKLIST(listop);
4814 PL_parser->copline = (line_t)whileline;
4816 o = new_logop(OP_AND, 0, &expr, &listop);
4817 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4818 op_free(expr); /* oops, it's a while (0) */
4820 return NULL; /* listop already freed by new_logop */
4823 ((LISTOP*)listop)->op_last->op_next =
4824 (o == listop ? redo : LINKLIST(o));
4830 NewOp(1101,loop,1,LOOP);
4831 loop->op_type = OP_ENTERLOOP;
4832 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4833 loop->op_private = 0;
4834 loop->op_next = (OP*)loop;
4837 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4839 loop->op_redoop = redo;
4840 loop->op_lastop = o;
4841 o->op_private |= loopflags;
4844 loop->op_nextop = next;
4846 loop->op_nextop = o;
4848 o->op_flags |= flags;
4849 o->op_private |= (flags >> 8);
4854 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
4859 PADOFFSET padoff = 0;
4864 PERL_ARGS_ASSERT_NEWFOROP;
4867 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4868 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
4869 sv->op_type = OP_RV2GV;
4870 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4872 /* The op_type check is needed to prevent a possible segfault
4873 * if the loop variable is undeclared and 'strict vars' is in
4874 * effect. This is illegal but is nonetheless parsed, so we
4875 * may reach this point with an OP_CONST where we're expecting
4878 if (cUNOPx(sv)->op_first->op_type == OP_GV
4879 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
4880 iterpflags |= OPpITER_DEF;
4882 else if (sv->op_type == OP_PADSV) { /* private variable */
4883 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
4884 padoff = sv->op_targ;
4894 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4896 SV *const namesv = PAD_COMPNAME_SV(padoff);
4898 const char *const name = SvPV_const(namesv, len);
4900 if (len == 2 && name[0] == '$' && name[1] == '_')
4901 iterpflags |= OPpITER_DEF;
4905 const PADOFFSET offset = pad_findmy("$_");
4906 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
4907 sv = newGVOP(OP_GV, 0, PL_defgv);
4912 iterpflags |= OPpITER_DEF;
4914 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4915 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4916 iterflags |= OPf_STACKED;
4918 else if (expr->op_type == OP_NULL &&
4919 (expr->op_flags & OPf_KIDS) &&
4920 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4922 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4923 * set the STACKED flag to indicate that these values are to be
4924 * treated as min/max values by 'pp_iterinit'.
4926 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4927 LOGOP* const range = (LOGOP*) flip->op_first;
4928 OP* const left = range->op_first;
4929 OP* const right = left->op_sibling;
4932 range->op_flags &= ~OPf_KIDS;
4933 range->op_first = NULL;
4935 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4936 listop->op_first->op_next = range->op_next;
4937 left->op_next = range->op_other;
4938 right->op_next = (OP*)listop;
4939 listop->op_next = listop->op_first;
4942 op_getmad(expr,(OP*)listop,'O');
4946 expr = (OP*)(listop);
4948 iterflags |= OPf_STACKED;
4951 expr = mod(force_list(expr), OP_GREPSTART);
4954 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4955 append_elem(OP_LIST, expr, scalar(sv))));
4956 assert(!loop->op_next);
4957 /* for my $x () sets OPpLVAL_INTRO;
4958 * for our $x () sets OPpOUR_INTRO */
4959 loop->op_private = (U8)iterpflags;
4960 #ifdef PL_OP_SLAB_ALLOC
4963 NewOp(1234,tmp,1,LOOP);
4964 Copy(loop,tmp,1,LISTOP);
4965 S_op_destroy(aTHX_ (OP*)loop);
4969 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
4971 loop->op_targ = padoff;
4972 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
4974 op_getmad(madsv, (OP*)loop, 'v');
4975 PL_parser->copline = forline;
4976 return newSTATEOP(0, label, wop);
4980 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4985 PERL_ARGS_ASSERT_NEWLOOPEX;
4987 if (type != OP_GOTO || label->op_type == OP_CONST) {
4988 /* "last()" means "last" */
4989 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4990 o = newOP(type, OPf_SPECIAL);
4992 o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
4993 ? SvPV_nolen_const(((SVOP*)label)->op_sv)
4997 op_getmad(label,o,'L');
5003 /* Check whether it's going to be a goto &function */
5004 if (label->op_type == OP_ENTERSUB
5005 && !(label->op_flags & OPf_STACKED))
5006 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
5007 o = newUNOP(type, OPf_STACKED, label);
5009 PL_hints |= HINT_BLOCK_SCOPE;
5013 /* if the condition is a literal array or hash
5014 (or @{ ... } etc), make a reference to it.
5017 S_ref_array_or_hash(pTHX_ OP *cond)
5020 && (cond->op_type == OP_RV2AV
5021 || cond->op_type == OP_PADAV
5022 || cond->op_type == OP_RV2HV
5023 || cond->op_type == OP_PADHV))
5025 return newUNOP(OP_REFGEN,
5026 0, mod(cond, OP_REFGEN));
5032 /* These construct the optree fragments representing given()
5035 entergiven and enterwhen are LOGOPs; the op_other pointer
5036 points up to the associated leave op. We need this so we
5037 can put it in the context and make break/continue work.
5038 (Also, of course, pp_enterwhen will jump straight to
5039 op_other if the match fails.)
5043 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
5044 I32 enter_opcode, I32 leave_opcode,
5045 PADOFFSET entertarg)
5051 PERL_ARGS_ASSERT_NEWGIVWHENOP;
5053 NewOp(1101, enterop, 1, LOGOP);
5054 enterop->op_type = (optype)enter_opcode;
5055 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
5056 enterop->op_flags = (U8) OPf_KIDS;
5057 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
5058 enterop->op_private = 0;
5060 o = newUNOP(leave_opcode, 0, (OP *) enterop);
5063 enterop->op_first = scalar(cond);
5064 cond->op_sibling = block;
5066 o->op_next = LINKLIST(cond);
5067 cond->op_next = (OP *) enterop;
5070 /* This is a default {} block */
5071 enterop->op_first = block;
5072 enterop->op_flags |= OPf_SPECIAL;
5074 o->op_next = (OP *) enterop;
5077 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
5078 entergiven and enterwhen both
5081 enterop->op_next = LINKLIST(block);
5082 block->op_next = enterop->op_other = o;
5087 /* Does this look like a boolean operation? For these purposes
5088 a boolean operation is:
5089 - a subroutine call [*]
5090 - a logical connective
5091 - a comparison operator
5092 - a filetest operator, with the exception of -s -M -A -C
5093 - defined(), exists() or eof()
5094 - /$re/ or $foo =~ /$re/
5096 [*] possibly surprising
5099 S_looks_like_bool(pTHX_ const OP *o)
5103 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
5105 switch(o->op_type) {
5107 return looks_like_bool(cLOGOPo->op_first);
5111 looks_like_bool(cLOGOPo->op_first)
5112 && looks_like_bool(cLOGOPo->op_first->op_sibling));
5116 o->op_flags & OPf_KIDS
5117 && looks_like_bool(cUNOPo->op_first));
5121 case OP_NOT: case OP_XOR:
5122 /* Note that OP_DOR is not here */
5124 case OP_EQ: case OP_NE: case OP_LT:
5125 case OP_GT: case OP_LE: case OP_GE:
5127 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
5128 case OP_I_GT: case OP_I_LE: case OP_I_GE:
5130 case OP_SEQ: case OP_SNE: case OP_SLT:
5131 case OP_SGT: case OP_SLE: case OP_SGE:
5135 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
5136 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
5137 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
5138 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
5139 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
5140 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
5141 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
5142 case OP_FTTEXT: case OP_FTBINARY:
5144 case OP_DEFINED: case OP_EXISTS:
5145 case OP_MATCH: case OP_EOF:
5150 /* Detect comparisons that have been optimized away */
5151 if (cSVOPo->op_sv == &PL_sv_yes
5152 || cSVOPo->op_sv == &PL_sv_no)
5163 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
5166 PERL_ARGS_ASSERT_NEWGIVENOP;
5167 return newGIVWHENOP(
5168 ref_array_or_hash(cond),
5170 OP_ENTERGIVEN, OP_LEAVEGIVEN,
5174 /* If cond is null, this is a default {} block */
5176 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
5178 const bool cond_llb = (!cond || looks_like_bool(cond));
5181 PERL_ARGS_ASSERT_NEWWHENOP;
5186 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
5188 scalar(ref_array_or_hash(cond)));
5191 return newGIVWHENOP(
5193 append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
5194 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
5198 =for apidoc cv_undef
5200 Clear out all the active components of a CV. This can happen either
5201 by an explicit C<undef &foo>, or by the reference count going to zero.
5202 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
5203 children can still follow the full lexical scope chain.
5209 Perl_cv_undef(pTHX_ CV *cv)
5213 PERL_ARGS_ASSERT_CV_UNDEF;
5215 DEBUG_X(PerlIO_printf(Perl_debug_log,
5216 "CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n",
5217 PTR2UV(cv), PTR2UV(PL_comppad))
5221 if (CvFILE(cv) && !CvISXSUB(cv)) {
5222 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
5223 Safefree(CvFILE(cv));
5228 if (!CvISXSUB(cv) && CvROOT(cv)) {
5229 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
5230 Perl_croak(aTHX_ "Can't undef active subroutine");
5233 PAD_SAVE_SETNULLPAD();
5235 op_free(CvROOT(cv));
5240 SvPOK_off((SV*)cv); /* forget prototype */
5245 /* remove CvOUTSIDE unless this is an undef rather than a free */
5246 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
5247 if (!CvWEAKOUTSIDE(cv))
5248 SvREFCNT_dec(CvOUTSIDE(cv));
5249 CvOUTSIDE(cv) = NULL;
5252 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
5255 if (CvISXSUB(cv) && CvXSUB(cv)) {
5258 /* delete all flags except WEAKOUTSIDE */
5259 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
5263 Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
5266 PERL_ARGS_ASSERT_CV_CKPROTO_LEN;
5268 /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
5269 relying on SvCUR, and doubling up the buffer to hold CvFILE(). */
5270 if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
5271 || (p && (len != SvCUR(cv) /* Not the same length. */
5272 || memNE(p, SvPVX_const(cv), len))))
5273 && ckWARN_d(WARN_PROTOTYPE)) {
5274 SV* const msg = sv_newmortal();
5278 gv_efullname3(name = sv_newmortal(), gv, NULL);
5279 sv_setpvs(msg, "Prototype mismatch:");
5281 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
5283 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv));
5285 sv_catpvs(msg, ": none");
5286 sv_catpvs(msg, " vs ");
5288 Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
5290 sv_catpvs(msg, "none");
5291 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
5295 static void const_sv_xsub(pTHX_ CV* cv);
5299 =head1 Optree Manipulation Functions
5301 =for apidoc cv_const_sv
5303 If C<cv> is a constant sub eligible for inlining. returns the constant
5304 value returned by the sub. Otherwise, returns NULL.
5306 Constant subs can be created with C<newCONSTSUB> or as described in
5307 L<perlsub/"Constant Functions">.
5312 Perl_cv_const_sv(pTHX_ CV *cv)
5314 PERL_UNUSED_CONTEXT;
5317 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
5319 return CvCONST(cv) ? (SV*)CvXSUBANY(cv).any_ptr : NULL;
5322 /* op_const_sv: examine an optree to determine whether it's in-lineable.
5323 * Can be called in 3 ways:
5326 * look for a single OP_CONST with attached value: return the value
5328 * cv && CvCLONE(cv) && !CvCONST(cv)
5330 * examine the clone prototype, and if contains only a single
5331 * OP_CONST referencing a pad const, or a single PADSV referencing
5332 * an outer lexical, return a non-zero value to indicate the CV is
5333 * a candidate for "constizing" at clone time
5337 * We have just cloned an anon prototype that was marked as a const
5338 * candidiate. Try to grab the current value, and in the case of
5339 * PADSV, ignore it if it has multiple references. Return the value.
5343 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
5354 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
5355 o = cLISTOPo->op_first->op_sibling;
5357 for (; o; o = o->op_next) {
5358 const OPCODE type = o->op_type;
5360 if (sv && o->op_next == o)
5362 if (o->op_next != o) {
5363 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
5365 if (type == OP_DBSTATE)
5368 if (type == OP_LEAVESUB || type == OP_RETURN)
5372 if (type == OP_CONST && cSVOPo->op_sv)
5374 else if (cv && type == OP_CONST) {
5375 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5379 else if (cv && type == OP_PADSV) {
5380 if (CvCONST(cv)) { /* newly cloned anon */
5381 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5382 /* the candidate should have 1 ref from this pad and 1 ref
5383 * from the parent */
5384 if (!sv || SvREFCNT(sv) != 2)
5391 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
5392 sv = &PL_sv_undef; /* an arbitrary non-null value */
5407 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5410 /* This would be the return value, but the return cannot be reached. */
5411 OP* pegop = newOP(OP_NULL, 0);
5414 PERL_UNUSED_ARG(floor);
5424 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
5426 NORETURN_FUNCTION_END;
5431 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
5433 return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
5437 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5444 register CV *cv = NULL;
5446 /* If the subroutine has no body, no attributes, and no builtin attributes
5447 then it's just a sub declaration, and we may be able to get away with
5448 storing with a placeholder scalar in the symbol table, rather than a
5449 full GV and CV. If anything is present then it will take a full CV to
5451 const I32 gv_fetch_flags
5452 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5454 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
5455 const char * const name = o ? SvPV_nolen_const(cSVOPo->op_sv) : NULL;
5458 assert(proto->op_type == OP_CONST);
5459 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
5464 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
5465 SV * const sv = sv_newmortal();
5466 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
5467 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
5468 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
5469 aname = SvPVX_const(sv);
5474 gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
5475 : gv_fetchpv(aname ? aname
5476 : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5477 gv_fetch_flags, SVt_PVCV);
5479 if (!PL_madskills) {
5488 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
5489 maximum a prototype before. */
5490 if (SvTYPE(gv) > SVt_NULL) {
5491 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
5492 && ckWARN_d(WARN_PROTOTYPE))
5494 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
5496 cv_ckproto_len((CV*)gv, NULL, ps, ps_len);
5499 sv_setpvn((SV*)gv, ps, ps_len);
5501 sv_setiv((SV*)gv, -1);
5503 SvREFCNT_dec(PL_compcv);
5504 cv = PL_compcv = NULL;
5508 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
5510 #ifdef GV_UNIQUE_CHECK
5511 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
5512 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
5516 if (!block || !ps || *ps || attrs
5517 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5519 || block->op_type == OP_NULL
5524 const_sv = op_const_sv(block, NULL);
5527 const bool exists = CvROOT(cv) || CvXSUB(cv);
5529 #ifdef GV_UNIQUE_CHECK
5530 if (exists && GvUNIQUE(gv)) {
5531 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
5535 /* if the subroutine doesn't exist and wasn't pre-declared
5536 * with a prototype, assume it will be AUTOLOADed,
5537 * skipping the prototype check
5539 if (exists || SvPOK(cv))
5540 cv_ckproto_len(cv, gv, ps, ps_len);
5541 /* already defined (or promised)? */
5542 if (exists || GvASSUMECV(gv)) {
5545 || block->op_type == OP_NULL
5548 if (CvFLAGS(PL_compcv)) {
5549 /* might have had built-in attrs applied */
5550 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5552 /* just a "sub foo;" when &foo is already defined */
5553 SAVEFREESV(PL_compcv);
5558 && block->op_type != OP_NULL
5561 if (ckWARN(WARN_REDEFINE)
5563 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
5565 const line_t oldline = CopLINE(PL_curcop);
5566 if (PL_parser && PL_parser->copline != NOLINE)
5567 CopLINE_set(PL_curcop, PL_parser->copline);
5568 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5569 CvCONST(cv) ? "Constant subroutine %s redefined"
5570 : "Subroutine %s redefined", name);
5571 CopLINE_set(PL_curcop, oldline);
5574 if (!PL_minus_c) /* keep old one around for madskills */
5577 /* (PL_madskills unset in used file.) */
5585 SvREFCNT_inc_simple_void_NN(const_sv);
5587 assert(!CvROOT(cv) && !CvCONST(cv));
5588 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
5589 CvXSUBANY(cv).any_ptr = const_sv;
5590 CvXSUB(cv) = const_sv_xsub;
5596 cv = newCONSTSUB(NULL, name, const_sv);
5598 mro_method_changed_in( /* sub Foo::Bar () { 123 } */
5599 (CvGV(cv) && GvSTASH(CvGV(cv)))
5608 SvREFCNT_dec(PL_compcv);
5616 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
5617 * before we clobber PL_compcv.
5621 || block->op_type == OP_NULL
5625 /* Might have had built-in attributes applied -- propagate them. */
5626 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5627 if (CvGV(cv) && GvSTASH(CvGV(cv)))
5628 stash = GvSTASH(CvGV(cv));
5629 else if (CvSTASH(cv))
5630 stash = CvSTASH(cv);
5632 stash = PL_curstash;
5635 /* possibly about to re-define existing subr -- ignore old cv */
5636 rcv = (SV*)PL_compcv;
5637 if (name && GvSTASH(gv))
5638 stash = GvSTASH(gv);
5640 stash = PL_curstash;
5642 apply_attrs(stash, rcv, attrs, FALSE);
5644 if (cv) { /* must reuse cv if autoloaded */
5651 || block->op_type == OP_NULL) && !PL_madskills
5654 /* got here with just attrs -- work done, so bug out */
5655 SAVEFREESV(PL_compcv);
5658 /* transfer PL_compcv to cv */
5660 CvFLAGS(cv) = CvFLAGS(PL_compcv);
5661 if (!CvWEAKOUTSIDE(cv))
5662 SvREFCNT_dec(CvOUTSIDE(cv));
5663 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
5664 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
5665 CvOUTSIDE(PL_compcv) = 0;
5666 CvPADLIST(cv) = CvPADLIST(PL_compcv);
5667 CvPADLIST(PL_compcv) = 0;
5668 /* inner references to PL_compcv must be fixed up ... */
5669 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
5670 /* ... before we throw it away */
5671 SvREFCNT_dec(PL_compcv);
5673 if (PERLDB_INTER)/* Advice debugger on the new sub. */
5674 ++PL_sub_generation;
5681 if (strEQ(name, "import")) {
5682 PL_formfeed = (SV*)cv;
5683 Perl_warner(aTHX_ packWARN(WARN_VOID), "%lx\n", (long)cv);
5687 mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */
5691 CvFILE_set_from_cop(cv, PL_curcop);
5692 CvSTASH(cv) = PL_curstash;
5695 sv_setpvn((SV*)cv, ps, ps_len);
5697 if (PL_parser && PL_parser->error_count) {
5701 const char *s = strrchr(name, ':');
5703 if (strEQ(s, "BEGIN")) {
5704 const char not_safe[] =
5705 "BEGIN not safe after errors--compilation aborted";
5706 if (PL_in_eval & EVAL_KEEPERR)
5707 Perl_croak(aTHX_ not_safe);
5709 /* force display of errors found but not reported */
5710 sv_catpv(ERRSV, not_safe);
5711 Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
5721 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5722 mod(scalarseq(block), OP_LEAVESUBLV));
5723 block->op_attached = 1;
5726 /* This makes sub {}; work as expected. */
5727 if (block->op_type == OP_STUB) {
5728 OP* const newblock = newSTATEOP(0, NULL, 0);
5730 op_getmad(block,newblock,'B');
5737 block->op_attached = 1;
5738 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5740 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5741 OpREFCNT_set(CvROOT(cv), 1);
5742 CvSTART(cv) = LINKLIST(CvROOT(cv));
5743 CvROOT(cv)->op_next = 0;
5744 CALL_PEEP(CvSTART(cv));
5746 /* now that optimizer has done its work, adjust pad values */
5748 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
5751 assert(!CvCONST(cv));
5752 if (ps && !*ps && op_const_sv(block, cv))
5756 if (name || aname) {
5757 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5758 SV * const sv = newSV(0);
5759 SV * const tmpstr = sv_newmortal();
5760 GV * const db_postponed = gv_fetchpvs("DB::postponed",
5761 GV_ADDMULTI, SVt_PVHV);
5764 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5766 (long)PL_subline, (long)CopLINE(PL_curcop));
5767 gv_efullname3(tmpstr, gv, NULL);
5768 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
5769 SvCUR(tmpstr), sv, 0);
5770 hv = GvHVn(db_postponed);
5771 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
5772 CV * const pcv = GvCV(db_postponed);
5778 call_sv((SV*)pcv, G_DISCARD);
5783 if (name && ! (PL_parser && PL_parser->error_count))
5784 process_special_blocks(name, gv, cv);
5789 PL_parser->copline = NOLINE;
5795 S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
5798 const char *const colon = strrchr(fullname,':');
5799 const char *const name = colon ? colon + 1 : fullname;
5801 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
5804 if (strEQ(name, "BEGIN")) {
5805 const I32 oldscope = PL_scopestack_ix;
5807 SAVECOPFILE(&PL_compiling);
5808 SAVECOPLINE(&PL_compiling);
5810 DEBUG_x( dump_sub(gv) );
5811 Perl_av_create_and_push(aTHX_ &PL_beginav, (SV*)cv);
5812 GvCV(gv) = 0; /* cv has been hijacked */
5813 call_list(oldscope, PL_beginav);
5815 PL_curcop = &PL_compiling;
5816 CopHINTS_set(&PL_compiling, PL_hints);
5823 if strEQ(name, "END") {
5824 DEBUG_x( dump_sub(gv) );
5825 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, (SV*)cv);
5828 } else if (*name == 'U') {
5829 if (strEQ(name, "UNITCHECK")) {
5830 /* It's never too late to run a unitcheck block */
5831 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, (SV*)cv);
5835 } else if (*name == 'C') {
5836 if (strEQ(name, "CHECK")) {
5837 if (PL_main_start && ckWARN(WARN_VOID))
5838 Perl_warner(aTHX_ packWARN(WARN_VOID),
5839 "Too late to run CHECK block");
5840 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, (SV*)cv);
5844 } else if (*name == 'I') {
5845 if (strEQ(name, "INIT")) {
5846 if (PL_main_start && ckWARN(WARN_VOID))
5847 Perl_warner(aTHX_ packWARN(WARN_VOID),
5848 "Too late to run INIT block");
5849 Perl_av_create_and_push(aTHX_ &PL_initav, (SV*)cv);
5855 DEBUG_x( dump_sub(gv) );
5856 GvCV(gv) = 0; /* cv has been hijacked */
5861 =for apidoc newCONSTSUB
5863 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5864 eligible for inlining at compile-time.
5870 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
5875 const char *const temp_p = CopFILE(PL_curcop);
5876 const STRLEN len = temp_p ? strlen(temp_p) : 0;
5878 SV *const temp_sv = CopFILESV(PL_curcop);
5880 const char *const temp_p = temp_sv ? SvPV_const(temp_sv, len) : NULL;
5882 char *const file = savepvn(temp_p, temp_p ? len : 0);
5886 if (IN_PERL_RUNTIME) {
5887 /* at runtime, it's not safe to manipulate PL_curcop: it may be
5888 * an op shared between threads. Use a non-shared COP for our
5890 SAVEVPTR(PL_curcop);
5891 PL_curcop = &PL_compiling;
5893 SAVECOPLINE(PL_curcop);
5894 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
5897 PL_hints &= ~HINT_BLOCK_SCOPE;
5900 SAVESPTR(PL_curstash);
5901 SAVECOPSTASH(PL_curcop);
5902 PL_curstash = stash;
5903 CopSTASH_set(PL_curcop,stash);
5906 /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
5907 and so doesn't get free()d. (It's expected to be from the C pre-
5908 processor __FILE__ directive). But we need a dynamically allocated one,
5909 and we need it to get freed. */
5910 cv = newXS_flags(name, const_sv_xsub, file, "", XS_DYNAMIC_FILENAME);
5911 CvXSUBANY(cv).any_ptr = sv;
5917 CopSTASH_free(PL_curcop);
5925 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
5926 const char *const filename, const char *const proto,
5929 CV *cv = newXS(name, subaddr, filename);
5931 PERL_ARGS_ASSERT_NEWXS_FLAGS;
5933 if (flags & XS_DYNAMIC_FILENAME) {
5934 /* We need to "make arrangements" (ie cheat) to ensure that the
5935 filename lasts as long as the PVCV we just created, but also doesn't
5937 STRLEN filename_len = strlen(filename);
5938 STRLEN proto_and_file_len = filename_len;
5939 char *proto_and_file;
5943 proto_len = strlen(proto);
5944 proto_and_file_len += proto_len;
5946 Newx(proto_and_file, proto_and_file_len + 1, char);
5947 Copy(proto, proto_and_file, proto_len, char);
5948 Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
5951 proto_and_file = savepvn(filename, filename_len);
5954 /* This gets free()d. :-) */
5955 sv_usepvn_flags((SV*)cv, proto_and_file, proto_and_file_len,
5956 SV_HAS_TRAILING_NUL);
5958 /* This gives us the correct prototype, rather than one with the
5959 file name appended. */
5960 SvCUR_set(cv, proto_len);
5964 CvFILE(cv) = proto_and_file + proto_len;
5966 sv_setpv((SV *)cv, proto);
5972 =for apidoc U||newXS
5974 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
5975 static storage, as it is used directly as CvFILE(), without a copy being made.
5981 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
5984 GV * const gv = gv_fetchpv(name ? name :
5985 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5986 GV_ADDMULTI, SVt_PVCV);
5989 PERL_ARGS_ASSERT_NEWXS;
5992 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
5994 if ((cv = (name ? GvCV(gv) : NULL))) {
5996 /* just a cached method */
6000 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
6001 /* already defined (or promised) */
6002 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
6003 if (ckWARN(WARN_REDEFINE)) {
6004 GV * const gvcv = CvGV(cv);
6006 HV * const stash = GvSTASH(gvcv);
6008 const char *redefined_name = HvNAME_get(stash);
6009 if ( strEQ(redefined_name,"autouse") ) {
6010 const line_t oldline = CopLINE(PL_curcop);
6011 if (PL_parser && PL_parser->copline != NOLINE)
6012 CopLINE_set(PL_curcop, PL_parser->copline);
6013 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6014 CvCONST(cv) ? "Constant subroutine %s redefined"
6015 : "Subroutine %s redefined"
6017 CopLINE_set(PL_curcop, oldline);
6027 if (cv) /* must reuse cv if autoloaded */
6030 cv = (CV*)newSV_type(SVt_PVCV);
6034 mro_method_changed_in(GvSTASH(gv)); /* newXS */
6038 (void)gv_fetchfile(filename);
6039 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
6040 an external constant string */
6042 CvXSUB(cv) = subaddr;
6045 process_special_blocks(name, gv, cv);
6057 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
6062 OP* pegop = newOP(OP_NULL, 0);
6066 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
6067 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
6069 #ifdef GV_UNIQUE_CHECK
6071 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
6075 if ((cv = GvFORM(gv))) {
6076 if (ckWARN(WARN_REDEFINE)) {
6077 const line_t oldline = CopLINE(PL_curcop);
6078 if (PL_parser && PL_parser->copline != NOLINE)
6079 CopLINE_set(PL_curcop, PL_parser->copline);
6080 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6081 o ? "Format %"SVf" redefined"
6082 : "Format STDOUT redefined", SVfARG(cSVOPo->op_sv));
6083 CopLINE_set(PL_curcop, oldline);
6090 CvFILE_set_from_cop(cv, PL_curcop);
6093 pad_tidy(padtidy_FORMAT);
6094 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
6095 CvROOT(cv)->op_private |= OPpREFCOUNTED;
6096 OpREFCNT_set(CvROOT(cv), 1);
6097 CvSTART(cv) = LINKLIST(CvROOT(cv));
6098 CvROOT(cv)->op_next = 0;
6099 CALL_PEEP(CvSTART(cv));
6101 op_getmad(o,pegop,'n');
6102 op_getmad_weak(block, pegop, 'b');
6107 PL_parser->copline = NOLINE;
6115 Perl_newANONLIST(pTHX_ OP *o)
6117 return convert(OP_ANONLIST, OPf_SPECIAL, o);
6121 Perl_newANONHASH(pTHX_ OP *o)
6123 return convert(OP_ANONHASH, OPf_SPECIAL, o);
6127 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
6129 return newANONATTRSUB(floor, proto, NULL, block);
6133 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
6135 return newUNOP(OP_REFGEN, 0,
6136 newSVOP(OP_ANONCODE, 0,
6137 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
6141 Perl_oopsAV(pTHX_ OP *o)
6145 PERL_ARGS_ASSERT_OOPSAV;
6147 switch (o->op_type) {
6149 o->op_type = OP_PADAV;
6150 o->op_ppaddr = PL_ppaddr[OP_PADAV];
6151 return ref(o, OP_RV2AV);
6154 o->op_type = OP_RV2AV;
6155 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
6160 if (ckWARN_d(WARN_INTERNAL))
6161 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
6168 Perl_oopsHV(pTHX_ OP *o)
6172 PERL_ARGS_ASSERT_OOPSHV;
6174 switch (o->op_type) {
6177 o->op_type = OP_PADHV;
6178 o->op_ppaddr = PL_ppaddr[OP_PADHV];
6179 return ref(o, OP_RV2HV);
6183 o->op_type = OP_RV2HV;
6184 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
6189 if (ckWARN_d(WARN_INTERNAL))
6190 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
6197 Perl_newAVREF(pTHX_ OP *o)
6201 PERL_ARGS_ASSERT_NEWAVREF;
6203 if (o->op_type == OP_PADANY) {
6204 o->op_type = OP_PADAV;
6205 o->op_ppaddr = PL_ppaddr[OP_PADAV];
6208 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
6209 && ckWARN(WARN_DEPRECATED)) {
6210 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
6211 "Using an array as a reference is deprecated");
6213 return newUNOP(OP_RV2AV, 0, scalar(o));
6217 Perl_newGVREF(pTHX_ I32 type, OP *o)
6219 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
6220 return newUNOP(OP_NULL, 0, o);
6221 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
6225 Perl_newHVREF(pTHX_ OP *o)
6229 PERL_ARGS_ASSERT_NEWHVREF;
6231 if (o->op_type == OP_PADANY) {
6232 o->op_type = OP_PADHV;
6233 o->op_ppaddr = PL_ppaddr[OP_PADHV];
6236 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
6237 && ckWARN(WARN_DEPRECATED)) {
6238 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
6239 "Using a hash as a reference is deprecated");
6241 return newUNOP(OP_RV2HV, 0, scalar(o));
6245 Perl_newCVREF(pTHX_ I32 flags, OP *o)
6247 return newUNOP(OP_RV2CV, flags, scalar(o));
6251 Perl_newSVREF(pTHX_ OP *o)
6255 PERL_ARGS_ASSERT_NEWSVREF;
6257 if (o->op_type == OP_PADANY) {
6258 o->op_type = OP_PADSV;
6259 o->op_ppaddr = PL_ppaddr[OP_PADSV];
6262 return newUNOP(OP_RV2SV, 0, scalar(o));
6265 /* Check routines. See the comments at the top of this file for details
6266 * on when these are called */
6269 Perl_ck_anoncode(pTHX_ OP *o)
6271 PERL_ARGS_ASSERT_CK_ANONCODE;
6273 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
6275 cSVOPo->op_sv = NULL;
6280 Perl_ck_bitop(pTHX_ OP *o)
6284 PERL_ARGS_ASSERT_CK_BITOP;
6286 #define OP_IS_NUMCOMPARE(op) \
6287 ((op) == OP_LT || (op) == OP_I_LT || \
6288 (op) == OP_GT || (op) == OP_I_GT || \
6289 (op) == OP_LE || (op) == OP_I_LE || \
6290 (op) == OP_GE || (op) == OP_I_GE || \
6291 (op) == OP_EQ || (op) == OP_I_EQ || \
6292 (op) == OP_NE || (op) == OP_I_NE || \
6293 (op) == OP_NCMP || (op) == OP_I_NCMP)
6294 o->op_private = (U8)(PL_hints & HINT_INTEGER);
6295 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
6296 && (o->op_type == OP_BIT_OR
6297 || o->op_type == OP_BIT_AND
6298 || o->op_type == OP_BIT_XOR))
6300 const OP * const left = cBINOPo->op_first;
6301 const OP * const right = left->op_sibling;
6302 if ((OP_IS_NUMCOMPARE(left->op_type) &&
6303 (left->op_flags & OPf_PARENS) == 0) ||
6304 (OP_IS_NUMCOMPARE(right->op_type) &&
6305 (right->op_flags & OPf_PARENS) == 0))
6306 if (ckWARN(WARN_PRECEDENCE))
6307 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
6308 "Possible precedence problem on bitwise %c operator",
6309 o->op_type == OP_BIT_OR ? '|'
6310 : o->op_type == OP_BIT_AND ? '&' : '^'
6317 Perl_ck_concat(pTHX_ OP *o)
6319 const OP * const kid = cUNOPo->op_first;
6321 PERL_ARGS_ASSERT_CK_CONCAT;
6322 PERL_UNUSED_CONTEXT;
6324 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
6325 !(kUNOP->op_first->op_flags & OPf_MOD))
6326 o->op_flags |= OPf_STACKED;
6331 Perl_ck_spair(pTHX_ OP *o)
6335 PERL_ARGS_ASSERT_CK_SPAIR;
6337 if (o->op_flags & OPf_KIDS) {
6340 const OPCODE type = o->op_type;
6341 o = modkids(ck_fun(o), type);
6342 kid = cUNOPo->op_first;
6343 newop = kUNOP->op_first->op_sibling;
6345 const OPCODE type = newop->op_type;
6346 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
6347 type == OP_PADAV || type == OP_PADHV ||
6348 type == OP_RV2AV || type == OP_RV2HV)
6352 op_getmad(kUNOP->op_first,newop,'K');
6354 op_free(kUNOP->op_first);
6356 kUNOP->op_first = newop;
6358 o->op_ppaddr = PL_ppaddr[++o->op_type];
6363 Perl_ck_delete(pTHX_ OP *o)
6365 PERL_ARGS_ASSERT_CK_DELETE;
6369 if (o->op_flags & OPf_KIDS) {
6370 OP * const kid = cUNOPo->op_first;
6371 switch (kid->op_type) {
6373 o->op_flags |= OPf_SPECIAL;
6376 o->op_private |= OPpSLICE;
6379 o->op_flags |= OPf_SPECIAL;
6384 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
6393 Perl_ck_die(pTHX_ OP *o)
6395 PERL_ARGS_ASSERT_CK_DIE;
6398 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6404 Perl_ck_eof(pTHX_ OP *o)
6408 PERL_ARGS_ASSERT_CK_EOF;
6410 if (o->op_flags & OPf_KIDS) {
6411 if (cLISTOPo->op_first->op_type == OP_STUB) {
6413 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
6415 op_getmad(o,newop,'O');
6427 Perl_ck_eval(pTHX_ OP *o)
6431 PERL_ARGS_ASSERT_CK_EVAL;
6433 PL_hints |= HINT_BLOCK_SCOPE;
6434 if (o->op_flags & OPf_KIDS) {
6435 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6438 o->op_flags &= ~OPf_KIDS;
6441 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
6447 cUNOPo->op_first = 0;
6452 NewOp(1101, enter, 1, LOGOP);
6453 enter->op_type = OP_ENTERTRY;
6454 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
6455 enter->op_private = 0;
6457 /* establish postfix order */
6458 enter->op_next = (OP*)enter;
6460 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
6461 o->op_type = OP_LEAVETRY;
6462 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
6463 enter->op_other = o;
6464 op_getmad(oldo,o,'O');
6478 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
6479 op_getmad(oldo,o,'O');
6481 o->op_targ = (PADOFFSET)PL_hints;
6482 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
6483 /* Store a copy of %^H that pp_entereval can pick up. */
6484 OP *hhop = newSVOP(OP_HINTSEVAL, 0,
6485 (SV*)Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv)));
6486 cUNOPo->op_first->op_sibling = hhop;
6487 o->op_private |= OPpEVAL_HAS_HH;
6493 Perl_ck_exit(pTHX_ OP *o)
6495 PERL_ARGS_ASSERT_CK_EXIT;
6498 HV * const table = GvHV(PL_hintgv);
6500 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
6501 if (svp && *svp && SvTRUE(*svp))
6502 o->op_private |= OPpEXIT_VMSISH;
6504 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6510 Perl_ck_exec(pTHX_ OP *o)
6512 PERL_ARGS_ASSERT_CK_EXEC;
6514 if (o->op_flags & OPf_STACKED) {
6517 kid = cUNOPo->op_first->op_sibling;
6518 if (kid->op_type == OP_RV2GV)
6527 Perl_ck_exists(pTHX_ OP *o)
6531 PERL_ARGS_ASSERT_CK_EXISTS;
6534 if (o->op_flags & OPf_KIDS) {
6535 OP * const kid = cUNOPo->op_first;
6536 if (kid->op_type == OP_ENTERSUB) {
6537 (void) ref(kid, o->op_type);
6538 if (kid->op_type != OP_RV2CV
6539 && !(PL_parser && PL_parser->error_count))
6540 Perl_croak(aTHX_ "%s argument is not a subroutine name",
6542 o->op_private |= OPpEXISTS_SUB;
6544 else if (kid->op_type == OP_AELEM)
6545 o->op_flags |= OPf_SPECIAL;
6546 else if (kid->op_type != OP_HELEM)
6547 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
6555 Perl_ck_rvconst(pTHX_ register OP *o)
6558 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6560 PERL_ARGS_ASSERT_CK_RVCONST;
6562 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6563 if (o->op_type == OP_RV2CV)
6564 o->op_private &= ~1;
6566 if (kid->op_type == OP_CONST) {
6569 SV * const kidsv = kid->op_sv;
6571 /* Is it a constant from cv_const_sv()? */
6572 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
6573 SV * const rsv = SvRV(kidsv);
6574 const svtype type = SvTYPE(rsv);
6575 const char *badtype = NULL;
6577 switch (o->op_type) {
6579 if (type > SVt_PVMG)
6580 badtype = "a SCALAR";
6583 if (type != SVt_PVAV)
6584 badtype = "an ARRAY";
6587 if (type != SVt_PVHV)
6591 if (type != SVt_PVCV)
6596 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
6599 else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
6600 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
6601 /* If this is an access to a stash, disable "strict refs", because
6602 * stashes aren't auto-vivified at compile-time (unless we store
6603 * symbols in them), and we don't want to produce a run-time
6604 * stricture error when auto-vivifying the stash. */
6605 const char *s = SvPV_nolen(kidsv);
6606 const STRLEN l = SvCUR(kidsv);
6607 if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
6608 o->op_private &= ~HINT_STRICT_REFS;
6610 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
6611 const char *badthing;
6612 switch (o->op_type) {
6614 badthing = "a SCALAR";
6617 badthing = "an ARRAY";
6620 badthing = "a HASH";
6628 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
6629 SVfARG(kidsv), badthing);
6632 * This is a little tricky. We only want to add the symbol if we
6633 * didn't add it in the lexer. Otherwise we get duplicate strict
6634 * warnings. But if we didn't add it in the lexer, we must at
6635 * least pretend like we wanted to add it even if it existed before,
6636 * or we get possible typo warnings. OPpCONST_ENTERED says
6637 * whether the lexer already added THIS instance of this symbol.
6639 iscv = (o->op_type == OP_RV2CV) * 2;
6641 gv = gv_fetchsv(kidsv,
6642 iscv | !(kid->op_private & OPpCONST_ENTERED),
6645 : o->op_type == OP_RV2SV
6647 : o->op_type == OP_RV2AV
6649 : o->op_type == OP_RV2HV
6652 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
6654 kid->op_type = OP_GV;
6655 SvREFCNT_dec(kid->op_sv);
6657 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
6658 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
6659 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
6661 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc_simple_NN(gv));
6663 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
6665 kid->op_private = 0;
6666 kid->op_ppaddr = PL_ppaddr[OP_GV];
6673 Perl_ck_ftst(pTHX_ OP *o)
6676 const I32 type = o->op_type;
6678 PERL_ARGS_ASSERT_CK_FTST;
6680 if (o->op_flags & OPf_REF) {
6683 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
6684 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6685 const OPCODE kidtype = kid->op_type;
6687 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6688 OP * const newop = newGVOP(type, OPf_REF,
6689 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
6691 op_getmad(o,newop,'O');
6697 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
6698 o->op_private |= OPpFT_ACCESS;
6699 if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst)
6700 && kidtype != OP_STAT && kidtype != OP_LSTAT)
6701 o->op_private |= OPpFT_STACKED;
6709 if (type == OP_FTTTY)
6710 o = newGVOP(type, OPf_REF, PL_stdingv);
6712 o = newUNOP(type, 0, newDEFSVOP());
6713 op_getmad(oldo,o,'O');
6719 Perl_ck_fun(pTHX_ OP *o)
6722 const int type = o->op_type;
6723 register I32 oa = PL_opargs[type] >> OASHIFT;
6725 PERL_ARGS_ASSERT_CK_FUN;
6727 if (o->op_flags & OPf_STACKED) {
6728 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
6731 return no_fh_allowed(o);
6734 if (o->op_flags & OPf_KIDS) {
6735 OP **tokid = &cLISTOPo->op_first;
6736 register OP *kid = cLISTOPo->op_first;
6740 if (kid->op_type == OP_PUSHMARK ||
6741 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
6743 tokid = &kid->op_sibling;
6744 kid = kid->op_sibling;
6746 if (!kid && PL_opargs[type] & OA_DEFGV)
6747 *tokid = kid = newDEFSVOP();
6751 sibl = kid->op_sibling;
6753 if (!sibl && kid->op_type == OP_STUB) {
6760 /* list seen where single (scalar) arg expected? */
6761 if (numargs == 1 && !(oa >> 4)
6762 && kid->op_type == OP_LIST && type != OP_SCALAR)
6764 return too_many_arguments(o,PL_op_desc[type]);
6777 if ((type == OP_PUSH || type == OP_UNSHIFT)
6778 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
6779 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6780 "Useless use of %s with no values",
6783 if (kid->op_type == OP_CONST &&
6784 (kid->op_private & OPpCONST_BARE))
6786 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
6787 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
6788 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6789 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6790 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
6791 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6793 op_getmad(kid,newop,'K');
6798 kid->op_sibling = sibl;
6801 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
6802 bad_type(numargs, "array", PL_op_desc[type], kid);
6806 if (kid->op_type == OP_CONST &&
6807 (kid->op_private & OPpCONST_BARE))
6809 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
6810 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
6811 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6812 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6813 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
6814 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6816 op_getmad(kid,newop,'K');
6821 kid->op_sibling = sibl;
6824 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
6825 bad_type(numargs, "hash", PL_op_desc[type], kid);
6830 OP * const newop = newUNOP(OP_NULL, 0, kid);
6831 kid->op_sibling = 0;
6833 newop->op_next = newop;
6835 kid->op_sibling = sibl;
6840 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
6841 if (kid->op_type == OP_CONST &&
6842 (kid->op_private & OPpCONST_BARE))
6844 OP * const newop = newGVOP(OP_GV, 0,
6845 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
6846 if (!(o->op_private & 1) && /* if not unop */
6847 kid == cLISTOPo->op_last)
6848 cLISTOPo->op_last = newop;
6850 op_getmad(kid,newop,'K');
6856 else if (kid->op_type == OP_READLINE) {
6857 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
6858 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
6861 I32 flags = OPf_SPECIAL;
6865 /* is this op a FH constructor? */
6866 if (is_handle_constructor(o,numargs)) {
6867 const char *name = NULL;
6871 /* Set a flag to tell rv2gv to vivify
6872 * need to "prove" flag does not mean something
6873 * else already - NI-S 1999/05/07
6876 if (kid->op_type == OP_PADSV) {
6878 = PAD_COMPNAME_SV(kid->op_targ);
6879 name = SvPV_const(namesv, len);
6881 else if (kid->op_type == OP_RV2SV
6882 && kUNOP->op_first->op_type == OP_GV)
6884 GV * const gv = cGVOPx_gv(kUNOP->op_first);
6886 len = GvNAMELEN(gv);
6888 else if (kid->op_type == OP_AELEM
6889 || kid->op_type == OP_HELEM)
6892 OP *op = ((BINOP*)kid)->op_first;
6896 const char * const a =
6897 kid->op_type == OP_AELEM ?
6899 if (((op->op_type == OP_RV2AV) ||
6900 (op->op_type == OP_RV2HV)) &&
6901 (firstop = ((UNOP*)op)->op_first) &&
6902 (firstop->op_type == OP_GV)) {
6903 /* packagevar $a[] or $h{} */
6904 GV * const gv = cGVOPx_gv(firstop);
6912 else if (op->op_type == OP_PADAV
6913 || op->op_type == OP_PADHV) {
6914 /* lexicalvar $a[] or $h{} */
6915 const char * const padname =
6916 PAD_COMPNAME_PV(op->op_targ);
6925 name = SvPV_const(tmpstr, len);
6930 name = "__ANONIO__";
6937 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
6938 namesv = PAD_SVl(targ);
6939 SvUPGRADE(namesv, SVt_PV);
6941 sv_setpvn(namesv, "$", 1);
6942 sv_catpvn(namesv, name, len);
6945 kid->op_sibling = 0;
6946 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
6947 kid->op_targ = targ;
6948 kid->op_private |= priv;
6950 kid->op_sibling = sibl;
6956 mod(scalar(kid), type);
6960 tokid = &kid->op_sibling;
6961 kid = kid->op_sibling;
6964 if (kid && kid->op_type != OP_STUB)
6965 return too_many_arguments(o,OP_DESC(o));
6966 o->op_private |= numargs;
6968 /* FIXME - should the numargs move as for the PERL_MAD case? */
6969 o->op_private |= numargs;
6971 return too_many_arguments(o,OP_DESC(o));
6975 else if (PL_opargs[type] & OA_DEFGV) {
6977 OP *newop = newUNOP(type, 0, newDEFSVOP());
6978 op_getmad(o,newop,'O');
6981 /* Ordering of these two is important to keep f_map.t passing. */
6983 return newUNOP(type, 0, newDEFSVOP());
6988 while (oa & OA_OPTIONAL)
6990 if (oa && oa != OA_LIST)
6991 return too_few_arguments(o,OP_DESC(o));
6997 Perl_ck_glob(pTHX_ OP *o)
7002 PERL_ARGS_ASSERT_CK_GLOB;
7005 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
7006 append_elem(OP_GLOB, o, newDEFSVOP());
7008 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
7009 && GvCVu(gv) && GvIMPORTED_CV(gv)))
7011 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7014 #if !defined(PERL_EXTERNAL_GLOB)
7015 /* XXX this can be tightened up and made more failsafe. */
7016 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7019 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
7020 newSVpvs("File::Glob"), NULL, NULL, NULL);
7021 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7022 glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
7023 GvCV(gv) = GvCV(glob_gv);
7024 SvREFCNT_inc_void((SV*)GvCV(gv));
7025 GvIMPORTED_CV_on(gv);
7028 #endif /* PERL_EXTERNAL_GLOB */
7030 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7031 append_elem(OP_GLOB, o,
7032 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
7033 o->op_type = OP_LIST;
7034 o->op_ppaddr = PL_ppaddr[OP_LIST];
7035 cLISTOPo->op_first->op_type = OP_PUSHMARK;
7036 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
7037 cLISTOPo->op_first->op_targ = 0;
7038 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
7039 append_elem(OP_LIST, o,
7040 scalar(newUNOP(OP_RV2CV, 0,
7041 newGVOP(OP_GV, 0, gv)))));
7042 o = newUNOP(OP_NULL, 0, ck_subr(o));
7043 o->op_targ = OP_GLOB; /* hint at what it used to be */
7046 gv = newGVgen("main");
7048 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
7054 Perl_ck_grep(pTHX_ OP *o)
7059 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
7062 PERL_ARGS_ASSERT_CK_GREP;
7064 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
7065 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
7067 if (o->op_flags & OPf_STACKED) {
7070 kid = cLISTOPo->op_first->op_sibling;
7071 if (!cUNOPx(kid)->op_next)
7072 Perl_croak(aTHX_ "panic: ck_grep");
7073 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
7076 NewOp(1101, gwop, 1, LOGOP);
7077 kid->op_next = (OP*)gwop;
7078 o->op_flags &= ~OPf_STACKED;
7080 kid = cLISTOPo->op_first->op_sibling;
7081 if (type == OP_MAPWHILE)
7086 if (PL_parser && PL_parser->error_count)
7088 kid = cLISTOPo->op_first->op_sibling;
7089 if (kid->op_type != OP_NULL)
7090 Perl_croak(aTHX_ "panic: ck_grep");
7091 kid = kUNOP->op_first;
7094 NewOp(1101, gwop, 1, LOGOP);
7095 gwop->op_type = type;
7096 gwop->op_ppaddr = PL_ppaddr[type];
7097 gwop->op_first = listkids(o);
7098 gwop->op_flags |= OPf_KIDS;
7099 gwop->op_other = LINKLIST(kid);
7100 kid->op_next = (OP*)gwop;
7101 offset = pad_findmy("$_");
7102 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
7103 o->op_private = gwop->op_private = 0;
7104 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
7107 o->op_private = gwop->op_private = OPpGREP_LEX;
7108 gwop->op_targ = o->op_targ = offset;
7111 kid = cLISTOPo->op_first->op_sibling;
7112 if (!kid || !kid->op_sibling)
7113 return too_few_arguments(o,OP_DESC(o));
7114 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
7115 mod(kid, OP_GREPSTART);
7121 Perl_ck_index(pTHX_ OP *o)
7123 PERL_ARGS_ASSERT_CK_INDEX;
7125 if (o->op_flags & OPf_KIDS) {
7126 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7128 kid = kid->op_sibling; /* get past "big" */
7129 if (kid && kid->op_type == OP_CONST)
7130 fbm_compile(((SVOP*)kid)->op_sv, 0);
7136 Perl_ck_lfun(pTHX_ OP *o)
7138 const OPCODE type = o->op_type;
7140 PERL_ARGS_ASSERT_CK_LFUN;
7142 return modkids(ck_fun(o), type);
7146 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
7148 PERL_ARGS_ASSERT_CK_DEFINED;
7150 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
7151 switch (cUNOPo->op_first->op_type) {
7153 /* This is needed for
7154 if (defined %stash::)
7155 to work. Do not break Tk.
7157 break; /* Globals via GV can be undef */
7159 case OP_AASSIGN: /* Is this a good idea? */
7160 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
7161 "defined(@array) is deprecated");
7162 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
7163 "\t(Maybe you should just omit the defined()?)\n");
7166 /* This is needed for
7167 if (defined %stash::)
7168 to work. Do not break Tk.
7170 break; /* Globals via GV can be undef */
7172 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
7173 "defined(%%hash) is deprecated");
7174 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
7175 "\t(Maybe you should just omit the defined()?)\n");
7186 Perl_ck_readline(pTHX_ OP *o)
7188 PERL_ARGS_ASSERT_CK_READLINE;
7190 if (!(o->op_flags & OPf_KIDS)) {
7192 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
7194 op_getmad(o,newop,'O');
7204 Perl_ck_rfun(pTHX_ OP *o)
7206 const OPCODE type = o->op_type;
7208 PERL_ARGS_ASSERT_CK_RFUN;
7210 return refkids(ck_fun(o), type);
7214 Perl_ck_listiob(pTHX_ OP *o)
7218 PERL_ARGS_ASSERT_CK_LISTIOB;
7220 kid = cLISTOPo->op_first;
7223 kid = cLISTOPo->op_first;
7225 if (kid->op_type == OP_PUSHMARK)
7226 kid = kid->op_sibling;
7227 if (kid && o->op_flags & OPf_STACKED)
7228 kid = kid->op_sibling;
7229 else if (kid && !kid->op_sibling) { /* print HANDLE; */
7230 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
7231 o->op_flags |= OPf_STACKED; /* make it a filehandle */
7232 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
7233 cLISTOPo->op_first->op_sibling = kid;
7234 cLISTOPo->op_last = kid;
7235 kid = kid->op_sibling;
7240 append_elem(o->op_type, o, newDEFSVOP());
7246 Perl_ck_smartmatch(pTHX_ OP *o)
7249 if (0 == (o->op_flags & OPf_SPECIAL)) {
7250 OP *first = cBINOPo->op_first;
7251 OP *second = first->op_sibling;
7253 /* Implicitly take a reference to an array or hash */
7254 first->op_sibling = NULL;
7255 first = cBINOPo->op_first = ref_array_or_hash(first);
7256 second = first->op_sibling = ref_array_or_hash(second);
7258 /* Implicitly take a reference to a regular expression */
7259 if (first->op_type == OP_MATCH) {
7260 first->op_type = OP_QR;
7261 first->op_ppaddr = PL_ppaddr[OP_QR];
7263 if (second->op_type == OP_MATCH) {
7264 second->op_type = OP_QR;
7265 second->op_ppaddr = PL_ppaddr[OP_QR];
7274 Perl_ck_sassign(pTHX_ OP *o)
7277 OP * const kid = cLISTOPo->op_first;
7279 PERL_ARGS_ASSERT_CK_SASSIGN;
7281 /* has a disposable target? */
7282 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
7283 && !(kid->op_flags & OPf_STACKED)
7284 /* Cannot steal the second time! */
7285 && !(kid->op_private & OPpTARGET_MY)
7286 /* Keep the full thing for madskills */
7290 OP * const kkid = kid->op_sibling;
7292 /* Can just relocate the target. */
7293 if (kkid && kkid->op_type == OP_PADSV
7294 && !(kkid->op_private & OPpLVAL_INTRO))
7296 kid->op_targ = kkid->op_targ;
7298 /* Now we do not need PADSV and SASSIGN. */
7299 kid->op_sibling = o->op_sibling; /* NULL */
7300 cLISTOPo->op_first = NULL;
7303 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
7307 if (kid->op_sibling) {
7308 OP *kkid = kid->op_sibling;
7309 if (kkid->op_type == OP_PADSV
7310 && (kkid->op_private & OPpLVAL_INTRO)
7311 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
7312 const PADOFFSET target = kkid->op_targ;
7313 OP *const other = newOP(OP_PADSV,
7315 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
7316 OP *const first = newOP(OP_NULL, 0);
7317 OP *const nullop = newCONDOP(0, first, o, other);
7318 OP *const condop = first->op_next;
7319 /* hijacking PADSTALE for uninitialized state variables */
7320 SvPADSTALE_on(PAD_SVl(target));
7322 condop->op_type = OP_ONCE;
7323 condop->op_ppaddr = PL_ppaddr[OP_ONCE];
7324 condop->op_targ = target;
7325 other->op_targ = target;
7327 /* Because we change the type of the op here, we will skip the
7328 assinment binop->op_last = binop->op_first->op_sibling; at the
7329 end of Perl_newBINOP(). So need to do it here. */
7330 cBINOPo->op_last = cBINOPo->op_first->op_sibling;
7339 Perl_ck_match(pTHX_ OP *o)
7343 PERL_ARGS_ASSERT_CK_MATCH;
7345 if (o->op_type != OP_QR && PL_compcv) {
7346 const PADOFFSET offset = pad_findmy("$_");
7347 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
7348 o->op_targ = offset;
7349 o->op_private |= OPpTARGET_MY;
7352 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
7353 o->op_private |= OPpRUNTIME;
7358 Perl_ck_method(pTHX_ OP *o)
7360 OP * const kid = cUNOPo->op_first;
7362 PERL_ARGS_ASSERT_CK_METHOD;
7364 if (kid->op_type == OP_CONST) {
7365 SV* sv = kSVOP->op_sv;
7366 const char * const method = SvPVX_const(sv);
7367 if (!(strchr(method, ':') || strchr(method, '\''))) {
7369 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
7370 sv = newSVpvn_share(method, SvCUR(sv), 0);
7373 kSVOP->op_sv = NULL;
7375 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
7377 op_getmad(o,cmop,'O');
7388 Perl_ck_null(pTHX_ OP *o)
7390 PERL_ARGS_ASSERT_CK_NULL;
7391 PERL_UNUSED_CONTEXT;
7396 Perl_ck_open(pTHX_ OP *o)
7399 HV * const table = GvHV(PL_hintgv);
7401 PERL_ARGS_ASSERT_CK_OPEN;
7404 SV **svp = hv_fetchs(table, "open_IN", FALSE);
7406 const I32 mode = mode_from_discipline(*svp);
7407 if (mode & O_BINARY)
7408 o->op_private |= OPpOPEN_IN_RAW;
7409 else if (mode & O_TEXT)
7410 o->op_private |= OPpOPEN_IN_CRLF;
7413 svp = hv_fetchs(table, "open_OUT", FALSE);
7415 const I32 mode = mode_from_discipline(*svp);
7416 if (mode & O_BINARY)
7417 o->op_private |= OPpOPEN_OUT_RAW;
7418 else if (mode & O_TEXT)
7419 o->op_private |= OPpOPEN_OUT_CRLF;
7422 if (o->op_type == OP_BACKTICK) {
7423 if (!(o->op_flags & OPf_KIDS)) {
7424 OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
7426 op_getmad(o,newop,'O');
7435 /* In case of three-arg dup open remove strictness
7436 * from the last arg if it is a bareword. */
7437 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
7438 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
7442 if ((last->op_type == OP_CONST) && /* The bareword. */
7443 (last->op_private & OPpCONST_BARE) &&
7444 (last->op_private & OPpCONST_STRICT) &&
7445 (oa = first->op_sibling) && /* The fh. */
7446 (oa = oa->op_sibling) && /* The mode. */
7447 (oa->op_type == OP_CONST) &&
7448 SvPOK(((SVOP*)oa)->op_sv) &&
7449 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
7450 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
7451 (last == oa->op_sibling)) /* The bareword. */
7452 last->op_private &= ~OPpCONST_STRICT;
7458 Perl_ck_repeat(pTHX_ OP *o)
7460 PERL_ARGS_ASSERT_CK_REPEAT;
7462 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
7463 o->op_private |= OPpREPEAT_DOLIST;
7464 cBINOPo->op_first = force_list(cBINOPo->op_first);
7472 Perl_ck_require(pTHX_ OP *o)
7477 PERL_ARGS_ASSERT_CK_REQUIRE;
7479 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
7480 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7482 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
7483 SV * const sv = kid->op_sv;
7484 U32 was_readonly = SvREADONLY(sv);
7491 sv_force_normal_flags(sv, 0);
7492 assert(!SvREADONLY(sv));
7502 for (; s < end; s++) {
7503 if (*s == ':' && s[1] == ':') {
7505 Move(s+2, s+1, end - s - 1, char);
7510 sv_catpvs(sv, ".pm");
7511 SvFLAGS(sv) |= was_readonly;
7515 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
7516 /* handle override, if any */
7517 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
7518 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7519 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
7520 gv = gvp ? *gvp : NULL;
7524 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7525 OP * const kid = cUNOPo->op_first;
7528 cUNOPo->op_first = 0;
7532 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
7533 append_elem(OP_LIST, kid,
7534 scalar(newUNOP(OP_RV2CV, 0,
7537 op_getmad(o,newop,'O');
7545 Perl_ck_return(pTHX_ OP *o)
7549 PERL_ARGS_ASSERT_CK_RETURN;
7551 if (CvLVALUE(PL_compcv)) {
7553 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
7554 mod(kid, OP_LEAVESUBLV);
7560 Perl_ck_select(pTHX_ OP *o)
7565 PERL_ARGS_ASSERT_CK_SELECT;
7567 if (o->op_flags & OPf_KIDS) {
7568 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7569 if (kid && kid->op_sibling) {
7570 o->op_type = OP_SSELECT;
7571 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
7573 return fold_constants(o);
7577 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7578 if (kid && kid->op_type == OP_RV2GV)
7579 kid->op_private &= ~HINT_STRICT_REFS;
7584 Perl_ck_shift(pTHX_ OP *o)
7587 const I32 type = o->op_type;
7589 PERL_ARGS_ASSERT_CK_SHIFT;
7591 if (!(o->op_flags & OPf_KIDS)) {
7593 /* FIXME - this can be refactored to reduce code in #ifdefs */
7595 OP * const oldo = o;
7599 argop = newUNOP(OP_RV2AV, 0,
7600 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
7602 o = newUNOP(type, 0, scalar(argop));
7603 op_getmad(oldo,o,'O');
7606 return newUNOP(type, 0, scalar(argop));
7609 return scalar(modkids(ck_fun(o), type));
7613 Perl_ck_sort(pTHX_ OP *o)
7618 PERL_ARGS_ASSERT_CK_SORT;
7620 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
7621 HV * const hinthv = GvHV(PL_hintgv);
7623 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
7625 const I32 sorthints = (I32)SvIV(*svp);
7626 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
7627 o->op_private |= OPpSORT_QSORT;
7628 if ((sorthints & HINT_SORT_STABLE) != 0)
7629 o->op_private |= OPpSORT_STABLE;
7634 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
7636 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7637 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
7639 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
7641 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
7643 if (kid->op_type == OP_SCOPE) {
7647 else if (kid->op_type == OP_LEAVE) {
7648 if (o->op_type == OP_SORT) {
7649 op_null(kid); /* wipe out leave */
7652 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
7653 if (k->op_next == kid)
7655 /* don't descend into loops */
7656 else if (k->op_type == OP_ENTERLOOP
7657 || k->op_type == OP_ENTERITER)
7659 k = cLOOPx(k)->op_lastop;
7664 kid->op_next = 0; /* just disconnect the leave */
7665 k = kLISTOP->op_first;
7670 if (o->op_type == OP_SORT) {
7671 /* provide scalar context for comparison function/block */
7677 o->op_flags |= OPf_SPECIAL;
7679 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
7682 firstkid = firstkid->op_sibling;
7685 /* provide list context for arguments */
7686 if (o->op_type == OP_SORT)
7693 S_simplify_sort(pTHX_ OP *o)
7696 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7702 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
7704 if (!(o->op_flags & OPf_STACKED))
7706 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7707 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
7708 kid = kUNOP->op_first; /* get past null */
7709 if (kid->op_type != OP_SCOPE)
7711 kid = kLISTOP->op_last; /* get past scope */
7712 switch(kid->op_type) {
7720 k = kid; /* remember this node*/
7721 if (kBINOP->op_first->op_type != OP_RV2SV)
7723 kid = kBINOP->op_first; /* get past cmp */
7724 if (kUNOP->op_first->op_type != OP_GV)
7726 kid = kUNOP->op_first; /* get past rv2sv */
7728 if (GvSTASH(gv) != PL_curstash)
7730 gvname = GvNAME(gv);
7731 if (*gvname == 'a' && gvname[1] == '\0')
7733 else if (*gvname == 'b' && gvname[1] == '\0')
7738 kid = k; /* back to cmp */
7739 if (kBINOP->op_last->op_type != OP_RV2SV)
7741 kid = kBINOP->op_last; /* down to 2nd arg */
7742 if (kUNOP->op_first->op_type != OP_GV)
7744 kid = kUNOP->op_first; /* get past rv2sv */
7746 if (GvSTASH(gv) != PL_curstash)
7748 gvname = GvNAME(gv);
7750 ? !(*gvname == 'a' && gvname[1] == '\0')
7751 : !(*gvname == 'b' && gvname[1] == '\0'))
7753 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
7755 o->op_private |= OPpSORT_DESCEND;
7756 if (k->op_type == OP_NCMP)
7757 o->op_private |= OPpSORT_NUMERIC;
7758 if (k->op_type == OP_I_NCMP)
7759 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
7760 kid = cLISTOPo->op_first->op_sibling;
7761 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
7763 op_getmad(kid,o,'S'); /* then delete it */
7765 op_free(kid); /* then delete it */
7770 Perl_ck_split(pTHX_ OP *o)
7775 PERL_ARGS_ASSERT_CK_SPLIT;
7777 if (o->op_flags & OPf_STACKED)
7778 return no_fh_allowed(o);
7780 kid = cLISTOPo->op_first;
7781 if (kid->op_type != OP_NULL)
7782 Perl_croak(aTHX_ "panic: ck_split");
7783 kid = kid->op_sibling;
7784 op_free(cLISTOPo->op_first);
7785 cLISTOPo->op_first = kid;
7787 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
7788 cLISTOPo->op_last = kid; /* There was only one element previously */
7791 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
7792 OP * const sibl = kid->op_sibling;
7793 kid->op_sibling = 0;
7794 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
7795 if (cLISTOPo->op_first == cLISTOPo->op_last)
7796 cLISTOPo->op_last = kid;
7797 cLISTOPo->op_first = kid;
7798 kid->op_sibling = sibl;
7801 kid->op_type = OP_PUSHRE;
7802 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
7804 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
7805 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
7806 "Use of /g modifier is meaningless in split");
7809 if (!kid->op_sibling)
7810 append_elem(OP_SPLIT, o, newDEFSVOP());
7812 kid = kid->op_sibling;
7815 if (!kid->op_sibling)
7816 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
7817 assert(kid->op_sibling);
7819 kid = kid->op_sibling;
7822 if (kid->op_sibling)
7823 return too_many_arguments(o,OP_DESC(o));
7829 Perl_ck_join(pTHX_ OP *o)
7831 const OP * const kid = cLISTOPo->op_first->op_sibling;
7833 PERL_ARGS_ASSERT_CK_JOIN;
7835 if (kid && kid->op_type == OP_MATCH) {
7836 if (ckWARN(WARN_SYNTAX)) {
7837 const REGEXP *re = PM_GETRE(kPMOP);
7838 const char *pmstr = re ? RX_PRECOMP(re) : "STRING";
7839 const STRLEN len = re ? RX_PRELEN(re) : 6;
7840 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7841 "/%.*s/ should probably be written as \"%.*s\"",
7842 (int)len, pmstr, (int)len, pmstr);
7849 Perl_ck_subr(pTHX_ OP *o)
7852 OP *prev = ((cUNOPo->op_first->op_sibling)
7853 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
7854 OP *o2 = prev->op_sibling;
7856 const char *proto = NULL;
7857 const char *proto_end = NULL;
7862 I32 contextclass = 0;
7863 const char *e = NULL;
7866 PERL_ARGS_ASSERT_CK_SUBR;
7868 o->op_private |= OPpENTERSUB_HASTARG;
7869 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
7870 if (cvop->op_type == OP_RV2CV) {
7872 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
7873 op_null(cvop); /* disable rv2cv */
7874 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
7875 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
7876 GV *gv = cGVOPx_gv(tmpop);
7879 tmpop->op_private |= OPpEARLY_CV;
7883 namegv = CvANON(cv) ? gv : CvGV(cv);
7884 proto = SvPV((SV*)cv, len);
7885 proto_end = proto + len;
7890 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7891 if (o2->op_type == OP_CONST)
7892 o2->op_private &= ~OPpCONST_STRICT;
7893 else if (o2->op_type == OP_LIST) {
7894 OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
7895 if (sib && sib->op_type == OP_CONST)
7896 sib->op_private &= ~OPpCONST_STRICT;
7899 o->op_private |= (PL_hints & HINT_STRICT_REFS);
7900 if (PERLDB_SUB && PL_curstash != PL_debstash)
7901 o->op_private |= OPpENTERSUB_DB;
7902 while (o2 != cvop) {
7904 if (PL_madskills && o2->op_type == OP_STUB) {
7905 o2 = o2->op_sibling;
7908 if (PL_madskills && o2->op_type == OP_NULL)
7909 o3 = ((UNOP*)o2)->op_first;
7913 if (proto >= proto_end)
7914 return too_many_arguments(o, gv_ename(namegv));
7922 /* _ must be at the end */
7923 if (proto[1] && proto[1] != ';')
7938 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
7940 arg == 1 ? "block or sub {}" : "sub {}",
7941 gv_ename(namegv), o3);
7944 /* '*' allows any scalar type, including bareword */
7947 if (o3->op_type == OP_RV2GV)
7948 goto wrapref; /* autoconvert GLOB -> GLOBref */
7949 else if (o3->op_type == OP_CONST)
7950 o3->op_private &= ~OPpCONST_STRICT;
7951 else if (o3->op_type == OP_ENTERSUB) {
7952 /* accidental subroutine, revert to bareword */
7953 OP *gvop = ((UNOP*)o3)->op_first;
7954 if (gvop && gvop->op_type == OP_NULL) {
7955 gvop = ((UNOP*)gvop)->op_first;
7957 for (; gvop->op_sibling; gvop = gvop->op_sibling)
7960 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
7961 (gvop = ((UNOP*)gvop)->op_first) &&
7962 gvop->op_type == OP_GV)
7964 GV * const gv = cGVOPx_gv(gvop);
7965 OP * const sibling = o2->op_sibling;
7966 SV * const n = newSVpvs("");
7968 OP * const oldo2 = o2;
7972 gv_fullname4(n, gv, "", FALSE);
7973 o2 = newSVOP(OP_CONST, 0, n);
7974 op_getmad(oldo2,o2,'O');
7975 prev->op_sibling = o2;
7976 o2->op_sibling = sibling;
7992 if (contextclass++ == 0) {
7993 e = strchr(proto, ']');
7994 if (!e || e == proto)
8003 const char *p = proto;
8004 const char *const end = proto;
8006 while (*--p != '[');
8007 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
8009 gv_ename(namegv), o3);
8014 if (o3->op_type == OP_RV2GV)
8017 bad_type(arg, "symbol", gv_ename(namegv), o3);
8020 if (o3->op_type == OP_ENTERSUB)
8023 bad_type(arg, "subroutine entry", gv_ename(namegv),
8027 if (o3->op_type == OP_RV2SV ||
8028 o3->op_type == OP_PADSV ||
8029 o3->op_type == OP_HELEM ||
8030 o3->op_type == OP_AELEM)
8033 bad_type(arg, "scalar", gv_ename(namegv), o3);
8036 if (o3->op_type == OP_RV2AV ||
8037 o3->op_type == OP_PADAV)
8040 bad_type(arg, "array", gv_ename(namegv), o3);
8043 if (o3->op_type == OP_RV2HV ||
8044 o3->op_type == OP_PADHV)
8047 bad_type(arg, "hash", gv_ename(namegv), o3);
8052 OP* const sib = kid->op_sibling;
8053 kid->op_sibling = 0;
8054 o2 = newUNOP(OP_REFGEN, 0, kid);
8055 o2->op_sibling = sib;
8056 prev->op_sibling = o2;
8058 if (contextclass && e) {
8073 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
8074 gv_ename(namegv), SVfARG(cv));
8079 mod(o2, OP_ENTERSUB);
8081 o2 = o2->op_sibling;
8083 if (o2 == cvop && proto && *proto == '_') {
8084 /* generate an access to $_ */
8086 o2->op_sibling = prev->op_sibling;
8087 prev->op_sibling = o2; /* instead of cvop */
8089 if (proto && !optional && proto_end > proto &&
8090 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
8091 return too_few_arguments(o, gv_ename(namegv));
8094 OP * const oldo = o;
8098 o=newSVOP(OP_CONST, 0, newSViv(0));
8099 op_getmad(oldo,o,'O');
8105 Perl_ck_svconst(pTHX_ OP *o)
8107 PERL_ARGS_ASSERT_CK_SVCONST;
8108 PERL_UNUSED_CONTEXT;
8109 SvREADONLY_on(cSVOPo->op_sv);
8114 Perl_ck_chdir(pTHX_ OP *o)
8116 if (o->op_flags & OPf_KIDS) {
8117 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8119 if (kid && kid->op_type == OP_CONST &&
8120 (kid->op_private & OPpCONST_BARE))
8122 o->op_flags |= OPf_SPECIAL;
8123 kid->op_private &= ~OPpCONST_STRICT;
8130 Perl_ck_trunc(pTHX_ OP *o)
8132 PERL_ARGS_ASSERT_CK_TRUNC;
8134 if (o->op_flags & OPf_KIDS) {
8135 SVOP *kid = (SVOP*)cUNOPo->op_first;
8137 if (kid->op_type == OP_NULL)
8138 kid = (SVOP*)kid->op_sibling;
8139 if (kid && kid->op_type == OP_CONST &&
8140 (kid->op_private & OPpCONST_BARE))
8142 o->op_flags |= OPf_SPECIAL;
8143 kid->op_private &= ~OPpCONST_STRICT;
8150 Perl_ck_unpack(pTHX_ OP *o)
8152 OP *kid = cLISTOPo->op_first;
8154 PERL_ARGS_ASSERT_CK_UNPACK;
8156 if (kid->op_sibling) {
8157 kid = kid->op_sibling;
8158 if (!kid->op_sibling)
8159 kid->op_sibling = newDEFSVOP();
8165 Perl_ck_substr(pTHX_ OP *o)
8167 PERL_ARGS_ASSERT_CK_SUBSTR;
8170 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
8171 OP *kid = cLISTOPo->op_first;
8173 if (kid->op_type == OP_NULL)
8174 kid = kid->op_sibling;
8176 kid->op_flags |= OPf_MOD;
8183 Perl_ck_each(pTHX_ OP *o)
8186 OP *kid = cLISTOPo->op_first;
8188 PERL_ARGS_ASSERT_CK_EACH;
8190 if (kid->op_type == OP_PADAV || kid->op_type == OP_RV2AV) {
8191 const unsigned new_type = o->op_type == OP_EACH ? OP_AEACH
8192 : o->op_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
8193 o->op_type = new_type;
8194 o->op_ppaddr = PL_ppaddr[new_type];
8196 else if (!(kid->op_type == OP_PADHV || kid->op_type == OP_RV2HV
8197 || (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE)
8199 bad_type(1, "hash or array", PL_op_desc[o->op_type], kid);
8205 /* A peephole optimizer. We visit the ops in the order they're to execute.
8206 * See the comments at the top of this file for more details about when
8207 * peep() is called */
8210 Perl_peep(pTHX_ register OP *o)
8213 register OP* oldop = NULL;
8215 if (!o || o->op_opt)
8219 SAVEVPTR(PL_curcop);
8220 for (; o; o = o->op_next) {
8223 /* By default, this op has now been optimised. A couple of cases below
8224 clear this again. */
8227 switch (o->op_type) {
8230 PL_curcop = ((COP*)o); /* for warnings */
8234 if (cSVOPo->op_private & OPpCONST_STRICT)
8235 no_bareword_allowed(o);
8238 case OP_METHOD_NAMED:
8239 /* Relocate sv to the pad for thread safety.
8240 * Despite being a "constant", the SV is written to,
8241 * for reference counts, sv_upgrade() etc. */
8243 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
8244 if (o->op_type != OP_METHOD_NAMED && SvPADTMP(cSVOPo->op_sv)) {
8245 /* If op_sv is already a PADTMP then it is being used by
8246 * some pad, so make a copy. */
8247 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
8248 SvREADONLY_on(PAD_SVl(ix));
8249 SvREFCNT_dec(cSVOPo->op_sv);
8251 else if (o->op_type != OP_METHOD_NAMED
8252 && cSVOPo->op_sv == &PL_sv_undef) {
8253 /* PL_sv_undef is hack - it's unsafe to store it in the
8254 AV that is the pad, because av_fetch treats values of
8255 PL_sv_undef as a "free" AV entry and will merrily
8256 replace them with a new SV, causing pad_alloc to think
8257 that this pad slot is free. (When, clearly, it is not)
8259 SvOK_off(PAD_SVl(ix));
8260 SvPADTMP_on(PAD_SVl(ix));
8261 SvREADONLY_on(PAD_SVl(ix));
8264 SvREFCNT_dec(PAD_SVl(ix));
8265 SvPADTMP_on(cSVOPo->op_sv);
8266 PAD_SETSV(ix, cSVOPo->op_sv);
8267 /* XXX I don't know how this isn't readonly already. */
8268 SvREADONLY_on(PAD_SVl(ix));
8270 cSVOPo->op_sv = NULL;
8277 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
8278 if (o->op_next->op_private & OPpTARGET_MY) {
8279 if (o->op_flags & OPf_STACKED) /* chained concats */
8280 break; /* ignore_optimization */
8282 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
8283 o->op_targ = o->op_next->op_targ;
8284 o->op_next->op_targ = 0;
8285 o->op_private |= OPpTARGET_MY;
8288 op_null(o->op_next);
8292 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
8293 break; /* Scalar stub must produce undef. List stub is noop */
8297 if (o->op_targ == OP_NEXTSTATE
8298 || o->op_targ == OP_DBSTATE)
8300 PL_curcop = ((COP*)o);
8302 /* XXX: We avoid setting op_seq here to prevent later calls
8303 to peep() from mistakenly concluding that optimisation
8304 has already occurred. This doesn't fix the real problem,
8305 though (See 20010220.007). AMS 20010719 */
8306 /* op_seq functionality is now replaced by op_opt */
8313 if (oldop && o->op_next) {
8314 oldop->op_next = o->op_next;
8322 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
8323 OP* const pop = (o->op_type == OP_PADAV) ?
8324 o->op_next : o->op_next->op_next;
8326 if (pop && pop->op_type == OP_CONST &&
8327 ((PL_op = pop->op_next)) &&
8328 pop->op_next->op_type == OP_AELEM &&
8329 !(pop->op_next->op_private &
8330 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
8331 (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
8336 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
8337 no_bareword_allowed(pop);
8338 if (o->op_type == OP_GV)
8339 op_null(o->op_next);
8340 op_null(pop->op_next);
8342 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
8343 o->op_next = pop->op_next->op_next;
8344 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
8345 o->op_private = (U8)i;
8346 if (o->op_type == OP_GV) {
8351 o->op_flags |= OPf_SPECIAL;
8352 o->op_type = OP_AELEMFAST;
8357 if (o->op_next->op_type == OP_RV2SV) {
8358 if (!(o->op_next->op_private & OPpDEREF)) {
8359 op_null(o->op_next);
8360 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
8362 o->op_next = o->op_next->op_next;
8363 o->op_type = OP_GVSV;
8364 o->op_ppaddr = PL_ppaddr[OP_GVSV];
8367 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
8368 GV * const gv = cGVOPo_gv;
8369 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
8370 /* XXX could check prototype here instead of just carping */
8371 SV * const sv = sv_newmortal();
8372 gv_efullname3(sv, gv, NULL);
8373 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
8374 "%"SVf"() called too early to check prototype",
8378 else if (o->op_next->op_type == OP_READLINE
8379 && o->op_next->op_next->op_type == OP_CONCAT
8380 && (o->op_next->op_next->op_flags & OPf_STACKED))
8382 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
8383 o->op_type = OP_RCATLINE;
8384 o->op_flags |= OPf_STACKED;
8385 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
8386 op_null(o->op_next->op_next);
8387 op_null(o->op_next);
8403 while (cLOGOP->op_other->op_type == OP_NULL)
8404 cLOGOP->op_other = cLOGOP->op_other->op_next;
8405 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
8410 while (cLOOP->op_redoop->op_type == OP_NULL)
8411 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
8412 peep(cLOOP->op_redoop);
8413 while (cLOOP->op_nextop->op_type == OP_NULL)
8414 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
8415 peep(cLOOP->op_nextop);
8416 while (cLOOP->op_lastop->op_type == OP_NULL)
8417 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
8418 peep(cLOOP->op_lastop);
8422 assert(!(cPMOP->op_pmflags & PMf_ONCE));
8423 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
8424 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
8425 cPMOP->op_pmstashstartu.op_pmreplstart
8426 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
8427 peep(cPMOP->op_pmstashstartu.op_pmreplstart);
8431 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
8432 && ckWARN(WARN_SYNTAX))
8434 if (o->op_next->op_sibling) {
8435 const OPCODE type = o->op_next->op_sibling->op_type;
8436 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
8437 const line_t oldline = CopLINE(PL_curcop);
8438 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
8439 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8440 "Statement unlikely to be reached");
8441 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8442 "\t(Maybe you meant system() when you said exec()?)\n");
8443 CopLINE_set(PL_curcop, oldline);
8454 const char *key = NULL;
8457 if (((BINOP*)o)->op_last->op_type != OP_CONST)
8460 /* Make the CONST have a shared SV */
8461 svp = cSVOPx_svp(((BINOP*)o)->op_last);
8462 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
8463 key = SvPV_const(sv, keylen);
8464 lexname = newSVpvn_share(key,
8465 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
8471 if ((o->op_private & (OPpLVAL_INTRO)))
8474 rop = (UNOP*)((BINOP*)o)->op_first;
8475 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
8477 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
8478 if (!SvPAD_TYPED(lexname))
8480 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8481 if (!fields || !GvHV(*fields))
8483 key = SvPV_const(*svp, keylen);
8484 if (!hv_fetch(GvHV(*fields), key,
8485 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8487 Perl_croak(aTHX_ "No such class field \"%s\" "
8488 "in variable %s of type %s",
8489 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
8502 SVOP *first_key_op, *key_op;
8504 if ((o->op_private & (OPpLVAL_INTRO))
8505 /* I bet there's always a pushmark... */
8506 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
8507 /* hmmm, no optimization if list contains only one key. */
8509 rop = (UNOP*)((LISTOP*)o)->op_last;
8510 if (rop->op_type != OP_RV2HV)
8512 if (rop->op_first->op_type == OP_PADSV)
8513 /* @$hash{qw(keys here)} */
8514 rop = (UNOP*)rop->op_first;
8516 /* @{$hash}{qw(keys here)} */
8517 if (rop->op_first->op_type == OP_SCOPE
8518 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
8520 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
8526 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
8527 if (!SvPAD_TYPED(lexname))
8529 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8530 if (!fields || !GvHV(*fields))
8532 /* Again guessing that the pushmark can be jumped over.... */
8533 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
8534 ->op_first->op_sibling;
8535 for (key_op = first_key_op; key_op;
8536 key_op = (SVOP*)key_op->op_sibling) {
8537 if (key_op->op_type != OP_CONST)
8539 svp = cSVOPx_svp(key_op);
8540 key = SvPV_const(*svp, keylen);
8541 if (!hv_fetch(GvHV(*fields), key,
8542 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8544 Perl_croak(aTHX_ "No such class field \"%s\" "
8545 "in variable %s of type %s",
8546 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
8553 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
8557 /* check that RHS of sort is a single plain array */
8558 OP *oright = cUNOPo->op_first;
8559 if (!oright || oright->op_type != OP_PUSHMARK)
8562 /* reverse sort ... can be optimised. */
8563 if (!cUNOPo->op_sibling) {
8564 /* Nothing follows us on the list. */
8565 OP * const reverse = o->op_next;
8567 if (reverse->op_type == OP_REVERSE &&
8568 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
8569 OP * const pushmark = cUNOPx(reverse)->op_first;
8570 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
8571 && (cUNOPx(pushmark)->op_sibling == o)) {
8572 /* reverse -> pushmark -> sort */
8573 o->op_private |= OPpSORT_REVERSE;
8575 pushmark->op_next = oright->op_next;
8581 /* make @a = sort @a act in-place */
8583 oright = cUNOPx(oright)->op_sibling;
8586 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
8587 oright = cUNOPx(oright)->op_sibling;
8591 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
8592 || oright->op_next != o
8593 || (oright->op_private & OPpLVAL_INTRO)
8597 /* o2 follows the chain of op_nexts through the LHS of the
8598 * assign (if any) to the aassign op itself */
8600 if (!o2 || o2->op_type != OP_NULL)
8603 if (!o2 || o2->op_type != OP_PUSHMARK)
8606 if (o2 && o2->op_type == OP_GV)
8609 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
8610 || (o2->op_private & OPpLVAL_INTRO)
8615 if (!o2 || o2->op_type != OP_NULL)
8618 if (!o2 || o2->op_type != OP_AASSIGN
8619 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
8622 /* check that the sort is the first arg on RHS of assign */
8624 o2 = cUNOPx(o2)->op_first;
8625 if (!o2 || o2->op_type != OP_NULL)
8627 o2 = cUNOPx(o2)->op_first;
8628 if (!o2 || o2->op_type != OP_PUSHMARK)
8630 if (o2->op_sibling != o)
8633 /* check the array is the same on both sides */
8634 if (oleft->op_type == OP_RV2AV) {
8635 if (oright->op_type != OP_RV2AV
8636 || !cUNOPx(oright)->op_first
8637 || cUNOPx(oright)->op_first->op_type != OP_GV
8638 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
8639 cGVOPx_gv(cUNOPx(oright)->op_first)
8643 else if (oright->op_type != OP_PADAV
8644 || oright->op_targ != oleft->op_targ
8648 /* transfer MODishness etc from LHS arg to RHS arg */
8649 oright->op_flags = oleft->op_flags;
8650 o->op_private |= OPpSORT_INPLACE;
8652 /* excise push->gv->rv2av->null->aassign */
8653 o2 = o->op_next->op_next;
8654 op_null(o2); /* PUSHMARK */
8656 if (o2->op_type == OP_GV) {
8657 op_null(o2); /* GV */
8660 op_null(o2); /* RV2AV or PADAV */
8661 o2 = o2->op_next->op_next;
8662 op_null(o2); /* AASSIGN */
8664 o->op_next = o2->op_next;
8670 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
8672 LISTOP *enter, *exlist;
8674 enter = (LISTOP *) o->op_next;
8677 if (enter->op_type == OP_NULL) {
8678 enter = (LISTOP *) enter->op_next;
8682 /* for $a (...) will have OP_GV then OP_RV2GV here.
8683 for (...) just has an OP_GV. */
8684 if (enter->op_type == OP_GV) {
8685 gvop = (OP *) enter;
8686 enter = (LISTOP *) enter->op_next;
8689 if (enter->op_type == OP_RV2GV) {
8690 enter = (LISTOP *) enter->op_next;
8696 if (enter->op_type != OP_ENTERITER)
8699 iter = enter->op_next;
8700 if (!iter || iter->op_type != OP_ITER)
8703 expushmark = enter->op_first;
8704 if (!expushmark || expushmark->op_type != OP_NULL
8705 || expushmark->op_targ != OP_PUSHMARK)
8708 exlist = (LISTOP *) expushmark->op_sibling;
8709 if (!exlist || exlist->op_type != OP_NULL
8710 || exlist->op_targ != OP_LIST)
8713 if (exlist->op_last != o) {
8714 /* Mmm. Was expecting to point back to this op. */
8717 theirmark = exlist->op_first;
8718 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
8721 if (theirmark->op_sibling != o) {
8722 /* There's something between the mark and the reverse, eg
8723 for (1, reverse (...))
8728 ourmark = ((LISTOP *)o)->op_first;
8729 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
8732 ourlast = ((LISTOP *)o)->op_last;
8733 if (!ourlast || ourlast->op_next != o)
8736 rv2av = ourmark->op_sibling;
8737 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
8738 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
8739 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
8740 /* We're just reversing a single array. */
8741 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
8742 enter->op_flags |= OPf_STACKED;
8745 /* We don't have control over who points to theirmark, so sacrifice
8747 theirmark->op_next = ourmark->op_next;
8748 theirmark->op_flags = ourmark->op_flags;
8749 ourlast->op_next = gvop ? gvop : (OP *) enter;
8752 enter->op_private |= OPpITER_REVERSED;
8753 iter->op_private |= OPpITER_REVERSED;
8760 UNOP *refgen, *rv2cv;
8763 if ((o->op_flags & OPf_WANT) != OPf_WANT_VOID)
8766 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
8769 rv2gv = ((BINOP *)o)->op_last;
8770 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
8773 refgen = (UNOP *)((BINOP *)o)->op_first;
8775 if (!refgen || refgen->op_type != OP_REFGEN)
8778 exlist = (LISTOP *)refgen->op_first;
8779 if (!exlist || exlist->op_type != OP_NULL
8780 || exlist->op_targ != OP_LIST)
8783 if (exlist->op_first->op_type != OP_PUSHMARK)
8786 rv2cv = (UNOP*)exlist->op_last;
8788 if (rv2cv->op_type != OP_RV2CV)
8791 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
8792 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
8793 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
8795 o->op_private |= OPpASSIGN_CV_TO_GV;
8796 rv2gv->op_private |= OPpDONT_INIT_GV;
8797 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
8805 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
8806 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
8816 Perl_custom_op_name(pTHX_ const OP* o)
8819 const IV index = PTR2IV(o->op_ppaddr);
8823 PERL_ARGS_ASSERT_CUSTOM_OP_NAME;
8825 if (!PL_custom_op_names) /* This probably shouldn't happen */
8826 return (char *)PL_op_name[OP_CUSTOM];
8828 keysv = sv_2mortal(newSViv(index));
8830 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
8832 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
8834 return SvPV_nolen(HeVAL(he));
8838 Perl_custom_op_desc(pTHX_ const OP* o)
8841 const IV index = PTR2IV(o->op_ppaddr);
8845 PERL_ARGS_ASSERT_CUSTOM_OP_DESC;
8847 if (!PL_custom_op_descs)
8848 return (char *)PL_op_desc[OP_CUSTOM];
8850 keysv = sv_2mortal(newSViv(index));
8852 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
8854 return (char *)PL_op_desc[OP_CUSTOM];
8856 return SvPV_nolen(HeVAL(he));
8861 /* Efficient sub that returns a constant scalar value. */
8863 const_sv_xsub(pTHX_ CV* cv)
8870 Perl_croak(aTHX_ "usage: %s::%s()",
8871 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
8875 ST(0) = (SV*)XSANY.any_ptr;
8881 * c-indentation-style: bsd
8883 * indent-tabs-mode: t
8886 * ex: set ts=8 sts=4 sw=4 noet: