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