3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * "You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
13 * our Mr. Bilbo's first cousin on the mother's side (her mother being the
14 * youngest of the Old Took's daughters); and Mr. Drogo was his second
15 * cousin. So Mr. Frodo is his first *and* second cousin, once removed
16 * either way, as the saying is, if you follow me." --the Gaffer
19 /* This file contains the functions that create, manipulate and optimize
20 * the OP structures that hold a compiled perl program.
22 * A Perl program is compiled into a tree of OPs. Each op contains
23 * structural pointers (eg to its siblings and the next op in the
24 * execution sequence), a pointer to the function that would execute the
25 * op, plus any data specific to that op. For example, an OP_CONST op
26 * points to the pp_const() function and to an SV containing the constant
27 * value. When pp_const() is executed, its job is to push that SV onto the
30 * OPs are mainly created by the newFOO() functions, which are mainly
31 * called from the parser (in perly.y) as the code is parsed. For example
32 * the Perl code $a + $b * $c would cause the equivalent of the following
33 * to be called (oversimplifying a bit):
35 * newBINOP(OP_ADD, flags,
37 * newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
40 * Note that during the build of miniperl, a temporary copy of this file
41 * is made, called opmini.c.
45 Perl's compiler is essentially a 3-pass compiler with interleaved phases:
49 An execution-order pass
51 The bottom-up pass is represented by all the "newOP" routines and
52 the ck_ routines. The bottom-upness is actually driven by yacc.
53 So at the point that a ck_ routine fires, we have no idea what the
54 context is, either upward in the syntax tree, or either forward or
55 backward in the execution order. (The bottom-up parser builds that
56 part of the execution order it knows about, but if you follow the "next"
57 links around, you'll find it's actually a closed loop through the
60 Whenever the bottom-up parser gets to a node that supplies context to
61 its components, it invokes that portion of the top-down pass that applies
62 to that part of the subtree (and marks the top node as processed, so
63 if a node further up supplies context, it doesn't have to take the
64 plunge again). As a particular subcase of this, as the new node is
65 built, it takes all the closed execution loops of its subcomponents
66 and links them into a new closed loop for the higher level node. But
67 it's still not the real execution order.
69 The actual execution order is not known till we get a grammar reduction
70 to a top-level unit like a subroutine or file that will be called by
71 "name" rather than via a "next" pointer. At that point, we can call
72 into peep() to do that code's portion of the 3rd pass. It has to be
73 recursive, but it's recursive on basic blocks, not on tree nodes.
76 /* To implement user lexical pragmas, there needs to be a way at run time to
77 get the compile time state of %^H for that block. Storing %^H in every
78 block (or even COP) would be very expensive, so a different approach is
79 taken. The (running) state of %^H is serialised into a tree of HE-like
80 structs. Stores into %^H are chained onto the current leaf as a struct
81 refcounted_he * with the key and the value. Deletes from %^H are saved
82 with a value of PL_sv_placeholder. The state of %^H at any point can be
83 turned back into a regular HV by walking back up the tree from that point's
84 leaf, ignoring any key you've already seen (placeholder or not), storing
85 the rest into the HV structure, then removing the placeholders. Hence
86 memory is only used to store the %^H deltas from the enclosing COP, rather
87 than the entire %^H on each COP.
89 To cause actions on %^H to write out the serialisation records, it has
90 magic type 'H'. This magic (itself) does nothing, but its presence causes
91 the values to gain magic type 'h', which has entries for set and clear.
92 C<Perl_magic_sethint> updates C<PL_compiling.cop_hints_hash> with a store
93 record, with deletes written by C<Perl_magic_clearhint>. C<SAVEHINTS>
94 saves the current C<PL_compiling.cop_hints_hash> on the save stack, so that
95 it will be correctly restored when any inner compiling scope is exited.
101 #include "keywords.h"
103 #define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
105 #if defined(PL_OP_SLAB_ALLOC)
107 #ifdef PERL_DEBUG_READONLY_OPS
108 # define PERL_SLAB_SIZE 4096
109 # include <sys/mman.h>
112 #ifndef PERL_SLAB_SIZE
113 #define PERL_SLAB_SIZE 2048
117 Perl_Slab_Alloc(pTHX_ size_t sz)
121 * To make incrementing use count easy PL_OpSlab is an I32 *
122 * To make inserting the link to slab PL_OpPtr is I32 **
123 * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
124 * Add an overhead for pointer to slab and round up as a number of pointers
126 sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
127 if ((PL_OpSpace -= sz) < 0) {
128 #ifdef PERL_DEBUG_READONLY_OPS
129 /* We need to allocate chunk by chunk so that we can control the VM
131 PL_OpPtr = (I32**) mmap(0, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE,
132 MAP_ANON|MAP_PRIVATE, -1, 0);
134 DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
135 (unsigned long) PERL_SLAB_SIZE*sizeof(I32*),
137 if(PL_OpPtr == MAP_FAILED) {
138 perror("mmap failed");
143 PL_OpPtr = (I32 **) PerlMemShared_calloc(PERL_SLAB_SIZE,sizeof(I32*));
148 /* We reserve the 0'th I32 sized chunk as a use count */
149 PL_OpSlab = (I32 *) PL_OpPtr;
150 /* Reduce size by the use count word, and by the size we need.
151 * Latter is to mimic the '-=' in the if() above
153 PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
154 /* Allocation pointer starts at the top.
155 Theory: because we build leaves before trunk allocating at end
156 means that at run time access is cache friendly upward
158 PL_OpPtr += PERL_SLAB_SIZE;
160 #ifdef PERL_DEBUG_READONLY_OPS
161 /* We remember this slab. */
162 /* This implementation isn't efficient, but it is simple. */
163 PL_slabs = (I32**) realloc(PL_slabs, sizeof(I32**) * (PL_slab_count + 1));
164 PL_slabs[PL_slab_count++] = PL_OpSlab;
165 DEBUG_m(PerlIO_printf(Perl_debug_log, "Allocate %p\n", PL_OpSlab));
168 assert( PL_OpSpace >= 0 );
169 /* Move the allocation pointer down */
171 assert( PL_OpPtr > (I32 **) PL_OpSlab );
172 *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */
173 (*PL_OpSlab)++; /* Increment use count of slab */
174 assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
175 assert( *PL_OpSlab > 0 );
176 return (void *)(PL_OpPtr + 1);
179 #ifdef PERL_DEBUG_READONLY_OPS
181 Perl_pending_Slabs_to_ro(pTHX) {
182 /* Turn all the allocated op slabs read only. */
183 U32 count = PL_slab_count;
184 I32 **const slabs = PL_slabs;
186 /* Reset the array of pending OP slabs, as we're about to turn this lot
187 read only. Also, do it ahead of the loop in case the warn triggers,
188 and a warn handler has an eval */
193 /* Force a new slab for any further allocation. */
197 void *const start = slabs[count];
198 const size_t size = PERL_SLAB_SIZE* sizeof(I32*);
199 if(mprotect(start, size, PROT_READ)) {
200 Perl_warn(aTHX_ "mprotect for %p %lu failed with %d",
201 start, (unsigned long) size, errno);
209 S_Slab_to_rw(pTHX_ void *op)
211 I32 * const * const ptr = (I32 **) op;
212 I32 * const slab = ptr[-1];
214 PERL_ARGS_ASSERT_SLAB_TO_RW;
216 assert( ptr-1 > (I32 **) slab );
217 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
219 if(mprotect(slab, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE)) {
220 Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d",
221 slab, (unsigned long) PERL_SLAB_SIZE*sizeof(I32*), errno);
226 Perl_op_refcnt_inc(pTHX_ OP *o)
237 Perl_op_refcnt_dec(pTHX_ OP *o)
239 PERL_ARGS_ASSERT_OP_REFCNT_DEC;
244 # define Slab_to_rw(op)
248 Perl_Slab_Free(pTHX_ void *op)
250 I32 * const * const ptr = (I32 **) op;
251 I32 * const slab = ptr[-1];
252 PERL_ARGS_ASSERT_SLAB_FREE;
253 assert( ptr-1 > (I32 **) slab );
254 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
257 if (--(*slab) == 0) {
259 # define PerlMemShared PerlMem
262 #ifdef PERL_DEBUG_READONLY_OPS
263 U32 count = PL_slab_count;
264 /* Need to remove this slab from our list of slabs */
267 if (PL_slabs[count] == slab) {
269 /* Found it. Move the entry at the end to overwrite it. */
270 DEBUG_m(PerlIO_printf(Perl_debug_log,
271 "Deallocate %p by moving %p from %lu to %lu\n",
273 PL_slabs[PL_slab_count - 1],
274 PL_slab_count, count));
275 PL_slabs[count] = PL_slabs[--PL_slab_count];
276 /* Could realloc smaller at this point, but probably not
278 if(munmap(slab, PERL_SLAB_SIZE*sizeof(I32*))) {
279 perror("munmap failed");
287 PerlMemShared_free(slab);
289 if (slab == PL_OpSlab) {
296 * In the following definition, the ", (OP*)0" is just to make the compiler
297 * think the expression is of the right type: croak actually does a Siglongjmp.
299 #define CHECKOP(type,o) \
300 ((PL_op_mask && PL_op_mask[type]) \
301 ? ( op_free((OP*)o), \
302 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
304 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
306 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
309 S_gv_ename(pTHX_ GV *gv)
311 SV* const tmpsv = sv_newmortal();
313 PERL_ARGS_ASSERT_GV_ENAME;
315 gv_efullname3(tmpsv, gv, NULL);
316 return SvPV_nolen_const(tmpsv);
320 S_no_fh_allowed(pTHX_ OP *o)
322 PERL_ARGS_ASSERT_NO_FH_ALLOWED;
324 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
330 S_too_few_arguments(pTHX_ OP *o, const char *name)
332 PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS;
334 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
339 S_too_many_arguments(pTHX_ OP *o, const char *name)
341 PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS;
343 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
348 S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid)
350 PERL_ARGS_ASSERT_BAD_TYPE;
352 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
353 (int)n, name, t, OP_DESC(kid)));
357 S_no_bareword_allowed(pTHX_ const OP *o)
359 PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
362 return; /* various ok barewords are hidden in extra OP_NULL */
363 qerror(Perl_mess(aTHX_
364 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
368 /* "register" allocation */
371 Perl_allocmy(pTHX_ const char *const name)
375 const bool is_our = (PL_parser->in_my == KEY_our);
377 PERL_ARGS_ASSERT_ALLOCMY;
379 /* complain about "my $<special_var>" etc etc */
383 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
384 (name[1] == '_' && (*name == '$' || name[2]))))
386 /* name[2] is true if strlen(name) > 2 */
387 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
388 yyerror(Perl_form(aTHX_ "Can't use global %c^%c%s in \"%s\"",
389 name[0], toCTRL(name[1]), name + 2,
390 PL_parser->in_my == KEY_state ? "state" : "my"));
392 yyerror(Perl_form(aTHX_ "Can't use global %s in \"%s\"",name,
393 PL_parser->in_my == KEY_state ? "state" : "my"));
397 /* check for duplicate declaration */
398 pad_check_dup(name, is_our, (PL_curstash ? PL_curstash : PL_defstash));
400 if (PL_parser->in_my_stash && *name != '$') {
401 yyerror(Perl_form(aTHX_
402 "Can't declare class for non-scalar %s in \"%s\"",
405 : PL_parser->in_my == KEY_state ? "state" : "my"));
408 /* allocate a spare slot and store the name in that slot */
410 off = pad_add_name(name,
411 PL_parser->in_my_stash,
413 /* $_ is always in main::, even with our */
414 ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
418 PL_parser->in_my == KEY_state
420 /* anon sub prototypes contains state vars should always be cloned,
421 * otherwise the state var would be shared between anon subs */
423 if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
424 CvCLONE_on(PL_compcv);
429 /* free the body of an op without examining its contents.
430 * Always use this rather than FreeOp directly */
433 S_op_destroy(pTHX_ OP *o)
435 if (o->op_latefree) {
443 # define forget_pmop(a,b) S_forget_pmop(aTHX_ a,b)
445 # define forget_pmop(a,b) S_forget_pmop(aTHX_ a)
451 Perl_op_free(pTHX_ OP *o)
458 if (o->op_latefreed) {
465 if (o->op_private & OPpREFCOUNTED) {
476 refcnt = OpREFCNT_dec(o);
479 /* Need to find and remove any pattern match ops from the list
480 we maintain for reset(). */
481 find_and_forget_pmops(o);
491 if (o->op_flags & OPf_KIDS) {
492 register OP *kid, *nextkid;
493 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
494 nextkid = kid->op_sibling; /* Get before next freeing kid */
499 type = (OPCODE)o->op_targ;
501 #ifdef PERL_DEBUG_READONLY_OPS
505 /* COP* is not cleared by op_clear() so that we may track line
506 * numbers etc even after null() */
507 if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
512 if (o->op_latefree) {
518 #ifdef DEBUG_LEAKING_SCALARS
525 Perl_op_clear(pTHX_ OP *o)
530 PERL_ARGS_ASSERT_OP_CLEAR;
533 /* if (o->op_madprop && o->op_madprop->mad_next)
535 /* FIXME for MAD - if I uncomment these two lines t/op/pack.t fails with
536 "modification of a read only value" for a reason I can't fathom why.
537 It's the "" stringification of $_, where $_ was set to '' in a foreach
538 loop, but it defies simplification into a small test case.
539 However, commenting them out has caused ext/List/Util/t/weak.t to fail
542 mad_free(o->op_madprop);
548 switch (o->op_type) {
549 case OP_NULL: /* Was holding old type, if any. */
550 if (PL_madskills && o->op_targ != OP_NULL) {
551 o->op_type = (optype)o->op_targ;
555 case OP_ENTEREVAL: /* Was holding hints. */
559 if (!(o->op_flags & OPf_REF)
560 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
566 if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
567 /* not an OP_PADAV replacement */
569 if (cPADOPo->op_padix > 0) {
570 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
571 * may still exist on the pad */
572 pad_swipe(cPADOPo->op_padix, TRUE);
573 cPADOPo->op_padix = 0;
576 SvREFCNT_dec(cSVOPo->op_sv);
577 cSVOPo->op_sv = NULL;
581 case OP_METHOD_NAMED:
584 SvREFCNT_dec(cSVOPo->op_sv);
585 cSVOPo->op_sv = NULL;
588 Even if op_clear does a pad_free for the target of the op,
589 pad_free doesn't actually remove the sv that exists in the pad;
590 instead it lives on. This results in that it could be reused as
591 a target later on when the pad was reallocated.
594 pad_swipe(o->op_targ,1);
603 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
607 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
609 if (cPADOPo->op_padix > 0) {
610 pad_swipe(cPADOPo->op_padix, TRUE);
611 cPADOPo->op_padix = 0;
614 SvREFCNT_dec(cSVOPo->op_sv);
615 cSVOPo->op_sv = NULL;
619 PerlMemShared_free(cPVOPo->op_pv);
620 cPVOPo->op_pv = NULL;
624 op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
628 if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
629 /* No GvIN_PAD_off here, because other references may still
630 * exist on the pad */
631 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
634 SvREFCNT_dec((SV*)cPMOPo->op_pmreplrootu.op_pmtargetgv);
640 forget_pmop(cPMOPo, 1);
641 cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
642 /* we use the same protection as the "SAFE" version of the PM_ macros
643 * here since sv_clean_all might release some PMOPs
644 * after PL_regex_padav has been cleared
645 * and the clearing of PL_regex_padav needs to
646 * happen before sv_clean_all
649 if(PL_regex_pad) { /* We could be in destruction */
650 const IV offset = (cPMOPo)->op_pmoffset;
651 ReREFCNT_dec(PM_GETRE(cPMOPo));
652 PL_regex_pad[offset] = &PL_sv_undef;
653 sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
657 ReREFCNT_dec(PM_GETRE(cPMOPo));
658 PM_SETRE(cPMOPo, NULL);
664 if (o->op_targ > 0) {
665 pad_free(o->op_targ);
671 S_cop_free(pTHX_ COP* cop)
673 PERL_ARGS_ASSERT_COP_FREE;
678 if (! specialWARN(cop->cop_warnings))
679 PerlMemShared_free(cop->cop_warnings);
680 Perl_refcounted_he_free(aTHX_ cop->cop_hints_hash);
684 S_forget_pmop(pTHX_ PMOP *const o
690 HV * const pmstash = PmopSTASH(o);
692 PERL_ARGS_ASSERT_FORGET_PMOP;
694 if (pmstash && !SvIS_FREED(pmstash)) {
695 MAGIC * const mg = mg_find((SV*)pmstash, PERL_MAGIC_symtab);
697 PMOP **const array = (PMOP**) mg->mg_ptr;
698 U32 count = mg->mg_len / sizeof(PMOP**);
703 /* Found it. Move the entry at the end to overwrite it. */
704 array[i] = array[--count];
705 mg->mg_len = count * sizeof(PMOP**);
706 /* Could realloc smaller at this point always, but probably
707 not worth it. Probably worth free()ing if we're the
710 Safefree(mg->mg_ptr);
727 S_find_and_forget_pmops(pTHX_ OP *o)
729 PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
731 if (o->op_flags & OPf_KIDS) {
732 OP *kid = cUNOPo->op_first;
734 switch (kid->op_type) {
739 forget_pmop((PMOP*)kid, 0);
741 find_and_forget_pmops(kid);
742 kid = kid->op_sibling;
748 Perl_op_null(pTHX_ OP *o)
752 PERL_ARGS_ASSERT_OP_NULL;
754 if (o->op_type == OP_NULL)
758 o->op_targ = o->op_type;
759 o->op_type = OP_NULL;
760 o->op_ppaddr = PL_ppaddr[OP_NULL];
764 Perl_op_refcnt_lock(pTHX)
772 Perl_op_refcnt_unlock(pTHX)
779 /* Contextualizers */
781 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
784 Perl_linklist(pTHX_ OP *o)
788 PERL_ARGS_ASSERT_LINKLIST;
793 /* establish postfix order */
794 first = cUNOPo->op_first;
797 o->op_next = LINKLIST(first);
800 if (kid->op_sibling) {
801 kid->op_next = LINKLIST(kid->op_sibling);
802 kid = kid->op_sibling;
816 Perl_scalarkids(pTHX_ OP *o)
818 if (o && o->op_flags & OPf_KIDS) {
820 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
827 S_scalarboolean(pTHX_ OP *o)
831 PERL_ARGS_ASSERT_SCALARBOOLEAN;
833 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
834 if (ckWARN(WARN_SYNTAX)) {
835 const line_t oldline = CopLINE(PL_curcop);
837 if (PL_parser && PL_parser->copline != NOLINE)
838 CopLINE_set(PL_curcop, PL_parser->copline);
839 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
840 CopLINE_set(PL_curcop, oldline);
847 Perl_scalar(pTHX_ OP *o)
852 /* assumes no premature commitment */
853 if (!o || (PL_parser && PL_parser->error_count)
854 || (o->op_flags & OPf_WANT)
855 || o->op_type == OP_RETURN)
860 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
862 switch (o->op_type) {
864 scalar(cBINOPo->op_first);
869 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
873 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
874 if (!kPMOP->op_pmreplrootu.op_pmreplroot)
875 deprecate_old("implicit split to @_");
883 if (o->op_flags & OPf_KIDS) {
884 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
890 kid = cLISTOPo->op_first;
892 while ((kid = kid->op_sibling)) {
898 PL_curcop = &PL_compiling;
903 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
909 PL_curcop = &PL_compiling;
912 if (ckWARN(WARN_VOID))
913 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
920 Perl_scalarvoid(pTHX_ OP *o)
924 const char* useless = NULL;
928 PERL_ARGS_ASSERT_SCALARVOID;
930 /* trailing mad null ops don't count as "there" for void processing */
932 o->op_type != OP_NULL &&
934 o->op_sibling->op_type == OP_NULL)
937 for (sib = o->op_sibling;
938 sib && sib->op_type == OP_NULL;
939 sib = sib->op_sibling) ;
945 if (o->op_type == OP_NEXTSTATE
946 || o->op_type == OP_DBSTATE
947 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
948 || o->op_targ == OP_DBSTATE)))
949 PL_curcop = (COP*)o; /* for warning below */
951 /* assumes no premature commitment */
952 want = o->op_flags & OPf_WANT;
953 if ((want && want != OPf_WANT_SCALAR)
954 || (PL_parser && PL_parser->error_count)
955 || o->op_type == OP_RETURN)
960 if ((o->op_private & OPpTARGET_MY)
961 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
963 return scalar(o); /* As if inside SASSIGN */
966 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
968 switch (o->op_type) {
970 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
974 if (o->op_flags & OPf_STACKED)
978 if (o->op_private == 4)
1021 case OP_GETSOCKNAME:
1022 case OP_GETPEERNAME:
1027 case OP_GETPRIORITY:
1051 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1052 /* Otherwise it's "Useless use of grep iterator" */
1053 useless = OP_DESC(o);
1057 kid = cUNOPo->op_first;
1058 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1059 kid->op_type != OP_TRANS) {
1062 useless = "negative pattern binding (!~)";
1069 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1070 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1071 useless = "a variable";
1076 if (cSVOPo->op_private & OPpCONST_STRICT)
1077 no_bareword_allowed(o);
1079 if (ckWARN(WARN_VOID)) {
1081 SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_
1082 "a constant (%"SVf")", sv));
1083 useless = SvPV_nolen(msv);
1086 useless = "a constant (undef)";
1087 if (o->op_private & OPpCONST_ARYBASE)
1089 /* don't warn on optimised away booleans, eg
1090 * use constant Foo, 5; Foo || print; */
1091 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1093 /* the constants 0 and 1 are permitted as they are
1094 conventionally used as dummies in constructs like
1095 1 while some_condition_with_side_effects; */
1096 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1098 else if (SvPOK(sv)) {
1099 /* perl4's way of mixing documentation and code
1100 (before the invention of POD) was based on a
1101 trick to mix nroff and perl code. The trick was
1102 built upon these three nroff macros being used in
1103 void context. The pink camel has the details in
1104 the script wrapman near page 319. */
1105 const char * const maybe_macro = SvPVX_const(sv);
1106 if (strnEQ(maybe_macro, "di", 2) ||
1107 strnEQ(maybe_macro, "ds", 2) ||
1108 strnEQ(maybe_macro, "ig", 2))
1113 op_null(o); /* don't execute or even remember it */
1117 o->op_type = OP_PREINC; /* pre-increment is faster */
1118 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1122 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1123 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1127 o->op_type = OP_I_PREINC; /* pre-increment is faster */
1128 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1132 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
1133 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1142 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1147 if (o->op_flags & OPf_STACKED)
1154 if (!(o->op_flags & OPf_KIDS))
1165 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1172 /* all requires must return a boolean value */
1173 o->op_flags &= ~OPf_WANT;
1178 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
1179 if (!kPMOP->op_pmreplrootu.op_pmreplroot)
1180 deprecate_old("implicit split to @_");
1184 if (useless && ckWARN(WARN_VOID))
1185 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
1190 Perl_listkids(pTHX_ OP *o)
1192 if (o && o->op_flags & OPf_KIDS) {
1194 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1201 Perl_list(pTHX_ OP *o)
1206 /* assumes no premature commitment */
1207 if (!o || (o->op_flags & OPf_WANT)
1208 || (PL_parser && PL_parser->error_count)
1209 || o->op_type == OP_RETURN)
1214 if ((o->op_private & OPpTARGET_MY)
1215 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1217 return o; /* As if inside SASSIGN */
1220 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1222 switch (o->op_type) {
1225 list(cBINOPo->op_first);
1230 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1238 if (!(o->op_flags & OPf_KIDS))
1240 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1241 list(cBINOPo->op_first);
1242 return gen_constant_list(o);
1249 kid = cLISTOPo->op_first;
1251 while ((kid = kid->op_sibling)) {
1252 if (kid->op_sibling)
1257 PL_curcop = &PL_compiling;
1261 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1262 if (kid->op_sibling)
1267 PL_curcop = &PL_compiling;
1270 /* all requires must return a boolean value */
1271 o->op_flags &= ~OPf_WANT;
1278 Perl_scalarseq(pTHX_ OP *o)
1282 const OPCODE type = o->op_type;
1284 if (type == OP_LINESEQ || type == OP_SCOPE ||
1285 type == OP_LEAVE || type == OP_LEAVETRY)
1288 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1289 if (kid->op_sibling) {
1293 PL_curcop = &PL_compiling;
1295 o->op_flags &= ~OPf_PARENS;
1296 if (PL_hints & HINT_BLOCK_SCOPE)
1297 o->op_flags |= OPf_PARENS;
1300 o = newOP(OP_STUB, 0);
1305 S_modkids(pTHX_ OP *o, I32 type)
1307 if (o && o->op_flags & OPf_KIDS) {
1309 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1315 /* Propagate lvalue ("modifiable") context to an op and its children.
1316 * 'type' represents the context type, roughly based on the type of op that
1317 * would do the modifying, although local() is represented by OP_NULL.
1318 * It's responsible for detecting things that can't be modified, flag
1319 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
1320 * might have to vivify a reference in $x), and so on.
1322 * For example, "$a+1 = 2" would cause mod() to be called with o being
1323 * OP_ADD and type being OP_SASSIGN, and would output an error.
1327 Perl_mod(pTHX_ OP *o, I32 type)
1331 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1334 if (!o || (PL_parser && PL_parser->error_count))
1337 if ((o->op_private & OPpTARGET_MY)
1338 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1343 switch (o->op_type) {
1349 if (!(o->op_private & OPpCONST_ARYBASE))
1352 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1353 CopARYBASE_set(&PL_compiling,
1354 (I32)SvIV(cSVOPx(PL_eval_start)->op_sv));
1358 SAVECOPARYBASE(&PL_compiling);
1359 CopARYBASE_set(&PL_compiling, 0);
1361 else if (type == OP_REFGEN)
1364 Perl_croak(aTHX_ "That use of $[ is unsupported");
1367 if ((o->op_flags & OPf_PARENS) || PL_madskills)
1371 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1372 !(o->op_flags & OPf_STACKED)) {
1373 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1374 /* The default is to set op_private to the number of children,
1375 which for a UNOP such as RV2CV is always 1. And w're using
1376 the bit for a flag in RV2CV, so we need it clear. */
1377 o->op_private &= ~1;
1378 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1379 assert(cUNOPo->op_first->op_type == OP_NULL);
1380 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1383 else if (o->op_private & OPpENTERSUB_NOMOD)
1385 else { /* lvalue subroutine call */
1386 o->op_private |= OPpLVAL_INTRO;
1387 PL_modcount = RETURN_UNLIMITED_NUMBER;
1388 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1389 /* Backward compatibility mode: */
1390 o->op_private |= OPpENTERSUB_INARGS;
1393 else { /* Compile-time error message: */
1394 OP *kid = cUNOPo->op_first;
1398 if (kid->op_type != OP_PUSHMARK) {
1399 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1401 "panic: unexpected lvalue entersub "
1402 "args: type/targ %ld:%"UVuf,
1403 (long)kid->op_type, (UV)kid->op_targ);
1404 kid = kLISTOP->op_first;
1406 while (kid->op_sibling)
1407 kid = kid->op_sibling;
1408 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1410 if (kid->op_type == OP_METHOD_NAMED
1411 || kid->op_type == OP_METHOD)
1415 NewOp(1101, newop, 1, UNOP);
1416 newop->op_type = OP_RV2CV;
1417 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1418 newop->op_first = NULL;
1419 newop->op_next = (OP*)newop;
1420 kid->op_sibling = (OP*)newop;
1421 newop->op_private |= OPpLVAL_INTRO;
1422 newop->op_private &= ~1;
1426 if (kid->op_type != OP_RV2CV)
1428 "panic: unexpected lvalue entersub "
1429 "entry via type/targ %ld:%"UVuf,
1430 (long)kid->op_type, (UV)kid->op_targ);
1431 kid->op_private |= OPpLVAL_INTRO;
1432 break; /* Postpone until runtime */
1436 kid = kUNOP->op_first;
1437 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1438 kid = kUNOP->op_first;
1439 if (kid->op_type == OP_NULL)
1441 "Unexpected constant lvalue entersub "
1442 "entry via type/targ %ld:%"UVuf,
1443 (long)kid->op_type, (UV)kid->op_targ);
1444 if (kid->op_type != OP_GV) {
1445 /* Restore RV2CV to check lvalueness */
1447 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1448 okid->op_next = kid->op_next;
1449 kid->op_next = okid;
1452 okid->op_next = NULL;
1453 okid->op_type = OP_RV2CV;
1455 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1456 okid->op_private |= OPpLVAL_INTRO;
1457 okid->op_private &= ~1;
1461 cv = GvCV(kGVOP_gv);
1471 /* grep, foreach, subcalls, refgen */
1472 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1474 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1475 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1477 : (o->op_type == OP_ENTERSUB
1478 ? "non-lvalue subroutine call"
1480 type ? PL_op_desc[type] : "local"));
1494 case OP_RIGHT_SHIFT:
1503 if (!(o->op_flags & OPf_STACKED))
1510 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1516 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1517 PL_modcount = RETURN_UNLIMITED_NUMBER;
1518 return o; /* Treat \(@foo) like ordinary list. */
1522 if (scalar_mod_type(o, type))
1524 ref(cUNOPo->op_first, o->op_type);
1528 if (type == OP_LEAVESUBLV)
1529 o->op_private |= OPpMAYBE_LVSUB;
1535 PL_modcount = RETURN_UNLIMITED_NUMBER;
1538 ref(cUNOPo->op_first, o->op_type);
1543 PL_hints |= HINT_BLOCK_SCOPE;
1558 PL_modcount = RETURN_UNLIMITED_NUMBER;
1559 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1560 return o; /* Treat \(@foo) like ordinary list. */
1561 if (scalar_mod_type(o, type))
1563 if (type == OP_LEAVESUBLV)
1564 o->op_private |= OPpMAYBE_LVSUB;
1568 if (!type) /* local() */
1569 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1570 PAD_COMPNAME_PV(o->op_targ));
1578 if (type != OP_SASSIGN)
1582 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1587 if (type == OP_LEAVESUBLV)
1588 o->op_private |= OPpMAYBE_LVSUB;
1590 pad_free(o->op_targ);
1591 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1592 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1593 if (o->op_flags & OPf_KIDS)
1594 mod(cBINOPo->op_first->op_sibling, type);
1599 ref(cBINOPo->op_first, o->op_type);
1600 if (type == OP_ENTERSUB &&
1601 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1602 o->op_private |= OPpLVAL_DEFER;
1603 if (type == OP_LEAVESUBLV)
1604 o->op_private |= OPpMAYBE_LVSUB;
1614 if (o->op_flags & OPf_KIDS)
1615 mod(cLISTOPo->op_last, type);
1620 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1622 else if (!(o->op_flags & OPf_KIDS))
1624 if (o->op_targ != OP_LIST) {
1625 mod(cBINOPo->op_first, type);
1631 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1636 if (type != OP_LEAVESUBLV)
1638 break; /* mod()ing was handled by ck_return() */
1641 /* [20011101.069] File test operators interpret OPf_REF to mean that
1642 their argument is a filehandle; thus \stat(".") should not set
1644 if (type == OP_REFGEN &&
1645 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1648 if (type != OP_LEAVESUBLV)
1649 o->op_flags |= OPf_MOD;
1651 if (type == OP_AASSIGN || type == OP_SASSIGN)
1652 o->op_flags |= OPf_SPECIAL|OPf_REF;
1653 else if (!type) { /* local() */
1656 o->op_private |= OPpLVAL_INTRO;
1657 o->op_flags &= ~OPf_SPECIAL;
1658 PL_hints |= HINT_BLOCK_SCOPE;
1663 if (ckWARN(WARN_SYNTAX)) {
1664 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1665 "Useless localization of %s", OP_DESC(o));
1669 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1670 && type != OP_LEAVESUBLV)
1671 o->op_flags |= OPf_REF;
1676 S_scalar_mod_type(const OP *o, I32 type)
1678 PERL_ARGS_ASSERT_SCALAR_MOD_TYPE;
1682 if (o->op_type == OP_RV2GV)
1706 case OP_RIGHT_SHIFT:
1726 S_is_handle_constructor(const OP *o, I32 numargs)
1728 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
1730 switch (o->op_type) {
1738 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1751 Perl_refkids(pTHX_ OP *o, I32 type)
1753 if (o && o->op_flags & OPf_KIDS) {
1755 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1762 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
1767 PERL_ARGS_ASSERT_DOREF;
1769 if (!o || (PL_parser && PL_parser->error_count))
1772 switch (o->op_type) {
1774 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1775 !(o->op_flags & OPf_STACKED)) {
1776 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1777 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1778 assert(cUNOPo->op_first->op_type == OP_NULL);
1779 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1780 o->op_flags |= OPf_SPECIAL;
1781 o->op_private &= ~1;
1786 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1787 doref(kid, type, set_op_ref);
1790 if (type == OP_DEFINED)
1791 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1792 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1795 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1796 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1797 : type == OP_RV2HV ? OPpDEREF_HV
1799 o->op_flags |= OPf_MOD;
1806 o->op_flags |= OPf_REF;
1809 if (type == OP_DEFINED)
1810 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1811 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1817 o->op_flags |= OPf_REF;
1822 if (!(o->op_flags & OPf_KIDS))
1824 doref(cBINOPo->op_first, type, set_op_ref);
1828 doref(cBINOPo->op_first, o->op_type, set_op_ref);
1829 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1830 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1831 : type == OP_RV2HV ? OPpDEREF_HV
1833 o->op_flags |= OPf_MOD;
1843 if (!(o->op_flags & OPf_KIDS))
1845 doref(cLISTOPo->op_last, type, set_op_ref);
1855 S_dup_attrlist(pTHX_ OP *o)
1860 PERL_ARGS_ASSERT_DUP_ATTRLIST;
1862 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1863 * where the first kid is OP_PUSHMARK and the remaining ones
1864 * are OP_CONST. We need to push the OP_CONST values.
1866 if (o->op_type == OP_CONST)
1867 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
1869 else if (o->op_type == OP_NULL)
1873 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1875 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1876 if (o->op_type == OP_CONST)
1877 rop = append_elem(OP_LIST, rop,
1878 newSVOP(OP_CONST, o->op_flags,
1879 SvREFCNT_inc_NN(cSVOPo->op_sv)));
1886 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1891 PERL_ARGS_ASSERT_APPLY_ATTRS;
1893 /* fake up C<use attributes $pkg,$rv,@attrs> */
1894 ENTER; /* need to protect against side-effects of 'use' */
1895 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1897 #define ATTRSMODULE "attributes"
1898 #define ATTRSMODULE_PM "attributes.pm"
1901 /* Don't force the C<use> if we don't need it. */
1902 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
1903 if (svp && *svp != &PL_sv_undef)
1904 NOOP; /* already in %INC */
1906 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1907 newSVpvs(ATTRSMODULE), NULL);
1910 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1911 newSVpvs(ATTRSMODULE),
1913 prepend_elem(OP_LIST,
1914 newSVOP(OP_CONST, 0, stashsv),
1915 prepend_elem(OP_LIST,
1916 newSVOP(OP_CONST, 0,
1918 dup_attrlist(attrs))));
1924 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1927 OP *pack, *imop, *arg;
1930 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
1935 assert(target->op_type == OP_PADSV ||
1936 target->op_type == OP_PADHV ||
1937 target->op_type == OP_PADAV);
1939 /* Ensure that attributes.pm is loaded. */
1940 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1942 /* Need package name for method call. */
1943 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
1945 /* Build up the real arg-list. */
1946 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1948 arg = newOP(OP_PADSV, 0);
1949 arg->op_targ = target->op_targ;
1950 arg = prepend_elem(OP_LIST,
1951 newSVOP(OP_CONST, 0, stashsv),
1952 prepend_elem(OP_LIST,
1953 newUNOP(OP_REFGEN, 0,
1954 mod(arg, OP_REFGEN)),
1955 dup_attrlist(attrs)));
1957 /* Fake up a method call to import */
1958 meth = newSVpvs_share("import");
1959 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1960 append_elem(OP_LIST,
1961 prepend_elem(OP_LIST, pack, list(arg)),
1962 newSVOP(OP_METHOD_NAMED, 0, meth)));
1963 imop->op_private |= OPpENTERSUB_NOMOD;
1965 /* Combine the ops. */
1966 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1970 =notfor apidoc apply_attrs_string
1972 Attempts to apply a list of attributes specified by the C<attrstr> and
1973 C<len> arguments to the subroutine identified by the C<cv> argument which
1974 is expected to be associated with the package identified by the C<stashpv>
1975 argument (see L<attributes>). It gets this wrong, though, in that it
1976 does not correctly identify the boundaries of the individual attribute
1977 specifications within C<attrstr>. This is not really intended for the
1978 public API, but has to be listed here for systems such as AIX which
1979 need an explicit export list for symbols. (It's called from XS code
1980 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1981 to respect attribute syntax properly would be welcome.
1987 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
1988 const char *attrstr, STRLEN len)
1992 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
1995 len = strlen(attrstr);
1999 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2001 const char * const sstr = attrstr;
2002 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2003 attrs = append_elem(OP_LIST, attrs,
2004 newSVOP(OP_CONST, 0,
2005 newSVpvn(sstr, attrstr-sstr)));
2009 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2010 newSVpvs(ATTRSMODULE),
2011 NULL, prepend_elem(OP_LIST,
2012 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2013 prepend_elem(OP_LIST,
2014 newSVOP(OP_CONST, 0,
2020 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
2025 PERL_ARGS_ASSERT_MY_KID;
2027 if (!o || (PL_parser && PL_parser->error_count))
2031 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
2032 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
2036 if (type == OP_LIST) {
2038 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2039 my_kid(kid, attrs, imopsp);
2040 } else if (type == OP_UNDEF
2046 } else if (type == OP_RV2SV || /* "our" declaration */
2048 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
2049 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
2050 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2052 PL_parser->in_my == KEY_our
2054 : PL_parser->in_my == KEY_state ? "state" : "my"));
2056 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
2057 PL_parser->in_my = FALSE;
2058 PL_parser->in_my_stash = NULL;
2059 apply_attrs(GvSTASH(gv),
2060 (type == OP_RV2SV ? GvSV(gv) :
2061 type == OP_RV2AV ? (SV*)GvAV(gv) :
2062 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
2065 o->op_private |= OPpOUR_INTRO;
2068 else if (type != OP_PADSV &&
2071 type != OP_PUSHMARK)
2073 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2075 PL_parser->in_my == KEY_our
2077 : PL_parser->in_my == KEY_state ? "state" : "my"));
2080 else if (attrs && type != OP_PUSHMARK) {
2083 PL_parser->in_my = FALSE;
2084 PL_parser->in_my_stash = NULL;
2086 /* check for C<my Dog $spot> when deciding package */
2087 stash = PAD_COMPNAME_TYPE(o->op_targ);
2089 stash = PL_curstash;
2090 apply_attrs_my(stash, o, attrs, imopsp);
2092 o->op_flags |= OPf_MOD;
2093 o->op_private |= OPpLVAL_INTRO;
2094 if (PL_parser->in_my == KEY_state)
2095 o->op_private |= OPpPAD_STATE;
2100 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2104 int maybe_scalar = 0;
2106 PERL_ARGS_ASSERT_MY_ATTRS;
2108 /* [perl #17376]: this appears to be premature, and results in code such as
2109 C< our(%x); > executing in list mode rather than void mode */
2111 if (o->op_flags & OPf_PARENS)
2121 o = my_kid(o, attrs, &rops);
2123 if (maybe_scalar && o->op_type == OP_PADSV) {
2124 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
2125 o->op_private |= OPpLVAL_INTRO;
2128 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
2130 PL_parser->in_my = FALSE;
2131 PL_parser->in_my_stash = NULL;
2136 Perl_my(pTHX_ OP *o)
2138 PERL_ARGS_ASSERT_MY;
2140 return my_attrs(o, NULL);
2144 Perl_sawparens(pTHX_ OP *o)
2146 PERL_UNUSED_CONTEXT;
2148 o->op_flags |= OPf_PARENS;
2153 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2157 const OPCODE ltype = left->op_type;
2158 const OPCODE rtype = right->op_type;
2160 PERL_ARGS_ASSERT_BIND_MATCH;
2162 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2163 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
2165 const char * const desc
2166 = PL_op_desc[(rtype == OP_SUBST || rtype == OP_TRANS)
2167 ? (int)rtype : OP_MATCH];
2168 const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV)
2169 ? "@array" : "%hash");
2170 Perl_warner(aTHX_ packWARN(WARN_MISC),
2171 "Applying %s to %s will act on scalar(%s)",
2172 desc, sample, sample);
2175 if (rtype == OP_CONST &&
2176 cSVOPx(right)->op_private & OPpCONST_BARE &&
2177 cSVOPx(right)->op_private & OPpCONST_STRICT)
2179 no_bareword_allowed(right);
2182 ismatchop = rtype == OP_MATCH ||
2183 rtype == OP_SUBST ||
2185 if (ismatchop && right->op_private & OPpTARGET_MY) {
2187 right->op_private &= ~OPpTARGET_MY;
2189 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
2192 right->op_flags |= OPf_STACKED;
2193 if (rtype != OP_MATCH &&
2194 ! (rtype == OP_TRANS &&
2195 right->op_private & OPpTRANS_IDENTICAL))
2196 newleft = mod(left, rtype);
2199 if (right->op_type == OP_TRANS)
2200 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
2202 o = prepend_elem(rtype, scalar(newleft), right);
2204 return newUNOP(OP_NOT, 0, scalar(o));
2208 return bind_match(type, left,
2209 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
2213 Perl_invert(pTHX_ OP *o)
2217 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2221 Perl_scope(pTHX_ OP *o)
2225 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2226 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2227 o->op_type = OP_LEAVE;
2228 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2230 else if (o->op_type == OP_LINESEQ) {
2232 o->op_type = OP_SCOPE;
2233 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2234 kid = ((LISTOP*)o)->op_first;
2235 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2238 /* The following deals with things like 'do {1 for 1}' */
2239 kid = kid->op_sibling;
2241 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2246 o = newLISTOP(OP_SCOPE, 0, o, NULL);
2252 Perl_block_start(pTHX_ int full)
2255 const int retval = PL_savestack_ix;
2256 pad_block_start(full);
2258 PL_hints &= ~HINT_BLOCK_SCOPE;
2259 SAVECOMPILEWARNINGS();
2260 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
2265 Perl_block_end(pTHX_ I32 floor, OP *seq)
2268 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2269 OP* const retval = scalarseq(seq);
2271 CopHINTS_set(&PL_compiling, PL_hints);
2273 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2282 const PADOFFSET offset = pad_findmy("$_");
2283 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
2284 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2287 OP * const o = newOP(OP_PADSV, 0);
2288 o->op_targ = offset;
2294 Perl_newPROG(pTHX_ OP *o)
2298 PERL_ARGS_ASSERT_NEWPROG;
2303 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2304 ((PL_in_eval & EVAL_KEEPERR)
2305 ? OPf_SPECIAL : 0), o);
2306 PL_eval_start = linklist(PL_eval_root);
2307 PL_eval_root->op_private |= OPpREFCOUNTED;
2308 OpREFCNT_set(PL_eval_root, 1);
2309 PL_eval_root->op_next = 0;
2310 CALL_PEEP(PL_eval_start);
2313 if (o->op_type == OP_STUB) {
2314 PL_comppad_name = 0;
2316 S_op_destroy(aTHX_ o);
2319 PL_main_root = scope(sawparens(scalarvoid(o)));
2320 PL_curcop = &PL_compiling;
2321 PL_main_start = LINKLIST(PL_main_root);
2322 PL_main_root->op_private |= OPpREFCOUNTED;
2323 OpREFCNT_set(PL_main_root, 1);
2324 PL_main_root->op_next = 0;
2325 CALL_PEEP(PL_main_start);
2328 /* Register with debugger */
2331 = Perl_get_cvn_flags(aTHX_ STR_WITH_LEN("DB::postponed"), 0);
2335 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2337 call_sv((SV*)cv, G_DISCARD);
2344 Perl_localize(pTHX_ OP *o, I32 lex)
2348 PERL_ARGS_ASSERT_LOCALIZE;
2350 if (o->op_flags & OPf_PARENS)
2351 /* [perl #17376]: this appears to be premature, and results in code such as
2352 C< our(%x); > executing in list mode rather than void mode */
2359 if ( PL_parser->bufptr > PL_parser->oldbufptr
2360 && PL_parser->bufptr[-1] == ','
2361 && ckWARN(WARN_PARENTHESIS))
2363 char *s = PL_parser->bufptr;
2366 /* some heuristics to detect a potential error */
2367 while (*s && (strchr(", \t\n", *s)))
2371 if (*s && strchr("@$%*", *s) && *++s
2372 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2375 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2377 while (*s && (strchr(", \t\n", *s)))
2383 if (sigil && (*s == ';' || *s == '=')) {
2384 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2385 "Parentheses missing around \"%s\" list",
2387 ? (PL_parser->in_my == KEY_our
2389 : PL_parser->in_my == KEY_state
2399 o = mod(o, OP_NULL); /* a bit kludgey */
2400 PL_parser->in_my = FALSE;
2401 PL_parser->in_my_stash = NULL;
2406 Perl_jmaybe(pTHX_ OP *o)
2408 PERL_ARGS_ASSERT_JMAYBE;
2410 if (o->op_type == OP_LIST) {
2412 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2413 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2419 Perl_fold_constants(pTHX_ register OP *o)
2422 register OP * VOL curop;
2424 VOL I32 type = o->op_type;
2429 SV * const oldwarnhook = PL_warnhook;
2430 SV * const olddiehook = PL_diehook;
2434 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
2436 if (PL_opargs[type] & OA_RETSCALAR)
2438 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2439 o->op_targ = pad_alloc(type, SVs_PADTMP);
2441 /* integerize op, unless it happens to be C<-foo>.
2442 * XXX should pp_i_negate() do magic string negation instead? */
2443 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2444 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2445 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2447 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2450 if (!(PL_opargs[type] & OA_FOLDCONST))
2455 /* XXX might want a ck_negate() for this */
2456 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2467 /* XXX what about the numeric ops? */
2468 if (PL_hints & HINT_LOCALE)
2473 if (PL_parser && PL_parser->error_count)
2474 goto nope; /* Don't try to run w/ errors */
2476 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2477 const OPCODE type = curop->op_type;
2478 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2480 type != OP_SCALAR &&
2482 type != OP_PUSHMARK)
2488 curop = LINKLIST(o);
2489 old_next = o->op_next;
2493 oldscope = PL_scopestack_ix;
2494 create_eval_scope(G_FAKINGEVAL);
2496 /* Verify that we don't need to save it: */
2497 assert(PL_curcop == &PL_compiling);
2498 StructCopy(&PL_compiling, ¬_compiling, COP);
2499 PL_curcop = ¬_compiling;
2500 /* The above ensures that we run with all the correct hints of the
2501 currently compiling COP, but that IN_PERL_RUNTIME is not true. */
2502 assert(IN_PERL_RUNTIME);
2503 PL_warnhook = PERL_WARNHOOK_FATAL;
2510 sv = *(PL_stack_sp--);
2511 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2512 pad_swipe(o->op_targ, FALSE);
2513 else if (SvTEMP(sv)) { /* grab mortal temp? */
2514 SvREFCNT_inc_simple_void(sv);
2519 /* Something tried to die. Abandon constant folding. */
2520 /* Pretend the error never happened. */
2521 sv_setpvn(ERRSV,"",0);
2522 o->op_next = old_next;
2526 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
2527 PL_warnhook = oldwarnhook;
2528 PL_diehook = olddiehook;
2529 /* XXX note that this croak may fail as we've already blown away
2530 * the stack - eg any nested evals */
2531 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
2534 PL_warnhook = oldwarnhook;
2535 PL_diehook = olddiehook;
2536 PL_curcop = &PL_compiling;
2538 if (PL_scopestack_ix > oldscope)
2539 delete_eval_scope();
2548 if (type == OP_RV2GV)
2549 newop = newGVOP(OP_GV, 0, (GV*)sv);
2551 newop = newSVOP(OP_CONST, 0, (SV*)sv);
2552 op_getmad(o,newop,'f');
2560 Perl_gen_constant_list(pTHX_ register OP *o)
2564 const I32 oldtmps_floor = PL_tmps_floor;
2567 if (PL_parser && PL_parser->error_count)
2568 return o; /* Don't attempt to run with errors */
2570 PL_op = curop = LINKLIST(o);
2576 assert (!(curop->op_flags & OPf_SPECIAL));
2577 assert(curop->op_type == OP_RANGE);
2579 PL_tmps_floor = oldtmps_floor;
2581 o->op_type = OP_RV2AV;
2582 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2583 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2584 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2585 o->op_opt = 0; /* needs to be revisited in peep() */
2586 curop = ((UNOP*)o)->op_first;
2587 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
2589 op_getmad(curop,o,'O');
2598 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2601 if (!o || o->op_type != OP_LIST)
2602 o = newLISTOP(OP_LIST, 0, o, NULL);
2604 o->op_flags &= ~OPf_WANT;
2606 if (!(PL_opargs[type] & OA_MARK))
2607 op_null(cLISTOPo->op_first);
2609 o->op_type = (OPCODE)type;
2610 o->op_ppaddr = PL_ppaddr[type];
2611 o->op_flags |= flags;
2613 o = CHECKOP(type, o);
2614 if (o->op_type != (unsigned)type)
2617 return fold_constants(o);
2620 /* List constructors */
2623 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2631 if (first->op_type != (unsigned)type
2632 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2634 return newLISTOP(type, 0, first, last);
2637 if (first->op_flags & OPf_KIDS)
2638 ((LISTOP*)first)->op_last->op_sibling = last;
2640 first->op_flags |= OPf_KIDS;
2641 ((LISTOP*)first)->op_first = last;
2643 ((LISTOP*)first)->op_last = last;
2648 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2656 if (first->op_type != (unsigned)type)
2657 return prepend_elem(type, (OP*)first, (OP*)last);
2659 if (last->op_type != (unsigned)type)
2660 return append_elem(type, (OP*)first, (OP*)last);
2662 first->op_last->op_sibling = last->op_first;
2663 first->op_last = last->op_last;
2664 first->op_flags |= (last->op_flags & OPf_KIDS);
2667 if (last->op_first && first->op_madprop) {
2668 MADPROP *mp = last->op_first->op_madprop;
2670 while (mp->mad_next)
2672 mp->mad_next = first->op_madprop;
2675 last->op_first->op_madprop = first->op_madprop;
2678 first->op_madprop = last->op_madprop;
2679 last->op_madprop = 0;
2682 S_op_destroy(aTHX_ (OP*)last);
2688 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2696 if (last->op_type == (unsigned)type) {
2697 if (type == OP_LIST) { /* already a PUSHMARK there */
2698 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2699 ((LISTOP*)last)->op_first->op_sibling = first;
2700 if (!(first->op_flags & OPf_PARENS))
2701 last->op_flags &= ~OPf_PARENS;
2704 if (!(last->op_flags & OPf_KIDS)) {
2705 ((LISTOP*)last)->op_last = first;
2706 last->op_flags |= OPf_KIDS;
2708 first->op_sibling = ((LISTOP*)last)->op_first;
2709 ((LISTOP*)last)->op_first = first;
2711 last->op_flags |= OPf_KIDS;
2715 return newLISTOP(type, 0, first, last);
2723 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2726 Newxz(tk, 1, TOKEN);
2727 tk->tk_type = (OPCODE)optype;
2728 tk->tk_type = 12345;
2730 tk->tk_mad = madprop;
2735 Perl_token_free(pTHX_ TOKEN* tk)
2737 PERL_ARGS_ASSERT_TOKEN_FREE;
2739 if (tk->tk_type != 12345)
2741 mad_free(tk->tk_mad);
2746 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2751 PERL_ARGS_ASSERT_TOKEN_GETMAD;
2753 if (tk->tk_type != 12345) {
2754 Perl_warner(aTHX_ packWARN(WARN_MISC),
2755 "Invalid TOKEN object ignored");
2762 /* faked up qw list? */
2764 tm->mad_type == MAD_SV &&
2765 SvPVX((SV*)tm->mad_val)[0] == 'q')
2772 /* pretend constant fold didn't happen? */
2773 if (mp->mad_key == 'f' &&
2774 (o->op_type == OP_CONST ||
2775 o->op_type == OP_GV) )
2777 token_getmad(tk,(OP*)mp->mad_val,slot);
2791 if (mp->mad_key == 'X')
2792 mp->mad_key = slot; /* just change the first one */
2802 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
2811 /* pretend constant fold didn't happen? */
2812 if (mp->mad_key == 'f' &&
2813 (o->op_type == OP_CONST ||
2814 o->op_type == OP_GV) )
2816 op_getmad(from,(OP*)mp->mad_val,slot);
2823 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
2826 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
2832 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
2841 /* pretend constant fold didn't happen? */
2842 if (mp->mad_key == 'f' &&
2843 (o->op_type == OP_CONST ||
2844 o->op_type == OP_GV) )
2846 op_getmad(from,(OP*)mp->mad_val,slot);
2853 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
2856 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
2860 PerlIO_printf(PerlIO_stderr(),
2861 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
2867 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
2885 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
2889 addmad(tm, &(o->op_madprop), slot);
2893 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
2914 Perl_newMADsv(pTHX_ char key, SV* sv)
2916 PERL_ARGS_ASSERT_NEWMADSV;
2918 return newMADPROP(key, MAD_SV, sv, 0);
2922 Perl_newMADPROP(pTHX_ char key, char type, const void* val, I32 vlen)
2925 Newxz(mp, 1, MADPROP);
2928 mp->mad_vlen = vlen;
2929 mp->mad_type = type;
2931 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
2936 Perl_mad_free(pTHX_ MADPROP* mp)
2938 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
2942 mad_free(mp->mad_next);
2943 /* if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
2944 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
2945 switch (mp->mad_type) {
2949 Safefree((char*)mp->mad_val);
2952 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
2953 op_free((OP*)mp->mad_val);
2956 sv_free((SV*)mp->mad_val);
2959 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
2968 Perl_newNULLLIST(pTHX)
2970 return newOP(OP_STUB, 0);
2974 Perl_force_list(pTHX_ OP *o)
2976 if (!o || o->op_type != OP_LIST)
2977 o = newLISTOP(OP_LIST, 0, o, NULL);
2983 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2988 NewOp(1101, listop, 1, LISTOP);
2990 listop->op_type = (OPCODE)type;
2991 listop->op_ppaddr = PL_ppaddr[type];
2994 listop->op_flags = (U8)flags;
2998 else if (!first && last)
3001 first->op_sibling = last;
3002 listop->op_first = first;
3003 listop->op_last = last;
3004 if (type == OP_LIST) {
3005 OP* const pushop = newOP(OP_PUSHMARK, 0);
3006 pushop->op_sibling = first;
3007 listop->op_first = pushop;
3008 listop->op_flags |= OPf_KIDS;
3010 listop->op_last = pushop;
3013 return CHECKOP(type, listop);
3017 Perl_newOP(pTHX_ I32 type, I32 flags)
3021 NewOp(1101, o, 1, OP);
3022 o->op_type = (OPCODE)type;
3023 o->op_ppaddr = PL_ppaddr[type];
3024 o->op_flags = (U8)flags;
3026 o->op_latefreed = 0;
3030 o->op_private = (U8)(0 | (flags >> 8));
3031 if (PL_opargs[type] & OA_RETSCALAR)
3033 if (PL_opargs[type] & OA_TARGET)
3034 o->op_targ = pad_alloc(type, SVs_PADTMP);
3035 return CHECKOP(type, o);
3039 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
3045 first = newOP(OP_STUB, 0);
3046 if (PL_opargs[type] & OA_MARK)
3047 first = force_list(first);
3049 NewOp(1101, unop, 1, UNOP);
3050 unop->op_type = (OPCODE)type;
3051 unop->op_ppaddr = PL_ppaddr[type];
3052 unop->op_first = first;
3053 unop->op_flags = (U8)(flags | OPf_KIDS);
3054 unop->op_private = (U8)(1 | (flags >> 8));
3055 unop = (UNOP*) CHECKOP(type, unop);
3059 return fold_constants((OP *) unop);
3063 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3067 NewOp(1101, binop, 1, BINOP);
3070 first = newOP(OP_NULL, 0);
3072 binop->op_type = (OPCODE)type;
3073 binop->op_ppaddr = PL_ppaddr[type];
3074 binop->op_first = first;
3075 binop->op_flags = (U8)(flags | OPf_KIDS);
3078 binop->op_private = (U8)(1 | (flags >> 8));
3081 binop->op_private = (U8)(2 | (flags >> 8));
3082 first->op_sibling = last;
3085 binop = (BINOP*)CHECKOP(type, binop);
3086 if (binop->op_next || binop->op_type != (OPCODE)type)
3089 binop->op_last = binop->op_first->op_sibling;
3091 return fold_constants((OP *)binop);
3094 static int uvcompare(const void *a, const void *b)
3095 __attribute__nonnull__(1)
3096 __attribute__nonnull__(2)
3097 __attribute__pure__;
3098 static int uvcompare(const void *a, const void *b)
3100 if (*((const UV *)a) < (*(const UV *)b))
3102 if (*((const UV *)a) > (*(const UV *)b))
3104 if (*((const UV *)a+1) < (*(const UV *)b+1))
3106 if (*((const UV *)a+1) > (*(const UV *)b+1))
3112 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
3115 SV * const tstr = ((SVOP*)expr)->op_sv;
3118 (repl->op_type == OP_NULL)
3119 ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
3121 ((SVOP*)repl)->op_sv;
3124 const U8 *t = (U8*)SvPV_const(tstr, tlen);
3125 const U8 *r = (U8*)SvPV_const(rstr, rlen);
3129 register short *tbl;
3131 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
3132 const I32 squash = o->op_private & OPpTRANS_SQUASH;
3133 I32 del = o->op_private & OPpTRANS_DELETE;
3136 PERL_ARGS_ASSERT_PMTRANS;
3138 PL_hints |= HINT_BLOCK_SCOPE;
3141 o->op_private |= OPpTRANS_FROM_UTF;
3144 o->op_private |= OPpTRANS_TO_UTF;
3146 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
3147 SV* const listsv = newSVpvs("# comment\n");
3149 const U8* tend = t + tlen;
3150 const U8* rend = r + rlen;
3164 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
3165 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
3168 const U32 flags = UTF8_ALLOW_DEFAULT;
3172 t = tsave = bytes_to_utf8(t, &len);
3175 if (!to_utf && rlen) {
3177 r = rsave = bytes_to_utf8(r, &len);
3181 /* There are several snags with this code on EBCDIC:
3182 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
3183 2. scan_const() in toke.c has encoded chars in native encoding which makes
3184 ranges at least in EBCDIC 0..255 range the bottom odd.
3188 U8 tmpbuf[UTF8_MAXBYTES+1];
3191 Newx(cp, 2*tlen, UV);
3193 transv = newSVpvs("");
3195 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3197 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
3199 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3203 cp[2*i+1] = cp[2*i];
3207 qsort(cp, i, 2*sizeof(UV), uvcompare);
3208 for (j = 0; j < i; j++) {
3210 diff = val - nextmin;
3212 t = uvuni_to_utf8(tmpbuf,nextmin);
3213 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3215 U8 range_mark = UTF_TO_NATIVE(0xff);
3216 t = uvuni_to_utf8(tmpbuf, val - 1);
3217 sv_catpvn(transv, (char *)&range_mark, 1);
3218 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3225 t = uvuni_to_utf8(tmpbuf,nextmin);
3226 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3228 U8 range_mark = UTF_TO_NATIVE(0xff);
3229 sv_catpvn(transv, (char *)&range_mark, 1);
3231 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
3232 UNICODE_ALLOW_SUPER);
3233 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3234 t = (const U8*)SvPVX_const(transv);
3235 tlen = SvCUR(transv);
3239 else if (!rlen && !del) {
3240 r = t; rlen = tlen; rend = tend;
3243 if ((!rlen && !del) || t == r ||
3244 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
3246 o->op_private |= OPpTRANS_IDENTICAL;
3250 while (t < tend || tfirst <= tlast) {
3251 /* see if we need more "t" chars */
3252 if (tfirst > tlast) {
3253 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3255 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
3257 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3264 /* now see if we need more "r" chars */
3265 if (rfirst > rlast) {
3267 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3269 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
3271 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3280 rfirst = rlast = 0xffffffff;
3284 /* now see which range will peter our first, if either. */
3285 tdiff = tlast - tfirst;
3286 rdiff = rlast - rfirst;
3293 if (rfirst == 0xffffffff) {
3294 diff = tdiff; /* oops, pretend rdiff is infinite */
3296 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
3297 (long)tfirst, (long)tlast);
3299 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
3303 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
3304 (long)tfirst, (long)(tfirst + diff),
3307 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3308 (long)tfirst, (long)rfirst);
3310 if (rfirst + diff > max)
3311 max = rfirst + diff;
3313 grows = (tfirst < rfirst &&
3314 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3326 else if (max > 0xff)
3331 PerlMemShared_free(cPVOPo->op_pv);
3332 cPVOPo->op_pv = NULL;
3334 swash = (SV*)swash_init("utf8", "", listsv, bits, none);
3336 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
3337 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
3338 PAD_SETSV(cPADOPo->op_padix, swash);
3341 cSVOPo->op_sv = swash;
3343 SvREFCNT_dec(listsv);
3344 SvREFCNT_dec(transv);
3346 if (!del && havefinal && rlen)
3347 (void)hv_store((HV*)SvRV(swash), "FINAL", 5,
3348 newSVuv((UV)final), 0);
3351 o->op_private |= OPpTRANS_GROWS;
3357 op_getmad(expr,o,'e');
3358 op_getmad(repl,o,'r');
3366 tbl = (short*)cPVOPo->op_pv;
3368 Zero(tbl, 256, short);
3369 for (i = 0; i < (I32)tlen; i++)
3371 for (i = 0, j = 0; i < 256; i++) {
3373 if (j >= (I32)rlen) {
3382 if (i < 128 && r[j] >= 128)
3392 o->op_private |= OPpTRANS_IDENTICAL;
3394 else if (j >= (I32)rlen)
3399 PerlMemShared_realloc(tbl,
3400 (0x101+rlen-j) * sizeof(short));
3401 cPVOPo->op_pv = (char*)tbl;
3403 tbl[0x100] = (short)(rlen - j);
3404 for (i=0; i < (I32)rlen - j; i++)
3405 tbl[0x101+i] = r[j+i];
3409 if (!rlen && !del) {
3412 o->op_private |= OPpTRANS_IDENTICAL;
3414 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3415 o->op_private |= OPpTRANS_IDENTICAL;
3417 for (i = 0; i < 256; i++)
3419 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3420 if (j >= (I32)rlen) {
3422 if (tbl[t[i]] == -1)
3428 if (tbl[t[i]] == -1) {
3429 if (t[i] < 128 && r[j] >= 128)
3436 o->op_private |= OPpTRANS_GROWS;
3438 op_getmad(expr,o,'e');
3439 op_getmad(repl,o,'r');
3449 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3454 NewOp(1101, pmop, 1, PMOP);
3455 pmop->op_type = (OPCODE)type;
3456 pmop->op_ppaddr = PL_ppaddr[type];
3457 pmop->op_flags = (U8)flags;
3458 pmop->op_private = (U8)(0 | (flags >> 8));
3460 if (PL_hints & HINT_RE_TAINT)
3461 pmop->op_pmflags |= PMf_RETAINT;
3462 if (PL_hints & HINT_LOCALE)
3463 pmop->op_pmflags |= PMf_LOCALE;
3467 assert(SvPOK(PL_regex_pad[0]));
3468 if (SvCUR(PL_regex_pad[0])) {
3469 /* Pop off the "packed" IV from the end. */
3470 SV *const repointer_list = PL_regex_pad[0];
3471 const char *p = SvEND(repointer_list) - sizeof(IV);
3472 const IV offset = *((IV*)p);
3474 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
3476 SvEND_set(repointer_list, p);
3478 pmop->op_pmoffset = offset;
3479 /* This slot should be free, so assert this: */
3480 assert(PL_regex_pad[offset] == &PL_sv_undef);
3482 SV * const repointer = &PL_sv_undef;
3483 av_push(PL_regex_padav, repointer);
3484 pmop->op_pmoffset = av_len(PL_regex_padav);
3485 PL_regex_pad = AvARRAY(PL_regex_padav);
3489 return CHECKOP(type, pmop);
3492 /* Given some sort of match op o, and an expression expr containing a
3493 * pattern, either compile expr into a regex and attach it to o (if it's
3494 * constant), or convert expr into a runtime regcomp op sequence (if it's
3497 * isreg indicates that the pattern is part of a regex construct, eg
3498 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3499 * split "pattern", which aren't. In the former case, expr will be a list
3500 * if the pattern contains more than one term (eg /a$b/) or if it contains
3501 * a replacement, ie s/// or tr///.
3505 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
3510 I32 repl_has_vars = 0;
3514 PERL_ARGS_ASSERT_PMRUNTIME;
3516 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
3517 /* last element in list is the replacement; pop it */
3519 repl = cLISTOPx(expr)->op_last;
3520 kid = cLISTOPx(expr)->op_first;
3521 while (kid->op_sibling != repl)
3522 kid = kid->op_sibling;
3523 kid->op_sibling = NULL;
3524 cLISTOPx(expr)->op_last = kid;
3527 if (isreg && expr->op_type == OP_LIST &&
3528 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3530 /* convert single element list to element */
3531 OP* const oe = expr;
3532 expr = cLISTOPx(oe)->op_first->op_sibling;
3533 cLISTOPx(oe)->op_first->op_sibling = NULL;
3534 cLISTOPx(oe)->op_last = NULL;
3538 if (o->op_type == OP_TRANS) {
3539 return pmtrans(o, expr, repl);
3542 reglist = isreg && expr->op_type == OP_LIST;
3546 PL_hints |= HINT_BLOCK_SCOPE;
3549 if (expr->op_type == OP_CONST) {
3550 SV *pat = ((SVOP*)expr)->op_sv;
3551 U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
3553 if (o->op_flags & OPf_SPECIAL)
3554 pm_flags |= RXf_SPLIT;
3557 assert (SvUTF8(pat));
3558 } else if (SvUTF8(pat)) {
3559 /* Not doing UTF-8, despite what the SV says. Is this only if we're
3560 trapped in use 'bytes'? */
3561 /* Make a copy of the octet sequence, but without the flag on, as
3562 the compiler now honours the SvUTF8 flag on pat. */
3564 const char *const p = SvPV(pat, len);
3565 pat = newSVpvn_flags(p, len, SVs_TEMP);
3568 PM_SETRE(pm, CALLREGCOMP(pat, pm_flags));
3571 op_getmad(expr,(OP*)pm,'e');
3577 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3578 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3580 : OP_REGCMAYBE),0,expr);
3582 NewOp(1101, rcop, 1, LOGOP);
3583 rcop->op_type = OP_REGCOMP;
3584 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3585 rcop->op_first = scalar(expr);
3586 rcop->op_flags |= OPf_KIDS
3587 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3588 | (reglist ? OPf_STACKED : 0);
3589 rcop->op_private = 1;
3592 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3594 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
3597 /* establish postfix order */
3598 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3600 rcop->op_next = expr;
3601 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3604 rcop->op_next = LINKLIST(expr);
3605 expr->op_next = (OP*)rcop;
3608 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3613 if (pm->op_pmflags & PMf_EVAL) {
3615 if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
3616 CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
3618 else if (repl->op_type == OP_CONST)
3622 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3623 if (curop->op_type == OP_SCOPE
3624 || curop->op_type == OP_LEAVE
3625 || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
3626 if (curop->op_type == OP_GV) {
3627 GV * const gv = cGVOPx_gv(curop);
3629 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3632 else if (curop->op_type == OP_RV2CV)
3634 else if (curop->op_type == OP_RV2SV ||
3635 curop->op_type == OP_RV2AV ||
3636 curop->op_type == OP_RV2HV ||
3637 curop->op_type == OP_RV2GV) {
3638 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3641 else if (curop->op_type == OP_PADSV ||
3642 curop->op_type == OP_PADAV ||
3643 curop->op_type == OP_PADHV ||
3644 curop->op_type == OP_PADANY)
3648 else if (curop->op_type == OP_PUSHRE)
3649 NOOP; /* Okay here, dangerous in newASSIGNOP */
3659 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
3661 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3662 prepend_elem(o->op_type, scalar(repl), o);
3665 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3666 pm->op_pmflags |= PMf_MAYBE_CONST;
3668 NewOp(1101, rcop, 1, LOGOP);
3669 rcop->op_type = OP_SUBSTCONT;
3670 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3671 rcop->op_first = scalar(repl);
3672 rcop->op_flags |= OPf_KIDS;
3673 rcop->op_private = 1;
3676 /* establish postfix order */
3677 rcop->op_next = LINKLIST(repl);
3678 repl->op_next = (OP*)rcop;
3680 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
3681 assert(!(pm->op_pmflags & PMf_ONCE));
3682 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
3691 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3696 PERL_ARGS_ASSERT_NEWSVOP;
3698 NewOp(1101, svop, 1, SVOP);
3699 svop->op_type = (OPCODE)type;
3700 svop->op_ppaddr = PL_ppaddr[type];
3702 svop->op_next = (OP*)svop;
3703 svop->op_flags = (U8)flags;
3704 if (PL_opargs[type] & OA_RETSCALAR)
3706 if (PL_opargs[type] & OA_TARGET)
3707 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3708 return CHECKOP(type, svop);
3713 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3718 PERL_ARGS_ASSERT_NEWPADOP;
3720 NewOp(1101, padop, 1, PADOP);
3721 padop->op_type = (OPCODE)type;
3722 padop->op_ppaddr = PL_ppaddr[type];
3723 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3724 SvREFCNT_dec(PAD_SVl(padop->op_padix));
3725 PAD_SETSV(padop->op_padix, sv);
3728 padop->op_next = (OP*)padop;
3729 padop->op_flags = (U8)flags;
3730 if (PL_opargs[type] & OA_RETSCALAR)
3732 if (PL_opargs[type] & OA_TARGET)
3733 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3734 return CHECKOP(type, padop);
3739 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3743 PERL_ARGS_ASSERT_NEWGVOP;
3747 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3749 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3754 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3758 NewOp(1101, pvop, 1, PVOP);
3759 pvop->op_type = (OPCODE)type;
3760 pvop->op_ppaddr = PL_ppaddr[type];
3762 pvop->op_next = (OP*)pvop;
3763 pvop->op_flags = (U8)flags;
3764 if (PL_opargs[type] & OA_RETSCALAR)
3766 if (PL_opargs[type] & OA_TARGET)
3767 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3768 return CHECKOP(type, pvop);
3776 Perl_package(pTHX_ OP *o)
3779 SV *const sv = cSVOPo->op_sv;
3784 PERL_ARGS_ASSERT_PACKAGE;
3786 save_hptr(&PL_curstash);
3787 save_item(PL_curstname);
3789 PL_curstash = gv_stashsv(sv, GV_ADD);
3791 sv_setsv(PL_curstname, sv);
3793 PL_hints |= HINT_BLOCK_SCOPE;
3794 PL_parser->copline = NOLINE;
3795 PL_parser->expect = XSTATE;
3800 if (!PL_madskills) {
3805 pegop = newOP(OP_NULL,0);
3806 op_getmad(o,pegop,'P');
3816 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3823 OP *pegop = newOP(OP_NULL,0);
3826 PERL_ARGS_ASSERT_UTILIZE;
3828 if (idop->op_type != OP_CONST)
3829 Perl_croak(aTHX_ "Module name must be constant");
3832 op_getmad(idop,pegop,'U');
3837 SV * const vesv = ((SVOP*)version)->op_sv;
3840 op_getmad(version,pegop,'V');
3841 if (!arg && !SvNIOKp(vesv)) {
3848 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3849 Perl_croak(aTHX_ "Version number must be constant number");
3851 /* Make copy of idop so we don't free it twice */
3852 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3854 /* Fake up a method call to VERSION */
3855 meth = newSVpvs_share("VERSION");
3856 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3857 append_elem(OP_LIST,
3858 prepend_elem(OP_LIST, pack, list(version)),
3859 newSVOP(OP_METHOD_NAMED, 0, meth)));
3863 /* Fake up an import/unimport */
3864 if (arg && arg->op_type == OP_STUB) {
3866 op_getmad(arg,pegop,'S');
3867 imop = arg; /* no import on explicit () */
3869 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3870 imop = NULL; /* use 5.0; */
3872 idop->op_private |= OPpCONST_NOVER;
3878 op_getmad(arg,pegop,'A');
3880 /* Make copy of idop so we don't free it twice */
3881 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3883 /* Fake up a method call to import/unimport */
3885 ? newSVpvs_share("import") : newSVpvs_share("unimport");
3886 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3887 append_elem(OP_LIST,
3888 prepend_elem(OP_LIST, pack, list(arg)),
3889 newSVOP(OP_METHOD_NAMED, 0, meth)));
3892 /* Fake up the BEGIN {}, which does its thing immediately. */
3894 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
3897 append_elem(OP_LINESEQ,
3898 append_elem(OP_LINESEQ,
3899 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
3900 newSTATEOP(0, NULL, veop)),
3901 newSTATEOP(0, NULL, imop) ));
3903 /* The "did you use incorrect case?" warning used to be here.
3904 * The problem is that on case-insensitive filesystems one
3905 * might get false positives for "use" (and "require"):
3906 * "use Strict" or "require CARP" will work. This causes
3907 * portability problems for the script: in case-strict
3908 * filesystems the script will stop working.
3910 * The "incorrect case" warning checked whether "use Foo"
3911 * imported "Foo" to your namespace, but that is wrong, too:
3912 * there is no requirement nor promise in the language that
3913 * a Foo.pm should or would contain anything in package "Foo".
3915 * There is very little Configure-wise that can be done, either:
3916 * the case-sensitivity of the build filesystem of Perl does not
3917 * help in guessing the case-sensitivity of the runtime environment.
3920 PL_hints |= HINT_BLOCK_SCOPE;
3921 PL_parser->copline = NOLINE;
3922 PL_parser->expect = XSTATE;
3923 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3926 if (!PL_madskills) {
3927 /* FIXME - don't allocate pegop if !PL_madskills */
3936 =head1 Embedding Functions
3938 =for apidoc load_module
3940 Loads the module whose name is pointed to by the string part of name.
3941 Note that the actual module name, not its filename, should be given.
3942 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3943 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3944 (or 0 for no flags). ver, if specified, provides version semantics
3945 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3946 arguments can be used to specify arguments to the module's import()
3947 method, similar to C<use Foo::Bar VERSION LIST>.
3952 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3956 PERL_ARGS_ASSERT_LOAD_MODULE;
3958 va_start(args, ver);
3959 vload_module(flags, name, ver, &args);
3963 #ifdef PERL_IMPLICIT_CONTEXT
3965 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3969 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
3970 va_start(args, ver);
3971 vload_module(flags, name, ver, &args);
3977 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3981 OP * const modname = newSVOP(OP_CONST, 0, name);
3983 PERL_ARGS_ASSERT_VLOAD_MODULE;
3985 modname->op_private |= OPpCONST_BARE;
3987 veop = newSVOP(OP_CONST, 0, ver);
3991 if (flags & PERL_LOADMOD_NOIMPORT) {
3992 imop = sawparens(newNULLLIST());
3994 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3995 imop = va_arg(*args, OP*);
4000 sv = va_arg(*args, SV*);
4002 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
4003 sv = va_arg(*args, SV*);
4007 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
4008 * that it has a PL_parser to play with while doing that, and also
4009 * that it doesn't mess with any existing parser, by creating a tmp
4010 * new parser with lex_start(). This won't actually be used for much,
4011 * since pp_require() will create another parser for the real work. */
4014 SAVEVPTR(PL_curcop);
4015 lex_start(NULL, NULL, FALSE);
4016 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
4017 veop, modname, imop);
4022 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
4028 PERL_ARGS_ASSERT_DOFILE;
4030 if (!force_builtin) {
4031 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
4032 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
4033 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
4034 gv = gvp ? *gvp : NULL;
4038 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
4039 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
4040 append_elem(OP_LIST, term,
4041 scalar(newUNOP(OP_RV2CV, 0,
4042 newGVOP(OP_GV, 0, gv))))));
4045 doop = newUNOP(OP_DOFILE, 0, scalar(term));
4051 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
4053 return newBINOP(OP_LSLICE, flags,
4054 list(force_list(subscript)),
4055 list(force_list(listval)) );
4059 S_is_list_assignment(pTHX_ register const OP *o)
4067 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
4068 o = cUNOPo->op_first;
4070 flags = o->op_flags;
4072 if (type == OP_COND_EXPR) {
4073 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
4074 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
4079 yyerror("Assignment to both a list and a scalar");
4083 if (type == OP_LIST &&
4084 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
4085 o->op_private & OPpLVAL_INTRO)
4088 if (type == OP_LIST || flags & OPf_PARENS ||
4089 type == OP_RV2AV || type == OP_RV2HV ||
4090 type == OP_ASLICE || type == OP_HSLICE)
4093 if (type == OP_PADAV || type == OP_PADHV)
4096 if (type == OP_RV2SV)
4103 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
4109 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
4110 return newLOGOP(optype, 0,
4111 mod(scalar(left), optype),
4112 newUNOP(OP_SASSIGN, 0, scalar(right)));
4115 return newBINOP(optype, OPf_STACKED,
4116 mod(scalar(left), optype), scalar(right));
4120 if (is_list_assignment(left)) {
4121 static const char no_list_state[] = "Initialization of state variables"
4122 " in list context currently forbidden";
4124 bool maybe_common_vars = TRUE;
4127 /* Grandfathering $[ assignment here. Bletch.*/
4128 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
4129 PL_eval_start = (left->op_type == OP_CONST) ? right : NULL;
4130 left = mod(left, OP_AASSIGN);
4133 else if (left->op_type == OP_CONST) {
4135 /* Result of assignment is always 1 (or we'd be dead already) */
4136 return newSVOP(OP_CONST, 0, newSViv(1));
4138 curop = list(force_list(left));
4139 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
4140 o->op_private = (U8)(0 | (flags >> 8));
4142 if ((left->op_type == OP_LIST
4143 || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
4145 OP* lop = ((LISTOP*)left)->op_first;
4146 maybe_common_vars = FALSE;
4148 if (lop->op_type == OP_PADSV ||
4149 lop->op_type == OP_PADAV ||
4150 lop->op_type == OP_PADHV ||
4151 lop->op_type == OP_PADANY) {
4152 if (!(lop->op_private & OPpLVAL_INTRO))
4153 maybe_common_vars = TRUE;
4155 if (lop->op_private & OPpPAD_STATE) {
4156 if (left->op_private & OPpLVAL_INTRO) {
4157 /* Each variable in state($a, $b, $c) = ... */
4160 /* Each state variable in
4161 (state $a, my $b, our $c, $d, undef) = ... */
4163 yyerror(no_list_state);
4165 /* Each my variable in
4166 (state $a, my $b, our $c, $d, undef) = ... */
4168 } else if (lop->op_type == OP_UNDEF ||
4169 lop->op_type == OP_PUSHMARK) {
4170 /* undef may be interesting in
4171 (state $a, undef, state $c) */
4173 /* Other ops in the list. */
4174 maybe_common_vars = TRUE;
4176 lop = lop->op_sibling;
4179 else if ((left->op_private & OPpLVAL_INTRO)
4180 && ( left->op_type == OP_PADSV
4181 || left->op_type == OP_PADAV
4182 || left->op_type == OP_PADHV
4183 || left->op_type == OP_PADANY))
4185 maybe_common_vars = FALSE;
4186 if (left->op_private & OPpPAD_STATE) {
4187 /* All single variable list context state assignments, hence
4197 yyerror(no_list_state);
4201 /* PL_generation sorcery:
4202 * an assignment like ($a,$b) = ($c,$d) is easier than
4203 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
4204 * To detect whether there are common vars, the global var
4205 * PL_generation is incremented for each assign op we compile.
4206 * Then, while compiling the assign op, we run through all the
4207 * variables on both sides of the assignment, setting a spare slot
4208 * in each of them to PL_generation. If any of them already have
4209 * that value, we know we've got commonality. We could use a
4210 * single bit marker, but then we'd have to make 2 passes, first
4211 * to clear the flag, then to test and set it. To find somewhere
4212 * to store these values, evil chicanery is done with SvUVX().
4215 if (maybe_common_vars) {
4218 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4219 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
4220 if (curop->op_type == OP_GV) {
4221 GV *gv = cGVOPx_gv(curop);
4223 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4225 GvASSIGN_GENERATION_set(gv, PL_generation);
4227 else if (curop->op_type == OP_PADSV ||
4228 curop->op_type == OP_PADAV ||
4229 curop->op_type == OP_PADHV ||
4230 curop->op_type == OP_PADANY)
4232 if (PAD_COMPNAME_GEN(curop->op_targ)
4233 == (STRLEN)PL_generation)
4235 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
4238 else if (curop->op_type == OP_RV2CV)
4240 else if (curop->op_type == OP_RV2SV ||
4241 curop->op_type == OP_RV2AV ||
4242 curop->op_type == OP_RV2HV ||
4243 curop->op_type == OP_RV2GV) {
4244 if (lastop->op_type != OP_GV) /* funny deref? */
4247 else if (curop->op_type == OP_PUSHRE) {
4249 if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
4250 GV *const gv = (GV*)PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff);
4252 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4254 GvASSIGN_GENERATION_set(gv, PL_generation);
4258 = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
4261 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4263 GvASSIGN_GENERATION_set(gv, PL_generation);
4273 o->op_private |= OPpASSIGN_COMMON;
4276 if (right && right->op_type == OP_SPLIT && !PL_madskills) {
4277 OP* tmpop = ((LISTOP*)right)->op_first;
4278 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
4279 PMOP * const pm = (PMOP*)tmpop;
4280 if (left->op_type == OP_RV2AV &&
4281 !(left->op_private & OPpLVAL_INTRO) &&
4282 !(o->op_private & OPpASSIGN_COMMON) )
4284 tmpop = ((UNOP*)left)->op_first;
4285 if (tmpop->op_type == OP_GV
4287 && !pm->op_pmreplrootu.op_pmtargetoff
4289 && !pm->op_pmreplrootu.op_pmtargetgv
4293 pm->op_pmreplrootu.op_pmtargetoff
4294 = cPADOPx(tmpop)->op_padix;
4295 cPADOPx(tmpop)->op_padix = 0; /* steal it */
4297 pm->op_pmreplrootu.op_pmtargetgv
4298 = (GV*)cSVOPx(tmpop)->op_sv;
4299 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
4301 pm->op_pmflags |= PMf_ONCE;
4302 tmpop = cUNOPo->op_first; /* to list (nulled) */
4303 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
4304 tmpop->op_sibling = NULL; /* don't free split */
4305 right->op_next = tmpop->op_next; /* fix starting loc */
4306 op_free(o); /* blow off assign */
4307 right->op_flags &= ~OPf_WANT;
4308 /* "I don't know and I don't care." */
4313 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
4314 ((LISTOP*)right)->op_last->op_type == OP_CONST)
4316 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
4318 sv_setiv(sv, PL_modcount+1);
4326 right = newOP(OP_UNDEF, 0);
4327 if (right->op_type == OP_READLINE) {
4328 right->op_flags |= OPf_STACKED;
4329 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
4332 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
4333 o = newBINOP(OP_SASSIGN, flags,
4334 scalar(right), mod(scalar(left), OP_SASSIGN) );
4338 if (!PL_madskills) { /* assignment to $[ is ignored when making a mad dump */
4340 o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
4341 o->op_private |= OPpCONST_ARYBASE;
4349 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
4352 const U32 seq = intro_my();
4355 NewOp(1101, cop, 1, COP);
4356 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
4357 cop->op_type = OP_DBSTATE;
4358 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
4361 cop->op_type = OP_NEXTSTATE;
4362 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
4364 cop->op_flags = (U8)flags;
4365 CopHINTS_set(cop, PL_hints);
4367 cop->op_private |= NATIVE_HINTS;
4369 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
4370 cop->op_next = (OP*)cop;
4373 CopLABEL_set(cop, label);
4374 PL_hints |= HINT_BLOCK_SCOPE;
4377 /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
4378 CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
4380 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
4381 cop->cop_hints_hash = PL_curcop->cop_hints_hash;
4382 if (cop->cop_hints_hash) {
4384 cop->cop_hints_hash->refcounted_he_refcnt++;
4385 HINTS_REFCNT_UNLOCK;
4388 if (PL_parser && PL_parser->copline == NOLINE)
4389 CopLINE_set(cop, CopLINE(PL_curcop));
4391 CopLINE_set(cop, PL_parser->copline);
4393 PL_parser->copline = NOLINE;
4396 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
4398 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
4400 CopSTASH_set(cop, PL_curstash);
4402 if (PERLDB_LINE && PL_curstash != PL_debstash) {
4403 AV *av = CopFILEAVx(PL_curcop);
4405 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
4406 if (svp && *svp != &PL_sv_undef ) {
4407 (void)SvIOK_on(*svp);
4408 SvIV_set(*svp, PTR2IV(cop));
4413 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
4418 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
4422 PERL_ARGS_ASSERT_NEWLOGOP;
4424 return new_logop(type, flags, &first, &other);
4428 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
4433 OP *first = *firstp;
4434 OP * const other = *otherp;
4436 PERL_ARGS_ASSERT_NEW_LOGOP;
4438 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
4439 return newBINOP(type, flags, scalar(first), scalar(other));
4441 scalarboolean(first);
4442 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
4443 if (first->op_type == OP_NOT
4444 && (first->op_flags & OPf_SPECIAL)
4445 && (first->op_flags & OPf_KIDS)
4447 if (type == OP_AND || type == OP_OR) {
4453 first = *firstp = cUNOPo->op_first;
4455 first->op_next = o->op_next;
4456 cUNOPo->op_first = NULL;
4460 if (first->op_type == OP_CONST) {
4461 if (first->op_private & OPpCONST_STRICT)
4462 no_bareword_allowed(first);
4463 else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
4464 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
4465 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
4466 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
4467 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
4469 if (other->op_type == OP_CONST)
4470 other->op_private |= OPpCONST_SHORTCIRCUIT;
4472 OP *newop = newUNOP(OP_NULL, 0, other);
4473 op_getmad(first, newop, '1');
4474 newop->op_targ = type; /* set "was" field */
4481 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
4482 const OP *o2 = other;
4483 if ( ! (o2->op_type == OP_LIST
4484 && (( o2 = cUNOPx(o2)->op_first))
4485 && o2->op_type == OP_PUSHMARK
4486 && (( o2 = o2->op_sibling)) )
4489 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
4490 || o2->op_type == OP_PADHV)
4491 && o2->op_private & OPpLVAL_INTRO
4492 && !(o2->op_private & OPpPAD_STATE)
4493 && ckWARN(WARN_DEPRECATED))
4495 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4496 "Deprecated use of my() in false conditional");
4500 if (first->op_type == OP_CONST)
4501 first->op_private |= OPpCONST_SHORTCIRCUIT;
4503 first = newUNOP(OP_NULL, 0, first);
4504 op_getmad(other, first, '2');
4505 first->op_targ = type; /* set "was" field */
4512 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
4513 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
4515 const OP * const k1 = ((UNOP*)first)->op_first;
4516 const OP * const k2 = k1->op_sibling;
4518 switch (first->op_type)
4521 if (k2 && k2->op_type == OP_READLINE
4522 && (k2->op_flags & OPf_STACKED)
4523 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4525 warnop = k2->op_type;
4530 if (k1->op_type == OP_READDIR
4531 || k1->op_type == OP_GLOB
4532 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4533 || k1->op_type == OP_EACH)
4535 warnop = ((k1->op_type == OP_NULL)
4536 ? (OPCODE)k1->op_targ : k1->op_type);
4541 const line_t oldline = CopLINE(PL_curcop);
4542 CopLINE_set(PL_curcop, PL_parser->copline);
4543 Perl_warner(aTHX_ packWARN(WARN_MISC),
4544 "Value of %s%s can be \"0\"; test with defined()",
4546 ((warnop == OP_READLINE || warnop == OP_GLOB)
4547 ? " construct" : "() operator"));
4548 CopLINE_set(PL_curcop, oldline);
4555 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
4556 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
4558 NewOp(1101, logop, 1, LOGOP);
4560 logop->op_type = (OPCODE)type;
4561 logop->op_ppaddr = PL_ppaddr[type];
4562 logop->op_first = first;
4563 logop->op_flags = (U8)(flags | OPf_KIDS);
4564 logop->op_other = LINKLIST(other);
4565 logop->op_private = (U8)(1 | (flags >> 8));
4567 /* establish postfix order */
4568 logop->op_next = LINKLIST(first);
4569 first->op_next = (OP*)logop;
4570 first->op_sibling = other;
4572 CHECKOP(type,logop);
4574 o = newUNOP(OP_NULL, 0, (OP*)logop);
4581 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
4588 PERL_ARGS_ASSERT_NEWCONDOP;
4591 return newLOGOP(OP_AND, 0, first, trueop);
4593 return newLOGOP(OP_OR, 0, first, falseop);
4595 scalarboolean(first);
4596 if (first->op_type == OP_CONST) {
4597 /* Left or right arm of the conditional? */
4598 const bool left = SvTRUE(((SVOP*)first)->op_sv);
4599 OP *live = left ? trueop : falseop;
4600 OP *const dead = left ? falseop : trueop;
4601 if (first->op_private & OPpCONST_BARE &&
4602 first->op_private & OPpCONST_STRICT) {
4603 no_bareword_allowed(first);
4606 /* This is all dead code when PERL_MAD is not defined. */
4607 live = newUNOP(OP_NULL, 0, live);
4608 op_getmad(first, live, 'C');
4609 op_getmad(dead, live, left ? 'e' : 't');
4616 NewOp(1101, logop, 1, LOGOP);
4617 logop->op_type = OP_COND_EXPR;
4618 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4619 logop->op_first = first;
4620 logop->op_flags = (U8)(flags | OPf_KIDS);
4621 logop->op_private = (U8)(1 | (flags >> 8));
4622 logop->op_other = LINKLIST(trueop);
4623 logop->op_next = LINKLIST(falseop);
4625 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
4628 /* establish postfix order */
4629 start = LINKLIST(first);
4630 first->op_next = (OP*)logop;
4632 first->op_sibling = trueop;
4633 trueop->op_sibling = falseop;
4634 o = newUNOP(OP_NULL, 0, (OP*)logop);
4636 trueop->op_next = falseop->op_next = o;
4643 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4652 PERL_ARGS_ASSERT_NEWRANGE;
4654 NewOp(1101, range, 1, LOGOP);
4656 range->op_type = OP_RANGE;
4657 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4658 range->op_first = left;
4659 range->op_flags = OPf_KIDS;
4660 leftstart = LINKLIST(left);
4661 range->op_other = LINKLIST(right);
4662 range->op_private = (U8)(1 | (flags >> 8));
4664 left->op_sibling = right;
4666 range->op_next = (OP*)range;
4667 flip = newUNOP(OP_FLIP, flags, (OP*)range);
4668 flop = newUNOP(OP_FLOP, 0, flip);
4669 o = newUNOP(OP_NULL, 0, flop);
4671 range->op_next = leftstart;
4673 left->op_next = flip;
4674 right->op_next = flop;
4676 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4677 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4678 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4679 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4681 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4682 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4685 if (!flip->op_private || !flop->op_private)
4686 linklist(o); /* blow off optimizer unless constant */
4692 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4697 const bool once = block && block->op_flags & OPf_SPECIAL &&
4698 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4700 PERL_UNUSED_ARG(debuggable);
4703 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4704 return block; /* do {} while 0 does once */
4705 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4706 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4707 expr = newUNOP(OP_DEFINED, 0,
4708 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4709 } else if (expr->op_flags & OPf_KIDS) {
4710 const OP * const k1 = ((UNOP*)expr)->op_first;
4711 const OP * const k2 = k1 ? k1->op_sibling : NULL;
4712 switch (expr->op_type) {
4714 if (k2 && k2->op_type == OP_READLINE
4715 && (k2->op_flags & OPf_STACKED)
4716 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4717 expr = newUNOP(OP_DEFINED, 0, expr);
4721 if (k1 && (k1->op_type == OP_READDIR
4722 || k1->op_type == OP_GLOB
4723 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4724 || k1->op_type == OP_EACH))
4725 expr = newUNOP(OP_DEFINED, 0, expr);
4731 /* if block is null, the next append_elem() would put UNSTACK, a scalar
4732 * op, in listop. This is wrong. [perl #27024] */
4734 block = newOP(OP_NULL, 0);
4735 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4736 o = new_logop(OP_AND, 0, &expr, &listop);
4739 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4741 if (once && o != listop)
4742 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4745 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
4747 o->op_flags |= flags;
4749 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4754 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
4755 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
4764 PERL_UNUSED_ARG(debuggable);
4767 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4768 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4769 expr = newUNOP(OP_DEFINED, 0,
4770 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4771 } else if (expr->op_flags & OPf_KIDS) {
4772 const OP * const k1 = ((UNOP*)expr)->op_first;
4773 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
4774 switch (expr->op_type) {
4776 if (k2 && k2->op_type == OP_READLINE
4777 && (k2->op_flags & OPf_STACKED)
4778 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4779 expr = newUNOP(OP_DEFINED, 0, expr);
4783 if (k1 && (k1->op_type == OP_READDIR
4784 || k1->op_type == OP_GLOB
4785 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4786 || k1->op_type == OP_EACH))
4787 expr = newUNOP(OP_DEFINED, 0, expr);
4794 block = newOP(OP_NULL, 0);
4795 else if (cont || has_my) {
4796 block = scope(block);
4800 next = LINKLIST(cont);
4803 OP * const unstack = newOP(OP_UNSTACK, 0);
4806 cont = append_elem(OP_LINESEQ, cont, unstack);
4810 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4812 redo = LINKLIST(listop);
4815 PL_parser->copline = (line_t)whileline;
4817 o = new_logop(OP_AND, 0, &expr, &listop);
4818 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4819 op_free(expr); /* oops, it's a while (0) */
4821 return NULL; /* listop already freed by new_logop */
4824 ((LISTOP*)listop)->op_last->op_next =
4825 (o == listop ? redo : LINKLIST(o));
4831 NewOp(1101,loop,1,LOOP);
4832 loop->op_type = OP_ENTERLOOP;
4833 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4834 loop->op_private = 0;
4835 loop->op_next = (OP*)loop;
4838 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4840 loop->op_redoop = redo;
4841 loop->op_lastop = o;
4842 o->op_private |= loopflags;
4845 loop->op_nextop = next;
4847 loop->op_nextop = o;
4849 o->op_flags |= flags;
4850 o->op_private |= (flags >> 8);
4855 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
4860 PADOFFSET padoff = 0;
4865 PERL_ARGS_ASSERT_NEWFOROP;
4868 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4869 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
4870 sv->op_type = OP_RV2GV;
4871 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4873 /* The op_type check is needed to prevent a possible segfault
4874 * if the loop variable is undeclared and 'strict vars' is in
4875 * effect. This is illegal but is nonetheless parsed, so we
4876 * may reach this point with an OP_CONST where we're expecting
4879 if (cUNOPx(sv)->op_first->op_type == OP_GV
4880 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
4881 iterpflags |= OPpITER_DEF;
4883 else if (sv->op_type == OP_PADSV) { /* private variable */
4884 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
4885 padoff = sv->op_targ;
4895 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4897 SV *const namesv = PAD_COMPNAME_SV(padoff);
4899 const char *const name = SvPV_const(namesv, len);
4901 if (len == 2 && name[0] == '$' && name[1] == '_')
4902 iterpflags |= OPpITER_DEF;
4906 const PADOFFSET offset = pad_findmy("$_");
4907 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
4908 sv = newGVOP(OP_GV, 0, PL_defgv);
4913 iterpflags |= OPpITER_DEF;
4915 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4916 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4917 iterflags |= OPf_STACKED;
4919 else if (expr->op_type == OP_NULL &&
4920 (expr->op_flags & OPf_KIDS) &&
4921 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4923 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4924 * set the STACKED flag to indicate that these values are to be
4925 * treated as min/max values by 'pp_iterinit'.
4927 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4928 LOGOP* const range = (LOGOP*) flip->op_first;
4929 OP* const left = range->op_first;
4930 OP* const right = left->op_sibling;
4933 range->op_flags &= ~OPf_KIDS;
4934 range->op_first = NULL;
4936 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4937 listop->op_first->op_next = range->op_next;
4938 left->op_next = range->op_other;
4939 right->op_next = (OP*)listop;
4940 listop->op_next = listop->op_first;
4943 op_getmad(expr,(OP*)listop,'O');
4947 expr = (OP*)(listop);
4949 iterflags |= OPf_STACKED;
4952 expr = mod(force_list(expr), OP_GREPSTART);
4955 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4956 append_elem(OP_LIST, expr, scalar(sv))));
4957 assert(!loop->op_next);
4958 /* for my $x () sets OPpLVAL_INTRO;
4959 * for our $x () sets OPpOUR_INTRO */
4960 loop->op_private = (U8)iterpflags;
4961 #ifdef PL_OP_SLAB_ALLOC
4964 NewOp(1234,tmp,1,LOOP);
4965 Copy(loop,tmp,1,LISTOP);
4966 S_op_destroy(aTHX_ (OP*)loop);
4970 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
4972 loop->op_targ = padoff;
4973 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
4975 op_getmad(madsv, (OP*)loop, 'v');
4976 PL_parser->copline = forline;
4977 return newSTATEOP(0, label, wop);
4981 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4986 PERL_ARGS_ASSERT_NEWLOOPEX;
4988 if (type != OP_GOTO || label->op_type == OP_CONST) {
4989 /* "last()" means "last" */
4990 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4991 o = newOP(type, OPf_SPECIAL);
4993 o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
4994 ? SvPV_nolen_const(((SVOP*)label)->op_sv)
4998 op_getmad(label,o,'L');
5004 /* Check whether it's going to be a goto &function */
5005 if (label->op_type == OP_ENTERSUB
5006 && !(label->op_flags & OPf_STACKED))
5007 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
5008 o = newUNOP(type, OPf_STACKED, label);
5010 PL_hints |= HINT_BLOCK_SCOPE;
5014 /* if the condition is a literal array or hash
5015 (or @{ ... } etc), make a reference to it.
5018 S_ref_array_or_hash(pTHX_ OP *cond)
5021 && (cond->op_type == OP_RV2AV
5022 || cond->op_type == OP_PADAV
5023 || cond->op_type == OP_RV2HV
5024 || cond->op_type == OP_PADHV))
5026 return newUNOP(OP_REFGEN,
5027 0, mod(cond, OP_REFGEN));
5033 /* These construct the optree fragments representing given()
5036 entergiven and enterwhen are LOGOPs; the op_other pointer
5037 points up to the associated leave op. We need this so we
5038 can put it in the context and make break/continue work.
5039 (Also, of course, pp_enterwhen will jump straight to
5040 op_other if the match fails.)
5044 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
5045 I32 enter_opcode, I32 leave_opcode,
5046 PADOFFSET entertarg)
5052 PERL_ARGS_ASSERT_NEWGIVWHENOP;
5054 NewOp(1101, enterop, 1, LOGOP);
5055 enterop->op_type = (optype)enter_opcode;
5056 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
5057 enterop->op_flags = (U8) OPf_KIDS;
5058 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
5059 enterop->op_private = 0;
5061 o = newUNOP(leave_opcode, 0, (OP *) enterop);
5064 enterop->op_first = scalar(cond);
5065 cond->op_sibling = block;
5067 o->op_next = LINKLIST(cond);
5068 cond->op_next = (OP *) enterop;
5071 /* This is a default {} block */
5072 enterop->op_first = block;
5073 enterop->op_flags |= OPf_SPECIAL;
5075 o->op_next = (OP *) enterop;
5078 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
5079 entergiven and enterwhen both
5082 enterop->op_next = LINKLIST(block);
5083 block->op_next = enterop->op_other = o;
5088 /* Does this look like a boolean operation? For these purposes
5089 a boolean operation is:
5090 - a subroutine call [*]
5091 - a logical connective
5092 - a comparison operator
5093 - a filetest operator, with the exception of -s -M -A -C
5094 - defined(), exists() or eof()
5095 - /$re/ or $foo =~ /$re/
5097 [*] possibly surprising
5100 S_looks_like_bool(pTHX_ const OP *o)
5104 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
5106 switch(o->op_type) {
5108 return looks_like_bool(cLOGOPo->op_first);
5112 looks_like_bool(cLOGOPo->op_first)
5113 && looks_like_bool(cLOGOPo->op_first->op_sibling));
5117 o->op_flags & OPf_KIDS
5118 && looks_like_bool(cUNOPo->op_first));
5122 case OP_NOT: case OP_XOR:
5123 /* Note that OP_DOR is not here */
5125 case OP_EQ: case OP_NE: case OP_LT:
5126 case OP_GT: case OP_LE: case OP_GE:
5128 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
5129 case OP_I_GT: case OP_I_LE: case OP_I_GE:
5131 case OP_SEQ: case OP_SNE: case OP_SLT:
5132 case OP_SGT: case OP_SLE: case OP_SGE:
5136 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
5137 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
5138 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
5139 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
5140 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
5141 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
5142 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
5143 case OP_FTTEXT: case OP_FTBINARY:
5145 case OP_DEFINED: case OP_EXISTS:
5146 case OP_MATCH: case OP_EOF:
5151 /* Detect comparisons that have been optimized away */
5152 if (cSVOPo->op_sv == &PL_sv_yes
5153 || cSVOPo->op_sv == &PL_sv_no)
5164 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
5167 PERL_ARGS_ASSERT_NEWGIVENOP;
5168 return newGIVWHENOP(
5169 ref_array_or_hash(cond),
5171 OP_ENTERGIVEN, OP_LEAVEGIVEN,
5175 /* If cond is null, this is a default {} block */
5177 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
5179 const bool cond_llb = (!cond || looks_like_bool(cond));
5182 PERL_ARGS_ASSERT_NEWWHENOP;
5187 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
5189 scalar(ref_array_or_hash(cond)));
5192 return newGIVWHENOP(
5194 append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
5195 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
5199 =for apidoc cv_undef
5201 Clear out all the active components of a CV. This can happen either
5202 by an explicit C<undef &foo>, or by the reference count going to zero.
5203 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
5204 children can still follow the full lexical scope chain.
5210 Perl_cv_undef(pTHX_ CV *cv)
5214 PERL_ARGS_ASSERT_CV_UNDEF;
5216 DEBUG_X(PerlIO_printf(Perl_debug_log,
5217 "CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n",
5218 PTR2UV(cv), PTR2UV(PL_comppad))
5222 if (CvFILE(cv) && !CvISXSUB(cv)) {
5223 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
5224 Safefree(CvFILE(cv));
5229 if (!CvISXSUB(cv) && CvROOT(cv)) {
5230 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
5231 Perl_croak(aTHX_ "Can't undef active subroutine");
5234 PAD_SAVE_SETNULLPAD();
5236 op_free(CvROOT(cv));
5241 SvPOK_off((SV*)cv); /* forget prototype */
5246 /* remove CvOUTSIDE unless this is an undef rather than a free */
5247 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
5248 if (!CvWEAKOUTSIDE(cv))
5249 SvREFCNT_dec(CvOUTSIDE(cv));
5250 CvOUTSIDE(cv) = NULL;
5253 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
5256 if (CvISXSUB(cv) && CvXSUB(cv)) {
5259 /* delete all flags except WEAKOUTSIDE */
5260 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
5264 Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
5267 PERL_ARGS_ASSERT_CV_CKPROTO_LEN;
5269 /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
5270 relying on SvCUR, and doubling up the buffer to hold CvFILE(). */
5271 if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
5272 || (p && (len != SvCUR(cv) /* Not the same length. */
5273 || memNE(p, SvPVX_const(cv), len))))
5274 && ckWARN_d(WARN_PROTOTYPE)) {
5275 SV* const msg = sv_newmortal();
5279 gv_efullname3(name = sv_newmortal(), gv, NULL);
5280 sv_setpvs(msg, "Prototype mismatch:");
5282 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
5284 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv));
5286 sv_catpvs(msg, ": none");
5287 sv_catpvs(msg, " vs ");
5289 Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
5291 sv_catpvs(msg, "none");
5292 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
5296 static void const_sv_xsub(pTHX_ CV* cv);
5300 =head1 Optree Manipulation Functions
5302 =for apidoc cv_const_sv
5304 If C<cv> is a constant sub eligible for inlining. returns the constant
5305 value returned by the sub. Otherwise, returns NULL.
5307 Constant subs can be created with C<newCONSTSUB> or as described in
5308 L<perlsub/"Constant Functions">.
5313 Perl_cv_const_sv(pTHX_ CV *cv)
5315 PERL_UNUSED_CONTEXT;
5318 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
5320 return CvCONST(cv) ? (SV*)CvXSUBANY(cv).any_ptr : NULL;
5323 /* op_const_sv: examine an optree to determine whether it's in-lineable.
5324 * Can be called in 3 ways:
5327 * look for a single OP_CONST with attached value: return the value
5329 * cv && CvCLONE(cv) && !CvCONST(cv)
5331 * examine the clone prototype, and if contains only a single
5332 * OP_CONST referencing a pad const, or a single PADSV referencing
5333 * an outer lexical, return a non-zero value to indicate the CV is
5334 * a candidate for "constizing" at clone time
5338 * We have just cloned an anon prototype that was marked as a const
5339 * candidiate. Try to grab the current value, and in the case of
5340 * PADSV, ignore it if it has multiple references. Return the value.
5344 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
5355 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
5356 o = cLISTOPo->op_first->op_sibling;
5358 for (; o; o = o->op_next) {
5359 const OPCODE type = o->op_type;
5361 if (sv && o->op_next == o)
5363 if (o->op_next != o) {
5364 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
5366 if (type == OP_DBSTATE)
5369 if (type == OP_LEAVESUB || type == OP_RETURN)
5373 if (type == OP_CONST && cSVOPo->op_sv)
5375 else if (cv && type == OP_CONST) {
5376 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5380 else if (cv && type == OP_PADSV) {
5381 if (CvCONST(cv)) { /* newly cloned anon */
5382 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5383 /* the candidate should have 1 ref from this pad and 1 ref
5384 * from the parent */
5385 if (!sv || SvREFCNT(sv) != 2)
5392 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
5393 sv = &PL_sv_undef; /* an arbitrary non-null value */
5408 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5411 /* This would be the return value, but the return cannot be reached. */
5412 OP* pegop = newOP(OP_NULL, 0);
5415 PERL_UNUSED_ARG(floor);
5425 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
5427 NORETURN_FUNCTION_END;
5432 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
5434 return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
5438 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5445 register CV *cv = NULL;
5447 /* If the subroutine has no body, no attributes, and no builtin attributes
5448 then it's just a sub declaration, and we may be able to get away with
5449 storing with a placeholder scalar in the symbol table, rather than a
5450 full GV and CV. If anything is present then it will take a full CV to
5452 const I32 gv_fetch_flags
5453 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5455 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
5456 const char * const name = o ? SvPV_nolen_const(cSVOPo->op_sv) : NULL;
5459 assert(proto->op_type == OP_CONST);
5460 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
5465 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
5466 SV * const sv = sv_newmortal();
5467 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
5468 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
5469 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
5470 aname = SvPVX_const(sv);
5475 gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
5476 : gv_fetchpv(aname ? aname
5477 : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5478 gv_fetch_flags, SVt_PVCV);
5480 if (!PL_madskills) {
5489 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
5490 maximum a prototype before. */
5491 if (SvTYPE(gv) > SVt_NULL) {
5492 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
5493 && ckWARN_d(WARN_PROTOTYPE))
5495 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
5497 cv_ckproto_len((CV*)gv, NULL, ps, ps_len);
5500 sv_setpvn((SV*)gv, ps, ps_len);
5502 sv_setiv((SV*)gv, -1);
5504 SvREFCNT_dec(PL_compcv);
5505 cv = PL_compcv = NULL;
5509 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
5511 #ifdef GV_UNIQUE_CHECK
5512 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
5513 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
5517 if (!block || !ps || *ps || attrs
5518 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5520 || block->op_type == OP_NULL
5525 const_sv = op_const_sv(block, NULL);
5528 const bool exists = CvROOT(cv) || CvXSUB(cv);
5530 #ifdef GV_UNIQUE_CHECK
5531 if (exists && GvUNIQUE(gv)) {
5532 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
5536 /* if the subroutine doesn't exist and wasn't pre-declared
5537 * with a prototype, assume it will be AUTOLOADed,
5538 * skipping the prototype check
5540 if (exists || SvPOK(cv))
5541 cv_ckproto_len(cv, gv, ps, ps_len);
5542 /* already defined (or promised)? */
5543 if (exists || GvASSUMECV(gv)) {
5546 || block->op_type == OP_NULL
5549 if (CvFLAGS(PL_compcv)) {
5550 /* might have had built-in attrs applied */
5551 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5553 /* just a "sub foo;" when &foo is already defined */
5554 SAVEFREESV(PL_compcv);
5559 && block->op_type != OP_NULL
5562 if (ckWARN(WARN_REDEFINE)
5564 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
5566 const line_t oldline = CopLINE(PL_curcop);
5567 if (PL_parser && PL_parser->copline != NOLINE)
5568 CopLINE_set(PL_curcop, PL_parser->copline);
5569 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5570 CvCONST(cv) ? "Constant subroutine %s redefined"
5571 : "Subroutine %s redefined", name);
5572 CopLINE_set(PL_curcop, oldline);
5575 if (!PL_minus_c) /* keep old one around for madskills */
5578 /* (PL_madskills unset in used file.) */
5586 SvREFCNT_inc_simple_void_NN(const_sv);
5588 assert(!CvROOT(cv) && !CvCONST(cv));
5589 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
5590 CvXSUBANY(cv).any_ptr = const_sv;
5591 CvXSUB(cv) = const_sv_xsub;
5597 cv = newCONSTSUB(NULL, name, const_sv);
5599 mro_method_changed_in( /* sub Foo::Bar () { 123 } */
5600 (CvGV(cv) && GvSTASH(CvGV(cv)))
5609 SvREFCNT_dec(PL_compcv);
5617 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
5618 * before we clobber PL_compcv.
5622 || block->op_type == OP_NULL
5626 /* Might have had built-in attributes applied -- propagate them. */
5627 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5628 if (CvGV(cv) && GvSTASH(CvGV(cv)))
5629 stash = GvSTASH(CvGV(cv));
5630 else if (CvSTASH(cv))
5631 stash = CvSTASH(cv);
5633 stash = PL_curstash;
5636 /* possibly about to re-define existing subr -- ignore old cv */
5637 rcv = (SV*)PL_compcv;
5638 if (name && GvSTASH(gv))
5639 stash = GvSTASH(gv);
5641 stash = PL_curstash;
5643 apply_attrs(stash, rcv, attrs, FALSE);
5645 if (cv) { /* must reuse cv if autoloaded */
5652 || block->op_type == OP_NULL) && !PL_madskills
5655 /* got here with just attrs -- work done, so bug out */
5656 SAVEFREESV(PL_compcv);
5659 /* transfer PL_compcv to cv */
5661 CvFLAGS(cv) = CvFLAGS(PL_compcv);
5662 if (!CvWEAKOUTSIDE(cv))
5663 SvREFCNT_dec(CvOUTSIDE(cv));
5664 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
5665 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
5666 CvOUTSIDE(PL_compcv) = 0;
5667 CvPADLIST(cv) = CvPADLIST(PL_compcv);
5668 CvPADLIST(PL_compcv) = 0;
5669 /* inner references to PL_compcv must be fixed up ... */
5670 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
5671 /* ... before we throw it away */
5672 SvREFCNT_dec(PL_compcv);
5674 if (PERLDB_INTER)/* Advice debugger on the new sub. */
5675 ++PL_sub_generation;
5682 if (strEQ(name, "import")) {
5683 PL_formfeed = (SV*)cv;
5684 Perl_warner(aTHX_ packWARN(WARN_VOID), "%lx\n", (long)cv);
5688 mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */
5692 CvFILE_set_from_cop(cv, PL_curcop);
5693 CvSTASH(cv) = PL_curstash;
5696 sv_setpvn((SV*)cv, ps, ps_len);
5698 if (PL_parser && PL_parser->error_count) {
5702 const char *s = strrchr(name, ':');
5704 if (strEQ(s, "BEGIN")) {
5705 const char not_safe[] =
5706 "BEGIN not safe after errors--compilation aborted";
5707 if (PL_in_eval & EVAL_KEEPERR)
5708 Perl_croak(aTHX_ not_safe);
5710 /* force display of errors found but not reported */
5711 sv_catpv(ERRSV, not_safe);
5712 Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
5722 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5723 mod(scalarseq(block), OP_LEAVESUBLV));
5724 block->op_attached = 1;
5727 /* This makes sub {}; work as expected. */
5728 if (block->op_type == OP_STUB) {
5729 OP* const newblock = newSTATEOP(0, NULL, 0);
5731 op_getmad(block,newblock,'B');
5738 block->op_attached = 1;
5739 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5741 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5742 OpREFCNT_set(CvROOT(cv), 1);
5743 CvSTART(cv) = LINKLIST(CvROOT(cv));
5744 CvROOT(cv)->op_next = 0;
5745 CALL_PEEP(CvSTART(cv));
5747 /* now that optimizer has done its work, adjust pad values */
5749 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
5752 assert(!CvCONST(cv));
5753 if (ps && !*ps && op_const_sv(block, cv))
5757 if (name || aname) {
5758 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5759 SV * const sv = newSV(0);
5760 SV * const tmpstr = sv_newmortal();
5761 GV * const db_postponed = gv_fetchpvs("DB::postponed",
5762 GV_ADDMULTI, SVt_PVHV);
5765 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5767 (long)PL_subline, (long)CopLINE(PL_curcop));
5768 gv_efullname3(tmpstr, gv, NULL);
5769 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
5770 SvCUR(tmpstr), sv, 0);
5771 hv = GvHVn(db_postponed);
5772 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
5773 CV * const pcv = GvCV(db_postponed);
5779 call_sv((SV*)pcv, G_DISCARD);
5784 if (name && ! (PL_parser && PL_parser->error_count))
5785 process_special_blocks(name, gv, cv);
5790 PL_parser->copline = NOLINE;
5796 S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
5799 const char *const colon = strrchr(fullname,':');
5800 const char *const name = colon ? colon + 1 : fullname;
5802 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
5805 if (strEQ(name, "BEGIN")) {
5806 const I32 oldscope = PL_scopestack_ix;
5808 SAVECOPFILE(&PL_compiling);
5809 SAVECOPLINE(&PL_compiling);
5811 DEBUG_x( dump_sub(gv) );
5812 Perl_av_create_and_push(aTHX_ &PL_beginav, (SV*)cv);
5813 GvCV(gv) = 0; /* cv has been hijacked */
5814 call_list(oldscope, PL_beginav);
5816 PL_curcop = &PL_compiling;
5817 CopHINTS_set(&PL_compiling, PL_hints);
5824 if strEQ(name, "END") {
5825 DEBUG_x( dump_sub(gv) );
5826 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, (SV*)cv);
5829 } else if (*name == 'U') {
5830 if (strEQ(name, "UNITCHECK")) {
5831 /* It's never too late to run a unitcheck block */
5832 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, (SV*)cv);
5836 } else if (*name == 'C') {
5837 if (strEQ(name, "CHECK")) {
5838 if (PL_main_start && ckWARN(WARN_VOID))
5839 Perl_warner(aTHX_ packWARN(WARN_VOID),
5840 "Too late to run CHECK block");
5841 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, (SV*)cv);
5845 } else if (*name == 'I') {
5846 if (strEQ(name, "INIT")) {
5847 if (PL_main_start && ckWARN(WARN_VOID))
5848 Perl_warner(aTHX_ packWARN(WARN_VOID),
5849 "Too late to run INIT block");
5850 Perl_av_create_and_push(aTHX_ &PL_initav, (SV*)cv);
5856 DEBUG_x( dump_sub(gv) );
5857 GvCV(gv) = 0; /* cv has been hijacked */
5862 =for apidoc newCONSTSUB
5864 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5865 eligible for inlining at compile-time.
5871 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
5876 const char *const temp_p = CopFILE(PL_curcop);
5877 const STRLEN len = temp_p ? strlen(temp_p) : 0;
5879 SV *const temp_sv = CopFILESV(PL_curcop);
5881 const char *const temp_p = temp_sv ? SvPV_const(temp_sv, len) : NULL;
5883 char *const file = savepvn(temp_p, temp_p ? len : 0);
5887 if (IN_PERL_RUNTIME) {
5888 /* at runtime, it's not safe to manipulate PL_curcop: it may be
5889 * an op shared between threads. Use a non-shared COP for our
5891 SAVEVPTR(PL_curcop);
5892 PL_curcop = &PL_compiling;
5894 SAVECOPLINE(PL_curcop);
5895 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
5898 PL_hints &= ~HINT_BLOCK_SCOPE;
5901 SAVESPTR(PL_curstash);
5902 SAVECOPSTASH(PL_curcop);
5903 PL_curstash = stash;
5904 CopSTASH_set(PL_curcop,stash);
5907 /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
5908 and so doesn't get free()d. (It's expected to be from the C pre-
5909 processor __FILE__ directive). But we need a dynamically allocated one,
5910 and we need it to get freed. */
5911 cv = newXS_flags(name, const_sv_xsub, file, "", XS_DYNAMIC_FILENAME);
5912 CvXSUBANY(cv).any_ptr = sv;
5918 CopSTASH_free(PL_curcop);
5926 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
5927 const char *const filename, const char *const proto,
5930 CV *cv = newXS(name, subaddr, filename);
5932 PERL_ARGS_ASSERT_NEWXS_FLAGS;
5934 if (flags & XS_DYNAMIC_FILENAME) {
5935 /* We need to "make arrangements" (ie cheat) to ensure that the
5936 filename lasts as long as the PVCV we just created, but also doesn't
5938 STRLEN filename_len = strlen(filename);
5939 STRLEN proto_and_file_len = filename_len;
5940 char *proto_and_file;
5944 proto_len = strlen(proto);
5945 proto_and_file_len += proto_len;
5947 Newx(proto_and_file, proto_and_file_len + 1, char);
5948 Copy(proto, proto_and_file, proto_len, char);
5949 Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
5952 proto_and_file = savepvn(filename, filename_len);
5955 /* This gets free()d. :-) */
5956 sv_usepvn_flags((SV*)cv, proto_and_file, proto_and_file_len,
5957 SV_HAS_TRAILING_NUL);
5959 /* This gives us the correct prototype, rather than one with the
5960 file name appended. */
5961 SvCUR_set(cv, proto_len);
5965 CvFILE(cv) = proto_and_file + proto_len;
5967 sv_setpv((SV *)cv, proto);
5973 =for apidoc U||newXS
5975 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
5976 static storage, as it is used directly as CvFILE(), without a copy being made.
5982 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
5985 GV * const gv = gv_fetchpv(name ? name :
5986 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5987 GV_ADDMULTI, SVt_PVCV);
5990 PERL_ARGS_ASSERT_NEWXS;
5993 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
5995 if ((cv = (name ? GvCV(gv) : NULL))) {
5997 /* just a cached method */
6001 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
6002 /* already defined (or promised) */
6003 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
6004 if (ckWARN(WARN_REDEFINE)) {
6005 GV * const gvcv = CvGV(cv);
6007 HV * const stash = GvSTASH(gvcv);
6009 const char *redefined_name = HvNAME_get(stash);
6010 if ( strEQ(redefined_name,"autouse") ) {
6011 const line_t oldline = CopLINE(PL_curcop);
6012 if (PL_parser && PL_parser->copline != NOLINE)
6013 CopLINE_set(PL_curcop, PL_parser->copline);
6014 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6015 CvCONST(cv) ? "Constant subroutine %s redefined"
6016 : "Subroutine %s redefined"
6018 CopLINE_set(PL_curcop, oldline);
6028 if (cv) /* must reuse cv if autoloaded */
6031 cv = (CV*)newSV_type(SVt_PVCV);
6035 mro_method_changed_in(GvSTASH(gv)); /* newXS */
6039 (void)gv_fetchfile(filename);
6040 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
6041 an external constant string */
6043 CvXSUB(cv) = subaddr;
6046 process_special_blocks(name, gv, cv);
6058 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
6063 OP* pegop = newOP(OP_NULL, 0);
6067 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
6068 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
6070 #ifdef GV_UNIQUE_CHECK
6072 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
6076 if ((cv = GvFORM(gv))) {
6077 if (ckWARN(WARN_REDEFINE)) {
6078 const line_t oldline = CopLINE(PL_curcop);
6079 if (PL_parser && PL_parser->copline != NOLINE)
6080 CopLINE_set(PL_curcop, PL_parser->copline);
6081 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6082 o ? "Format %"SVf" redefined"
6083 : "Format STDOUT redefined", SVfARG(cSVOPo->op_sv));
6084 CopLINE_set(PL_curcop, oldline);
6091 CvFILE_set_from_cop(cv, PL_curcop);
6094 pad_tidy(padtidy_FORMAT);
6095 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
6096 CvROOT(cv)->op_private |= OPpREFCOUNTED;
6097 OpREFCNT_set(CvROOT(cv), 1);
6098 CvSTART(cv) = LINKLIST(CvROOT(cv));
6099 CvROOT(cv)->op_next = 0;
6100 CALL_PEEP(CvSTART(cv));
6102 op_getmad(o,pegop,'n');
6103 op_getmad_weak(block, pegop, 'b');
6108 PL_parser->copline = NOLINE;
6116 Perl_newANONLIST(pTHX_ OP *o)
6118 return convert(OP_ANONLIST, OPf_SPECIAL, o);
6122 Perl_newANONHASH(pTHX_ OP *o)
6124 return convert(OP_ANONHASH, OPf_SPECIAL, o);
6128 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
6130 return newANONATTRSUB(floor, proto, NULL, block);
6134 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
6136 return newUNOP(OP_REFGEN, 0,
6137 newSVOP(OP_ANONCODE, 0,
6138 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
6142 Perl_oopsAV(pTHX_ OP *o)
6146 PERL_ARGS_ASSERT_OOPSAV;
6148 switch (o->op_type) {
6150 o->op_type = OP_PADAV;
6151 o->op_ppaddr = PL_ppaddr[OP_PADAV];
6152 return ref(o, OP_RV2AV);
6155 o->op_type = OP_RV2AV;
6156 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
6161 if (ckWARN_d(WARN_INTERNAL))
6162 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
6169 Perl_oopsHV(pTHX_ OP *o)
6173 PERL_ARGS_ASSERT_OOPSHV;
6175 switch (o->op_type) {
6178 o->op_type = OP_PADHV;
6179 o->op_ppaddr = PL_ppaddr[OP_PADHV];
6180 return ref(o, OP_RV2HV);
6184 o->op_type = OP_RV2HV;
6185 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
6190 if (ckWARN_d(WARN_INTERNAL))
6191 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
6198 Perl_newAVREF(pTHX_ OP *o)
6202 PERL_ARGS_ASSERT_NEWAVREF;
6204 if (o->op_type == OP_PADANY) {
6205 o->op_type = OP_PADAV;
6206 o->op_ppaddr = PL_ppaddr[OP_PADAV];
6209 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
6210 && ckWARN(WARN_DEPRECATED)) {
6211 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
6212 "Using an array as a reference is deprecated");
6214 return newUNOP(OP_RV2AV, 0, scalar(o));
6218 Perl_newGVREF(pTHX_ I32 type, OP *o)
6220 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
6221 return newUNOP(OP_NULL, 0, o);
6222 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
6226 Perl_newHVREF(pTHX_ OP *o)
6230 PERL_ARGS_ASSERT_NEWHVREF;
6232 if (o->op_type == OP_PADANY) {
6233 o->op_type = OP_PADHV;
6234 o->op_ppaddr = PL_ppaddr[OP_PADHV];
6237 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
6238 && ckWARN(WARN_DEPRECATED)) {
6239 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
6240 "Using a hash as a reference is deprecated");
6242 return newUNOP(OP_RV2HV, 0, scalar(o));
6246 Perl_newCVREF(pTHX_ I32 flags, OP *o)
6248 return newUNOP(OP_RV2CV, flags, scalar(o));
6252 Perl_newSVREF(pTHX_ OP *o)
6256 PERL_ARGS_ASSERT_NEWSVREF;
6258 if (o->op_type == OP_PADANY) {
6259 o->op_type = OP_PADSV;
6260 o->op_ppaddr = PL_ppaddr[OP_PADSV];
6263 return newUNOP(OP_RV2SV, 0, scalar(o));
6266 /* Check routines. See the comments at the top of this file for details
6267 * on when these are called */
6270 Perl_ck_anoncode(pTHX_ OP *o)
6272 PERL_ARGS_ASSERT_CK_ANONCODE;
6274 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
6276 cSVOPo->op_sv = NULL;
6281 Perl_ck_bitop(pTHX_ OP *o)
6285 PERL_ARGS_ASSERT_CK_BITOP;
6287 #define OP_IS_NUMCOMPARE(op) \
6288 ((op) == OP_LT || (op) == OP_I_LT || \
6289 (op) == OP_GT || (op) == OP_I_GT || \
6290 (op) == OP_LE || (op) == OP_I_LE || \
6291 (op) == OP_GE || (op) == OP_I_GE || \
6292 (op) == OP_EQ || (op) == OP_I_EQ || \
6293 (op) == OP_NE || (op) == OP_I_NE || \
6294 (op) == OP_NCMP || (op) == OP_I_NCMP)
6295 o->op_private = (U8)(PL_hints & HINT_INTEGER);
6296 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
6297 && (o->op_type == OP_BIT_OR
6298 || o->op_type == OP_BIT_AND
6299 || o->op_type == OP_BIT_XOR))
6301 const OP * const left = cBINOPo->op_first;
6302 const OP * const right = left->op_sibling;
6303 if ((OP_IS_NUMCOMPARE(left->op_type) &&
6304 (left->op_flags & OPf_PARENS) == 0) ||
6305 (OP_IS_NUMCOMPARE(right->op_type) &&
6306 (right->op_flags & OPf_PARENS) == 0))
6307 if (ckWARN(WARN_PRECEDENCE))
6308 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
6309 "Possible precedence problem on bitwise %c operator",
6310 o->op_type == OP_BIT_OR ? '|'
6311 : o->op_type == OP_BIT_AND ? '&' : '^'
6318 Perl_ck_concat(pTHX_ OP *o)
6320 const OP * const kid = cUNOPo->op_first;
6322 PERL_ARGS_ASSERT_CK_CONCAT;
6323 PERL_UNUSED_CONTEXT;
6325 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
6326 !(kUNOP->op_first->op_flags & OPf_MOD))
6327 o->op_flags |= OPf_STACKED;
6332 Perl_ck_spair(pTHX_ OP *o)
6336 PERL_ARGS_ASSERT_CK_SPAIR;
6338 if (o->op_flags & OPf_KIDS) {
6341 const OPCODE type = o->op_type;
6342 o = modkids(ck_fun(o), type);
6343 kid = cUNOPo->op_first;
6344 newop = kUNOP->op_first->op_sibling;
6346 const OPCODE type = newop->op_type;
6347 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
6348 type == OP_PADAV || type == OP_PADHV ||
6349 type == OP_RV2AV || type == OP_RV2HV)
6353 op_getmad(kUNOP->op_first,newop,'K');
6355 op_free(kUNOP->op_first);
6357 kUNOP->op_first = newop;
6359 o->op_ppaddr = PL_ppaddr[++o->op_type];
6364 Perl_ck_delete(pTHX_ OP *o)
6366 PERL_ARGS_ASSERT_CK_DELETE;
6370 if (o->op_flags & OPf_KIDS) {
6371 OP * const kid = cUNOPo->op_first;
6372 switch (kid->op_type) {
6374 o->op_flags |= OPf_SPECIAL;
6377 o->op_private |= OPpSLICE;
6380 o->op_flags |= OPf_SPECIAL;
6385 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
6394 Perl_ck_die(pTHX_ OP *o)
6396 PERL_ARGS_ASSERT_CK_DIE;
6399 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6405 Perl_ck_eof(pTHX_ OP *o)
6409 PERL_ARGS_ASSERT_CK_EOF;
6411 if (o->op_flags & OPf_KIDS) {
6412 if (cLISTOPo->op_first->op_type == OP_STUB) {
6414 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
6416 op_getmad(o,newop,'O');
6428 Perl_ck_eval(pTHX_ OP *o)
6432 PERL_ARGS_ASSERT_CK_EVAL;
6434 PL_hints |= HINT_BLOCK_SCOPE;
6435 if (o->op_flags & OPf_KIDS) {
6436 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6439 o->op_flags &= ~OPf_KIDS;
6442 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
6448 cUNOPo->op_first = 0;
6453 NewOp(1101, enter, 1, LOGOP);
6454 enter->op_type = OP_ENTERTRY;
6455 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
6456 enter->op_private = 0;
6458 /* establish postfix order */
6459 enter->op_next = (OP*)enter;
6461 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
6462 o->op_type = OP_LEAVETRY;
6463 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
6464 enter->op_other = o;
6465 op_getmad(oldo,o,'O');
6479 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
6480 op_getmad(oldo,o,'O');
6482 o->op_targ = (PADOFFSET)PL_hints;
6483 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
6484 /* Store a copy of %^H that pp_entereval can pick up. */
6485 OP *hhop = newSVOP(OP_HINTSEVAL, 0,
6486 (SV*)Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv)));
6487 cUNOPo->op_first->op_sibling = hhop;
6488 o->op_private |= OPpEVAL_HAS_HH;
6494 Perl_ck_exit(pTHX_ OP *o)
6496 PERL_ARGS_ASSERT_CK_EXIT;
6499 HV * const table = GvHV(PL_hintgv);
6501 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
6502 if (svp && *svp && SvTRUE(*svp))
6503 o->op_private |= OPpEXIT_VMSISH;
6505 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6511 Perl_ck_exec(pTHX_ OP *o)
6513 PERL_ARGS_ASSERT_CK_EXEC;
6515 if (o->op_flags & OPf_STACKED) {
6518 kid = cUNOPo->op_first->op_sibling;
6519 if (kid->op_type == OP_RV2GV)
6528 Perl_ck_exists(pTHX_ OP *o)
6532 PERL_ARGS_ASSERT_CK_EXISTS;
6535 if (o->op_flags & OPf_KIDS) {
6536 OP * const kid = cUNOPo->op_first;
6537 if (kid->op_type == OP_ENTERSUB) {
6538 (void) ref(kid, o->op_type);
6539 if (kid->op_type != OP_RV2CV
6540 && !(PL_parser && PL_parser->error_count))
6541 Perl_croak(aTHX_ "%s argument is not a subroutine name",
6543 o->op_private |= OPpEXISTS_SUB;
6545 else if (kid->op_type == OP_AELEM)
6546 o->op_flags |= OPf_SPECIAL;
6547 else if (kid->op_type != OP_HELEM)
6548 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
6556 Perl_ck_rvconst(pTHX_ register OP *o)
6559 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6561 PERL_ARGS_ASSERT_CK_RVCONST;
6563 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6564 if (o->op_type == OP_RV2CV)
6565 o->op_private &= ~1;
6567 if (kid->op_type == OP_CONST) {
6570 SV * const kidsv = kid->op_sv;
6572 /* Is it a constant from cv_const_sv()? */
6573 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
6574 SV * const rsv = SvRV(kidsv);
6575 const svtype type = SvTYPE(rsv);
6576 const char *badtype = NULL;
6578 switch (o->op_type) {
6580 if (type > SVt_PVMG)
6581 badtype = "a SCALAR";
6584 if (type != SVt_PVAV)
6585 badtype = "an ARRAY";
6588 if (type != SVt_PVHV)
6592 if (type != SVt_PVCV)
6597 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
6600 else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
6601 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
6602 /* If this is an access to a stash, disable "strict refs", because
6603 * stashes aren't auto-vivified at compile-time (unless we store
6604 * symbols in them), and we don't want to produce a run-time
6605 * stricture error when auto-vivifying the stash. */
6606 const char *s = SvPV_nolen(kidsv);
6607 const STRLEN l = SvCUR(kidsv);
6608 if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
6609 o->op_private &= ~HINT_STRICT_REFS;
6611 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
6612 const char *badthing;
6613 switch (o->op_type) {
6615 badthing = "a SCALAR";
6618 badthing = "an ARRAY";
6621 badthing = "a HASH";
6629 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
6630 SVfARG(kidsv), badthing);
6633 * This is a little tricky. We only want to add the symbol if we
6634 * didn't add it in the lexer. Otherwise we get duplicate strict
6635 * warnings. But if we didn't add it in the lexer, we must at
6636 * least pretend like we wanted to add it even if it existed before,
6637 * or we get possible typo warnings. OPpCONST_ENTERED says
6638 * whether the lexer already added THIS instance of this symbol.
6640 iscv = (o->op_type == OP_RV2CV) * 2;
6642 gv = gv_fetchsv(kidsv,
6643 iscv | !(kid->op_private & OPpCONST_ENTERED),
6646 : o->op_type == OP_RV2SV
6648 : o->op_type == OP_RV2AV
6650 : o->op_type == OP_RV2HV
6653 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
6655 kid->op_type = OP_GV;
6656 SvREFCNT_dec(kid->op_sv);
6658 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
6659 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
6660 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
6662 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc_simple_NN(gv));
6664 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
6666 kid->op_private = 0;
6667 kid->op_ppaddr = PL_ppaddr[OP_GV];
6674 Perl_ck_ftst(pTHX_ OP *o)
6677 const I32 type = o->op_type;
6679 PERL_ARGS_ASSERT_CK_FTST;
6681 if (o->op_flags & OPf_REF) {
6684 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
6685 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6686 const OPCODE kidtype = kid->op_type;
6688 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6689 OP * const newop = newGVOP(type, OPf_REF,
6690 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
6692 op_getmad(o,newop,'O');
6698 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
6699 o->op_private |= OPpFT_ACCESS;
6700 if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst)
6701 && kidtype != OP_STAT && kidtype != OP_LSTAT)
6702 o->op_private |= OPpFT_STACKED;
6710 if (type == OP_FTTTY)
6711 o = newGVOP(type, OPf_REF, PL_stdingv);
6713 o = newUNOP(type, 0, newDEFSVOP());
6714 op_getmad(oldo,o,'O');
6720 Perl_ck_fun(pTHX_ OP *o)
6723 const int type = o->op_type;
6724 register I32 oa = PL_opargs[type] >> OASHIFT;
6726 PERL_ARGS_ASSERT_CK_FUN;
6728 if (o->op_flags & OPf_STACKED) {
6729 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
6732 return no_fh_allowed(o);
6735 if (o->op_flags & OPf_KIDS) {
6736 OP **tokid = &cLISTOPo->op_first;
6737 register OP *kid = cLISTOPo->op_first;
6741 if (kid->op_type == OP_PUSHMARK ||
6742 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
6744 tokid = &kid->op_sibling;
6745 kid = kid->op_sibling;
6747 if (!kid && PL_opargs[type] & OA_DEFGV)
6748 *tokid = kid = newDEFSVOP();
6752 sibl = kid->op_sibling;
6754 if (!sibl && kid->op_type == OP_STUB) {
6761 /* list seen where single (scalar) arg expected? */
6762 if (numargs == 1 && !(oa >> 4)
6763 && kid->op_type == OP_LIST && type != OP_SCALAR)
6765 return too_many_arguments(o,PL_op_desc[type]);
6778 if ((type == OP_PUSH || type == OP_UNSHIFT)
6779 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
6780 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6781 "Useless use of %s with no values",
6784 if (kid->op_type == OP_CONST &&
6785 (kid->op_private & OPpCONST_BARE))
6787 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
6788 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
6789 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6790 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6791 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
6792 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6794 op_getmad(kid,newop,'K');
6799 kid->op_sibling = sibl;
6802 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
6803 bad_type(numargs, "array", PL_op_desc[type], kid);
6807 if (kid->op_type == OP_CONST &&
6808 (kid->op_private & OPpCONST_BARE))
6810 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
6811 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
6812 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6813 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6814 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
6815 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6817 op_getmad(kid,newop,'K');
6822 kid->op_sibling = sibl;
6825 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
6826 bad_type(numargs, "hash", PL_op_desc[type], kid);
6831 OP * const newop = newUNOP(OP_NULL, 0, kid);
6832 kid->op_sibling = 0;
6834 newop->op_next = newop;
6836 kid->op_sibling = sibl;
6841 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
6842 if (kid->op_type == OP_CONST &&
6843 (kid->op_private & OPpCONST_BARE))
6845 OP * const newop = newGVOP(OP_GV, 0,
6846 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
6847 if (!(o->op_private & 1) && /* if not unop */
6848 kid == cLISTOPo->op_last)
6849 cLISTOPo->op_last = newop;
6851 op_getmad(kid,newop,'K');
6857 else if (kid->op_type == OP_READLINE) {
6858 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
6859 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
6862 I32 flags = OPf_SPECIAL;
6866 /* is this op a FH constructor? */
6867 if (is_handle_constructor(o,numargs)) {
6868 const char *name = NULL;
6872 /* Set a flag to tell rv2gv to vivify
6873 * need to "prove" flag does not mean something
6874 * else already - NI-S 1999/05/07
6877 if (kid->op_type == OP_PADSV) {
6879 = PAD_COMPNAME_SV(kid->op_targ);
6880 name = SvPV_const(namesv, len);
6882 else if (kid->op_type == OP_RV2SV
6883 && kUNOP->op_first->op_type == OP_GV)
6885 GV * const gv = cGVOPx_gv(kUNOP->op_first);
6887 len = GvNAMELEN(gv);
6889 else if (kid->op_type == OP_AELEM
6890 || kid->op_type == OP_HELEM)
6893 OP *op = ((BINOP*)kid)->op_first;
6897 const char * const a =
6898 kid->op_type == OP_AELEM ?
6900 if (((op->op_type == OP_RV2AV) ||
6901 (op->op_type == OP_RV2HV)) &&
6902 (firstop = ((UNOP*)op)->op_first) &&
6903 (firstop->op_type == OP_GV)) {
6904 /* packagevar $a[] or $h{} */
6905 GV * const gv = cGVOPx_gv(firstop);
6913 else if (op->op_type == OP_PADAV
6914 || op->op_type == OP_PADHV) {
6915 /* lexicalvar $a[] or $h{} */
6916 const char * const padname =
6917 PAD_COMPNAME_PV(op->op_targ);
6926 name = SvPV_const(tmpstr, len);
6931 name = "__ANONIO__";
6938 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
6939 namesv = PAD_SVl(targ);
6940 SvUPGRADE(namesv, SVt_PV);
6942 sv_setpvn(namesv, "$", 1);
6943 sv_catpvn(namesv, name, len);
6946 kid->op_sibling = 0;
6947 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
6948 kid->op_targ = targ;
6949 kid->op_private |= priv;
6951 kid->op_sibling = sibl;
6957 mod(scalar(kid), type);
6961 tokid = &kid->op_sibling;
6962 kid = kid->op_sibling;
6965 if (kid && kid->op_type != OP_STUB)
6966 return too_many_arguments(o,OP_DESC(o));
6967 o->op_private |= numargs;
6969 /* FIXME - should the numargs move as for the PERL_MAD case? */
6970 o->op_private |= numargs;
6972 return too_many_arguments(o,OP_DESC(o));
6976 else if (PL_opargs[type] & OA_DEFGV) {
6978 OP *newop = newUNOP(type, 0, newDEFSVOP());
6979 op_getmad(o,newop,'O');
6982 /* Ordering of these two is important to keep f_map.t passing. */
6984 return newUNOP(type, 0, newDEFSVOP());
6989 while (oa & OA_OPTIONAL)
6991 if (oa && oa != OA_LIST)
6992 return too_few_arguments(o,OP_DESC(o));
6998 Perl_ck_glob(pTHX_ OP *o)
7003 PERL_ARGS_ASSERT_CK_GLOB;
7006 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
7007 append_elem(OP_GLOB, o, newDEFSVOP());
7009 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
7010 && GvCVu(gv) && GvIMPORTED_CV(gv)))
7012 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7015 #if !defined(PERL_EXTERNAL_GLOB)
7016 /* XXX this can be tightened up and made more failsafe. */
7017 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7020 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
7021 newSVpvs("File::Glob"), NULL, NULL, NULL);
7022 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7023 glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
7024 GvCV(gv) = GvCV(glob_gv);
7025 SvREFCNT_inc_void((SV*)GvCV(gv));
7026 GvIMPORTED_CV_on(gv);
7029 #endif /* PERL_EXTERNAL_GLOB */
7031 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7032 append_elem(OP_GLOB, o,
7033 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
7034 o->op_type = OP_LIST;
7035 o->op_ppaddr = PL_ppaddr[OP_LIST];
7036 cLISTOPo->op_first->op_type = OP_PUSHMARK;
7037 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
7038 cLISTOPo->op_first->op_targ = 0;
7039 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
7040 append_elem(OP_LIST, o,
7041 scalar(newUNOP(OP_RV2CV, 0,
7042 newGVOP(OP_GV, 0, gv)))));
7043 o = newUNOP(OP_NULL, 0, ck_subr(o));
7044 o->op_targ = OP_GLOB; /* hint at what it used to be */
7047 gv = newGVgen("main");
7049 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
7055 Perl_ck_grep(pTHX_ OP *o)
7060 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
7063 PERL_ARGS_ASSERT_CK_GREP;
7065 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
7066 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
7068 if (o->op_flags & OPf_STACKED) {
7071 kid = cLISTOPo->op_first->op_sibling;
7072 if (!cUNOPx(kid)->op_next)
7073 Perl_croak(aTHX_ "panic: ck_grep");
7074 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
7077 NewOp(1101, gwop, 1, LOGOP);
7078 kid->op_next = (OP*)gwop;
7079 o->op_flags &= ~OPf_STACKED;
7081 kid = cLISTOPo->op_first->op_sibling;
7082 if (type == OP_MAPWHILE)
7087 if (PL_parser && PL_parser->error_count)
7089 kid = cLISTOPo->op_first->op_sibling;
7090 if (kid->op_type != OP_NULL)
7091 Perl_croak(aTHX_ "panic: ck_grep");
7092 kid = kUNOP->op_first;
7095 NewOp(1101, gwop, 1, LOGOP);
7096 gwop->op_type = type;
7097 gwop->op_ppaddr = PL_ppaddr[type];
7098 gwop->op_first = listkids(o);
7099 gwop->op_flags |= OPf_KIDS;
7100 gwop->op_other = LINKLIST(kid);
7101 kid->op_next = (OP*)gwop;
7102 offset = pad_findmy("$_");
7103 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
7104 o->op_private = gwop->op_private = 0;
7105 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
7108 o->op_private = gwop->op_private = OPpGREP_LEX;
7109 gwop->op_targ = o->op_targ = offset;
7112 kid = cLISTOPo->op_first->op_sibling;
7113 if (!kid || !kid->op_sibling)
7114 return too_few_arguments(o,OP_DESC(o));
7115 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
7116 mod(kid, OP_GREPSTART);
7122 Perl_ck_index(pTHX_ OP *o)
7124 PERL_ARGS_ASSERT_CK_INDEX;
7126 if (o->op_flags & OPf_KIDS) {
7127 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7129 kid = kid->op_sibling; /* get past "big" */
7130 if (kid && kid->op_type == OP_CONST)
7131 fbm_compile(((SVOP*)kid)->op_sv, 0);
7137 Perl_ck_lfun(pTHX_ OP *o)
7139 const OPCODE type = o->op_type;
7141 PERL_ARGS_ASSERT_CK_LFUN;
7143 return modkids(ck_fun(o), type);
7147 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
7149 PERL_ARGS_ASSERT_CK_DEFINED;
7151 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
7152 switch (cUNOPo->op_first->op_type) {
7154 /* This is needed for
7155 if (defined %stash::)
7156 to work. Do not break Tk.
7158 break; /* Globals via GV can be undef */
7160 case OP_AASSIGN: /* Is this a good idea? */
7161 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
7162 "defined(@array) is deprecated");
7163 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
7164 "\t(Maybe you should just omit the defined()?)\n");
7167 /* This is needed for
7168 if (defined %stash::)
7169 to work. Do not break Tk.
7171 break; /* Globals via GV can be undef */
7173 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
7174 "defined(%%hash) is deprecated");
7175 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
7176 "\t(Maybe you should just omit the defined()?)\n");
7187 Perl_ck_readline(pTHX_ OP *o)
7189 PERL_ARGS_ASSERT_CK_READLINE;
7191 if (!(o->op_flags & OPf_KIDS)) {
7193 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
7195 op_getmad(o,newop,'O');
7205 Perl_ck_rfun(pTHX_ OP *o)
7207 const OPCODE type = o->op_type;
7209 PERL_ARGS_ASSERT_CK_RFUN;
7211 return refkids(ck_fun(o), type);
7215 Perl_ck_listiob(pTHX_ OP *o)
7219 PERL_ARGS_ASSERT_CK_LISTIOB;
7221 kid = cLISTOPo->op_first;
7224 kid = cLISTOPo->op_first;
7226 if (kid->op_type == OP_PUSHMARK)
7227 kid = kid->op_sibling;
7228 if (kid && o->op_flags & OPf_STACKED)
7229 kid = kid->op_sibling;
7230 else if (kid && !kid->op_sibling) { /* print HANDLE; */
7231 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
7232 o->op_flags |= OPf_STACKED; /* make it a filehandle */
7233 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
7234 cLISTOPo->op_first->op_sibling = kid;
7235 cLISTOPo->op_last = kid;
7236 kid = kid->op_sibling;
7241 append_elem(o->op_type, o, newDEFSVOP());
7247 Perl_ck_smartmatch(pTHX_ OP *o)
7250 if (0 == (o->op_flags & OPf_SPECIAL)) {
7251 OP *first = cBINOPo->op_first;
7252 OP *second = first->op_sibling;
7254 /* Implicitly take a reference to an array or hash */
7255 first->op_sibling = NULL;
7256 first = cBINOPo->op_first = ref_array_or_hash(first);
7257 second = first->op_sibling = ref_array_or_hash(second);
7259 /* Implicitly take a reference to a regular expression */
7260 if (first->op_type == OP_MATCH) {
7261 first->op_type = OP_QR;
7262 first->op_ppaddr = PL_ppaddr[OP_QR];
7264 if (second->op_type == OP_MATCH) {
7265 second->op_type = OP_QR;
7266 second->op_ppaddr = PL_ppaddr[OP_QR];
7275 Perl_ck_sassign(pTHX_ OP *o)
7278 OP * const kid = cLISTOPo->op_first;
7280 PERL_ARGS_ASSERT_CK_SASSIGN;
7282 /* has a disposable target? */
7283 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
7284 && !(kid->op_flags & OPf_STACKED)
7285 /* Cannot steal the second time! */
7286 && !(kid->op_private & OPpTARGET_MY)
7287 /* Keep the full thing for madskills */
7291 OP * const kkid = kid->op_sibling;
7293 /* Can just relocate the target. */
7294 if (kkid && kkid->op_type == OP_PADSV
7295 && !(kkid->op_private & OPpLVAL_INTRO))
7297 kid->op_targ = kkid->op_targ;
7299 /* Now we do not need PADSV and SASSIGN. */
7300 kid->op_sibling = o->op_sibling; /* NULL */
7301 cLISTOPo->op_first = NULL;
7304 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
7308 if (kid->op_sibling) {
7309 OP *kkid = kid->op_sibling;
7310 if (kkid->op_type == OP_PADSV
7311 && (kkid->op_private & OPpLVAL_INTRO)
7312 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
7313 const PADOFFSET target = kkid->op_targ;
7314 OP *const other = newOP(OP_PADSV,
7316 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
7317 OP *const first = newOP(OP_NULL, 0);
7318 OP *const nullop = newCONDOP(0, first, o, other);
7319 OP *const condop = first->op_next;
7320 /* hijacking PADSTALE for uninitialized state variables */
7321 SvPADSTALE_on(PAD_SVl(target));
7323 condop->op_type = OP_ONCE;
7324 condop->op_ppaddr = PL_ppaddr[OP_ONCE];
7325 condop->op_targ = target;
7326 other->op_targ = target;
7328 /* Because we change the type of the op here, we will skip the
7329 assinment binop->op_last = binop->op_first->op_sibling; at the
7330 end of Perl_newBINOP(). So need to do it here. */
7331 cBINOPo->op_last = cBINOPo->op_first->op_sibling;
7340 Perl_ck_match(pTHX_ OP *o)
7344 PERL_ARGS_ASSERT_CK_MATCH;
7346 if (o->op_type != OP_QR && PL_compcv) {
7347 const PADOFFSET offset = pad_findmy("$_");
7348 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
7349 o->op_targ = offset;
7350 o->op_private |= OPpTARGET_MY;
7353 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
7354 o->op_private |= OPpRUNTIME;
7359 Perl_ck_method(pTHX_ OP *o)
7361 OP * const kid = cUNOPo->op_first;
7363 PERL_ARGS_ASSERT_CK_METHOD;
7365 if (kid->op_type == OP_CONST) {
7366 SV* sv = kSVOP->op_sv;
7367 const char * const method = SvPVX_const(sv);
7368 if (!(strchr(method, ':') || strchr(method, '\''))) {
7370 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
7371 sv = newSVpvn_share(method, SvCUR(sv), 0);
7374 kSVOP->op_sv = NULL;
7376 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
7378 op_getmad(o,cmop,'O');
7389 Perl_ck_null(pTHX_ OP *o)
7391 PERL_ARGS_ASSERT_CK_NULL;
7392 PERL_UNUSED_CONTEXT;
7397 Perl_ck_open(pTHX_ OP *o)
7400 HV * const table = GvHV(PL_hintgv);
7402 PERL_ARGS_ASSERT_CK_OPEN;
7405 SV **svp = hv_fetchs(table, "open_IN", FALSE);
7407 const I32 mode = mode_from_discipline(*svp);
7408 if (mode & O_BINARY)
7409 o->op_private |= OPpOPEN_IN_RAW;
7410 else if (mode & O_TEXT)
7411 o->op_private |= OPpOPEN_IN_CRLF;
7414 svp = hv_fetchs(table, "open_OUT", FALSE);
7416 const I32 mode = mode_from_discipline(*svp);
7417 if (mode & O_BINARY)
7418 o->op_private |= OPpOPEN_OUT_RAW;
7419 else if (mode & O_TEXT)
7420 o->op_private |= OPpOPEN_OUT_CRLF;
7423 if (o->op_type == OP_BACKTICK) {
7424 if (!(o->op_flags & OPf_KIDS)) {
7425 OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
7427 op_getmad(o,newop,'O');
7436 /* In case of three-arg dup open remove strictness
7437 * from the last arg if it is a bareword. */
7438 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
7439 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
7443 if ((last->op_type == OP_CONST) && /* The bareword. */
7444 (last->op_private & OPpCONST_BARE) &&
7445 (last->op_private & OPpCONST_STRICT) &&
7446 (oa = first->op_sibling) && /* The fh. */
7447 (oa = oa->op_sibling) && /* The mode. */
7448 (oa->op_type == OP_CONST) &&
7449 SvPOK(((SVOP*)oa)->op_sv) &&
7450 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
7451 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
7452 (last == oa->op_sibling)) /* The bareword. */
7453 last->op_private &= ~OPpCONST_STRICT;
7459 Perl_ck_repeat(pTHX_ OP *o)
7461 PERL_ARGS_ASSERT_CK_REPEAT;
7463 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
7464 o->op_private |= OPpREPEAT_DOLIST;
7465 cBINOPo->op_first = force_list(cBINOPo->op_first);
7473 Perl_ck_require(pTHX_ OP *o)
7478 PERL_ARGS_ASSERT_CK_REQUIRE;
7480 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
7481 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7483 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
7484 SV * const sv = kid->op_sv;
7485 U32 was_readonly = SvREADONLY(sv);
7492 sv_force_normal_flags(sv, 0);
7493 assert(!SvREADONLY(sv));
7503 for (; s < end; s++) {
7504 if (*s == ':' && s[1] == ':') {
7506 Move(s+2, s+1, end - s - 1, char);
7511 sv_catpvs(sv, ".pm");
7512 SvFLAGS(sv) |= was_readonly;
7516 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
7517 /* handle override, if any */
7518 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
7519 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7520 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
7521 gv = gvp ? *gvp : NULL;
7525 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7526 OP * const kid = cUNOPo->op_first;
7529 cUNOPo->op_first = 0;
7533 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
7534 append_elem(OP_LIST, kid,
7535 scalar(newUNOP(OP_RV2CV, 0,
7538 op_getmad(o,newop,'O');
7546 Perl_ck_return(pTHX_ OP *o)
7550 PERL_ARGS_ASSERT_CK_RETURN;
7552 if (CvLVALUE(PL_compcv)) {
7554 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
7555 mod(kid, OP_LEAVESUBLV);
7561 Perl_ck_select(pTHX_ OP *o)
7566 PERL_ARGS_ASSERT_CK_SELECT;
7568 if (o->op_flags & OPf_KIDS) {
7569 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7570 if (kid && kid->op_sibling) {
7571 o->op_type = OP_SSELECT;
7572 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
7574 return fold_constants(o);
7578 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7579 if (kid && kid->op_type == OP_RV2GV)
7580 kid->op_private &= ~HINT_STRICT_REFS;
7585 Perl_ck_shift(pTHX_ OP *o)
7588 const I32 type = o->op_type;
7590 PERL_ARGS_ASSERT_CK_SHIFT;
7592 if (!(o->op_flags & OPf_KIDS)) {
7594 /* FIXME - this can be refactored to reduce code in #ifdefs */
7596 OP * const oldo = o;
7600 argop = newUNOP(OP_RV2AV, 0,
7601 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
7603 o = newUNOP(type, 0, scalar(argop));
7604 op_getmad(oldo,o,'O');
7607 return newUNOP(type, 0, scalar(argop));
7610 return scalar(modkids(ck_fun(o), type));
7614 Perl_ck_sort(pTHX_ OP *o)
7619 PERL_ARGS_ASSERT_CK_SORT;
7621 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
7622 HV * const hinthv = GvHV(PL_hintgv);
7624 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
7626 const I32 sorthints = (I32)SvIV(*svp);
7627 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
7628 o->op_private |= OPpSORT_QSORT;
7629 if ((sorthints & HINT_SORT_STABLE) != 0)
7630 o->op_private |= OPpSORT_STABLE;
7635 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
7637 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7638 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
7640 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
7642 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
7644 if (kid->op_type == OP_SCOPE) {
7648 else if (kid->op_type == OP_LEAVE) {
7649 if (o->op_type == OP_SORT) {
7650 op_null(kid); /* wipe out leave */
7653 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
7654 if (k->op_next == kid)
7656 /* don't descend into loops */
7657 else if (k->op_type == OP_ENTERLOOP
7658 || k->op_type == OP_ENTERITER)
7660 k = cLOOPx(k)->op_lastop;
7665 kid->op_next = 0; /* just disconnect the leave */
7666 k = kLISTOP->op_first;
7671 if (o->op_type == OP_SORT) {
7672 /* provide scalar context for comparison function/block */
7678 o->op_flags |= OPf_SPECIAL;
7680 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
7683 firstkid = firstkid->op_sibling;
7686 /* provide list context for arguments */
7687 if (o->op_type == OP_SORT)
7694 S_simplify_sort(pTHX_ OP *o)
7697 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7703 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
7705 if (!(o->op_flags & OPf_STACKED))
7707 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7708 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
7709 kid = kUNOP->op_first; /* get past null */
7710 if (kid->op_type != OP_SCOPE)
7712 kid = kLISTOP->op_last; /* get past scope */
7713 switch(kid->op_type) {
7721 k = kid; /* remember this node*/
7722 if (kBINOP->op_first->op_type != OP_RV2SV)
7724 kid = kBINOP->op_first; /* get past cmp */
7725 if (kUNOP->op_first->op_type != OP_GV)
7727 kid = kUNOP->op_first; /* get past rv2sv */
7729 if (GvSTASH(gv) != PL_curstash)
7731 gvname = GvNAME(gv);
7732 if (*gvname == 'a' && gvname[1] == '\0')
7734 else if (*gvname == 'b' && gvname[1] == '\0')
7739 kid = k; /* back to cmp */
7740 if (kBINOP->op_last->op_type != OP_RV2SV)
7742 kid = kBINOP->op_last; /* down to 2nd arg */
7743 if (kUNOP->op_first->op_type != OP_GV)
7745 kid = kUNOP->op_first; /* get past rv2sv */
7747 if (GvSTASH(gv) != PL_curstash)
7749 gvname = GvNAME(gv);
7751 ? !(*gvname == 'a' && gvname[1] == '\0')
7752 : !(*gvname == 'b' && gvname[1] == '\0'))
7754 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
7756 o->op_private |= OPpSORT_DESCEND;
7757 if (k->op_type == OP_NCMP)
7758 o->op_private |= OPpSORT_NUMERIC;
7759 if (k->op_type == OP_I_NCMP)
7760 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
7761 kid = cLISTOPo->op_first->op_sibling;
7762 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
7764 op_getmad(kid,o,'S'); /* then delete it */
7766 op_free(kid); /* then delete it */
7771 Perl_ck_split(pTHX_ OP *o)
7776 PERL_ARGS_ASSERT_CK_SPLIT;
7778 if (o->op_flags & OPf_STACKED)
7779 return no_fh_allowed(o);
7781 kid = cLISTOPo->op_first;
7782 if (kid->op_type != OP_NULL)
7783 Perl_croak(aTHX_ "panic: ck_split");
7784 kid = kid->op_sibling;
7785 op_free(cLISTOPo->op_first);
7786 cLISTOPo->op_first = kid;
7788 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
7789 cLISTOPo->op_last = kid; /* There was only one element previously */
7792 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
7793 OP * const sibl = kid->op_sibling;
7794 kid->op_sibling = 0;
7795 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
7796 if (cLISTOPo->op_first == cLISTOPo->op_last)
7797 cLISTOPo->op_last = kid;
7798 cLISTOPo->op_first = kid;
7799 kid->op_sibling = sibl;
7802 kid->op_type = OP_PUSHRE;
7803 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
7805 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
7806 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
7807 "Use of /g modifier is meaningless in split");
7810 if (!kid->op_sibling)
7811 append_elem(OP_SPLIT, o, newDEFSVOP());
7813 kid = kid->op_sibling;
7816 if (!kid->op_sibling)
7817 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
7818 assert(kid->op_sibling);
7820 kid = kid->op_sibling;
7823 if (kid->op_sibling)
7824 return too_many_arguments(o,OP_DESC(o));
7830 Perl_ck_join(pTHX_ OP *o)
7832 const OP * const kid = cLISTOPo->op_first->op_sibling;
7834 PERL_ARGS_ASSERT_CK_JOIN;
7836 if (kid && kid->op_type == OP_MATCH) {
7837 if (ckWARN(WARN_SYNTAX)) {
7838 const REGEXP *re = PM_GETRE(kPMOP);
7839 const char *pmstr = re ? RX_PRECOMP(re) : "STRING";
7840 const STRLEN len = re ? RX_PRELEN(re) : 6;
7841 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7842 "/%.*s/ should probably be written as \"%.*s\"",
7843 (int)len, pmstr, (int)len, pmstr);
7850 Perl_ck_subr(pTHX_ OP *o)
7853 OP *prev = ((cUNOPo->op_first->op_sibling)
7854 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
7855 OP *o2 = prev->op_sibling;
7857 const char *proto = NULL;
7858 const char *proto_end = NULL;
7863 I32 contextclass = 0;
7864 const char *e = NULL;
7867 PERL_ARGS_ASSERT_CK_SUBR;
7869 o->op_private |= OPpENTERSUB_HASTARG;
7870 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
7871 if (cvop->op_type == OP_RV2CV) {
7873 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
7874 op_null(cvop); /* disable rv2cv */
7875 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
7876 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
7877 GV *gv = cGVOPx_gv(tmpop);
7880 tmpop->op_private |= OPpEARLY_CV;
7884 namegv = CvANON(cv) ? gv : CvGV(cv);
7885 proto = SvPV((SV*)cv, len);
7886 proto_end = proto + len;
7891 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7892 if (o2->op_type == OP_CONST)
7893 o2->op_private &= ~OPpCONST_STRICT;
7894 else if (o2->op_type == OP_LIST) {
7895 OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
7896 if (sib && sib->op_type == OP_CONST)
7897 sib->op_private &= ~OPpCONST_STRICT;
7900 o->op_private |= (PL_hints & HINT_STRICT_REFS);
7901 if (PERLDB_SUB && PL_curstash != PL_debstash)
7902 o->op_private |= OPpENTERSUB_DB;
7903 while (o2 != cvop) {
7905 if (PL_madskills && o2->op_type == OP_STUB) {
7906 o2 = o2->op_sibling;
7909 if (PL_madskills && o2->op_type == OP_NULL)
7910 o3 = ((UNOP*)o2)->op_first;
7914 if (proto >= proto_end)
7915 return too_many_arguments(o, gv_ename(namegv));
7923 /* _ must be at the end */
7924 if (proto[1] && proto[1] != ';')
7939 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
7941 arg == 1 ? "block or sub {}" : "sub {}",
7942 gv_ename(namegv), o3);
7945 /* '*' allows any scalar type, including bareword */
7948 if (o3->op_type == OP_RV2GV)
7949 goto wrapref; /* autoconvert GLOB -> GLOBref */
7950 else if (o3->op_type == OP_CONST)
7951 o3->op_private &= ~OPpCONST_STRICT;
7952 else if (o3->op_type == OP_ENTERSUB) {
7953 /* accidental subroutine, revert to bareword */
7954 OP *gvop = ((UNOP*)o3)->op_first;
7955 if (gvop && gvop->op_type == OP_NULL) {
7956 gvop = ((UNOP*)gvop)->op_first;
7958 for (; gvop->op_sibling; gvop = gvop->op_sibling)
7961 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
7962 (gvop = ((UNOP*)gvop)->op_first) &&
7963 gvop->op_type == OP_GV)
7965 GV * const gv = cGVOPx_gv(gvop);
7966 OP * const sibling = o2->op_sibling;
7967 SV * const n = newSVpvs("");
7969 OP * const oldo2 = o2;
7973 gv_fullname4(n, gv, "", FALSE);
7974 o2 = newSVOP(OP_CONST, 0, n);
7975 op_getmad(oldo2,o2,'O');
7976 prev->op_sibling = o2;
7977 o2->op_sibling = sibling;
7993 if (contextclass++ == 0) {
7994 e = strchr(proto, ']');
7995 if (!e || e == proto)
8004 const char *p = proto;
8005 const char *const end = proto;
8007 while (*--p != '[');
8008 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
8010 gv_ename(namegv), o3);
8015 if (o3->op_type == OP_RV2GV)
8018 bad_type(arg, "symbol", gv_ename(namegv), o3);
8021 if (o3->op_type == OP_ENTERSUB)
8024 bad_type(arg, "subroutine entry", gv_ename(namegv),
8028 if (o3->op_type == OP_RV2SV ||
8029 o3->op_type == OP_PADSV ||
8030 o3->op_type == OP_HELEM ||
8031 o3->op_type == OP_AELEM)
8034 bad_type(arg, "scalar", gv_ename(namegv), o3);
8037 if (o3->op_type == OP_RV2AV ||
8038 o3->op_type == OP_PADAV)
8041 bad_type(arg, "array", gv_ename(namegv), o3);
8044 if (o3->op_type == OP_RV2HV ||
8045 o3->op_type == OP_PADHV)
8048 bad_type(arg, "hash", gv_ename(namegv), o3);
8053 OP* const sib = kid->op_sibling;
8054 kid->op_sibling = 0;
8055 o2 = newUNOP(OP_REFGEN, 0, kid);
8056 o2->op_sibling = sib;
8057 prev->op_sibling = o2;
8059 if (contextclass && e) {
8074 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
8075 gv_ename(namegv), SVfARG(cv));
8080 mod(o2, OP_ENTERSUB);
8082 o2 = o2->op_sibling;
8084 if (o2 == cvop && proto && *proto == '_') {
8085 /* generate an access to $_ */
8087 o2->op_sibling = prev->op_sibling;
8088 prev->op_sibling = o2; /* instead of cvop */
8090 if (proto && !optional && proto_end > proto &&
8091 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
8092 return too_few_arguments(o, gv_ename(namegv));
8095 OP * const oldo = o;
8099 o=newSVOP(OP_CONST, 0, newSViv(0));
8100 op_getmad(oldo,o,'O');
8106 Perl_ck_svconst(pTHX_ OP *o)
8108 PERL_ARGS_ASSERT_CK_SVCONST;
8109 PERL_UNUSED_CONTEXT;
8110 SvREADONLY_on(cSVOPo->op_sv);
8115 Perl_ck_chdir(pTHX_ OP *o)
8117 if (o->op_flags & OPf_KIDS) {
8118 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8120 if (kid && kid->op_type == OP_CONST &&
8121 (kid->op_private & OPpCONST_BARE))
8123 o->op_flags |= OPf_SPECIAL;
8124 kid->op_private &= ~OPpCONST_STRICT;
8131 Perl_ck_trunc(pTHX_ OP *o)
8133 PERL_ARGS_ASSERT_CK_TRUNC;
8135 if (o->op_flags & OPf_KIDS) {
8136 SVOP *kid = (SVOP*)cUNOPo->op_first;
8138 if (kid->op_type == OP_NULL)
8139 kid = (SVOP*)kid->op_sibling;
8140 if (kid && kid->op_type == OP_CONST &&
8141 (kid->op_private & OPpCONST_BARE))
8143 o->op_flags |= OPf_SPECIAL;
8144 kid->op_private &= ~OPpCONST_STRICT;
8151 Perl_ck_unpack(pTHX_ OP *o)
8153 OP *kid = cLISTOPo->op_first;
8155 PERL_ARGS_ASSERT_CK_UNPACK;
8157 if (kid->op_sibling) {
8158 kid = kid->op_sibling;
8159 if (!kid->op_sibling)
8160 kid->op_sibling = newDEFSVOP();
8166 Perl_ck_substr(pTHX_ OP *o)
8168 PERL_ARGS_ASSERT_CK_SUBSTR;
8171 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
8172 OP *kid = cLISTOPo->op_first;
8174 if (kid->op_type == OP_NULL)
8175 kid = kid->op_sibling;
8177 kid->op_flags |= OPf_MOD;
8184 Perl_ck_each(pTHX_ OP *o)
8187 OP *kid = cLISTOPo->op_first;
8189 PERL_ARGS_ASSERT_CK_EACH;
8191 if (kid->op_type == OP_PADAV || kid->op_type == OP_RV2AV) {
8192 const unsigned new_type = o->op_type == OP_EACH ? OP_AEACH
8193 : o->op_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
8194 o->op_type = new_type;
8195 o->op_ppaddr = PL_ppaddr[new_type];
8197 else if (!(kid->op_type == OP_PADHV || kid->op_type == OP_RV2HV
8198 || (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE)
8200 bad_type(1, "hash or array", PL_op_desc[o->op_type], kid);
8206 /* A peephole optimizer. We visit the ops in the order they're to execute.
8207 * See the comments at the top of this file for more details about when
8208 * peep() is called */
8211 Perl_peep(pTHX_ register OP *o)
8214 register OP* oldop = NULL;
8216 if (!o || o->op_opt)
8220 SAVEVPTR(PL_curcop);
8221 for (; o; o = o->op_next) {
8224 /* By default, this op has now been optimised. A couple of cases below
8225 clear this again. */
8228 switch (o->op_type) {
8231 PL_curcop = ((COP*)o); /* for warnings */
8235 if (cSVOPo->op_private & OPpCONST_STRICT)
8236 no_bareword_allowed(o);
8239 case OP_METHOD_NAMED:
8240 /* Relocate sv to the pad for thread safety.
8241 * Despite being a "constant", the SV is written to,
8242 * for reference counts, sv_upgrade() etc. */
8244 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
8245 if (o->op_type != OP_METHOD_NAMED && SvPADTMP(cSVOPo->op_sv)) {
8246 /* If op_sv is already a PADTMP then it is being used by
8247 * some pad, so make a copy. */
8248 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
8249 SvREADONLY_on(PAD_SVl(ix));
8250 SvREFCNT_dec(cSVOPo->op_sv);
8252 else if (o->op_type != OP_METHOD_NAMED
8253 && cSVOPo->op_sv == &PL_sv_undef) {
8254 /* PL_sv_undef is hack - it's unsafe to store it in the
8255 AV that is the pad, because av_fetch treats values of
8256 PL_sv_undef as a "free" AV entry and will merrily
8257 replace them with a new SV, causing pad_alloc to think
8258 that this pad slot is free. (When, clearly, it is not)
8260 SvOK_off(PAD_SVl(ix));
8261 SvPADTMP_on(PAD_SVl(ix));
8262 SvREADONLY_on(PAD_SVl(ix));
8265 SvREFCNT_dec(PAD_SVl(ix));
8266 SvPADTMP_on(cSVOPo->op_sv);
8267 PAD_SETSV(ix, cSVOPo->op_sv);
8268 /* XXX I don't know how this isn't readonly already. */
8269 SvREADONLY_on(PAD_SVl(ix));
8271 cSVOPo->op_sv = NULL;
8278 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
8279 if (o->op_next->op_private & OPpTARGET_MY) {
8280 if (o->op_flags & OPf_STACKED) /* chained concats */
8281 break; /* ignore_optimization */
8283 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
8284 o->op_targ = o->op_next->op_targ;
8285 o->op_next->op_targ = 0;
8286 o->op_private |= OPpTARGET_MY;
8289 op_null(o->op_next);
8293 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
8294 break; /* Scalar stub must produce undef. List stub is noop */
8298 if (o->op_targ == OP_NEXTSTATE
8299 || o->op_targ == OP_DBSTATE)
8301 PL_curcop = ((COP*)o);
8303 /* XXX: We avoid setting op_seq here to prevent later calls
8304 to peep() from mistakenly concluding that optimisation
8305 has already occurred. This doesn't fix the real problem,
8306 though (See 20010220.007). AMS 20010719 */
8307 /* op_seq functionality is now replaced by op_opt */
8314 if (oldop && o->op_next) {
8315 oldop->op_next = o->op_next;
8323 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
8324 OP* const pop = (o->op_type == OP_PADAV) ?
8325 o->op_next : o->op_next->op_next;
8327 if (pop && pop->op_type == OP_CONST &&
8328 ((PL_op = pop->op_next)) &&
8329 pop->op_next->op_type == OP_AELEM &&
8330 !(pop->op_next->op_private &
8331 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
8332 (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
8337 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
8338 no_bareword_allowed(pop);
8339 if (o->op_type == OP_GV)
8340 op_null(o->op_next);
8341 op_null(pop->op_next);
8343 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
8344 o->op_next = pop->op_next->op_next;
8345 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
8346 o->op_private = (U8)i;
8347 if (o->op_type == OP_GV) {
8352 o->op_flags |= OPf_SPECIAL;
8353 o->op_type = OP_AELEMFAST;
8358 if (o->op_next->op_type == OP_RV2SV) {
8359 if (!(o->op_next->op_private & OPpDEREF)) {
8360 op_null(o->op_next);
8361 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
8363 o->op_next = o->op_next->op_next;
8364 o->op_type = OP_GVSV;
8365 o->op_ppaddr = PL_ppaddr[OP_GVSV];
8368 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
8369 GV * const gv = cGVOPo_gv;
8370 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
8371 /* XXX could check prototype here instead of just carping */
8372 SV * const sv = sv_newmortal();
8373 gv_efullname3(sv, gv, NULL);
8374 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
8375 "%"SVf"() called too early to check prototype",
8379 else if (o->op_next->op_type == OP_READLINE
8380 && o->op_next->op_next->op_type == OP_CONCAT
8381 && (o->op_next->op_next->op_flags & OPf_STACKED))
8383 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
8384 o->op_type = OP_RCATLINE;
8385 o->op_flags |= OPf_STACKED;
8386 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
8387 op_null(o->op_next->op_next);
8388 op_null(o->op_next);
8404 while (cLOGOP->op_other->op_type == OP_NULL)
8405 cLOGOP->op_other = cLOGOP->op_other->op_next;
8406 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
8411 while (cLOOP->op_redoop->op_type == OP_NULL)
8412 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
8413 peep(cLOOP->op_redoop);
8414 while (cLOOP->op_nextop->op_type == OP_NULL)
8415 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
8416 peep(cLOOP->op_nextop);
8417 while (cLOOP->op_lastop->op_type == OP_NULL)
8418 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
8419 peep(cLOOP->op_lastop);
8423 assert(!(cPMOP->op_pmflags & PMf_ONCE));
8424 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
8425 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
8426 cPMOP->op_pmstashstartu.op_pmreplstart
8427 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
8428 peep(cPMOP->op_pmstashstartu.op_pmreplstart);
8432 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
8433 && ckWARN(WARN_SYNTAX))
8435 if (o->op_next->op_sibling) {
8436 const OPCODE type = o->op_next->op_sibling->op_type;
8437 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
8438 const line_t oldline = CopLINE(PL_curcop);
8439 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
8440 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8441 "Statement unlikely to be reached");
8442 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8443 "\t(Maybe you meant system() when you said exec()?)\n");
8444 CopLINE_set(PL_curcop, oldline);
8455 const char *key = NULL;
8458 if (((BINOP*)o)->op_last->op_type != OP_CONST)
8461 /* Make the CONST have a shared SV */
8462 svp = cSVOPx_svp(((BINOP*)o)->op_last);
8463 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
8464 key = SvPV_const(sv, keylen);
8465 lexname = newSVpvn_share(key,
8466 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
8472 if ((o->op_private & (OPpLVAL_INTRO)))
8475 rop = (UNOP*)((BINOP*)o)->op_first;
8476 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
8478 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
8479 if (!SvPAD_TYPED(lexname))
8481 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8482 if (!fields || !GvHV(*fields))
8484 key = SvPV_const(*svp, keylen);
8485 if (!hv_fetch(GvHV(*fields), key,
8486 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8488 Perl_croak(aTHX_ "No such class field \"%s\" "
8489 "in variable %s of type %s",
8490 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
8503 SVOP *first_key_op, *key_op;
8505 if ((o->op_private & (OPpLVAL_INTRO))
8506 /* I bet there's always a pushmark... */
8507 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
8508 /* hmmm, no optimization if list contains only one key. */
8510 rop = (UNOP*)((LISTOP*)o)->op_last;
8511 if (rop->op_type != OP_RV2HV)
8513 if (rop->op_first->op_type == OP_PADSV)
8514 /* @$hash{qw(keys here)} */
8515 rop = (UNOP*)rop->op_first;
8517 /* @{$hash}{qw(keys here)} */
8518 if (rop->op_first->op_type == OP_SCOPE
8519 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
8521 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
8527 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
8528 if (!SvPAD_TYPED(lexname))
8530 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8531 if (!fields || !GvHV(*fields))
8533 /* Again guessing that the pushmark can be jumped over.... */
8534 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
8535 ->op_first->op_sibling;
8536 for (key_op = first_key_op; key_op;
8537 key_op = (SVOP*)key_op->op_sibling) {
8538 if (key_op->op_type != OP_CONST)
8540 svp = cSVOPx_svp(key_op);
8541 key = SvPV_const(*svp, keylen);
8542 if (!hv_fetch(GvHV(*fields), key,
8543 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8545 Perl_croak(aTHX_ "No such class field \"%s\" "
8546 "in variable %s of type %s",
8547 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
8554 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
8558 /* check that RHS of sort is a single plain array */
8559 OP *oright = cUNOPo->op_first;
8560 if (!oright || oright->op_type != OP_PUSHMARK)
8563 /* reverse sort ... can be optimised. */
8564 if (!cUNOPo->op_sibling) {
8565 /* Nothing follows us on the list. */
8566 OP * const reverse = o->op_next;
8568 if (reverse->op_type == OP_REVERSE &&
8569 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
8570 OP * const pushmark = cUNOPx(reverse)->op_first;
8571 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
8572 && (cUNOPx(pushmark)->op_sibling == o)) {
8573 /* reverse -> pushmark -> sort */
8574 o->op_private |= OPpSORT_REVERSE;
8576 pushmark->op_next = oright->op_next;
8582 /* make @a = sort @a act in-place */
8584 oright = cUNOPx(oright)->op_sibling;
8587 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
8588 oright = cUNOPx(oright)->op_sibling;
8592 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
8593 || oright->op_next != o
8594 || (oright->op_private & OPpLVAL_INTRO)
8598 /* o2 follows the chain of op_nexts through the LHS of the
8599 * assign (if any) to the aassign op itself */
8601 if (!o2 || o2->op_type != OP_NULL)
8604 if (!o2 || o2->op_type != OP_PUSHMARK)
8607 if (o2 && o2->op_type == OP_GV)
8610 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
8611 || (o2->op_private & OPpLVAL_INTRO)
8616 if (!o2 || o2->op_type != OP_NULL)
8619 if (!o2 || o2->op_type != OP_AASSIGN
8620 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
8623 /* check that the sort is the first arg on RHS of assign */
8625 o2 = cUNOPx(o2)->op_first;
8626 if (!o2 || o2->op_type != OP_NULL)
8628 o2 = cUNOPx(o2)->op_first;
8629 if (!o2 || o2->op_type != OP_PUSHMARK)
8631 if (o2->op_sibling != o)
8634 /* check the array is the same on both sides */
8635 if (oleft->op_type == OP_RV2AV) {
8636 if (oright->op_type != OP_RV2AV
8637 || !cUNOPx(oright)->op_first
8638 || cUNOPx(oright)->op_first->op_type != OP_GV
8639 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
8640 cGVOPx_gv(cUNOPx(oright)->op_first)
8644 else if (oright->op_type != OP_PADAV
8645 || oright->op_targ != oleft->op_targ
8649 /* transfer MODishness etc from LHS arg to RHS arg */
8650 oright->op_flags = oleft->op_flags;
8651 o->op_private |= OPpSORT_INPLACE;
8653 /* excise push->gv->rv2av->null->aassign */
8654 o2 = o->op_next->op_next;
8655 op_null(o2); /* PUSHMARK */
8657 if (o2->op_type == OP_GV) {
8658 op_null(o2); /* GV */
8661 op_null(o2); /* RV2AV or PADAV */
8662 o2 = o2->op_next->op_next;
8663 op_null(o2); /* AASSIGN */
8665 o->op_next = o2->op_next;
8671 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
8673 LISTOP *enter, *exlist;
8675 enter = (LISTOP *) o->op_next;
8678 if (enter->op_type == OP_NULL) {
8679 enter = (LISTOP *) enter->op_next;
8683 /* for $a (...) will have OP_GV then OP_RV2GV here.
8684 for (...) just has an OP_GV. */
8685 if (enter->op_type == OP_GV) {
8686 gvop = (OP *) enter;
8687 enter = (LISTOP *) enter->op_next;
8690 if (enter->op_type == OP_RV2GV) {
8691 enter = (LISTOP *) enter->op_next;
8697 if (enter->op_type != OP_ENTERITER)
8700 iter = enter->op_next;
8701 if (!iter || iter->op_type != OP_ITER)
8704 expushmark = enter->op_first;
8705 if (!expushmark || expushmark->op_type != OP_NULL
8706 || expushmark->op_targ != OP_PUSHMARK)
8709 exlist = (LISTOP *) expushmark->op_sibling;
8710 if (!exlist || exlist->op_type != OP_NULL
8711 || exlist->op_targ != OP_LIST)
8714 if (exlist->op_last != o) {
8715 /* Mmm. Was expecting to point back to this op. */
8718 theirmark = exlist->op_first;
8719 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
8722 if (theirmark->op_sibling != o) {
8723 /* There's something between the mark and the reverse, eg
8724 for (1, reverse (...))
8729 ourmark = ((LISTOP *)o)->op_first;
8730 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
8733 ourlast = ((LISTOP *)o)->op_last;
8734 if (!ourlast || ourlast->op_next != o)
8737 rv2av = ourmark->op_sibling;
8738 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
8739 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
8740 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
8741 /* We're just reversing a single array. */
8742 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
8743 enter->op_flags |= OPf_STACKED;
8746 /* We don't have control over who points to theirmark, so sacrifice
8748 theirmark->op_next = ourmark->op_next;
8749 theirmark->op_flags = ourmark->op_flags;
8750 ourlast->op_next = gvop ? gvop : (OP *) enter;
8753 enter->op_private |= OPpITER_REVERSED;
8754 iter->op_private |= OPpITER_REVERSED;
8761 UNOP *refgen, *rv2cv;
8764 if ((o->op_flags & OPf_WANT) != OPf_WANT_VOID)
8767 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
8770 rv2gv = ((BINOP *)o)->op_last;
8771 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
8774 refgen = (UNOP *)((BINOP *)o)->op_first;
8776 if (!refgen || refgen->op_type != OP_REFGEN)
8779 exlist = (LISTOP *)refgen->op_first;
8780 if (!exlist || exlist->op_type != OP_NULL
8781 || exlist->op_targ != OP_LIST)
8784 if (exlist->op_first->op_type != OP_PUSHMARK)
8787 rv2cv = (UNOP*)exlist->op_last;
8789 if (rv2cv->op_type != OP_RV2CV)
8792 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
8793 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
8794 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
8796 o->op_private |= OPpASSIGN_CV_TO_GV;
8797 rv2gv->op_private |= OPpDONT_INIT_GV;
8798 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
8806 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
8807 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
8817 Perl_custom_op_name(pTHX_ const OP* o)
8820 const IV index = PTR2IV(o->op_ppaddr);
8824 PERL_ARGS_ASSERT_CUSTOM_OP_NAME;
8826 if (!PL_custom_op_names) /* This probably shouldn't happen */
8827 return (char *)PL_op_name[OP_CUSTOM];
8829 keysv = sv_2mortal(newSViv(index));
8831 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
8833 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
8835 return SvPV_nolen(HeVAL(he));
8839 Perl_custom_op_desc(pTHX_ const OP* o)
8842 const IV index = PTR2IV(o->op_ppaddr);
8846 PERL_ARGS_ASSERT_CUSTOM_OP_DESC;
8848 if (!PL_custom_op_descs)
8849 return (char *)PL_op_desc[OP_CUSTOM];
8851 keysv = sv_2mortal(newSViv(index));
8853 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
8855 return (char *)PL_op_desc[OP_CUSTOM];
8857 return SvPV_nolen(HeVAL(he));
8862 /* Efficient sub that returns a constant scalar value. */
8864 const_sv_xsub(pTHX_ CV* cv)
8871 Perl_croak(aTHX_ "usage: %s::%s()",
8872 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
8876 ST(0) = (SV*)XSANY.any_ptr;
8882 * c-indentation-style: bsd
8884 * indent-tabs-mode: t
8887 * ex: set ts=8 sts=4 sw=4 noet: