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:
583 SvREFCNT_dec(cSVOPo->op_sv);
584 cSVOPo->op_sv = NULL;
587 Even if op_clear does a pad_free for the target of the op,
588 pad_free doesn't actually remove the sv that exists in the pad;
589 instead it lives on. This results in that it could be reused as
590 a target later on when the pad was reallocated.
593 pad_swipe(o->op_targ,1);
602 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
606 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
608 if (cPADOPo->op_padix > 0) {
609 pad_swipe(cPADOPo->op_padix, TRUE);
610 cPADOPo->op_padix = 0;
613 SvREFCNT_dec(cSVOPo->op_sv);
614 cSVOPo->op_sv = NULL;
618 PerlMemShared_free(cPVOPo->op_pv);
619 cPVOPo->op_pv = NULL;
623 op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
627 if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
628 /* No GvIN_PAD_off here, because other references may still
629 * exist on the pad */
630 pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
633 SvREFCNT_dec((SV*)cPMOPo->op_pmreplrootu.op_pmtargetgv);
639 forget_pmop(cPMOPo, 1);
640 cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
641 /* we use the same protection as the "SAFE" version of the PM_ macros
642 * here since sv_clean_all might release some PMOPs
643 * after PL_regex_padav has been cleared
644 * and the clearing of PL_regex_padav needs to
645 * happen before sv_clean_all
648 if(PL_regex_pad) { /* We could be in destruction */
649 const IV offset = (cPMOPo)->op_pmoffset;
650 ReREFCNT_dec(PM_GETRE(cPMOPo));
651 PL_regex_pad[offset] = &PL_sv_undef;
652 sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
656 ReREFCNT_dec(PM_GETRE(cPMOPo));
657 PM_SETRE(cPMOPo, NULL);
663 if (o->op_targ > 0) {
664 pad_free(o->op_targ);
670 S_cop_free(pTHX_ COP* cop)
672 PERL_ARGS_ASSERT_COP_FREE;
677 if (! specialWARN(cop->cop_warnings))
678 PerlMemShared_free(cop->cop_warnings);
679 Perl_refcounted_he_free(aTHX_ cop->cop_hints_hash);
683 S_forget_pmop(pTHX_ PMOP *const o
689 HV * const pmstash = PmopSTASH(o);
691 PERL_ARGS_ASSERT_FORGET_PMOP;
693 if (pmstash && !SvIS_FREED(pmstash)) {
694 MAGIC * const mg = mg_find((SV*)pmstash, PERL_MAGIC_symtab);
696 PMOP **const array = (PMOP**) mg->mg_ptr;
697 U32 count = mg->mg_len / sizeof(PMOP**);
702 /* Found it. Move the entry at the end to overwrite it. */
703 array[i] = array[--count];
704 mg->mg_len = count * sizeof(PMOP**);
705 /* Could realloc smaller at this point always, but probably
706 not worth it. Probably worth free()ing if we're the
709 Safefree(mg->mg_ptr);
726 S_find_and_forget_pmops(pTHX_ OP *o)
728 PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
730 if (o->op_flags & OPf_KIDS) {
731 OP *kid = cUNOPo->op_first;
733 switch (kid->op_type) {
738 forget_pmop((PMOP*)kid, 0);
740 find_and_forget_pmops(kid);
741 kid = kid->op_sibling;
747 Perl_op_null(pTHX_ OP *o)
751 PERL_ARGS_ASSERT_OP_NULL;
753 if (o->op_type == OP_NULL)
757 o->op_targ = o->op_type;
758 o->op_type = OP_NULL;
759 o->op_ppaddr = PL_ppaddr[OP_NULL];
763 Perl_op_refcnt_lock(pTHX)
771 Perl_op_refcnt_unlock(pTHX)
778 /* Contextualizers */
780 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
783 Perl_linklist(pTHX_ OP *o)
787 PERL_ARGS_ASSERT_LINKLIST;
792 /* establish postfix order */
793 first = cUNOPo->op_first;
796 o->op_next = LINKLIST(first);
799 if (kid->op_sibling) {
800 kid->op_next = LINKLIST(kid->op_sibling);
801 kid = kid->op_sibling;
815 Perl_scalarkids(pTHX_ OP *o)
817 if (o && o->op_flags & OPf_KIDS) {
819 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
826 S_scalarboolean(pTHX_ OP *o)
830 PERL_ARGS_ASSERT_SCALARBOOLEAN;
832 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
833 if (ckWARN(WARN_SYNTAX)) {
834 const line_t oldline = CopLINE(PL_curcop);
836 if (PL_parser && PL_parser->copline != NOLINE)
837 CopLINE_set(PL_curcop, PL_parser->copline);
838 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
839 CopLINE_set(PL_curcop, oldline);
846 Perl_scalar(pTHX_ OP *o)
851 /* assumes no premature commitment */
852 if (!o || (PL_parser && PL_parser->error_count)
853 || (o->op_flags & OPf_WANT)
854 || o->op_type == OP_RETURN)
859 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
861 switch (o->op_type) {
863 scalar(cBINOPo->op_first);
868 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
872 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
873 if (!kPMOP->op_pmreplrootu.op_pmreplroot)
874 deprecate_old("implicit split to @_");
882 if (o->op_flags & OPf_KIDS) {
883 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
889 kid = cLISTOPo->op_first;
891 while ((kid = kid->op_sibling)) {
897 PL_curcop = &PL_compiling;
902 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
908 PL_curcop = &PL_compiling;
911 if (ckWARN(WARN_VOID))
912 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
918 Perl_scalarvoid(pTHX_ OP *o)
922 const char* useless = NULL;
926 PERL_ARGS_ASSERT_SCALARVOID;
928 /* trailing mad null ops don't count as "there" for void processing */
930 o->op_type != OP_NULL &&
932 o->op_sibling->op_type == OP_NULL)
935 for (sib = o->op_sibling;
936 sib && sib->op_type == OP_NULL;
937 sib = sib->op_sibling) ;
943 if (o->op_type == OP_NEXTSTATE
944 || o->op_type == OP_DBSTATE
945 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
946 || o->op_targ == OP_DBSTATE)))
947 PL_curcop = (COP*)o; /* for warning below */
949 /* assumes no premature commitment */
950 want = o->op_flags & OPf_WANT;
951 if ((want && want != OPf_WANT_SCALAR)
952 || (PL_parser && PL_parser->error_count)
953 || o->op_type == OP_RETURN)
958 if ((o->op_private & OPpTARGET_MY)
959 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
961 return scalar(o); /* As if inside SASSIGN */
964 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
966 switch (o->op_type) {
968 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
972 if (o->op_flags & OPf_STACKED)
976 if (o->op_private == 4)
1019 case OP_GETSOCKNAME:
1020 case OP_GETPEERNAME:
1025 case OP_GETPRIORITY:
1049 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1050 /* Otherwise it's "Useless use of grep iterator" */
1051 useless = OP_DESC(o);
1055 kid = cUNOPo->op_first;
1056 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1057 kid->op_type != OP_TRANS) {
1060 useless = "negative pattern binding (!~)";
1067 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1068 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1069 useless = "a variable";
1074 if (cSVOPo->op_private & OPpCONST_STRICT)
1075 no_bareword_allowed(o);
1077 if (ckWARN(WARN_VOID)) {
1079 SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_
1080 "a constant (%"SVf")", sv));
1081 useless = SvPV_nolen(msv);
1084 useless = "a constant (undef)";
1085 if (o->op_private & OPpCONST_ARYBASE)
1087 /* don't warn on optimised away booleans, eg
1088 * use constant Foo, 5; Foo || print; */
1089 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1091 /* the constants 0 and 1 are permitted as they are
1092 conventionally used as dummies in constructs like
1093 1 while some_condition_with_side_effects; */
1094 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1096 else if (SvPOK(sv)) {
1097 /* perl4's way of mixing documentation and code
1098 (before the invention of POD) was based on a
1099 trick to mix nroff and perl code. The trick was
1100 built upon these three nroff macros being used in
1101 void context. The pink camel has the details in
1102 the script wrapman near page 319. */
1103 const char * const maybe_macro = SvPVX_const(sv);
1104 if (strnEQ(maybe_macro, "di", 2) ||
1105 strnEQ(maybe_macro, "ds", 2) ||
1106 strnEQ(maybe_macro, "ig", 2))
1111 op_null(o); /* don't execute or even remember it */
1115 o->op_type = OP_PREINC; /* pre-increment is faster */
1116 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1120 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1121 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1125 o->op_type = OP_I_PREINC; /* pre-increment is faster */
1126 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1130 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
1131 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1140 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1145 if (o->op_flags & OPf_STACKED)
1152 if (!(o->op_flags & OPf_KIDS))
1163 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1170 /* all requires must return a boolean value */
1171 o->op_flags &= ~OPf_WANT;
1176 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
1177 if (!kPMOP->op_pmreplrootu.op_pmreplroot)
1178 deprecate_old("implicit split to @_");
1182 if (useless && ckWARN(WARN_VOID))
1183 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
1188 Perl_listkids(pTHX_ OP *o)
1190 if (o && o->op_flags & OPf_KIDS) {
1192 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1199 Perl_list(pTHX_ OP *o)
1204 /* assumes no premature commitment */
1205 if (!o || (o->op_flags & OPf_WANT)
1206 || (PL_parser && PL_parser->error_count)
1207 || o->op_type == OP_RETURN)
1212 if ((o->op_private & OPpTARGET_MY)
1213 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1215 return o; /* As if inside SASSIGN */
1218 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1220 switch (o->op_type) {
1223 list(cBINOPo->op_first);
1228 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1236 if (!(o->op_flags & OPf_KIDS))
1238 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1239 list(cBINOPo->op_first);
1240 return gen_constant_list(o);
1247 kid = cLISTOPo->op_first;
1249 while ((kid = kid->op_sibling)) {
1250 if (kid->op_sibling)
1255 PL_curcop = &PL_compiling;
1259 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1260 if (kid->op_sibling)
1265 PL_curcop = &PL_compiling;
1268 /* all requires must return a boolean value */
1269 o->op_flags &= ~OPf_WANT;
1276 Perl_scalarseq(pTHX_ OP *o)
1280 const OPCODE type = o->op_type;
1282 if (type == OP_LINESEQ || type == OP_SCOPE ||
1283 type == OP_LEAVE || type == OP_LEAVETRY)
1286 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1287 if (kid->op_sibling) {
1291 PL_curcop = &PL_compiling;
1293 o->op_flags &= ~OPf_PARENS;
1294 if (PL_hints & HINT_BLOCK_SCOPE)
1295 o->op_flags |= OPf_PARENS;
1298 o = newOP(OP_STUB, 0);
1303 S_modkids(pTHX_ OP *o, I32 type)
1305 if (o && o->op_flags & OPf_KIDS) {
1307 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1313 /* Propagate lvalue ("modifiable") context to an op and its children.
1314 * 'type' represents the context type, roughly based on the type of op that
1315 * would do the modifying, although local() is represented by OP_NULL.
1316 * It's responsible for detecting things that can't be modified, flag
1317 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
1318 * might have to vivify a reference in $x), and so on.
1320 * For example, "$a+1 = 2" would cause mod() to be called with o being
1321 * OP_ADD and type being OP_SASSIGN, and would output an error.
1325 Perl_mod(pTHX_ OP *o, I32 type)
1329 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1332 if (!o || (PL_parser && PL_parser->error_count))
1335 if ((o->op_private & OPpTARGET_MY)
1336 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1341 switch (o->op_type) {
1347 if (!(o->op_private & OPpCONST_ARYBASE))
1350 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1351 CopARYBASE_set(&PL_compiling,
1352 (I32)SvIV(cSVOPx(PL_eval_start)->op_sv));
1356 SAVECOPARYBASE(&PL_compiling);
1357 CopARYBASE_set(&PL_compiling, 0);
1359 else if (type == OP_REFGEN)
1362 Perl_croak(aTHX_ "That use of $[ is unsupported");
1365 if ((o->op_flags & OPf_PARENS) || PL_madskills)
1369 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1370 !(o->op_flags & OPf_STACKED)) {
1371 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1372 /* The default is to set op_private to the number of children,
1373 which for a UNOP such as RV2CV is always 1. And w're using
1374 the bit for a flag in RV2CV, so we need it clear. */
1375 o->op_private &= ~1;
1376 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1377 assert(cUNOPo->op_first->op_type == OP_NULL);
1378 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1381 else if (o->op_private & OPpENTERSUB_NOMOD)
1383 else { /* lvalue subroutine call */
1384 o->op_private |= OPpLVAL_INTRO;
1385 PL_modcount = RETURN_UNLIMITED_NUMBER;
1386 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1387 /* Backward compatibility mode: */
1388 o->op_private |= OPpENTERSUB_INARGS;
1391 else { /* Compile-time error message: */
1392 OP *kid = cUNOPo->op_first;
1396 if (kid->op_type != OP_PUSHMARK) {
1397 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1399 "panic: unexpected lvalue entersub "
1400 "args: type/targ %ld:%"UVuf,
1401 (long)kid->op_type, (UV)kid->op_targ);
1402 kid = kLISTOP->op_first;
1404 while (kid->op_sibling)
1405 kid = kid->op_sibling;
1406 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1408 if (kid->op_type == OP_METHOD_NAMED
1409 || kid->op_type == OP_METHOD)
1413 NewOp(1101, newop, 1, UNOP);
1414 newop->op_type = OP_RV2CV;
1415 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1416 newop->op_first = NULL;
1417 newop->op_next = (OP*)newop;
1418 kid->op_sibling = (OP*)newop;
1419 newop->op_private |= OPpLVAL_INTRO;
1420 newop->op_private &= ~1;
1424 if (kid->op_type != OP_RV2CV)
1426 "panic: unexpected lvalue entersub "
1427 "entry via type/targ %ld:%"UVuf,
1428 (long)kid->op_type, (UV)kid->op_targ);
1429 kid->op_private |= OPpLVAL_INTRO;
1430 break; /* Postpone until runtime */
1434 kid = kUNOP->op_first;
1435 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1436 kid = kUNOP->op_first;
1437 if (kid->op_type == OP_NULL)
1439 "Unexpected constant lvalue entersub "
1440 "entry via type/targ %ld:%"UVuf,
1441 (long)kid->op_type, (UV)kid->op_targ);
1442 if (kid->op_type != OP_GV) {
1443 /* Restore RV2CV to check lvalueness */
1445 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1446 okid->op_next = kid->op_next;
1447 kid->op_next = okid;
1450 okid->op_next = NULL;
1451 okid->op_type = OP_RV2CV;
1453 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1454 okid->op_private |= OPpLVAL_INTRO;
1455 okid->op_private &= ~1;
1459 cv = GvCV(kGVOP_gv);
1469 /* grep, foreach, subcalls, refgen */
1470 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1472 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1473 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1475 : (o->op_type == OP_ENTERSUB
1476 ? "non-lvalue subroutine call"
1478 type ? PL_op_desc[type] : "local"));
1492 case OP_RIGHT_SHIFT:
1501 if (!(o->op_flags & OPf_STACKED))
1508 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1514 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1515 PL_modcount = RETURN_UNLIMITED_NUMBER;
1516 return o; /* Treat \(@foo) like ordinary list. */
1520 if (scalar_mod_type(o, type))
1522 ref(cUNOPo->op_first, o->op_type);
1526 if (type == OP_LEAVESUBLV)
1527 o->op_private |= OPpMAYBE_LVSUB;
1533 PL_modcount = RETURN_UNLIMITED_NUMBER;
1536 ref(cUNOPo->op_first, o->op_type);
1541 PL_hints |= HINT_BLOCK_SCOPE;
1556 PL_modcount = RETURN_UNLIMITED_NUMBER;
1557 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1558 return o; /* Treat \(@foo) like ordinary list. */
1559 if (scalar_mod_type(o, type))
1561 if (type == OP_LEAVESUBLV)
1562 o->op_private |= OPpMAYBE_LVSUB;
1566 if (!type) /* local() */
1567 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1568 PAD_COMPNAME_PV(o->op_targ));
1576 if (type != OP_SASSIGN)
1580 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1585 if (type == OP_LEAVESUBLV)
1586 o->op_private |= OPpMAYBE_LVSUB;
1588 pad_free(o->op_targ);
1589 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1590 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1591 if (o->op_flags & OPf_KIDS)
1592 mod(cBINOPo->op_first->op_sibling, type);
1597 ref(cBINOPo->op_first, o->op_type);
1598 if (type == OP_ENTERSUB &&
1599 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1600 o->op_private |= OPpLVAL_DEFER;
1601 if (type == OP_LEAVESUBLV)
1602 o->op_private |= OPpMAYBE_LVSUB;
1612 if (o->op_flags & OPf_KIDS)
1613 mod(cLISTOPo->op_last, type);
1618 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1620 else if (!(o->op_flags & OPf_KIDS))
1622 if (o->op_targ != OP_LIST) {
1623 mod(cBINOPo->op_first, type);
1629 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1634 if (type != OP_LEAVESUBLV)
1636 break; /* mod()ing was handled by ck_return() */
1639 /* [20011101.069] File test operators interpret OPf_REF to mean that
1640 their argument is a filehandle; thus \stat(".") should not set
1642 if (type == OP_REFGEN &&
1643 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1646 if (type != OP_LEAVESUBLV)
1647 o->op_flags |= OPf_MOD;
1649 if (type == OP_AASSIGN || type == OP_SASSIGN)
1650 o->op_flags |= OPf_SPECIAL|OPf_REF;
1651 else if (!type) { /* local() */
1654 o->op_private |= OPpLVAL_INTRO;
1655 o->op_flags &= ~OPf_SPECIAL;
1656 PL_hints |= HINT_BLOCK_SCOPE;
1661 if (ckWARN(WARN_SYNTAX)) {
1662 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1663 "Useless localization of %s", OP_DESC(o));
1667 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1668 && type != OP_LEAVESUBLV)
1669 o->op_flags |= OPf_REF;
1674 S_scalar_mod_type(const OP *o, I32 type)
1676 PERL_ARGS_ASSERT_SCALAR_MOD_TYPE;
1680 if (o->op_type == OP_RV2GV)
1704 case OP_RIGHT_SHIFT:
1724 S_is_handle_constructor(const OP *o, I32 numargs)
1726 PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
1728 switch (o->op_type) {
1736 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1749 Perl_refkids(pTHX_ OP *o, I32 type)
1751 if (o && o->op_flags & OPf_KIDS) {
1753 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1760 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
1765 PERL_ARGS_ASSERT_DOREF;
1767 if (!o || (PL_parser && PL_parser->error_count))
1770 switch (o->op_type) {
1772 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1773 !(o->op_flags & OPf_STACKED)) {
1774 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1775 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1776 assert(cUNOPo->op_first->op_type == OP_NULL);
1777 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1778 o->op_flags |= OPf_SPECIAL;
1779 o->op_private &= ~1;
1784 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1785 doref(kid, type, set_op_ref);
1788 if (type == OP_DEFINED)
1789 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1790 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1793 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1794 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1795 : type == OP_RV2HV ? OPpDEREF_HV
1797 o->op_flags |= OPf_MOD;
1804 o->op_flags |= OPf_REF;
1807 if (type == OP_DEFINED)
1808 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1809 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1815 o->op_flags |= OPf_REF;
1820 if (!(o->op_flags & OPf_KIDS))
1822 doref(cBINOPo->op_first, type, set_op_ref);
1826 doref(cBINOPo->op_first, o->op_type, set_op_ref);
1827 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1828 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1829 : type == OP_RV2HV ? OPpDEREF_HV
1831 o->op_flags |= OPf_MOD;
1841 if (!(o->op_flags & OPf_KIDS))
1843 doref(cLISTOPo->op_last, type, set_op_ref);
1853 S_dup_attrlist(pTHX_ OP *o)
1858 PERL_ARGS_ASSERT_DUP_ATTRLIST;
1860 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1861 * where the first kid is OP_PUSHMARK and the remaining ones
1862 * are OP_CONST. We need to push the OP_CONST values.
1864 if (o->op_type == OP_CONST)
1865 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
1867 else if (o->op_type == OP_NULL)
1871 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1873 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1874 if (o->op_type == OP_CONST)
1875 rop = append_elem(OP_LIST, rop,
1876 newSVOP(OP_CONST, o->op_flags,
1877 SvREFCNT_inc_NN(cSVOPo->op_sv)));
1884 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1889 PERL_ARGS_ASSERT_APPLY_ATTRS;
1891 /* fake up C<use attributes $pkg,$rv,@attrs> */
1892 ENTER; /* need to protect against side-effects of 'use' */
1893 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1895 #define ATTRSMODULE "attributes"
1896 #define ATTRSMODULE_PM "attributes.pm"
1899 /* Don't force the C<use> if we don't need it. */
1900 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
1901 if (svp && *svp != &PL_sv_undef)
1902 NOOP; /* already in %INC */
1904 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1905 newSVpvs(ATTRSMODULE), NULL);
1908 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1909 newSVpvs(ATTRSMODULE),
1911 prepend_elem(OP_LIST,
1912 newSVOP(OP_CONST, 0, stashsv),
1913 prepend_elem(OP_LIST,
1914 newSVOP(OP_CONST, 0,
1916 dup_attrlist(attrs))));
1922 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1925 OP *pack, *imop, *arg;
1928 PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
1933 assert(target->op_type == OP_PADSV ||
1934 target->op_type == OP_PADHV ||
1935 target->op_type == OP_PADAV);
1937 /* Ensure that attributes.pm is loaded. */
1938 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1940 /* Need package name for method call. */
1941 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
1943 /* Build up the real arg-list. */
1944 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1946 arg = newOP(OP_PADSV, 0);
1947 arg->op_targ = target->op_targ;
1948 arg = prepend_elem(OP_LIST,
1949 newSVOP(OP_CONST, 0, stashsv),
1950 prepend_elem(OP_LIST,
1951 newUNOP(OP_REFGEN, 0,
1952 mod(arg, OP_REFGEN)),
1953 dup_attrlist(attrs)));
1955 /* Fake up a method call to import */
1956 meth = newSVpvs_share("import");
1957 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1958 append_elem(OP_LIST,
1959 prepend_elem(OP_LIST, pack, list(arg)),
1960 newSVOP(OP_METHOD_NAMED, 0, meth)));
1961 imop->op_private |= OPpENTERSUB_NOMOD;
1963 /* Combine the ops. */
1964 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1968 =notfor apidoc apply_attrs_string
1970 Attempts to apply a list of attributes specified by the C<attrstr> and
1971 C<len> arguments to the subroutine identified by the C<cv> argument which
1972 is expected to be associated with the package identified by the C<stashpv>
1973 argument (see L<attributes>). It gets this wrong, though, in that it
1974 does not correctly identify the boundaries of the individual attribute
1975 specifications within C<attrstr>. This is not really intended for the
1976 public API, but has to be listed here for systems such as AIX which
1977 need an explicit export list for symbols. (It's called from XS code
1978 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1979 to respect attribute syntax properly would be welcome.
1985 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
1986 const char *attrstr, STRLEN len)
1990 PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
1993 len = strlen(attrstr);
1997 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1999 const char * const sstr = attrstr;
2000 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2001 attrs = append_elem(OP_LIST, attrs,
2002 newSVOP(OP_CONST, 0,
2003 newSVpvn(sstr, attrstr-sstr)));
2007 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2008 newSVpvs(ATTRSMODULE),
2009 NULL, prepend_elem(OP_LIST,
2010 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2011 prepend_elem(OP_LIST,
2012 newSVOP(OP_CONST, 0,
2018 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
2023 PERL_ARGS_ASSERT_MY_KID;
2025 if (!o || (PL_parser && PL_parser->error_count))
2029 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
2030 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
2034 if (type == OP_LIST) {
2036 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2037 my_kid(kid, attrs, imopsp);
2038 } else if (type == OP_UNDEF
2044 } else if (type == OP_RV2SV || /* "our" declaration */
2046 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
2047 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
2048 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2050 PL_parser->in_my == KEY_our
2052 : PL_parser->in_my == KEY_state ? "state" : "my"));
2054 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
2055 PL_parser->in_my = FALSE;
2056 PL_parser->in_my_stash = NULL;
2057 apply_attrs(GvSTASH(gv),
2058 (type == OP_RV2SV ? GvSV(gv) :
2059 type == OP_RV2AV ? (SV*)GvAV(gv) :
2060 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
2063 o->op_private |= OPpOUR_INTRO;
2066 else if (type != OP_PADSV &&
2069 type != OP_PUSHMARK)
2071 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2073 PL_parser->in_my == KEY_our
2075 : PL_parser->in_my == KEY_state ? "state" : "my"));
2078 else if (attrs && type != OP_PUSHMARK) {
2081 PL_parser->in_my = FALSE;
2082 PL_parser->in_my_stash = NULL;
2084 /* check for C<my Dog $spot> when deciding package */
2085 stash = PAD_COMPNAME_TYPE(o->op_targ);
2087 stash = PL_curstash;
2088 apply_attrs_my(stash, o, attrs, imopsp);
2090 o->op_flags |= OPf_MOD;
2091 o->op_private |= OPpLVAL_INTRO;
2092 if (PL_parser->in_my == KEY_state)
2093 o->op_private |= OPpPAD_STATE;
2098 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2102 int maybe_scalar = 0;
2104 PERL_ARGS_ASSERT_MY_ATTRS;
2106 /* [perl #17376]: this appears to be premature, and results in code such as
2107 C< our(%x); > executing in list mode rather than void mode */
2109 if (o->op_flags & OPf_PARENS)
2119 o = my_kid(o, attrs, &rops);
2121 if (maybe_scalar && o->op_type == OP_PADSV) {
2122 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
2123 o->op_private |= OPpLVAL_INTRO;
2126 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
2128 PL_parser->in_my = FALSE;
2129 PL_parser->in_my_stash = NULL;
2134 Perl_my(pTHX_ OP *o)
2136 PERL_ARGS_ASSERT_MY;
2138 return my_attrs(o, NULL);
2142 Perl_sawparens(pTHX_ OP *o)
2144 PERL_UNUSED_CONTEXT;
2146 o->op_flags |= OPf_PARENS;
2151 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2155 const OPCODE ltype = left->op_type;
2156 const OPCODE rtype = right->op_type;
2158 PERL_ARGS_ASSERT_BIND_MATCH;
2160 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2161 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
2163 const char * const desc
2164 = PL_op_desc[(rtype == OP_SUBST || rtype == OP_TRANS)
2165 ? (int)rtype : OP_MATCH];
2166 const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV)
2167 ? "@array" : "%hash");
2168 Perl_warner(aTHX_ packWARN(WARN_MISC),
2169 "Applying %s to %s will act on scalar(%s)",
2170 desc, sample, sample);
2173 if (rtype == OP_CONST &&
2174 cSVOPx(right)->op_private & OPpCONST_BARE &&
2175 cSVOPx(right)->op_private & OPpCONST_STRICT)
2177 no_bareword_allowed(right);
2180 ismatchop = rtype == OP_MATCH ||
2181 rtype == OP_SUBST ||
2183 if (ismatchop && right->op_private & OPpTARGET_MY) {
2185 right->op_private &= ~OPpTARGET_MY;
2187 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
2190 right->op_flags |= OPf_STACKED;
2191 if (rtype != OP_MATCH &&
2192 ! (rtype == OP_TRANS &&
2193 right->op_private & OPpTRANS_IDENTICAL))
2194 newleft = mod(left, rtype);
2197 if (right->op_type == OP_TRANS)
2198 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
2200 o = prepend_elem(rtype, scalar(newleft), right);
2202 return newUNOP(OP_NOT, 0, scalar(o));
2206 return bind_match(type, left,
2207 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
2211 Perl_invert(pTHX_ OP *o)
2215 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2219 Perl_scope(pTHX_ OP *o)
2223 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2224 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2225 o->op_type = OP_LEAVE;
2226 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2228 else if (o->op_type == OP_LINESEQ) {
2230 o->op_type = OP_SCOPE;
2231 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2232 kid = ((LISTOP*)o)->op_first;
2233 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2236 /* The following deals with things like 'do {1 for 1}' */
2237 kid = kid->op_sibling;
2239 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2244 o = newLISTOP(OP_SCOPE, 0, o, NULL);
2250 Perl_block_start(pTHX_ int full)
2253 const int retval = PL_savestack_ix;
2254 pad_block_start(full);
2256 PL_hints &= ~HINT_BLOCK_SCOPE;
2257 SAVECOMPILEWARNINGS();
2258 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
2263 Perl_block_end(pTHX_ I32 floor, OP *seq)
2266 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2267 OP* const retval = scalarseq(seq);
2269 CopHINTS_set(&PL_compiling, PL_hints);
2271 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2280 const PADOFFSET offset = pad_findmy("$_");
2281 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
2282 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2285 OP * const o = newOP(OP_PADSV, 0);
2286 o->op_targ = offset;
2292 Perl_newPROG(pTHX_ OP *o)
2296 PERL_ARGS_ASSERT_NEWPROG;
2301 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2302 ((PL_in_eval & EVAL_KEEPERR)
2303 ? OPf_SPECIAL : 0), o);
2304 PL_eval_start = linklist(PL_eval_root);
2305 PL_eval_root->op_private |= OPpREFCOUNTED;
2306 OpREFCNT_set(PL_eval_root, 1);
2307 PL_eval_root->op_next = 0;
2308 CALL_PEEP(PL_eval_start);
2311 if (o->op_type == OP_STUB) {
2312 PL_comppad_name = 0;
2314 S_op_destroy(aTHX_ o);
2317 PL_main_root = scope(sawparens(scalarvoid(o)));
2318 PL_curcop = &PL_compiling;
2319 PL_main_start = LINKLIST(PL_main_root);
2320 PL_main_root->op_private |= OPpREFCOUNTED;
2321 OpREFCNT_set(PL_main_root, 1);
2322 PL_main_root->op_next = 0;
2323 CALL_PEEP(PL_main_start);
2326 /* Register with debugger */
2329 = Perl_get_cvn_flags(aTHX_ STR_WITH_LEN("DB::postponed"), 0);
2333 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2335 call_sv((SV*)cv, G_DISCARD);
2342 Perl_localize(pTHX_ OP *o, I32 lex)
2346 PERL_ARGS_ASSERT_LOCALIZE;
2348 if (o->op_flags & OPf_PARENS)
2349 /* [perl #17376]: this appears to be premature, and results in code such as
2350 C< our(%x); > executing in list mode rather than void mode */
2357 if ( PL_parser->bufptr > PL_parser->oldbufptr
2358 && PL_parser->bufptr[-1] == ','
2359 && ckWARN(WARN_PARENTHESIS))
2361 char *s = PL_parser->bufptr;
2364 /* some heuristics to detect a potential error */
2365 while (*s && (strchr(", \t\n", *s)))
2369 if (*s && strchr("@$%*", *s) && *++s
2370 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2373 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2375 while (*s && (strchr(", \t\n", *s)))
2381 if (sigil && (*s == ';' || *s == '=')) {
2382 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2383 "Parentheses missing around \"%s\" list",
2385 ? (PL_parser->in_my == KEY_our
2387 : PL_parser->in_my == KEY_state
2397 o = mod(o, OP_NULL); /* a bit kludgey */
2398 PL_parser->in_my = FALSE;
2399 PL_parser->in_my_stash = NULL;
2404 Perl_jmaybe(pTHX_ OP *o)
2406 PERL_ARGS_ASSERT_JMAYBE;
2408 if (o->op_type == OP_LIST) {
2410 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2411 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2417 Perl_fold_constants(pTHX_ register OP *o)
2420 register OP * VOL curop;
2422 VOL I32 type = o->op_type;
2427 SV * const oldwarnhook = PL_warnhook;
2428 SV * const olddiehook = PL_diehook;
2431 PERL_ARGS_ASSERT_FOLD_CONSTANTS;
2433 if (PL_opargs[type] & OA_RETSCALAR)
2435 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2436 o->op_targ = pad_alloc(type, SVs_PADTMP);
2438 /* integerize op, unless it happens to be C<-foo>.
2439 * XXX should pp_i_negate() do magic string negation instead? */
2440 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2441 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2442 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2444 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2447 if (!(PL_opargs[type] & OA_FOLDCONST))
2452 /* XXX might want a ck_negate() for this */
2453 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2464 /* XXX what about the numeric ops? */
2465 if (PL_hints & HINT_LOCALE)
2469 if (PL_parser && PL_parser->error_count)
2470 goto nope; /* Don't try to run w/ errors */
2472 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2473 const OPCODE type = curop->op_type;
2474 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2476 type != OP_SCALAR &&
2478 type != OP_PUSHMARK)
2484 curop = LINKLIST(o);
2485 old_next = o->op_next;
2489 oldscope = PL_scopestack_ix;
2490 create_eval_scope(G_FAKINGEVAL);
2492 PL_warnhook = PERL_WARNHOOK_FATAL;
2499 sv = *(PL_stack_sp--);
2500 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2501 pad_swipe(o->op_targ, FALSE);
2502 else if (SvTEMP(sv)) { /* grab mortal temp? */
2503 SvREFCNT_inc_simple_void(sv);
2508 /* Something tried to die. Abandon constant folding. */
2509 /* Pretend the error never happened. */
2510 sv_setpvn(ERRSV,"",0);
2511 o->op_next = old_next;
2515 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
2516 PL_warnhook = oldwarnhook;
2517 PL_diehook = olddiehook;
2518 /* XXX note that this croak may fail as we've already blown away
2519 * the stack - eg any nested evals */
2520 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
2523 PL_warnhook = oldwarnhook;
2524 PL_diehook = olddiehook;
2526 if (PL_scopestack_ix > oldscope)
2527 delete_eval_scope();
2536 if (type == OP_RV2GV)
2537 newop = newGVOP(OP_GV, 0, (GV*)sv);
2539 newop = newSVOP(OP_CONST, 0, (SV*)sv);
2540 op_getmad(o,newop,'f');
2548 Perl_gen_constant_list(pTHX_ register OP *o)
2552 const I32 oldtmps_floor = PL_tmps_floor;
2555 if (PL_parser && PL_parser->error_count)
2556 return o; /* Don't attempt to run with errors */
2558 PL_op = curop = LINKLIST(o);
2564 assert (!(curop->op_flags & OPf_SPECIAL));
2565 assert(curop->op_type == OP_RANGE);
2567 PL_tmps_floor = oldtmps_floor;
2569 o->op_type = OP_RV2AV;
2570 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2571 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2572 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2573 o->op_opt = 0; /* needs to be revisited in peep() */
2574 curop = ((UNOP*)o)->op_first;
2575 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
2577 op_getmad(curop,o,'O');
2586 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2589 if (!o || o->op_type != OP_LIST)
2590 o = newLISTOP(OP_LIST, 0, o, NULL);
2592 o->op_flags &= ~OPf_WANT;
2594 if (!(PL_opargs[type] & OA_MARK))
2595 op_null(cLISTOPo->op_first);
2597 o->op_type = (OPCODE)type;
2598 o->op_ppaddr = PL_ppaddr[type];
2599 o->op_flags |= flags;
2601 o = CHECKOP(type, o);
2602 if (o->op_type != (unsigned)type)
2605 return fold_constants(o);
2608 /* List constructors */
2611 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2619 if (first->op_type != (unsigned)type
2620 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2622 return newLISTOP(type, 0, first, last);
2625 if (first->op_flags & OPf_KIDS)
2626 ((LISTOP*)first)->op_last->op_sibling = last;
2628 first->op_flags |= OPf_KIDS;
2629 ((LISTOP*)first)->op_first = last;
2631 ((LISTOP*)first)->op_last = last;
2636 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2644 if (first->op_type != (unsigned)type)
2645 return prepend_elem(type, (OP*)first, (OP*)last);
2647 if (last->op_type != (unsigned)type)
2648 return append_elem(type, (OP*)first, (OP*)last);
2650 first->op_last->op_sibling = last->op_first;
2651 first->op_last = last->op_last;
2652 first->op_flags |= (last->op_flags & OPf_KIDS);
2655 if (last->op_first && first->op_madprop) {
2656 MADPROP *mp = last->op_first->op_madprop;
2658 while (mp->mad_next)
2660 mp->mad_next = first->op_madprop;
2663 last->op_first->op_madprop = first->op_madprop;
2666 first->op_madprop = last->op_madprop;
2667 last->op_madprop = 0;
2670 S_op_destroy(aTHX_ (OP*)last);
2676 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2684 if (last->op_type == (unsigned)type) {
2685 if (type == OP_LIST) { /* already a PUSHMARK there */
2686 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2687 ((LISTOP*)last)->op_first->op_sibling = first;
2688 if (!(first->op_flags & OPf_PARENS))
2689 last->op_flags &= ~OPf_PARENS;
2692 if (!(last->op_flags & OPf_KIDS)) {
2693 ((LISTOP*)last)->op_last = first;
2694 last->op_flags |= OPf_KIDS;
2696 first->op_sibling = ((LISTOP*)last)->op_first;
2697 ((LISTOP*)last)->op_first = first;
2699 last->op_flags |= OPf_KIDS;
2703 return newLISTOP(type, 0, first, last);
2711 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2714 Newxz(tk, 1, TOKEN);
2715 tk->tk_type = (OPCODE)optype;
2716 tk->tk_type = 12345;
2718 tk->tk_mad = madprop;
2723 Perl_token_free(pTHX_ TOKEN* tk)
2725 PERL_ARGS_ASSERT_TOKEN_FREE;
2727 if (tk->tk_type != 12345)
2729 mad_free(tk->tk_mad);
2734 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2739 PERL_ARGS_ASSERT_TOKEN_GETMAD;
2741 if (tk->tk_type != 12345) {
2742 Perl_warner(aTHX_ packWARN(WARN_MISC),
2743 "Invalid TOKEN object ignored");
2750 /* faked up qw list? */
2752 tm->mad_type == MAD_SV &&
2753 SvPVX((SV*)tm->mad_val)[0] == 'q')
2760 /* pretend constant fold didn't happen? */
2761 if (mp->mad_key == 'f' &&
2762 (o->op_type == OP_CONST ||
2763 o->op_type == OP_GV) )
2765 token_getmad(tk,(OP*)mp->mad_val,slot);
2779 if (mp->mad_key == 'X')
2780 mp->mad_key = slot; /* just change the first one */
2790 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
2799 /* pretend constant fold didn't happen? */
2800 if (mp->mad_key == 'f' &&
2801 (o->op_type == OP_CONST ||
2802 o->op_type == OP_GV) )
2804 op_getmad(from,(OP*)mp->mad_val,slot);
2811 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
2814 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
2820 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
2829 /* pretend constant fold didn't happen? */
2830 if (mp->mad_key == 'f' &&
2831 (o->op_type == OP_CONST ||
2832 o->op_type == OP_GV) )
2834 op_getmad(from,(OP*)mp->mad_val,slot);
2841 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
2844 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
2848 PerlIO_printf(PerlIO_stderr(),
2849 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
2855 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
2873 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
2877 addmad(tm, &(o->op_madprop), slot);
2881 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
2902 Perl_newMADsv(pTHX_ char key, SV* sv)
2904 PERL_ARGS_ASSERT_NEWMADSV;
2906 return newMADPROP(key, MAD_SV, sv, 0);
2910 Perl_newMADPROP(pTHX_ char key, char type, const void* val, I32 vlen)
2913 Newxz(mp, 1, MADPROP);
2916 mp->mad_vlen = vlen;
2917 mp->mad_type = type;
2919 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
2924 Perl_mad_free(pTHX_ MADPROP* mp)
2926 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
2930 mad_free(mp->mad_next);
2931 /* if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
2932 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
2933 switch (mp->mad_type) {
2937 Safefree((char*)mp->mad_val);
2940 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
2941 op_free((OP*)mp->mad_val);
2944 sv_free((SV*)mp->mad_val);
2947 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
2956 Perl_newNULLLIST(pTHX)
2958 return newOP(OP_STUB, 0);
2962 Perl_force_list(pTHX_ OP *o)
2964 if (!o || o->op_type != OP_LIST)
2965 o = newLISTOP(OP_LIST, 0, o, NULL);
2971 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2976 NewOp(1101, listop, 1, LISTOP);
2978 listop->op_type = (OPCODE)type;
2979 listop->op_ppaddr = PL_ppaddr[type];
2982 listop->op_flags = (U8)flags;
2986 else if (!first && last)
2989 first->op_sibling = last;
2990 listop->op_first = first;
2991 listop->op_last = last;
2992 if (type == OP_LIST) {
2993 OP* const pushop = newOP(OP_PUSHMARK, 0);
2994 pushop->op_sibling = first;
2995 listop->op_first = pushop;
2996 listop->op_flags |= OPf_KIDS;
2998 listop->op_last = pushop;
3001 return CHECKOP(type, listop);
3005 Perl_newOP(pTHX_ I32 type, I32 flags)
3009 NewOp(1101, o, 1, OP);
3010 o->op_type = (OPCODE)type;
3011 o->op_ppaddr = PL_ppaddr[type];
3012 o->op_flags = (U8)flags;
3014 o->op_latefreed = 0;
3018 o->op_private = (U8)(0 | (flags >> 8));
3019 if (PL_opargs[type] & OA_RETSCALAR)
3021 if (PL_opargs[type] & OA_TARGET)
3022 o->op_targ = pad_alloc(type, SVs_PADTMP);
3023 return CHECKOP(type, o);
3027 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
3033 first = newOP(OP_STUB, 0);
3034 if (PL_opargs[type] & OA_MARK)
3035 first = force_list(first);
3037 NewOp(1101, unop, 1, UNOP);
3038 unop->op_type = (OPCODE)type;
3039 unop->op_ppaddr = PL_ppaddr[type];
3040 unop->op_first = first;
3041 unop->op_flags = (U8)(flags | OPf_KIDS);
3042 unop->op_private = (U8)(1 | (flags >> 8));
3043 unop = (UNOP*) CHECKOP(type, unop);
3047 return fold_constants((OP *) unop);
3051 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3055 NewOp(1101, binop, 1, BINOP);
3058 first = newOP(OP_NULL, 0);
3060 binop->op_type = (OPCODE)type;
3061 binop->op_ppaddr = PL_ppaddr[type];
3062 binop->op_first = first;
3063 binop->op_flags = (U8)(flags | OPf_KIDS);
3066 binop->op_private = (U8)(1 | (flags >> 8));
3069 binop->op_private = (U8)(2 | (flags >> 8));
3070 first->op_sibling = last;
3073 binop = (BINOP*)CHECKOP(type, binop);
3074 if (binop->op_next || binop->op_type != (OPCODE)type)
3077 binop->op_last = binop->op_first->op_sibling;
3079 return fold_constants((OP *)binop);
3082 static int uvcompare(const void *a, const void *b)
3083 __attribute__nonnull__(1)
3084 __attribute__nonnull__(2)
3085 __attribute__pure__;
3086 static int uvcompare(const void *a, const void *b)
3088 if (*((const UV *)a) < (*(const UV *)b))
3090 if (*((const UV *)a) > (*(const UV *)b))
3092 if (*((const UV *)a+1) < (*(const UV *)b+1))
3094 if (*((const UV *)a+1) > (*(const UV *)b+1))
3100 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
3103 SV * const tstr = ((SVOP*)expr)->op_sv;
3106 (repl->op_type == OP_NULL)
3107 ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
3109 ((SVOP*)repl)->op_sv;
3112 const U8 *t = (U8*)SvPV_const(tstr, tlen);
3113 const U8 *r = (U8*)SvPV_const(rstr, rlen);
3117 register short *tbl;
3119 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
3120 const I32 squash = o->op_private & OPpTRANS_SQUASH;
3121 I32 del = o->op_private & OPpTRANS_DELETE;
3124 PERL_ARGS_ASSERT_PMTRANS;
3126 PL_hints |= HINT_BLOCK_SCOPE;
3129 o->op_private |= OPpTRANS_FROM_UTF;
3132 o->op_private |= OPpTRANS_TO_UTF;
3134 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
3135 SV* const listsv = newSVpvs("# comment\n");
3137 const U8* tend = t + tlen;
3138 const U8* rend = r + rlen;
3152 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
3153 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
3156 const U32 flags = UTF8_ALLOW_DEFAULT;
3160 t = tsave = bytes_to_utf8(t, &len);
3163 if (!to_utf && rlen) {
3165 r = rsave = bytes_to_utf8(r, &len);
3169 /* There are several snags with this code on EBCDIC:
3170 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
3171 2. scan_const() in toke.c has encoded chars in native encoding which makes
3172 ranges at least in EBCDIC 0..255 range the bottom odd.
3176 U8 tmpbuf[UTF8_MAXBYTES+1];
3179 Newx(cp, 2*tlen, UV);
3181 transv = newSVpvs("");
3183 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3185 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
3187 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3191 cp[2*i+1] = cp[2*i];
3195 qsort(cp, i, 2*sizeof(UV), uvcompare);
3196 for (j = 0; j < i; j++) {
3198 diff = val - nextmin;
3200 t = uvuni_to_utf8(tmpbuf,nextmin);
3201 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3203 U8 range_mark = UTF_TO_NATIVE(0xff);
3204 t = uvuni_to_utf8(tmpbuf, val - 1);
3205 sv_catpvn(transv, (char *)&range_mark, 1);
3206 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3213 t = uvuni_to_utf8(tmpbuf,nextmin);
3214 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3216 U8 range_mark = UTF_TO_NATIVE(0xff);
3217 sv_catpvn(transv, (char *)&range_mark, 1);
3219 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
3220 UNICODE_ALLOW_SUPER);
3221 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3222 t = (const U8*)SvPVX_const(transv);
3223 tlen = SvCUR(transv);
3227 else if (!rlen && !del) {
3228 r = t; rlen = tlen; rend = tend;
3231 if ((!rlen && !del) || t == r ||
3232 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
3234 o->op_private |= OPpTRANS_IDENTICAL;
3238 while (t < tend || tfirst <= tlast) {
3239 /* see if we need more "t" chars */
3240 if (tfirst > tlast) {
3241 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3243 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
3245 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3252 /* now see if we need more "r" chars */
3253 if (rfirst > rlast) {
3255 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3257 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
3259 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3268 rfirst = rlast = 0xffffffff;
3272 /* now see which range will peter our first, if either. */
3273 tdiff = tlast - tfirst;
3274 rdiff = rlast - rfirst;
3281 if (rfirst == 0xffffffff) {
3282 diff = tdiff; /* oops, pretend rdiff is infinite */
3284 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
3285 (long)tfirst, (long)tlast);
3287 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
3291 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
3292 (long)tfirst, (long)(tfirst + diff),
3295 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3296 (long)tfirst, (long)rfirst);
3298 if (rfirst + diff > max)
3299 max = rfirst + diff;
3301 grows = (tfirst < rfirst &&
3302 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3314 else if (max > 0xff)
3319 PerlMemShared_free(cPVOPo->op_pv);
3320 cPVOPo->op_pv = NULL;
3322 swash = (SV*)swash_init("utf8", "", listsv, bits, none);
3324 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
3325 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
3326 PAD_SETSV(cPADOPo->op_padix, swash);
3329 cSVOPo->op_sv = swash;
3331 SvREFCNT_dec(listsv);
3332 SvREFCNT_dec(transv);
3334 if (!del && havefinal && rlen)
3335 (void)hv_store((HV*)SvRV(swash), "FINAL", 5,
3336 newSVuv((UV)final), 0);
3339 o->op_private |= OPpTRANS_GROWS;
3345 op_getmad(expr,o,'e');
3346 op_getmad(repl,o,'r');
3354 tbl = (short*)cPVOPo->op_pv;
3356 Zero(tbl, 256, short);
3357 for (i = 0; i < (I32)tlen; i++)
3359 for (i = 0, j = 0; i < 256; i++) {
3361 if (j >= (I32)rlen) {
3370 if (i < 128 && r[j] >= 128)
3380 o->op_private |= OPpTRANS_IDENTICAL;
3382 else if (j >= (I32)rlen)
3387 PerlMemShared_realloc(tbl,
3388 (0x101+rlen-j) * sizeof(short));
3389 cPVOPo->op_pv = (char*)tbl;
3391 tbl[0x100] = (short)(rlen - j);
3392 for (i=0; i < (I32)rlen - j; i++)
3393 tbl[0x101+i] = r[j+i];
3397 if (!rlen && !del) {
3400 o->op_private |= OPpTRANS_IDENTICAL;
3402 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3403 o->op_private |= OPpTRANS_IDENTICAL;
3405 for (i = 0; i < 256; i++)
3407 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3408 if (j >= (I32)rlen) {
3410 if (tbl[t[i]] == -1)
3416 if (tbl[t[i]] == -1) {
3417 if (t[i] < 128 && r[j] >= 128)
3424 o->op_private |= OPpTRANS_GROWS;
3426 op_getmad(expr,o,'e');
3427 op_getmad(repl,o,'r');
3437 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3442 NewOp(1101, pmop, 1, PMOP);
3443 pmop->op_type = (OPCODE)type;
3444 pmop->op_ppaddr = PL_ppaddr[type];
3445 pmop->op_flags = (U8)flags;
3446 pmop->op_private = (U8)(0 | (flags >> 8));
3448 if (PL_hints & HINT_RE_TAINT)
3449 pmop->op_pmflags |= PMf_RETAINT;
3450 if (PL_hints & HINT_LOCALE)
3451 pmop->op_pmflags |= PMf_LOCALE;
3455 assert(SvPOK(PL_regex_pad[0]));
3456 if (SvCUR(PL_regex_pad[0])) {
3457 /* Pop off the "packed" IV from the end. */
3458 SV *const repointer_list = PL_regex_pad[0];
3459 const char *p = SvEND(repointer_list) - sizeof(IV);
3460 const IV offset = *((IV*)p);
3462 assert(SvCUR(repointer_list) % sizeof(IV) == 0);
3464 SvEND_set(repointer_list, p);
3466 pmop->op_pmoffset = offset;
3467 /* This slot should be free, so assert this: */
3468 assert(PL_regex_pad[offset] == &PL_sv_undef);
3470 SV * const repointer = &PL_sv_undef;
3471 av_push(PL_regex_padav, repointer);
3472 pmop->op_pmoffset = av_len(PL_regex_padav);
3473 PL_regex_pad = AvARRAY(PL_regex_padav);
3477 return CHECKOP(type, pmop);
3480 /* Given some sort of match op o, and an expression expr containing a
3481 * pattern, either compile expr into a regex and attach it to o (if it's
3482 * constant), or convert expr into a runtime regcomp op sequence (if it's
3485 * isreg indicates that the pattern is part of a regex construct, eg
3486 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3487 * split "pattern", which aren't. In the former case, expr will be a list
3488 * if the pattern contains more than one term (eg /a$b/) or if it contains
3489 * a replacement, ie s/// or tr///.
3493 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
3498 I32 repl_has_vars = 0;
3502 PERL_ARGS_ASSERT_PMRUNTIME;
3504 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
3505 /* last element in list is the replacement; pop it */
3507 repl = cLISTOPx(expr)->op_last;
3508 kid = cLISTOPx(expr)->op_first;
3509 while (kid->op_sibling != repl)
3510 kid = kid->op_sibling;
3511 kid->op_sibling = NULL;
3512 cLISTOPx(expr)->op_last = kid;
3515 if (isreg && expr->op_type == OP_LIST &&
3516 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3518 /* convert single element list to element */
3519 OP* const oe = expr;
3520 expr = cLISTOPx(oe)->op_first->op_sibling;
3521 cLISTOPx(oe)->op_first->op_sibling = NULL;
3522 cLISTOPx(oe)->op_last = NULL;
3526 if (o->op_type == OP_TRANS) {
3527 return pmtrans(o, expr, repl);
3530 reglist = isreg && expr->op_type == OP_LIST;
3534 PL_hints |= HINT_BLOCK_SCOPE;
3537 if (expr->op_type == OP_CONST) {
3538 SV *pat = ((SVOP*)expr)->op_sv;
3539 U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
3541 if (o->op_flags & OPf_SPECIAL)
3542 pm_flags |= RXf_SPLIT;
3545 assert (SvUTF8(pat));
3546 } else if (SvUTF8(pat)) {
3547 /* Not doing UTF-8, despite what the SV says. Is this only if we're
3548 trapped in use 'bytes'? */
3549 /* Make a copy of the octet sequence, but without the flag on, as
3550 the compiler now honours the SvUTF8 flag on pat. */
3552 const char *const p = SvPV(pat, len);
3553 pat = newSVpvn_flags(p, len, SVs_TEMP);
3556 PM_SETRE(pm, CALLREGCOMP(pat, pm_flags));
3559 op_getmad(expr,(OP*)pm,'e');
3565 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3566 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3568 : OP_REGCMAYBE),0,expr);
3570 NewOp(1101, rcop, 1, LOGOP);
3571 rcop->op_type = OP_REGCOMP;
3572 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3573 rcop->op_first = scalar(expr);
3574 rcop->op_flags |= OPf_KIDS
3575 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3576 | (reglist ? OPf_STACKED : 0);
3577 rcop->op_private = 1;
3580 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3582 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
3585 /* establish postfix order */
3586 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3588 rcop->op_next = expr;
3589 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3592 rcop->op_next = LINKLIST(expr);
3593 expr->op_next = (OP*)rcop;
3596 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3601 if (pm->op_pmflags & PMf_EVAL) {
3603 if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
3604 CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
3606 else if (repl->op_type == OP_CONST)
3610 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3611 if (curop->op_type == OP_SCOPE
3612 || curop->op_type == OP_LEAVE
3613 || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
3614 if (curop->op_type == OP_GV) {
3615 GV * const gv = cGVOPx_gv(curop);
3617 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3620 else if (curop->op_type == OP_RV2CV)
3622 else if (curop->op_type == OP_RV2SV ||
3623 curop->op_type == OP_RV2AV ||
3624 curop->op_type == OP_RV2HV ||
3625 curop->op_type == OP_RV2GV) {
3626 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3629 else if (curop->op_type == OP_PADSV ||
3630 curop->op_type == OP_PADAV ||
3631 curop->op_type == OP_PADHV ||
3632 curop->op_type == OP_PADANY)
3636 else if (curop->op_type == OP_PUSHRE)
3637 NOOP; /* Okay here, dangerous in newASSIGNOP */
3647 || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
3649 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3650 prepend_elem(o->op_type, scalar(repl), o);
3653 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3654 pm->op_pmflags |= PMf_MAYBE_CONST;
3656 NewOp(1101, rcop, 1, LOGOP);
3657 rcop->op_type = OP_SUBSTCONT;
3658 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3659 rcop->op_first = scalar(repl);
3660 rcop->op_flags |= OPf_KIDS;
3661 rcop->op_private = 1;
3664 /* establish postfix order */
3665 rcop->op_next = LINKLIST(repl);
3666 repl->op_next = (OP*)rcop;
3668 pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
3669 assert(!(pm->op_pmflags & PMf_ONCE));
3670 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
3679 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3684 PERL_ARGS_ASSERT_NEWSVOP;
3686 NewOp(1101, svop, 1, SVOP);
3687 svop->op_type = (OPCODE)type;
3688 svop->op_ppaddr = PL_ppaddr[type];
3690 svop->op_next = (OP*)svop;
3691 svop->op_flags = (U8)flags;
3692 if (PL_opargs[type] & OA_RETSCALAR)
3694 if (PL_opargs[type] & OA_TARGET)
3695 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3696 return CHECKOP(type, svop);
3701 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3706 PERL_ARGS_ASSERT_NEWPADOP;
3708 NewOp(1101, padop, 1, PADOP);
3709 padop->op_type = (OPCODE)type;
3710 padop->op_ppaddr = PL_ppaddr[type];
3711 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3712 SvREFCNT_dec(PAD_SVl(padop->op_padix));
3713 PAD_SETSV(padop->op_padix, sv);
3716 padop->op_next = (OP*)padop;
3717 padop->op_flags = (U8)flags;
3718 if (PL_opargs[type] & OA_RETSCALAR)
3720 if (PL_opargs[type] & OA_TARGET)
3721 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3722 return CHECKOP(type, padop);
3727 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3731 PERL_ARGS_ASSERT_NEWGVOP;
3735 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3737 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3742 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3746 NewOp(1101, pvop, 1, PVOP);
3747 pvop->op_type = (OPCODE)type;
3748 pvop->op_ppaddr = PL_ppaddr[type];
3750 pvop->op_next = (OP*)pvop;
3751 pvop->op_flags = (U8)flags;
3752 if (PL_opargs[type] & OA_RETSCALAR)
3754 if (PL_opargs[type] & OA_TARGET)
3755 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3756 return CHECKOP(type, pvop);
3764 Perl_package(pTHX_ OP *o)
3767 SV *const sv = cSVOPo->op_sv;
3772 PERL_ARGS_ASSERT_PACKAGE;
3774 save_hptr(&PL_curstash);
3775 save_item(PL_curstname);
3777 PL_curstash = gv_stashsv(sv, GV_ADD);
3779 sv_setsv(PL_curstname, sv);
3781 PL_hints |= HINT_BLOCK_SCOPE;
3782 PL_parser->copline = NOLINE;
3783 PL_parser->expect = XSTATE;
3788 if (!PL_madskills) {
3793 pegop = newOP(OP_NULL,0);
3794 op_getmad(o,pegop,'P');
3804 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3811 OP *pegop = newOP(OP_NULL,0);
3814 PERL_ARGS_ASSERT_UTILIZE;
3816 if (idop->op_type != OP_CONST)
3817 Perl_croak(aTHX_ "Module name must be constant");
3820 op_getmad(idop,pegop,'U');
3825 SV * const vesv = ((SVOP*)version)->op_sv;
3828 op_getmad(version,pegop,'V');
3829 if (!arg && !SvNIOKp(vesv)) {
3836 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3837 Perl_croak(aTHX_ "Version number must be constant number");
3839 /* Make copy of idop so we don't free it twice */
3840 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3842 /* Fake up a method call to VERSION */
3843 meth = newSVpvs_share("VERSION");
3844 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3845 append_elem(OP_LIST,
3846 prepend_elem(OP_LIST, pack, list(version)),
3847 newSVOP(OP_METHOD_NAMED, 0, meth)));
3851 /* Fake up an import/unimport */
3852 if (arg && arg->op_type == OP_STUB) {
3854 op_getmad(arg,pegop,'S');
3855 imop = arg; /* no import on explicit () */
3857 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3858 imop = NULL; /* use 5.0; */
3860 idop->op_private |= OPpCONST_NOVER;
3866 op_getmad(arg,pegop,'A');
3868 /* Make copy of idop so we don't free it twice */
3869 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3871 /* Fake up a method call to import/unimport */
3873 ? newSVpvs_share("import") : newSVpvs_share("unimport");
3874 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3875 append_elem(OP_LIST,
3876 prepend_elem(OP_LIST, pack, list(arg)),
3877 newSVOP(OP_METHOD_NAMED, 0, meth)));
3880 /* Fake up the BEGIN {}, which does its thing immediately. */
3882 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
3885 append_elem(OP_LINESEQ,
3886 append_elem(OP_LINESEQ,
3887 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
3888 newSTATEOP(0, NULL, veop)),
3889 newSTATEOP(0, NULL, imop) ));
3891 /* The "did you use incorrect case?" warning used to be here.
3892 * The problem is that on case-insensitive filesystems one
3893 * might get false positives for "use" (and "require"):
3894 * "use Strict" or "require CARP" will work. This causes
3895 * portability problems for the script: in case-strict
3896 * filesystems the script will stop working.
3898 * The "incorrect case" warning checked whether "use Foo"
3899 * imported "Foo" to your namespace, but that is wrong, too:
3900 * there is no requirement nor promise in the language that
3901 * a Foo.pm should or would contain anything in package "Foo".
3903 * There is very little Configure-wise that can be done, either:
3904 * the case-sensitivity of the build filesystem of Perl does not
3905 * help in guessing the case-sensitivity of the runtime environment.
3908 PL_hints |= HINT_BLOCK_SCOPE;
3909 PL_parser->copline = NOLINE;
3910 PL_parser->expect = XSTATE;
3911 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3914 if (!PL_madskills) {
3915 /* FIXME - don't allocate pegop if !PL_madskills */
3924 =head1 Embedding Functions
3926 =for apidoc load_module
3928 Loads the module whose name is pointed to by the string part of name.
3929 Note that the actual module name, not its filename, should be given.
3930 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3931 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3932 (or 0 for no flags). ver, if specified, provides version semantics
3933 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3934 arguments can be used to specify arguments to the module's import()
3935 method, similar to C<use Foo::Bar VERSION LIST>.
3940 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3944 PERL_ARGS_ASSERT_LOAD_MODULE;
3946 va_start(args, ver);
3947 vload_module(flags, name, ver, &args);
3951 #ifdef PERL_IMPLICIT_CONTEXT
3953 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3957 PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
3958 va_start(args, ver);
3959 vload_module(flags, name, ver, &args);
3965 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3969 OP * const modname = newSVOP(OP_CONST, 0, name);
3971 PERL_ARGS_ASSERT_VLOAD_MODULE;
3973 modname->op_private |= OPpCONST_BARE;
3975 veop = newSVOP(OP_CONST, 0, ver);
3979 if (flags & PERL_LOADMOD_NOIMPORT) {
3980 imop = sawparens(newNULLLIST());
3982 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3983 imop = va_arg(*args, OP*);
3988 sv = va_arg(*args, SV*);
3990 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3991 sv = va_arg(*args, SV*);
3995 /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
3996 * that it has a PL_parser to play with while doing that, and also
3997 * that it doesn't mess with any existing parser, by creating a tmp
3998 * new parser with lex_start(). This won't actually be used for much,
3999 * since pp_require() will create another parser for the real work. */
4002 SAVEVPTR(PL_curcop);
4003 lex_start(NULL, NULL, FALSE);
4004 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
4005 veop, modname, imop);
4010 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
4016 PERL_ARGS_ASSERT_DOFILE;
4018 if (!force_builtin) {
4019 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
4020 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
4021 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
4022 gv = gvp ? *gvp : NULL;
4026 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
4027 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
4028 append_elem(OP_LIST, term,
4029 scalar(newUNOP(OP_RV2CV, 0,
4030 newGVOP(OP_GV, 0, gv))))));
4033 doop = newUNOP(OP_DOFILE, 0, scalar(term));
4039 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
4041 return newBINOP(OP_LSLICE, flags,
4042 list(force_list(subscript)),
4043 list(force_list(listval)) );
4047 S_is_list_assignment(pTHX_ register const OP *o)
4055 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
4056 o = cUNOPo->op_first;
4058 flags = o->op_flags;
4060 if (type == OP_COND_EXPR) {
4061 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
4062 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
4067 yyerror("Assignment to both a list and a scalar");
4071 if (type == OP_LIST &&
4072 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
4073 o->op_private & OPpLVAL_INTRO)
4076 if (type == OP_LIST || flags & OPf_PARENS ||
4077 type == OP_RV2AV || type == OP_RV2HV ||
4078 type == OP_ASLICE || type == OP_HSLICE)
4081 if (type == OP_PADAV || type == OP_PADHV)
4084 if (type == OP_RV2SV)
4091 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
4097 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
4098 return newLOGOP(optype, 0,
4099 mod(scalar(left), optype),
4100 newUNOP(OP_SASSIGN, 0, scalar(right)));
4103 return newBINOP(optype, OPf_STACKED,
4104 mod(scalar(left), optype), scalar(right));
4108 if (is_list_assignment(left)) {
4109 static const char no_list_state[] = "Initialization of state variables"
4110 " in list context currently forbidden";
4112 bool maybe_common_vars = TRUE;
4115 /* Grandfathering $[ assignment here. Bletch.*/
4116 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
4117 PL_eval_start = (left->op_type == OP_CONST) ? right : NULL;
4118 left = mod(left, OP_AASSIGN);
4121 else if (left->op_type == OP_CONST) {
4123 /* Result of assignment is always 1 (or we'd be dead already) */
4124 return newSVOP(OP_CONST, 0, newSViv(1));
4126 curop = list(force_list(left));
4127 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
4128 o->op_private = (U8)(0 | (flags >> 8));
4130 if ((left->op_type == OP_LIST
4131 || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
4133 OP* lop = ((LISTOP*)left)->op_first;
4134 maybe_common_vars = FALSE;
4136 if (lop->op_type == OP_PADSV ||
4137 lop->op_type == OP_PADAV ||
4138 lop->op_type == OP_PADHV ||
4139 lop->op_type == OP_PADANY) {
4140 if (!(lop->op_private & OPpLVAL_INTRO))
4141 maybe_common_vars = TRUE;
4143 if (lop->op_private & OPpPAD_STATE) {
4144 if (left->op_private & OPpLVAL_INTRO) {
4145 /* Each variable in state($a, $b, $c) = ... */
4148 /* Each state variable in
4149 (state $a, my $b, our $c, $d, undef) = ... */
4151 yyerror(no_list_state);
4153 /* Each my variable in
4154 (state $a, my $b, our $c, $d, undef) = ... */
4156 } else if (lop->op_type == OP_UNDEF ||
4157 lop->op_type == OP_PUSHMARK) {
4158 /* undef may be interesting in
4159 (state $a, undef, state $c) */
4161 /* Other ops in the list. */
4162 maybe_common_vars = TRUE;
4164 lop = lop->op_sibling;
4167 else if ((left->op_private & OPpLVAL_INTRO)
4168 && ( left->op_type == OP_PADSV
4169 || left->op_type == OP_PADAV
4170 || left->op_type == OP_PADHV
4171 || left->op_type == OP_PADANY))
4173 maybe_common_vars = FALSE;
4174 if (left->op_private & OPpPAD_STATE) {
4175 /* All single variable list context state assignments, hence
4185 yyerror(no_list_state);
4189 /* PL_generation sorcery:
4190 * an assignment like ($a,$b) = ($c,$d) is easier than
4191 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
4192 * To detect whether there are common vars, the global var
4193 * PL_generation is incremented for each assign op we compile.
4194 * Then, while compiling the assign op, we run through all the
4195 * variables on both sides of the assignment, setting a spare slot
4196 * in each of them to PL_generation. If any of them already have
4197 * that value, we know we've got commonality. We could use a
4198 * single bit marker, but then we'd have to make 2 passes, first
4199 * to clear the flag, then to test and set it. To find somewhere
4200 * to store these values, evil chicanery is done with SvUVX().
4203 if (maybe_common_vars) {
4206 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4207 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
4208 if (curop->op_type == OP_GV) {
4209 GV *gv = cGVOPx_gv(curop);
4211 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4213 GvASSIGN_GENERATION_set(gv, PL_generation);
4215 else if (curop->op_type == OP_PADSV ||
4216 curop->op_type == OP_PADAV ||
4217 curop->op_type == OP_PADHV ||
4218 curop->op_type == OP_PADANY)
4220 if (PAD_COMPNAME_GEN(curop->op_targ)
4221 == (STRLEN)PL_generation)
4223 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
4226 else if (curop->op_type == OP_RV2CV)
4228 else if (curop->op_type == OP_RV2SV ||
4229 curop->op_type == OP_RV2AV ||
4230 curop->op_type == OP_RV2HV ||
4231 curop->op_type == OP_RV2GV) {
4232 if (lastop->op_type != OP_GV) /* funny deref? */
4235 else if (curop->op_type == OP_PUSHRE) {
4237 if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
4238 GV *const gv = (GV*)PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff);
4240 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4242 GvASSIGN_GENERATION_set(gv, PL_generation);
4246 = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
4249 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4251 GvASSIGN_GENERATION_set(gv, PL_generation);
4261 o->op_private |= OPpASSIGN_COMMON;
4264 if (right && right->op_type == OP_SPLIT && !PL_madskills) {
4265 OP* tmpop = ((LISTOP*)right)->op_first;
4266 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
4267 PMOP * const pm = (PMOP*)tmpop;
4268 if (left->op_type == OP_RV2AV &&
4269 !(left->op_private & OPpLVAL_INTRO) &&
4270 !(o->op_private & OPpASSIGN_COMMON) )
4272 tmpop = ((UNOP*)left)->op_first;
4273 if (tmpop->op_type == OP_GV
4275 && !pm->op_pmreplrootu.op_pmtargetoff
4277 && !pm->op_pmreplrootu.op_pmtargetgv
4281 pm->op_pmreplrootu.op_pmtargetoff
4282 = cPADOPx(tmpop)->op_padix;
4283 cPADOPx(tmpop)->op_padix = 0; /* steal it */
4285 pm->op_pmreplrootu.op_pmtargetgv
4286 = (GV*)cSVOPx(tmpop)->op_sv;
4287 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
4289 pm->op_pmflags |= PMf_ONCE;
4290 tmpop = cUNOPo->op_first; /* to list (nulled) */
4291 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
4292 tmpop->op_sibling = NULL; /* don't free split */
4293 right->op_next = tmpop->op_next; /* fix starting loc */
4294 op_free(o); /* blow off assign */
4295 right->op_flags &= ~OPf_WANT;
4296 /* "I don't know and I don't care." */
4301 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
4302 ((LISTOP*)right)->op_last->op_type == OP_CONST)
4304 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
4306 sv_setiv(sv, PL_modcount+1);
4314 right = newOP(OP_UNDEF, 0);
4315 if (right->op_type == OP_READLINE) {
4316 right->op_flags |= OPf_STACKED;
4317 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
4320 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
4321 o = newBINOP(OP_SASSIGN, flags,
4322 scalar(right), mod(scalar(left), OP_SASSIGN) );
4328 o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
4329 o->op_private |= OPpCONST_ARYBASE;
4336 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
4339 const U32 seq = intro_my();
4342 NewOp(1101, cop, 1, COP);
4343 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
4344 cop->op_type = OP_DBSTATE;
4345 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
4348 cop->op_type = OP_NEXTSTATE;
4349 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
4351 cop->op_flags = (U8)flags;
4352 CopHINTS_set(cop, PL_hints);
4354 cop->op_private |= NATIVE_HINTS;
4356 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
4357 cop->op_next = (OP*)cop;
4360 CopLABEL_set(cop, label);
4361 PL_hints |= HINT_BLOCK_SCOPE;
4364 /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
4365 CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
4367 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
4368 cop->cop_hints_hash = PL_curcop->cop_hints_hash;
4369 if (cop->cop_hints_hash) {
4371 cop->cop_hints_hash->refcounted_he_refcnt++;
4372 HINTS_REFCNT_UNLOCK;
4375 if (PL_parser && PL_parser->copline == NOLINE)
4376 CopLINE_set(cop, CopLINE(PL_curcop));
4378 CopLINE_set(cop, PL_parser->copline);
4380 PL_parser->copline = NOLINE;
4383 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
4385 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
4387 CopSTASH_set(cop, PL_curstash);
4389 if (PERLDB_LINE && PL_curstash != PL_debstash) {
4390 AV *av = CopFILEAVx(PL_curcop);
4392 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
4393 if (svp && *svp != &PL_sv_undef ) {
4394 (void)SvIOK_on(*svp);
4395 SvIV_set(*svp, PTR2IV(cop));
4400 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
4405 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
4409 PERL_ARGS_ASSERT_NEWLOGOP;
4411 return new_logop(type, flags, &first, &other);
4415 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
4420 OP *first = *firstp;
4421 OP * const other = *otherp;
4423 PERL_ARGS_ASSERT_NEW_LOGOP;
4425 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
4426 return newBINOP(type, flags, scalar(first), scalar(other));
4428 scalarboolean(first);
4429 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
4430 if (first->op_type == OP_NOT
4431 && (first->op_flags & OPf_SPECIAL)
4432 && (first->op_flags & OPf_KIDS)
4434 if (type == OP_AND || type == OP_OR) {
4440 first = *firstp = cUNOPo->op_first;
4442 first->op_next = o->op_next;
4443 cUNOPo->op_first = NULL;
4447 if (first->op_type == OP_CONST) {
4448 if (first->op_private & OPpCONST_STRICT)
4449 no_bareword_allowed(first);
4450 else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
4451 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
4452 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
4453 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
4454 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
4456 if (other->op_type == OP_CONST)
4457 other->op_private |= OPpCONST_SHORTCIRCUIT;
4459 OP *newop = newUNOP(OP_NULL, 0, other);
4460 op_getmad(first, newop, '1');
4461 newop->op_targ = type; /* set "was" field */
4468 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
4469 const OP *o2 = other;
4470 if ( ! (o2->op_type == OP_LIST
4471 && (( o2 = cUNOPx(o2)->op_first))
4472 && o2->op_type == OP_PUSHMARK
4473 && (( o2 = o2->op_sibling)) )
4476 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
4477 || o2->op_type == OP_PADHV)
4478 && o2->op_private & OPpLVAL_INTRO
4479 && !(o2->op_private & OPpPAD_STATE)
4480 && ckWARN(WARN_DEPRECATED))
4482 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4483 "Deprecated use of my() in false conditional");
4487 if (first->op_type == OP_CONST)
4488 first->op_private |= OPpCONST_SHORTCIRCUIT;
4490 first = newUNOP(OP_NULL, 0, first);
4491 op_getmad(other, first, '2');
4492 first->op_targ = type; /* set "was" field */
4499 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
4500 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
4502 const OP * const k1 = ((UNOP*)first)->op_first;
4503 const OP * const k2 = k1->op_sibling;
4505 switch (first->op_type)
4508 if (k2 && k2->op_type == OP_READLINE
4509 && (k2->op_flags & OPf_STACKED)
4510 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4512 warnop = k2->op_type;
4517 if (k1->op_type == OP_READDIR
4518 || k1->op_type == OP_GLOB
4519 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4520 || k1->op_type == OP_EACH)
4522 warnop = ((k1->op_type == OP_NULL)
4523 ? (OPCODE)k1->op_targ : k1->op_type);
4528 const line_t oldline = CopLINE(PL_curcop);
4529 CopLINE_set(PL_curcop, PL_parser->copline);
4530 Perl_warner(aTHX_ packWARN(WARN_MISC),
4531 "Value of %s%s can be \"0\"; test with defined()",
4533 ((warnop == OP_READLINE || warnop == OP_GLOB)
4534 ? " construct" : "() operator"));
4535 CopLINE_set(PL_curcop, oldline);
4542 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
4543 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
4545 NewOp(1101, logop, 1, LOGOP);
4547 logop->op_type = (OPCODE)type;
4548 logop->op_ppaddr = PL_ppaddr[type];
4549 logop->op_first = first;
4550 logop->op_flags = (U8)(flags | OPf_KIDS);
4551 logop->op_other = LINKLIST(other);
4552 logop->op_private = (U8)(1 | (flags >> 8));
4554 /* establish postfix order */
4555 logop->op_next = LINKLIST(first);
4556 first->op_next = (OP*)logop;
4557 first->op_sibling = other;
4559 CHECKOP(type,logop);
4561 o = newUNOP(OP_NULL, 0, (OP*)logop);
4568 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
4575 PERL_ARGS_ASSERT_NEWCONDOP;
4578 return newLOGOP(OP_AND, 0, first, trueop);
4580 return newLOGOP(OP_OR, 0, first, falseop);
4582 scalarboolean(first);
4583 if (first->op_type == OP_CONST) {
4584 /* Left or right arm of the conditional? */
4585 const bool left = SvTRUE(((SVOP*)first)->op_sv);
4586 OP *live = left ? trueop : falseop;
4587 OP *const dead = left ? falseop : trueop;
4588 if (first->op_private & OPpCONST_BARE &&
4589 first->op_private & OPpCONST_STRICT) {
4590 no_bareword_allowed(first);
4593 /* This is all dead code when PERL_MAD is not defined. */
4594 live = newUNOP(OP_NULL, 0, live);
4595 op_getmad(first, live, 'C');
4596 op_getmad(dead, live, left ? 'e' : 't');
4603 NewOp(1101, logop, 1, LOGOP);
4604 logop->op_type = OP_COND_EXPR;
4605 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4606 logop->op_first = first;
4607 logop->op_flags = (U8)(flags | OPf_KIDS);
4608 logop->op_private = (U8)(1 | (flags >> 8));
4609 logop->op_other = LINKLIST(trueop);
4610 logop->op_next = LINKLIST(falseop);
4612 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
4615 /* establish postfix order */
4616 start = LINKLIST(first);
4617 first->op_next = (OP*)logop;
4619 first->op_sibling = trueop;
4620 trueop->op_sibling = falseop;
4621 o = newUNOP(OP_NULL, 0, (OP*)logop);
4623 trueop->op_next = falseop->op_next = o;
4630 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4639 PERL_ARGS_ASSERT_NEWRANGE;
4641 NewOp(1101, range, 1, LOGOP);
4643 range->op_type = OP_RANGE;
4644 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4645 range->op_first = left;
4646 range->op_flags = OPf_KIDS;
4647 leftstart = LINKLIST(left);
4648 range->op_other = LINKLIST(right);
4649 range->op_private = (U8)(1 | (flags >> 8));
4651 left->op_sibling = right;
4653 range->op_next = (OP*)range;
4654 flip = newUNOP(OP_FLIP, flags, (OP*)range);
4655 flop = newUNOP(OP_FLOP, 0, flip);
4656 o = newUNOP(OP_NULL, 0, flop);
4658 range->op_next = leftstart;
4660 left->op_next = flip;
4661 right->op_next = flop;
4663 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4664 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4665 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4666 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4668 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4669 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4672 if (!flip->op_private || !flop->op_private)
4673 linklist(o); /* blow off optimizer unless constant */
4679 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4684 const bool once = block && block->op_flags & OPf_SPECIAL &&
4685 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4687 PERL_UNUSED_ARG(debuggable);
4690 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4691 return block; /* do {} while 0 does once */
4692 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4693 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4694 expr = newUNOP(OP_DEFINED, 0,
4695 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4696 } else if (expr->op_flags & OPf_KIDS) {
4697 const OP * const k1 = ((UNOP*)expr)->op_first;
4698 const OP * const k2 = k1 ? k1->op_sibling : NULL;
4699 switch (expr->op_type) {
4701 if (k2 && k2->op_type == OP_READLINE
4702 && (k2->op_flags & OPf_STACKED)
4703 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4704 expr = newUNOP(OP_DEFINED, 0, expr);
4708 if (k1 && (k1->op_type == OP_READDIR
4709 || k1->op_type == OP_GLOB
4710 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4711 || k1->op_type == OP_EACH))
4712 expr = newUNOP(OP_DEFINED, 0, expr);
4718 /* if block is null, the next append_elem() would put UNSTACK, a scalar
4719 * op, in listop. This is wrong. [perl #27024] */
4721 block = newOP(OP_NULL, 0);
4722 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4723 o = new_logop(OP_AND, 0, &expr, &listop);
4726 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4728 if (once && o != listop)
4729 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4732 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
4734 o->op_flags |= flags;
4736 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4741 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
4742 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
4751 PERL_UNUSED_ARG(debuggable);
4754 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4755 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4756 expr = newUNOP(OP_DEFINED, 0,
4757 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4758 } else if (expr->op_flags & OPf_KIDS) {
4759 const OP * const k1 = ((UNOP*)expr)->op_first;
4760 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
4761 switch (expr->op_type) {
4763 if (k2 && k2->op_type == OP_READLINE
4764 && (k2->op_flags & OPf_STACKED)
4765 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4766 expr = newUNOP(OP_DEFINED, 0, expr);
4770 if (k1 && (k1->op_type == OP_READDIR
4771 || k1->op_type == OP_GLOB
4772 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4773 || k1->op_type == OP_EACH))
4774 expr = newUNOP(OP_DEFINED, 0, expr);
4781 block = newOP(OP_NULL, 0);
4782 else if (cont || has_my) {
4783 block = scope(block);
4787 next = LINKLIST(cont);
4790 OP * const unstack = newOP(OP_UNSTACK, 0);
4793 cont = append_elem(OP_LINESEQ, cont, unstack);
4797 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4799 redo = LINKLIST(listop);
4802 PL_parser->copline = (line_t)whileline;
4804 o = new_logop(OP_AND, 0, &expr, &listop);
4805 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4806 op_free(expr); /* oops, it's a while (0) */
4808 return NULL; /* listop already freed by new_logop */
4811 ((LISTOP*)listop)->op_last->op_next =
4812 (o == listop ? redo : LINKLIST(o));
4818 NewOp(1101,loop,1,LOOP);
4819 loop->op_type = OP_ENTERLOOP;
4820 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4821 loop->op_private = 0;
4822 loop->op_next = (OP*)loop;
4825 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4827 loop->op_redoop = redo;
4828 loop->op_lastop = o;
4829 o->op_private |= loopflags;
4832 loop->op_nextop = next;
4834 loop->op_nextop = o;
4836 o->op_flags |= flags;
4837 o->op_private |= (flags >> 8);
4842 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
4847 PADOFFSET padoff = 0;
4852 PERL_ARGS_ASSERT_NEWFOROP;
4855 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4856 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
4857 sv->op_type = OP_RV2GV;
4858 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4860 /* The op_type check is needed to prevent a possible segfault
4861 * if the loop variable is undeclared and 'strict vars' is in
4862 * effect. This is illegal but is nonetheless parsed, so we
4863 * may reach this point with an OP_CONST where we're expecting
4866 if (cUNOPx(sv)->op_first->op_type == OP_GV
4867 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
4868 iterpflags |= OPpITER_DEF;
4870 else if (sv->op_type == OP_PADSV) { /* private variable */
4871 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
4872 padoff = sv->op_targ;
4882 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4884 SV *const namesv = PAD_COMPNAME_SV(padoff);
4886 const char *const name = SvPV_const(namesv, len);
4888 if (len == 2 && name[0] == '$' && name[1] == '_')
4889 iterpflags |= OPpITER_DEF;
4893 const PADOFFSET offset = pad_findmy("$_");
4894 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
4895 sv = newGVOP(OP_GV, 0, PL_defgv);
4900 iterpflags |= OPpITER_DEF;
4902 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4903 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4904 iterflags |= OPf_STACKED;
4906 else if (expr->op_type == OP_NULL &&
4907 (expr->op_flags & OPf_KIDS) &&
4908 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4910 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4911 * set the STACKED flag to indicate that these values are to be
4912 * treated as min/max values by 'pp_iterinit'.
4914 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4915 LOGOP* const range = (LOGOP*) flip->op_first;
4916 OP* const left = range->op_first;
4917 OP* const right = left->op_sibling;
4920 range->op_flags &= ~OPf_KIDS;
4921 range->op_first = NULL;
4923 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4924 listop->op_first->op_next = range->op_next;
4925 left->op_next = range->op_other;
4926 right->op_next = (OP*)listop;
4927 listop->op_next = listop->op_first;
4930 op_getmad(expr,(OP*)listop,'O');
4934 expr = (OP*)(listop);
4936 iterflags |= OPf_STACKED;
4939 expr = mod(force_list(expr), OP_GREPSTART);
4942 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4943 append_elem(OP_LIST, expr, scalar(sv))));
4944 assert(!loop->op_next);
4945 /* for my $x () sets OPpLVAL_INTRO;
4946 * for our $x () sets OPpOUR_INTRO */
4947 loop->op_private = (U8)iterpflags;
4948 #ifdef PL_OP_SLAB_ALLOC
4951 NewOp(1234,tmp,1,LOOP);
4952 Copy(loop,tmp,1,LISTOP);
4953 S_op_destroy(aTHX_ (OP*)loop);
4957 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
4959 loop->op_targ = padoff;
4960 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
4962 op_getmad(madsv, (OP*)loop, 'v');
4963 PL_parser->copline = forline;
4964 return newSTATEOP(0, label, wop);
4968 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4973 PERL_ARGS_ASSERT_NEWLOOPEX;
4975 if (type != OP_GOTO || label->op_type == OP_CONST) {
4976 /* "last()" means "last" */
4977 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4978 o = newOP(type, OPf_SPECIAL);
4980 o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
4981 ? SvPV_nolen_const(((SVOP*)label)->op_sv)
4985 op_getmad(label,o,'L');
4991 /* Check whether it's going to be a goto &function */
4992 if (label->op_type == OP_ENTERSUB
4993 && !(label->op_flags & OPf_STACKED))
4994 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4995 o = newUNOP(type, OPf_STACKED, label);
4997 PL_hints |= HINT_BLOCK_SCOPE;
5001 /* if the condition is a literal array or hash
5002 (or @{ ... } etc), make a reference to it.
5005 S_ref_array_or_hash(pTHX_ OP *cond)
5008 && (cond->op_type == OP_RV2AV
5009 || cond->op_type == OP_PADAV
5010 || cond->op_type == OP_RV2HV
5011 || cond->op_type == OP_PADHV))
5013 return newUNOP(OP_REFGEN,
5014 0, mod(cond, OP_REFGEN));
5020 /* These construct the optree fragments representing given()
5023 entergiven and enterwhen are LOGOPs; the op_other pointer
5024 points up to the associated leave op. We need this so we
5025 can put it in the context and make break/continue work.
5026 (Also, of course, pp_enterwhen will jump straight to
5027 op_other if the match fails.)
5031 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
5032 I32 enter_opcode, I32 leave_opcode,
5033 PADOFFSET entertarg)
5039 PERL_ARGS_ASSERT_NEWGIVWHENOP;
5041 NewOp(1101, enterop, 1, LOGOP);
5042 enterop->op_type = (optype)enter_opcode;
5043 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
5044 enterop->op_flags = (U8) OPf_KIDS;
5045 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
5046 enterop->op_private = 0;
5048 o = newUNOP(leave_opcode, 0, (OP *) enterop);
5051 enterop->op_first = scalar(cond);
5052 cond->op_sibling = block;
5054 o->op_next = LINKLIST(cond);
5055 cond->op_next = (OP *) enterop;
5058 /* This is a default {} block */
5059 enterop->op_first = block;
5060 enterop->op_flags |= OPf_SPECIAL;
5062 o->op_next = (OP *) enterop;
5065 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
5066 entergiven and enterwhen both
5069 enterop->op_next = LINKLIST(block);
5070 block->op_next = enterop->op_other = o;
5075 /* Does this look like a boolean operation? For these purposes
5076 a boolean operation is:
5077 - a subroutine call [*]
5078 - a logical connective
5079 - a comparison operator
5080 - a filetest operator, with the exception of -s -M -A -C
5081 - defined(), exists() or eof()
5082 - /$re/ or $foo =~ /$re/
5084 [*] possibly surprising
5087 S_looks_like_bool(pTHX_ const OP *o)
5091 PERL_ARGS_ASSERT_LOOKS_LIKE_BOOL;
5093 switch(o->op_type) {
5095 return looks_like_bool(cLOGOPo->op_first);
5099 looks_like_bool(cLOGOPo->op_first)
5100 && looks_like_bool(cLOGOPo->op_first->op_sibling));
5104 o->op_flags & OPf_KIDS
5105 && looks_like_bool(cUNOPo->op_first));
5109 case OP_NOT: case OP_XOR:
5110 /* Note that OP_DOR is not here */
5112 case OP_EQ: case OP_NE: case OP_LT:
5113 case OP_GT: case OP_LE: case OP_GE:
5115 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
5116 case OP_I_GT: case OP_I_LE: case OP_I_GE:
5118 case OP_SEQ: case OP_SNE: case OP_SLT:
5119 case OP_SGT: case OP_SLE: case OP_SGE:
5123 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
5124 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
5125 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
5126 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
5127 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
5128 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
5129 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
5130 case OP_FTTEXT: case OP_FTBINARY:
5132 case OP_DEFINED: case OP_EXISTS:
5133 case OP_MATCH: case OP_EOF:
5138 /* Detect comparisons that have been optimized away */
5139 if (cSVOPo->op_sv == &PL_sv_yes
5140 || cSVOPo->op_sv == &PL_sv_no)
5151 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
5154 PERL_ARGS_ASSERT_NEWGIVENOP;
5155 return newGIVWHENOP(
5156 ref_array_or_hash(cond),
5158 OP_ENTERGIVEN, OP_LEAVEGIVEN,
5162 /* If cond is null, this is a default {} block */
5164 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
5166 const bool cond_llb = (!cond || looks_like_bool(cond));
5169 PERL_ARGS_ASSERT_NEWWHENOP;
5174 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
5176 scalar(ref_array_or_hash(cond)));
5179 return newGIVWHENOP(
5181 append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
5182 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
5186 =for apidoc cv_undef
5188 Clear out all the active components of a CV. This can happen either
5189 by an explicit C<undef &foo>, or by the reference count going to zero.
5190 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
5191 children can still follow the full lexical scope chain.
5197 Perl_cv_undef(pTHX_ CV *cv)
5201 PERL_ARGS_ASSERT_CV_UNDEF;
5203 DEBUG_X(PerlIO_printf(Perl_debug_log,
5204 "CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n",
5205 PTR2UV(cv), PTR2UV(PL_comppad))
5209 if (CvFILE(cv) && !CvISXSUB(cv)) {
5210 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
5211 Safefree(CvFILE(cv));
5216 if (!CvISXSUB(cv) && CvROOT(cv)) {
5217 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
5218 Perl_croak(aTHX_ "Can't undef active subroutine");
5221 PAD_SAVE_SETNULLPAD();
5223 op_free(CvROOT(cv));
5228 SvPOK_off((SV*)cv); /* forget prototype */
5233 /* remove CvOUTSIDE unless this is an undef rather than a free */
5234 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
5235 if (!CvWEAKOUTSIDE(cv))
5236 SvREFCNT_dec(CvOUTSIDE(cv));
5237 CvOUTSIDE(cv) = NULL;
5240 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
5243 if (CvISXSUB(cv) && CvXSUB(cv)) {
5246 /* delete all flags except WEAKOUTSIDE */
5247 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
5251 Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
5254 PERL_ARGS_ASSERT_CV_CKPROTO_LEN;
5256 /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
5257 relying on SvCUR, and doubling up the buffer to hold CvFILE(). */
5258 if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
5259 || (p && (len != SvCUR(cv) /* Not the same length. */
5260 || memNE(p, SvPVX_const(cv), len))))
5261 && ckWARN_d(WARN_PROTOTYPE)) {
5262 SV* const msg = sv_newmortal();
5266 gv_efullname3(name = sv_newmortal(), gv, NULL);
5267 sv_setpvs(msg, "Prototype mismatch:");
5269 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
5271 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv));
5273 sv_catpvs(msg, ": none");
5274 sv_catpvs(msg, " vs ");
5276 Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
5278 sv_catpvs(msg, "none");
5279 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
5283 static void const_sv_xsub(pTHX_ CV* cv);
5287 =head1 Optree Manipulation Functions
5289 =for apidoc cv_const_sv
5291 If C<cv> is a constant sub eligible for inlining. returns the constant
5292 value returned by the sub. Otherwise, returns NULL.
5294 Constant subs can be created with C<newCONSTSUB> or as described in
5295 L<perlsub/"Constant Functions">.
5300 Perl_cv_const_sv(pTHX_ CV *cv)
5302 PERL_UNUSED_CONTEXT;
5305 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
5307 return CvCONST(cv) ? (SV*)CvXSUBANY(cv).any_ptr : NULL;
5310 /* op_const_sv: examine an optree to determine whether it's in-lineable.
5311 * Can be called in 3 ways:
5314 * look for a single OP_CONST with attached value: return the value
5316 * cv && CvCLONE(cv) && !CvCONST(cv)
5318 * examine the clone prototype, and if contains only a single
5319 * OP_CONST referencing a pad const, or a single PADSV referencing
5320 * an outer lexical, return a non-zero value to indicate the CV is
5321 * a candidate for "constizing" at clone time
5325 * We have just cloned an anon prototype that was marked as a const
5326 * candidiate. Try to grab the current value, and in the case of
5327 * PADSV, ignore it if it has multiple references. Return the value.
5331 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
5342 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
5343 o = cLISTOPo->op_first->op_sibling;
5345 for (; o; o = o->op_next) {
5346 const OPCODE type = o->op_type;
5348 if (sv && o->op_next == o)
5350 if (o->op_next != o) {
5351 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
5353 if (type == OP_DBSTATE)
5356 if (type == OP_LEAVESUB || type == OP_RETURN)
5360 if (type == OP_CONST && cSVOPo->op_sv)
5362 else if (cv && type == OP_CONST) {
5363 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5367 else if (cv && type == OP_PADSV) {
5368 if (CvCONST(cv)) { /* newly cloned anon */
5369 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5370 /* the candidate should have 1 ref from this pad and 1 ref
5371 * from the parent */
5372 if (!sv || SvREFCNT(sv) != 2)
5379 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
5380 sv = &PL_sv_undef; /* an arbitrary non-null value */
5395 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5398 /* This would be the return value, but the return cannot be reached. */
5399 OP* pegop = newOP(OP_NULL, 0);
5402 PERL_UNUSED_ARG(floor);
5412 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
5414 NORETURN_FUNCTION_END;
5419 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
5421 return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
5425 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5432 register CV *cv = NULL;
5434 /* If the subroutine has no body, no attributes, and no builtin attributes
5435 then it's just a sub declaration, and we may be able to get away with
5436 storing with a placeholder scalar in the symbol table, rather than a
5437 full GV and CV. If anything is present then it will take a full CV to
5439 const I32 gv_fetch_flags
5440 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5442 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
5443 const char * const name = o ? SvPV_nolen_const(cSVOPo->op_sv) : NULL;
5446 assert(proto->op_type == OP_CONST);
5447 ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
5452 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
5453 SV * const sv = sv_newmortal();
5454 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
5455 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
5456 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
5457 aname = SvPVX_const(sv);
5462 gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
5463 : gv_fetchpv(aname ? aname
5464 : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5465 gv_fetch_flags, SVt_PVCV);
5467 if (!PL_madskills) {
5476 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
5477 maximum a prototype before. */
5478 if (SvTYPE(gv) > SVt_NULL) {
5479 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
5480 && ckWARN_d(WARN_PROTOTYPE))
5482 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
5484 cv_ckproto_len((CV*)gv, NULL, ps, ps_len);
5487 sv_setpvn((SV*)gv, ps, ps_len);
5489 sv_setiv((SV*)gv, -1);
5491 SvREFCNT_dec(PL_compcv);
5492 cv = PL_compcv = NULL;
5496 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
5498 #ifdef GV_UNIQUE_CHECK
5499 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
5500 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
5504 if (!block || !ps || *ps || attrs
5505 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5507 || block->op_type == OP_NULL
5512 const_sv = op_const_sv(block, NULL);
5515 const bool exists = CvROOT(cv) || CvXSUB(cv);
5517 #ifdef GV_UNIQUE_CHECK
5518 if (exists && GvUNIQUE(gv)) {
5519 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
5523 /* if the subroutine doesn't exist and wasn't pre-declared
5524 * with a prototype, assume it will be AUTOLOADed,
5525 * skipping the prototype check
5527 if (exists || SvPOK(cv))
5528 cv_ckproto_len(cv, gv, ps, ps_len);
5529 /* already defined (or promised)? */
5530 if (exists || GvASSUMECV(gv)) {
5533 || block->op_type == OP_NULL
5536 if (CvFLAGS(PL_compcv)) {
5537 /* might have had built-in attrs applied */
5538 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5540 /* just a "sub foo;" when &foo is already defined */
5541 SAVEFREESV(PL_compcv);
5546 && block->op_type != OP_NULL
5549 if (ckWARN(WARN_REDEFINE)
5551 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
5553 const line_t oldline = CopLINE(PL_curcop);
5554 if (PL_parser && PL_parser->copline != NOLINE)
5555 CopLINE_set(PL_curcop, PL_parser->copline);
5556 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5557 CvCONST(cv) ? "Constant subroutine %s redefined"
5558 : "Subroutine %s redefined", name);
5559 CopLINE_set(PL_curcop, oldline);
5562 if (!PL_minus_c) /* keep old one around for madskills */
5565 /* (PL_madskills unset in used file.) */
5573 SvREFCNT_inc_simple_void_NN(const_sv);
5575 assert(!CvROOT(cv) && !CvCONST(cv));
5576 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
5577 CvXSUBANY(cv).any_ptr = const_sv;
5578 CvXSUB(cv) = const_sv_xsub;
5584 cv = newCONSTSUB(NULL, name, const_sv);
5586 mro_method_changed_in( /* sub Foo::Bar () { 123 } */
5587 (CvGV(cv) && GvSTASH(CvGV(cv)))
5596 SvREFCNT_dec(PL_compcv);
5604 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
5605 * before we clobber PL_compcv.
5609 || block->op_type == OP_NULL
5613 /* Might have had built-in attributes applied -- propagate them. */
5614 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5615 if (CvGV(cv) && GvSTASH(CvGV(cv)))
5616 stash = GvSTASH(CvGV(cv));
5617 else if (CvSTASH(cv))
5618 stash = CvSTASH(cv);
5620 stash = PL_curstash;
5623 /* possibly about to re-define existing subr -- ignore old cv */
5624 rcv = (SV*)PL_compcv;
5625 if (name && GvSTASH(gv))
5626 stash = GvSTASH(gv);
5628 stash = PL_curstash;
5630 apply_attrs(stash, rcv, attrs, FALSE);
5632 if (cv) { /* must reuse cv if autoloaded */
5639 || block->op_type == OP_NULL) && !PL_madskills
5642 /* got here with just attrs -- work done, so bug out */
5643 SAVEFREESV(PL_compcv);
5646 /* transfer PL_compcv to cv */
5648 CvFLAGS(cv) = CvFLAGS(PL_compcv);
5649 if (!CvWEAKOUTSIDE(cv))
5650 SvREFCNT_dec(CvOUTSIDE(cv));
5651 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
5652 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
5653 CvOUTSIDE(PL_compcv) = 0;
5654 CvPADLIST(cv) = CvPADLIST(PL_compcv);
5655 CvPADLIST(PL_compcv) = 0;
5656 /* inner references to PL_compcv must be fixed up ... */
5657 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
5658 /* ... before we throw it away */
5659 SvREFCNT_dec(PL_compcv);
5661 if (PERLDB_INTER)/* Advice debugger on the new sub. */
5662 ++PL_sub_generation;
5669 if (strEQ(name, "import")) {
5670 PL_formfeed = (SV*)cv;
5671 Perl_warner(aTHX_ packWARN(WARN_VOID), "%lx\n", (long)cv);
5675 mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */
5679 CvFILE_set_from_cop(cv, PL_curcop);
5680 CvSTASH(cv) = PL_curstash;
5683 sv_setpvn((SV*)cv, ps, ps_len);
5685 if (PL_parser && PL_parser->error_count) {
5689 const char *s = strrchr(name, ':');
5691 if (strEQ(s, "BEGIN")) {
5692 const char not_safe[] =
5693 "BEGIN not safe after errors--compilation aborted";
5694 if (PL_in_eval & EVAL_KEEPERR)
5695 Perl_croak(aTHX_ not_safe);
5697 /* force display of errors found but not reported */
5698 sv_catpv(ERRSV, not_safe);
5699 Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
5709 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5710 mod(scalarseq(block), OP_LEAVESUBLV));
5711 block->op_attached = 1;
5714 /* This makes sub {}; work as expected. */
5715 if (block->op_type == OP_STUB) {
5716 OP* const newblock = newSTATEOP(0, NULL, 0);
5718 op_getmad(block,newblock,'B');
5725 block->op_attached = 1;
5726 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5728 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5729 OpREFCNT_set(CvROOT(cv), 1);
5730 CvSTART(cv) = LINKLIST(CvROOT(cv));
5731 CvROOT(cv)->op_next = 0;
5732 CALL_PEEP(CvSTART(cv));
5734 /* now that optimizer has done its work, adjust pad values */
5736 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
5739 assert(!CvCONST(cv));
5740 if (ps && !*ps && op_const_sv(block, cv))
5744 if (name || aname) {
5745 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5746 SV * const sv = newSV(0);
5747 SV * const tmpstr = sv_newmortal();
5748 GV * const db_postponed = gv_fetchpvs("DB::postponed",
5749 GV_ADDMULTI, SVt_PVHV);
5752 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5754 (long)PL_subline, (long)CopLINE(PL_curcop));
5755 gv_efullname3(tmpstr, gv, NULL);
5756 (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
5757 SvCUR(tmpstr), sv, 0);
5758 hv = GvHVn(db_postponed);
5759 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
5760 CV * const pcv = GvCV(db_postponed);
5766 call_sv((SV*)pcv, G_DISCARD);
5771 if (name && ! (PL_parser && PL_parser->error_count))
5772 process_special_blocks(name, gv, cv);
5777 PL_parser->copline = NOLINE;
5783 S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
5786 const char *const colon = strrchr(fullname,':');
5787 const char *const name = colon ? colon + 1 : fullname;
5789 PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
5792 if (strEQ(name, "BEGIN")) {
5793 const I32 oldscope = PL_scopestack_ix;
5795 SAVECOPFILE(&PL_compiling);
5796 SAVECOPLINE(&PL_compiling);
5798 DEBUG_x( dump_sub(gv) );
5799 Perl_av_create_and_push(aTHX_ &PL_beginav, (SV*)cv);
5800 GvCV(gv) = 0; /* cv has been hijacked */
5801 call_list(oldscope, PL_beginav);
5803 PL_curcop = &PL_compiling;
5804 CopHINTS_set(&PL_compiling, PL_hints);
5811 if strEQ(name, "END") {
5812 DEBUG_x( dump_sub(gv) );
5813 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, (SV*)cv);
5816 } else if (*name == 'U') {
5817 if (strEQ(name, "UNITCHECK")) {
5818 /* It's never too late to run a unitcheck block */
5819 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, (SV*)cv);
5823 } else if (*name == 'C') {
5824 if (strEQ(name, "CHECK")) {
5825 if (PL_main_start && ckWARN(WARN_VOID))
5826 Perl_warner(aTHX_ packWARN(WARN_VOID),
5827 "Too late to run CHECK block");
5828 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, (SV*)cv);
5832 } else if (*name == 'I') {
5833 if (strEQ(name, "INIT")) {
5834 if (PL_main_start && ckWARN(WARN_VOID))
5835 Perl_warner(aTHX_ packWARN(WARN_VOID),
5836 "Too late to run INIT block");
5837 Perl_av_create_and_push(aTHX_ &PL_initav, (SV*)cv);
5843 DEBUG_x( dump_sub(gv) );
5844 GvCV(gv) = 0; /* cv has been hijacked */
5849 =for apidoc newCONSTSUB
5851 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5852 eligible for inlining at compile-time.
5858 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
5863 const char *const temp_p = CopFILE(PL_curcop);
5864 const STRLEN len = temp_p ? strlen(temp_p) : 0;
5866 SV *const temp_sv = CopFILESV(PL_curcop);
5868 const char *const temp_p = temp_sv ? SvPV_const(temp_sv, len) : NULL;
5870 char *const file = savepvn(temp_p, temp_p ? len : 0);
5874 if (IN_PERL_RUNTIME) {
5875 /* at runtime, it's not safe to manipulate PL_curcop: it may be
5876 * an op shared between threads. Use a non-shared COP for our
5878 SAVEVPTR(PL_curcop);
5879 PL_curcop = &PL_compiling;
5881 SAVECOPLINE(PL_curcop);
5882 CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
5885 PL_hints &= ~HINT_BLOCK_SCOPE;
5888 SAVESPTR(PL_curstash);
5889 SAVECOPSTASH(PL_curcop);
5890 PL_curstash = stash;
5891 CopSTASH_set(PL_curcop,stash);
5894 /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
5895 and so doesn't get free()d. (It's expected to be from the C pre-
5896 processor __FILE__ directive). But we need a dynamically allocated one,
5897 and we need it to get freed. */
5898 cv = newXS_flags(name, const_sv_xsub, file, "", XS_DYNAMIC_FILENAME);
5899 CvXSUBANY(cv).any_ptr = sv;
5905 CopSTASH_free(PL_curcop);
5913 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
5914 const char *const filename, const char *const proto,
5917 CV *cv = newXS(name, subaddr, filename);
5919 PERL_ARGS_ASSERT_NEWXS_FLAGS;
5921 if (flags & XS_DYNAMIC_FILENAME) {
5922 /* We need to "make arrangements" (ie cheat) to ensure that the
5923 filename lasts as long as the PVCV we just created, but also doesn't
5925 STRLEN filename_len = strlen(filename);
5926 STRLEN proto_and_file_len = filename_len;
5927 char *proto_and_file;
5931 proto_len = strlen(proto);
5932 proto_and_file_len += proto_len;
5934 Newx(proto_and_file, proto_and_file_len + 1, char);
5935 Copy(proto, proto_and_file, proto_len, char);
5936 Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
5939 proto_and_file = savepvn(filename, filename_len);
5942 /* This gets free()d. :-) */
5943 sv_usepvn_flags((SV*)cv, proto_and_file, proto_and_file_len,
5944 SV_HAS_TRAILING_NUL);
5946 /* This gives us the correct prototype, rather than one with the
5947 file name appended. */
5948 SvCUR_set(cv, proto_len);
5952 CvFILE(cv) = proto_and_file + proto_len;
5954 sv_setpv((SV *)cv, proto);
5960 =for apidoc U||newXS
5962 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
5963 static storage, as it is used directly as CvFILE(), without a copy being made.
5969 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
5972 GV * const gv = gv_fetchpv(name ? name :
5973 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5974 GV_ADDMULTI, SVt_PVCV);
5977 PERL_ARGS_ASSERT_NEWXS;
5980 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
5982 if ((cv = (name ? GvCV(gv) : NULL))) {
5984 /* just a cached method */
5988 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5989 /* already defined (or promised) */
5990 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
5991 if (ckWARN(WARN_REDEFINE)) {
5992 GV * const gvcv = CvGV(cv);
5994 HV * const stash = GvSTASH(gvcv);
5996 const char *redefined_name = HvNAME_get(stash);
5997 if ( strEQ(redefined_name,"autouse") ) {
5998 const line_t oldline = CopLINE(PL_curcop);
5999 if (PL_parser && PL_parser->copline != NOLINE)
6000 CopLINE_set(PL_curcop, PL_parser->copline);
6001 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6002 CvCONST(cv) ? "Constant subroutine %s redefined"
6003 : "Subroutine %s redefined"
6005 CopLINE_set(PL_curcop, oldline);
6015 if (cv) /* must reuse cv if autoloaded */
6018 cv = (CV*)newSV_type(SVt_PVCV);
6022 mro_method_changed_in(GvSTASH(gv)); /* newXS */
6026 (void)gv_fetchfile(filename);
6027 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
6028 an external constant string */
6030 CvXSUB(cv) = subaddr;
6033 process_special_blocks(name, gv, cv);
6045 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
6050 OP* pegop = newOP(OP_NULL, 0);
6054 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
6055 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
6057 #ifdef GV_UNIQUE_CHECK
6059 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
6063 if ((cv = GvFORM(gv))) {
6064 if (ckWARN(WARN_REDEFINE)) {
6065 const line_t oldline = CopLINE(PL_curcop);
6066 if (PL_parser && PL_parser->copline != NOLINE)
6067 CopLINE_set(PL_curcop, PL_parser->copline);
6068 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
6069 o ? "Format %"SVf" redefined"
6070 : "Format STDOUT redefined", SVfARG(cSVOPo->op_sv));
6071 CopLINE_set(PL_curcop, oldline);
6078 CvFILE_set_from_cop(cv, PL_curcop);
6081 pad_tidy(padtidy_FORMAT);
6082 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
6083 CvROOT(cv)->op_private |= OPpREFCOUNTED;
6084 OpREFCNT_set(CvROOT(cv), 1);
6085 CvSTART(cv) = LINKLIST(CvROOT(cv));
6086 CvROOT(cv)->op_next = 0;
6087 CALL_PEEP(CvSTART(cv));
6089 op_getmad(o,pegop,'n');
6090 op_getmad_weak(block, pegop, 'b');
6095 PL_parser->copline = NOLINE;
6103 Perl_newANONLIST(pTHX_ OP *o)
6105 return convert(OP_ANONLIST, OPf_SPECIAL, o);
6109 Perl_newANONHASH(pTHX_ OP *o)
6111 return convert(OP_ANONHASH, OPf_SPECIAL, o);
6115 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
6117 return newANONATTRSUB(floor, proto, NULL, block);
6121 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
6123 return newUNOP(OP_REFGEN, 0,
6124 newSVOP(OP_ANONCODE, 0,
6125 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
6129 Perl_oopsAV(pTHX_ OP *o)
6133 PERL_ARGS_ASSERT_OOPSAV;
6135 switch (o->op_type) {
6137 o->op_type = OP_PADAV;
6138 o->op_ppaddr = PL_ppaddr[OP_PADAV];
6139 return ref(o, OP_RV2AV);
6142 o->op_type = OP_RV2AV;
6143 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
6148 if (ckWARN_d(WARN_INTERNAL))
6149 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
6156 Perl_oopsHV(pTHX_ OP *o)
6160 PERL_ARGS_ASSERT_OOPSHV;
6162 switch (o->op_type) {
6165 o->op_type = OP_PADHV;
6166 o->op_ppaddr = PL_ppaddr[OP_PADHV];
6167 return ref(o, OP_RV2HV);
6171 o->op_type = OP_RV2HV;
6172 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
6177 if (ckWARN_d(WARN_INTERNAL))
6178 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
6185 Perl_newAVREF(pTHX_ OP *o)
6189 PERL_ARGS_ASSERT_NEWAVREF;
6191 if (o->op_type == OP_PADANY) {
6192 o->op_type = OP_PADAV;
6193 o->op_ppaddr = PL_ppaddr[OP_PADAV];
6196 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
6197 && ckWARN(WARN_DEPRECATED)) {
6198 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
6199 "Using an array as a reference is deprecated");
6201 return newUNOP(OP_RV2AV, 0, scalar(o));
6205 Perl_newGVREF(pTHX_ I32 type, OP *o)
6207 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
6208 return newUNOP(OP_NULL, 0, o);
6209 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
6213 Perl_newHVREF(pTHX_ OP *o)
6217 PERL_ARGS_ASSERT_NEWHVREF;
6219 if (o->op_type == OP_PADANY) {
6220 o->op_type = OP_PADHV;
6221 o->op_ppaddr = PL_ppaddr[OP_PADHV];
6224 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
6225 && ckWARN(WARN_DEPRECATED)) {
6226 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
6227 "Using a hash as a reference is deprecated");
6229 return newUNOP(OP_RV2HV, 0, scalar(o));
6233 Perl_newCVREF(pTHX_ I32 flags, OP *o)
6235 return newUNOP(OP_RV2CV, flags, scalar(o));
6239 Perl_newSVREF(pTHX_ OP *o)
6243 PERL_ARGS_ASSERT_NEWSVREF;
6245 if (o->op_type == OP_PADANY) {
6246 o->op_type = OP_PADSV;
6247 o->op_ppaddr = PL_ppaddr[OP_PADSV];
6250 return newUNOP(OP_RV2SV, 0, scalar(o));
6253 /* Check routines. See the comments at the top of this file for details
6254 * on when these are called */
6257 Perl_ck_anoncode(pTHX_ OP *o)
6259 PERL_ARGS_ASSERT_CK_ANONCODE;
6261 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
6263 cSVOPo->op_sv = NULL;
6268 Perl_ck_bitop(pTHX_ OP *o)
6272 PERL_ARGS_ASSERT_CK_BITOP;
6274 #define OP_IS_NUMCOMPARE(op) \
6275 ((op) == OP_LT || (op) == OP_I_LT || \
6276 (op) == OP_GT || (op) == OP_I_GT || \
6277 (op) == OP_LE || (op) == OP_I_LE || \
6278 (op) == OP_GE || (op) == OP_I_GE || \
6279 (op) == OP_EQ || (op) == OP_I_EQ || \
6280 (op) == OP_NE || (op) == OP_I_NE || \
6281 (op) == OP_NCMP || (op) == OP_I_NCMP)
6282 o->op_private = (U8)(PL_hints & HINT_INTEGER);
6283 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
6284 && (o->op_type == OP_BIT_OR
6285 || o->op_type == OP_BIT_AND
6286 || o->op_type == OP_BIT_XOR))
6288 const OP * const left = cBINOPo->op_first;
6289 const OP * const right = left->op_sibling;
6290 if ((OP_IS_NUMCOMPARE(left->op_type) &&
6291 (left->op_flags & OPf_PARENS) == 0) ||
6292 (OP_IS_NUMCOMPARE(right->op_type) &&
6293 (right->op_flags & OPf_PARENS) == 0))
6294 if (ckWARN(WARN_PRECEDENCE))
6295 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
6296 "Possible precedence problem on bitwise %c operator",
6297 o->op_type == OP_BIT_OR ? '|'
6298 : o->op_type == OP_BIT_AND ? '&' : '^'
6305 Perl_ck_concat(pTHX_ OP *o)
6307 const OP * const kid = cUNOPo->op_first;
6309 PERL_ARGS_ASSERT_CK_CONCAT;
6310 PERL_UNUSED_CONTEXT;
6312 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
6313 !(kUNOP->op_first->op_flags & OPf_MOD))
6314 o->op_flags |= OPf_STACKED;
6319 Perl_ck_spair(pTHX_ OP *o)
6323 PERL_ARGS_ASSERT_CK_SPAIR;
6325 if (o->op_flags & OPf_KIDS) {
6328 const OPCODE type = o->op_type;
6329 o = modkids(ck_fun(o), type);
6330 kid = cUNOPo->op_first;
6331 newop = kUNOP->op_first->op_sibling;
6333 const OPCODE type = newop->op_type;
6334 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
6335 type == OP_PADAV || type == OP_PADHV ||
6336 type == OP_RV2AV || type == OP_RV2HV)
6340 op_getmad(kUNOP->op_first,newop,'K');
6342 op_free(kUNOP->op_first);
6344 kUNOP->op_first = newop;
6346 o->op_ppaddr = PL_ppaddr[++o->op_type];
6351 Perl_ck_delete(pTHX_ OP *o)
6353 PERL_ARGS_ASSERT_CK_DELETE;
6357 if (o->op_flags & OPf_KIDS) {
6358 OP * const kid = cUNOPo->op_first;
6359 switch (kid->op_type) {
6361 o->op_flags |= OPf_SPECIAL;
6364 o->op_private |= OPpSLICE;
6367 o->op_flags |= OPf_SPECIAL;
6372 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
6381 Perl_ck_die(pTHX_ OP *o)
6383 PERL_ARGS_ASSERT_CK_DIE;
6386 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6392 Perl_ck_eof(pTHX_ OP *o)
6396 PERL_ARGS_ASSERT_CK_EOF;
6398 if (o->op_flags & OPf_KIDS) {
6399 if (cLISTOPo->op_first->op_type == OP_STUB) {
6401 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
6403 op_getmad(o,newop,'O');
6415 Perl_ck_eval(pTHX_ OP *o)
6419 PERL_ARGS_ASSERT_CK_EVAL;
6421 PL_hints |= HINT_BLOCK_SCOPE;
6422 if (o->op_flags & OPf_KIDS) {
6423 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6426 o->op_flags &= ~OPf_KIDS;
6429 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
6435 cUNOPo->op_first = 0;
6440 NewOp(1101, enter, 1, LOGOP);
6441 enter->op_type = OP_ENTERTRY;
6442 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
6443 enter->op_private = 0;
6445 /* establish postfix order */
6446 enter->op_next = (OP*)enter;
6448 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
6449 o->op_type = OP_LEAVETRY;
6450 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
6451 enter->op_other = o;
6452 op_getmad(oldo,o,'O');
6466 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
6467 op_getmad(oldo,o,'O');
6469 o->op_targ = (PADOFFSET)PL_hints;
6470 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
6471 /* Store a copy of %^H that pp_entereval can pick up.
6472 OPf_SPECIAL flags the opcode as being for this purpose,
6473 so that it in turn will return a copy at every
6475 OP *hhop = newSVOP(OP_CONST, OPf_SPECIAL,
6476 (SV*)Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv)));
6477 cUNOPo->op_first->op_sibling = hhop;
6478 o->op_private |= OPpEVAL_HAS_HH;
6484 Perl_ck_exit(pTHX_ OP *o)
6486 PERL_ARGS_ASSERT_CK_EXIT;
6489 HV * const table = GvHV(PL_hintgv);
6491 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
6492 if (svp && *svp && SvTRUE(*svp))
6493 o->op_private |= OPpEXIT_VMSISH;
6495 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6501 Perl_ck_exec(pTHX_ OP *o)
6503 PERL_ARGS_ASSERT_CK_EXEC;
6505 if (o->op_flags & OPf_STACKED) {
6508 kid = cUNOPo->op_first->op_sibling;
6509 if (kid->op_type == OP_RV2GV)
6518 Perl_ck_exists(pTHX_ OP *o)
6522 PERL_ARGS_ASSERT_CK_EXISTS;
6525 if (o->op_flags & OPf_KIDS) {
6526 OP * const kid = cUNOPo->op_first;
6527 if (kid->op_type == OP_ENTERSUB) {
6528 (void) ref(kid, o->op_type);
6529 if (kid->op_type != OP_RV2CV
6530 && !(PL_parser && PL_parser->error_count))
6531 Perl_croak(aTHX_ "%s argument is not a subroutine name",
6533 o->op_private |= OPpEXISTS_SUB;
6535 else if (kid->op_type == OP_AELEM)
6536 o->op_flags |= OPf_SPECIAL;
6537 else if (kid->op_type != OP_HELEM)
6538 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
6546 Perl_ck_rvconst(pTHX_ register OP *o)
6549 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6551 PERL_ARGS_ASSERT_CK_RVCONST;
6553 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6554 if (o->op_type == OP_RV2CV)
6555 o->op_private &= ~1;
6557 if (kid->op_type == OP_CONST) {
6560 SV * const kidsv = kid->op_sv;
6562 /* Is it a constant from cv_const_sv()? */
6563 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
6564 SV * const rsv = SvRV(kidsv);
6565 const svtype type = SvTYPE(rsv);
6566 const char *badtype = NULL;
6568 switch (o->op_type) {
6570 if (type > SVt_PVMG)
6571 badtype = "a SCALAR";
6574 if (type != SVt_PVAV)
6575 badtype = "an ARRAY";
6578 if (type != SVt_PVHV)
6582 if (type != SVt_PVCV)
6587 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
6590 else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
6591 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
6592 /* If this is an access to a stash, disable "strict refs", because
6593 * stashes aren't auto-vivified at compile-time (unless we store
6594 * symbols in them), and we don't want to produce a run-time
6595 * stricture error when auto-vivifying the stash. */
6596 const char *s = SvPV_nolen(kidsv);
6597 const STRLEN l = SvCUR(kidsv);
6598 if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
6599 o->op_private &= ~HINT_STRICT_REFS;
6601 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
6602 const char *badthing;
6603 switch (o->op_type) {
6605 badthing = "a SCALAR";
6608 badthing = "an ARRAY";
6611 badthing = "a HASH";
6619 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
6620 SVfARG(kidsv), badthing);
6623 * This is a little tricky. We only want to add the symbol if we
6624 * didn't add it in the lexer. Otherwise we get duplicate strict
6625 * warnings. But if we didn't add it in the lexer, we must at
6626 * least pretend like we wanted to add it even if it existed before,
6627 * or we get possible typo warnings. OPpCONST_ENTERED says
6628 * whether the lexer already added THIS instance of this symbol.
6630 iscv = (o->op_type == OP_RV2CV) * 2;
6632 gv = gv_fetchsv(kidsv,
6633 iscv | !(kid->op_private & OPpCONST_ENTERED),
6636 : o->op_type == OP_RV2SV
6638 : o->op_type == OP_RV2AV
6640 : o->op_type == OP_RV2HV
6643 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
6645 kid->op_type = OP_GV;
6646 SvREFCNT_dec(kid->op_sv);
6648 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
6649 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
6650 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
6652 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc_simple_NN(gv));
6654 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
6656 kid->op_private = 0;
6657 kid->op_ppaddr = PL_ppaddr[OP_GV];
6664 Perl_ck_ftst(pTHX_ OP *o)
6667 const I32 type = o->op_type;
6669 PERL_ARGS_ASSERT_CK_FTST;
6671 if (o->op_flags & OPf_REF) {
6674 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
6675 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6676 const OPCODE kidtype = kid->op_type;
6678 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6679 OP * const newop = newGVOP(type, OPf_REF,
6680 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
6682 op_getmad(o,newop,'O');
6688 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o))
6689 o->op_private |= OPpFT_ACCESS;
6690 if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst)
6691 && kidtype != OP_STAT && kidtype != OP_LSTAT)
6692 o->op_private |= OPpFT_STACKED;
6700 if (type == OP_FTTTY)
6701 o = newGVOP(type, OPf_REF, PL_stdingv);
6703 o = newUNOP(type, 0, newDEFSVOP());
6704 op_getmad(oldo,o,'O');
6710 Perl_ck_fun(pTHX_ OP *o)
6713 const int type = o->op_type;
6714 register I32 oa = PL_opargs[type] >> OASHIFT;
6716 PERL_ARGS_ASSERT_CK_FUN;
6718 if (o->op_flags & OPf_STACKED) {
6719 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
6722 return no_fh_allowed(o);
6725 if (o->op_flags & OPf_KIDS) {
6726 OP **tokid = &cLISTOPo->op_first;
6727 register OP *kid = cLISTOPo->op_first;
6731 if (kid->op_type == OP_PUSHMARK ||
6732 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
6734 tokid = &kid->op_sibling;
6735 kid = kid->op_sibling;
6737 if (!kid && PL_opargs[type] & OA_DEFGV)
6738 *tokid = kid = newDEFSVOP();
6742 sibl = kid->op_sibling;
6744 if (!sibl && kid->op_type == OP_STUB) {
6751 /* list seen where single (scalar) arg expected? */
6752 if (numargs == 1 && !(oa >> 4)
6753 && kid->op_type == OP_LIST && type != OP_SCALAR)
6755 return too_many_arguments(o,PL_op_desc[type]);
6768 if ((type == OP_PUSH || type == OP_UNSHIFT)
6769 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
6770 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6771 "Useless use of %s with no values",
6774 if (kid->op_type == OP_CONST &&
6775 (kid->op_private & OPpCONST_BARE))
6777 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
6778 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
6779 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6780 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6781 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
6782 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6784 op_getmad(kid,newop,'K');
6789 kid->op_sibling = sibl;
6792 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
6793 bad_type(numargs, "array", PL_op_desc[type], kid);
6797 if (kid->op_type == OP_CONST &&
6798 (kid->op_private & OPpCONST_BARE))
6800 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
6801 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
6802 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6803 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6804 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
6805 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6807 op_getmad(kid,newop,'K');
6812 kid->op_sibling = sibl;
6815 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
6816 bad_type(numargs, "hash", PL_op_desc[type], kid);
6821 OP * const newop = newUNOP(OP_NULL, 0, kid);
6822 kid->op_sibling = 0;
6824 newop->op_next = newop;
6826 kid->op_sibling = sibl;
6831 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
6832 if (kid->op_type == OP_CONST &&
6833 (kid->op_private & OPpCONST_BARE))
6835 OP * const newop = newGVOP(OP_GV, 0,
6836 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
6837 if (!(o->op_private & 1) && /* if not unop */
6838 kid == cLISTOPo->op_last)
6839 cLISTOPo->op_last = newop;
6841 op_getmad(kid,newop,'K');
6847 else if (kid->op_type == OP_READLINE) {
6848 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
6849 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
6852 I32 flags = OPf_SPECIAL;
6856 /* is this op a FH constructor? */
6857 if (is_handle_constructor(o,numargs)) {
6858 const char *name = NULL;
6862 /* Set a flag to tell rv2gv to vivify
6863 * need to "prove" flag does not mean something
6864 * else already - NI-S 1999/05/07
6867 if (kid->op_type == OP_PADSV) {
6869 = PAD_COMPNAME_SV(kid->op_targ);
6870 name = SvPV_const(namesv, len);
6872 else if (kid->op_type == OP_RV2SV
6873 && kUNOP->op_first->op_type == OP_GV)
6875 GV * const gv = cGVOPx_gv(kUNOP->op_first);
6877 len = GvNAMELEN(gv);
6879 else if (kid->op_type == OP_AELEM
6880 || kid->op_type == OP_HELEM)
6883 OP *op = ((BINOP*)kid)->op_first;
6887 const char * const a =
6888 kid->op_type == OP_AELEM ?
6890 if (((op->op_type == OP_RV2AV) ||
6891 (op->op_type == OP_RV2HV)) &&
6892 (firstop = ((UNOP*)op)->op_first) &&
6893 (firstop->op_type == OP_GV)) {
6894 /* packagevar $a[] or $h{} */
6895 GV * const gv = cGVOPx_gv(firstop);
6903 else if (op->op_type == OP_PADAV
6904 || op->op_type == OP_PADHV) {
6905 /* lexicalvar $a[] or $h{} */
6906 const char * const padname =
6907 PAD_COMPNAME_PV(op->op_targ);
6916 name = SvPV_const(tmpstr, len);
6921 name = "__ANONIO__";
6928 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
6929 namesv = PAD_SVl(targ);
6930 SvUPGRADE(namesv, SVt_PV);
6932 sv_setpvn(namesv, "$", 1);
6933 sv_catpvn(namesv, name, len);
6936 kid->op_sibling = 0;
6937 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
6938 kid->op_targ = targ;
6939 kid->op_private |= priv;
6941 kid->op_sibling = sibl;
6947 mod(scalar(kid), type);
6951 tokid = &kid->op_sibling;
6952 kid = kid->op_sibling;
6955 if (kid && kid->op_type != OP_STUB)
6956 return too_many_arguments(o,OP_DESC(o));
6957 o->op_private |= numargs;
6959 /* FIXME - should the numargs move as for the PERL_MAD case? */
6960 o->op_private |= numargs;
6962 return too_many_arguments(o,OP_DESC(o));
6966 else if (PL_opargs[type] & OA_DEFGV) {
6968 OP *newop = newUNOP(type, 0, newDEFSVOP());
6969 op_getmad(o,newop,'O');
6972 /* Ordering of these two is important to keep f_map.t passing. */
6974 return newUNOP(type, 0, newDEFSVOP());
6979 while (oa & OA_OPTIONAL)
6981 if (oa && oa != OA_LIST)
6982 return too_few_arguments(o,OP_DESC(o));
6988 Perl_ck_glob(pTHX_ OP *o)
6993 PERL_ARGS_ASSERT_CK_GLOB;
6996 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
6997 append_elem(OP_GLOB, o, newDEFSVOP());
6999 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
7000 && GvCVu(gv) && GvIMPORTED_CV(gv)))
7002 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7005 #if !defined(PERL_EXTERNAL_GLOB)
7006 /* XXX this can be tightened up and made more failsafe. */
7007 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7010 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
7011 newSVpvs("File::Glob"), NULL, NULL, NULL);
7012 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
7013 glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
7014 GvCV(gv) = GvCV(glob_gv);
7015 SvREFCNT_inc_void((SV*)GvCV(gv));
7016 GvIMPORTED_CV_on(gv);
7019 #endif /* PERL_EXTERNAL_GLOB */
7021 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7022 append_elem(OP_GLOB, o,
7023 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
7024 o->op_type = OP_LIST;
7025 o->op_ppaddr = PL_ppaddr[OP_LIST];
7026 cLISTOPo->op_first->op_type = OP_PUSHMARK;
7027 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
7028 cLISTOPo->op_first->op_targ = 0;
7029 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
7030 append_elem(OP_LIST, o,
7031 scalar(newUNOP(OP_RV2CV, 0,
7032 newGVOP(OP_GV, 0, gv)))));
7033 o = newUNOP(OP_NULL, 0, ck_subr(o));
7034 o->op_targ = OP_GLOB; /* hint at what it used to be */
7037 gv = newGVgen("main");
7039 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
7045 Perl_ck_grep(pTHX_ OP *o)
7050 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
7053 PERL_ARGS_ASSERT_CK_GREP;
7055 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
7056 /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
7058 if (o->op_flags & OPf_STACKED) {
7061 kid = cLISTOPo->op_first->op_sibling;
7062 if (!cUNOPx(kid)->op_next)
7063 Perl_croak(aTHX_ "panic: ck_grep");
7064 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
7067 NewOp(1101, gwop, 1, LOGOP);
7068 kid->op_next = (OP*)gwop;
7069 o->op_flags &= ~OPf_STACKED;
7071 kid = cLISTOPo->op_first->op_sibling;
7072 if (type == OP_MAPWHILE)
7077 if (PL_parser && PL_parser->error_count)
7079 kid = cLISTOPo->op_first->op_sibling;
7080 if (kid->op_type != OP_NULL)
7081 Perl_croak(aTHX_ "panic: ck_grep");
7082 kid = kUNOP->op_first;
7085 NewOp(1101, gwop, 1, LOGOP);
7086 gwop->op_type = type;
7087 gwop->op_ppaddr = PL_ppaddr[type];
7088 gwop->op_first = listkids(o);
7089 gwop->op_flags |= OPf_KIDS;
7090 gwop->op_other = LINKLIST(kid);
7091 kid->op_next = (OP*)gwop;
7092 offset = pad_findmy("$_");
7093 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
7094 o->op_private = gwop->op_private = 0;
7095 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
7098 o->op_private = gwop->op_private = OPpGREP_LEX;
7099 gwop->op_targ = o->op_targ = offset;
7102 kid = cLISTOPo->op_first->op_sibling;
7103 if (!kid || !kid->op_sibling)
7104 return too_few_arguments(o,OP_DESC(o));
7105 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
7106 mod(kid, OP_GREPSTART);
7112 Perl_ck_index(pTHX_ OP *o)
7114 PERL_ARGS_ASSERT_CK_INDEX;
7116 if (o->op_flags & OPf_KIDS) {
7117 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7119 kid = kid->op_sibling; /* get past "big" */
7120 if (kid && kid->op_type == OP_CONST)
7121 fbm_compile(((SVOP*)kid)->op_sv, 0);
7127 Perl_ck_lfun(pTHX_ OP *o)
7129 const OPCODE type = o->op_type;
7131 PERL_ARGS_ASSERT_CK_LFUN;
7133 return modkids(ck_fun(o), type);
7137 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
7139 PERL_ARGS_ASSERT_CK_DEFINED;
7141 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
7142 switch (cUNOPo->op_first->op_type) {
7144 /* This is needed for
7145 if (defined %stash::)
7146 to work. Do not break Tk.
7148 break; /* Globals via GV can be undef */
7150 case OP_AASSIGN: /* Is this a good idea? */
7151 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
7152 "defined(@array) is deprecated");
7153 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
7154 "\t(Maybe you should just omit the defined()?)\n");
7157 /* This is needed for
7158 if (defined %stash::)
7159 to work. Do not break Tk.
7161 break; /* Globals via GV can be undef */
7163 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
7164 "defined(%%hash) is deprecated");
7165 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
7166 "\t(Maybe you should just omit the defined()?)\n");
7177 Perl_ck_readline(pTHX_ OP *o)
7179 PERL_ARGS_ASSERT_CK_READLINE;
7181 if (!(o->op_flags & OPf_KIDS)) {
7183 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
7185 op_getmad(o,newop,'O');
7195 Perl_ck_rfun(pTHX_ OP *o)
7197 const OPCODE type = o->op_type;
7199 PERL_ARGS_ASSERT_CK_RFUN;
7201 return refkids(ck_fun(o), type);
7205 Perl_ck_listiob(pTHX_ OP *o)
7209 PERL_ARGS_ASSERT_CK_LISTIOB;
7211 kid = cLISTOPo->op_first;
7214 kid = cLISTOPo->op_first;
7216 if (kid->op_type == OP_PUSHMARK)
7217 kid = kid->op_sibling;
7218 if (kid && o->op_flags & OPf_STACKED)
7219 kid = kid->op_sibling;
7220 else if (kid && !kid->op_sibling) { /* print HANDLE; */
7221 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
7222 o->op_flags |= OPf_STACKED; /* make it a filehandle */
7223 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
7224 cLISTOPo->op_first->op_sibling = kid;
7225 cLISTOPo->op_last = kid;
7226 kid = kid->op_sibling;
7231 append_elem(o->op_type, o, newDEFSVOP());
7237 Perl_ck_smartmatch(pTHX_ OP *o)
7240 if (0 == (o->op_flags & OPf_SPECIAL)) {
7241 OP *first = cBINOPo->op_first;
7242 OP *second = first->op_sibling;
7244 /* Implicitly take a reference to an array or hash */
7245 first->op_sibling = NULL;
7246 first = cBINOPo->op_first = ref_array_or_hash(first);
7247 second = first->op_sibling = ref_array_or_hash(second);
7249 /* Implicitly take a reference to a regular expression */
7250 if (first->op_type == OP_MATCH) {
7251 first->op_type = OP_QR;
7252 first->op_ppaddr = PL_ppaddr[OP_QR];
7254 if (second->op_type == OP_MATCH) {
7255 second->op_type = OP_QR;
7256 second->op_ppaddr = PL_ppaddr[OP_QR];
7265 Perl_ck_sassign(pTHX_ OP *o)
7268 OP * const kid = cLISTOPo->op_first;
7270 PERL_ARGS_ASSERT_CK_SASSIGN;
7272 /* has a disposable target? */
7273 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
7274 && !(kid->op_flags & OPf_STACKED)
7275 /* Cannot steal the second time! */
7276 && !(kid->op_private & OPpTARGET_MY)
7277 /* Keep the full thing for madskills */
7281 OP * const kkid = kid->op_sibling;
7283 /* Can just relocate the target. */
7284 if (kkid && kkid->op_type == OP_PADSV
7285 && !(kkid->op_private & OPpLVAL_INTRO))
7287 kid->op_targ = kkid->op_targ;
7289 /* Now we do not need PADSV and SASSIGN. */
7290 kid->op_sibling = o->op_sibling; /* NULL */
7291 cLISTOPo->op_first = NULL;
7294 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
7298 if (kid->op_sibling) {
7299 OP *kkid = kid->op_sibling;
7300 if (kkid->op_type == OP_PADSV
7301 && (kkid->op_private & OPpLVAL_INTRO)
7302 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
7303 const PADOFFSET target = kkid->op_targ;
7304 OP *const other = newOP(OP_PADSV,
7306 | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
7307 OP *const first = newOP(OP_NULL, 0);
7308 OP *const nullop = newCONDOP(0, first, o, other);
7309 OP *const condop = first->op_next;
7310 /* hijacking PADSTALE for uninitialized state variables */
7311 SvPADSTALE_on(PAD_SVl(target));
7313 condop->op_type = OP_ONCE;
7314 condop->op_ppaddr = PL_ppaddr[OP_ONCE];
7315 condop->op_targ = target;
7316 other->op_targ = target;
7318 /* Because we change the type of the op here, we will skip the
7319 assinment binop->op_last = binop->op_first->op_sibling; at the
7320 end of Perl_newBINOP(). So need to do it here. */
7321 cBINOPo->op_last = cBINOPo->op_first->op_sibling;
7330 Perl_ck_match(pTHX_ OP *o)
7334 PERL_ARGS_ASSERT_CK_MATCH;
7336 if (o->op_type != OP_QR && PL_compcv) {
7337 const PADOFFSET offset = pad_findmy("$_");
7338 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
7339 o->op_targ = offset;
7340 o->op_private |= OPpTARGET_MY;
7343 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
7344 o->op_private |= OPpRUNTIME;
7349 Perl_ck_method(pTHX_ OP *o)
7351 OP * const kid = cUNOPo->op_first;
7353 PERL_ARGS_ASSERT_CK_METHOD;
7355 if (kid->op_type == OP_CONST) {
7356 SV* sv = kSVOP->op_sv;
7357 const char * const method = SvPVX_const(sv);
7358 if (!(strchr(method, ':') || strchr(method, '\''))) {
7360 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
7361 sv = newSVpvn_share(method, SvCUR(sv), 0);
7364 kSVOP->op_sv = NULL;
7366 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
7368 op_getmad(o,cmop,'O');
7379 Perl_ck_null(pTHX_ OP *o)
7381 PERL_ARGS_ASSERT_CK_NULL;
7382 PERL_UNUSED_CONTEXT;
7387 Perl_ck_open(pTHX_ OP *o)
7390 HV * const table = GvHV(PL_hintgv);
7392 PERL_ARGS_ASSERT_CK_OPEN;
7395 SV **svp = hv_fetchs(table, "open_IN", FALSE);
7397 const I32 mode = mode_from_discipline(*svp);
7398 if (mode & O_BINARY)
7399 o->op_private |= OPpOPEN_IN_RAW;
7400 else if (mode & O_TEXT)
7401 o->op_private |= OPpOPEN_IN_CRLF;
7404 svp = hv_fetchs(table, "open_OUT", FALSE);
7406 const I32 mode = mode_from_discipline(*svp);
7407 if (mode & O_BINARY)
7408 o->op_private |= OPpOPEN_OUT_RAW;
7409 else if (mode & O_TEXT)
7410 o->op_private |= OPpOPEN_OUT_CRLF;
7413 if (o->op_type == OP_BACKTICK) {
7414 if (!(o->op_flags & OPf_KIDS)) {
7415 OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
7417 op_getmad(o,newop,'O');
7426 /* In case of three-arg dup open remove strictness
7427 * from the last arg if it is a bareword. */
7428 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
7429 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
7433 if ((last->op_type == OP_CONST) && /* The bareword. */
7434 (last->op_private & OPpCONST_BARE) &&
7435 (last->op_private & OPpCONST_STRICT) &&
7436 (oa = first->op_sibling) && /* The fh. */
7437 (oa = oa->op_sibling) && /* The mode. */
7438 (oa->op_type == OP_CONST) &&
7439 SvPOK(((SVOP*)oa)->op_sv) &&
7440 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
7441 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
7442 (last == oa->op_sibling)) /* The bareword. */
7443 last->op_private &= ~OPpCONST_STRICT;
7449 Perl_ck_repeat(pTHX_ OP *o)
7451 PERL_ARGS_ASSERT_CK_REPEAT;
7453 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
7454 o->op_private |= OPpREPEAT_DOLIST;
7455 cBINOPo->op_first = force_list(cBINOPo->op_first);
7463 Perl_ck_require(pTHX_ OP *o)
7468 PERL_ARGS_ASSERT_CK_REQUIRE;
7470 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
7471 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7473 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
7474 SV * const sv = kid->op_sv;
7475 U32 was_readonly = SvREADONLY(sv);
7482 sv_force_normal_flags(sv, 0);
7483 assert(!SvREADONLY(sv));
7493 for (; s < end; s++) {
7494 if (*s == ':' && s[1] == ':') {
7496 Move(s+2, s+1, end - s - 1, char);
7501 sv_catpvs(sv, ".pm");
7502 SvFLAGS(sv) |= was_readonly;
7506 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
7507 /* handle override, if any */
7508 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
7509 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7510 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
7511 gv = gvp ? *gvp : NULL;
7515 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7516 OP * const kid = cUNOPo->op_first;
7519 cUNOPo->op_first = 0;
7523 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
7524 append_elem(OP_LIST, kid,
7525 scalar(newUNOP(OP_RV2CV, 0,
7528 op_getmad(o,newop,'O');
7536 Perl_ck_return(pTHX_ OP *o)
7540 PERL_ARGS_ASSERT_CK_RETURN;
7542 if (CvLVALUE(PL_compcv)) {
7544 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
7545 mod(kid, OP_LEAVESUBLV);
7551 Perl_ck_select(pTHX_ OP *o)
7556 PERL_ARGS_ASSERT_CK_SELECT;
7558 if (o->op_flags & OPf_KIDS) {
7559 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7560 if (kid && kid->op_sibling) {
7561 o->op_type = OP_SSELECT;
7562 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
7564 return fold_constants(o);
7568 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7569 if (kid && kid->op_type == OP_RV2GV)
7570 kid->op_private &= ~HINT_STRICT_REFS;
7575 Perl_ck_shift(pTHX_ OP *o)
7578 const I32 type = o->op_type;
7580 PERL_ARGS_ASSERT_CK_SHIFT;
7582 if (!(o->op_flags & OPf_KIDS)) {
7584 /* FIXME - this can be refactored to reduce code in #ifdefs */
7586 OP * const oldo = o;
7590 argop = newUNOP(OP_RV2AV, 0,
7591 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
7593 o = newUNOP(type, 0, scalar(argop));
7594 op_getmad(oldo,o,'O');
7597 return newUNOP(type, 0, scalar(argop));
7600 return scalar(modkids(ck_fun(o), type));
7604 Perl_ck_sort(pTHX_ OP *o)
7609 PERL_ARGS_ASSERT_CK_SORT;
7611 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
7612 HV * const hinthv = GvHV(PL_hintgv);
7614 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
7616 const I32 sorthints = (I32)SvIV(*svp);
7617 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
7618 o->op_private |= OPpSORT_QSORT;
7619 if ((sorthints & HINT_SORT_STABLE) != 0)
7620 o->op_private |= OPpSORT_STABLE;
7625 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
7627 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7628 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
7630 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
7632 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
7634 if (kid->op_type == OP_SCOPE) {
7638 else if (kid->op_type == OP_LEAVE) {
7639 if (o->op_type == OP_SORT) {
7640 op_null(kid); /* wipe out leave */
7643 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
7644 if (k->op_next == kid)
7646 /* don't descend into loops */
7647 else if (k->op_type == OP_ENTERLOOP
7648 || k->op_type == OP_ENTERITER)
7650 k = cLOOPx(k)->op_lastop;
7655 kid->op_next = 0; /* just disconnect the leave */
7656 k = kLISTOP->op_first;
7661 if (o->op_type == OP_SORT) {
7662 /* provide scalar context for comparison function/block */
7668 o->op_flags |= OPf_SPECIAL;
7670 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
7673 firstkid = firstkid->op_sibling;
7676 /* provide list context for arguments */
7677 if (o->op_type == OP_SORT)
7684 S_simplify_sort(pTHX_ OP *o)
7687 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7693 PERL_ARGS_ASSERT_SIMPLIFY_SORT;
7695 if (!(o->op_flags & OPf_STACKED))
7697 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7698 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
7699 kid = kUNOP->op_first; /* get past null */
7700 if (kid->op_type != OP_SCOPE)
7702 kid = kLISTOP->op_last; /* get past scope */
7703 switch(kid->op_type) {
7711 k = kid; /* remember this node*/
7712 if (kBINOP->op_first->op_type != OP_RV2SV)
7714 kid = kBINOP->op_first; /* get past cmp */
7715 if (kUNOP->op_first->op_type != OP_GV)
7717 kid = kUNOP->op_first; /* get past rv2sv */
7719 if (GvSTASH(gv) != PL_curstash)
7721 gvname = GvNAME(gv);
7722 if (*gvname == 'a' && gvname[1] == '\0')
7724 else if (*gvname == 'b' && gvname[1] == '\0')
7729 kid = k; /* back to cmp */
7730 if (kBINOP->op_last->op_type != OP_RV2SV)
7732 kid = kBINOP->op_last; /* down to 2nd arg */
7733 if (kUNOP->op_first->op_type != OP_GV)
7735 kid = kUNOP->op_first; /* get past rv2sv */
7737 if (GvSTASH(gv) != PL_curstash)
7739 gvname = GvNAME(gv);
7741 ? !(*gvname == 'a' && gvname[1] == '\0')
7742 : !(*gvname == 'b' && gvname[1] == '\0'))
7744 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
7746 o->op_private |= OPpSORT_DESCEND;
7747 if (k->op_type == OP_NCMP)
7748 o->op_private |= OPpSORT_NUMERIC;
7749 if (k->op_type == OP_I_NCMP)
7750 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
7751 kid = cLISTOPo->op_first->op_sibling;
7752 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
7754 op_getmad(kid,o,'S'); /* then delete it */
7756 op_free(kid); /* then delete it */
7761 Perl_ck_split(pTHX_ OP *o)
7766 PERL_ARGS_ASSERT_CK_SPLIT;
7768 if (o->op_flags & OPf_STACKED)
7769 return no_fh_allowed(o);
7771 kid = cLISTOPo->op_first;
7772 if (kid->op_type != OP_NULL)
7773 Perl_croak(aTHX_ "panic: ck_split");
7774 kid = kid->op_sibling;
7775 op_free(cLISTOPo->op_first);
7776 cLISTOPo->op_first = kid;
7778 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
7779 cLISTOPo->op_last = kid; /* There was only one element previously */
7782 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
7783 OP * const sibl = kid->op_sibling;
7784 kid->op_sibling = 0;
7785 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
7786 if (cLISTOPo->op_first == cLISTOPo->op_last)
7787 cLISTOPo->op_last = kid;
7788 cLISTOPo->op_first = kid;
7789 kid->op_sibling = sibl;
7792 kid->op_type = OP_PUSHRE;
7793 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
7795 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
7796 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
7797 "Use of /g modifier is meaningless in split");
7800 if (!kid->op_sibling)
7801 append_elem(OP_SPLIT, o, newDEFSVOP());
7803 kid = kid->op_sibling;
7806 if (!kid->op_sibling)
7807 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
7808 assert(kid->op_sibling);
7810 kid = kid->op_sibling;
7813 if (kid->op_sibling)
7814 return too_many_arguments(o,OP_DESC(o));
7820 Perl_ck_join(pTHX_ OP *o)
7822 const OP * const kid = cLISTOPo->op_first->op_sibling;
7824 PERL_ARGS_ASSERT_CK_JOIN;
7826 if (kid && kid->op_type == OP_MATCH) {
7827 if (ckWARN(WARN_SYNTAX)) {
7828 const REGEXP *re = PM_GETRE(kPMOP);
7829 const char *pmstr = re ? RX_PRECOMP(re) : "STRING";
7830 const STRLEN len = re ? RX_PRELEN(re) : 6;
7831 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7832 "/%.*s/ should probably be written as \"%.*s\"",
7833 (int)len, pmstr, (int)len, pmstr);
7840 Perl_ck_subr(pTHX_ OP *o)
7843 OP *prev = ((cUNOPo->op_first->op_sibling)
7844 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
7845 OP *o2 = prev->op_sibling;
7847 const char *proto = NULL;
7848 const char *proto_end = NULL;
7853 I32 contextclass = 0;
7854 const char *e = NULL;
7857 PERL_ARGS_ASSERT_CK_SUBR;
7859 o->op_private |= OPpENTERSUB_HASTARG;
7860 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
7861 if (cvop->op_type == OP_RV2CV) {
7863 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
7864 op_null(cvop); /* disable rv2cv */
7865 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
7866 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
7867 GV *gv = cGVOPx_gv(tmpop);
7870 tmpop->op_private |= OPpEARLY_CV;
7874 namegv = CvANON(cv) ? gv : CvGV(cv);
7875 proto = SvPV((SV*)cv, len);
7876 proto_end = proto + len;
7881 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7882 if (o2->op_type == OP_CONST)
7883 o2->op_private &= ~OPpCONST_STRICT;
7884 else if (o2->op_type == OP_LIST) {
7885 OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
7886 if (sib && sib->op_type == OP_CONST)
7887 sib->op_private &= ~OPpCONST_STRICT;
7890 o->op_private |= (PL_hints & HINT_STRICT_REFS);
7891 if (PERLDB_SUB && PL_curstash != PL_debstash)
7892 o->op_private |= OPpENTERSUB_DB;
7893 while (o2 != cvop) {
7895 if (PL_madskills && o2->op_type == OP_STUB) {
7896 o2 = o2->op_sibling;
7899 if (PL_madskills && o2->op_type == OP_NULL)
7900 o3 = ((UNOP*)o2)->op_first;
7904 if (proto >= proto_end)
7905 return too_many_arguments(o, gv_ename(namegv));
7913 /* _ must be at the end */
7914 if (proto[1] && proto[1] != ';')
7929 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
7931 arg == 1 ? "block or sub {}" : "sub {}",
7932 gv_ename(namegv), o3);
7935 /* '*' allows any scalar type, including bareword */
7938 if (o3->op_type == OP_RV2GV)
7939 goto wrapref; /* autoconvert GLOB -> GLOBref */
7940 else if (o3->op_type == OP_CONST)
7941 o3->op_private &= ~OPpCONST_STRICT;
7942 else if (o3->op_type == OP_ENTERSUB) {
7943 /* accidental subroutine, revert to bareword */
7944 OP *gvop = ((UNOP*)o3)->op_first;
7945 if (gvop && gvop->op_type == OP_NULL) {
7946 gvop = ((UNOP*)gvop)->op_first;
7948 for (; gvop->op_sibling; gvop = gvop->op_sibling)
7951 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
7952 (gvop = ((UNOP*)gvop)->op_first) &&
7953 gvop->op_type == OP_GV)
7955 GV * const gv = cGVOPx_gv(gvop);
7956 OP * const sibling = o2->op_sibling;
7957 SV * const n = newSVpvs("");
7959 OP * const oldo2 = o2;
7963 gv_fullname4(n, gv, "", FALSE);
7964 o2 = newSVOP(OP_CONST, 0, n);
7965 op_getmad(oldo2,o2,'O');
7966 prev->op_sibling = o2;
7967 o2->op_sibling = sibling;
7983 if (contextclass++ == 0) {
7984 e = strchr(proto, ']');
7985 if (!e || e == proto)
7994 const char *p = proto;
7995 const char *const end = proto;
7997 while (*--p != '[');
7998 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
8000 gv_ename(namegv), o3);
8005 if (o3->op_type == OP_RV2GV)
8008 bad_type(arg, "symbol", gv_ename(namegv), o3);
8011 if (o3->op_type == OP_ENTERSUB)
8014 bad_type(arg, "subroutine entry", gv_ename(namegv),
8018 if (o3->op_type == OP_RV2SV ||
8019 o3->op_type == OP_PADSV ||
8020 o3->op_type == OP_HELEM ||
8021 o3->op_type == OP_AELEM)
8024 bad_type(arg, "scalar", gv_ename(namegv), o3);
8027 if (o3->op_type == OP_RV2AV ||
8028 o3->op_type == OP_PADAV)
8031 bad_type(arg, "array", gv_ename(namegv), o3);
8034 if (o3->op_type == OP_RV2HV ||
8035 o3->op_type == OP_PADHV)
8038 bad_type(arg, "hash", gv_ename(namegv), o3);
8043 OP* const sib = kid->op_sibling;
8044 kid->op_sibling = 0;
8045 o2 = newUNOP(OP_REFGEN, 0, kid);
8046 o2->op_sibling = sib;
8047 prev->op_sibling = o2;
8049 if (contextclass && e) {
8064 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
8065 gv_ename(namegv), SVfARG(cv));
8070 mod(o2, OP_ENTERSUB);
8072 o2 = o2->op_sibling;
8074 if (o2 == cvop && proto && *proto == '_') {
8075 /* generate an access to $_ */
8077 o2->op_sibling = prev->op_sibling;
8078 prev->op_sibling = o2; /* instead of cvop */
8080 if (proto && !optional && proto_end > proto &&
8081 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
8082 return too_few_arguments(o, gv_ename(namegv));
8085 OP * const oldo = o;
8089 o=newSVOP(OP_CONST, 0, newSViv(0));
8090 op_getmad(oldo,o,'O');
8096 Perl_ck_svconst(pTHX_ OP *o)
8098 PERL_ARGS_ASSERT_CK_SVCONST;
8099 PERL_UNUSED_CONTEXT;
8100 SvREADONLY_on(cSVOPo->op_sv);
8105 Perl_ck_chdir(pTHX_ OP *o)
8107 if (o->op_flags & OPf_KIDS) {
8108 SVOP * const kid = (SVOP*)cUNOPo->op_first;
8110 if (kid && kid->op_type == OP_CONST &&
8111 (kid->op_private & OPpCONST_BARE))
8113 o->op_flags |= OPf_SPECIAL;
8114 kid->op_private &= ~OPpCONST_STRICT;
8121 Perl_ck_trunc(pTHX_ OP *o)
8123 PERL_ARGS_ASSERT_CK_TRUNC;
8125 if (o->op_flags & OPf_KIDS) {
8126 SVOP *kid = (SVOP*)cUNOPo->op_first;
8128 if (kid->op_type == OP_NULL)
8129 kid = (SVOP*)kid->op_sibling;
8130 if (kid && kid->op_type == OP_CONST &&
8131 (kid->op_private & OPpCONST_BARE))
8133 o->op_flags |= OPf_SPECIAL;
8134 kid->op_private &= ~OPpCONST_STRICT;
8141 Perl_ck_unpack(pTHX_ OP *o)
8143 OP *kid = cLISTOPo->op_first;
8145 PERL_ARGS_ASSERT_CK_UNPACK;
8147 if (kid->op_sibling) {
8148 kid = kid->op_sibling;
8149 if (!kid->op_sibling)
8150 kid->op_sibling = newDEFSVOP();
8156 Perl_ck_substr(pTHX_ OP *o)
8158 PERL_ARGS_ASSERT_CK_SUBSTR;
8161 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
8162 OP *kid = cLISTOPo->op_first;
8164 if (kid->op_type == OP_NULL)
8165 kid = kid->op_sibling;
8167 kid->op_flags |= OPf_MOD;
8174 Perl_ck_each(pTHX_ OP *o)
8177 OP *kid = cLISTOPo->op_first;
8179 PERL_ARGS_ASSERT_CK_EACH;
8181 if (kid->op_type == OP_PADAV || kid->op_type == OP_RV2AV) {
8182 const unsigned new_type = o->op_type == OP_EACH ? OP_AEACH
8183 : o->op_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
8184 o->op_type = new_type;
8185 o->op_ppaddr = PL_ppaddr[new_type];
8187 else if (!(kid->op_type == OP_PADHV || kid->op_type == OP_RV2HV
8188 || (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE)
8190 bad_type(1, "hash or array", PL_op_desc[o->op_type], kid);
8196 /* A peephole optimizer. We visit the ops in the order they're to execute.
8197 * See the comments at the top of this file for more details about when
8198 * peep() is called */
8201 Perl_peep(pTHX_ register OP *o)
8204 register OP* oldop = NULL;
8206 if (!o || o->op_opt)
8210 SAVEVPTR(PL_curcop);
8211 for (; o; o = o->op_next) {
8214 /* By default, this op has now been optimised. A couple of cases below
8215 clear this again. */
8218 switch (o->op_type) {
8221 PL_curcop = ((COP*)o); /* for warnings */
8225 if (cSVOPo->op_private & OPpCONST_STRICT)
8226 no_bareword_allowed(o);
8228 case OP_METHOD_NAMED:
8229 /* Relocate sv to the pad for thread safety.
8230 * Despite being a "constant", the SV is written to,
8231 * for reference counts, sv_upgrade() etc. */
8233 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
8234 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
8235 /* If op_sv is already a PADTMP then it is being used by
8236 * some pad, so make a copy. */
8237 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
8238 SvREADONLY_on(PAD_SVl(ix));
8239 SvREFCNT_dec(cSVOPo->op_sv);
8241 else if (o->op_type == OP_CONST
8242 && cSVOPo->op_sv == &PL_sv_undef) {
8243 /* PL_sv_undef is hack - it's unsafe to store it in the
8244 AV that is the pad, because av_fetch treats values of
8245 PL_sv_undef as a "free" AV entry and will merrily
8246 replace them with a new SV, causing pad_alloc to think
8247 that this pad slot is free. (When, clearly, it is not)
8249 SvOK_off(PAD_SVl(ix));
8250 SvPADTMP_on(PAD_SVl(ix));
8251 SvREADONLY_on(PAD_SVl(ix));
8254 SvREFCNT_dec(PAD_SVl(ix));
8255 SvPADTMP_on(cSVOPo->op_sv);
8256 PAD_SETSV(ix, cSVOPo->op_sv);
8257 /* XXX I don't know how this isn't readonly already. */
8258 SvREADONLY_on(PAD_SVl(ix));
8260 cSVOPo->op_sv = NULL;
8267 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
8268 if (o->op_next->op_private & OPpTARGET_MY) {
8269 if (o->op_flags & OPf_STACKED) /* chained concats */
8270 break; /* ignore_optimization */
8272 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
8273 o->op_targ = o->op_next->op_targ;
8274 o->op_next->op_targ = 0;
8275 o->op_private |= OPpTARGET_MY;
8278 op_null(o->op_next);
8282 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
8283 break; /* Scalar stub must produce undef. List stub is noop */
8287 if (o->op_targ == OP_NEXTSTATE
8288 || o->op_targ == OP_DBSTATE)
8290 PL_curcop = ((COP*)o);
8292 /* XXX: We avoid setting op_seq here to prevent later calls
8293 to peep() from mistakenly concluding that optimisation
8294 has already occurred. This doesn't fix the real problem,
8295 though (See 20010220.007). AMS 20010719 */
8296 /* op_seq functionality is now replaced by op_opt */
8303 if (oldop && o->op_next) {
8304 oldop->op_next = o->op_next;
8312 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
8313 OP* const pop = (o->op_type == OP_PADAV) ?
8314 o->op_next : o->op_next->op_next;
8316 if (pop && pop->op_type == OP_CONST &&
8317 ((PL_op = pop->op_next)) &&
8318 pop->op_next->op_type == OP_AELEM &&
8319 !(pop->op_next->op_private &
8320 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
8321 (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
8326 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
8327 no_bareword_allowed(pop);
8328 if (o->op_type == OP_GV)
8329 op_null(o->op_next);
8330 op_null(pop->op_next);
8332 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
8333 o->op_next = pop->op_next->op_next;
8334 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
8335 o->op_private = (U8)i;
8336 if (o->op_type == OP_GV) {
8341 o->op_flags |= OPf_SPECIAL;
8342 o->op_type = OP_AELEMFAST;
8347 if (o->op_next->op_type == OP_RV2SV) {
8348 if (!(o->op_next->op_private & OPpDEREF)) {
8349 op_null(o->op_next);
8350 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
8352 o->op_next = o->op_next->op_next;
8353 o->op_type = OP_GVSV;
8354 o->op_ppaddr = PL_ppaddr[OP_GVSV];
8357 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
8358 GV * const gv = cGVOPo_gv;
8359 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
8360 /* XXX could check prototype here instead of just carping */
8361 SV * const sv = sv_newmortal();
8362 gv_efullname3(sv, gv, NULL);
8363 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
8364 "%"SVf"() called too early to check prototype",
8368 else if (o->op_next->op_type == OP_READLINE
8369 && o->op_next->op_next->op_type == OP_CONCAT
8370 && (o->op_next->op_next->op_flags & OPf_STACKED))
8372 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
8373 o->op_type = OP_RCATLINE;
8374 o->op_flags |= OPf_STACKED;
8375 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
8376 op_null(o->op_next->op_next);
8377 op_null(o->op_next);
8393 while (cLOGOP->op_other->op_type == OP_NULL)
8394 cLOGOP->op_other = cLOGOP->op_other->op_next;
8395 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
8400 while (cLOOP->op_redoop->op_type == OP_NULL)
8401 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
8402 peep(cLOOP->op_redoop);
8403 while (cLOOP->op_nextop->op_type == OP_NULL)
8404 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
8405 peep(cLOOP->op_nextop);
8406 while (cLOOP->op_lastop->op_type == OP_NULL)
8407 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
8408 peep(cLOOP->op_lastop);
8412 assert(!(cPMOP->op_pmflags & PMf_ONCE));
8413 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
8414 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
8415 cPMOP->op_pmstashstartu.op_pmreplstart
8416 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
8417 peep(cPMOP->op_pmstashstartu.op_pmreplstart);
8421 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
8422 && ckWARN(WARN_SYNTAX))
8424 if (o->op_next->op_sibling) {
8425 const OPCODE type = o->op_next->op_sibling->op_type;
8426 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
8427 const line_t oldline = CopLINE(PL_curcop);
8428 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
8429 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8430 "Statement unlikely to be reached");
8431 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8432 "\t(Maybe you meant system() when you said exec()?)\n");
8433 CopLINE_set(PL_curcop, oldline);
8444 const char *key = NULL;
8447 if (((BINOP*)o)->op_last->op_type != OP_CONST)
8450 /* Make the CONST have a shared SV */
8451 svp = cSVOPx_svp(((BINOP*)o)->op_last);
8452 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
8453 key = SvPV_const(sv, keylen);
8454 lexname = newSVpvn_share(key,
8455 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
8461 if ((o->op_private & (OPpLVAL_INTRO)))
8464 rop = (UNOP*)((BINOP*)o)->op_first;
8465 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
8467 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
8468 if (!SvPAD_TYPED(lexname))
8470 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8471 if (!fields || !GvHV(*fields))
8473 key = SvPV_const(*svp, keylen);
8474 if (!hv_fetch(GvHV(*fields), key,
8475 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8477 Perl_croak(aTHX_ "No such class field \"%s\" "
8478 "in variable %s of type %s",
8479 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
8492 SVOP *first_key_op, *key_op;
8494 if ((o->op_private & (OPpLVAL_INTRO))
8495 /* I bet there's always a pushmark... */
8496 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
8497 /* hmmm, no optimization if list contains only one key. */
8499 rop = (UNOP*)((LISTOP*)o)->op_last;
8500 if (rop->op_type != OP_RV2HV)
8502 if (rop->op_first->op_type == OP_PADSV)
8503 /* @$hash{qw(keys here)} */
8504 rop = (UNOP*)rop->op_first;
8506 /* @{$hash}{qw(keys here)} */
8507 if (rop->op_first->op_type == OP_SCOPE
8508 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
8510 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
8516 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
8517 if (!SvPAD_TYPED(lexname))
8519 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8520 if (!fields || !GvHV(*fields))
8522 /* Again guessing that the pushmark can be jumped over.... */
8523 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
8524 ->op_first->op_sibling;
8525 for (key_op = first_key_op; key_op;
8526 key_op = (SVOP*)key_op->op_sibling) {
8527 if (key_op->op_type != OP_CONST)
8529 svp = cSVOPx_svp(key_op);
8530 key = SvPV_const(*svp, keylen);
8531 if (!hv_fetch(GvHV(*fields), key,
8532 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8534 Perl_croak(aTHX_ "No such class field \"%s\" "
8535 "in variable %s of type %s",
8536 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
8543 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
8547 /* check that RHS of sort is a single plain array */
8548 OP *oright = cUNOPo->op_first;
8549 if (!oright || oright->op_type != OP_PUSHMARK)
8552 /* reverse sort ... can be optimised. */
8553 if (!cUNOPo->op_sibling) {
8554 /* Nothing follows us on the list. */
8555 OP * const reverse = o->op_next;
8557 if (reverse->op_type == OP_REVERSE &&
8558 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
8559 OP * const pushmark = cUNOPx(reverse)->op_first;
8560 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
8561 && (cUNOPx(pushmark)->op_sibling == o)) {
8562 /* reverse -> pushmark -> sort */
8563 o->op_private |= OPpSORT_REVERSE;
8565 pushmark->op_next = oright->op_next;
8571 /* make @a = sort @a act in-place */
8573 oright = cUNOPx(oright)->op_sibling;
8576 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
8577 oright = cUNOPx(oright)->op_sibling;
8581 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
8582 || oright->op_next != o
8583 || (oright->op_private & OPpLVAL_INTRO)
8587 /* o2 follows the chain of op_nexts through the LHS of the
8588 * assign (if any) to the aassign op itself */
8590 if (!o2 || o2->op_type != OP_NULL)
8593 if (!o2 || o2->op_type != OP_PUSHMARK)
8596 if (o2 && o2->op_type == OP_GV)
8599 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
8600 || (o2->op_private & OPpLVAL_INTRO)
8605 if (!o2 || o2->op_type != OP_NULL)
8608 if (!o2 || o2->op_type != OP_AASSIGN
8609 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
8612 /* check that the sort is the first arg on RHS of assign */
8614 o2 = cUNOPx(o2)->op_first;
8615 if (!o2 || o2->op_type != OP_NULL)
8617 o2 = cUNOPx(o2)->op_first;
8618 if (!o2 || o2->op_type != OP_PUSHMARK)
8620 if (o2->op_sibling != o)
8623 /* check the array is the same on both sides */
8624 if (oleft->op_type == OP_RV2AV) {
8625 if (oright->op_type != OP_RV2AV
8626 || !cUNOPx(oright)->op_first
8627 || cUNOPx(oright)->op_first->op_type != OP_GV
8628 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
8629 cGVOPx_gv(cUNOPx(oright)->op_first)
8633 else if (oright->op_type != OP_PADAV
8634 || oright->op_targ != oleft->op_targ
8638 /* transfer MODishness etc from LHS arg to RHS arg */
8639 oright->op_flags = oleft->op_flags;
8640 o->op_private |= OPpSORT_INPLACE;
8642 /* excise push->gv->rv2av->null->aassign */
8643 o2 = o->op_next->op_next;
8644 op_null(o2); /* PUSHMARK */
8646 if (o2->op_type == OP_GV) {
8647 op_null(o2); /* GV */
8650 op_null(o2); /* RV2AV or PADAV */
8651 o2 = o2->op_next->op_next;
8652 op_null(o2); /* AASSIGN */
8654 o->op_next = o2->op_next;
8660 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
8662 LISTOP *enter, *exlist;
8664 enter = (LISTOP *) o->op_next;
8667 if (enter->op_type == OP_NULL) {
8668 enter = (LISTOP *) enter->op_next;
8672 /* for $a (...) will have OP_GV then OP_RV2GV here.
8673 for (...) just has an OP_GV. */
8674 if (enter->op_type == OP_GV) {
8675 gvop = (OP *) enter;
8676 enter = (LISTOP *) enter->op_next;
8679 if (enter->op_type == OP_RV2GV) {
8680 enter = (LISTOP *) enter->op_next;
8686 if (enter->op_type != OP_ENTERITER)
8689 iter = enter->op_next;
8690 if (!iter || iter->op_type != OP_ITER)
8693 expushmark = enter->op_first;
8694 if (!expushmark || expushmark->op_type != OP_NULL
8695 || expushmark->op_targ != OP_PUSHMARK)
8698 exlist = (LISTOP *) expushmark->op_sibling;
8699 if (!exlist || exlist->op_type != OP_NULL
8700 || exlist->op_targ != OP_LIST)
8703 if (exlist->op_last != o) {
8704 /* Mmm. Was expecting to point back to this op. */
8707 theirmark = exlist->op_first;
8708 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
8711 if (theirmark->op_sibling != o) {
8712 /* There's something between the mark and the reverse, eg
8713 for (1, reverse (...))
8718 ourmark = ((LISTOP *)o)->op_first;
8719 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
8722 ourlast = ((LISTOP *)o)->op_last;
8723 if (!ourlast || ourlast->op_next != o)
8726 rv2av = ourmark->op_sibling;
8727 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
8728 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
8729 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
8730 /* We're just reversing a single array. */
8731 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
8732 enter->op_flags |= OPf_STACKED;
8735 /* We don't have control over who points to theirmark, so sacrifice
8737 theirmark->op_next = ourmark->op_next;
8738 theirmark->op_flags = ourmark->op_flags;
8739 ourlast->op_next = gvop ? gvop : (OP *) enter;
8742 enter->op_private |= OPpITER_REVERSED;
8743 iter->op_private |= OPpITER_REVERSED;
8750 UNOP *refgen, *rv2cv;
8753 if ((o->op_flags & OPf_WANT) != OPf_WANT_VOID)
8756 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
8759 rv2gv = ((BINOP *)o)->op_last;
8760 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
8763 refgen = (UNOP *)((BINOP *)o)->op_first;
8765 if (!refgen || refgen->op_type != OP_REFGEN)
8768 exlist = (LISTOP *)refgen->op_first;
8769 if (!exlist || exlist->op_type != OP_NULL
8770 || exlist->op_targ != OP_LIST)
8773 if (exlist->op_first->op_type != OP_PUSHMARK)
8776 rv2cv = (UNOP*)exlist->op_last;
8778 if (rv2cv->op_type != OP_RV2CV)
8781 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
8782 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
8783 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
8785 o->op_private |= OPpASSIGN_CV_TO_GV;
8786 rv2gv->op_private |= OPpDONT_INIT_GV;
8787 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
8795 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
8796 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
8806 Perl_custom_op_name(pTHX_ const OP* o)
8809 const IV index = PTR2IV(o->op_ppaddr);
8813 PERL_ARGS_ASSERT_CUSTOM_OP_NAME;
8815 if (!PL_custom_op_names) /* This probably shouldn't happen */
8816 return (char *)PL_op_name[OP_CUSTOM];
8818 keysv = sv_2mortal(newSViv(index));
8820 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
8822 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
8824 return SvPV_nolen(HeVAL(he));
8828 Perl_custom_op_desc(pTHX_ const OP* o)
8831 const IV index = PTR2IV(o->op_ppaddr);
8835 PERL_ARGS_ASSERT_CUSTOM_OP_DESC;
8837 if (!PL_custom_op_descs)
8838 return (char *)PL_op_desc[OP_CUSTOM];
8840 keysv = sv_2mortal(newSViv(index));
8842 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
8844 return (char *)PL_op_desc[OP_CUSTOM];
8846 return SvPV_nolen(HeVAL(he));
8851 /* Efficient sub that returns a constant scalar value. */
8853 const_sv_xsub(pTHX_ CV* cv)
8860 Perl_croak(aTHX_ "usage: %s::%s()",
8861 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
8865 ST(0) = (SV*)XSANY.any_ptr;
8871 * c-indentation-style: bsd
8873 * indent-tabs-mode: t
8876 * ex: set ts=8 sts=4 sw=4 noet: