3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * "You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
13 * our Mr. Bilbo's first cousin on the mother's side (her mother being the
14 * youngest of the Old Took's daughters); and Mr. Drogo was his second
15 * cousin. So Mr. Frodo is his first *and* second cousin, once removed
16 * either way, as the saying is, if you follow me." --the Gaffer
19 /* This file contains the functions that create, manipulate and optimize
20 * the OP structures that hold a compiled perl program.
22 * A Perl program is compiled into a tree of OPs. Each op contains
23 * structural pointers (eg to its siblings and the next op in the
24 * execution sequence), a pointer to the function that would execute the
25 * op, plus any data specific to that op. For example, an OP_CONST op
26 * points to the pp_const() function and to an SV containing the constant
27 * value. When pp_const() is executed, its job is to push that SV onto the
30 * OPs are mainly created by the newFOO() functions, which are mainly
31 * called from the parser (in perly.y) as the code is parsed. For example
32 * the Perl code $a + $b * $c would cause the equivalent of the following
33 * to be called (oversimplifying a bit):
35 * newBINOP(OP_ADD, flags,
37 * newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
40 * Note that during the build of miniperl, a temporary copy of this file
41 * is made, called opmini.c.
45 Perl's compiler is essentially a 3-pass compiler with interleaved phases:
49 An execution-order pass
51 The bottom-up pass is represented by all the "newOP" routines and
52 the ck_ routines. The bottom-upness is actually driven by yacc.
53 So at the point that a ck_ routine fires, we have no idea what the
54 context is, either upward in the syntax tree, or either forward or
55 backward in the execution order. (The bottom-up parser builds that
56 part of the execution order it knows about, but if you follow the "next"
57 links around, you'll find it's actually a closed loop through the
60 Whenever the bottom-up parser gets to a node that supplies context to
61 its components, it invokes that portion of the top-down pass that applies
62 to that part of the subtree (and marks the top node as processed, so
63 if a node further up supplies context, it doesn't have to take the
64 plunge again). As a particular subcase of this, as the new node is
65 built, it takes all the closed execution loops of its subcomponents
66 and links them into a new closed loop for the higher level node. But
67 it's still not the real execution order.
69 The actual execution order is not known till we get a grammar reduction
70 to a top-level unit like a subroutine or file that will be called by
71 "name" rather than via a "next" pointer. At that point, we can call
72 into peep() to do that code's portion of the 3rd pass. It has to be
73 recursive, but it's recursive on basic blocks, not on tree nodes.
76 /* To implement user lexical pragmas, there needs to be a way at run time to
77 get the compile time state of %^H for that block. Storing %^H in every
78 block (or even COP) would be very expensive, so a different approach is
79 taken. The (running) state of %^H is serialised into a tree of HE-like
80 structs. Stores into %^H are chained onto the current leaf as a struct
81 refcounted_he * with the key and the value. Deletes from %^H are saved
82 with a value of PL_sv_placeholder. The state of %^H at any point can be
83 turned back into a regular HV by walking back up the tree from that point's
84 leaf, ignoring any key you've already seen (placeholder or not), storing
85 the rest into the HV structure, then removing the placeholders. Hence
86 memory is only used to store the %^H deltas from the enclosing COP, rather
87 than the entire %^H on each COP.
89 To cause actions on %^H to write out the serialisation records, it has
90 magic type 'H'. This magic (itself) does nothing, but its presence causes
91 the values to gain magic type 'h', which has entries for set and clear.
92 C<Perl_magic_sethint> updates C<PL_compiling.cop_hints_hash> with a store
93 record, with deletes written by C<Perl_magic_clearhint>. C<SAVE_HINTS>
94 saves the current C<PL_compiling.cop_hints_hash> on the save stack, so that
95 it will be correctly restored when any inner compiling scope is exited.
101 #include "keywords.h"
103 #define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
105 #if defined(PL_OP_SLAB_ALLOC)
107 #ifdef PERL_DEBUG_READONLY_OPS
108 # define PERL_SLAB_SIZE 4096
109 # include <sys/mman.h>
112 #ifndef PERL_SLAB_SIZE
113 #define PERL_SLAB_SIZE 2048
117 Perl_Slab_Alloc(pTHX_ int m, size_t sz)
120 * To make incrementing use count easy PL_OpSlab is an I32 *
121 * To make inserting the link to slab PL_OpPtr is I32 **
122 * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
123 * Add an overhead for pointer to slab and round up as a number of pointers
125 sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
126 if ((PL_OpSpace -= sz) < 0) {
127 #ifdef PERL_DEBUG_READONLY_OPS
128 /* We need to allocate chunk by chunk so that we can control the VM
130 PL_OpPtr = mmap(0, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE,
131 MAP_ANON|MAP_PRIVATE, -1, 0);
133 DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
134 (unsigned long) PERL_SLAB_SIZE*sizeof(I32*),
136 if(PL_OpPtr == MAP_FAILED) {
137 perror("mmap failed");
141 PL_OpPtr = (I32 **) PerlMemShared_malloc(PERL_SLAB_SIZE*sizeof(I32*));
146 Zero(PL_OpPtr,PERL_SLAB_SIZE,I32 **);
147 /* We reserve the 0'th I32 sized chunk as a use count */
148 PL_OpSlab = (I32 *) PL_OpPtr;
149 /* Reduce size by the use count word, and by the size we need.
150 * Latter is to mimic the '-=' in the if() above
152 PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
153 /* Allocation pointer starts at the top.
154 Theory: because we build leaves before trunk allocating at end
155 means that at run time access is cache friendly upward
157 PL_OpPtr += PERL_SLAB_SIZE;
159 #ifdef PERL_DEBUG_READONLY_OPS
160 /* We remember this slab. */
161 /* This implementation isn't efficient, but it is simple. */
162 PL_slabs = realloc(PL_slabs, sizeof(I32**) * (PL_slab_count + 1));
163 PL_slabs[PL_slab_count++] = PL_OpSlab;
164 DEBUG_m(PerlIO_printf(Perl_debug_log, "Allocate %p\n", PL_OpSlab));
167 assert( PL_OpSpace >= 0 );
168 /* Move the allocation pointer down */
170 assert( PL_OpPtr > (I32 **) PL_OpSlab );
171 *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */
172 (*PL_OpSlab)++; /* Increment use count of slab */
173 assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
174 assert( *PL_OpSlab > 0 );
175 return (void *)(PL_OpPtr + 1);
178 #ifdef PERL_DEBUG_READONLY_OPS
180 Perl_pending_Slabs_to_ro(pTHX) {
181 /* Turn all the allocated op slabs read only. */
182 U32 count = PL_slab_count;
183 I32 **const slabs = PL_slabs;
185 /* Reset the array of pending OP slabs, as we're about to turn this lot
186 read only. Also, do it ahead of the loop in case the warn triggers,
187 and a warn handler has an eval */
193 /* Force a new slab for any further allocation. */
197 const void *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);
207 S_Slab_to_rw(pTHX_ void *op)
209 I32 * const * const ptr = (I32 **) op;
210 I32 * const slab = ptr[-1];
211 assert( ptr-1 > (I32 **) slab );
212 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
214 if(mprotect(slab, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE)) {
215 Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d",
216 slab, (unsigned long) PERL_SLAB_SIZE*sizeof(I32*), errno);
220 # define Slab_to_rw(op)
224 Perl_Slab_Free(pTHX_ void *op)
226 I32 * const * const ptr = (I32 **) op;
227 I32 * const slab = ptr[-1];
228 assert( ptr-1 > (I32 **) slab );
229 assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
232 if (--(*slab) == 0) {
234 # define PerlMemShared PerlMem
237 #ifdef PERL_DEBUG_READONLY_OPS
238 /* Need to remove this slab from our list of slabs */
240 U32 count = PL_slab_count;
243 if (PL_slabs[count] == slab) {
244 /* Found it. Move the entry at the end to overwrite it. */
245 DEBUG_m(PerlIO_printf(Perl_debug_log,
246 "Deallocate %p by moving %p from %lu to %lu\n",
248 PL_slabs[PL_slab_count - 1],
249 PL_slab_count, count));
250 PL_slabs[count] = PL_slabs[--PL_slab_count];
251 /* Could realloc smaller at this point, but probably not
258 "panic: Couldn't find slab at %p (%lu allocated)",
259 slab, (unsigned long) PL_slabs);
261 if(munmap(slab, PERL_SLAB_SIZE*sizeof(I32*))) {
262 perror("munmap failed");
267 PerlMemShared_free(slab);
269 if (slab == PL_OpSlab) {
276 * In the following definition, the ", (OP*)0" is just to make the compiler
277 * think the expression is of the right type: croak actually does a Siglongjmp.
279 #define CHECKOP(type,o) \
280 ((PL_op_mask && PL_op_mask[type]) \
281 ? ( op_free((OP*)o), \
282 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
284 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
286 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
289 S_gv_ename(pTHX_ GV *gv)
291 SV* const tmpsv = sv_newmortal();
292 gv_efullname3(tmpsv, gv, NULL);
293 return SvPV_nolen_const(tmpsv);
297 S_no_fh_allowed(pTHX_ OP *o)
299 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
305 S_too_few_arguments(pTHX_ OP *o, const char *name)
307 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
312 S_too_many_arguments(pTHX_ OP *o, const char *name)
314 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
319 S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid)
321 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
322 (int)n, name, t, OP_DESC(kid)));
326 S_no_bareword_allowed(pTHX_ const OP *o)
329 return; /* various ok barewords are hidden in extra OP_NULL */
330 qerror(Perl_mess(aTHX_
331 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
335 /* "register" allocation */
338 Perl_allocmy(pTHX_ const char *const name)
342 const bool is_our = (PL_in_my == KEY_our);
344 /* complain about "my $<special_var>" etc etc */
348 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
349 (name[1] == '_' && (*name == '$' || name[2]))))
351 /* name[2] is true if strlen(name) > 2 */
352 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
353 yyerror(Perl_form(aTHX_ "Can't use global %c^%c%s in \"my\"",
354 name[0], toCTRL(name[1]), name + 2));
356 yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
360 /* check for duplicate declaration */
361 pad_check_dup(name, is_our, (PL_curstash ? PL_curstash : PL_defstash));
363 if (PL_in_my_stash && *name != '$') {
364 yyerror(Perl_form(aTHX_
365 "Can't declare class for non-scalar %s in \"%s\"",
367 is_our ? "our" : PL_in_my == KEY_state ? "state" : "my"));
370 /* allocate a spare slot and store the name in that slot */
372 off = pad_add_name(name,
375 /* $_ is always in main::, even with our */
376 ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
380 PL_in_my == KEY_state
385 /* free the body of an op without examining its contents.
386 * Always use this rather than FreeOp directly */
389 S_op_destroy(pTHX_ OP *o)
391 if (o->op_latefree) {
402 Perl_op_free(pTHX_ OP *o)
407 if (!o || o->op_static)
409 if (o->op_latefreed) {
416 if (o->op_private & OPpREFCOUNTED) {
426 #ifdef PERL_DEBUG_READONLY_OPS
430 refcnt = OpREFCNT_dec(o);
441 if (o->op_flags & OPf_KIDS) {
442 register OP *kid, *nextkid;
443 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
444 nextkid = kid->op_sibling; /* Get before next freeing kid */
449 type = (OPCODE)o->op_targ;
451 /* COP* is not cleared by op_clear() so that we may track line
452 * numbers etc even after null() */
453 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
457 if (o->op_latefree) {
463 #ifdef DEBUG_LEAKING_SCALARS
470 Perl_op_clear(pTHX_ OP *o)
475 /* if (o->op_madprop && o->op_madprop->mad_next)
477 /* FIXME for MAD - if I uncomment these two lines t/op/pack.t fails with
478 "modification of a read only value" for a reason I can't fathom why.
479 It's the "" stringification of $_, where $_ was set to '' in a foreach
480 loop, but it defies simplification into a small test case.
481 However, commenting them out has caused ext/List/Util/t/weak.t to fail
484 mad_free(o->op_madprop);
490 switch (o->op_type) {
491 case OP_NULL: /* Was holding old type, if any. */
492 if (PL_madskills && o->op_targ != OP_NULL) {
493 o->op_type = o->op_targ;
497 case OP_ENTEREVAL: /* Was holding hints. */
501 if (!(o->op_flags & OPf_REF)
502 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
508 if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
509 /* not an OP_PADAV replacement */
511 if (cPADOPo->op_padix > 0) {
512 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
513 * may still exist on the pad */
514 pad_swipe(cPADOPo->op_padix, TRUE);
515 cPADOPo->op_padix = 0;
518 SvREFCNT_dec(cSVOPo->op_sv);
519 cSVOPo->op_sv = NULL;
523 case OP_METHOD_NAMED:
525 SvREFCNT_dec(cSVOPo->op_sv);
526 cSVOPo->op_sv = NULL;
529 Even if op_clear does a pad_free for the target of the op,
530 pad_free doesn't actually remove the sv that exists in the pad;
531 instead it lives on. This results in that it could be reused as
532 a target later on when the pad was reallocated.
535 pad_swipe(o->op_targ,1);
544 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
548 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
550 if (cPADOPo->op_padix > 0) {
551 pad_swipe(cPADOPo->op_padix, TRUE);
552 cPADOPo->op_padix = 0;
555 SvREFCNT_dec(cSVOPo->op_sv);
556 cSVOPo->op_sv = NULL;
560 PerlMemShared_free(cPVOPo->op_pv);
561 cPVOPo->op_pv = NULL;
565 op_free(cPMOPo->op_pmreplroot);
569 if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) {
570 /* No GvIN_PAD_off here, because other references may still
571 * exist on the pad */
572 pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot), TRUE);
575 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
582 HV * const pmstash = PmopSTASH(cPMOPo);
583 if (pmstash && !SvIS_FREED(pmstash)) {
584 MAGIC * const mg = mg_find((SV*)pmstash, PERL_MAGIC_symtab);
586 PMOP *pmop = (PMOP*) mg->mg_obj;
587 PMOP *lastpmop = NULL;
589 if (cPMOPo == pmop) {
591 lastpmop->op_pmnext = pmop->op_pmnext;
593 mg->mg_obj = (SV*) pmop->op_pmnext;
597 pmop = pmop->op_pmnext;
601 PmopSTASH_free(cPMOPo);
603 cPMOPo->op_pmreplroot = NULL;
604 /* we use the "SAFE" version of the PM_ macros here
605 * since sv_clean_all might release some PMOPs
606 * after PL_regex_padav has been cleared
607 * and the clearing of PL_regex_padav needs to
608 * happen before sv_clean_all
610 ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
611 PM_SETRE_SAFE(cPMOPo, NULL);
613 if(PL_regex_pad) { /* We could be in destruction */
614 av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
615 SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
616 PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
623 if (o->op_targ > 0) {
624 pad_free(o->op_targ);
630 S_cop_free(pTHX_ COP* cop)
635 if (! specialWARN(cop->cop_warnings))
636 PerlMemShared_free(cop->cop_warnings);
637 Perl_refcounted_he_free(aTHX_ cop->cop_hints_hash);
641 Perl_op_null(pTHX_ OP *o)
644 if (o->op_type == OP_NULL)
648 o->op_targ = o->op_type;
649 o->op_type = OP_NULL;
650 o->op_ppaddr = PL_ppaddr[OP_NULL];
654 Perl_op_refcnt_lock(pTHX)
662 Perl_op_refcnt_unlock(pTHX)
669 /* Contextualizers */
671 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
674 Perl_linklist(pTHX_ OP *o)
681 /* establish postfix order */
682 first = cUNOPo->op_first;
685 o->op_next = LINKLIST(first);
688 if (kid->op_sibling) {
689 kid->op_next = LINKLIST(kid->op_sibling);
690 kid = kid->op_sibling;
704 Perl_scalarkids(pTHX_ OP *o)
706 if (o && o->op_flags & OPf_KIDS) {
708 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
715 S_scalarboolean(pTHX_ OP *o)
718 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
719 if (ckWARN(WARN_SYNTAX)) {
720 const line_t oldline = CopLINE(PL_curcop);
722 if (PL_copline != NOLINE)
723 CopLINE_set(PL_curcop, PL_copline);
724 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
725 CopLINE_set(PL_curcop, oldline);
732 Perl_scalar(pTHX_ OP *o)
737 /* assumes no premature commitment */
738 if (!o || PL_error_count || (o->op_flags & OPf_WANT)
739 || o->op_type == OP_RETURN)
744 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
746 switch (o->op_type) {
748 scalar(cBINOPo->op_first);
753 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
757 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
758 if (!kPMOP->op_pmreplroot)
759 deprecate_old("implicit split to @_");
767 if (o->op_flags & OPf_KIDS) {
768 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
774 kid = cLISTOPo->op_first;
776 while ((kid = kid->op_sibling)) {
782 PL_curcop = &PL_compiling;
787 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
793 PL_curcop = &PL_compiling;
796 if (ckWARN(WARN_VOID))
797 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
803 Perl_scalarvoid(pTHX_ OP *o)
807 const char* useless = NULL;
811 /* trailing mad null ops don't count as "there" for void processing */
813 o->op_type != OP_NULL &&
815 o->op_sibling->op_type == OP_NULL)
818 for (sib = o->op_sibling;
819 sib && sib->op_type == OP_NULL;
820 sib = sib->op_sibling) ;
826 if (o->op_type == OP_NEXTSTATE
827 || o->op_type == OP_SETSTATE
828 || o->op_type == OP_DBSTATE
829 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
830 || o->op_targ == OP_SETSTATE
831 || o->op_targ == OP_DBSTATE)))
832 PL_curcop = (COP*)o; /* for warning below */
834 /* assumes no premature commitment */
835 want = o->op_flags & OPf_WANT;
836 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
837 || o->op_type == OP_RETURN)
842 if ((o->op_private & OPpTARGET_MY)
843 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
845 return scalar(o); /* As if inside SASSIGN */
848 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
850 switch (o->op_type) {
852 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
856 if (o->op_flags & OPf_STACKED)
860 if (o->op_private == 4)
932 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
933 useless = OP_DESC(o);
937 kid = cUNOPo->op_first;
938 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
939 kid->op_type != OP_TRANS) {
942 useless = "negative pattern binding (!~)";
949 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
950 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
951 useless = "a variable";
956 if (cSVOPo->op_private & OPpCONST_STRICT)
957 no_bareword_allowed(o);
959 if (ckWARN(WARN_VOID)) {
960 useless = "a constant";
961 if (o->op_private & OPpCONST_ARYBASE)
963 /* don't warn on optimised away booleans, eg
964 * use constant Foo, 5; Foo || print; */
965 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
967 /* the constants 0 and 1 are permitted as they are
968 conventionally used as dummies in constructs like
969 1 while some_condition_with_side_effects; */
970 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
972 else if (SvPOK(sv)) {
973 /* perl4's way of mixing documentation and code
974 (before the invention of POD) was based on a
975 trick to mix nroff and perl code. The trick was
976 built upon these three nroff macros being used in
977 void context. The pink camel has the details in
978 the script wrapman near page 319. */
979 const char * const maybe_macro = SvPVX_const(sv);
980 if (strnEQ(maybe_macro, "di", 2) ||
981 strnEQ(maybe_macro, "ds", 2) ||
982 strnEQ(maybe_macro, "ig", 2))
987 op_null(o); /* don't execute or even remember it */
991 o->op_type = OP_PREINC; /* pre-increment is faster */
992 o->op_ppaddr = PL_ppaddr[OP_PREINC];
996 o->op_type = OP_PREDEC; /* pre-decrement is faster */
997 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1001 o->op_type = OP_I_PREINC; /* pre-increment is faster */
1002 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1006 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
1007 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1016 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1021 if (o->op_flags & OPf_STACKED)
1028 if (!(o->op_flags & OPf_KIDS))
1039 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1046 /* all requires must return a boolean value */
1047 o->op_flags &= ~OPf_WANT;
1052 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
1053 if (!kPMOP->op_pmreplroot)
1054 deprecate_old("implicit split to @_");
1058 if (useless && ckWARN(WARN_VOID))
1059 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
1064 Perl_listkids(pTHX_ OP *o)
1066 if (o && o->op_flags & OPf_KIDS) {
1068 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1075 Perl_list(pTHX_ OP *o)
1080 /* assumes no premature commitment */
1081 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
1082 || o->op_type == OP_RETURN)
1087 if ((o->op_private & OPpTARGET_MY)
1088 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1090 return o; /* As if inside SASSIGN */
1093 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1095 switch (o->op_type) {
1098 list(cBINOPo->op_first);
1103 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1111 if (!(o->op_flags & OPf_KIDS))
1113 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1114 list(cBINOPo->op_first);
1115 return gen_constant_list(o);
1122 kid = cLISTOPo->op_first;
1124 while ((kid = kid->op_sibling)) {
1125 if (kid->op_sibling)
1130 PL_curcop = &PL_compiling;
1134 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1135 if (kid->op_sibling)
1140 PL_curcop = &PL_compiling;
1143 /* all requires must return a boolean value */
1144 o->op_flags &= ~OPf_WANT;
1151 Perl_scalarseq(pTHX_ OP *o)
1155 const OPCODE type = o->op_type;
1157 if (type == OP_LINESEQ || type == OP_SCOPE ||
1158 type == OP_LEAVE || type == OP_LEAVETRY)
1161 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1162 if (kid->op_sibling) {
1166 PL_curcop = &PL_compiling;
1168 o->op_flags &= ~OPf_PARENS;
1169 if (PL_hints & HINT_BLOCK_SCOPE)
1170 o->op_flags |= OPf_PARENS;
1173 o = newOP(OP_STUB, 0);
1178 S_modkids(pTHX_ OP *o, I32 type)
1180 if (o && o->op_flags & OPf_KIDS) {
1182 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1188 /* Propagate lvalue ("modifiable") context to an op and its children.
1189 * 'type' represents the context type, roughly based on the type of op that
1190 * would do the modifying, although local() is represented by OP_NULL.
1191 * It's responsible for detecting things that can't be modified, flag
1192 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
1193 * might have to vivify a reference in $x), and so on.
1195 * For example, "$a+1 = 2" would cause mod() to be called with o being
1196 * OP_ADD and type being OP_SASSIGN, and would output an error.
1200 Perl_mod(pTHX_ OP *o, I32 type)
1204 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1207 if (!o || PL_error_count)
1210 if ((o->op_private & OPpTARGET_MY)
1211 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1216 switch (o->op_type) {
1222 if (!(o->op_private & OPpCONST_ARYBASE))
1225 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1226 CopARYBASE_set(&PL_compiling,
1227 (I32)SvIV(cSVOPx(PL_eval_start)->op_sv));
1231 SAVECOPARYBASE(&PL_compiling);
1232 CopARYBASE_set(&PL_compiling, 0);
1234 else if (type == OP_REFGEN)
1237 Perl_croak(aTHX_ "That use of $[ is unsupported");
1240 if (o->op_flags & OPf_PARENS || PL_madskills)
1244 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1245 !(o->op_flags & OPf_STACKED)) {
1246 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1247 /* The default is to set op_private to the number of children,
1248 which for a UNOP such as RV2CV is always 1. And w're using
1249 the bit for a flag in RV2CV, so we need it clear. */
1250 o->op_private &= ~1;
1251 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1252 assert(cUNOPo->op_first->op_type == OP_NULL);
1253 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1256 else if (o->op_private & OPpENTERSUB_NOMOD)
1258 else { /* lvalue subroutine call */
1259 o->op_private |= OPpLVAL_INTRO;
1260 PL_modcount = RETURN_UNLIMITED_NUMBER;
1261 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1262 /* Backward compatibility mode: */
1263 o->op_private |= OPpENTERSUB_INARGS;
1266 else { /* Compile-time error message: */
1267 OP *kid = cUNOPo->op_first;
1271 if (kid->op_type != OP_PUSHMARK) {
1272 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1274 "panic: unexpected lvalue entersub "
1275 "args: type/targ %ld:%"UVuf,
1276 (long)kid->op_type, (UV)kid->op_targ);
1277 kid = kLISTOP->op_first;
1279 while (kid->op_sibling)
1280 kid = kid->op_sibling;
1281 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1283 if (kid->op_type == OP_METHOD_NAMED
1284 || kid->op_type == OP_METHOD)
1288 NewOp(1101, newop, 1, UNOP);
1289 newop->op_type = OP_RV2CV;
1290 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1291 newop->op_first = NULL;
1292 newop->op_next = (OP*)newop;
1293 kid->op_sibling = (OP*)newop;
1294 newop->op_private |= OPpLVAL_INTRO;
1295 newop->op_private &= ~1;
1299 if (kid->op_type != OP_RV2CV)
1301 "panic: unexpected lvalue entersub "
1302 "entry via type/targ %ld:%"UVuf,
1303 (long)kid->op_type, (UV)kid->op_targ);
1304 kid->op_private |= OPpLVAL_INTRO;
1305 break; /* Postpone until runtime */
1309 kid = kUNOP->op_first;
1310 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1311 kid = kUNOP->op_first;
1312 if (kid->op_type == OP_NULL)
1314 "Unexpected constant lvalue entersub "
1315 "entry via type/targ %ld:%"UVuf,
1316 (long)kid->op_type, (UV)kid->op_targ);
1317 if (kid->op_type != OP_GV) {
1318 /* Restore RV2CV to check lvalueness */
1320 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1321 okid->op_next = kid->op_next;
1322 kid->op_next = okid;
1325 okid->op_next = NULL;
1326 okid->op_type = OP_RV2CV;
1328 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1329 okid->op_private |= OPpLVAL_INTRO;
1330 okid->op_private &= ~1;
1334 cv = GvCV(kGVOP_gv);
1344 /* grep, foreach, subcalls, refgen */
1345 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1347 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1348 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1350 : (o->op_type == OP_ENTERSUB
1351 ? "non-lvalue subroutine call"
1353 type ? PL_op_desc[type] : "local"));
1367 case OP_RIGHT_SHIFT:
1376 if (!(o->op_flags & OPf_STACKED))
1383 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1389 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1390 PL_modcount = RETURN_UNLIMITED_NUMBER;
1391 return o; /* Treat \(@foo) like ordinary list. */
1395 if (scalar_mod_type(o, type))
1397 ref(cUNOPo->op_first, o->op_type);
1401 if (type == OP_LEAVESUBLV)
1402 o->op_private |= OPpMAYBE_LVSUB;
1408 PL_modcount = RETURN_UNLIMITED_NUMBER;
1411 ref(cUNOPo->op_first, o->op_type);
1416 PL_hints |= HINT_BLOCK_SCOPE;
1431 PL_modcount = RETURN_UNLIMITED_NUMBER;
1432 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1433 return o; /* Treat \(@foo) like ordinary list. */
1434 if (scalar_mod_type(o, type))
1436 if (type == OP_LEAVESUBLV)
1437 o->op_private |= OPpMAYBE_LVSUB;
1441 if (!type) /* local() */
1442 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1443 PAD_COMPNAME_PV(o->op_targ));
1451 if (type != OP_SASSIGN)
1455 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1460 if (type == OP_LEAVESUBLV)
1461 o->op_private |= OPpMAYBE_LVSUB;
1463 pad_free(o->op_targ);
1464 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1465 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1466 if (o->op_flags & OPf_KIDS)
1467 mod(cBINOPo->op_first->op_sibling, type);
1472 ref(cBINOPo->op_first, o->op_type);
1473 if (type == OP_ENTERSUB &&
1474 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1475 o->op_private |= OPpLVAL_DEFER;
1476 if (type == OP_LEAVESUBLV)
1477 o->op_private |= OPpMAYBE_LVSUB;
1487 if (o->op_flags & OPf_KIDS)
1488 mod(cLISTOPo->op_last, type);
1493 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1495 else if (!(o->op_flags & OPf_KIDS))
1497 if (o->op_targ != OP_LIST) {
1498 mod(cBINOPo->op_first, type);
1504 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1509 if (type != OP_LEAVESUBLV)
1511 break; /* mod()ing was handled by ck_return() */
1514 /* [20011101.069] File test operators interpret OPf_REF to mean that
1515 their argument is a filehandle; thus \stat(".") should not set
1517 if (type == OP_REFGEN &&
1518 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1521 if (type != OP_LEAVESUBLV)
1522 o->op_flags |= OPf_MOD;
1524 if (type == OP_AASSIGN || type == OP_SASSIGN)
1525 o->op_flags |= OPf_SPECIAL|OPf_REF;
1526 else if (!type) { /* local() */
1529 o->op_private |= OPpLVAL_INTRO;
1530 o->op_flags &= ~OPf_SPECIAL;
1531 PL_hints |= HINT_BLOCK_SCOPE;
1536 if (ckWARN(WARN_SYNTAX)) {
1537 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1538 "Useless localization of %s", OP_DESC(o));
1542 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1543 && type != OP_LEAVESUBLV)
1544 o->op_flags |= OPf_REF;
1549 S_scalar_mod_type(const OP *o, I32 type)
1553 if (o->op_type == OP_RV2GV)
1577 case OP_RIGHT_SHIFT:
1596 S_is_handle_constructor(const OP *o, I32 numargs)
1598 switch (o->op_type) {
1606 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1619 Perl_refkids(pTHX_ OP *o, I32 type)
1621 if (o && o->op_flags & OPf_KIDS) {
1623 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1630 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
1635 if (!o || PL_error_count)
1638 switch (o->op_type) {
1640 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1641 !(o->op_flags & OPf_STACKED)) {
1642 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1643 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1644 assert(cUNOPo->op_first->op_type == OP_NULL);
1645 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1646 o->op_flags |= OPf_SPECIAL;
1647 o->op_private &= ~1;
1652 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1653 doref(kid, type, set_op_ref);
1656 if (type == OP_DEFINED)
1657 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1658 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1661 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1662 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1663 : type == OP_RV2HV ? OPpDEREF_HV
1665 o->op_flags |= OPf_MOD;
1672 o->op_flags |= OPf_REF;
1675 if (type == OP_DEFINED)
1676 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1677 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1683 o->op_flags |= OPf_REF;
1688 if (!(o->op_flags & OPf_KIDS))
1690 doref(cBINOPo->op_first, type, set_op_ref);
1694 doref(cBINOPo->op_first, o->op_type, set_op_ref);
1695 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1696 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1697 : type == OP_RV2HV ? OPpDEREF_HV
1699 o->op_flags |= OPf_MOD;
1709 if (!(o->op_flags & OPf_KIDS))
1711 doref(cLISTOPo->op_last, type, set_op_ref);
1721 S_dup_attrlist(pTHX_ OP *o)
1726 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1727 * where the first kid is OP_PUSHMARK and the remaining ones
1728 * are OP_CONST. We need to push the OP_CONST values.
1730 if (o->op_type == OP_CONST)
1731 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
1733 else if (o->op_type == OP_NULL)
1737 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1739 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1740 if (o->op_type == OP_CONST)
1741 rop = append_elem(OP_LIST, rop,
1742 newSVOP(OP_CONST, o->op_flags,
1743 SvREFCNT_inc_NN(cSVOPo->op_sv)));
1750 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1755 /* fake up C<use attributes $pkg,$rv,@attrs> */
1756 ENTER; /* need to protect against side-effects of 'use' */
1758 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1760 #define ATTRSMODULE "attributes"
1761 #define ATTRSMODULE_PM "attributes.pm"
1764 /* Don't force the C<use> if we don't need it. */
1765 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
1766 if (svp && *svp != &PL_sv_undef)
1767 NOOP; /* already in %INC */
1769 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1770 newSVpvs(ATTRSMODULE), NULL);
1773 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1774 newSVpvs(ATTRSMODULE),
1776 prepend_elem(OP_LIST,
1777 newSVOP(OP_CONST, 0, stashsv),
1778 prepend_elem(OP_LIST,
1779 newSVOP(OP_CONST, 0,
1781 dup_attrlist(attrs))));
1787 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1790 OP *pack, *imop, *arg;
1796 assert(target->op_type == OP_PADSV ||
1797 target->op_type == OP_PADHV ||
1798 target->op_type == OP_PADAV);
1800 /* Ensure that attributes.pm is loaded. */
1801 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1803 /* Need package name for method call. */
1804 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
1806 /* Build up the real arg-list. */
1807 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1809 arg = newOP(OP_PADSV, 0);
1810 arg->op_targ = target->op_targ;
1811 arg = prepend_elem(OP_LIST,
1812 newSVOP(OP_CONST, 0, stashsv),
1813 prepend_elem(OP_LIST,
1814 newUNOP(OP_REFGEN, 0,
1815 mod(arg, OP_REFGEN)),
1816 dup_attrlist(attrs)));
1818 /* Fake up a method call to import */
1819 meth = newSVpvs_share("import");
1820 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1821 append_elem(OP_LIST,
1822 prepend_elem(OP_LIST, pack, list(arg)),
1823 newSVOP(OP_METHOD_NAMED, 0, meth)));
1824 imop->op_private |= OPpENTERSUB_NOMOD;
1826 /* Combine the ops. */
1827 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1831 =notfor apidoc apply_attrs_string
1833 Attempts to apply a list of attributes specified by the C<attrstr> and
1834 C<len> arguments to the subroutine identified by the C<cv> argument which
1835 is expected to be associated with the package identified by the C<stashpv>
1836 argument (see L<attributes>). It gets this wrong, though, in that it
1837 does not correctly identify the boundaries of the individual attribute
1838 specifications within C<attrstr>. This is not really intended for the
1839 public API, but has to be listed here for systems such as AIX which
1840 need an explicit export list for symbols. (It's called from XS code
1841 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1842 to respect attribute syntax properly would be welcome.
1848 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
1849 const char *attrstr, STRLEN len)
1854 len = strlen(attrstr);
1858 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1860 const char * const sstr = attrstr;
1861 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1862 attrs = append_elem(OP_LIST, attrs,
1863 newSVOP(OP_CONST, 0,
1864 newSVpvn(sstr, attrstr-sstr)));
1868 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1869 newSVpvs(ATTRSMODULE),
1870 NULL, prepend_elem(OP_LIST,
1871 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1872 prepend_elem(OP_LIST,
1873 newSVOP(OP_CONST, 0,
1879 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
1884 if (!o || PL_error_count)
1888 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
1889 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
1893 if (type == OP_LIST) {
1895 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1896 my_kid(kid, attrs, imopsp);
1897 } else if (type == OP_UNDEF
1903 } else if (type == OP_RV2SV || /* "our" declaration */
1905 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1906 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1907 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1909 PL_in_my == KEY_our ? "our" : PL_in_my == KEY_state ? "state" : "my"));
1911 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
1913 PL_in_my_stash = NULL;
1914 apply_attrs(GvSTASH(gv),
1915 (type == OP_RV2SV ? GvSV(gv) :
1916 type == OP_RV2AV ? (SV*)GvAV(gv) :
1917 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1920 o->op_private |= OPpOUR_INTRO;
1923 else if (type != OP_PADSV &&
1926 type != OP_PUSHMARK)
1928 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1930 PL_in_my == KEY_our ? "our" : PL_in_my == KEY_state ? "state" : "my"));
1933 else if (attrs && type != OP_PUSHMARK) {
1937 PL_in_my_stash = NULL;
1939 /* check for C<my Dog $spot> when deciding package */
1940 stash = PAD_COMPNAME_TYPE(o->op_targ);
1942 stash = PL_curstash;
1943 apply_attrs_my(stash, o, attrs, imopsp);
1945 o->op_flags |= OPf_MOD;
1946 o->op_private |= OPpLVAL_INTRO;
1947 if (PL_in_my == KEY_state)
1948 o->op_private |= OPpPAD_STATE;
1953 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1957 int maybe_scalar = 0;
1959 /* [perl #17376]: this appears to be premature, and results in code such as
1960 C< our(%x); > executing in list mode rather than void mode */
1962 if (o->op_flags & OPf_PARENS)
1972 o = my_kid(o, attrs, &rops);
1974 if (maybe_scalar && o->op_type == OP_PADSV) {
1975 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
1976 o->op_private |= OPpLVAL_INTRO;
1979 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
1982 PL_in_my_stash = NULL;
1987 Perl_my(pTHX_ OP *o)
1989 return my_attrs(o, NULL);
1993 Perl_sawparens(pTHX_ OP *o)
1995 PERL_UNUSED_CONTEXT;
1997 o->op_flags |= OPf_PARENS;
2002 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2006 const OPCODE ltype = left->op_type;
2007 const OPCODE rtype = right->op_type;
2009 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2010 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
2012 const char * const desc
2013 = PL_op_desc[(rtype == OP_SUBST || rtype == OP_TRANS)
2014 ? (int)rtype : OP_MATCH];
2015 const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV)
2016 ? "@array" : "%hash");
2017 Perl_warner(aTHX_ packWARN(WARN_MISC),
2018 "Applying %s to %s will act on scalar(%s)",
2019 desc, sample, sample);
2022 if (rtype == OP_CONST &&
2023 cSVOPx(right)->op_private & OPpCONST_BARE &&
2024 cSVOPx(right)->op_private & OPpCONST_STRICT)
2026 no_bareword_allowed(right);
2029 ismatchop = rtype == OP_MATCH ||
2030 rtype == OP_SUBST ||
2032 if (ismatchop && right->op_private & OPpTARGET_MY) {
2034 right->op_private &= ~OPpTARGET_MY;
2036 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
2039 right->op_flags |= OPf_STACKED;
2040 if (rtype != OP_MATCH &&
2041 ! (rtype == OP_TRANS &&
2042 right->op_private & OPpTRANS_IDENTICAL))
2043 newleft = mod(left, rtype);
2046 if (right->op_type == OP_TRANS)
2047 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
2049 o = prepend_elem(rtype, scalar(newleft), right);
2051 return newUNOP(OP_NOT, 0, scalar(o));
2055 return bind_match(type, left,
2056 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
2060 Perl_invert(pTHX_ OP *o)
2064 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2068 Perl_scope(pTHX_ OP *o)
2072 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2073 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2074 o->op_type = OP_LEAVE;
2075 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2077 else if (o->op_type == OP_LINESEQ) {
2079 o->op_type = OP_SCOPE;
2080 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2081 kid = ((LISTOP*)o)->op_first;
2082 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2085 /* The following deals with things like 'do {1 for 1}' */
2086 kid = kid->op_sibling;
2088 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2093 o = newLISTOP(OP_SCOPE, 0, o, NULL);
2099 Perl_block_start(pTHX_ int full)
2102 const int retval = PL_savestack_ix;
2103 pad_block_start(full);
2105 PL_hints &= ~HINT_BLOCK_SCOPE;
2106 SAVECOMPILEWARNINGS();
2107 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
2112 Perl_block_end(pTHX_ I32 floor, OP *seq)
2115 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2116 OP* const retval = scalarseq(seq);
2118 CopHINTS_set(&PL_compiling, PL_hints);
2120 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2129 const PADOFFSET offset = pad_findmy("$_");
2130 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
2131 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2134 OP * const o = newOP(OP_PADSV, 0);
2135 o->op_targ = offset;
2141 Perl_newPROG(pTHX_ OP *o)
2147 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2148 ((PL_in_eval & EVAL_KEEPERR)
2149 ? OPf_SPECIAL : 0), o);
2150 PL_eval_start = linklist(PL_eval_root);
2151 PL_eval_root->op_private |= OPpREFCOUNTED;
2152 OpREFCNT_set(PL_eval_root, 1);
2153 PL_eval_root->op_next = 0;
2154 CALL_PEEP(PL_eval_start);
2157 if (o->op_type == OP_STUB) {
2158 PL_comppad_name = 0;
2160 S_op_destroy(aTHX_ o);
2163 PL_main_root = scope(sawparens(scalarvoid(o)));
2164 PL_curcop = &PL_compiling;
2165 PL_main_start = LINKLIST(PL_main_root);
2166 PL_main_root->op_private |= OPpREFCOUNTED;
2167 OpREFCNT_set(PL_main_root, 1);
2168 PL_main_root->op_next = 0;
2169 CALL_PEEP(PL_main_start);
2172 /* Register with debugger */
2175 = Perl_get_cvn_flags(aTHX_ STR_WITH_LEN("DB::postponed"), 0);
2179 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2181 call_sv((SV*)cv, G_DISCARD);
2188 Perl_localize(pTHX_ OP *o, I32 lex)
2191 if (o->op_flags & OPf_PARENS)
2192 /* [perl #17376]: this appears to be premature, and results in code such as
2193 C< our(%x); > executing in list mode rather than void mode */
2200 if ( PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ','
2201 && ckWARN(WARN_PARENTHESIS))
2203 char *s = PL_bufptr;
2206 /* some heuristics to detect a potential error */
2207 while (*s && (strchr(", \t\n", *s)))
2211 if (*s && strchr("@$%*", *s) && *++s
2212 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2215 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2217 while (*s && (strchr(", \t\n", *s)))
2223 if (sigil && (*s == ';' || *s == '=')) {
2224 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2225 "Parentheses missing around \"%s\" list",
2226 lex ? (PL_in_my == KEY_our ? "our" : PL_in_my == KEY_state ? "state" : "my")
2234 o = mod(o, OP_NULL); /* a bit kludgey */
2236 PL_in_my_stash = NULL;
2241 Perl_jmaybe(pTHX_ OP *o)
2243 if (o->op_type == OP_LIST) {
2245 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2246 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2252 Perl_fold_constants(pTHX_ register OP *o)
2257 VOL I32 type = o->op_type;
2262 SV * const oldwarnhook = PL_warnhook;
2263 SV * const olddiehook = PL_diehook;
2266 if (PL_opargs[type] & OA_RETSCALAR)
2268 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2269 o->op_targ = pad_alloc(type, SVs_PADTMP);
2271 /* integerize op, unless it happens to be C<-foo>.
2272 * XXX should pp_i_negate() do magic string negation instead? */
2273 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2274 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2275 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2277 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2280 if (!(PL_opargs[type] & OA_FOLDCONST))
2285 /* XXX might want a ck_negate() for this */
2286 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2297 /* XXX what about the numeric ops? */
2298 if (PL_hints & HINT_LOCALE)
2303 goto nope; /* Don't try to run w/ errors */
2305 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2306 const OPCODE type = curop->op_type;
2307 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2309 type != OP_SCALAR &&
2311 type != OP_PUSHMARK)
2317 curop = LINKLIST(o);
2318 old_next = o->op_next;
2322 oldscope = PL_scopestack_ix;
2323 create_eval_scope(G_FAKINGEVAL);
2325 PL_warnhook = PERL_WARNHOOK_FATAL;
2332 sv = *(PL_stack_sp--);
2333 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2334 pad_swipe(o->op_targ, FALSE);
2335 else if (SvTEMP(sv)) { /* grab mortal temp? */
2336 SvREFCNT_inc_simple_void(sv);
2341 /* Something tried to die. Abandon constant folding. */
2342 /* Pretend the error never happened. */
2343 sv_setpvn(ERRSV,"",0);
2344 o->op_next = old_next;
2348 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
2349 PL_warnhook = oldwarnhook;
2350 PL_diehook = olddiehook;
2351 /* XXX note that this croak may fail as we've already blown away
2352 * the stack - eg any nested evals */
2353 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
2356 PL_warnhook = oldwarnhook;
2357 PL_diehook = olddiehook;
2359 if (PL_scopestack_ix > oldscope)
2360 delete_eval_scope();
2369 if (type == OP_RV2GV)
2370 newop = newGVOP(OP_GV, 0, (GV*)sv);
2372 newop = newSVOP(OP_CONST, 0, (SV*)sv);
2373 op_getmad(o,newop,'f');
2381 Perl_gen_constant_list(pTHX_ register OP *o)
2385 const I32 oldtmps_floor = PL_tmps_floor;
2389 return o; /* Don't attempt to run with errors */
2391 PL_op = curop = LINKLIST(o);
2397 assert (!(curop->op_flags & OPf_SPECIAL));
2398 assert(curop->op_type == OP_RANGE);
2400 PL_tmps_floor = oldtmps_floor;
2402 o->op_type = OP_RV2AV;
2403 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2404 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2405 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2406 o->op_opt = 0; /* needs to be revisited in peep() */
2407 curop = ((UNOP*)o)->op_first;
2408 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
2410 op_getmad(curop,o,'O');
2419 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2422 if (!o || o->op_type != OP_LIST)
2423 o = newLISTOP(OP_LIST, 0, o, NULL);
2425 o->op_flags &= ~OPf_WANT;
2427 if (!(PL_opargs[type] & OA_MARK))
2428 op_null(cLISTOPo->op_first);
2430 o->op_type = (OPCODE)type;
2431 o->op_ppaddr = PL_ppaddr[type];
2432 o->op_flags |= flags;
2434 o = CHECKOP(type, o);
2435 if (o->op_type != (unsigned)type)
2438 return fold_constants(o);
2441 /* List constructors */
2444 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2452 if (first->op_type != (unsigned)type
2453 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2455 return newLISTOP(type, 0, first, last);
2458 if (first->op_flags & OPf_KIDS)
2459 ((LISTOP*)first)->op_last->op_sibling = last;
2461 first->op_flags |= OPf_KIDS;
2462 ((LISTOP*)first)->op_first = last;
2464 ((LISTOP*)first)->op_last = last;
2469 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2477 if (first->op_type != (unsigned)type)
2478 return prepend_elem(type, (OP*)first, (OP*)last);
2480 if (last->op_type != (unsigned)type)
2481 return append_elem(type, (OP*)first, (OP*)last);
2483 first->op_last->op_sibling = last->op_first;
2484 first->op_last = last->op_last;
2485 first->op_flags |= (last->op_flags & OPf_KIDS);
2488 if (last->op_first && first->op_madprop) {
2489 MADPROP *mp = last->op_first->op_madprop;
2491 while (mp->mad_next)
2493 mp->mad_next = first->op_madprop;
2496 last->op_first->op_madprop = first->op_madprop;
2499 first->op_madprop = last->op_madprop;
2500 last->op_madprop = 0;
2503 S_op_destroy(aTHX_ (OP*)last);
2509 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2517 if (last->op_type == (unsigned)type) {
2518 if (type == OP_LIST) { /* already a PUSHMARK there */
2519 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2520 ((LISTOP*)last)->op_first->op_sibling = first;
2521 if (!(first->op_flags & OPf_PARENS))
2522 last->op_flags &= ~OPf_PARENS;
2525 if (!(last->op_flags & OPf_KIDS)) {
2526 ((LISTOP*)last)->op_last = first;
2527 last->op_flags |= OPf_KIDS;
2529 first->op_sibling = ((LISTOP*)last)->op_first;
2530 ((LISTOP*)last)->op_first = first;
2532 last->op_flags |= OPf_KIDS;
2536 return newLISTOP(type, 0, first, last);
2544 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2547 Newxz(tk, 1, TOKEN);
2548 tk->tk_type = (OPCODE)optype;
2549 tk->tk_type = 12345;
2551 tk->tk_mad = madprop;
2556 Perl_token_free(pTHX_ TOKEN* tk)
2558 if (tk->tk_type != 12345)
2560 mad_free(tk->tk_mad);
2565 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2569 if (tk->tk_type != 12345) {
2570 Perl_warner(aTHX_ packWARN(WARN_MISC),
2571 "Invalid TOKEN object ignored");
2578 /* faked up qw list? */
2580 tm->mad_type == MAD_SV &&
2581 SvPVX((SV*)tm->mad_val)[0] == 'q')
2588 /* pretend constant fold didn't happen? */
2589 if (mp->mad_key == 'f' &&
2590 (o->op_type == OP_CONST ||
2591 o->op_type == OP_GV) )
2593 token_getmad(tk,(OP*)mp->mad_val,slot);
2607 if (mp->mad_key == 'X')
2608 mp->mad_key = slot; /* just change the first one */
2618 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
2627 /* pretend constant fold didn't happen? */
2628 if (mp->mad_key == 'f' &&
2629 (o->op_type == OP_CONST ||
2630 o->op_type == OP_GV) )
2632 op_getmad(from,(OP*)mp->mad_val,slot);
2639 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
2642 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
2648 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
2657 /* pretend constant fold didn't happen? */
2658 if (mp->mad_key == 'f' &&
2659 (o->op_type == OP_CONST ||
2660 o->op_type == OP_GV) )
2662 op_getmad(from,(OP*)mp->mad_val,slot);
2669 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
2672 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
2676 PerlIO_printf(PerlIO_stderr(),
2677 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
2683 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
2701 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
2705 addmad(tm, &(o->op_madprop), slot);
2709 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
2730 Perl_newMADsv(pTHX_ char key, SV* sv)
2732 return newMADPROP(key, MAD_SV, sv, 0);
2736 Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
2739 Newxz(mp, 1, MADPROP);
2742 mp->mad_vlen = vlen;
2743 mp->mad_type = type;
2745 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
2750 Perl_mad_free(pTHX_ MADPROP* mp)
2752 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
2756 mad_free(mp->mad_next);
2757 /* if (PL_lex_state != LEX_NOTPARSING && mp->mad_vlen)
2758 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
2759 switch (mp->mad_type) {
2763 Safefree((char*)mp->mad_val);
2766 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
2767 op_free((OP*)mp->mad_val);
2770 sv_free((SV*)mp->mad_val);
2773 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
2782 Perl_newNULLLIST(pTHX)
2784 return newOP(OP_STUB, 0);
2788 Perl_force_list(pTHX_ OP *o)
2790 if (!o || o->op_type != OP_LIST)
2791 o = newLISTOP(OP_LIST, 0, o, NULL);
2797 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2802 NewOp(1101, listop, 1, LISTOP);
2804 listop->op_type = (OPCODE)type;
2805 listop->op_ppaddr = PL_ppaddr[type];
2808 listop->op_flags = (U8)flags;
2812 else if (!first && last)
2815 first->op_sibling = last;
2816 listop->op_first = first;
2817 listop->op_last = last;
2818 if (type == OP_LIST) {
2819 OP* const pushop = newOP(OP_PUSHMARK, 0);
2820 pushop->op_sibling = first;
2821 listop->op_first = pushop;
2822 listop->op_flags |= OPf_KIDS;
2824 listop->op_last = pushop;
2827 return CHECKOP(type, listop);
2831 Perl_newOP(pTHX_ I32 type, I32 flags)
2835 NewOp(1101, o, 1, OP);
2836 o->op_type = (OPCODE)type;
2837 o->op_ppaddr = PL_ppaddr[type];
2838 o->op_flags = (U8)flags;
2840 o->op_latefreed = 0;
2844 o->op_private = (U8)(0 | (flags >> 8));
2845 if (PL_opargs[type] & OA_RETSCALAR)
2847 if (PL_opargs[type] & OA_TARGET)
2848 o->op_targ = pad_alloc(type, SVs_PADTMP);
2849 return CHECKOP(type, o);
2853 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2859 first = newOP(OP_STUB, 0);
2860 if (PL_opargs[type] & OA_MARK)
2861 first = force_list(first);
2863 NewOp(1101, unop, 1, UNOP);
2864 unop->op_type = (OPCODE)type;
2865 unop->op_ppaddr = PL_ppaddr[type];
2866 unop->op_first = first;
2867 unop->op_flags = (U8)(flags | OPf_KIDS);
2868 unop->op_private = (U8)(1 | (flags >> 8));
2869 unop = (UNOP*) CHECKOP(type, unop);
2873 return fold_constants((OP *) unop);
2877 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2881 NewOp(1101, binop, 1, BINOP);
2884 first = newOP(OP_NULL, 0);
2886 binop->op_type = (OPCODE)type;
2887 binop->op_ppaddr = PL_ppaddr[type];
2888 binop->op_first = first;
2889 binop->op_flags = (U8)(flags | OPf_KIDS);
2892 binop->op_private = (U8)(1 | (flags >> 8));
2895 binop->op_private = (U8)(2 | (flags >> 8));
2896 first->op_sibling = last;
2899 binop = (BINOP*)CHECKOP(type, binop);
2900 if (binop->op_next || binop->op_type != (OPCODE)type)
2903 binop->op_last = binop->op_first->op_sibling;
2905 return fold_constants((OP *)binop);
2908 static int uvcompare(const void *a, const void *b)
2909 __attribute__nonnull__(1)
2910 __attribute__nonnull__(2)
2911 __attribute__pure__;
2912 static int uvcompare(const void *a, const void *b)
2914 if (*((const UV *)a) < (*(const UV *)b))
2916 if (*((const UV *)a) > (*(const UV *)b))
2918 if (*((const UV *)a+1) < (*(const UV *)b+1))
2920 if (*((const UV *)a+1) > (*(const UV *)b+1))
2926 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2929 SV * const tstr = ((SVOP*)expr)->op_sv;
2932 (repl->op_type == OP_NULL)
2933 ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
2935 ((SVOP*)repl)->op_sv;
2938 const U8 *t = (U8*)SvPV_const(tstr, tlen);
2939 const U8 *r = (U8*)SvPV_const(rstr, rlen);
2943 register short *tbl;
2945 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
2946 const I32 squash = o->op_private & OPpTRANS_SQUASH;
2947 I32 del = o->op_private & OPpTRANS_DELETE;
2949 PL_hints |= HINT_BLOCK_SCOPE;
2952 o->op_private |= OPpTRANS_FROM_UTF;
2955 o->op_private |= OPpTRANS_TO_UTF;
2957 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2958 SV* const listsv = newSVpvs("# comment\n");
2960 const U8* tend = t + tlen;
2961 const U8* rend = r + rlen;
2975 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
2976 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
2979 const U32 flags = UTF8_ALLOW_DEFAULT;
2983 t = tsave = bytes_to_utf8(t, &len);
2986 if (!to_utf && rlen) {
2988 r = rsave = bytes_to_utf8(r, &len);
2992 /* There are several snags with this code on EBCDIC:
2993 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2994 2. scan_const() in toke.c has encoded chars in native encoding which makes
2995 ranges at least in EBCDIC 0..255 range the bottom odd.
2999 U8 tmpbuf[UTF8_MAXBYTES+1];
3002 Newx(cp, 2*tlen, UV);
3004 transv = newSVpvs("");
3006 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3008 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
3010 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3014 cp[2*i+1] = cp[2*i];
3018 qsort(cp, i, 2*sizeof(UV), uvcompare);
3019 for (j = 0; j < i; j++) {
3021 diff = val - nextmin;
3023 t = uvuni_to_utf8(tmpbuf,nextmin);
3024 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3026 U8 range_mark = UTF_TO_NATIVE(0xff);
3027 t = uvuni_to_utf8(tmpbuf, val - 1);
3028 sv_catpvn(transv, (char *)&range_mark, 1);
3029 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3036 t = uvuni_to_utf8(tmpbuf,nextmin);
3037 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3039 U8 range_mark = UTF_TO_NATIVE(0xff);
3040 sv_catpvn(transv, (char *)&range_mark, 1);
3042 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
3043 UNICODE_ALLOW_SUPER);
3044 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3045 t = (const U8*)SvPVX_const(transv);
3046 tlen = SvCUR(transv);
3050 else if (!rlen && !del) {
3051 r = t; rlen = tlen; rend = tend;
3054 if ((!rlen && !del) || t == r ||
3055 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
3057 o->op_private |= OPpTRANS_IDENTICAL;
3061 while (t < tend || tfirst <= tlast) {
3062 /* see if we need more "t" chars */
3063 if (tfirst > tlast) {
3064 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3066 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
3068 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3075 /* now see if we need more "r" chars */
3076 if (rfirst > rlast) {
3078 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3080 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
3082 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3091 rfirst = rlast = 0xffffffff;
3095 /* now see which range will peter our first, if either. */
3096 tdiff = tlast - tfirst;
3097 rdiff = rlast - rfirst;
3104 if (rfirst == 0xffffffff) {
3105 diff = tdiff; /* oops, pretend rdiff is infinite */
3107 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
3108 (long)tfirst, (long)tlast);
3110 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
3114 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
3115 (long)tfirst, (long)(tfirst + diff),
3118 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3119 (long)tfirst, (long)rfirst);
3121 if (rfirst + diff > max)
3122 max = rfirst + diff;
3124 grows = (tfirst < rfirst &&
3125 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3137 else if (max > 0xff)
3142 PerlMemShared_free(cPVOPo->op_pv);
3143 cPVOPo->op_pv = NULL;
3145 swash = (SV*)swash_init("utf8", "", listsv, bits, none);
3147 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
3148 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
3149 PAD_SETSV(cPADOPo->op_padix, swash);
3152 cSVOPo->op_sv = swash;
3154 SvREFCNT_dec(listsv);
3155 SvREFCNT_dec(transv);
3157 if (!del && havefinal && rlen)
3158 (void)hv_store((HV*)SvRV(swash), "FINAL", 5,
3159 newSVuv((UV)final), 0);
3162 o->op_private |= OPpTRANS_GROWS;
3168 op_getmad(expr,o,'e');
3169 op_getmad(repl,o,'r');
3177 tbl = (short*)cPVOPo->op_pv;
3179 Zero(tbl, 256, short);
3180 for (i = 0; i < (I32)tlen; i++)
3182 for (i = 0, j = 0; i < 256; i++) {
3184 if (j >= (I32)rlen) {
3193 if (i < 128 && r[j] >= 128)
3203 o->op_private |= OPpTRANS_IDENTICAL;
3205 else if (j >= (I32)rlen)
3210 PerlMemShared_realloc(tbl,
3211 (0x101+rlen-j) * sizeof(short));
3212 cPVOPo->op_pv = (char*)tbl;
3214 tbl[0x100] = (short)(rlen - j);
3215 for (i=0; i < (I32)rlen - j; i++)
3216 tbl[0x101+i] = r[j+i];
3220 if (!rlen && !del) {
3223 o->op_private |= OPpTRANS_IDENTICAL;
3225 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3226 o->op_private |= OPpTRANS_IDENTICAL;
3228 for (i = 0; i < 256; i++)
3230 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3231 if (j >= (I32)rlen) {
3233 if (tbl[t[i]] == -1)
3239 if (tbl[t[i]] == -1) {
3240 if (t[i] < 128 && r[j] >= 128)
3247 o->op_private |= OPpTRANS_GROWS;
3249 op_getmad(expr,o,'e');
3250 op_getmad(repl,o,'r');
3260 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3265 NewOp(1101, pmop, 1, PMOP);
3266 pmop->op_type = (OPCODE)type;
3267 pmop->op_ppaddr = PL_ppaddr[type];
3268 pmop->op_flags = (U8)flags;
3269 pmop->op_private = (U8)(0 | (flags >> 8));
3271 if (PL_hints & HINT_RE_TAINT)
3272 pmop->op_pmpermflags |= PMf_RETAINT;
3273 if (PL_hints & HINT_LOCALE)
3274 pmop->op_pmpermflags |= PMf_LOCALE;
3275 pmop->op_pmflags = pmop->op_pmpermflags;
3278 if (av_len((AV*) PL_regex_pad[0]) > -1) {
3279 SV * const repointer = av_pop((AV*)PL_regex_pad[0]);
3280 pmop->op_pmoffset = SvIV(repointer);
3281 SvREPADTMP_off(repointer);
3282 sv_setiv(repointer,0);
3284 SV * const repointer = newSViv(0);
3285 av_push(PL_regex_padav, SvREFCNT_inc_simple_NN(repointer));
3286 pmop->op_pmoffset = av_len(PL_regex_padav);
3287 PL_regex_pad = AvARRAY(PL_regex_padav);
3291 /* link into pm list */
3292 if (type != OP_TRANS && PL_curstash) {
3293 MAGIC *mg = mg_find((SV*)PL_curstash, PERL_MAGIC_symtab);
3296 mg = sv_magicext((SV*)PL_curstash, 0, PERL_MAGIC_symtab, 0, 0, 0);
3298 pmop->op_pmnext = (PMOP*)mg->mg_obj;
3299 mg->mg_obj = (SV*)pmop;
3300 PmopSTASH_set(pmop,PL_curstash);
3303 return CHECKOP(type, pmop);
3306 /* Given some sort of match op o, and an expression expr containing a
3307 * pattern, either compile expr into a regex and attach it to o (if it's
3308 * constant), or convert expr into a runtime regcomp op sequence (if it's
3311 * isreg indicates that the pattern is part of a regex construct, eg
3312 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3313 * split "pattern", which aren't. In the former case, expr will be a list
3314 * if the pattern contains more than one term (eg /a$b/) or if it contains
3315 * a replacement, ie s/// or tr///.
3319 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
3324 I32 repl_has_vars = 0;
3328 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
3329 /* last element in list is the replacement; pop it */
3331 repl = cLISTOPx(expr)->op_last;
3332 kid = cLISTOPx(expr)->op_first;
3333 while (kid->op_sibling != repl)
3334 kid = kid->op_sibling;
3335 kid->op_sibling = NULL;
3336 cLISTOPx(expr)->op_last = kid;
3339 if (isreg && expr->op_type == OP_LIST &&
3340 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3342 /* convert single element list to element */
3343 OP* const oe = expr;
3344 expr = cLISTOPx(oe)->op_first->op_sibling;
3345 cLISTOPx(oe)->op_first->op_sibling = NULL;
3346 cLISTOPx(oe)->op_last = NULL;
3350 if (o->op_type == OP_TRANS) {
3351 return pmtrans(o, expr, repl);
3354 reglist = isreg && expr->op_type == OP_LIST;
3358 PL_hints |= HINT_BLOCK_SCOPE;
3361 if (expr->op_type == OP_CONST) {
3363 SV * const pat = ((SVOP*)expr)->op_sv;
3364 const char *p = SvPV_const(pat, plen);
3365 if ((o->op_flags & OPf_SPECIAL) && (plen == 1 && *p == ' ')) {
3366 U32 was_readonly = SvREADONLY(pat);
3370 sv_force_normal_flags(pat, 0);
3371 assert(!SvREADONLY(pat));
3374 SvREADONLY_off(pat);
3378 sv_setpvn(pat, "\\s+", 3);
3380 SvFLAGS(pat) |= was_readonly;
3382 p = SvPV_const(pat, plen);
3383 pm->op_pmflags |= PMf_SKIPWHITE;
3386 pm->op_pmdynflags |= PMdf_UTF8;
3387 /* FIXME - can we make this function take const char * args? */
3388 PM_SETRE(pm, CALLREGCOMP((char*)p, (char*)p + plen, pm));
3389 if (PM_GETRE(pm)->extflags & RXf_WHITE)
3390 pm->op_pmflags |= PMf_WHITE;
3392 pm->op_pmflags &= ~PMf_WHITE;
3394 op_getmad(expr,(OP*)pm,'e');
3400 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3401 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3403 : OP_REGCMAYBE),0,expr);
3405 NewOp(1101, rcop, 1, LOGOP);
3406 rcop->op_type = OP_REGCOMP;
3407 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3408 rcop->op_first = scalar(expr);
3409 rcop->op_flags |= OPf_KIDS
3410 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3411 | (reglist ? OPf_STACKED : 0);
3412 rcop->op_private = 1;
3415 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3417 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
3420 /* establish postfix order */
3421 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3423 rcop->op_next = expr;
3424 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3427 rcop->op_next = LINKLIST(expr);
3428 expr->op_next = (OP*)rcop;
3431 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3436 if (pm->op_pmflags & PMf_EVAL) {
3438 if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
3439 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
3441 else if (repl->op_type == OP_CONST)
3445 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3446 if (curop->op_type == OP_SCOPE
3447 || curop->op_type == OP_LEAVE
3448 || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
3449 if (curop->op_type == OP_GV) {
3450 GV * const gv = cGVOPx_gv(curop);
3452 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3455 else if (curop->op_type == OP_RV2CV)
3457 else if (curop->op_type == OP_RV2SV ||
3458 curop->op_type == OP_RV2AV ||
3459 curop->op_type == OP_RV2HV ||
3460 curop->op_type == OP_RV2GV) {
3461 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3464 else if (curop->op_type == OP_PADSV ||
3465 curop->op_type == OP_PADAV ||
3466 curop->op_type == OP_PADHV ||
3467 curop->op_type == OP_PADANY)
3471 else if (curop->op_type == OP_PUSHRE)
3472 NOOP; /* Okay here, dangerous in newASSIGNOP */
3482 || PM_GETRE(pm)->extflags & RXf_EVAL_SEEN)))
3484 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3485 pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
3486 prepend_elem(o->op_type, scalar(repl), o);
3489 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3490 pm->op_pmflags |= PMf_MAYBE_CONST;
3491 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3493 NewOp(1101, rcop, 1, LOGOP);
3494 rcop->op_type = OP_SUBSTCONT;
3495 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3496 rcop->op_first = scalar(repl);
3497 rcop->op_flags |= OPf_KIDS;
3498 rcop->op_private = 1;
3501 /* establish postfix order */
3502 rcop->op_next = LINKLIST(repl);
3503 repl->op_next = (OP*)rcop;
3505 pm->op_pmreplroot = scalar((OP*)rcop);
3506 pm->op_pmreplstart = LINKLIST(rcop);
3515 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3519 NewOp(1101, svop, 1, SVOP);
3520 svop->op_type = (OPCODE)type;
3521 svop->op_ppaddr = PL_ppaddr[type];
3523 svop->op_next = (OP*)svop;
3524 svop->op_flags = (U8)flags;
3525 if (PL_opargs[type] & OA_RETSCALAR)
3527 if (PL_opargs[type] & OA_TARGET)
3528 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3529 return CHECKOP(type, svop);
3534 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3538 NewOp(1101, padop, 1, PADOP);
3539 padop->op_type = (OPCODE)type;
3540 padop->op_ppaddr = PL_ppaddr[type];
3541 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3542 SvREFCNT_dec(PAD_SVl(padop->op_padix));
3543 PAD_SETSV(padop->op_padix, sv);
3546 padop->op_next = (OP*)padop;
3547 padop->op_flags = (U8)flags;
3548 if (PL_opargs[type] & OA_RETSCALAR)
3550 if (PL_opargs[type] & OA_TARGET)
3551 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3552 return CHECKOP(type, padop);
3557 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3563 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3565 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3570 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3574 NewOp(1101, pvop, 1, PVOP);
3575 pvop->op_type = (OPCODE)type;
3576 pvop->op_ppaddr = PL_ppaddr[type];
3578 pvop->op_next = (OP*)pvop;
3579 pvop->op_flags = (U8)flags;
3580 if (PL_opargs[type] & OA_RETSCALAR)
3582 if (PL_opargs[type] & OA_TARGET)
3583 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3584 return CHECKOP(type, pvop);
3592 Perl_package(pTHX_ OP *o)
3595 SV *const sv = cSVOPo->op_sv;
3600 save_hptr(&PL_curstash);
3601 save_item(PL_curstname);
3603 PL_curstash = gv_stashsv(sv, GV_ADD);
3604 sv_setsv(PL_curstname, sv);
3606 PL_hints |= HINT_BLOCK_SCOPE;
3607 PL_copline = NOLINE;
3613 if (!PL_madskills) {
3618 pegop = newOP(OP_NULL,0);
3619 op_getmad(o,pegop,'P');
3629 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3636 OP *pegop = newOP(OP_NULL,0);
3639 if (idop->op_type != OP_CONST)
3640 Perl_croak(aTHX_ "Module name must be constant");
3643 op_getmad(idop,pegop,'U');
3648 SV * const vesv = ((SVOP*)version)->op_sv;
3651 op_getmad(version,pegop,'V');
3652 if (!arg && !SvNIOKp(vesv)) {
3659 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3660 Perl_croak(aTHX_ "Version number must be constant number");
3662 /* Make copy of idop so we don't free it twice */
3663 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3665 /* Fake up a method call to VERSION */
3666 meth = newSVpvs_share("VERSION");
3667 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3668 append_elem(OP_LIST,
3669 prepend_elem(OP_LIST, pack, list(version)),
3670 newSVOP(OP_METHOD_NAMED, 0, meth)));
3674 /* Fake up an import/unimport */
3675 if (arg && arg->op_type == OP_STUB) {
3677 op_getmad(arg,pegop,'S');
3678 imop = arg; /* no import on explicit () */
3680 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3681 imop = NULL; /* use 5.0; */
3683 idop->op_private |= OPpCONST_NOVER;
3689 op_getmad(arg,pegop,'A');
3691 /* Make copy of idop so we don't free it twice */
3692 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3694 /* Fake up a method call to import/unimport */
3696 ? newSVpvs_share("import") : newSVpvs_share("unimport");
3697 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3698 append_elem(OP_LIST,
3699 prepend_elem(OP_LIST, pack, list(arg)),
3700 newSVOP(OP_METHOD_NAMED, 0, meth)));
3703 /* Fake up the BEGIN {}, which does its thing immediately. */
3705 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
3708 append_elem(OP_LINESEQ,
3709 append_elem(OP_LINESEQ,
3710 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
3711 newSTATEOP(0, NULL, veop)),
3712 newSTATEOP(0, NULL, imop) ));
3714 /* The "did you use incorrect case?" warning used to be here.
3715 * The problem is that on case-insensitive filesystems one
3716 * might get false positives for "use" (and "require"):
3717 * "use Strict" or "require CARP" will work. This causes
3718 * portability problems for the script: in case-strict
3719 * filesystems the script will stop working.
3721 * The "incorrect case" warning checked whether "use Foo"
3722 * imported "Foo" to your namespace, but that is wrong, too:
3723 * there is no requirement nor promise in the language that
3724 * a Foo.pm should or would contain anything in package "Foo".
3726 * There is very little Configure-wise that can be done, either:
3727 * the case-sensitivity of the build filesystem of Perl does not
3728 * help in guessing the case-sensitivity of the runtime environment.
3731 PL_hints |= HINT_BLOCK_SCOPE;
3732 PL_copline = NOLINE;
3734 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3737 if (!PL_madskills) {
3738 /* FIXME - don't allocate pegop if !PL_madskills */
3747 =head1 Embedding Functions
3749 =for apidoc load_module
3751 Loads the module whose name is pointed to by the string part of name.
3752 Note that the actual module name, not its filename, should be given.
3753 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3754 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3755 (or 0 for no flags). ver, if specified, provides version semantics
3756 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3757 arguments can be used to specify arguments to the module's import()
3758 method, similar to C<use Foo::Bar VERSION LIST>.
3763 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3766 va_start(args, ver);
3767 vload_module(flags, name, ver, &args);
3771 #ifdef PERL_IMPLICIT_CONTEXT
3773 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3777 va_start(args, ver);
3778 vload_module(flags, name, ver, &args);
3784 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3789 OP * const modname = newSVOP(OP_CONST, 0, name);
3790 modname->op_private |= OPpCONST_BARE;
3792 veop = newSVOP(OP_CONST, 0, ver);
3796 if (flags & PERL_LOADMOD_NOIMPORT) {
3797 imop = sawparens(newNULLLIST());
3799 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3800 imop = va_arg(*args, OP*);
3805 sv = va_arg(*args, SV*);
3807 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3808 sv = va_arg(*args, SV*);
3812 const line_t ocopline = PL_copline;
3813 COP * const ocurcop = PL_curcop;
3814 const int oexpect = PL_expect;
3816 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3817 veop, modname, imop);
3818 PL_expect = oexpect;
3819 PL_copline = ocopline;
3820 PL_curcop = ocurcop;
3825 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
3831 if (!force_builtin) {
3832 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
3833 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
3834 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
3835 gv = gvp ? *gvp : NULL;
3839 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3840 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3841 append_elem(OP_LIST, term,
3842 scalar(newUNOP(OP_RV2CV, 0,
3843 newGVOP(OP_GV, 0, gv))))));
3846 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3852 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3854 return newBINOP(OP_LSLICE, flags,
3855 list(force_list(subscript)),
3856 list(force_list(listval)) );
3860 S_is_list_assignment(pTHX_ register const OP *o)
3868 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
3869 o = cUNOPo->op_first;
3871 flags = o->op_flags;
3873 if (type == OP_COND_EXPR) {
3874 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
3875 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3880 yyerror("Assignment to both a list and a scalar");
3884 if (type == OP_LIST &&
3885 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
3886 o->op_private & OPpLVAL_INTRO)
3889 if (type == OP_LIST || flags & OPf_PARENS ||
3890 type == OP_RV2AV || type == OP_RV2HV ||
3891 type == OP_ASLICE || type == OP_HSLICE)
3894 if (type == OP_PADAV || type == OP_PADHV)
3897 if (type == OP_RV2SV)
3904 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3910 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3911 return newLOGOP(optype, 0,
3912 mod(scalar(left), optype),
3913 newUNOP(OP_SASSIGN, 0, scalar(right)));
3916 return newBINOP(optype, OPf_STACKED,
3917 mod(scalar(left), optype), scalar(right));
3921 if (is_list_assignment(left)) {
3925 /* Grandfathering $[ assignment here. Bletch.*/
3926 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
3927 PL_eval_start = (left->op_type == OP_CONST) ? right : 0;
3928 left = mod(left, OP_AASSIGN);
3931 else if (left->op_type == OP_CONST) {
3933 /* Result of assignment is always 1 (or we'd be dead already) */
3934 return newSVOP(OP_CONST, 0, newSViv(1));
3936 curop = list(force_list(left));
3937 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3938 o->op_private = (U8)(0 | (flags >> 8));
3940 /* PL_generation sorcery:
3941 * an assignment like ($a,$b) = ($c,$d) is easier than
3942 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3943 * To detect whether there are common vars, the global var
3944 * PL_generation is incremented for each assign op we compile.
3945 * Then, while compiling the assign op, we run through all the
3946 * variables on both sides of the assignment, setting a spare slot
3947 * in each of them to PL_generation. If any of them already have
3948 * that value, we know we've got commonality. We could use a
3949 * single bit marker, but then we'd have to make 2 passes, first
3950 * to clear the flag, then to test and set it. To find somewhere
3951 * to store these values, evil chicanery is done with SvUVX().
3957 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3958 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3959 if (curop->op_type == OP_GV) {
3960 GV *gv = cGVOPx_gv(curop);
3962 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
3964 GvASSIGN_GENERATION_set(gv, PL_generation);
3966 else if (curop->op_type == OP_PADSV ||
3967 curop->op_type == OP_PADAV ||
3968 curop->op_type == OP_PADHV ||
3969 curop->op_type == OP_PADANY)
3971 if (PAD_COMPNAME_GEN(curop->op_targ)
3972 == (STRLEN)PL_generation)
3974 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
3977 else if (curop->op_type == OP_RV2CV)
3979 else if (curop->op_type == OP_RV2SV ||
3980 curop->op_type == OP_RV2AV ||
3981 curop->op_type == OP_RV2HV ||
3982 curop->op_type == OP_RV2GV) {
3983 if (lastop->op_type != OP_GV) /* funny deref? */
3986 else if (curop->op_type == OP_PUSHRE) {
3987 if (((PMOP*)curop)->op_pmreplroot) {
3989 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3990 ((PMOP*)curop)->op_pmreplroot));
3992 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3995 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
3997 GvASSIGN_GENERATION_set(gv, PL_generation);
3998 GvASSIGN_GENERATION_set(gv, PL_generation);
4007 o->op_private |= OPpASSIGN_COMMON;
4010 if ( ((left->op_private & OPpLVAL_INTRO) || ckWARN(WARN_MISC))
4011 && (left->op_type == OP_LIST
4012 || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
4014 OP* lop = ((LISTOP*)left)->op_first;
4016 if (lop->op_type == OP_PADSV ||
4017 lop->op_type == OP_PADAV ||
4018 lop->op_type == OP_PADHV ||
4019 lop->op_type == OP_PADANY)
4021 if (lop->op_private & OPpPAD_STATE) {
4022 if (left->op_private & OPpLVAL_INTRO) {
4023 o->op_private |= OPpASSIGN_STATE;
4024 /* hijacking PADSTALE for uninitialized state variables */
4025 SvPADSTALE_on(PAD_SVl(lop->op_targ));
4027 else { /* we already checked for WARN_MISC before */
4028 Perl_warner(aTHX_ packWARN(WARN_MISC), "State variable %s will be reinitialized",
4029 PAD_COMPNAME_PV(lop->op_targ));
4033 lop = lop->op_sibling;
4036 else if (((left->op_private & (OPpLVAL_INTRO | OPpPAD_STATE))
4037 == (OPpLVAL_INTRO | OPpPAD_STATE))
4038 && ( left->op_type == OP_PADSV
4039 || left->op_type == OP_PADAV
4040 || left->op_type == OP_PADHV
4041 || left->op_type == OP_PADANY))
4043 o->op_private |= OPpASSIGN_STATE;
4044 /* hijacking PADSTALE for uninitialized state variables */
4045 SvPADSTALE_on(PAD_SVl(left->op_targ));
4048 if (right && right->op_type == OP_SPLIT) {
4049 OP* tmpop = ((LISTOP*)right)->op_first;
4050 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
4051 PMOP * const pm = (PMOP*)tmpop;
4052 if (left->op_type == OP_RV2AV &&
4053 !(left->op_private & OPpLVAL_INTRO) &&
4054 !(o->op_private & OPpASSIGN_COMMON) )
4056 tmpop = ((UNOP*)left)->op_first;
4057 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
4059 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
4060 cPADOPx(tmpop)->op_padix = 0; /* steal it */
4062 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
4063 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
4065 pm->op_pmflags |= PMf_ONCE;
4066 tmpop = cUNOPo->op_first; /* to list (nulled) */
4067 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
4068 tmpop->op_sibling = NULL; /* don't free split */
4069 right->op_next = tmpop->op_next; /* fix starting loc */
4071 op_getmad(o,right,'R'); /* blow off assign */
4073 op_free(o); /* blow off assign */
4075 right->op_flags &= ~OPf_WANT;
4076 /* "I don't know and I don't care." */
4081 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
4082 ((LISTOP*)right)->op_last->op_type == OP_CONST)
4084 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
4086 sv_setiv(sv, PL_modcount+1);
4094 right = newOP(OP_UNDEF, 0);
4095 if (right->op_type == OP_READLINE) {
4096 right->op_flags |= OPf_STACKED;
4097 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
4100 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
4101 o = newBINOP(OP_SASSIGN, flags,
4102 scalar(right), mod(scalar(left), OP_SASSIGN) );
4108 o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
4109 o->op_private |= OPpCONST_ARYBASE;
4116 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
4119 const U32 seq = intro_my();
4122 NewOp(1101, cop, 1, COP);
4123 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
4124 cop->op_type = OP_DBSTATE;
4125 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
4128 cop->op_type = OP_NEXTSTATE;
4129 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
4131 cop->op_flags = (U8)flags;
4132 CopHINTS_set(cop, PL_hints);
4134 cop->op_private |= NATIVE_HINTS;
4136 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
4137 cop->op_next = (OP*)cop;
4140 CopLABEL_set(cop, label);
4141 PL_hints |= HINT_BLOCK_SCOPE;
4144 /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
4145 CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
4147 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
4148 cop->cop_hints_hash = PL_curcop->cop_hints_hash;
4149 if (cop->cop_hints_hash) {
4151 cop->cop_hints_hash->refcounted_he_refcnt++;
4152 HINTS_REFCNT_UNLOCK;
4155 if (PL_copline == NOLINE)
4156 CopLINE_set(cop, CopLINE(PL_curcop));
4158 CopLINE_set(cop, PL_copline);
4159 PL_copline = NOLINE;
4162 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
4164 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
4166 CopSTASH_set(cop, PL_curstash);
4168 if (PERLDB_LINE && PL_curstash != PL_debstash) {
4169 AV *av = CopFILEAVx(PL_curcop);
4171 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
4172 if (svp && *svp != &PL_sv_undef ) {
4173 (void)SvIOK_on(*svp);
4174 SvIV_set(*svp, PTR2IV(cop));
4179 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
4184 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
4187 return new_logop(type, flags, &first, &other);
4191 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
4196 OP *first = *firstp;
4197 OP * const other = *otherp;
4199 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
4200 return newBINOP(type, flags, scalar(first), scalar(other));
4202 scalarboolean(first);
4203 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
4204 if (first->op_type == OP_NOT
4205 && (first->op_flags & OPf_SPECIAL)
4206 && (first->op_flags & OPf_KIDS)) {
4207 if (type == OP_AND || type == OP_OR) {
4213 first = *firstp = cUNOPo->op_first;
4215 first->op_next = o->op_next;
4216 cUNOPo->op_first = NULL;
4218 op_getmad(o,first,'O');
4224 if (first->op_type == OP_CONST) {
4225 if (first->op_private & OPpCONST_STRICT)
4226 no_bareword_allowed(first);
4227 else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
4228 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
4229 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
4230 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
4231 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
4233 if (other->op_type == OP_CONST)
4234 other->op_private |= OPpCONST_SHORTCIRCUIT;
4236 OP *newop = newUNOP(OP_NULL, 0, other);
4237 op_getmad(first, newop, '1');
4238 newop->op_targ = type; /* set "was" field */
4245 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
4246 const OP *o2 = other;
4247 if ( ! (o2->op_type == OP_LIST
4248 && (( o2 = cUNOPx(o2)->op_first))
4249 && o2->op_type == OP_PUSHMARK
4250 && (( o2 = o2->op_sibling)) )
4253 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
4254 || o2->op_type == OP_PADHV)
4255 && o2->op_private & OPpLVAL_INTRO
4256 && ckWARN(WARN_DEPRECATED))
4258 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4259 "Deprecated use of my() in false conditional");
4263 if (first->op_type == OP_CONST)
4264 first->op_private |= OPpCONST_SHORTCIRCUIT;
4266 first = newUNOP(OP_NULL, 0, first);
4267 op_getmad(other, first, '2');
4268 first->op_targ = type; /* set "was" field */
4275 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
4276 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
4278 const OP * const k1 = ((UNOP*)first)->op_first;
4279 const OP * const k2 = k1->op_sibling;
4281 switch (first->op_type)
4284 if (k2 && k2->op_type == OP_READLINE
4285 && (k2->op_flags & OPf_STACKED)
4286 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4288 warnop = k2->op_type;
4293 if (k1->op_type == OP_READDIR
4294 || k1->op_type == OP_GLOB
4295 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4296 || k1->op_type == OP_EACH)
4298 warnop = ((k1->op_type == OP_NULL)
4299 ? (OPCODE)k1->op_targ : k1->op_type);
4304 const line_t oldline = CopLINE(PL_curcop);
4305 CopLINE_set(PL_curcop, PL_copline);
4306 Perl_warner(aTHX_ packWARN(WARN_MISC),
4307 "Value of %s%s can be \"0\"; test with defined()",
4309 ((warnop == OP_READLINE || warnop == OP_GLOB)
4310 ? " construct" : "() operator"));
4311 CopLINE_set(PL_curcop, oldline);
4318 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
4319 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
4321 NewOp(1101, logop, 1, LOGOP);
4323 logop->op_type = (OPCODE)type;
4324 logop->op_ppaddr = PL_ppaddr[type];
4325 logop->op_first = first;
4326 logop->op_flags = (U8)(flags | OPf_KIDS);
4327 logop->op_other = LINKLIST(other);
4328 logop->op_private = (U8)(1 | (flags >> 8));
4330 /* establish postfix order */
4331 logop->op_next = LINKLIST(first);
4332 first->op_next = (OP*)logop;
4333 first->op_sibling = other;
4335 CHECKOP(type,logop);
4337 o = newUNOP(OP_NULL, 0, (OP*)logop);
4344 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
4352 return newLOGOP(OP_AND, 0, first, trueop);
4354 return newLOGOP(OP_OR, 0, first, falseop);
4356 scalarboolean(first);
4357 if (first->op_type == OP_CONST) {
4358 /* Left or right arm of the conditional? */
4359 const bool left = SvTRUE(((SVOP*)first)->op_sv);
4360 OP *live = left ? trueop : falseop;
4361 OP *const dead = left ? falseop : trueop;
4362 if (first->op_private & OPpCONST_BARE &&
4363 first->op_private & OPpCONST_STRICT) {
4364 no_bareword_allowed(first);
4367 /* This is all dead code when PERL_MAD is not defined. */
4368 live = newUNOP(OP_NULL, 0, live);
4369 op_getmad(first, live, 'C');
4370 op_getmad(dead, live, left ? 'e' : 't');
4377 NewOp(1101, logop, 1, LOGOP);
4378 logop->op_type = OP_COND_EXPR;
4379 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4380 logop->op_first = first;
4381 logop->op_flags = (U8)(flags | OPf_KIDS);
4382 logop->op_private = (U8)(1 | (flags >> 8));
4383 logop->op_other = LINKLIST(trueop);
4384 logop->op_next = LINKLIST(falseop);
4386 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
4389 /* establish postfix order */
4390 start = LINKLIST(first);
4391 first->op_next = (OP*)logop;
4393 first->op_sibling = trueop;
4394 trueop->op_sibling = falseop;
4395 o = newUNOP(OP_NULL, 0, (OP*)logop);
4397 trueop->op_next = falseop->op_next = o;
4404 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4413 NewOp(1101, range, 1, LOGOP);
4415 range->op_type = OP_RANGE;
4416 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4417 range->op_first = left;
4418 range->op_flags = OPf_KIDS;
4419 leftstart = LINKLIST(left);
4420 range->op_other = LINKLIST(right);
4421 range->op_private = (U8)(1 | (flags >> 8));
4423 left->op_sibling = right;
4425 range->op_next = (OP*)range;
4426 flip = newUNOP(OP_FLIP, flags, (OP*)range);
4427 flop = newUNOP(OP_FLOP, 0, flip);
4428 o = newUNOP(OP_NULL, 0, flop);
4430 range->op_next = leftstart;
4432 left->op_next = flip;
4433 right->op_next = flop;
4435 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4436 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4437 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4438 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4440 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4441 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4444 if (!flip->op_private || !flop->op_private)
4445 linklist(o); /* blow off optimizer unless constant */
4451 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4456 const bool once = block && block->op_flags & OPf_SPECIAL &&
4457 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4459 PERL_UNUSED_ARG(debuggable);
4462 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4463 return block; /* do {} while 0 does once */
4464 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4465 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4466 expr = newUNOP(OP_DEFINED, 0,
4467 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4468 } else if (expr->op_flags & OPf_KIDS) {
4469 const OP * const k1 = ((UNOP*)expr)->op_first;
4470 const OP * const k2 = k1 ? k1->op_sibling : NULL;
4471 switch (expr->op_type) {
4473 if (k2 && k2->op_type == OP_READLINE
4474 && (k2->op_flags & OPf_STACKED)
4475 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4476 expr = newUNOP(OP_DEFINED, 0, expr);
4480 if (k1 && (k1->op_type == OP_READDIR
4481 || k1->op_type == OP_GLOB
4482 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4483 || k1->op_type == OP_EACH))
4484 expr = newUNOP(OP_DEFINED, 0, expr);
4490 /* if block is null, the next append_elem() would put UNSTACK, a scalar
4491 * op, in listop. This is wrong. [perl #27024] */
4493 block = newOP(OP_NULL, 0);
4494 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4495 o = new_logop(OP_AND, 0, &expr, &listop);
4498 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4500 if (once && o != listop)
4501 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4504 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
4506 o->op_flags |= flags;
4508 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4513 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
4514 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
4523 PERL_UNUSED_ARG(debuggable);
4526 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4527 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4528 expr = newUNOP(OP_DEFINED, 0,
4529 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4530 } else if (expr->op_flags & OPf_KIDS) {
4531 const OP * const k1 = ((UNOP*)expr)->op_first;
4532 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
4533 switch (expr->op_type) {
4535 if (k2 && k2->op_type == OP_READLINE
4536 && (k2->op_flags & OPf_STACKED)
4537 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4538 expr = newUNOP(OP_DEFINED, 0, expr);
4542 if (k1 && (k1->op_type == OP_READDIR
4543 || k1->op_type == OP_GLOB
4544 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4545 || k1->op_type == OP_EACH))
4546 expr = newUNOP(OP_DEFINED, 0, expr);
4553 block = newOP(OP_NULL, 0);
4554 else if (cont || has_my) {
4555 block = scope(block);
4559 next = LINKLIST(cont);
4562 OP * const unstack = newOP(OP_UNSTACK, 0);
4565 cont = append_elem(OP_LINESEQ, cont, unstack);
4569 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4571 redo = LINKLIST(listop);
4574 PL_copline = (line_t)whileline;
4576 o = new_logop(OP_AND, 0, &expr, &listop);
4577 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4578 op_free(expr); /* oops, it's a while (0) */
4580 return NULL; /* listop already freed by new_logop */
4583 ((LISTOP*)listop)->op_last->op_next =
4584 (o == listop ? redo : LINKLIST(o));
4590 NewOp(1101,loop,1,LOOP);
4591 loop->op_type = OP_ENTERLOOP;
4592 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4593 loop->op_private = 0;
4594 loop->op_next = (OP*)loop;
4597 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4599 loop->op_redoop = redo;
4600 loop->op_lastop = o;
4601 o->op_private |= loopflags;
4604 loop->op_nextop = next;
4606 loop->op_nextop = o;
4608 o->op_flags |= flags;
4609 o->op_private |= (flags >> 8);
4614 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
4619 PADOFFSET padoff = 0;
4625 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4626 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
4627 sv->op_type = OP_RV2GV;
4628 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4630 /* The op_type check is needed to prevent a possible segfault
4631 * if the loop variable is undeclared and 'strict vars' is in
4632 * effect. This is illegal but is nonetheless parsed, so we
4633 * may reach this point with an OP_CONST where we're expecting
4636 if (cUNOPx(sv)->op_first->op_type == OP_GV
4637 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
4638 iterpflags |= OPpITER_DEF;
4640 else if (sv->op_type == OP_PADSV) { /* private variable */
4641 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
4642 padoff = sv->op_targ;
4652 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4654 SV *const namesv = PAD_COMPNAME_SV(padoff);
4656 const char *const name = SvPV_const(namesv, len);
4658 if (len == 2 && name[0] == '$' && name[1] == '_')
4659 iterpflags |= OPpITER_DEF;
4663 const PADOFFSET offset = pad_findmy("$_");
4664 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
4665 sv = newGVOP(OP_GV, 0, PL_defgv);
4670 iterpflags |= OPpITER_DEF;
4672 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4673 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4674 iterflags |= OPf_STACKED;
4676 else if (expr->op_type == OP_NULL &&
4677 (expr->op_flags & OPf_KIDS) &&
4678 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4680 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4681 * set the STACKED flag to indicate that these values are to be
4682 * treated as min/max values by 'pp_iterinit'.
4684 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4685 LOGOP* const range = (LOGOP*) flip->op_first;
4686 OP* const left = range->op_first;
4687 OP* const right = left->op_sibling;
4690 range->op_flags &= ~OPf_KIDS;
4691 range->op_first = NULL;
4693 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4694 listop->op_first->op_next = range->op_next;
4695 left->op_next = range->op_other;
4696 right->op_next = (OP*)listop;
4697 listop->op_next = listop->op_first;
4700 op_getmad(expr,(OP*)listop,'O');
4704 expr = (OP*)(listop);
4706 iterflags |= OPf_STACKED;
4709 expr = mod(force_list(expr), OP_GREPSTART);
4712 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4713 append_elem(OP_LIST, expr, scalar(sv))));
4714 assert(!loop->op_next);
4715 /* for my $x () sets OPpLVAL_INTRO;
4716 * for our $x () sets OPpOUR_INTRO */
4717 loop->op_private = (U8)iterpflags;
4718 #ifdef PL_OP_SLAB_ALLOC
4721 NewOp(1234,tmp,1,LOOP);
4722 Copy(loop,tmp,1,LISTOP);
4723 S_op_destroy(aTHX_ (OP*)loop);
4727 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
4729 loop->op_targ = padoff;
4730 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
4732 op_getmad(madsv, (OP*)loop, 'v');
4733 PL_copline = forline;
4734 return newSTATEOP(0, label, wop);
4738 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4743 if (type != OP_GOTO || label->op_type == OP_CONST) {
4744 /* "last()" means "last" */
4745 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4746 o = newOP(type, OPf_SPECIAL);
4748 o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
4749 ? SvPVx_nolen_const(((SVOP*)label)->op_sv)
4753 op_getmad(label,o,'L');
4759 /* Check whether it's going to be a goto &function */
4760 if (label->op_type == OP_ENTERSUB
4761 && !(label->op_flags & OPf_STACKED))
4762 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4763 o = newUNOP(type, OPf_STACKED, label);
4765 PL_hints |= HINT_BLOCK_SCOPE;
4769 /* if the condition is a literal array or hash
4770 (or @{ ... } etc), make a reference to it.
4773 S_ref_array_or_hash(pTHX_ OP *cond)
4776 && (cond->op_type == OP_RV2AV
4777 || cond->op_type == OP_PADAV
4778 || cond->op_type == OP_RV2HV
4779 || cond->op_type == OP_PADHV))
4781 return newUNOP(OP_REFGEN,
4782 0, mod(cond, OP_REFGEN));
4788 /* These construct the optree fragments representing given()
4791 entergiven and enterwhen are LOGOPs; the op_other pointer
4792 points up to the associated leave op. We need this so we
4793 can put it in the context and make break/continue work.
4794 (Also, of course, pp_enterwhen will jump straight to
4795 op_other if the match fails.)
4800 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
4801 I32 enter_opcode, I32 leave_opcode,
4802 PADOFFSET entertarg)
4808 NewOp(1101, enterop, 1, LOGOP);
4809 enterop->op_type = enter_opcode;
4810 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
4811 enterop->op_flags = (U8) OPf_KIDS;
4812 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
4813 enterop->op_private = 0;
4815 o = newUNOP(leave_opcode, 0, (OP *) enterop);
4818 enterop->op_first = scalar(cond);
4819 cond->op_sibling = block;
4821 o->op_next = LINKLIST(cond);
4822 cond->op_next = (OP *) enterop;
4825 /* This is a default {} block */
4826 enterop->op_first = block;
4827 enterop->op_flags |= OPf_SPECIAL;
4829 o->op_next = (OP *) enterop;
4832 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
4833 entergiven and enterwhen both
4836 enterop->op_next = LINKLIST(block);
4837 block->op_next = enterop->op_other = o;
4842 /* Does this look like a boolean operation? For these purposes
4843 a boolean operation is:
4844 - a subroutine call [*]
4845 - a logical connective
4846 - a comparison operator
4847 - a filetest operator, with the exception of -s -M -A -C
4848 - defined(), exists() or eof()
4849 - /$re/ or $foo =~ /$re/
4851 [*] possibly surprising
4855 S_looks_like_bool(pTHX_ const OP *o)
4858 switch(o->op_type) {
4860 return looks_like_bool(cLOGOPo->op_first);
4864 looks_like_bool(cLOGOPo->op_first)
4865 && looks_like_bool(cLOGOPo->op_first->op_sibling));
4869 case OP_NOT: case OP_XOR:
4870 /* Note that OP_DOR is not here */
4872 case OP_EQ: case OP_NE: case OP_LT:
4873 case OP_GT: case OP_LE: case OP_GE:
4875 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
4876 case OP_I_GT: case OP_I_LE: case OP_I_GE:
4878 case OP_SEQ: case OP_SNE: case OP_SLT:
4879 case OP_SGT: case OP_SLE: case OP_SGE:
4883 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
4884 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
4885 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
4886 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
4887 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
4888 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
4889 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
4890 case OP_FTTEXT: case OP_FTBINARY:
4892 case OP_DEFINED: case OP_EXISTS:
4893 case OP_MATCH: case OP_EOF:
4898 /* Detect comparisons that have been optimized away */
4899 if (cSVOPo->op_sv == &PL_sv_yes
4900 || cSVOPo->op_sv == &PL_sv_no)
4911 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
4915 return newGIVWHENOP(
4916 ref_array_or_hash(cond),
4918 OP_ENTERGIVEN, OP_LEAVEGIVEN,
4922 /* If cond is null, this is a default {} block */
4924 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
4926 const bool cond_llb = (!cond || looks_like_bool(cond));
4932 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
4934 scalar(ref_array_or_hash(cond)));
4937 return newGIVWHENOP(
4939 append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
4940 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
4944 =for apidoc cv_undef
4946 Clear out all the active components of a CV. This can happen either
4947 by an explicit C<undef &foo>, or by the reference count going to zero.
4948 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
4949 children can still follow the full lexical scope chain.
4955 Perl_cv_undef(pTHX_ CV *cv)
4959 if (CvFILE(cv) && !CvISXSUB(cv)) {
4960 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4961 Safefree(CvFILE(cv));
4966 if (!CvISXSUB(cv) && CvROOT(cv)) {
4967 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
4968 Perl_croak(aTHX_ "Can't undef active subroutine");
4971 PAD_SAVE_SETNULLPAD();
4973 op_free(CvROOT(cv));
4978 SvPOK_off((SV*)cv); /* forget prototype */
4983 /* remove CvOUTSIDE unless this is an undef rather than a free */
4984 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
4985 if (!CvWEAKOUTSIDE(cv))
4986 SvREFCNT_dec(CvOUTSIDE(cv));
4987 CvOUTSIDE(cv) = NULL;
4990 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4993 if (CvISXSUB(cv) && CvXSUB(cv)) {
4996 /* delete all flags except WEAKOUTSIDE */
4997 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
5001 Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
5004 /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
5005 relying on SvCUR, and doubling up the buffer to hold CvFILE(). */
5006 if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
5007 || (p && (len != SvCUR(cv) /* Not the same length. */
5008 || memNE(p, SvPVX_const(cv), len))))
5009 && ckWARN_d(WARN_PROTOTYPE)) {
5010 SV* const msg = sv_newmortal();
5014 gv_efullname3(name = sv_newmortal(), gv, NULL);
5015 sv_setpvs(msg, "Prototype mismatch:");
5017 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
5019 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv));
5021 sv_catpvs(msg, ": none");
5022 sv_catpvs(msg, " vs ");
5024 Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
5026 sv_catpvs(msg, "none");
5027 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
5031 static void const_sv_xsub(pTHX_ CV* cv);
5035 =head1 Optree Manipulation Functions
5037 =for apidoc cv_const_sv
5039 If C<cv> is a constant sub eligible for inlining. returns the constant
5040 value returned by the sub. Otherwise, returns NULL.
5042 Constant subs can be created with C<newCONSTSUB> or as described in
5043 L<perlsub/"Constant Functions">.
5048 Perl_cv_const_sv(pTHX_ CV *cv)
5050 PERL_UNUSED_CONTEXT;
5053 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
5055 return CvCONST(cv) ? (SV*)CvXSUBANY(cv).any_ptr : NULL;
5058 /* op_const_sv: examine an optree to determine whether it's in-lineable.
5059 * Can be called in 3 ways:
5062 * look for a single OP_CONST with attached value: return the value
5064 * cv && CvCLONE(cv) && !CvCONST(cv)
5066 * examine the clone prototype, and if contains only a single
5067 * OP_CONST referencing a pad const, or a single PADSV referencing
5068 * an outer lexical, return a non-zero value to indicate the CV is
5069 * a candidate for "constizing" at clone time
5073 * We have just cloned an anon prototype that was marked as a const
5074 * candidiate. Try to grab the current value, and in the case of
5075 * PADSV, ignore it if it has multiple references. Return the value.
5079 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
5087 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
5088 o = cLISTOPo->op_first->op_sibling;
5090 for (; o; o = o->op_next) {
5091 const OPCODE type = o->op_type;
5093 if (sv && o->op_next == o)
5095 if (o->op_next != o) {
5096 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
5098 if (type == OP_DBSTATE)
5101 if (type == OP_LEAVESUB || type == OP_RETURN)
5105 if (type == OP_CONST && cSVOPo->op_sv)
5107 else if (cv && type == OP_CONST) {
5108 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5112 else if (cv && type == OP_PADSV) {
5113 if (CvCONST(cv)) { /* newly cloned anon */
5114 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5115 /* the candidate should have 1 ref from this pad and 1 ref
5116 * from the parent */
5117 if (!sv || SvREFCNT(sv) != 2)
5124 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
5125 sv = &PL_sv_undef; /* an arbitrary non-null value */
5140 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5143 /* This would be the return value, but the return cannot be reached. */
5144 OP* pegop = newOP(OP_NULL, 0);
5147 PERL_UNUSED_ARG(floor);
5157 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
5159 NORETURN_FUNCTION_END;
5164 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
5166 return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
5170 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5177 register CV *cv = NULL;
5179 /* If the subroutine has no body, no attributes, and no builtin attributes
5180 then it's just a sub declaration, and we may be able to get away with
5181 storing with a placeholder scalar in the symbol table, rather than a
5182 full GV and CV. If anything is present then it will take a full CV to
5184 const I32 gv_fetch_flags
5185 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5187 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
5188 const char * const name = o ? SvPVx_nolen_const(cSVOPo->op_sv) : NULL;
5191 assert(proto->op_type == OP_CONST);
5192 ps = SvPVx_const(((SVOP*)proto)->op_sv, ps_len);
5197 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
5198 SV * const sv = sv_newmortal();
5199 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
5200 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
5201 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
5202 aname = SvPVX_const(sv);
5207 gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
5208 : gv_fetchpv(aname ? aname
5209 : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5210 gv_fetch_flags, SVt_PVCV);
5212 if (!PL_madskills) {
5221 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
5222 maximum a prototype before. */
5223 if (SvTYPE(gv) > SVt_NULL) {
5224 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
5225 && ckWARN_d(WARN_PROTOTYPE))
5227 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
5229 cv_ckproto_len((CV*)gv, NULL, ps, ps_len);
5232 sv_setpvn((SV*)gv, ps, ps_len);
5234 sv_setiv((SV*)gv, -1);
5235 SvREFCNT_dec(PL_compcv);
5236 cv = PL_compcv = NULL;
5237 PL_sub_generation++;
5241 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
5243 #ifdef GV_UNIQUE_CHECK
5244 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
5245 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
5249 if (!block || !ps || *ps || attrs
5250 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5252 || block->op_type == OP_NULL
5257 const_sv = op_const_sv(block, NULL);
5260 const bool exists = CvROOT(cv) || CvXSUB(cv);
5262 #ifdef GV_UNIQUE_CHECK
5263 if (exists && GvUNIQUE(gv)) {
5264 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
5268 /* if the subroutine doesn't exist and wasn't pre-declared
5269 * with a prototype, assume it will be AUTOLOADed,
5270 * skipping the prototype check
5272 if (exists || SvPOK(cv))
5273 cv_ckproto_len(cv, gv, ps, ps_len);
5274 /* already defined (or promised)? */
5275 if (exists || GvASSUMECV(gv)) {
5278 || block->op_type == OP_NULL
5281 if (CvFLAGS(PL_compcv)) {
5282 /* might have had built-in attrs applied */
5283 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5285 /* just a "sub foo;" when &foo is already defined */
5286 SAVEFREESV(PL_compcv);
5291 && block->op_type != OP_NULL
5294 if (ckWARN(WARN_REDEFINE)
5296 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
5298 const line_t oldline = CopLINE(PL_curcop);
5299 if (PL_copline != NOLINE)
5300 CopLINE_set(PL_curcop, PL_copline);
5301 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5302 CvCONST(cv) ? "Constant subroutine %s redefined"
5303 : "Subroutine %s redefined", name);
5304 CopLINE_set(PL_curcop, oldline);
5307 if (!PL_minus_c) /* keep old one around for madskills */
5310 /* (PL_madskills unset in used file.) */
5318 SvREFCNT_inc_simple_void_NN(const_sv);
5320 assert(!CvROOT(cv) && !CvCONST(cv));
5321 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
5322 CvXSUBANY(cv).any_ptr = const_sv;
5323 CvXSUB(cv) = const_sv_xsub;
5329 cv = newCONSTSUB(NULL, name, const_sv);
5331 PL_sub_generation++;
5335 SvREFCNT_dec(PL_compcv);
5343 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
5344 * before we clobber PL_compcv.
5348 || block->op_type == OP_NULL
5352 /* Might have had built-in attributes applied -- propagate them. */
5353 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5354 if (CvGV(cv) && GvSTASH(CvGV(cv)))
5355 stash = GvSTASH(CvGV(cv));
5356 else if (CvSTASH(cv))
5357 stash = CvSTASH(cv);
5359 stash = PL_curstash;
5362 /* possibly about to re-define existing subr -- ignore old cv */
5363 rcv = (SV*)PL_compcv;
5364 if (name && GvSTASH(gv))
5365 stash = GvSTASH(gv);
5367 stash = PL_curstash;
5369 apply_attrs(stash, rcv, attrs, FALSE);
5371 if (cv) { /* must reuse cv if autoloaded */
5378 || block->op_type == OP_NULL) && !PL_madskills
5381 /* got here with just attrs -- work done, so bug out */
5382 SAVEFREESV(PL_compcv);
5385 /* transfer PL_compcv to cv */
5387 CvFLAGS(cv) = CvFLAGS(PL_compcv);
5388 if (!CvWEAKOUTSIDE(cv))
5389 SvREFCNT_dec(CvOUTSIDE(cv));
5390 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
5391 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
5392 CvOUTSIDE(PL_compcv) = 0;
5393 CvPADLIST(cv) = CvPADLIST(PL_compcv);
5394 CvPADLIST(PL_compcv) = 0;
5395 /* inner references to PL_compcv must be fixed up ... */
5396 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
5397 /* ... before we throw it away */
5398 SvREFCNT_dec(PL_compcv);
5400 if (PERLDB_INTER)/* Advice debugger on the new sub. */
5401 ++PL_sub_generation;
5408 if (strEQ(name, "import")) {
5409 PL_formfeed = (SV*)cv;
5410 Perl_warner(aTHX_ packWARN(WARN_VOID), "%lx\n", (long)cv);
5414 PL_sub_generation++;
5418 CvFILE_set_from_cop(cv, PL_curcop);
5419 CvSTASH(cv) = PL_curstash;
5422 sv_setpvn((SV*)cv, ps, ps_len);
5424 if (PL_error_count) {
5428 const char *s = strrchr(name, ':');
5430 if (strEQ(s, "BEGIN")) {
5431 const char not_safe[] =
5432 "BEGIN not safe after errors--compilation aborted";
5433 if (PL_in_eval & EVAL_KEEPERR)
5434 Perl_croak(aTHX_ not_safe);
5436 /* force display of errors found but not reported */
5437 sv_catpv(ERRSV, not_safe);
5438 Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
5448 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5449 mod(scalarseq(block), OP_LEAVESUBLV));
5450 block->op_attached = 1;
5453 /* This makes sub {}; work as expected. */
5454 if (block->op_type == OP_STUB) {
5455 OP* const newblock = newSTATEOP(0, NULL, 0);
5457 op_getmad(block,newblock,'B');
5464 block->op_attached = 1;
5465 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5467 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5468 OpREFCNT_set(CvROOT(cv), 1);
5469 CvSTART(cv) = LINKLIST(CvROOT(cv));
5470 CvROOT(cv)->op_next = 0;
5471 CALL_PEEP(CvSTART(cv));
5473 /* now that optimizer has done its work, adjust pad values */
5475 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
5478 assert(!CvCONST(cv));
5479 if (ps && !*ps && op_const_sv(block, cv))
5483 if (name || aname) {
5484 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5485 SV * const sv = newSV(0);
5486 SV * const tmpstr = sv_newmortal();
5487 GV * const db_postponed = gv_fetchpvs("DB::postponed",
5488 GV_ADDMULTI, SVt_PVHV);
5491 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5493 (long)PL_subline, (long)CopLINE(PL_curcop));
5494 gv_efullname3(tmpstr, gv, NULL);
5495 hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0);
5496 hv = GvHVn(db_postponed);
5497 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
5498 CV * const pcv = GvCV(db_postponed);
5504 call_sv((SV*)pcv, G_DISCARD);
5509 if (name && !PL_error_count)
5510 process_special_blocks(name, gv, cv);
5514 PL_copline = NOLINE;
5520 S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
5523 const char *const colon = strrchr(fullname,':');
5524 const char *const name = colon ? colon + 1 : fullname;
5527 if (strEQ(name, "BEGIN")) {
5528 const I32 oldscope = PL_scopestack_ix;
5530 SAVECOPFILE(&PL_compiling);
5531 SAVECOPLINE(&PL_compiling);
5533 DEBUG_x( dump_sub(gv) );
5534 Perl_av_create_and_push(aTHX_ &PL_beginav, (SV*)cv);
5535 GvCV(gv) = 0; /* cv has been hijacked */
5536 call_list(oldscope, PL_beginav);
5538 PL_curcop = &PL_compiling;
5539 CopHINTS_set(&PL_compiling, PL_hints);
5546 if strEQ(name, "END") {
5547 DEBUG_x( dump_sub(gv) );
5548 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, (SV*)cv);
5551 } else if (*name == 'U') {
5552 if (strEQ(name, "UNITCHECK")) {
5553 /* It's never too late to run a unitcheck block */
5554 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, (SV*)cv);
5558 } else if (*name == 'C') {
5559 if (strEQ(name, "CHECK")) {
5560 if (PL_main_start && ckWARN(WARN_VOID))
5561 Perl_warner(aTHX_ packWARN(WARN_VOID),
5562 "Too late to run CHECK block");
5563 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, (SV*)cv);
5567 } else if (*name == 'I') {
5568 if (strEQ(name, "INIT")) {
5569 if (PL_main_start && ckWARN(WARN_VOID))
5570 Perl_warner(aTHX_ packWARN(WARN_VOID),
5571 "Too late to run INIT block");
5572 Perl_av_create_and_push(aTHX_ &PL_initav, (SV*)cv);
5578 DEBUG_x( dump_sub(gv) );
5579 GvCV(gv) = 0; /* cv has been hijacked */
5584 =for apidoc newCONSTSUB
5586 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5587 eligible for inlining at compile-time.
5593 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
5598 const char *const temp_p = CopFILE(PL_curcop);
5599 const STRLEN len = temp_p ? strlen(temp_p) : 0;
5601 SV *const temp_sv = CopFILESV(PL_curcop);
5603 const char *const temp_p = temp_sv ? SvPV_const(temp_sv, len) : NULL;
5605 char *const file = savepvn(temp_p, temp_p ? len : 0);
5609 SAVECOPLINE(PL_curcop);
5610 CopLINE_set(PL_curcop, PL_copline);
5613 PL_hints &= ~HINT_BLOCK_SCOPE;
5616 SAVESPTR(PL_curstash);
5617 SAVECOPSTASH(PL_curcop);
5618 PL_curstash = stash;
5619 CopSTASH_set(PL_curcop,stash);
5622 /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
5623 and so doesn't get free()d. (It's expected to be from the C pre-
5624 processor __FILE__ directive). But we need a dynamically allocated one,
5625 and we need it to get freed. */
5626 cv = newXS_flags(name, const_sv_xsub, file, "", XS_DYNAMIC_FILENAME);
5627 CvXSUBANY(cv).any_ptr = sv;
5633 CopSTASH_free(PL_curcop);
5641 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
5642 const char *const filename, const char *const proto,
5645 CV *cv = newXS(name, subaddr, filename);
5647 if (flags & XS_DYNAMIC_FILENAME) {
5648 /* We need to "make arrangements" (ie cheat) to ensure that the
5649 filename lasts as long as the PVCV we just created, but also doesn't
5651 STRLEN filename_len = strlen(filename);
5652 STRLEN proto_and_file_len = filename_len;
5653 char *proto_and_file;
5657 proto_len = strlen(proto);
5658 proto_and_file_len += proto_len;
5660 Newx(proto_and_file, proto_and_file_len + 1, char);
5661 Copy(proto, proto_and_file, proto_len, char);
5662 Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
5665 proto_and_file = savepvn(filename, filename_len);
5668 /* This gets free()d. :-) */
5669 sv_usepvn_flags((SV*)cv, proto_and_file, proto_and_file_len,
5670 SV_HAS_TRAILING_NUL);
5672 /* This gives us the correct prototype, rather than one with the
5673 file name appended. */
5674 SvCUR_set(cv, proto_len);
5678 CvFILE(cv) = proto_and_file + proto_len;
5680 sv_setpv((SV *)cv, proto);
5686 =for apidoc U||newXS
5688 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
5689 static storage, as it is used directly as CvFILE(), without a copy being made.
5695 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
5698 GV * const gv = gv_fetchpv(name ? name :
5699 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5700 GV_ADDMULTI, SVt_PVCV);
5704 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
5706 if ((cv = (name ? GvCV(gv) : NULL))) {
5708 /* just a cached method */
5712 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5713 /* already defined (or promised) */
5714 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
5715 if (ckWARN(WARN_REDEFINE)) {
5716 GV * const gvcv = CvGV(cv);
5718 HV * const stash = GvSTASH(gvcv);
5720 const char *redefined_name = HvNAME_get(stash);
5721 if ( strEQ(redefined_name,"autouse") ) {
5722 const line_t oldline = CopLINE(PL_curcop);
5723 if (PL_copline != NOLINE)
5724 CopLINE_set(PL_curcop, PL_copline);
5725 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5726 CvCONST(cv) ? "Constant subroutine %s redefined"
5727 : "Subroutine %s redefined"
5729 CopLINE_set(PL_curcop, oldline);
5739 if (cv) /* must reuse cv if autoloaded */
5742 cv = (CV*)newSV_type(SVt_PVCV);
5746 PL_sub_generation++;
5750 (void)gv_fetchfile(filename);
5751 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
5752 an external constant string */
5754 CvXSUB(cv) = subaddr;
5757 process_special_blocks(name, gv, cv);
5769 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5774 OP* pegop = newOP(OP_NULL, 0);
5778 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
5779 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
5781 #ifdef GV_UNIQUE_CHECK
5783 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5787 if ((cv = GvFORM(gv))) {
5788 if (ckWARN(WARN_REDEFINE)) {
5789 const line_t oldline = CopLINE(PL_curcop);
5790 if (PL_copline != NOLINE)
5791 CopLINE_set(PL_curcop, PL_copline);
5792 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5793 o ? "Format %"SVf" redefined"
5794 : "Format STDOUT redefined", SVfARG(cSVOPo->op_sv));
5795 CopLINE_set(PL_curcop, oldline);
5802 CvFILE_set_from_cop(cv, PL_curcop);
5805 pad_tidy(padtidy_FORMAT);
5806 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5807 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5808 OpREFCNT_set(CvROOT(cv), 1);
5809 CvSTART(cv) = LINKLIST(CvROOT(cv));
5810 CvROOT(cv)->op_next = 0;
5811 CALL_PEEP(CvSTART(cv));
5813 op_getmad(o,pegop,'n');
5814 op_getmad_weak(block, pegop, 'b');
5818 PL_copline = NOLINE;
5826 Perl_newANONLIST(pTHX_ OP *o)
5828 return convert(OP_ANONLIST, OPf_SPECIAL, o);
5832 Perl_newANONHASH(pTHX_ OP *o)
5834 return convert(OP_ANONHASH, OPf_SPECIAL, o);
5838 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5840 return newANONATTRSUB(floor, proto, NULL, block);
5844 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5846 return newUNOP(OP_REFGEN, 0,
5847 newSVOP(OP_ANONCODE, 0,
5848 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5852 Perl_oopsAV(pTHX_ OP *o)
5855 switch (o->op_type) {
5857 o->op_type = OP_PADAV;
5858 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5859 return ref(o, OP_RV2AV);
5862 o->op_type = OP_RV2AV;
5863 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5868 if (ckWARN_d(WARN_INTERNAL))
5869 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
5876 Perl_oopsHV(pTHX_ OP *o)
5879 switch (o->op_type) {
5882 o->op_type = OP_PADHV;
5883 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5884 return ref(o, OP_RV2HV);
5888 o->op_type = OP_RV2HV;
5889 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5894 if (ckWARN_d(WARN_INTERNAL))
5895 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
5902 Perl_newAVREF(pTHX_ OP *o)
5905 if (o->op_type == OP_PADANY) {
5906 o->op_type = OP_PADAV;
5907 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5910 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5911 && ckWARN(WARN_DEPRECATED)) {
5912 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5913 "Using an array as a reference is deprecated");
5915 return newUNOP(OP_RV2AV, 0, scalar(o));
5919 Perl_newGVREF(pTHX_ I32 type, OP *o)
5921 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5922 return newUNOP(OP_NULL, 0, o);
5923 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5927 Perl_newHVREF(pTHX_ OP *o)
5930 if (o->op_type == OP_PADANY) {
5931 o->op_type = OP_PADHV;
5932 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5935 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5936 && ckWARN(WARN_DEPRECATED)) {
5937 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5938 "Using a hash as a reference is deprecated");
5940 return newUNOP(OP_RV2HV, 0, scalar(o));
5944 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5946 return newUNOP(OP_RV2CV, flags, scalar(o));
5950 Perl_newSVREF(pTHX_ OP *o)
5953 if (o->op_type == OP_PADANY) {
5954 o->op_type = OP_PADSV;
5955 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5958 return newUNOP(OP_RV2SV, 0, scalar(o));
5961 /* Check routines. See the comments at the top of this file for details
5962 * on when these are called */
5965 Perl_ck_anoncode(pTHX_ OP *o)
5967 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
5969 cSVOPo->op_sv = NULL;
5974 Perl_ck_bitop(pTHX_ OP *o)
5977 #define OP_IS_NUMCOMPARE(op) \
5978 ((op) == OP_LT || (op) == OP_I_LT || \
5979 (op) == OP_GT || (op) == OP_I_GT || \
5980 (op) == OP_LE || (op) == OP_I_LE || \
5981 (op) == OP_GE || (op) == OP_I_GE || \
5982 (op) == OP_EQ || (op) == OP_I_EQ || \
5983 (op) == OP_NE || (op) == OP_I_NE || \
5984 (op) == OP_NCMP || (op) == OP_I_NCMP)
5985 o->op_private = (U8)(PL_hints & HINT_INTEGER);
5986 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
5987 && (o->op_type == OP_BIT_OR
5988 || o->op_type == OP_BIT_AND
5989 || o->op_type == OP_BIT_XOR))
5991 const OP * const left = cBINOPo->op_first;
5992 const OP * const right = left->op_sibling;
5993 if ((OP_IS_NUMCOMPARE(left->op_type) &&
5994 (left->op_flags & OPf_PARENS) == 0) ||
5995 (OP_IS_NUMCOMPARE(right->op_type) &&
5996 (right->op_flags & OPf_PARENS) == 0))
5997 if (ckWARN(WARN_PRECEDENCE))
5998 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
5999 "Possible precedence problem on bitwise %c operator",
6000 o->op_type == OP_BIT_OR ? '|'
6001 : o->op_type == OP_BIT_AND ? '&' : '^'
6008 Perl_ck_concat(pTHX_ OP *o)
6010 const OP * const kid = cUNOPo->op_first;
6011 PERL_UNUSED_CONTEXT;
6012 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
6013 !(kUNOP->op_first->op_flags & OPf_MOD))
6014 o->op_flags |= OPf_STACKED;
6019 Perl_ck_spair(pTHX_ OP *o)
6022 if (o->op_flags & OPf_KIDS) {
6025 const OPCODE type = o->op_type;
6026 o = modkids(ck_fun(o), type);
6027 kid = cUNOPo->op_first;
6028 newop = kUNOP->op_first->op_sibling;
6030 const OPCODE type = newop->op_type;
6031 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
6032 type == OP_PADAV || type == OP_PADHV ||
6033 type == OP_RV2AV || type == OP_RV2HV)
6037 op_getmad(kUNOP->op_first,newop,'K');
6039 op_free(kUNOP->op_first);
6041 kUNOP->op_first = newop;
6043 o->op_ppaddr = PL_ppaddr[++o->op_type];
6048 Perl_ck_delete(pTHX_ OP *o)
6052 if (o->op_flags & OPf_KIDS) {
6053 OP * const kid = cUNOPo->op_first;
6054 switch (kid->op_type) {
6056 o->op_flags |= OPf_SPECIAL;
6059 o->op_private |= OPpSLICE;
6062 o->op_flags |= OPf_SPECIAL;
6067 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
6076 Perl_ck_die(pTHX_ OP *o)
6079 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6085 Perl_ck_eof(pTHX_ OP *o)
6089 if (o->op_flags & OPf_KIDS) {
6090 if (cLISTOPo->op_first->op_type == OP_STUB) {
6092 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
6094 op_getmad(o,newop,'O');
6106 Perl_ck_eval(pTHX_ OP *o)
6109 PL_hints |= HINT_BLOCK_SCOPE;
6110 if (o->op_flags & OPf_KIDS) {
6111 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6114 o->op_flags &= ~OPf_KIDS;
6117 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
6123 cUNOPo->op_first = 0;
6128 NewOp(1101, enter, 1, LOGOP);
6129 enter->op_type = OP_ENTERTRY;
6130 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
6131 enter->op_private = 0;
6133 /* establish postfix order */
6134 enter->op_next = (OP*)enter;
6136 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
6137 o->op_type = OP_LEAVETRY;
6138 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
6139 enter->op_other = o;
6140 op_getmad(oldo,o,'O');
6154 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
6155 op_getmad(oldo,o,'O');
6157 o->op_targ = (PADOFFSET)PL_hints;
6158 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
6159 /* Store a copy of %^H that pp_entereval can pick up.
6160 OPf_SPECIAL flags the opcode as being for this purpose,
6161 so that it in turn will return a copy at every
6163 OP *hhop = newSVOP(OP_CONST, OPf_SPECIAL,
6164 (SV*)Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv)));
6165 cUNOPo->op_first->op_sibling = hhop;
6166 o->op_private |= OPpEVAL_HAS_HH;
6172 Perl_ck_exit(pTHX_ OP *o)
6175 HV * const table = GvHV(PL_hintgv);
6177 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
6178 if (svp && *svp && SvTRUE(*svp))
6179 o->op_private |= OPpEXIT_VMSISH;
6181 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6187 Perl_ck_exec(pTHX_ OP *o)
6189 if (o->op_flags & OPf_STACKED) {
6192 kid = cUNOPo->op_first->op_sibling;
6193 if (kid->op_type == OP_RV2GV)
6202 Perl_ck_exists(pTHX_ OP *o)
6206 if (o->op_flags & OPf_KIDS) {
6207 OP * const kid = cUNOPo->op_first;
6208 if (kid->op_type == OP_ENTERSUB) {
6209 (void) ref(kid, o->op_type);
6210 if (kid->op_type != OP_RV2CV && !PL_error_count)
6211 Perl_croak(aTHX_ "%s argument is not a subroutine name",
6213 o->op_private |= OPpEXISTS_SUB;
6215 else if (kid->op_type == OP_AELEM)
6216 o->op_flags |= OPf_SPECIAL;
6217 else if (kid->op_type != OP_HELEM)
6218 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
6226 Perl_ck_rvconst(pTHX_ register OP *o)
6229 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6231 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6232 if (o->op_type == OP_RV2CV)
6233 o->op_private &= ~1;
6235 if (kid->op_type == OP_CONST) {
6238 SV * const kidsv = kid->op_sv;
6240 /* Is it a constant from cv_const_sv()? */
6241 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
6242 SV * const rsv = SvRV(kidsv);
6243 const svtype type = SvTYPE(rsv);
6244 const char *badtype = NULL;
6246 switch (o->op_type) {
6248 if (type > SVt_PVMG)
6249 badtype = "a SCALAR";
6252 if (type != SVt_PVAV)
6253 badtype = "an ARRAY";
6256 if (type != SVt_PVHV)
6260 if (type != SVt_PVCV)
6265 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
6268 else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
6269 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
6270 /* If this is an access to a stash, disable "strict refs", because
6271 * stashes aren't auto-vivified at compile-time (unless we store
6272 * symbols in them), and we don't want to produce a run-time
6273 * stricture error when auto-vivifying the stash. */
6274 const char *s = SvPV_nolen(kidsv);
6275 const STRLEN l = SvCUR(kidsv);
6276 if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
6277 o->op_private &= ~HINT_STRICT_REFS;
6279 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
6280 const char *badthing;
6281 switch (o->op_type) {
6283 badthing = "a SCALAR";
6286 badthing = "an ARRAY";
6289 badthing = "a HASH";
6297 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
6298 SVfARG(kidsv), badthing);
6301 * This is a little tricky. We only want to add the symbol if we
6302 * didn't add it in the lexer. Otherwise we get duplicate strict
6303 * warnings. But if we didn't add it in the lexer, we must at
6304 * least pretend like we wanted to add it even if it existed before,
6305 * or we get possible typo warnings. OPpCONST_ENTERED says
6306 * whether the lexer already added THIS instance of this symbol.
6308 iscv = (o->op_type == OP_RV2CV) * 2;
6310 gv = gv_fetchsv(kidsv,
6311 iscv | !(kid->op_private & OPpCONST_ENTERED),
6314 : o->op_type == OP_RV2SV
6316 : o->op_type == OP_RV2AV
6318 : o->op_type == OP_RV2HV
6321 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
6323 kid->op_type = OP_GV;
6324 SvREFCNT_dec(kid->op_sv);
6326 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
6327 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
6328 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
6330 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc_simple_NN(gv));
6332 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
6334 kid->op_private = 0;
6335 kid->op_ppaddr = PL_ppaddr[OP_GV];
6342 Perl_ck_ftst(pTHX_ OP *o)
6345 const I32 type = o->op_type;
6347 if (o->op_flags & OPf_REF) {
6350 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
6351 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6352 const OPCODE kidtype = kid->op_type;
6354 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6355 OP * const newop = newGVOP(type, OPf_REF,
6356 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
6358 op_getmad(o,newop,'O');
6364 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o))
6365 o->op_private |= OPpFT_ACCESS;
6366 if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst)
6367 && kidtype != OP_STAT && kidtype != OP_LSTAT)
6368 o->op_private |= OPpFT_STACKED;
6376 if (type == OP_FTTTY)
6377 o = newGVOP(type, OPf_REF, PL_stdingv);
6379 o = newUNOP(type, 0, newDEFSVOP());
6380 op_getmad(oldo,o,'O');
6386 Perl_ck_fun(pTHX_ OP *o)
6389 const int type = o->op_type;
6390 register I32 oa = PL_opargs[type] >> OASHIFT;
6392 if (o->op_flags & OPf_STACKED) {
6393 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
6396 return no_fh_allowed(o);
6399 if (o->op_flags & OPf_KIDS) {
6400 OP **tokid = &cLISTOPo->op_first;
6401 register OP *kid = cLISTOPo->op_first;
6405 if (kid->op_type == OP_PUSHMARK ||
6406 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
6408 tokid = &kid->op_sibling;
6409 kid = kid->op_sibling;
6411 if (!kid && PL_opargs[type] & OA_DEFGV)
6412 *tokid = kid = newDEFSVOP();
6416 sibl = kid->op_sibling;
6418 if (!sibl && kid->op_type == OP_STUB) {
6425 /* list seen where single (scalar) arg expected? */
6426 if (numargs == 1 && !(oa >> 4)
6427 && kid->op_type == OP_LIST && type != OP_SCALAR)
6429 return too_many_arguments(o,PL_op_desc[type]);
6442 if ((type == OP_PUSH || type == OP_UNSHIFT)
6443 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
6444 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6445 "Useless use of %s with no values",
6448 if (kid->op_type == OP_CONST &&
6449 (kid->op_private & OPpCONST_BARE))
6451 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
6452 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
6453 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6454 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6455 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
6456 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6458 op_getmad(kid,newop,'K');
6463 kid->op_sibling = sibl;
6466 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
6467 bad_type(numargs, "array", PL_op_desc[type], kid);
6471 if (kid->op_type == OP_CONST &&
6472 (kid->op_private & OPpCONST_BARE))
6474 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
6475 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
6476 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6477 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6478 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
6479 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6481 op_getmad(kid,newop,'K');
6486 kid->op_sibling = sibl;
6489 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
6490 bad_type(numargs, "hash", PL_op_desc[type], kid);
6495 OP * const newop = newUNOP(OP_NULL, 0, kid);
6496 kid->op_sibling = 0;
6498 newop->op_next = newop;
6500 kid->op_sibling = sibl;
6505 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
6506 if (kid->op_type == OP_CONST &&
6507 (kid->op_private & OPpCONST_BARE))
6509 OP * const newop = newGVOP(OP_GV, 0,
6510 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
6511 if (!(o->op_private & 1) && /* if not unop */
6512 kid == cLISTOPo->op_last)
6513 cLISTOPo->op_last = newop;
6515 op_getmad(kid,newop,'K');
6521 else if (kid->op_type == OP_READLINE) {
6522 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
6523 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
6526 I32 flags = OPf_SPECIAL;
6530 /* is this op a FH constructor? */
6531 if (is_handle_constructor(o,numargs)) {
6532 const char *name = NULL;
6536 /* Set a flag to tell rv2gv to vivify
6537 * need to "prove" flag does not mean something
6538 * else already - NI-S 1999/05/07
6541 if (kid->op_type == OP_PADSV) {
6543 = PAD_COMPNAME_SV(kid->op_targ);
6544 name = SvPV_const(namesv, len);
6546 else if (kid->op_type == OP_RV2SV
6547 && kUNOP->op_first->op_type == OP_GV)
6549 GV * const gv = cGVOPx_gv(kUNOP->op_first);
6551 len = GvNAMELEN(gv);
6553 else if (kid->op_type == OP_AELEM
6554 || kid->op_type == OP_HELEM)
6557 OP *op = ((BINOP*)kid)->op_first;
6561 const char * const a =
6562 kid->op_type == OP_AELEM ?
6564 if (((op->op_type == OP_RV2AV) ||
6565 (op->op_type == OP_RV2HV)) &&
6566 (firstop = ((UNOP*)op)->op_first) &&
6567 (firstop->op_type == OP_GV)) {
6568 /* packagevar $a[] or $h{} */
6569 GV * const gv = cGVOPx_gv(firstop);
6577 else if (op->op_type == OP_PADAV
6578 || op->op_type == OP_PADHV) {
6579 /* lexicalvar $a[] or $h{} */
6580 const char * const padname =
6581 PAD_COMPNAME_PV(op->op_targ);
6590 name = SvPV_const(tmpstr, len);
6595 name = "__ANONIO__";
6602 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
6603 namesv = PAD_SVl(targ);
6604 SvUPGRADE(namesv, SVt_PV);
6606 sv_setpvn(namesv, "$", 1);
6607 sv_catpvn(namesv, name, len);
6610 kid->op_sibling = 0;
6611 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
6612 kid->op_targ = targ;
6613 kid->op_private |= priv;
6615 kid->op_sibling = sibl;
6621 mod(scalar(kid), type);
6625 tokid = &kid->op_sibling;
6626 kid = kid->op_sibling;
6629 if (kid && kid->op_type != OP_STUB)
6630 return too_many_arguments(o,OP_DESC(o));
6631 o->op_private |= numargs;
6633 /* FIXME - should the numargs move as for the PERL_MAD case? */
6634 o->op_private |= numargs;
6636 return too_many_arguments(o,OP_DESC(o));
6640 else if (PL_opargs[type] & OA_DEFGV) {
6642 OP *newop = newUNOP(type, 0, newDEFSVOP());
6643 op_getmad(o,newop,'O');
6646 /* Ordering of these two is important to keep f_map.t passing. */
6648 return newUNOP(type, 0, newDEFSVOP());
6653 while (oa & OA_OPTIONAL)
6655 if (oa && oa != OA_LIST)
6656 return too_few_arguments(o,OP_DESC(o));
6662 Perl_ck_glob(pTHX_ OP *o)
6668 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
6669 append_elem(OP_GLOB, o, newDEFSVOP());
6671 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
6672 && GvCVu(gv) && GvIMPORTED_CV(gv)))
6674 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6677 #if !defined(PERL_EXTERNAL_GLOB)
6678 /* XXX this can be tightened up and made more failsafe. */
6679 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
6682 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
6683 newSVpvs("File::Glob"), NULL, NULL, NULL);
6684 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6685 glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
6686 GvCV(gv) = GvCV(glob_gv);
6687 SvREFCNT_inc_void((SV*)GvCV(gv));
6688 GvIMPORTED_CV_on(gv);
6691 #endif /* PERL_EXTERNAL_GLOB */
6693 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6694 append_elem(OP_GLOB, o,
6695 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
6696 o->op_type = OP_LIST;
6697 o->op_ppaddr = PL_ppaddr[OP_LIST];
6698 cLISTOPo->op_first->op_type = OP_PUSHMARK;
6699 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
6700 cLISTOPo->op_first->op_targ = 0;
6701 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
6702 append_elem(OP_LIST, o,
6703 scalar(newUNOP(OP_RV2CV, 0,
6704 newGVOP(OP_GV, 0, gv)))));
6705 o = newUNOP(OP_NULL, 0, ck_subr(o));
6706 o->op_targ = OP_GLOB; /* hint at what it used to be */
6709 gv = newGVgen("main");
6711 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
6717 Perl_ck_grep(pTHX_ OP *o)
6722 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
6725 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
6726 /* don't allocate gwop here, as we may leak it if PL_error_count > 0 */
6728 if (o->op_flags & OPf_STACKED) {
6731 kid = cLISTOPo->op_first->op_sibling;
6732 if (!cUNOPx(kid)->op_next)
6733 Perl_croak(aTHX_ "panic: ck_grep");
6734 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
6737 NewOp(1101, gwop, 1, LOGOP);
6738 kid->op_next = (OP*)gwop;
6739 o->op_flags &= ~OPf_STACKED;
6741 kid = cLISTOPo->op_first->op_sibling;
6742 if (type == OP_MAPWHILE)
6749 kid = cLISTOPo->op_first->op_sibling;
6750 if (kid->op_type != OP_NULL)
6751 Perl_croak(aTHX_ "panic: ck_grep");
6752 kid = kUNOP->op_first;
6755 NewOp(1101, gwop, 1, LOGOP);
6756 gwop->op_type = type;
6757 gwop->op_ppaddr = PL_ppaddr[type];
6758 gwop->op_first = listkids(o);
6759 gwop->op_flags |= OPf_KIDS;
6760 gwop->op_other = LINKLIST(kid);
6761 kid->op_next = (OP*)gwop;
6762 offset = pad_findmy("$_");
6763 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
6764 o->op_private = gwop->op_private = 0;
6765 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
6768 o->op_private = gwop->op_private = OPpGREP_LEX;
6769 gwop->op_targ = o->op_targ = offset;
6772 kid = cLISTOPo->op_first->op_sibling;
6773 if (!kid || !kid->op_sibling)
6774 return too_few_arguments(o,OP_DESC(o));
6775 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
6776 mod(kid, OP_GREPSTART);
6782 Perl_ck_index(pTHX_ OP *o)
6784 if (o->op_flags & OPf_KIDS) {
6785 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6787 kid = kid->op_sibling; /* get past "big" */
6788 if (kid && kid->op_type == OP_CONST)
6789 fbm_compile(((SVOP*)kid)->op_sv, 0);
6795 Perl_ck_lengthconst(pTHX_ OP *o)
6797 /* XXX length optimization goes here */
6802 Perl_ck_lfun(pTHX_ OP *o)
6804 const OPCODE type = o->op_type;
6805 return modkids(ck_fun(o), type);
6809 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
6811 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
6812 switch (cUNOPo->op_first->op_type) {
6814 /* This is needed for
6815 if (defined %stash::)
6816 to work. Do not break Tk.
6818 break; /* Globals via GV can be undef */
6820 case OP_AASSIGN: /* Is this a good idea? */
6821 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6822 "defined(@array) is deprecated");
6823 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6824 "\t(Maybe you should just omit the defined()?)\n");
6827 /* This is needed for
6828 if (defined %stash::)
6829 to work. Do not break Tk.
6831 break; /* Globals via GV can be undef */
6833 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6834 "defined(%%hash) is deprecated");
6835 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6836 "\t(Maybe you should just omit the defined()?)\n");
6847 Perl_ck_readline(pTHX_ OP *o)
6849 if (!(o->op_flags & OPf_KIDS)) {
6851 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
6853 op_getmad(o,newop,'O');
6863 Perl_ck_rfun(pTHX_ OP *o)
6865 const OPCODE type = o->op_type;
6866 return refkids(ck_fun(o), type);
6870 Perl_ck_listiob(pTHX_ OP *o)
6874 kid = cLISTOPo->op_first;
6877 kid = cLISTOPo->op_first;
6879 if (kid->op_type == OP_PUSHMARK)
6880 kid = kid->op_sibling;
6881 if (kid && o->op_flags & OPf_STACKED)
6882 kid = kid->op_sibling;
6883 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6884 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6885 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6886 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6887 cLISTOPo->op_first->op_sibling = kid;
6888 cLISTOPo->op_last = kid;
6889 kid = kid->op_sibling;
6894 append_elem(o->op_type, o, newDEFSVOP());
6900 Perl_ck_smartmatch(pTHX_ OP *o)
6903 if (0 == (o->op_flags & OPf_SPECIAL)) {
6904 OP *first = cBINOPo->op_first;
6905 OP *second = first->op_sibling;
6907 /* Implicitly take a reference to an array or hash */
6908 first->op_sibling = NULL;
6909 first = cBINOPo->op_first = ref_array_or_hash(first);
6910 second = first->op_sibling = ref_array_or_hash(second);
6912 /* Implicitly take a reference to a regular expression */
6913 if (first->op_type == OP_MATCH) {
6914 first->op_type = OP_QR;
6915 first->op_ppaddr = PL_ppaddr[OP_QR];
6917 if (second->op_type == OP_MATCH) {
6918 second->op_type = OP_QR;
6919 second->op_ppaddr = PL_ppaddr[OP_QR];
6928 Perl_ck_sassign(pTHX_ OP *o)
6930 OP * const kid = cLISTOPo->op_first;
6931 /* has a disposable target? */
6932 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6933 && !(kid->op_flags & OPf_STACKED)
6934 /* Cannot steal the second time! */
6935 && !(kid->op_private & OPpTARGET_MY))
6937 OP * const kkid = kid->op_sibling;
6939 /* Can just relocate the target. */
6940 if (kkid && kkid->op_type == OP_PADSV
6941 && !(kkid->op_private & OPpLVAL_INTRO))
6943 kid->op_targ = kkid->op_targ;
6945 /* Now we do not need PADSV and SASSIGN. */
6946 kid->op_sibling = o->op_sibling; /* NULL */
6947 cLISTOPo->op_first = NULL;
6949 op_getmad(o,kid,'O');
6950 op_getmad(kkid,kid,'M');
6955 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6959 if (kid->op_sibling) {
6960 OP *kkid = kid->op_sibling;
6961 if (kkid->op_type == OP_PADSV
6962 && (kkid->op_private & OPpLVAL_INTRO)
6963 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
6964 o->op_private |= OPpASSIGN_STATE;
6965 /* hijacking PADSTALE for uninitialized state variables */
6966 SvPADSTALE_on(PAD_SVl(kkid->op_targ));
6973 Perl_ck_match(pTHX_ OP *o)
6976 if (o->op_type != OP_QR && PL_compcv) {
6977 const PADOFFSET offset = pad_findmy("$_");
6978 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
6979 o->op_targ = offset;
6980 o->op_private |= OPpTARGET_MY;
6983 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
6984 o->op_private |= OPpRUNTIME;
6989 Perl_ck_method(pTHX_ OP *o)
6991 OP * const kid = cUNOPo->op_first;
6992 if (kid->op_type == OP_CONST) {
6993 SV* sv = kSVOP->op_sv;
6994 const char * const method = SvPVX_const(sv);
6995 if (!(strchr(method, ':') || strchr(method, '\''))) {
6997 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6998 sv = newSVpvn_share(method, SvCUR(sv), 0);
7001 kSVOP->op_sv = NULL;
7003 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
7005 op_getmad(o,cmop,'O');
7016 Perl_ck_null(pTHX_ OP *o)
7018 PERL_UNUSED_CONTEXT;
7023 Perl_ck_open(pTHX_ OP *o)
7026 HV * const table = GvHV(PL_hintgv);
7028 SV **svp = hv_fetchs(table, "open_IN", FALSE);
7030 const I32 mode = mode_from_discipline(*svp);
7031 if (mode & O_BINARY)
7032 o->op_private |= OPpOPEN_IN_RAW;
7033 else if (mode & O_TEXT)
7034 o->op_private |= OPpOPEN_IN_CRLF;
7037 svp = hv_fetchs(table, "open_OUT", FALSE);
7039 const I32 mode = mode_from_discipline(*svp);
7040 if (mode & O_BINARY)
7041 o->op_private |= OPpOPEN_OUT_RAW;
7042 else if (mode & O_TEXT)
7043 o->op_private |= OPpOPEN_OUT_CRLF;
7046 if (o->op_type == OP_BACKTICK) {
7047 if (!(o->op_flags & OPf_KIDS)) {
7048 OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
7050 op_getmad(o,newop,'O');
7059 /* In case of three-arg dup open remove strictness
7060 * from the last arg if it is a bareword. */
7061 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
7062 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
7066 if ((last->op_type == OP_CONST) && /* The bareword. */
7067 (last->op_private & OPpCONST_BARE) &&
7068 (last->op_private & OPpCONST_STRICT) &&
7069 (oa = first->op_sibling) && /* The fh. */
7070 (oa = oa->op_sibling) && /* The mode. */
7071 (oa->op_type == OP_CONST) &&
7072 SvPOK(((SVOP*)oa)->op_sv) &&
7073 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
7074 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
7075 (last == oa->op_sibling)) /* The bareword. */
7076 last->op_private &= ~OPpCONST_STRICT;
7082 Perl_ck_repeat(pTHX_ OP *o)
7084 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
7085 o->op_private |= OPpREPEAT_DOLIST;
7086 cBINOPo->op_first = force_list(cBINOPo->op_first);
7094 Perl_ck_require(pTHX_ OP *o)
7099 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
7100 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7102 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
7103 SV * const sv = kid->op_sv;
7104 U32 was_readonly = SvREADONLY(sv);
7109 sv_force_normal_flags(sv, 0);
7110 assert(!SvREADONLY(sv));
7117 for (s = SvPVX(sv); *s; s++) {
7118 if (*s == ':' && s[1] == ':') {
7119 const STRLEN len = strlen(s+2)+1;
7121 Move(s+2, s+1, len, char);
7122 SvCUR_set(sv, SvCUR(sv) - 1);
7125 sv_catpvs(sv, ".pm");
7126 SvFLAGS(sv) |= was_readonly;
7130 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
7131 /* handle override, if any */
7132 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
7133 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7134 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
7135 gv = gvp ? *gvp : NULL;
7139 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7140 OP * const kid = cUNOPo->op_first;
7143 cUNOPo->op_first = 0;
7147 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
7148 append_elem(OP_LIST, kid,
7149 scalar(newUNOP(OP_RV2CV, 0,
7152 op_getmad(o,newop,'O');
7160 Perl_ck_return(pTHX_ OP *o)
7163 if (CvLVALUE(PL_compcv)) {
7165 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
7166 mod(kid, OP_LEAVESUBLV);
7172 Perl_ck_select(pTHX_ OP *o)
7176 if (o->op_flags & OPf_KIDS) {
7177 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7178 if (kid && kid->op_sibling) {
7179 o->op_type = OP_SSELECT;
7180 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
7182 return fold_constants(o);
7186 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7187 if (kid && kid->op_type == OP_RV2GV)
7188 kid->op_private &= ~HINT_STRICT_REFS;
7193 Perl_ck_shift(pTHX_ OP *o)
7196 const I32 type = o->op_type;
7198 if (!(o->op_flags & OPf_KIDS)) {
7200 /* FIXME - this can be refactored to reduce code in #ifdefs */
7202 OP * const oldo = o;
7206 argop = newUNOP(OP_RV2AV, 0,
7207 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
7209 o = newUNOP(type, 0, scalar(argop));
7210 op_getmad(oldo,o,'O');
7213 return newUNOP(type, 0, scalar(argop));
7216 return scalar(modkids(ck_fun(o), type));
7220 Perl_ck_sort(pTHX_ OP *o)
7225 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
7226 HV * const hinthv = GvHV(PL_hintgv);
7228 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
7230 const I32 sorthints = (I32)SvIV(*svp);
7231 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
7232 o->op_private |= OPpSORT_QSORT;
7233 if ((sorthints & HINT_SORT_STABLE) != 0)
7234 o->op_private |= OPpSORT_STABLE;
7239 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
7241 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7242 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
7244 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
7246 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
7248 if (kid->op_type == OP_SCOPE) {
7252 else if (kid->op_type == OP_LEAVE) {
7253 if (o->op_type == OP_SORT) {
7254 op_null(kid); /* wipe out leave */
7257 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
7258 if (k->op_next == kid)
7260 /* don't descend into loops */
7261 else if (k->op_type == OP_ENTERLOOP
7262 || k->op_type == OP_ENTERITER)
7264 k = cLOOPx(k)->op_lastop;
7269 kid->op_next = 0; /* just disconnect the leave */
7270 k = kLISTOP->op_first;
7275 if (o->op_type == OP_SORT) {
7276 /* provide scalar context for comparison function/block */
7282 o->op_flags |= OPf_SPECIAL;
7284 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
7287 firstkid = firstkid->op_sibling;
7290 /* provide list context for arguments */
7291 if (o->op_type == OP_SORT)
7298 S_simplify_sort(pTHX_ OP *o)
7301 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7306 if (!(o->op_flags & OPf_STACKED))
7308 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7309 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
7310 kid = kUNOP->op_first; /* get past null */
7311 if (kid->op_type != OP_SCOPE)
7313 kid = kLISTOP->op_last; /* get past scope */
7314 switch(kid->op_type) {
7322 k = kid; /* remember this node*/
7323 if (kBINOP->op_first->op_type != OP_RV2SV)
7325 kid = kBINOP->op_first; /* get past cmp */
7326 if (kUNOP->op_first->op_type != OP_GV)
7328 kid = kUNOP->op_first; /* get past rv2sv */
7330 if (GvSTASH(gv) != PL_curstash)
7332 gvname = GvNAME(gv);
7333 if (*gvname == 'a' && gvname[1] == '\0')
7335 else if (*gvname == 'b' && gvname[1] == '\0')
7340 kid = k; /* back to cmp */
7341 if (kBINOP->op_last->op_type != OP_RV2SV)
7343 kid = kBINOP->op_last; /* down to 2nd arg */
7344 if (kUNOP->op_first->op_type != OP_GV)
7346 kid = kUNOP->op_first; /* get past rv2sv */
7348 if (GvSTASH(gv) != PL_curstash)
7350 gvname = GvNAME(gv);
7352 ? !(*gvname == 'a' && gvname[1] == '\0')
7353 : !(*gvname == 'b' && gvname[1] == '\0'))
7355 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
7357 o->op_private |= OPpSORT_DESCEND;
7358 if (k->op_type == OP_NCMP)
7359 o->op_private |= OPpSORT_NUMERIC;
7360 if (k->op_type == OP_I_NCMP)
7361 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
7362 kid = cLISTOPo->op_first->op_sibling;
7363 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
7365 op_getmad(kid,o,'S'); /* then delete it */
7367 op_free(kid); /* then delete it */
7372 Perl_ck_split(pTHX_ OP *o)
7377 if (o->op_flags & OPf_STACKED)
7378 return no_fh_allowed(o);
7380 kid = cLISTOPo->op_first;
7381 if (kid->op_type != OP_NULL)
7382 Perl_croak(aTHX_ "panic: ck_split");
7383 kid = kid->op_sibling;
7384 op_free(cLISTOPo->op_first);
7385 cLISTOPo->op_first = kid;
7387 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
7388 cLISTOPo->op_last = kid; /* There was only one element previously */
7391 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
7392 OP * const sibl = kid->op_sibling;
7393 kid->op_sibling = 0;
7394 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
7395 if (cLISTOPo->op_first == cLISTOPo->op_last)
7396 cLISTOPo->op_last = kid;
7397 cLISTOPo->op_first = kid;
7398 kid->op_sibling = sibl;
7401 kid->op_type = OP_PUSHRE;
7402 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
7404 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
7405 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
7406 "Use of /g modifier is meaningless in split");
7409 if (!kid->op_sibling)
7410 append_elem(OP_SPLIT, o, newDEFSVOP());
7412 kid = kid->op_sibling;
7415 if (!kid->op_sibling)
7416 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
7417 assert(kid->op_sibling);
7419 kid = kid->op_sibling;
7422 if (kid->op_sibling)
7423 return too_many_arguments(o,OP_DESC(o));
7429 Perl_ck_join(pTHX_ OP *o)
7431 const OP * const kid = cLISTOPo->op_first->op_sibling;
7432 if (kid && kid->op_type == OP_MATCH) {
7433 if (ckWARN(WARN_SYNTAX)) {
7434 const REGEXP *re = PM_GETRE(kPMOP);
7435 const char *pmstr = re ? re->precomp : "STRING";
7436 const STRLEN len = re ? re->prelen : 6;
7437 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7438 "/%.*s/ should probably be written as \"%.*s\"",
7439 (int)len, pmstr, (int)len, pmstr);
7446 Perl_ck_subr(pTHX_ OP *o)
7449 OP *prev = ((cUNOPo->op_first->op_sibling)
7450 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
7451 OP *o2 = prev->op_sibling;
7453 const char *proto = NULL;
7454 const char *proto_end = NULL;
7459 I32 contextclass = 0;
7460 const char *e = NULL;
7463 o->op_private |= OPpENTERSUB_HASTARG;
7464 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
7465 if (cvop->op_type == OP_RV2CV) {
7467 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
7468 op_null(cvop); /* disable rv2cv */
7469 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
7470 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
7471 GV *gv = cGVOPx_gv(tmpop);
7474 tmpop->op_private |= OPpEARLY_CV;
7478 namegv = CvANON(cv) ? gv : CvGV(cv);
7479 proto = SvPV((SV*)cv, len);
7480 proto_end = proto + len;
7482 if (CvASSERTION(cv)) {
7483 U32 asserthints = 0;
7484 HV *const hinthv = GvHV(PL_hintgv);
7486 SV **svp = hv_fetchs(hinthv, "assertions", FALSE);
7488 asserthints = SvUV(*svp);
7490 if (asserthints & HINT_ASSERTING) {
7491 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
7492 o->op_private |= OPpENTERSUB_DB;
7496 if (!(asserthints & HINT_ASSERTIONSSEEN) && ckWARN(WARN_ASSERTIONS)) {
7497 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
7498 "Impossible to activate assertion call");
7505 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7506 if (o2->op_type == OP_CONST)
7507 o2->op_private &= ~OPpCONST_STRICT;
7508 else if (o2->op_type == OP_LIST) {
7509 OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
7510 if (sib && sib->op_type == OP_CONST)
7511 sib->op_private &= ~OPpCONST_STRICT;
7514 o->op_private |= (PL_hints & HINT_STRICT_REFS);
7515 if (PERLDB_SUB && PL_curstash != PL_debstash)
7516 o->op_private |= OPpENTERSUB_DB;
7517 while (o2 != cvop) {
7519 if (PL_madskills && o2->op_type == OP_NULL)
7520 o3 = ((UNOP*)o2)->op_first;
7524 if (proto >= proto_end)
7525 return too_many_arguments(o, gv_ename(namegv));
7533 /* _ must be at the end */
7534 if (proto[1] && proto[1] != ';')
7549 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
7551 arg == 1 ? "block or sub {}" : "sub {}",
7552 gv_ename(namegv), o3);
7555 /* '*' allows any scalar type, including bareword */
7558 if (o3->op_type == OP_RV2GV)
7559 goto wrapref; /* autoconvert GLOB -> GLOBref */
7560 else if (o3->op_type == OP_CONST)
7561 o3->op_private &= ~OPpCONST_STRICT;
7562 else if (o3->op_type == OP_ENTERSUB) {
7563 /* accidental subroutine, revert to bareword */
7564 OP *gvop = ((UNOP*)o3)->op_first;
7565 if (gvop && gvop->op_type == OP_NULL) {
7566 gvop = ((UNOP*)gvop)->op_first;
7568 for (; gvop->op_sibling; gvop = gvop->op_sibling)
7571 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
7572 (gvop = ((UNOP*)gvop)->op_first) &&
7573 gvop->op_type == OP_GV)
7575 GV * const gv = cGVOPx_gv(gvop);
7576 OP * const sibling = o2->op_sibling;
7577 SV * const n = newSVpvs("");
7579 OP * const oldo2 = o2;
7583 gv_fullname4(n, gv, "", FALSE);
7584 o2 = newSVOP(OP_CONST, 0, n);
7585 op_getmad(oldo2,o2,'O');
7586 prev->op_sibling = o2;
7587 o2->op_sibling = sibling;
7603 if (contextclass++ == 0) {
7604 e = strchr(proto, ']');
7605 if (!e || e == proto)
7614 const char *p = proto;
7615 const char *const end = proto;
7617 while (*--p != '[');
7618 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
7620 gv_ename(namegv), o3);
7625 if (o3->op_type == OP_RV2GV)
7628 bad_type(arg, "symbol", gv_ename(namegv), o3);
7631 if (o3->op_type == OP_ENTERSUB)
7634 bad_type(arg, "subroutine entry", gv_ename(namegv),
7638 if (o3->op_type == OP_RV2SV ||
7639 o3->op_type == OP_PADSV ||
7640 o3->op_type == OP_HELEM ||
7641 o3->op_type == OP_AELEM)
7644 bad_type(arg, "scalar", gv_ename(namegv), o3);
7647 if (o3->op_type == OP_RV2AV ||
7648 o3->op_type == OP_PADAV)
7651 bad_type(arg, "array", gv_ename(namegv), o3);
7654 if (o3->op_type == OP_RV2HV ||
7655 o3->op_type == OP_PADHV)
7658 bad_type(arg, "hash", gv_ename(namegv), o3);
7663 OP* const sib = kid->op_sibling;
7664 kid->op_sibling = 0;
7665 o2 = newUNOP(OP_REFGEN, 0, kid);
7666 o2->op_sibling = sib;
7667 prev->op_sibling = o2;
7669 if (contextclass && e) {
7684 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
7685 gv_ename(namegv), SVfARG(cv));
7690 mod(o2, OP_ENTERSUB);
7692 o2 = o2->op_sibling;
7694 if (o2 == cvop && proto && *proto == '_') {
7695 /* generate an access to $_ */
7697 o2->op_sibling = prev->op_sibling;
7698 prev->op_sibling = o2; /* instead of cvop */
7700 if (proto && !optional && proto_end > proto &&
7701 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
7702 return too_few_arguments(o, gv_ename(namegv));
7705 OP * const oldo = o;
7709 o=newSVOP(OP_CONST, 0, newSViv(0));
7710 op_getmad(oldo,o,'O');
7716 Perl_ck_svconst(pTHX_ OP *o)
7718 PERL_UNUSED_CONTEXT;
7719 SvREADONLY_on(cSVOPo->op_sv);
7724 Perl_ck_chdir(pTHX_ OP *o)
7726 if (o->op_flags & OPf_KIDS) {
7727 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7729 if (kid && kid->op_type == OP_CONST &&
7730 (kid->op_private & OPpCONST_BARE))
7732 o->op_flags |= OPf_SPECIAL;
7733 kid->op_private &= ~OPpCONST_STRICT;
7740 Perl_ck_trunc(pTHX_ OP *o)
7742 if (o->op_flags & OPf_KIDS) {
7743 SVOP *kid = (SVOP*)cUNOPo->op_first;
7745 if (kid->op_type == OP_NULL)
7746 kid = (SVOP*)kid->op_sibling;
7747 if (kid && kid->op_type == OP_CONST &&
7748 (kid->op_private & OPpCONST_BARE))
7750 o->op_flags |= OPf_SPECIAL;
7751 kid->op_private &= ~OPpCONST_STRICT;
7758 Perl_ck_unpack(pTHX_ OP *o)
7760 OP *kid = cLISTOPo->op_first;
7761 if (kid->op_sibling) {
7762 kid = kid->op_sibling;
7763 if (!kid->op_sibling)
7764 kid->op_sibling = newDEFSVOP();
7770 Perl_ck_substr(pTHX_ OP *o)
7773 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
7774 OP *kid = cLISTOPo->op_first;
7776 if (kid->op_type == OP_NULL)
7777 kid = kid->op_sibling;
7779 kid->op_flags |= OPf_MOD;
7785 /* A peephole optimizer. We visit the ops in the order they're to execute.
7786 * See the comments at the top of this file for more details about when
7787 * peep() is called */
7790 Perl_peep(pTHX_ register OP *o)
7793 register OP* oldop = NULL;
7795 if (!o || o->op_opt)
7799 SAVEVPTR(PL_curcop);
7800 for (; o; o = o->op_next) {
7804 switch (o->op_type) {
7808 PL_curcop = ((COP*)o); /* for warnings */
7813 if (cSVOPo->op_private & OPpCONST_STRICT)
7814 no_bareword_allowed(o);
7816 case OP_METHOD_NAMED:
7817 /* Relocate sv to the pad for thread safety.
7818 * Despite being a "constant", the SV is written to,
7819 * for reference counts, sv_upgrade() etc. */
7821 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
7822 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
7823 /* If op_sv is already a PADTMP then it is being used by
7824 * some pad, so make a copy. */
7825 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
7826 SvREADONLY_on(PAD_SVl(ix));
7827 SvREFCNT_dec(cSVOPo->op_sv);
7829 else if (o->op_type == OP_CONST
7830 && cSVOPo->op_sv == &PL_sv_undef) {
7831 /* PL_sv_undef is hack - it's unsafe to store it in the
7832 AV that is the pad, because av_fetch treats values of
7833 PL_sv_undef as a "free" AV entry and will merrily
7834 replace them with a new SV, causing pad_alloc to think
7835 that this pad slot is free. (When, clearly, it is not)
7837 SvOK_off(PAD_SVl(ix));
7838 SvPADTMP_on(PAD_SVl(ix));
7839 SvREADONLY_on(PAD_SVl(ix));
7842 SvREFCNT_dec(PAD_SVl(ix));
7843 SvPADTMP_on(cSVOPo->op_sv);
7844 PAD_SETSV(ix, cSVOPo->op_sv);
7845 /* XXX I don't know how this isn't readonly already. */
7846 SvREADONLY_on(PAD_SVl(ix));
7848 cSVOPo->op_sv = NULL;
7856 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
7857 if (o->op_next->op_private & OPpTARGET_MY) {
7858 if (o->op_flags & OPf_STACKED) /* chained concats */
7859 goto ignore_optimization;
7861 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
7862 o->op_targ = o->op_next->op_targ;
7863 o->op_next->op_targ = 0;
7864 o->op_private |= OPpTARGET_MY;
7867 op_null(o->op_next);
7869 ignore_optimization:
7873 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
7875 break; /* Scalar stub must produce undef. List stub is noop */
7879 if (o->op_targ == OP_NEXTSTATE
7880 || o->op_targ == OP_DBSTATE
7881 || o->op_targ == OP_SETSTATE)
7883 PL_curcop = ((COP*)o);
7885 /* XXX: We avoid setting op_seq here to prevent later calls
7886 to peep() from mistakenly concluding that optimisation
7887 has already occurred. This doesn't fix the real problem,
7888 though (See 20010220.007). AMS 20010719 */
7889 /* op_seq functionality is now replaced by op_opt */
7890 if (oldop && o->op_next) {
7891 oldop->op_next = o->op_next;
7899 if (oldop && o->op_next) {
7900 oldop->op_next = o->op_next;
7908 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
7909 OP* const pop = (o->op_type == OP_PADAV) ?
7910 o->op_next : o->op_next->op_next;
7912 if (pop && pop->op_type == OP_CONST &&
7913 ((PL_op = pop->op_next)) &&
7914 pop->op_next->op_type == OP_AELEM &&
7915 !(pop->op_next->op_private &
7916 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
7917 (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
7922 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
7923 no_bareword_allowed(pop);
7924 if (o->op_type == OP_GV)
7925 op_null(o->op_next);
7926 op_null(pop->op_next);
7928 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
7929 o->op_next = pop->op_next->op_next;
7930 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
7931 o->op_private = (U8)i;
7932 if (o->op_type == OP_GV) {
7937 o->op_flags |= OPf_SPECIAL;
7938 o->op_type = OP_AELEMFAST;
7944 if (o->op_next->op_type == OP_RV2SV) {
7945 if (!(o->op_next->op_private & OPpDEREF)) {
7946 op_null(o->op_next);
7947 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
7949 o->op_next = o->op_next->op_next;
7950 o->op_type = OP_GVSV;
7951 o->op_ppaddr = PL_ppaddr[OP_GVSV];
7954 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
7955 GV * const gv = cGVOPo_gv;
7956 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
7957 /* XXX could check prototype here instead of just carping */
7958 SV * const sv = sv_newmortal();
7959 gv_efullname3(sv, gv, NULL);
7960 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
7961 "%"SVf"() called too early to check prototype",
7965 else if (o->op_next->op_type == OP_READLINE
7966 && o->op_next->op_next->op_type == OP_CONCAT
7967 && (o->op_next->op_next->op_flags & OPf_STACKED))
7969 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
7970 o->op_type = OP_RCATLINE;
7971 o->op_flags |= OPf_STACKED;
7972 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
7973 op_null(o->op_next->op_next);
7974 op_null(o->op_next);
7991 while (cLOGOP->op_other->op_type == OP_NULL)
7992 cLOGOP->op_other = cLOGOP->op_other->op_next;
7993 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
7999 while (cLOOP->op_redoop->op_type == OP_NULL)
8000 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
8001 peep(cLOOP->op_redoop);
8002 while (cLOOP->op_nextop->op_type == OP_NULL)
8003 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
8004 peep(cLOOP->op_nextop);
8005 while (cLOOP->op_lastop->op_type == OP_NULL)
8006 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
8007 peep(cLOOP->op_lastop);
8014 while (cPMOP->op_pmreplstart &&
8015 cPMOP->op_pmreplstart->op_type == OP_NULL)
8016 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
8017 peep(cPMOP->op_pmreplstart);
8022 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
8023 && ckWARN(WARN_SYNTAX))
8025 if (o->op_next->op_sibling) {
8026 const OPCODE type = o->op_next->op_sibling->op_type;
8027 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
8028 const line_t oldline = CopLINE(PL_curcop);
8029 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
8030 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8031 "Statement unlikely to be reached");
8032 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8033 "\t(Maybe you meant system() when you said exec()?)\n");
8034 CopLINE_set(PL_curcop, oldline);
8045 const char *key = NULL;
8050 if (((BINOP*)o)->op_last->op_type != OP_CONST)
8053 /* Make the CONST have a shared SV */
8054 svp = cSVOPx_svp(((BINOP*)o)->op_last);
8055 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
8056 key = SvPV_const(sv, keylen);
8057 lexname = newSVpvn_share(key,
8058 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
8064 if ((o->op_private & (OPpLVAL_INTRO)))
8067 rop = (UNOP*)((BINOP*)o)->op_first;
8068 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
8070 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
8071 if (!SvPAD_TYPED(lexname))
8073 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8074 if (!fields || !GvHV(*fields))
8076 key = SvPV_const(*svp, keylen);
8077 if (!hv_fetch(GvHV(*fields), key,
8078 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8080 Perl_croak(aTHX_ "No such class field \"%s\" "
8081 "in variable %s of type %s",
8082 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
8095 SVOP *first_key_op, *key_op;
8097 if ((o->op_private & (OPpLVAL_INTRO))
8098 /* I bet there's always a pushmark... */
8099 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
8100 /* hmmm, no optimization if list contains only one key. */
8102 rop = (UNOP*)((LISTOP*)o)->op_last;
8103 if (rop->op_type != OP_RV2HV)
8105 if (rop->op_first->op_type == OP_PADSV)
8106 /* @$hash{qw(keys here)} */
8107 rop = (UNOP*)rop->op_first;
8109 /* @{$hash}{qw(keys here)} */
8110 if (rop->op_first->op_type == OP_SCOPE
8111 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
8113 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
8119 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
8120 if (!SvPAD_TYPED(lexname))
8122 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8123 if (!fields || !GvHV(*fields))
8125 /* Again guessing that the pushmark can be jumped over.... */
8126 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
8127 ->op_first->op_sibling;
8128 for (key_op = first_key_op; key_op;
8129 key_op = (SVOP*)key_op->op_sibling) {
8130 if (key_op->op_type != OP_CONST)
8132 svp = cSVOPx_svp(key_op);
8133 key = SvPV_const(*svp, keylen);
8134 if (!hv_fetch(GvHV(*fields), key,
8135 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8137 Perl_croak(aTHX_ "No such class field \"%s\" "
8138 "in variable %s of type %s",
8139 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
8146 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
8150 /* check that RHS of sort is a single plain array */
8151 OP *oright = cUNOPo->op_first;
8152 if (!oright || oright->op_type != OP_PUSHMARK)
8155 /* reverse sort ... can be optimised. */
8156 if (!cUNOPo->op_sibling) {
8157 /* Nothing follows us on the list. */
8158 OP * const reverse = o->op_next;
8160 if (reverse->op_type == OP_REVERSE &&
8161 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
8162 OP * const pushmark = cUNOPx(reverse)->op_first;
8163 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
8164 && (cUNOPx(pushmark)->op_sibling == o)) {
8165 /* reverse -> pushmark -> sort */
8166 o->op_private |= OPpSORT_REVERSE;
8168 pushmark->op_next = oright->op_next;
8174 /* make @a = sort @a act in-place */
8178 oright = cUNOPx(oright)->op_sibling;
8181 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
8182 oright = cUNOPx(oright)->op_sibling;
8186 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
8187 || oright->op_next != o
8188 || (oright->op_private & OPpLVAL_INTRO)
8192 /* o2 follows the chain of op_nexts through the LHS of the
8193 * assign (if any) to the aassign op itself */
8195 if (!o2 || o2->op_type != OP_NULL)
8198 if (!o2 || o2->op_type != OP_PUSHMARK)
8201 if (o2 && o2->op_type == OP_GV)
8204 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
8205 || (o2->op_private & OPpLVAL_INTRO)
8210 if (!o2 || o2->op_type != OP_NULL)
8213 if (!o2 || o2->op_type != OP_AASSIGN
8214 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
8217 /* check that the sort is the first arg on RHS of assign */
8219 o2 = cUNOPx(o2)->op_first;
8220 if (!o2 || o2->op_type != OP_NULL)
8222 o2 = cUNOPx(o2)->op_first;
8223 if (!o2 || o2->op_type != OP_PUSHMARK)
8225 if (o2->op_sibling != o)
8228 /* check the array is the same on both sides */
8229 if (oleft->op_type == OP_RV2AV) {
8230 if (oright->op_type != OP_RV2AV
8231 || !cUNOPx(oright)->op_first
8232 || cUNOPx(oright)->op_first->op_type != OP_GV
8233 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
8234 cGVOPx_gv(cUNOPx(oright)->op_first)
8238 else if (oright->op_type != OP_PADAV
8239 || oright->op_targ != oleft->op_targ
8243 /* transfer MODishness etc from LHS arg to RHS arg */
8244 oright->op_flags = oleft->op_flags;
8245 o->op_private |= OPpSORT_INPLACE;
8247 /* excise push->gv->rv2av->null->aassign */
8248 o2 = o->op_next->op_next;
8249 op_null(o2); /* PUSHMARK */
8251 if (o2->op_type == OP_GV) {
8252 op_null(o2); /* GV */
8255 op_null(o2); /* RV2AV or PADAV */
8256 o2 = o2->op_next->op_next;
8257 op_null(o2); /* AASSIGN */
8259 o->op_next = o2->op_next;
8265 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
8267 LISTOP *enter, *exlist;
8270 enter = (LISTOP *) o->op_next;
8273 if (enter->op_type == OP_NULL) {
8274 enter = (LISTOP *) enter->op_next;
8278 /* for $a (...) will have OP_GV then OP_RV2GV here.
8279 for (...) just has an OP_GV. */
8280 if (enter->op_type == OP_GV) {
8281 gvop = (OP *) enter;
8282 enter = (LISTOP *) enter->op_next;
8285 if (enter->op_type == OP_RV2GV) {
8286 enter = (LISTOP *) enter->op_next;
8292 if (enter->op_type != OP_ENTERITER)
8295 iter = enter->op_next;
8296 if (!iter || iter->op_type != OP_ITER)
8299 expushmark = enter->op_first;
8300 if (!expushmark || expushmark->op_type != OP_NULL
8301 || expushmark->op_targ != OP_PUSHMARK)
8304 exlist = (LISTOP *) expushmark->op_sibling;
8305 if (!exlist || exlist->op_type != OP_NULL
8306 || exlist->op_targ != OP_LIST)
8309 if (exlist->op_last != o) {
8310 /* Mmm. Was expecting to point back to this op. */
8313 theirmark = exlist->op_first;
8314 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
8317 if (theirmark->op_sibling != o) {
8318 /* There's something between the mark and the reverse, eg
8319 for (1, reverse (...))
8324 ourmark = ((LISTOP *)o)->op_first;
8325 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
8328 ourlast = ((LISTOP *)o)->op_last;
8329 if (!ourlast || ourlast->op_next != o)
8332 rv2av = ourmark->op_sibling;
8333 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
8334 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
8335 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
8336 /* We're just reversing a single array. */
8337 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
8338 enter->op_flags |= OPf_STACKED;
8341 /* We don't have control over who points to theirmark, so sacrifice
8343 theirmark->op_next = ourmark->op_next;
8344 theirmark->op_flags = ourmark->op_flags;
8345 ourlast->op_next = gvop ? gvop : (OP *) enter;
8348 enter->op_private |= OPpITER_REVERSED;
8349 iter->op_private |= OPpITER_REVERSED;
8356 UNOP *refgen, *rv2cv;
8359 /* I do not understand this, but if o->op_opt isn't set to 1,
8360 various tests in ext/B/t/bytecode.t fail with no readily
8366 if ((o->op_flags && OPf_WANT) != OPf_WANT_VOID)
8369 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
8372 rv2gv = ((BINOP *)o)->op_last;
8373 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
8376 refgen = (UNOP *)((BINOP *)o)->op_first;
8378 if (!refgen || refgen->op_type != OP_REFGEN)
8381 exlist = (LISTOP *)refgen->op_first;
8382 if (!exlist || exlist->op_type != OP_NULL
8383 || exlist->op_targ != OP_LIST)
8386 if (exlist->op_first->op_type != OP_PUSHMARK)
8389 rv2cv = (UNOP*)exlist->op_last;
8391 if (rv2cv->op_type != OP_RV2CV)
8394 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
8395 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
8396 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
8398 o->op_private |= OPpASSIGN_CV_TO_GV;
8399 rv2gv->op_private |= OPpDONT_INIT_GV;
8400 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
8416 Perl_custom_op_name(pTHX_ const OP* o)
8419 const IV index = PTR2IV(o->op_ppaddr);
8423 if (!PL_custom_op_names) /* This probably shouldn't happen */
8424 return (char *)PL_op_name[OP_CUSTOM];
8426 keysv = sv_2mortal(newSViv(index));
8428 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
8430 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
8432 return SvPV_nolen(HeVAL(he));
8436 Perl_custom_op_desc(pTHX_ const OP* o)
8439 const IV index = PTR2IV(o->op_ppaddr);
8443 if (!PL_custom_op_descs)
8444 return (char *)PL_op_desc[OP_CUSTOM];
8446 keysv = sv_2mortal(newSViv(index));
8448 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
8450 return (char *)PL_op_desc[OP_CUSTOM];
8452 return SvPV_nolen(HeVAL(he));
8457 /* Efficient sub that returns a constant scalar value. */
8459 const_sv_xsub(pTHX_ CV* cv)
8466 Perl_croak(aTHX_ "usage: %s::%s()",
8467 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
8471 ST(0) = (SV*)XSANY.any_ptr;
8477 * c-indentation-style: bsd
8479 * indent-tabs-mode: t
8482 * ex: set ts=8 sts=4 sw=4 noet: