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");
919 Perl_scalarvoid(pTHX_ OP *o)
923 const char* useless = NULL;
927 PERL_ARGS_ASSERT_SCALARVOID;
929 /* trailing mad null ops don't count as "there" for void processing */
931 o->op_type != OP_NULL &&
933 o->op_sibling->op_type == OP_NULL)
936 for (sib = o->op_sibling;
937 sib && sib->op_type == OP_NULL;
938 sib = sib->op_sibling) ;
944 if (o->op_type == OP_NEXTSTATE
945 || o->op_type == OP_DBSTATE
946 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
947 || o->op_targ == OP_DBSTATE)))
948 PL_curcop = (COP*)o; /* for warning below */
950 /* assumes no premature commitment */
951 want = o->op_flags & OPf_WANT;
952 if ((want && want != OPf_WANT_SCALAR)
953 || (PL_parser && PL_parser->error_count)
954 || o->op_type == OP_RETURN)
959 if ((o->op_private & OPpTARGET_MY)
960 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
962 return scalar(o); /* As if inside SASSIGN */
965 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
967 switch (o->op_type) {
969 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
973 if (o->op_flags & OPf_STACKED)
977 if (o->op_private == 4)
1020 case OP_GETSOCKNAME:
1021 case OP_GETPEERNAME:
1026 case OP_GETPRIORITY:
1050 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1051 /* Otherwise it's "Useless use of grep iterator" */
1052 useless = OP_DESC(o);
1056 kid = cUNOPo->op_first;
1057 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1058 kid->op_type != OP_TRANS) {
1061 useless = "negative pattern binding (!~)";
1068 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1069 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1070 useless = "a variable";
1075 if (cSVOPo->op_private & OPpCONST_STRICT)
1076 no_bareword_allowed(o);
1078 if (ckWARN(WARN_VOID)) {
1080 SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_
1081 "a constant (%"SVf")", sv));
1082 useless = SvPV_nolen(msv);
1085 useless = "a constant (undef)";
1086 if (o->op_private & OPpCONST_ARYBASE)
1088 /* don't warn on optimised away booleans, eg
1089 * use constant Foo, 5; Foo || print; */
1090 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1092 /* the constants 0 and 1 are permitted as they are
1093 conventionally used as dummies in constructs like
1094 1 while some_condition_with_side_effects; */
1095 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1097 else if (SvPOK(sv)) {
1098 /* perl4's way of mixing documentation and code
1099 (before the invention of POD) was based on a
1100 trick to mix nroff and perl code. The trick was
1101 built upon these three nroff macros being used in
1102 void context. The pink camel has the details in
1103 the script wrapman near page 319. */
1104 const char * const maybe_macro = SvPVX_const(sv);
1105 if (strnEQ(maybe_macro, "di", 2) ||
1106 strnEQ(maybe_macro, "ds", 2) ||
1107 strnEQ(maybe_macro, "ig", 2))
1112 op_null(o); /* don't execute or even remember it */
1116 o->op_type = OP_PREINC; /* pre-increment is faster */
1117 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1121 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1122 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1126 o->op_type = OP_I_PREINC; /* pre-increment is faster */
1127 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1131 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
1132 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1141 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1146 if (o->op_flags & OPf_STACKED)
1153 if (!(o->op_flags & OPf_KIDS))
1164 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1171 /* all requires must return a boolean value */
1172 o->op_flags &= ~OPf_WANT;
1177 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
1178 if (!kPMOP->op_pmreplrootu.op_pmreplroot)
1179 deprecate_old("implicit split to @_");
1183 if (useless && ckWARN(WARN_VOID))
1184 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
1189 Perl_listkids(pTHX_ OP *o)
1191 if (o && o->op_flags & OPf_KIDS) {
1193 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1200 Perl_list(pTHX_ OP *o)
1205 /* assumes no premature commitment */
1206 if (!o || (o->op_flags & OPf_WANT)
1207 || (PL_parser && PL_parser->error_count)
1208 || o->op_type == OP_RETURN)
1213 if ((o->op_private & OPpTARGET_MY)
1214 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1216 return o; /* As if inside SASSIGN */
1219 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1221 switch (o->op_type) {
1224 list(cBINOPo->op_first);
1229 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1237 if (!(o->op_flags & OPf_KIDS))
1239 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1240 list(cBINOPo->op_first);
1241 return gen_constant_list(o);
1248 kid = cLISTOPo->op_first;
1250 while ((kid = kid->op_sibling)) {
1251 if (kid->op_sibling)
1256 PL_curcop = &PL_compiling;
1260 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1261 if (kid->op_sibling)
1266 PL_curcop = &PL_compiling;
1269 /* all requires must return a boolean value */
1270 o->op_flags &= ~OPf_WANT;
1277 Perl_scalarseq(pTHX_ OP *o)
1281 const OPCODE type = o->op_type;
1283 if (type == OP_LINESEQ || type == OP_SCOPE ||
1284 type == OP_LEAVE || type == OP_LEAVETRY)
1287 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1288 if (kid->op_sibling) {
1292 PL_curcop = &PL_compiling;
1294 o->op_flags &= ~OPf_PARENS;
1295 if (PL_hints & HINT_BLOCK_SCOPE)
1296 o->op_flags |= OPf_PARENS;
1299 o = newOP(OP_STUB, 0);
1304 S_modkids(pTHX_ OP *o, I32 type)
1306 if (o && o->op_flags & OPf_KIDS) {
1308 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1314 /* Propagate lvalue ("modifiable") context to an op and its children.
1315 * 'type' represents the context type, roughly based on the type of op that
1316 * would do the modifying, although local() is represented by OP_NULL.
1317 * It's responsible for detecting things that can't be modified, flag
1318 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
1319 * might have to vivify a reference in $x), and so on.
1321 * For example, "$a+1 = 2" would cause mod() to be called with o being
1322 * OP_ADD and type being OP_SASSIGN, and would output an error.
1326 Perl_mod(pTHX_ OP *o, I32 type)
1330 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1333 if (!o || (PL_parser && PL_parser->error_count))
1336 if ((o->op_private & OPpTARGET_MY)
1337 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1342 switch (o->op_type) {
1348 if (!(o->op_private & OPpCONST_ARYBASE))
1351 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1352 CopARYBASE_set(&PL_compiling,
1353 (I32)SvIV(cSVOPx(PL_eval_start)->op_sv));
1357 SAVECOPARYBASE(&PL_compiling);
1358 CopARYBASE_set(&PL_compiling, 0);
1360 else if (type == OP_REFGEN)
1363 Perl_croak(aTHX_ "That use of $[ is unsupported");
1366 if ((o->op_flags & OPf_PARENS) || PL_madskills)
1370 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1371 !(o->op_flags & OPf_STACKED)) {
1372 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1373 /* The default is to set op_private to the number of children,
1374 which for a UNOP such as RV2CV is always 1. And w're using
1375 the bit for a flag in RV2CV, so we need it clear. */
1376 o->op_private &= ~1;
1377 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1378 assert(cUNOPo->op_first->op_type == OP_NULL);
1379 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1382 else if (o->op_private & OPpENTERSUB_NOMOD)
1384 else { /* lvalue subroutine call */
1385 o->op_private |= OPpLVAL_INTRO;
1386 PL_modcount = RETURN_UNLIMITED_NUMBER;
1387 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1388 /* Backward compatibility mode: */
1389 o->op_private |= OPpENTERSUB_INARGS;
1392 else { /* Compile-time error message: */
1393 OP *kid = cUNOPo->op_first;
1397 if (kid->op_type != OP_PUSHMARK) {
1398 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1400 "panic: unexpected lvalue entersub "
1401 "args: type/targ %ld:%"UVuf,
1402 (long)kid->op_type, (UV)kid->op_targ);
1403 kid = kLISTOP->op_first;
1405 while (kid->op_sibling)
1406 kid = kid->op_sibling;
1407 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1409 if (kid->op_type == OP_METHOD_NAMED
1410 || kid->op_type == OP_METHOD)
1414 NewOp(1101, newop, 1, UNOP);
1415 newop->op_type = OP_RV2CV;
1416 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1417 newop->op_first = NULL;
1418 newop->op_next = (OP*)newop;
1419 kid->op_sibling = (OP*)newop;
1420 newop->op_private |= OPpLVAL_INTRO;
1421 newop->op_private &= ~1;
1425 if (kid->op_type != OP_RV2CV)
1427 "panic: unexpected lvalue entersub "
1428 "entry via type/targ %ld:%"UVuf,
1429 (long)kid->op_type, (UV)kid->op_targ);
1430 kid->op_private |= OPpLVAL_INTRO;
1431 break; /* Postpone until runtime */
1435 kid = kUNOP->op_first;
1436 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1437 kid = kUNOP->op_first;
1438 if (kid->op_type == OP_NULL)
1440 "Unexpected constant lvalue entersub "
1441 "entry via type/targ %ld:%"UVuf,
1442 (long)kid->op_type, (UV)kid->op_targ);
1443 if (kid->op_type != OP_GV) {
1444 /* Restore RV2CV to check lvalueness */
1446 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1447 okid->op_next = kid->op_next;
1448 kid->op_next = okid;
1451 okid->op_next = NULL;
1452 okid->op_type = OP_RV2CV;
1454 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1455 okid->op_private |= OPpLVAL_INTRO;
1456 okid->op_private &= ~1;
1460 cv = GvCV(kGVOP_gv);
1470 /* grep, foreach, subcalls, refgen */
1471 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1473 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1474 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1476 : (o->op_type == OP_ENTERSUB
1477 ? "non-lvalue subroutine call"
1479 type ? PL_op_desc[type] : "local"));
1493 case OP_RIGHT_SHIFT:
1502 if (!(o->op_flags & OPf_STACKED))
1509 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1515 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1516 PL_modcount = RETURN_UNLIMITED_NUMBER;
1517 return o; /* Treat \(@foo) like ordinary list. */
1521 if (scalar_mod_type(o, type))
1523 ref(cUNOPo->op_first, o->op_type);
1527 if (type == OP_LEAVESUBLV)
1528 o->op_private |= OPpMAYBE_LVSUB;
1534 PL_modcount = RETURN_UNLIMITED_NUMBER;
1537 ref(cUNOPo->op_first, o->op_type);
1542 PL_hints |= HINT_BLOCK_SCOPE;
1557 PL_modcount = RETURN_UNLIMITED_NUMBER;
1558 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1559 return o; /* Treat \(@foo) like ordinary list. */
1560 if (scalar_mod_type(o, type))
1562 if (type == OP_LEAVESUBLV)
1563 o->op_private |= OPpMAYBE_LVSUB;
1567 if (!type) /* local() */
1568 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1569 PAD_COMPNAME_PV(o->op_targ));
1577 if (type != OP_SASSIGN)
1581 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1586 if (type == OP_LEAVESUBLV)
1587 o->op_private |= OPpMAYBE_LVSUB;
1589 pad_free(o->op_targ);
1590 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1591 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1592 if (o->op_flags & OPf_KIDS)
1593 mod(cBINOPo->op_first->op_sibling, type);
1598 ref(cBINOPo->op_first, o->op_type);
1599 if (type == OP_ENTERSUB &&
1600 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1601 o->op_private |= OPpLVAL_DEFER;
1602 if (type == OP_LEAVESUBLV)
1603 o->op_private |= OPpMAYBE_LVSUB;
1613 if (o->op_flags & OPf_KIDS)
1614 mod(cLISTOPo->op_last, type);
1619 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1621 else if (!(o->op_flags & OPf_KIDS))
1623 if (o->op_targ != OP_LIST) {
1624 mod(cBINOPo->op_first, type);
1630 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1635 if (type != OP_LEAVESUBLV)
1637 break; /* mod()ing was handled by ck_return() */
1640 /* [20011101.069] File test operators interpret OPf_REF to mean that
1641 their argument is a filehandle; thus \stat(".") should not set
1643 if (type == OP_REFGEN &&
1644 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1647 if (type != OP_LEAVESUBLV)
1648 o->op_flags |= OPf_MOD;
1650 if (type == OP_AASSIGN || type == OP_SASSIGN)
1651 o->op_flags |= OPf_SPECIAL|OPf_REF;
1652 else if (!type) { /* local() */
1655 o->op_private |= OPpLVAL_INTRO;
1656 o->op_flags &= ~OPf_SPECIAL;
1657 PL_hints |= HINT_BLOCK_SCOPE;
1662 if (ckWARN(WARN_SYNTAX)) {
1663 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1664 "Useless localization of %s", OP_DESC(o));
1668 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1669 && type != OP_LEAVESUBLV)
1670 o->op_flags |= OPf_REF;
1675 S_scalar_mod_type(const OP *o, I32 type)
1677 PERL_ARGS_ASSERT_SCALAR_MOD_TYPE;
1681 if (o->op_type == OP_RV2GV)
1705 case OP_RIGHT_SHIFT:
1725 S_is_handle_constructor(const OP *o, I32 numargs)
1727 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
1729 switch (o->op_type) {
1737 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1750 Perl_refkids(pTHX_ OP *o, I32 type)
1752 if (o && o->op_flags & OPf_KIDS) {
1754 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1761 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
1766 PERL_ARGS_ASSERT_DOREF;
1768 if (!o || (PL_parser && PL_parser->error_count))
1771 switch (o->op_type) {
1773 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1774 !(o->op_flags & OPf_STACKED)) {
1775 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1776 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1777 assert(cUNOPo->op_first->op_type == OP_NULL);
1778 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1779 o->op_flags |= OPf_SPECIAL;
1780 o->op_private &= ~1;
1785 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1786 doref(kid, type, set_op_ref);
1789 if (type == OP_DEFINED)
1790 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1791 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1794 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1795 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1796 : type == OP_RV2HV ? OPpDEREF_HV
1798 o->op_flags |= OPf_MOD;
1805 o->op_flags |= OPf_REF;
1808 if (type == OP_DEFINED)
1809 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1810 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1816 o->op_flags |= OPf_REF;
1821 if (!(o->op_flags & OPf_KIDS))
1823 doref(cBINOPo->op_first, type, set_op_ref);
1827 doref(cBINOPo->op_first, o->op_type, set_op_ref);
1828 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1829 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1830 : type == OP_RV2HV ? OPpDEREF_HV
1832 o->op_flags |= OPf_MOD;
1842 if (!(o->op_flags & OPf_KIDS))
1844 doref(cLISTOPo->op_last, type, set_op_ref);
1854 S_dup_attrlist(pTHX_ OP *o)
1859 PERL_ARGS_ASSERT_DUP_ATTRLIST;
1861 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1862 * where the first kid is OP_PUSHMARK and the remaining ones
1863 * are OP_CONST. We need to push the OP_CONST values.
1865 if (o->op_type == OP_CONST)
1866 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
1868 else if (o->op_type == OP_NULL)
1872 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1874 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1875 if (o->op_type == OP_CONST)
1876 rop = append_elem(OP_LIST, rop,
1877 newSVOP(OP_CONST, o->op_flags,
1878 SvREFCNT_inc_NN(cSVOPo->op_sv)));
1885 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1890 PERL_ARGS_ASSERT_APPLY_ATTRS;
1892 /* fake up C<use attributes $pkg,$rv,@attrs> */
1893 ENTER; /* need to protect against side-effects of 'use' */
1894 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1896 #define ATTRSMODULE "attributes"
1897 #define ATTRSMODULE_PM "attributes.pm"
1900 /* Don't force the C<use> if we don't need it. */
1901 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
1902 if (svp && *svp != &PL_sv_undef)
1903 NOOP; /* already in %INC */
1905 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1906 newSVpvs(ATTRSMODULE), NULL);
1909 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1910 newSVpvs(ATTRSMODULE),
1912 prepend_elem(OP_LIST,
1913 newSVOP(OP_CONST, 0, stashsv),
1914 prepend_elem(OP_LIST,
1915 newSVOP(OP_CONST, 0,
1917 dup_attrlist(attrs))));
1923 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1926 OP *pack, *imop, *arg;
1929 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
1934 assert(target->op_type == OP_PADSV ||
1935 target->op_type == OP_PADHV ||
1936 target->op_type == OP_PADAV);
1938 /* Ensure that attributes.pm is loaded. */
1939 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1941 /* Need package name for method call. */
1942 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
1944 /* Build up the real arg-list. */
1945 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1947 arg = newOP(OP_PADSV, 0);
1948 arg->op_targ = target->op_targ;
1949 arg = prepend_elem(OP_LIST,
1950 newSVOP(OP_CONST, 0, stashsv),
1951 prepend_elem(OP_LIST,
1952 newUNOP(OP_REFGEN, 0,
1953 mod(arg, OP_REFGEN)),
1954 dup_attrlist(attrs)));
1956 /* Fake up a method call to import */
1957 meth = newSVpvs_share("import");
1958 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1959 append_elem(OP_LIST,
1960 prepend_elem(OP_LIST, pack, list(arg)),
1961 newSVOP(OP_METHOD_NAMED, 0, meth)));
1962 imop->op_private |= OPpENTERSUB_NOMOD;
1964 /* Combine the ops. */
1965 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1969 =notfor apidoc apply_attrs_string
1971 Attempts to apply a list of attributes specified by the C<attrstr> and
1972 C<len> arguments to the subroutine identified by the C<cv> argument which
1973 is expected to be associated with the package identified by the C<stashpv>
1974 argument (see L<attributes>). It gets this wrong, though, in that it
1975 does not correctly identify the boundaries of the individual attribute
1976 specifications within C<attrstr>. This is not really intended for the
1977 public API, but has to be listed here for systems such as AIX which
1978 need an explicit export list for symbols. (It's called from XS code
1979 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1980 to respect attribute syntax properly would be welcome.
1986 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
1987 const char *attrstr, STRLEN len)
1991 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
1994 len = strlen(attrstr);
1998 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2000 const char * const sstr = attrstr;
2001 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2002 attrs = append_elem(OP_LIST, attrs,
2003 newSVOP(OP_CONST, 0,
2004 newSVpvn(sstr, attrstr-sstr)));
2008 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2009 newSVpvs(ATTRSMODULE),
2010 NULL, prepend_elem(OP_LIST,
2011 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2012 prepend_elem(OP_LIST,
2013 newSVOP(OP_CONST, 0,
2019 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
2024 PERL_ARGS_ASSERT_MY_KID;
2026 if (!o || (PL_parser && PL_parser->error_count))
2030 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
2031 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
2035 if (type == OP_LIST) {
2037 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2038 my_kid(kid, attrs, imopsp);
2039 } else if (type == OP_UNDEF
2045 } else if (type == OP_RV2SV || /* "our" declaration */
2047 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
2048 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
2049 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2051 PL_parser->in_my == KEY_our
2053 : PL_parser->in_my == KEY_state ? "state" : "my"));
2055 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
2056 PL_parser->in_my = FALSE;
2057 PL_parser->in_my_stash = NULL;
2058 apply_attrs(GvSTASH(gv),
2059 (type == OP_RV2SV ? GvSV(gv) :
2060 type == OP_RV2AV ? (SV*)GvAV(gv) :
2061 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
2064 o->op_private |= OPpOUR_INTRO;
2067 else if (type != OP_PADSV &&
2070 type != OP_PUSHMARK)
2072 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2074 PL_parser->in_my == KEY_our
2076 : PL_parser->in_my == KEY_state ? "state" : "my"));
2079 else if (attrs && type != OP_PUSHMARK) {
2082 PL_parser->in_my = FALSE;
2083 PL_parser->in_my_stash = NULL;
2085 /* check for C<my Dog $spot> when deciding package */
2086 stash = PAD_COMPNAME_TYPE(o->op_targ);
2088 stash = PL_curstash;
2089 apply_attrs_my(stash, o, attrs, imopsp);
2091 o->op_flags |= OPf_MOD;
2092 o->op_private |= OPpLVAL_INTRO;
2093 if (PL_parser->in_my == KEY_state)
2094 o->op_private |= OPpPAD_STATE;
2099 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2103 int maybe_scalar = 0;
2105 PERL_ARGS_ASSERT_MY_ATTRS;
2107 /* [perl #17376]: this appears to be premature, and results in code such as
2108 C< our(%x); > executing in list mode rather than void mode */
2110 if (o->op_flags & OPf_PARENS)
2120 o = my_kid(o, attrs, &rops);
2122 if (maybe_scalar && o->op_type == OP_PADSV) {
2123 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
2124 o->op_private |= OPpLVAL_INTRO;
2127 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
2129 PL_parser->in_my = FALSE;
2130 PL_parser->in_my_stash = NULL;
2135 Perl_my(pTHX_ OP *o)
2137 PERL_ARGS_ASSERT_MY;
2139 return my_attrs(o, NULL);
2143 Perl_sawparens(pTHX_ OP *o)
2145 PERL_UNUSED_CONTEXT;
2147 o->op_flags |= OPf_PARENS;
2152 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2156 const OPCODE ltype = left->op_type;
2157 const OPCODE rtype = right->op_type;
2159 PERL_ARGS_ASSERT_BIND_MATCH;
2161 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2162 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
2164 const char * const desc
2165 = PL_op_desc[(rtype == OP_SUBST || rtype == OP_TRANS)
2166 ? (int)rtype : OP_MATCH];
2167 const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV)
2168 ? "@array" : "%hash");
2169 Perl_warner(aTHX_ packWARN(WARN_MISC),
2170 "Applying %s to %s will act on scalar(%s)",
2171 desc, sample, sample);
2174 if (rtype == OP_CONST &&
2175 cSVOPx(right)->op_private & OPpCONST_BARE &&
2176 cSVOPx(right)->op_private & OPpCONST_STRICT)
2178 no_bareword_allowed(right);
2181 ismatchop = rtype == OP_MATCH ||
2182 rtype == OP_SUBST ||
2184 if (ismatchop && right->op_private & OPpTARGET_MY) {
2186 right->op_private &= ~OPpTARGET_MY;
2188 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
2191 right->op_flags |= OPf_STACKED;
2192 if (rtype != OP_MATCH &&
2193 ! (rtype == OP_TRANS &&
2194 right->op_private & OPpTRANS_IDENTICAL))
2195 newleft = mod(left, rtype);
2198 if (right->op_type == OP_TRANS)
2199 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
2201 o = prepend_elem(rtype, scalar(newleft), right);
2203 return newUNOP(OP_NOT, 0, scalar(o));
2207 return bind_match(type, left,
2208 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
2212 Perl_invert(pTHX_ OP *o)
2216 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2220 Perl_scope(pTHX_ OP *o)
2224 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2225 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2226 o->op_type = OP_LEAVE;
2227 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2229 else if (o->op_type == OP_LINESEQ) {
2231 o->op_type = OP_SCOPE;
2232 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2233 kid = ((LISTOP*)o)->op_first;
2234 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2237 /* The following deals with things like 'do {1 for 1}' */
2238 kid = kid->op_sibling;
2240 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2245 o = newLISTOP(OP_SCOPE, 0, o, NULL);
2251 Perl_block_start(pTHX_ int full)
2254 const int retval = PL_savestack_ix;
2255 pad_block_start(full);
2257 PL_hints &= ~HINT_BLOCK_SCOPE;
2258 SAVECOMPILEWARNINGS();
2259 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
2264 Perl_block_end(pTHX_ I32 floor, OP *seq)
2267 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2268 OP* const retval = scalarseq(seq);
2270 CopHINTS_set(&PL_compiling, PL_hints);
2272 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2281 const PADOFFSET offset = pad_findmy("$_");
2282 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
2283 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2286 OP * const o = newOP(OP_PADSV, 0);
2287 o->op_targ = offset;
2293 Perl_newPROG(pTHX_ OP *o)
2297 PERL_ARGS_ASSERT_NEWPROG;
2302 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2303 ((PL_in_eval & EVAL_KEEPERR)
2304 ? OPf_SPECIAL : 0), o);
2305 PL_eval_start = linklist(PL_eval_root);
2306 PL_eval_root->op_private |= OPpREFCOUNTED;
2307 OpREFCNT_set(PL_eval_root, 1);
2308 PL_eval_root->op_next = 0;
2309 CALL_PEEP(PL_eval_start);
2312 if (o->op_type == OP_STUB) {
2313 PL_comppad_name = 0;
2315 S_op_destroy(aTHX_ o);
2318 PL_main_root = scope(sawparens(scalarvoid(o)));
2319 PL_curcop = &PL_compiling;
2320 PL_main_start = LINKLIST(PL_main_root);
2321 PL_main_root->op_private |= OPpREFCOUNTED;
2322 OpREFCNT_set(PL_main_root, 1);
2323 PL_main_root->op_next = 0;
2324 CALL_PEEP(PL_main_start);
2327 /* Register with debugger */
2330 = Perl_get_cvn_flags(aTHX_ STR_WITH_LEN("DB::postponed"), 0);
2334 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2336 call_sv((SV*)cv, G_DISCARD);
2343 Perl_localize(pTHX_ OP *o, I32 lex)
2347 PERL_ARGS_ASSERT_LOCALIZE;
2349 if (o->op_flags & OPf_PARENS)
2350 /* [perl #17376]: this appears to be premature, and results in code such as
2351 C< our(%x); > executing in list mode rather than void mode */
2358 if ( PL_parser->bufptr > PL_parser->oldbufptr
2359 && PL_parser->bufptr[-1] == ','
2360 && ckWARN(WARN_PARENTHESIS))
2362 char *s = PL_parser->bufptr;
2365 /* some heuristics to detect a potential error */
2366 while (*s && (strchr(", \t\n", *s)))
2370 if (*s && strchr("@$%*", *s) && *++s
2371 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2374 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2376 while (*s && (strchr(", \t\n", *s)))
2382 if (sigil && (*s == ';' || *s == '=')) {
2383 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2384 "Parentheses missing around \"%s\" list",
2386 ? (PL_parser->in_my == KEY_our
2388 : PL_parser->in_my == KEY_state
2398 o = mod(o, OP_NULL); /* a bit kludgey */
2399 PL_parser->in_my = FALSE;
2400 PL_parser->in_my_stash = NULL;
2405 Perl_jmaybe(pTHX_ OP *o)
2407 PERL_ARGS_ASSERT_JMAYBE;
2409 if (o->op_type == OP_LIST) {
2411 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2412 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2418 Perl_fold_constants(pTHX_ register OP *o)
2421 register OP * VOL curop;
2423 VOL I32 type = o->op_type;
2428 SV * const oldwarnhook = PL_warnhook;
2429 SV * const olddiehook = PL_diehook;
2432 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
2434 if (PL_opargs[type] & OA_RETSCALAR)
2436 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2437 o->op_targ = pad_alloc(type, SVs_PADTMP);
2439 /* integerize op, unless it happens to be C<-foo>.
2440 * XXX should pp_i_negate() do magic string negation instead? */
2441 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2442 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2443 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2445 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2448 if (!(PL_opargs[type] & OA_FOLDCONST))
2453 /* XXX might want a ck_negate() for this */
2454 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2465 /* XXX what about the numeric ops? */
2466 if (PL_hints & HINT_LOCALE)
2470 if (PL_parser && PL_parser->error_count)
2471 goto nope; /* Don't try to run w/ errors */
2473 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2474 const OPCODE type = curop->op_type;
2475 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2477 type != OP_SCALAR &&
2479 type != OP_PUSHMARK)
2485 curop = LINKLIST(o);
2486 old_next = o->op_next;
2490 oldscope = PL_scopestack_ix;
2491 create_eval_scope(G_FAKINGEVAL);
2493 PL_warnhook = PERL_WARNHOOK_FATAL;
2500 sv = *(PL_stack_sp--);
2501 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2502 pad_swipe(o->op_targ, FALSE);
2503 else if (SvTEMP(sv)) { /* grab mortal temp? */
2504 SvREFCNT_inc_simple_void(sv);
2509 /* Something tried to die. Abandon constant folding. */
2510 /* Pretend the error never happened. */
2511 sv_setpvn(ERRSV,"",0);
2512 o->op_next = old_next;
2516 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
2517 PL_warnhook = oldwarnhook;
2518 PL_diehook = olddiehook;
2519 /* XXX note that this croak may fail as we've already blown away
2520 * the stack - eg any nested evals */
2521 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
2524 PL_warnhook = oldwarnhook;
2525 PL_diehook = olddiehook;
2527 if (PL_scopestack_ix > oldscope)
2528 delete_eval_scope();
2537 if (type == OP_RV2GV)
2538 newop = newGVOP(OP_GV, 0, (GV*)sv);
2540 newop = newSVOP(OP_CONST, 0, (SV*)sv);
2541 op_getmad(o,newop,'f');
2549 Perl_gen_constant_list(pTHX_ register OP *o)
2553 const I32 oldtmps_floor = PL_tmps_floor;
2556 if (PL_parser && PL_parser->error_count)
2557 return o; /* Don't attempt to run with errors */
2559 PL_op = curop = LINKLIST(o);
2565 assert (!(curop->op_flags & OPf_SPECIAL));
2566 assert(curop->op_type == OP_RANGE);
2568 PL_tmps_floor = oldtmps_floor;
2570 o->op_type = OP_RV2AV;
2571 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2572 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2573 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2574 o->op_opt = 0; /* needs to be revisited in peep() */
2575 curop = ((UNOP*)o)->op_first;
2576 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
2578 op_getmad(curop,o,'O');
2587 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2590 if (!o || o->op_type != OP_LIST)
2591 o = newLISTOP(OP_LIST, 0, o, NULL);
2593 o->op_flags &= ~OPf_WANT;
2595 if (!(PL_opargs[type] & OA_MARK))
2596 op_null(cLISTOPo->op_first);
2598 o->op_type = (OPCODE)type;
2599 o->op_ppaddr = PL_ppaddr[type];
2600 o->op_flags |= flags;
2602 o = CHECKOP(type, o);
2603 if (o->op_type != (unsigned)type)
2606 return fold_constants(o);
2609 /* List constructors */
2612 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2620 if (first->op_type != (unsigned)type
2621 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2623 return newLISTOP(type, 0, first, last);
2626 if (first->op_flags & OPf_KIDS)
2627 ((LISTOP*)first)->op_last->op_sibling = last;
2629 first->op_flags |= OPf_KIDS;
2630 ((LISTOP*)first)->op_first = last;
2632 ((LISTOP*)first)->op_last = last;
2637 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2645 if (first->op_type != (unsigned)type)
2646 return prepend_elem(type, (OP*)first, (OP*)last);
2648 if (last->op_type != (unsigned)type)
2649 return append_elem(type, (OP*)first, (OP*)last);
2651 first->op_last->op_sibling = last->op_first;
2652 first->op_last = last->op_last;
2653 first->op_flags |= (last->op_flags & OPf_KIDS);
2656 if (last->op_first && first->op_madprop) {
2657 MADPROP *mp = last->op_first->op_madprop;
2659 while (mp->mad_next)
2661 mp->mad_next = first->op_madprop;
2664 last->op_first->op_madprop = first->op_madprop;
2667 first->op_madprop = last->op_madprop;
2668 last->op_madprop = 0;
2671 S_op_destroy(aTHX_ (OP*)last);
2677 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2685 if (last->op_type == (unsigned)type) {
2686 if (type == OP_LIST) { /* already a PUSHMARK there */
2687 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2688 ((LISTOP*)last)->op_first->op_sibling = first;
2689 if (!(first->op_flags & OPf_PARENS))
2690 last->op_flags &= ~OPf_PARENS;
2693 if (!(last->op_flags & OPf_KIDS)) {
2694 ((LISTOP*)last)->op_last = first;
2695 last->op_flags |= OPf_KIDS;
2697 first->op_sibling = ((LISTOP*)last)->op_first;
2698 ((LISTOP*)last)->op_first = first;
2700 last->op_flags |= OPf_KIDS;
2704 return newLISTOP(type, 0, first, last);
2712 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2715 Newxz(tk, 1, TOKEN);
2716 tk->tk_type = (OPCODE)optype;
2717 tk->tk_type = 12345;
2719 tk->tk_mad = madprop;
2724 Perl_token_free(pTHX_ TOKEN* tk)
2726 PERL_ARGS_ASSERT_TOKEN_FREE;
2728 if (tk->tk_type != 12345)
2730 mad_free(tk->tk_mad);
2735 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2740 PERL_ARGS_ASSERT_TOKEN_GETMAD;
2742 if (tk->tk_type != 12345) {
2743 Perl_warner(aTHX_ packWARN(WARN_MISC),
2744 "Invalid TOKEN object ignored");
2751 /* faked up qw list? */
2753 tm->mad_type == MAD_SV &&
2754 SvPVX((SV*)tm->mad_val)[0] == 'q')
2761 /* pretend constant fold didn't happen? */
2762 if (mp->mad_key == 'f' &&
2763 (o->op_type == OP_CONST ||
2764 o->op_type == OP_GV) )
2766 token_getmad(tk,(OP*)mp->mad_val,slot);
2780 if (mp->mad_key == 'X')
2781 mp->mad_key = slot; /* just change the first one */
2791 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
2800 /* pretend constant fold didn't happen? */
2801 if (mp->mad_key == 'f' &&
2802 (o->op_type == OP_CONST ||
2803 o->op_type == OP_GV) )
2805 op_getmad(from,(OP*)mp->mad_val,slot);
2812 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
2815 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
2821 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
2830 /* pretend constant fold didn't happen? */
2831 if (mp->mad_key == 'f' &&
2832 (o->op_type == OP_CONST ||
2833 o->op_type == OP_GV) )
2835 op_getmad(from,(OP*)mp->mad_val,slot);
2842 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
2845 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
2849 PerlIO_printf(PerlIO_stderr(),
2850 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
2856 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
2874 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
2878 addmad(tm, &(o->op_madprop), slot);
2882 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
2903 Perl_newMADsv(pTHX_ char key, SV* sv)
2905 PERL_ARGS_ASSERT_NEWMADSV;
2907 return newMADPROP(key, MAD_SV, sv, 0);
2911 Perl_newMADPROP(pTHX_ char key, char type, const void* val, I32 vlen)
2914 Newxz(mp, 1, MADPROP);
2917 mp->mad_vlen = vlen;
2918 mp->mad_type = type;
2920 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
2925 Perl_mad_free(pTHX_ MADPROP* mp)
2927 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
2931 mad_free(mp->mad_next);
2932 /* if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
2933 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
2934 switch (mp->mad_type) {
2938 Safefree((char*)mp->mad_val);
2941 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
2942 op_free((OP*)mp->mad_val);
2945 sv_free((SV*)mp->mad_val);
2948 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
2957 Perl_newNULLLIST(pTHX)
2959 return newOP(OP_STUB, 0);
2963 Perl_force_list(pTHX_ OP *o)
2965 if (!o || o->op_type != OP_LIST)
2966 o = newLISTOP(OP_LIST, 0, o, NULL);
2972 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2977 NewOp(1101, listop, 1, LISTOP);
2979 listop->op_type = (OPCODE)type;
2980 listop->op_ppaddr = PL_ppaddr[type];
2983 listop->op_flags = (U8)flags;
2987 else if (!first && last)
2990 first->op_sibling = last;
2991 listop->op_first = first;
2992 listop->op_last = last;
2993 if (type == OP_LIST) {
2994 OP* const pushop = newOP(OP_PUSHMARK, 0);
2995 pushop->op_sibling = first;
2996 listop->op_first = pushop;
2997 listop->op_flags |= OPf_KIDS;
2999 listop->op_last = pushop;
3002 return CHECKOP(type, listop);
3006 Perl_newOP(pTHX_ I32 type, I32 flags)
3010 NewOp(1101, o, 1, OP);
3011 o->op_type = (OPCODE)type;
3012 o->op_ppaddr = PL_ppaddr[type];
3013 o->op_flags = (U8)flags;
3015 o->op_latefreed = 0;
3019 o->op_private = (U8)(0 | (flags >> 8));
3020 if (PL_opargs[type] & OA_RETSCALAR)
3022 if (PL_opargs[type] & OA_TARGET)
3023 o->op_targ = pad_alloc(type, SVs_PADTMP);
3024 return CHECKOP(type, o);
3028 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
3034 first = newOP(OP_STUB, 0);
3035 if (PL_opargs[type] & OA_MARK)
3036 first = force_list(first);
3038 NewOp(1101, unop, 1, UNOP);
3039 unop->op_type = (OPCODE)type;
3040 unop->op_ppaddr = PL_ppaddr[type];
3041 unop->op_first = first;
3042 unop->op_flags = (U8)(flags | OPf_KIDS);
3043 unop->op_private = (U8)(1 | (flags >> 8));
3044 unop = (UNOP*) CHECKOP(type, unop);
3048 return fold_constants((OP *) unop);
3052 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3056 NewOp(1101, binop, 1, BINOP);
3059 first = newOP(OP_NULL, 0);
3061 binop->op_type = (OPCODE)type;
3062 binop->op_ppaddr = PL_ppaddr[type];
3063 binop->op_first = first;
3064 binop->op_flags = (U8)(flags | OPf_KIDS);
3067 binop->op_private = (U8)(1 | (flags >> 8));
3070 binop->op_private = (U8)(2 | (flags >> 8));
3071 first->op_sibling = last;
3074 binop = (BINOP*)CHECKOP(type, binop);
3075 if (binop->op_next || binop->op_type != (OPCODE)type)
3078 binop->op_last = binop->op_first->op_sibling;
3080 return fold_constants((OP *)binop);
3083 static int uvcompare(const void *a, const void *b)
3084 __attribute__nonnull__(1)
3085 __attribute__nonnull__(2)
3086 __attribute__pure__;
3087 static int uvcompare(const void *a, const void *b)
3089 if (*((const UV *)a) < (*(const UV *)b))
3091 if (*((const UV *)a) > (*(const UV *)b))
3093 if (*((const UV *)a+1) < (*(const UV *)b+1))
3095 if (*((const UV *)a+1) > (*(const UV *)b+1))
3101 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
3104 SV * const tstr = ((SVOP*)expr)->op_sv;
3107 (repl->op_type == OP_NULL)
3108 ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
3110 ((SVOP*)repl)->op_sv;
3113 const U8 *t = (U8*)SvPV_const(tstr, tlen);
3114 const U8 *r = (U8*)SvPV_const(rstr, rlen);
3118 register short *tbl;
3120 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
3121 const I32 squash = o->op_private & OPpTRANS_SQUASH;
3122 I32 del = o->op_private & OPpTRANS_DELETE;
3125 PERL_ARGS_ASSERT_PMTRANS;
3127 PL_hints |= HINT_BLOCK_SCOPE;
3130 o->op_private |= OPpTRANS_FROM_UTF;
3133 o->op_private |= OPpTRANS_TO_UTF;
3135 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
3136 SV* const listsv = newSVpvs("# comment\n");
3138 const U8* tend = t + tlen;
3139 const U8* rend = r + rlen;
3153 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
3154 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
3157 const U32 flags = UTF8_ALLOW_DEFAULT;
3161 t = tsave = bytes_to_utf8(t, &len);
3164 if (!to_utf && rlen) {
3166 r = rsave = bytes_to_utf8(r, &len);
3170 /* There are several snags with this code on EBCDIC:
3171 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
3172 2. scan_const() in toke.c has encoded chars in native encoding which makes
3173 ranges at least in EBCDIC 0..255 range the bottom odd.
3177 U8 tmpbuf[UTF8_MAXBYTES+1];
3180 Newx(cp, 2*tlen, UV);
3182 transv = newSVpvs("");
3184 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3186 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
3188 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3192 cp[2*i+1] = cp[2*i];
3196 qsort(cp, i, 2*sizeof(UV), uvcompare);
3197 for (j = 0; j < i; j++) {
3199 diff = val - nextmin;
3201 t = uvuni_to_utf8(tmpbuf,nextmin);
3202 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3204 U8 range_mark = UTF_TO_NATIVE(0xff);
3205 t = uvuni_to_utf8(tmpbuf, val - 1);
3206 sv_catpvn(transv, (char *)&range_mark, 1);
3207 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3214 t = uvuni_to_utf8(tmpbuf,nextmin);
3215 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3217 U8 range_mark = UTF_TO_NATIVE(0xff);
3218 sv_catpvn(transv, (char *)&range_mark, 1);
3220 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
3221 UNICODE_ALLOW_SUPER);
3222 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3223 t = (const U8*)SvPVX_const(transv);
3224 tlen = SvCUR(transv);
3228 else if (!rlen && !del) {
3229 r = t; rlen = tlen; rend = tend;
3232 if ((!rlen && !del) || t == r ||
3233 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
3235 o->op_private |= OPpTRANS_IDENTICAL;
3239 while (t < tend || tfirst <= tlast) {
3240 /* see if we need more "t" chars */
3241 if (tfirst > tlast) {
3242 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3244 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
3246 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3253 /* now see if we need more "r" chars */
3254 if (rfirst > rlast) {
3256 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3258 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
3260 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3269 rfirst = rlast = 0xffffffff;
3273 /* now see which range will peter our first, if either. */
3274 tdiff = tlast - tfirst;
3275 rdiff = rlast - rfirst;
3282 if (rfirst == 0xffffffff) {
3283 diff = tdiff; /* oops, pretend rdiff is infinite */
3285 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
3286 (long)tfirst, (long)tlast);
3288 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
3292 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
3293 (long)tfirst, (long)(tfirst + diff),
3296 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3297 (long)tfirst, (long)rfirst);
3299 if (rfirst + diff > max)
3300 max = rfirst + diff;
3302 grows = (tfirst < rfirst &&
3303 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3315 else if (max > 0xff)
3320 PerlMemShared_free(cPVOPo->op_pv);
3321 cPVOPo->op_pv = NULL;
3323 swash = (SV*)swash_init("utf8", "", listsv, bits, none);
3325 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
3326 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
3327 PAD_SETSV(cPADOPo->op_padix, swash);
3330 cSVOPo->op_sv = swash;
3332 SvREFCNT_dec(listsv);
3333 SvREFCNT_dec(transv);
3335 if (!del && havefinal && rlen)
3336 (void)hv_store((HV*)SvRV(swash), "FINAL", 5,
3337 newSVuv((UV)final), 0);
3340 o->op_private |= OPpTRANS_GROWS;
3346 op_getmad(expr,o,'e');
3347 op_getmad(repl,o,'r');
3355 tbl = (short*)cPVOPo->op_pv;
3357 Zero(tbl, 256, short);
3358 for (i = 0; i < (I32)tlen; i++)
3360 for (i = 0, j = 0; i < 256; i++) {
3362 if (j >= (I32)rlen) {
3371 if (i < 128 && r[j] >= 128)
3381 o->op_private |= OPpTRANS_IDENTICAL;
3383 else if (j >= (I32)rlen)
3388 PerlMemShared_realloc(tbl,
3389 (0x101+rlen-j) * sizeof(short));
3390 cPVOPo->op_pv = (char*)tbl;
3392 tbl[0x100] = (short)(rlen - j);
3393 for (i=0; i < (I32)rlen - j; i++)
3394 tbl[0x101+i] = r[j+i];
3398 if (!rlen && !del) {
3401 o->op_private |= OPpTRANS_IDENTICAL;
3403 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3404 o->op_private |= OPpTRANS_IDENTICAL;
3406 for (i = 0; i < 256; i++)
3408 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3409 if (j >= (I32)rlen) {
3411 if (tbl[t[i]] == -1)
3417 if (tbl[t[i]] == -1) {
3418 if (t[i] < 128 && r[j] >= 128)
3425 o->op_private |= OPpTRANS_GROWS;
3427 op_getmad(expr,o,'e');
3428 op_getmad(repl,o,'r');
3438 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3443 NewOp(1101, pmop, 1, PMOP);
3444 pmop->op_type = (OPCODE)type;
3445 pmop->op_ppaddr = PL_ppaddr[type];
3446 pmop->op_flags = (U8)flags;
3447 pmop->op_private = (U8)(0 | (flags >> 8));
3449 if (PL_hints & HINT_RE_TAINT)
3450 pmop->op_pmflags |= PMf_RETAINT;
3451 if (PL_hints & HINT_LOCALE)
3452 pmop->op_pmflags |= PMf_LOCALE;
3456 assert(SvPOK(PL_regex_pad[0]));
3457 if (SvCUR(PL_regex_pad[0])) {
3458 /* Pop off the "packed" IV from the end. */
3459 SV *const repointer_list = PL_regex_pad[0];
3460 const char *p = SvEND(repointer_list) - sizeof(IV);
3461 const IV offset = *((IV*)p);
3463 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
3465 SvEND_set(repointer_list, p);
3467 pmop->op_pmoffset = offset;
3468 /* This slot should be free, so assert this: */
3469 assert(PL_regex_pad[offset] == &PL_sv_undef);
3471 SV * const repointer = &PL_sv_undef;
3472 av_push(PL_regex_padav, repointer);
3473 pmop->op_pmoffset = av_len(PL_regex_padav);
3474 PL_regex_pad = AvARRAY(PL_regex_padav);
3478 return CHECKOP(type, pmop);
3481 /* Given some sort of match op o, and an expression expr containing a
3482 * pattern, either compile expr into a regex and attach it to o (if it's
3483 * constant), or convert expr into a runtime regcomp op sequence (if it's
3486 * isreg indicates that the pattern is part of a regex construct, eg
3487 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3488 * split "pattern", which aren't. In the former case, expr will be a list
3489 * if the pattern contains more than one term (eg /a$b/) or if it contains
3490 * a replacement, ie s/// or tr///.
3494 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
3499 I32 repl_has_vars = 0;
3503 PERL_ARGS_ASSERT_PMRUNTIME;
3505 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
3506 /* last element in list is the replacement; pop it */
3508 repl = cLISTOPx(expr)->op_last;
3509 kid = cLISTOPx(expr)->op_first;
3510 while (kid->op_sibling != repl)
3511 kid = kid->op_sibling;
3512 kid->op_sibling = NULL;
3513 cLISTOPx(expr)->op_last = kid;
3516 if (isreg && expr->op_type == OP_LIST &&
3517 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3519 /* convert single element list to element */
3520 OP* const oe = expr;
3521 expr = cLISTOPx(oe)->op_first->op_sibling;
3522 cLISTOPx(oe)->op_first->op_sibling = NULL;
3523 cLISTOPx(oe)->op_last = NULL;
3527 if (o->op_type == OP_TRANS) {
3528 return pmtrans(o, expr, repl);
3531 reglist = isreg && expr->op_type == OP_LIST;
3535 PL_hints |= HINT_BLOCK_SCOPE;
3538 if (expr->op_type == OP_CONST) {
3539 SV *pat = ((SVOP*)expr)->op_sv;
3540 U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
3542 if (o->op_flags & OPf_SPECIAL)
3543 pm_flags |= RXf_SPLIT;
3546 assert (SvUTF8(pat));
3547 } else if (SvUTF8(pat)) {
3548 /* Not doing UTF-8, despite what the SV says. Is this only if we're
3549 trapped in use 'bytes'? */
3550 /* Make a copy of the octet sequence, but without the flag on, as
3551 the compiler now honours the SvUTF8 flag on pat. */
3553 const char *const p = SvPV(pat, len);
3554 pat = newSVpvn_flags(p, len, SVs_TEMP);
3557 PM_SETRE(pm, CALLREGCOMP(pat, pm_flags));
3560 op_getmad(expr,(OP*)pm,'e');
3566 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3567 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3569 : OP_REGCMAYBE),0,expr);
3571 NewOp(1101, rcop, 1, LOGOP);
3572 rcop->op_type = OP_REGCOMP;
3573 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3574 rcop->op_first = scalar(expr);
3575 rcop->op_flags |= OPf_KIDS
3576 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3577 | (reglist ? OPf_STACKED : 0);
3578 rcop->op_private = 1;
3581 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3583 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
3586 /* establish postfix order */
3587 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3589 rcop->op_next = expr;
3590 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3593 rcop->op_next = LINKLIST(expr);
3594 expr->op_next = (OP*)rcop;
3597 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3602 if (pm->op_pmflags & PMf_EVAL) {
3604 if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
3605 CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
3607 else if (repl->op_type == OP_CONST)
3611 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3612 if (curop->op_type == OP_SCOPE
3613 || curop->op_type == OP_LEAVE
3614 || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
3615 if (curop->op_type == OP_GV) {
3616 GV * const gv = cGVOPx_gv(curop);
3618 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3621 else if (curop->op_type == OP_RV2CV)
3623 else if (curop->op_type == OP_RV2SV ||
3624 curop->op_type == OP_RV2AV ||
3625 curop->op_type == OP_RV2HV ||
3626 curop->op_type == OP_RV2GV) {
3627 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3630 else if (curop->op_type == OP_PADSV ||
3631 curop->op_type == OP_PADAV ||
3632 curop->op_type == OP_PADHV ||
3633 curop->op_type == OP_PADANY)
3637 else if (curop->op_type == OP_PUSHRE)
3638 NOOP; /* Okay here, dangerous in newASSIGNOP */
3648 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
3650 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3651 prepend_elem(o->op_type, scalar(repl), o);
3654 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3655 pm->op_pmflags |= PMf_MAYBE_CONST;
3657 NewOp(1101, rcop, 1, LOGOP);
3658 rcop->op_type = OP_SUBSTCONT;
3659 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3660 rcop->op_first = scalar(repl);
3661 rcop->op_flags |= OPf_KIDS;
3662 rcop->op_private = 1;
3665 /* establish postfix order */
3666 rcop->op_next = LINKLIST(repl);
3667 repl->op_next = (OP*)rcop;
3669 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
3670 assert(!(pm->op_pmflags & PMf_ONCE));
3671 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
3680 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3685 PERL_ARGS_ASSERT_NEWSVOP;
3687 NewOp(1101, svop, 1, SVOP);
3688 svop->op_type = (OPCODE)type;
3689 svop->op_ppaddr = PL_ppaddr[type];
3691 svop->op_next = (OP*)svop;
3692 svop->op_flags = (U8)flags;
3693 if (PL_opargs[type] & OA_RETSCALAR)
3695 if (PL_opargs[type] & OA_TARGET)
3696 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3697 return CHECKOP(type, svop);
3702 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3707 PERL_ARGS_ASSERT_NEWPADOP;
3709 NewOp(1101, padop, 1, PADOP);
3710 padop->op_type = (OPCODE)type;
3711 padop->op_ppaddr = PL_ppaddr[type];
3712 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3713 SvREFCNT_dec(PAD_SVl(padop->op_padix));
3714 PAD_SETSV(padop->op_padix, sv);
3717 padop->op_next = (OP*)padop;
3718 padop->op_flags = (U8)flags;
3719 if (PL_opargs[type] & OA_RETSCALAR)
3721 if (PL_opargs[type] & OA_TARGET)
3722 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3723 return CHECKOP(type, padop);
3728 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3732 PERL_ARGS_ASSERT_NEWGVOP;
3736 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3738 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3743 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3747 NewOp(1101, pvop, 1, PVOP);
3748 pvop->op_type = (OPCODE)type;
3749 pvop->op_ppaddr = PL_ppaddr[type];
3751 pvop->op_next = (OP*)pvop;
3752 pvop->op_flags = (U8)flags;
3753 if (PL_opargs[type] & OA_RETSCALAR)
3755 if (PL_opargs[type] & OA_TARGET)
3756 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3757 return CHECKOP(type, pvop);
3765 Perl_package(pTHX_ OP *o)
3768 SV *const sv = cSVOPo->op_sv;
3773 PERL_ARGS_ASSERT_PACKAGE;
3775 save_hptr(&PL_curstash);
3776 save_item(PL_curstname);
3778 PL_curstash = gv_stashsv(sv, GV_ADD);
3780 sv_setsv(PL_curstname, sv);
3782 PL_hints |= HINT_BLOCK_SCOPE;
3783 PL_parser->copline = NOLINE;
3784 PL_parser->expect = XSTATE;
3789 if (!PL_madskills) {
3794 pegop = newOP(OP_NULL,0);
3795 op_getmad(o,pegop,'P');
3805 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3812 OP *pegop = newOP(OP_NULL,0);
3815 PERL_ARGS_ASSERT_UTILIZE;
3817 if (idop->op_type != OP_CONST)
3818 Perl_croak(aTHX_ "Module name must be constant");
3821 op_getmad(idop,pegop,'U');
3826 SV * const vesv = ((SVOP*)version)->op_sv;
3829 op_getmad(version,pegop,'V');
3830 if (!arg && !SvNIOKp(vesv)) {
3837 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3838 Perl_croak(aTHX_ "Version number must be constant number");
3840 /* Make copy of idop so we don't free it twice */
3841 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3843 /* Fake up a method call to VERSION */
3844 meth = newSVpvs_share("VERSION");
3845 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3846 append_elem(OP_LIST,
3847 prepend_elem(OP_LIST, pack, list(version)),
3848 newSVOP(OP_METHOD_NAMED, 0, meth)));
3852 /* Fake up an import/unimport */
3853 if (arg && arg->op_type == OP_STUB) {
3855 op_getmad(arg,pegop,'S');
3856 imop = arg; /* no import on explicit () */
3858 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3859 imop = NULL; /* use 5.0; */
3861 idop->op_private |= OPpCONST_NOVER;
3867 op_getmad(arg,pegop,'A');
3869 /* Make copy of idop so we don't free it twice */
3870 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3872 /* Fake up a method call to import/unimport */
3874 ? newSVpvs_share("import") : newSVpvs_share("unimport");
3875 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3876 append_elem(OP_LIST,
3877 prepend_elem(OP_LIST, pack, list(arg)),
3878 newSVOP(OP_METHOD_NAMED, 0, meth)));
3881 /* Fake up the BEGIN {}, which does its thing immediately. */
3883 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
3886 append_elem(OP_LINESEQ,
3887 append_elem(OP_LINESEQ,
3888 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
3889 newSTATEOP(0, NULL, veop)),
3890 newSTATEOP(0, NULL, imop) ));
3892 /* The "did you use incorrect case?" warning used to be here.
3893 * The problem is that on case-insensitive filesystems one
3894 * might get false positives for "use" (and "require"):
3895 * "use Strict" or "require CARP" will work. This causes
3896 * portability problems for the script: in case-strict
3897 * filesystems the script will stop working.
3899 * The "incorrect case" warning checked whether "use Foo"
3900 * imported "Foo" to your namespace, but that is wrong, too:
3901 * there is no requirement nor promise in the language that
3902 * a Foo.pm should or would contain anything in package "Foo".
3904 * There is very little Configure-wise that can be done, either:
3905 * the case-sensitivity of the build filesystem of Perl does not
3906 * help in guessing the case-sensitivity of the runtime environment.
3909 PL_hints |= HINT_BLOCK_SCOPE;
3910 PL_parser->copline = NOLINE;
3911 PL_parser->expect = XSTATE;
3912 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3915 if (!PL_madskills) {
3916 /* FIXME - don't allocate pegop if !PL_madskills */
3925 =head1 Embedding Functions
3927 =for apidoc load_module
3929 Loads the module whose name is pointed to by the string part of name.
3930 Note that the actual module name, not its filename, should be given.
3931 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3932 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3933 (or 0 for no flags). ver, if specified, provides version semantics
3934 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3935 arguments can be used to specify arguments to the module's import()
3936 method, similar to C<use Foo::Bar VERSION LIST>.
3941 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3945 PERL_ARGS_ASSERT_LOAD_MODULE;
3947 va_start(args, ver);
3948 vload_module(flags, name, ver, &args);
3952 #ifdef PERL_IMPLICIT_CONTEXT
3954 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3958 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
3959 va_start(args, ver);
3960 vload_module(flags, name, ver, &args);
3966 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3970 OP * const modname = newSVOP(OP_CONST, 0, name);
3972 PERL_ARGS_ASSERT_VLOAD_MODULE;
3974 modname->op_private |= OPpCONST_BARE;
3976 veop = newSVOP(OP_CONST, 0, ver);
3980 if (flags & PERL_LOADMOD_NOIMPORT) {
3981 imop = sawparens(newNULLLIST());
3983 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3984 imop = va_arg(*args, OP*);
3989 sv = va_arg(*args, SV*);
3991 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3992 sv = va_arg(*args, SV*);
3996 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
3997 * that it has a PL_parser to play with while doing that, and also
3998 * that it doesn't mess with any existing parser, by creating a tmp
3999 * new parser with lex_start(). This won't actually be used for much,
4000 * since pp_require() will create another parser for the real work. */
4003 SAVEVPTR(PL_curcop);
4004 lex_start(NULL, NULL, FALSE);
4005 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
4006 veop, modname, imop);
4011 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
4017 PERL_ARGS_ASSERT_DOFILE;
4019 if (!force_builtin) {
4020 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
4021 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
4022 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
4023 gv = gvp ? *gvp : NULL;
4027 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
4028 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
4029 append_elem(OP_LIST, term,
4030 scalar(newUNOP(OP_RV2CV, 0,
4031 newGVOP(OP_GV, 0, gv))))));
4034 doop = newUNOP(OP_DOFILE, 0, scalar(term));
4040 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
4042 return newBINOP(OP_LSLICE, flags,
4043 list(force_list(subscript)),
4044 list(force_list(listval)) );
4048 S_is_list_assignment(pTHX_ register const OP *o)
4056 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
4057 o = cUNOPo->op_first;
4059 flags = o->op_flags;
4061 if (type == OP_COND_EXPR) {
4062 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
4063 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
4068 yyerror("Assignment to both a list and a scalar");
4072 if (type == OP_LIST &&
4073 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
4074 o->op_private & OPpLVAL_INTRO)
4077 if (type == OP_LIST || flags & OPf_PARENS ||
4078 type == OP_RV2AV || type == OP_RV2HV ||
4079 type == OP_ASLICE || type == OP_HSLICE)
4082 if (type == OP_PADAV || type == OP_PADHV)
4085 if (type == OP_RV2SV)
4092 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
4098 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
4099 return newLOGOP(optype, 0,
4100 mod(scalar(left), optype),
4101 newUNOP(OP_SASSIGN, 0, scalar(right)));
4104 return newBINOP(optype, OPf_STACKED,
4105 mod(scalar(left), optype), scalar(right));
4109 if (is_list_assignment(left)) {
4110 static const char no_list_state[] = "Initialization of state variables"
4111 " in list context currently forbidden";
4113 bool maybe_common_vars = TRUE;
4116 /* Grandfathering $[ assignment here. Bletch.*/
4117 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
4118 PL_eval_start = (left->op_type == OP_CONST) ? right : NULL;
4119 left = mod(left, OP_AASSIGN);
4122 else if (left->op_type == OP_CONST) {
4124 /* Result of assignment is always 1 (or we'd be dead already) */
4125 return newSVOP(OP_CONST, 0, newSViv(1));
4127 curop = list(force_list(left));
4128 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
4129 o->op_private = (U8)(0 | (flags >> 8));
4131 if ((left->op_type == OP_LIST
4132 || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
4134 OP* lop = ((LISTOP*)left)->op_first;
4135 maybe_common_vars = FALSE;
4137 if (lop->op_type == OP_PADSV ||
4138 lop->op_type == OP_PADAV ||
4139 lop->op_type == OP_PADHV ||
4140 lop->op_type == OP_PADANY) {
4141 if (!(lop->op_private & OPpLVAL_INTRO))
4142 maybe_common_vars = TRUE;
4144 if (lop->op_private & OPpPAD_STATE) {
4145 if (left->op_private & OPpLVAL_INTRO) {
4146 /* Each variable in state($a, $b, $c) = ... */
4149 /* Each state variable in
4150 (state $a, my $b, our $c, $d, undef) = ... */
4152 yyerror(no_list_state);
4154 /* Each my variable in
4155 (state $a, my $b, our $c, $d, undef) = ... */
4157 } else if (lop->op_type == OP_UNDEF ||
4158 lop->op_type == OP_PUSHMARK) {
4159 /* undef may be interesting in
4160 (state $a, undef, state $c) */
4162 /* Other ops in the list. */
4163 maybe_common_vars = TRUE;
4165 lop = lop->op_sibling;
4168 else if ((left->op_private & OPpLVAL_INTRO)
4169 && ( left->op_type == OP_PADSV
4170 || left->op_type == OP_PADAV
4171 || left->op_type == OP_PADHV
4172 || left->op_type == OP_PADANY))
4174 maybe_common_vars = FALSE;
4175 if (left->op_private & OPpPAD_STATE) {
4176 /* All single variable list context state assignments, hence
4186 yyerror(no_list_state);
4190 /* PL_generation sorcery:
4191 * an assignment like ($a,$b) = ($c,$d) is easier than
4192 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
4193 * To detect whether there are common vars, the global var
4194 * PL_generation is incremented for each assign op we compile.
4195 * Then, while compiling the assign op, we run through all the
4196 * variables on both sides of the assignment, setting a spare slot
4197 * in each of them to PL_generation. If any of them already have
4198 * that value, we know we've got commonality. We could use a
4199 * single bit marker, but then we'd have to make 2 passes, first
4200 * to clear the flag, then to test and set it. To find somewhere
4201 * to store these values, evil chicanery is done with SvUVX().
4204 if (maybe_common_vars) {
4207 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4208 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
4209 if (curop->op_type == OP_GV) {
4210 GV *gv = cGVOPx_gv(curop);
4212 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4214 GvASSIGN_GENERATION_set(gv, PL_generation);
4216 else if (curop->op_type == OP_PADSV ||
4217 curop->op_type == OP_PADAV ||
4218 curop->op_type == OP_PADHV ||
4219 curop->op_type == OP_PADANY)
4221 if (PAD_COMPNAME_GEN(curop->op_targ)
4222 == (STRLEN)PL_generation)
4224 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
4227 else if (curop->op_type == OP_RV2CV)
4229 else if (curop->op_type == OP_RV2SV ||
4230 curop->op_type == OP_RV2AV ||
4231 curop->op_type == OP_RV2HV ||
4232 curop->op_type == OP_RV2GV) {
4233 if (lastop->op_type != OP_GV) /* funny deref? */
4236 else if (curop->op_type == OP_PUSHRE) {
4238 if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
4239 GV *const gv = (GV*)PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff);
4241 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4243 GvASSIGN_GENERATION_set(gv, PL_generation);
4247 = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
4250 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4252 GvASSIGN_GENERATION_set(gv, PL_generation);
4262 o->op_private |= OPpASSIGN_COMMON;
4265 if (right && right->op_type == OP_SPLIT && !PL_madskills) {
4266 OP* tmpop = ((LISTOP*)right)->op_first;
4267 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
4268 PMOP * const pm = (PMOP*)tmpop;
4269 if (left->op_type == OP_RV2AV &&
4270 !(left->op_private & OPpLVAL_INTRO) &&
4271 !(o->op_private & OPpASSIGN_COMMON) )
4273 tmpop = ((UNOP*)left)->op_first;
4274 if (tmpop->op_type == OP_GV
4276 && !pm->op_pmreplrootu.op_pmtargetoff
4278 && !pm->op_pmreplrootu.op_pmtargetgv
4282 pm->op_pmreplrootu.op_pmtargetoff
4283 = cPADOPx(tmpop)->op_padix;
4284 cPADOPx(tmpop)->op_padix = 0; /* steal it */
4286 pm->op_pmreplrootu.op_pmtargetgv
4287 = (GV*)cSVOPx(tmpop)->op_sv;
4288 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
4290 pm->op_pmflags |= PMf_ONCE;
4291 tmpop = cUNOPo->op_first; /* to list (nulled) */
4292 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
4293 tmpop->op_sibling = NULL; /* don't free split */
4294 right->op_next = tmpop->op_next; /* fix starting loc */
4295 op_free(o); /* blow off assign */
4296 right->op_flags &= ~OPf_WANT;
4297 /* "I don't know and I don't care." */
4302 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
4303 ((LISTOP*)right)->op_last->op_type == OP_CONST)
4305 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
4307 sv_setiv(sv, PL_modcount+1);
4315 right = newOP(OP_UNDEF, 0);
4316 if (right->op_type == OP_READLINE) {
4317 right->op_flags |= OPf_STACKED;
4318 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
4321 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
4322 o = newBINOP(OP_SASSIGN, flags,
4323 scalar(right), mod(scalar(left), OP_SASSIGN) );
4329 o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
4330 o->op_private |= OPpCONST_ARYBASE;
4337 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
4340 const U32 seq = intro_my();
4343 NewOp(1101, cop, 1, COP);
4344 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
4345 cop->op_type = OP_DBSTATE;
4346 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
4349 cop->op_type = OP_NEXTSTATE;
4350 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
4352 cop->op_flags = (U8)flags;
4353 CopHINTS_set(cop, PL_hints);
4355 cop->op_private |= NATIVE_HINTS;
4357 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
4358 cop->op_next = (OP*)cop;
4361 CopLABEL_set(cop, label);
4362 PL_hints |= HINT_BLOCK_SCOPE;
4365 /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
4366 CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
4368 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
4369 cop->cop_hints_hash = PL_curcop->cop_hints_hash;
4370 if (cop->cop_hints_hash) {
4372 cop->cop_hints_hash->refcounted_he_refcnt++;
4373 HINTS_REFCNT_UNLOCK;
4376 if (PL_parser && PL_parser->copline == NOLINE)
4377 CopLINE_set(cop, CopLINE(PL_curcop));
4379 CopLINE_set(cop, PL_parser->copline);
4381 PL_parser->copline = NOLINE;
4384 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
4386 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
4388 CopSTASH_set(cop, PL_curstash);
4390 if (PERLDB_LINE && PL_curstash != PL_debstash) {
4391 AV *av = CopFILEAVx(PL_curcop);
4393 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
4394 if (svp && *svp != &PL_sv_undef ) {
4395 (void)SvIOK_on(*svp);
4396 SvIV_set(*svp, PTR2IV(cop));
4401 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
4406 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
4410 PERL_ARGS_ASSERT_NEWLOGOP;
4412 return new_logop(type, flags, &first, &other);
4416 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
4421 OP *first = *firstp;
4422 OP * const other = *otherp;
4424 PERL_ARGS_ASSERT_NEW_LOGOP;
4426 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
4427 return newBINOP(type, flags, scalar(first), scalar(other));
4429 scalarboolean(first);
4430 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
4431 if (first->op_type == OP_NOT
4432 && (first->op_flags & OPf_SPECIAL)
4433 && (first->op_flags & OPf_KIDS)
4435 if (type == OP_AND || type == OP_OR) {
4441 first = *firstp = cUNOPo->op_first;
4443 first->op_next = o->op_next;
4444 cUNOPo->op_first = NULL;
4448 if (first->op_type == OP_CONST) {
4449 if (first->op_private & OPpCONST_STRICT)
4450 no_bareword_allowed(first);
4451 else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
4452 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
4453 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
4454 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
4455 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
4457 if (other->op_type == OP_CONST)
4458 other->op_private |= OPpCONST_SHORTCIRCUIT;
4460 OP *newop = newUNOP(OP_NULL, 0, other);
4461 op_getmad(first, newop, '1');
4462 newop->op_targ = type; /* set "was" field */
4469 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
4470 const OP *o2 = other;
4471 if ( ! (o2->op_type == OP_LIST
4472 && (( o2 = cUNOPx(o2)->op_first))
4473 && o2->op_type == OP_PUSHMARK
4474 && (( o2 = o2->op_sibling)) )
4477 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
4478 || o2->op_type == OP_PADHV)
4479 && o2->op_private & OPpLVAL_INTRO
4480 && !(o2->op_private & OPpPAD_STATE)
4481 && ckWARN(WARN_DEPRECATED))
4483 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4484 "Deprecated use of my() in false conditional");
4488 if (first->op_type == OP_CONST)
4489 first->op_private |= OPpCONST_SHORTCIRCUIT;
4491 first = newUNOP(OP_NULL, 0, first);
4492 op_getmad(other, first, '2');
4493 first->op_targ = type; /* set "was" field */
4500 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
4501 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
4503 const OP * const k1 = ((UNOP*)first)->op_first;
4504 const OP * const k2 = k1->op_sibling;
4506 switch (first->op_type)
4509 if (k2 && k2->op_type == OP_READLINE
4510 && (k2->op_flags & OPf_STACKED)
4511 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4513 warnop = k2->op_type;
4518 if (k1->op_type == OP_READDIR
4519 || k1->op_type == OP_GLOB
4520 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4521 || k1->op_type == OP_EACH)
4523 warnop = ((k1->op_type == OP_NULL)
4524 ? (OPCODE)k1->op_targ : k1->op_type);
4529 const line_t oldline = CopLINE(PL_curcop);
4530 CopLINE_set(PL_curcop, PL_parser->copline);
4531 Perl_warner(aTHX_ packWARN(WARN_MISC),
4532 "Value of %s%s can be \"0\"; test with defined()",
4534 ((warnop == OP_READLINE || warnop == OP_GLOB)
4535 ? " construct" : "() operator"));
4536 CopLINE_set(PL_curcop, oldline);
4543 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
4544 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
4546 NewOp(1101, logop, 1, LOGOP);
4548 logop->op_type = (OPCODE)type;
4549 logop->op_ppaddr = PL_ppaddr[type];
4550 logop->op_first = first;
4551 logop->op_flags = (U8)(flags | OPf_KIDS);
4552 logop->op_other = LINKLIST(other);
4553 logop->op_private = (U8)(1 | (flags >> 8));
4555 /* establish postfix order */
4556 logop->op_next = LINKLIST(first);
4557 first->op_next = (OP*)logop;
4558 first->op_sibling = other;
4560 CHECKOP(type,logop);
4562 o = newUNOP(OP_NULL, 0, (OP*)logop);
4569 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
4576 PERL_ARGS_ASSERT_NEWCONDOP;
4579 return newLOGOP(OP_AND, 0, first, trueop);
4581 return newLOGOP(OP_OR, 0, first, falseop);
4583 scalarboolean(first);
4584 if (first->op_type == OP_CONST) {
4585 /* Left or right arm of the conditional? */
4586 const bool left = SvTRUE(((SVOP*)first)->op_sv);
4587 OP *live = left ? trueop : falseop;
4588 OP *const dead = left ? falseop : trueop;
4589 if (first->op_private & OPpCONST_BARE &&
4590 first->op_private & OPpCONST_STRICT) {
4591 no_bareword_allowed(first);
4594 /* This is all dead code when PERL_MAD is not defined. */
4595 live = newUNOP(OP_NULL, 0, live);
4596 op_getmad(first, live, 'C');
4597 op_getmad(dead, live, left ? 'e' : 't');
4604 NewOp(1101, logop, 1, LOGOP);
4605 logop->op_type = OP_COND_EXPR;
4606 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4607 logop->op_first = first;
4608 logop->op_flags = (U8)(flags | OPf_KIDS);
4609 logop->op_private = (U8)(1 | (flags >> 8));
4610 logop->op_other = LINKLIST(trueop);
4611 logop->op_next = LINKLIST(falseop);
4613 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
4616 /* establish postfix order */
4617 start = LINKLIST(first);
4618 first->op_next = (OP*)logop;
4620 first->op_sibling = trueop;
4621 trueop->op_sibling = falseop;
4622 o = newUNOP(OP_NULL, 0, (OP*)logop);
4624 trueop->op_next = falseop->op_next = o;
4631 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4640 PERL_ARGS_ASSERT_NEWRANGE;
4642 NewOp(1101, range, 1, LOGOP);
4644 range->op_type = OP_RANGE;
4645 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4646 range->op_first = left;
4647 range->op_flags = OPf_KIDS;
4648 leftstart = LINKLIST(left);
4649 range->op_other = LINKLIST(right);
4650 range->op_private = (U8)(1 | (flags >> 8));
4652 left->op_sibling = right;
4654 range->op_next = (OP*)range;
4655 flip = newUNOP(OP_FLIP, flags, (OP*)range);
4656 flop = newUNOP(OP_FLOP, 0, flip);
4657 o = newUNOP(OP_NULL, 0, flop);
4659 range->op_next = leftstart;
4661 left->op_next = flip;
4662 right->op_next = flop;
4664 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4665 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4666 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4667 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4669 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4670 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4673 if (!flip->op_private || !flop->op_private)
4674 linklist(o); /* blow off optimizer unless constant */
4680 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4685 const bool once = block && block->op_flags & OPf_SPECIAL &&
4686 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4688 PERL_UNUSED_ARG(debuggable);
4691 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4692 return block; /* do {} while 0 does once */
4693 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4694 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4695 expr = newUNOP(OP_DEFINED, 0,
4696 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4697 } else if (expr->op_flags & OPf_KIDS) {
4698 const OP * const k1 = ((UNOP*)expr)->op_first;
4699 const OP * const k2 = k1 ? k1->op_sibling : NULL;
4700 switch (expr->op_type) {
4702 if (k2 && k2->op_type == OP_READLINE
4703 && (k2->op_flags & OPf_STACKED)
4704 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4705 expr = newUNOP(OP_DEFINED, 0, expr);
4709 if (k1 && (k1->op_type == OP_READDIR
4710 || k1->op_type == OP_GLOB
4711 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4712 || k1->op_type == OP_EACH))
4713 expr = newUNOP(OP_DEFINED, 0, expr);
4719 /* if block is null, the next append_elem() would put UNSTACK, a scalar
4720 * op, in listop. This is wrong. [perl #27024] */
4722 block = newOP(OP_NULL, 0);
4723 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4724 o = new_logop(OP_AND, 0, &expr, &listop);
4727 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4729 if (once && o != listop)
4730 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4733 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
4735 o->op_flags |= flags;
4737 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4742 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
4743 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
4752 PERL_UNUSED_ARG(debuggable);
4755 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4756 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4757 expr = newUNOP(OP_DEFINED, 0,
4758 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4759 } else if (expr->op_flags & OPf_KIDS) {
4760 const OP * const k1 = ((UNOP*)expr)->op_first;
4761 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
4762 switch (expr->op_type) {
4764 if (k2 && k2->op_type == OP_READLINE
4765 && (k2->op_flags & OPf_STACKED)
4766 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4767 expr = newUNOP(OP_DEFINED, 0, expr);
4771 if (k1 && (k1->op_type == OP_READDIR
4772 || k1->op_type == OP_GLOB
4773 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4774 || k1->op_type == OP_EACH))
4775 expr = newUNOP(OP_DEFINED, 0, expr);
4782 block = newOP(OP_NULL, 0);
4783 else if (cont || has_my) {
4784 block = scope(block);
4788 next = LINKLIST(cont);
4791 OP * const unstack = newOP(OP_UNSTACK, 0);
4794 cont = append_elem(OP_LINESEQ, cont, unstack);
4798 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4800 redo = LINKLIST(listop);
4803 PL_parser->copline = (line_t)whileline;
4805 o = new_logop(OP_AND, 0, &expr, &listop);
4806 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4807 op_free(expr); /* oops, it's a while (0) */
4809 return NULL; /* listop already freed by new_logop */
4812 ((LISTOP*)listop)->op_last->op_next =
4813 (o == listop ? redo : LINKLIST(o));
4819 NewOp(1101,loop,1,LOOP);
4820 loop->op_type = OP_ENTERLOOP;
4821 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4822 loop->op_private = 0;
4823 loop->op_next = (OP*)loop;
4826 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4828 loop->op_redoop = redo;
4829 loop->op_lastop = o;
4830 o->op_private |= loopflags;
4833 loop->op_nextop = next;
4835 loop->op_nextop = o;
4837 o->op_flags |= flags;
4838 o->op_private |= (flags >> 8);
4843 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
4848 PADOFFSET padoff = 0;
4853 PERL_ARGS_ASSERT_NEWFOROP;
4856 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4857 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
4858 sv->op_type = OP_RV2GV;
4859 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4861 /* The op_type check is needed to prevent a possible segfault
4862 * if the loop variable is undeclared and 'strict vars' is in
4863 * effect. This is illegal but is nonetheless parsed, so we
4864 * may reach this point with an OP_CONST where we're expecting
4867 if (cUNOPx(sv)->op_first->op_type == OP_GV
4868 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
4869 iterpflags |= OPpITER_DEF;
4871 else if (sv->op_type == OP_PADSV) { /* private variable */
4872 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
4873 padoff = sv->op_targ;
4883 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4885 SV *const namesv = PAD_COMPNAME_SV(padoff);
4887 const char *const name = SvPV_const(namesv, len);
4889 if (len == 2 && name[0] == '$' && name[1] == '_')
4890 iterpflags |= OPpITER_DEF;
4894 const PADOFFSET offset = pad_findmy("$_");
4895 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
4896 sv = newGVOP(OP_GV, 0, PL_defgv);
4901 iterpflags |= OPpITER_DEF;
4903 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4904 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4905 iterflags |= OPf_STACKED;
4907 else if (expr->op_type == OP_NULL &&
4908 (expr->op_flags & OPf_KIDS) &&
4909 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4911 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4912 * set the STACKED flag to indicate that these values are to be
4913 * treated as min/max values by 'pp_iterinit'.
4915 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4916 LOGOP* const range = (LOGOP*) flip->op_first;
4917 OP* const left = range->op_first;
4918 OP* const right = left->op_sibling;
4921 range->op_flags &= ~OPf_KIDS;
4922 range->op_first = NULL;
4924 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4925 listop->op_first->op_next = range->op_next;
4926 left->op_next = range->op_other;
4927 right->op_next = (OP*)listop;
4928 listop->op_next = listop->op_first;
4931 op_getmad(expr,(OP*)listop,'O');
4935 expr = (OP*)(listop);
4937 iterflags |= OPf_STACKED;
4940 expr = mod(force_list(expr), OP_GREPSTART);
4943 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4944 append_elem(OP_LIST, expr, scalar(sv))));
4945 assert(!loop->op_next);
4946 /* for my $x () sets OPpLVAL_INTRO;
4947 * for our $x () sets OPpOUR_INTRO */
4948 loop->op_private = (U8)iterpflags;
4949 #ifdef PL_OP_SLAB_ALLOC
4952 NewOp(1234,tmp,1,LOOP);
4953 Copy(loop,tmp,1,LISTOP);
4954 S_op_destroy(aTHX_ (OP*)loop);
4958 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
4960 loop->op_targ = padoff;
4961 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
4963 op_getmad(madsv, (OP*)loop, 'v');
4964 PL_parser->copline = forline;
4965 return newSTATEOP(0, label, wop);
4969 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4974 PERL_ARGS_ASSERT_NEWLOOPEX;
4976 if (type != OP_GOTO || label->op_type == OP_CONST) {
4977 /* "last()" means "last" */
4978 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4979 o = newOP(type, OPf_SPECIAL);
4981 o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
4982 ? SvPV_nolen_const(((SVOP*)label)->op_sv)
4986 op_getmad(label,o,'L');
4992 /* Check whether it's going to be a goto &function */
4993 if (label->op_type == OP_ENTERSUB
4994 && !(label->op_flags & OPf_STACKED))
4995 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4996 o = newUNOP(type, OPf_STACKED, label);
4998 PL_hints |= HINT_BLOCK_SCOPE;
5002 /* if the condition is a literal array or hash
5003 (or @{ ... } etc), make a reference to it.
5006 S_ref_array_or_hash(pTHX_ OP *cond)
5009 && (cond->op_type == OP_RV2AV
5010 || cond->op_type == OP_PADAV
5011 || cond->op_type == OP_RV2HV
5012 || cond->op_type == OP_PADHV))
5014 return newUNOP(OP_REFGEN,
5015 0, mod(cond, OP_REFGEN));
5021 /* These construct the optree fragments representing given()
5024 entergiven and enterwhen are LOGOPs; the op_other pointer
5025 points up to the associated leave op. We need this so we
5026 can put it in the context and make break/continue work.
5027 (Also, of course, pp_enterwhen will jump straight to
5028 op_other if the match fails.)
5032 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
5033 I32 enter_opcode, I32 leave_opcode,
5034 PADOFFSET entertarg)
5040 PERL_ARGS_ASSERT_NEWGIVWHENOP;
5042 NewOp(1101, enterop, 1, LOGOP);
5043 enterop->op_type = (optype)enter_opcode;
5044 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
5045 enterop->op_flags = (U8) OPf_KIDS;
5046 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
5047 enterop->op_private = 0;
5049 o = newUNOP(leave_opcode, 0, (OP *) enterop);
5052 enterop->op_first = scalar(cond);
5053 cond->op_sibling = block;
5055 o->op_next = LINKLIST(cond);
5056 cond->op_next = (OP *) enterop;
5059 /* This is a default {} block */
5060 enterop->op_first = block;
5061 enterop->op_flags |= OPf_SPECIAL;
5063 o->op_next = (OP *) enterop;
5066 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
5067 entergiven and enterwhen both
5070 enterop->op_next = LINKLIST(block);
5071 block->op_next = enterop->op_other = o;
5076 /* Does this look like a boolean operation? For these purposes
5077 a boolean operation is:
5078 - a subroutine call [*]
5079 - a logical connective
5080 - a comparison operator
5081 - a filetest operator, with the exception of -s -M -A -C
5082 - defined(), exists() or eof()
5083 - /$re/ or $foo =~ /$re/
5085 [*] possibly surprising
5088 S_looks_like_bool(pTHX_ const OP *o)
5092 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
5094 switch(o->op_type) {
5096 return looks_like_bool(cLOGOPo->op_first);
5100 looks_like_bool(cLOGOPo->op_first)
5101 && looks_like_bool(cLOGOPo->op_first->op_sibling));
5105 o->op_flags & OPf_KIDS
5106 && looks_like_bool(cUNOPo->op_first));
5110 case OP_NOT: case OP_XOR:
5111 /* Note that OP_DOR is not here */
5113 case OP_EQ: case OP_NE: case OP_LT:
5114 case OP_GT: case OP_LE: case OP_GE:
5116 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
5117 case OP_I_GT: case OP_I_LE: case OP_I_GE:
5119 case OP_SEQ: case OP_SNE: case OP_SLT:
5120 case OP_SGT: case OP_SLE: case OP_SGE:
5124 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
5125 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
5126 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
5127 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
5128 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
5129 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
5130 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
5131 case OP_FTTEXT: case OP_FTBINARY:
5133 case OP_DEFINED: case OP_EXISTS:
5134 case OP_MATCH: case OP_EOF:
5139 /* Detect comparisons that have been optimized away */
5140 if (cSVOPo->op_sv == &PL_sv_yes
5141 || cSVOPo->op_sv == &PL_sv_no)
5152 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
5155 PERL_ARGS_ASSERT_NEWGIVENOP;
5156 return newGIVWHENOP(
5157 ref_array_or_hash(cond),
5159 OP_ENTERGIVEN, OP_LEAVEGIVEN,
5163 /* If cond is null, this is a default {} block */
5165 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
5167 const bool cond_llb = (!cond || looks_like_bool(cond));
5170 PERL_ARGS_ASSERT_NEWWHENOP;
5175 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
5177 scalar(ref_array_or_hash(cond)));
5180 return newGIVWHENOP(
5182 append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
5183 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
5187 =for apidoc cv_undef
5189 Clear out all the active components of a CV. This can happen either
5190 by an explicit C<undef &foo>, or by the reference count going to zero.
5191 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
5192 children can still follow the full lexical scope chain.
5198 Perl_cv_undef(pTHX_ CV *cv)
5202 PERL_ARGS_ASSERT_CV_UNDEF;
5204 DEBUG_X(PerlIO_printf(Perl_debug_log,
5205 "CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n",
5206 PTR2UV(cv), PTR2UV(PL_comppad))
5210 if (CvFILE(cv) && !CvISXSUB(cv)) {
5211 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
5212 Safefree(CvFILE(cv));
5217 if (!CvISXSUB(cv) && CvROOT(cv)) {
5218 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
5219 Perl_croak(aTHX_ "Can't undef active subroutine");
5222 PAD_SAVE_SETNULLPAD();
5224 op_free(CvROOT(cv));
5229 SvPOK_off((SV*)cv); /* forget prototype */
5234 /* remove CvOUTSIDE unless this is an undef rather than a free */
5235 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
5236 if (!CvWEAKOUTSIDE(cv))
5237 SvREFCNT_dec(CvOUTSIDE(cv));
5238 CvOUTSIDE(cv) = NULL;
5241 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
5244 if (CvISXSUB(cv) && CvXSUB(cv)) {
5247 /* delete all flags except WEAKOUTSIDE */
5248 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
5252 Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
5255 PERL_ARGS_ASSERT_CV_CKPROTO_LEN;
5257 /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
5258 relying on SvCUR, and doubling up the buffer to hold CvFILE(). */
5259 if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
5260 || (p && (len != SvCUR(cv) /* Not the same length. */
5261 || memNE(p, SvPVX_const(cv), len))))
5262 && ckWARN_d(WARN_PROTOTYPE)) {
5263 SV* const msg = sv_newmortal();
5267 gv_efullname3(name = sv_newmortal(), gv, NULL);
5268 sv_setpvs(msg, "Prototype mismatch:");
5270 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
5272 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv));
5274 sv_catpvs(msg, ": none");
5275 sv_catpvs(msg, " vs ");
5277 Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
5279 sv_catpvs(msg, "none");
5280 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
5284 static void const_sv_xsub(pTHX_ CV* cv);
5288 =head1 Optree Manipulation Functions
5290 =for apidoc cv_const_sv
5292 If C<cv> is a constant sub eligible for inlining. returns the constant
5293 value returned by the sub. Otherwise, returns NULL.
5295 Constant subs can be created with C<newCONSTSUB> or as described in
5296 L<perlsub/"Constant Functions">.
5301 Perl_cv_const_sv(pTHX_ CV *cv)
5303 PERL_UNUSED_CONTEXT;
5306 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
5308 return CvCONST(cv) ? (SV*)CvXSUBANY(cv).any_ptr : NULL;
5311 /* op_const_sv: examine an optree to determine whether it's in-lineable.
5312 * Can be called in 3 ways:
5315 * look for a single OP_CONST with attached value: return the value
5317 * cv && CvCLONE(cv) && !CvCONST(cv)
5319 * examine the clone prototype, and if contains only a single
5320 * OP_CONST referencing a pad const, or a single PADSV referencing
5321 * an outer lexical, return a non-zero value to indicate the CV is
5322 * a candidate for "constizing" at clone time
5326 * We have just cloned an anon prototype that was marked as a const
5327 * candidiate. Try to grab the current value, and in the case of
5328 * PADSV, ignore it if it has multiple references. Return the value.
5332 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
5343 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
5344 o = cLISTOPo->op_first->op_sibling;
5346 for (; o; o = o->op_next) {
5347 const OPCODE type = o->op_type;
5349 if (sv && o->op_next == o)
5351 if (o->op_next != o) {
5352 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
5354 if (type == OP_DBSTATE)
5357 if (type == OP_LEAVESUB || type == OP_RETURN)
5361 if (type == OP_CONST && cSVOPo->op_sv)
5363 else if (cv && type == OP_CONST) {
5364 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5368 else if (cv && type == OP_PADSV) {
5369 if (CvCONST(cv)) { /* newly cloned anon */
5370 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5371 /* the candidate should have 1 ref from this pad and 1 ref
5372 * from the parent */
5373 if (!sv || SvREFCNT(sv) != 2)
5380 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
5381 sv = &PL_sv_undef; /* an arbitrary non-null value */
5396 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5399 /* This would be the return value, but the return cannot be reached. */
5400 OP* pegop = newOP(OP_NULL, 0);
5403 PERL_UNUSED_ARG(floor);
5413 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
5415 NORETURN_FUNCTION_END;
5420 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
5422 return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
5426 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5433 register CV *cv = NULL;
5435 /* If the subroutine has no body, no attributes, and no builtin attributes
5436 then it's just a sub declaration, and we may be able to get away with
5437 storing with a placeholder scalar in the symbol table, rather than a
5438 full GV and CV. If anything is present then it will take a full CV to
5440 const I32 gv_fetch_flags
5441 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5443 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
5444 const char * const name = o ? SvPV_nolen_const(cSVOPo->op_sv) : NULL;
5447 assert(proto->op_type == OP_CONST);
5448 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
5453 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
5454 SV * const sv = sv_newmortal();
5455 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
5456 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
5457 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
5458 aname = SvPVX_const(sv);
5463 gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
5464 : gv_fetchpv(aname ? aname
5465 : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5466 gv_fetch_flags, SVt_PVCV);
5468 if (!PL_madskills) {
5477 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
5478 maximum a prototype before. */
5479 if (SvTYPE(gv) > SVt_NULL) {
5480 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
5481 && ckWARN_d(WARN_PROTOTYPE))
5483 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
5485 cv_ckproto_len((CV*)gv, NULL, ps, ps_len);
5488 sv_setpvn((SV*)gv, ps, ps_len);
5490 sv_setiv((SV*)gv, -1);
5492 SvREFCNT_dec(PL_compcv);
5493 cv = PL_compcv = NULL;
5497 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
5499 #ifdef GV_UNIQUE_CHECK
5500 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
5501 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
5505 if (!block || !ps || *ps || attrs
5506 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5508 || block->op_type == OP_NULL
5513 const_sv = op_const_sv(block, NULL);
5516 const bool exists = CvROOT(cv) || CvXSUB(cv);
5518 #ifdef GV_UNIQUE_CHECK
5519 if (exists && GvUNIQUE(gv)) {
5520 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
5524 /* if the subroutine doesn't exist and wasn't pre-declared
5525 * with a prototype, assume it will be AUTOLOADed,
5526 * skipping the prototype check
5528 if (exists || SvPOK(cv))
5529 cv_ckproto_len(cv, gv, ps, ps_len);
5530 /* already defined (or promised)? */
5531 if (exists || GvASSUMECV(gv)) {
5534 || block->op_type == OP_NULL
5537 if (CvFLAGS(PL_compcv)) {
5538 /* might have had built-in attrs applied */
5539 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5541 /* just a "sub foo;" when &foo is already defined */
5542 SAVEFREESV(PL_compcv);
5547 && block->op_type != OP_NULL
5550 if (ckWARN(WARN_REDEFINE)
5552 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
5554 const line_t oldline = CopLINE(PL_curcop);
5555 if (PL_parser && PL_parser->copline != NOLINE)
5556 CopLINE_set(PL_curcop, PL_parser->copline);
5557 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5558 CvCONST(cv) ? "Constant subroutine %s redefined"
5559 : "Subroutine %s redefined", name);
5560 CopLINE_set(PL_curcop, oldline);
5563 if (!PL_minus_c) /* keep old one around for madskills */
5566 /* (PL_madskills unset in used file.) */
5574 SvREFCNT_inc_simple_void_NN(const_sv);
5576 assert(!CvROOT(cv) && !CvCONST(cv));
5577 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
5578 CvXSUBANY(cv).any_ptr = const_sv;
5579 CvXSUB(cv) = const_sv_xsub;
5585 cv = newCONSTSUB(NULL, name, const_sv);
5587 mro_method_changed_in( /* sub Foo::Bar () { 123 } */
5588 (CvGV(cv) && GvSTASH(CvGV(cv)))
5597 SvREFCNT_dec(PL_compcv);
5605 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
5606 * before we clobber PL_compcv.
5610 || block->op_type == OP_NULL
5614 /* Might have had built-in attributes applied -- propagate them. */
5615 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5616 if (CvGV(cv) && GvSTASH(CvGV(cv)))
5617 stash = GvSTASH(CvGV(cv));
5618 else if (CvSTASH(cv))
5619 stash = CvSTASH(cv);
5621 stash = PL_curstash;
5624 /* possibly about to re-define existing subr -- ignore old cv */
5625 rcv = (SV*)PL_compcv;
5626 if (name && GvSTASH(gv))
5627 stash = GvSTASH(gv);
5629 stash = PL_curstash;
5631 apply_attrs(stash, rcv, attrs, FALSE);
5633 if (cv) { /* must reuse cv if autoloaded */
5640 || block->op_type == OP_NULL) && !PL_madskills
5643 /* got here with just attrs -- work done, so bug out */
5644 SAVEFREESV(PL_compcv);
5647 /* transfer PL_compcv to cv */
5649 CvFLAGS(cv) = CvFLAGS(PL_compcv);
5650 if (!CvWEAKOUTSIDE(cv))
5651 SvREFCNT_dec(CvOUTSIDE(cv));
5652 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
5653 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
5654 CvOUTSIDE(PL_compcv) = 0;
5655 CvPADLIST(cv) = CvPADLIST(PL_compcv);
5656 CvPADLIST(PL_compcv) = 0;
5657 /* inner references to PL_compcv must be fixed up ... */
5658 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
5659 /* ... before we throw it away */
5660 SvREFCNT_dec(PL_compcv);
5662 if (PERLDB_INTER)/* Advice debugger on the new sub. */
5663 ++PL_sub_generation;
5670 if (strEQ(name, "import")) {
5671 PL_formfeed = (SV*)cv;
5672 Perl_warner(aTHX_ packWARN(WARN_VOID), "%lx\n", (long)cv);
5676 mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */
5680 CvFILE_set_from_cop(cv, PL_curcop);
5681 CvSTASH(cv) = PL_curstash;
5684 sv_setpvn((SV*)cv, ps, ps_len);
5686 if (PL_parser && PL_parser->error_count) {
5690 const char *s = strrchr(name, ':');
5692 if (strEQ(s, "BEGIN")) {
5693 const char not_safe[] =
5694 "BEGIN not safe after errors--compilation aborted";
5695 if (PL_in_eval & EVAL_KEEPERR)
5696 Perl_croak(aTHX_ not_safe);
5698 /* force display of errors found but not reported */
5699 sv_catpv(ERRSV, not_safe);
5700 Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
5710 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5711 mod(scalarseq(block), OP_LEAVESUBLV));
5712 block->op_attached = 1;
5715 /* This makes sub {}; work as expected. */
5716 if (block->op_type == OP_STUB) {
5717 OP* const newblock = newSTATEOP(0, NULL, 0);
5719 op_getmad(block,newblock,'B');
5726 block->op_attached = 1;
5727 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5729 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5730 OpREFCNT_set(CvROOT(cv), 1);
5731 CvSTART(cv) = LINKLIST(CvROOT(cv));
5732 CvROOT(cv)->op_next = 0;
5733 CALL_PEEP(CvSTART(cv));
5735 /* now that optimizer has done its work, adjust pad values */
5737 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
5740 assert(!CvCONST(cv));
5741 if (ps && !*ps && op_const_sv(block, cv))
5745 if (name || aname) {
5746 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5747 SV * const sv = newSV(0);
5748 SV * const tmpstr = sv_newmortal();
5749 GV * const db_postponed = gv_fetchpvs("DB::postponed",
5750 GV_ADDMULTI, SVt_PVHV);
5753 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5755 (long)PL_subline, (long)CopLINE(PL_curcop));
5756 gv_efullname3(tmpstr, gv, NULL);
5757 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
5758 SvCUR(tmpstr), sv, 0);
5759 hv = GvHVn(db_postponed);
5760 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
5761 CV * const pcv = GvCV(db_postponed);
5767 call_sv((SV*)pcv, G_DISCARD);
5772 if (name && ! (PL_parser && PL_parser->error_count))
5773 process_special_blocks(name, gv, cv);
5778 PL_parser->copline = NOLINE;
5784 S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
5787 const char *const colon = strrchr(fullname,':');
5788 const char *const name = colon ? colon + 1 : fullname;
5790 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
5793 if (strEQ(name, "BEGIN")) {
5794 const I32 oldscope = PL_scopestack_ix;
5796 SAVECOPFILE(&PL_compiling);
5797 SAVECOPLINE(&PL_compiling);
5799 DEBUG_x( dump_sub(gv) );
5800 Perl_av_create_and_push(aTHX_ &PL_beginav, (SV*)cv);
5801 GvCV(gv) = 0; /* cv has been hijacked */
5802 call_list(oldscope, PL_beginav);
5804 PL_curcop = &PL_compiling;
5805 CopHINTS_set(&PL_compiling, PL_hints);
5812 if strEQ(name, "END") {
5813 DEBUG_x( dump_sub(gv) );
5814 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, (SV*)cv);
5817 } else if (*name == 'U') {
5818 if (strEQ(name, "UNITCHECK")) {
5819 /* It's never too late to run a unitcheck block */
5820 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, (SV*)cv);
5824 } else if (*name == 'C') {
5825 if (strEQ(name, "CHECK")) {
5826 if (PL_main_start && ckWARN(WARN_VOID))
5827 Perl_warner(aTHX_ packWARN(WARN_VOID),
5828 "Too late to run CHECK block");
5829 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, (SV*)cv);
5833 } else if (*name == 'I') {
5834 if (strEQ(name, "INIT")) {
5835 if (PL_main_start && ckWARN(WARN_VOID))
5836 Perl_warner(aTHX_ packWARN(WARN_VOID),
5837 "Too late to run INIT block");
5838 Perl_av_create_and_push(aTHX_ &PL_initav, (SV*)cv);
5844 DEBUG_x( dump_sub(gv) );
5845 GvCV(gv) = 0; /* cv has been hijacked */
5850 =for apidoc newCONSTSUB
5852 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5853 eligible for inlining at compile-time.
5859 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
5864 const char *const temp_p = CopFILE(PL_curcop);
5865 const STRLEN len = temp_p ? strlen(temp_p) : 0;
5867 SV *const temp_sv = CopFILESV(PL_curcop);
5869 const char *const temp_p = temp_sv ? SvPV_const(temp_sv, len) : NULL;
5871 char *const file = savepvn(temp_p, temp_p ? len : 0);
5875 if (IN_PERL_RUNTIME) {
5876 /* at runtime, it's not safe to manipulate PL_curcop: it may be
5877 * an op shared between threads. Use a non-shared COP for our
5879 SAVEVPTR(PL_curcop);
5880 PL_curcop = &PL_compiling;
5882 SAVECOPLINE(PL_curcop);
5883 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
5886 PL_hints &= ~HINT_BLOCK_SCOPE;
5889 SAVESPTR(PL_curstash);
5890 SAVECOPSTASH(PL_curcop);
5891 PL_curstash = stash;
5892 CopSTASH_set(PL_curcop,stash);
5895 /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
5896 and so doesn't get free()d. (It's expected to be from the C pre-
5897 processor __FILE__ directive). But we need a dynamically allocated one,
5898 and we need it to get freed. */
5899 cv = newXS_flags(name, const_sv_xsub, file, "", XS_DYNAMIC_FILENAME);
5900 CvXSUBANY(cv).any_ptr = sv;
5906 CopSTASH_free(PL_curcop);
5914 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
5915 const char *const filename, const char *const proto,
5918 CV *cv = newXS(name, subaddr, filename);
5920 PERL_ARGS_ASSERT_NEWXS_FLAGS;
5922 if (flags & XS_DYNAMIC_FILENAME) {
5923 /* We need to "make arrangements" (ie cheat) to ensure that the
5924 filename lasts as long as the PVCV we just created, but also doesn't
5926 STRLEN filename_len = strlen(filename);
5927 STRLEN proto_and_file_len = filename_len;
5928 char *proto_and_file;
5932 proto_len = strlen(proto);
5933 proto_and_file_len += proto_len;
5935 Newx(proto_and_file, proto_and_file_len + 1, char);
5936 Copy(proto, proto_and_file, proto_len, char);
5937 Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
5940 proto_and_file = savepvn(filename, filename_len);
5943 /* This gets free()d. :-) */
5944 sv_usepvn_flags((SV*)cv, proto_and_file, proto_and_file_len,
5945 SV_HAS_TRAILING_NUL);
5947 /* This gives us the correct prototype, rather than one with the
5948 file name appended. */
5949 SvCUR_set(cv, proto_len);
5953 CvFILE(cv) = proto_and_file + proto_len;
5955 sv_setpv((SV *)cv, proto);
5961 =for apidoc U||newXS
5963 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
5964 static storage, as it is used directly as CvFILE(), without a copy being made.
5970 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
5973 GV * const gv = gv_fetchpv(name ? name :
5974 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5975 GV_ADDMULTI, SVt_PVCV);
5978 PERL_ARGS_ASSERT_NEWXS;
5981 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
5983 if ((cv = (name ? GvCV(gv) : NULL))) {
5985 /* just a cached method */
5989 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5990 /* already defined (or promised) */
5991 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
5992 if (ckWARN(WARN_REDEFINE)) {
5993 GV * const gvcv = CvGV(cv);
5995 HV * const stash = GvSTASH(gvcv);
5997 const char *redefined_name = HvNAME_get(stash);
5998 if ( strEQ(redefined_name,"autouse") ) {
5999 const line_t oldline = CopLINE(PL_curcop);
6000 if (PL_parser && PL_parser->copline != NOLINE)
6001 CopLINE_set(PL_curcop, PL_parser->copline);
6002 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6003 CvCONST(cv) ? "Constant subroutine %s redefined"
6004 : "Subroutine %s redefined"
6006 CopLINE_set(PL_curcop, oldline);
6016 if (cv) /* must reuse cv if autoloaded */
6019 cv = (CV*)newSV_type(SVt_PVCV);
6023 mro_method_changed_in(GvSTASH(gv)); /* newXS */
6027 (void)gv_fetchfile(filename);
6028 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
6029 an external constant string */
6031 CvXSUB(cv) = subaddr;
6034 process_special_blocks(name, gv, cv);
6046 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
6051 OP* pegop = newOP(OP_NULL, 0);
6055 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
6056 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
6058 #ifdef GV_UNIQUE_CHECK
6060 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
6064 if ((cv = GvFORM(gv))) {
6065 if (ckWARN(WARN_REDEFINE)) {
6066 const line_t oldline = CopLINE(PL_curcop);
6067 if (PL_parser && PL_parser->copline != NOLINE)
6068 CopLINE_set(PL_curcop, PL_parser->copline);
6069 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6070 o ? "Format %"SVf" redefined"
6071 : "Format STDOUT redefined", SVfARG(cSVOPo->op_sv));
6072 CopLINE_set(PL_curcop, oldline);
6079 CvFILE_set_from_cop(cv, PL_curcop);
6082 pad_tidy(padtidy_FORMAT);
6083 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
6084 CvROOT(cv)->op_private |= OPpREFCOUNTED;
6085 OpREFCNT_set(CvROOT(cv), 1);
6086 CvSTART(cv) = LINKLIST(CvROOT(cv));
6087 CvROOT(cv)->op_next = 0;
6088 CALL_PEEP(CvSTART(cv));
6090 op_getmad(o,pegop,'n');
6091 op_getmad_weak(block, pegop, 'b');
6096 PL_parser->copline = NOLINE;
6104 Perl_newANONLIST(pTHX_ OP *o)
6106 return convert(OP_ANONLIST, OPf_SPECIAL, o);
6110 Perl_newANONHASH(pTHX_ OP *o)
6112 return convert(OP_ANONHASH, OPf_SPECIAL, o);
6116 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
6118 return newANONATTRSUB(floor, proto, NULL, block);
6122 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
6124 return newUNOP(OP_REFGEN, 0,
6125 newSVOP(OP_ANONCODE, 0,
6126 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
6130 Perl_oopsAV(pTHX_ OP *o)
6134 PERL_ARGS_ASSERT_OOPSAV;
6136 switch (o->op_type) {
6138 o->op_type = OP_PADAV;
6139 o->op_ppaddr = PL_ppaddr[OP_PADAV];
6140 return ref(o, OP_RV2AV);
6143 o->op_type = OP_RV2AV;
6144 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
6149 if (ckWARN_d(WARN_INTERNAL))
6150 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
6157 Perl_oopsHV(pTHX_ OP *o)
6161 PERL_ARGS_ASSERT_OOPSHV;
6163 switch (o->op_type) {
6166 o->op_type = OP_PADHV;
6167 o->op_ppaddr = PL_ppaddr[OP_PADHV];
6168 return ref(o, OP_RV2HV);
6172 o->op_type = OP_RV2HV;
6173 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
6178 if (ckWARN_d(WARN_INTERNAL))
6179 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
6186 Perl_newAVREF(pTHX_ OP *o)
6190 PERL_ARGS_ASSERT_NEWAVREF;
6192 if (o->op_type == OP_PADANY) {
6193 o->op_type = OP_PADAV;
6194 o->op_ppaddr = PL_ppaddr[OP_PADAV];
6197 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
6198 && ckWARN(WARN_DEPRECATED)) {
6199 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
6200 "Using an array as a reference is deprecated");
6202 return newUNOP(OP_RV2AV, 0, scalar(o));
6206 Perl_newGVREF(pTHX_ I32 type, OP *o)
6208 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
6209 return newUNOP(OP_NULL, 0, o);
6210 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
6214 Perl_newHVREF(pTHX_ OP *o)
6218 PERL_ARGS_ASSERT_NEWHVREF;
6220 if (o->op_type == OP_PADANY) {
6221 o->op_type = OP_PADHV;
6222 o->op_ppaddr = PL_ppaddr[OP_PADHV];
6225 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
6226 && ckWARN(WARN_DEPRECATED)) {
6227 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
6228 "Using a hash as a reference is deprecated");
6230 return newUNOP(OP_RV2HV, 0, scalar(o));
6234 Perl_newCVREF(pTHX_ I32 flags, OP *o)
6236 return newUNOP(OP_RV2CV, flags, scalar(o));
6240 Perl_newSVREF(pTHX_ OP *o)
6244 PERL_ARGS_ASSERT_NEWSVREF;
6246 if (o->op_type == OP_PADANY) {
6247 o->op_type = OP_PADSV;
6248 o->op_ppaddr = PL_ppaddr[OP_PADSV];
6251 return newUNOP(OP_RV2SV, 0, scalar(o));
6254 /* Check routines. See the comments at the top of this file for details
6255 * on when these are called */
6258 Perl_ck_anoncode(pTHX_ OP *o)
6260 PERL_ARGS_ASSERT_CK_ANONCODE;
6262 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
6264 cSVOPo->op_sv = NULL;
6269 Perl_ck_bitop(pTHX_ OP *o)
6273 PERL_ARGS_ASSERT_CK_BITOP;
6275 #define OP_IS_NUMCOMPARE(op) \
6276 ((op) == OP_LT || (op) == OP_I_LT || \
6277 (op) == OP_GT || (op) == OP_I_GT || \
6278 (op) == OP_LE || (op) == OP_I_LE || \
6279 (op) == OP_GE || (op) == OP_I_GE || \
6280 (op) == OP_EQ || (op) == OP_I_EQ || \
6281 (op) == OP_NE || (op) == OP_I_NE || \
6282 (op) == OP_NCMP || (op) == OP_I_NCMP)
6283 o->op_private = (U8)(PL_hints & HINT_INTEGER);
6284 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
6285 && (o->op_type == OP_BIT_OR
6286 || o->op_type == OP_BIT_AND
6287 || o->op_type == OP_BIT_XOR))
6289 const OP * const left = cBINOPo->op_first;
6290 const OP * const right = left->op_sibling;
6291 if ((OP_IS_NUMCOMPARE(left->op_type) &&
6292 (left->op_flags & OPf_PARENS) == 0) ||
6293 (OP_IS_NUMCOMPARE(right->op_type) &&
6294 (right->op_flags & OPf_PARENS) == 0))
6295 if (ckWARN(WARN_PRECEDENCE))
6296 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
6297 "Possible precedence problem on bitwise %c operator",
6298 o->op_type == OP_BIT_OR ? '|'
6299 : o->op_type == OP_BIT_AND ? '&' : '^'
6306 Perl_ck_concat(pTHX_ OP *o)
6308 const OP * const kid = cUNOPo->op_first;
6310 PERL_ARGS_ASSERT_CK_CONCAT;
6311 PERL_UNUSED_CONTEXT;
6313 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
6314 !(kUNOP->op_first->op_flags & OPf_MOD))
6315 o->op_flags |= OPf_STACKED;
6320 Perl_ck_spair(pTHX_ OP *o)
6324 PERL_ARGS_ASSERT_CK_SPAIR;
6326 if (o->op_flags & OPf_KIDS) {
6329 const OPCODE type = o->op_type;
6330 o = modkids(ck_fun(o), type);
6331 kid = cUNOPo->op_first;
6332 newop = kUNOP->op_first->op_sibling;
6334 const OPCODE type = newop->op_type;
6335 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
6336 type == OP_PADAV || type == OP_PADHV ||
6337 type == OP_RV2AV || type == OP_RV2HV)
6341 op_getmad(kUNOP->op_first,newop,'K');
6343 op_free(kUNOP->op_first);
6345 kUNOP->op_first = newop;
6347 o->op_ppaddr = PL_ppaddr[++o->op_type];
6352 Perl_ck_delete(pTHX_ OP *o)
6354 PERL_ARGS_ASSERT_CK_DELETE;
6358 if (o->op_flags & OPf_KIDS) {
6359 OP * const kid = cUNOPo->op_first;
6360 switch (kid->op_type) {
6362 o->op_flags |= OPf_SPECIAL;
6365 o->op_private |= OPpSLICE;
6368 o->op_flags |= OPf_SPECIAL;
6373 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
6382 Perl_ck_die(pTHX_ OP *o)
6384 PERL_ARGS_ASSERT_CK_DIE;
6387 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6393 Perl_ck_eof(pTHX_ OP *o)
6397 PERL_ARGS_ASSERT_CK_EOF;
6399 if (o->op_flags & OPf_KIDS) {
6400 if (cLISTOPo->op_first->op_type == OP_STUB) {
6402 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
6404 op_getmad(o,newop,'O');
6416 Perl_ck_eval(pTHX_ OP *o)
6420 PERL_ARGS_ASSERT_CK_EVAL;
6422 PL_hints |= HINT_BLOCK_SCOPE;
6423 if (o->op_flags & OPf_KIDS) {
6424 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6427 o->op_flags &= ~OPf_KIDS;
6430 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
6436 cUNOPo->op_first = 0;
6441 NewOp(1101, enter, 1, LOGOP);
6442 enter->op_type = OP_ENTERTRY;
6443 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
6444 enter->op_private = 0;
6446 /* establish postfix order */
6447 enter->op_next = (OP*)enter;
6449 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
6450 o->op_type = OP_LEAVETRY;
6451 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
6452 enter->op_other = o;
6453 op_getmad(oldo,o,'O');
6467 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
6468 op_getmad(oldo,o,'O');
6470 o->op_targ = (PADOFFSET)PL_hints;
6471 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
6472 /* Store a copy of %^H that pp_entereval can pick up. */
6473 OP *hhop = newSVOP(OP_HINTSEVAL, 0,
6474 (SV*)Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv)));
6475 cUNOPo->op_first->op_sibling = hhop;
6476 o->op_private |= OPpEVAL_HAS_HH;
6482 Perl_ck_exit(pTHX_ OP *o)
6484 PERL_ARGS_ASSERT_CK_EXIT;
6487 HV * const table = GvHV(PL_hintgv);
6489 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
6490 if (svp && *svp && SvTRUE(*svp))
6491 o->op_private |= OPpEXIT_VMSISH;
6493 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6499 Perl_ck_exec(pTHX_ OP *o)
6501 PERL_ARGS_ASSERT_CK_EXEC;
6503 if (o->op_flags & OPf_STACKED) {
6506 kid = cUNOPo->op_first->op_sibling;
6507 if (kid->op_type == OP_RV2GV)
6516 Perl_ck_exists(pTHX_ OP *o)
6520 PERL_ARGS_ASSERT_CK_EXISTS;
6523 if (o->op_flags & OPf_KIDS) {
6524 OP * const kid = cUNOPo->op_first;
6525 if (kid->op_type == OP_ENTERSUB) {
6526 (void) ref(kid, o->op_type);
6527 if (kid->op_type != OP_RV2CV
6528 && !(PL_parser && PL_parser->error_count))
6529 Perl_croak(aTHX_ "%s argument is not a subroutine name",
6531 o->op_private |= OPpEXISTS_SUB;
6533 else if (kid->op_type == OP_AELEM)
6534 o->op_flags |= OPf_SPECIAL;
6535 else if (kid->op_type != OP_HELEM)
6536 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
6544 Perl_ck_rvconst(pTHX_ register OP *o)
6547 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6549 PERL_ARGS_ASSERT_CK_RVCONST;
6551 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6552 if (o->op_type == OP_RV2CV)
6553 o->op_private &= ~1;
6555 if (kid->op_type == OP_CONST) {
6558 SV * const kidsv = kid->op_sv;
6560 /* Is it a constant from cv_const_sv()? */
6561 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
6562 SV * const rsv = SvRV(kidsv);
6563 const svtype type = SvTYPE(rsv);
6564 const char *badtype = NULL;
6566 switch (o->op_type) {
6568 if (type > SVt_PVMG)
6569 badtype = "a SCALAR";
6572 if (type != SVt_PVAV)
6573 badtype = "an ARRAY";
6576 if (type != SVt_PVHV)
6580 if (type != SVt_PVCV)
6585 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
6588 else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
6589 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
6590 /* If this is an access to a stash, disable "strict refs", because
6591 * stashes aren't auto-vivified at compile-time (unless we store
6592 * symbols in them), and we don't want to produce a run-time
6593 * stricture error when auto-vivifying the stash. */
6594 const char *s = SvPV_nolen(kidsv);
6595 const STRLEN l = SvCUR(kidsv);
6596 if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
6597 o->op_private &= ~HINT_STRICT_REFS;
6599 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
6600 const char *badthing;
6601 switch (o->op_type) {
6603 badthing = "a SCALAR";
6606 badthing = "an ARRAY";
6609 badthing = "a HASH";
6617 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
6618 SVfARG(kidsv), badthing);
6621 * This is a little tricky. We only want to add the symbol if we
6622 * didn't add it in the lexer. Otherwise we get duplicate strict
6623 * warnings. But if we didn't add it in the lexer, we must at
6624 * least pretend like we wanted to add it even if it existed before,
6625 * or we get possible typo warnings. OPpCONST_ENTERED says
6626 * whether the lexer already added THIS instance of this symbol.
6628 iscv = (o->op_type == OP_RV2CV) * 2;
6630 gv = gv_fetchsv(kidsv,
6631 iscv | !(kid->op_private & OPpCONST_ENTERED),
6634 : o->op_type == OP_RV2SV
6636 : o->op_type == OP_RV2AV
6638 : o->op_type == OP_RV2HV
6641 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
6643 kid->op_type = OP_GV;
6644 SvREFCNT_dec(kid->op_sv);
6646 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
6647 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
6648 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
6650 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc_simple_NN(gv));
6652 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
6654 kid->op_private = 0;
6655 kid->op_ppaddr = PL_ppaddr[OP_GV];
6662 Perl_ck_ftst(pTHX_ OP *o)
6665 const I32 type = o->op_type;
6667 PERL_ARGS_ASSERT_CK_FTST;
6669 if (o->op_flags & OPf_REF) {
6672 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
6673 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6674 const OPCODE kidtype = kid->op_type;
6676 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6677 OP * const newop = newGVOP(type, OPf_REF,
6678 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
6680 op_getmad(o,newop,'O');
6686 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o))
6687 o->op_private |= OPpFT_ACCESS;
6688 if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst)
6689 && kidtype != OP_STAT && kidtype != OP_LSTAT)
6690 o->op_private |= OPpFT_STACKED;
6698 if (type == OP_FTTTY)
6699 o = newGVOP(type, OPf_REF, PL_stdingv);
6701 o = newUNOP(type, 0, newDEFSVOP());
6702 op_getmad(oldo,o,'O');
6708 Perl_ck_fun(pTHX_ OP *o)
6711 const int type = o->op_type;
6712 register I32 oa = PL_opargs[type] >> OASHIFT;
6714 PERL_ARGS_ASSERT_CK_FUN;
6716 if (o->op_flags & OPf_STACKED) {
6717 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
6720 return no_fh_allowed(o);
6723 if (o->op_flags & OPf_KIDS) {
6724 OP **tokid = &cLISTOPo->op_first;
6725 register OP *kid = cLISTOPo->op_first;
6729 if (kid->op_type == OP_PUSHMARK ||
6730 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
6732 tokid = &kid->op_sibling;
6733 kid = kid->op_sibling;
6735 if (!kid && PL_opargs[type] & OA_DEFGV)
6736 *tokid = kid = newDEFSVOP();
6740 sibl = kid->op_sibling;
6742 if (!sibl && kid->op_type == OP_STUB) {
6749 /* list seen where single (scalar) arg expected? */
6750 if (numargs == 1 && !(oa >> 4)
6751 && kid->op_type == OP_LIST && type != OP_SCALAR)
6753 return too_many_arguments(o,PL_op_desc[type]);
6766 if ((type == OP_PUSH || type == OP_UNSHIFT)
6767 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
6768 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6769 "Useless use of %s with no values",
6772 if (kid->op_type == OP_CONST &&
6773 (kid->op_private & OPpCONST_BARE))
6775 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
6776 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
6777 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6778 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6779 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
6780 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6782 op_getmad(kid,newop,'K');
6787 kid->op_sibling = sibl;
6790 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
6791 bad_type(numargs, "array", PL_op_desc[type], kid);
6795 if (kid->op_type == OP_CONST &&
6796 (kid->op_private & OPpCONST_BARE))
6798 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
6799 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
6800 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6801 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6802 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
6803 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6805 op_getmad(kid,newop,'K');
6810 kid->op_sibling = sibl;
6813 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
6814 bad_type(numargs, "hash", PL_op_desc[type], kid);
6819 OP * const newop = newUNOP(OP_NULL, 0, kid);
6820 kid->op_sibling = 0;
6822 newop->op_next = newop;
6824 kid->op_sibling = sibl;
6829 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
6830 if (kid->op_type == OP_CONST &&
6831 (kid->op_private & OPpCONST_BARE))
6833 OP * const newop = newGVOP(OP_GV, 0,
6834 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
6835 if (!(o->op_private & 1) && /* if not unop */
6836 kid == cLISTOPo->op_last)
6837 cLISTOPo->op_last = newop;
6839 op_getmad(kid,newop,'K');
6845 else if (kid->op_type == OP_READLINE) {
6846 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
6847 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
6850 I32 flags = OPf_SPECIAL;
6854 /* is this op a FH constructor? */
6855 if (is_handle_constructor(o,numargs)) {
6856 const char *name = NULL;
6860 /* Set a flag to tell rv2gv to vivify
6861 * need to "prove" flag does not mean something
6862 * else already - NI-S 1999/05/07
6865 if (kid->op_type == OP_PADSV) {
6867 = PAD_COMPNAME_SV(kid->op_targ);
6868 name = SvPV_const(namesv, len);
6870 else if (kid->op_type == OP_RV2SV
6871 && kUNOP->op_first->op_type == OP_GV)
6873 GV * const gv = cGVOPx_gv(kUNOP->op_first);
6875 len = GvNAMELEN(gv);
6877 else if (kid->op_type == OP_AELEM
6878 || kid->op_type == OP_HELEM)
6881 OP *op = ((BINOP*)kid)->op_first;
6885 const char * const a =
6886 kid->op_type == OP_AELEM ?
6888 if (((op->op_type == OP_RV2AV) ||
6889 (op->op_type == OP_RV2HV)) &&
6890 (firstop = ((UNOP*)op)->op_first) &&
6891 (firstop->op_type == OP_GV)) {
6892 /* packagevar $a[] or $h{} */
6893 GV * const gv = cGVOPx_gv(firstop);
6901 else if (op->op_type == OP_PADAV
6902 || op->op_type == OP_PADHV) {
6903 /* lexicalvar $a[] or $h{} */
6904 const char * const padname =
6905 PAD_COMPNAME_PV(op->op_targ);
6914 name = SvPV_const(tmpstr, len);
6919 name = "__ANONIO__";
6926 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
6927 namesv = PAD_SVl(targ);
6928 SvUPGRADE(namesv, SVt_PV);
6930 sv_setpvn(namesv, "$", 1);
6931 sv_catpvn(namesv, name, len);
6934 kid->op_sibling = 0;
6935 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
6936 kid->op_targ = targ;
6937 kid->op_private |= priv;
6939 kid->op_sibling = sibl;
6945 mod(scalar(kid), type);
6949 tokid = &kid->op_sibling;
6950 kid = kid->op_sibling;
6953 if (kid && kid->op_type != OP_STUB)
6954 return too_many_arguments(o,OP_DESC(o));
6955 o->op_private |= numargs;
6957 /* FIXME - should the numargs move as for the PERL_MAD case? */
6958 o->op_private |= numargs;
6960 return too_many_arguments(o,OP_DESC(o));
6964 else if (PL_opargs[type] & OA_DEFGV) {
6966 OP *newop = newUNOP(type, 0, newDEFSVOP());
6967 op_getmad(o,newop,'O');
6970 /* Ordering of these two is important to keep f_map.t passing. */
6972 return newUNOP(type, 0, newDEFSVOP());
6977 while (oa & OA_OPTIONAL)
6979 if (oa && oa != OA_LIST)
6980 return too_few_arguments(o,OP_DESC(o));
6986 Perl_ck_glob(pTHX_ OP *o)
6991 PERL_ARGS_ASSERT_CK_GLOB;
6994 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
6995 append_elem(OP_GLOB, o, newDEFSVOP());
6997 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
6998 && GvCVu(gv) && GvIMPORTED_CV(gv)))
7000 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7003 #if !defined(PERL_EXTERNAL_GLOB)
7004 /* XXX this can be tightened up and made more failsafe. */
7005 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7008 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
7009 newSVpvs("File::Glob"), NULL, NULL, NULL);
7010 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7011 glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
7012 GvCV(gv) = GvCV(glob_gv);
7013 SvREFCNT_inc_void((SV*)GvCV(gv));
7014 GvIMPORTED_CV_on(gv);
7017 #endif /* PERL_EXTERNAL_GLOB */
7019 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7020 append_elem(OP_GLOB, o,
7021 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
7022 o->op_type = OP_LIST;
7023 o->op_ppaddr = PL_ppaddr[OP_LIST];
7024 cLISTOPo->op_first->op_type = OP_PUSHMARK;
7025 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
7026 cLISTOPo->op_first->op_targ = 0;
7027 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
7028 append_elem(OP_LIST, o,
7029 scalar(newUNOP(OP_RV2CV, 0,
7030 newGVOP(OP_GV, 0, gv)))));
7031 o = newUNOP(OP_NULL, 0, ck_subr(o));
7032 o->op_targ = OP_GLOB; /* hint at what it used to be */
7035 gv = newGVgen("main");
7037 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
7043 Perl_ck_grep(pTHX_ OP *o)
7048 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
7051 PERL_ARGS_ASSERT_CK_GREP;
7053 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
7054 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
7056 if (o->op_flags & OPf_STACKED) {
7059 kid = cLISTOPo->op_first->op_sibling;
7060 if (!cUNOPx(kid)->op_next)
7061 Perl_croak(aTHX_ "panic: ck_grep");
7062 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
7065 NewOp(1101, gwop, 1, LOGOP);
7066 kid->op_next = (OP*)gwop;
7067 o->op_flags &= ~OPf_STACKED;
7069 kid = cLISTOPo->op_first->op_sibling;
7070 if (type == OP_MAPWHILE)
7075 if (PL_parser && PL_parser->error_count)
7077 kid = cLISTOPo->op_first->op_sibling;
7078 if (kid->op_type != OP_NULL)
7079 Perl_croak(aTHX_ "panic: ck_grep");
7080 kid = kUNOP->op_first;
7083 NewOp(1101, gwop, 1, LOGOP);
7084 gwop->op_type = type;
7085 gwop->op_ppaddr = PL_ppaddr[type];
7086 gwop->op_first = listkids(o);
7087 gwop->op_flags |= OPf_KIDS;
7088 gwop->op_other = LINKLIST(kid);
7089 kid->op_next = (OP*)gwop;
7090 offset = pad_findmy("$_");
7091 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
7092 o->op_private = gwop->op_private = 0;
7093 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
7096 o->op_private = gwop->op_private = OPpGREP_LEX;
7097 gwop->op_targ = o->op_targ = offset;
7100 kid = cLISTOPo->op_first->op_sibling;
7101 if (!kid || !kid->op_sibling)
7102 return too_few_arguments(o,OP_DESC(o));
7103 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
7104 mod(kid, OP_GREPSTART);
7110 Perl_ck_index(pTHX_ OP *o)
7112 PERL_ARGS_ASSERT_CK_INDEX;
7114 if (o->op_flags & OPf_KIDS) {
7115 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7117 kid = kid->op_sibling; /* get past "big" */
7118 if (kid && kid->op_type == OP_CONST)
7119 fbm_compile(((SVOP*)kid)->op_sv, 0);
7125 Perl_ck_lfun(pTHX_ OP *o)
7127 const OPCODE type = o->op_type;
7129 PERL_ARGS_ASSERT_CK_LFUN;
7131 return modkids(ck_fun(o), type);
7135 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
7137 PERL_ARGS_ASSERT_CK_DEFINED;
7139 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
7140 switch (cUNOPo->op_first->op_type) {
7142 /* This is needed for
7143 if (defined %stash::)
7144 to work. Do not break Tk.
7146 break; /* Globals via GV can be undef */
7148 case OP_AASSIGN: /* Is this a good idea? */
7149 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
7150 "defined(@array) is deprecated");
7151 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
7152 "\t(Maybe you should just omit the defined()?)\n");
7155 /* This is needed for
7156 if (defined %stash::)
7157 to work. Do not break Tk.
7159 break; /* Globals via GV can be undef */
7161 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
7162 "defined(%%hash) is deprecated");
7163 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
7164 "\t(Maybe you should just omit the defined()?)\n");
7175 Perl_ck_readline(pTHX_ OP *o)
7177 PERL_ARGS_ASSERT_CK_READLINE;
7179 if (!(o->op_flags & OPf_KIDS)) {
7181 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
7183 op_getmad(o,newop,'O');
7193 Perl_ck_rfun(pTHX_ OP *o)
7195 const OPCODE type = o->op_type;
7197 PERL_ARGS_ASSERT_CK_RFUN;
7199 return refkids(ck_fun(o), type);
7203 Perl_ck_listiob(pTHX_ OP *o)
7207 PERL_ARGS_ASSERT_CK_LISTIOB;
7209 kid = cLISTOPo->op_first;
7212 kid = cLISTOPo->op_first;
7214 if (kid->op_type == OP_PUSHMARK)
7215 kid = kid->op_sibling;
7216 if (kid && o->op_flags & OPf_STACKED)
7217 kid = kid->op_sibling;
7218 else if (kid && !kid->op_sibling) { /* print HANDLE; */
7219 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
7220 o->op_flags |= OPf_STACKED; /* make it a filehandle */
7221 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
7222 cLISTOPo->op_first->op_sibling = kid;
7223 cLISTOPo->op_last = kid;
7224 kid = kid->op_sibling;
7229 append_elem(o->op_type, o, newDEFSVOP());
7235 Perl_ck_smartmatch(pTHX_ OP *o)
7238 if (0 == (o->op_flags & OPf_SPECIAL)) {
7239 OP *first = cBINOPo->op_first;
7240 OP *second = first->op_sibling;
7242 /* Implicitly take a reference to an array or hash */
7243 first->op_sibling = NULL;
7244 first = cBINOPo->op_first = ref_array_or_hash(first);
7245 second = first->op_sibling = ref_array_or_hash(second);
7247 /* Implicitly take a reference to a regular expression */
7248 if (first->op_type == OP_MATCH) {
7249 first->op_type = OP_QR;
7250 first->op_ppaddr = PL_ppaddr[OP_QR];
7252 if (second->op_type == OP_MATCH) {
7253 second->op_type = OP_QR;
7254 second->op_ppaddr = PL_ppaddr[OP_QR];
7263 Perl_ck_sassign(pTHX_ OP *o)
7266 OP * const kid = cLISTOPo->op_first;
7268 PERL_ARGS_ASSERT_CK_SASSIGN;
7270 /* has a disposable target? */
7271 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
7272 && !(kid->op_flags & OPf_STACKED)
7273 /* Cannot steal the second time! */
7274 && !(kid->op_private & OPpTARGET_MY)
7275 /* Keep the full thing for madskills */
7279 OP * const kkid = kid->op_sibling;
7281 /* Can just relocate the target. */
7282 if (kkid && kkid->op_type == OP_PADSV
7283 && !(kkid->op_private & OPpLVAL_INTRO))
7285 kid->op_targ = kkid->op_targ;
7287 /* Now we do not need PADSV and SASSIGN. */
7288 kid->op_sibling = o->op_sibling; /* NULL */
7289 cLISTOPo->op_first = NULL;
7292 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
7296 if (kid->op_sibling) {
7297 OP *kkid = kid->op_sibling;
7298 if (kkid->op_type == OP_PADSV
7299 && (kkid->op_private & OPpLVAL_INTRO)
7300 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
7301 const PADOFFSET target = kkid->op_targ;
7302 OP *const other = newOP(OP_PADSV,
7304 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
7305 OP *const first = newOP(OP_NULL, 0);
7306 OP *const nullop = newCONDOP(0, first, o, other);
7307 OP *const condop = first->op_next;
7308 /* hijacking PADSTALE for uninitialized state variables */
7309 SvPADSTALE_on(PAD_SVl(target));
7311 condop->op_type = OP_ONCE;
7312 condop->op_ppaddr = PL_ppaddr[OP_ONCE];
7313 condop->op_targ = target;
7314 other->op_targ = target;
7316 /* Because we change the type of the op here, we will skip the
7317 assinment binop->op_last = binop->op_first->op_sibling; at the
7318 end of Perl_newBINOP(). So need to do it here. */
7319 cBINOPo->op_last = cBINOPo->op_first->op_sibling;
7328 Perl_ck_match(pTHX_ OP *o)
7332 PERL_ARGS_ASSERT_CK_MATCH;
7334 if (o->op_type != OP_QR && PL_compcv) {
7335 const PADOFFSET offset = pad_findmy("$_");
7336 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
7337 o->op_targ = offset;
7338 o->op_private |= OPpTARGET_MY;
7341 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
7342 o->op_private |= OPpRUNTIME;
7347 Perl_ck_method(pTHX_ OP *o)
7349 OP * const kid = cUNOPo->op_first;
7351 PERL_ARGS_ASSERT_CK_METHOD;
7353 if (kid->op_type == OP_CONST) {
7354 SV* sv = kSVOP->op_sv;
7355 const char * const method = SvPVX_const(sv);
7356 if (!(strchr(method, ':') || strchr(method, '\''))) {
7358 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
7359 sv = newSVpvn_share(method, SvCUR(sv), 0);
7362 kSVOP->op_sv = NULL;
7364 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
7366 op_getmad(o,cmop,'O');
7377 Perl_ck_null(pTHX_ OP *o)
7379 PERL_ARGS_ASSERT_CK_NULL;
7380 PERL_UNUSED_CONTEXT;
7385 Perl_ck_open(pTHX_ OP *o)
7388 HV * const table = GvHV(PL_hintgv);
7390 PERL_ARGS_ASSERT_CK_OPEN;
7393 SV **svp = hv_fetchs(table, "open_IN", FALSE);
7395 const I32 mode = mode_from_discipline(*svp);
7396 if (mode & O_BINARY)
7397 o->op_private |= OPpOPEN_IN_RAW;
7398 else if (mode & O_TEXT)
7399 o->op_private |= OPpOPEN_IN_CRLF;
7402 svp = hv_fetchs(table, "open_OUT", FALSE);
7404 const I32 mode = mode_from_discipline(*svp);
7405 if (mode & O_BINARY)
7406 o->op_private |= OPpOPEN_OUT_RAW;
7407 else if (mode & O_TEXT)
7408 o->op_private |= OPpOPEN_OUT_CRLF;
7411 if (o->op_type == OP_BACKTICK) {
7412 if (!(o->op_flags & OPf_KIDS)) {
7413 OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
7415 op_getmad(o,newop,'O');
7424 /* In case of three-arg dup open remove strictness
7425 * from the last arg if it is a bareword. */
7426 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
7427 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
7431 if ((last->op_type == OP_CONST) && /* The bareword. */
7432 (last->op_private & OPpCONST_BARE) &&
7433 (last->op_private & OPpCONST_STRICT) &&
7434 (oa = first->op_sibling) && /* The fh. */
7435 (oa = oa->op_sibling) && /* The mode. */
7436 (oa->op_type == OP_CONST) &&
7437 SvPOK(((SVOP*)oa)->op_sv) &&
7438 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
7439 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
7440 (last == oa->op_sibling)) /* The bareword. */
7441 last->op_private &= ~OPpCONST_STRICT;
7447 Perl_ck_repeat(pTHX_ OP *o)
7449 PERL_ARGS_ASSERT_CK_REPEAT;
7451 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
7452 o->op_private |= OPpREPEAT_DOLIST;
7453 cBINOPo->op_first = force_list(cBINOPo->op_first);
7461 Perl_ck_require(pTHX_ OP *o)
7466 PERL_ARGS_ASSERT_CK_REQUIRE;
7468 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
7469 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7471 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
7472 SV * const sv = kid->op_sv;
7473 U32 was_readonly = SvREADONLY(sv);
7480 sv_force_normal_flags(sv, 0);
7481 assert(!SvREADONLY(sv));
7491 for (; s < end; s++) {
7492 if (*s == ':' && s[1] == ':') {
7494 Move(s+2, s+1, end - s - 1, char);
7499 sv_catpvs(sv, ".pm");
7500 SvFLAGS(sv) |= was_readonly;
7504 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
7505 /* handle override, if any */
7506 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
7507 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7508 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
7509 gv = gvp ? *gvp : NULL;
7513 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7514 OP * const kid = cUNOPo->op_first;
7517 cUNOPo->op_first = 0;
7521 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
7522 append_elem(OP_LIST, kid,
7523 scalar(newUNOP(OP_RV2CV, 0,
7526 op_getmad(o,newop,'O');
7534 Perl_ck_return(pTHX_ OP *o)
7538 PERL_ARGS_ASSERT_CK_RETURN;
7540 if (CvLVALUE(PL_compcv)) {
7542 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
7543 mod(kid, OP_LEAVESUBLV);
7549 Perl_ck_select(pTHX_ OP *o)
7554 PERL_ARGS_ASSERT_CK_SELECT;
7556 if (o->op_flags & OPf_KIDS) {
7557 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7558 if (kid && kid->op_sibling) {
7559 o->op_type = OP_SSELECT;
7560 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
7562 return fold_constants(o);
7566 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7567 if (kid && kid->op_type == OP_RV2GV)
7568 kid->op_private &= ~HINT_STRICT_REFS;
7573 Perl_ck_shift(pTHX_ OP *o)
7576 const I32 type = o->op_type;
7578 PERL_ARGS_ASSERT_CK_SHIFT;
7580 if (!(o->op_flags & OPf_KIDS)) {
7582 /* FIXME - this can be refactored to reduce code in #ifdefs */
7584 OP * const oldo = o;
7588 argop = newUNOP(OP_RV2AV, 0,
7589 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
7591 o = newUNOP(type, 0, scalar(argop));
7592 op_getmad(oldo,o,'O');
7595 return newUNOP(type, 0, scalar(argop));
7598 return scalar(modkids(ck_fun(o), type));
7602 Perl_ck_sort(pTHX_ OP *o)
7607 PERL_ARGS_ASSERT_CK_SORT;
7609 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
7610 HV * const hinthv = GvHV(PL_hintgv);
7612 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
7614 const I32 sorthints = (I32)SvIV(*svp);
7615 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
7616 o->op_private |= OPpSORT_QSORT;
7617 if ((sorthints & HINT_SORT_STABLE) != 0)
7618 o->op_private |= OPpSORT_STABLE;
7623 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
7625 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7626 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
7628 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
7630 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
7632 if (kid->op_type == OP_SCOPE) {
7636 else if (kid->op_type == OP_LEAVE) {
7637 if (o->op_type == OP_SORT) {
7638 op_null(kid); /* wipe out leave */
7641 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
7642 if (k->op_next == kid)
7644 /* don't descend into loops */
7645 else if (k->op_type == OP_ENTERLOOP
7646 || k->op_type == OP_ENTERITER)
7648 k = cLOOPx(k)->op_lastop;
7653 kid->op_next = 0; /* just disconnect the leave */
7654 k = kLISTOP->op_first;
7659 if (o->op_type == OP_SORT) {
7660 /* provide scalar context for comparison function/block */
7666 o->op_flags |= OPf_SPECIAL;
7668 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
7671 firstkid = firstkid->op_sibling;
7674 /* provide list context for arguments */
7675 if (o->op_type == OP_SORT)
7682 S_simplify_sort(pTHX_ OP *o)
7685 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7691 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
7693 if (!(o->op_flags & OPf_STACKED))
7695 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7696 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
7697 kid = kUNOP->op_first; /* get past null */
7698 if (kid->op_type != OP_SCOPE)
7700 kid = kLISTOP->op_last; /* get past scope */
7701 switch(kid->op_type) {
7709 k = kid; /* remember this node*/
7710 if (kBINOP->op_first->op_type != OP_RV2SV)
7712 kid = kBINOP->op_first; /* get past cmp */
7713 if (kUNOP->op_first->op_type != OP_GV)
7715 kid = kUNOP->op_first; /* get past rv2sv */
7717 if (GvSTASH(gv) != PL_curstash)
7719 gvname = GvNAME(gv);
7720 if (*gvname == 'a' && gvname[1] == '\0')
7722 else if (*gvname == 'b' && gvname[1] == '\0')
7727 kid = k; /* back to cmp */
7728 if (kBINOP->op_last->op_type != OP_RV2SV)
7730 kid = kBINOP->op_last; /* down to 2nd arg */
7731 if (kUNOP->op_first->op_type != OP_GV)
7733 kid = kUNOP->op_first; /* get past rv2sv */
7735 if (GvSTASH(gv) != PL_curstash)
7737 gvname = GvNAME(gv);
7739 ? !(*gvname == 'a' && gvname[1] == '\0')
7740 : !(*gvname == 'b' && gvname[1] == '\0'))
7742 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
7744 o->op_private |= OPpSORT_DESCEND;
7745 if (k->op_type == OP_NCMP)
7746 o->op_private |= OPpSORT_NUMERIC;
7747 if (k->op_type == OP_I_NCMP)
7748 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
7749 kid = cLISTOPo->op_first->op_sibling;
7750 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
7752 op_getmad(kid,o,'S'); /* then delete it */
7754 op_free(kid); /* then delete it */
7759 Perl_ck_split(pTHX_ OP *o)
7764 PERL_ARGS_ASSERT_CK_SPLIT;
7766 if (o->op_flags & OPf_STACKED)
7767 return no_fh_allowed(o);
7769 kid = cLISTOPo->op_first;
7770 if (kid->op_type != OP_NULL)
7771 Perl_croak(aTHX_ "panic: ck_split");
7772 kid = kid->op_sibling;
7773 op_free(cLISTOPo->op_first);
7774 cLISTOPo->op_first = kid;
7776 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
7777 cLISTOPo->op_last = kid; /* There was only one element previously */
7780 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
7781 OP * const sibl = kid->op_sibling;
7782 kid->op_sibling = 0;
7783 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
7784 if (cLISTOPo->op_first == cLISTOPo->op_last)
7785 cLISTOPo->op_last = kid;
7786 cLISTOPo->op_first = kid;
7787 kid->op_sibling = sibl;
7790 kid->op_type = OP_PUSHRE;
7791 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
7793 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
7794 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
7795 "Use of /g modifier is meaningless in split");
7798 if (!kid->op_sibling)
7799 append_elem(OP_SPLIT, o, newDEFSVOP());
7801 kid = kid->op_sibling;
7804 if (!kid->op_sibling)
7805 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
7806 assert(kid->op_sibling);
7808 kid = kid->op_sibling;
7811 if (kid->op_sibling)
7812 return too_many_arguments(o,OP_DESC(o));
7818 Perl_ck_join(pTHX_ OP *o)
7820 const OP * const kid = cLISTOPo->op_first->op_sibling;
7822 PERL_ARGS_ASSERT_CK_JOIN;
7824 if (kid && kid->op_type == OP_MATCH) {
7825 if (ckWARN(WARN_SYNTAX)) {
7826 const REGEXP *re = PM_GETRE(kPMOP);
7827 const char *pmstr = re ? RX_PRECOMP(re) : "STRING";
7828 const STRLEN len = re ? RX_PRELEN(re) : 6;
7829 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7830 "/%.*s/ should probably be written as \"%.*s\"",
7831 (int)len, pmstr, (int)len, pmstr);
7838 Perl_ck_subr(pTHX_ OP *o)
7841 OP *prev = ((cUNOPo->op_first->op_sibling)
7842 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
7843 OP *o2 = prev->op_sibling;
7845 const char *proto = NULL;
7846 const char *proto_end = NULL;
7851 I32 contextclass = 0;
7852 const char *e = NULL;
7855 PERL_ARGS_ASSERT_CK_SUBR;
7857 o->op_private |= OPpENTERSUB_HASTARG;
7858 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
7859 if (cvop->op_type == OP_RV2CV) {
7861 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
7862 op_null(cvop); /* disable rv2cv */
7863 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
7864 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
7865 GV *gv = cGVOPx_gv(tmpop);
7868 tmpop->op_private |= OPpEARLY_CV;
7872 namegv = CvANON(cv) ? gv : CvGV(cv);
7873 proto = SvPV((SV*)cv, len);
7874 proto_end = proto + len;
7879 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7880 if (o2->op_type == OP_CONST)
7881 o2->op_private &= ~OPpCONST_STRICT;
7882 else if (o2->op_type == OP_LIST) {
7883 OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
7884 if (sib && sib->op_type == OP_CONST)
7885 sib->op_private &= ~OPpCONST_STRICT;
7888 o->op_private |= (PL_hints & HINT_STRICT_REFS);
7889 if (PERLDB_SUB && PL_curstash != PL_debstash)
7890 o->op_private |= OPpENTERSUB_DB;
7891 while (o2 != cvop) {
7893 if (PL_madskills && o2->op_type == OP_STUB) {
7894 o2 = o2->op_sibling;
7897 if (PL_madskills && o2->op_type == OP_NULL)
7898 o3 = ((UNOP*)o2)->op_first;
7902 if (proto >= proto_end)
7903 return too_many_arguments(o, gv_ename(namegv));
7911 /* _ must be at the end */
7912 if (proto[1] && proto[1] != ';')
7927 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
7929 arg == 1 ? "block or sub {}" : "sub {}",
7930 gv_ename(namegv), o3);
7933 /* '*' allows any scalar type, including bareword */
7936 if (o3->op_type == OP_RV2GV)
7937 goto wrapref; /* autoconvert GLOB -> GLOBref */
7938 else if (o3->op_type == OP_CONST)
7939 o3->op_private &= ~OPpCONST_STRICT;
7940 else if (o3->op_type == OP_ENTERSUB) {
7941 /* accidental subroutine, revert to bareword */
7942 OP *gvop = ((UNOP*)o3)->op_first;
7943 if (gvop && gvop->op_type == OP_NULL) {
7944 gvop = ((UNOP*)gvop)->op_first;
7946 for (; gvop->op_sibling; gvop = gvop->op_sibling)
7949 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
7950 (gvop = ((UNOP*)gvop)->op_first) &&
7951 gvop->op_type == OP_GV)
7953 GV * const gv = cGVOPx_gv(gvop);
7954 OP * const sibling = o2->op_sibling;
7955 SV * const n = newSVpvs("");
7957 OP * const oldo2 = o2;
7961 gv_fullname4(n, gv, "", FALSE);
7962 o2 = newSVOP(OP_CONST, 0, n);
7963 op_getmad(oldo2,o2,'O');
7964 prev->op_sibling = o2;
7965 o2->op_sibling = sibling;
7981 if (contextclass++ == 0) {
7982 e = strchr(proto, ']');
7983 if (!e || e == proto)
7992 const char *p = proto;
7993 const char *const end = proto;
7995 while (*--p != '[');
7996 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
7998 gv_ename(namegv), o3);
8003 if (o3->op_type == OP_RV2GV)
8006 bad_type(arg, "symbol", gv_ename(namegv), o3);
8009 if (o3->op_type == OP_ENTERSUB)
8012 bad_type(arg, "subroutine entry", gv_ename(namegv),
8016 if (o3->op_type == OP_RV2SV ||
8017 o3->op_type == OP_PADSV ||
8018 o3->op_type == OP_HELEM ||
8019 o3->op_type == OP_AELEM)
8022 bad_type(arg, "scalar", gv_ename(namegv), o3);
8025 if (o3->op_type == OP_RV2AV ||
8026 o3->op_type == OP_PADAV)
8029 bad_type(arg, "array", gv_ename(namegv), o3);
8032 if (o3->op_type == OP_RV2HV ||
8033 o3->op_type == OP_PADHV)
8036 bad_type(arg, "hash", gv_ename(namegv), o3);
8041 OP* const sib = kid->op_sibling;
8042 kid->op_sibling = 0;
8043 o2 = newUNOP(OP_REFGEN, 0, kid);
8044 o2->op_sibling = sib;
8045 prev->op_sibling = o2;
8047 if (contextclass && e) {
8062 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
8063 gv_ename(namegv), SVfARG(cv));
8068 mod(o2, OP_ENTERSUB);
8070 o2 = o2->op_sibling;
8072 if (o2 == cvop && proto && *proto == '_') {
8073 /* generate an access to $_ */
8075 o2->op_sibling = prev->op_sibling;
8076 prev->op_sibling = o2; /* instead of cvop */
8078 if (proto && !optional && proto_end > proto &&
8079 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
8080 return too_few_arguments(o, gv_ename(namegv));
8083 OP * const oldo = o;
8087 o=newSVOP(OP_CONST, 0, newSViv(0));
8088 op_getmad(oldo,o,'O');
8094 Perl_ck_svconst(pTHX_ OP *o)
8096 PERL_ARGS_ASSERT_CK_SVCONST;
8097 PERL_UNUSED_CONTEXT;
8098 SvREADONLY_on(cSVOPo->op_sv);
8103 Perl_ck_chdir(pTHX_ OP *o)
8105 if (o->op_flags & OPf_KIDS) {
8106 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8108 if (kid && kid->op_type == OP_CONST &&
8109 (kid->op_private & OPpCONST_BARE))
8111 o->op_flags |= OPf_SPECIAL;
8112 kid->op_private &= ~OPpCONST_STRICT;
8119 Perl_ck_trunc(pTHX_ OP *o)
8121 PERL_ARGS_ASSERT_CK_TRUNC;
8123 if (o->op_flags & OPf_KIDS) {
8124 SVOP *kid = (SVOP*)cUNOPo->op_first;
8126 if (kid->op_type == OP_NULL)
8127 kid = (SVOP*)kid->op_sibling;
8128 if (kid && kid->op_type == OP_CONST &&
8129 (kid->op_private & OPpCONST_BARE))
8131 o->op_flags |= OPf_SPECIAL;
8132 kid->op_private &= ~OPpCONST_STRICT;
8139 Perl_ck_unpack(pTHX_ OP *o)
8141 OP *kid = cLISTOPo->op_first;
8143 PERL_ARGS_ASSERT_CK_UNPACK;
8145 if (kid->op_sibling) {
8146 kid = kid->op_sibling;
8147 if (!kid->op_sibling)
8148 kid->op_sibling = newDEFSVOP();
8154 Perl_ck_substr(pTHX_ OP *o)
8156 PERL_ARGS_ASSERT_CK_SUBSTR;
8159 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
8160 OP *kid = cLISTOPo->op_first;
8162 if (kid->op_type == OP_NULL)
8163 kid = kid->op_sibling;
8165 kid->op_flags |= OPf_MOD;
8172 Perl_ck_each(pTHX_ OP *o)
8175 OP *kid = cLISTOPo->op_first;
8177 PERL_ARGS_ASSERT_CK_EACH;
8179 if (kid->op_type == OP_PADAV || kid->op_type == OP_RV2AV) {
8180 const unsigned new_type = o->op_type == OP_EACH ? OP_AEACH
8181 : o->op_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
8182 o->op_type = new_type;
8183 o->op_ppaddr = PL_ppaddr[new_type];
8185 else if (!(kid->op_type == OP_PADHV || kid->op_type == OP_RV2HV
8186 || (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE)
8188 bad_type(1, "hash or array", PL_op_desc[o->op_type], kid);
8194 /* A peephole optimizer. We visit the ops in the order they're to execute.
8195 * See the comments at the top of this file for more details about when
8196 * peep() is called */
8199 Perl_peep(pTHX_ register OP *o)
8202 register OP* oldop = NULL;
8204 if (!o || o->op_opt)
8208 SAVEVPTR(PL_curcop);
8209 for (; o; o = o->op_next) {
8212 /* By default, this op has now been optimised. A couple of cases below
8213 clear this again. */
8216 switch (o->op_type) {
8219 PL_curcop = ((COP*)o); /* for warnings */
8223 if (cSVOPo->op_private & OPpCONST_STRICT)
8224 no_bareword_allowed(o);
8227 case OP_METHOD_NAMED:
8228 /* Relocate sv to the pad for thread safety.
8229 * Despite being a "constant", the SV is written to,
8230 * for reference counts, sv_upgrade() etc. */
8232 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
8233 if (o->op_type != OP_METHOD_NAMED && SvPADTMP(cSVOPo->op_sv)) {
8234 /* If op_sv is already a PADTMP then it is being used by
8235 * some pad, so make a copy. */
8236 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
8237 SvREADONLY_on(PAD_SVl(ix));
8238 SvREFCNT_dec(cSVOPo->op_sv);
8240 else if (o->op_type != OP_METHOD_NAMED
8241 && cSVOPo->op_sv == &PL_sv_undef) {
8242 /* PL_sv_undef is hack - it's unsafe to store it in the
8243 AV that is the pad, because av_fetch treats values of
8244 PL_sv_undef as a "free" AV entry and will merrily
8245 replace them with a new SV, causing pad_alloc to think
8246 that this pad slot is free. (When, clearly, it is not)
8248 SvOK_off(PAD_SVl(ix));
8249 SvPADTMP_on(PAD_SVl(ix));
8250 SvREADONLY_on(PAD_SVl(ix));
8253 SvREFCNT_dec(PAD_SVl(ix));
8254 SvPADTMP_on(cSVOPo->op_sv);
8255 PAD_SETSV(ix, cSVOPo->op_sv);
8256 /* XXX I don't know how this isn't readonly already. */
8257 SvREADONLY_on(PAD_SVl(ix));
8259 cSVOPo->op_sv = NULL;
8266 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
8267 if (o->op_next->op_private & OPpTARGET_MY) {
8268 if (o->op_flags & OPf_STACKED) /* chained concats */
8269 break; /* ignore_optimization */
8271 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
8272 o->op_targ = o->op_next->op_targ;
8273 o->op_next->op_targ = 0;
8274 o->op_private |= OPpTARGET_MY;
8277 op_null(o->op_next);
8281 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
8282 break; /* Scalar stub must produce undef. List stub is noop */
8286 if (o->op_targ == OP_NEXTSTATE
8287 || o->op_targ == OP_DBSTATE)
8289 PL_curcop = ((COP*)o);
8291 /* XXX: We avoid setting op_seq here to prevent later calls
8292 to peep() from mistakenly concluding that optimisation
8293 has already occurred. This doesn't fix the real problem,
8294 though (See 20010220.007). AMS 20010719 */
8295 /* op_seq functionality is now replaced by op_opt */
8302 if (oldop && o->op_next) {
8303 oldop->op_next = o->op_next;
8311 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
8312 OP* const pop = (o->op_type == OP_PADAV) ?
8313 o->op_next : o->op_next->op_next;
8315 if (pop && pop->op_type == OP_CONST &&
8316 ((PL_op = pop->op_next)) &&
8317 pop->op_next->op_type == OP_AELEM &&
8318 !(pop->op_next->op_private &
8319 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
8320 (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
8325 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
8326 no_bareword_allowed(pop);
8327 if (o->op_type == OP_GV)
8328 op_null(o->op_next);
8329 op_null(pop->op_next);
8331 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
8332 o->op_next = pop->op_next->op_next;
8333 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
8334 o->op_private = (U8)i;
8335 if (o->op_type == OP_GV) {
8340 o->op_flags |= OPf_SPECIAL;
8341 o->op_type = OP_AELEMFAST;
8346 if (o->op_next->op_type == OP_RV2SV) {
8347 if (!(o->op_next->op_private & OPpDEREF)) {
8348 op_null(o->op_next);
8349 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
8351 o->op_next = o->op_next->op_next;
8352 o->op_type = OP_GVSV;
8353 o->op_ppaddr = PL_ppaddr[OP_GVSV];
8356 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
8357 GV * const gv = cGVOPo_gv;
8358 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
8359 /* XXX could check prototype here instead of just carping */
8360 SV * const sv = sv_newmortal();
8361 gv_efullname3(sv, gv, NULL);
8362 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
8363 "%"SVf"() called too early to check prototype",
8367 else if (o->op_next->op_type == OP_READLINE
8368 && o->op_next->op_next->op_type == OP_CONCAT
8369 && (o->op_next->op_next->op_flags & OPf_STACKED))
8371 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
8372 o->op_type = OP_RCATLINE;
8373 o->op_flags |= OPf_STACKED;
8374 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
8375 op_null(o->op_next->op_next);
8376 op_null(o->op_next);
8392 while (cLOGOP->op_other->op_type == OP_NULL)
8393 cLOGOP->op_other = cLOGOP->op_other->op_next;
8394 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
8399 while (cLOOP->op_redoop->op_type == OP_NULL)
8400 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
8401 peep(cLOOP->op_redoop);
8402 while (cLOOP->op_nextop->op_type == OP_NULL)
8403 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
8404 peep(cLOOP->op_nextop);
8405 while (cLOOP->op_lastop->op_type == OP_NULL)
8406 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
8407 peep(cLOOP->op_lastop);
8411 assert(!(cPMOP->op_pmflags & PMf_ONCE));
8412 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
8413 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
8414 cPMOP->op_pmstashstartu.op_pmreplstart
8415 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
8416 peep(cPMOP->op_pmstashstartu.op_pmreplstart);
8420 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
8421 && ckWARN(WARN_SYNTAX))
8423 if (o->op_next->op_sibling) {
8424 const OPCODE type = o->op_next->op_sibling->op_type;
8425 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
8426 const line_t oldline = CopLINE(PL_curcop);
8427 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
8428 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8429 "Statement unlikely to be reached");
8430 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8431 "\t(Maybe you meant system() when you said exec()?)\n");
8432 CopLINE_set(PL_curcop, oldline);
8443 const char *key = NULL;
8446 if (((BINOP*)o)->op_last->op_type != OP_CONST)
8449 /* Make the CONST have a shared SV */
8450 svp = cSVOPx_svp(((BINOP*)o)->op_last);
8451 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
8452 key = SvPV_const(sv, keylen);
8453 lexname = newSVpvn_share(key,
8454 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
8460 if ((o->op_private & (OPpLVAL_INTRO)))
8463 rop = (UNOP*)((BINOP*)o)->op_first;
8464 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
8466 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
8467 if (!SvPAD_TYPED(lexname))
8469 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8470 if (!fields || !GvHV(*fields))
8472 key = SvPV_const(*svp, keylen);
8473 if (!hv_fetch(GvHV(*fields), key,
8474 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8476 Perl_croak(aTHX_ "No such class field \"%s\" "
8477 "in variable %s of type %s",
8478 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
8491 SVOP *first_key_op, *key_op;
8493 if ((o->op_private & (OPpLVAL_INTRO))
8494 /* I bet there's always a pushmark... */
8495 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
8496 /* hmmm, no optimization if list contains only one key. */
8498 rop = (UNOP*)((LISTOP*)o)->op_last;
8499 if (rop->op_type != OP_RV2HV)
8501 if (rop->op_first->op_type == OP_PADSV)
8502 /* @$hash{qw(keys here)} */
8503 rop = (UNOP*)rop->op_first;
8505 /* @{$hash}{qw(keys here)} */
8506 if (rop->op_first->op_type == OP_SCOPE
8507 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
8509 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
8515 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
8516 if (!SvPAD_TYPED(lexname))
8518 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8519 if (!fields || !GvHV(*fields))
8521 /* Again guessing that the pushmark can be jumped over.... */
8522 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
8523 ->op_first->op_sibling;
8524 for (key_op = first_key_op; key_op;
8525 key_op = (SVOP*)key_op->op_sibling) {
8526 if (key_op->op_type != OP_CONST)
8528 svp = cSVOPx_svp(key_op);
8529 key = SvPV_const(*svp, keylen);
8530 if (!hv_fetch(GvHV(*fields), key,
8531 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8533 Perl_croak(aTHX_ "No such class field \"%s\" "
8534 "in variable %s of type %s",
8535 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
8542 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
8546 /* check that RHS of sort is a single plain array */
8547 OP *oright = cUNOPo->op_first;
8548 if (!oright || oright->op_type != OP_PUSHMARK)
8551 /* reverse sort ... can be optimised. */
8552 if (!cUNOPo->op_sibling) {
8553 /* Nothing follows us on the list. */
8554 OP * const reverse = o->op_next;
8556 if (reverse->op_type == OP_REVERSE &&
8557 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
8558 OP * const pushmark = cUNOPx(reverse)->op_first;
8559 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
8560 && (cUNOPx(pushmark)->op_sibling == o)) {
8561 /* reverse -> pushmark -> sort */
8562 o->op_private |= OPpSORT_REVERSE;
8564 pushmark->op_next = oright->op_next;
8570 /* make @a = sort @a act in-place */
8572 oright = cUNOPx(oright)->op_sibling;
8575 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
8576 oright = cUNOPx(oright)->op_sibling;
8580 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
8581 || oright->op_next != o
8582 || (oright->op_private & OPpLVAL_INTRO)
8586 /* o2 follows the chain of op_nexts through the LHS of the
8587 * assign (if any) to the aassign op itself */
8589 if (!o2 || o2->op_type != OP_NULL)
8592 if (!o2 || o2->op_type != OP_PUSHMARK)
8595 if (o2 && o2->op_type == OP_GV)
8598 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
8599 || (o2->op_private & OPpLVAL_INTRO)
8604 if (!o2 || o2->op_type != OP_NULL)
8607 if (!o2 || o2->op_type != OP_AASSIGN
8608 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
8611 /* check that the sort is the first arg on RHS of assign */
8613 o2 = cUNOPx(o2)->op_first;
8614 if (!o2 || o2->op_type != OP_NULL)
8616 o2 = cUNOPx(o2)->op_first;
8617 if (!o2 || o2->op_type != OP_PUSHMARK)
8619 if (o2->op_sibling != o)
8622 /* check the array is the same on both sides */
8623 if (oleft->op_type == OP_RV2AV) {
8624 if (oright->op_type != OP_RV2AV
8625 || !cUNOPx(oright)->op_first
8626 || cUNOPx(oright)->op_first->op_type != OP_GV
8627 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
8628 cGVOPx_gv(cUNOPx(oright)->op_first)
8632 else if (oright->op_type != OP_PADAV
8633 || oright->op_targ != oleft->op_targ
8637 /* transfer MODishness etc from LHS arg to RHS arg */
8638 oright->op_flags = oleft->op_flags;
8639 o->op_private |= OPpSORT_INPLACE;
8641 /* excise push->gv->rv2av->null->aassign */
8642 o2 = o->op_next->op_next;
8643 op_null(o2); /* PUSHMARK */
8645 if (o2->op_type == OP_GV) {
8646 op_null(o2); /* GV */
8649 op_null(o2); /* RV2AV or PADAV */
8650 o2 = o2->op_next->op_next;
8651 op_null(o2); /* AASSIGN */
8653 o->op_next = o2->op_next;
8659 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
8661 LISTOP *enter, *exlist;
8663 enter = (LISTOP *) o->op_next;
8666 if (enter->op_type == OP_NULL) {
8667 enter = (LISTOP *) enter->op_next;
8671 /* for $a (...) will have OP_GV then OP_RV2GV here.
8672 for (...) just has an OP_GV. */
8673 if (enter->op_type == OP_GV) {
8674 gvop = (OP *) enter;
8675 enter = (LISTOP *) enter->op_next;
8678 if (enter->op_type == OP_RV2GV) {
8679 enter = (LISTOP *) enter->op_next;
8685 if (enter->op_type != OP_ENTERITER)
8688 iter = enter->op_next;
8689 if (!iter || iter->op_type != OP_ITER)
8692 expushmark = enter->op_first;
8693 if (!expushmark || expushmark->op_type != OP_NULL
8694 || expushmark->op_targ != OP_PUSHMARK)
8697 exlist = (LISTOP *) expushmark->op_sibling;
8698 if (!exlist || exlist->op_type != OP_NULL
8699 || exlist->op_targ != OP_LIST)
8702 if (exlist->op_last != o) {
8703 /* Mmm. Was expecting to point back to this op. */
8706 theirmark = exlist->op_first;
8707 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
8710 if (theirmark->op_sibling != o) {
8711 /* There's something between the mark and the reverse, eg
8712 for (1, reverse (...))
8717 ourmark = ((LISTOP *)o)->op_first;
8718 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
8721 ourlast = ((LISTOP *)o)->op_last;
8722 if (!ourlast || ourlast->op_next != o)
8725 rv2av = ourmark->op_sibling;
8726 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
8727 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
8728 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
8729 /* We're just reversing a single array. */
8730 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
8731 enter->op_flags |= OPf_STACKED;
8734 /* We don't have control over who points to theirmark, so sacrifice
8736 theirmark->op_next = ourmark->op_next;
8737 theirmark->op_flags = ourmark->op_flags;
8738 ourlast->op_next = gvop ? gvop : (OP *) enter;
8741 enter->op_private |= OPpITER_REVERSED;
8742 iter->op_private |= OPpITER_REVERSED;
8749 UNOP *refgen, *rv2cv;
8752 if ((o->op_flags & OPf_WANT) != OPf_WANT_VOID)
8755 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
8758 rv2gv = ((BINOP *)o)->op_last;
8759 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
8762 refgen = (UNOP *)((BINOP *)o)->op_first;
8764 if (!refgen || refgen->op_type != OP_REFGEN)
8767 exlist = (LISTOP *)refgen->op_first;
8768 if (!exlist || exlist->op_type != OP_NULL
8769 || exlist->op_targ != OP_LIST)
8772 if (exlist->op_first->op_type != OP_PUSHMARK)
8775 rv2cv = (UNOP*)exlist->op_last;
8777 if (rv2cv->op_type != OP_RV2CV)
8780 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
8781 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
8782 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
8784 o->op_private |= OPpASSIGN_CV_TO_GV;
8785 rv2gv->op_private |= OPpDONT_INIT_GV;
8786 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
8794 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
8795 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
8805 Perl_custom_op_name(pTHX_ const OP* o)
8808 const IV index = PTR2IV(o->op_ppaddr);
8812 PERL_ARGS_ASSERT_CUSTOM_OP_NAME;
8814 if (!PL_custom_op_names) /* This probably shouldn't happen */
8815 return (char *)PL_op_name[OP_CUSTOM];
8817 keysv = sv_2mortal(newSViv(index));
8819 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
8821 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
8823 return SvPV_nolen(HeVAL(he));
8827 Perl_custom_op_desc(pTHX_ const OP* o)
8830 const IV index = PTR2IV(o->op_ppaddr);
8834 PERL_ARGS_ASSERT_CUSTOM_OP_DESC;
8836 if (!PL_custom_op_descs)
8837 return (char *)PL_op_desc[OP_CUSTOM];
8839 keysv = sv_2mortal(newSViv(index));
8841 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
8843 return (char *)PL_op_desc[OP_CUSTOM];
8845 return SvPV_nolen(HeVAL(he));
8850 /* Efficient sub that returns a constant scalar value. */
8852 const_sv_xsub(pTHX_ CV* cv)
8859 Perl_croak(aTHX_ "usage: %s::%s()",
8860 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
8864 ST(0) = (SV*)XSANY.any_ptr;
8870 * c-indentation-style: bsd
8872 * indent-tabs-mode: t
8875 * ex: set ts=8 sts=4 sw=4 noet: