3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * "You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was
13 * our Mr. Bilbo's first cousin on the mother's side (her mother being the
14 * youngest of the Old Took's daughters); and Mr. Drogo was his second
15 * cousin. So Mr. Frodo is his first *and* second cousin, once removed
16 * either way, as the saying is, if you follow me." --the Gaffer
19 /* This file contains the functions that create, manipulate and optimize
20 * the OP structures that hold a compiled perl program.
22 * A Perl program is compiled into a tree of OPs. Each op contains
23 * structural pointers (eg to its siblings and the next op in the
24 * execution sequence), a pointer to the function that would execute the
25 * op, plus any data specific to that op. For example, an OP_CONST op
26 * points to the pp_const() function and to an SV containing the constant
27 * value. When pp_const() is executed, its job is to push that SV onto the
30 * OPs are mainly created by the newFOO() functions, which are mainly
31 * called from the parser (in perly.y) as the code is parsed. For example
32 * the Perl code $a + $b * $c would cause the equivalent of the following
33 * to be called (oversimplifying a bit):
35 * newBINOP(OP_ADD, flags,
37 * newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
40 * Note that during the build of miniperl, a temporary copy of this file
41 * is made, called opmini.c.
45 Perl's compiler is essentially a 3-pass compiler with interleaved phases:
49 An execution-order pass
51 The bottom-up pass is represented by all the "newOP" routines and
52 the ck_ routines. The bottom-upness is actually driven by yacc.
53 So at the point that a ck_ routine fires, we have no idea what the
54 context is, either upward in the syntax tree, or either forward or
55 backward in the execution order. (The bottom-up parser builds that
56 part of the execution order it knows about, but if you follow the "next"
57 links around, you'll find it's actually a closed loop through the
60 Whenever the bottom-up parser gets to a node that supplies context to
61 its components, it invokes that portion of the top-down pass that applies
62 to that part of the subtree (and marks the top node as processed, so
63 if a node further up supplies context, it doesn't have to take the
64 plunge again). As a particular subcase of this, as the new node is
65 built, it takes all the closed execution loops of its subcomponents
66 and links them into a new closed loop for the higher level node. But
67 it's still not the real execution order.
69 The actual execution order is not known till we get a grammar reduction
70 to a top-level unit like a subroutine or file that will be called by
71 "name" rather than via a "next" pointer. At that point, we can call
72 into peep() to do that code's portion of the 3rd pass. It has to be
73 recursive, but it's recursive on basic blocks, not on tree nodes.
76 /* To implement user lexical pragmas, there needs to be a way at run time to
77 get the compile time state of %^H for that block. Storing %^H in every
78 block (or even COP) would be very expensive, so a different approach is
79 taken. The (running) state of %^H is serialised into a tree of HE-like
80 structs. Stores into %^H are chained onto the current leaf as a struct
81 refcounted_he * with the key and the value. Deletes from %^H are saved
82 with a value of PL_sv_placeholder. The state of %^H at any point can be
83 turned back into a regular HV by walking back up the tree from that point's
84 leaf, ignoring any key you've already seen (placeholder or not), storing
85 the rest into the HV structure, then removing the placeholders. Hence
86 memory is only used to store the %^H deltas from the enclosing COP, rather
87 than the entire %^H on each COP.
89 To cause actions on %^H to write out the serialisation records, it has
90 magic type 'H'. This magic (itself) does nothing, but its presence causes
91 the values to gain magic type 'h', which has entries for set and clear.
92 C<Perl_magic_sethint> updates C<PL_compiling.cop_hints_hash> with a store
93 record, with deletes written by C<Perl_magic_clearhint>. C<SAVE_HINTS>
94 saves the current C<PL_compiling.cop_hints_hash> on the save stack, so that
95 it will be correctly restored when any inner compiling scope is exited.
101 #include "keywords.h"
103 #define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
105 #if defined(PL_OP_SLAB_ALLOC)
107 #ifdef PERL_DEBUG_READONLY_OPS
108 # define PERL_SLAB_SIZE 4096
109 # include <sys/mman.h>
112 #ifndef PERL_SLAB_SIZE
113 #define PERL_SLAB_SIZE 2048
117 Perl_Slab_Alloc(pTHX_ size_t sz)
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");
142 PL_OpPtr = (I32 **) PerlMemShared_calloc(PERL_SLAB_SIZE,sizeof(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 U32 count = PL_slab_count;
239 /* Need to remove this slab from our list of slabs */
242 if (PL_slabs[count] == slab) {
243 /* Found it. Move the entry at the end to overwrite it. */
244 DEBUG_m(PerlIO_printf(Perl_debug_log,
245 "Deallocate %p by moving %p from %lu to %lu\n",
247 PL_slabs[PL_slab_count - 1],
248 PL_slab_count, count));
249 PL_slabs[count] = PL_slabs[--PL_slab_count];
250 /* Could realloc smaller at this point, but probably not
257 "panic: Couldn't find slab at %p (%lu allocated)",
258 slab, (unsigned long) PL_slabs);
260 if(munmap(slab, PERL_SLAB_SIZE*sizeof(I32*))) {
261 perror("munmap failed");
266 PerlMemShared_free(slab);
268 if (slab == PL_OpSlab) {
275 * In the following definition, the ", (OP*)0" is just to make the compiler
276 * think the expression is of the right type: croak actually does a Siglongjmp.
278 #define CHECKOP(type,o) \
279 ((PL_op_mask && PL_op_mask[type]) \
280 ? ( op_free((OP*)o), \
281 Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
283 : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
285 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
288 S_gv_ename(pTHX_ GV *gv)
290 SV* const tmpsv = sv_newmortal();
291 gv_efullname3(tmpsv, gv, NULL);
292 return SvPV_nolen_const(tmpsv);
296 S_no_fh_allowed(pTHX_ OP *o)
298 yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
304 S_too_few_arguments(pTHX_ OP *o, const char *name)
306 yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
311 S_too_many_arguments(pTHX_ OP *o, const char *name)
313 yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
318 S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid)
320 yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
321 (int)n, name, t, OP_DESC(kid)));
325 S_no_bareword_allowed(pTHX_ const OP *o)
328 return; /* various ok barewords are hidden in extra OP_NULL */
329 qerror(Perl_mess(aTHX_
330 "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
334 /* "register" allocation */
337 Perl_allocmy(pTHX_ const char *const name)
341 const bool is_our = (PL_in_my == KEY_our);
343 /* complain about "my $<special_var>" etc etc */
347 (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
348 (name[1] == '_' && (*name == '$' || name[2]))))
350 /* name[2] is true if strlen(name) > 2 */
351 if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
352 yyerror(Perl_form(aTHX_ "Can't use global %c^%c%s in \"my\"",
353 name[0], toCTRL(name[1]), name + 2));
355 yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
359 /* check for duplicate declaration */
360 pad_check_dup(name, is_our, (PL_curstash ? PL_curstash : PL_defstash));
362 if (PL_in_my_stash && *name != '$') {
363 yyerror(Perl_form(aTHX_
364 "Can't declare class for non-scalar %s in \"%s\"",
366 is_our ? "our" : PL_in_my == KEY_state ? "state" : "my"));
369 /* allocate a spare slot and store the name in that slot */
371 off = pad_add_name(name,
374 /* $_ is always in main::, even with our */
375 ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
379 PL_in_my == KEY_state
384 /* free the body of an op without examining its contents.
385 * Always use this rather than FreeOp directly */
388 S_op_destroy(pTHX_ OP *o)
390 if (o->op_latefree) {
401 Perl_op_free(pTHX_ OP *o)
406 if (!o || o->op_static)
408 if (o->op_latefreed) {
415 if (o->op_private & OPpREFCOUNTED) {
425 #ifdef PERL_DEBUG_READONLY_OPS
429 refcnt = OpREFCNT_dec(o);
432 /* Need to find and remove any pattern match ops from the list
433 we maintain for reset(). */
434 find_and_forget_pmops(o);
444 if (o->op_flags & OPf_KIDS) {
445 register OP *kid, *nextkid;
446 for (kid = cUNOPo->op_first; kid; kid = nextkid) {
447 nextkid = kid->op_sibling; /* Get before next freeing kid */
452 type = (OPCODE)o->op_targ;
454 /* COP* is not cleared by op_clear() so that we may track line
455 * numbers etc even after null() */
456 if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE) {
457 #ifdef PERL_DEBUG_READONLY_OPS
464 if (o->op_latefree) {
470 #ifdef DEBUG_LEAKING_SCALARS
477 Perl_op_clear(pTHX_ OP *o)
482 /* if (o->op_madprop && o->op_madprop->mad_next)
484 /* FIXME for MAD - if I uncomment these two lines t/op/pack.t fails with
485 "modification of a read only value" for a reason I can't fathom why.
486 It's the "" stringification of $_, where $_ was set to '' in a foreach
487 loop, but it defies simplification into a small test case.
488 However, commenting them out has caused ext/List/Util/t/weak.t to fail
491 mad_free(o->op_madprop);
497 switch (o->op_type) {
498 case OP_NULL: /* Was holding old type, if any. */
499 if (PL_madskills && o->op_targ != OP_NULL) {
500 o->op_type = o->op_targ;
504 case OP_ENTEREVAL: /* Was holding hints. */
508 if (!(o->op_flags & OPf_REF)
509 || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
515 if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
516 /* not an OP_PADAV replacement */
518 if (cPADOPo->op_padix > 0) {
519 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
520 * may still exist on the pad */
521 pad_swipe(cPADOPo->op_padix, TRUE);
522 cPADOPo->op_padix = 0;
525 SvREFCNT_dec(cSVOPo->op_sv);
526 cSVOPo->op_sv = NULL;
530 case OP_METHOD_NAMED:
532 SvREFCNT_dec(cSVOPo->op_sv);
533 cSVOPo->op_sv = NULL;
536 Even if op_clear does a pad_free for the target of the op,
537 pad_free doesn't actually remove the sv that exists in the pad;
538 instead it lives on. This results in that it could be reused as
539 a target later on when the pad was reallocated.
542 pad_swipe(o->op_targ,1);
551 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
555 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
557 if (cPADOPo->op_padix > 0) {
558 pad_swipe(cPADOPo->op_padix, TRUE);
559 cPADOPo->op_padix = 0;
562 SvREFCNT_dec(cSVOPo->op_sv);
563 cSVOPo->op_sv = NULL;
567 PerlMemShared_free(cPVOPo->op_pv);
568 cPVOPo->op_pv = NULL;
572 op_free(cPMOPo->op_pmreplroot);
576 if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) {
577 /* No GvIN_PAD_off here, because other references may still
578 * exist on the pad */
579 pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot), TRUE);
582 SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
588 forget_pmop(cPMOPo, 1);
589 cPMOPo->op_pmreplroot = NULL;
590 /* we use the "SAFE" version of the PM_ macros here
591 * since sv_clean_all might release some PMOPs
592 * after PL_regex_padav has been cleared
593 * and the clearing of PL_regex_padav needs to
594 * happen before sv_clean_all
596 ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
597 PM_SETRE_SAFE(cPMOPo, NULL);
599 if(PL_regex_pad) { /* We could be in destruction */
600 av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
601 SvREADONLY_off(PL_regex_pad[(cPMOPo)->op_pmoffset]);
602 SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
603 PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
610 if (o->op_targ > 0) {
611 pad_free(o->op_targ);
617 S_cop_free(pTHX_ COP* cop)
622 if (! specialWARN(cop->cop_warnings))
623 PerlMemShared_free(cop->cop_warnings);
624 Perl_refcounted_he_free(aTHX_ cop->cop_hints_hash);
628 S_forget_pmop(pTHX_ PMOP *const o, U32 flags)
630 HV * const pmstash = PmopSTASH(o);
631 if (pmstash && !SvIS_FREED(pmstash)) {
632 MAGIC * const mg = mg_find((SV*)pmstash, PERL_MAGIC_symtab);
634 PMOP **const array = (PMOP**) mg->mg_ptr;
635 U32 count = mg->mg_len / sizeof(PMOP**);
640 /* Found it. Move the entry at the end to overwrite it. */
641 array[i] = array[--count];
642 mg->mg_len = count * sizeof(PMOP**);
643 /* Could realloc smaller at this point always, but probably
644 not worth it. Probably worth free()ing if we're the
647 Safefree(mg->mg_ptr);
660 S_find_and_forget_pmops(pTHX_ OP *o)
662 if (o->op_flags & OPf_KIDS) {
663 OP *kid = cUNOPo->op_first;
665 switch (kid->op_type) {
670 forget_pmop((PMOP*)kid, 0);
672 find_and_forget_pmops(kid);
673 kid = kid->op_sibling;
679 Perl_op_null(pTHX_ OP *o)
682 if (o->op_type == OP_NULL)
686 o->op_targ = o->op_type;
687 o->op_type = OP_NULL;
688 o->op_ppaddr = PL_ppaddr[OP_NULL];
692 Perl_op_refcnt_lock(pTHX)
700 Perl_op_refcnt_unlock(pTHX)
707 /* Contextualizers */
709 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
712 Perl_linklist(pTHX_ OP *o)
719 /* establish postfix order */
720 first = cUNOPo->op_first;
723 o->op_next = LINKLIST(first);
726 if (kid->op_sibling) {
727 kid->op_next = LINKLIST(kid->op_sibling);
728 kid = kid->op_sibling;
742 Perl_scalarkids(pTHX_ OP *o)
744 if (o && o->op_flags & OPf_KIDS) {
746 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
753 S_scalarboolean(pTHX_ OP *o)
756 if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
757 if (ckWARN(WARN_SYNTAX)) {
758 const line_t oldline = CopLINE(PL_curcop);
760 if (PL_copline != NOLINE)
761 CopLINE_set(PL_curcop, PL_copline);
762 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
763 CopLINE_set(PL_curcop, oldline);
770 Perl_scalar(pTHX_ OP *o)
775 /* assumes no premature commitment */
776 if (!o || PL_error_count || (o->op_flags & OPf_WANT)
777 || o->op_type == OP_RETURN)
782 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
784 switch (o->op_type) {
786 scalar(cBINOPo->op_first);
791 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
795 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
796 if (!kPMOP->op_pmreplroot)
797 deprecate_old("implicit split to @_");
805 if (o->op_flags & OPf_KIDS) {
806 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
812 kid = cLISTOPo->op_first;
814 while ((kid = kid->op_sibling)) {
820 PL_curcop = &PL_compiling;
825 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
831 PL_curcop = &PL_compiling;
834 if (ckWARN(WARN_VOID))
835 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
841 Perl_scalarvoid(pTHX_ OP *o)
845 const char* useless = NULL;
849 /* trailing mad null ops don't count as "there" for void processing */
851 o->op_type != OP_NULL &&
853 o->op_sibling->op_type == OP_NULL)
856 for (sib = o->op_sibling;
857 sib && sib->op_type == OP_NULL;
858 sib = sib->op_sibling) ;
864 if (o->op_type == OP_NEXTSTATE
865 || o->op_type == OP_SETSTATE
866 || o->op_type == OP_DBSTATE
867 || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
868 || o->op_targ == OP_SETSTATE
869 || o->op_targ == OP_DBSTATE)))
870 PL_curcop = (COP*)o; /* for warning below */
872 /* assumes no premature commitment */
873 want = o->op_flags & OPf_WANT;
874 if ((want && want != OPf_WANT_SCALAR) || PL_error_count
875 || o->op_type == OP_RETURN)
880 if ((o->op_private & OPpTARGET_MY)
881 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
883 return scalar(o); /* As if inside SASSIGN */
886 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
888 switch (o->op_type) {
890 if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
894 if (o->op_flags & OPf_STACKED)
898 if (o->op_private == 4)
970 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
971 useless = OP_DESC(o);
975 kid = cUNOPo->op_first;
976 if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
977 kid->op_type != OP_TRANS) {
980 useless = "negative pattern binding (!~)";
987 if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
988 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
989 useless = "a variable";
994 if (cSVOPo->op_private & OPpCONST_STRICT)
995 no_bareword_allowed(o);
997 if (ckWARN(WARN_VOID)) {
998 useless = "a constant";
999 if (o->op_private & OPpCONST_ARYBASE)
1001 /* don't warn on optimised away booleans, eg
1002 * use constant Foo, 5; Foo || print; */
1003 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1005 /* the constants 0 and 1 are permitted as they are
1006 conventionally used as dummies in constructs like
1007 1 while some_condition_with_side_effects; */
1008 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1010 else if (SvPOK(sv)) {
1011 /* perl4's way of mixing documentation and code
1012 (before the invention of POD) was based on a
1013 trick to mix nroff and perl code. The trick was
1014 built upon these three nroff macros being used in
1015 void context. The pink camel has the details in
1016 the script wrapman near page 319. */
1017 const char * const maybe_macro = SvPVX_const(sv);
1018 if (strnEQ(maybe_macro, "di", 2) ||
1019 strnEQ(maybe_macro, "ds", 2) ||
1020 strnEQ(maybe_macro, "ig", 2))
1025 op_null(o); /* don't execute or even remember it */
1029 o->op_type = OP_PREINC; /* pre-increment is faster */
1030 o->op_ppaddr = PL_ppaddr[OP_PREINC];
1034 o->op_type = OP_PREDEC; /* pre-decrement is faster */
1035 o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1039 o->op_type = OP_I_PREINC; /* pre-increment is faster */
1040 o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1044 o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
1045 o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1054 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1059 if (o->op_flags & OPf_STACKED)
1066 if (!(o->op_flags & OPf_KIDS))
1077 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1084 /* all requires must return a boolean value */
1085 o->op_flags &= ~OPf_WANT;
1090 if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
1091 if (!kPMOP->op_pmreplroot)
1092 deprecate_old("implicit split to @_");
1096 if (useless && ckWARN(WARN_VOID))
1097 Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
1102 Perl_listkids(pTHX_ OP *o)
1104 if (o && o->op_flags & OPf_KIDS) {
1106 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1113 Perl_list(pTHX_ OP *o)
1118 /* assumes no premature commitment */
1119 if (!o || (o->op_flags & OPf_WANT) || PL_error_count
1120 || o->op_type == OP_RETURN)
1125 if ((o->op_private & OPpTARGET_MY)
1126 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1128 return o; /* As if inside SASSIGN */
1131 o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1133 switch (o->op_type) {
1136 list(cBINOPo->op_first);
1141 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1149 if (!(o->op_flags & OPf_KIDS))
1151 if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1152 list(cBINOPo->op_first);
1153 return gen_constant_list(o);
1160 kid = cLISTOPo->op_first;
1162 while ((kid = kid->op_sibling)) {
1163 if (kid->op_sibling)
1168 PL_curcop = &PL_compiling;
1172 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1173 if (kid->op_sibling)
1178 PL_curcop = &PL_compiling;
1181 /* all requires must return a boolean value */
1182 o->op_flags &= ~OPf_WANT;
1189 Perl_scalarseq(pTHX_ OP *o)
1193 const OPCODE type = o->op_type;
1195 if (type == OP_LINESEQ || type == OP_SCOPE ||
1196 type == OP_LEAVE || type == OP_LEAVETRY)
1199 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1200 if (kid->op_sibling) {
1204 PL_curcop = &PL_compiling;
1206 o->op_flags &= ~OPf_PARENS;
1207 if (PL_hints & HINT_BLOCK_SCOPE)
1208 o->op_flags |= OPf_PARENS;
1211 o = newOP(OP_STUB, 0);
1216 S_modkids(pTHX_ OP *o, I32 type)
1218 if (o && o->op_flags & OPf_KIDS) {
1220 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1226 /* Propagate lvalue ("modifiable") context to an op and its children.
1227 * 'type' represents the context type, roughly based on the type of op that
1228 * would do the modifying, although local() is represented by OP_NULL.
1229 * It's responsible for detecting things that can't be modified, flag
1230 * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
1231 * might have to vivify a reference in $x), and so on.
1233 * For example, "$a+1 = 2" would cause mod() to be called with o being
1234 * OP_ADD and type being OP_SASSIGN, and would output an error.
1238 Perl_mod(pTHX_ OP *o, I32 type)
1242 /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1245 if (!o || PL_error_count)
1248 if ((o->op_private & OPpTARGET_MY)
1249 && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1254 switch (o->op_type) {
1260 if (!(o->op_private & OPpCONST_ARYBASE))
1263 if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1264 CopARYBASE_set(&PL_compiling,
1265 (I32)SvIV(cSVOPx(PL_eval_start)->op_sv));
1269 SAVECOPARYBASE(&PL_compiling);
1270 CopARYBASE_set(&PL_compiling, 0);
1272 else if (type == OP_REFGEN)
1275 Perl_croak(aTHX_ "That use of $[ is unsupported");
1278 if (o->op_flags & OPf_PARENS || PL_madskills)
1282 if ((type == OP_UNDEF || type == OP_REFGEN) &&
1283 !(o->op_flags & OPf_STACKED)) {
1284 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1285 /* The default is to set op_private to the number of children,
1286 which for a UNOP such as RV2CV is always 1. And w're using
1287 the bit for a flag in RV2CV, so we need it clear. */
1288 o->op_private &= ~1;
1289 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1290 assert(cUNOPo->op_first->op_type == OP_NULL);
1291 op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1294 else if (o->op_private & OPpENTERSUB_NOMOD)
1296 else { /* lvalue subroutine call */
1297 o->op_private |= OPpLVAL_INTRO;
1298 PL_modcount = RETURN_UNLIMITED_NUMBER;
1299 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1300 /* Backward compatibility mode: */
1301 o->op_private |= OPpENTERSUB_INARGS;
1304 else { /* Compile-time error message: */
1305 OP *kid = cUNOPo->op_first;
1309 if (kid->op_type != OP_PUSHMARK) {
1310 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1312 "panic: unexpected lvalue entersub "
1313 "args: type/targ %ld:%"UVuf,
1314 (long)kid->op_type, (UV)kid->op_targ);
1315 kid = kLISTOP->op_first;
1317 while (kid->op_sibling)
1318 kid = kid->op_sibling;
1319 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1321 if (kid->op_type == OP_METHOD_NAMED
1322 || kid->op_type == OP_METHOD)
1326 NewOp(1101, newop, 1, UNOP);
1327 newop->op_type = OP_RV2CV;
1328 newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1329 newop->op_first = NULL;
1330 newop->op_next = (OP*)newop;
1331 kid->op_sibling = (OP*)newop;
1332 newop->op_private |= OPpLVAL_INTRO;
1333 newop->op_private &= ~1;
1337 if (kid->op_type != OP_RV2CV)
1339 "panic: unexpected lvalue entersub "
1340 "entry via type/targ %ld:%"UVuf,
1341 (long)kid->op_type, (UV)kid->op_targ);
1342 kid->op_private |= OPpLVAL_INTRO;
1343 break; /* Postpone until runtime */
1347 kid = kUNOP->op_first;
1348 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1349 kid = kUNOP->op_first;
1350 if (kid->op_type == OP_NULL)
1352 "Unexpected constant lvalue entersub "
1353 "entry via type/targ %ld:%"UVuf,
1354 (long)kid->op_type, (UV)kid->op_targ);
1355 if (kid->op_type != OP_GV) {
1356 /* Restore RV2CV to check lvalueness */
1358 if (kid->op_next && kid->op_next != kid) { /* Happens? */
1359 okid->op_next = kid->op_next;
1360 kid->op_next = okid;
1363 okid->op_next = NULL;
1364 okid->op_type = OP_RV2CV;
1366 okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1367 okid->op_private |= OPpLVAL_INTRO;
1368 okid->op_private &= ~1;
1372 cv = GvCV(kGVOP_gv);
1382 /* grep, foreach, subcalls, refgen */
1383 if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1385 yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1386 (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1388 : (o->op_type == OP_ENTERSUB
1389 ? "non-lvalue subroutine call"
1391 type ? PL_op_desc[type] : "local"));
1405 case OP_RIGHT_SHIFT:
1414 if (!(o->op_flags & OPf_STACKED))
1421 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1427 if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1428 PL_modcount = RETURN_UNLIMITED_NUMBER;
1429 return o; /* Treat \(@foo) like ordinary list. */
1433 if (scalar_mod_type(o, type))
1435 ref(cUNOPo->op_first, o->op_type);
1439 if (type == OP_LEAVESUBLV)
1440 o->op_private |= OPpMAYBE_LVSUB;
1446 PL_modcount = RETURN_UNLIMITED_NUMBER;
1449 ref(cUNOPo->op_first, o->op_type);
1454 PL_hints |= HINT_BLOCK_SCOPE;
1469 PL_modcount = RETURN_UNLIMITED_NUMBER;
1470 if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1471 return o; /* Treat \(@foo) like ordinary list. */
1472 if (scalar_mod_type(o, type))
1474 if (type == OP_LEAVESUBLV)
1475 o->op_private |= OPpMAYBE_LVSUB;
1479 if (!type) /* local() */
1480 Perl_croak(aTHX_ "Can't localize lexical variable %s",
1481 PAD_COMPNAME_PV(o->op_targ));
1489 if (type != OP_SASSIGN)
1493 if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1498 if (type == OP_LEAVESUBLV)
1499 o->op_private |= OPpMAYBE_LVSUB;
1501 pad_free(o->op_targ);
1502 o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1503 assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1504 if (o->op_flags & OPf_KIDS)
1505 mod(cBINOPo->op_first->op_sibling, type);
1510 ref(cBINOPo->op_first, o->op_type);
1511 if (type == OP_ENTERSUB &&
1512 !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1513 o->op_private |= OPpLVAL_DEFER;
1514 if (type == OP_LEAVESUBLV)
1515 o->op_private |= OPpMAYBE_LVSUB;
1525 if (o->op_flags & OPf_KIDS)
1526 mod(cLISTOPo->op_last, type);
1531 if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
1533 else if (!(o->op_flags & OPf_KIDS))
1535 if (o->op_targ != OP_LIST) {
1536 mod(cBINOPo->op_first, type);
1542 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1547 if (type != OP_LEAVESUBLV)
1549 break; /* mod()ing was handled by ck_return() */
1552 /* [20011101.069] File test operators interpret OPf_REF to mean that
1553 their argument is a filehandle; thus \stat(".") should not set
1555 if (type == OP_REFGEN &&
1556 PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1559 if (type != OP_LEAVESUBLV)
1560 o->op_flags |= OPf_MOD;
1562 if (type == OP_AASSIGN || type == OP_SASSIGN)
1563 o->op_flags |= OPf_SPECIAL|OPf_REF;
1564 else if (!type) { /* local() */
1567 o->op_private |= OPpLVAL_INTRO;
1568 o->op_flags &= ~OPf_SPECIAL;
1569 PL_hints |= HINT_BLOCK_SCOPE;
1574 if (ckWARN(WARN_SYNTAX)) {
1575 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1576 "Useless localization of %s", OP_DESC(o));
1580 else if (type != OP_GREPSTART && type != OP_ENTERSUB
1581 && type != OP_LEAVESUBLV)
1582 o->op_flags |= OPf_REF;
1587 S_scalar_mod_type(const OP *o, I32 type)
1591 if (o->op_type == OP_RV2GV)
1615 case OP_RIGHT_SHIFT:
1634 S_is_handle_constructor(const OP *o, I32 numargs)
1636 switch (o->op_type) {
1644 case OP_SELECT: /* XXX c.f. SelectSaver.pm */
1657 Perl_refkids(pTHX_ OP *o, I32 type)
1659 if (o && o->op_flags & OPf_KIDS) {
1661 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1668 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
1673 if (!o || PL_error_count)
1676 switch (o->op_type) {
1678 if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1679 !(o->op_flags & OPf_STACKED)) {
1680 o->op_type = OP_RV2CV; /* entersub => rv2cv */
1681 o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1682 assert(cUNOPo->op_first->op_type == OP_NULL);
1683 op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
1684 o->op_flags |= OPf_SPECIAL;
1685 o->op_private &= ~1;
1690 for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1691 doref(kid, type, set_op_ref);
1694 if (type == OP_DEFINED)
1695 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1696 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1699 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1700 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1701 : type == OP_RV2HV ? OPpDEREF_HV
1703 o->op_flags |= OPf_MOD;
1710 o->op_flags |= OPf_REF;
1713 if (type == OP_DEFINED)
1714 o->op_flags |= OPf_SPECIAL; /* don't create GV */
1715 doref(cUNOPo->op_first, o->op_type, set_op_ref);
1721 o->op_flags |= OPf_REF;
1726 if (!(o->op_flags & OPf_KIDS))
1728 doref(cBINOPo->op_first, type, set_op_ref);
1732 doref(cBINOPo->op_first, o->op_type, set_op_ref);
1733 if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1734 o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1735 : type == OP_RV2HV ? OPpDEREF_HV
1737 o->op_flags |= OPf_MOD;
1747 if (!(o->op_flags & OPf_KIDS))
1749 doref(cLISTOPo->op_last, type, set_op_ref);
1759 S_dup_attrlist(pTHX_ OP *o)
1764 /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1765 * where the first kid is OP_PUSHMARK and the remaining ones
1766 * are OP_CONST. We need to push the OP_CONST values.
1768 if (o->op_type == OP_CONST)
1769 rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
1771 else if (o->op_type == OP_NULL)
1775 assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1777 for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1778 if (o->op_type == OP_CONST)
1779 rop = append_elem(OP_LIST, rop,
1780 newSVOP(OP_CONST, o->op_flags,
1781 SvREFCNT_inc_NN(cSVOPo->op_sv)));
1788 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1793 /* fake up C<use attributes $pkg,$rv,@attrs> */
1794 ENTER; /* need to protect against side-effects of 'use' */
1796 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1798 #define ATTRSMODULE "attributes"
1799 #define ATTRSMODULE_PM "attributes.pm"
1802 /* Don't force the C<use> if we don't need it. */
1803 SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
1804 if (svp && *svp != &PL_sv_undef)
1805 NOOP; /* already in %INC */
1807 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1808 newSVpvs(ATTRSMODULE), NULL);
1811 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1812 newSVpvs(ATTRSMODULE),
1814 prepend_elem(OP_LIST,
1815 newSVOP(OP_CONST, 0, stashsv),
1816 prepend_elem(OP_LIST,
1817 newSVOP(OP_CONST, 0,
1819 dup_attrlist(attrs))));
1825 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1828 OP *pack, *imop, *arg;
1834 assert(target->op_type == OP_PADSV ||
1835 target->op_type == OP_PADHV ||
1836 target->op_type == OP_PADAV);
1838 /* Ensure that attributes.pm is loaded. */
1839 apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1841 /* Need package name for method call. */
1842 pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
1844 /* Build up the real arg-list. */
1845 stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1847 arg = newOP(OP_PADSV, 0);
1848 arg->op_targ = target->op_targ;
1849 arg = prepend_elem(OP_LIST,
1850 newSVOP(OP_CONST, 0, stashsv),
1851 prepend_elem(OP_LIST,
1852 newUNOP(OP_REFGEN, 0,
1853 mod(arg, OP_REFGEN)),
1854 dup_attrlist(attrs)));
1856 /* Fake up a method call to import */
1857 meth = newSVpvs_share("import");
1858 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1859 append_elem(OP_LIST,
1860 prepend_elem(OP_LIST, pack, list(arg)),
1861 newSVOP(OP_METHOD_NAMED, 0, meth)));
1862 imop->op_private |= OPpENTERSUB_NOMOD;
1864 /* Combine the ops. */
1865 *imopsp = append_elem(OP_LIST, *imopsp, imop);
1869 =notfor apidoc apply_attrs_string
1871 Attempts to apply a list of attributes specified by the C<attrstr> and
1872 C<len> arguments to the subroutine identified by the C<cv> argument which
1873 is expected to be associated with the package identified by the C<stashpv>
1874 argument (see L<attributes>). It gets this wrong, though, in that it
1875 does not correctly identify the boundaries of the individual attribute
1876 specifications within C<attrstr>. This is not really intended for the
1877 public API, but has to be listed here for systems such as AIX which
1878 need an explicit export list for symbols. (It's called from XS code
1879 in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
1880 to respect attribute syntax properly would be welcome.
1886 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
1887 const char *attrstr, STRLEN len)
1892 len = strlen(attrstr);
1896 for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1898 const char * const sstr = attrstr;
1899 for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1900 attrs = append_elem(OP_LIST, attrs,
1901 newSVOP(OP_CONST, 0,
1902 newSVpvn(sstr, attrstr-sstr)));
1906 Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1907 newSVpvs(ATTRSMODULE),
1908 NULL, prepend_elem(OP_LIST,
1909 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1910 prepend_elem(OP_LIST,
1911 newSVOP(OP_CONST, 0,
1917 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
1922 if (!o || PL_error_count)
1926 if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
1927 (void)my_kid(cUNOPo->op_first, attrs, imopsp);
1931 if (type == OP_LIST) {
1933 for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1934 my_kid(kid, attrs, imopsp);
1935 } else if (type == OP_UNDEF
1941 } else if (type == OP_RV2SV || /* "our" declaration */
1943 type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1944 if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1945 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1947 PL_in_my == KEY_our ? "our" : PL_in_my == KEY_state ? "state" : "my"));
1949 GV * const gv = cGVOPx_gv(cUNOPo->op_first);
1951 PL_in_my_stash = NULL;
1952 apply_attrs(GvSTASH(gv),
1953 (type == OP_RV2SV ? GvSV(gv) :
1954 type == OP_RV2AV ? (SV*)GvAV(gv) :
1955 type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1958 o->op_private |= OPpOUR_INTRO;
1961 else if (type != OP_PADSV &&
1964 type != OP_PUSHMARK)
1966 yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1968 PL_in_my == KEY_our ? "our" : PL_in_my == KEY_state ? "state" : "my"));
1971 else if (attrs && type != OP_PUSHMARK) {
1975 PL_in_my_stash = NULL;
1977 /* check for C<my Dog $spot> when deciding package */
1978 stash = PAD_COMPNAME_TYPE(o->op_targ);
1980 stash = PL_curstash;
1981 apply_attrs_my(stash, o, attrs, imopsp);
1983 o->op_flags |= OPf_MOD;
1984 o->op_private |= OPpLVAL_INTRO;
1985 if (PL_in_my == KEY_state)
1986 o->op_private |= OPpPAD_STATE;
1991 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1995 int maybe_scalar = 0;
1997 /* [perl #17376]: this appears to be premature, and results in code such as
1998 C< our(%x); > executing in list mode rather than void mode */
2000 if (o->op_flags & OPf_PARENS)
2010 o = my_kid(o, attrs, &rops);
2012 if (maybe_scalar && o->op_type == OP_PADSV) {
2013 o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
2014 o->op_private |= OPpLVAL_INTRO;
2017 o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
2020 PL_in_my_stash = NULL;
2025 Perl_my(pTHX_ OP *o)
2027 return my_attrs(o, NULL);
2031 Perl_sawparens(pTHX_ OP *o)
2033 PERL_UNUSED_CONTEXT;
2035 o->op_flags |= OPf_PARENS;
2040 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2044 const OPCODE ltype = left->op_type;
2045 const OPCODE rtype = right->op_type;
2047 if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
2048 || ltype == OP_PADHV) && ckWARN(WARN_MISC))
2050 const char * const desc
2051 = PL_op_desc[(rtype == OP_SUBST || rtype == OP_TRANS)
2052 ? (int)rtype : OP_MATCH];
2053 const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV)
2054 ? "@array" : "%hash");
2055 Perl_warner(aTHX_ packWARN(WARN_MISC),
2056 "Applying %s to %s will act on scalar(%s)",
2057 desc, sample, sample);
2060 if (rtype == OP_CONST &&
2061 cSVOPx(right)->op_private & OPpCONST_BARE &&
2062 cSVOPx(right)->op_private & OPpCONST_STRICT)
2064 no_bareword_allowed(right);
2067 ismatchop = rtype == OP_MATCH ||
2068 rtype == OP_SUBST ||
2070 if (ismatchop && right->op_private & OPpTARGET_MY) {
2072 right->op_private &= ~OPpTARGET_MY;
2074 if (!(right->op_flags & OPf_STACKED) && ismatchop) {
2077 right->op_flags |= OPf_STACKED;
2078 if (rtype != OP_MATCH &&
2079 ! (rtype == OP_TRANS &&
2080 right->op_private & OPpTRANS_IDENTICAL))
2081 newleft = mod(left, rtype);
2084 if (right->op_type == OP_TRANS)
2085 o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
2087 o = prepend_elem(rtype, scalar(newleft), right);
2089 return newUNOP(OP_NOT, 0, scalar(o));
2093 return bind_match(type, left,
2094 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
2098 Perl_invert(pTHX_ OP *o)
2102 return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2106 Perl_scope(pTHX_ OP *o)
2110 if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2111 o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2112 o->op_type = OP_LEAVE;
2113 o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2115 else if (o->op_type == OP_LINESEQ) {
2117 o->op_type = OP_SCOPE;
2118 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2119 kid = ((LISTOP*)o)->op_first;
2120 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2123 /* The following deals with things like 'do {1 for 1}' */
2124 kid = kid->op_sibling;
2126 (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
2131 o = newLISTOP(OP_SCOPE, 0, o, NULL);
2137 Perl_block_start(pTHX_ int full)
2140 const int retval = PL_savestack_ix;
2141 pad_block_start(full);
2143 PL_hints &= ~HINT_BLOCK_SCOPE;
2144 SAVECOMPILEWARNINGS();
2145 PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
2150 Perl_block_end(pTHX_ I32 floor, OP *seq)
2153 const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2154 OP* const retval = scalarseq(seq);
2156 CopHINTS_set(&PL_compiling, PL_hints);
2158 PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2167 const PADOFFSET offset = pad_findmy("$_");
2168 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
2169 return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2172 OP * const o = newOP(OP_PADSV, 0);
2173 o->op_targ = offset;
2179 Perl_newPROG(pTHX_ OP *o)
2185 PL_eval_root = newUNOP(OP_LEAVEEVAL,
2186 ((PL_in_eval & EVAL_KEEPERR)
2187 ? OPf_SPECIAL : 0), o);
2188 PL_eval_start = linklist(PL_eval_root);
2189 PL_eval_root->op_private |= OPpREFCOUNTED;
2190 OpREFCNT_set(PL_eval_root, 1);
2191 PL_eval_root->op_next = 0;
2192 CALL_PEEP(PL_eval_start);
2195 if (o->op_type == OP_STUB) {
2196 PL_comppad_name = 0;
2198 S_op_destroy(aTHX_ o);
2201 PL_main_root = scope(sawparens(scalarvoid(o)));
2202 PL_curcop = &PL_compiling;
2203 PL_main_start = LINKLIST(PL_main_root);
2204 PL_main_root->op_private |= OPpREFCOUNTED;
2205 OpREFCNT_set(PL_main_root, 1);
2206 PL_main_root->op_next = 0;
2207 CALL_PEEP(PL_main_start);
2210 /* Register with debugger */
2213 = Perl_get_cvn_flags(aTHX_ STR_WITH_LEN("DB::postponed"), 0);
2217 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2219 call_sv((SV*)cv, G_DISCARD);
2226 Perl_localize(pTHX_ OP *o, I32 lex)
2229 if (o->op_flags & OPf_PARENS)
2230 /* [perl #17376]: this appears to be premature, and results in code such as
2231 C< our(%x); > executing in list mode rather than void mode */
2238 if ( PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ','
2239 && ckWARN(WARN_PARENTHESIS))
2241 char *s = PL_bufptr;
2244 /* some heuristics to detect a potential error */
2245 while (*s && (strchr(", \t\n", *s)))
2249 if (*s && strchr("@$%*", *s) && *++s
2250 && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
2253 while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
2255 while (*s && (strchr(", \t\n", *s)))
2261 if (sigil && (*s == ';' || *s == '=')) {
2262 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2263 "Parentheses missing around \"%s\" list",
2264 lex ? (PL_in_my == KEY_our ? "our" : PL_in_my == KEY_state ? "state" : "my")
2272 o = mod(o, OP_NULL); /* a bit kludgey */
2274 PL_in_my_stash = NULL;
2279 Perl_jmaybe(pTHX_ OP *o)
2281 if (o->op_type == OP_LIST) {
2283 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
2284 o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2290 Perl_fold_constants(pTHX_ register OP *o)
2295 VOL I32 type = o->op_type;
2300 SV * const oldwarnhook = PL_warnhook;
2301 SV * const olddiehook = PL_diehook;
2304 if (PL_opargs[type] & OA_RETSCALAR)
2306 if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2307 o->op_targ = pad_alloc(type, SVs_PADTMP);
2309 /* integerize op, unless it happens to be C<-foo>.
2310 * XXX should pp_i_negate() do magic string negation instead? */
2311 if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2312 && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2313 && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2315 o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2318 if (!(PL_opargs[type] & OA_FOLDCONST))
2323 /* XXX might want a ck_negate() for this */
2324 cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2335 /* XXX what about the numeric ops? */
2336 if (PL_hints & HINT_LOCALE)
2341 goto nope; /* Don't try to run w/ errors */
2343 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2344 const OPCODE type = curop->op_type;
2345 if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2347 type != OP_SCALAR &&
2349 type != OP_PUSHMARK)
2355 curop = LINKLIST(o);
2356 old_next = o->op_next;
2360 oldscope = PL_scopestack_ix;
2361 create_eval_scope(G_FAKINGEVAL);
2363 PL_warnhook = PERL_WARNHOOK_FATAL;
2370 sv = *(PL_stack_sp--);
2371 if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2372 pad_swipe(o->op_targ, FALSE);
2373 else if (SvTEMP(sv)) { /* grab mortal temp? */
2374 SvREFCNT_inc_simple_void(sv);
2379 /* Something tried to die. Abandon constant folding. */
2380 /* Pretend the error never happened. */
2381 sv_setpvn(ERRSV,"",0);
2382 o->op_next = old_next;
2386 /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
2387 PL_warnhook = oldwarnhook;
2388 PL_diehook = olddiehook;
2389 /* XXX note that this croak may fail as we've already blown away
2390 * the stack - eg any nested evals */
2391 Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
2394 PL_warnhook = oldwarnhook;
2395 PL_diehook = olddiehook;
2397 if (PL_scopestack_ix > oldscope)
2398 delete_eval_scope();
2407 if (type == OP_RV2GV)
2408 newop = newGVOP(OP_GV, 0, (GV*)sv);
2410 newop = newSVOP(OP_CONST, 0, (SV*)sv);
2411 op_getmad(o,newop,'f');
2419 Perl_gen_constant_list(pTHX_ register OP *o)
2423 const I32 oldtmps_floor = PL_tmps_floor;
2427 return o; /* Don't attempt to run with errors */
2429 PL_op = curop = LINKLIST(o);
2435 assert (!(curop->op_flags & OPf_SPECIAL));
2436 assert(curop->op_type == OP_RANGE);
2438 PL_tmps_floor = oldtmps_floor;
2440 o->op_type = OP_RV2AV;
2441 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2442 o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
2443 o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
2444 o->op_opt = 0; /* needs to be revisited in peep() */
2445 curop = ((UNOP*)o)->op_first;
2446 ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
2448 op_getmad(curop,o,'O');
2457 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2460 if (!o || o->op_type != OP_LIST)
2461 o = newLISTOP(OP_LIST, 0, o, NULL);
2463 o->op_flags &= ~OPf_WANT;
2465 if (!(PL_opargs[type] & OA_MARK))
2466 op_null(cLISTOPo->op_first);
2468 o->op_type = (OPCODE)type;
2469 o->op_ppaddr = PL_ppaddr[type];
2470 o->op_flags |= flags;
2472 o = CHECKOP(type, o);
2473 if (o->op_type != (unsigned)type)
2476 return fold_constants(o);
2479 /* List constructors */
2482 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2490 if (first->op_type != (unsigned)type
2491 || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2493 return newLISTOP(type, 0, first, last);
2496 if (first->op_flags & OPf_KIDS)
2497 ((LISTOP*)first)->op_last->op_sibling = last;
2499 first->op_flags |= OPf_KIDS;
2500 ((LISTOP*)first)->op_first = last;
2502 ((LISTOP*)first)->op_last = last;
2507 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2515 if (first->op_type != (unsigned)type)
2516 return prepend_elem(type, (OP*)first, (OP*)last);
2518 if (last->op_type != (unsigned)type)
2519 return append_elem(type, (OP*)first, (OP*)last);
2521 first->op_last->op_sibling = last->op_first;
2522 first->op_last = last->op_last;
2523 first->op_flags |= (last->op_flags & OPf_KIDS);
2526 if (last->op_first && first->op_madprop) {
2527 MADPROP *mp = last->op_first->op_madprop;
2529 while (mp->mad_next)
2531 mp->mad_next = first->op_madprop;
2534 last->op_first->op_madprop = first->op_madprop;
2537 first->op_madprop = last->op_madprop;
2538 last->op_madprop = 0;
2541 S_op_destroy(aTHX_ (OP*)last);
2547 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2555 if (last->op_type == (unsigned)type) {
2556 if (type == OP_LIST) { /* already a PUSHMARK there */
2557 first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2558 ((LISTOP*)last)->op_first->op_sibling = first;
2559 if (!(first->op_flags & OPf_PARENS))
2560 last->op_flags &= ~OPf_PARENS;
2563 if (!(last->op_flags & OPf_KIDS)) {
2564 ((LISTOP*)last)->op_last = first;
2565 last->op_flags |= OPf_KIDS;
2567 first->op_sibling = ((LISTOP*)last)->op_first;
2568 ((LISTOP*)last)->op_first = first;
2570 last->op_flags |= OPf_KIDS;
2574 return newLISTOP(type, 0, first, last);
2582 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2585 Newxz(tk, 1, TOKEN);
2586 tk->tk_type = (OPCODE)optype;
2587 tk->tk_type = 12345;
2589 tk->tk_mad = madprop;
2594 Perl_token_free(pTHX_ TOKEN* tk)
2596 if (tk->tk_type != 12345)
2598 mad_free(tk->tk_mad);
2603 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2607 if (tk->tk_type != 12345) {
2608 Perl_warner(aTHX_ packWARN(WARN_MISC),
2609 "Invalid TOKEN object ignored");
2616 /* faked up qw list? */
2618 tm->mad_type == MAD_SV &&
2619 SvPVX((SV*)tm->mad_val)[0] == 'q')
2626 /* pretend constant fold didn't happen? */
2627 if (mp->mad_key == 'f' &&
2628 (o->op_type == OP_CONST ||
2629 o->op_type == OP_GV) )
2631 token_getmad(tk,(OP*)mp->mad_val,slot);
2645 if (mp->mad_key == 'X')
2646 mp->mad_key = slot; /* just change the first one */
2656 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
2665 /* pretend constant fold didn't happen? */
2666 if (mp->mad_key == 'f' &&
2667 (o->op_type == OP_CONST ||
2668 o->op_type == OP_GV) )
2670 op_getmad(from,(OP*)mp->mad_val,slot);
2677 mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
2680 o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
2686 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
2695 /* pretend constant fold didn't happen? */
2696 if (mp->mad_key == 'f' &&
2697 (o->op_type == OP_CONST ||
2698 o->op_type == OP_GV) )
2700 op_getmad(from,(OP*)mp->mad_val,slot);
2707 mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
2710 o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
2714 PerlIO_printf(PerlIO_stderr(),
2715 "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
2721 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
2739 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
2743 addmad(tm, &(o->op_madprop), slot);
2747 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
2768 Perl_newMADsv(pTHX_ char key, SV* sv)
2770 return newMADPROP(key, MAD_SV, sv, 0);
2774 Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
2777 Newxz(mp, 1, MADPROP);
2780 mp->mad_vlen = vlen;
2781 mp->mad_type = type;
2783 /* PerlIO_printf(PerlIO_stderr(), "NEW mp = %0x\n", mp); */
2788 Perl_mad_free(pTHX_ MADPROP* mp)
2790 /* PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
2794 mad_free(mp->mad_next);
2795 /* if (PL_lex_state != LEX_NOTPARSING && mp->mad_vlen)
2796 PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
2797 switch (mp->mad_type) {
2801 Safefree((char*)mp->mad_val);
2804 if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
2805 op_free((OP*)mp->mad_val);
2808 sv_free((SV*)mp->mad_val);
2811 PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
2820 Perl_newNULLLIST(pTHX)
2822 return newOP(OP_STUB, 0);
2826 Perl_force_list(pTHX_ OP *o)
2828 if (!o || o->op_type != OP_LIST)
2829 o = newLISTOP(OP_LIST, 0, o, NULL);
2835 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2840 NewOp(1101, listop, 1, LISTOP);
2842 listop->op_type = (OPCODE)type;
2843 listop->op_ppaddr = PL_ppaddr[type];
2846 listop->op_flags = (U8)flags;
2850 else if (!first && last)
2853 first->op_sibling = last;
2854 listop->op_first = first;
2855 listop->op_last = last;
2856 if (type == OP_LIST) {
2857 OP* const pushop = newOP(OP_PUSHMARK, 0);
2858 pushop->op_sibling = first;
2859 listop->op_first = pushop;
2860 listop->op_flags |= OPf_KIDS;
2862 listop->op_last = pushop;
2865 return CHECKOP(type, listop);
2869 Perl_newOP(pTHX_ I32 type, I32 flags)
2873 NewOp(1101, o, 1, OP);
2874 o->op_type = (OPCODE)type;
2875 o->op_ppaddr = PL_ppaddr[type];
2876 o->op_flags = (U8)flags;
2878 o->op_latefreed = 0;
2882 o->op_private = (U8)(0 | (flags >> 8));
2883 if (PL_opargs[type] & OA_RETSCALAR)
2885 if (PL_opargs[type] & OA_TARGET)
2886 o->op_targ = pad_alloc(type, SVs_PADTMP);
2887 return CHECKOP(type, o);
2891 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2897 first = newOP(OP_STUB, 0);
2898 if (PL_opargs[type] & OA_MARK)
2899 first = force_list(first);
2901 NewOp(1101, unop, 1, UNOP);
2902 unop->op_type = (OPCODE)type;
2903 unop->op_ppaddr = PL_ppaddr[type];
2904 unop->op_first = first;
2905 unop->op_flags = (U8)(flags | OPf_KIDS);
2906 unop->op_private = (U8)(1 | (flags >> 8));
2907 unop = (UNOP*) CHECKOP(type, unop);
2911 return fold_constants((OP *) unop);
2915 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2919 NewOp(1101, binop, 1, BINOP);
2922 first = newOP(OP_NULL, 0);
2924 binop->op_type = (OPCODE)type;
2925 binop->op_ppaddr = PL_ppaddr[type];
2926 binop->op_first = first;
2927 binop->op_flags = (U8)(flags | OPf_KIDS);
2930 binop->op_private = (U8)(1 | (flags >> 8));
2933 binop->op_private = (U8)(2 | (flags >> 8));
2934 first->op_sibling = last;
2937 binop = (BINOP*)CHECKOP(type, binop);
2938 if (binop->op_next || binop->op_type != (OPCODE)type)
2941 binop->op_last = binop->op_first->op_sibling;
2943 return fold_constants((OP *)binop);
2946 static int uvcompare(const void *a, const void *b)
2947 __attribute__nonnull__(1)
2948 __attribute__nonnull__(2)
2949 __attribute__pure__;
2950 static int uvcompare(const void *a, const void *b)
2952 if (*((const UV *)a) < (*(const UV *)b))
2954 if (*((const UV *)a) > (*(const UV *)b))
2956 if (*((const UV *)a+1) < (*(const UV *)b+1))
2958 if (*((const UV *)a+1) > (*(const UV *)b+1))
2964 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2967 SV * const tstr = ((SVOP*)expr)->op_sv;
2970 (repl->op_type == OP_NULL)
2971 ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
2973 ((SVOP*)repl)->op_sv;
2976 const U8 *t = (U8*)SvPV_const(tstr, tlen);
2977 const U8 *r = (U8*)SvPV_const(rstr, rlen);
2981 register short *tbl;
2983 const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
2984 const I32 squash = o->op_private & OPpTRANS_SQUASH;
2985 I32 del = o->op_private & OPpTRANS_DELETE;
2987 PL_hints |= HINT_BLOCK_SCOPE;
2990 o->op_private |= OPpTRANS_FROM_UTF;
2993 o->op_private |= OPpTRANS_TO_UTF;
2995 if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2996 SV* const listsv = newSVpvs("# comment\n");
2998 const U8* tend = t + tlen;
2999 const U8* rend = r + rlen;
3013 const I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
3014 const I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
3017 const U32 flags = UTF8_ALLOW_DEFAULT;
3021 t = tsave = bytes_to_utf8(t, &len);
3024 if (!to_utf && rlen) {
3026 r = rsave = bytes_to_utf8(r, &len);
3030 /* There are several snags with this code on EBCDIC:
3031 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
3032 2. scan_const() in toke.c has encoded chars in native encoding which makes
3033 ranges at least in EBCDIC 0..255 range the bottom odd.
3037 U8 tmpbuf[UTF8_MAXBYTES+1];
3040 Newx(cp, 2*tlen, UV);
3042 transv = newSVpvs("");
3044 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3046 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
3048 cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3052 cp[2*i+1] = cp[2*i];
3056 qsort(cp, i, 2*sizeof(UV), uvcompare);
3057 for (j = 0; j < i; j++) {
3059 diff = val - nextmin;
3061 t = uvuni_to_utf8(tmpbuf,nextmin);
3062 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3064 U8 range_mark = UTF_TO_NATIVE(0xff);
3065 t = uvuni_to_utf8(tmpbuf, val - 1);
3066 sv_catpvn(transv, (char *)&range_mark, 1);
3067 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3074 t = uvuni_to_utf8(tmpbuf,nextmin);
3075 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3077 U8 range_mark = UTF_TO_NATIVE(0xff);
3078 sv_catpvn(transv, (char *)&range_mark, 1);
3080 t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
3081 UNICODE_ALLOW_SUPER);
3082 sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3083 t = (const U8*)SvPVX_const(transv);
3084 tlen = SvCUR(transv);
3088 else if (!rlen && !del) {
3089 r = t; rlen = tlen; rend = tend;
3092 if ((!rlen && !del) || t == r ||
3093 (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
3095 o->op_private |= OPpTRANS_IDENTICAL;
3099 while (t < tend || tfirst <= tlast) {
3100 /* see if we need more "t" chars */
3101 if (tfirst > tlast) {
3102 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3104 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
3106 tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3113 /* now see if we need more "r" chars */
3114 if (rfirst > rlast) {
3116 rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3118 if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
3120 rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3129 rfirst = rlast = 0xffffffff;
3133 /* now see which range will peter our first, if either. */
3134 tdiff = tlast - tfirst;
3135 rdiff = rlast - rfirst;
3142 if (rfirst == 0xffffffff) {
3143 diff = tdiff; /* oops, pretend rdiff is infinite */
3145 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
3146 (long)tfirst, (long)tlast);
3148 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
3152 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
3153 (long)tfirst, (long)(tfirst + diff),
3156 Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3157 (long)tfirst, (long)rfirst);
3159 if (rfirst + diff > max)
3160 max = rfirst + diff;
3162 grows = (tfirst < rfirst &&
3163 UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3175 else if (max > 0xff)
3180 PerlMemShared_free(cPVOPo->op_pv);
3181 cPVOPo->op_pv = NULL;
3183 swash = (SV*)swash_init("utf8", "", listsv, bits, none);
3185 cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
3186 SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
3187 PAD_SETSV(cPADOPo->op_padix, swash);
3190 cSVOPo->op_sv = swash;
3192 SvREFCNT_dec(listsv);
3193 SvREFCNT_dec(transv);
3195 if (!del && havefinal && rlen)
3196 (void)hv_store((HV*)SvRV(swash), "FINAL", 5,
3197 newSVuv((UV)final), 0);
3200 o->op_private |= OPpTRANS_GROWS;
3206 op_getmad(expr,o,'e');
3207 op_getmad(repl,o,'r');
3215 tbl = (short*)cPVOPo->op_pv;
3217 Zero(tbl, 256, short);
3218 for (i = 0; i < (I32)tlen; i++)
3220 for (i = 0, j = 0; i < 256; i++) {
3222 if (j >= (I32)rlen) {
3231 if (i < 128 && r[j] >= 128)
3241 o->op_private |= OPpTRANS_IDENTICAL;
3243 else if (j >= (I32)rlen)
3248 PerlMemShared_realloc(tbl,
3249 (0x101+rlen-j) * sizeof(short));
3250 cPVOPo->op_pv = (char*)tbl;
3252 tbl[0x100] = (short)(rlen - j);
3253 for (i=0; i < (I32)rlen - j; i++)
3254 tbl[0x101+i] = r[j+i];
3258 if (!rlen && !del) {
3261 o->op_private |= OPpTRANS_IDENTICAL;
3263 else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3264 o->op_private |= OPpTRANS_IDENTICAL;
3266 for (i = 0; i < 256; i++)
3268 for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3269 if (j >= (I32)rlen) {
3271 if (tbl[t[i]] == -1)
3277 if (tbl[t[i]] == -1) {
3278 if (t[i] < 128 && r[j] >= 128)
3285 o->op_private |= OPpTRANS_GROWS;
3287 op_getmad(expr,o,'e');
3288 op_getmad(repl,o,'r');
3298 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3303 NewOp(1101, pmop, 1, PMOP);
3304 pmop->op_type = (OPCODE)type;
3305 pmop->op_ppaddr = PL_ppaddr[type];
3306 pmop->op_flags = (U8)flags;
3307 pmop->op_private = (U8)(0 | (flags >> 8));
3309 if (PL_hints & HINT_RE_TAINT)
3310 pmop->op_pmflags |= PMf_RETAINT;
3311 if (PL_hints & HINT_LOCALE)
3312 pmop->op_pmflags |= PMf_LOCALE;
3316 if (av_len((AV*) PL_regex_pad[0]) > -1) {
3317 SV * const repointer = av_pop((AV*)PL_regex_pad[0]);
3318 pmop->op_pmoffset = SvIV(repointer);
3319 SvREPADTMP_off(repointer);
3320 sv_setiv(repointer,0);
3322 SV * const repointer = newSViv(0);
3323 av_push(PL_regex_padav, SvREFCNT_inc_simple_NN(repointer));
3324 pmop->op_pmoffset = av_len(PL_regex_padav);
3325 PL_regex_pad = AvARRAY(PL_regex_padav);
3329 return CHECKOP(type, pmop);
3332 /* Given some sort of match op o, and an expression expr containing a
3333 * pattern, either compile expr into a regex and attach it to o (if it's
3334 * constant), or convert expr into a runtime regcomp op sequence (if it's
3337 * isreg indicates that the pattern is part of a regex construct, eg
3338 * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3339 * split "pattern", which aren't. In the former case, expr will be a list
3340 * if the pattern contains more than one term (eg /a$b/) or if it contains
3341 * a replacement, ie s/// or tr///.
3345 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
3350 I32 repl_has_vars = 0;
3354 if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
3355 /* last element in list is the replacement; pop it */
3357 repl = cLISTOPx(expr)->op_last;
3358 kid = cLISTOPx(expr)->op_first;
3359 while (kid->op_sibling != repl)
3360 kid = kid->op_sibling;
3361 kid->op_sibling = NULL;
3362 cLISTOPx(expr)->op_last = kid;
3365 if (isreg && expr->op_type == OP_LIST &&
3366 cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3368 /* convert single element list to element */
3369 OP* const oe = expr;
3370 expr = cLISTOPx(oe)->op_first->op_sibling;
3371 cLISTOPx(oe)->op_first->op_sibling = NULL;
3372 cLISTOPx(oe)->op_last = NULL;
3376 if (o->op_type == OP_TRANS) {
3377 return pmtrans(o, expr, repl);
3380 reglist = isreg && expr->op_type == OP_LIST;
3384 PL_hints |= HINT_BLOCK_SCOPE;
3387 if (expr->op_type == OP_CONST) {
3389 SV * const pat = ((SVOP*)expr)->op_sv;
3390 const char *p = SvPV_const(pat, plen);
3391 U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
3392 if ((o->op_flags & OPf_SPECIAL) && (plen == 1 && *p == ' ')) {
3393 U32 was_readonly = SvREADONLY(pat);
3397 sv_force_normal_flags(pat, 0);
3398 assert(!SvREADONLY(pat));
3401 SvREADONLY_off(pat);
3405 sv_setpvn(pat, "\\s+", 3);
3407 SvFLAGS(pat) |= was_readonly;
3409 p = SvPV_const(pat, plen);
3410 pm_flags |= RXf_SKIPWHITE;
3413 pm_flags |= RXf_UTF8;
3414 /* FIXME - can we make this function take const char * args? */
3415 PM_SETRE(pm, CALLREGCOMP((char*)p, (char*)p + plen, pm_flags));
3418 op_getmad(expr,(OP*)pm,'e');
3424 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3425 expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3427 : OP_REGCMAYBE),0,expr);
3429 NewOp(1101, rcop, 1, LOGOP);
3430 rcop->op_type = OP_REGCOMP;
3431 rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3432 rcop->op_first = scalar(expr);
3433 rcop->op_flags |= OPf_KIDS
3434 | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3435 | (reglist ? OPf_STACKED : 0);
3436 rcop->op_private = 1;
3439 rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3441 /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
3444 /* establish postfix order */
3445 if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3447 rcop->op_next = expr;
3448 ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3451 rcop->op_next = LINKLIST(expr);
3452 expr->op_next = (OP*)rcop;
3455 prepend_elem(o->op_type, scalar((OP*)rcop), o);
3460 if (pm->op_pmflags & PMf_EVAL) {
3462 if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
3463 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
3465 else if (repl->op_type == OP_CONST)
3469 for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3470 if (curop->op_type == OP_SCOPE
3471 || curop->op_type == OP_LEAVE
3472 || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
3473 if (curop->op_type == OP_GV) {
3474 GV * const gv = cGVOPx_gv(curop);
3476 if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3479 else if (curop->op_type == OP_RV2CV)
3481 else if (curop->op_type == OP_RV2SV ||
3482 curop->op_type == OP_RV2AV ||
3483 curop->op_type == OP_RV2HV ||
3484 curop->op_type == OP_RV2GV) {
3485 if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3488 else if (curop->op_type == OP_PADSV ||
3489 curop->op_type == OP_PADAV ||
3490 curop->op_type == OP_PADHV ||
3491 curop->op_type == OP_PADANY)
3495 else if (curop->op_type == OP_PUSHRE)
3496 NOOP; /* Okay here, dangerous in newASSIGNOP */
3506 || PM_GETRE(pm)->extflags & RXf_EVAL_SEEN)))
3508 pm->op_pmflags |= PMf_CONST; /* const for long enough */
3509 prepend_elem(o->op_type, scalar(repl), o);
3512 if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3513 pm->op_pmflags |= PMf_MAYBE_CONST;
3515 NewOp(1101, rcop, 1, LOGOP);
3516 rcop->op_type = OP_SUBSTCONT;
3517 rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3518 rcop->op_first = scalar(repl);
3519 rcop->op_flags |= OPf_KIDS;
3520 rcop->op_private = 1;
3523 /* establish postfix order */
3524 rcop->op_next = LINKLIST(repl);
3525 repl->op_next = (OP*)rcop;
3527 pm->op_pmreplroot = scalar((OP*)rcop);
3528 assert(!(pm->op_pmflags & PMf_ONCE));
3529 pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
3538 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3542 NewOp(1101, svop, 1, SVOP);
3543 svop->op_type = (OPCODE)type;
3544 svop->op_ppaddr = PL_ppaddr[type];
3546 svop->op_next = (OP*)svop;
3547 svop->op_flags = (U8)flags;
3548 if (PL_opargs[type] & OA_RETSCALAR)
3550 if (PL_opargs[type] & OA_TARGET)
3551 svop->op_targ = pad_alloc(type, SVs_PADTMP);
3552 return CHECKOP(type, svop);
3557 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3561 NewOp(1101, padop, 1, PADOP);
3562 padop->op_type = (OPCODE)type;
3563 padop->op_ppaddr = PL_ppaddr[type];
3564 padop->op_padix = pad_alloc(type, SVs_PADTMP);
3565 SvREFCNT_dec(PAD_SVl(padop->op_padix));
3566 PAD_SETSV(padop->op_padix, sv);
3569 padop->op_next = (OP*)padop;
3570 padop->op_flags = (U8)flags;
3571 if (PL_opargs[type] & OA_RETSCALAR)
3573 if (PL_opargs[type] & OA_TARGET)
3574 padop->op_targ = pad_alloc(type, SVs_PADTMP);
3575 return CHECKOP(type, padop);
3580 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3586 return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3588 return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3593 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3597 NewOp(1101, pvop, 1, PVOP);
3598 pvop->op_type = (OPCODE)type;
3599 pvop->op_ppaddr = PL_ppaddr[type];
3601 pvop->op_next = (OP*)pvop;
3602 pvop->op_flags = (U8)flags;
3603 if (PL_opargs[type] & OA_RETSCALAR)
3605 if (PL_opargs[type] & OA_TARGET)
3606 pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3607 return CHECKOP(type, pvop);
3615 Perl_package(pTHX_ OP *o)
3618 SV *const sv = cSVOPo->op_sv;
3623 save_hptr(&PL_curstash);
3624 save_item(PL_curstname);
3626 PL_curstash = gv_stashsv(sv, GV_ADD);
3627 sv_setsv(PL_curstname, sv);
3629 PL_hints |= HINT_BLOCK_SCOPE;
3630 PL_copline = NOLINE;
3636 if (!PL_madskills) {
3641 pegop = newOP(OP_NULL,0);
3642 op_getmad(o,pegop,'P');
3652 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3659 OP *pegop = newOP(OP_NULL,0);
3662 if (idop->op_type != OP_CONST)
3663 Perl_croak(aTHX_ "Module name must be constant");
3666 op_getmad(idop,pegop,'U');
3671 SV * const vesv = ((SVOP*)version)->op_sv;
3674 op_getmad(version,pegop,'V');
3675 if (!arg && !SvNIOKp(vesv)) {
3682 if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3683 Perl_croak(aTHX_ "Version number must be constant number");
3685 /* Make copy of idop so we don't free it twice */
3686 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3688 /* Fake up a method call to VERSION */
3689 meth = newSVpvs_share("VERSION");
3690 veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3691 append_elem(OP_LIST,
3692 prepend_elem(OP_LIST, pack, list(version)),
3693 newSVOP(OP_METHOD_NAMED, 0, meth)));
3697 /* Fake up an import/unimport */
3698 if (arg && arg->op_type == OP_STUB) {
3700 op_getmad(arg,pegop,'S');
3701 imop = arg; /* no import on explicit () */
3703 else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3704 imop = NULL; /* use 5.0; */
3706 idop->op_private |= OPpCONST_NOVER;
3712 op_getmad(arg,pegop,'A');
3714 /* Make copy of idop so we don't free it twice */
3715 pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3717 /* Fake up a method call to import/unimport */
3719 ? newSVpvs_share("import") : newSVpvs_share("unimport");
3720 imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3721 append_elem(OP_LIST,
3722 prepend_elem(OP_LIST, pack, list(arg)),
3723 newSVOP(OP_METHOD_NAMED, 0, meth)));
3726 /* Fake up the BEGIN {}, which does its thing immediately. */
3728 newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
3731 append_elem(OP_LINESEQ,
3732 append_elem(OP_LINESEQ,
3733 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
3734 newSTATEOP(0, NULL, veop)),
3735 newSTATEOP(0, NULL, imop) ));
3737 /* The "did you use incorrect case?" warning used to be here.
3738 * The problem is that on case-insensitive filesystems one
3739 * might get false positives for "use" (and "require"):
3740 * "use Strict" or "require CARP" will work. This causes
3741 * portability problems for the script: in case-strict
3742 * filesystems the script will stop working.
3744 * The "incorrect case" warning checked whether "use Foo"
3745 * imported "Foo" to your namespace, but that is wrong, too:
3746 * there is no requirement nor promise in the language that
3747 * a Foo.pm should or would contain anything in package "Foo".
3749 * There is very little Configure-wise that can be done, either:
3750 * the case-sensitivity of the build filesystem of Perl does not
3751 * help in guessing the case-sensitivity of the runtime environment.
3754 PL_hints |= HINT_BLOCK_SCOPE;
3755 PL_copline = NOLINE;
3757 PL_cop_seqmax++; /* Purely for B::*'s benefit */
3760 if (!PL_madskills) {
3761 /* FIXME - don't allocate pegop if !PL_madskills */
3770 =head1 Embedding Functions
3772 =for apidoc load_module
3774 Loads the module whose name is pointed to by the string part of name.
3775 Note that the actual module name, not its filename, should be given.
3776 Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
3777 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3778 (or 0 for no flags). ver, if specified, provides version semantics
3779 similar to C<use Foo::Bar VERSION>. The optional trailing SV*
3780 arguments can be used to specify arguments to the module's import()
3781 method, similar to C<use Foo::Bar VERSION LIST>.
3786 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3789 va_start(args, ver);
3790 vload_module(flags, name, ver, &args);
3794 #ifdef PERL_IMPLICIT_CONTEXT
3796 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3800 va_start(args, ver);
3801 vload_module(flags, name, ver, &args);
3807 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3812 OP * const modname = newSVOP(OP_CONST, 0, name);
3813 modname->op_private |= OPpCONST_BARE;
3815 veop = newSVOP(OP_CONST, 0, ver);
3819 if (flags & PERL_LOADMOD_NOIMPORT) {
3820 imop = sawparens(newNULLLIST());
3822 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3823 imop = va_arg(*args, OP*);
3828 sv = va_arg(*args, SV*);
3830 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3831 sv = va_arg(*args, SV*);
3835 const line_t ocopline = PL_copline;
3836 COP * const ocurcop = PL_curcop;
3837 const int oexpect = PL_expect;
3839 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3840 veop, modname, imop);
3841 PL_expect = oexpect;
3842 PL_copline = ocopline;
3843 PL_curcop = ocurcop;
3848 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
3854 if (!force_builtin) {
3855 gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
3856 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
3857 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
3858 gv = gvp ? *gvp : NULL;
3862 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3863 doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3864 append_elem(OP_LIST, term,
3865 scalar(newUNOP(OP_RV2CV, 0,
3866 newGVOP(OP_GV, 0, gv))))));
3869 doop = newUNOP(OP_DOFILE, 0, scalar(term));
3875 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3877 return newBINOP(OP_LSLICE, flags,
3878 list(force_list(subscript)),
3879 list(force_list(listval)) );
3883 S_is_list_assignment(pTHX_ register const OP *o)
3891 if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
3892 o = cUNOPo->op_first;
3894 flags = o->op_flags;
3896 if (type == OP_COND_EXPR) {
3897 const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
3898 const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3903 yyerror("Assignment to both a list and a scalar");
3907 if (type == OP_LIST &&
3908 (flags & OPf_WANT) == OPf_WANT_SCALAR &&
3909 o->op_private & OPpLVAL_INTRO)
3912 if (type == OP_LIST || flags & OPf_PARENS ||
3913 type == OP_RV2AV || type == OP_RV2HV ||
3914 type == OP_ASLICE || type == OP_HSLICE)
3917 if (type == OP_PADAV || type == OP_PADHV)
3920 if (type == OP_RV2SV)
3927 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3933 if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3934 return newLOGOP(optype, 0,
3935 mod(scalar(left), optype),
3936 newUNOP(OP_SASSIGN, 0, scalar(right)));
3939 return newBINOP(optype, OPf_STACKED,
3940 mod(scalar(left), optype), scalar(right));
3944 if (is_list_assignment(left)) {
3948 /* Grandfathering $[ assignment here. Bletch.*/
3949 /* Only simple assignments like C<< ($[) = 1 >> are allowed */
3950 PL_eval_start = (left->op_type == OP_CONST) ? right : 0;
3951 left = mod(left, OP_AASSIGN);
3954 else if (left->op_type == OP_CONST) {
3956 /* Result of assignment is always 1 (or we'd be dead already) */
3957 return newSVOP(OP_CONST, 0, newSViv(1));
3959 curop = list(force_list(left));
3960 o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3961 o->op_private = (U8)(0 | (flags >> 8));
3963 /* PL_generation sorcery:
3964 * an assignment like ($a,$b) = ($c,$d) is easier than
3965 * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3966 * To detect whether there are common vars, the global var
3967 * PL_generation is incremented for each assign op we compile.
3968 * Then, while compiling the assign op, we run through all the
3969 * variables on both sides of the assignment, setting a spare slot
3970 * in each of them to PL_generation. If any of them already have
3971 * that value, we know we've got commonality. We could use a
3972 * single bit marker, but then we'd have to make 2 passes, first
3973 * to clear the flag, then to test and set it. To find somewhere
3974 * to store these values, evil chicanery is done with SvUVX().
3980 for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3981 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3982 if (curop->op_type == OP_GV) {
3983 GV *gv = cGVOPx_gv(curop);
3985 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
3987 GvASSIGN_GENERATION_set(gv, PL_generation);
3989 else if (curop->op_type == OP_PADSV ||
3990 curop->op_type == OP_PADAV ||
3991 curop->op_type == OP_PADHV ||
3992 curop->op_type == OP_PADANY)
3994 if (PAD_COMPNAME_GEN(curop->op_targ)
3995 == (STRLEN)PL_generation)
3997 PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
4000 else if (curop->op_type == OP_RV2CV)
4002 else if (curop->op_type == OP_RV2SV ||
4003 curop->op_type == OP_RV2AV ||
4004 curop->op_type == OP_RV2HV ||
4005 curop->op_type == OP_RV2GV) {
4006 if (lastop->op_type != OP_GV) /* funny deref? */
4009 else if (curop->op_type == OP_PUSHRE) {
4010 if (((PMOP*)curop)->op_pmreplroot) {
4012 GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
4013 ((PMOP*)curop)->op_pmreplroot));
4015 GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
4018 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4020 GvASSIGN_GENERATION_set(gv, PL_generation);
4021 GvASSIGN_GENERATION_set(gv, PL_generation);
4030 o->op_private |= OPpASSIGN_COMMON;
4033 if ( ((left->op_private & OPpLVAL_INTRO) || ckWARN(WARN_MISC))
4034 && (left->op_type == OP_LIST
4035 || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
4037 OP* lop = ((LISTOP*)left)->op_first;
4039 if (lop->op_type == OP_PADSV ||
4040 lop->op_type == OP_PADAV ||
4041 lop->op_type == OP_PADHV ||
4042 lop->op_type == OP_PADANY)
4044 if (lop->op_private & OPpPAD_STATE) {
4045 if (left->op_private & OPpLVAL_INTRO) {
4046 o->op_private |= OPpASSIGN_STATE;
4047 /* hijacking PADSTALE for uninitialized state variables */
4048 SvPADSTALE_on(PAD_SVl(lop->op_targ));
4050 else { /* we already checked for WARN_MISC before */
4051 Perl_warner(aTHX_ packWARN(WARN_MISC), "State variable %s will be reinitialized",
4052 PAD_COMPNAME_PV(lop->op_targ));
4056 lop = lop->op_sibling;
4059 else if (((left->op_private & (OPpLVAL_INTRO | OPpPAD_STATE))
4060 == (OPpLVAL_INTRO | OPpPAD_STATE))
4061 && ( left->op_type == OP_PADSV
4062 || left->op_type == OP_PADAV
4063 || left->op_type == OP_PADHV
4064 || left->op_type == OP_PADANY))
4066 o->op_private |= OPpASSIGN_STATE;
4067 /* hijacking PADSTALE for uninitialized state variables */
4068 SvPADSTALE_on(PAD_SVl(left->op_targ));
4071 if (right && right->op_type == OP_SPLIT) {
4072 OP* tmpop = ((LISTOP*)right)->op_first;
4073 if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
4074 PMOP * const pm = (PMOP*)tmpop;
4075 if (left->op_type == OP_RV2AV &&
4076 !(left->op_private & OPpLVAL_INTRO) &&
4077 !(o->op_private & OPpASSIGN_COMMON) )
4079 tmpop = ((UNOP*)left)->op_first;
4080 if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
4082 pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
4083 cPADOPx(tmpop)->op_padix = 0; /* steal it */
4085 pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
4086 cSVOPx(tmpop)->op_sv = NULL; /* steal it */
4088 pm->op_pmflags |= PMf_ONCE;
4089 tmpop = cUNOPo->op_first; /* to list (nulled) */
4090 tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
4091 tmpop->op_sibling = NULL; /* don't free split */
4092 right->op_next = tmpop->op_next; /* fix starting loc */
4094 op_getmad(o,right,'R'); /* blow off assign */
4096 op_free(o); /* blow off assign */
4098 right->op_flags &= ~OPf_WANT;
4099 /* "I don't know and I don't care." */
4104 if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
4105 ((LISTOP*)right)->op_last->op_type == OP_CONST)
4107 SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
4109 sv_setiv(sv, PL_modcount+1);
4117 right = newOP(OP_UNDEF, 0);
4118 if (right->op_type == OP_READLINE) {
4119 right->op_flags |= OPf_STACKED;
4120 return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
4123 PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/
4124 o = newBINOP(OP_SASSIGN, flags,
4125 scalar(right), mod(scalar(left), OP_SASSIGN) );
4131 o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
4132 o->op_private |= OPpCONST_ARYBASE;
4139 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
4142 const U32 seq = intro_my();
4145 NewOp(1101, cop, 1, COP);
4146 if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
4147 cop->op_type = OP_DBSTATE;
4148 cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
4151 cop->op_type = OP_NEXTSTATE;
4152 cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
4154 cop->op_flags = (U8)flags;
4155 CopHINTS_set(cop, PL_hints);
4157 cop->op_private |= NATIVE_HINTS;
4159 CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
4160 cop->op_next = (OP*)cop;
4163 CopLABEL_set(cop, label);
4164 PL_hints |= HINT_BLOCK_SCOPE;
4167 /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
4168 CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
4170 cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
4171 cop->cop_hints_hash = PL_curcop->cop_hints_hash;
4172 if (cop->cop_hints_hash) {
4174 cop->cop_hints_hash->refcounted_he_refcnt++;
4175 HINTS_REFCNT_UNLOCK;
4178 if (PL_copline == NOLINE)
4179 CopLINE_set(cop, CopLINE(PL_curcop));
4181 CopLINE_set(cop, PL_copline);
4182 PL_copline = NOLINE;
4185 CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */
4187 CopFILEGV_set(cop, CopFILEGV(PL_curcop));
4189 CopSTASH_set(cop, PL_curstash);
4191 if (PERLDB_LINE && PL_curstash != PL_debstash) {
4192 AV *av = CopFILEAVx(PL_curcop);
4194 SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
4195 if (svp && *svp != &PL_sv_undef ) {
4196 (void)SvIOK_on(*svp);
4197 SvIV_set(*svp, PTR2IV(cop));
4202 return prepend_elem(OP_LINESEQ, (OP*)cop, o);
4207 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
4210 return new_logop(type, flags, &first, &other);
4214 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
4219 OP *first = *firstp;
4220 OP * const other = *otherp;
4222 if (type == OP_XOR) /* Not short circuit, but here by precedence. */
4223 return newBINOP(type, flags, scalar(first), scalar(other));
4225 scalarboolean(first);
4226 /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
4227 if (first->op_type == OP_NOT
4228 && (first->op_flags & OPf_SPECIAL)
4229 && (first->op_flags & OPf_KIDS)) {
4230 if (type == OP_AND || type == OP_OR) {
4236 first = *firstp = cUNOPo->op_first;
4238 first->op_next = o->op_next;
4239 cUNOPo->op_first = NULL;
4241 op_getmad(o,first,'O');
4247 if (first->op_type == OP_CONST) {
4248 if (first->op_private & OPpCONST_STRICT)
4249 no_bareword_allowed(first);
4250 else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
4251 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
4252 if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) ||
4253 (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) ||
4254 (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
4256 if (other->op_type == OP_CONST)
4257 other->op_private |= OPpCONST_SHORTCIRCUIT;
4259 OP *newop = newUNOP(OP_NULL, 0, other);
4260 op_getmad(first, newop, '1');
4261 newop->op_targ = type; /* set "was" field */
4268 /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
4269 const OP *o2 = other;
4270 if ( ! (o2->op_type == OP_LIST
4271 && (( o2 = cUNOPx(o2)->op_first))
4272 && o2->op_type == OP_PUSHMARK
4273 && (( o2 = o2->op_sibling)) )
4276 if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
4277 || o2->op_type == OP_PADHV)
4278 && o2->op_private & OPpLVAL_INTRO
4279 && ckWARN(WARN_DEPRECATED))
4281 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4282 "Deprecated use of my() in false conditional");
4286 if (first->op_type == OP_CONST)
4287 first->op_private |= OPpCONST_SHORTCIRCUIT;
4289 first = newUNOP(OP_NULL, 0, first);
4290 op_getmad(other, first, '2');
4291 first->op_targ = type; /* set "was" field */
4298 else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
4299 && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
4301 const OP * const k1 = ((UNOP*)first)->op_first;
4302 const OP * const k2 = k1->op_sibling;
4304 switch (first->op_type)
4307 if (k2 && k2->op_type == OP_READLINE
4308 && (k2->op_flags & OPf_STACKED)
4309 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4311 warnop = k2->op_type;
4316 if (k1->op_type == OP_READDIR
4317 || k1->op_type == OP_GLOB
4318 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4319 || k1->op_type == OP_EACH)
4321 warnop = ((k1->op_type == OP_NULL)
4322 ? (OPCODE)k1->op_targ : k1->op_type);
4327 const line_t oldline = CopLINE(PL_curcop);
4328 CopLINE_set(PL_curcop, PL_copline);
4329 Perl_warner(aTHX_ packWARN(WARN_MISC),
4330 "Value of %s%s can be \"0\"; test with defined()",
4332 ((warnop == OP_READLINE || warnop == OP_GLOB)
4333 ? " construct" : "() operator"));
4334 CopLINE_set(PL_curcop, oldline);
4341 if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
4342 other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
4344 NewOp(1101, logop, 1, LOGOP);
4346 logop->op_type = (OPCODE)type;
4347 logop->op_ppaddr = PL_ppaddr[type];
4348 logop->op_first = first;
4349 logop->op_flags = (U8)(flags | OPf_KIDS);
4350 logop->op_other = LINKLIST(other);
4351 logop->op_private = (U8)(1 | (flags >> 8));
4353 /* establish postfix order */
4354 logop->op_next = LINKLIST(first);
4355 first->op_next = (OP*)logop;
4356 first->op_sibling = other;
4358 CHECKOP(type,logop);
4360 o = newUNOP(OP_NULL, 0, (OP*)logop);
4367 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
4375 return newLOGOP(OP_AND, 0, first, trueop);
4377 return newLOGOP(OP_OR, 0, first, falseop);
4379 scalarboolean(first);
4380 if (first->op_type == OP_CONST) {
4381 /* Left or right arm of the conditional? */
4382 const bool left = SvTRUE(((SVOP*)first)->op_sv);
4383 OP *live = left ? trueop : falseop;
4384 OP *const dead = left ? falseop : trueop;
4385 if (first->op_private & OPpCONST_BARE &&
4386 first->op_private & OPpCONST_STRICT) {
4387 no_bareword_allowed(first);
4390 /* This is all dead code when PERL_MAD is not defined. */
4391 live = newUNOP(OP_NULL, 0, live);
4392 op_getmad(first, live, 'C');
4393 op_getmad(dead, live, left ? 'e' : 't');
4400 NewOp(1101, logop, 1, LOGOP);
4401 logop->op_type = OP_COND_EXPR;
4402 logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4403 logop->op_first = first;
4404 logop->op_flags = (U8)(flags | OPf_KIDS);
4405 logop->op_private = (U8)(1 | (flags >> 8));
4406 logop->op_other = LINKLIST(trueop);
4407 logop->op_next = LINKLIST(falseop);
4409 CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
4412 /* establish postfix order */
4413 start = LINKLIST(first);
4414 first->op_next = (OP*)logop;
4416 first->op_sibling = trueop;
4417 trueop->op_sibling = falseop;
4418 o = newUNOP(OP_NULL, 0, (OP*)logop);
4420 trueop->op_next = falseop->op_next = o;
4427 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4436 NewOp(1101, range, 1, LOGOP);
4438 range->op_type = OP_RANGE;
4439 range->op_ppaddr = PL_ppaddr[OP_RANGE];
4440 range->op_first = left;
4441 range->op_flags = OPf_KIDS;
4442 leftstart = LINKLIST(left);
4443 range->op_other = LINKLIST(right);
4444 range->op_private = (U8)(1 | (flags >> 8));
4446 left->op_sibling = right;
4448 range->op_next = (OP*)range;
4449 flip = newUNOP(OP_FLIP, flags, (OP*)range);
4450 flop = newUNOP(OP_FLOP, 0, flip);
4451 o = newUNOP(OP_NULL, 0, flop);
4453 range->op_next = leftstart;
4455 left->op_next = flip;
4456 right->op_next = flop;
4458 range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4459 sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4460 flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4461 sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4463 flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4464 flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4467 if (!flip->op_private || !flop->op_private)
4468 linklist(o); /* blow off optimizer unless constant */
4474 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4479 const bool once = block && block->op_flags & OPf_SPECIAL &&
4480 (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4482 PERL_UNUSED_ARG(debuggable);
4485 if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4486 return block; /* do {} while 0 does once */
4487 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4488 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4489 expr = newUNOP(OP_DEFINED, 0,
4490 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4491 } else if (expr->op_flags & OPf_KIDS) {
4492 const OP * const k1 = ((UNOP*)expr)->op_first;
4493 const OP * const k2 = k1 ? k1->op_sibling : NULL;
4494 switch (expr->op_type) {
4496 if (k2 && k2->op_type == OP_READLINE
4497 && (k2->op_flags & OPf_STACKED)
4498 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4499 expr = newUNOP(OP_DEFINED, 0, expr);
4503 if (k1 && (k1->op_type == OP_READDIR
4504 || k1->op_type == OP_GLOB
4505 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4506 || k1->op_type == OP_EACH))
4507 expr = newUNOP(OP_DEFINED, 0, expr);
4513 /* if block is null, the next append_elem() would put UNSTACK, a scalar
4514 * op, in listop. This is wrong. [perl #27024] */
4516 block = newOP(OP_NULL, 0);
4517 listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4518 o = new_logop(OP_AND, 0, &expr, &listop);
4521 ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4523 if (once && o != listop)
4524 o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4527 o = newUNOP(OP_NULL, 0, o); /* or do {} while 1 loses outer block */
4529 o->op_flags |= flags;
4531 o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4536 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
4537 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
4546 PERL_UNUSED_ARG(debuggable);
4549 if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4550 || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4551 expr = newUNOP(OP_DEFINED, 0,
4552 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4553 } else if (expr->op_flags & OPf_KIDS) {
4554 const OP * const k1 = ((UNOP*)expr)->op_first;
4555 const OP * const k2 = (k1) ? k1->op_sibling : NULL;
4556 switch (expr->op_type) {
4558 if (k2 && k2->op_type == OP_READLINE
4559 && (k2->op_flags & OPf_STACKED)
4560 && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4561 expr = newUNOP(OP_DEFINED, 0, expr);
4565 if (k1 && (k1->op_type == OP_READDIR
4566 || k1->op_type == OP_GLOB
4567 || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4568 || k1->op_type == OP_EACH))
4569 expr = newUNOP(OP_DEFINED, 0, expr);
4576 block = newOP(OP_NULL, 0);
4577 else if (cont || has_my) {
4578 block = scope(block);
4582 next = LINKLIST(cont);
4585 OP * const unstack = newOP(OP_UNSTACK, 0);
4588 cont = append_elem(OP_LINESEQ, cont, unstack);
4592 listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4594 redo = LINKLIST(listop);
4597 PL_copline = (line_t)whileline;
4599 o = new_logop(OP_AND, 0, &expr, &listop);
4600 if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4601 op_free(expr); /* oops, it's a while (0) */
4603 return NULL; /* listop already freed by new_logop */
4606 ((LISTOP*)listop)->op_last->op_next =
4607 (o == listop ? redo : LINKLIST(o));
4613 NewOp(1101,loop,1,LOOP);
4614 loop->op_type = OP_ENTERLOOP;
4615 loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4616 loop->op_private = 0;
4617 loop->op_next = (OP*)loop;
4620 o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4622 loop->op_redoop = redo;
4623 loop->op_lastop = o;
4624 o->op_private |= loopflags;
4627 loop->op_nextop = next;
4629 loop->op_nextop = o;
4631 o->op_flags |= flags;
4632 o->op_private |= (flags >> 8);
4637 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
4642 PADOFFSET padoff = 0;
4648 if (sv->op_type == OP_RV2SV) { /* symbol table variable */
4649 iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
4650 sv->op_type = OP_RV2GV;
4651 sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4653 /* The op_type check is needed to prevent a possible segfault
4654 * if the loop variable is undeclared and 'strict vars' is in
4655 * effect. This is illegal but is nonetheless parsed, so we
4656 * may reach this point with an OP_CONST where we're expecting
4659 if (cUNOPx(sv)->op_first->op_type == OP_GV
4660 && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
4661 iterpflags |= OPpITER_DEF;
4663 else if (sv->op_type == OP_PADSV) { /* private variable */
4664 iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
4665 padoff = sv->op_targ;
4675 Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4677 SV *const namesv = PAD_COMPNAME_SV(padoff);
4679 const char *const name = SvPV_const(namesv, len);
4681 if (len == 2 && name[0] == '$' && name[1] == '_')
4682 iterpflags |= OPpITER_DEF;
4686 const PADOFFSET offset = pad_findmy("$_");
4687 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
4688 sv = newGVOP(OP_GV, 0, PL_defgv);
4693 iterpflags |= OPpITER_DEF;
4695 if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4696 expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4697 iterflags |= OPf_STACKED;
4699 else if (expr->op_type == OP_NULL &&
4700 (expr->op_flags & OPf_KIDS) &&
4701 ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4703 /* Basically turn for($x..$y) into the same as for($x,$y), but we
4704 * set the STACKED flag to indicate that these values are to be
4705 * treated as min/max values by 'pp_iterinit'.
4707 const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4708 LOGOP* const range = (LOGOP*) flip->op_first;
4709 OP* const left = range->op_first;
4710 OP* const right = left->op_sibling;
4713 range->op_flags &= ~OPf_KIDS;
4714 range->op_first = NULL;
4716 listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4717 listop->op_first->op_next = range->op_next;
4718 left->op_next = range->op_other;
4719 right->op_next = (OP*)listop;
4720 listop->op_next = listop->op_first;
4723 op_getmad(expr,(OP*)listop,'O');
4727 expr = (OP*)(listop);
4729 iterflags |= OPf_STACKED;
4732 expr = mod(force_list(expr), OP_GREPSTART);
4735 loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4736 append_elem(OP_LIST, expr, scalar(sv))));
4737 assert(!loop->op_next);
4738 /* for my $x () sets OPpLVAL_INTRO;
4739 * for our $x () sets OPpOUR_INTRO */
4740 loop->op_private = (U8)iterpflags;
4741 #ifdef PL_OP_SLAB_ALLOC
4744 NewOp(1234,tmp,1,LOOP);
4745 Copy(loop,tmp,1,LISTOP);
4746 S_op_destroy(aTHX_ (OP*)loop);
4750 loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
4752 loop->op_targ = padoff;
4753 wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
4755 op_getmad(madsv, (OP*)loop, 'v');
4756 PL_copline = forline;
4757 return newSTATEOP(0, label, wop);
4761 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4766 if (type != OP_GOTO || label->op_type == OP_CONST) {
4767 /* "last()" means "last" */
4768 if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4769 o = newOP(type, OPf_SPECIAL);
4771 o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
4772 ? SvPVx_nolen_const(((SVOP*)label)->op_sv)
4776 op_getmad(label,o,'L');
4782 /* Check whether it's going to be a goto &function */
4783 if (label->op_type == OP_ENTERSUB
4784 && !(label->op_flags & OPf_STACKED))
4785 label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4786 o = newUNOP(type, OPf_STACKED, label);
4788 PL_hints |= HINT_BLOCK_SCOPE;
4792 /* if the condition is a literal array or hash
4793 (or @{ ... } etc), make a reference to it.
4796 S_ref_array_or_hash(pTHX_ OP *cond)
4799 && (cond->op_type == OP_RV2AV
4800 || cond->op_type == OP_PADAV
4801 || cond->op_type == OP_RV2HV
4802 || cond->op_type == OP_PADHV))
4804 return newUNOP(OP_REFGEN,
4805 0, mod(cond, OP_REFGEN));
4811 /* These construct the optree fragments representing given()
4814 entergiven and enterwhen are LOGOPs; the op_other pointer
4815 points up to the associated leave op. We need this so we
4816 can put it in the context and make break/continue work.
4817 (Also, of course, pp_enterwhen will jump straight to
4818 op_other if the match fails.)
4822 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
4823 I32 enter_opcode, I32 leave_opcode,
4824 PADOFFSET entertarg)
4830 NewOp(1101, enterop, 1, LOGOP);
4831 enterop->op_type = enter_opcode;
4832 enterop->op_ppaddr = PL_ppaddr[enter_opcode];
4833 enterop->op_flags = (U8) OPf_KIDS;
4834 enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
4835 enterop->op_private = 0;
4837 o = newUNOP(leave_opcode, 0, (OP *) enterop);
4840 enterop->op_first = scalar(cond);
4841 cond->op_sibling = block;
4843 o->op_next = LINKLIST(cond);
4844 cond->op_next = (OP *) enterop;
4847 /* This is a default {} block */
4848 enterop->op_first = block;
4849 enterop->op_flags |= OPf_SPECIAL;
4851 o->op_next = (OP *) enterop;
4854 CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
4855 entergiven and enterwhen both
4858 enterop->op_next = LINKLIST(block);
4859 block->op_next = enterop->op_other = o;
4864 /* Does this look like a boolean operation? For these purposes
4865 a boolean operation is:
4866 - a subroutine call [*]
4867 - a logical connective
4868 - a comparison operator
4869 - a filetest operator, with the exception of -s -M -A -C
4870 - defined(), exists() or eof()
4871 - /$re/ or $foo =~ /$re/
4873 [*] possibly surprising
4876 S_looks_like_bool(pTHX_ const OP *o)
4879 switch(o->op_type) {
4881 return looks_like_bool(cLOGOPo->op_first);
4885 looks_like_bool(cLOGOPo->op_first)
4886 && looks_like_bool(cLOGOPo->op_first->op_sibling));
4890 case OP_NOT: case OP_XOR:
4891 /* Note that OP_DOR is not here */
4893 case OP_EQ: case OP_NE: case OP_LT:
4894 case OP_GT: case OP_LE: case OP_GE:
4896 case OP_I_EQ: case OP_I_NE: case OP_I_LT:
4897 case OP_I_GT: case OP_I_LE: case OP_I_GE:
4899 case OP_SEQ: case OP_SNE: case OP_SLT:
4900 case OP_SGT: case OP_SLE: case OP_SGE:
4904 case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
4905 case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
4906 case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
4907 case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
4908 case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
4909 case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
4910 case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
4911 case OP_FTTEXT: case OP_FTBINARY:
4913 case OP_DEFINED: case OP_EXISTS:
4914 case OP_MATCH: case OP_EOF:
4919 /* Detect comparisons that have been optimized away */
4920 if (cSVOPo->op_sv == &PL_sv_yes
4921 || cSVOPo->op_sv == &PL_sv_no)
4932 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
4936 return newGIVWHENOP(
4937 ref_array_or_hash(cond),
4939 OP_ENTERGIVEN, OP_LEAVEGIVEN,
4943 /* If cond is null, this is a default {} block */
4945 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
4947 const bool cond_llb = (!cond || looks_like_bool(cond));
4953 cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
4955 scalar(ref_array_or_hash(cond)));
4958 return newGIVWHENOP(
4960 append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
4961 OP_ENTERWHEN, OP_LEAVEWHEN, 0);
4965 =for apidoc cv_undef
4967 Clear out all the active components of a CV. This can happen either
4968 by an explicit C<undef &foo>, or by the reference count going to zero.
4969 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
4970 children can still follow the full lexical scope chain.
4976 Perl_cv_undef(pTHX_ CV *cv)
4980 if (CvFILE(cv) && !CvISXSUB(cv)) {
4981 /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4982 Safefree(CvFILE(cv));
4987 if (!CvISXSUB(cv) && CvROOT(cv)) {
4988 if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
4989 Perl_croak(aTHX_ "Can't undef active subroutine");
4992 PAD_SAVE_SETNULLPAD();
4994 op_free(CvROOT(cv));
4999 SvPOK_off((SV*)cv); /* forget prototype */
5004 /* remove CvOUTSIDE unless this is an undef rather than a free */
5005 if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
5006 if (!CvWEAKOUTSIDE(cv))
5007 SvREFCNT_dec(CvOUTSIDE(cv));
5008 CvOUTSIDE(cv) = NULL;
5011 SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
5014 if (CvISXSUB(cv) && CvXSUB(cv)) {
5017 /* delete all flags except WEAKOUTSIDE */
5018 CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
5022 Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
5025 /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
5026 relying on SvCUR, and doubling up the buffer to hold CvFILE(). */
5027 if (((!p != !SvPOK(cv)) /* One has prototype, one has not. */
5028 || (p && (len != SvCUR(cv) /* Not the same length. */
5029 || memNE(p, SvPVX_const(cv), len))))
5030 && ckWARN_d(WARN_PROTOTYPE)) {
5031 SV* const msg = sv_newmortal();
5035 gv_efullname3(name = sv_newmortal(), gv, NULL);
5036 sv_setpvs(msg, "Prototype mismatch:");
5038 Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
5040 Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv));
5042 sv_catpvs(msg, ": none");
5043 sv_catpvs(msg, " vs ");
5045 Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
5047 sv_catpvs(msg, "none");
5048 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
5052 static void const_sv_xsub(pTHX_ CV* cv);
5056 =head1 Optree Manipulation Functions
5058 =for apidoc cv_const_sv
5060 If C<cv> is a constant sub eligible for inlining. returns the constant
5061 value returned by the sub. Otherwise, returns NULL.
5063 Constant subs can be created with C<newCONSTSUB> or as described in
5064 L<perlsub/"Constant Functions">.
5069 Perl_cv_const_sv(pTHX_ CV *cv)
5071 PERL_UNUSED_CONTEXT;
5074 if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
5076 return CvCONST(cv) ? (SV*)CvXSUBANY(cv).any_ptr : NULL;
5079 /* op_const_sv: examine an optree to determine whether it's in-lineable.
5080 * Can be called in 3 ways:
5083 * look for a single OP_CONST with attached value: return the value
5085 * cv && CvCLONE(cv) && !CvCONST(cv)
5087 * examine the clone prototype, and if contains only a single
5088 * OP_CONST referencing a pad const, or a single PADSV referencing
5089 * an outer lexical, return a non-zero value to indicate the CV is
5090 * a candidate for "constizing" at clone time
5094 * We have just cloned an anon prototype that was marked as a const
5095 * candidiate. Try to grab the current value, and in the case of
5096 * PADSV, ignore it if it has multiple references. Return the value.
5100 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
5108 if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
5109 o = cLISTOPo->op_first->op_sibling;
5111 for (; o; o = o->op_next) {
5112 const OPCODE type = o->op_type;
5114 if (sv && o->op_next == o)
5116 if (o->op_next != o) {
5117 if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
5119 if (type == OP_DBSTATE)
5122 if (type == OP_LEAVESUB || type == OP_RETURN)
5126 if (type == OP_CONST && cSVOPo->op_sv)
5128 else if (cv && type == OP_CONST) {
5129 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5133 else if (cv && type == OP_PADSV) {
5134 if (CvCONST(cv)) { /* newly cloned anon */
5135 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
5136 /* the candidate should have 1 ref from this pad and 1 ref
5137 * from the parent */
5138 if (!sv || SvREFCNT(sv) != 2)
5145 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
5146 sv = &PL_sv_undef; /* an arbitrary non-null value */
5161 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5164 /* This would be the return value, but the return cannot be reached. */
5165 OP* pegop = newOP(OP_NULL, 0);
5168 PERL_UNUSED_ARG(floor);
5178 Perl_croak(aTHX_ "\"my sub\" not yet implemented");
5180 NORETURN_FUNCTION_END;
5185 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
5187 return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
5191 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
5198 register CV *cv = NULL;
5200 /* If the subroutine has no body, no attributes, and no builtin attributes
5201 then it's just a sub declaration, and we may be able to get away with
5202 storing with a placeholder scalar in the symbol table, rather than a
5203 full GV and CV. If anything is present then it will take a full CV to
5205 const I32 gv_fetch_flags
5206 = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5208 ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
5209 const char * const name = o ? SvPVx_nolen_const(cSVOPo->op_sv) : NULL;
5212 assert(proto->op_type == OP_CONST);
5213 ps = SvPVx_const(((SVOP*)proto)->op_sv, ps_len);
5218 if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
5219 SV * const sv = sv_newmortal();
5220 Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
5221 PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
5222 CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
5223 aname = SvPVX_const(sv);
5228 gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
5229 : gv_fetchpv(aname ? aname
5230 : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5231 gv_fetch_flags, SVt_PVCV);
5233 if (!PL_madskills) {
5242 if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at
5243 maximum a prototype before. */
5244 if (SvTYPE(gv) > SVt_NULL) {
5245 if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
5246 && ckWARN_d(WARN_PROTOTYPE))
5248 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
5250 cv_ckproto_len((CV*)gv, NULL, ps, ps_len);
5253 sv_setpvn((SV*)gv, ps, ps_len);
5255 sv_setiv((SV*)gv, -1);
5256 SvREFCNT_dec(PL_compcv);
5257 cv = PL_compcv = NULL;
5258 PL_sub_generation++;
5262 cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
5264 #ifdef GV_UNIQUE_CHECK
5265 if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
5266 Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
5270 if (!block || !ps || *ps || attrs
5271 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
5273 || block->op_type == OP_NULL
5278 const_sv = op_const_sv(block, NULL);
5281 const bool exists = CvROOT(cv) || CvXSUB(cv);
5283 #ifdef GV_UNIQUE_CHECK
5284 if (exists && GvUNIQUE(gv)) {
5285 Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
5289 /* if the subroutine doesn't exist and wasn't pre-declared
5290 * with a prototype, assume it will be AUTOLOADed,
5291 * skipping the prototype check
5293 if (exists || SvPOK(cv))
5294 cv_ckproto_len(cv, gv, ps, ps_len);
5295 /* already defined (or promised)? */
5296 if (exists || GvASSUMECV(gv)) {
5299 || block->op_type == OP_NULL
5302 if (CvFLAGS(PL_compcv)) {
5303 /* might have had built-in attrs applied */
5304 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5306 /* just a "sub foo;" when &foo is already defined */
5307 SAVEFREESV(PL_compcv);
5312 && block->op_type != OP_NULL
5315 if (ckWARN(WARN_REDEFINE)
5317 && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
5319 const line_t oldline = CopLINE(PL_curcop);
5320 if (PL_copline != NOLINE)
5321 CopLINE_set(PL_curcop, PL_copline);
5322 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5323 CvCONST(cv) ? "Constant subroutine %s redefined"
5324 : "Subroutine %s redefined", name);
5325 CopLINE_set(PL_curcop, oldline);
5328 if (!PL_minus_c) /* keep old one around for madskills */
5331 /* (PL_madskills unset in used file.) */
5339 SvREFCNT_inc_simple_void_NN(const_sv);
5341 assert(!CvROOT(cv) && !CvCONST(cv));
5342 sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
5343 CvXSUBANY(cv).any_ptr = const_sv;
5344 CvXSUB(cv) = const_sv_xsub;
5350 cv = newCONSTSUB(NULL, name, const_sv);
5352 PL_sub_generation++;
5356 SvREFCNT_dec(PL_compcv);
5364 /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
5365 * before we clobber PL_compcv.
5369 || block->op_type == OP_NULL
5373 /* Might have had built-in attributes applied -- propagate them. */
5374 CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
5375 if (CvGV(cv) && GvSTASH(CvGV(cv)))
5376 stash = GvSTASH(CvGV(cv));
5377 else if (CvSTASH(cv))
5378 stash = CvSTASH(cv);
5380 stash = PL_curstash;
5383 /* possibly about to re-define existing subr -- ignore old cv */
5384 rcv = (SV*)PL_compcv;
5385 if (name && GvSTASH(gv))
5386 stash = GvSTASH(gv);
5388 stash = PL_curstash;
5390 apply_attrs(stash, rcv, attrs, FALSE);
5392 if (cv) { /* must reuse cv if autoloaded */
5399 || block->op_type == OP_NULL) && !PL_madskills
5402 /* got here with just attrs -- work done, so bug out */
5403 SAVEFREESV(PL_compcv);
5406 /* transfer PL_compcv to cv */
5408 CvFLAGS(cv) = CvFLAGS(PL_compcv);
5409 if (!CvWEAKOUTSIDE(cv))
5410 SvREFCNT_dec(CvOUTSIDE(cv));
5411 CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
5412 CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
5413 CvOUTSIDE(PL_compcv) = 0;
5414 CvPADLIST(cv) = CvPADLIST(PL_compcv);
5415 CvPADLIST(PL_compcv) = 0;
5416 /* inner references to PL_compcv must be fixed up ... */
5417 pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
5418 /* ... before we throw it away */
5419 SvREFCNT_dec(PL_compcv);
5421 if (PERLDB_INTER)/* Advice debugger on the new sub. */
5422 ++PL_sub_generation;
5429 if (strEQ(name, "import")) {
5430 PL_formfeed = (SV*)cv;
5431 Perl_warner(aTHX_ packWARN(WARN_VOID), "%lx\n", (long)cv);
5435 PL_sub_generation++;
5439 CvFILE_set_from_cop(cv, PL_curcop);
5440 CvSTASH(cv) = PL_curstash;
5443 sv_setpvn((SV*)cv, ps, ps_len);
5445 if (PL_error_count) {
5449 const char *s = strrchr(name, ':');
5451 if (strEQ(s, "BEGIN")) {
5452 const char not_safe[] =
5453 "BEGIN not safe after errors--compilation aborted";
5454 if (PL_in_eval & EVAL_KEEPERR)
5455 Perl_croak(aTHX_ not_safe);
5457 /* force display of errors found but not reported */
5458 sv_catpv(ERRSV, not_safe);
5459 Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
5469 CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5470 mod(scalarseq(block), OP_LEAVESUBLV));
5471 block->op_attached = 1;
5474 /* This makes sub {}; work as expected. */
5475 if (block->op_type == OP_STUB) {
5476 OP* const newblock = newSTATEOP(0, NULL, 0);
5478 op_getmad(block,newblock,'B');
5485 block->op_attached = 1;
5486 CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5488 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5489 OpREFCNT_set(CvROOT(cv), 1);
5490 CvSTART(cv) = LINKLIST(CvROOT(cv));
5491 CvROOT(cv)->op_next = 0;
5492 CALL_PEEP(CvSTART(cv));
5494 /* now that optimizer has done its work, adjust pad values */
5496 pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
5499 assert(!CvCONST(cv));
5500 if (ps && !*ps && op_const_sv(block, cv))
5504 if (name || aname) {
5505 if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5506 SV * const sv = newSV(0);
5507 SV * const tmpstr = sv_newmortal();
5508 GV * const db_postponed = gv_fetchpvs("DB::postponed",
5509 GV_ADDMULTI, SVt_PVHV);
5512 Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5514 (long)PL_subline, (long)CopLINE(PL_curcop));
5515 gv_efullname3(tmpstr, gv, NULL);
5516 hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0);
5517 hv = GvHVn(db_postponed);
5518 if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
5519 CV * const pcv = GvCV(db_postponed);
5525 call_sv((SV*)pcv, G_DISCARD);
5530 if (name && !PL_error_count)
5531 process_special_blocks(name, gv, cv);
5535 PL_copline = NOLINE;
5541 S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
5544 const char *const colon = strrchr(fullname,':');
5545 const char *const name = colon ? colon + 1 : fullname;
5548 if (strEQ(name, "BEGIN")) {
5549 const I32 oldscope = PL_scopestack_ix;
5551 SAVECOPFILE(&PL_compiling);
5552 SAVECOPLINE(&PL_compiling);
5554 DEBUG_x( dump_sub(gv) );
5555 Perl_av_create_and_push(aTHX_ &PL_beginav, (SV*)cv);
5556 GvCV(gv) = 0; /* cv has been hijacked */
5557 call_list(oldscope, PL_beginav);
5559 PL_curcop = &PL_compiling;
5560 CopHINTS_set(&PL_compiling, PL_hints);
5567 if strEQ(name, "END") {
5568 DEBUG_x( dump_sub(gv) );
5569 Perl_av_create_and_unshift_one(aTHX_ &PL_endav, (SV*)cv);
5572 } else if (*name == 'U') {
5573 if (strEQ(name, "UNITCHECK")) {
5574 /* It's never too late to run a unitcheck block */
5575 Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, (SV*)cv);
5579 } else if (*name == 'C') {
5580 if (strEQ(name, "CHECK")) {
5581 if (PL_main_start && ckWARN(WARN_VOID))
5582 Perl_warner(aTHX_ packWARN(WARN_VOID),
5583 "Too late to run CHECK block");
5584 Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, (SV*)cv);
5588 } else if (*name == 'I') {
5589 if (strEQ(name, "INIT")) {
5590 if (PL_main_start && ckWARN(WARN_VOID))
5591 Perl_warner(aTHX_ packWARN(WARN_VOID),
5592 "Too late to run INIT block");
5593 Perl_av_create_and_push(aTHX_ &PL_initav, (SV*)cv);
5599 DEBUG_x( dump_sub(gv) );
5600 GvCV(gv) = 0; /* cv has been hijacked */
5605 =for apidoc newCONSTSUB
5607 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5608 eligible for inlining at compile-time.
5614 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
5619 const char *const temp_p = CopFILE(PL_curcop);
5620 const STRLEN len = temp_p ? strlen(temp_p) : 0;
5622 SV *const temp_sv = CopFILESV(PL_curcop);
5624 const char *const temp_p = temp_sv ? SvPV_const(temp_sv, len) : NULL;
5626 char *const file = savepvn(temp_p, temp_p ? len : 0);
5630 SAVECOPLINE(PL_curcop);
5631 CopLINE_set(PL_curcop, PL_copline);
5634 PL_hints &= ~HINT_BLOCK_SCOPE;
5637 SAVESPTR(PL_curstash);
5638 SAVECOPSTASH(PL_curcop);
5639 PL_curstash = stash;
5640 CopSTASH_set(PL_curcop,stash);
5643 /* file becomes the CvFILE. For an XS, it's supposed to be static storage,
5644 and so doesn't get free()d. (It's expected to be from the C pre-
5645 processor __FILE__ directive). But we need a dynamically allocated one,
5646 and we need it to get freed. */
5647 cv = newXS_flags(name, const_sv_xsub, file, "", XS_DYNAMIC_FILENAME);
5648 CvXSUBANY(cv).any_ptr = sv;
5654 CopSTASH_free(PL_curcop);
5662 Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr,
5663 const char *const filename, const char *const proto,
5666 CV *cv = newXS(name, subaddr, filename);
5668 if (flags & XS_DYNAMIC_FILENAME) {
5669 /* We need to "make arrangements" (ie cheat) to ensure that the
5670 filename lasts as long as the PVCV we just created, but also doesn't
5672 STRLEN filename_len = strlen(filename);
5673 STRLEN proto_and_file_len = filename_len;
5674 char *proto_and_file;
5678 proto_len = strlen(proto);
5679 proto_and_file_len += proto_len;
5681 Newx(proto_and_file, proto_and_file_len + 1, char);
5682 Copy(proto, proto_and_file, proto_len, char);
5683 Copy(filename, proto_and_file + proto_len, filename_len + 1, char);
5686 proto_and_file = savepvn(filename, filename_len);
5689 /* This gets free()d. :-) */
5690 sv_usepvn_flags((SV*)cv, proto_and_file, proto_and_file_len,
5691 SV_HAS_TRAILING_NUL);
5693 /* This gives us the correct prototype, rather than one with the
5694 file name appended. */
5695 SvCUR_set(cv, proto_len);
5699 CvFILE(cv) = proto_and_file + proto_len;
5701 sv_setpv((SV *)cv, proto);
5707 =for apidoc U||newXS
5709 Used by C<xsubpp> to hook up XSUBs as Perl subs. I<filename> needs to be
5710 static storage, as it is used directly as CvFILE(), without a copy being made.
5716 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
5719 GV * const gv = gv_fetchpv(name ? name :
5720 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5721 GV_ADDMULTI, SVt_PVCV);
5725 Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
5727 if ((cv = (name ? GvCV(gv) : NULL))) {
5729 /* just a cached method */
5733 else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5734 /* already defined (or promised) */
5735 /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
5736 if (ckWARN(WARN_REDEFINE)) {
5737 GV * const gvcv = CvGV(cv);
5739 HV * const stash = GvSTASH(gvcv);
5741 const char *redefined_name = HvNAME_get(stash);
5742 if ( strEQ(redefined_name,"autouse") ) {
5743 const line_t oldline = CopLINE(PL_curcop);
5744 if (PL_copline != NOLINE)
5745 CopLINE_set(PL_curcop, PL_copline);
5746 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5747 CvCONST(cv) ? "Constant subroutine %s redefined"
5748 : "Subroutine %s redefined"
5750 CopLINE_set(PL_curcop, oldline);
5760 if (cv) /* must reuse cv if autoloaded */
5763 cv = (CV*)newSV_type(SVt_PVCV);
5767 PL_sub_generation++;
5771 (void)gv_fetchfile(filename);
5772 CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
5773 an external constant string */
5775 CvXSUB(cv) = subaddr;
5778 process_special_blocks(name, gv, cv);
5790 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5795 OP* pegop = newOP(OP_NULL, 0);
5799 ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
5800 : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
5802 #ifdef GV_UNIQUE_CHECK
5804 Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5808 if ((cv = GvFORM(gv))) {
5809 if (ckWARN(WARN_REDEFINE)) {
5810 const line_t oldline = CopLINE(PL_curcop);
5811 if (PL_copline != NOLINE)
5812 CopLINE_set(PL_curcop, PL_copline);
5813 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5814 o ? "Format %"SVf" redefined"
5815 : "Format STDOUT redefined", SVfARG(cSVOPo->op_sv));
5816 CopLINE_set(PL_curcop, oldline);
5823 CvFILE_set_from_cop(cv, PL_curcop);
5826 pad_tidy(padtidy_FORMAT);
5827 CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5828 CvROOT(cv)->op_private |= OPpREFCOUNTED;
5829 OpREFCNT_set(CvROOT(cv), 1);
5830 CvSTART(cv) = LINKLIST(CvROOT(cv));
5831 CvROOT(cv)->op_next = 0;
5832 CALL_PEEP(CvSTART(cv));
5834 op_getmad(o,pegop,'n');
5835 op_getmad_weak(block, pegop, 'b');
5839 PL_copline = NOLINE;
5847 Perl_newANONLIST(pTHX_ OP *o)
5849 return convert(OP_ANONLIST, OPf_SPECIAL, o);
5853 Perl_newANONHASH(pTHX_ OP *o)
5855 return convert(OP_ANONHASH, OPf_SPECIAL, o);
5859 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5861 return newANONATTRSUB(floor, proto, NULL, block);
5865 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5867 return newUNOP(OP_REFGEN, 0,
5868 newSVOP(OP_ANONCODE, 0,
5869 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5873 Perl_oopsAV(pTHX_ OP *o)
5876 switch (o->op_type) {
5878 o->op_type = OP_PADAV;
5879 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5880 return ref(o, OP_RV2AV);
5883 o->op_type = OP_RV2AV;
5884 o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5889 if (ckWARN_d(WARN_INTERNAL))
5890 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
5897 Perl_oopsHV(pTHX_ OP *o)
5900 switch (o->op_type) {
5903 o->op_type = OP_PADHV;
5904 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5905 return ref(o, OP_RV2HV);
5909 o->op_type = OP_RV2HV;
5910 o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5915 if (ckWARN_d(WARN_INTERNAL))
5916 Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
5923 Perl_newAVREF(pTHX_ OP *o)
5926 if (o->op_type == OP_PADANY) {
5927 o->op_type = OP_PADAV;
5928 o->op_ppaddr = PL_ppaddr[OP_PADAV];
5931 else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5932 && ckWARN(WARN_DEPRECATED)) {
5933 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5934 "Using an array as a reference is deprecated");
5936 return newUNOP(OP_RV2AV, 0, scalar(o));
5940 Perl_newGVREF(pTHX_ I32 type, OP *o)
5942 if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5943 return newUNOP(OP_NULL, 0, o);
5944 return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5948 Perl_newHVREF(pTHX_ OP *o)
5951 if (o->op_type == OP_PADANY) {
5952 o->op_type = OP_PADHV;
5953 o->op_ppaddr = PL_ppaddr[OP_PADHV];
5956 else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5957 && ckWARN(WARN_DEPRECATED)) {
5958 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5959 "Using a hash as a reference is deprecated");
5961 return newUNOP(OP_RV2HV, 0, scalar(o));
5965 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5967 return newUNOP(OP_RV2CV, flags, scalar(o));
5971 Perl_newSVREF(pTHX_ OP *o)
5974 if (o->op_type == OP_PADANY) {
5975 o->op_type = OP_PADSV;
5976 o->op_ppaddr = PL_ppaddr[OP_PADSV];
5979 return newUNOP(OP_RV2SV, 0, scalar(o));
5982 /* Check routines. See the comments at the top of this file for details
5983 * on when these are called */
5986 Perl_ck_anoncode(pTHX_ OP *o)
5988 cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type);
5990 cSVOPo->op_sv = NULL;
5995 Perl_ck_bitop(pTHX_ OP *o)
5998 #define OP_IS_NUMCOMPARE(op) \
5999 ((op) == OP_LT || (op) == OP_I_LT || \
6000 (op) == OP_GT || (op) == OP_I_GT || \
6001 (op) == OP_LE || (op) == OP_I_LE || \
6002 (op) == OP_GE || (op) == OP_I_GE || \
6003 (op) == OP_EQ || (op) == OP_I_EQ || \
6004 (op) == OP_NE || (op) == OP_I_NE || \
6005 (op) == OP_NCMP || (op) == OP_I_NCMP)
6006 o->op_private = (U8)(PL_hints & HINT_INTEGER);
6007 if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
6008 && (o->op_type == OP_BIT_OR
6009 || o->op_type == OP_BIT_AND
6010 || o->op_type == OP_BIT_XOR))
6012 const OP * const left = cBINOPo->op_first;
6013 const OP * const right = left->op_sibling;
6014 if ((OP_IS_NUMCOMPARE(left->op_type) &&
6015 (left->op_flags & OPf_PARENS) == 0) ||
6016 (OP_IS_NUMCOMPARE(right->op_type) &&
6017 (right->op_flags & OPf_PARENS) == 0))
6018 if (ckWARN(WARN_PRECEDENCE))
6019 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
6020 "Possible precedence problem on bitwise %c operator",
6021 o->op_type == OP_BIT_OR ? '|'
6022 : o->op_type == OP_BIT_AND ? '&' : '^'
6029 Perl_ck_concat(pTHX_ OP *o)
6031 const OP * const kid = cUNOPo->op_first;
6032 PERL_UNUSED_CONTEXT;
6033 if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
6034 !(kUNOP->op_first->op_flags & OPf_MOD))
6035 o->op_flags |= OPf_STACKED;
6040 Perl_ck_spair(pTHX_ OP *o)
6043 if (o->op_flags & OPf_KIDS) {
6046 const OPCODE type = o->op_type;
6047 o = modkids(ck_fun(o), type);
6048 kid = cUNOPo->op_first;
6049 newop = kUNOP->op_first->op_sibling;
6051 const OPCODE type = newop->op_type;
6052 if (newop->op_sibling || !(PL_opargs[type] & OA_RETSCALAR) ||
6053 type == OP_PADAV || type == OP_PADHV ||
6054 type == OP_RV2AV || type == OP_RV2HV)
6058 op_getmad(kUNOP->op_first,newop,'K');
6060 op_free(kUNOP->op_first);
6062 kUNOP->op_first = newop;
6064 o->op_ppaddr = PL_ppaddr[++o->op_type];
6069 Perl_ck_delete(pTHX_ OP *o)
6073 if (o->op_flags & OPf_KIDS) {
6074 OP * const kid = cUNOPo->op_first;
6075 switch (kid->op_type) {
6077 o->op_flags |= OPf_SPECIAL;
6080 o->op_private |= OPpSLICE;
6083 o->op_flags |= OPf_SPECIAL;
6088 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
6097 Perl_ck_die(pTHX_ OP *o)
6100 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6106 Perl_ck_eof(pTHX_ OP *o)
6110 if (o->op_flags & OPf_KIDS) {
6111 if (cLISTOPo->op_first->op_type == OP_STUB) {
6113 = newUNOP(o->op_type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
6115 op_getmad(o,newop,'O');
6127 Perl_ck_eval(pTHX_ OP *o)
6130 PL_hints |= HINT_BLOCK_SCOPE;
6131 if (o->op_flags & OPf_KIDS) {
6132 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6135 o->op_flags &= ~OPf_KIDS;
6138 else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
6144 cUNOPo->op_first = 0;
6149 NewOp(1101, enter, 1, LOGOP);
6150 enter->op_type = OP_ENTERTRY;
6151 enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
6152 enter->op_private = 0;
6154 /* establish postfix order */
6155 enter->op_next = (OP*)enter;
6157 o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
6158 o->op_type = OP_LEAVETRY;
6159 o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
6160 enter->op_other = o;
6161 op_getmad(oldo,o,'O');
6175 o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
6176 op_getmad(oldo,o,'O');
6178 o->op_targ = (PADOFFSET)PL_hints;
6179 if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
6180 /* Store a copy of %^H that pp_entereval can pick up.
6181 OPf_SPECIAL flags the opcode as being for this purpose,
6182 so that it in turn will return a copy at every
6184 OP *hhop = newSVOP(OP_CONST, OPf_SPECIAL,
6185 (SV*)Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv)));
6186 cUNOPo->op_first->op_sibling = hhop;
6187 o->op_private |= OPpEVAL_HAS_HH;
6193 Perl_ck_exit(pTHX_ OP *o)
6196 HV * const table = GvHV(PL_hintgv);
6198 SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
6199 if (svp && *svp && SvTRUE(*svp))
6200 o->op_private |= OPpEXIT_VMSISH;
6202 if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
6208 Perl_ck_exec(pTHX_ OP *o)
6210 if (o->op_flags & OPf_STACKED) {
6213 kid = cUNOPo->op_first->op_sibling;
6214 if (kid->op_type == OP_RV2GV)
6223 Perl_ck_exists(pTHX_ OP *o)
6227 if (o->op_flags & OPf_KIDS) {
6228 OP * const kid = cUNOPo->op_first;
6229 if (kid->op_type == OP_ENTERSUB) {
6230 (void) ref(kid, o->op_type);
6231 if (kid->op_type != OP_RV2CV && !PL_error_count)
6232 Perl_croak(aTHX_ "%s argument is not a subroutine name",
6234 o->op_private |= OPpEXISTS_SUB;
6236 else if (kid->op_type == OP_AELEM)
6237 o->op_flags |= OPf_SPECIAL;
6238 else if (kid->op_type != OP_HELEM)
6239 Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
6247 Perl_ck_rvconst(pTHX_ register OP *o)
6250 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6252 o->op_private |= (PL_hints & HINT_STRICT_REFS);
6253 if (o->op_type == OP_RV2CV)
6254 o->op_private &= ~1;
6256 if (kid->op_type == OP_CONST) {
6259 SV * const kidsv = kid->op_sv;
6261 /* Is it a constant from cv_const_sv()? */
6262 if (SvROK(kidsv) && SvREADONLY(kidsv)) {
6263 SV * const rsv = SvRV(kidsv);
6264 const svtype type = SvTYPE(rsv);
6265 const char *badtype = NULL;
6267 switch (o->op_type) {
6269 if (type > SVt_PVMG)
6270 badtype = "a SCALAR";
6273 if (type != SVt_PVAV)
6274 badtype = "an ARRAY";
6277 if (type != SVt_PVHV)
6281 if (type != SVt_PVCV)
6286 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
6289 else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
6290 (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
6291 /* If this is an access to a stash, disable "strict refs", because
6292 * stashes aren't auto-vivified at compile-time (unless we store
6293 * symbols in them), and we don't want to produce a run-time
6294 * stricture error when auto-vivifying the stash. */
6295 const char *s = SvPV_nolen(kidsv);
6296 const STRLEN l = SvCUR(kidsv);
6297 if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
6298 o->op_private &= ~HINT_STRICT_REFS;
6300 if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
6301 const char *badthing;
6302 switch (o->op_type) {
6304 badthing = "a SCALAR";
6307 badthing = "an ARRAY";
6310 badthing = "a HASH";
6318 "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use",
6319 SVfARG(kidsv), badthing);
6322 * This is a little tricky. We only want to add the symbol if we
6323 * didn't add it in the lexer. Otherwise we get duplicate strict
6324 * warnings. But if we didn't add it in the lexer, we must at
6325 * least pretend like we wanted to add it even if it existed before,
6326 * or we get possible typo warnings. OPpCONST_ENTERED says
6327 * whether the lexer already added THIS instance of this symbol.
6329 iscv = (o->op_type == OP_RV2CV) * 2;
6331 gv = gv_fetchsv(kidsv,
6332 iscv | !(kid->op_private & OPpCONST_ENTERED),
6335 : o->op_type == OP_RV2SV
6337 : o->op_type == OP_RV2AV
6339 : o->op_type == OP_RV2HV
6342 } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
6344 kid->op_type = OP_GV;
6345 SvREFCNT_dec(kid->op_sv);
6347 /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
6348 kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
6349 SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
6351 PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc_simple_NN(gv));
6353 kid->op_sv = SvREFCNT_inc_simple_NN(gv);
6355 kid->op_private = 0;
6356 kid->op_ppaddr = PL_ppaddr[OP_GV];
6363 Perl_ck_ftst(pTHX_ OP *o)
6366 const I32 type = o->op_type;
6368 if (o->op_flags & OPf_REF) {
6371 else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
6372 SVOP * const kid = (SVOP*)cUNOPo->op_first;
6373 const OPCODE kidtype = kid->op_type;
6375 if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6376 OP * const newop = newGVOP(type, OPf_REF,
6377 gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
6379 op_getmad(o,newop,'O');
6385 if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o))
6386 o->op_private |= OPpFT_ACCESS;
6387 if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst)
6388 && kidtype != OP_STAT && kidtype != OP_LSTAT)
6389 o->op_private |= OPpFT_STACKED;
6397 if (type == OP_FTTTY)
6398 o = newGVOP(type, OPf_REF, PL_stdingv);
6400 o = newUNOP(type, 0, newDEFSVOP());
6401 op_getmad(oldo,o,'O');
6407 Perl_ck_fun(pTHX_ OP *o)
6410 const int type = o->op_type;
6411 register I32 oa = PL_opargs[type] >> OASHIFT;
6413 if (o->op_flags & OPf_STACKED) {
6414 if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
6417 return no_fh_allowed(o);
6420 if (o->op_flags & OPf_KIDS) {
6421 OP **tokid = &cLISTOPo->op_first;
6422 register OP *kid = cLISTOPo->op_first;
6426 if (kid->op_type == OP_PUSHMARK ||
6427 (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
6429 tokid = &kid->op_sibling;
6430 kid = kid->op_sibling;
6432 if (!kid && PL_opargs[type] & OA_DEFGV)
6433 *tokid = kid = newDEFSVOP();
6437 sibl = kid->op_sibling;
6439 if (!sibl && kid->op_type == OP_STUB) {
6446 /* list seen where single (scalar) arg expected? */
6447 if (numargs == 1 && !(oa >> 4)
6448 && kid->op_type == OP_LIST && type != OP_SCALAR)
6450 return too_many_arguments(o,PL_op_desc[type]);
6463 if ((type == OP_PUSH || type == OP_UNSHIFT)
6464 && !kid->op_sibling && ckWARN(WARN_SYNTAX))
6465 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6466 "Useless use of %s with no values",
6469 if (kid->op_type == OP_CONST &&
6470 (kid->op_private & OPpCONST_BARE))
6472 OP * const newop = newAVREF(newGVOP(OP_GV, 0,
6473 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
6474 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6475 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6476 "Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
6477 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6479 op_getmad(kid,newop,'K');
6484 kid->op_sibling = sibl;
6487 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
6488 bad_type(numargs, "array", PL_op_desc[type], kid);
6492 if (kid->op_type == OP_CONST &&
6493 (kid->op_private & OPpCONST_BARE))
6495 OP * const newop = newHVREF(newGVOP(OP_GV, 0,
6496 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
6497 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
6498 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6499 "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
6500 SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
6502 op_getmad(kid,newop,'K');
6507 kid->op_sibling = sibl;
6510 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
6511 bad_type(numargs, "hash", PL_op_desc[type], kid);
6516 OP * const newop = newUNOP(OP_NULL, 0, kid);
6517 kid->op_sibling = 0;
6519 newop->op_next = newop;
6521 kid->op_sibling = sibl;
6526 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
6527 if (kid->op_type == OP_CONST &&
6528 (kid->op_private & OPpCONST_BARE))
6530 OP * const newop = newGVOP(OP_GV, 0,
6531 gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
6532 if (!(o->op_private & 1) && /* if not unop */
6533 kid == cLISTOPo->op_last)
6534 cLISTOPo->op_last = newop;
6536 op_getmad(kid,newop,'K');
6542 else if (kid->op_type == OP_READLINE) {
6543 /* neophyte patrol: open(<FH>), close(<FH>) etc. */
6544 bad_type(numargs, "HANDLE", OP_DESC(o), kid);
6547 I32 flags = OPf_SPECIAL;
6551 /* is this op a FH constructor? */
6552 if (is_handle_constructor(o,numargs)) {
6553 const char *name = NULL;
6557 /* Set a flag to tell rv2gv to vivify
6558 * need to "prove" flag does not mean something
6559 * else already - NI-S 1999/05/07
6562 if (kid->op_type == OP_PADSV) {
6564 = PAD_COMPNAME_SV(kid->op_targ);
6565 name = SvPV_const(namesv, len);
6567 else if (kid->op_type == OP_RV2SV
6568 && kUNOP->op_first->op_type == OP_GV)
6570 GV * const gv = cGVOPx_gv(kUNOP->op_first);
6572 len = GvNAMELEN(gv);
6574 else if (kid->op_type == OP_AELEM
6575 || kid->op_type == OP_HELEM)
6578 OP *op = ((BINOP*)kid)->op_first;
6582 const char * const a =
6583 kid->op_type == OP_AELEM ?
6585 if (((op->op_type == OP_RV2AV) ||
6586 (op->op_type == OP_RV2HV)) &&
6587 (firstop = ((UNOP*)op)->op_first) &&
6588 (firstop->op_type == OP_GV)) {
6589 /* packagevar $a[] or $h{} */
6590 GV * const gv = cGVOPx_gv(firstop);
6598 else if (op->op_type == OP_PADAV
6599 || op->op_type == OP_PADHV) {
6600 /* lexicalvar $a[] or $h{} */
6601 const char * const padname =
6602 PAD_COMPNAME_PV(op->op_targ);
6611 name = SvPV_const(tmpstr, len);
6616 name = "__ANONIO__";
6623 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
6624 namesv = PAD_SVl(targ);
6625 SvUPGRADE(namesv, SVt_PV);
6627 sv_setpvn(namesv, "$", 1);
6628 sv_catpvn(namesv, name, len);
6631 kid->op_sibling = 0;
6632 kid = newUNOP(OP_RV2GV, flags, scalar(kid));
6633 kid->op_targ = targ;
6634 kid->op_private |= priv;
6636 kid->op_sibling = sibl;
6642 mod(scalar(kid), type);
6646 tokid = &kid->op_sibling;
6647 kid = kid->op_sibling;
6650 if (kid && kid->op_type != OP_STUB)
6651 return too_many_arguments(o,OP_DESC(o));
6652 o->op_private |= numargs;
6654 /* FIXME - should the numargs move as for the PERL_MAD case? */
6655 o->op_private |= numargs;
6657 return too_many_arguments(o,OP_DESC(o));
6661 else if (PL_opargs[type] & OA_DEFGV) {
6663 OP *newop = newUNOP(type, 0, newDEFSVOP());
6664 op_getmad(o,newop,'O');
6667 /* Ordering of these two is important to keep f_map.t passing. */
6669 return newUNOP(type, 0, newDEFSVOP());
6674 while (oa & OA_OPTIONAL)
6676 if (oa && oa != OA_LIST)
6677 return too_few_arguments(o,OP_DESC(o));
6683 Perl_ck_glob(pTHX_ OP *o)
6689 if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
6690 append_elem(OP_GLOB, o, newDEFSVOP());
6692 if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
6693 && GvCVu(gv) && GvIMPORTED_CV(gv)))
6695 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6698 #if !defined(PERL_EXTERNAL_GLOB)
6699 /* XXX this can be tightened up and made more failsafe. */
6700 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
6703 Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
6704 newSVpvs("File::Glob"), NULL, NULL, NULL);
6705 gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
6706 glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
6707 GvCV(gv) = GvCV(glob_gv);
6708 SvREFCNT_inc_void((SV*)GvCV(gv));
6709 GvIMPORTED_CV_on(gv);
6712 #endif /* PERL_EXTERNAL_GLOB */
6714 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6715 append_elem(OP_GLOB, o,
6716 newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
6717 o->op_type = OP_LIST;
6718 o->op_ppaddr = PL_ppaddr[OP_LIST];
6719 cLISTOPo->op_first->op_type = OP_PUSHMARK;
6720 cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
6721 cLISTOPo->op_first->op_targ = 0;
6722 o = newUNOP(OP_ENTERSUB, OPf_STACKED,
6723 append_elem(OP_LIST, o,
6724 scalar(newUNOP(OP_RV2CV, 0,
6725 newGVOP(OP_GV, 0, gv)))));
6726 o = newUNOP(OP_NULL, 0, ck_subr(o));
6727 o->op_targ = OP_GLOB; /* hint at what it used to be */
6730 gv = newGVgen("main");
6732 append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
6738 Perl_ck_grep(pTHX_ OP *o)
6743 const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
6746 o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
6747 /* don't allocate gwop here, as we may leak it if PL_error_count > 0 */
6749 if (o->op_flags & OPf_STACKED) {
6752 kid = cLISTOPo->op_first->op_sibling;
6753 if (!cUNOPx(kid)->op_next)
6754 Perl_croak(aTHX_ "panic: ck_grep");
6755 for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
6758 NewOp(1101, gwop, 1, LOGOP);
6759 kid->op_next = (OP*)gwop;
6760 o->op_flags &= ~OPf_STACKED;
6762 kid = cLISTOPo->op_first->op_sibling;
6763 if (type == OP_MAPWHILE)
6770 kid = cLISTOPo->op_first->op_sibling;
6771 if (kid->op_type != OP_NULL)
6772 Perl_croak(aTHX_ "panic: ck_grep");
6773 kid = kUNOP->op_first;
6776 NewOp(1101, gwop, 1, LOGOP);
6777 gwop->op_type = type;
6778 gwop->op_ppaddr = PL_ppaddr[type];
6779 gwop->op_first = listkids(o);
6780 gwop->op_flags |= OPf_KIDS;
6781 gwop->op_other = LINKLIST(kid);
6782 kid->op_next = (OP*)gwop;
6783 offset = pad_findmy("$_");
6784 if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
6785 o->op_private = gwop->op_private = 0;
6786 gwop->op_targ = pad_alloc(type, SVs_PADTMP);
6789 o->op_private = gwop->op_private = OPpGREP_LEX;
6790 gwop->op_targ = o->op_targ = offset;
6793 kid = cLISTOPo->op_first->op_sibling;
6794 if (!kid || !kid->op_sibling)
6795 return too_few_arguments(o,OP_DESC(o));
6796 for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
6797 mod(kid, OP_GREPSTART);
6803 Perl_ck_index(pTHX_ OP *o)
6805 if (o->op_flags & OPf_KIDS) {
6806 OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
6808 kid = kid->op_sibling; /* get past "big" */
6809 if (kid && kid->op_type == OP_CONST)
6810 fbm_compile(((SVOP*)kid)->op_sv, 0);
6816 Perl_ck_lengthconst(pTHX_ OP *o)
6818 /* XXX length optimization goes here */
6823 Perl_ck_lfun(pTHX_ OP *o)
6825 const OPCODE type = o->op_type;
6826 return modkids(ck_fun(o), type);
6830 Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
6832 if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
6833 switch (cUNOPo->op_first->op_type) {
6835 /* This is needed for
6836 if (defined %stash::)
6837 to work. Do not break Tk.
6839 break; /* Globals via GV can be undef */
6841 case OP_AASSIGN: /* Is this a good idea? */
6842 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6843 "defined(@array) is deprecated");
6844 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6845 "\t(Maybe you should just omit the defined()?)\n");
6848 /* This is needed for
6849 if (defined %stash::)
6850 to work. Do not break Tk.
6852 break; /* Globals via GV can be undef */
6854 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6855 "defined(%%hash) is deprecated");
6856 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6857 "\t(Maybe you should just omit the defined()?)\n");
6868 Perl_ck_readline(pTHX_ OP *o)
6870 if (!(o->op_flags & OPf_KIDS)) {
6872 = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
6874 op_getmad(o,newop,'O');
6884 Perl_ck_rfun(pTHX_ OP *o)
6886 const OPCODE type = o->op_type;
6887 return refkids(ck_fun(o), type);
6891 Perl_ck_listiob(pTHX_ OP *o)
6895 kid = cLISTOPo->op_first;
6898 kid = cLISTOPo->op_first;
6900 if (kid->op_type == OP_PUSHMARK)
6901 kid = kid->op_sibling;
6902 if (kid && o->op_flags & OPf_STACKED)
6903 kid = kid->op_sibling;
6904 else if (kid && !kid->op_sibling) { /* print HANDLE; */
6905 if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6906 o->op_flags |= OPf_STACKED; /* make it a filehandle */
6907 kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6908 cLISTOPo->op_first->op_sibling = kid;
6909 cLISTOPo->op_last = kid;
6910 kid = kid->op_sibling;
6915 append_elem(o->op_type, o, newDEFSVOP());
6921 Perl_ck_smartmatch(pTHX_ OP *o)
6924 if (0 == (o->op_flags & OPf_SPECIAL)) {
6925 OP *first = cBINOPo->op_first;
6926 OP *second = first->op_sibling;
6928 /* Implicitly take a reference to an array or hash */
6929 first->op_sibling = NULL;
6930 first = cBINOPo->op_first = ref_array_or_hash(first);
6931 second = first->op_sibling = ref_array_or_hash(second);
6933 /* Implicitly take a reference to a regular expression */
6934 if (first->op_type == OP_MATCH) {
6935 first->op_type = OP_QR;
6936 first->op_ppaddr = PL_ppaddr[OP_QR];
6938 if (second->op_type == OP_MATCH) {
6939 second->op_type = OP_QR;
6940 second->op_ppaddr = PL_ppaddr[OP_QR];
6949 Perl_ck_sassign(pTHX_ OP *o)
6951 OP * const kid = cLISTOPo->op_first;
6952 /* has a disposable target? */
6953 if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6954 && !(kid->op_flags & OPf_STACKED)
6955 /* Cannot steal the second time! */
6956 && !(kid->op_private & OPpTARGET_MY))
6958 OP * const kkid = kid->op_sibling;
6960 /* Can just relocate the target. */
6961 if (kkid && kkid->op_type == OP_PADSV
6962 && !(kkid->op_private & OPpLVAL_INTRO))
6964 kid->op_targ = kkid->op_targ;
6966 /* Now we do not need PADSV and SASSIGN. */
6967 kid->op_sibling = o->op_sibling; /* NULL */
6968 cLISTOPo->op_first = NULL;
6970 op_getmad(o,kid,'O');
6971 op_getmad(kkid,kid,'M');
6976 kid->op_private |= OPpTARGET_MY; /* Used for context settings */
6980 if (kid->op_sibling) {
6981 OP *kkid = kid->op_sibling;
6982 if (kkid->op_type == OP_PADSV
6983 && (kkid->op_private & OPpLVAL_INTRO)
6984 && SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
6985 o->op_private |= OPpASSIGN_STATE;
6986 /* hijacking PADSTALE for uninitialized state variables */
6987 SvPADSTALE_on(PAD_SVl(kkid->op_targ));
6994 Perl_ck_match(pTHX_ OP *o)
6997 if (o->op_type != OP_QR && PL_compcv) {
6998 const PADOFFSET offset = pad_findmy("$_");
6999 if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
7000 o->op_targ = offset;
7001 o->op_private |= OPpTARGET_MY;
7004 if (o->op_type == OP_MATCH || o->op_type == OP_QR)
7005 o->op_private |= OPpRUNTIME;
7010 Perl_ck_method(pTHX_ OP *o)
7012 OP * const kid = cUNOPo->op_first;
7013 if (kid->op_type == OP_CONST) {
7014 SV* sv = kSVOP->op_sv;
7015 const char * const method = SvPVX_const(sv);
7016 if (!(strchr(method, ':') || strchr(method, '\''))) {
7018 if (!SvREADONLY(sv) || !SvFAKE(sv)) {
7019 sv = newSVpvn_share(method, SvCUR(sv), 0);
7022 kSVOP->op_sv = NULL;
7024 cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
7026 op_getmad(o,cmop,'O');
7037 Perl_ck_null(pTHX_ OP *o)
7039 PERL_UNUSED_CONTEXT;
7044 Perl_ck_open(pTHX_ OP *o)
7047 HV * const table = GvHV(PL_hintgv);
7049 SV **svp = hv_fetchs(table, "open_IN", FALSE);
7051 const I32 mode = mode_from_discipline(*svp);
7052 if (mode & O_BINARY)
7053 o->op_private |= OPpOPEN_IN_RAW;
7054 else if (mode & O_TEXT)
7055 o->op_private |= OPpOPEN_IN_CRLF;
7058 svp = hv_fetchs(table, "open_OUT", FALSE);
7060 const I32 mode = mode_from_discipline(*svp);
7061 if (mode & O_BINARY)
7062 o->op_private |= OPpOPEN_OUT_RAW;
7063 else if (mode & O_TEXT)
7064 o->op_private |= OPpOPEN_OUT_CRLF;
7067 if (o->op_type == OP_BACKTICK) {
7068 if (!(o->op_flags & OPf_KIDS)) {
7069 OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
7071 op_getmad(o,newop,'O');
7080 /* In case of three-arg dup open remove strictness
7081 * from the last arg if it is a bareword. */
7082 OP * const first = cLISTOPx(o)->op_first; /* The pushmark. */
7083 OP * const last = cLISTOPx(o)->op_last; /* The bareword. */
7087 if ((last->op_type == OP_CONST) && /* The bareword. */
7088 (last->op_private & OPpCONST_BARE) &&
7089 (last->op_private & OPpCONST_STRICT) &&
7090 (oa = first->op_sibling) && /* The fh. */
7091 (oa = oa->op_sibling) && /* The mode. */
7092 (oa->op_type == OP_CONST) &&
7093 SvPOK(((SVOP*)oa)->op_sv) &&
7094 (mode = SvPVX_const(((SVOP*)oa)->op_sv)) &&
7095 mode[0] == '>' && mode[1] == '&' && /* A dup open. */
7096 (last == oa->op_sibling)) /* The bareword. */
7097 last->op_private &= ~OPpCONST_STRICT;
7103 Perl_ck_repeat(pTHX_ OP *o)
7105 if (cBINOPo->op_first->op_flags & OPf_PARENS) {
7106 o->op_private |= OPpREPEAT_DOLIST;
7107 cBINOPo->op_first = force_list(cBINOPo->op_first);
7115 Perl_ck_require(pTHX_ OP *o)
7120 if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
7121 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7123 if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
7124 SV * const sv = kid->op_sv;
7125 U32 was_readonly = SvREADONLY(sv);
7130 sv_force_normal_flags(sv, 0);
7131 assert(!SvREADONLY(sv));
7138 for (s = SvPVX(sv); *s; s++) {
7139 if (*s == ':' && s[1] == ':') {
7140 const STRLEN len = strlen(s+2)+1;
7142 Move(s+2, s+1, len, char);
7143 SvCUR_set(sv, SvCUR(sv) - 1);
7146 sv_catpvs(sv, ".pm");
7147 SvFLAGS(sv) |= was_readonly;
7151 if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
7152 /* handle override, if any */
7153 gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
7154 if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
7155 GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
7156 gv = gvp ? *gvp : NULL;
7160 if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
7161 OP * const kid = cUNOPo->op_first;
7164 cUNOPo->op_first = 0;
7168 newop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
7169 append_elem(OP_LIST, kid,
7170 scalar(newUNOP(OP_RV2CV, 0,
7173 op_getmad(o,newop,'O');
7181 Perl_ck_return(pTHX_ OP *o)
7184 if (CvLVALUE(PL_compcv)) {
7186 for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
7187 mod(kid, OP_LEAVESUBLV);
7193 Perl_ck_select(pTHX_ OP *o)
7197 if (o->op_flags & OPf_KIDS) {
7198 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7199 if (kid && kid->op_sibling) {
7200 o->op_type = OP_SSELECT;
7201 o->op_ppaddr = PL_ppaddr[OP_SSELECT];
7203 return fold_constants(o);
7207 kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7208 if (kid && kid->op_type == OP_RV2GV)
7209 kid->op_private &= ~HINT_STRICT_REFS;
7214 Perl_ck_shift(pTHX_ OP *o)
7217 const I32 type = o->op_type;
7219 if (!(o->op_flags & OPf_KIDS)) {
7221 /* FIXME - this can be refactored to reduce code in #ifdefs */
7223 OP * const oldo = o;
7227 argop = newUNOP(OP_RV2AV, 0,
7228 scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
7230 o = newUNOP(type, 0, scalar(argop));
7231 op_getmad(oldo,o,'O');
7234 return newUNOP(type, 0, scalar(argop));
7237 return scalar(modkids(ck_fun(o), type));
7241 Perl_ck_sort(pTHX_ OP *o)
7246 if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0) {
7247 HV * const hinthv = GvHV(PL_hintgv);
7249 SV ** const svp = hv_fetchs(hinthv, "sort", FALSE);
7251 const I32 sorthints = (I32)SvIV(*svp);
7252 if ((sorthints & HINT_SORT_QUICKSORT) != 0)
7253 o->op_private |= OPpSORT_QSORT;
7254 if ((sorthints & HINT_SORT_STABLE) != 0)
7255 o->op_private |= OPpSORT_STABLE;
7260 if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
7262 firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7263 if (o->op_flags & OPf_STACKED) { /* may have been cleared */
7265 OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
7267 if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
7269 if (kid->op_type == OP_SCOPE) {
7273 else if (kid->op_type == OP_LEAVE) {
7274 if (o->op_type == OP_SORT) {
7275 op_null(kid); /* wipe out leave */
7278 for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
7279 if (k->op_next == kid)
7281 /* don't descend into loops */
7282 else if (k->op_type == OP_ENTERLOOP
7283 || k->op_type == OP_ENTERITER)
7285 k = cLOOPx(k)->op_lastop;
7290 kid->op_next = 0; /* just disconnect the leave */
7291 k = kLISTOP->op_first;
7296 if (o->op_type == OP_SORT) {
7297 /* provide scalar context for comparison function/block */
7303 o->op_flags |= OPf_SPECIAL;
7305 else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
7308 firstkid = firstkid->op_sibling;
7311 /* provide list context for arguments */
7312 if (o->op_type == OP_SORT)
7319 S_simplify_sort(pTHX_ OP *o)
7322 register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
7327 if (!(o->op_flags & OPf_STACKED))
7329 GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
7330 GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
7331 kid = kUNOP->op_first; /* get past null */
7332 if (kid->op_type != OP_SCOPE)
7334 kid = kLISTOP->op_last; /* get past scope */
7335 switch(kid->op_type) {
7343 k = kid; /* remember this node*/
7344 if (kBINOP->op_first->op_type != OP_RV2SV)
7346 kid = kBINOP->op_first; /* get past cmp */
7347 if (kUNOP->op_first->op_type != OP_GV)
7349 kid = kUNOP->op_first; /* get past rv2sv */
7351 if (GvSTASH(gv) != PL_curstash)
7353 gvname = GvNAME(gv);
7354 if (*gvname == 'a' && gvname[1] == '\0')
7356 else if (*gvname == 'b' && gvname[1] == '\0')
7361 kid = k; /* back to cmp */
7362 if (kBINOP->op_last->op_type != OP_RV2SV)
7364 kid = kBINOP->op_last; /* down to 2nd arg */
7365 if (kUNOP->op_first->op_type != OP_GV)
7367 kid = kUNOP->op_first; /* get past rv2sv */
7369 if (GvSTASH(gv) != PL_curstash)
7371 gvname = GvNAME(gv);
7373 ? !(*gvname == 'a' && gvname[1] == '\0')
7374 : !(*gvname == 'b' && gvname[1] == '\0'))
7376 o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
7378 o->op_private |= OPpSORT_DESCEND;
7379 if (k->op_type == OP_NCMP)
7380 o->op_private |= OPpSORT_NUMERIC;
7381 if (k->op_type == OP_I_NCMP)
7382 o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
7383 kid = cLISTOPo->op_first->op_sibling;
7384 cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
7386 op_getmad(kid,o,'S'); /* then delete it */
7388 op_free(kid); /* then delete it */
7393 Perl_ck_split(pTHX_ OP *o)
7398 if (o->op_flags & OPf_STACKED)
7399 return no_fh_allowed(o);
7401 kid = cLISTOPo->op_first;
7402 if (kid->op_type != OP_NULL)
7403 Perl_croak(aTHX_ "panic: ck_split");
7404 kid = kid->op_sibling;
7405 op_free(cLISTOPo->op_first);
7406 cLISTOPo->op_first = kid;
7408 cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
7409 cLISTOPo->op_last = kid; /* There was only one element previously */
7412 if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
7413 OP * const sibl = kid->op_sibling;
7414 kid->op_sibling = 0;
7415 kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0);
7416 if (cLISTOPo->op_first == cLISTOPo->op_last)
7417 cLISTOPo->op_last = kid;
7418 cLISTOPo->op_first = kid;
7419 kid->op_sibling = sibl;
7422 kid->op_type = OP_PUSHRE;
7423 kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
7425 if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) {
7426 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
7427 "Use of /g modifier is meaningless in split");
7430 if (!kid->op_sibling)
7431 append_elem(OP_SPLIT, o, newDEFSVOP());
7433 kid = kid->op_sibling;
7436 if (!kid->op_sibling)
7437 append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
7438 assert(kid->op_sibling);
7440 kid = kid->op_sibling;
7443 if (kid->op_sibling)
7444 return too_many_arguments(o,OP_DESC(o));
7450 Perl_ck_join(pTHX_ OP *o)
7452 const OP * const kid = cLISTOPo->op_first->op_sibling;
7453 if (kid && kid->op_type == OP_MATCH) {
7454 if (ckWARN(WARN_SYNTAX)) {
7455 const REGEXP *re = PM_GETRE(kPMOP);
7456 const char *pmstr = re ? re->precomp : "STRING";
7457 const STRLEN len = re ? re->prelen : 6;
7458 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7459 "/%.*s/ should probably be written as \"%.*s\"",
7460 (int)len, pmstr, (int)len, pmstr);
7467 Perl_ck_subr(pTHX_ OP *o)
7470 OP *prev = ((cUNOPo->op_first->op_sibling)
7471 ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
7472 OP *o2 = prev->op_sibling;
7474 const char *proto = NULL;
7475 const char *proto_end = NULL;
7480 I32 contextclass = 0;
7481 const char *e = NULL;
7484 o->op_private |= OPpENTERSUB_HASTARG;
7485 for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
7486 if (cvop->op_type == OP_RV2CV) {
7488 o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
7489 op_null(cvop); /* disable rv2cv */
7490 tmpop = (SVOP*)((UNOP*)cvop)->op_first;
7491 if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
7492 GV *gv = cGVOPx_gv(tmpop);
7495 tmpop->op_private |= OPpEARLY_CV;
7499 namegv = CvANON(cv) ? gv : CvGV(cv);
7500 proto = SvPV((SV*)cv, len);
7501 proto_end = proto + len;
7503 if (CvASSERTION(cv)) {
7504 U32 asserthints = 0;
7505 HV *const hinthv = GvHV(PL_hintgv);
7507 SV **svp = hv_fetchs(hinthv, "assertions", FALSE);
7509 asserthints = SvUV(*svp);
7511 if (asserthints & HINT_ASSERTING) {
7512 if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
7513 o->op_private |= OPpENTERSUB_DB;
7517 if (!(asserthints & HINT_ASSERTIONSSEEN) && ckWARN(WARN_ASSERTIONS)) {
7518 Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
7519 "Impossible to activate assertion call");
7526 else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
7527 if (o2->op_type == OP_CONST)
7528 o2->op_private &= ~OPpCONST_STRICT;
7529 else if (o2->op_type == OP_LIST) {
7530 OP * const sib = ((UNOP*)o2)->op_first->op_sibling;
7531 if (sib && sib->op_type == OP_CONST)
7532 sib->op_private &= ~OPpCONST_STRICT;
7535 o->op_private |= (PL_hints & HINT_STRICT_REFS);
7536 if (PERLDB_SUB && PL_curstash != PL_debstash)
7537 o->op_private |= OPpENTERSUB_DB;
7538 while (o2 != cvop) {
7540 if (PL_madskills && o2->op_type == OP_STUB) {
7541 o2 = o2->op_sibling;
7544 if (PL_madskills && o2->op_type == OP_NULL)
7545 o3 = ((UNOP*)o2)->op_first;
7549 if (proto >= proto_end)
7550 return too_many_arguments(o, gv_ename(namegv));
7558 /* _ must be at the end */
7559 if (proto[1] && proto[1] != ';')
7574 if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
7576 arg == 1 ? "block or sub {}" : "sub {}",
7577 gv_ename(namegv), o3);
7580 /* '*' allows any scalar type, including bareword */
7583 if (o3->op_type == OP_RV2GV)
7584 goto wrapref; /* autoconvert GLOB -> GLOBref */
7585 else if (o3->op_type == OP_CONST)
7586 o3->op_private &= ~OPpCONST_STRICT;
7587 else if (o3->op_type == OP_ENTERSUB) {
7588 /* accidental subroutine, revert to bareword */
7589 OP *gvop = ((UNOP*)o3)->op_first;
7590 if (gvop && gvop->op_type == OP_NULL) {
7591 gvop = ((UNOP*)gvop)->op_first;
7593 for (; gvop->op_sibling; gvop = gvop->op_sibling)
7596 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
7597 (gvop = ((UNOP*)gvop)->op_first) &&
7598 gvop->op_type == OP_GV)
7600 GV * const gv = cGVOPx_gv(gvop);
7601 OP * const sibling = o2->op_sibling;
7602 SV * const n = newSVpvs("");
7604 OP * const oldo2 = o2;
7608 gv_fullname4(n, gv, "", FALSE);
7609 o2 = newSVOP(OP_CONST, 0, n);
7610 op_getmad(oldo2,o2,'O');
7611 prev->op_sibling = o2;
7612 o2->op_sibling = sibling;
7628 if (contextclass++ == 0) {
7629 e = strchr(proto, ']');
7630 if (!e || e == proto)
7639 const char *p = proto;
7640 const char *const end = proto;
7642 while (*--p != '[');
7643 bad_type(arg, Perl_form(aTHX_ "one of %.*s",
7645 gv_ename(namegv), o3);
7650 if (o3->op_type == OP_RV2GV)
7653 bad_type(arg, "symbol", gv_ename(namegv), o3);
7656 if (o3->op_type == OP_ENTERSUB)
7659 bad_type(arg, "subroutine entry", gv_ename(namegv),
7663 if (o3->op_type == OP_RV2SV ||
7664 o3->op_type == OP_PADSV ||
7665 o3->op_type == OP_HELEM ||
7666 o3->op_type == OP_AELEM)
7669 bad_type(arg, "scalar", gv_ename(namegv), o3);
7672 if (o3->op_type == OP_RV2AV ||
7673 o3->op_type == OP_PADAV)
7676 bad_type(arg, "array", gv_ename(namegv), o3);
7679 if (o3->op_type == OP_RV2HV ||
7680 o3->op_type == OP_PADHV)
7683 bad_type(arg, "hash", gv_ename(namegv), o3);
7688 OP* const sib = kid->op_sibling;
7689 kid->op_sibling = 0;
7690 o2 = newUNOP(OP_REFGEN, 0, kid);
7691 o2->op_sibling = sib;
7692 prev->op_sibling = o2;
7694 if (contextclass && e) {
7709 Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf,
7710 gv_ename(namegv), SVfARG(cv));
7715 mod(o2, OP_ENTERSUB);
7717 o2 = o2->op_sibling;
7719 if (o2 == cvop && proto && *proto == '_') {
7720 /* generate an access to $_ */
7722 o2->op_sibling = prev->op_sibling;
7723 prev->op_sibling = o2; /* instead of cvop */
7725 if (proto && !optional && proto_end > proto &&
7726 (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
7727 return too_few_arguments(o, gv_ename(namegv));
7730 OP * const oldo = o;
7734 o=newSVOP(OP_CONST, 0, newSViv(0));
7735 op_getmad(oldo,o,'O');
7741 Perl_ck_svconst(pTHX_ OP *o)
7743 PERL_UNUSED_CONTEXT;
7744 SvREADONLY_on(cSVOPo->op_sv);
7749 Perl_ck_chdir(pTHX_ OP *o)
7751 if (o->op_flags & OPf_KIDS) {
7752 SVOP * const kid = (SVOP*)cUNOPo->op_first;
7754 if (kid && kid->op_type == OP_CONST &&
7755 (kid->op_private & OPpCONST_BARE))
7757 o->op_flags |= OPf_SPECIAL;
7758 kid->op_private &= ~OPpCONST_STRICT;
7765 Perl_ck_trunc(pTHX_ OP *o)
7767 if (o->op_flags & OPf_KIDS) {
7768 SVOP *kid = (SVOP*)cUNOPo->op_first;
7770 if (kid->op_type == OP_NULL)
7771 kid = (SVOP*)kid->op_sibling;
7772 if (kid && kid->op_type == OP_CONST &&
7773 (kid->op_private & OPpCONST_BARE))
7775 o->op_flags |= OPf_SPECIAL;
7776 kid->op_private &= ~OPpCONST_STRICT;
7783 Perl_ck_unpack(pTHX_ OP *o)
7785 OP *kid = cLISTOPo->op_first;
7786 if (kid->op_sibling) {
7787 kid = kid->op_sibling;
7788 if (!kid->op_sibling)
7789 kid->op_sibling = newDEFSVOP();
7795 Perl_ck_substr(pTHX_ OP *o)
7798 if ((o->op_flags & OPf_KIDS) && (o->op_private == 4)) {
7799 OP *kid = cLISTOPo->op_first;
7801 if (kid->op_type == OP_NULL)
7802 kid = kid->op_sibling;
7804 kid->op_flags |= OPf_MOD;
7810 /* A peephole optimizer. We visit the ops in the order they're to execute.
7811 * See the comments at the top of this file for more details about when
7812 * peep() is called */
7815 Perl_peep(pTHX_ register OP *o)
7818 register OP* oldop = NULL;
7820 if (!o || o->op_opt)
7824 SAVEVPTR(PL_curcop);
7825 for (; o; o = o->op_next) {
7828 /* By default, this op has now been optimised. A couple of cases below
7829 clear this again. */
7832 switch (o->op_type) {
7836 PL_curcop = ((COP*)o); /* for warnings */
7840 if (cSVOPo->op_private & OPpCONST_STRICT)
7841 no_bareword_allowed(o);
7843 case OP_METHOD_NAMED:
7844 /* Relocate sv to the pad for thread safety.
7845 * Despite being a "constant", the SV is written to,
7846 * for reference counts, sv_upgrade() etc. */
7848 const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
7849 if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
7850 /* If op_sv is already a PADTMP then it is being used by
7851 * some pad, so make a copy. */
7852 sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
7853 SvREADONLY_on(PAD_SVl(ix));
7854 SvREFCNT_dec(cSVOPo->op_sv);
7856 else if (o->op_type == OP_CONST
7857 && cSVOPo->op_sv == &PL_sv_undef) {
7858 /* PL_sv_undef is hack - it's unsafe to store it in the
7859 AV that is the pad, because av_fetch treats values of
7860 PL_sv_undef as a "free" AV entry and will merrily
7861 replace them with a new SV, causing pad_alloc to think
7862 that this pad slot is free. (When, clearly, it is not)
7864 SvOK_off(PAD_SVl(ix));
7865 SvPADTMP_on(PAD_SVl(ix));
7866 SvREADONLY_on(PAD_SVl(ix));
7869 SvREFCNT_dec(PAD_SVl(ix));
7870 SvPADTMP_on(cSVOPo->op_sv);
7871 PAD_SETSV(ix, cSVOPo->op_sv);
7872 /* XXX I don't know how this isn't readonly already. */
7873 SvREADONLY_on(PAD_SVl(ix));
7875 cSVOPo->op_sv = NULL;
7882 if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
7883 if (o->op_next->op_private & OPpTARGET_MY) {
7884 if (o->op_flags & OPf_STACKED) /* chained concats */
7885 break; /* ignore_optimization */
7887 /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
7888 o->op_targ = o->op_next->op_targ;
7889 o->op_next->op_targ = 0;
7890 o->op_private |= OPpTARGET_MY;
7893 op_null(o->op_next);
7897 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
7898 break; /* Scalar stub must produce undef. List stub is noop */
7902 if (o->op_targ == OP_NEXTSTATE
7903 || o->op_targ == OP_DBSTATE
7904 || o->op_targ == OP_SETSTATE)
7906 PL_curcop = ((COP*)o);
7908 /* XXX: We avoid setting op_seq here to prevent later calls
7909 to peep() from mistakenly concluding that optimisation
7910 has already occurred. This doesn't fix the real problem,
7911 though (See 20010220.007). AMS 20010719 */
7912 /* op_seq functionality is now replaced by op_opt */
7919 if (oldop && o->op_next) {
7920 oldop->op_next = o->op_next;
7928 if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
7929 OP* const pop = (o->op_type == OP_PADAV) ?
7930 o->op_next : o->op_next->op_next;
7932 if (pop && pop->op_type == OP_CONST &&
7933 ((PL_op = pop->op_next)) &&
7934 pop->op_next->op_type == OP_AELEM &&
7935 !(pop->op_next->op_private &
7936 (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
7937 (i = SvIV(((SVOP*)pop)->op_sv) - CopARYBASE_get(PL_curcop))
7942 if (cSVOPx(pop)->op_private & OPpCONST_STRICT)
7943 no_bareword_allowed(pop);
7944 if (o->op_type == OP_GV)
7945 op_null(o->op_next);
7946 op_null(pop->op_next);
7948 o->op_flags |= pop->op_next->op_flags & OPf_MOD;
7949 o->op_next = pop->op_next->op_next;
7950 o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
7951 o->op_private = (U8)i;
7952 if (o->op_type == OP_GV) {
7957 o->op_flags |= OPf_SPECIAL;
7958 o->op_type = OP_AELEMFAST;
7963 if (o->op_next->op_type == OP_RV2SV) {
7964 if (!(o->op_next->op_private & OPpDEREF)) {
7965 op_null(o->op_next);
7966 o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
7968 o->op_next = o->op_next->op_next;
7969 o->op_type = OP_GVSV;
7970 o->op_ppaddr = PL_ppaddr[OP_GVSV];
7973 else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
7974 GV * const gv = cGVOPo_gv;
7975 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
7976 /* XXX could check prototype here instead of just carping */
7977 SV * const sv = sv_newmortal();
7978 gv_efullname3(sv, gv, NULL);
7979 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
7980 "%"SVf"() called too early to check prototype",
7984 else if (o->op_next->op_type == OP_READLINE
7985 && o->op_next->op_next->op_type == OP_CONCAT
7986 && (o->op_next->op_next->op_flags & OPf_STACKED))
7988 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
7989 o->op_type = OP_RCATLINE;
7990 o->op_flags |= OPf_STACKED;
7991 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
7992 op_null(o->op_next->op_next);
7993 op_null(o->op_next);
8008 while (cLOGOP->op_other->op_type == OP_NULL)
8009 cLOGOP->op_other = cLOGOP->op_other->op_next;
8010 peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
8015 while (cLOOP->op_redoop->op_type == OP_NULL)
8016 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
8017 peep(cLOOP->op_redoop);
8018 while (cLOOP->op_nextop->op_type == OP_NULL)
8019 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
8020 peep(cLOOP->op_nextop);
8021 while (cLOOP->op_lastop->op_type == OP_NULL)
8022 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
8023 peep(cLOOP->op_lastop);
8027 assert(!(cPMOP->op_pmflags & PMf_ONCE));
8028 while (cPMOP->op_pmstashstartu.op_pmreplstart &&
8029 cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
8030 cPMOP->op_pmstashstartu.op_pmreplstart
8031 = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
8032 peep(cPMOP->op_pmstashstartu.op_pmreplstart);
8036 if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
8037 && ckWARN(WARN_SYNTAX))
8039 if (o->op_next->op_sibling) {
8040 const OPCODE type = o->op_next->op_sibling->op_type;
8041 if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
8042 const line_t oldline = CopLINE(PL_curcop);
8043 CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
8044 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8045 "Statement unlikely to be reached");
8046 Perl_warner(aTHX_ packWARN(WARN_EXEC),
8047 "\t(Maybe you meant system() when you said exec()?)\n");
8048 CopLINE_set(PL_curcop, oldline);
8059 const char *key = NULL;
8062 if (((BINOP*)o)->op_last->op_type != OP_CONST)
8065 /* Make the CONST have a shared SV */
8066 svp = cSVOPx_svp(((BINOP*)o)->op_last);
8067 if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
8068 key = SvPV_const(sv, keylen);
8069 lexname = newSVpvn_share(key,
8070 SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
8076 if ((o->op_private & (OPpLVAL_INTRO)))
8079 rop = (UNOP*)((BINOP*)o)->op_first;
8080 if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
8082 lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
8083 if (!SvPAD_TYPED(lexname))
8085 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8086 if (!fields || !GvHV(*fields))
8088 key = SvPV_const(*svp, keylen);
8089 if (!hv_fetch(GvHV(*fields), key,
8090 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8092 Perl_croak(aTHX_ "No such class field \"%s\" "
8093 "in variable %s of type %s",
8094 key, SvPV_nolen_const(lexname), HvNAME_get(SvSTASH(lexname)));
8107 SVOP *first_key_op, *key_op;
8109 if ((o->op_private & (OPpLVAL_INTRO))
8110 /* I bet there's always a pushmark... */
8111 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
8112 /* hmmm, no optimization if list contains only one key. */
8114 rop = (UNOP*)((LISTOP*)o)->op_last;
8115 if (rop->op_type != OP_RV2HV)
8117 if (rop->op_first->op_type == OP_PADSV)
8118 /* @$hash{qw(keys here)} */
8119 rop = (UNOP*)rop->op_first;
8121 /* @{$hash}{qw(keys here)} */
8122 if (rop->op_first->op_type == OP_SCOPE
8123 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
8125 rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
8131 lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE);
8132 if (!SvPAD_TYPED(lexname))
8134 fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
8135 if (!fields || !GvHV(*fields))
8137 /* Again guessing that the pushmark can be jumped over.... */
8138 first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
8139 ->op_first->op_sibling;
8140 for (key_op = first_key_op; key_op;
8141 key_op = (SVOP*)key_op->op_sibling) {
8142 if (key_op->op_type != OP_CONST)
8144 svp = cSVOPx_svp(key_op);
8145 key = SvPV_const(*svp, keylen);
8146 if (!hv_fetch(GvHV(*fields), key,
8147 SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE))
8149 Perl_croak(aTHX_ "No such class field \"%s\" "
8150 "in variable %s of type %s",
8151 key, SvPV_nolen(lexname), HvNAME_get(SvSTASH(lexname)));
8158 /* will point to RV2AV or PADAV op on LHS/RHS of assign */
8162 /* check that RHS of sort is a single plain array */
8163 OP *oright = cUNOPo->op_first;
8164 if (!oright || oright->op_type != OP_PUSHMARK)
8167 /* reverse sort ... can be optimised. */
8168 if (!cUNOPo->op_sibling) {
8169 /* Nothing follows us on the list. */
8170 OP * const reverse = o->op_next;
8172 if (reverse->op_type == OP_REVERSE &&
8173 (reverse->op_flags & OPf_WANT) == OPf_WANT_LIST) {
8174 OP * const pushmark = cUNOPx(reverse)->op_first;
8175 if (pushmark && (pushmark->op_type == OP_PUSHMARK)
8176 && (cUNOPx(pushmark)->op_sibling == o)) {
8177 /* reverse -> pushmark -> sort */
8178 o->op_private |= OPpSORT_REVERSE;
8180 pushmark->op_next = oright->op_next;
8186 /* make @a = sort @a act in-place */
8188 oright = cUNOPx(oright)->op_sibling;
8191 if (oright->op_type == OP_NULL) { /* skip sort block/sub */
8192 oright = cUNOPx(oright)->op_sibling;
8196 (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
8197 || oright->op_next != o
8198 || (oright->op_private & OPpLVAL_INTRO)
8202 /* o2 follows the chain of op_nexts through the LHS of the
8203 * assign (if any) to the aassign op itself */
8205 if (!o2 || o2->op_type != OP_NULL)
8208 if (!o2 || o2->op_type != OP_PUSHMARK)
8211 if (o2 && o2->op_type == OP_GV)
8214 || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
8215 || (o2->op_private & OPpLVAL_INTRO)
8220 if (!o2 || o2->op_type != OP_NULL)
8223 if (!o2 || o2->op_type != OP_AASSIGN
8224 || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
8227 /* check that the sort is the first arg on RHS of assign */
8229 o2 = cUNOPx(o2)->op_first;
8230 if (!o2 || o2->op_type != OP_NULL)
8232 o2 = cUNOPx(o2)->op_first;
8233 if (!o2 || o2->op_type != OP_PUSHMARK)
8235 if (o2->op_sibling != o)
8238 /* check the array is the same on both sides */
8239 if (oleft->op_type == OP_RV2AV) {
8240 if (oright->op_type != OP_RV2AV
8241 || !cUNOPx(oright)->op_first
8242 || cUNOPx(oright)->op_first->op_type != OP_GV
8243 || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
8244 cGVOPx_gv(cUNOPx(oright)->op_first)
8248 else if (oright->op_type != OP_PADAV
8249 || oright->op_targ != oleft->op_targ
8253 /* transfer MODishness etc from LHS arg to RHS arg */
8254 oright->op_flags = oleft->op_flags;
8255 o->op_private |= OPpSORT_INPLACE;
8257 /* excise push->gv->rv2av->null->aassign */
8258 o2 = o->op_next->op_next;
8259 op_null(o2); /* PUSHMARK */
8261 if (o2->op_type == OP_GV) {
8262 op_null(o2); /* GV */
8265 op_null(o2); /* RV2AV or PADAV */
8266 o2 = o2->op_next->op_next;
8267 op_null(o2); /* AASSIGN */
8269 o->op_next = o2->op_next;
8275 OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
8277 LISTOP *enter, *exlist;
8279 enter = (LISTOP *) o->op_next;
8282 if (enter->op_type == OP_NULL) {
8283 enter = (LISTOP *) enter->op_next;
8287 /* for $a (...) will have OP_GV then OP_RV2GV here.
8288 for (...) just has an OP_GV. */
8289 if (enter->op_type == OP_GV) {
8290 gvop = (OP *) enter;
8291 enter = (LISTOP *) enter->op_next;
8294 if (enter->op_type == OP_RV2GV) {
8295 enter = (LISTOP *) enter->op_next;
8301 if (enter->op_type != OP_ENTERITER)
8304 iter = enter->op_next;
8305 if (!iter || iter->op_type != OP_ITER)
8308 expushmark = enter->op_first;
8309 if (!expushmark || expushmark->op_type != OP_NULL
8310 || expushmark->op_targ != OP_PUSHMARK)
8313 exlist = (LISTOP *) expushmark->op_sibling;
8314 if (!exlist || exlist->op_type != OP_NULL
8315 || exlist->op_targ != OP_LIST)
8318 if (exlist->op_last != o) {
8319 /* Mmm. Was expecting to point back to this op. */
8322 theirmark = exlist->op_first;
8323 if (!theirmark || theirmark->op_type != OP_PUSHMARK)
8326 if (theirmark->op_sibling != o) {
8327 /* There's something between the mark and the reverse, eg
8328 for (1, reverse (...))
8333 ourmark = ((LISTOP *)o)->op_first;
8334 if (!ourmark || ourmark->op_type != OP_PUSHMARK)
8337 ourlast = ((LISTOP *)o)->op_last;
8338 if (!ourlast || ourlast->op_next != o)
8341 rv2av = ourmark->op_sibling;
8342 if (rv2av && rv2av->op_type == OP_RV2AV && rv2av->op_sibling == 0
8343 && rv2av->op_flags == (OPf_WANT_LIST | OPf_KIDS)
8344 && enter->op_flags == (OPf_WANT_LIST | OPf_KIDS)) {
8345 /* We're just reversing a single array. */
8346 rv2av->op_flags = OPf_WANT_SCALAR | OPf_KIDS | OPf_REF;
8347 enter->op_flags |= OPf_STACKED;
8350 /* We don't have control over who points to theirmark, so sacrifice
8352 theirmark->op_next = ourmark->op_next;
8353 theirmark->op_flags = ourmark->op_flags;
8354 ourlast->op_next = gvop ? gvop : (OP *) enter;
8357 enter->op_private |= OPpITER_REVERSED;
8358 iter->op_private |= OPpITER_REVERSED;
8365 UNOP *refgen, *rv2cv;
8368 if ((o->op_flags && OPf_WANT) != OPf_WANT_VOID)
8371 if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
8374 rv2gv = ((BINOP *)o)->op_last;
8375 if (!rv2gv || rv2gv->op_type != OP_RV2GV)
8378 refgen = (UNOP *)((BINOP *)o)->op_first;
8380 if (!refgen || refgen->op_type != OP_REFGEN)
8383 exlist = (LISTOP *)refgen->op_first;
8384 if (!exlist || exlist->op_type != OP_NULL
8385 || exlist->op_targ != OP_LIST)
8388 if (exlist->op_first->op_type != OP_PUSHMARK)
8391 rv2cv = (UNOP*)exlist->op_last;
8393 if (rv2cv->op_type != OP_RV2CV)
8396 assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
8397 assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
8398 assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
8400 o->op_private |= OPpASSIGN_CV_TO_GV;
8401 rv2gv->op_private |= OPpDONT_INIT_GV;
8402 rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
8410 if (!(cPMOP->op_pmflags & PMf_ONCE)) {
8411 assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
8421 Perl_custom_op_name(pTHX_ const OP* o)
8424 const IV index = PTR2IV(o->op_ppaddr);
8428 if (!PL_custom_op_names) /* This probably shouldn't happen */
8429 return (char *)PL_op_name[OP_CUSTOM];
8431 keysv = sv_2mortal(newSViv(index));
8433 he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
8435 return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
8437 return SvPV_nolen(HeVAL(he));
8441 Perl_custom_op_desc(pTHX_ const OP* o)
8444 const IV index = PTR2IV(o->op_ppaddr);
8448 if (!PL_custom_op_descs)
8449 return (char *)PL_op_desc[OP_CUSTOM];
8451 keysv = sv_2mortal(newSViv(index));
8453 he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
8455 return (char *)PL_op_desc[OP_CUSTOM];
8457 return SvPV_nolen(HeVAL(he));
8462 /* Efficient sub that returns a constant scalar value. */
8464 const_sv_xsub(pTHX_ CV* cv)
8471 Perl_croak(aTHX_ "usage: %s::%s()",
8472 HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
8476 ST(0) = (SV*)XSANY.any_ptr;
8482 * c-indentation-style: bsd
8484 * indent-tabs-mode: t
8487 * ex: set ts=8 sts=4 sw=4 noet: