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