Upgrade to PathTools-3.14_01
[perl.git] / op.c
1 /*    op.c
2  *
3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4  *    2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others
5  *
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.
8  *
9  */
10
11 /*
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
17  */
18
19 /* This file contains the functions that create, manipulate and optimize
20  * the OP structures that hold a compiled perl program.
21  *
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
28  * stack.
29  *
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):
34  *
35  *  newBINOP(OP_ADD, flags,
36  *      newSVREF($a),
37  *      newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
38  *  )
39  *
40  * Note that during the build of miniperl, a temporary copy of this file
41  * is made, called opmini.c.
42  */
43
44 /*
45 Perl's compiler is essentially a 3-pass compiler with interleaved phases:
46
47     A bottom-up pass
48     A top-down pass
49     An execution-order pass
50
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
58 top level node.
59
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.
68
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.
74 */
75
76 #include "EXTERN.h"
77 #define PERL_IN_OP_C
78 #include "perl.h"
79 #include "keywords.h"
80
81 #define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
82
83 #if defined(PL_OP_SLAB_ALLOC)
84
85 #ifndef PERL_SLAB_SIZE
86 #define PERL_SLAB_SIZE 2048
87 #endif
88
89 void *
90 Perl_Slab_Alloc(pTHX_ int m, size_t sz)
91 {
92     /*
93      * To make incrementing use count easy PL_OpSlab is an I32 *
94      * To make inserting the link to slab PL_OpPtr is I32 **
95      * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
96      * Add an overhead for pointer to slab and round up as a number of pointers
97      */
98     sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
99     if ((PL_OpSpace -= sz) < 0) {
100         PL_OpPtr = (I32 **) PerlMemShared_malloc(PERL_SLAB_SIZE*sizeof(I32*)); 
101         if (!PL_OpPtr) {
102             return NULL;
103         }
104         Zero(PL_OpPtr,PERL_SLAB_SIZE,I32 **);
105         /* We reserve the 0'th I32 sized chunk as a use count */
106         PL_OpSlab = (I32 *) PL_OpPtr;
107         /* Reduce size by the use count word, and by the size we need.
108          * Latter is to mimic the '-=' in the if() above
109          */
110         PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
111         /* Allocation pointer starts at the top.
112            Theory: because we build leaves before trunk allocating at end
113            means that at run time access is cache friendly upward
114          */
115         PL_OpPtr += PERL_SLAB_SIZE;
116     }
117     assert( PL_OpSpace >= 0 );
118     /* Move the allocation pointer down */
119     PL_OpPtr   -= sz;
120     assert( PL_OpPtr > (I32 **) PL_OpSlab );
121     *PL_OpPtr   = PL_OpSlab;    /* Note which slab it belongs to */
122     (*PL_OpSlab)++;             /* Increment use count of slab */
123     assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
124     assert( *PL_OpSlab > 0 );
125     return (void *)(PL_OpPtr + 1);
126 }
127
128 void
129 Perl_Slab_Free(pTHX_ void *op)
130 {
131     I32 * const * const ptr = (I32 **) op;
132     I32 * const slab = ptr[-1];
133     assert( ptr-1 > (I32 **) slab );
134     assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
135     assert( *slab > 0 );
136     if (--(*slab) == 0) {
137 #  ifdef NETWARE
138 #    define PerlMemShared PerlMem
139 #  endif
140         
141     PerlMemShared_free(slab);
142         if (slab == PL_OpSlab) {
143             PL_OpSpace = 0;
144         }
145     }
146 }
147 #endif
148 /*
149  * In the following definition, the ", Nullop" is just to make the compiler
150  * think the expression is of the right type: croak actually does a Siglongjmp.
151  */
152 #define CHECKOP(type,o) \
153     ((PL_op_mask && PL_op_mask[type])                                   \
154      ? ( op_free((OP*)o),                                       \
155          Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]),  \
156          Nullop )                                               \
157      : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
158
159 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
160
161 STATIC const char*
162 S_gv_ename(pTHX_ GV *gv)
163 {
164     SV* const tmpsv = sv_newmortal();
165     gv_efullname3(tmpsv, gv, Nullch);
166     return SvPV_nolen_const(tmpsv);
167 }
168
169 STATIC OP *
170 S_no_fh_allowed(pTHX_ OP *o)
171 {
172     yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
173                  OP_DESC(o)));
174     return o;
175 }
176
177 STATIC OP *
178 S_too_few_arguments(pTHX_ OP *o, const char *name)
179 {
180     yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
181     return o;
182 }
183
184 STATIC OP *
185 S_too_many_arguments(pTHX_ OP *o, const char *name)
186 {
187     yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
188     return o;
189 }
190
191 STATIC void
192 S_bad_type(pTHX_ I32 n, const char *t, const char *name, const OP *kid)
193 {
194     yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
195                  (int)n, name, t, OP_DESC(kid)));
196 }
197
198 STATIC void
199 S_no_bareword_allowed(pTHX_ const OP *o)
200 {
201     qerror(Perl_mess(aTHX_
202                      "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
203                      cSVOPo_sv));
204 }
205
206 /* "register" allocation */
207
208 PADOFFSET
209 Perl_allocmy(pTHX_ char *name)
210 {
211     PADOFFSET off;
212
213     /* complain about "my $<special_var>" etc etc */
214     if (*name &&
215         !(PL_in_my == KEY_our ||
216           isALPHA(name[1]) ||
217           (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
218           (name[1] == '_' && (*name == '$' || name[2]))))
219     {
220         /* name[2] is true if strlen(name) > 2  */
221         if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
222             /* 1999-02-27 mjd@plover.com */
223             char *p;
224             p = strchr(name, '\0');
225             /* The next block assumes the buffer is at least 205 chars
226                long.  At present, it's always at least 256 chars. */
227             if (p-name > 200) {
228                 strcpy(name+200, "...");
229                 p = name+199;
230             }
231             else {
232                 p[1] = '\0';
233             }
234             /* Move everything else down one character */
235             for (; p-name > 2; p--)
236                 *p = *(p-1);
237             name[2] = toCTRL(name[1]);
238             name[1] = '^';
239         }
240         yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
241     }
242
243     /* check for duplicate declaration */
244     pad_check_dup(name,
245                 (bool)(PL_in_my == KEY_our),
246                 (PL_curstash ? PL_curstash : PL_defstash)
247     );
248
249     if (PL_in_my_stash && *name != '$') {
250         yyerror(Perl_form(aTHX_
251                     "Can't declare class for non-scalar %s in \"%s\"",
252                      name, PL_in_my == KEY_our ? "our" : "my"));
253     }
254
255     /* allocate a spare slot and store the name in that slot */
256
257     off = pad_add_name(name,
258                     PL_in_my_stash,
259                     (PL_in_my == KEY_our 
260                         /* $_ is always in main::, even with our */
261                         ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
262                         : Nullhv
263                     ),
264                     0 /*  not fake */
265     );
266     return off;
267 }
268
269 /* Destructor */
270
271 void
272 Perl_op_free(pTHX_ OP *o)
273 {
274     dVAR;
275     OPCODE type;
276     PADOFFSET refcnt;
277
278     if (!o || o->op_static)
279         return;
280
281     if (o->op_private & OPpREFCOUNTED) {
282         switch (o->op_type) {
283         case OP_LEAVESUB:
284         case OP_LEAVESUBLV:
285         case OP_LEAVEEVAL:
286         case OP_LEAVE:
287         case OP_SCOPE:
288         case OP_LEAVEWRITE:
289             OP_REFCNT_LOCK;
290             refcnt = OpREFCNT_dec(o);
291             OP_REFCNT_UNLOCK;
292             if (refcnt)
293                 return;
294             break;
295         default:
296             break;
297         }
298     }
299
300     if (o->op_flags & OPf_KIDS) {
301         register OP *kid, *nextkid;
302         for (kid = cUNOPo->op_first; kid; kid = nextkid) {
303             nextkid = kid->op_sibling; /* Get before next freeing kid */
304             op_free(kid);
305         }
306     }
307     type = o->op_type;
308     if (type == OP_NULL)
309         type = (OPCODE)o->op_targ;
310
311     /* COP* is not cleared by op_clear() so that we may track line
312      * numbers etc even after null() */
313     if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
314         cop_free((COP*)o);
315
316     op_clear(o);
317     FreeOp(o);
318 #ifdef DEBUG_LEAKING_SCALARS
319     if (PL_op == o)
320         PL_op = Nullop;
321 #endif
322 }
323
324 void
325 Perl_op_clear(pTHX_ OP *o)
326 {
327
328     dVAR;
329     switch (o->op_type) {
330     case OP_NULL:       /* Was holding old type, if any. */
331     case OP_ENTEREVAL:  /* Was holding hints. */
332         o->op_targ = 0;
333         break;
334     default:
335         if (!(o->op_flags & OPf_REF)
336             || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
337             break;
338         /* FALL THROUGH */
339     case OP_GVSV:
340     case OP_GV:
341     case OP_AELEMFAST:
342         if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
343             /* not an OP_PADAV replacement */
344 #ifdef USE_ITHREADS
345             if (cPADOPo->op_padix > 0) {
346                 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
347                  * may still exist on the pad */
348                 pad_swipe(cPADOPo->op_padix, TRUE);
349                 cPADOPo->op_padix = 0;
350             }
351 #else
352             SvREFCNT_dec(cSVOPo->op_sv);
353             cSVOPo->op_sv = Nullsv;
354 #endif
355         }
356         break;
357     case OP_METHOD_NAMED:
358     case OP_CONST:
359         SvREFCNT_dec(cSVOPo->op_sv);
360         cSVOPo->op_sv = Nullsv;
361 #ifdef USE_ITHREADS
362         /** Bug #15654
363           Even if op_clear does a pad_free for the target of the op,
364           pad_free doesn't actually remove the sv that exists in the pad;
365           instead it lives on. This results in that it could be reused as 
366           a target later on when the pad was reallocated.
367         **/
368         if(o->op_targ) {
369           pad_swipe(o->op_targ,1);
370           o->op_targ = 0;
371         }
372 #endif
373         break;
374     case OP_GOTO:
375     case OP_NEXT:
376     case OP_LAST:
377     case OP_REDO:
378         if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
379             break;
380         /* FALL THROUGH */
381     case OP_TRANS:
382         if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
383             SvREFCNT_dec(cSVOPo->op_sv);
384             cSVOPo->op_sv = Nullsv;
385         }
386         else {
387             Safefree(cPVOPo->op_pv);
388             cPVOPo->op_pv = Nullch;
389         }
390         break;
391     case OP_SUBST:
392         op_free(cPMOPo->op_pmreplroot);
393         goto clear_pmop;
394     case OP_PUSHRE:
395 #ifdef USE_ITHREADS
396         if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) {
397             /* No GvIN_PAD_off here, because other references may still
398              * exist on the pad */
399             pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot), TRUE);
400         }
401 #else
402         SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
403 #endif
404         /* FALL THROUGH */
405     case OP_MATCH:
406     case OP_QR:
407 clear_pmop:
408         {
409             HV * const pmstash = PmopSTASH(cPMOPo);
410             if (pmstash && !SvIS_FREED(pmstash)) {
411                 MAGIC * const mg = mg_find((SV*)pmstash, PERL_MAGIC_symtab);
412                 if (mg) {
413                     PMOP *pmop = (PMOP*) mg->mg_obj;
414                     PMOP *lastpmop = NULL;
415                     while (pmop) {
416                         if (cPMOPo == pmop) {
417                             if (lastpmop)
418                                 lastpmop->op_pmnext = pmop->op_pmnext;
419                             else
420                                 mg->mg_obj = (SV*) pmop->op_pmnext;
421                             break;
422                         }
423                         lastpmop = pmop;
424                         pmop = pmop->op_pmnext;
425                     }
426                 }
427             }
428             PmopSTASH_free(cPMOPo);
429         }
430         cPMOPo->op_pmreplroot = Nullop;
431         /* we use the "SAFE" version of the PM_ macros here
432          * since sv_clean_all might release some PMOPs
433          * after PL_regex_padav has been cleared
434          * and the clearing of PL_regex_padav needs to
435          * happen before sv_clean_all
436          */
437         ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
438         PM_SETRE_SAFE(cPMOPo, (REGEXP*)NULL);
439 #ifdef USE_ITHREADS
440         if(PL_regex_pad) {        /* We could be in destruction */
441             av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
442             SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
443             PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
444         }
445 #endif
446
447         break;
448     }
449
450     if (o->op_targ > 0) {
451         pad_free(o->op_targ);
452         o->op_targ = 0;
453     }
454 }
455
456 STATIC void
457 S_cop_free(pTHX_ COP* cop)
458 {
459     Safefree(cop->cop_label);   /* FIXME: treaddead ??? */
460     CopFILE_free(cop);
461     CopSTASH_free(cop);
462     if (! specialWARN(cop->cop_warnings))
463         SvREFCNT_dec(cop->cop_warnings);
464     if (! specialCopIO(cop->cop_io)) {
465 #ifdef USE_ITHREADS
466 #if 0
467         STRLEN len;
468         char *s = SvPV(cop->cop_io,len);
469         Perl_warn(aTHX_ "io='%.*s'",(int) len,s); /* ??? --jhi */
470 #endif
471 #else
472         SvREFCNT_dec(cop->cop_io);
473 #endif
474     }
475 }
476
477 void
478 Perl_op_null(pTHX_ OP *o)
479 {
480     dVAR;
481     if (o->op_type == OP_NULL)
482         return;
483     op_clear(o);
484     o->op_targ = o->op_type;
485     o->op_type = OP_NULL;
486     o->op_ppaddr = PL_ppaddr[OP_NULL];
487 }
488
489 void
490 Perl_op_refcnt_lock(pTHX)
491 {
492     dVAR;
493     OP_REFCNT_LOCK;
494 }
495
496 void
497 Perl_op_refcnt_unlock(pTHX)
498 {
499     dVAR;
500     OP_REFCNT_UNLOCK;
501 }
502
503 /* Contextualizers */
504
505 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
506
507 OP *
508 Perl_linklist(pTHX_ OP *o)
509 {
510
511     if (o->op_next)
512         return o->op_next;
513
514     /* establish postfix order */
515     if (cUNOPo->op_first) {
516         register OP *kid;
517         o->op_next = LINKLIST(cUNOPo->op_first);
518         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
519             if (kid->op_sibling)
520                 kid->op_next = LINKLIST(kid->op_sibling);
521             else
522                 kid->op_next = o;
523         }
524     }
525     else
526         o->op_next = o;
527
528     return o->op_next;
529 }
530
531 OP *
532 Perl_scalarkids(pTHX_ OP *o)
533 {
534     if (o && o->op_flags & OPf_KIDS) {
535         OP *kid;
536         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
537             scalar(kid);
538     }
539     return o;
540 }
541
542 STATIC OP *
543 S_scalarboolean(pTHX_ OP *o)
544 {
545     if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
546         if (ckWARN(WARN_SYNTAX)) {
547             const line_t oldline = CopLINE(PL_curcop);
548
549             if (PL_copline != NOLINE)
550                 CopLINE_set(PL_curcop, PL_copline);
551             Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
552             CopLINE_set(PL_curcop, oldline);
553         }
554     }
555     return scalar(o);
556 }
557
558 OP *
559 Perl_scalar(pTHX_ OP *o)
560 {
561     dVAR;
562     OP *kid;
563
564     /* assumes no premature commitment */
565     if (!o || PL_error_count || (o->op_flags & OPf_WANT)
566          || o->op_type == OP_RETURN)
567     {
568         return o;
569     }
570
571     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
572
573     switch (o->op_type) {
574     case OP_REPEAT:
575         scalar(cBINOPo->op_first);
576         break;
577     case OP_OR:
578     case OP_AND:
579     case OP_COND_EXPR:
580         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
581             scalar(kid);
582         break;
583     case OP_SPLIT:
584         if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
585             if (!kPMOP->op_pmreplroot)
586                 deprecate_old("implicit split to @_");
587         }
588         /* FALL THROUGH */
589     case OP_MATCH:
590     case OP_QR:
591     case OP_SUBST:
592     case OP_NULL:
593     default:
594         if (o->op_flags & OPf_KIDS) {
595             for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
596                 scalar(kid);
597         }
598         break;
599     case OP_LEAVE:
600     case OP_LEAVETRY:
601         kid = cLISTOPo->op_first;
602         scalar(kid);
603         while ((kid = kid->op_sibling)) {
604             if (kid->op_sibling)
605                 scalarvoid(kid);
606             else
607                 scalar(kid);
608         }
609         WITH_THR(PL_curcop = &PL_compiling);
610         break;
611     case OP_SCOPE:
612     case OP_LINESEQ:
613     case OP_LIST:
614         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
615             if (kid->op_sibling)
616                 scalarvoid(kid);
617             else
618                 scalar(kid);
619         }
620         WITH_THR(PL_curcop = &PL_compiling);
621         break;
622     case OP_SORT:
623         if (ckWARN(WARN_VOID))
624             Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
625     }
626     return o;
627 }
628
629 OP *
630 Perl_scalarvoid(pTHX_ OP *o)
631 {
632     dVAR;
633     OP *kid;
634     const char* useless = 0;
635     SV* sv;
636     U8 want;
637
638     if (o->op_type == OP_NEXTSTATE
639         || o->op_type == OP_SETSTATE
640         || o->op_type == OP_DBSTATE
641         || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
642                                       || o->op_targ == OP_SETSTATE
643                                       || o->op_targ == OP_DBSTATE)))
644         PL_curcop = (COP*)o;            /* for warning below */
645
646     /* assumes no premature commitment */
647     want = o->op_flags & OPf_WANT;
648     if ((want && want != OPf_WANT_SCALAR) || PL_error_count
649          || o->op_type == OP_RETURN)
650     {
651         return o;
652     }
653
654     if ((o->op_private & OPpTARGET_MY)
655         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
656     {
657         return scalar(o);                       /* As if inside SASSIGN */
658     }
659
660     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
661
662     switch (o->op_type) {
663     default:
664         if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
665             break;
666         /* FALL THROUGH */
667     case OP_REPEAT:
668         if (o->op_flags & OPf_STACKED)
669             break;
670         goto func_ops;
671     case OP_SUBSTR:
672         if (o->op_private == 4)
673             break;
674         /* FALL THROUGH */
675     case OP_GVSV:
676     case OP_WANTARRAY:
677     case OP_GV:
678     case OP_PADSV:
679     case OP_PADAV:
680     case OP_PADHV:
681     case OP_PADANY:
682     case OP_AV2ARYLEN:
683     case OP_REF:
684     case OP_REFGEN:
685     case OP_SREFGEN:
686     case OP_DEFINED:
687     case OP_HEX:
688     case OP_OCT:
689     case OP_LENGTH:
690     case OP_VEC:
691     case OP_INDEX:
692     case OP_RINDEX:
693     case OP_SPRINTF:
694     case OP_AELEM:
695     case OP_AELEMFAST:
696     case OP_ASLICE:
697     case OP_HELEM:
698     case OP_HSLICE:
699     case OP_UNPACK:
700     case OP_PACK:
701     case OP_JOIN:
702     case OP_LSLICE:
703     case OP_ANONLIST:
704     case OP_ANONHASH:
705     case OP_SORT:
706     case OP_REVERSE:
707     case OP_RANGE:
708     case OP_FLIP:
709     case OP_FLOP:
710     case OP_CALLER:
711     case OP_FILENO:
712     case OP_EOF:
713     case OP_TELL:
714     case OP_GETSOCKNAME:
715     case OP_GETPEERNAME:
716     case OP_READLINK:
717     case OP_TELLDIR:
718     case OP_GETPPID:
719     case OP_GETPGRP:
720     case OP_GETPRIORITY:
721     case OP_TIME:
722     case OP_TMS:
723     case OP_LOCALTIME:
724     case OP_GMTIME:
725     case OP_GHBYNAME:
726     case OP_GHBYADDR:
727     case OP_GHOSTENT:
728     case OP_GNBYNAME:
729     case OP_GNBYADDR:
730     case OP_GNETENT:
731     case OP_GPBYNAME:
732     case OP_GPBYNUMBER:
733     case OP_GPROTOENT:
734     case OP_GSBYNAME:
735     case OP_GSBYPORT:
736     case OP_GSERVENT:
737     case OP_GPWNAM:
738     case OP_GPWUID:
739     case OP_GGRNAM:
740     case OP_GGRGID:
741     case OP_GETLOGIN:
742     case OP_PROTOTYPE:
743       func_ops:
744         if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
745             useless = OP_DESC(o);
746         break;
747
748     case OP_NOT:
749        kid = cUNOPo->op_first;
750        if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
751            kid->op_type != OP_TRANS) {
752                 goto func_ops;
753        }
754        useless = "negative pattern binding (!~)";
755        break;
756
757     case OP_RV2GV:
758     case OP_RV2SV:
759     case OP_RV2AV:
760     case OP_RV2HV:
761         if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
762                 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
763             useless = "a variable";
764         break;
765
766     case OP_CONST:
767         sv = cSVOPo_sv;
768         if (cSVOPo->op_private & OPpCONST_STRICT)
769             no_bareword_allowed(o);
770         else {
771             if (ckWARN(WARN_VOID)) {
772                 useless = "a constant";
773                 /* don't warn on optimised away booleans, eg 
774                  * use constant Foo, 5; Foo || print; */
775                 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
776                     useless = 0;
777                 /* the constants 0 and 1 are permitted as they are
778                    conventionally used as dummies in constructs like
779                         1 while some_condition_with_side_effects;  */
780                 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
781                     useless = 0;
782                 else if (SvPOK(sv)) {
783                   /* perl4's way of mixing documentation and code
784                      (before the invention of POD) was based on a
785                      trick to mix nroff and perl code. The trick was
786                      built upon these three nroff macros being used in
787                      void context. The pink camel has the details in
788                      the script wrapman near page 319. */
789                     if (strnEQ(SvPVX_const(sv), "di", 2) ||
790                         strnEQ(SvPVX_const(sv), "ds", 2) ||
791                         strnEQ(SvPVX_const(sv), "ig", 2))
792                             useless = 0;
793                 }
794             }
795         }
796         op_null(o);             /* don't execute or even remember it */
797         break;
798
799     case OP_POSTINC:
800         o->op_type = OP_PREINC;         /* pre-increment is faster */
801         o->op_ppaddr = PL_ppaddr[OP_PREINC];
802         break;
803
804     case OP_POSTDEC:
805         o->op_type = OP_PREDEC;         /* pre-decrement is faster */
806         o->op_ppaddr = PL_ppaddr[OP_PREDEC];
807         break;
808
809     case OP_I_POSTINC:
810         o->op_type = OP_I_PREINC;       /* pre-increment is faster */
811         o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
812         break;
813
814     case OP_I_POSTDEC:
815         o->op_type = OP_I_PREDEC;       /* pre-decrement is faster */
816         o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
817         break;
818
819     case OP_OR:
820     case OP_AND:
821     case OP_DOR:
822     case OP_COND_EXPR:
823         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
824             scalarvoid(kid);
825         break;
826
827     case OP_NULL:
828         if (o->op_flags & OPf_STACKED)
829             break;
830         /* FALL THROUGH */
831     case OP_NEXTSTATE:
832     case OP_DBSTATE:
833     case OP_ENTERTRY:
834     case OP_ENTER:
835         if (!(o->op_flags & OPf_KIDS))
836             break;
837         /* FALL THROUGH */
838     case OP_SCOPE:
839     case OP_LEAVE:
840     case OP_LEAVETRY:
841     case OP_LEAVELOOP:
842     case OP_LINESEQ:
843     case OP_LIST:
844         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
845             scalarvoid(kid);
846         break;
847     case OP_ENTEREVAL:
848         scalarkids(o);
849         break;
850     case OP_REQUIRE:
851         /* all requires must return a boolean value */
852         o->op_flags &= ~OPf_WANT;
853         /* FALL THROUGH */
854     case OP_SCALAR:
855         return scalar(o);
856     case OP_SPLIT:
857         if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
858             if (!kPMOP->op_pmreplroot)
859                 deprecate_old("implicit split to @_");
860         }
861         break;
862     }
863     if (useless && ckWARN(WARN_VOID))
864         Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
865     return o;
866 }
867
868 OP *
869 Perl_listkids(pTHX_ OP *o)
870 {
871     if (o && o->op_flags & OPf_KIDS) {
872         OP *kid;
873         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
874             list(kid);
875     }
876     return o;
877 }
878
879 OP *
880 Perl_list(pTHX_ OP *o)
881 {
882     dVAR;
883     OP *kid;
884
885     /* assumes no premature commitment */
886     if (!o || (o->op_flags & OPf_WANT) || PL_error_count
887          || o->op_type == OP_RETURN)
888     {
889         return o;
890     }
891
892     if ((o->op_private & OPpTARGET_MY)
893         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
894     {
895         return o;                               /* As if inside SASSIGN */
896     }
897
898     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
899
900     switch (o->op_type) {
901     case OP_FLOP:
902     case OP_REPEAT:
903         list(cBINOPo->op_first);
904         break;
905     case OP_OR:
906     case OP_AND:
907     case OP_COND_EXPR:
908         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
909             list(kid);
910         break;
911     default:
912     case OP_MATCH:
913     case OP_QR:
914     case OP_SUBST:
915     case OP_NULL:
916         if (!(o->op_flags & OPf_KIDS))
917             break;
918         if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
919             list(cBINOPo->op_first);
920             return gen_constant_list(o);
921         }
922     case OP_LIST:
923         listkids(o);
924         break;
925     case OP_LEAVE:
926     case OP_LEAVETRY:
927         kid = cLISTOPo->op_first;
928         list(kid);
929         while ((kid = kid->op_sibling)) {
930             if (kid->op_sibling)
931                 scalarvoid(kid);
932             else
933                 list(kid);
934         }
935         WITH_THR(PL_curcop = &PL_compiling);
936         break;
937     case OP_SCOPE:
938     case OP_LINESEQ:
939         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
940             if (kid->op_sibling)
941                 scalarvoid(kid);
942             else
943                 list(kid);
944         }
945         WITH_THR(PL_curcop = &PL_compiling);
946         break;
947     case OP_REQUIRE:
948         /* all requires must return a boolean value */
949         o->op_flags &= ~OPf_WANT;
950         return scalar(o);
951     }
952     return o;
953 }
954
955 OP *
956 Perl_scalarseq(pTHX_ OP *o)
957 {
958     if (o) {
959         if (o->op_type == OP_LINESEQ ||
960              o->op_type == OP_SCOPE ||
961              o->op_type == OP_LEAVE ||
962              o->op_type == OP_LEAVETRY)
963         {
964             OP *kid;
965             for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
966                 if (kid->op_sibling) {
967                     scalarvoid(kid);
968                 }
969             }
970             PL_curcop = &PL_compiling;
971         }
972         o->op_flags &= ~OPf_PARENS;
973         if (PL_hints & HINT_BLOCK_SCOPE)
974             o->op_flags |= OPf_PARENS;
975     }
976     else
977         o = newOP(OP_STUB, 0);
978     return o;
979 }
980
981 STATIC OP *
982 S_modkids(pTHX_ OP *o, I32 type)
983 {
984     if (o && o->op_flags & OPf_KIDS) {
985         OP *kid;
986         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
987             mod(kid, type);
988     }
989     return o;
990 }
991
992 /* Propagate lvalue ("modifiable") context to an op and it's children.
993  * 'type' represents the context type, roughly based on the type of op that
994  * would do the modifying, although local() is represented by OP_NULL.
995  * It's responsible for detecting things that can't be modified,  flag
996  * things that need to behave specially in an lvalue context (e.g., "$$x = 5"
997  * might have to vivify a reference in $x), and so on.
998  *
999  * For example, "$a+1 = 2" would cause mod() to be called with o being
1000  * OP_ADD and type being OP_SASSIGN, and would output an error.
1001  */
1002
1003 OP *
1004 Perl_mod(pTHX_ OP *o, I32 type)
1005 {
1006     dVAR;
1007     OP *kid;
1008     /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
1009     int localize = -1;
1010
1011     if (!o || PL_error_count)
1012         return o;
1013
1014     if ((o->op_private & OPpTARGET_MY)
1015         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1016     {
1017         return o;
1018     }
1019
1020     switch (o->op_type) {
1021     case OP_UNDEF:
1022         localize = 0;
1023         PL_modcount++;
1024         return o;
1025     case OP_CONST:
1026         if (!(o->op_private & (OPpCONST_ARYBASE)))
1027             goto nomod;
1028         if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1029             PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
1030             PL_eval_start = 0;
1031         }
1032         else if (!type) {
1033             SAVEI32(PL_compiling.cop_arybase);
1034             PL_compiling.cop_arybase = 0;
1035         }
1036         else if (type == OP_REFGEN)
1037             goto nomod;
1038         else
1039             Perl_croak(aTHX_ "That use of $[ is unsupported");
1040         break;
1041     case OP_STUB:
1042         if (o->op_flags & OPf_PARENS)
1043             break;
1044         goto nomod;
1045     case OP_ENTERSUB:
1046         if ((type == OP_UNDEF || type == OP_REFGEN) &&
1047             !(o->op_flags & OPf_STACKED)) {
1048             o->op_type = OP_RV2CV;              /* entersub => rv2cv */
1049             o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1050             assert(cUNOPo->op_first->op_type == OP_NULL);
1051             op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1052             break;
1053         }
1054         else if (o->op_private & OPpENTERSUB_NOMOD)
1055             return o;
1056         else {                          /* lvalue subroutine call */
1057             o->op_private |= OPpLVAL_INTRO;
1058             PL_modcount = RETURN_UNLIMITED_NUMBER;
1059             if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1060                 /* Backward compatibility mode: */
1061                 o->op_private |= OPpENTERSUB_INARGS;
1062                 break;
1063             }
1064             else {                      /* Compile-time error message: */
1065                 OP *kid = cUNOPo->op_first;
1066                 CV *cv;
1067                 OP *okid;
1068
1069                 if (kid->op_type == OP_PUSHMARK)
1070                     goto skip_kids;
1071                 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1072                     Perl_croak(aTHX_
1073                                "panic: unexpected lvalue entersub "
1074                                "args: type/targ %ld:%"UVuf,
1075                                (long)kid->op_type, (UV)kid->op_targ);
1076                 kid = kLISTOP->op_first;
1077               skip_kids:
1078                 while (kid->op_sibling)
1079                     kid = kid->op_sibling;
1080                 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1081                     /* Indirect call */
1082                     if (kid->op_type == OP_METHOD_NAMED
1083                         || kid->op_type == OP_METHOD)
1084                     {
1085                         UNOP *newop;
1086
1087                         NewOp(1101, newop, 1, UNOP);
1088                         newop->op_type = OP_RV2CV;
1089                         newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1090                         newop->op_first = Nullop;
1091                         newop->op_next = (OP*)newop;
1092                         kid->op_sibling = (OP*)newop;
1093                         newop->op_private |= OPpLVAL_INTRO;
1094                         break;
1095                     }
1096
1097                     if (kid->op_type != OP_RV2CV)
1098                         Perl_croak(aTHX_
1099                                    "panic: unexpected lvalue entersub "
1100                                    "entry via type/targ %ld:%"UVuf,
1101                                    (long)kid->op_type, (UV)kid->op_targ);
1102                     kid->op_private |= OPpLVAL_INTRO;
1103                     break;      /* Postpone until runtime */
1104                 }
1105
1106                 okid = kid;
1107                 kid = kUNOP->op_first;
1108                 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1109                     kid = kUNOP->op_first;
1110                 if (kid->op_type == OP_NULL)
1111                     Perl_croak(aTHX_
1112                                "Unexpected constant lvalue entersub "
1113                                "entry via type/targ %ld:%"UVuf,
1114                                (long)kid->op_type, (UV)kid->op_targ);
1115                 if (kid->op_type != OP_GV) {
1116                     /* Restore RV2CV to check lvalueness */
1117                   restore_2cv:
1118                     if (kid->op_next && kid->op_next != kid) { /* Happens? */
1119                         okid->op_next = kid->op_next;
1120                         kid->op_next = okid;
1121                     }
1122                     else
1123                         okid->op_next = Nullop;
1124                     okid->op_type = OP_RV2CV;
1125                     okid->op_targ = 0;
1126                     okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1127                     okid->op_private |= OPpLVAL_INTRO;
1128                     break;
1129                 }
1130
1131                 cv = GvCV(kGVOP_gv);
1132                 if (!cv)
1133                     goto restore_2cv;
1134                 if (CvLVALUE(cv))
1135                     break;
1136             }
1137         }
1138         /* FALL THROUGH */
1139     default:
1140       nomod:
1141         /* grep, foreach, subcalls, refgen */
1142         if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1143             break;
1144         yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1145                      (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1146                       ? "do block"
1147                       : (o->op_type == OP_ENTERSUB
1148                         ? "non-lvalue subroutine call"
1149                         : OP_DESC(o))),
1150                      type ? PL_op_desc[type] : "local"));
1151         return o;
1152
1153     case OP_PREINC:
1154     case OP_PREDEC:
1155     case OP_POW:
1156     case OP_MULTIPLY:
1157     case OP_DIVIDE:
1158     case OP_MODULO:
1159     case OP_REPEAT:
1160     case OP_ADD:
1161     case OP_SUBTRACT:
1162     case OP_CONCAT:
1163     case OP_LEFT_SHIFT:
1164     case OP_RIGHT_SHIFT:
1165     case OP_BIT_AND:
1166     case OP_BIT_XOR:
1167     case OP_BIT_OR:
1168     case OP_I_MULTIPLY:
1169     case OP_I_DIVIDE:
1170     case OP_I_MODULO:
1171     case OP_I_ADD:
1172     case OP_I_SUBTRACT:
1173         if (!(o->op_flags & OPf_STACKED))
1174             goto nomod;
1175         PL_modcount++;
1176         break;
1177
1178     case OP_COND_EXPR:
1179         localize = 1;
1180         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1181             mod(kid, type);
1182         break;
1183
1184     case OP_RV2AV:
1185     case OP_RV2HV:
1186         if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1187            PL_modcount = RETURN_UNLIMITED_NUMBER;
1188             return o;           /* Treat \(@foo) like ordinary list. */
1189         }
1190         /* FALL THROUGH */
1191     case OP_RV2GV:
1192         if (scalar_mod_type(o, type))
1193             goto nomod;
1194         ref(cUNOPo->op_first, o->op_type);
1195         /* FALL THROUGH */
1196     case OP_ASLICE:
1197     case OP_HSLICE:
1198         if (type == OP_LEAVESUBLV)
1199             o->op_private |= OPpMAYBE_LVSUB;
1200         localize = 1;
1201         /* FALL THROUGH */
1202     case OP_AASSIGN:
1203     case OP_NEXTSTATE:
1204     case OP_DBSTATE:
1205        PL_modcount = RETURN_UNLIMITED_NUMBER;
1206         break;
1207     case OP_RV2SV:
1208         ref(cUNOPo->op_first, o->op_type);
1209         localize = 1;
1210         /* FALL THROUGH */
1211     case OP_GV:
1212     case OP_AV2ARYLEN:
1213         PL_hints |= HINT_BLOCK_SCOPE;
1214     case OP_SASSIGN:
1215     case OP_ANDASSIGN:
1216     case OP_ORASSIGN:
1217     case OP_DORASSIGN:
1218         PL_modcount++;
1219         break;
1220
1221     case OP_AELEMFAST:
1222         localize = -1;
1223         PL_modcount++;
1224         break;
1225
1226     case OP_PADAV:
1227     case OP_PADHV:
1228        PL_modcount = RETURN_UNLIMITED_NUMBER;
1229         if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1230             return o;           /* Treat \(@foo) like ordinary list. */
1231         if (scalar_mod_type(o, type))
1232             goto nomod;
1233         if (type == OP_LEAVESUBLV)
1234             o->op_private |= OPpMAYBE_LVSUB;
1235         /* FALL THROUGH */
1236     case OP_PADSV:
1237         PL_modcount++;
1238         if (!type) /* local() */
1239             Perl_croak(aTHX_ "Can't localize lexical variable %s",
1240                  PAD_COMPNAME_PV(o->op_targ));
1241         break;
1242
1243     case OP_PUSHMARK:
1244         localize = 0;
1245         break;
1246
1247     case OP_KEYS:
1248         if (type != OP_SASSIGN)
1249             goto nomod;
1250         goto lvalue_func;
1251     case OP_SUBSTR:
1252         if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1253             goto nomod;
1254         /* FALL THROUGH */
1255     case OP_POS:
1256     case OP_VEC:
1257         if (type == OP_LEAVESUBLV)
1258             o->op_private |= OPpMAYBE_LVSUB;
1259       lvalue_func:
1260         pad_free(o->op_targ);
1261         o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1262         assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1263         if (o->op_flags & OPf_KIDS)
1264             mod(cBINOPo->op_first->op_sibling, type);
1265         break;
1266
1267     case OP_AELEM:
1268     case OP_HELEM:
1269         ref(cBINOPo->op_first, o->op_type);
1270         if (type == OP_ENTERSUB &&
1271              !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1272             o->op_private |= OPpLVAL_DEFER;
1273         if (type == OP_LEAVESUBLV)
1274             o->op_private |= OPpMAYBE_LVSUB;
1275         localize = 1;
1276         PL_modcount++;
1277         break;
1278
1279     case OP_SCOPE:
1280     case OP_LEAVE:
1281     case OP_ENTER:
1282     case OP_LINESEQ:
1283         localize = 0;
1284         if (o->op_flags & OPf_KIDS)
1285             mod(cLISTOPo->op_last, type);
1286         break;
1287
1288     case OP_NULL:
1289         localize = 0;
1290         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
1291             goto nomod;
1292         else if (!(o->op_flags & OPf_KIDS))
1293             break;
1294         if (o->op_targ != OP_LIST) {
1295             mod(cBINOPo->op_first, type);
1296             break;
1297         }
1298         /* FALL THROUGH */
1299     case OP_LIST:
1300         localize = 0;
1301         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1302             mod(kid, type);
1303         break;
1304
1305     case OP_RETURN:
1306         if (type != OP_LEAVESUBLV)
1307             goto nomod;
1308         break; /* mod()ing was handled by ck_return() */
1309     }
1310
1311     /* [20011101.069] File test operators interpret OPf_REF to mean that
1312        their argument is a filehandle; thus \stat(".") should not set
1313        it. AMS 20011102 */
1314     if (type == OP_REFGEN &&
1315         PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
1316         return o;
1317
1318     if (type != OP_LEAVESUBLV)
1319         o->op_flags |= OPf_MOD;
1320
1321     if (type == OP_AASSIGN || type == OP_SASSIGN)
1322         o->op_flags |= OPf_SPECIAL|OPf_REF;
1323     else if (!type) { /* local() */
1324         switch (localize) {
1325         case 1:
1326             o->op_private |= OPpLVAL_INTRO;
1327             o->op_flags &= ~OPf_SPECIAL;
1328             PL_hints |= HINT_BLOCK_SCOPE;
1329             break;
1330         case 0:
1331             break;
1332         case -1:
1333             if (ckWARN(WARN_SYNTAX)) {
1334                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1335                     "Useless localization of %s", OP_DESC(o));
1336             }
1337         }
1338     }
1339     else if (type != OP_GREPSTART && type != OP_ENTERSUB
1340              && type != OP_LEAVESUBLV)
1341         o->op_flags |= OPf_REF;
1342     return o;
1343 }
1344
1345 STATIC bool
1346 S_scalar_mod_type(pTHX_ const OP *o, I32 type)
1347 {
1348     switch (type) {
1349     case OP_SASSIGN:
1350         if (o->op_type == OP_RV2GV)
1351             return FALSE;
1352         /* FALL THROUGH */
1353     case OP_PREINC:
1354     case OP_PREDEC:
1355     case OP_POSTINC:
1356     case OP_POSTDEC:
1357     case OP_I_PREINC:
1358     case OP_I_PREDEC:
1359     case OP_I_POSTINC:
1360     case OP_I_POSTDEC:
1361     case OP_POW:
1362     case OP_MULTIPLY:
1363     case OP_DIVIDE:
1364     case OP_MODULO:
1365     case OP_REPEAT:
1366     case OP_ADD:
1367     case OP_SUBTRACT:
1368     case OP_I_MULTIPLY:
1369     case OP_I_DIVIDE:
1370     case OP_I_MODULO:
1371     case OP_I_ADD:
1372     case OP_I_SUBTRACT:
1373     case OP_LEFT_SHIFT:
1374     case OP_RIGHT_SHIFT:
1375     case OP_BIT_AND:
1376     case OP_BIT_XOR:
1377     case OP_BIT_OR:
1378     case OP_CONCAT:
1379     case OP_SUBST:
1380     case OP_TRANS:
1381     case OP_READ:
1382     case OP_SYSREAD:
1383     case OP_RECV:
1384     case OP_ANDASSIGN:
1385     case OP_ORASSIGN:
1386         return TRUE;
1387     default:
1388         return FALSE;
1389     }
1390 }
1391
1392 STATIC bool
1393 S_is_handle_constructor(pTHX_ const OP *o, I32 numargs)
1394 {
1395     switch (o->op_type) {
1396     case OP_PIPE_OP:
1397     case OP_SOCKPAIR:
1398         if (numargs == 2)
1399             return TRUE;
1400         /* FALL THROUGH */
1401     case OP_SYSOPEN:
1402     case OP_OPEN:
1403     case OP_SELECT:             /* XXX c.f. SelectSaver.pm */
1404     case OP_SOCKET:
1405     case OP_OPEN_DIR:
1406     case OP_ACCEPT:
1407         if (numargs == 1)
1408             return TRUE;
1409         /* FALL THROUGH */
1410     default:
1411         return FALSE;
1412     }
1413 }
1414
1415 OP *
1416 Perl_refkids(pTHX_ OP *o, I32 type)
1417 {
1418     if (o && o->op_flags & OPf_KIDS) {
1419         OP *kid;
1420         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1421             ref(kid, type);
1422     }
1423     return o;
1424 }
1425
1426 OP *
1427 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
1428 {
1429     dVAR;
1430     OP *kid;
1431
1432     if (!o || PL_error_count)
1433         return o;
1434
1435     switch (o->op_type) {
1436     case OP_ENTERSUB:
1437         if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1438             !(o->op_flags & OPf_STACKED)) {
1439             o->op_type = OP_RV2CV;             /* entersub => rv2cv */
1440             o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1441             assert(cUNOPo->op_first->op_type == OP_NULL);
1442             op_null(((LISTOP*)cUNOPo->op_first)->op_first);     /* disable pushmark */
1443             o->op_flags |= OPf_SPECIAL;
1444         }
1445         break;
1446
1447     case OP_COND_EXPR:
1448         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1449             doref(kid, type, set_op_ref);
1450         break;
1451     case OP_RV2SV:
1452         if (type == OP_DEFINED)
1453             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
1454         doref(cUNOPo->op_first, o->op_type, set_op_ref);
1455         /* FALL THROUGH */
1456     case OP_PADSV:
1457         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1458             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1459                               : type == OP_RV2HV ? OPpDEREF_HV
1460                               : OPpDEREF_SV);
1461             o->op_flags |= OPf_MOD;
1462         }
1463         break;
1464
1465     case OP_THREADSV:
1466         o->op_flags |= OPf_MOD;         /* XXX ??? */
1467         break;
1468
1469     case OP_RV2AV:
1470     case OP_RV2HV:
1471         if (set_op_ref)
1472             o->op_flags |= OPf_REF;
1473         /* FALL THROUGH */
1474     case OP_RV2GV:
1475         if (type == OP_DEFINED)
1476             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
1477         doref(cUNOPo->op_first, o->op_type, set_op_ref);
1478         break;
1479
1480     case OP_PADAV:
1481     case OP_PADHV:
1482         if (set_op_ref)
1483             o->op_flags |= OPf_REF;
1484         break;
1485
1486     case OP_SCALAR:
1487     case OP_NULL:
1488         if (!(o->op_flags & OPf_KIDS))
1489             break;
1490         doref(cBINOPo->op_first, type, set_op_ref);
1491         break;
1492     case OP_AELEM:
1493     case OP_HELEM:
1494         doref(cBINOPo->op_first, o->op_type, set_op_ref);
1495         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1496             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1497                               : type == OP_RV2HV ? OPpDEREF_HV
1498                               : OPpDEREF_SV);
1499             o->op_flags |= OPf_MOD;
1500         }
1501         break;
1502
1503     case OP_SCOPE:
1504     case OP_LEAVE:
1505         set_op_ref = FALSE;
1506         /* FALL THROUGH */
1507     case OP_ENTER:
1508     case OP_LIST:
1509         if (!(o->op_flags & OPf_KIDS))
1510             break;
1511         doref(cLISTOPo->op_last, type, set_op_ref);
1512         break;
1513     default:
1514         break;
1515     }
1516     return scalar(o);
1517
1518 }
1519
1520 STATIC OP *
1521 S_dup_attrlist(pTHX_ OP *o)
1522 {
1523     OP *rop;
1524
1525     /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1526      * where the first kid is OP_PUSHMARK and the remaining ones
1527      * are OP_CONST.  We need to push the OP_CONST values.
1528      */
1529     if (o->op_type == OP_CONST)
1530         rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1531     else {
1532         assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1533         rop = Nullop;
1534         for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1535             if (o->op_type == OP_CONST)
1536                 rop = append_elem(OP_LIST, rop,
1537                                   newSVOP(OP_CONST, o->op_flags,
1538                                           SvREFCNT_inc(cSVOPo->op_sv)));
1539         }
1540     }
1541     return rop;
1542 }
1543
1544 STATIC void
1545 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
1546 {
1547     dVAR;
1548     SV *stashsv;
1549
1550     /* fake up C<use attributes $pkg,$rv,@attrs> */
1551     ENTER;              /* need to protect against side-effects of 'use' */
1552     SAVEINT(PL_expect);
1553     stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1554
1555 #define ATTRSMODULE "attributes"
1556 #define ATTRSMODULE_PM "attributes.pm"
1557
1558     if (for_my) {
1559         /* Don't force the C<use> if we don't need it. */
1560         SV * const * const svp = hv_fetch(GvHVn(PL_incgv), ATTRSMODULE_PM,
1561                        sizeof(ATTRSMODULE_PM)-1, 0);
1562         if (svp && *svp != &PL_sv_undef)
1563             ;           /* already in %INC */
1564         else
1565             Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
1566                              newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1567                              Nullsv);
1568     }
1569     else {
1570         Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1571                          newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1572                          Nullsv,
1573                          prepend_elem(OP_LIST,
1574                                       newSVOP(OP_CONST, 0, stashsv),
1575                                       prepend_elem(OP_LIST,
1576                                                    newSVOP(OP_CONST, 0,
1577                                                            newRV(target)),
1578                                                    dup_attrlist(attrs))));
1579     }
1580     LEAVE;
1581 }
1582
1583 STATIC void
1584 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
1585 {
1586     OP *pack, *imop, *arg;
1587     SV *meth, *stashsv;
1588
1589     if (!attrs)
1590         return;
1591
1592     assert(target->op_type == OP_PADSV ||
1593            target->op_type == OP_PADHV ||
1594            target->op_type == OP_PADAV);
1595
1596     /* Ensure that attributes.pm is loaded. */
1597     apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
1598
1599     /* Need package name for method call. */
1600     pack = newSVOP(OP_CONST, 0, newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1));
1601
1602     /* Build up the real arg-list. */
1603     stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
1604
1605     arg = newOP(OP_PADSV, 0);
1606     arg->op_targ = target->op_targ;
1607     arg = prepend_elem(OP_LIST,
1608                        newSVOP(OP_CONST, 0, stashsv),
1609                        prepend_elem(OP_LIST,
1610                                     newUNOP(OP_REFGEN, 0,
1611                                             mod(arg, OP_REFGEN)),
1612                                     dup_attrlist(attrs)));
1613
1614     /* Fake up a method call to import */
1615     meth = newSVpvn_share("import", 6, 0);
1616     imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
1617                    append_elem(OP_LIST,
1618                                prepend_elem(OP_LIST, pack, list(arg)),
1619                                newSVOP(OP_METHOD_NAMED, 0, meth)));
1620     imop->op_private |= OPpENTERSUB_NOMOD;
1621
1622     /* Combine the ops. */
1623     *imopsp = append_elem(OP_LIST, *imopsp, imop);
1624 }
1625
1626 /*
1627 =notfor apidoc apply_attrs_string
1628
1629 Attempts to apply a list of attributes specified by the C<attrstr> and
1630 C<len> arguments to the subroutine identified by the C<cv> argument which
1631 is expected to be associated with the package identified by the C<stashpv>
1632 argument (see L<attributes>).  It gets this wrong, though, in that it
1633 does not correctly identify the boundaries of the individual attribute
1634 specifications within C<attrstr>.  This is not really intended for the
1635 public API, but has to be listed here for systems such as AIX which
1636 need an explicit export list for symbols.  (It's called from XS code
1637 in support of the C<ATTRS:> keyword from F<xsubpp>.)  Patches to fix it
1638 to respect attribute syntax properly would be welcome.
1639
1640 =cut
1641 */
1642
1643 void
1644 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
1645                         const char *attrstr, STRLEN len)
1646 {
1647     OP *attrs = Nullop;
1648
1649     if (!len) {
1650         len = strlen(attrstr);
1651     }
1652
1653     while (len) {
1654         for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1655         if (len) {
1656             const char * const sstr = attrstr;
1657             for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1658             attrs = append_elem(OP_LIST, attrs,
1659                                 newSVOP(OP_CONST, 0,
1660                                         newSVpvn(sstr, attrstr-sstr)));
1661         }
1662     }
1663
1664     Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1665                      newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1666                      Nullsv, prepend_elem(OP_LIST,
1667                                   newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1668                                   prepend_elem(OP_LIST,
1669                                                newSVOP(OP_CONST, 0,
1670                                                        newRV((SV*)cv)),
1671                                                attrs)));
1672 }
1673
1674 STATIC OP *
1675 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
1676 {
1677     I32 type;
1678
1679     if (!o || PL_error_count)
1680         return o;
1681
1682     type = o->op_type;
1683     if (type == OP_LIST) {
1684         OP *kid;
1685         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1686             my_kid(kid, attrs, imopsp);
1687     } else if (type == OP_UNDEF) {
1688         return o;
1689     } else if (type == OP_RV2SV ||      /* "our" declaration */
1690                type == OP_RV2AV ||
1691                type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1692         if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
1693             yyerror(Perl_form(aTHX_ "Can't declare %s in %s",
1694                         OP_DESC(o), PL_in_my == KEY_our ? "our" : "my"));
1695         } else if (attrs) {
1696             GV * const gv = cGVOPx_gv(cUNOPo->op_first);
1697             PL_in_my = FALSE;
1698             PL_in_my_stash = Nullhv;
1699             apply_attrs(GvSTASH(gv),
1700                         (type == OP_RV2SV ? GvSV(gv) :
1701                          type == OP_RV2AV ? (SV*)GvAV(gv) :
1702                          type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1703                         attrs, FALSE);
1704         }
1705         o->op_private |= OPpOUR_INTRO;
1706         return o;
1707     }
1708     else if (type != OP_PADSV &&
1709              type != OP_PADAV &&
1710              type != OP_PADHV &&
1711              type != OP_PUSHMARK)
1712     {
1713         yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1714                           OP_DESC(o),
1715                           PL_in_my == KEY_our ? "our" : "my"));
1716         return o;
1717     }
1718     else if (attrs && type != OP_PUSHMARK) {
1719         HV *stash;
1720
1721         PL_in_my = FALSE;
1722         PL_in_my_stash = Nullhv;
1723
1724         /* check for C<my Dog $spot> when deciding package */
1725         stash = PAD_COMPNAME_TYPE(o->op_targ);
1726         if (!stash)
1727             stash = PL_curstash;
1728         apply_attrs_my(stash, o, attrs, imopsp);
1729     }
1730     o->op_flags |= OPf_MOD;
1731     o->op_private |= OPpLVAL_INTRO;
1732     return o;
1733 }
1734
1735 OP *
1736 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
1737 {
1738     OP *rops;
1739     int maybe_scalar = 0;
1740
1741 /* [perl #17376]: this appears to be premature, and results in code such as
1742    C< our(%x); > executing in list mode rather than void mode */
1743 #if 0
1744     if (o->op_flags & OPf_PARENS)
1745         list(o);
1746     else
1747         maybe_scalar = 1;
1748 #else
1749     maybe_scalar = 1;
1750 #endif
1751     if (attrs)
1752         SAVEFREEOP(attrs);
1753     rops = Nullop;
1754     o = my_kid(o, attrs, &rops);
1755     if (rops) {
1756         if (maybe_scalar && o->op_type == OP_PADSV) {
1757             o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
1758             o->op_private |= OPpLVAL_INTRO;
1759         }
1760         else
1761             o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
1762     }
1763     PL_in_my = FALSE;
1764     PL_in_my_stash = Nullhv;
1765     return o;
1766 }
1767
1768 OP *
1769 Perl_my(pTHX_ OP *o)
1770 {
1771     return my_attrs(o, Nullop);
1772 }
1773
1774 OP *
1775 Perl_sawparens(pTHX_ OP *o)
1776 {
1777     if (o)
1778         o->op_flags |= OPf_PARENS;
1779     return o;
1780 }
1781
1782 OP *
1783 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
1784 {
1785     OP *o;
1786     bool ismatchop = 0;
1787
1788     if ( (left->op_type == OP_RV2AV ||
1789        left->op_type == OP_RV2HV ||
1790        left->op_type == OP_PADAV ||
1791        left->op_type == OP_PADHV)
1792        && ckWARN(WARN_MISC))
1793     {
1794       const char * const desc = PL_op_desc[(right->op_type == OP_SUBST ||
1795                             right->op_type == OP_TRANS)
1796                            ? right->op_type : OP_MATCH];
1797       const char * const sample = ((left->op_type == OP_RV2AV ||
1798                              left->op_type == OP_PADAV)
1799                             ? "@array" : "%hash");
1800       Perl_warner(aTHX_ packWARN(WARN_MISC),
1801              "Applying %s to %s will act on scalar(%s)",
1802              desc, sample, sample);
1803     }
1804
1805     if (right->op_type == OP_CONST &&
1806         cSVOPx(right)->op_private & OPpCONST_BARE &&
1807         cSVOPx(right)->op_private & OPpCONST_STRICT)
1808     {
1809         no_bareword_allowed(right);
1810     }
1811
1812     ismatchop = right->op_type == OP_MATCH ||
1813                 right->op_type == OP_SUBST ||
1814                 right->op_type == OP_TRANS;
1815     if (ismatchop && right->op_private & OPpTARGET_MY) {
1816         right->op_targ = 0;
1817         right->op_private &= ~OPpTARGET_MY;
1818     }
1819     if (!(right->op_flags & OPf_STACKED) && ismatchop) {
1820         right->op_flags |= OPf_STACKED;
1821         if (right->op_type != OP_MATCH &&
1822             ! (right->op_type == OP_TRANS &&
1823                right->op_private & OPpTRANS_IDENTICAL))
1824             left = mod(left, right->op_type);
1825         if (right->op_type == OP_TRANS)
1826             o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
1827         else
1828             o = prepend_elem(right->op_type, scalar(left), right);
1829         if (type == OP_NOT)
1830             return newUNOP(OP_NOT, 0, scalar(o));
1831         return o;
1832     }
1833     else
1834         return bind_match(type, left,
1835                 pmruntime(newPMOP(OP_MATCH, 0), right, 0));
1836 }
1837
1838 OP *
1839 Perl_invert(pTHX_ OP *o)
1840 {
1841     if (!o)
1842         return o;
1843     /* XXX need to optimize away NOT NOT here?  Or do we let optimizer do it? */
1844     return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
1845 }
1846
1847 OP *
1848 Perl_scope(pTHX_ OP *o)
1849 {
1850     dVAR;
1851     if (o) {
1852         if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
1853             o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
1854             o->op_type = OP_LEAVE;
1855             o->op_ppaddr = PL_ppaddr[OP_LEAVE];
1856         }
1857         else if (o->op_type == OP_LINESEQ) {
1858             OP *kid;
1859             o->op_type = OP_SCOPE;
1860             o->op_ppaddr = PL_ppaddr[OP_SCOPE];
1861             kid = ((LISTOP*)o)->op_first;
1862             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
1863                 op_null(kid);
1864
1865                 /* The following deals with things like 'do {1 for 1}' */
1866                 kid = kid->op_sibling;
1867                 if (kid &&
1868                     (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
1869                     op_null(kid);
1870             }
1871         }
1872         else
1873             o = newLISTOP(OP_SCOPE, 0, o, Nullop);
1874     }
1875     return o;
1876 }
1877
1878 int
1879 Perl_block_start(pTHX_ int full)
1880 {
1881     const int retval = PL_savestack_ix;
1882     pad_block_start(full);
1883     SAVEHINTS();
1884     PL_hints &= ~HINT_BLOCK_SCOPE;
1885     SAVESPTR(PL_compiling.cop_warnings);
1886     if (! specialWARN(PL_compiling.cop_warnings)) {
1887         PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
1888         SAVEFREESV(PL_compiling.cop_warnings) ;
1889     }
1890     SAVESPTR(PL_compiling.cop_io);
1891     if (! specialCopIO(PL_compiling.cop_io)) {
1892         PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
1893         SAVEFREESV(PL_compiling.cop_io) ;
1894     }
1895     return retval;
1896 }
1897
1898 OP*
1899 Perl_block_end(pTHX_ I32 floor, OP *seq)
1900 {
1901     const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
1902     OP* const retval = scalarseq(seq);
1903     LEAVE_SCOPE(floor);
1904     PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
1905     if (needblockscope)
1906         PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
1907     pad_leavemy();
1908     return retval;
1909 }
1910
1911 STATIC OP *
1912 S_newDEFSVOP(pTHX)
1913 {
1914     const I32 offset = pad_findmy("$_");
1915     if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
1916         return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
1917     }
1918     else {
1919         OP * const o = newOP(OP_PADSV, 0);
1920         o->op_targ = offset;
1921         return o;
1922     }
1923 }
1924
1925 void
1926 Perl_newPROG(pTHX_ OP *o)
1927 {
1928     if (PL_in_eval) {
1929         if (PL_eval_root)
1930                 return;
1931         PL_eval_root = newUNOP(OP_LEAVEEVAL,
1932                                ((PL_in_eval & EVAL_KEEPERR)
1933                                 ? OPf_SPECIAL : 0), o);
1934         PL_eval_start = linklist(PL_eval_root);
1935         PL_eval_root->op_private |= OPpREFCOUNTED;
1936         OpREFCNT_set(PL_eval_root, 1);
1937         PL_eval_root->op_next = 0;
1938         CALL_PEEP(PL_eval_start);
1939     }
1940     else {
1941         if (o->op_type == OP_STUB) {
1942             PL_comppad_name = 0;
1943             PL_compcv = 0;
1944             FreeOp(o);
1945             return;
1946         }
1947         PL_main_root = scope(sawparens(scalarvoid(o)));
1948         PL_curcop = &PL_compiling;
1949         PL_main_start = LINKLIST(PL_main_root);
1950         PL_main_root->op_private |= OPpREFCOUNTED;
1951         OpREFCNT_set(PL_main_root, 1);
1952         PL_main_root->op_next = 0;
1953         CALL_PEEP(PL_main_start);
1954         PL_compcv = 0;
1955
1956         /* Register with debugger */
1957         if (PERLDB_INTER) {
1958             CV * const cv = get_cv("DB::postponed", FALSE);
1959             if (cv) {
1960                 dSP;
1961                 PUSHMARK(SP);
1962                 XPUSHs((SV*)CopFILEGV(&PL_compiling));
1963                 PUTBACK;
1964                 call_sv((SV*)cv, G_DISCARD);
1965             }
1966         }
1967     }
1968 }
1969
1970 OP *
1971 Perl_localize(pTHX_ OP *o, I32 lex)
1972 {
1973     if (o->op_flags & OPf_PARENS)
1974 /* [perl #17376]: this appears to be premature, and results in code such as
1975    C< our(%x); > executing in list mode rather than void mode */
1976 #if 0
1977         list(o);
1978 #else
1979         ;
1980 #endif
1981     else {
1982         if ( PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ','
1983             && ckWARN(WARN_PARENTHESIS))
1984         {
1985             char *s = PL_bufptr;
1986             bool sigil = FALSE;
1987
1988             /* some heuristics to detect a potential error */
1989             while (*s && (strchr(", \t\n", *s)))
1990                 s++;
1991
1992             while (1) {
1993                 if (*s && strchr("@$%*", *s) && *++s
1994                        && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
1995                     s++;
1996                     sigil = TRUE;
1997                     while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
1998                         s++;
1999                     while (*s && (strchr(", \t\n", *s)))
2000                         s++;
2001                 }
2002                 else
2003                     break;
2004             }
2005             if (sigil && (*s == ';' || *s == '=')) {
2006                 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
2007                                 "Parentheses missing around \"%s\" list",
2008                                 lex ? (PL_in_my == KEY_our ? "our" : "my")
2009                                 : "local");
2010             }
2011         }
2012     }
2013     if (lex)
2014         o = my(o);
2015     else
2016         o = mod(o, OP_NULL);            /* a bit kludgey */
2017     PL_in_my = FALSE;
2018     PL_in_my_stash = Nullhv;
2019     return o;
2020 }
2021
2022 OP *
2023 Perl_jmaybe(pTHX_ OP *o)
2024 {
2025     if (o->op_type == OP_LIST) {
2026         OP *o2;
2027         o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
2028         o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2029     }
2030     return o;
2031 }
2032
2033 OP *
2034 Perl_fold_constants(pTHX_ register OP *o)
2035 {
2036     dVAR;
2037     register OP *curop;
2038     I32 type = o->op_type;
2039     SV *sv;
2040
2041     if (PL_opargs[type] & OA_RETSCALAR)
2042         scalar(o);
2043     if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2044         o->op_targ = pad_alloc(type, SVs_PADTMP);
2045
2046     /* integerize op, unless it happens to be C<-foo>.
2047      * XXX should pp_i_negate() do magic string negation instead? */
2048     if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2049         && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2050              && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2051     {
2052         o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2053     }
2054
2055     if (!(PL_opargs[type] & OA_FOLDCONST))
2056         goto nope;
2057
2058     switch (type) {
2059     case OP_NEGATE:
2060         /* XXX might want a ck_negate() for this */
2061         cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2062         break;
2063     case OP_UCFIRST:
2064     case OP_LCFIRST:
2065     case OP_UC:
2066     case OP_LC:
2067     case OP_SLT:
2068     case OP_SGT:
2069     case OP_SLE:
2070     case OP_SGE:
2071     case OP_SCMP:
2072         /* XXX what about the numeric ops? */
2073         if (PL_hints & HINT_LOCALE)
2074             goto nope;
2075     }
2076
2077     if (PL_error_count)
2078         goto nope;              /* Don't try to run w/ errors */
2079
2080     for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2081         if ((curop->op_type != OP_CONST ||
2082              (curop->op_private & OPpCONST_BARE)) &&
2083             curop->op_type != OP_LIST &&
2084             curop->op_type != OP_SCALAR &&
2085             curop->op_type != OP_NULL &&
2086             curop->op_type != OP_PUSHMARK)
2087         {
2088             goto nope;
2089         }
2090     }
2091
2092     curop = LINKLIST(o);
2093     o->op_next = 0;
2094     PL_op = curop;
2095     CALLRUNOPS(aTHX);
2096     sv = *(PL_stack_sp--);
2097     if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2098         pad_swipe(o->op_targ,  FALSE);
2099     else if (SvTEMP(sv)) {                      /* grab mortal temp? */
2100         (void)SvREFCNT_inc(sv);
2101         SvTEMP_off(sv);
2102     }
2103     op_free(o);
2104     if (type == OP_RV2GV)
2105         return newGVOP(OP_GV, 0, (GV*)sv);
2106     return newSVOP(OP_CONST, 0, sv);
2107
2108   nope:
2109     return o;
2110 }
2111
2112 OP *
2113 Perl_gen_constant_list(pTHX_ register OP *o)
2114 {
2115     dVAR;
2116     register OP *curop;
2117     const I32 oldtmps_floor = PL_tmps_floor;
2118
2119     list(o);
2120     if (PL_error_count)
2121         return o;               /* Don't attempt to run with errors */
2122
2123     PL_op = curop = LINKLIST(o);
2124     o->op_next = 0;
2125     CALL_PEEP(curop);
2126     pp_pushmark();
2127     CALLRUNOPS(aTHX);
2128     PL_op = curop;
2129     pp_anonlist();
2130     PL_tmps_floor = oldtmps_floor;
2131
2132     o->op_type = OP_RV2AV;
2133     o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2134     o->op_flags &= ~OPf_REF;    /* treat \(1..2) like an ordinary list */
2135     o->op_flags |= OPf_PARENS;  /* and flatten \(1..2,3) */
2136     o->op_opt = 0;              /* needs to be revisited in peep() */
2137     curop = ((UNOP*)o)->op_first;
2138     ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2139     op_free(curop);
2140     linklist(o);
2141     return list(o);
2142 }
2143
2144 OP *
2145 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2146 {
2147     dVAR;
2148     if (!o || o->op_type != OP_LIST)
2149         o = newLISTOP(OP_LIST, 0, o, Nullop);
2150     else
2151         o->op_flags &= ~OPf_WANT;
2152
2153     if (!(PL_opargs[type] & OA_MARK))
2154         op_null(cLISTOPo->op_first);
2155
2156     o->op_type = (OPCODE)type;
2157     o->op_ppaddr = PL_ppaddr[type];
2158     o->op_flags |= flags;
2159
2160     o = CHECKOP(type, o);
2161     if (o->op_type != (unsigned)type)
2162         return o;
2163
2164     return fold_constants(o);
2165 }
2166
2167 /* List constructors */
2168
2169 OP *
2170 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2171 {
2172     if (!first)
2173         return last;
2174
2175     if (!last)
2176         return first;
2177
2178     if (first->op_type != (unsigned)type
2179         || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2180     {
2181         return newLISTOP(type, 0, first, last);
2182     }
2183
2184     if (first->op_flags & OPf_KIDS)
2185         ((LISTOP*)first)->op_last->op_sibling = last;
2186     else {
2187         first->op_flags |= OPf_KIDS;
2188         ((LISTOP*)first)->op_first = last;
2189     }
2190     ((LISTOP*)first)->op_last = last;
2191     return first;
2192 }
2193
2194 OP *
2195 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2196 {
2197     if (!first)
2198         return (OP*)last;
2199
2200     if (!last)
2201         return (OP*)first;
2202
2203     if (first->op_type != (unsigned)type)
2204         return prepend_elem(type, (OP*)first, (OP*)last);
2205
2206     if (last->op_type != (unsigned)type)
2207         return append_elem(type, (OP*)first, (OP*)last);
2208
2209     first->op_last->op_sibling = last->op_first;
2210     first->op_last = last->op_last;
2211     first->op_flags |= (last->op_flags & OPf_KIDS);
2212
2213     FreeOp(last);
2214
2215     return (OP*)first;
2216 }
2217
2218 OP *
2219 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2220 {
2221     if (!first)
2222         return last;
2223
2224     if (!last)
2225         return first;
2226
2227     if (last->op_type == (unsigned)type) {
2228         if (type == OP_LIST) {  /* already a PUSHMARK there */
2229             first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2230             ((LISTOP*)last)->op_first->op_sibling = first;
2231             if (!(first->op_flags & OPf_PARENS))
2232                 last->op_flags &= ~OPf_PARENS;
2233         }
2234         else {
2235             if (!(last->op_flags & OPf_KIDS)) {
2236                 ((LISTOP*)last)->op_last = first;
2237                 last->op_flags |= OPf_KIDS;
2238             }
2239             first->op_sibling = ((LISTOP*)last)->op_first;
2240             ((LISTOP*)last)->op_first = first;
2241         }
2242         last->op_flags |= OPf_KIDS;
2243         return last;
2244     }
2245
2246     return newLISTOP(type, 0, first, last);
2247 }
2248
2249 /* Constructors */
2250
2251 OP *
2252 Perl_newNULLLIST(pTHX)
2253 {
2254     return newOP(OP_STUB, 0);
2255 }
2256
2257 OP *
2258 Perl_force_list(pTHX_ OP *o)
2259 {
2260     if (!o || o->op_type != OP_LIST)
2261         o = newLISTOP(OP_LIST, 0, o, Nullop);
2262     op_null(o);
2263     return o;
2264 }
2265
2266 OP *
2267 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2268 {
2269     dVAR;
2270     LISTOP *listop;
2271
2272     NewOp(1101, listop, 1, LISTOP);
2273
2274     listop->op_type = (OPCODE)type;
2275     listop->op_ppaddr = PL_ppaddr[type];
2276     if (first || last)
2277         flags |= OPf_KIDS;
2278     listop->op_flags = (U8)flags;
2279
2280     if (!last && first)
2281         last = first;
2282     else if (!first && last)
2283         first = last;
2284     else if (first)
2285         first->op_sibling = last;
2286     listop->op_first = first;
2287     listop->op_last = last;
2288     if (type == OP_LIST) {
2289         OP* const pushop = newOP(OP_PUSHMARK, 0);
2290         pushop->op_sibling = first;
2291         listop->op_first = pushop;
2292         listop->op_flags |= OPf_KIDS;
2293         if (!last)
2294             listop->op_last = pushop;
2295     }
2296
2297     return CHECKOP(type, listop);
2298 }
2299
2300 OP *
2301 Perl_newOP(pTHX_ I32 type, I32 flags)
2302 {
2303     dVAR;
2304     OP *o;
2305     NewOp(1101, o, 1, OP);
2306     o->op_type = (OPCODE)type;
2307     o->op_ppaddr = PL_ppaddr[type];
2308     o->op_flags = (U8)flags;
2309
2310     o->op_next = o;
2311     o->op_private = (U8)(0 | (flags >> 8));
2312     if (PL_opargs[type] & OA_RETSCALAR)
2313         scalar(o);
2314     if (PL_opargs[type] & OA_TARGET)
2315         o->op_targ = pad_alloc(type, SVs_PADTMP);
2316     return CHECKOP(type, o);
2317 }
2318
2319 OP *
2320 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2321 {
2322     dVAR;
2323     UNOP *unop;
2324
2325     if (!first)
2326         first = newOP(OP_STUB, 0);
2327     if (PL_opargs[type] & OA_MARK)
2328         first = force_list(first);
2329
2330     NewOp(1101, unop, 1, UNOP);
2331     unop->op_type = (OPCODE)type;
2332     unop->op_ppaddr = PL_ppaddr[type];
2333     unop->op_first = first;
2334     unop->op_flags = (U8)(flags | OPf_KIDS);
2335     unop->op_private = (U8)(1 | (flags >> 8));
2336     unop = (UNOP*) CHECKOP(type, unop);
2337     if (unop->op_next)
2338         return (OP*)unop;
2339
2340     return fold_constants((OP *) unop);
2341 }
2342
2343 OP *
2344 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2345 {
2346     dVAR;
2347     BINOP *binop;
2348     NewOp(1101, binop, 1, BINOP);
2349
2350     if (!first)
2351         first = newOP(OP_NULL, 0);
2352
2353     binop->op_type = (OPCODE)type;
2354     binop->op_ppaddr = PL_ppaddr[type];
2355     binop->op_first = first;
2356     binop->op_flags = (U8)(flags | OPf_KIDS);
2357     if (!last) {
2358         last = first;
2359         binop->op_private = (U8)(1 | (flags >> 8));
2360     }
2361     else {
2362         binop->op_private = (U8)(2 | (flags >> 8));
2363         first->op_sibling = last;
2364     }
2365
2366     binop = (BINOP*)CHECKOP(type, binop);
2367     if (binop->op_next || binop->op_type != (OPCODE)type)
2368         return (OP*)binop;
2369
2370     binop->op_last = binop->op_first->op_sibling;
2371
2372     return fold_constants((OP *)binop);
2373 }
2374
2375 static int uvcompare(const void *a, const void *b) __attribute__nonnull__(1) __attribute__nonnull__(2) __attribute__pure__;
2376 static int uvcompare(const void *a, const void *b)
2377 {
2378     if (*((const UV *)a) < (*(const UV *)b))
2379         return -1;
2380     if (*((const UV *)a) > (*(const UV *)b))
2381         return 1;
2382     if (*((const UV *)a+1) < (*(const UV *)b+1))
2383         return -1;
2384     if (*((const UV *)a+1) > (*(const UV *)b+1))
2385         return 1;
2386     return 0;
2387 }
2388
2389 OP *
2390 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2391 {
2392     SV * const tstr = ((SVOP*)expr)->op_sv;
2393     SV * const rstr = ((SVOP*)repl)->op_sv;
2394     STRLEN tlen;
2395     STRLEN rlen;
2396     const U8 *t = (U8*)SvPV_const(tstr, tlen);
2397     const U8 *r = (U8*)SvPV_const(rstr, rlen);
2398     register I32 i;
2399     register I32 j;
2400     I32 grows = 0;
2401     register short *tbl;
2402
2403     const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
2404     const I32 squash     = o->op_private & OPpTRANS_SQUASH;
2405     I32 del              = o->op_private & OPpTRANS_DELETE;
2406     PL_hints |= HINT_BLOCK_SCOPE;
2407
2408     if (SvUTF8(tstr))
2409         o->op_private |= OPpTRANS_FROM_UTF;
2410
2411     if (SvUTF8(rstr))
2412         o->op_private |= OPpTRANS_TO_UTF;
2413
2414     if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2415         SV* const listsv = newSVpvn("# comment\n",10);
2416         SV* transv = 0;
2417         const U8* tend = t + tlen;
2418         const U8* rend = r + rlen;
2419         STRLEN ulen;
2420         UV tfirst = 1;
2421         UV tlast = 0;
2422         IV tdiff;
2423         UV rfirst = 1;
2424         UV rlast = 0;
2425         IV rdiff;
2426         IV diff;
2427         I32 none = 0;
2428         U32 max = 0;
2429         I32 bits;
2430         I32 havefinal = 0;
2431         U32 final = 0;
2432         const I32 from_utf  = o->op_private & OPpTRANS_FROM_UTF;
2433         const I32 to_utf    = o->op_private & OPpTRANS_TO_UTF;
2434         U8* tsave = NULL;
2435         U8* rsave = NULL;
2436
2437         if (!from_utf) {
2438             STRLEN len = tlen;
2439             t = tsave = bytes_to_utf8(t, &len);
2440             tend = t + len;
2441         }
2442         if (!to_utf && rlen) {
2443             STRLEN len = rlen;
2444             r = rsave = bytes_to_utf8(r, &len);
2445             rend = r + len;
2446         }
2447
2448 /* There are several snags with this code on EBCDIC:
2449    1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2450    2. scan_const() in toke.c has encoded chars in native encoding which makes
2451       ranges at least in EBCDIC 0..255 range the bottom odd.
2452 */
2453
2454         if (complement) {
2455             U8 tmpbuf[UTF8_MAXBYTES+1];
2456             UV *cp;
2457             UV nextmin = 0;
2458             Newx(cp, 2*tlen, UV);
2459             i = 0;
2460             transv = newSVpvn("",0);
2461             while (t < tend) {
2462                 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2463                 t += ulen;
2464                 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2465                     t++;
2466                     cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2467                     t += ulen;
2468                 }
2469                 else {
2470                  cp[2*i+1] = cp[2*i];
2471                 }
2472                 i++;
2473             }
2474             qsort(cp, i, 2*sizeof(UV), uvcompare);
2475             for (j = 0; j < i; j++) {
2476                 UV  val = cp[2*j];
2477                 diff = val - nextmin;
2478                 if (diff > 0) {
2479                     t = uvuni_to_utf8(tmpbuf,nextmin);
2480                     sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2481                     if (diff > 1) {
2482                         U8  range_mark = UTF_TO_NATIVE(0xff);
2483                         t = uvuni_to_utf8(tmpbuf, val - 1);
2484                         sv_catpvn(transv, (char *)&range_mark, 1);
2485                         sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2486                     }
2487                 }
2488                 val = cp[2*j+1];
2489                 if (val >= nextmin)
2490                     nextmin = val + 1;
2491             }
2492             t = uvuni_to_utf8(tmpbuf,nextmin);
2493             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2494             {
2495                 U8 range_mark = UTF_TO_NATIVE(0xff);
2496                 sv_catpvn(transv, (char *)&range_mark, 1);
2497             }
2498             t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2499                                     UNICODE_ALLOW_SUPER);
2500             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2501             t = (const U8*)SvPVX_const(transv);
2502             tlen = SvCUR(transv);
2503             tend = t + tlen;
2504             Safefree(cp);
2505         }
2506         else if (!rlen && !del) {
2507             r = t; rlen = tlen; rend = tend;
2508         }
2509         if (!squash) {
2510                 if ((!rlen && !del) || t == r ||
2511                     (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2512                 {
2513                     o->op_private |= OPpTRANS_IDENTICAL;
2514                 }
2515         }
2516
2517         while (t < tend || tfirst <= tlast) {
2518             /* see if we need more "t" chars */
2519             if (tfirst > tlast) {
2520                 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2521                 t += ulen;
2522                 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {    /* illegal utf8 val indicates range */
2523                     t++;
2524                     tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2525                     t += ulen;
2526                 }
2527                 else
2528                     tlast = tfirst;
2529             }
2530
2531             /* now see if we need more "r" chars */
2532             if (rfirst > rlast) {
2533                 if (r < rend) {
2534                     rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2535                     r += ulen;
2536                     if (r < rend && NATIVE_TO_UTF(*r) == 0xff) {        /* illegal utf8 val indicates range */
2537                         r++;
2538                         rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2539                         r += ulen;
2540                     }
2541                     else
2542                         rlast = rfirst;
2543                 }
2544                 else {
2545                     if (!havefinal++)
2546                         final = rlast;
2547                     rfirst = rlast = 0xffffffff;
2548                 }
2549             }
2550
2551             /* now see which range will peter our first, if either. */
2552             tdiff = tlast - tfirst;
2553             rdiff = rlast - rfirst;
2554
2555             if (tdiff <= rdiff)
2556                 diff = tdiff;
2557             else
2558                 diff = rdiff;
2559
2560             if (rfirst == 0xffffffff) {
2561                 diff = tdiff;   /* oops, pretend rdiff is infinite */
2562                 if (diff > 0)
2563                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2564                                    (long)tfirst, (long)tlast);
2565                 else
2566                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2567             }
2568             else {
2569                 if (diff > 0)
2570                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2571                                    (long)tfirst, (long)(tfirst + diff),
2572                                    (long)rfirst);
2573                 else
2574                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2575                                    (long)tfirst, (long)rfirst);
2576
2577                 if (rfirst + diff > max)
2578                     max = rfirst + diff;
2579                 if (!grows)
2580                     grows = (tfirst < rfirst &&
2581                              UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2582                 rfirst += diff + 1;
2583             }
2584             tfirst += diff + 1;
2585         }
2586
2587         none = ++max;
2588         if (del)
2589             del = ++max;
2590
2591         if (max > 0xffff)
2592             bits = 32;
2593         else if (max > 0xff)
2594             bits = 16;
2595         else
2596             bits = 8;
2597
2598         Safefree(cPVOPo->op_pv);
2599         cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2600         SvREFCNT_dec(listsv);
2601         if (transv)
2602             SvREFCNT_dec(transv);
2603
2604         if (!del && havefinal && rlen)
2605             (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2606                            newSVuv((UV)final), 0);
2607
2608         if (grows)
2609             o->op_private |= OPpTRANS_GROWS;
2610
2611         if (tsave)
2612             Safefree(tsave);
2613         if (rsave)
2614             Safefree(rsave);
2615
2616         op_free(expr);
2617         op_free(repl);
2618         return o;
2619     }
2620
2621     tbl = (short*)cPVOPo->op_pv;
2622     if (complement) {
2623         Zero(tbl, 256, short);
2624         for (i = 0; i < (I32)tlen; i++)
2625             tbl[t[i]] = -1;
2626         for (i = 0, j = 0; i < 256; i++) {
2627             if (!tbl[i]) {
2628                 if (j >= (I32)rlen) {
2629                     if (del)
2630                         tbl[i] = -2;
2631                     else if (rlen)
2632                         tbl[i] = r[j-1];
2633                     else
2634                         tbl[i] = (short)i;
2635                 }
2636                 else {
2637                     if (i < 128 && r[j] >= 128)
2638                         grows = 1;
2639                     tbl[i] = r[j++];
2640                 }
2641             }
2642         }
2643         if (!del) {
2644             if (!rlen) {
2645                 j = rlen;
2646                 if (!squash)
2647                     o->op_private |= OPpTRANS_IDENTICAL;
2648             }
2649             else if (j >= (I32)rlen)
2650                 j = rlen - 1;
2651             else
2652                 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2653             tbl[0x100] = (short)(rlen - j);
2654             for (i=0; i < (I32)rlen - j; i++)
2655                 tbl[0x101+i] = r[j+i];
2656         }
2657     }
2658     else {
2659         if (!rlen && !del) {
2660             r = t; rlen = tlen;
2661             if (!squash)
2662                 o->op_private |= OPpTRANS_IDENTICAL;
2663         }
2664         else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
2665             o->op_private |= OPpTRANS_IDENTICAL;
2666         }
2667         for (i = 0; i < 256; i++)
2668             tbl[i] = -1;
2669         for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
2670             if (j >= (I32)rlen) {
2671                 if (del) {
2672                     if (tbl[t[i]] == -1)
2673                         tbl[t[i]] = -2;
2674                     continue;
2675                 }
2676                 --j;
2677             }
2678             if (tbl[t[i]] == -1) {
2679                 if (t[i] < 128 && r[j] >= 128)
2680                     grows = 1;
2681                 tbl[t[i]] = r[j];
2682             }
2683         }
2684     }
2685     if (grows)
2686         o->op_private |= OPpTRANS_GROWS;
2687     op_free(expr);
2688     op_free(repl);
2689
2690     return o;
2691 }
2692
2693 OP *
2694 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2695 {
2696     dVAR;
2697     PMOP *pmop;
2698
2699     NewOp(1101, pmop, 1, PMOP);
2700     pmop->op_type = (OPCODE)type;
2701     pmop->op_ppaddr = PL_ppaddr[type];
2702     pmop->op_flags = (U8)flags;
2703     pmop->op_private = (U8)(0 | (flags >> 8));
2704
2705     if (PL_hints & HINT_RE_TAINT)
2706         pmop->op_pmpermflags |= PMf_RETAINT;
2707     if (PL_hints & HINT_LOCALE)
2708         pmop->op_pmpermflags |= PMf_LOCALE;
2709     pmop->op_pmflags = pmop->op_pmpermflags;
2710
2711 #ifdef USE_ITHREADS
2712     if (av_len((AV*) PL_regex_pad[0]) > -1) {
2713         SV * const repointer = av_pop((AV*)PL_regex_pad[0]);
2714         pmop->op_pmoffset = SvIV(repointer);
2715         SvREPADTMP_off(repointer);
2716         sv_setiv(repointer,0);
2717     } else {
2718         SV * const repointer = newSViv(0);
2719         av_push(PL_regex_padav,SvREFCNT_inc(repointer));
2720         pmop->op_pmoffset = av_len(PL_regex_padav);
2721         PL_regex_pad = AvARRAY(PL_regex_padav);
2722     }
2723 #endif
2724
2725         /* link into pm list */
2726     if (type != OP_TRANS && PL_curstash) {
2727         MAGIC *mg = mg_find((SV*)PL_curstash, PERL_MAGIC_symtab);
2728
2729         if (!mg) {
2730             mg = sv_magicext((SV*)PL_curstash, 0, PERL_MAGIC_symtab, 0, 0, 0);
2731         }
2732         pmop->op_pmnext = (PMOP*)mg->mg_obj;
2733         mg->mg_obj = (SV*)pmop;
2734         PmopSTASH_set(pmop,PL_curstash);
2735     }
2736
2737     return CHECKOP(type, pmop);
2738 }
2739
2740 /* Given some sort of match op o, and an expression expr containing a
2741  * pattern, either compile expr into a regex and attach it to o (if it's
2742  * constant), or convert expr into a runtime regcomp op sequence (if it's
2743  * not)
2744  *
2745  * isreg indicates that the pattern is part of a regex construct, eg
2746  * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
2747  * split "pattern", which aren't. In the former case, expr will be a list
2748  * if the pattern contains more than one term (eg /a$b/) or if it contains
2749  * a replacement, ie s/// or tr///.
2750  */
2751
2752 OP *
2753 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
2754 {
2755     dVAR;
2756     PMOP *pm;
2757     LOGOP *rcop;
2758     I32 repl_has_vars = 0;
2759     OP* repl  = Nullop;
2760     bool reglist;
2761
2762     if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
2763         /* last element in list is the replacement; pop it */
2764         OP* kid;
2765         repl = cLISTOPx(expr)->op_last;
2766         kid = cLISTOPx(expr)->op_first;
2767         while (kid->op_sibling != repl)
2768             kid = kid->op_sibling;
2769         kid->op_sibling = Nullop;
2770         cLISTOPx(expr)->op_last = kid;
2771     }
2772
2773     if (isreg && expr->op_type == OP_LIST &&
2774         cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
2775     {
2776         /* convert single element list to element */
2777         OP* const oe = expr;
2778         expr = cLISTOPx(oe)->op_first->op_sibling;
2779         cLISTOPx(oe)->op_first->op_sibling = Nullop;
2780         cLISTOPx(oe)->op_last = Nullop;
2781         op_free(oe);
2782     }
2783
2784     if (o->op_type == OP_TRANS) {
2785         return pmtrans(o, expr, repl);
2786     }
2787
2788     reglist = isreg && expr->op_type == OP_LIST;
2789     if (reglist)
2790         op_null(expr);
2791
2792     PL_hints |= HINT_BLOCK_SCOPE;
2793     pm = (PMOP*)o;
2794
2795     if (expr->op_type == OP_CONST) {
2796         STRLEN plen;
2797         SV *pat = ((SVOP*)expr)->op_sv;
2798         const char *p = SvPV_const(pat, plen);
2799         if ((o->op_flags & OPf_SPECIAL) && (*p == ' ' && p[1] == '\0')) {
2800             U32 was_readonly = SvREADONLY(pat);
2801
2802             if (was_readonly) {
2803                 if (SvFAKE(pat)) {
2804                     sv_force_normal_flags(pat, 0);
2805                     assert(!SvREADONLY(pat));
2806                     was_readonly = 0;
2807                 } else {
2808                     SvREADONLY_off(pat);
2809                 }
2810             }   
2811
2812             sv_setpvn(pat, "\\s+", 3);
2813
2814             SvFLAGS(pat) |= was_readonly;
2815
2816             p = SvPV_const(pat, plen);
2817             pm->op_pmflags |= PMf_SKIPWHITE;
2818         }
2819         if (DO_UTF8(pat))
2820             pm->op_pmdynflags |= PMdf_UTF8;
2821         /* FIXME - can we make this function take const char * args?  */
2822         PM_SETRE(pm, CALLREGCOMP(aTHX_ (char*)p, (char*)p + plen, pm));
2823         if (strEQ("\\s+", PM_GETRE(pm)->precomp))
2824             pm->op_pmflags |= PMf_WHITE;
2825         op_free(expr);
2826     }
2827     else {
2828         if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
2829             expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2830                             ? OP_REGCRESET
2831                             : OP_REGCMAYBE),0,expr);
2832
2833         NewOp(1101, rcop, 1, LOGOP);
2834         rcop->op_type = OP_REGCOMP;
2835         rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
2836         rcop->op_first = scalar(expr);
2837         rcop->op_flags |= OPf_KIDS
2838                             | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
2839                             | (reglist ? OPf_STACKED : 0);
2840         rcop->op_private = 1;
2841         rcop->op_other = o;
2842         if (reglist)
2843             rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
2844
2845         /* /$x/ may cause an eval, since $x might be qr/(?{..})/  */
2846         PL_cv_has_eval = 1;
2847
2848         /* establish postfix order */
2849         if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
2850             LINKLIST(expr);
2851             rcop->op_next = expr;
2852             ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
2853         }
2854         else {
2855             rcop->op_next = LINKLIST(expr);
2856             expr->op_next = (OP*)rcop;
2857         }
2858
2859         prepend_elem(o->op_type, scalar((OP*)rcop), o);
2860     }
2861
2862     if (repl) {
2863         OP *curop;
2864         if (pm->op_pmflags & PMf_EVAL) {
2865             curop = 0;
2866             if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
2867                 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
2868         }
2869         else if (repl->op_type == OP_CONST)
2870             curop = repl;
2871         else {
2872             OP *lastop = 0;
2873             for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
2874                 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
2875                     if (curop->op_type == OP_GV) {
2876                         GV *gv = cGVOPx_gv(curop);
2877                         repl_has_vars = 1;
2878                         if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
2879                             break;
2880                     }
2881                     else if (curop->op_type == OP_RV2CV)
2882                         break;
2883                     else if (curop->op_type == OP_RV2SV ||
2884                              curop->op_type == OP_RV2AV ||
2885                              curop->op_type == OP_RV2HV ||
2886                              curop->op_type == OP_RV2GV) {
2887                         if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
2888                             break;
2889                     }
2890                     else if (curop->op_type == OP_PADSV ||
2891                              curop->op_type == OP_PADAV ||
2892                              curop->op_type == OP_PADHV ||
2893                              curop->op_type == OP_PADANY) {
2894                         repl_has_vars = 1;
2895                     }
2896                     else if (curop->op_type == OP_PUSHRE)
2897                         ; /* Okay here, dangerous in newASSIGNOP */
2898                     else
2899                         break;
2900                 }
2901                 lastop = curop;
2902             }
2903         }
2904         if (curop == repl
2905             && !(repl_has_vars
2906                  && (!PM_GETRE(pm)
2907                      || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
2908             pm->op_pmflags |= PMf_CONST;        /* const for long enough */
2909             pm->op_pmpermflags |= PMf_CONST;    /* const for long enough */
2910             prepend_elem(o->op_type, scalar(repl), o);
2911         }
2912         else {
2913             if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
2914                 pm->op_pmflags |= PMf_MAYBE_CONST;
2915                 pm->op_pmpermflags |= PMf_MAYBE_CONST;
2916             }
2917             NewOp(1101, rcop, 1, LOGOP);
2918             rcop->op_type = OP_SUBSTCONT;
2919             rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
2920             rcop->op_first = scalar(repl);
2921             rcop->op_flags |= OPf_KIDS;
2922             rcop->op_private = 1;
2923             rcop->op_other = o;
2924
2925             /* establish postfix order */
2926             rcop->op_next = LINKLIST(repl);
2927             repl->op_next = (OP*)rcop;
2928
2929             pm->op_pmreplroot = scalar((OP*)rcop);
2930             pm->op_pmreplstart = LINKLIST(rcop);
2931             rcop->op_next = 0;
2932         }
2933     }
2934
2935     return (OP*)pm;
2936 }
2937
2938 OP *
2939 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
2940 {
2941     dVAR;
2942     SVOP *svop;
2943     NewOp(1101, svop, 1, SVOP);
2944     svop->op_type = (OPCODE)type;
2945     svop->op_ppaddr = PL_ppaddr[type];
2946     svop->op_sv = sv;
2947     svop->op_next = (OP*)svop;
2948     svop->op_flags = (U8)flags;
2949     if (PL_opargs[type] & OA_RETSCALAR)
2950         scalar((OP*)svop);
2951     if (PL_opargs[type] & OA_TARGET)
2952         svop->op_targ = pad_alloc(type, SVs_PADTMP);
2953     return CHECKOP(type, svop);
2954 }
2955
2956 OP *
2957 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
2958 {
2959     dVAR;
2960     PADOP *padop;
2961     NewOp(1101, padop, 1, PADOP);
2962     padop->op_type = (OPCODE)type;
2963     padop->op_ppaddr = PL_ppaddr[type];
2964     padop->op_padix = pad_alloc(type, SVs_PADTMP);
2965     SvREFCNT_dec(PAD_SVl(padop->op_padix));
2966     PAD_SETSV(padop->op_padix, sv);
2967     if (sv)
2968         SvPADTMP_on(sv);
2969     padop->op_next = (OP*)padop;
2970     padop->op_flags = (U8)flags;
2971     if (PL_opargs[type] & OA_RETSCALAR)
2972         scalar((OP*)padop);
2973     if (PL_opargs[type] & OA_TARGET)
2974         padop->op_targ = pad_alloc(type, SVs_PADTMP);
2975     return CHECKOP(type, padop);
2976 }
2977
2978 OP *
2979 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
2980 {
2981     dVAR;
2982 #ifdef USE_ITHREADS
2983     if (gv)
2984         GvIN_PAD_on(gv);
2985     return newPADOP(type, flags, SvREFCNT_inc(gv));
2986 #else
2987     return newSVOP(type, flags, SvREFCNT_inc(gv));
2988 #endif
2989 }
2990
2991 OP *
2992 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
2993 {
2994     dVAR;
2995     PVOP *pvop;
2996     NewOp(1101, pvop, 1, PVOP);
2997     pvop->op_type = (OPCODE)type;
2998     pvop->op_ppaddr = PL_ppaddr[type];
2999     pvop->op_pv = pv;
3000     pvop->op_next = (OP*)pvop;
3001     pvop->op_flags = (U8)flags;
3002     if (PL_opargs[type] & OA_RETSCALAR)
3003         scalar((OP*)pvop);
3004     if (PL_opargs[type] & OA_TARGET)
3005         pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3006     return CHECKOP(type, pvop);
3007 }
3008
3009 void
3010 Perl_package(pTHX_ OP *o)
3011 {
3012     const char *name;
3013     STRLEN len;
3014
3015     save_hptr(&PL_curstash);
3016     save_item(PL_curstname);
3017
3018     name = SvPV_const(cSVOPo->op_sv, len);
3019     PL_curstash = gv_stashpvn(name, len, TRUE);
3020     sv_setpvn(PL_curstname, name, len);
3021     op_free(o);
3022
3023     PL_hints |= HINT_BLOCK_SCOPE;
3024     PL_copline = NOLINE;
3025     PL_expect = XSTATE;
3026 }
3027
3028 void
3029 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3030 {
3031     OP *pack;
3032     OP *imop;
3033     OP *veop;
3034
3035     if (idop->op_type != OP_CONST)
3036         Perl_croak(aTHX_ "Module name must be constant");
3037
3038     veop = Nullop;
3039
3040     if (version) {
3041         SV * const vesv = ((SVOP*)version)->op_sv;
3042
3043         if (!arg && !SvNIOKp(vesv)) {
3044             arg = version;
3045         }
3046         else {
3047             OP *pack;
3048             SV *meth;
3049
3050             if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3051                 Perl_croak(aTHX_ "Version number must be constant number");
3052
3053             /* Make copy of idop so we don't free it twice */
3054             pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3055
3056             /* Fake up a method call to VERSION */
3057             meth = newSVpvn_share("VERSION", 7, 0);
3058             veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3059                             append_elem(OP_LIST,
3060                                         prepend_elem(OP_LIST, pack, list(version)),
3061                                         newSVOP(OP_METHOD_NAMED, 0, meth)));
3062         }
3063     }
3064
3065     /* Fake up an import/unimport */
3066     if (arg && arg->op_type == OP_STUB)
3067         imop = arg;             /* no import on explicit () */
3068     else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3069         imop = Nullop;          /* use 5.0; */
3070         if (!aver)
3071             idop->op_private |= OPpCONST_NOVER;
3072     }
3073     else {
3074         SV *meth;
3075
3076         /* Make copy of idop so we don't free it twice */
3077         pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3078
3079         /* Fake up a method call to import/unimport */
3080         meth = aver
3081             ? newSVpvn_share("import",6, 0) : newSVpvn_share("unimport", 8, 0);
3082         imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3083                        append_elem(OP_LIST,
3084                                    prepend_elem(OP_LIST, pack, list(arg)),
3085                                    newSVOP(OP_METHOD_NAMED, 0, meth)));
3086     }
3087
3088     /* Fake up the BEGIN {}, which does its thing immediately. */
3089     newATTRSUB(floor,
3090         newSVOP(OP_CONST, 0, newSVpvn_share("BEGIN", 5, 0)),
3091         Nullop,
3092         Nullop,
3093         append_elem(OP_LINESEQ,
3094             append_elem(OP_LINESEQ,
3095                 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, idop)),
3096                 newSTATEOP(0, Nullch, veop)),
3097             newSTATEOP(0, Nullch, imop) ));
3098
3099     /* The "did you use incorrect case?" warning used to be here.
3100      * The problem is that on case-insensitive filesystems one
3101      * might get false positives for "use" (and "require"):
3102      * "use Strict" or "require CARP" will work.  This causes
3103      * portability problems for the script: in case-strict
3104      * filesystems the script will stop working.
3105      *
3106      * The "incorrect case" warning checked whether "use Foo"
3107      * imported "Foo" to your namespace, but that is wrong, too:
3108      * there is no requirement nor promise in the language that
3109      * a Foo.pm should or would contain anything in package "Foo".
3110      *
3111      * There is very little Configure-wise that can be done, either:
3112      * the case-sensitivity of the build filesystem of Perl does not
3113      * help in guessing the case-sensitivity of the runtime environment.
3114      */
3115
3116     PL_hints |= HINT_BLOCK_SCOPE;
3117     PL_copline = NOLINE;
3118     PL_expect = XSTATE;
3119     PL_cop_seqmax++; /* Purely for B::*'s benefit */
3120 }
3121
3122 /*
3123 =head1 Embedding Functions
3124
3125 =for apidoc load_module
3126
3127 Loads the module whose name is pointed to by the string part of name.
3128 Note that the actual module name, not its filename, should be given.
3129 Eg, "Foo::Bar" instead of "Foo/Bar.pm".  flags can be any of
3130 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3131 (or 0 for no flags). ver, if specified, provides version semantics
3132 similar to C<use Foo::Bar VERSION>.  The optional trailing SV*
3133 arguments can be used to specify arguments to the module's import()
3134 method, similar to C<use Foo::Bar VERSION LIST>.
3135
3136 =cut */
3137
3138 void
3139 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3140 {
3141     va_list args;
3142     va_start(args, ver);
3143     vload_module(flags, name, ver, &args);
3144     va_end(args);
3145 }
3146
3147 #ifdef PERL_IMPLICIT_CONTEXT
3148 void
3149 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3150 {
3151     dTHX;
3152     va_list args;
3153     va_start(args, ver);
3154     vload_module(flags, name, ver, &args);
3155     va_end(args);
3156 }
3157 #endif
3158
3159 void
3160 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3161 {
3162     OP *veop, *imop;
3163
3164     OP * const modname = newSVOP(OP_CONST, 0, name);
3165     modname->op_private |= OPpCONST_BARE;
3166     if (ver) {
3167         veop = newSVOP(OP_CONST, 0, ver);
3168     }
3169     else
3170         veop = Nullop;
3171     if (flags & PERL_LOADMOD_NOIMPORT) {
3172         imop = sawparens(newNULLLIST());
3173     }
3174     else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3175         imop = va_arg(*args, OP*);
3176     }
3177     else {
3178         SV *sv;
3179         imop = Nullop;
3180         sv = va_arg(*args, SV*);
3181         while (sv) {
3182             imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3183             sv = va_arg(*args, SV*);
3184         }
3185     }
3186     {
3187         const line_t ocopline = PL_copline;
3188         COP * const ocurcop = PL_curcop;
3189         const int oexpect = PL_expect;
3190
3191         utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3192                 veop, modname, imop);
3193         PL_expect = oexpect;
3194         PL_copline = ocopline;
3195         PL_curcop = ocurcop;
3196     }
3197 }
3198
3199 OP *
3200 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
3201 {
3202     OP *doop;
3203     GV *gv = Nullgv;
3204
3205     if (!force_builtin) {
3206         gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3207         if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
3208             GV * const * const gvp = (GV**)hv_fetch(PL_globalstash, "do", 2, FALSE);
3209             gv = gvp ? *gvp : Nullgv;
3210         }
3211     }
3212
3213     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3214         doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3215                                append_elem(OP_LIST, term,
3216                                            scalar(newUNOP(OP_RV2CV, 0,
3217                                                           newGVOP(OP_GV, 0,
3218                                                                   gv))))));
3219     }
3220     else {
3221         doop = newUNOP(OP_DOFILE, 0, scalar(term));
3222     }
3223     return doop;
3224 }
3225
3226 OP *
3227 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3228 {
3229     return newBINOP(OP_LSLICE, flags,
3230             list(force_list(subscript)),
3231             list(force_list(listval)) );
3232 }
3233
3234 STATIC I32
3235 S_is_list_assignment(pTHX_ register const OP *o)
3236 {
3237     if (!o)
3238         return TRUE;
3239
3240     if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3241         o = cUNOPo->op_first;
3242
3243     if (o->op_type == OP_COND_EXPR) {
3244         const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
3245         const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3246
3247         if (t && f)
3248             return TRUE;
3249         if (t || f)
3250             yyerror("Assignment to both a list and a scalar");
3251         return FALSE;
3252     }
3253
3254     if (o->op_type == OP_LIST &&
3255         (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3256         o->op_private & OPpLVAL_INTRO)
3257         return FALSE;
3258
3259     if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3260         o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3261         o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3262         return TRUE;
3263
3264     if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3265         return TRUE;
3266
3267     if (o->op_type == OP_RV2SV)
3268         return FALSE;
3269
3270     return FALSE;
3271 }
3272
3273 OP *
3274 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3275 {
3276     OP *o;
3277
3278     if (optype) {
3279         if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3280             return newLOGOP(optype, 0,
3281                 mod(scalar(left), optype),
3282                 newUNOP(OP_SASSIGN, 0, scalar(right)));
3283         }
3284         else {
3285             return newBINOP(optype, OPf_STACKED,
3286                 mod(scalar(left), optype), scalar(right));
3287         }
3288     }
3289
3290     if (is_list_assignment(left)) {
3291         OP *curop;
3292
3293         PL_modcount = 0;
3294         /* Grandfathering $[ assignment here.  Bletch.*/
3295         /* Only simple assignments like C<< ($[) = 1 >> are allowed */
3296         PL_eval_start = (left->op_type == OP_CONST) ? right : 0;
3297         left = mod(left, OP_AASSIGN);
3298         if (PL_eval_start)
3299             PL_eval_start = 0;
3300         else if (left->op_type == OP_CONST) {
3301             /* Result of assignment is always 1 (or we'd be dead already) */
3302             return newSVOP(OP_CONST, 0, newSViv(1));
3303         }
3304         curop = list(force_list(left));
3305         o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3306         o->op_private = (U8)(0 | (flags >> 8));
3307
3308         /* PL_generation sorcery:
3309          * an assignment like ($a,$b) = ($c,$d) is easier than
3310          * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3311          * To detect whether there are common vars, the global var
3312          * PL_generation is incremented for each assign op we compile.
3313          * Then, while compiling the assign op, we run through all the
3314          * variables on both sides of the assignment, setting a spare slot
3315          * in each of them to PL_generation. If any of them already have
3316          * that value, we know we've got commonality.  We could use a
3317          * single bit marker, but then we'd have to make 2 passes, first
3318          * to clear the flag, then to test and set it.  To find somewhere
3319          * to store these values, evil chicanery is done with SvCUR().
3320          */
3321
3322         if (!(left->op_private & OPpLVAL_INTRO)) {
3323             OP *lastop = o;
3324             PL_generation++;
3325             for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3326                 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3327                     if (curop->op_type == OP_GV) {
3328                         GV *gv = cGVOPx_gv(curop);
3329                         if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3330                             break;
3331                         SvCUR_set(gv, PL_generation);
3332                     }
3333                     else if (curop->op_type == OP_PADSV ||
3334                              curop->op_type == OP_PADAV ||
3335                              curop->op_type == OP_PADHV ||
3336                              curop->op_type == OP_PADANY)
3337                     {
3338                         if (PAD_COMPNAME_GEN(curop->op_targ)
3339                                                     == (STRLEN)PL_generation)
3340                             break;
3341                         PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
3342
3343                     }
3344                     else if (curop->op_type == OP_RV2CV)
3345                         break;
3346                     else if (curop->op_type == OP_RV2SV ||
3347                              curop->op_type == OP_RV2AV ||
3348                              curop->op_type == OP_RV2HV ||
3349                              curop->op_type == OP_RV2GV) {
3350                         if (lastop->op_type != OP_GV)   /* funny deref? */
3351                             break;
3352                     }
3353                     else if (curop->op_type == OP_PUSHRE) {
3354                         if (((PMOP*)curop)->op_pmreplroot) {
3355 #ifdef USE_ITHREADS
3356                             GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3357                                         ((PMOP*)curop)->op_pmreplroot));
3358 #else
3359                             GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3360 #endif
3361                             if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
3362                                 break;
3363                             SvCUR_set(gv, PL_generation);
3364                         }
3365                     }
3366                     else
3367                         break;
3368                 }
3369                 lastop = curop;
3370             }
3371             if (curop != o)
3372                 o->op_private |= OPpASSIGN_COMMON;
3373         }
3374         if (right && right->op_type == OP_SPLIT) {
3375             OP* tmpop;
3376             if ((tmpop = ((LISTOP*)right)->op_first) &&
3377                 tmpop->op_type == OP_PUSHRE)
3378             {
3379                 PMOP * const pm = (PMOP*)tmpop;
3380                 if (left->op_type == OP_RV2AV &&
3381                     !(left->op_private & OPpLVAL_INTRO) &&
3382                     !(o->op_private & OPpASSIGN_COMMON) )
3383                 {
3384                     tmpop = ((UNOP*)left)->op_first;
3385                     if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3386 #ifdef USE_ITHREADS
3387                         pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3388                         cPADOPx(tmpop)->op_padix = 0;   /* steal it */
3389 #else
3390                         pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3391                         cSVOPx(tmpop)->op_sv = Nullsv;  /* steal it */
3392 #endif
3393                         pm->op_pmflags |= PMf_ONCE;
3394                         tmpop = cUNOPo->op_first;       /* to list (nulled) */
3395                         tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3396                         tmpop->op_sibling = Nullop;     /* don't free split */
3397                         right->op_next = tmpop->op_next;  /* fix starting loc */
3398                         op_free(o);                     /* blow off assign */
3399                         right->op_flags &= ~OPf_WANT;
3400                                 /* "I don't know and I don't care." */
3401                         return right;
3402                     }
3403                 }
3404                 else {
3405                    if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3406                       ((LISTOP*)right)->op_last->op_type == OP_CONST)
3407                     {
3408                         SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3409                         if (SvIVX(sv) == 0)
3410                             sv_setiv(sv, PL_modcount+1);
3411                     }
3412                 }
3413             }
3414         }
3415         return o;
3416     }
3417     if (!right)
3418         right = newOP(OP_UNDEF, 0);
3419     if (right->op_type == OP_READLINE) {
3420         right->op_flags |= OPf_STACKED;
3421         return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3422     }
3423     else {
3424         PL_eval_start = right;  /* Grandfathering $[ assignment here.  Bletch.*/
3425         o = newBINOP(OP_SASSIGN, flags,
3426             scalar(right), mod(scalar(left), OP_SASSIGN) );
3427         if (PL_eval_start)
3428             PL_eval_start = 0;
3429         else {
3430             o = newSVOP(OP_CONST, 0, newSViv(PL_compiling.cop_arybase));
3431         }
3432     }
3433     return o;
3434 }
3435
3436 OP *
3437 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3438 {
3439     dVAR;
3440     const U32 seq = intro_my();
3441     register COP *cop;
3442
3443     NewOp(1101, cop, 1, COP);
3444     if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3445         cop->op_type = OP_DBSTATE;
3446         cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3447     }
3448     else {
3449         cop->op_type = OP_NEXTSTATE;
3450         cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3451     }
3452     cop->op_flags = (U8)flags;
3453     cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
3454 #ifdef NATIVE_HINTS
3455     cop->op_private |= NATIVE_HINTS;
3456 #endif
3457     PL_compiling.op_private = cop->op_private;
3458     cop->op_next = (OP*)cop;
3459
3460     if (label) {
3461         cop->cop_label = label;
3462         PL_hints |= HINT_BLOCK_SCOPE;
3463     }
3464     cop->cop_seq = seq;
3465     cop->cop_arybase = PL_curcop->cop_arybase;
3466     if (specialWARN(PL_curcop->cop_warnings))
3467         cop->cop_warnings = PL_curcop->cop_warnings ;
3468     else
3469         cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3470     if (specialCopIO(PL_curcop->cop_io))
3471         cop->cop_io = PL_curcop->cop_io;
3472     else
3473         cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3474
3475
3476     if (PL_copline == NOLINE)
3477         CopLINE_set(cop, CopLINE(PL_curcop));
3478     else {
3479         CopLINE_set(cop, PL_copline);
3480         PL_copline = NOLINE;
3481     }
3482 #ifdef USE_ITHREADS
3483     CopFILE_set(cop, CopFILE(PL_curcop));       /* XXX share in a pvtable? */
3484 #else
3485     CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3486 #endif
3487     CopSTASH_set(cop, PL_curstash);
3488
3489     if (PERLDB_LINE && PL_curstash != PL_debstash) {
3490         SV * const * const svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3491         if (svp && *svp != &PL_sv_undef ) {
3492             (void)SvIOK_on(*svp);
3493             SvIV_set(*svp, PTR2IV(cop));
3494         }
3495     }
3496
3497     return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3498 }
3499
3500
3501 OP *
3502 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3503 {
3504     dVAR;
3505     return new_logop(type, flags, &first, &other);
3506 }
3507
3508 STATIC OP *
3509 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3510 {
3511     dVAR;
3512     LOGOP *logop;
3513     OP *o;
3514     OP *first = *firstp;
3515     OP * const other = *otherp;
3516
3517     if (type == OP_XOR)         /* Not short circuit, but here by precedence. */
3518         return newBINOP(type, flags, scalar(first), scalar(other));
3519
3520     scalarboolean(first);
3521     /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3522     if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3523         if (type == OP_AND || type == OP_OR) {
3524             if (type == OP_AND)
3525                 type = OP_OR;
3526             else
3527                 type = OP_AND;
3528             o = first;
3529             first = *firstp = cUNOPo->op_first;
3530             if (o->op_next)
3531                 first->op_next = o->op_next;
3532             cUNOPo->op_first = Nullop;
3533             op_free(o);
3534         }
3535     }
3536     if (first->op_type == OP_CONST) {
3537         if (first->op_private & OPpCONST_STRICT)
3538             no_bareword_allowed(first);
3539         else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
3540                 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
3541         if ((type == OP_AND &&  SvTRUE(((SVOP*)first)->op_sv)) ||
3542             (type == OP_OR  && !SvTRUE(((SVOP*)first)->op_sv)) ||
3543             (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
3544             op_free(first);
3545             *firstp = Nullop;
3546             if (other->op_type == OP_CONST)
3547                 other->op_private |= OPpCONST_SHORTCIRCUIT;
3548             return other;
3549         }
3550         else {
3551             /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
3552             const OP *o2 = other;
3553             if ( ! (o2->op_type == OP_LIST
3554                     && (( o2 = cUNOPx(o2)->op_first))
3555                     && o2->op_type == OP_PUSHMARK
3556                     && (( o2 = o2->op_sibling)) )
3557             )
3558                 o2 = other;
3559             if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
3560                         || o2->op_type == OP_PADHV)
3561                 && o2->op_private & OPpLVAL_INTRO
3562                 && ckWARN(WARN_DEPRECATED))
3563             {
3564                 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
3565                             "Deprecated use of my() in false conditional");
3566             }
3567
3568             op_free(other);
3569             *otherp = Nullop;
3570             if (first->op_type == OP_CONST)
3571                 first->op_private |= OPpCONST_SHORTCIRCUIT;
3572             return first;
3573         }
3574     }
3575     else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
3576         && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
3577     {
3578         const OP * const k1 = ((UNOP*)first)->op_first;
3579         const OP * const k2 = k1->op_sibling;
3580         OPCODE warnop = 0;
3581         switch (first->op_type)
3582         {
3583         case OP_NULL:
3584             if (k2 && k2->op_type == OP_READLINE
3585                   && (k2->op_flags & OPf_STACKED)
3586                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3587             {
3588                 warnop = k2->op_type;
3589             }
3590             break;
3591
3592         case OP_SASSIGN:
3593             if (k1->op_type == OP_READDIR
3594                   || k1->op_type == OP_GLOB
3595                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3596                   || k1->op_type == OP_EACH)
3597             {
3598                 warnop = ((k1->op_type == OP_NULL)
3599                           ? (OPCODE)k1->op_targ : k1->op_type);
3600             }
3601             break;
3602         }
3603         if (warnop) {
3604             const line_t oldline = CopLINE(PL_curcop);
3605             CopLINE_set(PL_curcop, PL_copline);
3606             Perl_warner(aTHX_ packWARN(WARN_MISC),
3607                  "Value of %s%s can be \"0\"; test with defined()",
3608                  PL_op_desc[warnop],
3609                  ((warnop == OP_READLINE || warnop == OP_GLOB)
3610                   ? " construct" : "() operator"));
3611             CopLINE_set(PL_curcop, oldline);
3612         }
3613     }
3614
3615     if (!other)
3616         return first;
3617
3618     if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
3619         other->op_private |= OPpASSIGN_BACKWARDS;  /* other is an OP_SASSIGN */
3620
3621     NewOp(1101, logop, 1, LOGOP);
3622
3623     logop->op_type = (OPCODE)type;
3624     logop->op_ppaddr = PL_ppaddr[type];
3625     logop->op_first = first;
3626     logop->op_flags = (U8)(flags | OPf_KIDS);
3627     logop->op_other = LINKLIST(other);
3628     logop->op_private = (U8)(1 | (flags >> 8));
3629
3630     /* establish postfix order */
3631     logop->op_next = LINKLIST(first);
3632     first->op_next = (OP*)logop;
3633     first->op_sibling = other;
3634
3635     CHECKOP(type,logop);
3636
3637     o = newUNOP(OP_NULL, 0, (OP*)logop);
3638     other->op_next = o;
3639
3640     return o;
3641 }
3642
3643 OP *
3644 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3645 {
3646     dVAR;
3647     LOGOP *logop;
3648     OP *start;
3649     OP *o;
3650
3651     if (!falseop)
3652         return newLOGOP(OP_AND, 0, first, trueop);
3653     if (!trueop)
3654         return newLOGOP(OP_OR, 0, first, falseop);
3655
3656     scalarboolean(first);
3657     if (first->op_type == OP_CONST) {
3658         if (first->op_private & OPpCONST_BARE &&
3659             first->op_private & OPpCONST_STRICT) {
3660             no_bareword_allowed(first);
3661         }
3662         if (SvTRUE(((SVOP*)first)->op_sv)) {
3663             op_free(first);
3664             op_free(falseop);
3665             return trueop;
3666         }
3667         else {
3668             op_free(first);
3669             op_free(trueop);
3670             return falseop;
3671         }
3672     }
3673     NewOp(1101, logop, 1, LOGOP);
3674     logop->op_type = OP_COND_EXPR;
3675     logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3676     logop->op_first = first;
3677     logop->op_flags = (U8)(flags | OPf_KIDS);
3678     logop->op_private = (U8)(1 | (flags >> 8));
3679     logop->op_other = LINKLIST(trueop);
3680     logop->op_next = LINKLIST(falseop);
3681
3682     CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
3683             logop);
3684
3685     /* establish postfix order */
3686     start = LINKLIST(first);
3687     first->op_next = (OP*)logop;
3688
3689     first->op_sibling = trueop;
3690     trueop->op_sibling = falseop;
3691     o = newUNOP(OP_NULL, 0, (OP*)logop);
3692
3693     trueop->op_next = falseop->op_next = o;
3694
3695     o->op_next = start;
3696     return o;
3697 }
3698
3699 OP *
3700 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3701 {
3702     dVAR;
3703     LOGOP *range;
3704     OP *flip;
3705     OP *flop;
3706     OP *leftstart;
3707     OP *o;
3708
3709     NewOp(1101, range, 1, LOGOP);
3710
3711     range->op_type = OP_RANGE;
3712     range->op_ppaddr = PL_ppaddr[OP_RANGE];
3713     range->op_first = left;
3714     range->op_flags = OPf_KIDS;
3715     leftstart = LINKLIST(left);
3716     range->op_other = LINKLIST(right);
3717     range->op_private = (U8)(1 | (flags >> 8));
3718
3719     left->op_sibling = right;
3720
3721     range->op_next = (OP*)range;
3722     flip = newUNOP(OP_FLIP, flags, (OP*)range);
3723     flop = newUNOP(OP_FLOP, 0, flip);
3724     o = newUNOP(OP_NULL, 0, flop);
3725     linklist(flop);
3726     range->op_next = leftstart;
3727
3728     left->op_next = flip;
3729     right->op_next = flop;
3730
3731     range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3732     sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3733     flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3734     sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3735
3736     flip->op_private =  left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3737     flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3738
3739     flip->op_next = o;
3740     if (!flip->op_private || !flop->op_private)
3741         linklist(o);            /* blow off optimizer unless constant */
3742
3743     return o;
3744 }
3745
3746 OP *
3747 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3748 {
3749     OP* listop;
3750     OP* o;
3751     const bool once = block && block->op_flags & OPf_SPECIAL &&
3752       (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3753
3754     PERL_UNUSED_ARG(debuggable);
3755
3756     if (expr) {
3757         if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3758             return block;       /* do {} while 0 does once */
3759         if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3760             || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3761             expr = newUNOP(OP_DEFINED, 0,
3762                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3763         } else if (expr->op_flags & OPf_KIDS) {
3764             const OP * const k1 = ((UNOP*)expr)->op_first;
3765             const OP * const k2 = k1 ? k1->op_sibling : NULL;
3766             switch (expr->op_type) {
3767               case OP_NULL:
3768                 if (k2 && k2->op_type == OP_READLINE
3769                       && (k2->op_flags & OPf_STACKED)
3770                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3771                     expr = newUNOP(OP_DEFINED, 0, expr);
3772                 break;
3773
3774               case OP_SASSIGN:
3775                 if (k1->op_type == OP_READDIR
3776                       || k1->op_type == OP_GLOB
3777                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3778                       || k1->op_type == OP_EACH)
3779                     expr = newUNOP(OP_DEFINED, 0, expr);
3780                 break;
3781             }
3782         }
3783     }
3784
3785     /* if block is null, the next append_elem() would put UNSTACK, a scalar
3786      * op, in listop. This is wrong. [perl #27024] */
3787     if (!block)
3788         block = newOP(OP_NULL, 0);
3789     listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3790     o = new_logop(OP_AND, 0, &expr, &listop);
3791
3792     if (listop)
3793         ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3794
3795     if (once && o != listop)
3796         o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3797
3798     if (o == listop)
3799         o = newUNOP(OP_NULL, 0, o);     /* or do {} while 1 loses outer block */
3800
3801     o->op_flags |= flags;
3802     o = scope(o);
3803     o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3804     return o;
3805 }
3806
3807 OP *
3808 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
3809 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
3810 {
3811     dVAR;
3812     OP *redo;
3813     OP *next = 0;
3814     OP *listop;
3815     OP *o;
3816     U8 loopflags = 0;
3817
3818     PERL_UNUSED_ARG(debuggable);
3819
3820     if (expr) {
3821         if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3822                      || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3823             expr = newUNOP(OP_DEFINED, 0,
3824                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3825         } else if (expr->op_flags & OPf_KIDS) {
3826             const OP * const k1 = ((UNOP*)expr)->op_first;
3827             const OP * const k2 = (k1) ? k1->op_sibling : NULL;
3828             switch (expr->op_type) {
3829               case OP_NULL:
3830                 if (k2 && k2->op_type == OP_READLINE
3831                       && (k2->op_flags & OPf_STACKED)
3832                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3833                     expr = newUNOP(OP_DEFINED, 0, expr);
3834                 break;
3835
3836               case OP_SASSIGN:
3837                 if (k1->op_type == OP_READDIR
3838                       || k1->op_type == OP_GLOB
3839                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3840                       || k1->op_type == OP_EACH)
3841                     expr = newUNOP(OP_DEFINED, 0, expr);
3842                 break;
3843             }
3844         }
3845     }
3846
3847     if (!block)
3848         block = newOP(OP_NULL, 0);
3849     else if (cont || has_my) {
3850         block = scope(block);
3851     }
3852
3853     if (cont) {
3854         next = LINKLIST(cont);
3855     }
3856     if (expr) {
3857         OP * const unstack = newOP(OP_UNSTACK, 0);
3858         if (!next)
3859             next = unstack;
3860         cont = append_elem(OP_LINESEQ, cont, unstack);
3861     }
3862
3863     listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3864     redo = LINKLIST(listop);
3865
3866     if (expr) {
3867         PL_copline = (line_t)whileline;
3868         scalar(listop);
3869         o = new_logop(OP_AND, 0, &expr, &listop);
3870         if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3871             op_free(expr);              /* oops, it's a while (0) */
3872             op_free((OP*)loop);
3873             return Nullop;              /* listop already freed by new_logop */
3874         }
3875         if (listop)
3876             ((LISTOP*)listop)->op_last->op_next =
3877                 (o == listop ? redo : LINKLIST(o));
3878     }
3879     else
3880         o = listop;
3881
3882     if (!loop) {
3883         NewOp(1101,loop,1,LOOP);
3884         loop->op_type = OP_ENTERLOOP;
3885         loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3886         loop->op_private = 0;
3887         loop->op_next = (OP*)loop;
3888     }
3889
3890     o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
3891
3892     loop->op_redoop = redo;
3893     loop->op_lastop = o;
3894     o->op_private |= loopflags;
3895
3896     if (next)
3897         loop->op_nextop = next;
3898     else
3899         loop->op_nextop = o;
3900
3901     o->op_flags |= flags;
3902     o->op_private |= (flags >> 8);
3903     return o;
3904 }
3905
3906 OP *
3907 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
3908 {
3909     dVAR;
3910     LOOP *loop;
3911     OP *wop;
3912     PADOFFSET padoff = 0;
3913     I32 iterflags = 0;
3914     I32 iterpflags = 0;
3915
3916     if (sv) {
3917         if (sv->op_type == OP_RV2SV) {  /* symbol table variable */
3918             iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
3919             sv->op_type = OP_RV2GV;
3920             sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
3921         }
3922         else if (sv->op_type == OP_PADSV) { /* private variable */
3923             iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
3924             padoff = sv->op_targ;
3925             sv->op_targ = 0;
3926             op_free(sv);
3927             sv = Nullop;
3928         }
3929         else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
3930             padoff = sv->op_targ;
3931             sv->op_targ = 0;
3932             iterflags |= OPf_SPECIAL;
3933             op_free(sv);
3934             sv = Nullop;
3935         }
3936         else
3937             Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
3938     }
3939     else {
3940         const I32 offset = pad_findmy("$_");
3941         if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
3942             sv = newGVOP(OP_GV, 0, PL_defgv);
3943         }
3944         else {
3945             padoff = offset;
3946         }
3947     }
3948     if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
3949         expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
3950         iterflags |= OPf_STACKED;
3951     }
3952     else if (expr->op_type == OP_NULL &&
3953              (expr->op_flags & OPf_KIDS) &&
3954              ((BINOP*)expr)->op_first->op_type == OP_FLOP)
3955     {
3956         /* Basically turn for($x..$y) into the same as for($x,$y), but we
3957          * set the STACKED flag to indicate that these values are to be
3958          * treated as min/max values by 'pp_iterinit'.
3959          */
3960         UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
3961         LOGOP* const range = (LOGOP*) flip->op_first;
3962         OP* const left  = range->op_first;
3963         OP* const right = left->op_sibling;
3964         LISTOP* listop;
3965
3966         range->op_flags &= ~OPf_KIDS;
3967         range->op_first = Nullop;
3968
3969         listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
3970         listop->op_first->op_next = range->op_next;
3971         left->op_next = range->op_other;
3972         right->op_next = (OP*)listop;
3973         listop->op_next = listop->op_first;
3974
3975         op_free(expr);
3976         expr = (OP*)(listop);
3977         op_null(expr);
3978         iterflags |= OPf_STACKED;
3979     }
3980     else {
3981         expr = mod(force_list(expr), OP_GREPSTART);
3982     }
3983
3984     loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
3985                                append_elem(OP_LIST, expr, scalar(sv))));
3986     assert(!loop->op_next);
3987     /* for my  $x () sets OPpLVAL_INTRO;
3988      * for our $x () sets OPpOUR_INTRO */
3989     loop->op_private = (U8)iterpflags;
3990 #ifdef PL_OP_SLAB_ALLOC
3991     {
3992         LOOP *tmp;
3993         NewOp(1234,tmp,1,LOOP);
3994         Copy(loop,tmp,1,LISTOP);
3995         FreeOp(loop);
3996         loop = tmp;
3997     }
3998 #else
3999     Renew(loop, 1, LOOP);
4000 #endif
4001     loop->op_targ = padoff;
4002     wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
4003     PL_copline = forline;
4004     return newSTATEOP(0, label, wop);
4005 }
4006
4007 OP*
4008 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4009 {
4010     OP *o;
4011
4012     if (type != OP_GOTO || label->op_type == OP_CONST) {
4013         /* "last()" means "last" */
4014         if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4015             o = newOP(type, OPf_SPECIAL);
4016         else {
4017             o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4018                                         ? SvPVx_nolen_const(((SVOP*)label)->op_sv)
4019                                         : ""));
4020         }
4021         op_free(label);
4022     }
4023     else {
4024         /* Check whether it's going to be a goto &function */
4025         if (label->op_type == OP_ENTERSUB
4026                 && !(label->op_flags & OPf_STACKED))
4027             label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4028         o = newUNOP(type, OPf_STACKED, label);
4029     }
4030     PL_hints |= HINT_BLOCK_SCOPE;
4031     return o;
4032 }
4033
4034 /*
4035 =for apidoc cv_undef
4036
4037 Clear out all the active components of a CV. This can happen either
4038 by an explicit C<undef &foo>, or by the reference count going to zero.
4039 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
4040 children can still follow the full lexical scope chain.
4041
4042 =cut
4043 */
4044
4045 void
4046 Perl_cv_undef(pTHX_ CV *cv)
4047 {
4048     dVAR;
4049 #ifdef USE_ITHREADS
4050     if (CvFILE(cv) && !CvXSUB(cv)) {
4051         /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4052         Safefree(CvFILE(cv));
4053     }
4054     CvFILE(cv) = 0;
4055 #endif
4056
4057     if (!CvXSUB(cv) && CvROOT(cv)) {
4058         if (CvDEPTH(cv))
4059             Perl_croak(aTHX_ "Can't undef active subroutine");
4060         ENTER;
4061
4062         PAD_SAVE_SETNULLPAD();
4063
4064         op_free(CvROOT(cv));
4065         CvROOT(cv) = Nullop;
4066         CvSTART(cv) = Nullop;
4067         LEAVE;
4068     }
4069     SvPOK_off((SV*)cv);         /* forget prototype */
4070     CvGV(cv) = Nullgv;
4071
4072     pad_undef(cv);
4073
4074     /* remove CvOUTSIDE unless this is an undef rather than a free */
4075     if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
4076         if (!CvWEAKOUTSIDE(cv))
4077             SvREFCNT_dec(CvOUTSIDE(cv));
4078         CvOUTSIDE(cv) = Nullcv;
4079     }
4080     if (CvCONST(cv)) {
4081         SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4082         CvCONST_off(cv);
4083     }
4084     if (CvXSUB(cv)) {
4085         CvXSUB(cv) = 0;
4086     }
4087     /* delete all flags except WEAKOUTSIDE */
4088     CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
4089 }
4090
4091 void
4092 Perl_cv_ckproto(pTHX_ const CV *cv, const GV *gv, const char *p)
4093 {
4094     if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX_const(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4095         SV* const msg = sv_newmortal();
4096         SV* name = Nullsv;
4097
4098         if (gv)
4099             gv_efullname3(name = sv_newmortal(), gv, Nullch);
4100         sv_setpv(msg, "Prototype mismatch:");
4101         if (name)
4102             Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4103         if (SvPOK(cv))
4104             Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (const SV *)cv);
4105         else
4106             Perl_sv_catpv(aTHX_ msg, ": none");
4107         sv_catpv(msg, " vs ");
4108         if (p)
4109             Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4110         else
4111             sv_catpv(msg, "none");
4112         Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
4113     }
4114 }
4115
4116 static void const_sv_xsub(pTHX_ CV* cv);
4117
4118 /*
4119
4120 =head1 Optree Manipulation Functions
4121
4122 =for apidoc cv_const_sv
4123
4124 If C<cv> is a constant sub eligible for inlining. returns the constant
4125 value returned by the sub.  Otherwise, returns NULL.
4126
4127 Constant subs can be created with C<newCONSTSUB> or as described in
4128 L<perlsub/"Constant Functions">.
4129
4130 =cut
4131 */
4132 SV *
4133 Perl_cv_const_sv(pTHX_ CV *cv)
4134 {
4135     if (!cv || !CvCONST(cv))
4136         return Nullsv;
4137     return (SV*)CvXSUBANY(cv).any_ptr;
4138 }
4139
4140 /* op_const_sv:  examine an optree to determine whether it's in-lineable.
4141  * Can be called in 3 ways:
4142  *
4143  * !cv
4144  *      look for a single OP_CONST with attached value: return the value
4145  *
4146  * cv && CvCLONE(cv) && !CvCONST(cv)
4147  *
4148  *      examine the clone prototype, and if contains only a single
4149  *      OP_CONST referencing a pad const, or a single PADSV referencing
4150  *      an outer lexical, return a non-zero value to indicate the CV is
4151  *      a candidate for "constizing" at clone time
4152  *
4153  * cv && CvCONST(cv)
4154  *
4155  *      We have just cloned an anon prototype that was marked as a const
4156  *      candidiate. Try to grab the current value, and in the case of
4157  *      PADSV, ignore it if it has multiple references. Return the value.
4158  */
4159
4160 SV *
4161 Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
4162 {
4163     SV *sv = Nullsv;
4164
4165     if (!o)
4166         return Nullsv;
4167
4168     if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4169         o = cLISTOPo->op_first->op_sibling;
4170
4171     for (; o; o = o->op_next) {
4172         const OPCODE type = o->op_type;
4173
4174         if (sv && o->op_next == o)
4175             return sv;
4176         if (o->op_next != o) {
4177             if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4178                 continue;
4179             if (type == OP_DBSTATE)
4180                 continue;
4181         }
4182         if (type == OP_LEAVESUB || type == OP_RETURN)
4183             break;
4184         if (sv)
4185             return Nullsv;
4186         if (type == OP_CONST && cSVOPo->op_sv)
4187             sv = cSVOPo->op_sv;
4188         else if (cv && type == OP_CONST) {
4189             sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4190             if (!sv)
4191                 return Nullsv;
4192         }
4193         else if (cv && type == OP_PADSV) {
4194             if (CvCONST(cv)) { /* newly cloned anon */
4195                 sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
4196                 /* the candidate should have 1 ref from this pad and 1 ref
4197                  * from the parent */
4198                 if (!sv || SvREFCNT(sv) != 2)
4199                     return Nullsv;
4200                 sv = newSVsv(sv);
4201                 SvREADONLY_on(sv);
4202                 return sv;
4203             }
4204             else {
4205                 if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
4206                     sv = &PL_sv_undef; /* an arbitrary non-null value */
4207             }
4208         }
4209         else {
4210             return Nullsv;
4211         }
4212     }
4213     return sv;
4214 }
4215
4216 void
4217 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4218 {
4219     PERL_UNUSED_ARG(floor);
4220
4221     if (o)
4222         SAVEFREEOP(o);
4223     if (proto)
4224         SAVEFREEOP(proto);
4225     if (attrs)
4226         SAVEFREEOP(attrs);
4227     if (block)
4228         SAVEFREEOP(block);
4229     Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4230 }
4231
4232 CV *
4233 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4234 {
4235     return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4236 }
4237
4238 CV *
4239 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4240 {
4241     dVAR;
4242     const char *aname;
4243     GV *gv;
4244     const char *ps;
4245     STRLEN ps_len;
4246     register CV *cv=0;
4247     SV *const_sv;
4248     I32 gv_fetch_flags;
4249
4250     const char * const name = o ? SvPVx_nolen_const(cSVOPo->op_sv) : Nullch;
4251
4252     if (proto) {
4253         assert(proto->op_type == OP_CONST);
4254         ps = SvPVx_const(((SVOP*)proto)->op_sv, ps_len);
4255     }
4256     else
4257         ps = Nullch;
4258
4259     if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4260         SV * const sv = sv_newmortal();
4261         Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4262                        PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
4263                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4264         aname = SvPVX_const(sv);
4265     }
4266     else
4267         aname = Nullch;
4268
4269     gv_fetch_flags = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
4270         ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
4271     gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
4272         : gv_fetchpv(aname ? aname
4273                      : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4274                      gv_fetch_flags, SVt_PVCV);
4275
4276     if (o)
4277         SAVEFREEOP(o);
4278     if (proto)
4279         SAVEFREEOP(proto);
4280     if (attrs)
4281         SAVEFREEOP(attrs);
4282
4283     if (SvTYPE(gv) != SVt_PVGV) {       /* Maybe prototype now, and had at
4284                                            maximum a prototype before. */
4285         if (SvTYPE(gv) > SVt_NULL) {
4286             if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4287                 && ckWARN_d(WARN_PROTOTYPE))
4288             {
4289                 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
4290             }
4291             cv_ckproto((CV*)gv, NULL, ps);
4292         }
4293         if (ps)
4294             sv_setpvn((SV*)gv, ps, ps_len);
4295         else
4296             sv_setiv((SV*)gv, -1);
4297         SvREFCNT_dec(PL_compcv);
4298         cv = PL_compcv = NULL;
4299         PL_sub_generation++;
4300         goto done;
4301     }
4302
4303     cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4304
4305 #ifdef GV_UNIQUE_CHECK
4306     if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4307         Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4308     }
4309 #endif
4310
4311     if (!block || !ps || *ps || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
4312         const_sv = Nullsv;
4313     else
4314         const_sv = op_const_sv(block, Nullcv);
4315
4316     if (cv) {
4317         const bool exists = CvROOT(cv) || CvXSUB(cv);
4318
4319 #ifdef GV_UNIQUE_CHECK
4320         if (exists && GvUNIQUE(gv)) {
4321             Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4322         }
4323 #endif
4324
4325         /* if the subroutine doesn't exist and wasn't pre-declared
4326          * with a prototype, assume it will be AUTOLOADed,
4327          * skipping the prototype check
4328          */
4329         if (exists || SvPOK(cv))
4330             cv_ckproto(cv, gv, ps);
4331         /* already defined (or promised)? */
4332         if (exists || GvASSUMECV(gv)) {
4333             if (!block && !attrs) {
4334                 if (CvFLAGS(PL_compcv)) {
4335                     /* might have had built-in attrs applied */
4336                     CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4337                 }
4338                 /* just a "sub foo;" when &foo is already defined */
4339                 SAVEFREESV(PL_compcv);
4340                 goto done;
4341             }
4342             if (block) {
4343                 if (ckWARN(WARN_REDEFINE)
4344                     || (CvCONST(cv)
4345                         && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4346                 {
4347                     const line_t oldline = CopLINE(PL_curcop);
4348                     if (PL_copline != NOLINE)
4349                         CopLINE_set(PL_curcop, PL_copline);
4350                     Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4351                         CvCONST(cv) ? "Constant subroutine %s redefined"
4352                                     : "Subroutine %s redefined", name);
4353                     CopLINE_set(PL_curcop, oldline);
4354                 }
4355                 SvREFCNT_dec(cv);
4356                 cv = Nullcv;
4357             }
4358         }
4359     }
4360     if (const_sv) {
4361         (void)SvREFCNT_inc(const_sv);
4362         if (cv) {
4363             assert(!CvROOT(cv) && !CvCONST(cv));
4364             sv_setpvn((SV*)cv, "", 0);  /* prototype is "" */
4365             CvXSUBANY(cv).any_ptr = const_sv;
4366             CvXSUB(cv) = const_sv_xsub;
4367             CvCONST_on(cv);
4368         }
4369         else {
4370             GvCV(gv) = Nullcv;
4371             cv = newCONSTSUB(NULL, name, const_sv);
4372         }
4373         op_free(block);
4374         SvREFCNT_dec(PL_compcv);
4375         PL_compcv = NULL;
4376         PL_sub_generation++;
4377         goto done;
4378     }
4379     if (attrs) {
4380         HV *stash;
4381         SV *rcv;
4382
4383         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4384          * before we clobber PL_compcv.
4385          */
4386         if (cv && !block) {
4387             rcv = (SV*)cv;
4388             /* Might have had built-in attributes applied -- propagate them. */
4389             CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4390             if (CvGV(cv) && GvSTASH(CvGV(cv)))
4391                 stash = GvSTASH(CvGV(cv));
4392             else if (CvSTASH(cv))
4393                 stash = CvSTASH(cv);
4394             else
4395                 stash = PL_curstash;
4396         }
4397         else {
4398             /* possibly about to re-define existing subr -- ignore old cv */
4399             rcv = (SV*)PL_compcv;
4400             if (name && GvSTASH(gv))
4401                 stash = GvSTASH(gv);
4402             else
4403                 stash = PL_curstash;
4404         }
4405         apply_attrs(stash, rcv, attrs, FALSE);
4406     }
4407     if (cv) {                           /* must reuse cv if autoloaded */
4408         if (!block) {
4409             /* got here with just attrs -- work done, so bug out */
4410             SAVEFREESV(PL_compcv);
4411             goto done;
4412         }
4413         /* transfer PL_compcv to cv */
4414         cv_undef(cv);
4415         CvFLAGS(cv) = CvFLAGS(PL_compcv);
4416         if (!CvWEAKOUTSIDE(cv))
4417             SvREFCNT_dec(CvOUTSIDE(cv));
4418         CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4419         CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
4420         CvOUTSIDE(PL_compcv) = 0;
4421         CvPADLIST(cv) = CvPADLIST(PL_compcv);
4422         CvPADLIST(PL_compcv) = 0;
4423         /* inner references to PL_compcv must be fixed up ... */
4424         pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
4425         /* ... before we throw it away */
4426         SvREFCNT_dec(PL_compcv);
4427         PL_compcv = cv;
4428         if (PERLDB_INTER)/* Advice debugger on the new sub. */
4429           ++PL_sub_generation;
4430     }
4431     else {
4432         cv = PL_compcv;
4433         if (name) {
4434             GvCV(gv) = cv;
4435             GvCVGEN(gv) = 0;
4436             PL_sub_generation++;
4437         }
4438     }
4439     CvGV(cv) = gv;
4440     CvFILE_set_from_cop(cv, PL_curcop);
4441     CvSTASH(cv) = PL_curstash;
4442
4443     if (ps)
4444         sv_setpvn((SV*)cv, ps, ps_len);
4445
4446     if (PL_error_count) {
4447         op_free(block);
4448         block = Nullop;
4449         if (name) {
4450             const char *s = strrchr(name, ':');
4451             s = s ? s+1 : name;
4452             if (strEQ(s, "BEGIN")) {
4453                 const char not_safe[] =
4454                     "BEGIN not safe after errors--compilation aborted";
4455                 if (PL_in_eval & EVAL_KEEPERR)
4456                     Perl_croak(aTHX_ not_safe);
4457                 else {
4458                     /* force display of errors found but not reported */
4459                     sv_catpv(ERRSV, not_safe);
4460                     Perl_croak(aTHX_ "%"SVf, ERRSV);
4461                 }
4462             }
4463         }
4464     }
4465     if (!block)
4466         goto done;
4467
4468     if (CvLVALUE(cv)) {
4469         CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4470                              mod(scalarseq(block), OP_LEAVESUBLV));
4471     }
4472     else {
4473         /* This makes sub {}; work as expected.  */
4474         if (block->op_type == OP_STUB) {
4475             op_free(block);
4476             block = newSTATEOP(0, Nullch, 0);
4477         }
4478         CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4479     }
4480     CvROOT(cv)->op_private |= OPpREFCOUNTED;
4481     OpREFCNT_set(CvROOT(cv), 1);
4482     CvSTART(cv) = LINKLIST(CvROOT(cv));
4483     CvROOT(cv)->op_next = 0;
4484     CALL_PEEP(CvSTART(cv));
4485
4486     /* now that optimizer has done its work, adjust pad values */
4487
4488     pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
4489
4490     if (CvCLONE(cv)) {
4491         assert(!CvCONST(cv));
4492         if (ps && !*ps && op_const_sv(block, cv))
4493             CvCONST_on(cv);
4494     }
4495
4496     if (name || aname) {
4497         const char *s;
4498         const char * const tname = (name ? name : aname);
4499
4500         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4501             SV * const sv = NEWSV(0,0);
4502             SV * const tmpstr = sv_newmortal();
4503             GV * const db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4504             HV *hv;
4505
4506             Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4507                            CopFILE(PL_curcop),
4508                            (long)PL_subline, (long)CopLINE(PL_curcop));
4509             gv_efullname3(tmpstr, gv, Nullch);
4510             hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0);
4511             hv = GvHVn(db_postponed);
4512             if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
4513                 CV * const pcv = GvCV(db_postponed);
4514                 if (pcv) {
4515                     dSP;
4516                     PUSHMARK(SP);
4517                     XPUSHs(tmpstr);
4518                     PUTBACK;
4519                     call_sv((SV*)pcv, G_DISCARD);
4520                 }
4521             }
4522         }
4523
4524         if ((s = strrchr(tname,':')))
4525             s++;
4526         else
4527             s = tname;
4528
4529         if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4530             goto done;
4531
4532         if (strEQ(s, "BEGIN") && !PL_error_count) {
4533             const I32 oldscope = PL_scopestack_ix;
4534             ENTER;
4535             SAVECOPFILE(&PL_compiling);
4536             SAVECOPLINE(&PL_compiling);
4537
4538             if (!PL_beginav)
4539                 PL_beginav = newAV();
4540             DEBUG_x( dump_sub(gv) );
4541             av_push(PL_beginav, (SV*)cv);
4542             GvCV(gv) = 0;               /* cv has been hijacked */
4543             call_list(oldscope, PL_beginav);
4544
4545             PL_curcop = &PL_compiling;
4546             PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
4547             LEAVE;
4548         }
4549         else if (strEQ(s, "END") && !PL_error_count) {
4550             if (!PL_endav)
4551                 PL_endav = newAV();
4552             DEBUG_x( dump_sub(gv) );
4553             av_unshift(PL_endav, 1);
4554             av_store(PL_endav, 0, (SV*)cv);
4555             GvCV(gv) = 0;               /* cv has been hijacked */
4556         }
4557         else if (strEQ(s, "CHECK") && !PL_error_count) {
4558             if (!PL_checkav)
4559                 PL_checkav = newAV();
4560             DEBUG_x( dump_sub(gv) );
4561             if (PL_main_start && ckWARN(WARN_VOID))
4562                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4563             av_unshift(PL_checkav, 1);
4564             av_store(PL_checkav, 0, (SV*)cv);
4565             GvCV(gv) = 0;               /* cv has been hijacked */
4566         }
4567         else if (strEQ(s, "INIT") && !PL_error_count) {
4568             if (!PL_initav)
4569                 PL_initav = newAV();
4570             DEBUG_x( dump_sub(gv) );
4571             if (PL_main_start && ckWARN(WARN_VOID))
4572                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4573             av_push(PL_initav, (SV*)cv);
4574             GvCV(gv) = 0;               /* cv has been hijacked */
4575         }
4576     }
4577
4578   done:
4579     PL_copline = NOLINE;
4580     LEAVE_SCOPE(floor);
4581     return cv;
4582 }
4583
4584 /* XXX unsafe for threads if eval_owner isn't held */
4585 /*
4586 =for apidoc newCONSTSUB
4587
4588 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4589 eligible for inlining at compile-time.
4590
4591 =cut
4592 */
4593
4594 CV *
4595 Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
4596 {
4597     dVAR;
4598     CV* cv;
4599
4600     ENTER;
4601
4602     SAVECOPLINE(PL_curcop);
4603     CopLINE_set(PL_curcop, PL_copline);
4604
4605     SAVEHINTS();
4606     PL_hints &= ~HINT_BLOCK_SCOPE;
4607
4608     if (stash) {
4609         SAVESPTR(PL_curstash);
4610         SAVECOPSTASH(PL_curcop);
4611         PL_curstash = stash;
4612         CopSTASH_set(PL_curcop,stash);
4613     }
4614
4615     cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
4616     CvXSUBANY(cv).any_ptr = sv;
4617     CvCONST_on(cv);
4618     sv_setpvn((SV*)cv, "", 0);  /* prototype is "" */
4619
4620 #ifdef USE_ITHREADS
4621     if (stash)
4622         CopSTASH_free(PL_curcop);
4623 #endif
4624     LEAVE;
4625
4626     return cv;
4627 }
4628
4629 /*
4630 =for apidoc U||newXS
4631
4632 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4633
4634 =cut
4635 */
4636
4637 CV *
4638 Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
4639 {
4640     GV * const gv = gv_fetchpv(name ? name :
4641                         (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
4642                         GV_ADDMULTI, SVt_PVCV);
4643     register CV *cv;
4644
4645     if (!subaddr)
4646         Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
4647
4648     if ((cv = (name ? GvCV(gv) : Nullcv))) {
4649         if (GvCVGEN(gv)) {
4650             /* just a cached method */
4651             SvREFCNT_dec(cv);
4652             cv = Nullcv;
4653         }
4654         else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4655             /* already defined (or promised) */
4656             /* XXX It's possible for this HvNAME_get to return null, and get passed into strEQ */
4657             if (ckWARN(WARN_REDEFINE)) {
4658                 GV * const gvcv = CvGV(cv);
4659                 if (gvcv) {
4660                     HV * const stash = GvSTASH(gvcv);
4661                     if (stash) {
4662                         const char *name = HvNAME_get(stash);
4663                         if ( strEQ(name,"autouse") ) {
4664                             const line_t oldline = CopLINE(PL_curcop);
4665                             if (PL_copline != NOLINE)
4666                                 CopLINE_set(PL_curcop, PL_copline);
4667                             Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4668                                         CvCONST(cv) ? "Constant subroutine %s redefined"
4669                                                     : "Subroutine %s redefined"
4670                                         ,name);
4671                             CopLINE_set(PL_curcop, oldline);
4672                         }
4673                     }
4674                 }
4675             }
4676             SvREFCNT_dec(cv);
4677             cv = Nullcv;
4678         }
4679     }
4680
4681     if (cv)                             /* must reuse cv if autoloaded */
4682         cv_undef(cv);
4683     else {
4684         cv = (CV*)NEWSV(1105,0);
4685         sv_upgrade((SV *)cv, SVt_PVCV);
4686         if (name) {
4687             GvCV(gv) = cv;
4688             GvCVGEN(gv) = 0;
4689             PL_sub_generation++;
4690         }
4691     }
4692     CvGV(cv) = gv;
4693     (void)gv_fetchfile(filename);
4694     CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
4695                                    an external constant string */
4696     CvXSUB(cv) = subaddr;
4697
4698     if (name) {
4699         const char *s = strrchr(name,':');
4700         if (s)
4701             s++;
4702         else
4703             s = name;
4704
4705         if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4706             goto done;
4707
4708         if (strEQ(s, "BEGIN")) {
4709             if (!PL_beginav)
4710                 PL_beginav = newAV();
4711             av_push(PL_beginav, (SV*)cv);
4712             GvCV(gv) = 0;               /* cv has been hijacked */
4713         }
4714         else if (strEQ(s, "END")) {
4715             if (!PL_endav)
4716                 PL_endav = newAV();
4717             av_unshift(PL_endav, 1);
4718             av_store(PL_endav, 0, (SV*)cv);
4719             GvCV(gv) = 0;               /* cv has been hijacked */
4720         }
4721         else if (strEQ(s, "CHECK")) {
4722             if (!PL_checkav)
4723                 PL_checkav = newAV();
4724             if (PL_main_start && ckWARN(WARN_VOID))
4725                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
4726             av_unshift(PL_checkav, 1);
4727             av_store(PL_checkav, 0, (SV*)cv);
4728             GvCV(gv) = 0;               /* cv has been hijacked */
4729         }
4730         else if (strEQ(s, "INIT")) {
4731             if (!PL_initav)
4732                 PL_initav = newAV();
4733             if (PL_main_start && ckWARN(WARN_VOID))
4734                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
4735             av_push(PL_initav, (SV*)cv);
4736             GvCV(gv) = 0;               /* cv has been hijacked */
4737         }
4738     }
4739     else
4740         CvANON_on(cv);
4741
4742 done:
4743     return cv;
4744 }
4745
4746 void
4747 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4748 {
4749     register CV *cv;
4750
4751     GV * const gv = o
4752         ? gv_fetchsv(cSVOPo->op_sv, TRUE, SVt_PVFM)
4753         : gv_fetchpv("STDOUT", TRUE, SVt_PVFM);
4754
4755 #ifdef GV_UNIQUE_CHECK
4756     if (GvUNIQUE(gv)) {
4757         Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
4758     }
4759 #endif
4760     GvMULTI_on(gv);
4761     if ((cv = GvFORM(gv))) {
4762         if (ckWARN(WARN_REDEFINE)) {
4763             const line_t oldline = CopLINE(PL_curcop);
4764             if (PL_copline != NOLINE)
4765                 CopLINE_set(PL_curcop, PL_copline);
4766             Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4767                         o ? "Format %"SVf" redefined"
4768                         : "Format STDOUT redefined" ,cSVOPo->op_sv);
4769             CopLINE_set(PL_curcop, oldline);
4770         }
4771         SvREFCNT_dec(cv);
4772     }
4773     cv = PL_compcv;
4774     GvFORM(gv) = cv;
4775     CvGV(cv) = gv;
4776     CvFILE_set_from_cop(cv, PL_curcop);
4777
4778
4779     pad_tidy(padtidy_FORMAT);
4780     CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
4781     CvROOT(cv)->op_private |= OPpREFCOUNTED;
4782     OpREFCNT_set(CvROOT(cv), 1);
4783     CvSTART(cv) = LINKLIST(CvROOT(cv));
4784     CvROOT(cv)->op_next = 0;
4785     CALL_PEEP(CvSTART(cv));
4786     op_free(o);
4787     PL_copline = NOLINE;
4788     LEAVE_SCOPE(floor);
4789 }
4790
4791 OP *
4792 Perl_newANONLIST(pTHX_ OP *o)
4793 {
4794     return newUNOP(OP_REFGEN, 0,
4795         mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
4796 }
4797
4798 OP *
4799 Perl_newANONHASH(pTHX_ OP *o)
4800 {
4801     return newUNOP(OP_REFGEN, 0,
4802         mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
4803 }
4804
4805 OP *
4806 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
4807 {
4808     return newANONATTRSUB(floor, proto, Nullop, block);
4809 }
4810
4811 OP *
4812 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
4813 {
4814     return newUNOP(OP_REFGEN, 0,
4815         newSVOP(OP_ANONCODE, 0,
4816                 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
4817 }