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<SAVE_HINTS>
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 = 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:
583 SvREFCNT_dec(cSVOPo->op_sv);
584 cSVOPo->op_sv = NULL;
587 Even if op_clear does a pad_free for the target of the op,
588 pad_free doesn't actually remove the sv that exists in the pad;
589 instead it lives on. This results in that it could be reused as
590 a target later on when the pad was reallocated.
593 pad_swipe(o->op_targ,1);
602 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
606 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
608 if (cPADOPo->op_padix > 0) {
609 pad_swipe(cPADOPo->op_padix, TRUE);
610 cPADOPo->op_padix = 0;
613 SvREFCNT_dec(cSVOPo->op_sv);
614 cSVOPo->op_sv = NULL;
618 PerlMemShared_free(cPVOPo->op_pv);
619 cPVOPo->op_pv = NULL;
623 op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
627 if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
628 /* No GvIN_PAD_off here, because other references may still
629 * exist on the pad */
630 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
633 SvREFCNT_dec((SV*)cPMOPo->op_pmreplrootu.op_pmtargetgv);
639 forget_pmop(cPMOPo, 1);
640 cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
641 /* we use the same protection as the "SAFE" version of the PM_ macros
642 * here since sv_clean_all might release some PMOPs
643 * after PL_regex_padav has been cleared
644 * and the clearing of PL_regex_padav needs to
645 * happen before sv_clean_all
648 if(PL_regex_pad) { /* We could be in destruction */
649 const IV offset = (cPMOPo)->op_pmoffset;
650 ReREFCNT_dec(PM_GETRE(cPMOPo));
651 PL_regex_pad[offset] = &PL_sv_undef;
652 sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
656 ReREFCNT_dec(PM_GETRE(cPMOPo));
657 PM_SETRE(cPMOPo, NULL);
663 if (o->op_targ > 0) {
664 pad_free(o->op_targ);
670 S_cop_free(pTHX_ COP* cop)
672 PERL_ARGS_ASSERT_COP_FREE;
677 if (! specialWARN(cop->cop_warnings))
678 PerlMemShared_free(cop->cop_warnings);
679 Perl_refcounted_he_free(aTHX_ cop->cop_hints_hash);
683 S_forget_pmop(pTHX_ PMOP *const o
689 HV * const pmstash = PmopSTASH(o);
691 PERL_ARGS_ASSERT_FORGET_PMOP;
693 if (pmstash && !SvIS_FREED(pmstash)) {
694 MAGIC * const mg = mg_find((SV*)pmstash, PERL_MAGIC_symtab);
696 PMOP **const array = (PMOP**) mg->mg_ptr;
697 U32 count = mg->mg_len / sizeof(PMOP**);
702 /* Found it. Move the entry at the end to overwrite it. */
703 array[i] = array[--count];
704 mg->mg_len = count * sizeof(PMOP**);
705 /* Could realloc smaller at this point always, but probably
706 not worth it. Probably worth free()ing if we're the
709 Safefree(mg->mg_ptr);
726 S_find_and_forget_pmops(pTHX_ OP *o)
728 PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
730 if (o->op_flags & OPf_KIDS) {
731 OP *kid = cUNOPo->op_first;
733 switch (kid->op_type) {
738 forget_pmop((PMOP*)kid, 0);
740 find_and_forget_pmops(kid);
741 kid = kid->op_sibling;
747 Perl_op_null(pTHX_ OP *o)
751 PERL_ARGS_ASSERT_OP_NULL;
753 if (o->op_type == OP_NULL)
757 o->op_targ = o->op_type;
758 o->op_type = OP_NULL;
759 o->op_ppaddr = PL_ppaddr[OP_NULL];
763 Perl_op_refcnt_lock(pTHX)
771 Perl_op_refcnt_unlock(pTHX)
778 /* Contextualizers */
780 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
783 Perl_linklist(pTHX_ OP *o)
787 PERL_ARGS_ASSERT_LINKLIST;
792 /* establish postfix order */
793 first = cUNOPo->op_first;
796 o->op_next = LINKLIST(first);
799 if (kid->op_sibling) {
800 kid->op_next = LINKLIST(kid->op_sibling);
801 kid = kid->op_sibling;
815 Perl_scalarkids(pTHX_ OP *o)
817 if (o && o->op_flags & OPf_KIDS) {
819 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
826 S_scalarboolean(pTHX_ OP *o)
830 PERL_ARGS_ASSERT_SCALARBOOLEAN;
832 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
833 if (ckWARN(WARN_SYNTAX)) {
834 const line_t oldline = CopLINE(PL_curcop);
836 if (PL_parser && PL_parser->copline != NOLINE)
837 CopLINE_set(PL_curcop, PL_parser->copline);
838 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
839 CopLINE_set(PL_curcop, oldline);
846 Perl_scalar(pTHX_ OP *o)
851 /* assumes no premature commitment */
852 if (!o || (PL_parser && PL_parser->error_count)
853 || (o->op_flags & OPf_WANT)
854 || o->op_type == OP_RETURN)
859 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
861 switch (o->op_type) {
863 scalar(cBINOPo->op_first);
868 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
872 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
873 if (!kPMOP->op_pmreplrootu.op_pmreplroot)
874 deprecate_old("implicit split to @_");
882 if (o->op_flags & OPf_KIDS) {
883 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
889 kid = cLISTOPo->op_first;
891 while ((kid = kid->op_sibling)) {
897 PL_curcop = &PL_compiling;
902 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
908 PL_curcop = &PL_compiling;
911 if (ckWARN(WARN_VOID))
912 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
918 Perl_scalarvoid(pTHX_ OP *o)
922 const char* useless = NULL;
926 PERL_ARGS_ASSERT_SCALARVOID;
928 /* trailing mad null ops don't count as "there" for void processing */
930 o->op_type != OP_NULL &&
932 o->op_sibling->op_type == OP_NULL)
935 for (sib = o->op_sibling;
936 sib && sib->op_type == OP_NULL;
937 sib = sib->op_sibling) ;
943 if (o->op_type == OP_NEXTSTATE
944 || o->op_type == OP_DBSTATE
945 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
946 || o->op_targ == OP_DBSTATE)))
947 PL_curcop = (COP*)o; /* for warning below */
949 /* assumes no premature commitment */
950 want = o->op_flags & OPf_WANT;
951 if ((want && want != OPf_WANT_SCALAR)
952 || (PL_parser && PL_parser->error_count)
953 || o->op_type == OP_RETURN)
958 if ((o->op_private & OPpTARGET_MY)
959 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
961 return scalar(o); /* As if inside SASSIGN */
964 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
966 switch (o->op_type) {
968 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
972 if (o->op_flags & OPf_STACKED)
976 if (o->op_private == 4)
1019 case OP_GETSOCKNAME:
1020 case OP_GETPEERNAME:
1025 case OP_GETPRIORITY:
1049 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1050 /* Otherwise it's "Useless use of grep iterator" */
1051 useless = OP_DESC(o);
1055 kid = cUNOPo->op_first;
1056 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1057 kid->op_type != OP_TRANS) {
1060 useless = "negative pattern binding (!~)";
1067 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1068 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1069 useless = "a variable";
1074 if (cSVOPo->op_private & OPpCONST_STRICT)
1075 no_bareword_allowed(o);
1077 if (ckWARN(WARN_VOID)) {
1078 useless = "a constant";
1079 if (o->op_private & OPpCONST_ARYBASE)
1081 /* don't warn on optimised away booleans, eg
1082 * use constant Foo, 5; Foo || print; */
1083 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1085 /* the constants 0 and 1 are permitted as they are
1086 conventionally used as dummies in constructs like
1087 1 while some_condition_with_side_effects; */
1088 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1090 else if (SvPOK(sv)) {
1091 /* perl4's way of mixing documentation and code
1092 (before the invention of POD) was based on a
1093 trick to mix nroff and perl code. The trick was
1094 built upon these three nroff macros being used in
1095 void context. The pink camel has the details in
1096 the script wrapman near page 319. */
1097 const char * const maybe_macro = SvPVX_const(sv);
1098 if (strnEQ(maybe_macro, "di", 2) ||
1099 strnEQ(maybe_macro, "ds", 2) ||
1100 strnEQ(maybe_macro, "ig", 2))
1105 op_null(o); /* don't execute or even remember it */
1109 o->op_type = OP_PREINC; /* pre-increment is faster */
1110 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1114 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1115 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1119 o->op_type = OP_I_PREINC; /* pre-increment is faster */
1120 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1124 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
1125 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1134 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1139 if (o->op_flags & OPf_STACKED)
1146 if (!(o->op_flags & OPf_KIDS))
1157 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1164 /* all requires must return a boolean value */
1165 o->op_flags &= ~OPf_WANT;
1170 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
1171 if (!kPMOP->op_pmreplrootu.op_pmreplroot)
1172 deprecate_old("implicit split to @_");
1176 if (useless && ckWARN(WARN_VOID))
1177 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
1182 Perl_listkids(pTHX_ OP *o)
1184 if (o && o->op_flags & OPf_KIDS) {
1186 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1193 Perl_list(pTHX_ OP *o)
1198 /* assumes no premature commitment */
1199 if (!o || (o->op_flags & OPf_WANT)
1200 || (PL_parser && PL_parser->error_count)
1201 || o->op_type == OP_RETURN)
1206 if ((o->op_private & OPpTARGET_MY)
1207 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1209 return o; /* As if inside SASSIGN */
1212 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1214 switch (o->op_type) {
1217 list(cBINOPo->op_first);
1222 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1230 if (!(o->op_flags & OPf_KIDS))
1232 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1233 list(cBINOPo->op_first);
1234 return gen_constant_list(o);
1241 kid = cLISTOPo->op_first;
1243 while ((kid = kid->op_sibling)) {
1244 if (kid->op_sibling)
1249 PL_curcop = &PL_compiling;
1253 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1254 if (kid->op_sibling)
1259 PL_curcop = &PL_compiling;
1262 /* all requires must return a boolean value */
1263 o->op_flags &= ~OPf_WANT;
1270 Perl_scalarseq(pTHX_ OP *o)
1274 const OPCODE type = o->op_type;
1276 if (type == OP_LINESEQ || type == OP_SCOPE ||
1277 type == OP_LEAVE || type == OP_LEAVETRY)
1280 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1281 if (kid->op_sibling) {
1285 PL_curcop = &PL_compiling;
1287 o->op_flags &= ~OPf_PARENS;
1288 if (PL_hints & HINT_BLOCK_SCOPE)
1289 o->op_flags |= OPf_PARENS;
1292 o = newOP(OP_STUB, 0);
1297 S_modkids(pTHX_ OP *o, I32 type)
1299 if (o && o->op_flags & OPf_KIDS) {
1301 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1307 /* Propagate lvalue ("modifiable") context to an op and its children.
1308 * 'type' represents the context type, roughly based on the type of op that
1309 * would do the modifying, although local() is represented by OP_NULL.
1310 * It's responsible for detecting things that can't be modified, flag
1311 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
1312 * might have to vivify a reference in $x), and so on.
1314 * For example, "$a+1 = 2" would cause mod() to be called with o being
1315 * OP_ADD and type being OP_SASSIGN, and would output an error.
1319 Perl_mod(pTHX_ OP *o, I32 type)
1323 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1326 if (!o || (PL_parser && PL_parser->error_count))
1329 if ((o->op_private & OPpTARGET_MY)
1330 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1335 switch (o->op_type) {
1341 if (!(o->op_private & OPpCONST_ARYBASE))
1344 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1345 CopARYBASE_set(&PL_compiling,
1346 (I32)SvIV(cSVOPx(PL_eval_start)->op_sv));
1350 SAVECOPARYBASE(&PL_compiling);
1351 CopARYBASE_set(&PL_compiling, 0);
1353 else if (type == OP_REFGEN)
1356 Perl_croak(aTHX_ "That use of $[ is unsupported");
1359 if ((o->op_flags & OPf_PARENS) || PL_madskills)
1363 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1364 !(o->op_flags & OPf_STACKED)) {
1365 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1366 /* The default is to set op_private to the number of children,
1367 which for a UNOP such as RV2CV is always 1. And w're using
1368 the bit for a flag in RV2CV, so we need it clear. */
1369 o->op_private &= ~1;
1370 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1371 assert(cUNOPo->op_first->op_type == OP_NULL);
1372 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1375 else if (o->op_private & OPpENTERSUB_NOMOD)
1377 else { /* lvalue subroutine call */
1378 o->op_private |= OPpLVAL_INTRO;
1379 PL_modcount = RETURN_UNLIMITED_NUMBER;
1380 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1381 /* Backward compatibility mode: */
1382 o->op_private |= OPpENTERSUB_INARGS;
1385 else { /* Compile-time error message: */
1386 OP *kid = cUNOPo->op_first;
1390 if (kid->op_type != OP_PUSHMARK) {
1391 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1393 "panic: unexpected lvalue entersub "
1394 "args: type/targ %ld:%"UVuf,
1395 (long)kid->op_type, (UV)kid->op_targ);
1396 kid = kLISTOP->op_first;
1398 while (kid->op_sibling)
1399 kid = kid->op_sibling;
1400 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1402 if (kid->op_type == OP_METHOD_NAMED
1403 || kid->op_type == OP_METHOD)
1407 NewOp(1101, newop, 1, UNOP);
1408 newop->op_type = OP_RV2CV;
1409 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1410 newop->op_first = NULL;
1411 newop->op_next = (OP*)newop;
1412 kid->op_sibling = (OP*)newop;
1413 newop->op_private |= OPpLVAL_INTRO;
1414 newop->op_private &= ~1;
1418 if (kid->op_type != OP_RV2CV)
1420 "panic: unexpected lvalue entersub "
1421 "entry via type/targ %ld:%"UVuf,
1422 (long)kid->op_type, (UV)kid->op_targ);
1423 kid->op_private |= OPpLVAL_INTRO;
1424 break; /* Postpone until runtime */
1428 kid = kUNOP->op_first;
1429 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1430 kid = kUNOP->op_first;
1431 if (kid->op_type == OP_NULL)
1433 "Unexpected constant lvalue entersub "
1434 "entry via type/targ %ld:%"UVuf,
1435 (long)kid->op_type, (UV)kid->op_targ);
1436 if (kid->op_type != OP_GV) {
1437 /* Restore RV2CV to check lvalueness */
1439 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1440 okid->op_next = kid->op_next;
1441 kid->op_next = okid;
1444 okid->op_next = NULL;
1445 okid->op_type = OP_RV2CV;
1447 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1448 okid->op_private |= OPpLVAL_INTRO;
1449 okid->op_private &= ~1;
1453 cv = GvCV(kGVOP_gv);
1463 /* grep, foreach, subcalls, refgen */
1464 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1466 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1467 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1469 : (o->op_type == OP_ENTERSUB
1470 ? "non-lvalue subroutine call"
1472 type ? PL_op_desc[type] : "local"));
1486 case OP_RIGHT_SHIFT:
1495 if (!(o->op_flags & OPf_STACKED))
1502 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1508 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1509 PL_modcount = RETURN_UNLIMITED_NUMBER;
1510 return o; /* Treat \(@foo) like ordinary list. */
1514 if (scalar_mod_type(o, type))
1516 ref(cUNOPo->op_first, o->op_type);
1520 if (type == OP_LEAVESUBLV)
1521 o->op_private |= OPpMAYBE_LVSUB;
1527 PL_modcount = RETURN_UNLIMITED_NUMBER;
1530 ref(cUNOPo->op_first, o->op_type);
1535 PL_hints |= HINT_BLOCK_SCOPE;
1550 PL_modcount = RETURN_UNLIMITED_NUMBER;
1551 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1552 return o; /* Treat \(@foo) like ordinary list. */
1553 if (scalar_mod_type(o, type))
1555 if (type == OP_LEAVESUBLV)
1556 o->op_private |= OPpMAYBE_LVSUB;
1560 if (!type) /* local() */
1561 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1562 PAD_COMPNAME_PV(o->op_targ));
1570 if (type != OP_SASSIGN)
1574 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1579 if (type == OP_LEAVESUBLV)
1580 o->op_private |= OPpMAYBE_LVSUB;
1582 pad_free(o->op_targ);
1583 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1584 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1585 if (o->op_flags & OPf_KIDS)
1586 mod(cBINOPo->op_first->op_sibling, type);
1591 ref(cBINOPo->op_first, o->op_type);
1592 if (type == OP_ENTERSUB &&
1593 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1594 o->op_private |= OPpLVAL_DEFER;
1595 if (type == OP_LEAVESUBLV)
1596 o->op_private |= OPpMAYBE_LVSUB;
1606 if (o->op_flags & OPf_KIDS)
1607 mod(cLISTOPo->op_last, type);
1612 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1614 else if (!(o->op_flags & OPf_KIDS))
1616 if (o->op_targ != OP_LIST) {
1617 mod(cBINOPo->op_first, type);
1623 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1628 if (type != OP_LEAVESUBLV)
1630 break; /* mod()ing was handled by ck_return() */
1633 /* [20011101.069] File test operators interpret OPf_REF to mean that
1634 their argument is a filehandle; thus \stat(".") should not set
1636 if (type == OP_REFGEN &&
1637 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1640 if (type != OP_LEAVESUBLV)
1641 o->op_flags |= OPf_MOD;
1643 if (type == OP_AASSIGN || type == OP_SASSIGN)
1644 o->op_flags |= OPf_SPECIAL|OPf_REF;
1645 else if (!type) { /* local() */
1648 o->op_private |= OPpLVAL_INTRO;
1649 o->op_flags &= ~OPf_SPECIAL;
1650 PL_hints |= HINT_BLOCK_SCOPE;
1655 if (ckWARN(WARN_SYNTAX)) {
1656 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1657 "Useless localization of %s", OP_DESC(o));
1661 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1662 && type != OP_LEAVESUBLV)
1663 o->op_flags |= OPf_REF;
1668 S_scalar_mod_type(const OP *o, I32 type)
1670 PERL_ARGS_ASSERT_SCALAR_MOD_TYPE;
1674 if (o->op_type == OP_RV2GV)
1698 case OP_RIGHT_SHIFT:
1718 S_is_handle_constructor(const OP *o, I32 numargs)
1720 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
1722 switch (o->op_type) {
1730 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1743 Perl_refkids(pTHX_ OP *o, I32 type)
1745 if (o && o->op_flags & OPf_KIDS) {
1747 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1754 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
1759 PERL_ARGS_ASSERT_DOREF;
1761 if (!o || (PL_parser && PL_parser->error_count))
1764 switch (o->op_type) {
1766 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1767 !(o->op_flags & OPf_STACKED)) {
1768 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1769 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1770 assert(cUNOPo->op_first->op_type == OP_NULL);
1771 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1772 o->op_flags |= OPf_SPECIAL;
1773 o->op_private &= ~1;
1778 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1779 doref(kid, type, set_op_ref);
1782 if (type == OP_DEFINED)
1783 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1784 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1787 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1788 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1789 : type == OP_RV2HV ? OPpDEREF_HV
1791 o->op_flags |= OPf_MOD;
1798 o->op_flags |= OPf_REF;
1801 if (type == OP_DEFINED)
1802 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1803 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1809 o->op_flags |= OPf_REF;
1814 if (!(o->op_flags & OPf_KIDS))
1816 doref(cBINOPo->op_first, type, set_op_ref);
1820 doref(cBINOPo->op_first, o->op_type, set_op_ref);
1821 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1822 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1823 : type == OP_RV2HV ? OPpDEREF_HV
1825 o->op_flags |= OPf_MOD;
1835 if (!(o->op_flags & OPf_KIDS))
1837 doref(cLISTOPo->op_last, type, set_op_ref);
1847 S_dup_attrlist(pTHX_ OP *o)
1852 PERL_ARGS_ASSERT_DUP_ATTRLIST;
1854 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1855 * where the first kid is OP_PUSHMARK and the remaining ones
1856 * are OP_CONST. We need to push the OP_CONST values.
1858 if (o->op_type == OP_CONST)
1859 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
1861 else if (o->op_type == OP_NULL)
1865 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1867 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1868 if (o->op_type == OP_CONST)
1869 rop = append_elem(OP_LIST, rop,
1870 newSVOP(OP_CONST, o->op_flags,
1871 SvREFCNT_inc_NN(cSVOPo->op_sv)));
1878 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1883 PERL_ARGS_ASSERT_APPLY_ATTRS;
1885 /* fake up C<use attributes $pkg,$rv,@attrs> */
1886 ENTER; /* need to protect against side-effects of 'use' */
1887 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1889 #define ATTRSMODULE "attributes"
1890 #define ATTRSMODULE_PM "attributes.pm"
1893 /* Don't force the C<use> if we don't need it. */
1894 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
1895 if (svp && *svp != &PL_sv_undef)
1896 NOOP; /* already in %INC */
1898 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1899 newSVpvs(ATTRSMODULE), NULL);
1902 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1903 newSVpvs(ATTRSMODULE),
1905 prepend_elem(OP_LIST,
1906 newSVOP(OP_CONST, 0, stashsv),
1907 prepend_elem(OP_LIST,
1908 newSVOP(OP_CONST, 0,
1910 dup_attrlist(attrs))));
1916 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1919 OP *pack, *imop, *arg;
1922 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
1927 assert(target->op_type == OP_PADSV ||
1928 target->op_type == OP_PADHV ||
1929 target->op_type == OP_PADAV);
1931 /* Ensure that attributes.pm is loaded. */
1932 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1934 /* Need package name for method call. */
1935 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
1937 /* Build up the real arg-list. */
1938 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1940 arg = newOP(OP_PADSV, 0);
1941 arg->op_targ = target->op_targ;
1942 arg = prepend_elem(OP_LIST,
1943 newSVOP(OP_CONST, 0, stashsv),
1944 prepend_elem(OP_LIST,
1945 newUNOP(OP_REFGEN, 0,
1946 mod(arg, OP_REFGEN)),
1947 dup_attrlist(attrs)));
1949 /* Fake up a method call to import */
1950 meth = newSVpvs_share("import");
1951 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1952 append_elem(OP_LIST,
1953 prepend_elem(OP_LIST, pack, list(arg)),
1954 newSVOP(OP_METHOD_NAMED, 0, meth)));
1955 imop->op_private |= OPpENTERSUB_NOMOD;
1957 /* Combine the ops. */
1958 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1962 =notfor apidoc apply_attrs_string
1964 Attempts to apply a list of attributes specified by the C<attrstr> and
1965 C<len> arguments to the subroutine identified by the C<cv> argument which
1966 is expected to be associated with the package identified by the C<stashpv>
1967 argument (see L<attributes>). It gets this wrong, though, in that it
1968 does not correctly identify the boundaries of the individual attribute
1969 specifications within C<attrstr>. This is not really intended for the
1970 public API, but has to be listed here for systems such as AIX which
1971 need an explicit export list for symbols. (It's called from XS code
1972 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1973 to respect attribute syntax properly would be welcome.
1979 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
1980 const char *attrstr, STRLEN len)
1984 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
1987 len = strlen(attrstr);
1991 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1993 const char * const sstr = attrstr;
1994 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1995 attrs = append_elem(OP_LIST, attrs,
1996 newSVOP(OP_CONST, 0,
1997 newSVpvn(sstr, attrstr-sstr)));
2001 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2002 newSVpvs(ATTRSMODULE),
2003 NULL, prepend_elem(OP_LIST,
2004 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2005 prepend_elem(OP_LIST,
2006 newSVOP(OP_CONST, 0,
2012 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
2017 PERL_ARGS_ASSERT_MY_KID;
2019 if (!o || (PL_parser && PL_parser->error_count))
2023 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
2024 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
2028 if (type == OP_LIST) {
2030 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2031 my_kid(kid, attrs, imopsp);
2032 } else if (type == OP_UNDEF
2038 } else if (type == OP_RV2SV || /* "our" declaration */
2040 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
2041 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
2042 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2044 PL_parser->in_my == KEY_our
2046 : PL_parser->in_my == KEY_state ? "state" : "my"));
2048 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
2049 PL_parser->in_my = FALSE;
2050 PL_parser->in_my_stash = NULL;
2051 apply_attrs(GvSTASH(gv),
2052 (type == OP_RV2SV ? GvSV(gv) :
2053 type == OP_RV2AV ? (SV*)GvAV(gv) :
2054 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
2057 o->op_private |= OPpOUR_INTRO;
2060 else if (type != OP_PADSV &&
2063 type != OP_PUSHMARK)
2065 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2067 PL_parser->in_my == KEY_our
2069 : PL_parser->in_my == KEY_state ? "state" : "my"));
2072 else if (attrs && type != OP_PUSHMARK) {
2075 PL_parser->in_my = FALSE;
2076 PL_parser->in_my_stash = NULL;
2078 /* check for C<my Dog $spot> when deciding package */
2079 stash = PAD_COMPNAME_TYPE(o->op_targ);
2081 stash = PL_curstash;
2082 apply_attrs_my(stash, o, attrs, imopsp);
2084 o->op_flags |= OPf_MOD;
2085 o->op_private |= OPpLVAL_INTRO;
2086 if (PL_parser->in_my == KEY_state)
2087 o->op_private |= OPpPAD_STATE;
2092 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2096 int maybe_scalar = 0;
2098 PERL_ARGS_ASSERT_MY_ATTRS;
2100 /* [perl #17376]: this appears to be premature, and results in code such as
2101 C< our(%x); > executing in list mode rather than void mode */
2103 if (o->op_flags & OPf_PARENS)
2113 o = my_kid(o, attrs, &rops);
2115 if (maybe_scalar && o->op_type == OP_PADSV) {
2116 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
2117 o->op_private |= OPpLVAL_INTRO;
2120 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
2122 PL_parser->in_my = FALSE;
2123 PL_parser->in_my_stash = NULL;
2128 Perl_my(pTHX_ OP *o)
2130 PERL_ARGS_ASSERT_MY;
2132 return my_attrs(o, NULL);
2136 Perl_sawparens(pTHX_ OP *o)
2138 PERL_UNUSED_CONTEXT;
2140 o->op_flags |= OPf_PARENS;
2145 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2149 const OPCODE ltype = left->op_type;
2150 const OPCODE rtype = right->op_type;
2152 PERL_ARGS_ASSERT_BIND_MATCH;
2154 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2155 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
2157 const char * const desc
2158 = PL_op_desc[(rtype == OP_SUBST || rtype == OP_TRANS)
2159 ? (int)rtype : OP_MATCH];
2160 const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV)
2161 ? "@array" : "%hash");
2162 Perl_warner(aTHX_ packWARN(WARN_MISC),
2163 "Applying %s to %s will act on scalar(%s)",
2164 desc, sample, sample);
2167 if (rtype == OP_CONST &&
2168 cSVOPx(right)->op_private & OPpCONST_BARE &&
2169 cSVOPx(right)->op_private & OPpCONST_STRICT)
2171 no_bareword_allowed(right);
2174 ismatchop = rtype == OP_MATCH ||
2175 rtype == OP_SUBST ||
2177 if (ismatchop && right->op_private & OPpTARGET_MY) {
2179 right->op_private &= ~OPpTARGET_MY;
2181 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
2184 right->op_flags |= OPf_STACKED;
2185 if (rtype != OP_MATCH &&
2186 ! (rtype == OP_TRANS &&
2187 right->op_private & OPpTRANS_IDENTICAL))
2188 newleft = mod(left, rtype);
2191 if (right->op_type == OP_TRANS)
2192 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
2194 o = prepend_elem(rtype, scalar(newleft), right);
2196 return newUNOP(OP_NOT, 0, scalar(o));
2200 return bind_match(type, left,
2201 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
2205 Perl_invert(pTHX_ OP *o)
2209 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2213 Perl_scope(pTHX_ OP *o)
2217 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2218 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2219 o->op_type = OP_LEAVE;
2220 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2222 else if (o->op_type == OP_LINESEQ) {
2224 o->op_type = OP_SCOPE;
2225 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2226 kid = ((LISTOP*)o)->op_first;
2227 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2230 /* The following deals with things like 'do {1 for 1}' */
2231 kid = kid->op_sibling;
2233 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2238 o = newLISTOP(OP_SCOPE, 0, o, NULL);
2244 Perl_block_start(pTHX_ int full)
2247 const int retval = PL_savestack_ix;
2248 pad_block_start(full);
2250 PL_hints &= ~HINT_BLOCK_SCOPE;
2251 SAVECOMPILEWARNINGS();
2252 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
2257 Perl_block_end(pTHX_ I32 floor, OP *seq)
2260 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2261 OP* const retval = scalarseq(seq);
2263 CopHINTS_set(&PL_compiling, PL_hints);
2265 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2274 const PADOFFSET offset = pad_findmy("$_");
2275 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
2276 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2279 OP * const o = newOP(OP_PADSV, 0);
2280 o->op_targ = offset;
2286 Perl_newPROG(pTHX_ OP *o)
2290 PERL_ARGS_ASSERT_NEWPROG;
2295 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2296 ((PL_in_eval & EVAL_KEEPERR)
2297 ? OPf_SPECIAL : 0), o);
2298 PL_eval_start = linklist(PL_eval_root);
2299 PL_eval_root->op_private |= OPpREFCOUNTED;
2300 OpREFCNT_set(PL_eval_root, 1);
2301 PL_eval_root->op_next = 0;
2302 CALL_PEEP(PL_eval_start);
2305 if (o->op_type == OP_STUB) {
2306 PL_comppad_name = 0;
2308 S_op_destroy(aTHX_ o);
2311 PL_main_root = scope(sawparens(scalarvoid(o)));
2312 PL_curcop = &PL_compiling;
2313 PL_main_start = LINKLIST(PL_main_root);
2314 PL_main_root->op_private |= OPpREFCOUNTED;
2315 OpREFCNT_set(PL_main_root, 1);
2316 PL_main_root->op_next = 0;
2317 CALL_PEEP(PL_main_start);
2320 /* Register with debugger */
2323 = Perl_get_cvn_flags(aTHX_ STR_WITH_LEN("DB::postponed"), 0);
2327 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2329 call_sv((SV*)cv, G_DISCARD);
2336 Perl_localize(pTHX_ OP *o, I32 lex)
2340 PERL_ARGS_ASSERT_LOCALIZE;
2342 if (o->op_flags & OPf_PARENS)
2343 /* [perl #17376]: this appears to be premature, and results in code such as
2344 C< our(%x); > executing in list mode rather than void mode */
2351 if ( PL_parser->bufptr > PL_parser->oldbufptr
2352 && PL_parser->bufptr[-1] == ','
2353 && ckWARN(WARN_PARENTHESIS))
2355 char *s = PL_parser->bufptr;
2358 /* some heuristics to detect a potential error */
2359 while (*s && (strchr(", \t\n", *s)))
2363 if (*s && strchr("@$%*", *s) && *++s
2364 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2367 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2369 while (*s && (strchr(", \t\n", *s)))
2375 if (sigil && (*s == ';' || *s == '=')) {
2376 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2377 "Parentheses missing around \"%s\" list",
2379 ? (PL_parser->in_my == KEY_our
2381 : PL_parser->in_my == KEY_state
2391 o = mod(o, OP_NULL); /* a bit kludgey */
2392 PL_parser->in_my = FALSE;
2393 PL_parser->in_my_stash = NULL;
2398 Perl_jmaybe(pTHX_ OP *o)
2400 PERL_ARGS_ASSERT_JMAYBE;
2402 if (o->op_type == OP_LIST) {
2404 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2405 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2411 Perl_fold_constants(pTHX_ register OP *o)
2414 register OP * VOL curop;
2416 VOL I32 type = o->op_type;
2421 SV * const oldwarnhook = PL_warnhook;
2422 SV * const olddiehook = PL_diehook;
2425 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
2427 if (PL_opargs[type] & OA_RETSCALAR)
2429 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2430 o->op_targ = pad_alloc(type, SVs_PADTMP);
2432 /* integerize op, unless it happens to be C<-foo>.
2433 * XXX should pp_i_negate() do magic string negation instead? */
2434 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2435 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2436 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2438 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2441 if (!(PL_opargs[type] & OA_FOLDCONST))
2446 /* XXX might want a ck_negate() for this */
2447 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2458 /* XXX what about the numeric ops? */
2459 if (PL_hints & HINT_LOCALE)
2463 if (PL_parser && PL_parser->error_count)
2464 goto nope; /* Don't try to run w/ errors */
2466 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2467 const OPCODE type = curop->op_type;
2468 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2470 type != OP_SCALAR &&
2472 type != OP_PUSHMARK)
2478 curop = LINKLIST(o);
2479 old_next = o->op_next;
2483 oldscope = PL_scopestack_ix;
2484 create_eval_scope(G_FAKINGEVAL);
2486 PL_warnhook = PERL_WARNHOOK_FATAL;
2493 sv = *(PL_stack_sp--);
2494 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2495 pad_swipe(o->op_targ, FALSE);
2496 else if (SvTEMP(sv)) { /* grab mortal temp? */
2497 SvREFCNT_inc_simple_void(sv);
2502 /* Something tried to die. Abandon constant folding. */
2503 /* Pretend the error never happened. */
2504 sv_setpvn(ERRSV,"",0);
2505 o->op_next = old_next;
2509 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
2510 PL_warnhook = oldwarnhook;
2511 PL_diehook = olddiehook;
2512 /* XXX note that this croak may fail as we've already blown away
2513 * the stack - eg any nested evals */
2514 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
2517 PL_warnhook = oldwarnhook;
2518 PL_diehook = olddiehook;
2520 if (PL_scopestack_ix > oldscope)
2521 delete_eval_scope();
2530 if (type == OP_RV2GV)
2531 newop = newGVOP(OP_GV, 0, (GV*)sv);
2533 newop = newSVOP(OP_CONST, 0, (SV*)sv);
2534 op_getmad(o,newop,'f');
2542 Perl_gen_constant_list(pTHX_ register OP *o)
2546 const I32 oldtmps_floor = PL_tmps_floor;
2549 if (PL_parser && PL_parser->error_count)
2550 return o; /* Don't attempt to run with errors */
2552 PL_op = curop = LINKLIST(o);
2558 assert (!(curop->op_flags & OPf_SPECIAL));
2559 assert(curop->op_type == OP_RANGE);
2561 PL_tmps_floor = oldtmps_floor;
2563 o->op_type = OP_RV2AV;
2564 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2565 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2566 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2567 o->op_opt = 0; /* needs to be revisited in peep() */
2568 curop = ((UNOP*)o)->op_first;
2569 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
2571 op_getmad(curop,o,'O');
2580 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2583 if (!o || o->op_type != OP_LIST)
2584 o = newLISTOP(OP_LIST, 0, o, NULL);
2586 o->op_flags &= ~OPf_WANT;
2588 if (!(PL_opargs[type] & OA_MARK))
2589 op_null(cLISTOPo->op_first);
2591 o->op_type = (OPCODE)type;
2592 o->op_ppaddr = PL_ppaddr[type];
2593 o->op_flags |= flags;
2595 o = CHECKOP(type, o);
2596 if (o->op_type != (unsigned)type)
2599 return fold_constants(o);
2602 /* List constructors */
2605 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2613 if (first->op_type != (unsigned)type
2614 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2616 return newLISTOP(type, 0, first, last);
2619 if (first->op_flags & OPf_KIDS)
2620 ((LISTOP*)first)->op_last->op_sibling = last;
2622 first->op_flags |= OPf_KIDS;
2623 ((LISTOP*)first)->op_first = last;
2625 ((LISTOP*)first)->op_last = last;
2630 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2638 if (first->op_type != (unsigned)type)
2639 return prepend_elem(type, (OP*)first, (OP*)last);
2641 if (last->op_type != (unsigned)type)
2642 return append_elem(type, (OP*)first, (OP*)last);
2644 first->op_last->op_sibling = last->op_first;
2645 first->op_last = last->op_last;
2646 first->op_flags |= (last->op_flags & OPf_KIDS);
2649 if (last->op_first && first->op_madprop) {
2650 MADPROP *mp = last->op_first->op_madprop;
2652 while (mp->mad_next)
2654 mp->mad_next = first->op_madprop;
2657 last->op_first->op_madprop = first->op_madprop;
2660 first->op_madprop = last->op_madprop;
2661 last->op_madprop = 0;
2664 S_op_destroy(aTHX_ (OP*)last);
2670 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2678 if (last->op_type == (unsigned)type) {
2679 if (type == OP_LIST) { /* already a PUSHMARK there */
2680 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2681 ((LISTOP*)last)->op_first->op_sibling = first;
2682 if (!(first->op_flags & OPf_PARENS))
2683 last->op_flags &= ~OPf_PARENS;
2686 if (!(last->op_flags & OPf_KIDS)) {
2687 ((LISTOP*)last)->op_last = first;
2688 last->op_flags |= OPf_KIDS;
2690 first->op_sibling = ((LISTOP*)last)->op_first;
2691 ((LISTOP*)last)->op_first = first;
2693 last->op_flags |= OPf_KIDS;
2697 return newLISTOP(type, 0, first, last);
2705 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2708 Newxz(tk, 1, TOKEN);
2709 tk->tk_type = (OPCODE)optype;
2710 tk->tk_type = 12345;
2712 tk->tk_mad = madprop;
2717 Perl_token_free(pTHX_ TOKEN* tk)
2719 PERL_ARGS_ASSERT_TOKEN_FREE;
2721 if (tk->tk_type != 12345)
2723 mad_free(tk->tk_mad);
2728 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2733 PERL_ARGS_ASSERT_TOKEN_GETMAD;
2735 if (tk->tk_type != 12345) {
2736 Perl_warner(aTHX_ packWARN(WARN_MISC),
2737 "Invalid TOKEN object ignored");
2744 /* faked up qw list? */
2746 tm->mad_type == MAD_SV &&
2747 SvPVX((SV*)tm->mad_val)[0] == 'q')
2754 /* pretend constant fold didn't happen? */
2755 if (mp->mad_key == 'f' &&
2756 (o->op_type == OP_CONST ||
2757 o->op_type == OP_GV) )
2759 token_getmad(tk,(OP*)mp->mad_val,slot);
2773 if (mp->mad_key == 'X')
2774 mp->mad_key = slot; /* just change the first one */
2784 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
2793 /* pretend constant fold didn't happen? */
2794 if (mp->mad_key == 'f' &&
2795 (o->op_type == OP_CONST ||
2796 o->op_type == OP_GV) )
2798 op_getmad(from,(OP*)mp->mad_val,slot);
2805 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
2808 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
2814 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
2823 /* pretend constant fold didn't happen? */
2824 if (mp->mad_key == 'f' &&
2825 (o->op_type == OP_CONST ||
2826 o->op_type == OP_GV) )
2828 op_getmad(from,(OP*)mp->mad_val,slot);
2835 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
2838 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
2842 PerlIO_printf(PerlIO_stderr(),
2843 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
2849 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
2867 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
2871 addmad(tm, &(o->op_madprop), slot);
2875 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
2896 Perl_newMADsv(pTHX_ char key, SV* sv)
2898 PERL_ARGS_ASSERT_NEWMADSV;
2900 return newMADPROP(key, MAD_SV, sv, 0);
2904 Perl_newMADPROP(pTHX_ char key, char type, const void* val, I32 vlen)
2907 Newxz(mp, 1, MADPROP);
2910 mp->mad_vlen = vlen;
2911 mp->mad_type = type;
2913 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
2918 Perl_mad_free(pTHX_ MADPROP* mp)
2920 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
2924 mad_free(mp->mad_next);
2925 /* if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
2926 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
2927 switch (mp->mad_type) {
2931 Safefree((char*)mp->mad_val);
2934 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
2935 op_free((OP*)mp->mad_val);
2938 sv_free((SV*)mp->mad_val);
2941 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
2950 Perl_newNULLLIST(pTHX)
2952 return newOP(OP_STUB, 0);
2956 Perl_force_list(pTHX_ OP *o)
2958 if (!o || o->op_type != OP_LIST)
2959 o = newLISTOP(OP_LIST, 0, o, NULL);
2965 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2970 NewOp(1101, listop, 1, LISTOP);
2972 listop->op_type = (OPCODE)type;
2973 listop->op_ppaddr = PL_ppaddr[type];
2976 listop->op_flags = (U8)flags;
2980 else if (!first && last)
2983 first->op_sibling = last;
2984 listop->op_first = first;
2985 listop->op_last = last;
2986 if (type == OP_LIST) {
2987 OP* const pushop = newOP(OP_PUSHMARK, 0);
2988 pushop->op_sibling = first;
2989 listop->op_first = pushop;
2990 listop->op_flags |= OPf_KIDS;
2992 listop->op_last = pushop;
2995 return CHECKOP(type, listop);
2999 Perl_newOP(pTHX_ I32 type, I32 flags)
3003 NewOp(1101, o, 1, OP);
3004 o->op_type = (OPCODE)type;
3005 o->op_ppaddr = PL_ppaddr[type];
3006 o->op_flags = (U8)flags;
3008 o->op_latefreed = 0;
3012 o->op_private = (U8)(0 | (flags >> 8));
3013 if (PL_opargs[type] & OA_RETSCALAR)
3015 if (PL_opargs[type] & OA_TARGET)
3016 o->op_targ = pad_alloc(type, SVs_PADTMP);
3017 return CHECKOP(type, o);
3021 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
3027 first = newOP(OP_STUB, 0);
3028 if (PL_opargs[type] & OA_MARK)
3029 first = force_list(first);
3031 NewOp(1101, unop, 1, UNOP);
3032 unop->op_type = (OPCODE)type;
3033 unop->op_ppaddr = PL_ppaddr[type];
3034 unop->op_first = first;
3035 unop->op_flags = (U8)(flags | OPf_KIDS);
3036 unop->op_private = (U8)(1 | (flags >> 8));
3037 unop = (UNOP*) CHECKOP(type, unop);
3041 return fold_constants((OP *) unop);
3045 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3049 NewOp(1101, binop, 1, BINOP);
3052 first = newOP(OP_NULL, 0);
3054 binop->op_type = (OPCODE)type;
3055 binop->op_ppaddr = PL_ppaddr[type];
3056 binop->op_first = first;
3057 binop->op_flags = (U8)(flags | OPf_KIDS);
3060 binop->op_private = (U8)(1 | (flags >> 8));
3063 binop->op_private = (U8)(2 | (flags >> 8));
3064 first->op_sibling = last;
3067 binop = (BINOP*)CHECKOP(type, binop);
3068 if (binop->op_next || binop->op_type != (OPCODE)type)
3071 binop->op_last = binop->op_first->op_sibling;
3073 return fold_constants((OP *)binop);
3076 static int uvcompare(const void *a, const void *b)
3077 __attribute__nonnull__(1)
3078 __attribute__nonnull__(2)
3079 __attribute__pure__;
3080 static int uvcompare(const void *a, const void *b)
3082 if (*((const UV *)a) < (*(const UV *)b))
3084 if (*((const UV *)a) > (*(const UV *)b))
3086 if (*((const UV *)a+1) < (*(const UV *)b+1))
3088 if (*((const UV *)a+1) > (*(const UV *)b+1))
3094 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
3097 SV * const tstr = ((SVOP*)expr)->op_sv;
3100 (repl->op_type == OP_NULL)
3101 ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
3103 ((SVOP*)repl)->op_sv;
3106 const U8 *t = (U8*)SvPV_const(tstr, tlen);
3107 const U8 *r = (U8*)SvPV_const(rstr, rlen);
3111 register short *tbl;
3113 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
3114 const I32 squash = o->op_private & OPpTRANS_SQUASH;
3115 I32 del = o->op_private & OPpTRANS_DELETE;
3118 PERL_ARGS_ASSERT_PMTRANS;
3120 PL_hints |= HINT_BLOCK_SCOPE;
3123 o->op_private |= OPpTRANS_FROM_UTF;
3126 o->op_private |= OPpTRANS_TO_UTF;
3128 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
3129 SV* const listsv = newSVpvs("# comment\n");
3131 const U8* tend = t + tlen;
3132 const U8* rend = r + rlen;
3146 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
3147 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
3150 const U32 flags = UTF8_ALLOW_DEFAULT;
3154 t = tsave = bytes_to_utf8(t, &len);
3157 if (!to_utf && rlen) {
3159 r = rsave = bytes_to_utf8(r, &len);
3163 /* There are several snags with this code on EBCDIC:
3164 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
3165 2. scan_const() in toke.c has encoded chars in native encoding which makes
3166 ranges at least in EBCDIC 0..255 range the bottom odd.
3170 U8 tmpbuf[UTF8_MAXBYTES+1];
3173 Newx(cp, 2*tlen, UV);
3175 transv = newSVpvs("");
3177 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3179 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
3181 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3185 cp[2*i+1] = cp[2*i];
3189 qsort(cp, i, 2*sizeof(UV), uvcompare);
3190 for (j = 0; j < i; j++) {
3192 diff = val - nextmin;
3194 t = uvuni_to_utf8(tmpbuf,nextmin);
3195 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3197 U8 range_mark = UTF_TO_NATIVE(0xff);
3198 t = uvuni_to_utf8(tmpbuf, val - 1);
3199 sv_catpvn(transv, (char *)&range_mark, 1);
3200 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3207 t = uvuni_to_utf8(tmpbuf,nextmin);
3208 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3210 U8 range_mark = UTF_TO_NATIVE(0xff);
3211 sv_catpvn(transv, (char *)&range_mark, 1);
3213 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
3214 UNICODE_ALLOW_SUPER);
3215 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3216 t = (const U8*)SvPVX_const(transv);
3217 tlen = SvCUR(transv);
3221 else if (!rlen && !del) {
3222 r = t; rlen = tlen; rend = tend;
3225 if ((!rlen && !del) || t == r ||
3226 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
3228 o->op_private |= OPpTRANS_IDENTICAL;
3232 while (t < tend || tfirst <= tlast) {
3233 /* see if we need more "t" chars */
3234 if (tfirst > tlast) {
3235 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3237 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
3239 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3246 /* now see if we need more "r" chars */
3247 if (rfirst > rlast) {
3249 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3251 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
3253 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3262 rfirst = rlast = 0xffffffff;
3266 /* now see which range will peter our first, if either. */
3267 tdiff = tlast - tfirst;
3268 rdiff = rlast - rfirst;
3275 if (rfirst == 0xffffffff) {
3276 diff = tdiff; /* oops, pretend rdiff is infinite */
3278 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
3279 (long)tfirst, (long)tlast);
3281 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
3285 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
3286 (long)tfirst, (long)(tfirst + diff),
3289 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3290 (long)tfirst, (long)rfirst);
3292 if (rfirst + diff > max)
3293 max = rfirst + diff;
3295 grows = (tfirst < rfirst &&
3296 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3308 else if (max > 0xff)
3313 PerlMemShared_free(cPVOPo->op_pv);
3314 cPVOPo->op_pv = NULL;
3316 swash = (SV*)swash_init("utf8", "", listsv, bits, none);
3318 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
3319 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
3320 PAD_SETSV(cPADOPo->op_padix, swash);
3323 cSVOPo->op_sv = swash;
3325 SvREFCNT_dec(listsv);
3326 SvREFCNT_dec(transv);
3328 if (!del && havefinal && rlen)
3329 (void)hv_store((HV*)SvRV(swash), "FINAL", 5,
3330 newSVuv((UV)final), 0);
3333 o->op_private |= OPpTRANS_GROWS;
3339 op_getmad(expr,o,'e');
3340 op_getmad(repl,o,'r');
3348 tbl = (short*)cPVOPo->op_pv;
3350 Zero(tbl, 256, short);
3351 for (i = 0; i < (I32)tlen; i++)
3353 for (i = 0, j = 0; i < 256; i++) {
3355 if (j >= (I32)rlen) {
3364 if (i < 128 && r[j] >= 128)
3374 o->op_private |= OPpTRANS_IDENTICAL;
3376 else if (j >= (I32)rlen)
3381 PerlMemShared_realloc(tbl,
3382 (0x101+rlen-j) * sizeof(short));
3383 cPVOPo->op_pv = (char*)tbl;
3385 tbl[0x100] = (short)(rlen - j);
3386 for (i=0; i < (I32)rlen - j; i++)
3387 tbl[0x101+i] = r[j+i];
3391 if (!rlen && !del) {
3394 o->op_private |= OPpTRANS_IDENTICAL;
3396 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3397 o->op_private |= OPpTRANS_IDENTICAL;
3399 for (i = 0; i < 256; i++)
3401 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3402 if (j >= (I32)rlen) {
3404 if (tbl[t[i]] == -1)
3410 if (tbl[t[i]] == -1) {
3411 if (t[i] < 128 && r[j] >= 128)
3418 o->op_private |= OPpTRANS_GROWS;
3420 op_getmad(expr,o,'e');
3421 op_getmad(repl,o,'r');
3431 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3436 NewOp(1101, pmop, 1, PMOP);
3437 pmop->op_type = (OPCODE)type;
3438 pmop->op_ppaddr = PL_ppaddr[type];
3439 pmop->op_flags = (U8)flags;
3440 pmop->op_private = (U8)(0 | (flags >> 8));
3442 if (PL_hints & HINT_RE_TAINT)
3443 pmop->op_pmflags |= PMf_RETAINT;
3444 if (PL_hints & HINT_LOCALE)
3445 pmop->op_pmflags |= PMf_LOCALE;
3449 assert(SvPOK(PL_regex_pad[0]));
3450 if (SvCUR(PL_regex_pad[0])) {
3451 /* Pop off the "packed" IV from the end. */
3452 SV *const repointer_list = PL_regex_pad[0];
3453 const char *p = SvEND(repointer_list) - sizeof(IV);
3454 const IV offset = *((IV*)p);
3456 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
3458 SvEND_set(repointer_list, p);
3460 pmop->op_pmoffset = offset;
3461 /* This slot should be free, so assert this: */
3462 assert(PL_regex_pad[offset] == &PL_sv_undef);
3464 SV * const repointer = &PL_sv_undef;
3465 av_push(PL_regex_padav, repointer);
3466 pmop->op_pmoffset = av_len(PL_regex_padav);
3467 PL_regex_pad = AvARRAY(PL_regex_padav);
3471 return CHECKOP(type, pmop);
3474 /* Given some sort of match op o, and an expression expr containing a
3475 * pattern, either compile expr into a regex and attach it to o (if it's
3476 * constant), or convert expr into a runtime regcomp op sequence (if it's
3479 * isreg indicates that the pattern is part of a regex construct, eg
3480 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3481 * split "pattern", which aren't. In the former case, expr will be a list
3482 * if the pattern contains more than one term (eg /a$b/) or if it contains
3483 * a replacement, ie s/// or tr///.
3487 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
3492 I32 repl_has_vars = 0;
3496 PERL_ARGS_ASSERT_PMRUNTIME;
3498 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
3499 /* last element in list is the replacement; pop it */
3501 repl = cLISTOPx(expr)->op_last;
3502 kid = cLISTOPx(expr)->op_first;
3503 while (kid->op_sibling != repl)
3504 kid = kid->op_sibling;
3505 kid->op_sibling = NULL;
3506 cLISTOPx(expr)->op_last = kid;
3509 if (isreg && expr->op_type == OP_LIST &&
3510 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3512 /* convert single element list to element */
3513 OP* const oe = expr;
3514 expr = cLISTOPx(oe)->op_first->op_sibling;
3515 cLISTOPx(oe)->op_first->op_sibling = NULL;
3516 cLISTOPx(oe)->op_last = NULL;
3520 if (o->op_type == OP_TRANS) {
3521 return pmtrans(o, expr, repl);
3524 reglist = isreg && expr->op_type == OP_LIST;
3528 PL_hints |= HINT_BLOCK_SCOPE;
3531 if (expr->op_type == OP_CONST) {
3532 SV *pat = ((SVOP*)expr)->op_sv;
3533 U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
3535 if (o->op_flags & OPf_SPECIAL)
3536 pm_flags |= RXf_SPLIT;
3539 assert (SvUTF8(pat));
3540 } else if (SvUTF8(pat)) {
3541 /* Not doing UTF-8, despite what the SV says. Is this only if we're
3542 trapped in use 'bytes'? */
3543 /* Make a copy of the octet sequence, but without the flag on, as
3544 the compiler now honours the SvUTF8 flag on pat. */
3546 const char *const p = SvPV(pat, len);
3547 pat = newSVpvn_flags(p, len, SVs_TEMP);
3550 PM_SETRE(pm, CALLREGCOMP(pat, pm_flags));
3553 op_getmad(expr,(OP*)pm,'e');
3559 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3560 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3562 : OP_REGCMAYBE),0,expr);
3564 NewOp(1101, rcop, 1, LOGOP);
3565 rcop->op_type = OP_REGCOMP;
3566 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3567 rcop->op_first = scalar(expr);
3568 rcop->op_flags |= OPf_KIDS
3569 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3570 | (reglist ? OPf_STACKED : 0);
3571 rcop->op_private = 1;
3574 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3576 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
3579 /* establish postfix order */
3580 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3582 rcop->op_next = expr;
3583 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3586 rcop->op_next = LINKLIST(expr);
3587 expr->op_next = (OP*)rcop;
3590 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3595 if (pm->op_pmflags & PMf_EVAL) {
3597 if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
3598 CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
3600 else if (repl->op_type == OP_CONST)
3604 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3605 if (curop->op_type == OP_SCOPE
3606 || curop->op_type == OP_LEAVE
3607 || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
3608 if (curop->op_type == OP_GV) {
3609 GV * const gv = cGVOPx_gv(curop);
3611 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3614 else if (curop->op_type == OP_RV2CV)
3616 else if (curop->op_type == OP_RV2SV ||
3617 curop->op_type == OP_RV2AV ||
3618 curop->op_type == OP_RV2HV ||
3619 curop->op_type == OP_RV2GV) {
3620 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3623 else if (curop->op_type == OP_PADSV ||
3624 curop->op_type == OP_PADAV ||
3625 curop->op_type == OP_PADHV ||
3626 curop->op_type == OP_PADANY)
3630 else if (curop->op_type == OP_PUSHRE)
3631 NOOP; /* Okay here, dangerous in newASSIGNOP */
3641 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
3643 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3644 prepend_elem(o->op_type, scalar(repl), o);
3647 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3648 pm->op_pmflags |= PMf_MAYBE_CONST;
3650 NewOp(1101, rcop, 1, LOGOP);
3651 rcop->op_type = OP_SUBSTCONT;
3652 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3653 rcop->op_first = scalar(repl);
3654 rcop->op_flags |= OPf_KIDS;
3655 rcop->op_private = 1;
3658 /* establish postfix order */
3659 rcop->op_next = LINKLIST(repl);
3660 repl->op_next = (OP*)rcop;
3662 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
3663 assert(!(pm->op_pmflags & PMf_ONCE));
3664 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
3673 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3678 PERL_ARGS_ASSERT_NEWSVOP;
3680 NewOp(1101, svop, 1, SVOP);
3681 svop->op_type = (OPCODE)type;
3682 svop->op_ppaddr = PL_ppaddr[type];
3684 svop->op_next = (OP*)svop;
3685 svop->op_flags = (U8)flags;
3686 if (PL_opargs[type] & OA_RETSCALAR)
3688 if (PL_opargs[type] & OA_TARGET)
3689 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3690 return CHECKOP(type, svop);
3695 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3700 PERL_ARGS_ASSERT_NEWPADOP;
3702 NewOp(1101, padop, 1, PADOP);
3703 padop->op_type = (OPCODE)type;
3704 padop->op_ppaddr = PL_ppaddr[type];
3705 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3706 SvREFCNT_dec(PAD_SVl(padop->op_padix));
3707 PAD_SETSV(padop->op_padix, sv);
3710 padop->op_next = (OP*)padop;
3711 padop->op_flags = (U8)flags;
3712 if (PL_opargs[type] & OA_RETSCALAR)
3714 if (PL_opargs[type] & OA_TARGET)
3715 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3716 return CHECKOP(type, padop);
3721 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3725 PERL_ARGS_ASSERT_NEWGVOP;
3729 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3731 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3736 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3740 NewOp(1101, pvop, 1, PVOP);
3741 pvop->op_type = (OPCODE)type;
3742 pvop->op_ppaddr = PL_ppaddr[type];
3744 pvop->op_next = (OP*)pvop;
3745 pvop->op_flags = (U8)flags;
3746 if (PL_opargs[type] & OA_RETSCALAR)
3748 if (PL_opargs[type] & OA_TARGET)
3749 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3750 return CHECKOP(type, pvop);
3758 Perl_package(pTHX_ OP *o)
3761 SV *const sv = cSVOPo->op_sv;
3766 PERL_ARGS_ASSERT_PACKAGE;
3768 save_hptr(&PL_curstash);
3769 save_item(PL_curstname);
3771 PL_curstash = gv_stashsv(sv, GV_ADD);
3773 sv_setsv(PL_curstname, sv);
3775 PL_hints |= HINT_BLOCK_SCOPE;
3776 PL_parser->copline = NOLINE;
3777 PL_parser->expect = XSTATE;
3782 if (!PL_madskills) {
3787 pegop = newOP(OP_NULL,0);
3788 op_getmad(o,pegop,'P');
3798 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3805 OP *pegop = newOP(OP_NULL,0);
3808 PERL_ARGS_ASSERT_UTILIZE;
3810 if (idop->op_type != OP_CONST)
3811 Perl_croak(aTHX_ "Module name must be constant");
3814 op_getmad(idop,pegop,'U');
3819 SV * const vesv = ((SVOP*)version)->op_sv;
3822 op_getmad(version,pegop,'V');
3823 if (!arg && !SvNIOKp(vesv)) {
3830 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3831 Perl_croak(aTHX_ "Version number must be constant number");
3833 /* Make copy of idop so we don't free it twice */
3834 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3836 /* Fake up a method call to VERSION */
3837 meth = newSVpvs_share("VERSION");
3838 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3839 append_elem(OP_LIST,
3840 prepend_elem(OP_LIST, pack, list(version)),
3841 newSVOP(OP_METHOD_NAMED, 0, meth)));
3845 /* Fake up an import/unimport */
3846 if (arg && arg->op_type == OP_STUB) {
3848 op_getmad(arg,pegop,'S');
3849 imop = arg; /* no import on explicit () */
3851 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3852 imop = NULL; /* use 5.0; */
3854 idop->op_private |= OPpCONST_NOVER;
3860 op_getmad(arg,pegop,'A');
3862 /* Make copy of idop so we don't free it twice */
3863 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3865 /* Fake up a method call to import/unimport */
3867 ? newSVpvs_share("import") : newSVpvs_share("unimport");
3868 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3869 append_elem(OP_LIST,
3870 prepend_elem(OP_LIST, pack, list(arg)),
3871 newSVOP(OP_METHOD_NAMED, 0, meth)));
3874 /* Fake up the BEGIN {}, which does its thing immediately. */
3876 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
3879 append_elem(OP_LINESEQ,
3880 append_elem(OP_LINESEQ,
3881 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
3882 newSTATEOP(0, NULL, veop)),
3883 newSTATEOP(0, NULL, imop) ));
3885 /* The "did you use incorrect case?" warning used to be here.
3886 * The problem is that on case-insensitive filesystems one
3887 * might get false positives for "use" (and "require"):
3888 * "use Strict" or "require CARP" will work. This causes
3889 * portability problems for the script: in case-strict
3890 * filesystems the script will stop working.
3892 * The "incorrect case" warning checked whether "use Foo"
3893 * imported "Foo" to your namespace, but that is wrong, too:
3894 * there is no requirement nor promise in the language that
3895 * a Foo.pm should or would contain anything in package "Foo".
3897 * There is very little Configure-wise that can be done, either:
3898 * the case-sensitivity of the build filesystem of Perl does not
3899 * help in guessing the case-sensitivity of the runtime environment.
3902 PL_hints |= HINT_BLOCK_SCOPE;
3903 PL_parser->copline = NOLINE;
3904 PL_parser->expect = XSTATE;
3905 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3908 if (!PL_madskills) {
3909 /* FIXME - don't allocate pegop if !PL_madskills */
3918 =head1 Embedding Functions
3920 =for apidoc load_module
3922 Loads the module whose name is pointed to by the string part of name.
3923 Note that the actual module name, not its filename, should be given.
3924 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3925 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3926 (or 0 for no flags). ver, if specified, provides version semantics
3927 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3928 arguments can be used to specify arguments to the module's import()
3929 method, similar to C<use Foo::Bar VERSION LIST>.
3934 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3938 PERL_ARGS_ASSERT_LOAD_MODULE;
3940 va_start(args, ver);
3941 vload_module(flags, name, ver, &args);
3945 #ifdef PERL_IMPLICIT_CONTEXT
3947 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3951 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
3952 va_start(args, ver);
3953 vload_module(flags, name, ver, &args);
3959 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3963 OP * const modname = newSVOP(OP_CONST, 0, name);
3965 PERL_ARGS_ASSERT_VLOAD_MODULE;
3967 modname->op_private |= OPpCONST_BARE;
3969 veop = newSVOP(OP_CONST, 0, ver);
3973 if (flags & PERL_LOADMOD_NOIMPORT) {
3974 imop = sawparens(newNULLLIST());
3976 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3977 imop = va_arg(*args, OP*);
3982 sv = va_arg(*args, SV*);
3984 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3985 sv = va_arg(*args, SV*);
3989 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
3990 * that it has a PL_parser to play with while doing that, and also
3991 * that it doesn't mess with any existing parser, by creating a tmp
3992 * new parser with lex_start(). This won't actually be used for much,
3993 * since pp_require() will create another parser for the real work. */
3996 SAVEVPTR(PL_curcop);
3997 lex_start(NULL, NULL, FALSE);
3998 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3999 veop, modname, imop);
4004 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
4010 PERL_ARGS_ASSERT_DOFILE;
4012 if (!force_builtin) {
4013 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
4014 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
4015 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
4016 gv = gvp ? *gvp : NULL;
4020 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
4021 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
4022 append_elem(OP_LIST, term,
4023 scalar(newUNOP(OP_RV2CV, 0,
4024 newGVOP(OP_GV, 0, gv))))));
4027 doop = newUNOP(OP_DOFILE, 0, scalar(term));
4033 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
4035 return newBINOP(OP_LSLICE, flags,
4036 list(force_list(subscript)),
4037 list(force_list(listval)) );
4041 S_is_list_assignment(pTHX_ register const OP *o)
4049 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
4050 o = cUNOPo->op_first;
4052 flags = o->op_flags;
4054 if (type == OP_COND_EXPR) {
4055 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
4056 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
4061 yyerror("Assignment to both a list and a scalar");
4065 if (type == OP_LIST &&
4066 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
4067 o->op_private & OPpLVAL_INTRO)
4070 if (type == OP_LIST || flags & OPf_PARENS ||
4071 type == OP_RV2AV || type == OP_RV2HV ||
4072 type == OP_ASLICE || type == OP_HSLICE)
4075 if (type == OP_PADAV || type == OP_PADHV)
4078 if (type == OP_RV2SV)
4085 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
4091 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
4092 return newLOGOP(optype, 0,
4093 mod(scalar(left), optype),
4094 newUNOP(OP_SASSIGN, 0, scalar(right)));
4097 return newBINOP(optype, OPf_STACKED,
4098 mod(scalar(left), optype), scalar(right));
4102 if (is_list_assignment(left)) {
4103 static const char no_list_state[] = "Initialization of state variables"
4104 " in list context currently forbidden";
4106 bool maybe_common_vars = TRUE;
4109 /* Grandfathering $[ assignment here. Bletch.*/
4110 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
4111 PL_eval_start = (left->op_type == OP_CONST) ? right : NULL;
4112 left = mod(left, OP_AASSIGN);
4115 else if (left->op_type == OP_CONST) {
4117 /* Result of assignment is always 1 (or we'd be dead already) */
4118 return newSVOP(OP_CONST, 0, newSViv(1));
4120 curop = list(force_list(left));
4121 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
4122 o->op_private = (U8)(0 | (flags >> 8));
4124 if ((left->op_type == OP_LIST
4125 || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
4127 OP* lop = ((LISTOP*)left)->op_first;
4128 maybe_common_vars = FALSE;
4130 if (lop->op_type == OP_PADSV ||
4131 lop->op_type == OP_PADAV ||
4132 lop->op_type == OP_PADHV ||
4133 lop->op_type == OP_PADANY) {
4134 if (!(lop->op_private & OPpLVAL_INTRO))
4135 maybe_common_vars = TRUE;
4137 if (lop->op_private & OPpPAD_STATE) {
4138 if (left->op_private & OPpLVAL_INTRO) {
4139 /* Each variable in state($a, $b, $c) = ... */
4142 /* Each state variable in
4143 (state $a, my $b, our $c, $d, undef) = ... */
4145 yyerror(no_list_state);
4147 /* Each my variable in
4148 (state $a, my $b, our $c, $d, undef) = ... */
4150 } else if (lop->op_type == OP_UNDEF ||
4151 lop->op_type == OP_PUSHMARK) {
4152 /* undef may be interesting in
4153 (state $a, undef, state $c) */
4155 /* Other ops in the list. */
4156 maybe_common_vars = TRUE;
4158 lop = lop->op_sibling;
4161 else if ((left->op_private & OPpLVAL_INTRO)
4162 && ( left->op_type == OP_PADSV
4163 || left->op_type == OP_PADAV
4164 || left->op_type == OP_PADHV
4165 || left->op_type == OP_PADANY))
4167 maybe_common_vars = FALSE;
4168 if (left->op_private & OPpPAD_STATE) {
4169 /* All single variable list context state assignments, hence
4179 yyerror(no_list_state);
4183 /* PL_generation sorcery:
4184 * an assignment like ($a,$b) = ($c,$d) is easier than
4185 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
4186 * To detect whether there are common vars, the global var
4187 * PL_generation is incremented for each assign op we compile.
4188 * Then, while compiling the assign op, we run through all the
4189 * variables on both sides of the assignment, setting a spare slot
4190 * in each of them to PL_generation. If any of them already have
4191 * that value, we know we've got commonality. We could use a
4192 * single bit marker, but then we'd have to make 2 passes, first
4193 * to clear the flag, then to test and set it. To find somewhere
4194 * to store these values, evil chicanery is done with SvUVX().
4197 if (maybe_common_vars) {
4200 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4201 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
4202 if (curop->op_type == OP_GV) {
4203 GV *gv = cGVOPx_gv(curop);
4205 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4207 GvASSIGN_GENERATION_set(gv, PL_generation);
4209 else if (curop->op_type == OP_PADSV ||
4210 curop->op_type == OP_PADAV ||
4211 curop->op_type == OP_PADHV ||
4212 curop->op_type == OP_PADANY)
4214 if (PAD_COMPNAME_GEN(curop->op_targ)
4215 == (STRLEN)PL_generation)
4217 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
4220 else if (curop->op_type == OP_RV2CV)
4222 else if (curop->op_type == OP_RV2SV ||
4223 curop->op_type == OP_RV2AV ||
4224 curop->op_type == OP_RV2HV ||
4225 curop->op_type == OP_RV2GV) {
4226 if (lastop->op_type != OP_GV) /* funny deref? */
4229 else if (curop->op_type == OP_PUSHRE) {
4231 if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
4232 GV *const gv = (GV*)PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff);
4234 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4236 GvASSIGN_GENERATION_set(gv, PL_generation);
4240 = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
4243 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4245 GvASSIGN_GENERATION_set(gv, PL_generation);
4255 o->op_private |= OPpASSIGN_COMMON;
4258 if (right && right->op_type == OP_SPLIT && !PL_madskills) {
4259 OP* tmpop = ((LISTOP*)right)->op_first;
4260 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
4261 PMOP * const pm = (PMOP*)tmpop;
4262 if (left->op_type == OP_RV2AV &&
4263 !(left->op_private & OPpLVAL_INTRO) &&
4264 !(o->op_private & OPpASSIGN_COMMON) )
4266 tmpop = ((UNOP*)left)->op_first;
4267 if (tmpop->op_type == OP_GV
4269 && !pm->op_pmreplrootu.op_pmtargetoff
4271 && !pm->op_pmreplrootu.op_pmtargetgv
4275 pm->op_pmreplrootu.op_pmtargetoff
4276 = cPADOPx(tmpop)->op_padix;
4277 cPADOPx(tmpop)->op_padix = 0; /* steal it */
4279 pm->op_pmreplrootu.op_pmtargetgv
4280 = (GV*)cSVOPx(tmpop)->op_sv;
4281 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
4283 pm->op_pmflags |= PMf_ONCE;
4284 tmpop = cUNOPo->op_first; /* to list (nulled) */
4285 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
4286 tmpop->op_sibling = NULL; /* don't free split */
4287 right->op_next = tmpop->op_next; /* fix starting loc */
4288 op_free(o); /* blow off assign */
4289 right->op_flags &= ~OPf_WANT;
4290 /* "I don't know and I don't care." */
4295 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
4296 ((LISTOP*)right)->op_last->op_type == OP_CONST)
4298 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
4300 sv_setiv(sv, PL_modcount+1);
4308 right = newOP(OP_UNDEF, 0);
4309 if (right->op_type == OP_READLINE) {
4310 right->op_flags |= OPf_STACKED;
4311 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
4314 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
4315 o = newBINOP(OP_SASSIGN, flags,
4316 scalar(right), mod(scalar(left), OP_SASSIGN) );
4322 o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
4323 o->op_private |= OPpCONST_ARYBASE;
4330 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
4333 const U32 seq = intro_my();
4336 NewOp(1101, cop, 1, COP);
4337 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
4338 cop->op_type = OP_DBSTATE;
4339 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
4342 cop->op_type = OP_NEXTSTATE;
4343 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
4345 cop->op_flags = (U8)flags;
4346 CopHINTS_set(cop, PL_hints);
4348 cop->op_private |= NATIVE_HINTS;
4350 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
4351 cop->op_next = (OP*)cop;
4354 CopLABEL_set(cop, label);
4355 PL_hints |= HINT_BLOCK_SCOPE;
4358 /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
4359 CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
4361 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
4362 cop->cop_hints_hash = PL_curcop->cop_hints_hash;
4363 if (cop->cop_hints_hash) {
4365 cop->cop_hints_hash->refcounted_he_refcnt++;
4366 HINTS_REFCNT_UNLOCK;
4369 if (PL_parser && PL_parser->copline == NOLINE)
4370 CopLINE_set(cop, CopLINE(PL_curcop));
4372 CopLINE_set(cop, PL_parser->copline);
4374 PL_parser->copline = NOLINE;
4377 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
4379 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
4381 CopSTASH_set(cop, PL_curstash);
4383 if (PERLDB_LINE && PL_curstash != PL_debstash) {
4384 AV *av = CopFILEAVx(PL_curcop);
4386 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
4387 if (svp && *svp != &PL_sv_undef ) {
4388 (void)SvIOK_on(*svp);
4389 SvIV_set(*svp, PTR2IV(cop));
4394 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
4399 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
4403 PERL_ARGS_ASSERT_NEWLOGOP;
4405 return new_logop(type, flags, &first, &other);
4409 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
4414 OP *first = *firstp;
4415 OP * const other = *otherp;
4417 PERL_ARGS_ASSERT_NEW_LOGOP;
4419 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
4420 return newBINOP(type, flags, scalar(first), scalar(other));
4422 scalarboolean(first);
4423 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
4424 if (first->op_type == OP_NOT
4425 && (first->op_flags & OPf_SPECIAL)
4426 && (first->op_flags & OPf_KIDS)
4428 if (type == OP_AND || type == OP_OR) {
4434 first = *firstp = cUNOPo->op_first;
4436 first->op_next = o->op_next;
4437 cUNOPo->op_first = NULL;
4441 if (first->op_type == OP_CONST) {
4442 if (first->op_private & OPpCONST_STRICT)
4443 no_bareword_allowed(first);
4444 else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
4445 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
4446 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
4447 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
4448 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
4450 if (other->op_type == OP_CONST)
4451 other->op_private |= OPpCONST_SHORTCIRCUIT;
4453 OP *newop = newUNOP(OP_NULL, 0, other);
4454 op_getmad(first, newop, '1');
4455 newop->op_targ = type; /* set "was" field */
4462 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
4463 const OP *o2 = other;
4464 if ( ! (o2->op_type == OP_LIST
4465 && (( o2 = cUNOPx(o2)->op_first))
4466 && o2->op_type == OP_PUSHMARK
4467 && (( o2 = o2->op_sibling)) )
4470 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
4471 || o2->op_type == OP_PADHV)
4472 && o2->op_private & OPpLVAL_INTRO
4473 && !(o2->op_private & OPpPAD_STATE)
4474 && ckWARN(WARN_DEPRECATED))
4476 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4477 "Deprecated use of my() in false conditional");
4481 if (first->op_type == OP_CONST)
4482 first->op_private |= OPpCONST_SHORTCIRCUIT;
4484 first = newUNOP(OP_NULL, 0, first);
4485 op_getmad(other, first, '2');
4486 first->op_targ = type; /* set "was" field */
4493 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
4494 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
4496 const OP * const k1 = ((UNOP*)first)->op_first;
4497 const OP * const k2 = k1->op_sibling;
4499 switch (first->op_type)
4502 if (k2 && k2->op_type == OP_READLINE
4503 && (k2->op_flags & OPf_STACKED)
4504 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4506 warnop = k2->op_type;
4511 if (k1->op_type == OP_READDIR
4512 || k1->op_type == OP_GLOB
4513 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4514 || k1->op_type == OP_EACH)
4516 warnop = ((k1->op_type == OP_NULL)
4517 ? (OPCODE)k1->op_targ : k1->op_type);
4522 const line_t oldline = CopLINE(PL_curcop);
4523 CopLINE_set(PL_curcop, PL_parser->copline);
4524 Perl_warner(aTHX_ packWARN(WARN_MISC),
4525 "Value of %s%s can be \"0\"; test with defined()",
4527 ((warnop == OP_READLINE || warnop == OP_GLOB)
4528 ? " construct" : "() operator"));
4529 CopLINE_set(PL_curcop, oldline);
4536 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
4537 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
4539 NewOp(1101, logop, 1, LOGOP);
4541 logop->op_type = (OPCODE)type;
4542 logop->op_ppaddr = PL_ppaddr[type];
4543 logop->op_first = first;
4544 logop->op_flags = (U8)(flags | OPf_KIDS);
4545 logop->op_other = LINKLIST(other);
4546 logop->op_private = (U8)(1 | (flags >> 8));
4548 /* establish postfix order */
4549 logop->op_next = LINKLIST(first);
4550 first->op_next = (OP*)logop;
4551 first->op_sibling = other;
4553 CHECKOP(type,logop);
4555 o = newUNOP(OP_NULL, 0, (OP*)logop);
4562 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
4569 PERL_ARGS_ASSERT_NEWCONDOP;
4572 return newLOGOP(OP_AND, 0, first, trueop);
4574 return newLOGOP(OP_OR, 0, first, falseop);
4576 scalarboolean(first);
4577 if (first->op_type == OP_CONST) {
4578 /* Left or right arm of the conditional? */
4579 const bool left = SvTRUE(((SVOP*)first)->op_sv);
4580 OP *live = left ? trueop : falseop;
4581 OP *const dead = left ? falseop : trueop;
4582 if (first->op_private & OPpCONST_BARE &&
4583 first->op_private & OPpCONST_STRICT) {
4584 no_bareword_allowed(first);
4587 /* This is all dead code when PERL_MAD is not defined. */
4588 live = newUNOP(OP_NULL, 0, live);
4589 op_getmad(first, live, 'C');
4590 op_getmad(dead, live, left ? 'e' : 't');
4597 NewOp(1101, logop, 1, LOGOP);
4598 logop->op_type = OP_COND_EXPR;
4599 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4600 logop->op_first = first;
4601 logop->op_flags = (U8)(flags | OPf_KIDS);
4602 logop->op_private = (U8)(1 | (flags >> 8));
4603 logop->op_other = LINKLIST(trueop);
4604 logop->op_next = LINKLIST(falseop);
4606 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
4609 /* establish postfix order */
4610 start = LINKLIST(first);
4611 first->op_next = (OP*)logop;
4613 first->op_sibling = trueop;
4614 trueop->op_sibling = falseop;
4615 o = newUNOP(OP_NULL, 0, (OP*)logop);
4617 trueop->op_next = falseop->op_next = o;
4624 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4633 PERL_ARGS_ASSERT_NEWRANGE;
4635 NewOp(1101, range, 1, LOGOP);
4637 range->op_type = OP_RANGE;
4638 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4639 range->op_first = left;
4640 range->op_flags = OPf_KIDS;
4641 leftstart = LINKLIST(left);
4642 range->op_other = LINKLIST(right);
4643 range->op_private = (U8)(1 | (flags >> 8));
4645 left->op_sibling = right;
4647 range->op_next = (OP*)range;
4648 flip = newUNOP(OP_FLIP, flags, (OP*)range);
4649 flop = newUNOP(OP_FLOP, 0, flip);
4650 o = newUNOP(OP_NULL, 0, flop);
4652 range->op_next = leftstart;
4654 left->op_next = flip;
4655 right->op_next = flop;
4657 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4658 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4659 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4660 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4662 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4663 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4666 if (!flip->op_private || !flop->op_private)
4667 linklist(o); /* blow off optimizer unless constant */
4673 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4678 const bool once = block && block->op_flags & OPf_SPECIAL &&
4679 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4681 PERL_UNUSED_ARG(debuggable);
4684 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4685 return block; /* do {} while 0 does once */
4686 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4687 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4688 expr = newUNOP(OP_DEFINED, 0,
4689 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4690 } else if (expr->op_flags & OPf_KIDS) {
4691 const OP * const k1 = ((UNOP*)expr)->op_first;
4692 const OP * const k2 = k1 ? k1->op_sibling : NULL;
4693 switch (expr->op_type) {
4695 if (k2 && k2->op_type == OP_READLINE
4696 && (k2->op_flags & OPf_STACKED)
4697 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4698 expr = newUNOP(OP_DEFINED, 0, expr);
4702 if (k1 && (k1->op_type == OP_READDIR
4703 || k1->op_type == OP_GLOB
4704 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4705 || k1->op_type == OP_EACH))
4706 expr = newUNOP(OP_DEFINED, 0, expr);
4712 /* if block is null, the next append_elem() would put UNSTACK, a scalar
4713 * op, in listop. This is wrong. [perl #27024] */
4715 block = newOP(OP_NULL, 0);
4716 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4717 o = new_logop(OP_AND, 0, &expr, &listop);
4720 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4722 if (once && o != listop)
4723 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4726 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
4728 o->op_flags |= flags;
4730 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4735 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
4736 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
4745 PERL_UNUSED_ARG(debuggable);
4748 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4749 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4750 expr = newUNOP(OP_DEFINED, 0,
4751 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4752 } else if (expr->op_flags & OPf_KIDS) {
4753 const OP * const k1 = ((UNOP*)expr)->op_first;
4754 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
4755 switch (expr->op_type) {
4757 if (k2 && k2->op_type == OP_READLINE
4758 && (k2->op_flags & OPf_STACKED)
4759 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4760 expr = newUNOP(OP_DEFINED, 0, expr);
4764 if (k1 && (k1->op_type == OP_READDIR
4765 || k1->op_type == OP_GLOB
4766 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4767 || k1->op_type == OP_EACH))
4768 expr = newUNOP(OP_DEFINED, 0, expr);
4775 block = newOP(OP_NULL, 0);
4776 else if (cont || has_my) {
4777 block = scope(block);
4781 next = LINKLIST(cont);
4784 OP * const unstack = newOP(OP_UNSTACK, 0);
4787 cont = append_elem(OP_LINESEQ, cont, unstack);
4791 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4793 redo = LINKLIST(listop);
4796 PL_parser->copline = (line_t)whileline;
4798 o = new_logop(OP_AND, 0, &expr, &listop);
4799 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4800 op_free(expr); /* oops, it's a while (0) */
4802 return NULL; /* listop already freed by new_logop */
4805 ((LISTOP*)listop)->op_last->op_next =
4806 (o == listop ? redo : LINKLIST(o));
4812 NewOp(1101,loop,1,LOOP);
4813 loop->op_type = OP_ENTERLOOP;
4814 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4815 loop->op_private = 0;
4816 loop->op_next = (OP*)loop;
4819 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4821 loop->op_redoop = redo;
4822 loop->op_lastop = o;
4823 o->op_private |= loopflags;
4826 loop->op_nextop = next;
4828 loop->op_nextop = o;
4830 o->op_flags |= flags;
4831 o->op_private |= (flags >> 8);
4836 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
4841 PADOFFSET padoff = 0;
4846 PERL_ARGS_ASSERT_NEWFOROP;
4849 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4850 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
4851 sv->op_type = OP_RV2GV;
4852 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4854 /* The op_type check is needed to prevent a possible segfault
4855 * if the loop variable is undeclared and 'strict vars' is in
4856 * effect. This is illegal but is nonetheless parsed, so we
4857 * may reach this point with an OP_CONST where we're expecting
4860 if (cUNOPx(sv)->op_first->op_type == OP_GV
4861 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
4862 iterpflags |= OPpITER_DEF;
4864 else if (sv->op_type == OP_PADSV) { /* private variable */
4865 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
4866 padoff = sv->op_targ;
4876 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4878 SV *const namesv = PAD_COMPNAME_SV(padoff);
4880 const char *const name = SvPV_const(namesv, len);
4882 if (len == 2 && name[0] == '$' && name[1] == '_')
4883 iterpflags |= OPpITER_DEF;
4887 const PADOFFSET offset = pad_findmy("$_");
4888 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
4889 sv = newGVOP(OP_GV, 0, PL_defgv);
4894 iterpflags |= OPpITER_DEF;
4896 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4897 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4898 iterflags |= OPf_STACKED;
4900 else if (expr->op_type == OP_NULL &&
4901 (expr->op_flags & OPf_KIDS) &&
4902 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4904 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4905 * set the STACKED flag to indicate that these values are to be
4906 * treated as min/max values by 'pp_iterinit'.
4908 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4909 LOGOP* const range = (LOGOP*) flip->op_first;
4910 OP* const left = range->op_first;
4911 OP* const right = left->op_sibling;
4914 range->op_flags &= ~OPf_KIDS;
4915 range->op_first = NULL;
4917 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4918 listop->op_first->op_next = range->op_next;
4919 left->op_next = range->op_other;
4920 right->op_next = (OP*)listop;
4921 listop->op_next = listop->op_first;
4924 op_getmad(expr,(OP*)listop,'O');
4928 expr = (OP*)(listop);
4930 iterflags |= OPf_STACKED;
4933 expr = mod(force_list(expr), OP_GREPSTART);
4936 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4937 append_elem(OP_LIST, expr, scalar(sv))));
4938 assert(!loop->op_next);
4939 /* for my $x () sets OPpLVAL_INTRO;
4940 * for our $x () sets OPpOUR_INTRO */
4941 loop->op_private = (U8)iterpflags;
4942 #ifdef PL_OP_SLAB_ALLOC
4945 NewOp(1234,tmp,1,LOOP);
4946 Copy(loop,tmp,1,LISTOP);
4947 S_op_destroy(aTHX_ (OP*)loop);
4951 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
4953 loop->op_targ = padoff;
4954 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
4956 op_getmad(madsv, (OP*)loop, 'v');
4957 PL_parser->copline = forline;
4958 return newSTATEOP(0, label, wop);
4962 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4967 PERL_ARGS_ASSERT_NEWLOOPEX;
4969 if (type != OP_GOTO || label->op_type == OP_CONST) {
4970 /* "last()" means "last" */
4971 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4972 o = newOP(type, OPf_SPECIAL);
4974 o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
4975 ? SvPV_nolen_const(((SVOP*)label)->op_sv)
4979 op_getmad(label,o,'L');
4985 /* Check whether it's going to be a goto &function */
4986 if (label->op_type == OP_ENTERSUB
4987 && !(label->op_flags & OPf_STACKED))
4988 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4989 o = newUNOP(type, OPf_STACKED, label);
4991 PL_hints |= HINT_BLOCK_SCOPE;
4995 /* if the condition is a literal array or hash
4996 (or @{ ... } etc), make a reference to it.
4999 S_ref_array_or_hash(pTHX_ OP *cond)
5002 && (cond->op_type == OP_RV2AV
5003 || cond->op_type == OP_PADAV
5004 || cond->op_type == OP_RV2HV
5005 || cond->op_type == OP_PADHV))
5007 return newUNOP(OP_REFGEN,
5008 0, mod(cond, OP_REFGEN));
5014 /* These construct the optree fragments representing given()
5017 entergiven and enterwhen are LOGOPs; the op_other pointer
5018 points up to the associated leave op. We need this so we
5019 can put it in the context and make break/continue work.
5020 (Also, of course, pp_enterwhen will jump straight to
5021 op_other if the match fails.)
5025 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
5026 I32 enter_opcode, I32 leave_opcode,
5027 PADOFFSET entertarg)
5033 PERL_ARGS_ASSERT_NEWGIVWHENOP;
5035 NewOp(1101, enterop, 1, LOGOP);
5036 enterop->op_type = enter_opcode;
5037 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
5038 enterop->op_flags = (U8) OPf_KIDS;
5039 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
5040 enterop->op_private = 0;
5042 o = newUNOP(leave_opcode, 0, (OP *) enterop);
5045 enterop->op_first = scalar(cond);
5046 cond->op_sibling = block;
5048 o->op_next = LINKLIST(cond);
5049 cond->op_next = (OP *) enterop;
5052 /* This is a default {} block */
5053 enterop->op_first = block;
5054 enterop->op_flags |= OPf_SPECIAL;
5056 o->op_next = (OP *) enterop;
5059 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
5060 entergiven and enterwhen both
5063 enterop->op_next = LINKLIST(block);
5064 block->op_next = enterop->op_other = o;
5069 /* Does this look like a boolean operation? For these purposes
5070 a boolean operation is:
5071 - a subroutine call [*]
5072 - a logical connective
5073 - a comparison operator
5074 - a filetest operator, with the exception of -s -M -A -C
5075 - defined(), exists() or eof()
5076 - /$re/ or $foo =~ /$re/
5078 [*] possibly surprising
5081 S_looks_like_bool(pTHX_ const OP *o)
5085 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
5087 switch(o->op_type) {
5089 return looks_like_bool(cLOGOPo->op_first);
5093 looks_like_bool(cLOGOPo->op_first)
5094 && looks_like_bool(cLOGOPo->op_first->op_sibling));
5098 o->op_flags & OPf_KIDS
5099 && looks_like_bool(cUNOPo->op_first));
5103 case OP_NOT: case OP_XOR:
5104 /* Note that OP_DOR is not here */
5106 case OP_EQ: case OP_NE: case OP_LT:
5107 case OP_GT: case OP_LE: case OP_GE:
5109 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
5110 case OP_I_GT: case OP_I_LE: case OP_I_GE:
5112 case OP_SEQ: case OP_SNE: case OP_SLT:
5113 case OP_SGT: case OP_SLE: case OP_SGE:
5117 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
5118 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
5119 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
5120 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
5121 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
5122 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
5123 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
5124 case OP_FTTEXT: case OP_FTBINARY:
5126 case OP_DEFINED: case OP_EXISTS:
5127 case OP_MATCH: case OP_EOF:
5132 /* Detect comparisons that have been optimized away */
5133 if (cSVOPo->op_sv == &PL_sv_yes
5134 || cSVOPo->op_sv == &PL_sv_no)
5145 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
5148 PERL_ARGS_ASSERT_NEWGIVENOP;
5149 return newGIVWHENOP(
5150 ref_array_or_hash(cond),
5152 OP_ENTERGIVEN, OP_LEAVEGIVEN,
5156 /* If cond is null, this is a default {} block */
5158 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
5160 const bool cond_llb = (!cond || looks_like_bool(cond));
5163 PERL_ARGS_ASSERT_NEWWHENOP;
5168 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
5170 scalar(ref_array_or_hash(cond)));
5173 return newGIVWHENOP(
5175 append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
5176 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
5180 =for apidoc cv_undef
5182 Clear out all the active components of a CV. This can happen either
5183 by an explicit C<undef &foo>, or by the reference count going to zero.
5184 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
5185 children can still follow the full lexical scope chain.
5191 Perl_cv_undef(pTHX_ CV *cv)
5195 PERL_ARGS_ASSERT_CV_UNDEF;
5197 DEBUG_X(PerlIO_printf(Perl_debug_log,
5198 "CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n",
5199 PTR2UV(cv), PTR2UV(PL_comppad))
5203 if (CvFILE(cv) && !CvISXSUB(cv)) {
5204 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
5205 Safefree(CvFILE(cv));
5210 if (!CvISXSUB(cv) && CvROOT(cv)) {
5211 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
5212 Perl_croak(aTHX_ "Can't undef active subroutine");
5215 PAD_SAVE_SETNULLPAD();
5217 op_free(CvROOT(cv));
5222 SvPOK_off((SV*)cv); /* forget prototype */
5227 /* remove CvOUTSIDE unless this is an undef rather than a free */
5228 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
5229 if (!CvWEAKOUTSIDE(cv))
5230 SvREFCNT_dec(CvOUTSIDE(cv));
5231 CvOUTSIDE(cv) = NULL;
5234 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
5237 if (CvISXSUB(cv) && CvXSUB(cv)) {
5240 /* delete all flags except WEAKOUTSIDE */
5241 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
5245 Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
5248 PERL_ARGS_ASSERT_CV_CKPROTO_LEN;
5250 /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
5251 relying on SvCUR, and doubling up the buffer to hold CvFILE(). */
5252 if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
5253 || (p && (len != SvCUR(cv) /* Not the same length. */
5254 || memNE(p, SvPVX_const(cv), len))))
5255 && ckWARN_d(WARN_PROTOTYPE)) {
5256 SV* const msg = sv_newmortal();
5260 gv_efullname3(name = sv_newmortal(), gv, NULL);
5261 sv_setpvs(msg, "Prototype mismatch:");
5263 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
5265 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv));
5267 sv_catpvs(msg, ": none");
5268 sv_catpvs(msg, " vs ");
5270 Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
5272 sv_catpvs(msg, "none");
5273 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
5277 static void const_sv_xsub(pTHX_ CV* cv);
5281 =head1 Optree Manipulation Functions
5283 =for apidoc cv_const_sv
5285 If C<cv> is a constant sub eligible for inlining. returns the constant
5286 value returned by the sub. Otherwise, returns NULL.
5288 Constant subs can be created with C<newCONSTSUB> or as described in
5289 L<perlsub/"Constant Functions">.
5294 Perl_cv_const_sv(pTHX_ CV *cv)
5296 PERL_UNUSED_CONTEXT;
5299 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
5301 return CvCONST(cv) ? (SV*)CvXSUBANY(cv).any_ptr : NULL;
5304 /* op_const_sv: examine an optree to determine whether it's in-lineable.
5305 * Can be called in 3 ways:
5308 * look for a single OP_CONST with attached value: return the value
5310 * cv && CvCLONE(cv) && !CvCONST(cv)
5312 * examine the clone prototype, and if contains only a single
5313 * OP_CONST referencing a pad const, or a single PADSV referencing
5314 * an outer lexical, return a non-zero value to indicate the CV is
5315 * a candidate for "constizing" at clone time
5319 * We have just cloned an anon prototype that was marked as a const
5320 * candidiate. Try to grab the current value, and in the case of
5321 * PADSV, ignore it if it has multiple references. Return the value.
5325 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
5336 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
5337 o = cLISTOPo->op_first->op_sibling;
5339 for (; o; o = o->op_next) {
5340 const OPCODE type = o->op_type;
5342 if (sv && o->op_next == o)
5344 if (o->op_next != o) {
5345 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
5347 if (type == OP_DBSTATE)
5350 if (type == OP_LEAVESUB || type == OP_RETURN)
5354 if (type == OP_CONST && cSVOPo->op_sv)
5356 else if (cv && type == OP_CONST) {
5357 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5361 else if (cv && type == OP_PADSV) {
5362 if (CvCONST(cv)) { /* newly cloned anon */
5363 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5364 /* the candidate should have 1 ref from this pad and 1 ref
5365 * from the parent */
5366 if (!sv || SvREFCNT(sv) != 2)
5373 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
5374 sv = &PL_sv_undef; /* an arbitrary non-null value */
5389 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5392 /* This would be the return value, but the return cannot be reached. */
5393 OP* pegop = newOP(OP_NULL, 0);
5396 PERL_UNUSED_ARG(floor);
5406 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
5408 NORETURN_FUNCTION_END;
5413 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
5415 return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
5419 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5426 register CV *cv = NULL;
5428 /* If the subroutine has no body, no attributes, and no builtin attributes
5429 then it's just a sub declaration, and we may be able to get away with
5430 storing with a placeholder scalar in the symbol table, rather than a
5431 full GV and CV. If anything is present then it will take a full CV to
5433 const I32 gv_fetch_flags
5434 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5436 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
5437 const char * const name = o ? SvPV_nolen_const(cSVOPo->op_sv) : NULL;
5440 assert(proto->op_type == OP_CONST);
5441 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
5446 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
5447 SV * const sv = sv_newmortal();
5448 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
5449 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
5450 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
5451 aname = SvPVX_const(sv);
5456 gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
5457 : gv_fetchpv(aname ? aname
5458 : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5459 gv_fetch_flags, SVt_PVCV);
5461 if (!PL_madskills) {
5470 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
5471 maximum a prototype before. */
5472 if (SvTYPE(gv) > SVt_NULL) {
5473 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
5474 && ckWARN_d(WARN_PROTOTYPE))
5476 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
5478 cv_ckproto_len((CV*)gv, NULL, ps, ps_len);
5481 sv_setpvn((SV*)gv, ps, ps_len);
5483 sv_setiv((SV*)gv, -1);
5485 SvREFCNT_dec(PL_compcv);
5486 cv = PL_compcv = NULL;
5490 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
5492 #ifdef GV_UNIQUE_CHECK
5493 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
5494 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
5498 if (!block || !ps || *ps || attrs
5499 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5501 || block->op_type == OP_NULL
5506 const_sv = op_const_sv(block, NULL);
5509 const bool exists = CvROOT(cv) || CvXSUB(cv);
5511 #ifdef GV_UNIQUE_CHECK
5512 if (exists && GvUNIQUE(gv)) {
5513 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
5517 /* if the subroutine doesn't exist and wasn't pre-declared
5518 * with a prototype, assume it will be AUTOLOADed,
5519 * skipping the prototype check
5521 if (exists || SvPOK(cv))
5522 cv_ckproto_len(cv, gv, ps, ps_len);
5523 /* already defined (or promised)? */
5524 if (exists || GvASSUMECV(gv)) {
5527 || block->op_type == OP_NULL
5530 if (CvFLAGS(PL_compcv)) {
5531 /* might have had built-in attrs applied */
5532 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5534 /* just a "sub foo;" when &foo is already defined */
5535 SAVEFREESV(PL_compcv);
5540 && block->op_type != OP_NULL
5543 if (ckWARN(WARN_REDEFINE)
5545 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
5547 const line_t oldline = CopLINE(PL_curcop);
5548 if (PL_parser && PL_parser->copline != NOLINE)
5549 CopLINE_set(PL_curcop, PL_parser->copline);
5550 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5551 CvCONST(cv) ? "Constant subroutine %s redefined"
5552 : "Subroutine %s redefined", name);
5553 CopLINE_set(PL_curcop, oldline);
5556 if (!PL_minus_c) /* keep old one around for madskills */
5559 /* (PL_madskills unset in used file.) */
5567 SvREFCNT_inc_simple_void_NN(const_sv);
5569 assert(!CvROOT(cv) && !CvCONST(cv));
5570 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
5571 CvXSUBANY(cv).any_ptr = const_sv;
5572 CvXSUB(cv) = const_sv_xsub;
5578 cv = newCONSTSUB(NULL, name, const_sv);
5580 mro_method_changed_in( /* sub Foo::Bar () { 123 } */
5581 (CvGV(cv) && GvSTASH(CvGV(cv)))
5590 SvREFCNT_dec(PL_compcv);
5598 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
5599 * before we clobber PL_compcv.
5603 || block->op_type == OP_NULL
5607 /* Might have had built-in attributes applied -- propagate them. */
5608 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5609 if (CvGV(cv) && GvSTASH(CvGV(cv)))
5610 stash = GvSTASH(CvGV(cv));
5611 else if (CvSTASH(cv))
5612 stash = CvSTASH(cv);
5614 stash = PL_curstash;
5617 /* possibly about to re-define existing subr -- ignore old cv */
5618 rcv = (SV*)PL_compcv;
5619 if (name && GvSTASH(gv))
5620 stash = GvSTASH(gv);
5622 stash = PL_curstash;
5624 apply_attrs(stash, rcv, attrs, FALSE);
5626 if (cv) { /* must reuse cv if autoloaded */
5633 || block->op_type == OP_NULL) && !PL_madskills
5636 /* got here with just attrs -- work done, so bug out */
5637 SAVEFREESV(PL_compcv);
5640 /* transfer PL_compcv to cv */
5642 CvFLAGS(cv) = CvFLAGS(PL_compcv);
5643 if (!CvWEAKOUTSIDE(cv))
5644 SvREFCNT_dec(CvOUTSIDE(cv));
5645 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
5646 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
5647 CvOUTSIDE(PL_compcv) = 0;
5648 CvPADLIST(cv) = CvPADLIST(PL_compcv);
5649 CvPADLIST(PL_compcv) = 0;
5650 /* inner references to PL_compcv must be fixed up ... */
5651 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
5652 /* ... before we throw it away */
5653 SvREFCNT_dec(PL_compcv);
5655 if (PERLDB_INTER)/* Advice debugger on the new sub. */
5656 ++PL_sub_generation;
5663 if (strEQ(name, "import")) {
5664 PL_formfeed = (SV*)cv;
5665 Perl_warner(aTHX_ packWARN(WARN_VOID), "%lx\n", (long)cv);
5669 mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */
5673 CvFILE_set_from_cop(cv, PL_curcop);
5674 CvSTASH(cv) = PL_curstash;
5677 sv_setpvn((SV*)cv, ps, ps_len);
5679 if (PL_parser && PL_parser->error_count) {
5683 const char *s = strrchr(name, ':');
5685 if (strEQ(s, "BEGIN")) {
5686 const char not_safe[] =
5687 "BEGIN not safe after errors--compilation aborted";
5688 if (PL_in_eval & EVAL_KEEPERR)
5689 Perl_croak(aTHX_ not_safe);
5691 /* force display of errors found but not reported */
5692 sv_catpv(ERRSV, not_safe);
5693 Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
5703 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5704 mod(scalarseq(block), OP_LEAVESUBLV));
5705 block->op_attached = 1;
5708 /* This makes sub {}; work as expected. */
5709 if (block->op_type == OP_STUB) {
5710 OP* const newblock = newSTATEOP(0, NULL, 0);
5712 op_getmad(block,newblock,'B');
5719 block->op_attached = 1;
5720 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5722 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5723 OpREFCNT_set(CvROOT(cv), 1);
5724 CvSTART(cv) = LINKLIST(CvROOT(cv));
5725 CvROOT(cv)->op_next = 0;
5726 CALL_PEEP(CvSTART(cv));
5728 /* now that optimizer has done its work, adjust pad values */
5730 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
5733 assert(!CvCONST(cv));
5734 if (ps && !*ps && op_const_sv(block, cv))
5738 if (name || aname) {
5739 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5740 SV * const sv = newSV(0);
5741 SV * const tmpstr = sv_newmortal();
5742 GV * const db_postponed = gv_fetchpvs("DB::postponed",
5743 GV_ADDMULTI, SVt_PVHV);
5746 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5748 (long)PL_subline, (long)CopLINE(PL_curcop));
5749 gv_efullname3(tmpstr, gv, NULL);
5750 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
5751 SvCUR(tmpstr), sv, 0);
5752 hv = GvHVn(db_postponed);
5753 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
5754 CV * const pcv = GvCV(db_postponed);
5760 call_sv((SV*)pcv, G_DISCARD);
5765 if (name && ! (PL_parser && PL_parser->error_count))
5766 process_special_blocks(name, gv, cv);
5771 PL_parser->copline = NOLINE;
5777 S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
5780 const char *const colon = strrchr(fullname,':');
5781 const char *const name = colon ? colon + 1 : fullname;
5783 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
5786 if (strEQ(name, "BEGIN")) {
5787 const I32 oldscope = PL_scopestack_ix;
5789 SAVECOPFILE(&PL_compiling);
5790 SAVECOPLINE(&PL_compiling);
5792 DEBUG_x( dump_sub(gv) );
5793 Perl_av_create_and_push(aTHX_ &PL_beginav, (SV*)cv);
5794 GvCV(gv) = 0; /* cv has been hijacked */
5795 call_list(oldscope, PL_beginav);
5797 PL_curcop = &PL_compiling;
5798 CopHINTS_set(&PL_compiling, PL_hints);
5805 if strEQ(name, "END") {
5806 DEBUG_x( dump_sub(gv) );
5807 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, (SV*)cv);
5810 } else if (*name == 'U') {
5811 if (strEQ(name, "UNITCHECK")) {
5812 /* It's never too late to run a unitcheck block */
5813 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, (SV*)cv);
5817 } else if (*name == 'C') {
5818 if (strEQ(name, "CHECK")) {
5819 if (PL_main_start && ckWARN(WARN_VOID))
5820 Perl_warner(aTHX_ packWARN(WARN_VOID),
5821 "Too late to run CHECK block");
5822 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, (SV*)cv);
5826 } else if (*name == 'I') {
5827 if (strEQ(name, "INIT")) {
5828 if (PL_main_start && ckWARN(WARN_VOID))
5829 Perl_warner(aTHX_ packWARN(WARN_VOID),
5830 "Too late to run INIT block");
5831 Perl_av_create_and_push(aTHX_ &PL_initav, (SV*)cv);
5837 DEBUG_x( dump_sub(gv) );
5838 GvCV(gv) = 0; /* cv has been hijacked */
5843 =for apidoc newCONSTSUB
5845 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5846 eligible for inlining at compile-time.
5852 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
5857 const char *const temp_p = CopFILE(PL_curcop);
5858 const STRLEN len = temp_p ? strlen(temp_p) : 0;
5860 SV *const temp_sv = CopFILESV(PL_curcop);
5862 const char *const temp_p = temp_sv ? SvPV_const(temp_sv, len) : NULL;
5864 char *const file = savepvn(temp_p, temp_p ? len : 0);
5868 if (IN_PERL_RUNTIME) {
5869 /* at runtime, it's not safe to manipulate PL_curcop: it may be
5870 * an op shared between threads. Use a non-shared COP for our
5872 SAVEVPTR(PL_curcop);
5873 PL_curcop = &PL_compiling;
5875 SAVECOPLINE(PL_curcop);
5876 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
5879 PL_hints &= ~HINT_BLOCK_SCOPE;
5882 SAVESPTR(PL_curstash);
5883 SAVECOPSTASH(PL_curcop);
5884 PL_curstash = stash;
5885 CopSTASH_set(PL_curcop,stash);
5888 /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
5889 and so doesn't get free()d. (It's expected to be from the C pre-
5890 processor __FILE__ directive). But we need a dynamically allocated one,
5891 and we need it to get freed. */
5892 cv = newXS_flags(name, const_sv_xsub, file, "", XS_DYNAMIC_FILENAME);
5893 CvXSUBANY(cv).any_ptr = sv;
5899 CopSTASH_free(PL_curcop);
5907 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
5908 const char *const filename, const char *const proto,
5911 CV *cv = newXS(name, subaddr, filename);
5913 PERL_ARGS_ASSERT_NEWXS_FLAGS;
5915 if (flags & XS_DYNAMIC_FILENAME) {
5916 /* We need to "make arrangements" (ie cheat) to ensure that the
5917 filename lasts as long as the PVCV we just created, but also doesn't
5919 STRLEN filename_len = strlen(filename);
5920 STRLEN proto_and_file_len = filename_len;
5921 char *proto_and_file;
5925 proto_len = strlen(proto);
5926 proto_and_file_len += proto_len;
5928 Newx(proto_and_file, proto_and_file_len + 1, char);
5929 Copy(proto, proto_and_file, proto_len, char);
5930 Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
5933 proto_and_file = savepvn(filename, filename_len);
5936 /* This gets free()d. :-) */
5937 sv_usepvn_flags((SV*)cv, proto_and_file, proto_and_file_len,
5938 SV_HAS_TRAILING_NUL);
5940 /* This gives us the correct prototype, rather than one with the
5941 file name appended. */
5942 SvCUR_set(cv, proto_len);
5946 CvFILE(cv) = proto_and_file + proto_len;
5948 sv_setpv((SV *)cv, proto);
5954 =for apidoc U||newXS
5956 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
5957 static storage, as it is used directly as CvFILE(), without a copy being made.
5963 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
5966 GV * const gv = gv_fetchpv(name ? name :
5967 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5968 GV_ADDMULTI, SVt_PVCV);
5971 PERL_ARGS_ASSERT_NEWXS;
5974 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
5976 if ((cv = (name ? GvCV(gv) : NULL))) {
5978 /* just a cached method */
5982 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5983 /* already defined (or promised) */
5984 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
5985 if (ckWARN(WARN_REDEFINE)) {
5986 GV * const gvcv = CvGV(cv);
5988 HV * const stash = GvSTASH(gvcv);
5990 const char *redefined_name = HvNAME_get(stash);
5991 if ( strEQ(redefined_name,"autouse") ) {
5992 const line_t oldline = CopLINE(PL_curcop);
5993 if (PL_parser && PL_parser->copline != NOLINE)
5994 CopLINE_set(PL_curcop, PL_parser->copline);
5995 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5996 CvCONST(cv) ? "Constant subroutine %s redefined"
5997 : "Subroutine %s redefined"
5999 CopLINE_set(PL_curcop, oldline);
6009 if (cv) /* must reuse cv if autoloaded */
6012 cv = (CV*)newSV_type(SVt_PVCV);
6016 mro_method_changed_in(GvSTASH(gv)); /* newXS */
6020 (void)gv_fetchfile(filename);
6021 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
6022 an external constant string */
6024 CvXSUB(cv) = subaddr;
6027 process_special_blocks(name, gv, cv);
6039 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
6044 OP* pegop = newOP(OP_NULL, 0);
6048 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
6049 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
6051 #ifdef GV_UNIQUE_CHECK
6053 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
6057 if ((cv = GvFORM(gv))) {
6058 if (ckWARN(WARN_REDEFINE)) {
6059 const line_t oldline = CopLINE(PL_curcop);
6060 if (PL_parser && PL_parser->copline != NOLINE)
6061 CopLINE_set(PL_curcop, PL_parser->copline);
6062 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6063 o ? "Format %"SVf" redefined"
6064 : "Format STDOUT redefined", SVfARG(cSVOPo->op_sv));
6065 CopLINE_set(PL_curcop, oldline);
6072 CvFILE_set_from_cop(cv, PL_curcop);
6075 pad_tidy(padtidy_FORMAT);
6076 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
6077 CvROOT(cv)->op_private |= OPpREFCOUNTED;
6078 OpREFCNT_set(CvROOT(cv), 1);
6079 CvSTART(cv) = LINKLIST(CvROOT(cv));
6080 CvROOT(cv)->op_next = 0;
6081 CALL_PEEP(CvSTART(cv));
6083 op_getmad(o,pegop,'n');
6084 op_getmad_weak(block, pegop, 'b');
6089 PL_parser->copline = NOLINE;
6097 Perl_newANONLIST(pTHX_ OP *o)
6099 return convert(OP_ANONLIST, OPf_SPECIAL, o);
6103 Perl_newANONHASH(pTHX_ OP *o)
6105 return convert(OP_ANONHASH, OPf_SPECIAL, o);
6109 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
6111 return newANONATTRSUB(floor, proto, NULL, block);
6115 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
6117 return newUNOP(OP_REFGEN, 0,
6118 newSVOP(OP_ANONCODE, 0,
6119 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
6123 Perl_oopsAV(pTHX_ OP *o)
6127 PERL_ARGS_ASSERT_OOPSAV;
6129 switch (o->op_type) {
6131 o->op_type = OP_PADAV;
6132 o->op_ppaddr = PL_ppaddr[OP_PADAV];
6133 return ref(o, OP_RV2AV);
6136 o->op_type = OP_RV2AV;
6137 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
6142 if (ckWARN_d(WARN_INTERNAL))
6143 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
6150 Perl_oopsHV(pTHX_ OP *o)
6154 PERL_ARGS_ASSERT_OOPSHV;
6156 switch (o->op_type) {
6159 o->op_type = OP_PADHV;
6160 o->op_ppaddr = PL_ppaddr[OP_PADHV];
6161 return ref(o, OP_RV2HV);
6165 o->op_type = OP_RV2HV;
6166 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
6171 if (ckWARN_d(WARN_INTERNAL))
6172 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
6179 Perl_newAVREF(pTHX_ OP *o)
6183 PERL_ARGS_ASSERT_NEWAVREF;
6185 if (o->op_type == OP_PADANY) {
6186 o->op_type = OP_PADAV;
6187 o->op_ppaddr = PL_ppaddr[OP_PADAV];
6190 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
6191 && ckWARN(WARN_DEPRECATED)) {
6192 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
6193 "Using an array as a reference is deprecated");
6195 return newUNOP(OP_RV2AV, 0, scalar(o));
6199 Perl_newGVREF(pTHX_ I32 type, OP *o)
6201 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
6202 return newUNOP(OP_NULL, 0, o);
6203 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
6207 Perl_newHVREF(pTHX_ OP *o)
6211 PERL_ARGS_ASSERT_NEWHVREF;
6213 if (o->op_type == OP_PADANY) {
6214 o->op_type = OP_PADHV;
6215 o->op_ppaddr = PL_ppaddr[OP_PADHV];
6218 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
6219 && ckWARN(WARN_DEPRECATED)) {
6220 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
6221 "Using a hash as a reference is deprecated");
6223 return newUNOP(OP_RV2HV, 0, scalar(o));
6227 Perl_newCVREF(pTHX_ I32 flags, OP *o)
6229 return newUNOP(OP_RV2CV, flags, scalar(o));
6233 Perl_newSVREF(pTHX_ OP *o)
6237 PERL_ARGS_ASSERT_NEWSVREF;
6239 if (o->op_type == OP_PADANY) {
6240 o->op_type = OP_PADSV;
6241 o->op_ppaddr = PL_ppaddr[OP_PADSV];
6244 return newUNOP(OP_RV2SV, 0, scalar(o));
6247 /* Check routines. See the comments at the top of this file for details
6248 * on when these are called */
6251 Perl_ck_anoncode(pTHX_ OP *o)
6253 PERL_ARGS_ASSERT_CK_ANONCODE;
6255 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
6257 cSVOPo->op_sv = NULL;
6262 Perl_ck_bitop(pTHX_ OP *o)
6266 PERL_ARGS_ASSERT_CK_BITOP;
6268 #define OP_IS_NUMCOMPARE(op) \
6269 ((op) == OP_LT || (op) == OP_I_LT || \
6270 (op) == OP_GT || (op) == OP_I_GT || \
6271 (op) == OP_LE || (op) == OP_I_LE || \
6272 (op) == OP_GE || (op) == OP_I_GE || \
6273 (op) == OP_EQ || (op) == OP_I_EQ || \
6274 (op) == OP_NE || (op) == OP_I_NE || \
6275 (op) == OP_NCMP || (op) == OP_I_NCMP)
6276 o->op_private = (U8)(PL_hints & HINT_INTEGER);
6277 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
6278 && (o->op_type == OP_BIT_OR
6279 || o->op_type == OP_BIT_AND
6280 || o->op_type == OP_BIT_XOR))
6282 const OP * const left = cBINOPo->op_first;
6283 const OP * const right = left->op_sibling;
6284 if ((OP_IS_NUMCOMPARE(left->op_type) &&
6285 (left->op_flags & OPf_PARENS) == 0) ||
6286 (OP_IS_NUMCOMPARE(right->op_type) &&
6287 (right->op_flags & OPf_PARENS) == 0))
6288 if (ckWARN(WARN_PRECEDENCE))
6289 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
6290 "Possible precedence problem on bitwise %c operator",
6291 o->op_type == OP_BIT_OR ? '|'
6292 : o->op_type == OP_BIT_AND ? '&' : '^'
6299 Perl_ck_concat(pTHX_ OP *o)
6301 const OP * const kid = cUNOPo->op_first;
6303 PERL_ARGS_ASSERT_CK_CONCAT;
6304 PERL_UNUSED_CONTEXT;
6306 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
6307 !(kUNOP->op_first->op_flags & OPf_MOD))
6308 o->op_flags |= OPf_STACKED;
6313 Perl_ck_spair(pTHX_ OP *o)
6317 PERL_ARGS_ASSERT_CK_SPAIR;
6319 if (o->op_flags & OPf_KIDS) {
6322 const OPCODE type = o->op_type;
6323 o = modkids(ck_fun(o), type);
6324 kid = cUNOPo->op_first;
6325 newop = kUNOP->op_first->op_sibling;
6327 const OPCODE type = newop->op_type;
6328 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
6329 type == OP_PADAV || type == OP_PADHV ||
6330 type == OP_RV2AV || type == OP_RV2HV)
6334 op_getmad(kUNOP->op_first,newop,'K');
6336 op_free(kUNOP->op_first);
6338 kUNOP->op_first = newop;
6340 o->op_ppaddr = PL_ppaddr[++o->op_type];
6345 Perl_ck_delete(pTHX_ OP *o)
6347 PERL_ARGS_ASSERT_CK_DELETE;
6351 if (o->op_flags & OPf_KIDS) {
6352 OP * const kid = cUNOPo->op_first;
6353 switch (kid->op_type) {
6355 o->op_flags |= OPf_SPECIAL;
6358 o->op_private |= OPpSLICE;
6361 o->op_flags |= OPf_SPECIAL;
6366 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
6375 Perl_ck_die(pTHX_ OP *o)
6377 PERL_ARGS_ASSERT_CK_DIE;
6380 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6386 Perl_ck_eof(pTHX_ OP *o)
6390 PERL_ARGS_ASSERT_CK_EOF;
6392 if (o->op_flags & OPf_KIDS) {
6393 if (cLISTOPo->op_first->op_type == OP_STUB) {
6395 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
6397 op_getmad(o,newop,'O');
6409 Perl_ck_eval(pTHX_ OP *o)
6413 PERL_ARGS_ASSERT_CK_EVAL;
6415 PL_hints |= HINT_BLOCK_SCOPE;
6416 if (o->op_flags & OPf_KIDS) {
6417 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6420 o->op_flags &= ~OPf_KIDS;
6423 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
6429 cUNOPo->op_first = 0;
6434 NewOp(1101, enter, 1, LOGOP);
6435 enter->op_type = OP_ENTERTRY;
6436 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
6437 enter->op_private = 0;
6439 /* establish postfix order */
6440 enter->op_next = (OP*)enter;
6442 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
6443 o->op_type = OP_LEAVETRY;
6444 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
6445 enter->op_other = o;
6446 op_getmad(oldo,o,'O');
6460 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
6461 op_getmad(oldo,o,'O');
6463 o->op_targ = (PADOFFSET)PL_hints;
6464 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
6465 /* Store a copy of %^H that pp_entereval can pick up.
6466 OPf_SPECIAL flags the opcode as being for this purpose,
6467 so that it in turn will return a copy at every
6469 OP *hhop = newSVOP(OP_CONST, OPf_SPECIAL,
6470 (SV*)Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv)));
6471 cUNOPo->op_first->op_sibling = hhop;
6472 o->op_private |= OPpEVAL_HAS_HH;
6478 Perl_ck_exit(pTHX_ OP *o)
6480 PERL_ARGS_ASSERT_CK_EXIT;
6483 HV * const table = GvHV(PL_hintgv);
6485 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
6486 if (svp && *svp && SvTRUE(*svp))
6487 o->op_private |= OPpEXIT_VMSISH;
6489 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6495 Perl_ck_exec(pTHX_ OP *o)
6497 PERL_ARGS_ASSERT_CK_EXEC;
6499 if (o->op_flags & OPf_STACKED) {
6502 kid = cUNOPo->op_first->op_sibling;
6503 if (kid->op_type == OP_RV2GV)
6512 Perl_ck_exists(pTHX_ OP *o)
6516 PERL_ARGS_ASSERT_CK_EXISTS;
6519 if (o->op_flags & OPf_KIDS) {
6520 OP * const kid = cUNOPo->op_first;
6521 if (kid->op_type == OP_ENTERSUB) {
6522 (void) ref(kid, o->op_type);
6523 if (kid->op_type != OP_RV2CV
6524 && !(PL_parser && PL_parser->error_count))
6525 Perl_croak(aTHX_ "%s argument is not a subroutine name",
6527 o->op_private |= OPpEXISTS_SUB;
6529 else if (kid->op_type == OP_AELEM)
6530 o->op_flags |= OPf_SPECIAL;
6531 else if (kid->op_type != OP_HELEM)
6532 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
6540 Perl_ck_rvconst(pTHX_ register OP *o)
6543 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6545 PERL_ARGS_ASSERT_CK_RVCONST;
6547 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6548 if (o->op_type == OP_RV2CV)
6549 o->op_private &= ~1;
6551 if (kid->op_type == OP_CONST) {
6554 SV * const kidsv = kid->op_sv;
6556 /* Is it a constant from cv_const_sv()? */
6557 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
6558 SV * const rsv = SvRV(kidsv);
6559 const svtype type = SvTYPE(rsv);
6560 const char *badtype = NULL;
6562 switch (o->op_type) {
6564 if (type > SVt_PVMG)
6565 badtype = "a SCALAR";
6568 if (type != SVt_PVAV)
6569 badtype = "an ARRAY";
6572 if (type != SVt_PVHV)
6576 if (type != SVt_PVCV)
6581 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
6584 else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
6585 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
6586 /* If this is an access to a stash, disable "strict refs", because
6587 * stashes aren't auto-vivified at compile-time (unless we store
6588 * symbols in them), and we don't want to produce a run-time
6589 * stricture error when auto-vivifying the stash. */
6590 const char *s = SvPV_nolen(kidsv);
6591 const STRLEN l = SvCUR(kidsv);
6592 if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
6593 o->op_private &= ~HINT_STRICT_REFS;
6595 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
6596 const char *badthing;
6597 switch (o->op_type) {
6599 badthing = "a SCALAR";
6602 badthing = "an ARRAY";
6605 badthing = "a HASH";
6613 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
6614 SVfARG(kidsv), badthing);
6617 * This is a little tricky. We only want to add the symbol if we
6618 * didn't add it in the lexer. Otherwise we get duplicate strict
6619 * warnings. But if we didn't add it in the lexer, we must at
6620 * least pretend like we wanted to add it even if it existed before,
6621 * or we get possible typo warnings. OPpCONST_ENTERED says
6622 * whether the lexer already added THIS instance of this symbol.
6624 iscv = (o->op_type == OP_RV2CV) * 2;
6626 gv = gv_fetchsv(kidsv,
6627 iscv | !(kid->op_private & OPpCONST_ENTERED),
6630 : o->op_type == OP_RV2SV
6632 : o->op_type == OP_RV2AV
6634 : o->op_type == OP_RV2HV
6637 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
6639 kid->op_type = OP_GV;
6640 SvREFCNT_dec(kid->op_sv);
6642 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
6643 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
6644 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
6646 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc_simple_NN(gv));
6648 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
6650 kid->op_private = 0;
6651 kid->op_ppaddr = PL_ppaddr[OP_GV];
6658 Perl_ck_ftst(pTHX_ OP *o)
6661 const I32 type = o->op_type;
6663 PERL_ARGS_ASSERT_CK_FTST;
6665 if (o->op_flags & OPf_REF) {
6668 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
6669 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6670 const OPCODE kidtype = kid->op_type;
6672 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6673 OP * const newop = newGVOP(type, OPf_REF,
6674 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
6676 op_getmad(o,newop,'O');
6682 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o))
6683 o->op_private |= OPpFT_ACCESS;
6684 if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst)
6685 && kidtype != OP_STAT && kidtype != OP_LSTAT)
6686 o->op_private |= OPpFT_STACKED;
6694 if (type == OP_FTTTY)
6695 o = newGVOP(type, OPf_REF, PL_stdingv);
6697 o = newUNOP(type, 0, newDEFSVOP());
6698 op_getmad(oldo,o,'O');
6704 Perl_ck_fun(pTHX_ OP *o)
6707 const int type = o->op_type;
6708 register I32 oa = PL_opargs[type] >> OASHIFT;
6710 PERL_ARGS_ASSERT_CK_FUN;
6712 if (o->op_flags & OPf_STACKED) {
6713 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
6716 return no_fh_allowed(o);
6719 if (o->op_flags & OPf_KIDS) {
6720 OP **tokid = &cLISTOPo->op_first;
6721 register OP *kid = cLISTOPo->op_first;
6725 if (kid->op_type == OP_PUSHMARK ||
6726 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
6728 tokid = &kid->op_sibling;
6729 kid = kid->op_sibling;
6731 if (!kid && PL_opargs[type] & OA_DEFGV)
6732 *tokid = kid = newDEFSVOP();
6736 sibl = kid->op_sibling;
6738 if (!sibl && kid->op_type == OP_STUB) {
6745 /* list seen where single (scalar) arg expected? */
6746 if (numargs == 1 && !(oa >> 4)
6747 && kid->op_type == OP_LIST && type != OP_SCALAR)
6749 return too_many_arguments(o,PL_op_desc[type]);
6762 if ((type == OP_PUSH || type == OP_UNSHIFT)
6763 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
6764 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6765 "Useless use of %s with no values",
6768 if (kid->op_type == OP_CONST &&
6769 (kid->op_private & OPpCONST_BARE))
6771 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
6772 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
6773 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6774 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6775 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
6776 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6778 op_getmad(kid,newop,'K');
6783 kid->op_sibling = sibl;
6786 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
6787 bad_type(numargs, "array", PL_op_desc[type], kid);
6791 if (kid->op_type == OP_CONST &&
6792 (kid->op_private & OPpCONST_BARE))
6794 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
6795 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
6796 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6797 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6798 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
6799 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6801 op_getmad(kid,newop,'K');
6806 kid->op_sibling = sibl;
6809 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
6810 bad_type(numargs, "hash", PL_op_desc[type], kid);
6815 OP * const newop = newUNOP(OP_NULL, 0, kid);
6816 kid->op_sibling = 0;
6818 newop->op_next = newop;
6820 kid->op_sibling = sibl;
6825 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
6826 if (kid->op_type == OP_CONST &&
6827 (kid->op_private & OPpCONST_BARE))
6829 OP * const newop = newGVOP(OP_GV, 0,
6830 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
6831 if (!(o->op_private & 1) && /* if not unop */
6832 kid == cLISTOPo->op_last)
6833 cLISTOPo->op_last = newop;
6835 op_getmad(kid,newop,'K');
6841 else if (kid->op_type == OP_READLINE) {
6842 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
6843 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
6846 I32 flags = OPf_SPECIAL;
6850 /* is this op a FH constructor? */
6851 if (is_handle_constructor(o,numargs)) {
6852 const char *name = NULL;
6856 /* Set a flag to tell rv2gv to vivify
6857 * need to "prove" flag does not mean something
6858 * else already - NI-S 1999/05/07
6861 if (kid->op_type == OP_PADSV) {
6863 = PAD_COMPNAME_SV(kid->op_targ);
6864 name = SvPV_const(namesv, len);
6866 else if (kid->op_type == OP_RV2SV
6867 && kUNOP->op_first->op_type == OP_GV)
6869 GV * const gv = cGVOPx_gv(kUNOP->op_first);
6871 len = GvNAMELEN(gv);
6873 else if (kid->op_type == OP_AELEM
6874 || kid->op_type == OP_HELEM)
6877 OP *op = ((BINOP*)kid)->op_first;
6881 const char * const a =
6882 kid->op_type == OP_AELEM ?
6884 if (((op->op_type == OP_RV2AV) ||
6885 (op->op_type == OP_RV2HV)) &&
6886 (firstop = ((UNOP*)op)->op_first) &&
6887 (firstop->op_type == OP_GV)) {
6888 /* packagevar $a[] or $h{} */
6889 GV * const gv = cGVOPx_gv(firstop);
6897 else if (op->op_type == OP_PADAV
6898 || op->op_type == OP_PADHV) {
6899 /* lexicalvar $a[] or $h{} */
6900 const char * const padname =
6901 PAD_COMPNAME_PV(op->op_targ);
6910 name = SvPV_const(tmpstr, len);
6915 name = "__ANONIO__";
6922 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
6923 namesv = PAD_SVl(targ);
6924 SvUPGRADE(namesv, SVt_PV);
6926 sv_setpvn(namesv, "$", 1);
6927 sv_catpvn(namesv, name, len);
6930 kid->op_sibling = 0;
6931 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
6932 kid->op_targ = targ;
6933 kid->op_private |= priv;
6935 kid->op_sibling = sibl;
6941 mod(scalar(kid), type);
6945 tokid = &kid->op_sibling;
6946 kid = kid->op_sibling;
6949 if (kid && kid->op_type != OP_STUB)
6950 return too_many_arguments(o,OP_DESC(o));
6951 o->op_private |= numargs;
6953 /* FIXME - should the numargs move as for the PERL_MAD case? */
6954 o->op_private |= numargs;
6956 return too_many_arguments(o,OP_DESC(o));
6960 else if (PL_opargs[type] & OA_DEFGV) {
6962 OP *newop = newUNOP(type, 0, newDEFSVOP());
6963 op_getmad(o,newop,'O');
6966 /* Ordering of these two is important to keep f_map.t passing. */
6968 return newUNOP(type, 0, newDEFSVOP());
6973 while (oa & OA_OPTIONAL)
6975 if (oa && oa != OA_LIST)
6976 return too_few_arguments(o,OP_DESC(o));
6982 Perl_ck_glob(pTHX_ OP *o)
6987 PERL_ARGS_ASSERT_CK_GLOB;
6990 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
6991 append_elem(OP_GLOB, o, newDEFSVOP());
6993 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
6994 && GvCVu(gv) && GvIMPORTED_CV(gv)))
6996 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6999 #if !defined(PERL_EXTERNAL_GLOB)
7000 /* XXX this can be tightened up and made more failsafe. */
7001 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7004 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
7005 newSVpvs("File::Glob"), NULL, NULL, NULL);
7006 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7007 glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
7008 GvCV(gv) = GvCV(glob_gv);
7009 SvREFCNT_inc_void((SV*)GvCV(gv));
7010 GvIMPORTED_CV_on(gv);
7013 #endif /* PERL_EXTERNAL_GLOB */
7015 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7016 append_elem(OP_GLOB, o,
7017 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
7018 o->op_type = OP_LIST;
7019 o->op_ppaddr = PL_ppaddr[OP_LIST];
7020 cLISTOPo->op_first->op_type = OP_PUSHMARK;
7021 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
7022 cLISTOPo->op_first->op_targ = 0;
7023 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
7024 append_elem(OP_LIST, o,
7025 scalar(newUNOP(OP_RV2CV, 0,
7026 newGVOP(OP_GV, 0, gv)))));
7027 o = newUNOP(OP_NULL, 0, ck_subr(o));
7028 o->op_targ = OP_GLOB; /* hint at what it used to be */
7031 gv = newGVgen("main");
7033 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
7039 Perl_ck_grep(pTHX_ OP *o)
7044 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
7047 PERL_ARGS_ASSERT_CK_GREP;
7049 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
7050 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
7052 if (o->op_flags & OPf_STACKED) {
7055 kid = cLISTOPo->op_first->op_sibling;
7056 if (!cUNOPx(kid)->op_next)
7057 Perl_croak(aTHX_ "panic: ck_grep");
7058 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
7061 NewOp(1101, gwop, 1, LOGOP);
7062 kid->op_next = (OP*)gwop;
7063 o->op_flags &= ~OPf_STACKED;
7065 kid = cLISTOPo->op_first->op_sibling;
7066 if (type == OP_MAPWHILE)
7071 if (PL_parser && PL_parser->error_count)
7073 kid = cLISTOPo->op_first->op_sibling;
7074 if (kid->op_type != OP_NULL)
7075 Perl_croak(aTHX_ "panic: ck_grep");
7076 kid = kUNOP->op_first;
7079 NewOp(1101, gwop, 1, LOGOP);
7080 gwop->op_type = type;
7081 gwop->op_ppaddr = PL_ppaddr[type];
7082 gwop->op_first = listkids(o);
7083 gwop->op_flags |= OPf_KIDS;
7084 gwop->op_other = LINKLIST(kid);
7085 kid->op_next = (OP*)gwop;
7086 offset = pad_findmy("$_");
7087 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
7088 o->op_private = gwop->op_private = 0;
7089 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
7092 o->op_private = gwop->op_private = OPpGREP_LEX;
7093 gwop->op_targ = o->op_targ = offset;
7096 kid = cLISTOPo->op_first->op_sibling;
7097 if (!kid || !kid->op_sibling)
7098 return too_few_arguments(o,OP_DESC(o));
7099 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
7100 mod(kid, OP_GREPSTART);
7106 Perl_ck_index(pTHX_ OP *o)
7108 PERL_ARGS_ASSERT_CK_INDEX;
7110 if (o->op_flags & OPf_KIDS) {
7111 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7113 kid = kid->op_sibling; /* get past "big" */
7114 if (kid && kid->op_type == OP_CONST)
7115 fbm_compile(((SVOP*)kid)->op_sv, 0);
7121 Perl_ck_lengthconst(pTHX_ OP *o)
7123 PERL_ARGS_ASSERT_CK_LENGTHCONST;
7125 /* XXX length optimization goes here */
7130 Perl_ck_lfun(pTHX_ OP *o)
7132 const OPCODE type = o->op_type;
7134 PERL_ARGS_ASSERT_CK_LFUN;
7136 return modkids(ck_fun(o), type);
7140 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
7142 PERL_ARGS_ASSERT_CK_DEFINED;
7144 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
7145 switch (cUNOPo->op_first->op_type) {
7147 /* This is needed for
7148 if (defined %stash::)
7149 to work. Do not break Tk.
7151 break; /* Globals via GV can be undef */
7153 case OP_AASSIGN: /* Is this a good idea? */
7154 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
7155 "defined(@array) is deprecated");
7156 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
7157 "\t(Maybe you should just omit the defined()?)\n");
7160 /* This is needed for
7161 if (defined %stash::)
7162 to work. Do not break Tk.
7164 break; /* Globals via GV can be undef */
7166 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
7167 "defined(%%hash) is deprecated");
7168 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
7169 "\t(Maybe you should just omit the defined()?)\n");
7180 Perl_ck_readline(pTHX_ OP *o)
7182 PERL_ARGS_ASSERT_CK_READLINE;
7184 if (!(o->op_flags & OPf_KIDS)) {
7186 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
7188 op_getmad(o,newop,'O');
7198 Perl_ck_rfun(pTHX_ OP *o)
7200 const OPCODE type = o->op_type;
7202 PERL_ARGS_ASSERT_CK_RFUN;
7204 return refkids(ck_fun(o), type);
7208 Perl_ck_listiob(pTHX_ OP *o)
7212 PERL_ARGS_ASSERT_CK_LISTIOB;
7214 kid = cLISTOPo->op_first;
7217 kid = cLISTOPo->op_first;
7219 if (kid->op_type == OP_PUSHMARK)
7220 kid = kid->op_sibling;
7221 if (kid && o->op_flags & OPf_STACKED)
7222 kid = kid->op_sibling;
7223 else if (kid && !kid->op_sibling) { /* print HANDLE; */
7224 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
7225 o->op_flags |= OPf_STACKED; /* make it a filehandle */
7226 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
7227 cLISTOPo->op_first->op_sibling = kid;
7228 cLISTOPo->op_last = kid;
7229 kid = kid->op_sibling;
7234 append_elem(o->op_type, o, newDEFSVOP());
7240 Perl_ck_smartmatch(pTHX_ OP *o)
7243 if (0 == (o->op_flags & OPf_SPECIAL)) {
7244 OP *first = cBINOPo->op_first;
7245 OP *second = first->op_sibling;
7247 /* Implicitly take a reference to an array or hash */
7248 first->op_sibling = NULL;
7249 first = cBINOPo->op_first = ref_array_or_hash(first);
7250 second = first->op_sibling = ref_array_or_hash(second);
7252 /* Implicitly take a reference to a regular expression */
7253 if (first->op_type == OP_MATCH) {
7254 first->op_type = OP_QR;
7255 first->op_ppaddr = PL_ppaddr[OP_QR];
7257 if (second->op_type == OP_MATCH) {
7258 second->op_type = OP_QR;
7259 second->op_ppaddr = PL_ppaddr[OP_QR];
7268 Perl_ck_sassign(pTHX_ OP *o)
7271 OP * const kid = cLISTOPo->op_first;
7273 PERL_ARGS_ASSERT_CK_SASSIGN;
7275 /* has a disposable target? */
7276 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
7277 && !(kid->op_flags & OPf_STACKED)
7278 /* Cannot steal the second time! */
7279 && !(kid->op_private & OPpTARGET_MY)
7280 /* Keep the full thing for madskills */
7284 OP * const kkid = kid->op_sibling;
7286 /* Can just relocate the target. */
7287 if (kkid && kkid->op_type == OP_PADSV
7288 && !(kkid->op_private & OPpLVAL_INTRO))
7290 kid->op_targ = kkid->op_targ;
7292 /* Now we do not need PADSV and SASSIGN. */
7293 kid->op_sibling = o->op_sibling; /* NULL */
7294 cLISTOPo->op_first = NULL;
7297 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
7301 if (kid->op_sibling) {
7302 OP *kkid = kid->op_sibling;
7303 if (kkid->op_type == OP_PADSV
7304 && (kkid->op_private & OPpLVAL_INTRO)
7305 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
7306 const PADOFFSET target = kkid->op_targ;
7307 OP *const other = newOP(OP_PADSV,
7309 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
7310 OP *const first = newOP(OP_NULL, 0);
7311 OP *const nullop = newCONDOP(0, first, o, other);
7312 OP *const condop = first->op_next;
7313 /* hijacking PADSTALE for uninitialized state variables */
7314 SvPADSTALE_on(PAD_SVl(target));
7316 condop->op_type = OP_ONCE;
7317 condop->op_ppaddr = PL_ppaddr[OP_ONCE];
7318 condop->op_targ = target;
7319 other->op_targ = target;
7321 /* Because we change the type of the op here, we will skip the
7322 assinment binop->op_last = binop->op_first->op_sibling; at the
7323 end of Perl_newBINOP(). So need to do it here. */
7324 cBINOPo->op_last = cBINOPo->op_first->op_sibling;
7333 Perl_ck_match(pTHX_ OP *o)
7337 PERL_ARGS_ASSERT_CK_MATCH;
7339 if (o->op_type != OP_QR && PL_compcv) {
7340 const PADOFFSET offset = pad_findmy("$_");
7341 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
7342 o->op_targ = offset;
7343 o->op_private |= OPpTARGET_MY;
7346 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
7347 o->op_private |= OPpRUNTIME;
7352 Perl_ck_method(pTHX_ OP *o)
7354 OP * const kid = cUNOPo->op_first;
7356 PERL_ARGS_ASSERT_CK_METHOD;
7358 if (kid->op_type == OP_CONST) {
7359 SV* sv = kSVOP->op_sv;
7360 const char * const method = SvPVX_const(sv);
7361 if (!(strchr(method, ':') || strchr(method, '\''))) {
7363 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
7364 sv = newSVpvn_share(method, SvCUR(sv), 0);
7367 kSVOP->op_sv = NULL;
7369 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
7371 op_getmad(o,cmop,'O');
7382 Perl_ck_null(pTHX_ OP *o)
7384 PERL_ARGS_ASSERT_CK_NULL;
7385 PERL_UNUSED_CONTEXT;
7390 Perl_ck_open(pTHX_ OP *o)
7393 HV * const table = GvHV(PL_hintgv);
7395 PERL_ARGS_ASSERT_CK_OPEN;
7398 SV **svp = hv_fetchs(table, "open_IN", FALSE);
7400 const I32 mode = mode_from_discipline(*svp);
7401 if (mode & O_BINARY)
7402 o->op_private |= OPpOPEN_IN_RAW;
7403 else if (mode & O_TEXT)
7404 o->op_private |= OPpOPEN_IN_CRLF;
7407 svp = hv_fetchs(table, "open_OUT", FALSE);
7409 const I32 mode = mode_from_discipline(*svp);
7410 if (mode & O_BINARY)
7411 o->op_private |= OPpOPEN_OUT_RAW;
7412 else if (mode & O_TEXT)
7413 o->op_private |= OPpOPEN_OUT_CRLF;
7416 if (o->op_type == OP_BACKTICK) {
7417 if (!(o->op_flags & OPf_KIDS)) {
7418 OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
7420 op_getmad(o,newop,'O');
7429 /* In case of three-arg dup open remove strictness
7430 * from the last arg if it is a bareword. */
7431 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
7432 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
7436 if ((last->op_type == OP_CONST) && /* The bareword. */
7437 (last->op_private & OPpCONST_BARE) &&
7438 (last->op_private & OPpCONST_STRICT) &&
7439 (oa = first->op_sibling) && /* The fh. */
7440 (oa = oa->op_sibling) && /* The mode. */
7441 (oa->op_type == OP_CONST) &&
7442 SvPOK(((SVOP*)oa)->op_sv) &&
7443 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
7444 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
7445 (last == oa->op_sibling)) /* The bareword. */
7446 last->op_private &= ~OPpCONST_STRICT;
7452 Perl_ck_repeat(pTHX_ OP *o)
7454 PERL_ARGS_ASSERT_CK_REPEAT;
7456 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
7457 o->op_private |= OPpREPEAT_DOLIST;
7458 cBINOPo->op_first = force_list(cBINOPo->op_first);
7466 Perl_ck_require(pTHX_ OP *o)
7471 PERL_ARGS_ASSERT_CK_REQUIRE;
7473 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
7474 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7476 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
7477 SV * const sv = kid->op_sv;
7478 U32 was_readonly = SvREADONLY(sv);
7485 sv_force_normal_flags(sv, 0);
7486 assert(!SvREADONLY(sv));
7496 for (; s < end; s++) {
7497 if (*s == ':' && s[1] == ':') {
7499 Move(s+2, s+1, end - s - 1, char);
7504 sv_catpvs(sv, ".pm");
7505 SvFLAGS(sv) |= was_readonly;
7509 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
7510 /* handle override, if any */
7511 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
7512 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7513 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
7514 gv = gvp ? *gvp : NULL;
7518 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7519 OP * const kid = cUNOPo->op_first;
7522 cUNOPo->op_first = 0;
7526 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
7527 append_elem(OP_LIST, kid,
7528 scalar(newUNOP(OP_RV2CV, 0,
7531 op_getmad(o,newop,'O');
7539 Perl_ck_return(pTHX_ OP *o)
7543 PERL_ARGS_ASSERT_CK_RETURN;
7545 if (CvLVALUE(PL_compcv)) {
7547 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
7548 mod(kid, OP_LEAVESUBLV);
7554 Perl_ck_select(pTHX_ OP *o)
7559 PERL_ARGS_ASSERT_CK_SELECT;
7561 if (o->op_flags & OPf_KIDS) {
7562 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7563 if (kid && kid->op_sibling) {
7564 o->op_type = OP_SSELECT;
7565 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
7567 return fold_constants(o);
7571 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7572 if (kid && kid->op_type == OP_RV2GV)
7573 kid->op_private &= ~HINT_STRICT_REFS;
7578 Perl_ck_shift(pTHX_ OP *o)
7581 const I32 type = o->op_type;
7583 PERL_ARGS_ASSERT_CK_SHIFT;
7585 if (!(o->op_flags & OPf_KIDS)) {
7587 /* FIXME - this can be refactored to reduce code in #ifdefs */
7589 OP * const oldo = o;
7593 argop = newUNOP(OP_RV2AV, 0,
7594 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
7596 o = newUNOP(type, 0, scalar(argop));
7597 op_getmad(oldo,o,'O');
7600 return newUNOP(type, 0, scalar(argop));
7603 return scalar(modkids(ck_fun(o), type));
7607 Perl_ck_sort(pTHX_ OP *o)
7612 PERL_ARGS_ASSERT_CK_SORT;
7614 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
7615 HV * const hinthv = GvHV(PL_hintgv);
7617 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
7619 const I32 sorthints = (I32)SvIV(*svp);
7620 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
7621 o->op_private |= OPpSORT_QSORT;
7622 if ((sorthints & HINT_SORT_STABLE) != 0)
7623 o->op_private |= OPpSORT_STABLE;
7628 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
7630 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7631 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
7633 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
7635 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
7637 if (kid->op_type == OP_SCOPE) {
7641 else if (kid->op_type == OP_LEAVE) {
7642 if (o->op_type == OP_SORT) {
7643 op_null(kid); /* wipe out leave */
7646 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
7647 if (k->op_next == kid)
7649 /* don't descend into loops */
7650 else if (k->op_type == OP_ENTERLOOP
7651 || k->op_type == OP_ENTERITER)
7653 k = cLOOPx(k)->op_lastop;
7658 kid->op_next = 0; /* just disconnect the leave */
7659 k = kLISTOP->op_first;
7664 if (o->op_type == OP_SORT) {
7665 /* provide scalar context for comparison function/block */
7671 o->op_flags |= OPf_SPECIAL;
7673 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
7676 firstkid = firstkid->op_sibling;
7679 /* provide list context for arguments */
7680 if (o->op_type == OP_SORT)
7687 S_simplify_sort(pTHX_ OP *o)
7690 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7696 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
7698 if (!(o->op_flags & OPf_STACKED))
7700 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7701 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
7702 kid = kUNOP->op_first; /* get past null */
7703 if (kid->op_type != OP_SCOPE)
7705 kid = kLISTOP->op_last; /* get past scope */
7706 switch(kid->op_type) {
7714 k = kid; /* remember this node*/
7715 if (kBINOP->op_first->op_type != OP_RV2SV)
7717 kid = kBINOP->op_first; /* get past cmp */
7718 if (kUNOP->op_first->op_type != OP_GV)
7720 kid = kUNOP->op_first; /* get past rv2sv */
7722 if (GvSTASH(gv) != PL_curstash)
7724 gvname = GvNAME(gv);
7725 if (*gvname == 'a' && gvname[1] == '\0')
7727 else if (*gvname == 'b' && gvname[1] == '\0')
7732 kid = k; /* back to cmp */
7733 if (kBINOP->op_last->op_type != OP_RV2SV)
7735 kid = kBINOP->op_last; /* down to 2nd arg */
7736 if (kUNOP->op_first->op_type != OP_GV)
7738 kid = kUNOP->op_first; /* get past rv2sv */
7740 if (GvSTASH(gv) != PL_curstash)
7742 gvname = GvNAME(gv);
7744 ? !(*gvname == 'a' && gvname[1] == '\0')
7745 : !(*gvname == 'b' && gvname[1] == '\0'))
7747 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
7749 o->op_private |= OPpSORT_DESCEND;
7750 if (k->op_type == OP_NCMP)
7751 o->op_private |= OPpSORT_NUMERIC;
7752 if (k->op_type == OP_I_NCMP)
7753 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
7754 kid = cLISTOPo->op_first->op_sibling;
7755 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
7757 op_getmad(kid,o,'S'); /* then delete it */
7759 op_free(kid); /* then delete it */
7764 Perl_ck_split(pTHX_ OP *o)
7769 PERL_ARGS_ASSERT_CK_SPLIT;
7771 if (o->op_flags & OPf_STACKED)
7772 return no_fh_allowed(o);
7774 kid = cLISTOPo->op_first;
7775 if (kid->op_type != OP_NULL)
7776 Perl_croak(aTHX_ "panic: ck_split");
7777 kid = kid->op_sibling;
7778 op_free(cLISTOPo->op_first);
7779 cLISTOPo->op_first = kid;
7781 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
7782 cLISTOPo->op_last = kid; /* There was only one element previously */
7785 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
7786 OP * const sibl = kid->op_sibling;
7787 kid->op_sibling = 0;
7788 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
7789 if (cLISTOPo->op_first == cLISTOPo->op_last)
7790 cLISTOPo->op_last = kid;
7791 cLISTOPo->op_first = kid;
7792 kid->op_sibling = sibl;
7795 kid->op_type = OP_PUSHRE;
7796 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
7798 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
7799 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
7800 "Use of /g modifier is meaningless in split");
7803 if (!kid->op_sibling)
7804 append_elem(OP_SPLIT, o, newDEFSVOP());
7806 kid = kid->op_sibling;
7809 if (!kid->op_sibling)
7810 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
7811 assert(kid->op_sibling);
7813 kid = kid->op_sibling;
7816 if (kid->op_sibling)
7817 return too_many_arguments(o,OP_DESC(o));
7823 Perl_ck_join(pTHX_ OP *o)
7825 const OP * const kid = cLISTOPo->op_first->op_sibling;
7827 PERL_ARGS_ASSERT_CK_JOIN;
7829 if (kid && kid->op_type == OP_MATCH) {
7830 if (ckWARN(WARN_SYNTAX)) {
7831 const REGEXP *re = PM_GETRE(kPMOP);
7832 const char *pmstr = re ? RX_PRECOMP(re) : "STRING";
7833 const STRLEN len = re ? RX_PRELEN(re) : 6;
7834 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7835 "/%.*s/ should probably be written as \"%.*s\"",
7836 (int)len, pmstr, (int)len, pmstr);
7843 Perl_ck_subr(pTHX_ OP *o)
7846 OP *prev = ((cUNOPo->op_first->op_sibling)
7847 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
7848 OP *o2 = prev->op_sibling;
7850 const char *proto = NULL;
7851 const char *proto_end = NULL;
7856 I32 contextclass = 0;
7857 const char *e = NULL;
7860 PERL_ARGS_ASSERT_CK_SUBR;
7862 o->op_private |= OPpENTERSUB_HASTARG;
7863 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
7864 if (cvop->op_type == OP_RV2CV) {
7866 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
7867 op_null(cvop); /* disable rv2cv */
7868 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
7869 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
7870 GV *gv = cGVOPx_gv(tmpop);
7873 tmpop->op_private |= OPpEARLY_CV;
7877 namegv = CvANON(cv) ? gv : CvGV(cv);
7878 proto = SvPV((SV*)cv, len);
7879 proto_end = proto + len;
7884 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7885 if (o2->op_type == OP_CONST)
7886 o2->op_private &= ~OPpCONST_STRICT;
7887 else if (o2->op_type == OP_LIST) {
7888 OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
7889 if (sib && sib->op_type == OP_CONST)
7890 sib->op_private &= ~OPpCONST_STRICT;
7893 o->op_private |= (PL_hints & HINT_STRICT_REFS);
7894 if (PERLDB_SUB && PL_curstash != PL_debstash)
7895 o->op_private |= OPpENTERSUB_DB;
7896 while (o2 != cvop) {
7898 if (PL_madskills && o2->op_type == OP_STUB) {
7899 o2 = o2->op_sibling;
7902 if (PL_madskills && o2->op_type == OP_NULL)
7903 o3 = ((UNOP*)o2)->op_first;
7907 if (proto >= proto_end)
7908 return too_many_arguments(o, gv_ename(namegv));
7916 /* _ must be at the end */
7917 if (proto[1] && proto[1] != ';')
7932 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
7934 arg == 1 ? "block or sub {}" : "sub {}",
7935 gv_ename(namegv), o3);
7938 /* '*' allows any scalar type, including bareword */
7941 if (o3->op_type == OP_RV2GV)
7942 goto wrapref; /* autoconvert GLOB -> GLOBref */
7943 else if (o3->op_type == OP_CONST)
7944 o3->op_private &= ~OPpCONST_STRICT;
7945 else if (o3->op_type == OP_ENTERSUB) {
7946 /* accidental subroutine, revert to bareword */
7947 OP *gvop = ((UNOP*)o3)->op_first;
7948 if (gvop && gvop->op_type == OP_NULL) {
7949 gvop = ((UNOP*)gvop)->op_first;
7951 for (; gvop->op_sibling; gvop = gvop->op_sibling)
7954 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
7955 (gvop = ((UNOP*)gvop)->op_first) &&
7956 gvop->op_type == OP_GV)
7958 GV * const gv = cGVOPx_gv(gvop);
7959 OP * const sibling = o2->op_sibling;
7960 SV * const n = newSVpvs("");
7962 OP * const oldo2 = o2;
7966 gv_fullname4(n, gv, "", FALSE);
7967 o2 = newSVOP(OP_CONST, 0, n);
7968 op_getmad(oldo2,o2,'O');
7969 prev->op_sibling = o2;
7970 o2->op_sibling = sibling;
7986 if (contextclass++ == 0) {
7987 e = strchr(proto, ']');
7988 if (!e || e == proto)
7997 const char *p = proto;
7998 const char *const end = proto;
8000 while (*--p != '[');
8001 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
8003 gv_ename(namegv), o3);
8008 if (o3->op_type == OP_RV2GV)
8011 bad_type(arg, "symbol", gv_ename(namegv), o3);
8014 if (o3->op_type == OP_ENTERSUB)
8017 bad_type(arg, "subroutine entry", gv_ename(namegv),
8021 if (o3->op_type == OP_RV2SV ||
8022 o3->op_type == OP_PADSV ||
8023 o3->op_type == OP_HELEM ||
8024 o3->op_type == OP_AELEM)
8027 bad_type(arg, "scalar", gv_ename(namegv), o3);
8030 if (o3->op_type == OP_RV2AV ||
8031 o3->op_type == OP_PADAV)
8034 bad_type(arg, "array", gv_ename(namegv), o3);
8037 if (o3->op_type == OP_RV2HV ||
8038 o3->op_type == OP_PADHV)
8041 bad_type(arg, "hash", gv_ename(namegv), o3);
8046 OP* const sib = kid->op_sibling;
8047 kid->op_sibling = 0;
8048 o2 = newUNOP(OP_REFGEN, 0, kid);
8049 o2->op_sibling = sib;
8050 prev->op_sibling = o2;
8052 if (contextclass && e) {
8067 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
8068 gv_ename(namegv), SVfARG(cv));
8073 mod(o2, OP_ENTERSUB);
8075 o2 = o2->op_sibling;
8077 if (o2 == cvop && proto && *proto == '_') {
8078 /* generate an access to $_ */
8080 o2->op_sibling = prev->op_sibling;
8081 prev->op_sibling = o2; /* instead of cvop */
8083 if (proto && !optional && proto_end > proto &&
8084 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
8085 return too_few_arguments(o, gv_ename(namegv));
8088 OP * const oldo = o;
8092 o=newSVOP(OP_CONST, 0, newSViv(0));
8093 op_getmad(oldo,o,'O');
8099 Perl_ck_svconst(pTHX_ OP *o)
8101 PERL_ARGS_ASSERT_CK_SVCONST;
8102 PERL_UNUSED_CONTEXT;
8103 SvREADONLY_on(cSVOPo->op_sv);
8108 Perl_ck_chdir(pTHX_ OP *o)
8110 if (o->op_flags & OPf_KIDS) {
8111 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8113 if (kid && kid->op_type == OP_CONST &&
8114 (kid->op_private & OPpCONST_BARE))
8116 o->op_flags |= OPf_SPECIAL;
8117 kid->op_private &= ~OPpCONST_STRICT;
8124 Perl_ck_trunc(pTHX_ OP *o)
8126 PERL_ARGS_ASSERT_CK_TRUNC;
8128 if (o->op_flags & OPf_KIDS) {
8129 SVOP *kid = (SVOP*)cUNOPo->op_first;
8131 if (kid->op_type == OP_NULL)
8132 kid = (SVOP*)kid->op_sibling;
8133 if (kid && kid->op_type == OP_CONST &&
8134 (kid->op_private & OPpCONST_BARE))
8136 o->op_flags |= OPf_SPECIAL;
8137 kid->op_private &= ~OPpCONST_STRICT;
8144 Perl_ck_unpack(pTHX_ OP *o)
8146 OP *kid = cLISTOPo->op_first;
8148 PERL_ARGS_ASSERT_CK_UNPACK;
8150 if (kid->op_sibling) {
8151 kid = kid->op_sibling;
8152 if (!kid->op_sibling)
8153 kid->op_sibling = newDEFSVOP();
8159 Perl_ck_substr(pTHX_ OP *o)
8161 PERL_ARGS_ASSERT_CK_SUBSTR;
8164 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
8165 OP *kid = cLISTOPo->op_first;
8167 if (kid->op_type == OP_NULL)
8168 kid = kid->op_sibling;
8170 kid->op_flags |= OPf_MOD;
8177 Perl_ck_each(pTHX_ OP *o)
8180 OP *kid = cLISTOPo->op_first;
8182 PERL_ARGS_ASSERT_CK_EACH;
8184 if (kid->op_type == OP_PADAV || kid->op_type == OP_RV2AV) {
8185 const unsigned new_type = o->op_type == OP_EACH ? OP_AEACH
8186 : o->op_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
8187 o->op_type = new_type;
8188 o->op_ppaddr = PL_ppaddr[new_type];
8190 else if (!(kid->op_type == OP_PADHV || kid->op_type == OP_RV2HV
8191 || (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE)
8193 bad_type(1, "hash or array", PL_op_desc[o->op_type], kid);
8199 /* A peephole optimizer. We visit the ops in the order they're to execute.
8200 * See the comments at the top of this file for more details about when
8201 * peep() is called */
8204 Perl_peep(pTHX_ register OP *o)
8207 register OP* oldop = NULL;
8209 if (!o || o->op_opt)
8213 SAVEVPTR(PL_curcop);
8214 for (; o; o = o->op_next) {
8217 /* By default, this op has now been optimised. A couple of cases below
8218 clear this again. */
8221 switch (o->op_type) {
8224 PL_curcop = ((COP*)o); /* for warnings */
8228 if (cSVOPo->op_private & OPpCONST_STRICT)
8229 no_bareword_allowed(o);
8231 case OP_METHOD_NAMED:
8232 /* Relocate sv to the pad for thread safety.
8233 * Despite being a "constant", the SV is written to,
8234 * for reference counts, sv_upgrade() etc. */
8236 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
8237 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
8238 /* If op_sv is already a PADTMP then it is being used by
8239 * some pad, so make a copy. */
8240 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
8241 SvREADONLY_on(PAD_SVl(ix));
8242 SvREFCNT_dec(cSVOPo->op_sv);
8244 else if (o->op_type == OP_CONST
8245 && cSVOPo->op_sv == &PL_sv_undef) {
8246 /* PL_sv_undef is hack - it's unsafe to store it in the
8247 AV that is the pad, because av_fetch treats values of
8248 PL_sv_undef as a "free" AV entry and will merrily
8249 replace them with a new SV, causing pad_alloc to think
8250 that this pad slot is free. (When, clearly, it is not)
8252 SvOK_off(PAD_SVl(ix));
8253 SvPADTMP_on(PAD_SVl(ix));
8254 SvREADONLY_on(PAD_SVl(ix));
8257 SvREFCNT_dec(PAD_SVl(ix));
8258 SvPADTMP_on(cSVOPo->op_sv);
8259 PAD_SETSV(ix, cSVOPo->op_sv);
8260 /* XXX I don't know how this isn't readonly already. */
8261 SvREADONLY_on(PAD_SVl(ix));
8263 cSVOPo->op_sv = NULL;
8270 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
8271 if (o->op_next->op_private & OPpTARGET_MY) {
8272 if (o->op_flags & OPf_STACKED) /* chained concats */
8273 break; /* ignore_optimization */
8275 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
8276 o->op_targ = o->op_next->op_targ;
8277 o->op_next->op_targ = 0;
8278 o->op_private |= OPpTARGET_MY;
8281 op_null(o->op_next);
8285 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
8286 break; /* Scalar stub must produce undef. List stub is noop */
8290 if (o->op_targ == OP_NEXTSTATE
8291 || o->op_targ == OP_DBSTATE)
8293 PL_curcop = ((COP*)o);
8295 /* XXX: We avoid setting op_seq here to prevent later calls
8296 to peep() from mistakenly concluding that optimisation
8297 has already occurred. This doesn't fix the real problem,
8298 though (See 20010220.007). AMS 20010719 */
8299 /* op_seq functionality is now replaced by op_opt */
8306 if (oldop && o->op_next) {
8307 oldop->op_next = o->op_next;
8315 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
8316 OP* const pop = (o->op_type == OP_PADAV) ?
8317 o->op_next : o->op_next->op_next;
8319 if (pop && pop->op_type == OP_CONST &&
8320 ((PL_op = pop->op_next)) &&
8321 pop->op_next->op_type == OP_AELEM &&
8322 !(pop->op_next->op_private &
8323 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
8324 (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
8329 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
8330 no_bareword_allowed(pop);
8331 if (o->op_type == OP_GV)
8332 op_null(o->op_next);
8333 op_null(pop->op_next);
8335 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
8336 o->op_next = pop->op_next->op_next;
8337 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
8338 o->op_private = (U8)i;
8339 if (o->op_type == OP_GV) {
8344 o->op_flags |= OPf_SPECIAL;
8345 o->op_type = OP_AELEMFAST;
8350 if (o->op_next->op_type == OP_RV2SV) {
8351 if (!(o->op_next->op_private & OPpDEREF)) {
8352 op_null(o->op_next);
8353 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
8355 o->op_next = o->op_next->op_next;
8356 o->op_type = OP_GVSV;
8357 o->op_ppaddr = PL_ppaddr[OP_GVSV];
8360 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
8361 GV * const gv = cGVOPo_gv;
8362 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
8363 /* XXX could check prototype here instead of just carping */
8364 SV * const sv = sv_newmortal();
8365 gv_efullname3(sv, gv, NULL);
8366 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
8367 "%"SVf"() called too early to check prototype",
8371 else if (o->op_next->op_type == OP_READLINE
8372 && o->op_next->op_next->op_type == OP_CONCAT
8373 && (o->op_next->op_next->op_flags & OPf_STACKED))
8375 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
8376 o->op_type = OP_RCATLINE;
8377 o->op_flags |= OPf_STACKED;
8378 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
8379 op_null(o->op_next->op_next);
8380 op_null(o->op_next);
8396 while (cLOGOP->op_other->op_type == OP_NULL)
8397 cLOGOP->op_other = cLOGOP->op_other->op_next;
8398 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
8403 while (cLOOP->op_redoop->op_type == OP_NULL)
8404 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
8405 peep(cLOOP->op_redoop);
8406 while (cLOOP->op_nextop->op_type == OP_NULL)
8407 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
8408 peep(cLOOP->op_nextop);
8409 while (cLOOP->op_lastop->op_type == OP_NULL)
8410 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
8411 peep(cLOOP->op_lastop);
8415 assert(!(cPMOP->op_pmflags & PMf_ONCE));
8416 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
8417 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
8418 cPMOP->op_pmstashstartu.op_pmreplstart
8419 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
8420 peep(cPMOP->op_pmstashstartu.op_pmreplstart);
8424 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
8425 && ckWARN(WARN_SYNTAX))
8427 if (o->op_next->op_sibling) {
8428 const OPCODE type = o->op_next->op_sibling->op_type;
8429 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
8430 const line_t oldline = CopLINE(PL_curcop);
8431 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
8432 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8433 "Statement unlikely to be reached");
8434 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8435 "\t(Maybe you meant system() when you said exec()?)\n");
8436 CopLINE_set(PL_curcop, oldline);
8447 const char *key = NULL;
8450 if (((BINOP*)o)->op_last->op_type != OP_CONST)
8453 /* Make the CONST have a shared SV */
8454 svp = cSVOPx_svp(((BINOP*)o)->op_last);
8455 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
8456 key = SvPV_const(sv, keylen);
8457 lexname = newSVpvn_share(key,
8458 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
8464 if ((o->op_private & (OPpLVAL_INTRO)))
8467 rop = (UNOP*)((BINOP*)o)->op_first;
8468 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
8470 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
8471 if (!SvPAD_TYPED(lexname))
8473 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8474 if (!fields || !GvHV(*fields))
8476 key = SvPV_const(*svp, keylen);
8477 if (!hv_fetch(GvHV(*fields), key,
8478 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8480 Perl_croak(aTHX_ "No such class field \"%s\" "
8481 "in variable %s of type %s",
8482 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
8495 SVOP *first_key_op, *key_op;
8497 if ((o->op_private & (OPpLVAL_INTRO))
8498 /* I bet there's always a pushmark... */
8499 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
8500 /* hmmm, no optimization if list contains only one key. */
8502 rop = (UNOP*)((LISTOP*)o)->op_last;
8503 if (rop->op_type != OP_RV2HV)
8505 if (rop->op_first->op_type == OP_PADSV)
8506 /* @$hash{qw(keys here)} */
8507 rop = (UNOP*)rop->op_first;
8509 /* @{$hash}{qw(keys here)} */
8510 if (rop->op_first->op_type == OP_SCOPE
8511 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
8513 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
8519 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
8520 if (!SvPAD_TYPED(lexname))
8522 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8523 if (!fields || !GvHV(*fields))
8525 /* Again guessing that the pushmark can be jumped over.... */
8526 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
8527 ->op_first->op_sibling;
8528 for (key_op = first_key_op; key_op;
8529 key_op = (SVOP*)key_op->op_sibling) {
8530 if (key_op->op_type != OP_CONST)
8532 svp = cSVOPx_svp(key_op);
8533 key = SvPV_const(*svp, keylen);
8534 if (!hv_fetch(GvHV(*fields), key,
8535 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8537 Perl_croak(aTHX_ "No such class field \"%s\" "
8538 "in variable %s of type %s",
8539 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
8546 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
8550 /* check that RHS of sort is a single plain array */
8551 OP *oright = cUNOPo->op_first;
8552 if (!oright || oright->op_type != OP_PUSHMARK)
8555 /* reverse sort ... can be optimised. */
8556 if (!cUNOPo->op_sibling) {
8557 /* Nothing follows us on the list. */
8558 OP * const reverse = o->op_next;
8560 if (reverse->op_type == OP_REVERSE &&
8561 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
8562 OP * const pushmark = cUNOPx(reverse)->op_first;
8563 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
8564 && (cUNOPx(pushmark)->op_sibling == o)) {
8565 /* reverse -> pushmark -> sort */
8566 o->op_private |= OPpSORT_REVERSE;
8568 pushmark->op_next = oright->op_next;
8574 /* make @a = sort @a act in-place */
8576 oright = cUNOPx(oright)->op_sibling;
8579 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
8580 oright = cUNOPx(oright)->op_sibling;
8584 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
8585 || oright->op_next != o
8586 || (oright->op_private & OPpLVAL_INTRO)
8590 /* o2 follows the chain of op_nexts through the LHS of the
8591 * assign (if any) to the aassign op itself */
8593 if (!o2 || o2->op_type != OP_NULL)
8596 if (!o2 || o2->op_type != OP_PUSHMARK)
8599 if (o2 && o2->op_type == OP_GV)
8602 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
8603 || (o2->op_private & OPpLVAL_INTRO)
8608 if (!o2 || o2->op_type != OP_NULL)
8611 if (!o2 || o2->op_type != OP_AASSIGN
8612 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
8615 /* check that the sort is the first arg on RHS of assign */
8617 o2 = cUNOPx(o2)->op_first;
8618 if (!o2 || o2->op_type != OP_NULL)
8620 o2 = cUNOPx(o2)->op_first;
8621 if (!o2 || o2->op_type != OP_PUSHMARK)
8623 if (o2->op_sibling != o)
8626 /* check the array is the same on both sides */
8627 if (oleft->op_type == OP_RV2AV) {
8628 if (oright->op_type != OP_RV2AV
8629 || !cUNOPx(oright)->op_first
8630 || cUNOPx(oright)->op_first->op_type != OP_GV
8631 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
8632 cGVOPx_gv(cUNOPx(oright)->op_first)
8636 else if (oright->op_type != OP_PADAV
8637 || oright->op_targ != oleft->op_targ
8641 /* transfer MODishness etc from LHS arg to RHS arg */
8642 oright->op_flags = oleft->op_flags;
8643 o->op_private |= OPpSORT_INPLACE;
8645 /* excise push->gv->rv2av->null->aassign */
8646 o2 = o->op_next->op_next;
8647 op_null(o2); /* PUSHMARK */
8649 if (o2->op_type == OP_GV) {
8650 op_null(o2); /* GV */
8653 op_null(o2); /* RV2AV or PADAV */
8654 o2 = o2->op_next->op_next;
8655 op_null(o2); /* AASSIGN */
8657 o->op_next = o2->op_next;
8663 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
8665 LISTOP *enter, *exlist;
8667 enter = (LISTOP *) o->op_next;
8670 if (enter->op_type == OP_NULL) {
8671 enter = (LISTOP *) enter->op_next;
8675 /* for $a (...) will have OP_GV then OP_RV2GV here.
8676 for (...) just has an OP_GV. */
8677 if (enter->op_type == OP_GV) {
8678 gvop = (OP *) enter;
8679 enter = (LISTOP *) enter->op_next;
8682 if (enter->op_type == OP_RV2GV) {
8683 enter = (LISTOP *) enter->op_next;
8689 if (enter->op_type != OP_ENTERITER)
8692 iter = enter->op_next;
8693 if (!iter || iter->op_type != OP_ITER)
8696 expushmark = enter->op_first;
8697 if (!expushmark || expushmark->op_type != OP_NULL
8698 || expushmark->op_targ != OP_PUSHMARK)
8701 exlist = (LISTOP *) expushmark->op_sibling;
8702 if (!exlist || exlist->op_type != OP_NULL
8703 || exlist->op_targ != OP_LIST)
8706 if (exlist->op_last != o) {
8707 /* Mmm. Was expecting to point back to this op. */
8710 theirmark = exlist->op_first;
8711 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
8714 if (theirmark->op_sibling != o) {
8715 /* There's something between the mark and the reverse, eg
8716 for (1, reverse (...))
8721 ourmark = ((LISTOP *)o)->op_first;
8722 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
8725 ourlast = ((LISTOP *)o)->op_last;
8726 if (!ourlast || ourlast->op_next != o)
8729 rv2av = ourmark->op_sibling;
8730 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
8731 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
8732 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
8733 /* We're just reversing a single array. */
8734 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
8735 enter->op_flags |= OPf_STACKED;
8738 /* We don't have control over who points to theirmark, so sacrifice
8740 theirmark->op_next = ourmark->op_next;
8741 theirmark->op_flags = ourmark->op_flags;
8742 ourlast->op_next = gvop ? gvop : (OP *) enter;
8745 enter->op_private |= OPpITER_REVERSED;
8746 iter->op_private |= OPpITER_REVERSED;
8753 UNOP *refgen, *rv2cv;
8756 if ((o->op_flags & OPf_WANT) != OPf_WANT_VOID)
8759 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
8762 rv2gv = ((BINOP *)o)->op_last;
8763 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
8766 refgen = (UNOP *)((BINOP *)o)->op_first;
8768 if (!refgen || refgen->op_type != OP_REFGEN)
8771 exlist = (LISTOP *)refgen->op_first;
8772 if (!exlist || exlist->op_type != OP_NULL
8773 || exlist->op_targ != OP_LIST)
8776 if (exlist->op_first->op_type != OP_PUSHMARK)
8779 rv2cv = (UNOP*)exlist->op_last;
8781 if (rv2cv->op_type != OP_RV2CV)
8784 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
8785 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
8786 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
8788 o->op_private |= OPpASSIGN_CV_TO_GV;
8789 rv2gv->op_private |= OPpDONT_INIT_GV;
8790 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
8798 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
8799 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
8809 Perl_custom_op_name(pTHX_ const OP* o)
8812 const IV index = PTR2IV(o->op_ppaddr);
8816 PERL_ARGS_ASSERT_CUSTOM_OP_NAME;
8818 if (!PL_custom_op_names) /* This probably shouldn't happen */
8819 return (char *)PL_op_name[OP_CUSTOM];
8821 keysv = sv_2mortal(newSViv(index));
8823 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
8825 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
8827 return SvPV_nolen(HeVAL(he));
8831 Perl_custom_op_desc(pTHX_ const OP* o)
8834 const IV index = PTR2IV(o->op_ppaddr);
8838 PERL_ARGS_ASSERT_CUSTOM_OP_DESC;
8840 if (!PL_custom_op_descs)
8841 return (char *)PL_op_desc[OP_CUSTOM];
8843 keysv = sv_2mortal(newSViv(index));
8845 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
8847 return (char *)PL_op_desc[OP_CUSTOM];
8849 return SvPV_nolen(HeVAL(he));
8854 /* Efficient sub that returns a constant scalar value. */
8856 const_sv_xsub(pTHX_ CV* cv)
8863 Perl_croak(aTHX_ "usage: %s::%s()",
8864 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
8868 ST(0) = (SV*)XSANY.any_ptr;
8874 * c-indentation-style: bsd
8876 * indent-tabs-mode: t
8879 * ex: set ts=8 sts=4 sw=4 noet: