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 SV* msv = newSVpvf("a constant (%"SVf")", sv);
1079 useless = SvPV_nolen(msv);
1080 if (o->op_private & OPpCONST_ARYBASE)
1082 /* don't warn on optimised away booleans, eg
1083 * use constant Foo, 5; Foo || print; */
1084 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1086 /* the constants 0 and 1 are permitted as they are
1087 conventionally used as dummies in constructs like
1088 1 while some_condition_with_side_effects; */
1089 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1091 else if (SvPOK(sv)) {
1092 /* perl4's way of mixing documentation and code
1093 (before the invention of POD) was based on a
1094 trick to mix nroff and perl code. The trick was
1095 built upon these three nroff macros being used in
1096 void context. The pink camel has the details in
1097 the script wrapman near page 319. */
1098 const char * const maybe_macro = SvPVX_const(sv);
1099 if (strnEQ(maybe_macro, "di", 2) ||
1100 strnEQ(maybe_macro, "ds", 2) ||
1101 strnEQ(maybe_macro, "ig", 2))
1106 op_null(o); /* don't execute or even remember it */
1110 o->op_type = OP_PREINC; /* pre-increment is faster */
1111 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1115 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1116 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1120 o->op_type = OP_I_PREINC; /* pre-increment is faster */
1121 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1125 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
1126 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1135 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1140 if (o->op_flags & OPf_STACKED)
1147 if (!(o->op_flags & OPf_KIDS))
1158 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1165 /* all requires must return a boolean value */
1166 o->op_flags &= ~OPf_WANT;
1171 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
1172 if (!kPMOP->op_pmreplrootu.op_pmreplroot)
1173 deprecate_old("implicit split to @_");
1177 if (useless && ckWARN(WARN_VOID))
1178 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
1183 Perl_listkids(pTHX_ OP *o)
1185 if (o && o->op_flags & OPf_KIDS) {
1187 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1194 Perl_list(pTHX_ OP *o)
1199 /* assumes no premature commitment */
1200 if (!o || (o->op_flags & OPf_WANT)
1201 || (PL_parser && PL_parser->error_count)
1202 || o->op_type == OP_RETURN)
1207 if ((o->op_private & OPpTARGET_MY)
1208 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1210 return o; /* As if inside SASSIGN */
1213 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1215 switch (o->op_type) {
1218 list(cBINOPo->op_first);
1223 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1231 if (!(o->op_flags & OPf_KIDS))
1233 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1234 list(cBINOPo->op_first);
1235 return gen_constant_list(o);
1242 kid = cLISTOPo->op_first;
1244 while ((kid = kid->op_sibling)) {
1245 if (kid->op_sibling)
1250 PL_curcop = &PL_compiling;
1254 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1255 if (kid->op_sibling)
1260 PL_curcop = &PL_compiling;
1263 /* all requires must return a boolean value */
1264 o->op_flags &= ~OPf_WANT;
1271 Perl_scalarseq(pTHX_ OP *o)
1275 const OPCODE type = o->op_type;
1277 if (type == OP_LINESEQ || type == OP_SCOPE ||
1278 type == OP_LEAVE || type == OP_LEAVETRY)
1281 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1282 if (kid->op_sibling) {
1286 PL_curcop = &PL_compiling;
1288 o->op_flags &= ~OPf_PARENS;
1289 if (PL_hints & HINT_BLOCK_SCOPE)
1290 o->op_flags |= OPf_PARENS;
1293 o = newOP(OP_STUB, 0);
1298 S_modkids(pTHX_ OP *o, I32 type)
1300 if (o && o->op_flags & OPf_KIDS) {
1302 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1308 /* Propagate lvalue ("modifiable") context to an op and its children.
1309 * 'type' represents the context type, roughly based on the type of op that
1310 * would do the modifying, although local() is represented by OP_NULL.
1311 * It's responsible for detecting things that can't be modified, flag
1312 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
1313 * might have to vivify a reference in $x), and so on.
1315 * For example, "$a+1 = 2" would cause mod() to be called with o being
1316 * OP_ADD and type being OP_SASSIGN, and would output an error.
1320 Perl_mod(pTHX_ OP *o, I32 type)
1324 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1327 if (!o || (PL_parser && PL_parser->error_count))
1330 if ((o->op_private & OPpTARGET_MY)
1331 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1336 switch (o->op_type) {
1342 if (!(o->op_private & OPpCONST_ARYBASE))
1345 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1346 CopARYBASE_set(&PL_compiling,
1347 (I32)SvIV(cSVOPx(PL_eval_start)->op_sv));
1351 SAVECOPARYBASE(&PL_compiling);
1352 CopARYBASE_set(&PL_compiling, 0);
1354 else if (type == OP_REFGEN)
1357 Perl_croak(aTHX_ "That use of $[ is unsupported");
1360 if ((o->op_flags & OPf_PARENS) || PL_madskills)
1364 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1365 !(o->op_flags & OPf_STACKED)) {
1366 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1367 /* The default is to set op_private to the number of children,
1368 which for a UNOP such as RV2CV is always 1. And w're using
1369 the bit for a flag in RV2CV, so we need it clear. */
1370 o->op_private &= ~1;
1371 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1372 assert(cUNOPo->op_first->op_type == OP_NULL);
1373 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1376 else if (o->op_private & OPpENTERSUB_NOMOD)
1378 else { /* lvalue subroutine call */
1379 o->op_private |= OPpLVAL_INTRO;
1380 PL_modcount = RETURN_UNLIMITED_NUMBER;
1381 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1382 /* Backward compatibility mode: */
1383 o->op_private |= OPpENTERSUB_INARGS;
1386 else { /* Compile-time error message: */
1387 OP *kid = cUNOPo->op_first;
1391 if (kid->op_type != OP_PUSHMARK) {
1392 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1394 "panic: unexpected lvalue entersub "
1395 "args: type/targ %ld:%"UVuf,
1396 (long)kid->op_type, (UV)kid->op_targ);
1397 kid = kLISTOP->op_first;
1399 while (kid->op_sibling)
1400 kid = kid->op_sibling;
1401 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1403 if (kid->op_type == OP_METHOD_NAMED
1404 || kid->op_type == OP_METHOD)
1408 NewOp(1101, newop, 1, UNOP);
1409 newop->op_type = OP_RV2CV;
1410 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1411 newop->op_first = NULL;
1412 newop->op_next = (OP*)newop;
1413 kid->op_sibling = (OP*)newop;
1414 newop->op_private |= OPpLVAL_INTRO;
1415 newop->op_private &= ~1;
1419 if (kid->op_type != OP_RV2CV)
1421 "panic: unexpected lvalue entersub "
1422 "entry via type/targ %ld:%"UVuf,
1423 (long)kid->op_type, (UV)kid->op_targ);
1424 kid->op_private |= OPpLVAL_INTRO;
1425 break; /* Postpone until runtime */
1429 kid = kUNOP->op_first;
1430 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1431 kid = kUNOP->op_first;
1432 if (kid->op_type == OP_NULL)
1434 "Unexpected constant lvalue entersub "
1435 "entry via type/targ %ld:%"UVuf,
1436 (long)kid->op_type, (UV)kid->op_targ);
1437 if (kid->op_type != OP_GV) {
1438 /* Restore RV2CV to check lvalueness */
1440 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1441 okid->op_next = kid->op_next;
1442 kid->op_next = okid;
1445 okid->op_next = NULL;
1446 okid->op_type = OP_RV2CV;
1448 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1449 okid->op_private |= OPpLVAL_INTRO;
1450 okid->op_private &= ~1;
1454 cv = GvCV(kGVOP_gv);
1464 /* grep, foreach, subcalls, refgen */
1465 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1467 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1468 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1470 : (o->op_type == OP_ENTERSUB
1471 ? "non-lvalue subroutine call"
1473 type ? PL_op_desc[type] : "local"));
1487 case OP_RIGHT_SHIFT:
1496 if (!(o->op_flags & OPf_STACKED))
1503 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1509 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1510 PL_modcount = RETURN_UNLIMITED_NUMBER;
1511 return o; /* Treat \(@foo) like ordinary list. */
1515 if (scalar_mod_type(o, type))
1517 ref(cUNOPo->op_first, o->op_type);
1521 if (type == OP_LEAVESUBLV)
1522 o->op_private |= OPpMAYBE_LVSUB;
1528 PL_modcount = RETURN_UNLIMITED_NUMBER;
1531 ref(cUNOPo->op_first, o->op_type);
1536 PL_hints |= HINT_BLOCK_SCOPE;
1551 PL_modcount = RETURN_UNLIMITED_NUMBER;
1552 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1553 return o; /* Treat \(@foo) like ordinary list. */
1554 if (scalar_mod_type(o, type))
1556 if (type == OP_LEAVESUBLV)
1557 o->op_private |= OPpMAYBE_LVSUB;
1561 if (!type) /* local() */
1562 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1563 PAD_COMPNAME_PV(o->op_targ));
1571 if (type != OP_SASSIGN)
1575 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1580 if (type == OP_LEAVESUBLV)
1581 o->op_private |= OPpMAYBE_LVSUB;
1583 pad_free(o->op_targ);
1584 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1585 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1586 if (o->op_flags & OPf_KIDS)
1587 mod(cBINOPo->op_first->op_sibling, type);
1592 ref(cBINOPo->op_first, o->op_type);
1593 if (type == OP_ENTERSUB &&
1594 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1595 o->op_private |= OPpLVAL_DEFER;
1596 if (type == OP_LEAVESUBLV)
1597 o->op_private |= OPpMAYBE_LVSUB;
1607 if (o->op_flags & OPf_KIDS)
1608 mod(cLISTOPo->op_last, type);
1613 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1615 else if (!(o->op_flags & OPf_KIDS))
1617 if (o->op_targ != OP_LIST) {
1618 mod(cBINOPo->op_first, type);
1624 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1629 if (type != OP_LEAVESUBLV)
1631 break; /* mod()ing was handled by ck_return() */
1634 /* [20011101.069] File test operators interpret OPf_REF to mean that
1635 their argument is a filehandle; thus \stat(".") should not set
1637 if (type == OP_REFGEN &&
1638 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1641 if (type != OP_LEAVESUBLV)
1642 o->op_flags |= OPf_MOD;
1644 if (type == OP_AASSIGN || type == OP_SASSIGN)
1645 o->op_flags |= OPf_SPECIAL|OPf_REF;
1646 else if (!type) { /* local() */
1649 o->op_private |= OPpLVAL_INTRO;
1650 o->op_flags &= ~OPf_SPECIAL;
1651 PL_hints |= HINT_BLOCK_SCOPE;
1656 if (ckWARN(WARN_SYNTAX)) {
1657 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1658 "Useless localization of %s", OP_DESC(o));
1662 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1663 && type != OP_LEAVESUBLV)
1664 o->op_flags |= OPf_REF;
1669 S_scalar_mod_type(const OP *o, I32 type)
1671 PERL_ARGS_ASSERT_SCALAR_MOD_TYPE;
1675 if (o->op_type == OP_RV2GV)
1699 case OP_RIGHT_SHIFT:
1719 S_is_handle_constructor(const OP *o, I32 numargs)
1721 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
1723 switch (o->op_type) {
1731 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1744 Perl_refkids(pTHX_ OP *o, I32 type)
1746 if (o && o->op_flags & OPf_KIDS) {
1748 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1755 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
1760 PERL_ARGS_ASSERT_DOREF;
1762 if (!o || (PL_parser && PL_parser->error_count))
1765 switch (o->op_type) {
1767 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1768 !(o->op_flags & OPf_STACKED)) {
1769 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1770 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1771 assert(cUNOPo->op_first->op_type == OP_NULL);
1772 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1773 o->op_flags |= OPf_SPECIAL;
1774 o->op_private &= ~1;
1779 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1780 doref(kid, type, set_op_ref);
1783 if (type == OP_DEFINED)
1784 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1785 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1788 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1789 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1790 : type == OP_RV2HV ? OPpDEREF_HV
1792 o->op_flags |= OPf_MOD;
1799 o->op_flags |= OPf_REF;
1802 if (type == OP_DEFINED)
1803 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1804 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1810 o->op_flags |= OPf_REF;
1815 if (!(o->op_flags & OPf_KIDS))
1817 doref(cBINOPo->op_first, type, set_op_ref);
1821 doref(cBINOPo->op_first, o->op_type, set_op_ref);
1822 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1823 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1824 : type == OP_RV2HV ? OPpDEREF_HV
1826 o->op_flags |= OPf_MOD;
1836 if (!(o->op_flags & OPf_KIDS))
1838 doref(cLISTOPo->op_last, type, set_op_ref);
1848 S_dup_attrlist(pTHX_ OP *o)
1853 PERL_ARGS_ASSERT_DUP_ATTRLIST;
1855 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1856 * where the first kid is OP_PUSHMARK and the remaining ones
1857 * are OP_CONST. We need to push the OP_CONST values.
1859 if (o->op_type == OP_CONST)
1860 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
1862 else if (o->op_type == OP_NULL)
1866 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1868 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1869 if (o->op_type == OP_CONST)
1870 rop = append_elem(OP_LIST, rop,
1871 newSVOP(OP_CONST, o->op_flags,
1872 SvREFCNT_inc_NN(cSVOPo->op_sv)));
1879 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1884 PERL_ARGS_ASSERT_APPLY_ATTRS;
1886 /* fake up C<use attributes $pkg,$rv,@attrs> */
1887 ENTER; /* need to protect against side-effects of 'use' */
1888 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1890 #define ATTRSMODULE "attributes"
1891 #define ATTRSMODULE_PM "attributes.pm"
1894 /* Don't force the C<use> if we don't need it. */
1895 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
1896 if (svp && *svp != &PL_sv_undef)
1897 NOOP; /* already in %INC */
1899 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1900 newSVpvs(ATTRSMODULE), NULL);
1903 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1904 newSVpvs(ATTRSMODULE),
1906 prepend_elem(OP_LIST,
1907 newSVOP(OP_CONST, 0, stashsv),
1908 prepend_elem(OP_LIST,
1909 newSVOP(OP_CONST, 0,
1911 dup_attrlist(attrs))));
1917 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1920 OP *pack, *imop, *arg;
1923 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
1928 assert(target->op_type == OP_PADSV ||
1929 target->op_type == OP_PADHV ||
1930 target->op_type == OP_PADAV);
1932 /* Ensure that attributes.pm is loaded. */
1933 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1935 /* Need package name for method call. */
1936 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
1938 /* Build up the real arg-list. */
1939 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1941 arg = newOP(OP_PADSV, 0);
1942 arg->op_targ = target->op_targ;
1943 arg = prepend_elem(OP_LIST,
1944 newSVOP(OP_CONST, 0, stashsv),
1945 prepend_elem(OP_LIST,
1946 newUNOP(OP_REFGEN, 0,
1947 mod(arg, OP_REFGEN)),
1948 dup_attrlist(attrs)));
1950 /* Fake up a method call to import */
1951 meth = newSVpvs_share("import");
1952 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1953 append_elem(OP_LIST,
1954 prepend_elem(OP_LIST, pack, list(arg)),
1955 newSVOP(OP_METHOD_NAMED, 0, meth)));
1956 imop->op_private |= OPpENTERSUB_NOMOD;
1958 /* Combine the ops. */
1959 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1963 =notfor apidoc apply_attrs_string
1965 Attempts to apply a list of attributes specified by the C<attrstr> and
1966 C<len> arguments to the subroutine identified by the C<cv> argument which
1967 is expected to be associated with the package identified by the C<stashpv>
1968 argument (see L<attributes>). It gets this wrong, though, in that it
1969 does not correctly identify the boundaries of the individual attribute
1970 specifications within C<attrstr>. This is not really intended for the
1971 public API, but has to be listed here for systems such as AIX which
1972 need an explicit export list for symbols. (It's called from XS code
1973 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1974 to respect attribute syntax properly would be welcome.
1980 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
1981 const char *attrstr, STRLEN len)
1985 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
1988 len = strlen(attrstr);
1992 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1994 const char * const sstr = attrstr;
1995 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1996 attrs = append_elem(OP_LIST, attrs,
1997 newSVOP(OP_CONST, 0,
1998 newSVpvn(sstr, attrstr-sstr)));
2002 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2003 newSVpvs(ATTRSMODULE),
2004 NULL, prepend_elem(OP_LIST,
2005 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2006 prepend_elem(OP_LIST,
2007 newSVOP(OP_CONST, 0,
2013 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
2018 PERL_ARGS_ASSERT_MY_KID;
2020 if (!o || (PL_parser && PL_parser->error_count))
2024 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
2025 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
2029 if (type == OP_LIST) {
2031 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2032 my_kid(kid, attrs, imopsp);
2033 } else if (type == OP_UNDEF
2039 } else if (type == OP_RV2SV || /* "our" declaration */
2041 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
2042 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
2043 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2045 PL_parser->in_my == KEY_our
2047 : PL_parser->in_my == KEY_state ? "state" : "my"));
2049 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
2050 PL_parser->in_my = FALSE;
2051 PL_parser->in_my_stash = NULL;
2052 apply_attrs(GvSTASH(gv),
2053 (type == OP_RV2SV ? GvSV(gv) :
2054 type == OP_RV2AV ? (SV*)GvAV(gv) :
2055 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
2058 o->op_private |= OPpOUR_INTRO;
2061 else if (type != OP_PADSV &&
2064 type != OP_PUSHMARK)
2066 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2068 PL_parser->in_my == KEY_our
2070 : PL_parser->in_my == KEY_state ? "state" : "my"));
2073 else if (attrs && type != OP_PUSHMARK) {
2076 PL_parser->in_my = FALSE;
2077 PL_parser->in_my_stash = NULL;
2079 /* check for C<my Dog $spot> when deciding package */
2080 stash = PAD_COMPNAME_TYPE(o->op_targ);
2082 stash = PL_curstash;
2083 apply_attrs_my(stash, o, attrs, imopsp);
2085 o->op_flags |= OPf_MOD;
2086 o->op_private |= OPpLVAL_INTRO;
2087 if (PL_parser->in_my == KEY_state)
2088 o->op_private |= OPpPAD_STATE;
2093 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2097 int maybe_scalar = 0;
2099 PERL_ARGS_ASSERT_MY_ATTRS;
2101 /* [perl #17376]: this appears to be premature, and results in code such as
2102 C< our(%x); > executing in list mode rather than void mode */
2104 if (o->op_flags & OPf_PARENS)
2114 o = my_kid(o, attrs, &rops);
2116 if (maybe_scalar && o->op_type == OP_PADSV) {
2117 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
2118 o->op_private |= OPpLVAL_INTRO;
2121 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
2123 PL_parser->in_my = FALSE;
2124 PL_parser->in_my_stash = NULL;
2129 Perl_my(pTHX_ OP *o)
2131 PERL_ARGS_ASSERT_MY;
2133 return my_attrs(o, NULL);
2137 Perl_sawparens(pTHX_ OP *o)
2139 PERL_UNUSED_CONTEXT;
2141 o->op_flags |= OPf_PARENS;
2146 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2150 const OPCODE ltype = left->op_type;
2151 const OPCODE rtype = right->op_type;
2153 PERL_ARGS_ASSERT_BIND_MATCH;
2155 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2156 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
2158 const char * const desc
2159 = PL_op_desc[(rtype == OP_SUBST || rtype == OP_TRANS)
2160 ? (int)rtype : OP_MATCH];
2161 const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV)
2162 ? "@array" : "%hash");
2163 Perl_warner(aTHX_ packWARN(WARN_MISC),
2164 "Applying %s to %s will act on scalar(%s)",
2165 desc, sample, sample);
2168 if (rtype == OP_CONST &&
2169 cSVOPx(right)->op_private & OPpCONST_BARE &&
2170 cSVOPx(right)->op_private & OPpCONST_STRICT)
2172 no_bareword_allowed(right);
2175 ismatchop = rtype == OP_MATCH ||
2176 rtype == OP_SUBST ||
2178 if (ismatchop && right->op_private & OPpTARGET_MY) {
2180 right->op_private &= ~OPpTARGET_MY;
2182 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
2185 right->op_flags |= OPf_STACKED;
2186 if (rtype != OP_MATCH &&
2187 ! (rtype == OP_TRANS &&
2188 right->op_private & OPpTRANS_IDENTICAL))
2189 newleft = mod(left, rtype);
2192 if (right->op_type == OP_TRANS)
2193 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
2195 o = prepend_elem(rtype, scalar(newleft), right);
2197 return newUNOP(OP_NOT, 0, scalar(o));
2201 return bind_match(type, left,
2202 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
2206 Perl_invert(pTHX_ OP *o)
2210 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2214 Perl_scope(pTHX_ OP *o)
2218 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2219 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2220 o->op_type = OP_LEAVE;
2221 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2223 else if (o->op_type == OP_LINESEQ) {
2225 o->op_type = OP_SCOPE;
2226 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2227 kid = ((LISTOP*)o)->op_first;
2228 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2231 /* The following deals with things like 'do {1 for 1}' */
2232 kid = kid->op_sibling;
2234 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2239 o = newLISTOP(OP_SCOPE, 0, o, NULL);
2245 Perl_block_start(pTHX_ int full)
2248 const int retval = PL_savestack_ix;
2249 pad_block_start(full);
2251 PL_hints &= ~HINT_BLOCK_SCOPE;
2252 SAVECOMPILEWARNINGS();
2253 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
2258 Perl_block_end(pTHX_ I32 floor, OP *seq)
2261 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2262 OP* const retval = scalarseq(seq);
2264 CopHINTS_set(&PL_compiling, PL_hints);
2266 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2275 const PADOFFSET offset = pad_findmy("$_");
2276 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
2277 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2280 OP * const o = newOP(OP_PADSV, 0);
2281 o->op_targ = offset;
2287 Perl_newPROG(pTHX_ OP *o)
2291 PERL_ARGS_ASSERT_NEWPROG;
2296 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2297 ((PL_in_eval & EVAL_KEEPERR)
2298 ? OPf_SPECIAL : 0), o);
2299 PL_eval_start = linklist(PL_eval_root);
2300 PL_eval_root->op_private |= OPpREFCOUNTED;
2301 OpREFCNT_set(PL_eval_root, 1);
2302 PL_eval_root->op_next = 0;
2303 CALL_PEEP(PL_eval_start);
2306 if (o->op_type == OP_STUB) {
2307 PL_comppad_name = 0;
2309 S_op_destroy(aTHX_ o);
2312 PL_main_root = scope(sawparens(scalarvoid(o)));
2313 PL_curcop = &PL_compiling;
2314 PL_main_start = LINKLIST(PL_main_root);
2315 PL_main_root->op_private |= OPpREFCOUNTED;
2316 OpREFCNT_set(PL_main_root, 1);
2317 PL_main_root->op_next = 0;
2318 CALL_PEEP(PL_main_start);
2321 /* Register with debugger */
2324 = Perl_get_cvn_flags(aTHX_ STR_WITH_LEN("DB::postponed"), 0);
2328 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2330 call_sv((SV*)cv, G_DISCARD);
2337 Perl_localize(pTHX_ OP *o, I32 lex)
2341 PERL_ARGS_ASSERT_LOCALIZE;
2343 if (o->op_flags & OPf_PARENS)
2344 /* [perl #17376]: this appears to be premature, and results in code such as
2345 C< our(%x); > executing in list mode rather than void mode */
2352 if ( PL_parser->bufptr > PL_parser->oldbufptr
2353 && PL_parser->bufptr[-1] == ','
2354 && ckWARN(WARN_PARENTHESIS))
2356 char *s = PL_parser->bufptr;
2359 /* some heuristics to detect a potential error */
2360 while (*s && (strchr(", \t\n", *s)))
2364 if (*s && strchr("@$%*", *s) && *++s
2365 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2368 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2370 while (*s && (strchr(", \t\n", *s)))
2376 if (sigil && (*s == ';' || *s == '=')) {
2377 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2378 "Parentheses missing around \"%s\" list",
2380 ? (PL_parser->in_my == KEY_our
2382 : PL_parser->in_my == KEY_state
2392 o = mod(o, OP_NULL); /* a bit kludgey */
2393 PL_parser->in_my = FALSE;
2394 PL_parser->in_my_stash = NULL;
2399 Perl_jmaybe(pTHX_ OP *o)
2401 PERL_ARGS_ASSERT_JMAYBE;
2403 if (o->op_type == OP_LIST) {
2405 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2406 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2412 Perl_fold_constants(pTHX_ register OP *o)
2415 register OP * VOL curop;
2417 VOL I32 type = o->op_type;
2422 SV * const oldwarnhook = PL_warnhook;
2423 SV * const olddiehook = PL_diehook;
2426 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
2428 if (PL_opargs[type] & OA_RETSCALAR)
2430 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2431 o->op_targ = pad_alloc(type, SVs_PADTMP);
2433 /* integerize op, unless it happens to be C<-foo>.
2434 * XXX should pp_i_negate() do magic string negation instead? */
2435 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2436 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2437 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2439 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2442 if (!(PL_opargs[type] & OA_FOLDCONST))
2447 /* XXX might want a ck_negate() for this */
2448 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2459 /* XXX what about the numeric ops? */
2460 if (PL_hints & HINT_LOCALE)
2464 if (PL_parser && PL_parser->error_count)
2465 goto nope; /* Don't try to run w/ errors */
2467 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2468 const OPCODE type = curop->op_type;
2469 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2471 type != OP_SCALAR &&
2473 type != OP_PUSHMARK)
2479 curop = LINKLIST(o);
2480 old_next = o->op_next;
2484 oldscope = PL_scopestack_ix;
2485 create_eval_scope(G_FAKINGEVAL);
2487 PL_warnhook = PERL_WARNHOOK_FATAL;
2494 sv = *(PL_stack_sp--);
2495 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2496 pad_swipe(o->op_targ, FALSE);
2497 else if (SvTEMP(sv)) { /* grab mortal temp? */
2498 SvREFCNT_inc_simple_void(sv);
2503 /* Something tried to die. Abandon constant folding. */
2504 /* Pretend the error never happened. */
2505 sv_setpvn(ERRSV,"",0);
2506 o->op_next = old_next;
2510 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
2511 PL_warnhook = oldwarnhook;
2512 PL_diehook = olddiehook;
2513 /* XXX note that this croak may fail as we've already blown away
2514 * the stack - eg any nested evals */
2515 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
2518 PL_warnhook = oldwarnhook;
2519 PL_diehook = olddiehook;
2521 if (PL_scopestack_ix > oldscope)
2522 delete_eval_scope();
2531 if (type == OP_RV2GV)
2532 newop = newGVOP(OP_GV, 0, (GV*)sv);
2534 newop = newSVOP(OP_CONST, 0, (SV*)sv);
2535 op_getmad(o,newop,'f');
2543 Perl_gen_constant_list(pTHX_ register OP *o)
2547 const I32 oldtmps_floor = PL_tmps_floor;
2550 if (PL_parser && PL_parser->error_count)
2551 return o; /* Don't attempt to run with errors */
2553 PL_op = curop = LINKLIST(o);
2559 assert (!(curop->op_flags & OPf_SPECIAL));
2560 assert(curop->op_type == OP_RANGE);
2562 PL_tmps_floor = oldtmps_floor;
2564 o->op_type = OP_RV2AV;
2565 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2566 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2567 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2568 o->op_opt = 0; /* needs to be revisited in peep() */
2569 curop = ((UNOP*)o)->op_first;
2570 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
2572 op_getmad(curop,o,'O');
2581 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2584 if (!o || o->op_type != OP_LIST)
2585 o = newLISTOP(OP_LIST, 0, o, NULL);
2587 o->op_flags &= ~OPf_WANT;
2589 if (!(PL_opargs[type] & OA_MARK))
2590 op_null(cLISTOPo->op_first);
2592 o->op_type = (OPCODE)type;
2593 o->op_ppaddr = PL_ppaddr[type];
2594 o->op_flags |= flags;
2596 o = CHECKOP(type, o);
2597 if (o->op_type != (unsigned)type)
2600 return fold_constants(o);
2603 /* List constructors */
2606 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2614 if (first->op_type != (unsigned)type
2615 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2617 return newLISTOP(type, 0, first, last);
2620 if (first->op_flags & OPf_KIDS)
2621 ((LISTOP*)first)->op_last->op_sibling = last;
2623 first->op_flags |= OPf_KIDS;
2624 ((LISTOP*)first)->op_first = last;
2626 ((LISTOP*)first)->op_last = last;
2631 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2639 if (first->op_type != (unsigned)type)
2640 return prepend_elem(type, (OP*)first, (OP*)last);
2642 if (last->op_type != (unsigned)type)
2643 return append_elem(type, (OP*)first, (OP*)last);
2645 first->op_last->op_sibling = last->op_first;
2646 first->op_last = last->op_last;
2647 first->op_flags |= (last->op_flags & OPf_KIDS);
2650 if (last->op_first && first->op_madprop) {
2651 MADPROP *mp = last->op_first->op_madprop;
2653 while (mp->mad_next)
2655 mp->mad_next = first->op_madprop;
2658 last->op_first->op_madprop = first->op_madprop;
2661 first->op_madprop = last->op_madprop;
2662 last->op_madprop = 0;
2665 S_op_destroy(aTHX_ (OP*)last);
2671 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2679 if (last->op_type == (unsigned)type) {
2680 if (type == OP_LIST) { /* already a PUSHMARK there */
2681 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2682 ((LISTOP*)last)->op_first->op_sibling = first;
2683 if (!(first->op_flags & OPf_PARENS))
2684 last->op_flags &= ~OPf_PARENS;
2687 if (!(last->op_flags & OPf_KIDS)) {
2688 ((LISTOP*)last)->op_last = first;
2689 last->op_flags |= OPf_KIDS;
2691 first->op_sibling = ((LISTOP*)last)->op_first;
2692 ((LISTOP*)last)->op_first = first;
2694 last->op_flags |= OPf_KIDS;
2698 return newLISTOP(type, 0, first, last);
2706 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2709 Newxz(tk, 1, TOKEN);
2710 tk->tk_type = (OPCODE)optype;
2711 tk->tk_type = 12345;
2713 tk->tk_mad = madprop;
2718 Perl_token_free(pTHX_ TOKEN* tk)
2720 PERL_ARGS_ASSERT_TOKEN_FREE;
2722 if (tk->tk_type != 12345)
2724 mad_free(tk->tk_mad);
2729 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2734 PERL_ARGS_ASSERT_TOKEN_GETMAD;
2736 if (tk->tk_type != 12345) {
2737 Perl_warner(aTHX_ packWARN(WARN_MISC),
2738 "Invalid TOKEN object ignored");
2745 /* faked up qw list? */
2747 tm->mad_type == MAD_SV &&
2748 SvPVX((SV*)tm->mad_val)[0] == 'q')
2755 /* pretend constant fold didn't happen? */
2756 if (mp->mad_key == 'f' &&
2757 (o->op_type == OP_CONST ||
2758 o->op_type == OP_GV) )
2760 token_getmad(tk,(OP*)mp->mad_val,slot);
2774 if (mp->mad_key == 'X')
2775 mp->mad_key = slot; /* just change the first one */
2785 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
2794 /* pretend constant fold didn't happen? */
2795 if (mp->mad_key == 'f' &&
2796 (o->op_type == OP_CONST ||
2797 o->op_type == OP_GV) )
2799 op_getmad(from,(OP*)mp->mad_val,slot);
2806 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
2809 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
2815 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
2824 /* pretend constant fold didn't happen? */
2825 if (mp->mad_key == 'f' &&
2826 (o->op_type == OP_CONST ||
2827 o->op_type == OP_GV) )
2829 op_getmad(from,(OP*)mp->mad_val,slot);
2836 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
2839 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
2843 PerlIO_printf(PerlIO_stderr(),
2844 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
2850 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
2868 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
2872 addmad(tm, &(o->op_madprop), slot);
2876 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
2897 Perl_newMADsv(pTHX_ char key, SV* sv)
2899 PERL_ARGS_ASSERT_NEWMADSV;
2901 return newMADPROP(key, MAD_SV, sv, 0);
2905 Perl_newMADPROP(pTHX_ char key, char type, const void* val, I32 vlen)
2908 Newxz(mp, 1, MADPROP);
2911 mp->mad_vlen = vlen;
2912 mp->mad_type = type;
2914 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
2919 Perl_mad_free(pTHX_ MADPROP* mp)
2921 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
2925 mad_free(mp->mad_next);
2926 /* if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
2927 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
2928 switch (mp->mad_type) {
2932 Safefree((char*)mp->mad_val);
2935 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
2936 op_free((OP*)mp->mad_val);
2939 sv_free((SV*)mp->mad_val);
2942 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
2951 Perl_newNULLLIST(pTHX)
2953 return newOP(OP_STUB, 0);
2957 Perl_force_list(pTHX_ OP *o)
2959 if (!o || o->op_type != OP_LIST)
2960 o = newLISTOP(OP_LIST, 0, o, NULL);
2966 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2971 NewOp(1101, listop, 1, LISTOP);
2973 listop->op_type = (OPCODE)type;
2974 listop->op_ppaddr = PL_ppaddr[type];
2977 listop->op_flags = (U8)flags;
2981 else if (!first && last)
2984 first->op_sibling = last;
2985 listop->op_first = first;
2986 listop->op_last = last;
2987 if (type == OP_LIST) {
2988 OP* const pushop = newOP(OP_PUSHMARK, 0);
2989 pushop->op_sibling = first;
2990 listop->op_first = pushop;
2991 listop->op_flags |= OPf_KIDS;
2993 listop->op_last = pushop;
2996 return CHECKOP(type, listop);
3000 Perl_newOP(pTHX_ I32 type, I32 flags)
3004 NewOp(1101, o, 1, OP);
3005 o->op_type = (OPCODE)type;
3006 o->op_ppaddr = PL_ppaddr[type];
3007 o->op_flags = (U8)flags;
3009 o->op_latefreed = 0;
3013 o->op_private = (U8)(0 | (flags >> 8));
3014 if (PL_opargs[type] & OA_RETSCALAR)
3016 if (PL_opargs[type] & OA_TARGET)
3017 o->op_targ = pad_alloc(type, SVs_PADTMP);
3018 return CHECKOP(type, o);
3022 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
3028 first = newOP(OP_STUB, 0);
3029 if (PL_opargs[type] & OA_MARK)
3030 first = force_list(first);
3032 NewOp(1101, unop, 1, UNOP);
3033 unop->op_type = (OPCODE)type;
3034 unop->op_ppaddr = PL_ppaddr[type];
3035 unop->op_first = first;
3036 unop->op_flags = (U8)(flags | OPf_KIDS);
3037 unop->op_private = (U8)(1 | (flags >> 8));
3038 unop = (UNOP*) CHECKOP(type, unop);
3042 return fold_constants((OP *) unop);
3046 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3050 NewOp(1101, binop, 1, BINOP);
3053 first = newOP(OP_NULL, 0);
3055 binop->op_type = (OPCODE)type;
3056 binop->op_ppaddr = PL_ppaddr[type];
3057 binop->op_first = first;
3058 binop->op_flags = (U8)(flags | OPf_KIDS);
3061 binop->op_private = (U8)(1 | (flags >> 8));
3064 binop->op_private = (U8)(2 | (flags >> 8));
3065 first->op_sibling = last;
3068 binop = (BINOP*)CHECKOP(type, binop);
3069 if (binop->op_next || binop->op_type != (OPCODE)type)
3072 binop->op_last = binop->op_first->op_sibling;
3074 return fold_constants((OP *)binop);
3077 static int uvcompare(const void *a, const void *b)
3078 __attribute__nonnull__(1)
3079 __attribute__nonnull__(2)
3080 __attribute__pure__;
3081 static int uvcompare(const void *a, const void *b)
3083 if (*((const UV *)a) < (*(const UV *)b))
3085 if (*((const UV *)a) > (*(const UV *)b))
3087 if (*((const UV *)a+1) < (*(const UV *)b+1))
3089 if (*((const UV *)a+1) > (*(const UV *)b+1))
3095 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
3098 SV * const tstr = ((SVOP*)expr)->op_sv;
3101 (repl->op_type == OP_NULL)
3102 ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
3104 ((SVOP*)repl)->op_sv;
3107 const U8 *t = (U8*)SvPV_const(tstr, tlen);
3108 const U8 *r = (U8*)SvPV_const(rstr, rlen);
3112 register short *tbl;
3114 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
3115 const I32 squash = o->op_private & OPpTRANS_SQUASH;
3116 I32 del = o->op_private & OPpTRANS_DELETE;
3119 PERL_ARGS_ASSERT_PMTRANS;
3121 PL_hints |= HINT_BLOCK_SCOPE;
3124 o->op_private |= OPpTRANS_FROM_UTF;
3127 o->op_private |= OPpTRANS_TO_UTF;
3129 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
3130 SV* const listsv = newSVpvs("# comment\n");
3132 const U8* tend = t + tlen;
3133 const U8* rend = r + rlen;
3147 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
3148 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
3151 const U32 flags = UTF8_ALLOW_DEFAULT;
3155 t = tsave = bytes_to_utf8(t, &len);
3158 if (!to_utf && rlen) {
3160 r = rsave = bytes_to_utf8(r, &len);
3164 /* There are several snags with this code on EBCDIC:
3165 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
3166 2. scan_const() in toke.c has encoded chars in native encoding which makes
3167 ranges at least in EBCDIC 0..255 range the bottom odd.
3171 U8 tmpbuf[UTF8_MAXBYTES+1];
3174 Newx(cp, 2*tlen, UV);
3176 transv = newSVpvs("");
3178 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3180 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
3182 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3186 cp[2*i+1] = cp[2*i];
3190 qsort(cp, i, 2*sizeof(UV), uvcompare);
3191 for (j = 0; j < i; j++) {
3193 diff = val - nextmin;
3195 t = uvuni_to_utf8(tmpbuf,nextmin);
3196 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3198 U8 range_mark = UTF_TO_NATIVE(0xff);
3199 t = uvuni_to_utf8(tmpbuf, val - 1);
3200 sv_catpvn(transv, (char *)&range_mark, 1);
3201 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3208 t = uvuni_to_utf8(tmpbuf,nextmin);
3209 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3211 U8 range_mark = UTF_TO_NATIVE(0xff);
3212 sv_catpvn(transv, (char *)&range_mark, 1);
3214 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
3215 UNICODE_ALLOW_SUPER);
3216 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3217 t = (const U8*)SvPVX_const(transv);
3218 tlen = SvCUR(transv);
3222 else if (!rlen && !del) {
3223 r = t; rlen = tlen; rend = tend;
3226 if ((!rlen && !del) || t == r ||
3227 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
3229 o->op_private |= OPpTRANS_IDENTICAL;
3233 while (t < tend || tfirst <= tlast) {
3234 /* see if we need more "t" chars */
3235 if (tfirst > tlast) {
3236 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3238 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
3240 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3247 /* now see if we need more "r" chars */
3248 if (rfirst > rlast) {
3250 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3252 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
3254 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3263 rfirst = rlast = 0xffffffff;
3267 /* now see which range will peter our first, if either. */
3268 tdiff = tlast - tfirst;
3269 rdiff = rlast - rfirst;
3276 if (rfirst == 0xffffffff) {
3277 diff = tdiff; /* oops, pretend rdiff is infinite */
3279 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
3280 (long)tfirst, (long)tlast);
3282 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
3286 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
3287 (long)tfirst, (long)(tfirst + diff),
3290 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3291 (long)tfirst, (long)rfirst);
3293 if (rfirst + diff > max)
3294 max = rfirst + diff;
3296 grows = (tfirst < rfirst &&
3297 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3309 else if (max > 0xff)
3314 PerlMemShared_free(cPVOPo->op_pv);
3315 cPVOPo->op_pv = NULL;
3317 swash = (SV*)swash_init("utf8", "", listsv, bits, none);
3319 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
3320 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
3321 PAD_SETSV(cPADOPo->op_padix, swash);
3324 cSVOPo->op_sv = swash;
3326 SvREFCNT_dec(listsv);
3327 SvREFCNT_dec(transv);
3329 if (!del && havefinal && rlen)
3330 (void)hv_store((HV*)SvRV(swash), "FINAL", 5,
3331 newSVuv((UV)final), 0);
3334 o->op_private |= OPpTRANS_GROWS;
3340 op_getmad(expr,o,'e');
3341 op_getmad(repl,o,'r');
3349 tbl = (short*)cPVOPo->op_pv;
3351 Zero(tbl, 256, short);
3352 for (i = 0; i < (I32)tlen; i++)
3354 for (i = 0, j = 0; i < 256; i++) {
3356 if (j >= (I32)rlen) {
3365 if (i < 128 && r[j] >= 128)
3375 o->op_private |= OPpTRANS_IDENTICAL;
3377 else if (j >= (I32)rlen)
3382 PerlMemShared_realloc(tbl,
3383 (0x101+rlen-j) * sizeof(short));
3384 cPVOPo->op_pv = (char*)tbl;
3386 tbl[0x100] = (short)(rlen - j);
3387 for (i=0; i < (I32)rlen - j; i++)
3388 tbl[0x101+i] = r[j+i];
3392 if (!rlen && !del) {
3395 o->op_private |= OPpTRANS_IDENTICAL;
3397 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3398 o->op_private |= OPpTRANS_IDENTICAL;
3400 for (i = 0; i < 256; i++)
3402 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3403 if (j >= (I32)rlen) {
3405 if (tbl[t[i]] == -1)
3411 if (tbl[t[i]] == -1) {
3412 if (t[i] < 128 && r[j] >= 128)
3419 o->op_private |= OPpTRANS_GROWS;
3421 op_getmad(expr,o,'e');
3422 op_getmad(repl,o,'r');
3432 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3437 NewOp(1101, pmop, 1, PMOP);
3438 pmop->op_type = (OPCODE)type;
3439 pmop->op_ppaddr = PL_ppaddr[type];
3440 pmop->op_flags = (U8)flags;
3441 pmop->op_private = (U8)(0 | (flags >> 8));
3443 if (PL_hints & HINT_RE_TAINT)
3444 pmop->op_pmflags |= PMf_RETAINT;
3445 if (PL_hints & HINT_LOCALE)
3446 pmop->op_pmflags |= PMf_LOCALE;
3450 assert(SvPOK(PL_regex_pad[0]));
3451 if (SvCUR(PL_regex_pad[0])) {
3452 /* Pop off the "packed" IV from the end. */
3453 SV *const repointer_list = PL_regex_pad[0];
3454 const char *p = SvEND(repointer_list) - sizeof(IV);
3455 const IV offset = *((IV*)p);
3457 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
3459 SvEND_set(repointer_list, p);
3461 pmop->op_pmoffset = offset;
3462 /* This slot should be free, so assert this: */
3463 assert(PL_regex_pad[offset] == &PL_sv_undef);
3465 SV * const repointer = &PL_sv_undef;
3466 av_push(PL_regex_padav, repointer);
3467 pmop->op_pmoffset = av_len(PL_regex_padav);
3468 PL_regex_pad = AvARRAY(PL_regex_padav);
3472 return CHECKOP(type, pmop);
3475 /* Given some sort of match op o, and an expression expr containing a
3476 * pattern, either compile expr into a regex and attach it to o (if it's
3477 * constant), or convert expr into a runtime regcomp op sequence (if it's
3480 * isreg indicates that the pattern is part of a regex construct, eg
3481 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3482 * split "pattern", which aren't. In the former case, expr will be a list
3483 * if the pattern contains more than one term (eg /a$b/) or if it contains
3484 * a replacement, ie s/// or tr///.
3488 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
3493 I32 repl_has_vars = 0;
3497 PERL_ARGS_ASSERT_PMRUNTIME;
3499 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
3500 /* last element in list is the replacement; pop it */
3502 repl = cLISTOPx(expr)->op_last;
3503 kid = cLISTOPx(expr)->op_first;
3504 while (kid->op_sibling != repl)
3505 kid = kid->op_sibling;
3506 kid->op_sibling = NULL;
3507 cLISTOPx(expr)->op_last = kid;
3510 if (isreg && expr->op_type == OP_LIST &&
3511 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3513 /* convert single element list to element */
3514 OP* const oe = expr;
3515 expr = cLISTOPx(oe)->op_first->op_sibling;
3516 cLISTOPx(oe)->op_first->op_sibling = NULL;
3517 cLISTOPx(oe)->op_last = NULL;
3521 if (o->op_type == OP_TRANS) {
3522 return pmtrans(o, expr, repl);
3525 reglist = isreg && expr->op_type == OP_LIST;
3529 PL_hints |= HINT_BLOCK_SCOPE;
3532 if (expr->op_type == OP_CONST) {
3533 SV *pat = ((SVOP*)expr)->op_sv;
3534 U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
3536 if (o->op_flags & OPf_SPECIAL)
3537 pm_flags |= RXf_SPLIT;
3540 assert (SvUTF8(pat));
3541 } else if (SvUTF8(pat)) {
3542 /* Not doing UTF-8, despite what the SV says. Is this only if we're
3543 trapped in use 'bytes'? */
3544 /* Make a copy of the octet sequence, but without the flag on, as
3545 the compiler now honours the SvUTF8 flag on pat. */
3547 const char *const p = SvPV(pat, len);
3548 pat = newSVpvn_flags(p, len, SVs_TEMP);
3551 PM_SETRE(pm, CALLREGCOMP(pat, pm_flags));
3554 op_getmad(expr,(OP*)pm,'e');
3560 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3561 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3563 : OP_REGCMAYBE),0,expr);
3565 NewOp(1101, rcop, 1, LOGOP);
3566 rcop->op_type = OP_REGCOMP;
3567 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3568 rcop->op_first = scalar(expr);
3569 rcop->op_flags |= OPf_KIDS
3570 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3571 | (reglist ? OPf_STACKED : 0);
3572 rcop->op_private = 1;
3575 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3577 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
3580 /* establish postfix order */
3581 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3583 rcop->op_next = expr;
3584 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3587 rcop->op_next = LINKLIST(expr);
3588 expr->op_next = (OP*)rcop;
3591 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3596 if (pm->op_pmflags & PMf_EVAL) {
3598 if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
3599 CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
3601 else if (repl->op_type == OP_CONST)
3605 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3606 if (curop->op_type == OP_SCOPE
3607 || curop->op_type == OP_LEAVE
3608 || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
3609 if (curop->op_type == OP_GV) {
3610 GV * const gv = cGVOPx_gv(curop);
3612 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3615 else if (curop->op_type == OP_RV2CV)
3617 else if (curop->op_type == OP_RV2SV ||
3618 curop->op_type == OP_RV2AV ||
3619 curop->op_type == OP_RV2HV ||
3620 curop->op_type == OP_RV2GV) {
3621 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3624 else if (curop->op_type == OP_PADSV ||
3625 curop->op_type == OP_PADAV ||
3626 curop->op_type == OP_PADHV ||
3627 curop->op_type == OP_PADANY)
3631 else if (curop->op_type == OP_PUSHRE)
3632 NOOP; /* Okay here, dangerous in newASSIGNOP */
3642 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
3644 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3645 prepend_elem(o->op_type, scalar(repl), o);
3648 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3649 pm->op_pmflags |= PMf_MAYBE_CONST;
3651 NewOp(1101, rcop, 1, LOGOP);
3652 rcop->op_type = OP_SUBSTCONT;
3653 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3654 rcop->op_first = scalar(repl);
3655 rcop->op_flags |= OPf_KIDS;
3656 rcop->op_private = 1;
3659 /* establish postfix order */
3660 rcop->op_next = LINKLIST(repl);
3661 repl->op_next = (OP*)rcop;
3663 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
3664 assert(!(pm->op_pmflags & PMf_ONCE));
3665 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
3674 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3679 PERL_ARGS_ASSERT_NEWSVOP;
3681 NewOp(1101, svop, 1, SVOP);
3682 svop->op_type = (OPCODE)type;
3683 svop->op_ppaddr = PL_ppaddr[type];
3685 svop->op_next = (OP*)svop;
3686 svop->op_flags = (U8)flags;
3687 if (PL_opargs[type] & OA_RETSCALAR)
3689 if (PL_opargs[type] & OA_TARGET)
3690 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3691 return CHECKOP(type, svop);
3696 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3701 PERL_ARGS_ASSERT_NEWPADOP;
3703 NewOp(1101, padop, 1, PADOP);
3704 padop->op_type = (OPCODE)type;
3705 padop->op_ppaddr = PL_ppaddr[type];
3706 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3707 SvREFCNT_dec(PAD_SVl(padop->op_padix));
3708 PAD_SETSV(padop->op_padix, sv);
3711 padop->op_next = (OP*)padop;
3712 padop->op_flags = (U8)flags;
3713 if (PL_opargs[type] & OA_RETSCALAR)
3715 if (PL_opargs[type] & OA_TARGET)
3716 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3717 return CHECKOP(type, padop);
3722 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3726 PERL_ARGS_ASSERT_NEWGVOP;
3730 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3732 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3737 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3741 NewOp(1101, pvop, 1, PVOP);
3742 pvop->op_type = (OPCODE)type;
3743 pvop->op_ppaddr = PL_ppaddr[type];
3745 pvop->op_next = (OP*)pvop;
3746 pvop->op_flags = (U8)flags;
3747 if (PL_opargs[type] & OA_RETSCALAR)
3749 if (PL_opargs[type] & OA_TARGET)
3750 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3751 return CHECKOP(type, pvop);
3759 Perl_package(pTHX_ OP *o)
3762 SV *const sv = cSVOPo->op_sv;
3767 PERL_ARGS_ASSERT_PACKAGE;
3769 save_hptr(&PL_curstash);
3770 save_item(PL_curstname);
3772 PL_curstash = gv_stashsv(sv, GV_ADD);
3774 sv_setsv(PL_curstname, sv);
3776 PL_hints |= HINT_BLOCK_SCOPE;
3777 PL_parser->copline = NOLINE;
3778 PL_parser->expect = XSTATE;
3783 if (!PL_madskills) {
3788 pegop = newOP(OP_NULL,0);
3789 op_getmad(o,pegop,'P');
3799 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3806 OP *pegop = newOP(OP_NULL,0);
3809 PERL_ARGS_ASSERT_UTILIZE;
3811 if (idop->op_type != OP_CONST)
3812 Perl_croak(aTHX_ "Module name must be constant");
3815 op_getmad(idop,pegop,'U');
3820 SV * const vesv = ((SVOP*)version)->op_sv;
3823 op_getmad(version,pegop,'V');
3824 if (!arg && !SvNIOKp(vesv)) {
3831 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3832 Perl_croak(aTHX_ "Version number must be constant number");
3834 /* Make copy of idop so we don't free it twice */
3835 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3837 /* Fake up a method call to VERSION */
3838 meth = newSVpvs_share("VERSION");
3839 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3840 append_elem(OP_LIST,
3841 prepend_elem(OP_LIST, pack, list(version)),
3842 newSVOP(OP_METHOD_NAMED, 0, meth)));
3846 /* Fake up an import/unimport */
3847 if (arg && arg->op_type == OP_STUB) {
3849 op_getmad(arg,pegop,'S');
3850 imop = arg; /* no import on explicit () */
3852 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3853 imop = NULL; /* use 5.0; */
3855 idop->op_private |= OPpCONST_NOVER;
3861 op_getmad(arg,pegop,'A');
3863 /* Make copy of idop so we don't free it twice */
3864 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3866 /* Fake up a method call to import/unimport */
3868 ? newSVpvs_share("import") : newSVpvs_share("unimport");
3869 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3870 append_elem(OP_LIST,
3871 prepend_elem(OP_LIST, pack, list(arg)),
3872 newSVOP(OP_METHOD_NAMED, 0, meth)));
3875 /* Fake up the BEGIN {}, which does its thing immediately. */
3877 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
3880 append_elem(OP_LINESEQ,
3881 append_elem(OP_LINESEQ,
3882 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
3883 newSTATEOP(0, NULL, veop)),
3884 newSTATEOP(0, NULL, imop) ));
3886 /* The "did you use incorrect case?" warning used to be here.
3887 * The problem is that on case-insensitive filesystems one
3888 * might get false positives for "use" (and "require"):
3889 * "use Strict" or "require CARP" will work. This causes
3890 * portability problems for the script: in case-strict
3891 * filesystems the script will stop working.
3893 * The "incorrect case" warning checked whether "use Foo"
3894 * imported "Foo" to your namespace, but that is wrong, too:
3895 * there is no requirement nor promise in the language that
3896 * a Foo.pm should or would contain anything in package "Foo".
3898 * There is very little Configure-wise that can be done, either:
3899 * the case-sensitivity of the build filesystem of Perl does not
3900 * help in guessing the case-sensitivity of the runtime environment.
3903 PL_hints |= HINT_BLOCK_SCOPE;
3904 PL_parser->copline = NOLINE;
3905 PL_parser->expect = XSTATE;
3906 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3909 if (!PL_madskills) {
3910 /* FIXME - don't allocate pegop if !PL_madskills */
3919 =head1 Embedding Functions
3921 =for apidoc load_module
3923 Loads the module whose name is pointed to by the string part of name.
3924 Note that the actual module name, not its filename, should be given.
3925 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3926 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3927 (or 0 for no flags). ver, if specified, provides version semantics
3928 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3929 arguments can be used to specify arguments to the module's import()
3930 method, similar to C<use Foo::Bar VERSION LIST>.
3935 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3939 PERL_ARGS_ASSERT_LOAD_MODULE;
3941 va_start(args, ver);
3942 vload_module(flags, name, ver, &args);
3946 #ifdef PERL_IMPLICIT_CONTEXT
3948 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3952 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
3953 va_start(args, ver);
3954 vload_module(flags, name, ver, &args);
3960 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3964 OP * const modname = newSVOP(OP_CONST, 0, name);
3966 PERL_ARGS_ASSERT_VLOAD_MODULE;
3968 modname->op_private |= OPpCONST_BARE;
3970 veop = newSVOP(OP_CONST, 0, ver);
3974 if (flags & PERL_LOADMOD_NOIMPORT) {
3975 imop = sawparens(newNULLLIST());
3977 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3978 imop = va_arg(*args, OP*);
3983 sv = va_arg(*args, SV*);
3985 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3986 sv = va_arg(*args, SV*);
3990 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
3991 * that it has a PL_parser to play with while doing that, and also
3992 * that it doesn't mess with any existing parser, by creating a tmp
3993 * new parser with lex_start(). This won't actually be used for much,
3994 * since pp_require() will create another parser for the real work. */
3997 SAVEVPTR(PL_curcop);
3998 lex_start(NULL, NULL, FALSE);
3999 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
4000 veop, modname, imop);
4005 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
4011 PERL_ARGS_ASSERT_DOFILE;
4013 if (!force_builtin) {
4014 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
4015 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
4016 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
4017 gv = gvp ? *gvp : NULL;
4021 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
4022 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
4023 append_elem(OP_LIST, term,
4024 scalar(newUNOP(OP_RV2CV, 0,
4025 newGVOP(OP_GV, 0, gv))))));
4028 doop = newUNOP(OP_DOFILE, 0, scalar(term));
4034 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
4036 return newBINOP(OP_LSLICE, flags,
4037 list(force_list(subscript)),
4038 list(force_list(listval)) );
4042 S_is_list_assignment(pTHX_ register const OP *o)
4050 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
4051 o = cUNOPo->op_first;
4053 flags = o->op_flags;
4055 if (type == OP_COND_EXPR) {
4056 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
4057 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
4062 yyerror("Assignment to both a list and a scalar");
4066 if (type == OP_LIST &&
4067 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
4068 o->op_private & OPpLVAL_INTRO)
4071 if (type == OP_LIST || flags & OPf_PARENS ||
4072 type == OP_RV2AV || type == OP_RV2HV ||
4073 type == OP_ASLICE || type == OP_HSLICE)
4076 if (type == OP_PADAV || type == OP_PADHV)
4079 if (type == OP_RV2SV)
4086 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
4092 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
4093 return newLOGOP(optype, 0,
4094 mod(scalar(left), optype),
4095 newUNOP(OP_SASSIGN, 0, scalar(right)));
4098 return newBINOP(optype, OPf_STACKED,
4099 mod(scalar(left), optype), scalar(right));
4103 if (is_list_assignment(left)) {
4104 static const char no_list_state[] = "Initialization of state variables"
4105 " in list context currently forbidden";
4107 bool maybe_common_vars = TRUE;
4110 /* Grandfathering $[ assignment here. Bletch.*/
4111 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
4112 PL_eval_start = (left->op_type == OP_CONST) ? right : NULL;
4113 left = mod(left, OP_AASSIGN);
4116 else if (left->op_type == OP_CONST) {
4118 /* Result of assignment is always 1 (or we'd be dead already) */
4119 return newSVOP(OP_CONST, 0, newSViv(1));
4121 curop = list(force_list(left));
4122 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
4123 o->op_private = (U8)(0 | (flags >> 8));
4125 if ((left->op_type == OP_LIST
4126 || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
4128 OP* lop = ((LISTOP*)left)->op_first;
4129 maybe_common_vars = FALSE;
4131 if (lop->op_type == OP_PADSV ||
4132 lop->op_type == OP_PADAV ||
4133 lop->op_type == OP_PADHV ||
4134 lop->op_type == OP_PADANY) {
4135 if (!(lop->op_private & OPpLVAL_INTRO))
4136 maybe_common_vars = TRUE;
4138 if (lop->op_private & OPpPAD_STATE) {
4139 if (left->op_private & OPpLVAL_INTRO) {
4140 /* Each variable in state($a, $b, $c) = ... */
4143 /* Each state variable in
4144 (state $a, my $b, our $c, $d, undef) = ... */
4146 yyerror(no_list_state);
4148 /* Each my variable in
4149 (state $a, my $b, our $c, $d, undef) = ... */
4151 } else if (lop->op_type == OP_UNDEF ||
4152 lop->op_type == OP_PUSHMARK) {
4153 /* undef may be interesting in
4154 (state $a, undef, state $c) */
4156 /* Other ops in the list. */
4157 maybe_common_vars = TRUE;
4159 lop = lop->op_sibling;
4162 else if ((left->op_private & OPpLVAL_INTRO)
4163 && ( left->op_type == OP_PADSV
4164 || left->op_type == OP_PADAV
4165 || left->op_type == OP_PADHV
4166 || left->op_type == OP_PADANY))
4168 maybe_common_vars = FALSE;
4169 if (left->op_private & OPpPAD_STATE) {
4170 /* All single variable list context state assignments, hence
4180 yyerror(no_list_state);
4184 /* PL_generation sorcery:
4185 * an assignment like ($a,$b) = ($c,$d) is easier than
4186 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
4187 * To detect whether there are common vars, the global var
4188 * PL_generation is incremented for each assign op we compile.
4189 * Then, while compiling the assign op, we run through all the
4190 * variables on both sides of the assignment, setting a spare slot
4191 * in each of them to PL_generation. If any of them already have
4192 * that value, we know we've got commonality. We could use a
4193 * single bit marker, but then we'd have to make 2 passes, first
4194 * to clear the flag, then to test and set it. To find somewhere
4195 * to store these values, evil chicanery is done with SvUVX().
4198 if (maybe_common_vars) {
4201 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4202 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
4203 if (curop->op_type == OP_GV) {
4204 GV *gv = cGVOPx_gv(curop);
4206 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4208 GvASSIGN_GENERATION_set(gv, PL_generation);
4210 else if (curop->op_type == OP_PADSV ||
4211 curop->op_type == OP_PADAV ||
4212 curop->op_type == OP_PADHV ||
4213 curop->op_type == OP_PADANY)
4215 if (PAD_COMPNAME_GEN(curop->op_targ)
4216 == (STRLEN)PL_generation)
4218 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
4221 else if (curop->op_type == OP_RV2CV)
4223 else if (curop->op_type == OP_RV2SV ||
4224 curop->op_type == OP_RV2AV ||
4225 curop->op_type == OP_RV2HV ||
4226 curop->op_type == OP_RV2GV) {
4227 if (lastop->op_type != OP_GV) /* funny deref? */
4230 else if (curop->op_type == OP_PUSHRE) {
4232 if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
4233 GV *const gv = (GV*)PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff);
4235 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4237 GvASSIGN_GENERATION_set(gv, PL_generation);
4241 = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
4244 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4246 GvASSIGN_GENERATION_set(gv, PL_generation);
4256 o->op_private |= OPpASSIGN_COMMON;
4259 if (right && right->op_type == OP_SPLIT && !PL_madskills) {
4260 OP* tmpop = ((LISTOP*)right)->op_first;
4261 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
4262 PMOP * const pm = (PMOP*)tmpop;
4263 if (left->op_type == OP_RV2AV &&
4264 !(left->op_private & OPpLVAL_INTRO) &&
4265 !(o->op_private & OPpASSIGN_COMMON) )
4267 tmpop = ((UNOP*)left)->op_first;
4268 if (tmpop->op_type == OP_GV
4270 && !pm->op_pmreplrootu.op_pmtargetoff
4272 && !pm->op_pmreplrootu.op_pmtargetgv
4276 pm->op_pmreplrootu.op_pmtargetoff
4277 = cPADOPx(tmpop)->op_padix;
4278 cPADOPx(tmpop)->op_padix = 0; /* steal it */
4280 pm->op_pmreplrootu.op_pmtargetgv
4281 = (GV*)cSVOPx(tmpop)->op_sv;
4282 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
4284 pm->op_pmflags |= PMf_ONCE;
4285 tmpop = cUNOPo->op_first; /* to list (nulled) */
4286 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
4287 tmpop->op_sibling = NULL; /* don't free split */
4288 right->op_next = tmpop->op_next; /* fix starting loc */
4289 op_free(o); /* blow off assign */
4290 right->op_flags &= ~OPf_WANT;
4291 /* "I don't know and I don't care." */
4296 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
4297 ((LISTOP*)right)->op_last->op_type == OP_CONST)
4299 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
4301 sv_setiv(sv, PL_modcount+1);
4309 right = newOP(OP_UNDEF, 0);
4310 if (right->op_type == OP_READLINE) {
4311 right->op_flags |= OPf_STACKED;
4312 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
4315 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
4316 o = newBINOP(OP_SASSIGN, flags,
4317 scalar(right), mod(scalar(left), OP_SASSIGN) );
4323 o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
4324 o->op_private |= OPpCONST_ARYBASE;
4331 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
4334 const U32 seq = intro_my();
4337 NewOp(1101, cop, 1, COP);
4338 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
4339 cop->op_type = OP_DBSTATE;
4340 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
4343 cop->op_type = OP_NEXTSTATE;
4344 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
4346 cop->op_flags = (U8)flags;
4347 CopHINTS_set(cop, PL_hints);
4349 cop->op_private |= NATIVE_HINTS;
4351 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
4352 cop->op_next = (OP*)cop;
4355 CopLABEL_set(cop, label);
4356 PL_hints |= HINT_BLOCK_SCOPE;
4359 /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
4360 CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
4362 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
4363 cop->cop_hints_hash = PL_curcop->cop_hints_hash;
4364 if (cop->cop_hints_hash) {
4366 cop->cop_hints_hash->refcounted_he_refcnt++;
4367 HINTS_REFCNT_UNLOCK;
4370 if (PL_parser && PL_parser->copline == NOLINE)
4371 CopLINE_set(cop, CopLINE(PL_curcop));
4373 CopLINE_set(cop, PL_parser->copline);
4375 PL_parser->copline = NOLINE;
4378 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
4380 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
4382 CopSTASH_set(cop, PL_curstash);
4384 if (PERLDB_LINE && PL_curstash != PL_debstash) {
4385 AV *av = CopFILEAVx(PL_curcop);
4387 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
4388 if (svp && *svp != &PL_sv_undef ) {
4389 (void)SvIOK_on(*svp);
4390 SvIV_set(*svp, PTR2IV(cop));
4395 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
4400 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
4404 PERL_ARGS_ASSERT_NEWLOGOP;
4406 return new_logop(type, flags, &first, &other);
4410 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
4415 OP *first = *firstp;
4416 OP * const other = *otherp;
4418 PERL_ARGS_ASSERT_NEW_LOGOP;
4420 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
4421 return newBINOP(type, flags, scalar(first), scalar(other));
4423 scalarboolean(first);
4424 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
4425 if (first->op_type == OP_NOT
4426 && (first->op_flags & OPf_SPECIAL)
4427 && (first->op_flags & OPf_KIDS)
4429 if (type == OP_AND || type == OP_OR) {
4435 first = *firstp = cUNOPo->op_first;
4437 first->op_next = o->op_next;
4438 cUNOPo->op_first = NULL;
4442 if (first->op_type == OP_CONST) {
4443 if (first->op_private & OPpCONST_STRICT)
4444 no_bareword_allowed(first);
4445 else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
4446 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
4447 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
4448 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
4449 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
4451 if (other->op_type == OP_CONST)
4452 other->op_private |= OPpCONST_SHORTCIRCUIT;
4454 OP *newop = newUNOP(OP_NULL, 0, other);
4455 op_getmad(first, newop, '1');
4456 newop->op_targ = type; /* set "was" field */
4463 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
4464 const OP *o2 = other;
4465 if ( ! (o2->op_type == OP_LIST
4466 && (( o2 = cUNOPx(o2)->op_first))
4467 && o2->op_type == OP_PUSHMARK
4468 && (( o2 = o2->op_sibling)) )
4471 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
4472 || o2->op_type == OP_PADHV)
4473 && o2->op_private & OPpLVAL_INTRO
4474 && !(o2->op_private & OPpPAD_STATE)
4475 && ckWARN(WARN_DEPRECATED))
4477 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4478 "Deprecated use of my() in false conditional");
4482 if (first->op_type == OP_CONST)
4483 first->op_private |= OPpCONST_SHORTCIRCUIT;
4485 first = newUNOP(OP_NULL, 0, first);
4486 op_getmad(other, first, '2');
4487 first->op_targ = type; /* set "was" field */
4494 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
4495 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
4497 const OP * const k1 = ((UNOP*)first)->op_first;
4498 const OP * const k2 = k1->op_sibling;
4500 switch (first->op_type)
4503 if (k2 && k2->op_type == OP_READLINE
4504 && (k2->op_flags & OPf_STACKED)
4505 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4507 warnop = k2->op_type;
4512 if (k1->op_type == OP_READDIR
4513 || k1->op_type == OP_GLOB
4514 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4515 || k1->op_type == OP_EACH)
4517 warnop = ((k1->op_type == OP_NULL)
4518 ? (OPCODE)k1->op_targ : k1->op_type);
4523 const line_t oldline = CopLINE(PL_curcop);
4524 CopLINE_set(PL_curcop, PL_parser->copline);
4525 Perl_warner(aTHX_ packWARN(WARN_MISC),
4526 "Value of %s%s can be \"0\"; test with defined()",
4528 ((warnop == OP_READLINE || warnop == OP_GLOB)
4529 ? " construct" : "() operator"));
4530 CopLINE_set(PL_curcop, oldline);
4537 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
4538 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
4540 NewOp(1101, logop, 1, LOGOP);
4542 logop->op_type = (OPCODE)type;
4543 logop->op_ppaddr = PL_ppaddr[type];
4544 logop->op_first = first;
4545 logop->op_flags = (U8)(flags | OPf_KIDS);
4546 logop->op_other = LINKLIST(other);
4547 logop->op_private = (U8)(1 | (flags >> 8));
4549 /* establish postfix order */
4550 logop->op_next = LINKLIST(first);
4551 first->op_next = (OP*)logop;
4552 first->op_sibling = other;
4554 CHECKOP(type,logop);
4556 o = newUNOP(OP_NULL, 0, (OP*)logop);
4563 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
4570 PERL_ARGS_ASSERT_NEWCONDOP;
4573 return newLOGOP(OP_AND, 0, first, trueop);
4575 return newLOGOP(OP_OR, 0, first, falseop);
4577 scalarboolean(first);
4578 if (first->op_type == OP_CONST) {
4579 /* Left or right arm of the conditional? */
4580 const bool left = SvTRUE(((SVOP*)first)->op_sv);
4581 OP *live = left ? trueop : falseop;
4582 OP *const dead = left ? falseop : trueop;
4583 if (first->op_private & OPpCONST_BARE &&
4584 first->op_private & OPpCONST_STRICT) {
4585 no_bareword_allowed(first);
4588 /* This is all dead code when PERL_MAD is not defined. */
4589 live = newUNOP(OP_NULL, 0, live);
4590 op_getmad(first, live, 'C');
4591 op_getmad(dead, live, left ? 'e' : 't');
4598 NewOp(1101, logop, 1, LOGOP);
4599 logop->op_type = OP_COND_EXPR;
4600 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4601 logop->op_first = first;
4602 logop->op_flags = (U8)(flags | OPf_KIDS);
4603 logop->op_private = (U8)(1 | (flags >> 8));
4604 logop->op_other = LINKLIST(trueop);
4605 logop->op_next = LINKLIST(falseop);
4607 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
4610 /* establish postfix order */
4611 start = LINKLIST(first);
4612 first->op_next = (OP*)logop;
4614 first->op_sibling = trueop;
4615 trueop->op_sibling = falseop;
4616 o = newUNOP(OP_NULL, 0, (OP*)logop);
4618 trueop->op_next = falseop->op_next = o;
4625 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4634 PERL_ARGS_ASSERT_NEWRANGE;
4636 NewOp(1101, range, 1, LOGOP);
4638 range->op_type = OP_RANGE;
4639 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4640 range->op_first = left;
4641 range->op_flags = OPf_KIDS;
4642 leftstart = LINKLIST(left);
4643 range->op_other = LINKLIST(right);
4644 range->op_private = (U8)(1 | (flags >> 8));
4646 left->op_sibling = right;
4648 range->op_next = (OP*)range;
4649 flip = newUNOP(OP_FLIP, flags, (OP*)range);
4650 flop = newUNOP(OP_FLOP, 0, flip);
4651 o = newUNOP(OP_NULL, 0, flop);
4653 range->op_next = leftstart;
4655 left->op_next = flip;
4656 right->op_next = flop;
4658 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4659 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4660 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4661 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4663 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4664 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4667 if (!flip->op_private || !flop->op_private)
4668 linklist(o); /* blow off optimizer unless constant */
4674 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4679 const bool once = block && block->op_flags & OPf_SPECIAL &&
4680 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4682 PERL_UNUSED_ARG(debuggable);
4685 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4686 return block; /* do {} while 0 does once */
4687 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4688 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4689 expr = newUNOP(OP_DEFINED, 0,
4690 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4691 } else if (expr->op_flags & OPf_KIDS) {
4692 const OP * const k1 = ((UNOP*)expr)->op_first;
4693 const OP * const k2 = k1 ? k1->op_sibling : NULL;
4694 switch (expr->op_type) {
4696 if (k2 && k2->op_type == OP_READLINE
4697 && (k2->op_flags & OPf_STACKED)
4698 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4699 expr = newUNOP(OP_DEFINED, 0, expr);
4703 if (k1 && (k1->op_type == OP_READDIR
4704 || k1->op_type == OP_GLOB
4705 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4706 || k1->op_type == OP_EACH))
4707 expr = newUNOP(OP_DEFINED, 0, expr);
4713 /* if block is null, the next append_elem() would put UNSTACK, a scalar
4714 * op, in listop. This is wrong. [perl #27024] */
4716 block = newOP(OP_NULL, 0);
4717 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4718 o = new_logop(OP_AND, 0, &expr, &listop);
4721 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4723 if (once && o != listop)
4724 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4727 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
4729 o->op_flags |= flags;
4731 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4736 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
4737 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
4746 PERL_UNUSED_ARG(debuggable);
4749 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4750 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4751 expr = newUNOP(OP_DEFINED, 0,
4752 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4753 } else if (expr->op_flags & OPf_KIDS) {
4754 const OP * const k1 = ((UNOP*)expr)->op_first;
4755 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
4756 switch (expr->op_type) {
4758 if (k2 && k2->op_type == OP_READLINE
4759 && (k2->op_flags & OPf_STACKED)
4760 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4761 expr = newUNOP(OP_DEFINED, 0, expr);
4765 if (k1 && (k1->op_type == OP_READDIR
4766 || k1->op_type == OP_GLOB
4767 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4768 || k1->op_type == OP_EACH))
4769 expr = newUNOP(OP_DEFINED, 0, expr);
4776 block = newOP(OP_NULL, 0);
4777 else if (cont || has_my) {
4778 block = scope(block);
4782 next = LINKLIST(cont);
4785 OP * const unstack = newOP(OP_UNSTACK, 0);
4788 cont = append_elem(OP_LINESEQ, cont, unstack);
4792 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4794 redo = LINKLIST(listop);
4797 PL_parser->copline = (line_t)whileline;
4799 o = new_logop(OP_AND, 0, &expr, &listop);
4800 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4801 op_free(expr); /* oops, it's a while (0) */
4803 return NULL; /* listop already freed by new_logop */
4806 ((LISTOP*)listop)->op_last->op_next =
4807 (o == listop ? redo : LINKLIST(o));
4813 NewOp(1101,loop,1,LOOP);
4814 loop->op_type = OP_ENTERLOOP;
4815 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4816 loop->op_private = 0;
4817 loop->op_next = (OP*)loop;
4820 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4822 loop->op_redoop = redo;
4823 loop->op_lastop = o;
4824 o->op_private |= loopflags;
4827 loop->op_nextop = next;
4829 loop->op_nextop = o;
4831 o->op_flags |= flags;
4832 o->op_private |= (flags >> 8);
4837 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
4842 PADOFFSET padoff = 0;
4847 PERL_ARGS_ASSERT_NEWFOROP;
4850 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4851 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
4852 sv->op_type = OP_RV2GV;
4853 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4855 /* The op_type check is needed to prevent a possible segfault
4856 * if the loop variable is undeclared and 'strict vars' is in
4857 * effect. This is illegal but is nonetheless parsed, so we
4858 * may reach this point with an OP_CONST where we're expecting
4861 if (cUNOPx(sv)->op_first->op_type == OP_GV
4862 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
4863 iterpflags |= OPpITER_DEF;
4865 else if (sv->op_type == OP_PADSV) { /* private variable */
4866 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
4867 padoff = sv->op_targ;
4877 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4879 SV *const namesv = PAD_COMPNAME_SV(padoff);
4881 const char *const name = SvPV_const(namesv, len);
4883 if (len == 2 && name[0] == '$' && name[1] == '_')
4884 iterpflags |= OPpITER_DEF;
4888 const PADOFFSET offset = pad_findmy("$_");
4889 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
4890 sv = newGVOP(OP_GV, 0, PL_defgv);
4895 iterpflags |= OPpITER_DEF;
4897 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4898 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4899 iterflags |= OPf_STACKED;
4901 else if (expr->op_type == OP_NULL &&
4902 (expr->op_flags & OPf_KIDS) &&
4903 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4905 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4906 * set the STACKED flag to indicate that these values are to be
4907 * treated as min/max values by 'pp_iterinit'.
4909 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4910 LOGOP* const range = (LOGOP*) flip->op_first;
4911 OP* const left = range->op_first;
4912 OP* const right = left->op_sibling;
4915 range->op_flags &= ~OPf_KIDS;
4916 range->op_first = NULL;
4918 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4919 listop->op_first->op_next = range->op_next;
4920 left->op_next = range->op_other;
4921 right->op_next = (OP*)listop;
4922 listop->op_next = listop->op_first;
4925 op_getmad(expr,(OP*)listop,'O');
4929 expr = (OP*)(listop);
4931 iterflags |= OPf_STACKED;
4934 expr = mod(force_list(expr), OP_GREPSTART);
4937 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4938 append_elem(OP_LIST, expr, scalar(sv))));
4939 assert(!loop->op_next);
4940 /* for my $x () sets OPpLVAL_INTRO;
4941 * for our $x () sets OPpOUR_INTRO */
4942 loop->op_private = (U8)iterpflags;
4943 #ifdef PL_OP_SLAB_ALLOC
4946 NewOp(1234,tmp,1,LOOP);
4947 Copy(loop,tmp,1,LISTOP);
4948 S_op_destroy(aTHX_ (OP*)loop);
4952 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
4954 loop->op_targ = padoff;
4955 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
4957 op_getmad(madsv, (OP*)loop, 'v');
4958 PL_parser->copline = forline;
4959 return newSTATEOP(0, label, wop);
4963 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4968 PERL_ARGS_ASSERT_NEWLOOPEX;
4970 if (type != OP_GOTO || label->op_type == OP_CONST) {
4971 /* "last()" means "last" */
4972 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4973 o = newOP(type, OPf_SPECIAL);
4975 o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
4976 ? SvPV_nolen_const(((SVOP*)label)->op_sv)
4980 op_getmad(label,o,'L');
4986 /* Check whether it's going to be a goto &function */
4987 if (label->op_type == OP_ENTERSUB
4988 && !(label->op_flags & OPf_STACKED))
4989 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4990 o = newUNOP(type, OPf_STACKED, label);
4992 PL_hints |= HINT_BLOCK_SCOPE;
4996 /* if the condition is a literal array or hash
4997 (or @{ ... } etc), make a reference to it.
5000 S_ref_array_or_hash(pTHX_ OP *cond)
5003 && (cond->op_type == OP_RV2AV
5004 || cond->op_type == OP_PADAV
5005 || cond->op_type == OP_RV2HV
5006 || cond->op_type == OP_PADHV))
5008 return newUNOP(OP_REFGEN,
5009 0, mod(cond, OP_REFGEN));
5015 /* These construct the optree fragments representing given()
5018 entergiven and enterwhen are LOGOPs; the op_other pointer
5019 points up to the associated leave op. We need this so we
5020 can put it in the context and make break/continue work.
5021 (Also, of course, pp_enterwhen will jump straight to
5022 op_other if the match fails.)
5026 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
5027 I32 enter_opcode, I32 leave_opcode,
5028 PADOFFSET entertarg)
5034 PERL_ARGS_ASSERT_NEWGIVWHENOP;
5036 NewOp(1101, enterop, 1, LOGOP);
5037 enterop->op_type = enter_opcode;
5038 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
5039 enterop->op_flags = (U8) OPf_KIDS;
5040 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
5041 enterop->op_private = 0;
5043 o = newUNOP(leave_opcode, 0, (OP *) enterop);
5046 enterop->op_first = scalar(cond);
5047 cond->op_sibling = block;
5049 o->op_next = LINKLIST(cond);
5050 cond->op_next = (OP *) enterop;
5053 /* This is a default {} block */
5054 enterop->op_first = block;
5055 enterop->op_flags |= OPf_SPECIAL;
5057 o->op_next = (OP *) enterop;
5060 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
5061 entergiven and enterwhen both
5064 enterop->op_next = LINKLIST(block);
5065 block->op_next = enterop->op_other = o;
5070 /* Does this look like a boolean operation? For these purposes
5071 a boolean operation is:
5072 - a subroutine call [*]
5073 - a logical connective
5074 - a comparison operator
5075 - a filetest operator, with the exception of -s -M -A -C
5076 - defined(), exists() or eof()
5077 - /$re/ or $foo =~ /$re/
5079 [*] possibly surprising
5082 S_looks_like_bool(pTHX_ const OP *o)
5086 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
5088 switch(o->op_type) {
5090 return looks_like_bool(cLOGOPo->op_first);
5094 looks_like_bool(cLOGOPo->op_first)
5095 && looks_like_bool(cLOGOPo->op_first->op_sibling));
5099 o->op_flags & OPf_KIDS
5100 && looks_like_bool(cUNOPo->op_first));
5104 case OP_NOT: case OP_XOR:
5105 /* Note that OP_DOR is not here */
5107 case OP_EQ: case OP_NE: case OP_LT:
5108 case OP_GT: case OP_LE: case OP_GE:
5110 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
5111 case OP_I_GT: case OP_I_LE: case OP_I_GE:
5113 case OP_SEQ: case OP_SNE: case OP_SLT:
5114 case OP_SGT: case OP_SLE: case OP_SGE:
5118 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
5119 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
5120 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
5121 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
5122 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
5123 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
5124 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
5125 case OP_FTTEXT: case OP_FTBINARY:
5127 case OP_DEFINED: case OP_EXISTS:
5128 case OP_MATCH: case OP_EOF:
5133 /* Detect comparisons that have been optimized away */
5134 if (cSVOPo->op_sv == &PL_sv_yes
5135 || cSVOPo->op_sv == &PL_sv_no)
5146 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
5149 PERL_ARGS_ASSERT_NEWGIVENOP;
5150 return newGIVWHENOP(
5151 ref_array_or_hash(cond),
5153 OP_ENTERGIVEN, OP_LEAVEGIVEN,
5157 /* If cond is null, this is a default {} block */
5159 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
5161 const bool cond_llb = (!cond || looks_like_bool(cond));
5164 PERL_ARGS_ASSERT_NEWWHENOP;
5169 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
5171 scalar(ref_array_or_hash(cond)));
5174 return newGIVWHENOP(
5176 append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
5177 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
5181 =for apidoc cv_undef
5183 Clear out all the active components of a CV. This can happen either
5184 by an explicit C<undef &foo>, or by the reference count going to zero.
5185 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
5186 children can still follow the full lexical scope chain.
5192 Perl_cv_undef(pTHX_ CV *cv)
5196 PERL_ARGS_ASSERT_CV_UNDEF;
5198 DEBUG_X(PerlIO_printf(Perl_debug_log,
5199 "CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n",
5200 PTR2UV(cv), PTR2UV(PL_comppad))
5204 if (CvFILE(cv) && !CvISXSUB(cv)) {
5205 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
5206 Safefree(CvFILE(cv));
5211 if (!CvISXSUB(cv) && CvROOT(cv)) {
5212 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
5213 Perl_croak(aTHX_ "Can't undef active subroutine");
5216 PAD_SAVE_SETNULLPAD();
5218 op_free(CvROOT(cv));
5223 SvPOK_off((SV*)cv); /* forget prototype */
5228 /* remove CvOUTSIDE unless this is an undef rather than a free */
5229 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
5230 if (!CvWEAKOUTSIDE(cv))
5231 SvREFCNT_dec(CvOUTSIDE(cv));
5232 CvOUTSIDE(cv) = NULL;
5235 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
5238 if (CvISXSUB(cv) && CvXSUB(cv)) {
5241 /* delete all flags except WEAKOUTSIDE */
5242 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
5246 Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
5249 PERL_ARGS_ASSERT_CV_CKPROTO_LEN;
5251 /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
5252 relying on SvCUR, and doubling up the buffer to hold CvFILE(). */
5253 if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
5254 || (p && (len != SvCUR(cv) /* Not the same length. */
5255 || memNE(p, SvPVX_const(cv), len))))
5256 && ckWARN_d(WARN_PROTOTYPE)) {
5257 SV* const msg = sv_newmortal();
5261 gv_efullname3(name = sv_newmortal(), gv, NULL);
5262 sv_setpvs(msg, "Prototype mismatch:");
5264 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
5266 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv));
5268 sv_catpvs(msg, ": none");
5269 sv_catpvs(msg, " vs ");
5271 Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
5273 sv_catpvs(msg, "none");
5274 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
5278 static void const_sv_xsub(pTHX_ CV* cv);
5282 =head1 Optree Manipulation Functions
5284 =for apidoc cv_const_sv
5286 If C<cv> is a constant sub eligible for inlining. returns the constant
5287 value returned by the sub. Otherwise, returns NULL.
5289 Constant subs can be created with C<newCONSTSUB> or as described in
5290 L<perlsub/"Constant Functions">.
5295 Perl_cv_const_sv(pTHX_ CV *cv)
5297 PERL_UNUSED_CONTEXT;
5300 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
5302 return CvCONST(cv) ? (SV*)CvXSUBANY(cv).any_ptr : NULL;
5305 /* op_const_sv: examine an optree to determine whether it's in-lineable.
5306 * Can be called in 3 ways:
5309 * look for a single OP_CONST with attached value: return the value
5311 * cv && CvCLONE(cv) && !CvCONST(cv)
5313 * examine the clone prototype, and if contains only a single
5314 * OP_CONST referencing a pad const, or a single PADSV referencing
5315 * an outer lexical, return a non-zero value to indicate the CV is
5316 * a candidate for "constizing" at clone time
5320 * We have just cloned an anon prototype that was marked as a const
5321 * candidiate. Try to grab the current value, and in the case of
5322 * PADSV, ignore it if it has multiple references. Return the value.
5326 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
5337 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
5338 o = cLISTOPo->op_first->op_sibling;
5340 for (; o; o = o->op_next) {
5341 const OPCODE type = o->op_type;
5343 if (sv && o->op_next == o)
5345 if (o->op_next != o) {
5346 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
5348 if (type == OP_DBSTATE)
5351 if (type == OP_LEAVESUB || type == OP_RETURN)
5355 if (type == OP_CONST && cSVOPo->op_sv)
5357 else if (cv && type == OP_CONST) {
5358 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5362 else if (cv && type == OP_PADSV) {
5363 if (CvCONST(cv)) { /* newly cloned anon */
5364 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5365 /* the candidate should have 1 ref from this pad and 1 ref
5366 * from the parent */
5367 if (!sv || SvREFCNT(sv) != 2)
5374 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
5375 sv = &PL_sv_undef; /* an arbitrary non-null value */
5390 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5393 /* This would be the return value, but the return cannot be reached. */
5394 OP* pegop = newOP(OP_NULL, 0);
5397 PERL_UNUSED_ARG(floor);
5407 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
5409 NORETURN_FUNCTION_END;
5414 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
5416 return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
5420 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5427 register CV *cv = NULL;
5429 /* If the subroutine has no body, no attributes, and no builtin attributes
5430 then it's just a sub declaration, and we may be able to get away with
5431 storing with a placeholder scalar in the symbol table, rather than a
5432 full GV and CV. If anything is present then it will take a full CV to
5434 const I32 gv_fetch_flags
5435 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5437 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
5438 const char * const name = o ? SvPV_nolen_const(cSVOPo->op_sv) : NULL;
5441 assert(proto->op_type == OP_CONST);
5442 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
5447 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
5448 SV * const sv = sv_newmortal();
5449 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
5450 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
5451 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
5452 aname = SvPVX_const(sv);
5457 gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
5458 : gv_fetchpv(aname ? aname
5459 : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5460 gv_fetch_flags, SVt_PVCV);
5462 if (!PL_madskills) {
5471 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
5472 maximum a prototype before. */
5473 if (SvTYPE(gv) > SVt_NULL) {
5474 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
5475 && ckWARN_d(WARN_PROTOTYPE))
5477 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
5479 cv_ckproto_len((CV*)gv, NULL, ps, ps_len);
5482 sv_setpvn((SV*)gv, ps, ps_len);
5484 sv_setiv((SV*)gv, -1);
5486 SvREFCNT_dec(PL_compcv);
5487 cv = PL_compcv = NULL;
5491 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
5493 #ifdef GV_UNIQUE_CHECK
5494 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
5495 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
5499 if (!block || !ps || *ps || attrs
5500 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5502 || block->op_type == OP_NULL
5507 const_sv = op_const_sv(block, NULL);
5510 const bool exists = CvROOT(cv) || CvXSUB(cv);
5512 #ifdef GV_UNIQUE_CHECK
5513 if (exists && GvUNIQUE(gv)) {
5514 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
5518 /* if the subroutine doesn't exist and wasn't pre-declared
5519 * with a prototype, assume it will be AUTOLOADed,
5520 * skipping the prototype check
5522 if (exists || SvPOK(cv))
5523 cv_ckproto_len(cv, gv, ps, ps_len);
5524 /* already defined (or promised)? */
5525 if (exists || GvASSUMECV(gv)) {
5528 || block->op_type == OP_NULL
5531 if (CvFLAGS(PL_compcv)) {
5532 /* might have had built-in attrs applied */
5533 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5535 /* just a "sub foo;" when &foo is already defined */
5536 SAVEFREESV(PL_compcv);
5541 && block->op_type != OP_NULL
5544 if (ckWARN(WARN_REDEFINE)
5546 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
5548 const line_t oldline = CopLINE(PL_curcop);
5549 if (PL_parser && PL_parser->copline != NOLINE)
5550 CopLINE_set(PL_curcop, PL_parser->copline);
5551 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5552 CvCONST(cv) ? "Constant subroutine %s redefined"
5553 : "Subroutine %s redefined", name);
5554 CopLINE_set(PL_curcop, oldline);
5557 if (!PL_minus_c) /* keep old one around for madskills */
5560 /* (PL_madskills unset in used file.) */
5568 SvREFCNT_inc_simple_void_NN(const_sv);
5570 assert(!CvROOT(cv) && !CvCONST(cv));
5571 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
5572 CvXSUBANY(cv).any_ptr = const_sv;
5573 CvXSUB(cv) = const_sv_xsub;
5579 cv = newCONSTSUB(NULL, name, const_sv);
5581 mro_method_changed_in( /* sub Foo::Bar () { 123 } */
5582 (CvGV(cv) && GvSTASH(CvGV(cv)))
5591 SvREFCNT_dec(PL_compcv);
5599 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
5600 * before we clobber PL_compcv.
5604 || block->op_type == OP_NULL
5608 /* Might have had built-in attributes applied -- propagate them. */
5609 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5610 if (CvGV(cv) && GvSTASH(CvGV(cv)))
5611 stash = GvSTASH(CvGV(cv));
5612 else if (CvSTASH(cv))
5613 stash = CvSTASH(cv);
5615 stash = PL_curstash;
5618 /* possibly about to re-define existing subr -- ignore old cv */
5619 rcv = (SV*)PL_compcv;
5620 if (name && GvSTASH(gv))
5621 stash = GvSTASH(gv);
5623 stash = PL_curstash;
5625 apply_attrs(stash, rcv, attrs, FALSE);
5627 if (cv) { /* must reuse cv if autoloaded */
5634 || block->op_type == OP_NULL) && !PL_madskills
5637 /* got here with just attrs -- work done, so bug out */
5638 SAVEFREESV(PL_compcv);
5641 /* transfer PL_compcv to cv */
5643 CvFLAGS(cv) = CvFLAGS(PL_compcv);
5644 if (!CvWEAKOUTSIDE(cv))
5645 SvREFCNT_dec(CvOUTSIDE(cv));
5646 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
5647 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
5648 CvOUTSIDE(PL_compcv) = 0;
5649 CvPADLIST(cv) = CvPADLIST(PL_compcv);
5650 CvPADLIST(PL_compcv) = 0;
5651 /* inner references to PL_compcv must be fixed up ... */
5652 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
5653 /* ... before we throw it away */
5654 SvREFCNT_dec(PL_compcv);
5656 if (PERLDB_INTER)/* Advice debugger on the new sub. */
5657 ++PL_sub_generation;
5664 if (strEQ(name, "import")) {
5665 PL_formfeed = (SV*)cv;
5666 Perl_warner(aTHX_ packWARN(WARN_VOID), "%lx\n", (long)cv);
5670 mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */
5674 CvFILE_set_from_cop(cv, PL_curcop);
5675 CvSTASH(cv) = PL_curstash;
5678 sv_setpvn((SV*)cv, ps, ps_len);
5680 if (PL_parser && PL_parser->error_count) {
5684 const char *s = strrchr(name, ':');
5686 if (strEQ(s, "BEGIN")) {
5687 const char not_safe[] =
5688 "BEGIN not safe after errors--compilation aborted";
5689 if (PL_in_eval & EVAL_KEEPERR)
5690 Perl_croak(aTHX_ not_safe);
5692 /* force display of errors found but not reported */
5693 sv_catpv(ERRSV, not_safe);
5694 Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
5704 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5705 mod(scalarseq(block), OP_LEAVESUBLV));
5706 block->op_attached = 1;
5709 /* This makes sub {}; work as expected. */
5710 if (block->op_type == OP_STUB) {
5711 OP* const newblock = newSTATEOP(0, NULL, 0);
5713 op_getmad(block,newblock,'B');
5720 block->op_attached = 1;
5721 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5723 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5724 OpREFCNT_set(CvROOT(cv), 1);
5725 CvSTART(cv) = LINKLIST(CvROOT(cv));
5726 CvROOT(cv)->op_next = 0;
5727 CALL_PEEP(CvSTART(cv));
5729 /* now that optimizer has done its work, adjust pad values */
5731 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
5734 assert(!CvCONST(cv));
5735 if (ps && !*ps && op_const_sv(block, cv))
5739 if (name || aname) {
5740 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5741 SV * const sv = newSV(0);
5742 SV * const tmpstr = sv_newmortal();
5743 GV * const db_postponed = gv_fetchpvs("DB::postponed",
5744 GV_ADDMULTI, SVt_PVHV);
5747 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5749 (long)PL_subline, (long)CopLINE(PL_curcop));
5750 gv_efullname3(tmpstr, gv, NULL);
5751 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
5752 SvCUR(tmpstr), sv, 0);
5753 hv = GvHVn(db_postponed);
5754 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
5755 CV * const pcv = GvCV(db_postponed);
5761 call_sv((SV*)pcv, G_DISCARD);
5766 if (name && ! (PL_parser && PL_parser->error_count))
5767 process_special_blocks(name, gv, cv);
5772 PL_parser->copline = NOLINE;
5778 S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
5781 const char *const colon = strrchr(fullname,':');
5782 const char *const name = colon ? colon + 1 : fullname;
5784 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
5787 if (strEQ(name, "BEGIN")) {
5788 const I32 oldscope = PL_scopestack_ix;
5790 SAVECOPFILE(&PL_compiling);
5791 SAVECOPLINE(&PL_compiling);
5793 DEBUG_x( dump_sub(gv) );
5794 Perl_av_create_and_push(aTHX_ &PL_beginav, (SV*)cv);
5795 GvCV(gv) = 0; /* cv has been hijacked */
5796 call_list(oldscope, PL_beginav);
5798 PL_curcop = &PL_compiling;
5799 CopHINTS_set(&PL_compiling, PL_hints);
5806 if strEQ(name, "END") {
5807 DEBUG_x( dump_sub(gv) );
5808 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, (SV*)cv);
5811 } else if (*name == 'U') {
5812 if (strEQ(name, "UNITCHECK")) {
5813 /* It's never too late to run a unitcheck block */
5814 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, (SV*)cv);
5818 } else if (*name == 'C') {
5819 if (strEQ(name, "CHECK")) {
5820 if (PL_main_start && ckWARN(WARN_VOID))
5821 Perl_warner(aTHX_ packWARN(WARN_VOID),
5822 "Too late to run CHECK block");
5823 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, (SV*)cv);
5827 } else if (*name == 'I') {
5828 if (strEQ(name, "INIT")) {
5829 if (PL_main_start && ckWARN(WARN_VOID))
5830 Perl_warner(aTHX_ packWARN(WARN_VOID),
5831 "Too late to run INIT block");
5832 Perl_av_create_and_push(aTHX_ &PL_initav, (SV*)cv);
5838 DEBUG_x( dump_sub(gv) );
5839 GvCV(gv) = 0; /* cv has been hijacked */
5844 =for apidoc newCONSTSUB
5846 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5847 eligible for inlining at compile-time.
5853 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
5858 const char *const temp_p = CopFILE(PL_curcop);
5859 const STRLEN len = temp_p ? strlen(temp_p) : 0;
5861 SV *const temp_sv = CopFILESV(PL_curcop);
5863 const char *const temp_p = temp_sv ? SvPV_const(temp_sv, len) : NULL;
5865 char *const file = savepvn(temp_p, temp_p ? len : 0);
5869 if (IN_PERL_RUNTIME) {
5870 /* at runtime, it's not safe to manipulate PL_curcop: it may be
5871 * an op shared between threads. Use a non-shared COP for our
5873 SAVEVPTR(PL_curcop);
5874 PL_curcop = &PL_compiling;
5876 SAVECOPLINE(PL_curcop);
5877 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
5880 PL_hints &= ~HINT_BLOCK_SCOPE;
5883 SAVESPTR(PL_curstash);
5884 SAVECOPSTASH(PL_curcop);
5885 PL_curstash = stash;
5886 CopSTASH_set(PL_curcop,stash);
5889 /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
5890 and so doesn't get free()d. (It's expected to be from the C pre-
5891 processor __FILE__ directive). But we need a dynamically allocated one,
5892 and we need it to get freed. */
5893 cv = newXS_flags(name, const_sv_xsub, file, "", XS_DYNAMIC_FILENAME);
5894 CvXSUBANY(cv).any_ptr = sv;
5900 CopSTASH_free(PL_curcop);
5908 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
5909 const char *const filename, const char *const proto,
5912 CV *cv = newXS(name, subaddr, filename);
5914 PERL_ARGS_ASSERT_NEWXS_FLAGS;
5916 if (flags & XS_DYNAMIC_FILENAME) {
5917 /* We need to "make arrangements" (ie cheat) to ensure that the
5918 filename lasts as long as the PVCV we just created, but also doesn't
5920 STRLEN filename_len = strlen(filename);
5921 STRLEN proto_and_file_len = filename_len;
5922 char *proto_and_file;
5926 proto_len = strlen(proto);
5927 proto_and_file_len += proto_len;
5929 Newx(proto_and_file, proto_and_file_len + 1, char);
5930 Copy(proto, proto_and_file, proto_len, char);
5931 Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
5934 proto_and_file = savepvn(filename, filename_len);
5937 /* This gets free()d. :-) */
5938 sv_usepvn_flags((SV*)cv, proto_and_file, proto_and_file_len,
5939 SV_HAS_TRAILING_NUL);
5941 /* This gives us the correct prototype, rather than one with the
5942 file name appended. */
5943 SvCUR_set(cv, proto_len);
5947 CvFILE(cv) = proto_and_file + proto_len;
5949 sv_setpv((SV *)cv, proto);
5955 =for apidoc U||newXS
5957 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
5958 static storage, as it is used directly as CvFILE(), without a copy being made.
5964 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
5967 GV * const gv = gv_fetchpv(name ? name :
5968 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5969 GV_ADDMULTI, SVt_PVCV);
5972 PERL_ARGS_ASSERT_NEWXS;
5975 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
5977 if ((cv = (name ? GvCV(gv) : NULL))) {
5979 /* just a cached method */
5983 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5984 /* already defined (or promised) */
5985 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
5986 if (ckWARN(WARN_REDEFINE)) {
5987 GV * const gvcv = CvGV(cv);
5989 HV * const stash = GvSTASH(gvcv);
5991 const char *redefined_name = HvNAME_get(stash);
5992 if ( strEQ(redefined_name,"autouse") ) {
5993 const line_t oldline = CopLINE(PL_curcop);
5994 if (PL_parser && PL_parser->copline != NOLINE)
5995 CopLINE_set(PL_curcop, PL_parser->copline);
5996 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5997 CvCONST(cv) ? "Constant subroutine %s redefined"
5998 : "Subroutine %s redefined"
6000 CopLINE_set(PL_curcop, oldline);
6010 if (cv) /* must reuse cv if autoloaded */
6013 cv = (CV*)newSV_type(SVt_PVCV);
6017 mro_method_changed_in(GvSTASH(gv)); /* newXS */
6021 (void)gv_fetchfile(filename);
6022 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
6023 an external constant string */
6025 CvXSUB(cv) = subaddr;
6028 process_special_blocks(name, gv, cv);
6040 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
6045 OP* pegop = newOP(OP_NULL, 0);
6049 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
6050 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
6052 #ifdef GV_UNIQUE_CHECK
6054 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
6058 if ((cv = GvFORM(gv))) {
6059 if (ckWARN(WARN_REDEFINE)) {
6060 const line_t oldline = CopLINE(PL_curcop);
6061 if (PL_parser && PL_parser->copline != NOLINE)
6062 CopLINE_set(PL_curcop, PL_parser->copline);
6063 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6064 o ? "Format %"SVf" redefined"
6065 : "Format STDOUT redefined", SVfARG(cSVOPo->op_sv));
6066 CopLINE_set(PL_curcop, oldline);
6073 CvFILE_set_from_cop(cv, PL_curcop);
6076 pad_tidy(padtidy_FORMAT);
6077 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
6078 CvROOT(cv)->op_private |= OPpREFCOUNTED;
6079 OpREFCNT_set(CvROOT(cv), 1);
6080 CvSTART(cv) = LINKLIST(CvROOT(cv));
6081 CvROOT(cv)->op_next = 0;
6082 CALL_PEEP(CvSTART(cv));
6084 op_getmad(o,pegop,'n');
6085 op_getmad_weak(block, pegop, 'b');
6090 PL_parser->copline = NOLINE;
6098 Perl_newANONLIST(pTHX_ OP *o)
6100 return convert(OP_ANONLIST, OPf_SPECIAL, o);
6104 Perl_newANONHASH(pTHX_ OP *o)
6106 return convert(OP_ANONHASH, OPf_SPECIAL, o);
6110 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
6112 return newANONATTRSUB(floor, proto, NULL, block);
6116 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
6118 return newUNOP(OP_REFGEN, 0,
6119 newSVOP(OP_ANONCODE, 0,
6120 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
6124 Perl_oopsAV(pTHX_ OP *o)
6128 PERL_ARGS_ASSERT_OOPSAV;
6130 switch (o->op_type) {
6132 o->op_type = OP_PADAV;
6133 o->op_ppaddr = PL_ppaddr[OP_PADAV];
6134 return ref(o, OP_RV2AV);
6137 o->op_type = OP_RV2AV;
6138 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
6143 if (ckWARN_d(WARN_INTERNAL))
6144 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
6151 Perl_oopsHV(pTHX_ OP *o)
6155 PERL_ARGS_ASSERT_OOPSHV;
6157 switch (o->op_type) {
6160 o->op_type = OP_PADHV;
6161 o->op_ppaddr = PL_ppaddr[OP_PADHV];
6162 return ref(o, OP_RV2HV);
6166 o->op_type = OP_RV2HV;
6167 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
6172 if (ckWARN_d(WARN_INTERNAL))
6173 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
6180 Perl_newAVREF(pTHX_ OP *o)
6184 PERL_ARGS_ASSERT_NEWAVREF;
6186 if (o->op_type == OP_PADANY) {
6187 o->op_type = OP_PADAV;
6188 o->op_ppaddr = PL_ppaddr[OP_PADAV];
6191 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
6192 && ckWARN(WARN_DEPRECATED)) {
6193 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
6194 "Using an array as a reference is deprecated");
6196 return newUNOP(OP_RV2AV, 0, scalar(o));
6200 Perl_newGVREF(pTHX_ I32 type, OP *o)
6202 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
6203 return newUNOP(OP_NULL, 0, o);
6204 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
6208 Perl_newHVREF(pTHX_ OP *o)
6212 PERL_ARGS_ASSERT_NEWHVREF;
6214 if (o->op_type == OP_PADANY) {
6215 o->op_type = OP_PADHV;
6216 o->op_ppaddr = PL_ppaddr[OP_PADHV];
6219 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
6220 && ckWARN(WARN_DEPRECATED)) {
6221 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
6222 "Using a hash as a reference is deprecated");
6224 return newUNOP(OP_RV2HV, 0, scalar(o));
6228 Perl_newCVREF(pTHX_ I32 flags, OP *o)
6230 return newUNOP(OP_RV2CV, flags, scalar(o));
6234 Perl_newSVREF(pTHX_ OP *o)
6238 PERL_ARGS_ASSERT_NEWSVREF;
6240 if (o->op_type == OP_PADANY) {
6241 o->op_type = OP_PADSV;
6242 o->op_ppaddr = PL_ppaddr[OP_PADSV];
6245 return newUNOP(OP_RV2SV, 0, scalar(o));
6248 /* Check routines. See the comments at the top of this file for details
6249 * on when these are called */
6252 Perl_ck_anoncode(pTHX_ OP *o)
6254 PERL_ARGS_ASSERT_CK_ANONCODE;
6256 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
6258 cSVOPo->op_sv = NULL;
6263 Perl_ck_bitop(pTHX_ OP *o)
6267 PERL_ARGS_ASSERT_CK_BITOP;
6269 #define OP_IS_NUMCOMPARE(op) \
6270 ((op) == OP_LT || (op) == OP_I_LT || \
6271 (op) == OP_GT || (op) == OP_I_GT || \
6272 (op) == OP_LE || (op) == OP_I_LE || \
6273 (op) == OP_GE || (op) == OP_I_GE || \
6274 (op) == OP_EQ || (op) == OP_I_EQ || \
6275 (op) == OP_NE || (op) == OP_I_NE || \
6276 (op) == OP_NCMP || (op) == OP_I_NCMP)
6277 o->op_private = (U8)(PL_hints & HINT_INTEGER);
6278 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
6279 && (o->op_type == OP_BIT_OR
6280 || o->op_type == OP_BIT_AND
6281 || o->op_type == OP_BIT_XOR))
6283 const OP * const left = cBINOPo->op_first;
6284 const OP * const right = left->op_sibling;
6285 if ((OP_IS_NUMCOMPARE(left->op_type) &&
6286 (left->op_flags & OPf_PARENS) == 0) ||
6287 (OP_IS_NUMCOMPARE(right->op_type) &&
6288 (right->op_flags & OPf_PARENS) == 0))
6289 if (ckWARN(WARN_PRECEDENCE))
6290 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
6291 "Possible precedence problem on bitwise %c operator",
6292 o->op_type == OP_BIT_OR ? '|'
6293 : o->op_type == OP_BIT_AND ? '&' : '^'
6300 Perl_ck_concat(pTHX_ OP *o)
6302 const OP * const kid = cUNOPo->op_first;
6304 PERL_ARGS_ASSERT_CK_CONCAT;
6305 PERL_UNUSED_CONTEXT;
6307 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
6308 !(kUNOP->op_first->op_flags & OPf_MOD))
6309 o->op_flags |= OPf_STACKED;
6314 Perl_ck_spair(pTHX_ OP *o)
6318 PERL_ARGS_ASSERT_CK_SPAIR;
6320 if (o->op_flags & OPf_KIDS) {
6323 const OPCODE type = o->op_type;
6324 o = modkids(ck_fun(o), type);
6325 kid = cUNOPo->op_first;
6326 newop = kUNOP->op_first->op_sibling;
6328 const OPCODE type = newop->op_type;
6329 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
6330 type == OP_PADAV || type == OP_PADHV ||
6331 type == OP_RV2AV || type == OP_RV2HV)
6335 op_getmad(kUNOP->op_first,newop,'K');
6337 op_free(kUNOP->op_first);
6339 kUNOP->op_first = newop;
6341 o->op_ppaddr = PL_ppaddr[++o->op_type];
6346 Perl_ck_delete(pTHX_ OP *o)
6348 PERL_ARGS_ASSERT_CK_DELETE;
6352 if (o->op_flags & OPf_KIDS) {
6353 OP * const kid = cUNOPo->op_first;
6354 switch (kid->op_type) {
6356 o->op_flags |= OPf_SPECIAL;
6359 o->op_private |= OPpSLICE;
6362 o->op_flags |= OPf_SPECIAL;
6367 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
6376 Perl_ck_die(pTHX_ OP *o)
6378 PERL_ARGS_ASSERT_CK_DIE;
6381 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6387 Perl_ck_eof(pTHX_ OP *o)
6391 PERL_ARGS_ASSERT_CK_EOF;
6393 if (o->op_flags & OPf_KIDS) {
6394 if (cLISTOPo->op_first->op_type == OP_STUB) {
6396 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
6398 op_getmad(o,newop,'O');
6410 Perl_ck_eval(pTHX_ OP *o)
6414 PERL_ARGS_ASSERT_CK_EVAL;
6416 PL_hints |= HINT_BLOCK_SCOPE;
6417 if (o->op_flags & OPf_KIDS) {
6418 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6421 o->op_flags &= ~OPf_KIDS;
6424 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
6430 cUNOPo->op_first = 0;
6435 NewOp(1101, enter, 1, LOGOP);
6436 enter->op_type = OP_ENTERTRY;
6437 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
6438 enter->op_private = 0;
6440 /* establish postfix order */
6441 enter->op_next = (OP*)enter;
6443 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
6444 o->op_type = OP_LEAVETRY;
6445 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
6446 enter->op_other = o;
6447 op_getmad(oldo,o,'O');
6461 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
6462 op_getmad(oldo,o,'O');
6464 o->op_targ = (PADOFFSET)PL_hints;
6465 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
6466 /* Store a copy of %^H that pp_entereval can pick up.
6467 OPf_SPECIAL flags the opcode as being for this purpose,
6468 so that it in turn will return a copy at every
6470 OP *hhop = newSVOP(OP_CONST, OPf_SPECIAL,
6471 (SV*)Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv)));
6472 cUNOPo->op_first->op_sibling = hhop;
6473 o->op_private |= OPpEVAL_HAS_HH;
6479 Perl_ck_exit(pTHX_ OP *o)
6481 PERL_ARGS_ASSERT_CK_EXIT;
6484 HV * const table = GvHV(PL_hintgv);
6486 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
6487 if (svp && *svp && SvTRUE(*svp))
6488 o->op_private |= OPpEXIT_VMSISH;
6490 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6496 Perl_ck_exec(pTHX_ OP *o)
6498 PERL_ARGS_ASSERT_CK_EXEC;
6500 if (o->op_flags & OPf_STACKED) {
6503 kid = cUNOPo->op_first->op_sibling;
6504 if (kid->op_type == OP_RV2GV)
6513 Perl_ck_exists(pTHX_ OP *o)
6517 PERL_ARGS_ASSERT_CK_EXISTS;
6520 if (o->op_flags & OPf_KIDS) {
6521 OP * const kid = cUNOPo->op_first;
6522 if (kid->op_type == OP_ENTERSUB) {
6523 (void) ref(kid, o->op_type);
6524 if (kid->op_type != OP_RV2CV
6525 && !(PL_parser && PL_parser->error_count))
6526 Perl_croak(aTHX_ "%s argument is not a subroutine name",
6528 o->op_private |= OPpEXISTS_SUB;
6530 else if (kid->op_type == OP_AELEM)
6531 o->op_flags |= OPf_SPECIAL;
6532 else if (kid->op_type != OP_HELEM)
6533 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
6541 Perl_ck_rvconst(pTHX_ register OP *o)
6544 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6546 PERL_ARGS_ASSERT_CK_RVCONST;
6548 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6549 if (o->op_type == OP_RV2CV)
6550 o->op_private &= ~1;
6552 if (kid->op_type == OP_CONST) {
6555 SV * const kidsv = kid->op_sv;
6557 /* Is it a constant from cv_const_sv()? */
6558 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
6559 SV * const rsv = SvRV(kidsv);
6560 const svtype type = SvTYPE(rsv);
6561 const char *badtype = NULL;
6563 switch (o->op_type) {
6565 if (type > SVt_PVMG)
6566 badtype = "a SCALAR";
6569 if (type != SVt_PVAV)
6570 badtype = "an ARRAY";
6573 if (type != SVt_PVHV)
6577 if (type != SVt_PVCV)
6582 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
6585 else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
6586 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
6587 /* If this is an access to a stash, disable "strict refs", because
6588 * stashes aren't auto-vivified at compile-time (unless we store
6589 * symbols in them), and we don't want to produce a run-time
6590 * stricture error when auto-vivifying the stash. */
6591 const char *s = SvPV_nolen(kidsv);
6592 const STRLEN l = SvCUR(kidsv);
6593 if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
6594 o->op_private &= ~HINT_STRICT_REFS;
6596 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
6597 const char *badthing;
6598 switch (o->op_type) {
6600 badthing = "a SCALAR";
6603 badthing = "an ARRAY";
6606 badthing = "a HASH";
6614 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
6615 SVfARG(kidsv), badthing);
6618 * This is a little tricky. We only want to add the symbol if we
6619 * didn't add it in the lexer. Otherwise we get duplicate strict
6620 * warnings. But if we didn't add it in the lexer, we must at
6621 * least pretend like we wanted to add it even if it existed before,
6622 * or we get possible typo warnings. OPpCONST_ENTERED says
6623 * whether the lexer already added THIS instance of this symbol.
6625 iscv = (o->op_type == OP_RV2CV) * 2;
6627 gv = gv_fetchsv(kidsv,
6628 iscv | !(kid->op_private & OPpCONST_ENTERED),
6631 : o->op_type == OP_RV2SV
6633 : o->op_type == OP_RV2AV
6635 : o->op_type == OP_RV2HV
6638 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
6640 kid->op_type = OP_GV;
6641 SvREFCNT_dec(kid->op_sv);
6643 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
6644 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
6645 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
6647 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc_simple_NN(gv));
6649 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
6651 kid->op_private = 0;
6652 kid->op_ppaddr = PL_ppaddr[OP_GV];
6659 Perl_ck_ftst(pTHX_ OP *o)
6662 const I32 type = o->op_type;
6664 PERL_ARGS_ASSERT_CK_FTST;
6666 if (o->op_flags & OPf_REF) {
6669 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
6670 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6671 const OPCODE kidtype = kid->op_type;
6673 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6674 OP * const newop = newGVOP(type, OPf_REF,
6675 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
6677 op_getmad(o,newop,'O');
6683 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o))
6684 o->op_private |= OPpFT_ACCESS;
6685 if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst)
6686 && kidtype != OP_STAT && kidtype != OP_LSTAT)
6687 o->op_private |= OPpFT_STACKED;
6695 if (type == OP_FTTTY)
6696 o = newGVOP(type, OPf_REF, PL_stdingv);
6698 o = newUNOP(type, 0, newDEFSVOP());
6699 op_getmad(oldo,o,'O');
6705 Perl_ck_fun(pTHX_ OP *o)
6708 const int type = o->op_type;
6709 register I32 oa = PL_opargs[type] >> OASHIFT;
6711 PERL_ARGS_ASSERT_CK_FUN;
6713 if (o->op_flags & OPf_STACKED) {
6714 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
6717 return no_fh_allowed(o);
6720 if (o->op_flags & OPf_KIDS) {
6721 OP **tokid = &cLISTOPo->op_first;
6722 register OP *kid = cLISTOPo->op_first;
6726 if (kid->op_type == OP_PUSHMARK ||
6727 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
6729 tokid = &kid->op_sibling;
6730 kid = kid->op_sibling;
6732 if (!kid && PL_opargs[type] & OA_DEFGV)
6733 *tokid = kid = newDEFSVOP();
6737 sibl = kid->op_sibling;
6739 if (!sibl && kid->op_type == OP_STUB) {
6746 /* list seen where single (scalar) arg expected? */
6747 if (numargs == 1 && !(oa >> 4)
6748 && kid->op_type == OP_LIST && type != OP_SCALAR)
6750 return too_many_arguments(o,PL_op_desc[type]);
6763 if ((type == OP_PUSH || type == OP_UNSHIFT)
6764 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
6765 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6766 "Useless use of %s with no values",
6769 if (kid->op_type == OP_CONST &&
6770 (kid->op_private & OPpCONST_BARE))
6772 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
6773 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
6774 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6775 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6776 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
6777 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6779 op_getmad(kid,newop,'K');
6784 kid->op_sibling = sibl;
6787 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
6788 bad_type(numargs, "array", PL_op_desc[type], kid);
6792 if (kid->op_type == OP_CONST &&
6793 (kid->op_private & OPpCONST_BARE))
6795 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
6796 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
6797 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6798 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6799 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
6800 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6802 op_getmad(kid,newop,'K');
6807 kid->op_sibling = sibl;
6810 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
6811 bad_type(numargs, "hash", PL_op_desc[type], kid);
6816 OP * const newop = newUNOP(OP_NULL, 0, kid);
6817 kid->op_sibling = 0;
6819 newop->op_next = newop;
6821 kid->op_sibling = sibl;
6826 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
6827 if (kid->op_type == OP_CONST &&
6828 (kid->op_private & OPpCONST_BARE))
6830 OP * const newop = newGVOP(OP_GV, 0,
6831 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
6832 if (!(o->op_private & 1) && /* if not unop */
6833 kid == cLISTOPo->op_last)
6834 cLISTOPo->op_last = newop;
6836 op_getmad(kid,newop,'K');
6842 else if (kid->op_type == OP_READLINE) {
6843 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
6844 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
6847 I32 flags = OPf_SPECIAL;
6851 /* is this op a FH constructor? */
6852 if (is_handle_constructor(o,numargs)) {
6853 const char *name = NULL;
6857 /* Set a flag to tell rv2gv to vivify
6858 * need to "prove" flag does not mean something
6859 * else already - NI-S 1999/05/07
6862 if (kid->op_type == OP_PADSV) {
6864 = PAD_COMPNAME_SV(kid->op_targ);
6865 name = SvPV_const(namesv, len);
6867 else if (kid->op_type == OP_RV2SV
6868 && kUNOP->op_first->op_type == OP_GV)
6870 GV * const gv = cGVOPx_gv(kUNOP->op_first);
6872 len = GvNAMELEN(gv);
6874 else if (kid->op_type == OP_AELEM
6875 || kid->op_type == OP_HELEM)
6878 OP *op = ((BINOP*)kid)->op_first;
6882 const char * const a =
6883 kid->op_type == OP_AELEM ?
6885 if (((op->op_type == OP_RV2AV) ||
6886 (op->op_type == OP_RV2HV)) &&
6887 (firstop = ((UNOP*)op)->op_first) &&
6888 (firstop->op_type == OP_GV)) {
6889 /* packagevar $a[] or $h{} */
6890 GV * const gv = cGVOPx_gv(firstop);
6898 else if (op->op_type == OP_PADAV
6899 || op->op_type == OP_PADHV) {
6900 /* lexicalvar $a[] or $h{} */
6901 const char * const padname =
6902 PAD_COMPNAME_PV(op->op_targ);
6911 name = SvPV_const(tmpstr, len);
6916 name = "__ANONIO__";
6923 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
6924 namesv = PAD_SVl(targ);
6925 SvUPGRADE(namesv, SVt_PV);
6927 sv_setpvn(namesv, "$", 1);
6928 sv_catpvn(namesv, name, len);
6931 kid->op_sibling = 0;
6932 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
6933 kid->op_targ = targ;
6934 kid->op_private |= priv;
6936 kid->op_sibling = sibl;
6942 mod(scalar(kid), type);
6946 tokid = &kid->op_sibling;
6947 kid = kid->op_sibling;
6950 if (kid && kid->op_type != OP_STUB)
6951 return too_many_arguments(o,OP_DESC(o));
6952 o->op_private |= numargs;
6954 /* FIXME - should the numargs move as for the PERL_MAD case? */
6955 o->op_private |= numargs;
6957 return too_many_arguments(o,OP_DESC(o));
6961 else if (PL_opargs[type] & OA_DEFGV) {
6963 OP *newop = newUNOP(type, 0, newDEFSVOP());
6964 op_getmad(o,newop,'O');
6967 /* Ordering of these two is important to keep f_map.t passing. */
6969 return newUNOP(type, 0, newDEFSVOP());
6974 while (oa & OA_OPTIONAL)
6976 if (oa && oa != OA_LIST)
6977 return too_few_arguments(o,OP_DESC(o));
6983 Perl_ck_glob(pTHX_ OP *o)
6988 PERL_ARGS_ASSERT_CK_GLOB;
6991 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
6992 append_elem(OP_GLOB, o, newDEFSVOP());
6994 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
6995 && GvCVu(gv) && GvIMPORTED_CV(gv)))
6997 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7000 #if !defined(PERL_EXTERNAL_GLOB)
7001 /* XXX this can be tightened up and made more failsafe. */
7002 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7005 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
7006 newSVpvs("File::Glob"), NULL, NULL, NULL);
7007 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7008 glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
7009 GvCV(gv) = GvCV(glob_gv);
7010 SvREFCNT_inc_void((SV*)GvCV(gv));
7011 GvIMPORTED_CV_on(gv);
7014 #endif /* PERL_EXTERNAL_GLOB */
7016 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7017 append_elem(OP_GLOB, o,
7018 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
7019 o->op_type = OP_LIST;
7020 o->op_ppaddr = PL_ppaddr[OP_LIST];
7021 cLISTOPo->op_first->op_type = OP_PUSHMARK;
7022 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
7023 cLISTOPo->op_first->op_targ = 0;
7024 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
7025 append_elem(OP_LIST, o,
7026 scalar(newUNOP(OP_RV2CV, 0,
7027 newGVOP(OP_GV, 0, gv)))));
7028 o = newUNOP(OP_NULL, 0, ck_subr(o));
7029 o->op_targ = OP_GLOB; /* hint at what it used to be */
7032 gv = newGVgen("main");
7034 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
7040 Perl_ck_grep(pTHX_ OP *o)
7045 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
7048 PERL_ARGS_ASSERT_CK_GREP;
7050 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
7051 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
7053 if (o->op_flags & OPf_STACKED) {
7056 kid = cLISTOPo->op_first->op_sibling;
7057 if (!cUNOPx(kid)->op_next)
7058 Perl_croak(aTHX_ "panic: ck_grep");
7059 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
7062 NewOp(1101, gwop, 1, LOGOP);
7063 kid->op_next = (OP*)gwop;
7064 o->op_flags &= ~OPf_STACKED;
7066 kid = cLISTOPo->op_first->op_sibling;
7067 if (type == OP_MAPWHILE)
7072 if (PL_parser && PL_parser->error_count)
7074 kid = cLISTOPo->op_first->op_sibling;
7075 if (kid->op_type != OP_NULL)
7076 Perl_croak(aTHX_ "panic: ck_grep");
7077 kid = kUNOP->op_first;
7080 NewOp(1101, gwop, 1, LOGOP);
7081 gwop->op_type = type;
7082 gwop->op_ppaddr = PL_ppaddr[type];
7083 gwop->op_first = listkids(o);
7084 gwop->op_flags |= OPf_KIDS;
7085 gwop->op_other = LINKLIST(kid);
7086 kid->op_next = (OP*)gwop;
7087 offset = pad_findmy("$_");
7088 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
7089 o->op_private = gwop->op_private = 0;
7090 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
7093 o->op_private = gwop->op_private = OPpGREP_LEX;
7094 gwop->op_targ = o->op_targ = offset;
7097 kid = cLISTOPo->op_first->op_sibling;
7098 if (!kid || !kid->op_sibling)
7099 return too_few_arguments(o,OP_DESC(o));
7100 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
7101 mod(kid, OP_GREPSTART);
7107 Perl_ck_index(pTHX_ OP *o)
7109 PERL_ARGS_ASSERT_CK_INDEX;
7111 if (o->op_flags & OPf_KIDS) {
7112 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7114 kid = kid->op_sibling; /* get past "big" */
7115 if (kid && kid->op_type == OP_CONST)
7116 fbm_compile(((SVOP*)kid)->op_sv, 0);
7122 Perl_ck_lengthconst(pTHX_ OP *o)
7124 PERL_ARGS_ASSERT_CK_LENGTHCONST;
7126 /* XXX length optimization goes here */
7131 Perl_ck_lfun(pTHX_ OP *o)
7133 const OPCODE type = o->op_type;
7135 PERL_ARGS_ASSERT_CK_LFUN;
7137 return modkids(ck_fun(o), type);
7141 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
7143 PERL_ARGS_ASSERT_CK_DEFINED;
7145 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
7146 switch (cUNOPo->op_first->op_type) {
7148 /* This is needed for
7149 if (defined %stash::)
7150 to work. Do not break Tk.
7152 break; /* Globals via GV can be undef */
7154 case OP_AASSIGN: /* Is this a good idea? */
7155 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
7156 "defined(@array) is deprecated");
7157 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
7158 "\t(Maybe you should just omit the defined()?)\n");
7161 /* This is needed for
7162 if (defined %stash::)
7163 to work. Do not break Tk.
7165 break; /* Globals via GV can be undef */
7167 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
7168 "defined(%%hash) is deprecated");
7169 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
7170 "\t(Maybe you should just omit the defined()?)\n");
7181 Perl_ck_readline(pTHX_ OP *o)
7183 PERL_ARGS_ASSERT_CK_READLINE;
7185 if (!(o->op_flags & OPf_KIDS)) {
7187 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
7189 op_getmad(o,newop,'O');
7199 Perl_ck_rfun(pTHX_ OP *o)
7201 const OPCODE type = o->op_type;
7203 PERL_ARGS_ASSERT_CK_RFUN;
7205 return refkids(ck_fun(o), type);
7209 Perl_ck_listiob(pTHX_ OP *o)
7213 PERL_ARGS_ASSERT_CK_LISTIOB;
7215 kid = cLISTOPo->op_first;
7218 kid = cLISTOPo->op_first;
7220 if (kid->op_type == OP_PUSHMARK)
7221 kid = kid->op_sibling;
7222 if (kid && o->op_flags & OPf_STACKED)
7223 kid = kid->op_sibling;
7224 else if (kid && !kid->op_sibling) { /* print HANDLE; */
7225 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
7226 o->op_flags |= OPf_STACKED; /* make it a filehandle */
7227 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
7228 cLISTOPo->op_first->op_sibling = kid;
7229 cLISTOPo->op_last = kid;
7230 kid = kid->op_sibling;
7235 append_elem(o->op_type, o, newDEFSVOP());
7241 Perl_ck_smartmatch(pTHX_ OP *o)
7244 if (0 == (o->op_flags & OPf_SPECIAL)) {
7245 OP *first = cBINOPo->op_first;
7246 OP *second = first->op_sibling;
7248 /* Implicitly take a reference to an array or hash */
7249 first->op_sibling = NULL;
7250 first = cBINOPo->op_first = ref_array_or_hash(first);
7251 second = first->op_sibling = ref_array_or_hash(second);
7253 /* Implicitly take a reference to a regular expression */
7254 if (first->op_type == OP_MATCH) {
7255 first->op_type = OP_QR;
7256 first->op_ppaddr = PL_ppaddr[OP_QR];
7258 if (second->op_type == OP_MATCH) {
7259 second->op_type = OP_QR;
7260 second->op_ppaddr = PL_ppaddr[OP_QR];
7269 Perl_ck_sassign(pTHX_ OP *o)
7272 OP * const kid = cLISTOPo->op_first;
7274 PERL_ARGS_ASSERT_CK_SASSIGN;
7276 /* has a disposable target? */
7277 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
7278 && !(kid->op_flags & OPf_STACKED)
7279 /* Cannot steal the second time! */
7280 && !(kid->op_private & OPpTARGET_MY)
7281 /* Keep the full thing for madskills */
7285 OP * const kkid = kid->op_sibling;
7287 /* Can just relocate the target. */
7288 if (kkid && kkid->op_type == OP_PADSV
7289 && !(kkid->op_private & OPpLVAL_INTRO))
7291 kid->op_targ = kkid->op_targ;
7293 /* Now we do not need PADSV and SASSIGN. */
7294 kid->op_sibling = o->op_sibling; /* NULL */
7295 cLISTOPo->op_first = NULL;
7298 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
7302 if (kid->op_sibling) {
7303 OP *kkid = kid->op_sibling;
7304 if (kkid->op_type == OP_PADSV
7305 && (kkid->op_private & OPpLVAL_INTRO)
7306 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
7307 const PADOFFSET target = kkid->op_targ;
7308 OP *const other = newOP(OP_PADSV,
7310 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
7311 OP *const first = newOP(OP_NULL, 0);
7312 OP *const nullop = newCONDOP(0, first, o, other);
7313 OP *const condop = first->op_next;
7314 /* hijacking PADSTALE for uninitialized state variables */
7315 SvPADSTALE_on(PAD_SVl(target));
7317 condop->op_type = OP_ONCE;
7318 condop->op_ppaddr = PL_ppaddr[OP_ONCE];
7319 condop->op_targ = target;
7320 other->op_targ = target;
7322 /* Because we change the type of the op here, we will skip the
7323 assinment binop->op_last = binop->op_first->op_sibling; at the
7324 end of Perl_newBINOP(). So need to do it here. */
7325 cBINOPo->op_last = cBINOPo->op_first->op_sibling;
7334 Perl_ck_match(pTHX_ OP *o)
7338 PERL_ARGS_ASSERT_CK_MATCH;
7340 if (o->op_type != OP_QR && PL_compcv) {
7341 const PADOFFSET offset = pad_findmy("$_");
7342 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
7343 o->op_targ = offset;
7344 o->op_private |= OPpTARGET_MY;
7347 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
7348 o->op_private |= OPpRUNTIME;
7353 Perl_ck_method(pTHX_ OP *o)
7355 OP * const kid = cUNOPo->op_first;
7357 PERL_ARGS_ASSERT_CK_METHOD;
7359 if (kid->op_type == OP_CONST) {
7360 SV* sv = kSVOP->op_sv;
7361 const char * const method = SvPVX_const(sv);
7362 if (!(strchr(method, ':') || strchr(method, '\''))) {
7364 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
7365 sv = newSVpvn_share(method, SvCUR(sv), 0);
7368 kSVOP->op_sv = NULL;
7370 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
7372 op_getmad(o,cmop,'O');
7383 Perl_ck_null(pTHX_ OP *o)
7385 PERL_ARGS_ASSERT_CK_NULL;
7386 PERL_UNUSED_CONTEXT;
7391 Perl_ck_open(pTHX_ OP *o)
7394 HV * const table = GvHV(PL_hintgv);
7396 PERL_ARGS_ASSERT_CK_OPEN;
7399 SV **svp = hv_fetchs(table, "open_IN", FALSE);
7401 const I32 mode = mode_from_discipline(*svp);
7402 if (mode & O_BINARY)
7403 o->op_private |= OPpOPEN_IN_RAW;
7404 else if (mode & O_TEXT)
7405 o->op_private |= OPpOPEN_IN_CRLF;
7408 svp = hv_fetchs(table, "open_OUT", FALSE);
7410 const I32 mode = mode_from_discipline(*svp);
7411 if (mode & O_BINARY)
7412 o->op_private |= OPpOPEN_OUT_RAW;
7413 else if (mode & O_TEXT)
7414 o->op_private |= OPpOPEN_OUT_CRLF;
7417 if (o->op_type == OP_BACKTICK) {
7418 if (!(o->op_flags & OPf_KIDS)) {
7419 OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
7421 op_getmad(o,newop,'O');
7430 /* In case of three-arg dup open remove strictness
7431 * from the last arg if it is a bareword. */
7432 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
7433 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
7437 if ((last->op_type == OP_CONST) && /* The bareword. */
7438 (last->op_private & OPpCONST_BARE) &&
7439 (last->op_private & OPpCONST_STRICT) &&
7440 (oa = first->op_sibling) && /* The fh. */
7441 (oa = oa->op_sibling) && /* The mode. */
7442 (oa->op_type == OP_CONST) &&
7443 SvPOK(((SVOP*)oa)->op_sv) &&
7444 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
7445 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
7446 (last == oa->op_sibling)) /* The bareword. */
7447 last->op_private &= ~OPpCONST_STRICT;
7453 Perl_ck_repeat(pTHX_ OP *o)
7455 PERL_ARGS_ASSERT_CK_REPEAT;
7457 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
7458 o->op_private |= OPpREPEAT_DOLIST;
7459 cBINOPo->op_first = force_list(cBINOPo->op_first);
7467 Perl_ck_require(pTHX_ OP *o)
7472 PERL_ARGS_ASSERT_CK_REQUIRE;
7474 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
7475 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7477 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
7478 SV * const sv = kid->op_sv;
7479 U32 was_readonly = SvREADONLY(sv);
7486 sv_force_normal_flags(sv, 0);
7487 assert(!SvREADONLY(sv));
7497 for (; s < end; s++) {
7498 if (*s == ':' && s[1] == ':') {
7500 Move(s+2, s+1, end - s - 1, char);
7505 sv_catpvs(sv, ".pm");
7506 SvFLAGS(sv) |= was_readonly;
7510 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
7511 /* handle override, if any */
7512 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
7513 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7514 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
7515 gv = gvp ? *gvp : NULL;
7519 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7520 OP * const kid = cUNOPo->op_first;
7523 cUNOPo->op_first = 0;
7527 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
7528 append_elem(OP_LIST, kid,
7529 scalar(newUNOP(OP_RV2CV, 0,
7532 op_getmad(o,newop,'O');
7540 Perl_ck_return(pTHX_ OP *o)
7544 PERL_ARGS_ASSERT_CK_RETURN;
7546 if (CvLVALUE(PL_compcv)) {
7548 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
7549 mod(kid, OP_LEAVESUBLV);
7555 Perl_ck_select(pTHX_ OP *o)
7560 PERL_ARGS_ASSERT_CK_SELECT;
7562 if (o->op_flags & OPf_KIDS) {
7563 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7564 if (kid && kid->op_sibling) {
7565 o->op_type = OP_SSELECT;
7566 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
7568 return fold_constants(o);
7572 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7573 if (kid && kid->op_type == OP_RV2GV)
7574 kid->op_private &= ~HINT_STRICT_REFS;
7579 Perl_ck_shift(pTHX_ OP *o)
7582 const I32 type = o->op_type;
7584 PERL_ARGS_ASSERT_CK_SHIFT;
7586 if (!(o->op_flags & OPf_KIDS)) {
7588 /* FIXME - this can be refactored to reduce code in #ifdefs */
7590 OP * const oldo = o;
7594 argop = newUNOP(OP_RV2AV, 0,
7595 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
7597 o = newUNOP(type, 0, scalar(argop));
7598 op_getmad(oldo,o,'O');
7601 return newUNOP(type, 0, scalar(argop));
7604 return scalar(modkids(ck_fun(o), type));
7608 Perl_ck_sort(pTHX_ OP *o)
7613 PERL_ARGS_ASSERT_CK_SORT;
7615 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
7616 HV * const hinthv = GvHV(PL_hintgv);
7618 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
7620 const I32 sorthints = (I32)SvIV(*svp);
7621 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
7622 o->op_private |= OPpSORT_QSORT;
7623 if ((sorthints & HINT_SORT_STABLE) != 0)
7624 o->op_private |= OPpSORT_STABLE;
7629 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
7631 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7632 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
7634 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
7636 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
7638 if (kid->op_type == OP_SCOPE) {
7642 else if (kid->op_type == OP_LEAVE) {
7643 if (o->op_type == OP_SORT) {
7644 op_null(kid); /* wipe out leave */
7647 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
7648 if (k->op_next == kid)
7650 /* don't descend into loops */
7651 else if (k->op_type == OP_ENTERLOOP
7652 || k->op_type == OP_ENTERITER)
7654 k = cLOOPx(k)->op_lastop;
7659 kid->op_next = 0; /* just disconnect the leave */
7660 k = kLISTOP->op_first;
7665 if (o->op_type == OP_SORT) {
7666 /* provide scalar context for comparison function/block */
7672 o->op_flags |= OPf_SPECIAL;
7674 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
7677 firstkid = firstkid->op_sibling;
7680 /* provide list context for arguments */
7681 if (o->op_type == OP_SORT)
7688 S_simplify_sort(pTHX_ OP *o)
7691 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7697 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
7699 if (!(o->op_flags & OPf_STACKED))
7701 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7702 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
7703 kid = kUNOP->op_first; /* get past null */
7704 if (kid->op_type != OP_SCOPE)
7706 kid = kLISTOP->op_last; /* get past scope */
7707 switch(kid->op_type) {
7715 k = kid; /* remember this node*/
7716 if (kBINOP->op_first->op_type != OP_RV2SV)
7718 kid = kBINOP->op_first; /* get past cmp */
7719 if (kUNOP->op_first->op_type != OP_GV)
7721 kid = kUNOP->op_first; /* get past rv2sv */
7723 if (GvSTASH(gv) != PL_curstash)
7725 gvname = GvNAME(gv);
7726 if (*gvname == 'a' && gvname[1] == '\0')
7728 else if (*gvname == 'b' && gvname[1] == '\0')
7733 kid = k; /* back to cmp */
7734 if (kBINOP->op_last->op_type != OP_RV2SV)
7736 kid = kBINOP->op_last; /* down to 2nd arg */
7737 if (kUNOP->op_first->op_type != OP_GV)
7739 kid = kUNOP->op_first; /* get past rv2sv */
7741 if (GvSTASH(gv) != PL_curstash)
7743 gvname = GvNAME(gv);
7745 ? !(*gvname == 'a' && gvname[1] == '\0')
7746 : !(*gvname == 'b' && gvname[1] == '\0'))
7748 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
7750 o->op_private |= OPpSORT_DESCEND;
7751 if (k->op_type == OP_NCMP)
7752 o->op_private |= OPpSORT_NUMERIC;
7753 if (k->op_type == OP_I_NCMP)
7754 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
7755 kid = cLISTOPo->op_first->op_sibling;
7756 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
7758 op_getmad(kid,o,'S'); /* then delete it */
7760 op_free(kid); /* then delete it */
7765 Perl_ck_split(pTHX_ OP *o)
7770 PERL_ARGS_ASSERT_CK_SPLIT;
7772 if (o->op_flags & OPf_STACKED)
7773 return no_fh_allowed(o);
7775 kid = cLISTOPo->op_first;
7776 if (kid->op_type != OP_NULL)
7777 Perl_croak(aTHX_ "panic: ck_split");
7778 kid = kid->op_sibling;
7779 op_free(cLISTOPo->op_first);
7780 cLISTOPo->op_first = kid;
7782 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
7783 cLISTOPo->op_last = kid; /* There was only one element previously */
7786 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
7787 OP * const sibl = kid->op_sibling;
7788 kid->op_sibling = 0;
7789 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
7790 if (cLISTOPo->op_first == cLISTOPo->op_last)
7791 cLISTOPo->op_last = kid;
7792 cLISTOPo->op_first = kid;
7793 kid->op_sibling = sibl;
7796 kid->op_type = OP_PUSHRE;
7797 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
7799 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
7800 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
7801 "Use of /g modifier is meaningless in split");
7804 if (!kid->op_sibling)
7805 append_elem(OP_SPLIT, o, newDEFSVOP());
7807 kid = kid->op_sibling;
7810 if (!kid->op_sibling)
7811 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
7812 assert(kid->op_sibling);
7814 kid = kid->op_sibling;
7817 if (kid->op_sibling)
7818 return too_many_arguments(o,OP_DESC(o));
7824 Perl_ck_join(pTHX_ OP *o)
7826 const OP * const kid = cLISTOPo->op_first->op_sibling;
7828 PERL_ARGS_ASSERT_CK_JOIN;
7830 if (kid && kid->op_type == OP_MATCH) {
7831 if (ckWARN(WARN_SYNTAX)) {
7832 const REGEXP *re = PM_GETRE(kPMOP);
7833 const char *pmstr = re ? RX_PRECOMP(re) : "STRING";
7834 const STRLEN len = re ? RX_PRELEN(re) : 6;
7835 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7836 "/%.*s/ should probably be written as \"%.*s\"",
7837 (int)len, pmstr, (int)len, pmstr);
7844 Perl_ck_subr(pTHX_ OP *o)
7847 OP *prev = ((cUNOPo->op_first->op_sibling)
7848 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
7849 OP *o2 = prev->op_sibling;
7851 const char *proto = NULL;
7852 const char *proto_end = NULL;
7857 I32 contextclass = 0;
7858 const char *e = NULL;
7861 PERL_ARGS_ASSERT_CK_SUBR;
7863 o->op_private |= OPpENTERSUB_HASTARG;
7864 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
7865 if (cvop->op_type == OP_RV2CV) {
7867 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
7868 op_null(cvop); /* disable rv2cv */
7869 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
7870 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
7871 GV *gv = cGVOPx_gv(tmpop);
7874 tmpop->op_private |= OPpEARLY_CV;
7878 namegv = CvANON(cv) ? gv : CvGV(cv);
7879 proto = SvPV((SV*)cv, len);
7880 proto_end = proto + len;
7885 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7886 if (o2->op_type == OP_CONST)
7887 o2->op_private &= ~OPpCONST_STRICT;
7888 else if (o2->op_type == OP_LIST) {
7889 OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
7890 if (sib && sib->op_type == OP_CONST)
7891 sib->op_private &= ~OPpCONST_STRICT;
7894 o->op_private |= (PL_hints & HINT_STRICT_REFS);
7895 if (PERLDB_SUB && PL_curstash != PL_debstash)
7896 o->op_private |= OPpENTERSUB_DB;
7897 while (o2 != cvop) {
7899 if (PL_madskills && o2->op_type == OP_STUB) {
7900 o2 = o2->op_sibling;
7903 if (PL_madskills && o2->op_type == OP_NULL)
7904 o3 = ((UNOP*)o2)->op_first;
7908 if (proto >= proto_end)
7909 return too_many_arguments(o, gv_ename(namegv));
7917 /* _ must be at the end */
7918 if (proto[1] && proto[1] != ';')
7933 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
7935 arg == 1 ? "block or sub {}" : "sub {}",
7936 gv_ename(namegv), o3);
7939 /* '*' allows any scalar type, including bareword */
7942 if (o3->op_type == OP_RV2GV)
7943 goto wrapref; /* autoconvert GLOB -> GLOBref */
7944 else if (o3->op_type == OP_CONST)
7945 o3->op_private &= ~OPpCONST_STRICT;
7946 else if (o3->op_type == OP_ENTERSUB) {
7947 /* accidental subroutine, revert to bareword */
7948 OP *gvop = ((UNOP*)o3)->op_first;
7949 if (gvop && gvop->op_type == OP_NULL) {
7950 gvop = ((UNOP*)gvop)->op_first;
7952 for (; gvop->op_sibling; gvop = gvop->op_sibling)
7955 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
7956 (gvop = ((UNOP*)gvop)->op_first) &&
7957 gvop->op_type == OP_GV)
7959 GV * const gv = cGVOPx_gv(gvop);
7960 OP * const sibling = o2->op_sibling;
7961 SV * const n = newSVpvs("");
7963 OP * const oldo2 = o2;
7967 gv_fullname4(n, gv, "", FALSE);
7968 o2 = newSVOP(OP_CONST, 0, n);
7969 op_getmad(oldo2,o2,'O');
7970 prev->op_sibling = o2;
7971 o2->op_sibling = sibling;
7987 if (contextclass++ == 0) {
7988 e = strchr(proto, ']');
7989 if (!e || e == proto)
7998 const char *p = proto;
7999 const char *const end = proto;
8001 while (*--p != '[');
8002 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
8004 gv_ename(namegv), o3);
8009 if (o3->op_type == OP_RV2GV)
8012 bad_type(arg, "symbol", gv_ename(namegv), o3);
8015 if (o3->op_type == OP_ENTERSUB)
8018 bad_type(arg, "subroutine entry", gv_ename(namegv),
8022 if (o3->op_type == OP_RV2SV ||
8023 o3->op_type == OP_PADSV ||
8024 o3->op_type == OP_HELEM ||
8025 o3->op_type == OP_AELEM)
8028 bad_type(arg, "scalar", gv_ename(namegv), o3);
8031 if (o3->op_type == OP_RV2AV ||
8032 o3->op_type == OP_PADAV)
8035 bad_type(arg, "array", gv_ename(namegv), o3);
8038 if (o3->op_type == OP_RV2HV ||
8039 o3->op_type == OP_PADHV)
8042 bad_type(arg, "hash", gv_ename(namegv), o3);
8047 OP* const sib = kid->op_sibling;
8048 kid->op_sibling = 0;
8049 o2 = newUNOP(OP_REFGEN, 0, kid);
8050 o2->op_sibling = sib;
8051 prev->op_sibling = o2;
8053 if (contextclass && e) {
8068 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
8069 gv_ename(namegv), SVfARG(cv));
8074 mod(o2, OP_ENTERSUB);
8076 o2 = o2->op_sibling;
8078 if (o2 == cvop && proto && *proto == '_') {
8079 /* generate an access to $_ */
8081 o2->op_sibling = prev->op_sibling;
8082 prev->op_sibling = o2; /* instead of cvop */
8084 if (proto && !optional && proto_end > proto &&
8085 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
8086 return too_few_arguments(o, gv_ename(namegv));
8089 OP * const oldo = o;
8093 o=newSVOP(OP_CONST, 0, newSViv(0));
8094 op_getmad(oldo,o,'O');
8100 Perl_ck_svconst(pTHX_ OP *o)
8102 PERL_ARGS_ASSERT_CK_SVCONST;
8103 PERL_UNUSED_CONTEXT;
8104 SvREADONLY_on(cSVOPo->op_sv);
8109 Perl_ck_chdir(pTHX_ OP *o)
8111 if (o->op_flags & OPf_KIDS) {
8112 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8114 if (kid && kid->op_type == OP_CONST &&
8115 (kid->op_private & OPpCONST_BARE))
8117 o->op_flags |= OPf_SPECIAL;
8118 kid->op_private &= ~OPpCONST_STRICT;
8125 Perl_ck_trunc(pTHX_ OP *o)
8127 PERL_ARGS_ASSERT_CK_TRUNC;
8129 if (o->op_flags & OPf_KIDS) {
8130 SVOP *kid = (SVOP*)cUNOPo->op_first;
8132 if (kid->op_type == OP_NULL)
8133 kid = (SVOP*)kid->op_sibling;
8134 if (kid && kid->op_type == OP_CONST &&
8135 (kid->op_private & OPpCONST_BARE))
8137 o->op_flags |= OPf_SPECIAL;
8138 kid->op_private &= ~OPpCONST_STRICT;
8145 Perl_ck_unpack(pTHX_ OP *o)
8147 OP *kid = cLISTOPo->op_first;
8149 PERL_ARGS_ASSERT_CK_UNPACK;
8151 if (kid->op_sibling) {
8152 kid = kid->op_sibling;
8153 if (!kid->op_sibling)
8154 kid->op_sibling = newDEFSVOP();
8160 Perl_ck_substr(pTHX_ OP *o)
8162 PERL_ARGS_ASSERT_CK_SUBSTR;
8165 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
8166 OP *kid = cLISTOPo->op_first;
8168 if (kid->op_type == OP_NULL)
8169 kid = kid->op_sibling;
8171 kid->op_flags |= OPf_MOD;
8178 Perl_ck_each(pTHX_ OP *o)
8181 OP *kid = cLISTOPo->op_first;
8183 PERL_ARGS_ASSERT_CK_EACH;
8185 if (kid->op_type == OP_PADAV || kid->op_type == OP_RV2AV) {
8186 const unsigned new_type = o->op_type == OP_EACH ? OP_AEACH
8187 : o->op_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
8188 o->op_type = new_type;
8189 o->op_ppaddr = PL_ppaddr[new_type];
8191 else if (!(kid->op_type == OP_PADHV || kid->op_type == OP_RV2HV
8192 || (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE)
8194 bad_type(1, "hash or array", PL_op_desc[o->op_type], kid);
8200 /* A peephole optimizer. We visit the ops in the order they're to execute.
8201 * See the comments at the top of this file for more details about when
8202 * peep() is called */
8205 Perl_peep(pTHX_ register OP *o)
8208 register OP* oldop = NULL;
8210 if (!o || o->op_opt)
8214 SAVEVPTR(PL_curcop);
8215 for (; o; o = o->op_next) {
8218 /* By default, this op has now been optimised. A couple of cases below
8219 clear this again. */
8222 switch (o->op_type) {
8225 PL_curcop = ((COP*)o); /* for warnings */
8229 if (cSVOPo->op_private & OPpCONST_STRICT)
8230 no_bareword_allowed(o);
8232 case OP_METHOD_NAMED:
8233 /* Relocate sv to the pad for thread safety.
8234 * Despite being a "constant", the SV is written to,
8235 * for reference counts, sv_upgrade() etc. */
8237 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
8238 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
8239 /* If op_sv is already a PADTMP then it is being used by
8240 * some pad, so make a copy. */
8241 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
8242 SvREADONLY_on(PAD_SVl(ix));
8243 SvREFCNT_dec(cSVOPo->op_sv);
8245 else if (o->op_type == OP_CONST
8246 && cSVOPo->op_sv == &PL_sv_undef) {
8247 /* PL_sv_undef is hack - it's unsafe to store it in the
8248 AV that is the pad, because av_fetch treats values of
8249 PL_sv_undef as a "free" AV entry and will merrily
8250 replace them with a new SV, causing pad_alloc to think
8251 that this pad slot is free. (When, clearly, it is not)
8253 SvOK_off(PAD_SVl(ix));
8254 SvPADTMP_on(PAD_SVl(ix));
8255 SvREADONLY_on(PAD_SVl(ix));
8258 SvREFCNT_dec(PAD_SVl(ix));
8259 SvPADTMP_on(cSVOPo->op_sv);
8260 PAD_SETSV(ix, cSVOPo->op_sv);
8261 /* XXX I don't know how this isn't readonly already. */
8262 SvREADONLY_on(PAD_SVl(ix));
8264 cSVOPo->op_sv = NULL;
8271 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
8272 if (o->op_next->op_private & OPpTARGET_MY) {
8273 if (o->op_flags & OPf_STACKED) /* chained concats */
8274 break; /* ignore_optimization */
8276 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
8277 o->op_targ = o->op_next->op_targ;
8278 o->op_next->op_targ = 0;
8279 o->op_private |= OPpTARGET_MY;
8282 op_null(o->op_next);
8286 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
8287 break; /* Scalar stub must produce undef. List stub is noop */
8291 if (o->op_targ == OP_NEXTSTATE
8292 || o->op_targ == OP_DBSTATE)
8294 PL_curcop = ((COP*)o);
8296 /* XXX: We avoid setting op_seq here to prevent later calls
8297 to peep() from mistakenly concluding that optimisation
8298 has already occurred. This doesn't fix the real problem,
8299 though (See 20010220.007). AMS 20010719 */
8300 /* op_seq functionality is now replaced by op_opt */
8307 if (oldop && o->op_next) {
8308 oldop->op_next = o->op_next;
8316 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
8317 OP* const pop = (o->op_type == OP_PADAV) ?
8318 o->op_next : o->op_next->op_next;
8320 if (pop && pop->op_type == OP_CONST &&
8321 ((PL_op = pop->op_next)) &&
8322 pop->op_next->op_type == OP_AELEM &&
8323 !(pop->op_next->op_private &
8324 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
8325 (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
8330 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
8331 no_bareword_allowed(pop);
8332 if (o->op_type == OP_GV)
8333 op_null(o->op_next);
8334 op_null(pop->op_next);
8336 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
8337 o->op_next = pop->op_next->op_next;
8338 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
8339 o->op_private = (U8)i;
8340 if (o->op_type == OP_GV) {
8345 o->op_flags |= OPf_SPECIAL;
8346 o->op_type = OP_AELEMFAST;
8351 if (o->op_next->op_type == OP_RV2SV) {
8352 if (!(o->op_next->op_private & OPpDEREF)) {
8353 op_null(o->op_next);
8354 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
8356 o->op_next = o->op_next->op_next;
8357 o->op_type = OP_GVSV;
8358 o->op_ppaddr = PL_ppaddr[OP_GVSV];
8361 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
8362 GV * const gv = cGVOPo_gv;
8363 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
8364 /* XXX could check prototype here instead of just carping */
8365 SV * const sv = sv_newmortal();
8366 gv_efullname3(sv, gv, NULL);
8367 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
8368 "%"SVf"() called too early to check prototype",
8372 else if (o->op_next->op_type == OP_READLINE
8373 && o->op_next->op_next->op_type == OP_CONCAT
8374 && (o->op_next->op_next->op_flags & OPf_STACKED))
8376 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
8377 o->op_type = OP_RCATLINE;
8378 o->op_flags |= OPf_STACKED;
8379 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
8380 op_null(o->op_next->op_next);
8381 op_null(o->op_next);
8397 while (cLOGOP->op_other->op_type == OP_NULL)
8398 cLOGOP->op_other = cLOGOP->op_other->op_next;
8399 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
8404 while (cLOOP->op_redoop->op_type == OP_NULL)
8405 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
8406 peep(cLOOP->op_redoop);
8407 while (cLOOP->op_nextop->op_type == OP_NULL)
8408 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
8409 peep(cLOOP->op_nextop);
8410 while (cLOOP->op_lastop->op_type == OP_NULL)
8411 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
8412 peep(cLOOP->op_lastop);
8416 assert(!(cPMOP->op_pmflags & PMf_ONCE));
8417 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
8418 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
8419 cPMOP->op_pmstashstartu.op_pmreplstart
8420 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
8421 peep(cPMOP->op_pmstashstartu.op_pmreplstart);
8425 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
8426 && ckWARN(WARN_SYNTAX))
8428 if (o->op_next->op_sibling) {
8429 const OPCODE type = o->op_next->op_sibling->op_type;
8430 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
8431 const line_t oldline = CopLINE(PL_curcop);
8432 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
8433 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8434 "Statement unlikely to be reached");
8435 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8436 "\t(Maybe you meant system() when you said exec()?)\n");
8437 CopLINE_set(PL_curcop, oldline);
8448 const char *key = NULL;
8451 if (((BINOP*)o)->op_last->op_type != OP_CONST)
8454 /* Make the CONST have a shared SV */
8455 svp = cSVOPx_svp(((BINOP*)o)->op_last);
8456 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
8457 key = SvPV_const(sv, keylen);
8458 lexname = newSVpvn_share(key,
8459 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
8465 if ((o->op_private & (OPpLVAL_INTRO)))
8468 rop = (UNOP*)((BINOP*)o)->op_first;
8469 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
8471 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
8472 if (!SvPAD_TYPED(lexname))
8474 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8475 if (!fields || !GvHV(*fields))
8477 key = SvPV_const(*svp, keylen);
8478 if (!hv_fetch(GvHV(*fields), key,
8479 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8481 Perl_croak(aTHX_ "No such class field \"%s\" "
8482 "in variable %s of type %s",
8483 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
8496 SVOP *first_key_op, *key_op;
8498 if ((o->op_private & (OPpLVAL_INTRO))
8499 /* I bet there's always a pushmark... */
8500 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
8501 /* hmmm, no optimization if list contains only one key. */
8503 rop = (UNOP*)((LISTOP*)o)->op_last;
8504 if (rop->op_type != OP_RV2HV)
8506 if (rop->op_first->op_type == OP_PADSV)
8507 /* @$hash{qw(keys here)} */
8508 rop = (UNOP*)rop->op_first;
8510 /* @{$hash}{qw(keys here)} */
8511 if (rop->op_first->op_type == OP_SCOPE
8512 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
8514 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
8520 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
8521 if (!SvPAD_TYPED(lexname))
8523 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8524 if (!fields || !GvHV(*fields))
8526 /* Again guessing that the pushmark can be jumped over.... */
8527 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
8528 ->op_first->op_sibling;
8529 for (key_op = first_key_op; key_op;
8530 key_op = (SVOP*)key_op->op_sibling) {
8531 if (key_op->op_type != OP_CONST)
8533 svp = cSVOPx_svp(key_op);
8534 key = SvPV_const(*svp, keylen);
8535 if (!hv_fetch(GvHV(*fields), key,
8536 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8538 Perl_croak(aTHX_ "No such class field \"%s\" "
8539 "in variable %s of type %s",
8540 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
8547 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
8551 /* check that RHS of sort is a single plain array */
8552 OP *oright = cUNOPo->op_first;
8553 if (!oright || oright->op_type != OP_PUSHMARK)
8556 /* reverse sort ... can be optimised. */
8557 if (!cUNOPo->op_sibling) {
8558 /* Nothing follows us on the list. */
8559 OP * const reverse = o->op_next;
8561 if (reverse->op_type == OP_REVERSE &&
8562 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
8563 OP * const pushmark = cUNOPx(reverse)->op_first;
8564 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
8565 && (cUNOPx(pushmark)->op_sibling == o)) {
8566 /* reverse -> pushmark -> sort */
8567 o->op_private |= OPpSORT_REVERSE;
8569 pushmark->op_next = oright->op_next;
8575 /* make @a = sort @a act in-place */
8577 oright = cUNOPx(oright)->op_sibling;
8580 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
8581 oright = cUNOPx(oright)->op_sibling;
8585 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
8586 || oright->op_next != o
8587 || (oright->op_private & OPpLVAL_INTRO)
8591 /* o2 follows the chain of op_nexts through the LHS of the
8592 * assign (if any) to the aassign op itself */
8594 if (!o2 || o2->op_type != OP_NULL)
8597 if (!o2 || o2->op_type != OP_PUSHMARK)
8600 if (o2 && o2->op_type == OP_GV)
8603 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
8604 || (o2->op_private & OPpLVAL_INTRO)
8609 if (!o2 || o2->op_type != OP_NULL)
8612 if (!o2 || o2->op_type != OP_AASSIGN
8613 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
8616 /* check that the sort is the first arg on RHS of assign */
8618 o2 = cUNOPx(o2)->op_first;
8619 if (!o2 || o2->op_type != OP_NULL)
8621 o2 = cUNOPx(o2)->op_first;
8622 if (!o2 || o2->op_type != OP_PUSHMARK)
8624 if (o2->op_sibling != o)
8627 /* check the array is the same on both sides */
8628 if (oleft->op_type == OP_RV2AV) {
8629 if (oright->op_type != OP_RV2AV
8630 || !cUNOPx(oright)->op_first
8631 || cUNOPx(oright)->op_first->op_type != OP_GV
8632 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
8633 cGVOPx_gv(cUNOPx(oright)->op_first)
8637 else if (oright->op_type != OP_PADAV
8638 || oright->op_targ != oleft->op_targ
8642 /* transfer MODishness etc from LHS arg to RHS arg */
8643 oright->op_flags = oleft->op_flags;
8644 o->op_private |= OPpSORT_INPLACE;
8646 /* excise push->gv->rv2av->null->aassign */
8647 o2 = o->op_next->op_next;
8648 op_null(o2); /* PUSHMARK */
8650 if (o2->op_type == OP_GV) {
8651 op_null(o2); /* GV */
8654 op_null(o2); /* RV2AV or PADAV */
8655 o2 = o2->op_next->op_next;
8656 op_null(o2); /* AASSIGN */
8658 o->op_next = o2->op_next;
8664 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
8666 LISTOP *enter, *exlist;
8668 enter = (LISTOP *) o->op_next;
8671 if (enter->op_type == OP_NULL) {
8672 enter = (LISTOP *) enter->op_next;
8676 /* for $a (...) will have OP_GV then OP_RV2GV here.
8677 for (...) just has an OP_GV. */
8678 if (enter->op_type == OP_GV) {
8679 gvop = (OP *) enter;
8680 enter = (LISTOP *) enter->op_next;
8683 if (enter->op_type == OP_RV2GV) {
8684 enter = (LISTOP *) enter->op_next;
8690 if (enter->op_type != OP_ENTERITER)
8693 iter = enter->op_next;
8694 if (!iter || iter->op_type != OP_ITER)
8697 expushmark = enter->op_first;
8698 if (!expushmark || expushmark->op_type != OP_NULL
8699 || expushmark->op_targ != OP_PUSHMARK)
8702 exlist = (LISTOP *) expushmark->op_sibling;
8703 if (!exlist || exlist->op_type != OP_NULL
8704 || exlist->op_targ != OP_LIST)
8707 if (exlist->op_last != o) {
8708 /* Mmm. Was expecting to point back to this op. */
8711 theirmark = exlist->op_first;
8712 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
8715 if (theirmark->op_sibling != o) {
8716 /* There's something between the mark and the reverse, eg
8717 for (1, reverse (...))
8722 ourmark = ((LISTOP *)o)->op_first;
8723 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
8726 ourlast = ((LISTOP *)o)->op_last;
8727 if (!ourlast || ourlast->op_next != o)
8730 rv2av = ourmark->op_sibling;
8731 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
8732 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
8733 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
8734 /* We're just reversing a single array. */
8735 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
8736 enter->op_flags |= OPf_STACKED;
8739 /* We don't have control over who points to theirmark, so sacrifice
8741 theirmark->op_next = ourmark->op_next;
8742 theirmark->op_flags = ourmark->op_flags;
8743 ourlast->op_next = gvop ? gvop : (OP *) enter;
8746 enter->op_private |= OPpITER_REVERSED;
8747 iter->op_private |= OPpITER_REVERSED;
8754 UNOP *refgen, *rv2cv;
8757 if ((o->op_flags & OPf_WANT) != OPf_WANT_VOID)
8760 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
8763 rv2gv = ((BINOP *)o)->op_last;
8764 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
8767 refgen = (UNOP *)((BINOP *)o)->op_first;
8769 if (!refgen || refgen->op_type != OP_REFGEN)
8772 exlist = (LISTOP *)refgen->op_first;
8773 if (!exlist || exlist->op_type != OP_NULL
8774 || exlist->op_targ != OP_LIST)
8777 if (exlist->op_first->op_type != OP_PUSHMARK)
8780 rv2cv = (UNOP*)exlist->op_last;
8782 if (rv2cv->op_type != OP_RV2CV)
8785 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
8786 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
8787 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
8789 o->op_private |= OPpASSIGN_CV_TO_GV;
8790 rv2gv->op_private |= OPpDONT_INIT_GV;
8791 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
8799 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
8800 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
8810 Perl_custom_op_name(pTHX_ const OP* o)
8813 const IV index = PTR2IV(o->op_ppaddr);
8817 PERL_ARGS_ASSERT_CUSTOM_OP_NAME;
8819 if (!PL_custom_op_names) /* This probably shouldn't happen */
8820 return (char *)PL_op_name[OP_CUSTOM];
8822 keysv = sv_2mortal(newSViv(index));
8824 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
8826 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
8828 return SvPV_nolen(HeVAL(he));
8832 Perl_custom_op_desc(pTHX_ const OP* o)
8835 const IV index = PTR2IV(o->op_ppaddr);
8839 PERL_ARGS_ASSERT_CUSTOM_OP_DESC;
8841 if (!PL_custom_op_descs)
8842 return (char *)PL_op_desc[OP_CUSTOM];
8844 keysv = sv_2mortal(newSViv(index));
8846 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
8848 return (char *)PL_op_desc[OP_CUSTOM];
8850 return SvPV_nolen(HeVAL(he));
8855 /* Efficient sub that returns a constant scalar value. */
8857 const_sv_xsub(pTHX_ CV* cv)
8864 Perl_croak(aTHX_ "usage: %s::%s()",
8865 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
8869 ST(0) = (SV*)XSANY.any_ptr;
8875 * c-indentation-style: bsd
8877 * indent-tabs-mode: t
8880 * ex: set ts=8 sts=4 sw=4 noet: