This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
94ff49f568caa613aa13839581a8a0c881a770aa
[perl5.git] / op.c
1 #line 2 "op.c"
2 /*    op.c
3  *
4  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
5  *    2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
6  *
7  *    You may distribute under the terms of either the GNU General Public
8  *    License or the Artistic License, as specified in the README file.
9  *
10  */
11
12 /*
13  * 'You see: Mr. Drogo, he married poor Miss Primula Brandybuck.  She was
14  *  our Mr. Bilbo's first cousin on the mother's side (her mother being the
15  *  youngest of the Old Took's daughters); and Mr. Drogo was his second
16  *  cousin.  So Mr. Frodo is his first *and* second cousin, once removed
17  *  either way, as the saying is, if you follow me.'       --the Gaffer
18  *
19  *     [p.23 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
20  */
21
22 /* This file contains the functions that create, manipulate and optimize
23  * the OP structures that hold a compiled perl program.
24  *
25  * A Perl program is compiled into a tree of OPs. Each op contains
26  * structural pointers (eg to its siblings and the next op in the
27  * execution sequence), a pointer to the function that would execute the
28  * op, plus any data specific to that op. For example, an OP_CONST op
29  * points to the pp_const() function and to an SV containing the constant
30  * value. When pp_const() is executed, its job is to push that SV onto the
31  * stack.
32  *
33  * OPs are mainly created by the newFOO() functions, which are mainly
34  * called from the parser (in perly.y) as the code is parsed. For example
35  * the Perl code $a + $b * $c would cause the equivalent of the following
36  * to be called (oversimplifying a bit):
37  *
38  *  newBINOP(OP_ADD, flags,
39  *      newSVREF($a),
40  *      newBINOP(OP_MULTIPLY, flags, newSVREF($b), newSVREF($c))
41  *  )
42  *
43  * Note that during the build of miniperl, a temporary copy of this file
44  * is made, called opmini.c.
45  */
46
47 /*
48 Perl's compiler is essentially a 3-pass compiler with interleaved phases:
49
50     A bottom-up pass
51     A top-down pass
52     An execution-order pass
53
54 The bottom-up pass is represented by all the "newOP" routines and
55 the ck_ routines.  The bottom-upness is actually driven by yacc.
56 So at the point that a ck_ routine fires, we have no idea what the
57 context is, either upward in the syntax tree, or either forward or
58 backward in the execution order.  (The bottom-up parser builds that
59 part of the execution order it knows about, but if you follow the "next"
60 links around, you'll find it's actually a closed loop through the
61 top level node.)
62
63 Whenever the bottom-up parser gets to a node that supplies context to
64 its components, it invokes that portion of the top-down pass that applies
65 to that part of the subtree (and marks the top node as processed, so
66 if a node further up supplies context, it doesn't have to take the
67 plunge again).  As a particular subcase of this, as the new node is
68 built, it takes all the closed execution loops of its subcomponents
69 and links them into a new closed loop for the higher level node.  But
70 it's still not the real execution order.
71
72 The actual execution order is not known till we get a grammar reduction
73 to a top-level unit like a subroutine or file that will be called by
74 "name" rather than via a "next" pointer.  At that point, we can call
75 into peep() to do that code's portion of the 3rd pass.  It has to be
76 recursive, but it's recursive on basic blocks, not on tree nodes.
77 */
78
79 /* To implement user lexical pragmas, there needs to be a way at run time to
80    get the compile time state of %^H for that block.  Storing %^H in every
81    block (or even COP) would be very expensive, so a different approach is
82    taken.  The (running) state of %^H is serialised into a tree of HE-like
83    structs.  Stores into %^H are chained onto the current leaf as a struct
84    refcounted_he * with the key and the value.  Deletes from %^H are saved
85    with a value of PL_sv_placeholder.  The state of %^H at any point can be
86    turned back into a regular HV by walking back up the tree from that point's
87    leaf, ignoring any key you've already seen (placeholder or not), storing
88    the rest into the HV structure, then removing the placeholders. Hence
89    memory is only used to store the %^H deltas from the enclosing COP, rather
90    than the entire %^H on each COP.
91
92    To cause actions on %^H to write out the serialisation records, it has
93    magic type 'H'. This magic (itself) does nothing, but its presence causes
94    the values to gain magic type 'h', which has entries for set and clear.
95    C<Perl_magic_sethint> updates C<PL_compiling.cop_hints_hash> with a store
96    record, with deletes written by C<Perl_magic_clearhint>. C<SAVEHINTS>
97    saves the current C<PL_compiling.cop_hints_hash> on the save stack, so that
98    it will be correctly restored when any inner compiling scope is exited.
99 */
100
101 #include "EXTERN.h"
102 #define PERL_IN_OP_C
103 #include "perl.h"
104 #include "keywords.h"
105 #include "feature.h"
106 #include "regcomp.h"
107
108 #define CALL_PEEP(o) PL_peepp(aTHX_ o)
109 #define CALL_RPEEP(o) PL_rpeepp(aTHX_ o)
110 #define CALL_OPFREEHOOK(o) if (PL_opfreehook) PL_opfreehook(aTHX_ o)
111
112 /* remove any leading "empty" ops from the op_next chain whose first
113  * node's address is stored in op_p. Store the updated address of the
114  * first node in op_p.
115  */
116
117 STATIC void
118 S_prune_chain_head(pTHX_ OP** op_p)
119 {
120     while (*op_p
121         && (   (*op_p)->op_type == OP_NULL
122             || (*op_p)->op_type == OP_SCOPE
123             || (*op_p)->op_type == OP_SCALAR
124             || (*op_p)->op_type == OP_LINESEQ)
125     )
126         *op_p = (*op_p)->op_next;
127 }
128
129
130 /* See the explanatory comments above struct opslab in op.h. */
131
132 #ifdef PERL_DEBUG_READONLY_OPS
133 #  define PERL_SLAB_SIZE 128
134 #  define PERL_MAX_SLAB_SIZE 4096
135 #  include <sys/mman.h>
136 #endif
137
138 #ifndef PERL_SLAB_SIZE
139 #  define PERL_SLAB_SIZE 64
140 #endif
141 #ifndef PERL_MAX_SLAB_SIZE
142 #  define PERL_MAX_SLAB_SIZE 2048
143 #endif
144
145 /* rounds up to nearest pointer */
146 #define SIZE_TO_PSIZE(x)        (((x) + sizeof(I32 *) - 1)/sizeof(I32 *))
147 #define DIFF(o,p)               ((size_t)((I32 **)(p) - (I32**)(o)))
148
149 static OPSLAB *
150 S_new_slab(pTHX_ size_t sz)
151 {
152 #ifdef PERL_DEBUG_READONLY_OPS
153     OPSLAB *slab = (OPSLAB *) mmap(0, sz * sizeof(I32 *),
154                                    PROT_READ|PROT_WRITE,
155                                    MAP_ANON|MAP_PRIVATE, -1, 0);
156     DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
157                           (unsigned long) sz, slab));
158     if (slab == MAP_FAILED) {
159         perror("mmap failed");
160         abort();
161     }
162     slab->opslab_size = (U16)sz;
163 #else
164     OPSLAB *slab = (OPSLAB *)PerlMemShared_calloc(sz, sizeof(I32 *));
165 #endif
166     slab->opslab_first = (OPSLOT *)((I32 **)slab + sz - 1);
167     return slab;
168 }
169
170 /* requires double parens and aTHX_ */
171 #define DEBUG_S_warn(args)                                             \
172     DEBUG_S(                                                            \
173         PerlIO_printf(Perl_debug_log, "%s", SvPVx_nolen(Perl_mess args)) \
174     )
175
176 void *
177 Perl_Slab_Alloc(pTHX_ size_t sz)
178 {
179     dVAR;
180     OPSLAB *slab;
181     OPSLAB *slab2;
182     OPSLOT *slot;
183     OP *o;
184     size_t opsz, space;
185
186     /* We only allocate ops from the slab during subroutine compilation.
187        We find the slab via PL_compcv, hence that must be non-NULL. It could
188        also be pointing to a subroutine which is now fully set up (CvROOT()
189        pointing to the top of the optree for that sub), or a subroutine
190        which isn't using the slab allocator. If our sanity checks aren't met,
191        don't use a slab, but allocate the OP directly from the heap.  */
192     if (!PL_compcv || CvROOT(PL_compcv)
193      || (CvSTART(PL_compcv) && !CvSLABBED(PL_compcv)))
194         return PerlMemShared_calloc(1, sz);
195
196     /* While the subroutine is under construction, the slabs are accessed via
197        CvSTART(), to avoid needing to expand PVCV by one pointer for something
198        unneeded at runtime. Once a subroutine is constructed, the slabs are
199        accessed via CvROOT(). So if CvSTART() is NULL, no slab has been
200        allocated yet.  See the commit message for 8be227ab5eaa23f2 for more
201        details.  */
202     if (!CvSTART(PL_compcv)) {
203         CvSTART(PL_compcv) =
204             (OP *)(slab = S_new_slab(aTHX_ PERL_SLAB_SIZE));
205         CvSLABBED_on(PL_compcv);
206         slab->opslab_refcnt = 2; /* one for the CV; one for the new OP */
207     }
208     else ++(slab = (OPSLAB *)CvSTART(PL_compcv))->opslab_refcnt;
209
210     opsz = SIZE_TO_PSIZE(sz);
211     sz = opsz + OPSLOT_HEADER_P;
212
213     /* The slabs maintain a free list of OPs. In particular, constant folding
214        will free up OPs, so it makes sense to re-use them where possible. A
215        freed up slot is used in preference to a new allocation.  */
216     if (slab->opslab_freed) {
217         OP **too = &slab->opslab_freed;
218         o = *too;
219         DEBUG_S_warn((aTHX_ "found free op at %p, slab %p", o, slab));
220         while (o && DIFF(OpSLOT(o), OpSLOT(o)->opslot_next) < sz) {
221             DEBUG_S_warn((aTHX_ "Alas! too small"));
222             o = *(too = &o->op_next);
223             if (o) { DEBUG_S_warn((aTHX_ "found another free op at %p", o)); }
224         }
225         if (o) {
226             *too = o->op_next;
227             Zero(o, opsz, I32 *);
228             o->op_slabbed = 1;
229             return (void *)o;
230         }
231     }
232
233 #define INIT_OPSLOT \
234             slot->opslot_slab = slab;                   \
235             slot->opslot_next = slab2->opslab_first;    \
236             slab2->opslab_first = slot;                 \
237             o = &slot->opslot_op;                       \
238             o->op_slabbed = 1
239
240     /* The partially-filled slab is next in the chain. */
241     slab2 = slab->opslab_next ? slab->opslab_next : slab;
242     if ((space = DIFF(&slab2->opslab_slots, slab2->opslab_first)) < sz) {
243         /* Remaining space is too small. */
244
245         /* If we can fit a BASEOP, add it to the free chain, so as not
246            to waste it. */
247         if (space >= SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P) {
248             slot = &slab2->opslab_slots;
249             INIT_OPSLOT;
250             o->op_type = OP_FREED;
251             o->op_next = slab->opslab_freed;
252             slab->opslab_freed = o;
253         }
254
255         /* Create a new slab.  Make this one twice as big. */
256         slot = slab2->opslab_first;
257         while (slot->opslot_next) slot = slot->opslot_next;
258         slab2 = S_new_slab(aTHX_
259                             (DIFF(slab2, slot)+1)*2 > PERL_MAX_SLAB_SIZE
260                                         ? PERL_MAX_SLAB_SIZE
261                                         : (DIFF(slab2, slot)+1)*2);
262         slab2->opslab_next = slab->opslab_next;
263         slab->opslab_next = slab2;
264     }
265     assert(DIFF(&slab2->opslab_slots, slab2->opslab_first) >= sz);
266
267     /* Create a new op slot */
268     slot = (OPSLOT *)((I32 **)slab2->opslab_first - sz);
269     assert(slot >= &slab2->opslab_slots);
270     if (DIFF(&slab2->opslab_slots, slot)
271          < SIZE_TO_PSIZE(sizeof(OP)) + OPSLOT_HEADER_P)
272         slot = &slab2->opslab_slots;
273     INIT_OPSLOT;
274     DEBUG_S_warn((aTHX_ "allocating op at %p, slab %p", o, slab));
275     return (void *)o;
276 }
277
278 #undef INIT_OPSLOT
279
280 #ifdef PERL_DEBUG_READONLY_OPS
281 void
282 Perl_Slab_to_ro(pTHX_ OPSLAB *slab)
283 {
284     PERL_ARGS_ASSERT_SLAB_TO_RO;
285
286     if (slab->opslab_readonly) return;
287     slab->opslab_readonly = 1;
288     for (; slab; slab = slab->opslab_next) {
289         /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->ro %lu at %p\n",
290                               (unsigned long) slab->opslab_size, slab));*/
291         if (mprotect(slab, slab->opslab_size * sizeof(I32 *), PROT_READ))
292             Perl_warn(aTHX_ "mprotect for %p %lu failed with %d", slab,
293                              (unsigned long)slab->opslab_size, errno);
294     }
295 }
296
297 void
298 Perl_Slab_to_rw(pTHX_ OPSLAB *const slab)
299 {
300     OPSLAB *slab2;
301
302     PERL_ARGS_ASSERT_SLAB_TO_RW;
303
304     if (!slab->opslab_readonly) return;
305     slab2 = slab;
306     for (; slab2; slab2 = slab2->opslab_next) {
307         /*DEBUG_U(PerlIO_printf(Perl_debug_log,"mprotect ->rw %lu at %p\n",
308                               (unsigned long) size, slab2));*/
309         if (mprotect((void *)slab2, slab2->opslab_size * sizeof(I32 *),
310                      PROT_READ|PROT_WRITE)) {
311             Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d", slab,
312                              (unsigned long)slab2->opslab_size, errno);
313         }
314     }
315     slab->opslab_readonly = 0;
316 }
317
318 #else
319 #  define Slab_to_rw(op)    NOOP
320 #endif
321
322 /* This cannot possibly be right, but it was copied from the old slab
323    allocator, to which it was originally added, without explanation, in
324    commit 083fcd5. */
325 #ifdef NETWARE
326 #    define PerlMemShared PerlMem
327 #endif
328
329 void
330 Perl_Slab_Free(pTHX_ void *op)
331 {
332     dVAR;
333     OP * const o = (OP *)op;
334     OPSLAB *slab;
335
336     PERL_ARGS_ASSERT_SLAB_FREE;
337
338     if (!o->op_slabbed) {
339         if (!o->op_static)
340             PerlMemShared_free(op);
341         return;
342     }
343
344     slab = OpSLAB(o);
345     /* If this op is already freed, our refcount will get screwy. */
346     assert(o->op_type != OP_FREED);
347     o->op_type = OP_FREED;
348     o->op_next = slab->opslab_freed;
349     slab->opslab_freed = o;
350     DEBUG_S_warn((aTHX_ "free op at %p, recorded in slab %p", o, slab));
351     OpslabREFCNT_dec_padok(slab);
352 }
353
354 void
355 Perl_opslab_free_nopad(pTHX_ OPSLAB *slab)
356 {
357     dVAR;
358     const bool havepad = !!PL_comppad;
359     PERL_ARGS_ASSERT_OPSLAB_FREE_NOPAD;
360     if (havepad) {
361         ENTER;
362         PAD_SAVE_SETNULLPAD();
363     }
364     opslab_free(slab);
365     if (havepad) LEAVE;
366 }
367
368 void
369 Perl_opslab_free(pTHX_ OPSLAB *slab)
370 {
371     dVAR;
372     OPSLAB *slab2;
373     PERL_ARGS_ASSERT_OPSLAB_FREE;
374     DEBUG_S_warn((aTHX_ "freeing slab %p", slab));
375     assert(slab->opslab_refcnt == 1);
376     for (; slab; slab = slab2) {
377         slab2 = slab->opslab_next;
378 #ifdef DEBUGGING
379         slab->opslab_refcnt = ~(size_t)0;
380 #endif
381 #ifdef PERL_DEBUG_READONLY_OPS
382         DEBUG_m(PerlIO_printf(Perl_debug_log, "Deallocate slab at %p\n",
383                                                slab));
384         if (munmap(slab, slab->opslab_size * sizeof(I32 *))) {
385             perror("munmap failed");
386             abort();
387         }
388 #else
389         PerlMemShared_free(slab);
390 #endif
391     }
392 }
393
394 void
395 Perl_opslab_force_free(pTHX_ OPSLAB *slab)
396 {
397     OPSLAB *slab2;
398     OPSLOT *slot;
399 #ifdef DEBUGGING
400     size_t savestack_count = 0;
401 #endif
402     PERL_ARGS_ASSERT_OPSLAB_FORCE_FREE;
403     slab2 = slab;
404     do {
405         for (slot = slab2->opslab_first;
406              slot->opslot_next;
407              slot = slot->opslot_next) {
408             if (slot->opslot_op.op_type != OP_FREED
409              && !(slot->opslot_op.op_savefree
410 #ifdef DEBUGGING
411                   && ++savestack_count
412 #endif
413                  )
414             ) {
415                 assert(slot->opslot_op.op_slabbed);
416                 op_free(&slot->opslot_op);
417                 if (slab->opslab_refcnt == 1) goto free;
418             }
419         }
420     } while ((slab2 = slab2->opslab_next));
421     /* > 1 because the CV still holds a reference count. */
422     if (slab->opslab_refcnt > 1) { /* still referenced by the savestack */
423 #ifdef DEBUGGING
424         assert(savestack_count == slab->opslab_refcnt-1);
425 #endif
426         /* Remove the CV’s reference count. */
427         slab->opslab_refcnt--;
428         return;
429     }
430    free:
431     opslab_free(slab);
432 }
433
434 #ifdef PERL_DEBUG_READONLY_OPS
435 OP *
436 Perl_op_refcnt_inc(pTHX_ OP *o)
437 {
438     if(o) {
439         OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
440         if (slab && slab->opslab_readonly) {
441             Slab_to_rw(slab);
442             ++o->op_targ;
443             Slab_to_ro(slab);
444         } else {
445             ++o->op_targ;
446         }
447     }
448     return o;
449
450 }
451
452 PADOFFSET
453 Perl_op_refcnt_dec(pTHX_ OP *o)
454 {
455     PADOFFSET result;
456     OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
457
458     PERL_ARGS_ASSERT_OP_REFCNT_DEC;
459
460     if (slab && slab->opslab_readonly) {
461         Slab_to_rw(slab);
462         result = --o->op_targ;
463         Slab_to_ro(slab);
464     } else {
465         result = --o->op_targ;
466     }
467     return result;
468 }
469 #endif
470 /*
471  * In the following definition, the ", (OP*)0" is just to make the compiler
472  * think the expression is of the right type: croak actually does a Siglongjmp.
473  */
474 #define CHECKOP(type,o) \
475     ((PL_op_mask && PL_op_mask[type])                           \
476      ? ( op_free((OP*)o),                                       \
477          Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]),  \
478          (OP*)0 )                                               \
479      : PL_check[type](aTHX_ (OP*)o))
480
481 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
482
483 #define CHANGE_TYPE(o,type) \
484     STMT_START {                                \
485         o->op_type = (OPCODE)type;              \
486         o->op_ppaddr = PL_ppaddr[type];         \
487     } STMT_END
488
489 STATIC SV*
490 S_gv_ename(pTHX_ GV *gv)
491 {
492     SV* const tmpsv = sv_newmortal();
493
494     PERL_ARGS_ASSERT_GV_ENAME;
495
496     gv_efullname3(tmpsv, gv, NULL);
497     return tmpsv;
498 }
499
500 STATIC OP *
501 S_no_fh_allowed(pTHX_ OP *o)
502 {
503     PERL_ARGS_ASSERT_NO_FH_ALLOWED;
504
505     yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
506                  OP_DESC(o)));
507     return o;
508 }
509
510 STATIC OP *
511 S_too_few_arguments_sv(pTHX_ OP *o, SV *namesv, U32 flags)
512 {
513     PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_SV;
514     yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %"SVf, namesv),
515                                     SvUTF8(namesv) | flags);
516     return o;
517 }
518
519 STATIC OP *
520 S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags)
521 {
522     PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV;
523     yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %s", name), flags);
524     return o;
525 }
526  
527 STATIC OP *
528 S_too_many_arguments_pv(pTHX_ OP *o, const char *name, U32 flags)
529 {
530     PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_PV;
531
532     yyerror_pv(Perl_form(aTHX_ "Too many arguments for %s", name), flags);
533     return o;
534 }
535
536 STATIC OP *
537 S_too_many_arguments_sv(pTHX_ OP *o, SV *namesv, U32 flags)
538 {
539     PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_SV;
540
541     yyerror_pv(Perl_form(aTHX_ "Too many arguments for %"SVf, SVfARG(namesv)),
542                 SvUTF8(namesv) | flags);
543     return o;
544 }
545
546 STATIC void
547 S_bad_type_pv(pTHX_ I32 n, const char *t, const char *name, U32 flags, const OP *kid)
548 {
549     PERL_ARGS_ASSERT_BAD_TYPE_PV;
550
551     yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
552                  (int)n, name, t, OP_DESC(kid)), flags);
553 }
554
555 STATIC void
556 S_bad_type_gv(pTHX_ I32 n, const char *t, GV *gv, U32 flags, const OP *kid)
557 {
558     SV * const namesv = gv_ename(gv);
559     PERL_ARGS_ASSERT_BAD_TYPE_GV;
560  
561     yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %"SVf" must be %s (not %s)",
562                  (int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv) | flags);
563 }
564
565 STATIC void
566 S_no_bareword_allowed(pTHX_ OP *o)
567 {
568     PERL_ARGS_ASSERT_NO_BAREWORD_ALLOWED;
569
570     if (PL_madskills)
571         return;         /* various ok barewords are hidden in extra OP_NULL */
572     qerror(Perl_mess(aTHX_
573                      "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use",
574                      SVfARG(cSVOPo_sv)));
575     o->op_private &= ~OPpCONST_STRICT; /* prevent warning twice about the same OP */
576 }
577
578 /* "register" allocation */
579
580 PADOFFSET
581 Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
582 {
583     dVAR;
584     PADOFFSET off;
585     const bool is_our = (PL_parser->in_my == KEY_our);
586
587     PERL_ARGS_ASSERT_ALLOCMY;
588
589     if (flags & ~SVf_UTF8)
590         Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
591                    (UV)flags);
592
593     /* Until we're using the length for real, cross check that we're being
594        told the truth.  */
595     assert(strlen(name) == len);
596
597     /* complain about "my $<special_var>" etc etc */
598     if (len &&
599         !(is_our ||
600           isALPHA(name[1]) ||
601           ((flags & SVf_UTF8) && isIDFIRST_utf8((U8 *)name+1)) ||
602           (name[1] == '_' && (*name == '$' || len > 2))))
603     {
604         /* name[2] is true if strlen(name) > 2  */
605         if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1]))
606          && (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1]))) {
607             yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
608                               name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
609                               PL_parser->in_my == KEY_state ? "state" : "my"));
610         } else {
611             yyerror_pv(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
612                               PL_parser->in_my == KEY_state ? "state" : "my"), flags & SVf_UTF8);
613         }
614     }
615     else if (len == 2 && name[1] == '_' && !is_our)
616         /* diag_listed_as: Use of my $_ is experimental */
617         Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__LEXICAL_TOPIC),
618                               "Use of %s $_ is experimental",
619                                PL_parser->in_my == KEY_state
620                                  ? "state"
621                                  : "my");
622
623     /* allocate a spare slot and store the name in that slot */
624
625     off = pad_add_name_pvn(name, len,
626                        (is_our ? padadd_OUR :
627                         PL_parser->in_my == KEY_state ? padadd_STATE : 0)
628                             | ( flags & SVf_UTF8 ? SVf_UTF8 : 0 ),
629                     PL_parser->in_my_stash,
630                     (is_our
631                         /* $_ is always in main::, even with our */
632                         ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
633                         : NULL
634                     )
635     );
636     /* anon sub prototypes contains state vars should always be cloned,
637      * otherwise the state var would be shared between anon subs */
638
639     if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
640         CvCLONE_on(PL_compcv);
641
642     return off;
643 }
644
645 /*
646 =for apidoc alloccopstash
647
648 Available only under threaded builds, this function allocates an entry in
649 C<PL_stashpad> for the stash passed to it.
650
651 =cut
652 */
653
654 #ifdef USE_ITHREADS
655 PADOFFSET
656 Perl_alloccopstash(pTHX_ HV *hv)
657 {
658     PADOFFSET off = 0, o = 1;
659     bool found_slot = FALSE;
660
661     PERL_ARGS_ASSERT_ALLOCCOPSTASH;
662
663     if (PL_stashpad[PL_stashpadix] == hv) return PL_stashpadix;
664
665     for (; o < PL_stashpadmax; ++o) {
666         if (PL_stashpad[o] == hv) return PL_stashpadix = o;
667         if (!PL_stashpad[o] || SvTYPE(PL_stashpad[o]) != SVt_PVHV)
668             found_slot = TRUE, off = o;
669     }
670     if (!found_slot) {
671         Renew(PL_stashpad, PL_stashpadmax + 10, HV *);
672         Zero(PL_stashpad + PL_stashpadmax, 10, HV *);
673         off = PL_stashpadmax;
674         PL_stashpadmax += 10;
675     }
676
677     PL_stashpad[PL_stashpadix = off] = hv;
678     return off;
679 }
680 #endif
681
682 /* free the body of an op without examining its contents.
683  * Always use this rather than FreeOp directly */
684
685 static void
686 S_op_destroy(pTHX_ OP *o)
687 {
688     FreeOp(o);
689 }
690
691 /* Destructor */
692
693 /*
694 =for apidoc Am|void|op_free|OP *o
695
696 Free an op.  Only use this when an op is no longer linked to from any
697 optree.
698
699 =cut
700 */
701
702 void
703 Perl_op_free(pTHX_ OP *o)
704 {
705     dVAR;
706     OPCODE type;
707
708     /* Though ops may be freed twice, freeing the op after its slab is a
709        big no-no. */
710     assert(!o || !o->op_slabbed || OpSLAB(o)->opslab_refcnt != ~(size_t)0); 
711     /* During the forced freeing of ops after compilation failure, kidops
712        may be freed before their parents. */
713     if (!o || o->op_type == OP_FREED)
714         return;
715
716     type = o->op_type;
717     if (o->op_private & OPpREFCOUNTED) {
718         switch (type) {
719         case OP_LEAVESUB:
720         case OP_LEAVESUBLV:
721         case OP_LEAVEEVAL:
722         case OP_LEAVE:
723         case OP_SCOPE:
724         case OP_LEAVEWRITE:
725             {
726             PADOFFSET refcnt;
727             OP_REFCNT_LOCK;
728             refcnt = OpREFCNT_dec(o);
729             OP_REFCNT_UNLOCK;
730             if (refcnt) {
731                 /* Need to find and remove any pattern match ops from the list
732                    we maintain for reset().  */
733                 find_and_forget_pmops(o);
734                 return;
735             }
736             }
737             break;
738         default:
739             break;
740         }
741     }
742
743     /* Call the op_free hook if it has been set. Do it now so that it's called
744      * at the right time for refcounted ops, but still before all of the kids
745      * are freed. */
746     CALL_OPFREEHOOK(o);
747
748     if (o->op_flags & OPf_KIDS) {
749         OP *kid, *nextkid;
750         for (kid = cUNOPo->op_first; kid; kid = nextkid) {
751             nextkid = kid->op_sibling; /* Get before next freeing kid */
752             op_free(kid);
753         }
754     }
755     if (type == OP_NULL)
756         type = (OPCODE)o->op_targ;
757
758     if (o->op_slabbed)
759         Slab_to_rw(OpSLAB(o));
760
761     /* COP* is not cleared by op_clear() so that we may track line
762      * numbers etc even after null() */
763     if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
764         cop_free((COP*)o);
765     }
766
767     op_clear(o);
768     FreeOp(o);
769 #ifdef DEBUG_LEAKING_SCALARS
770     if (PL_op == o)
771         PL_op = NULL;
772 #endif
773 }
774
775 void
776 Perl_op_clear(pTHX_ OP *o)
777 {
778
779     dVAR;
780
781     PERL_ARGS_ASSERT_OP_CLEAR;
782
783 #ifdef PERL_MAD
784     mad_free(o->op_madprop);
785     o->op_madprop = 0;
786 #endif    
787
788  retry:
789     switch (o->op_type) {
790     case OP_NULL:       /* Was holding old type, if any. */
791         if (PL_madskills && o->op_targ != OP_NULL) {
792             o->op_type = (Optype)o->op_targ;
793             o->op_targ = 0;
794             goto retry;
795         }
796         /* FALLTHROUGH */
797     case OP_ENTERTRY:
798     case OP_ENTEREVAL:  /* Was holding hints. */
799         o->op_targ = 0;
800         break;
801     default:
802         if (!(o->op_flags & OPf_REF)
803             || (PL_check[o->op_type] != Perl_ck_ftst))
804             break;
805         /* FALLTHROUGH */
806     case OP_GVSV:
807     case OP_GV:
808     case OP_AELEMFAST:
809         {
810             GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV)
811 #ifdef USE_ITHREADS
812                         && PL_curpad
813 #endif
814                         ? cGVOPo_gv : NULL;
815             /* It's possible during global destruction that the GV is freed
816                before the optree. Whilst the SvREFCNT_inc is happy to bump from
817                0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
818                will trigger an assertion failure, because the entry to sv_clear
819                checks that the scalar is not already freed.  A check of for
820                !SvIS_FREED(gv) turns out to be invalid, because during global
821                destruction the reference count can be forced down to zero
822                (with SVf_BREAK set).  In which case raising to 1 and then
823                dropping to 0 triggers cleanup before it should happen.  I
824                *think* that this might actually be a general, systematic,
825                weakness of the whole idea of SVf_BREAK, in that code *is*
826                allowed to raise and lower references during global destruction,
827                so any *valid* code that happens to do this during global
828                destruction might well trigger premature cleanup.  */
829             bool still_valid = gv && SvREFCNT(gv);
830
831             if (still_valid)
832                 SvREFCNT_inc_simple_void(gv);
833 #ifdef USE_ITHREADS
834             if (cPADOPo->op_padix > 0) {
835                 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
836                  * may still exist on the pad */
837                 pad_swipe(cPADOPo->op_padix, TRUE);
838                 cPADOPo->op_padix = 0;
839             }
840 #else
841             SvREFCNT_dec(cSVOPo->op_sv);
842             cSVOPo->op_sv = NULL;
843 #endif
844             if (still_valid) {
845                 int try_downgrade = SvREFCNT(gv) == 2;
846                 SvREFCNT_dec_NN(gv);
847                 if (try_downgrade)
848                     gv_try_downgrade(gv);
849             }
850         }
851         break;
852     case OP_METHOD_NAMED:
853     case OP_CONST:
854     case OP_HINTSEVAL:
855         SvREFCNT_dec(cSVOPo->op_sv);
856         cSVOPo->op_sv = NULL;
857 #ifdef USE_ITHREADS
858         /** Bug #15654
859           Even if op_clear does a pad_free for the target of the op,
860           pad_free doesn't actually remove the sv that exists in the pad;
861           instead it lives on. This results in that it could be reused as 
862           a target later on when the pad was reallocated.
863         **/
864         if(o->op_targ) {
865           pad_swipe(o->op_targ,1);
866           o->op_targ = 0;
867         }
868 #endif
869         break;
870     case OP_DUMP:
871     case OP_GOTO:
872     case OP_NEXT:
873     case OP_LAST:
874     case OP_REDO:
875         if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
876             break;
877         /* FALLTHROUGH */
878     case OP_TRANS:
879     case OP_TRANSR:
880         if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
881             assert(o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
882 #ifdef USE_ITHREADS
883             if (cPADOPo->op_padix > 0) {
884                 pad_swipe(cPADOPo->op_padix, TRUE);
885                 cPADOPo->op_padix = 0;
886             }
887 #else
888             SvREFCNT_dec(cSVOPo->op_sv);
889             cSVOPo->op_sv = NULL;
890 #endif
891         }
892         else {
893             PerlMemShared_free(cPVOPo->op_pv);
894             cPVOPo->op_pv = NULL;
895         }
896         break;
897     case OP_SUBST:
898         op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
899         goto clear_pmop;
900     case OP_PUSHRE:
901 #ifdef USE_ITHREADS
902         if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
903             /* No GvIN_PAD_off here, because other references may still
904              * exist on the pad */
905             pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
906         }
907 #else
908         SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
909 #endif
910         /* FALLTHROUGH */
911     case OP_MATCH:
912     case OP_QR:
913 clear_pmop:
914         if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE))
915             op_free(cPMOPo->op_code_list);
916         cPMOPo->op_code_list = NULL;
917         forget_pmop(cPMOPo);
918         cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
919         /* we use the same protection as the "SAFE" version of the PM_ macros
920          * here since sv_clean_all might release some PMOPs
921          * after PL_regex_padav has been cleared
922          * and the clearing of PL_regex_padav needs to
923          * happen before sv_clean_all
924          */
925 #ifdef USE_ITHREADS
926         if(PL_regex_pad) {        /* We could be in destruction */
927             const IV offset = (cPMOPo)->op_pmoffset;
928             ReREFCNT_dec(PM_GETRE(cPMOPo));
929             PL_regex_pad[offset] = &PL_sv_undef;
930             sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
931                            sizeof(offset));
932         }
933 #else
934         ReREFCNT_dec(PM_GETRE(cPMOPo));
935         PM_SETRE(cPMOPo, NULL);
936 #endif
937
938         break;
939     }
940
941     if (o->op_targ > 0) {
942         pad_free(o->op_targ);
943         o->op_targ = 0;
944     }
945 }
946
947 STATIC void
948 S_cop_free(pTHX_ COP* cop)
949 {
950     PERL_ARGS_ASSERT_COP_FREE;
951
952     CopFILE_free(cop);
953     if (! specialWARN(cop->cop_warnings))
954         PerlMemShared_free(cop->cop_warnings);
955     cophh_free(CopHINTHASH_get(cop));
956     if (PL_curcop == cop)
957        PL_curcop = NULL;
958 }
959
960 STATIC void
961 S_forget_pmop(pTHX_ PMOP *const o
962               )
963 {
964     HV * const pmstash = PmopSTASH(o);
965
966     PERL_ARGS_ASSERT_FORGET_PMOP;
967
968     if (pmstash && !SvIS_FREED(pmstash) && SvMAGICAL(pmstash)) {
969         MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
970         if (mg) {
971             PMOP **const array = (PMOP**) mg->mg_ptr;
972             U32 count = mg->mg_len / sizeof(PMOP**);
973             U32 i = count;
974
975             while (i--) {
976                 if (array[i] == o) {
977                     /* Found it. Move the entry at the end to overwrite it.  */
978                     array[i] = array[--count];
979                     mg->mg_len = count * sizeof(PMOP**);
980                     /* Could realloc smaller at this point always, but probably
981                        not worth it. Probably worth free()ing if we're the
982                        last.  */
983                     if(!count) {
984                         Safefree(mg->mg_ptr);
985                         mg->mg_ptr = NULL;
986                     }
987                     break;
988                 }
989             }
990         }
991     }
992     if (PL_curpm == o) 
993         PL_curpm = NULL;
994 }
995
996 STATIC void
997 S_find_and_forget_pmops(pTHX_ OP *o)
998 {
999     PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
1000
1001     if (o->op_flags & OPf_KIDS) {
1002         OP *kid = cUNOPo->op_first;
1003         while (kid) {
1004             switch (kid->op_type) {
1005             case OP_SUBST:
1006             case OP_PUSHRE:
1007             case OP_MATCH:
1008             case OP_QR:
1009                 forget_pmop((PMOP*)kid);
1010             }
1011             find_and_forget_pmops(kid);
1012             kid = kid->op_sibling;
1013         }
1014     }
1015 }
1016
1017 /*
1018 =for apidoc Am|void|op_null|OP *o
1019
1020 Neutralizes an op when it is no longer needed, but is still linked to from
1021 other ops.
1022
1023 =cut
1024 */
1025
1026 void
1027 Perl_op_null(pTHX_ OP *o)
1028 {
1029     dVAR;
1030
1031     PERL_ARGS_ASSERT_OP_NULL;
1032
1033     if (o->op_type == OP_NULL)
1034         return;
1035     if (!PL_madskills)
1036         op_clear(o);
1037     o->op_targ = o->op_type;
1038     o->op_type = OP_NULL;
1039     o->op_ppaddr = PL_ppaddr[OP_NULL];
1040 }
1041
1042 void
1043 Perl_op_refcnt_lock(pTHX)
1044 {
1045     dVAR;
1046     PERL_UNUSED_CONTEXT;
1047     OP_REFCNT_LOCK;
1048 }
1049
1050 void
1051 Perl_op_refcnt_unlock(pTHX)
1052 {
1053     dVAR;
1054     PERL_UNUSED_CONTEXT;
1055     OP_REFCNT_UNLOCK;
1056 }
1057
1058 /* Contextualizers */
1059
1060 /*
1061 =for apidoc Am|OP *|op_contextualize|OP *o|I32 context
1062
1063 Applies a syntactic context to an op tree representing an expression.
1064 I<o> is the op tree, and I<context> must be C<G_SCALAR>, C<G_ARRAY>,
1065 or C<G_VOID> to specify the context to apply.  The modified op tree
1066 is returned.
1067
1068 =cut
1069 */
1070
1071 OP *
1072 Perl_op_contextualize(pTHX_ OP *o, I32 context)
1073 {
1074     PERL_ARGS_ASSERT_OP_CONTEXTUALIZE;
1075     switch (context) {
1076         case G_SCALAR: return scalar(o);
1077         case G_ARRAY:  return list(o);
1078         case G_VOID:   return scalarvoid(o);
1079         default:
1080             Perl_croak(aTHX_ "panic: op_contextualize bad context %ld",
1081                        (long) context);
1082             return o;
1083     }
1084 }
1085
1086 /*
1087 =head1 Optree Manipulation Functions
1088
1089 =for apidoc Am|OP*|op_linklist|OP *o
1090 This function is the implementation of the L</LINKLIST> macro.  It should
1091 not be called directly.
1092
1093 =cut
1094 */
1095
1096 OP *
1097 Perl_op_linklist(pTHX_ OP *o)
1098 {
1099     OP *first;
1100
1101     PERL_ARGS_ASSERT_OP_LINKLIST;
1102
1103     if (o->op_next)
1104         return o->op_next;
1105
1106     /* establish postfix order */
1107     first = cUNOPo->op_first;
1108     if (first) {
1109         OP *kid;
1110         o->op_next = LINKLIST(first);
1111         kid = first;
1112         for (;;) {
1113             if (kid->op_sibling) {
1114                 kid->op_next = LINKLIST(kid->op_sibling);
1115                 kid = kid->op_sibling;
1116             } else {
1117                 kid->op_next = o;
1118                 break;
1119             }
1120         }
1121     }
1122     else
1123         o->op_next = o;
1124
1125     return o->op_next;
1126 }
1127
1128 static OP *
1129 S_scalarkids(pTHX_ OP *o)
1130 {
1131     if (o && o->op_flags & OPf_KIDS) {
1132         OP *kid;
1133         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1134             scalar(kid);
1135     }
1136     return o;
1137 }
1138
1139 STATIC OP *
1140 S_scalarboolean(pTHX_ OP *o)
1141 {
1142     dVAR;
1143
1144     PERL_ARGS_ASSERT_SCALARBOOLEAN;
1145
1146     if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST
1147      && !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) {
1148         if (ckWARN(WARN_SYNTAX)) {
1149             const line_t oldline = CopLINE(PL_curcop);
1150
1151             if (PL_parser && PL_parser->copline != NOLINE) {
1152                 /* This ensures that warnings are reported at the first line
1153                    of the conditional, not the last.  */
1154                 CopLINE_set(PL_curcop, PL_parser->copline);
1155             }
1156             Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
1157             CopLINE_set(PL_curcop, oldline);
1158         }
1159     }
1160     return scalar(o);
1161 }
1162
1163 static SV *
1164 S_op_varname(pTHX_ const OP *o)
1165 {
1166     assert(o);
1167     assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV ||
1168            o->op_type == OP_PADHV || o->op_type == OP_RV2HV);
1169     {
1170         const char funny  = o->op_type == OP_PADAV
1171                          || o->op_type == OP_RV2AV ? '@' : '%';
1172         if (o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) {
1173             GV *gv;
1174             if (cUNOPo->op_first->op_type != OP_GV
1175              || !(gv = cGVOPx_gv(cUNOPo->op_first)))
1176                 return NULL;
1177             return varname(gv, funny, 0, NULL, 0, 1);
1178         }
1179         return
1180             varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, 1);
1181     }
1182 }
1183
1184 static void
1185 S_op_pretty(pTHX_ const OP *o, SV **retsv, const char **retpv)
1186 { /* or not so pretty :-) */
1187     if (o->op_type == OP_CONST) {
1188         *retsv = cSVOPo_sv;
1189         if (SvPOK(*retsv)) {
1190             SV *sv = *retsv;
1191             *retsv = sv_newmortal();
1192             pv_pretty(*retsv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL,
1193                       PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT);
1194         }
1195         else if (!SvOK(*retsv))
1196             *retpv = "undef";
1197     }
1198     else *retpv = "...";
1199 }
1200
1201 static void
1202 S_scalar_slice_warning(pTHX_ const OP *o)
1203 {
1204     OP *kid;
1205     const char lbrack =
1206         o->op_type == OP_HSLICE ? '{' : '[';
1207     const char rbrack =
1208         o->op_type == OP_HSLICE ? '}' : ']';
1209     SV *name;
1210     SV *keysv = NULL; /* just to silence compiler warnings */
1211     const char *key = NULL;
1212
1213     if (!(o->op_private & OPpSLICEWARNING))
1214         return;
1215     if (PL_parser && PL_parser->error_count)
1216         /* This warning can be nonsensical when there is a syntax error. */
1217         return;
1218
1219     kid = cLISTOPo->op_first;
1220     kid = kid->op_sibling; /* get past pushmark */
1221     /* weed out false positives: any ops that can return lists */
1222     switch (kid->op_type) {
1223     case OP_BACKTICK:
1224     case OP_GLOB:
1225     case OP_READLINE:
1226     case OP_MATCH:
1227     case OP_RV2AV:
1228     case OP_EACH:
1229     case OP_VALUES:
1230     case OP_KEYS:
1231     case OP_SPLIT:
1232     case OP_LIST:
1233     case OP_SORT:
1234     case OP_REVERSE:
1235     case OP_ENTERSUB:
1236     case OP_CALLER:
1237     case OP_LSTAT:
1238     case OP_STAT:
1239     case OP_READDIR:
1240     case OP_SYSTEM:
1241     case OP_TMS:
1242     case OP_LOCALTIME:
1243     case OP_GMTIME:
1244     case OP_ENTEREVAL:
1245     case OP_REACH:
1246     case OP_RKEYS:
1247     case OP_RVALUES:
1248         return;
1249     }
1250
1251     /* Don't warn if we have a nulled list either. */
1252     if (kid->op_type == OP_NULL && kid->op_targ == OP_LIST)
1253         return;
1254
1255     assert(kid->op_sibling);
1256     name = S_op_varname(aTHX_ kid->op_sibling);
1257     if (!name) /* XS module fiddling with the op tree */
1258         return;
1259     S_op_pretty(aTHX_ kid, &keysv, &key);
1260     assert(SvPOK(name));
1261     sv_chop(name,SvPVX(name)+1);
1262     if (key)
1263        /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1264         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1265                    "Scalar value @%"SVf"%c%s%c better written as $%"SVf
1266                    "%c%s%c",
1267                     SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1268                     lbrack, key, rbrack);
1269     else
1270        /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1271         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1272                    "Scalar value @%"SVf"%c%"SVf"%c better written as $%"
1273                     SVf"%c%"SVf"%c",
1274                     SVfARG(name), lbrack, keysv, rbrack,
1275                     SVfARG(name), lbrack, keysv, rbrack);
1276 }
1277
1278 OP *
1279 Perl_scalar(pTHX_ OP *o)
1280 {
1281     dVAR;
1282     OP *kid;
1283
1284     /* assumes no premature commitment */
1285     if (!o || (PL_parser && PL_parser->error_count)
1286          || (o->op_flags & OPf_WANT)
1287          || o->op_type == OP_RETURN)
1288     {
1289         return o;
1290     }
1291
1292     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
1293
1294     switch (o->op_type) {
1295     case OP_REPEAT:
1296         scalar(cBINOPo->op_first);
1297         break;
1298     case OP_OR:
1299     case OP_AND:
1300     case OP_COND_EXPR:
1301         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1302             scalar(kid);
1303         break;
1304         /* FALLTHROUGH */
1305     case OP_SPLIT:
1306     case OP_MATCH:
1307     case OP_QR:
1308     case OP_SUBST:
1309     case OP_NULL:
1310     default:
1311         if (o->op_flags & OPf_KIDS) {
1312             for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1313                 scalar(kid);
1314         }
1315         break;
1316     case OP_LEAVE:
1317     case OP_LEAVETRY:
1318         kid = cLISTOPo->op_first;
1319         scalar(kid);
1320         kid = kid->op_sibling;
1321     do_kids:
1322         while (kid) {
1323             OP *sib = kid->op_sibling;
1324             if (sib && kid->op_type != OP_LEAVEWHEN)
1325                 scalarvoid(kid);
1326             else
1327                 scalar(kid);
1328             kid = sib;
1329         }
1330         PL_curcop = &PL_compiling;
1331         break;
1332     case OP_SCOPE:
1333     case OP_LINESEQ:
1334     case OP_LIST:
1335         kid = cLISTOPo->op_first;
1336         goto do_kids;
1337     case OP_SORT:
1338         Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
1339         break;
1340     case OP_KVHSLICE:
1341     case OP_KVASLICE:
1342     {
1343         /* Warn about scalar context */
1344         const char lbrack = o->op_type == OP_KVHSLICE ? '{' : '[';
1345         const char rbrack = o->op_type == OP_KVHSLICE ? '}' : ']';
1346         SV *name;
1347         SV *keysv;
1348         const char *key = NULL;
1349
1350         /* This warning can be nonsensical when there is a syntax error. */
1351         if (PL_parser && PL_parser->error_count)
1352             break;
1353
1354         if (!ckWARN(WARN_SYNTAX)) break;
1355
1356         kid = cLISTOPo->op_first;
1357         kid = kid->op_sibling; /* get past pushmark */
1358         assert(kid->op_sibling);
1359         name = S_op_varname(aTHX_ kid->op_sibling);
1360         if (!name) /* XS module fiddling with the op tree */
1361             break;
1362         S_op_pretty(aTHX_ kid, &keysv, &key);
1363         assert(SvPOK(name));
1364         sv_chop(name,SvPVX(name)+1);
1365         if (key)
1366   /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1367             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1368                        "%%%"SVf"%c%s%c in scalar context better written "
1369                        "as $%"SVf"%c%s%c",
1370                         SVfARG(name), lbrack, key, rbrack, SVfARG(name),
1371                         lbrack, key, rbrack);
1372         else
1373   /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1374             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
1375                        "%%%"SVf"%c%"SVf"%c in scalar context better "
1376                        "written as $%"SVf"%c%"SVf"%c",
1377                         SVfARG(name), lbrack, keysv, rbrack,
1378                         SVfARG(name), lbrack, keysv, rbrack);
1379     }
1380     }
1381     return o;
1382 }
1383
1384 OP *
1385 Perl_scalarvoid(pTHX_ OP *o)
1386 {
1387     dVAR;
1388     OP *kid;
1389     SV *useless_sv = NULL;
1390     const char* useless = NULL;
1391     SV* sv;
1392     U8 want;
1393
1394     PERL_ARGS_ASSERT_SCALARVOID;
1395
1396     /* trailing mad null ops don't count as "there" for void processing */
1397     if (PL_madskills &&
1398         o->op_type != OP_NULL &&
1399         o->op_sibling &&
1400         o->op_sibling->op_type == OP_NULL)
1401     {
1402         OP *sib;
1403         for (sib = o->op_sibling;
1404                 sib && sib->op_type == OP_NULL;
1405                 sib = sib->op_sibling) ;
1406         
1407         if (!sib)
1408             return o;
1409     }
1410
1411     if (o->op_type == OP_NEXTSTATE
1412         || o->op_type == OP_DBSTATE
1413         || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1414                                       || o->op_targ == OP_DBSTATE)))
1415         PL_curcop = (COP*)o;            /* for warning below */
1416
1417     /* assumes no premature commitment */
1418     want = o->op_flags & OPf_WANT;
1419     if ((want && want != OPf_WANT_SCALAR)
1420          || (PL_parser && PL_parser->error_count)
1421          || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
1422     {
1423         return o;
1424     }
1425
1426     if ((o->op_private & OPpTARGET_MY)
1427         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1428     {
1429         return scalar(o);                       /* As if inside SASSIGN */
1430     }
1431
1432     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1433
1434     switch (o->op_type) {
1435     default:
1436         if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1437             break;
1438         /* FALLTHROUGH */
1439     case OP_REPEAT:
1440         if (o->op_flags & OPf_STACKED)
1441             break;
1442         goto func_ops;
1443     case OP_SUBSTR:
1444         if (o->op_private == 4)
1445             break;
1446         /* FALLTHROUGH */
1447     case OP_GVSV:
1448     case OP_WANTARRAY:
1449     case OP_GV:
1450     case OP_SMARTMATCH:
1451     case OP_PADSV:
1452     case OP_PADAV:
1453     case OP_PADHV:
1454     case OP_PADANY:
1455     case OP_AV2ARYLEN:
1456     case OP_REF:
1457     case OP_REFGEN:
1458     case OP_SREFGEN:
1459     case OP_DEFINED:
1460     case OP_HEX:
1461     case OP_OCT:
1462     case OP_LENGTH:
1463     case OP_VEC:
1464     case OP_INDEX:
1465     case OP_RINDEX:
1466     case OP_SPRINTF:
1467     case OP_AELEM:
1468     case OP_AELEMFAST:
1469     case OP_AELEMFAST_LEX:
1470     case OP_ASLICE:
1471     case OP_KVASLICE:
1472     case OP_HELEM:
1473     case OP_HSLICE:
1474     case OP_KVHSLICE:
1475     case OP_UNPACK:
1476     case OP_PACK:
1477     case OP_JOIN:
1478     case OP_LSLICE:
1479     case OP_ANONLIST:
1480     case OP_ANONHASH:
1481     case OP_SORT:
1482     case OP_REVERSE:
1483     case OP_RANGE:
1484     case OP_FLIP:
1485     case OP_FLOP:
1486     case OP_CALLER:
1487     case OP_FILENO:
1488     case OP_EOF:
1489     case OP_TELL:
1490     case OP_GETSOCKNAME:
1491     case OP_GETPEERNAME:
1492     case OP_READLINK:
1493     case OP_TELLDIR:
1494     case OP_GETPPID:
1495     case OP_GETPGRP:
1496     case OP_GETPRIORITY:
1497     case OP_TIME:
1498     case OP_TMS:
1499     case OP_LOCALTIME:
1500     case OP_GMTIME:
1501     case OP_GHBYNAME:
1502     case OP_GHBYADDR:
1503     case OP_GHOSTENT:
1504     case OP_GNBYNAME:
1505     case OP_GNBYADDR:
1506     case OP_GNETENT:
1507     case OP_GPBYNAME:
1508     case OP_GPBYNUMBER:
1509     case OP_GPROTOENT:
1510     case OP_GSBYNAME:
1511     case OP_GSBYPORT:
1512     case OP_GSERVENT:
1513     case OP_GPWNAM:
1514     case OP_GPWUID:
1515     case OP_GGRNAM:
1516     case OP_GGRGID:
1517     case OP_GETLOGIN:
1518     case OP_PROTOTYPE:
1519     case OP_RUNCV:
1520       func_ops:
1521         if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1522             /* Otherwise it's "Useless use of grep iterator" */
1523             useless = OP_DESC(o);
1524         break;
1525
1526     case OP_SPLIT:
1527         kid = cLISTOPo->op_first;
1528         if (kid && kid->op_type == OP_PUSHRE
1529 #ifdef USE_ITHREADS
1530                 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff)
1531 #else
1532                 && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv)
1533 #endif
1534             useless = OP_DESC(o);
1535         break;
1536
1537     case OP_NOT:
1538        kid = cUNOPo->op_first;
1539        if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1540            kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
1541                 goto func_ops;
1542        }
1543        useless = "negative pattern binding (!~)";
1544        break;
1545
1546     case OP_SUBST:
1547         if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
1548             useless = "non-destructive substitution (s///r)";
1549         break;
1550
1551     case OP_TRANSR:
1552         useless = "non-destructive transliteration (tr///r)";
1553         break;
1554
1555     case OP_RV2GV:
1556     case OP_RV2SV:
1557     case OP_RV2AV:
1558     case OP_RV2HV:
1559         if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1560                 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1561             useless = "a variable";
1562         break;
1563
1564     case OP_CONST:
1565         sv = cSVOPo_sv;
1566         if (cSVOPo->op_private & OPpCONST_STRICT)
1567             no_bareword_allowed(o);
1568         else {
1569             if (ckWARN(WARN_VOID)) {
1570                 /* don't warn on optimised away booleans, eg 
1571                  * use constant Foo, 5; Foo || print; */
1572                 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1573                     useless = NULL;
1574                 /* the constants 0 and 1 are permitted as they are
1575                    conventionally used as dummies in constructs like
1576                         1 while some_condition_with_side_effects;  */
1577                 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1578                     useless = NULL;
1579                 else if (SvPOK(sv)) {
1580                     SV * const dsv = newSVpvs("");
1581                     useless_sv
1582                         = Perl_newSVpvf(aTHX_
1583                                         "a constant (%s)",
1584                                         pv_pretty(dsv, SvPVX_const(sv),
1585                                                   SvCUR(sv), 32, NULL, NULL,
1586                                                   PERL_PV_PRETTY_DUMP
1587                                                   | PERL_PV_ESCAPE_NOCLEAR
1588                                                   | PERL_PV_ESCAPE_UNI_DETECT));
1589                     SvREFCNT_dec_NN(dsv);
1590                 }
1591                 else if (SvOK(sv)) {
1592                     useless_sv = Perl_newSVpvf(aTHX_ "a constant (%"SVf")", sv);
1593                 }
1594                 else
1595                     useless = "a constant (undef)";
1596             }
1597         }
1598         op_null(o);             /* don't execute or even remember it */
1599         break;
1600
1601     case OP_POSTINC:
1602         o->op_type = OP_PREINC;         /* pre-increment is faster */
1603         o->op_ppaddr = PL_ppaddr[OP_PREINC];
1604         break;
1605
1606     case OP_POSTDEC:
1607         o->op_type = OP_PREDEC;         /* pre-decrement is faster */
1608         o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1609         break;
1610
1611     case OP_I_POSTINC:
1612         o->op_type = OP_I_PREINC;       /* pre-increment is faster */
1613         o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1614         break;
1615
1616     case OP_I_POSTDEC:
1617         o->op_type = OP_I_PREDEC;       /* pre-decrement is faster */
1618         o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1619         break;
1620
1621     case OP_SASSIGN: {
1622         OP *rv2gv;
1623         UNOP *refgen, *rv2cv;
1624         LISTOP *exlist;
1625
1626         if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
1627             break;
1628
1629         rv2gv = ((BINOP *)o)->op_last;
1630         if (!rv2gv || rv2gv->op_type != OP_RV2GV)
1631             break;
1632
1633         refgen = (UNOP *)((BINOP *)o)->op_first;
1634
1635         if (!refgen || refgen->op_type != OP_REFGEN)
1636             break;
1637
1638         exlist = (LISTOP *)refgen->op_first;
1639         if (!exlist || exlist->op_type != OP_NULL
1640             || exlist->op_targ != OP_LIST)
1641             break;
1642
1643         if (exlist->op_first->op_type != OP_PUSHMARK)
1644             break;
1645
1646         rv2cv = (UNOP*)exlist->op_last;
1647
1648         if (rv2cv->op_type != OP_RV2CV)
1649             break;
1650
1651         assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
1652         assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
1653         assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
1654
1655         o->op_private |= OPpASSIGN_CV_TO_GV;
1656         rv2gv->op_private |= OPpDONT_INIT_GV;
1657         rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
1658
1659         break;
1660     }
1661
1662     case OP_AASSIGN: {
1663         inplace_aassign(o);
1664         break;
1665     }
1666
1667     case OP_OR:
1668     case OP_AND:
1669         kid = cLOGOPo->op_first;
1670         if (kid->op_type == OP_NOT
1671             && (kid->op_flags & OPf_KIDS)
1672             && !PL_madskills) {
1673             if (o->op_type == OP_AND) {
1674                 o->op_type = OP_OR;
1675                 o->op_ppaddr = PL_ppaddr[OP_OR];
1676             } else {
1677                 o->op_type = OP_AND;
1678                 o->op_ppaddr = PL_ppaddr[OP_AND];
1679             }
1680             op_null(kid);
1681         }
1682         /* FALLTHROUGH */
1683
1684     case OP_DOR:
1685     case OP_COND_EXPR:
1686     case OP_ENTERGIVEN:
1687     case OP_ENTERWHEN:
1688         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1689             scalarvoid(kid);
1690         break;
1691
1692     case OP_NULL:
1693         if (o->op_flags & OPf_STACKED)
1694             break;
1695         /* FALLTHROUGH */
1696     case OP_NEXTSTATE:
1697     case OP_DBSTATE:
1698     case OP_ENTERTRY:
1699     case OP_ENTER:
1700         if (!(o->op_flags & OPf_KIDS))
1701             break;
1702         /* FALLTHROUGH */
1703     case OP_SCOPE:
1704     case OP_LEAVE:
1705     case OP_LEAVETRY:
1706     case OP_LEAVELOOP:
1707     case OP_LINESEQ:
1708     case OP_LIST:
1709     case OP_LEAVEGIVEN:
1710     case OP_LEAVEWHEN:
1711         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1712             scalarvoid(kid);
1713         break;
1714     case OP_ENTEREVAL:
1715         scalarkids(o);
1716         break;
1717     case OP_SCALAR:
1718         return scalar(o);
1719     }
1720
1721     if (useless_sv) {
1722         /* mortalise it, in case warnings are fatal.  */
1723         Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
1724                        "Useless use of %"SVf" in void context",
1725                        sv_2mortal(useless_sv));
1726     }
1727     else if (useless) {
1728        Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
1729                       "Useless use of %s in void context",
1730                       useless);
1731     }
1732     return o;
1733 }
1734
1735 static OP *
1736 S_listkids(pTHX_ OP *o)
1737 {
1738     if (o && o->op_flags & OPf_KIDS) {
1739         OP *kid;
1740         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1741             list(kid);
1742     }
1743     return o;
1744 }
1745
1746 OP *
1747 Perl_list(pTHX_ OP *o)
1748 {
1749     dVAR;
1750     OP *kid;
1751
1752     /* assumes no premature commitment */
1753     if (!o || (o->op_flags & OPf_WANT)
1754          || (PL_parser && PL_parser->error_count)
1755          || o->op_type == OP_RETURN)
1756     {
1757         return o;
1758     }
1759
1760     if ((o->op_private & OPpTARGET_MY)
1761         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1762     {
1763         return o;                               /* As if inside SASSIGN */
1764     }
1765
1766     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1767
1768     switch (o->op_type) {
1769     case OP_FLOP:
1770     case OP_REPEAT:
1771         list(cBINOPo->op_first);
1772         break;
1773     case OP_OR:
1774     case OP_AND:
1775     case OP_COND_EXPR:
1776         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1777             list(kid);
1778         break;
1779     default:
1780     case OP_MATCH:
1781     case OP_QR:
1782     case OP_SUBST:
1783     case OP_NULL:
1784         if (!(o->op_flags & OPf_KIDS))
1785             break;
1786         if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1787             list(cBINOPo->op_first);
1788             return gen_constant_list(o);
1789         }
1790     case OP_LIST:
1791         listkids(o);
1792         break;
1793     case OP_LEAVE:
1794     case OP_LEAVETRY:
1795         kid = cLISTOPo->op_first;
1796         list(kid);
1797         kid = kid->op_sibling;
1798     do_kids:
1799         while (kid) {
1800             OP *sib = kid->op_sibling;
1801             if (sib && kid->op_type != OP_LEAVEWHEN)
1802                 scalarvoid(kid);
1803             else
1804                 list(kid);
1805             kid = sib;
1806         }
1807         PL_curcop = &PL_compiling;
1808         break;
1809     case OP_SCOPE:
1810     case OP_LINESEQ:
1811         kid = cLISTOPo->op_first;
1812         goto do_kids;
1813     }
1814     return o;
1815 }
1816
1817 static OP *
1818 S_scalarseq(pTHX_ OP *o)
1819 {
1820     dVAR;
1821     if (o) {
1822         const OPCODE type = o->op_type;
1823
1824         if (type == OP_LINESEQ || type == OP_SCOPE ||
1825             type == OP_LEAVE || type == OP_LEAVETRY)
1826         {
1827             OP *kid;
1828             for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1829                 if (kid->op_sibling) {
1830                     scalarvoid(kid);
1831                 }
1832             }
1833             PL_curcop = &PL_compiling;
1834         }
1835         o->op_flags &= ~OPf_PARENS;
1836         if (PL_hints & HINT_BLOCK_SCOPE)
1837             o->op_flags |= OPf_PARENS;
1838     }
1839     else
1840         o = newOP(OP_STUB, 0);
1841     return o;
1842 }
1843
1844 STATIC OP *
1845 S_modkids(pTHX_ OP *o, I32 type)
1846 {
1847     if (o && o->op_flags & OPf_KIDS) {
1848         OP *kid;
1849         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1850             op_lvalue(kid, type);
1851     }
1852     return o;
1853 }
1854
1855 /*
1856 =for apidoc finalize_optree
1857
1858 This function finalizes the optree.  Should be called directly after
1859 the complete optree is built.  It does some additional
1860 checking which can't be done in the normal ck_xxx functions and makes
1861 the tree thread-safe.
1862
1863 =cut
1864 */
1865 void
1866 Perl_finalize_optree(pTHX_ OP* o)
1867 {
1868     PERL_ARGS_ASSERT_FINALIZE_OPTREE;
1869
1870     ENTER;
1871     SAVEVPTR(PL_curcop);
1872
1873     finalize_op(o);
1874
1875     LEAVE;
1876 }
1877
1878 STATIC void
1879 S_finalize_op(pTHX_ OP* o)
1880 {
1881     PERL_ARGS_ASSERT_FINALIZE_OP;
1882
1883 #if defined(PERL_MAD) && defined(USE_ITHREADS)
1884     {
1885         /* Make sure mad ops are also thread-safe */
1886         MADPROP *mp = o->op_madprop;
1887         while (mp) {
1888             if (mp->mad_type == MAD_OP && mp->mad_vlen) {
1889                 OP *prop_op = (OP *) mp->mad_val;
1890                 /* We only need "Relocate sv to the pad for thread safety.", but this
1891                    easiest way to make sure it traverses everything */
1892                 if (prop_op->op_type == OP_CONST)
1893                     cSVOPx(prop_op)->op_private &= ~OPpCONST_STRICT;
1894                 finalize_op(prop_op);
1895             }
1896             mp = mp->mad_next;
1897         }
1898     }
1899 #endif
1900
1901     switch (o->op_type) {
1902     case OP_NEXTSTATE:
1903     case OP_DBSTATE:
1904         PL_curcop = ((COP*)o);          /* for warnings */
1905         break;
1906     case OP_EXEC:
1907         if ( o->op_sibling
1908             && (o->op_sibling->op_type == OP_NEXTSTATE || o->op_sibling->op_type == OP_DBSTATE)
1909             && ckWARN(WARN_EXEC))
1910             {
1911                 if (o->op_sibling->op_sibling) {
1912                     const OPCODE type = o->op_sibling->op_sibling->op_type;
1913                     if (type != OP_EXIT && type != OP_WARN && type != OP_DIE) {
1914                         const line_t oldline = CopLINE(PL_curcop);
1915                         CopLINE_set(PL_curcop, CopLINE((COP*)o->op_sibling));
1916                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
1917                             "Statement unlikely to be reached");
1918                         Perl_warner(aTHX_ packWARN(WARN_EXEC),
1919                             "\t(Maybe you meant system() when you said exec()?)\n");
1920                         CopLINE_set(PL_curcop, oldline);
1921                     }
1922                 }
1923             }
1924         break;
1925
1926     case OP_GV:
1927         if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
1928             GV * const gv = cGVOPo_gv;
1929             if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX_const(GvCV(gv))) {
1930                 /* XXX could check prototype here instead of just carping */
1931                 SV * const sv = sv_newmortal();
1932                 gv_efullname3(sv, gv, NULL);
1933                 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
1934                     "%"SVf"() called too early to check prototype",
1935                     SVfARG(sv));
1936             }
1937         }
1938         break;
1939
1940     case OP_CONST:
1941         if (cSVOPo->op_private & OPpCONST_STRICT)
1942             no_bareword_allowed(o);
1943         /* FALLTHROUGH */
1944 #ifdef USE_ITHREADS
1945     case OP_HINTSEVAL:
1946     case OP_METHOD_NAMED:
1947         /* Relocate sv to the pad for thread safety.
1948          * Despite being a "constant", the SV is written to,
1949          * for reference counts, sv_upgrade() etc. */
1950         if (cSVOPo->op_sv) {
1951             const PADOFFSET ix = pad_alloc(OP_CONST, SVf_READONLY);
1952             SvREFCNT_dec(PAD_SVl(ix));
1953             PAD_SETSV(ix, cSVOPo->op_sv);
1954             /* XXX I don't know how this isn't readonly already. */
1955             if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
1956             cSVOPo->op_sv = NULL;
1957             o->op_targ = ix;
1958         }
1959 #endif
1960         break;
1961
1962     case OP_HELEM: {
1963         UNOP *rop;
1964         SV *lexname;
1965         GV **fields;
1966         SVOP *key_op;
1967         OP *kid;
1968         bool check_fields;
1969
1970         if ((key_op = cSVOPx(((BINOP*)o)->op_last))->op_type != OP_CONST)
1971             break;
1972
1973         rop = (UNOP*)((BINOP*)o)->op_first;
1974
1975         goto check_keys;
1976
1977     case OP_HSLICE:
1978         S_scalar_slice_warning(aTHX_ o);
1979         /* FALLTHROUGH */
1980
1981     case OP_KVHSLICE:
1982         kid = cLISTOPo->op_first->op_sibling;
1983         if (/* I bet there's always a pushmark... */
1984             OP_TYPE_ISNT_AND_WASNT_NN(kid, OP_LIST)
1985             && OP_TYPE_ISNT_NN(kid, OP_CONST))
1986         {
1987             break;
1988         }
1989
1990         key_op = (SVOP*)(kid->op_type == OP_CONST
1991                                 ? kid
1992                                 : kLISTOP->op_first->op_sibling);
1993
1994         rop = (UNOP*)((LISTOP*)o)->op_last;
1995
1996       check_keys:       
1997         if (o->op_private & OPpLVAL_INTRO || rop->op_type != OP_RV2HV)
1998             rop = NULL;
1999         else if (rop->op_first->op_type == OP_PADSV)
2000             /* @$hash{qw(keys here)} */
2001             rop = (UNOP*)rop->op_first;
2002         else {
2003             /* @{$hash}{qw(keys here)} */
2004             if (rop->op_first->op_type == OP_SCOPE
2005                 && cLISTOPx(rop->op_first)->op_last->op_type == OP_PADSV)
2006                 {
2007                     rop = (UNOP*)cLISTOPx(rop->op_first)->op_last;
2008                 }
2009             else
2010                 rop = NULL;
2011         }
2012
2013         lexname = NULL; /* just to silence compiler warnings */
2014         fields  = NULL; /* just to silence compiler warnings */
2015
2016         check_fields =
2017             rop
2018          && (lexname = *av_fetch(PL_comppad_name, rop->op_targ, TRUE),
2019              SvPAD_TYPED(lexname))
2020          && (fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE))
2021          && isGV(*fields) && GvHV(*fields);
2022         for (; key_op;
2023              key_op = (SVOP*)key_op->op_sibling) {
2024             SV **svp, *sv;
2025             if (key_op->op_type != OP_CONST)
2026                 continue;
2027             svp = cSVOPx_svp(key_op);
2028
2029             /* Make the CONST have a shared SV */
2030             if ((!SvIsCOW_shared_hash(sv = *svp))
2031              && SvTYPE(sv) < SVt_PVMG && SvOK(sv) && !SvROK(sv)) {
2032                 SSize_t keylen;
2033                 const char * const key = SvPV_const(sv, *(STRLEN*)&keylen);
2034                 SV *nsv = newSVpvn_share(key,
2035                                          SvUTF8(sv) ? -keylen : keylen, 0);
2036                 SvREFCNT_dec_NN(sv);
2037                 *svp = nsv;
2038             }
2039
2040             if (check_fields
2041              && !hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0)) {
2042                 Perl_croak(aTHX_ "No such class field \"%"SVf"\" " 
2043                            "in variable %"SVf" of type %"HEKf, 
2044                       SVfARG(*svp), SVfARG(lexname),
2045                       HEKfARG(HvNAME_HEK(SvSTASH(lexname))));
2046             }
2047         }
2048         break;
2049     }
2050     case OP_ASLICE:
2051         S_scalar_slice_warning(aTHX_ o);
2052         break;
2053
2054     case OP_SUBST: {
2055         if (cPMOPo->op_pmreplrootu.op_pmreplroot)
2056             finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
2057         break;
2058     }
2059     default:
2060         break;
2061     }
2062
2063     if (o->op_flags & OPf_KIDS) {
2064         OP *kid;
2065         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
2066             finalize_op(kid);
2067     }
2068 }
2069
2070 /*
2071 =for apidoc Amx|OP *|op_lvalue|OP *o|I32 type
2072
2073 Propagate lvalue ("modifiable") context to an op and its children.
2074 I<type> represents the context type, roughly based on the type of op that
2075 would do the modifying, although C<local()> is represented by OP_NULL,
2076 because it has no op type of its own (it is signalled by a flag on
2077 the lvalue op).
2078
2079 This function detects things that can't be modified, such as C<$x+1>, and
2080 generates errors for them.  For example, C<$x+1 = 2> would cause it to be
2081 called with an op of type OP_ADD and a C<type> argument of OP_SASSIGN.
2082
2083 It also flags things that need to behave specially in an lvalue context,
2084 such as C<$$x = 5> which might have to vivify a reference in C<$x>.
2085
2086 =cut
2087 */
2088
2089 static bool
2090 S_vivifies(const OPCODE type)
2091 {
2092     switch(type) {
2093     case OP_RV2AV:     case   OP_ASLICE:
2094     case OP_RV2HV:     case OP_KVASLICE:
2095     case OP_RV2SV:     case   OP_HSLICE:
2096     case OP_AELEMFAST: case OP_KVHSLICE:
2097     case OP_HELEM:
2098     case OP_AELEM:
2099         return 1;
2100     }
2101     return 0;
2102 }
2103
2104 OP *
2105 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
2106 {
2107     dVAR;
2108     OP *kid;
2109     /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
2110     int localize = -1;
2111
2112     if (!o || (PL_parser && PL_parser->error_count))
2113         return o;
2114
2115     if ((o->op_private & OPpTARGET_MY)
2116         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
2117     {
2118         return o;
2119     }
2120
2121     assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
2122
2123     if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
2124
2125     switch (o->op_type) {
2126     case OP_UNDEF:
2127         PL_modcount++;
2128         return o;
2129     case OP_STUB:
2130         if ((o->op_flags & OPf_PARENS) || PL_madskills)
2131             break;
2132         goto nomod;
2133     case OP_ENTERSUB:
2134         if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
2135             !(o->op_flags & OPf_STACKED)) {
2136             o->op_type = OP_RV2CV;              /* entersub => rv2cv */
2137             /* Both ENTERSUB and RV2CV use this bit, but for different pur-
2138                poses, so we need it clear.  */
2139             o->op_private &= ~1;
2140             o->op_ppaddr = PL_ppaddr[OP_RV2CV];
2141             assert(cUNOPo->op_first->op_type == OP_NULL);
2142             op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
2143             break;
2144         }
2145         else {                          /* lvalue subroutine call */
2146             o->op_private |= OPpLVAL_INTRO
2147                            |(OPpENTERSUB_INARGS * (type == OP_LEAVESUBLV));
2148             PL_modcount = RETURN_UNLIMITED_NUMBER;
2149             if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
2150                 /* Potential lvalue context: */
2151                 o->op_private |= OPpENTERSUB_INARGS;
2152                 break;
2153             }
2154             else {                      /* Compile-time error message: */
2155                 OP *kid = cUNOPo->op_first;
2156                 CV *cv;
2157
2158                 if (kid->op_type != OP_PUSHMARK) {
2159                     if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
2160                         Perl_croak(aTHX_
2161                                 "panic: unexpected lvalue entersub "
2162                                 "args: type/targ %ld:%"UVuf,
2163                                 (long)kid->op_type, (UV)kid->op_targ);
2164                     kid = kLISTOP->op_first;
2165                 }
2166                 while (kid->op_sibling)
2167                     kid = kid->op_sibling;
2168                 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
2169                     break;      /* Postpone until runtime */
2170                 }
2171
2172                 kid = kUNOP->op_first;
2173                 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
2174                     kid = kUNOP->op_first;
2175                 if (kid->op_type == OP_NULL)
2176                     Perl_croak(aTHX_
2177                                "Unexpected constant lvalue entersub "
2178                                "entry via type/targ %ld:%"UVuf,
2179                                (long)kid->op_type, (UV)kid->op_targ);
2180                 if (kid->op_type != OP_GV) {
2181                     break;
2182                 }
2183
2184                 cv = GvCV(kGVOP_gv);
2185                 if (!cv)
2186                     break;
2187                 if (CvLVALUE(cv))
2188                     break;
2189             }
2190         }
2191         /* FALLTHROUGH */
2192     default:
2193       nomod:
2194         if (flags & OP_LVALUE_NO_CROAK) return NULL;
2195         /* grep, foreach, subcalls, refgen */
2196         if (type == OP_GREPSTART || type == OP_ENTERSUB
2197          || type == OP_REFGEN    || type == OP_LEAVESUBLV)
2198             break;
2199         yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
2200                      (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
2201                       ? "do block"
2202                       : (o->op_type == OP_ENTERSUB
2203                         ? "non-lvalue subroutine call"
2204                         : OP_DESC(o))),
2205                      type ? PL_op_desc[type] : "local"));
2206         return o;
2207
2208     case OP_PREINC:
2209     case OP_PREDEC:
2210     case OP_POW:
2211     case OP_MULTIPLY:
2212     case OP_DIVIDE:
2213     case OP_MODULO:
2214     case OP_REPEAT:
2215     case OP_ADD:
2216     case OP_SUBTRACT:
2217     case OP_CONCAT:
2218     case OP_LEFT_SHIFT:
2219     case OP_RIGHT_SHIFT:
2220     case OP_BIT_AND:
2221     case OP_BIT_XOR:
2222     case OP_BIT_OR:
2223     case OP_I_MULTIPLY:
2224     case OP_I_DIVIDE:
2225     case OP_I_MODULO:
2226     case OP_I_ADD:
2227     case OP_I_SUBTRACT:
2228         if (!(o->op_flags & OPf_STACKED))
2229             goto nomod;
2230         PL_modcount++;
2231         break;
2232
2233     case OP_COND_EXPR:
2234         localize = 1;
2235         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
2236             op_lvalue(kid, type);
2237         break;
2238
2239     case OP_RV2AV:
2240     case OP_RV2HV:
2241         if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
2242            PL_modcount = RETURN_UNLIMITED_NUMBER;
2243             return o;           /* Treat \(@foo) like ordinary list. */
2244         }
2245         /* FALLTHROUGH */
2246     case OP_RV2GV:
2247         if (scalar_mod_type(o, type))
2248             goto nomod;
2249         ref(cUNOPo->op_first, o->op_type);
2250         /* FALLTHROUGH */
2251     case OP_ASLICE:
2252     case OP_HSLICE:
2253         localize = 1;
2254         /* FALLTHROUGH */
2255     case OP_AASSIGN:
2256         /* Do not apply the lvsub flag for rv2[ah]v in scalar context.  */
2257         if (type == OP_LEAVESUBLV && (
2258                 (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
2259              || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
2260            ))
2261             o->op_private |= OPpMAYBE_LVSUB;
2262         /* FALLTHROUGH */
2263     case OP_NEXTSTATE:
2264     case OP_DBSTATE:
2265        PL_modcount = RETURN_UNLIMITED_NUMBER;
2266         break;
2267     case OP_KVHSLICE:
2268     case OP_KVASLICE:
2269         if (type == OP_LEAVESUBLV)
2270             o->op_private |= OPpMAYBE_LVSUB;
2271         goto nomod;
2272     case OP_AV2ARYLEN:
2273         PL_hints |= HINT_BLOCK_SCOPE;
2274         if (type == OP_LEAVESUBLV)
2275             o->op_private |= OPpMAYBE_LVSUB;
2276         PL_modcount++;
2277         break;
2278     case OP_RV2SV:
2279         ref(cUNOPo->op_first, o->op_type);
2280         localize = 1;
2281         /* FALLTHROUGH */
2282     case OP_GV:
2283         PL_hints |= HINT_BLOCK_SCOPE;
2284         /* FALLTHROUGH */
2285     case OP_SASSIGN:
2286     case OP_ANDASSIGN:
2287     case OP_ORASSIGN:
2288     case OP_DORASSIGN:
2289         PL_modcount++;
2290         break;
2291
2292     case OP_AELEMFAST:
2293     case OP_AELEMFAST_LEX:
2294         localize = -1;
2295         PL_modcount++;
2296         break;
2297
2298     case OP_PADAV:
2299     case OP_PADHV:
2300        PL_modcount = RETURN_UNLIMITED_NUMBER;
2301         if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
2302             return o;           /* Treat \(@foo) like ordinary list. */
2303         if (scalar_mod_type(o, type))
2304             goto nomod;
2305         if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
2306           && type == OP_LEAVESUBLV)
2307             o->op_private |= OPpMAYBE_LVSUB;
2308         /* FALLTHROUGH */
2309     case OP_PADSV:
2310         PL_modcount++;
2311         if (!type) /* local() */
2312             Perl_croak(aTHX_ "Can't localize lexical variable %"SVf,
2313                  PAD_COMPNAME_SV(o->op_targ));
2314         break;
2315
2316     case OP_PUSHMARK:
2317         localize = 0;
2318         break;
2319
2320     case OP_KEYS:
2321     case OP_RKEYS:
2322         if (type != OP_SASSIGN && type != OP_LEAVESUBLV)
2323             goto nomod;
2324         goto lvalue_func;
2325     case OP_SUBSTR:
2326         if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
2327             goto nomod;
2328         /* FALLTHROUGH */
2329     case OP_POS:
2330     case OP_VEC:
2331       lvalue_func:
2332         if (type == OP_LEAVESUBLV)
2333             o->op_private |= OPpMAYBE_LVSUB;
2334         if (o->op_flags & OPf_KIDS)
2335             op_lvalue(cBINOPo->op_first->op_sibling, type);
2336         break;
2337
2338     case OP_AELEM:
2339     case OP_HELEM:
2340         ref(cBINOPo->op_first, o->op_type);
2341         if (type == OP_ENTERSUB &&
2342              !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
2343             o->op_private |= OPpLVAL_DEFER;
2344         if (type == OP_LEAVESUBLV)
2345             o->op_private |= OPpMAYBE_LVSUB;
2346         localize = 1;
2347         PL_modcount++;
2348         break;
2349
2350     case OP_LEAVE:
2351     case OP_LEAVELOOP:
2352         o->op_private |= OPpLVALUE;
2353         /* FALLTHROUGH */
2354     case OP_SCOPE:
2355     case OP_ENTER:
2356     case OP_LINESEQ:
2357         localize = 0;
2358         if (o->op_flags & OPf_KIDS)
2359             op_lvalue(cLISTOPo->op_last, type);
2360         break;
2361
2362     case OP_NULL:
2363         localize = 0;
2364         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
2365             goto nomod;
2366         else if (!(o->op_flags & OPf_KIDS))
2367             break;
2368         if (o->op_targ != OP_LIST) {
2369             op_lvalue(cBINOPo->op_first, type);
2370             break;
2371         }
2372         /* FALLTHROUGH */
2373     case OP_LIST:
2374         localize = 0;
2375         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2376             /* elements might be in void context because the list is
2377                in scalar context or because they are attribute sub calls */
2378             if ( (kid->op_flags & OPf_WANT) != OPf_WANT_VOID )
2379                 op_lvalue(kid, type);
2380         break;
2381
2382     case OP_RETURN:
2383         if (type != OP_LEAVESUBLV)
2384             goto nomod;
2385         break; /* op_lvalue()ing was handled by ck_return() */
2386
2387     case OP_COREARGS:
2388         return o;
2389
2390     case OP_AND:
2391     case OP_OR:
2392         if (type == OP_LEAVESUBLV
2393          || !S_vivifies(cLOGOPo->op_first->op_type))
2394             op_lvalue(cLOGOPo->op_first, type);
2395         if (type == OP_LEAVESUBLV
2396          || !S_vivifies(cLOGOPo->op_first->op_sibling->op_type))
2397             op_lvalue(cLOGOPo->op_first->op_sibling, type);
2398         goto nomod;
2399     }
2400
2401     /* [20011101.069] File test operators interpret OPf_REF to mean that
2402        their argument is a filehandle; thus \stat(".") should not set
2403        it. AMS 20011102 */
2404     if (type == OP_REFGEN &&
2405         PL_check[o->op_type] == Perl_ck_ftst)
2406         return o;
2407
2408     if (type != OP_LEAVESUBLV)
2409         o->op_flags |= OPf_MOD;
2410
2411     if (type == OP_AASSIGN || type == OP_SASSIGN)
2412         o->op_flags |= OPf_SPECIAL|OPf_REF;
2413     else if (!type) { /* local() */
2414         switch (localize) {
2415         case 1:
2416             o->op_private |= OPpLVAL_INTRO;
2417             o->op_flags &= ~OPf_SPECIAL;
2418             PL_hints |= HINT_BLOCK_SCOPE;
2419             break;
2420         case 0:
2421             break;
2422         case -1:
2423             Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
2424                            "Useless localization of %s", OP_DESC(o));
2425         }
2426     }
2427     else if (type != OP_GREPSTART && type != OP_ENTERSUB
2428              && type != OP_LEAVESUBLV)
2429         o->op_flags |= OPf_REF;
2430     return o;
2431 }
2432
2433 STATIC bool
2434 S_scalar_mod_type(const OP *o, I32 type)
2435 {
2436     switch (type) {
2437     case OP_POS:
2438     case OP_SASSIGN:
2439         if (o && o->op_type == OP_RV2GV)
2440             return FALSE;
2441         /* FALLTHROUGH */
2442     case OP_PREINC:
2443     case OP_PREDEC:
2444     case OP_POSTINC:
2445     case OP_POSTDEC:
2446     case OP_I_PREINC:
2447     case OP_I_PREDEC:
2448     case OP_I_POSTINC:
2449     case OP_I_POSTDEC:
2450     case OP_POW:
2451     case OP_MULTIPLY:
2452     case OP_DIVIDE:
2453     case OP_MODULO:
2454     case OP_REPEAT:
2455     case OP_ADD:
2456     case OP_SUBTRACT:
2457     case OP_I_MULTIPLY:
2458     case OP_I_DIVIDE:
2459     case OP_I_MODULO:
2460     case OP_I_ADD:
2461     case OP_I_SUBTRACT:
2462     case OP_LEFT_SHIFT:
2463     case OP_RIGHT_SHIFT:
2464     case OP_BIT_AND:
2465     case OP_BIT_XOR:
2466     case OP_BIT_OR:
2467     case OP_CONCAT:
2468     case OP_SUBST:
2469     case OP_TRANS:
2470     case OP_TRANSR:
2471     case OP_READ:
2472     case OP_SYSREAD:
2473     case OP_RECV:
2474     case OP_ANDASSIGN:
2475     case OP_ORASSIGN:
2476     case OP_DORASSIGN:
2477         return TRUE;
2478     default:
2479         return FALSE;
2480     }
2481 }
2482
2483 STATIC bool
2484 S_is_handle_constructor(const OP *o, I32 numargs)
2485 {
2486     PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
2487
2488     switch (o->op_type) {
2489     case OP_PIPE_OP:
2490     case OP_SOCKPAIR:
2491         if (numargs == 2)
2492             return TRUE;
2493         /* FALLTHROUGH */
2494     case OP_SYSOPEN:
2495     case OP_OPEN:
2496     case OP_SELECT:             /* XXX c.f. SelectSaver.pm */
2497     case OP_SOCKET:
2498     case OP_OPEN_DIR:
2499     case OP_ACCEPT:
2500         if (numargs == 1)
2501             return TRUE;
2502         /* FALLTHROUGH */
2503     default:
2504         return FALSE;
2505     }
2506 }
2507
2508 static OP *
2509 S_refkids(pTHX_ OP *o, I32 type)
2510 {
2511     if (o && o->op_flags & OPf_KIDS) {
2512         OP *kid;
2513         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2514             ref(kid, type);
2515     }
2516     return o;
2517 }
2518
2519 OP *
2520 Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
2521 {
2522     dVAR;
2523     OP *kid;
2524
2525     PERL_ARGS_ASSERT_DOREF;
2526
2527     if (!o || (PL_parser && PL_parser->error_count))
2528         return o;
2529
2530     switch (o->op_type) {
2531     case OP_ENTERSUB:
2532         if ((type == OP_EXISTS || type == OP_DEFINED) &&
2533             !(o->op_flags & OPf_STACKED)) {
2534             o->op_type = OP_RV2CV;             /* entersub => rv2cv */
2535             o->op_ppaddr = PL_ppaddr[OP_RV2CV];
2536             assert(cUNOPo->op_first->op_type == OP_NULL);
2537             op_null(((LISTOP*)cUNOPo->op_first)->op_first);     /* disable pushmark */
2538             o->op_flags |= OPf_SPECIAL;
2539             o->op_private &= ~1;
2540         }
2541         else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
2542             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2543                               : type == OP_RV2HV ? OPpDEREF_HV
2544                               : OPpDEREF_SV);
2545             o->op_flags |= OPf_MOD;
2546         }
2547
2548         break;
2549
2550     case OP_COND_EXPR:
2551         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
2552             doref(kid, type, set_op_ref);
2553         break;
2554     case OP_RV2SV:
2555         if (type == OP_DEFINED)
2556             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
2557         doref(cUNOPo->op_first, o->op_type, set_op_ref);
2558         /* FALLTHROUGH */
2559     case OP_PADSV:
2560         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
2561             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2562                               : type == OP_RV2HV ? OPpDEREF_HV
2563                               : OPpDEREF_SV);
2564             o->op_flags |= OPf_MOD;
2565         }
2566         break;
2567
2568     case OP_RV2AV:
2569     case OP_RV2HV:
2570         if (set_op_ref)
2571             o->op_flags |= OPf_REF;
2572         /* FALLTHROUGH */
2573     case OP_RV2GV:
2574         if (type == OP_DEFINED)
2575             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
2576         doref(cUNOPo->op_first, o->op_type, set_op_ref);
2577         break;
2578
2579     case OP_PADAV:
2580     case OP_PADHV:
2581         if (set_op_ref)
2582             o->op_flags |= OPf_REF;
2583         break;
2584
2585     case OP_SCALAR:
2586     case OP_NULL:
2587         if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
2588             break;
2589         doref(cBINOPo->op_first, type, set_op_ref);
2590         break;
2591     case OP_AELEM:
2592     case OP_HELEM:
2593         doref(cBINOPo->op_first, o->op_type, set_op_ref);
2594         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
2595             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
2596                               : type == OP_RV2HV ? OPpDEREF_HV
2597                               : OPpDEREF_SV);
2598             o->op_flags |= OPf_MOD;
2599         }
2600         break;
2601
2602     case OP_SCOPE:
2603     case OP_LEAVE:
2604         set_op_ref = FALSE;
2605         /* FALLTHROUGH */
2606     case OP_ENTER:
2607     case OP_LIST:
2608         if (!(o->op_flags & OPf_KIDS))
2609             break;
2610         doref(cLISTOPo->op_last, type, set_op_ref);
2611         break;
2612     default:
2613         break;
2614     }
2615     return scalar(o);
2616
2617 }
2618
2619 STATIC OP *
2620 S_dup_attrlist(pTHX_ OP *o)
2621 {
2622     dVAR;
2623     OP *rop;
2624
2625     PERL_ARGS_ASSERT_DUP_ATTRLIST;
2626
2627     /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
2628      * where the first kid is OP_PUSHMARK and the remaining ones
2629      * are OP_CONST.  We need to push the OP_CONST values.
2630      */
2631     if (o->op_type == OP_CONST)
2632         rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
2633 #ifdef PERL_MAD
2634     else if (o->op_type == OP_NULL)
2635         rop = NULL;
2636 #endif
2637     else {
2638         assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
2639         rop = NULL;
2640         for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
2641             if (o->op_type == OP_CONST)
2642                 rop = op_append_elem(OP_LIST, rop,
2643                                   newSVOP(OP_CONST, o->op_flags,
2644                                           SvREFCNT_inc_NN(cSVOPo->op_sv)));
2645         }
2646     }
2647     return rop;
2648 }
2649
2650 STATIC void
2651 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
2652 {
2653     dVAR;
2654     SV * const stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2655
2656     PERL_ARGS_ASSERT_APPLY_ATTRS;
2657
2658     /* fake up C<use attributes $pkg,$rv,@attrs> */
2659
2660 #define ATTRSMODULE "attributes"
2661 #define ATTRSMODULE_PM "attributes.pm"
2662
2663     Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2664                          newSVpvs(ATTRSMODULE),
2665                          NULL,
2666                          op_prepend_elem(OP_LIST,
2667                                       newSVOP(OP_CONST, 0, stashsv),
2668                                       op_prepend_elem(OP_LIST,
2669                                                    newSVOP(OP_CONST, 0,
2670                                                            newRV(target)),
2671                                                    dup_attrlist(attrs))));
2672 }
2673
2674 STATIC void
2675 S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
2676 {
2677     dVAR;
2678     OP *pack, *imop, *arg;
2679     SV *meth, *stashsv, **svp;
2680
2681     PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
2682
2683     if (!attrs)
2684         return;
2685
2686     assert(target->op_type == OP_PADSV ||
2687            target->op_type == OP_PADHV ||
2688            target->op_type == OP_PADAV);
2689
2690     /* Ensure that attributes.pm is loaded. */
2691     /* Don't force the C<use> if we don't need it. */
2692     svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
2693     if (svp && *svp != &PL_sv_undef)
2694         NOOP;   /* already in %INC */
2695     else
2696         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
2697                                newSVpvs(ATTRSMODULE), NULL);
2698
2699     /* Need package name for method call. */
2700     pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
2701
2702     /* Build up the real arg-list. */
2703     stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
2704
2705     arg = newOP(OP_PADSV, 0);
2706     arg->op_targ = target->op_targ;
2707     arg = op_prepend_elem(OP_LIST,
2708                        newSVOP(OP_CONST, 0, stashsv),
2709                        op_prepend_elem(OP_LIST,
2710                                     newUNOP(OP_REFGEN, 0,
2711                                             op_lvalue(arg, OP_REFGEN)),
2712                                     dup_attrlist(attrs)));
2713
2714     /* Fake up a method call to import */
2715     meth = newSVpvs_share("import");
2716     imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
2717                    op_append_elem(OP_LIST,
2718                                op_prepend_elem(OP_LIST, pack, list(arg)),
2719                                newSVOP(OP_METHOD_NAMED, 0, meth)));
2720
2721     /* Combine the ops. */
2722     *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
2723 }
2724
2725 /*
2726 =notfor apidoc apply_attrs_string
2727
2728 Attempts to apply a list of attributes specified by the C<attrstr> and
2729 C<len> arguments to the subroutine identified by the C<cv> argument which
2730 is expected to be associated with the package identified by the C<stashpv>
2731 argument (see L<attributes>).  It gets this wrong, though, in that it
2732 does not correctly identify the boundaries of the individual attribute
2733 specifications within C<attrstr>.  This is not really intended for the
2734 public API, but has to be listed here for systems such as AIX which
2735 need an explicit export list for symbols.  (It's called from XS code
2736 in support of the C<ATTRS:> keyword from F<xsubpp>.)  Patches to fix it
2737 to respect attribute syntax properly would be welcome.
2738
2739 =cut
2740 */
2741
2742 void
2743 Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
2744                         const char *attrstr, STRLEN len)
2745 {
2746     OP *attrs = NULL;
2747
2748     PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
2749
2750     if (!len) {
2751         len = strlen(attrstr);
2752     }
2753
2754     while (len) {
2755         for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
2756         if (len) {
2757             const char * const sstr = attrstr;
2758             for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
2759             attrs = op_append_elem(OP_LIST, attrs,
2760                                 newSVOP(OP_CONST, 0,
2761                                         newSVpvn(sstr, attrstr-sstr)));
2762         }
2763     }
2764
2765     Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
2766                      newSVpvs(ATTRSMODULE),
2767                      NULL, op_prepend_elem(OP_LIST,
2768                                   newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
2769                                   op_prepend_elem(OP_LIST,
2770                                                newSVOP(OP_CONST, 0,
2771                                                        newRV(MUTABLE_SV(cv))),
2772                                                attrs)));
2773 }
2774
2775 STATIC void
2776 S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name)
2777 {
2778     OP *new_proto = NULL;
2779     STRLEN pvlen;
2780     char *pv;
2781     OP *o;
2782
2783     PERL_ARGS_ASSERT_MOVE_PROTO_ATTR;
2784
2785     if (!*attrs)
2786         return;
2787
2788     o = *attrs;
2789     if (o->op_type == OP_CONST) {
2790         pv = SvPV(cSVOPo_sv, pvlen);
2791         if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
2792             SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
2793             SV ** const tmpo = cSVOPx_svp(o);
2794             SvREFCNT_dec(cSVOPo_sv);
2795             *tmpo = tmpsv;
2796             new_proto = o;
2797             *attrs = NULL;
2798         }
2799     } else if (o->op_type == OP_LIST) {
2800         OP * lasto = NULL;
2801         assert(o->op_flags & OPf_KIDS);
2802         assert(cLISTOPo->op_first->op_type == OP_PUSHMARK);
2803         /* Counting on the first op to hit the lasto = o line */
2804         for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
2805             if (o->op_type == OP_CONST) {
2806                 pv = SvPV(cSVOPo_sv, pvlen);
2807                 if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
2808                     SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
2809                     SV ** const tmpo = cSVOPx_svp(o);
2810                     SvREFCNT_dec(cSVOPo_sv);
2811                     *tmpo = tmpsv;
2812                     if (new_proto && ckWARN(WARN_MISC)) {
2813                         STRLEN new_len;
2814                         const char * newp = SvPV(cSVOPo_sv, new_len);
2815                         Perl_warner(aTHX_ packWARN(WARN_MISC),
2816                             "Attribute prototype(%"UTF8f") discards earlier prototype attribute in same sub",
2817                             UTF8fARG(SvUTF8(cSVOPo_sv), new_len, newp));
2818                         op_free(new_proto);
2819                     }
2820                     else if (new_proto)
2821                         op_free(new_proto);
2822                     new_proto = o;
2823                     lasto->op_sibling = o->op_sibling;
2824                     continue;
2825                 }
2826             }
2827             lasto = o;
2828         }
2829         /* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs
2830            would get pulled in with no real need */
2831         if (!cLISTOPx(*attrs)->op_first->op_sibling) {
2832             op_free(*attrs);
2833             *attrs = NULL;
2834         }
2835     }
2836
2837     if (new_proto) {
2838         SV *svname;
2839         if (isGV(name)) {
2840             svname = sv_newmortal();
2841             gv_efullname3(svname, name, NULL);
2842         }
2843         else if (SvPOK(name) && *SvPVX((SV *)name) == '&')
2844             svname = newSVpvn_flags(SvPVX((SV *)name)+1, SvCUR(name)-1, SvUTF8(name)|SVs_TEMP);
2845         else
2846             svname = (SV *)name;
2847         if (ckWARN(WARN_ILLEGALPROTO))
2848             (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE);
2849         if (*proto && ckWARN(WARN_PROTOTYPE)) {
2850             STRLEN old_len, new_len;
2851             const char * oldp = SvPV(cSVOPx_sv(*proto), old_len);
2852             const char * newp = SvPV(cSVOPx_sv(new_proto), new_len);
2853
2854             Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
2855                 "Prototype '%"UTF8f"' overridden by attribute 'prototype(%"UTF8f")'"
2856                 " in %"SVf,
2857                 UTF8fARG(SvUTF8(cSVOPx_sv(*proto)), old_len, oldp),
2858                 UTF8fARG(SvUTF8(cSVOPx_sv(new_proto)), new_len, newp),
2859                 SVfARG(svname));
2860         }
2861         if (*proto)
2862             op_free(*proto);
2863         *proto = new_proto;
2864     }
2865 }
2866
2867 static void
2868 S_cant_declare(pTHX_ OP *o)
2869 {
2870     if (o->op_type == OP_NULL
2871      && (o->op_flags & (OPf_SPECIAL|OPf_KIDS)) == OPf_KIDS)
2872         o = cUNOPo->op_first;
2873     yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2874                              o->op_type == OP_NULL
2875                                && o->op_flags & OPf_SPECIAL
2876                                  ? "do block"
2877                                  : OP_DESC(o),
2878                              PL_parser->in_my == KEY_our   ? "our"   :
2879                              PL_parser->in_my == KEY_state ? "state" :
2880                                                              "my"));
2881 }
2882
2883 STATIC OP *
2884 S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
2885 {
2886     dVAR;
2887     I32 type;
2888     const bool stately = PL_parser && PL_parser->in_my == KEY_state;
2889
2890     PERL_ARGS_ASSERT_MY_KID;
2891
2892     if (!o || (PL_parser && PL_parser->error_count))
2893         return o;
2894
2895     type = o->op_type;
2896     if (PL_madskills && type == OP_NULL && o->op_flags & OPf_KIDS) {
2897         (void)my_kid(cUNOPo->op_first, attrs, imopsp);
2898         return o;
2899     }
2900
2901     if (type == OP_LIST) {
2902         OP *kid;
2903         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
2904             my_kid(kid, attrs, imopsp);
2905         return o;
2906     } else if (type == OP_UNDEF || type == OP_STUB) {
2907         return o;
2908     } else if (type == OP_RV2SV ||      /* "our" declaration */
2909                type == OP_RV2AV ||
2910                type == OP_RV2HV) { /* XXX does this let anything illegal in? */
2911         if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
2912             S_cant_declare(aTHX_ o);
2913         } else if (attrs) {
2914             GV * const gv = cGVOPx_gv(cUNOPo->op_first);
2915             assert(PL_parser);
2916             PL_parser->in_my = FALSE;
2917             PL_parser->in_my_stash = NULL;
2918             apply_attrs(GvSTASH(gv),
2919                         (type == OP_RV2SV ? GvSV(gv) :
2920                          type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) :
2921                          type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)),
2922                         attrs);
2923         }
2924         o->op_private |= OPpOUR_INTRO;
2925         return o;
2926     }
2927     else if (type != OP_PADSV &&
2928              type != OP_PADAV &&
2929              type != OP_PADHV &&
2930              type != OP_PUSHMARK)
2931     {
2932         S_cant_declare(aTHX_ o);
2933         return o;
2934     }
2935     else if (attrs && type != OP_PUSHMARK) {
2936         HV *stash;
2937
2938         assert(PL_parser);
2939         PL_parser->in_my = FALSE;
2940         PL_parser->in_my_stash = NULL;
2941
2942         /* check for C<my Dog $spot> when deciding package */
2943         stash = PAD_COMPNAME_TYPE(o->op_targ);
2944         if (!stash)
2945             stash = PL_curstash;
2946         apply_attrs_my(stash, o, attrs, imopsp);
2947     }
2948     o->op_flags |= OPf_MOD;
2949     o->op_private |= OPpLVAL_INTRO;
2950     if (stately)
2951         o->op_private |= OPpPAD_STATE;
2952     return o;
2953 }
2954
2955 OP *
2956 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2957 {
2958     dVAR;
2959     OP *rops;
2960     int maybe_scalar = 0;
2961
2962     PERL_ARGS_ASSERT_MY_ATTRS;
2963
2964 /* [perl #17376]: this appears to be premature, and results in code such as
2965    C< our(%x); > executing in list mode rather than void mode */
2966 #if 0
2967     if (o->op_flags & OPf_PARENS)
2968         list(o);
2969     else
2970         maybe_scalar = 1;
2971 #else
2972     maybe_scalar = 1;
2973 #endif
2974     if (attrs)
2975         SAVEFREEOP(attrs);
2976     rops = NULL;
2977     o = my_kid(o, attrs, &rops);
2978     if (rops) {
2979         if (maybe_scalar && o->op_type == OP_PADSV) {
2980             o = scalar(op_append_list(OP_LIST, rops, o));
2981             o->op_private |= OPpLVAL_INTRO;
2982         }
2983         else {
2984             /* The listop in rops might have a pushmark at the beginning,
2985                which will mess up list assignment. */
2986             LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
2987             if (rops->op_type == OP_LIST && 
2988                 lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
2989             {
2990                 OP * const pushmark = lrops->op_first;
2991                 lrops->op_first = pushmark->op_sibling;
2992                 op_free(pushmark);
2993             }
2994             o = op_append_list(OP_LIST, o, rops);
2995         }
2996     }
2997     PL_parser->in_my = FALSE;
2998     PL_parser->in_my_stash = NULL;
2999     return o;
3000 }
3001
3002 OP *
3003 Perl_sawparens(pTHX_ OP *o)
3004 {
3005     PERL_UNUSED_CONTEXT;
3006     if (o)
3007         o->op_flags |= OPf_PARENS;
3008     return o;
3009 }
3010
3011 OP *
3012 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
3013 {
3014     OP *o;
3015     bool ismatchop = 0;
3016     const OPCODE ltype = left->op_type;
3017     const OPCODE rtype = right->op_type;
3018
3019     PERL_ARGS_ASSERT_BIND_MATCH;
3020
3021     if ( (ltype == OP_RV2AV || ltype == OP_RV2HV || ltype == OP_PADAV
3022           || ltype == OP_PADHV) && ckWARN(WARN_MISC))
3023     {
3024       const char * const desc
3025           = PL_op_desc[(
3026                           rtype == OP_SUBST || rtype == OP_TRANS
3027                        || rtype == OP_TRANSR
3028                        )
3029                        ? (int)rtype : OP_MATCH];
3030       const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
3031       SV * const name =
3032         S_op_varname(aTHX_ left);
3033       if (name)
3034         Perl_warner(aTHX_ packWARN(WARN_MISC),
3035              "Applying %s to %"SVf" will act on scalar(%"SVf")",
3036              desc, name, name);
3037       else {
3038         const char * const sample = (isary
3039              ? "@array" : "%hash");
3040         Perl_warner(aTHX_ packWARN(WARN_MISC),
3041              "Applying %s to %s will act on scalar(%s)",
3042              desc, sample, sample);
3043       }
3044     }
3045
3046     if (rtype == OP_CONST &&
3047         cSVOPx(right)->op_private & OPpCONST_BARE &&
3048         cSVOPx(right)->op_private & OPpCONST_STRICT)
3049     {
3050         no_bareword_allowed(right);
3051     }
3052
3053     /* !~ doesn't make sense with /r, so error on it for now */
3054     if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
3055         type == OP_NOT)
3056         /* diag_listed_as: Using !~ with %s doesn't make sense */
3057         yyerror("Using !~ with s///r doesn't make sense");
3058     if (rtype == OP_TRANSR && type == OP_NOT)
3059         /* diag_listed_as: Using !~ with %s doesn't make sense */
3060         yyerror("Using !~ with tr///r doesn't make sense");
3061
3062     ismatchop = (rtype == OP_MATCH ||
3063                  rtype == OP_SUBST ||
3064                  rtype == OP_TRANS || rtype == OP_TRANSR)
3065              && !(right->op_flags & OPf_SPECIAL);
3066     if (ismatchop && right->op_private & OPpTARGET_MY) {
3067         right->op_targ = 0;
3068         right->op_private &= ~OPpTARGET_MY;
3069     }
3070     if (!(right->op_flags & OPf_STACKED) && ismatchop) {
3071         OP *newleft;
3072
3073         right->op_flags |= OPf_STACKED;
3074         if (rtype != OP_MATCH && rtype != OP_TRANSR &&
3075             ! (rtype == OP_TRANS &&
3076                right->op_private & OPpTRANS_IDENTICAL) &&
3077             ! (rtype == OP_SUBST &&
3078                (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
3079             newleft = op_lvalue(left, rtype);
3080         else
3081             newleft = left;
3082         if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
3083             o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
3084         else
3085             o = op_prepend_elem(rtype, scalar(newleft), right);
3086         if (type == OP_NOT)
3087             return newUNOP(OP_NOT, 0, scalar(o));
3088         return o;
3089     }
3090     else
3091         return bind_match(type, left,
3092                 pmruntime(newPMOP(OP_MATCH, 0), right, 0, 0));
3093 }
3094
3095 OP *
3096 Perl_invert(pTHX_ OP *o)
3097 {
3098     if (!o)
3099         return NULL;
3100     return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
3101 }
3102
3103 /*
3104 =for apidoc Amx|OP *|op_scope|OP *o
3105
3106 Wraps up an op tree with some additional ops so that at runtime a dynamic
3107 scope will be created.  The original ops run in the new dynamic scope,
3108 and then, provided that they exit normally, the scope will be unwound.
3109 The additional ops used to create and unwind the dynamic scope will
3110 normally be an C<enter>/C<leave> pair, but a C<scope> op may be used
3111 instead if the ops are simple enough to not need the full dynamic scope
3112 structure.
3113
3114 =cut
3115 */
3116
3117 OP *
3118 Perl_op_scope(pTHX_ OP *o)
3119 {
3120     dVAR;
3121     if (o) {
3122         if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
3123             o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
3124             o->op_type = OP_LEAVE;
3125             o->op_ppaddr = PL_ppaddr[OP_LEAVE];
3126         }
3127         else if (o->op_type == OP_LINESEQ) {
3128             OP *kid;
3129             o->op_type = OP_SCOPE;
3130             o->op_ppaddr = PL_ppaddr[OP_SCOPE];
3131             kid = ((LISTOP*)o)->op_first;
3132             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
3133                 op_null(kid);
3134
3135                 /* The following deals with things like 'do {1 for 1}' */
3136                 kid = kid->op_sibling;
3137                 if (kid &&
3138                     (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE))
3139                     op_null(kid);
3140             }
3141         }
3142         else
3143             o = newLISTOP(OP_SCOPE, 0, o, NULL);
3144     }
3145     return o;
3146 }
3147
3148 OP *
3149 Perl_op_unscope(pTHX_ OP *o)
3150 {
3151     if (o && o->op_type == OP_LINESEQ) {
3152         OP *kid = cLISTOPo->op_first;
3153         for(; kid; kid = kid->op_sibling)
3154             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
3155                 op_null(kid);
3156     }
3157     return o;
3158 }
3159
3160 int
3161 Perl_block_start(pTHX_ int full)
3162 {
3163     dVAR;
3164     const int retval = PL_savestack_ix;
3165
3166     pad_block_start(full);
3167     SAVEHINTS();
3168     PL_hints &= ~HINT_BLOCK_SCOPE;
3169     SAVECOMPILEWARNINGS();
3170     PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
3171
3172     CALL_BLOCK_HOOKS(bhk_start, full);
3173
3174     return retval;
3175 }
3176
3177 OP*
3178 Perl_block_end(pTHX_ I32 floor, OP *seq)
3179 {
3180     dVAR;
3181     const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
3182     OP* retval = scalarseq(seq);
3183     OP *o;
3184
3185     CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
3186
3187     LEAVE_SCOPE(floor);
3188     if (needblockscope)
3189         PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
3190     o = pad_leavemy();
3191
3192     if (o) {
3193         /* pad_leavemy has created a sequence of introcv ops for all my
3194            subs declared in the block.  We have to replicate that list with
3195            clonecv ops, to deal with this situation:
3196
3197                sub {
3198                    my sub s1;
3199                    my sub s2;
3200                    sub s1 { state sub foo { \&s2 } }
3201                }->()
3202
3203            Originally, I was going to have introcv clone the CV and turn
3204            off the stale flag.  Since &s1 is declared before &s2, the
3205            introcv op for &s1 is executed (on sub entry) before the one for
3206            &s2.  But the &foo sub inside &s1 (which is cloned when &s1 is
3207            cloned, since it is a state sub) closes over &s2 and expects
3208            to see it in its outer CV’s pad.  If the introcv op clones &s1,
3209            then &s2 is still marked stale.  Since &s1 is not active, and
3210            &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia-
3211            ble will not stay shared’ warning.  Because it is the same stub
3212            that will be used when the introcv op for &s2 is executed, clos-
3213            ing over it is safe.  Hence, we have to turn off the stale flag
3214            on all lexical subs in the block before we clone any of them.
3215            Hence, having introcv clone the sub cannot work.  So we create a
3216            list of ops like this:
3217
3218                lineseq
3219                   |
3220                   +-- introcv
3221                   |
3222                   +-- introcv
3223                   |
3224                   +-- introcv
3225                   |
3226                   .
3227                   .
3228                   .
3229                   |
3230                   +-- clonecv
3231                   |
3232                   +-- clonecv
3233                   |
3234                   +-- clonecv
3235                   |
3236                   .
3237                   .
3238                   .
3239          */
3240         OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
3241         OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
3242         for (;; kid = kid->op_sibling) {
3243             OP *newkid = newOP(OP_CLONECV, 0);
3244             newkid->op_targ = kid->op_targ;
3245             o = op_append_elem(OP_LINESEQ, o, newkid);
3246             if (kid == last) break;
3247         }
3248         retval = op_prepend_elem(OP_LINESEQ, o, retval);
3249     }
3250
3251     CALL_BLOCK_HOOKS(bhk_post_end, &retval);
3252
3253     return retval;
3254 }
3255
3256 /*
3257 =head1 Compile-time scope hooks
3258
3259 =for apidoc Aox||blockhook_register
3260
3261 Register a set of hooks to be called when the Perl lexical scope changes
3262 at compile time.  See L<perlguts/"Compile-time scope hooks">.
3263
3264 =cut
3265 */
3266
3267 void
3268 Perl_blockhook_register(pTHX_ BHK *hk)
3269 {
3270     PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
3271
3272     Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
3273 }
3274
3275 STATIC OP *
3276 S_newDEFSVOP(pTHX)
3277 {
3278     dVAR;
3279     const PADOFFSET offset = pad_findmy_pvs("$_", 0);
3280     if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
3281         return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
3282     }
3283     else {
3284         OP * const o = newOP(OP_PADSV, 0);
3285         o->op_targ = offset;
3286         return o;
3287     }
3288 }
3289
3290 void
3291 Perl_newPROG(pTHX_ OP *o)
3292 {
3293     dVAR;
3294
3295     PERL_ARGS_ASSERT_NEWPROG;
3296
3297     if (PL_in_eval) {
3298         PERL_CONTEXT *cx;
3299         I32 i;
3300         if (PL_eval_root)
3301                 return;
3302         PL_eval_root = newUNOP(OP_LEAVEEVAL,
3303                                ((PL_in_eval & EVAL_KEEPERR)
3304                                 ? OPf_SPECIAL : 0), o);
3305
3306         cx = &cxstack[cxstack_ix];
3307         assert(CxTYPE(cx) == CXt_EVAL);
3308
3309         if ((cx->blk_gimme & G_WANT) == G_VOID)
3310             scalarvoid(PL_eval_root);
3311         else if ((cx->blk_gimme & G_WANT) == G_ARRAY)
3312             list(PL_eval_root);
3313         else
3314             scalar(PL_eval_root);
3315
3316         PL_eval_start = op_linklist(PL_eval_root);
3317         PL_eval_root->op_private |= OPpREFCOUNTED;
3318         OpREFCNT_set(PL_eval_root, 1);
3319         PL_eval_root->op_next = 0;
3320         i = PL_savestack_ix;
3321         SAVEFREEOP(o);
3322         ENTER;
3323         CALL_PEEP(PL_eval_start);
3324         finalize_optree(PL_eval_root);
3325         S_prune_chain_head(aTHX_ &PL_eval_start);
3326         LEAVE;
3327         PL_savestack_ix = i;
3328     }
3329     else {
3330         if (o->op_type == OP_STUB) {
3331             /* This block is entered if nothing is compiled for the main
3332                program. This will be the case for an genuinely empty main
3333                program, or one which only has BEGIN blocks etc, so already
3334                run and freed.
3335
3336                Historically (5.000) the guard above was !o. However, commit
3337                f8a08f7b8bd67b28 (Jun 2001), integrated to blead as
3338                c71fccf11fde0068, changed perly.y so that newPROG() is now
3339                called with the output of block_end(), which returns a new
3340                OP_STUB for the case of an empty optree. ByteLoader (and
3341                maybe other things) also take this path, because they set up
3342                PL_main_start and PL_main_root directly, without generating an
3343                optree.
3344
3345                If the parsing the main program aborts (due to parse errors,
3346                or due to BEGIN or similar calling exit), then newPROG()
3347                isn't even called, and hence this code path and its cleanups
3348                are skipped. This shouldn't make a make a difference:
3349                * a non-zero return from perl_parse is a failure, and
3350                  perl_destruct() should be called immediately.
3351                * however, if exit(0) is called during the parse, then
3352                  perl_parse() returns 0, and perl_run() is called. As
3353                  PL_main_start will be NULL, perl_run() will return
3354                  promptly, and the exit code will remain 0.
3355             */
3356
3357             PL_comppad_name = 0;
3358             PL_compcv = 0;
3359             S_op_destroy(aTHX_ o);
3360             return;
3361         }
3362         PL_main_root = op_scope(sawparens(scalarvoid(o)));
3363         PL_curcop = &PL_compiling;
3364         PL_main_start = LINKLIST(PL_main_root);
3365         PL_main_root->op_private |= OPpREFCOUNTED;
3366         OpREFCNT_set(PL_main_root, 1);
3367         PL_main_root->op_next = 0;
3368         CALL_PEEP(PL_main_start);
3369         finalize_optree(PL_main_root);
3370         S_prune_chain_head(aTHX_ &PL_main_start);
3371         cv_forget_slab(PL_compcv);
3372         PL_compcv = 0;
3373
3374         /* Register with debugger */
3375         if (PERLDB_INTER) {
3376             CV * const cv = get_cvs("DB::postponed", 0);
3377             if (cv) {
3378                 dSP;
3379                 PUSHMARK(SP);
3380                 XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3381                 PUTBACK;
3382                 call_sv(MUTABLE_SV(cv), G_DISCARD);
3383             }
3384         }
3385     }
3386 }
3387
3388 OP *
3389 Perl_localize(pTHX_ OP *o, I32 lex)
3390 {
3391     dVAR;
3392
3393     PERL_ARGS_ASSERT_LOCALIZE;
3394
3395     if (o->op_flags & OPf_PARENS)
3396 /* [perl #17376]: this appears to be premature, and results in code such as
3397    C< our(%x); > executing in list mode rather than void mode */
3398 #if 0
3399         list(o);
3400 #else
3401         NOOP;
3402 #endif
3403     else {
3404         if ( PL_parser->bufptr > PL_parser->oldbufptr
3405             && PL_parser->bufptr[-1] == ','
3406             && ckWARN(WARN_PARENTHESIS))
3407         {
3408             char *s = PL_parser->bufptr;
3409             bool sigil = FALSE;
3410
3411             /* some heuristics to detect a potential error */
3412             while (*s && (strchr(", \t\n", *s)))
3413                 s++;
3414
3415             while (1) {
3416                 if (*s && strchr("@$%*", *s) && *++s
3417                        && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) {
3418                     s++;
3419                     sigil = TRUE;
3420                     while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s)))
3421                         s++;
3422                     while (*s && (strchr(", \t\n", *s)))
3423                         s++;
3424                 }
3425                 else
3426                     break;
3427             }
3428             if (sigil && (*s == ';' || *s == '=')) {
3429                 Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
3430                                 "Parentheses missing around \"%s\" list",
3431                                 lex
3432                                     ? (PL_parser->in_my == KEY_our
3433                                         ? "our"
3434                                         : PL_parser->in_my == KEY_state
3435                                             ? "state"
3436                                             : "my")
3437                                     : "local");
3438             }
3439         }
3440     }
3441     if (lex)
3442         o = my(o);
3443     else
3444         o = op_lvalue(o, OP_NULL);              /* a bit kludgey */
3445     PL_parser->in_my = FALSE;
3446     PL_parser->in_my_stash = NULL;
3447     return o;
3448 }
3449
3450 OP *
3451 Perl_jmaybe(pTHX_ OP *o)
3452 {
3453     PERL_ARGS_ASSERT_JMAYBE;
3454
3455     if (o->op_type == OP_LIST) {
3456         OP * const o2
3457             = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL, SVt_PV)));
3458         o = convert(OP_JOIN, 0, op_prepend_elem(OP_LIST, o2, o));
3459     }
3460     return o;
3461 }
3462
3463 PERL_STATIC_INLINE OP *
3464 S_op_std_init(pTHX_ OP *o)
3465 {
3466     I32 type = o->op_type;
3467
3468     PERL_ARGS_ASSERT_OP_STD_INIT;
3469
3470     if (PL_opargs[type] & OA_RETSCALAR)
3471         scalar(o);
3472     if (PL_opargs[type] & OA_TARGET && !o->op_targ)
3473         o->op_targ = pad_alloc(type, SVs_PADTMP);
3474
3475     return o;
3476 }
3477
3478 PERL_STATIC_INLINE OP *
3479 S_op_integerize(pTHX_ OP *o)
3480 {
3481     I32 type = o->op_type;
3482
3483     PERL_ARGS_ASSERT_OP_INTEGERIZE;
3484
3485     /* integerize op. */
3486     if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
3487     {
3488         dVAR;
3489         o->op_ppaddr = PL_ppaddr[++(o->op_type)];
3490     }
3491
3492     if (type == OP_NEGATE)
3493         /* XXX might want a ck_negate() for this */
3494         cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
3495
3496     return o;
3497 }
3498
3499 static OP *
3500 S_fold_constants(pTHX_ OP *o)
3501 {
3502     dVAR;
3503     OP * VOL curop;
3504     OP *newop;
3505     VOL I32 type = o->op_type;
3506     SV * VOL sv = NULL;
3507     int ret = 0;
3508     I32 oldscope;
3509     OP *old_next;
3510     SV * const oldwarnhook = PL_warnhook;
3511     SV * const olddiehook  = PL_diehook;
3512     COP not_compiling;
3513     dJMPENV;
3514
3515     PERL_ARGS_ASSERT_FOLD_CONSTANTS;
3516
3517     if (!(PL_opargs[type] & OA_FOLDCONST))
3518         goto nope;
3519
3520     switch (type) {
3521     case OP_UCFIRST:
3522     case OP_LCFIRST:
3523     case OP_UC:
3524     case OP_LC:
3525     case OP_FC:
3526     case OP_SLT:
3527     case OP_SGT:
3528     case OP_SLE:
3529     case OP_SGE:
3530     case OP_SCMP:
3531     case OP_SPRINTF:
3532         /* XXX what about the numeric ops? */
3533         if (IN_LOCALE_COMPILETIME)
3534             goto nope;
3535         break;
3536     case OP_PACK:
3537         if (!cLISTOPo->op_first->op_sibling
3538           || cLISTOPo->op_first->op_sibling->op_type != OP_CONST)
3539             goto nope;
3540         {
3541             SV * const sv = cSVOPx_sv(cLISTOPo->op_first->op_sibling);
3542             if (!SvPOK(sv) || SvGMAGICAL(sv)) goto nope;
3543             {
3544                 const char *s = SvPVX_const(sv);
3545                 while (s < SvEND(sv)) {
3546                     if (*s == 'p' || *s == 'P') goto nope;
3547                     s++;
3548                 }
3549             }
3550         }
3551         break;
3552     case OP_REPEAT:
3553         if (o->op_private & OPpREPEAT_DOLIST) goto nope;
3554         break;
3555     case OP_SREFGEN:
3556         if (cUNOPx(cUNOPo->op_first)->op_first->op_type != OP_CONST
3557          || SvPADTMP(cSVOPx_sv(cUNOPx(cUNOPo->op_first)->op_first)))
3558             goto nope;
3559     }
3560
3561     if (PL_parser && PL_parser->error_count)
3562         goto nope;              /* Don't try to run w/ errors */
3563
3564     for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3565         const OPCODE type = curop->op_type;
3566         if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
3567             type != OP_LIST &&
3568             type != OP_SCALAR &&
3569             type != OP_NULL &&
3570             type != OP_PUSHMARK)
3571         {
3572             goto nope;
3573         }
3574     }
3575
3576     curop = LINKLIST(o);
3577     old_next = o->op_next;
3578     o->op_next = 0;
3579     PL_op = curop;
3580
3581     oldscope = PL_scopestack_ix;
3582     create_eval_scope(G_FAKINGEVAL);
3583
3584     /* Verify that we don't need to save it:  */
3585     assert(PL_curcop == &PL_compiling);
3586     StructCopy(&PL_compiling, &not_compiling, COP);
3587     PL_curcop = &not_compiling;
3588     /* The above ensures that we run with all the correct hints of the
3589        currently compiling COP, but that IN_PERL_RUNTIME is not true. */
3590     assert(IN_PERL_RUNTIME);
3591     PL_warnhook = PERL_WARNHOOK_FATAL;
3592     PL_diehook  = NULL;
3593     JMPENV_PUSH(ret);
3594
3595     switch (ret) {
3596     case 0:
3597         CALLRUNOPS(aTHX);
3598         sv = *(PL_stack_sp--);
3599         if (o->op_targ && sv == PAD_SV(o->op_targ)) {   /* grab pad temp? */
3600 #ifdef PERL_MAD
3601             /* Can't simply swipe the SV from the pad, because that relies on
3602                the op being freed "real soon now". Under MAD, this doesn't
3603                happen (see the #ifdef below).  */
3604             sv = newSVsv(sv);
3605 #else
3606             pad_swipe(o->op_targ,  FALSE);
3607 #endif
3608         }
3609         else if (SvTEMP(sv)) {                  /* grab mortal temp? */
3610             SvREFCNT_inc_simple_void(sv);
3611             SvTEMP_off(sv);
3612         }
3613         else { assert(SvIMMORTAL(sv)); }
3614         break;
3615     case 3:
3616         /* Something tried to die.  Abandon constant folding.  */
3617         /* Pretend the error never happened.  */
3618         CLEAR_ERRSV();
3619         o->op_next = old_next;
3620         break;
3621     default:
3622         JMPENV_POP;
3623         /* Don't expect 1 (setjmp failed) or 2 (something called my_exit)  */
3624         PL_warnhook = oldwarnhook;
3625         PL_diehook  = olddiehook;
3626         /* XXX note that this croak may fail as we've already blown away
3627          * the stack - eg any nested evals */
3628         Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
3629     }
3630     JMPENV_POP;
3631     PL_warnhook = oldwarnhook;
3632     PL_diehook  = olddiehook;
3633     PL_curcop = &PL_compiling;
3634
3635     if (PL_scopestack_ix > oldscope)
3636         delete_eval_scope();
3637
3638     if (ret)
3639         goto nope;
3640
3641 #ifndef PERL_MAD
3642     op_free(o);
3643 #endif
3644     assert(sv);
3645     if (type == OP_STRINGIFY) SvPADTMP_off(sv);
3646     else if (!SvIMMORTAL(sv)) {
3647         SvPADTMP_on(sv);
3648         SvREADONLY_on(sv);
3649     }
3650     if (type == OP_RV2GV)
3651         newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
3652     else
3653     {
3654         newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
3655         if (type != OP_STRINGIFY) newop->op_folded = 1;
3656     }
3657     op_getmad(o,newop,'f');
3658     return newop;
3659
3660  nope:
3661     return o;
3662 }
3663
3664 static OP *
3665 S_gen_constant_list(pTHX_ OP *o)
3666 {
3667     dVAR;
3668     OP *curop;
3669     const SSize_t oldtmps_floor = PL_tmps_floor;
3670     SV **svp;
3671     AV *av;
3672
3673     list(o);
3674     if (PL_parser && PL_parser->error_count)
3675         return o;               /* Don't attempt to run with errors */
3676
3677     curop = LINKLIST(o);
3678     o->op_next = 0;
3679     CALL_PEEP(curop);
3680     S_prune_chain_head(aTHX_ &curop);
3681     PL_op = curop;
3682     Perl_pp_pushmark(aTHX);
3683     CALLRUNOPS(aTHX);
3684     PL_op = curop;
3685     assert (!(curop->op_flags & OPf_SPECIAL));
3686     assert(curop->op_type == OP_RANGE);
3687     Perl_pp_anonlist(aTHX);
3688     PL_tmps_floor = oldtmps_floor;
3689
3690     o->op_type = OP_RV2AV;
3691     o->op_ppaddr = PL_ppaddr[OP_RV2AV];
3692     o->op_flags &= ~OPf_REF;    /* treat \(1..2) like an ordinary list */
3693     o->op_flags |= OPf_PARENS;  /* and flatten \(1..2,3) */
3694     o->op_opt = 0;              /* needs to be revisited in rpeep() */
3695     curop = ((UNOP*)o)->op_first;
3696     av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--);
3697     ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, (SV *)av);
3698     if (AvFILLp(av) != -1)
3699         for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp)
3700         {
3701             SvPADTMP_on(*svp);
3702             SvREADONLY_on(*svp);
3703         }
3704 #ifdef PERL_MAD
3705     op_getmad(curop,o,'O');
3706 #else
3707     op_free(curop);
3708 #endif
3709     LINKLIST(o);
3710     return list(o);
3711 }
3712
3713 OP *
3714 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
3715 {
3716     dVAR;
3717     if (type < 0) type = -type, flags |= OPf_SPECIAL;
3718     if (!o || o->op_type != OP_LIST)
3719         o = newLISTOP(OP_LIST, 0, o, NULL);
3720     else
3721         o->op_flags &= ~OPf_WANT;
3722
3723     if (!(PL_opargs[type] & OA_MARK))
3724         op_null(cLISTOPo->op_first);
3725     else {
3726         OP * const kid2 = cLISTOPo->op_first->op_sibling;
3727         if (kid2 && kid2->op_type == OP_COREARGS) {
3728             op_null(cLISTOPo->op_first);
3729             kid2->op_private |= OPpCOREARGS_PUSHMARK;
3730         }
3731     }   
3732
3733     o->op_type = (OPCODE)type;
3734     o->op_ppaddr = PL_ppaddr[type];
3735     o->op_flags |= flags;
3736
3737     o = CHECKOP(type, o);
3738     if (o->op_type != (unsigned)type)
3739         return o;
3740
3741     return fold_constants(op_integerize(op_std_init(o)));
3742 }
3743
3744 /*
3745 =head1 Optree Manipulation Functions
3746 */
3747
3748 /* List constructors */
3749
3750 /*
3751 =for apidoc Am|OP *|op_append_elem|I32 optype|OP *first|OP *last
3752
3753 Append an item to the list of ops contained directly within a list-type
3754 op, returning the lengthened list.  I<first> is the list-type op,
3755 and I<last> is the op to append to the list.  I<optype> specifies the
3756 intended opcode for the list.  If I<first> is not already a list of the
3757 right type, it will be upgraded into one.  If either I<first> or I<last>
3758 is null, the other is returned unchanged.
3759
3760 =cut
3761 */
3762
3763 OP *
3764 Perl_op_append_elem(pTHX_ I32 type, OP *first, OP *last)
3765 {
3766     if (!first)
3767         return last;
3768
3769     if (!last)
3770         return first;
3771
3772     if (first->op_type != (unsigned)type
3773         || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
3774     {
3775         return newLISTOP(type, 0, first, last);
3776     }
3777
3778     if (first->op_flags & OPf_KIDS)
3779         ((LISTOP*)first)->op_last->op_sibling = last;
3780     else {
3781         first->op_flags |= OPf_KIDS;
3782         ((LISTOP*)first)->op_first = last;
3783     }
3784     ((LISTOP*)first)->op_last = last;
3785     return first;
3786 }
3787
3788 /*
3789 =for apidoc Am|OP *|op_append_list|I32 optype|OP *first|OP *last
3790
3791 Concatenate the lists of ops contained directly within two list-type ops,
3792 returning the combined list.  I<first> and I<last> are the list-type ops
3793 to concatenate.  I<optype> specifies the intended opcode for the list.
3794 If either I<first> or I<last> is not already a list of the right type,
3795 it will be upgraded into one.  If either I<first> or I<last> is null,
3796 the other is returned unchanged.
3797
3798 =cut
3799 */
3800
3801 OP *
3802 Perl_op_append_list(pTHX_ I32 type, OP *first, OP *last)
3803 {
3804     if (!first)
3805         return last;
3806
3807     if (!last)
3808         return first;
3809
3810     if (first->op_type != (unsigned)type)
3811         return op_prepend_elem(type, first, last);
3812
3813     if (last->op_type != (unsigned)type)
3814         return op_append_elem(type, first, last);
3815
3816     ((LISTOP*)first)->op_last->op_sibling = ((LISTOP*)last)->op_first;
3817     ((LISTOP*)first)->op_last = ((LISTOP*)last)->op_last;
3818     first->op_flags |= (last->op_flags & OPf_KIDS);
3819
3820 #ifdef PERL_MAD
3821     if (((LISTOP*)last)->op_first && first->op_madprop) {
3822         MADPROP *mp = ((LISTOP*)last)->op_first->op_madprop;
3823         if (mp) {
3824             while (mp->mad_next)
3825                 mp = mp->mad_next;
3826             mp->mad_next = first->op_madprop;
3827         }
3828         else {
3829             ((LISTOP*)last)->op_first->op_madprop = first->op_madprop;
3830         }
3831     }
3832     first->op_madprop = last->op_madprop;
3833     last->op_madprop = 0;
3834 #endif
3835
3836     S_op_destroy(aTHX_ last);
3837
3838     return first;
3839 }
3840
3841 /*
3842 =for apidoc Am|OP *|op_prepend_elem|I32 optype|OP *first|OP *last
3843
3844 Prepend an item to the list of ops contained directly within a list-type
3845 op, returning the lengthened list.  I<first> is the op to prepend to the
3846 list, and I<last> is the list-type op.  I<optype> specifies the intended
3847 opcode for the list.  If I<last> is not already a list of the right type,
3848 it will be upgraded into one.  If either I<first> or I<last> is null,
3849 the other is returned unchanged.
3850
3851 =cut
3852 */
3853
3854 OP *
3855 Perl_op_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
3856 {
3857     if (!first)
3858         return last;
3859
3860     if (!last)
3861         return first;
3862
3863     if (last->op_type == (unsigned)type) {
3864         if (type == OP_LIST) {  /* already a PUSHMARK there */
3865             first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
3866             ((LISTOP*)last)->op_first->op_sibling = first;
3867             if (!(first->op_flags & OPf_PARENS))
3868                 last->op_flags &= ~OPf_PARENS;
3869         }
3870         else {
3871             if (!(last->op_flags & OPf_KIDS)) {
3872                 ((LISTOP*)last)->op_last = first;
3873                 last->op_flags |= OPf_KIDS;
3874             }
3875             first->op_sibling = ((LISTOP*)last)->op_first;
3876             ((LISTOP*)last)->op_first = first;
3877         }
3878         last->op_flags |= OPf_KIDS;
3879         return last;
3880     }
3881
3882     return newLISTOP(type, 0, first, last);
3883 }
3884
3885 /* Constructors */
3886
3887 #ifdef PERL_MAD
3888  
3889 TOKEN *
3890 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
3891 {
3892     TOKEN *tk;
3893     Newxz(tk, 1, TOKEN);
3894     tk->tk_type = (OPCODE)optype;
3895     tk->tk_type = 12345;
3896     tk->tk_lval = lval;
3897     tk->tk_mad = madprop;
3898     return tk;
3899 }
3900
3901 void
3902 Perl_token_free(pTHX_ TOKEN* tk)
3903 {
3904     PERL_ARGS_ASSERT_TOKEN_FREE;
3905
3906     if (tk->tk_type != 12345)
3907         return;
3908     mad_free(tk->tk_mad);
3909     Safefree(tk);
3910 }
3911
3912 void
3913 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
3914 {
3915     MADPROP* mp;
3916     MADPROP* tm;
3917
3918     PERL_ARGS_ASSERT_TOKEN_GETMAD;
3919
3920     if (tk->tk_type != 12345) {
3921         Perl_warner(aTHX_ packWARN(WARN_MISC),
3922              "Invalid TOKEN object ignored");
3923         return;
3924     }
3925     tm = tk->tk_mad;
3926     if (!tm)
3927         return;
3928
3929     /* faked up qw list? */
3930     if (slot == '(' &&
3931         tm->mad_type == MAD_SV &&
3932         SvPVX((SV *)tm->mad_val)[0] == 'q')
3933             slot = 'x';
3934
3935     if (o) {
3936         mp = o->op_madprop;
3937         if (mp) {
3938             for (;;) {
3939                 /* pretend constant fold didn't happen? */
3940                 if (mp->mad_key == 'f' &&
3941                     (o->op_type == OP_CONST ||
3942                      o->op_type == OP_GV) )
3943                 {
3944                     token_getmad(tk,(OP*)mp->mad_val,slot);
3945                     return;
3946                 }
3947                 if (!mp->mad_next)
3948                     break;
3949                 mp = mp->mad_next;
3950             }
3951             mp->mad_next = tm;
3952             mp = mp->mad_next;
3953         }
3954         else {
3955             o->op_madprop = tm;
3956             mp = o->op_madprop;
3957         }
3958         if (mp->mad_key == 'X')
3959             mp->mad_key = slot; /* just change the first one */
3960
3961         tk->tk_mad = 0;
3962     }
3963     else
3964         mad_free(tm);
3965     Safefree(tk);
3966 }
3967
3968 void
3969 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
3970 {
3971     MADPROP* mp;
3972     if (!from)
3973         return;
3974     if (o) {
3975         mp = o->op_madprop;
3976         if (mp) {
3977             for (;;) {
3978                 /* pretend constant fold didn't happen? */
3979                 if (mp->mad_key == 'f' &&
3980                     (o->op_type == OP_CONST ||
3981                      o->op_type == OP_GV) )
3982                 {
3983                     op_getmad(from,(OP*)mp->mad_val,slot);
3984                     return;
3985                 }
3986                 if (!mp->mad_next)
3987                     break;
3988                 mp = mp->mad_next;
3989             }
3990             mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
3991         }
3992         else {
3993             o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
3994         }
3995     }
3996 }
3997
3998 void
3999 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
4000 {
4001     MADPROP* mp;
4002     if (!from)
4003         return;
4004     if (o) {
4005         mp = o->op_madprop;
4006         if (mp) {
4007             for (;;) {
4008                 /* pretend constant fold didn't happen? */
4009                 if (mp->mad_key == 'f' &&
4010                     (o->op_type == OP_CONST ||
4011                      o->op_type == OP_GV) )
4012                 {
4013                     op_getmad(from,(OP*)mp->mad_val,slot);
4014                     return;
4015                 }
4016                 if (!mp->mad_next)
4017                     break;
4018                 mp = mp->mad_next;
4019             }
4020             mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
4021         }
4022         else {
4023             o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
4024         }
4025     }
4026     else {
4027         PerlIO_printf(PerlIO_stderr(),
4028                       "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
4029         op_free(from);
4030     }
4031 }
4032
4033 void
4034 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
4035 {
4036     MADPROP* tm;
4037     if (!mp || !o)
4038         return;
4039     if (slot)
4040         mp->mad_key = slot;
4041     tm = o->op_madprop;
4042     o->op_madprop = mp;
4043     for (;;) {
4044         if (!mp->mad_next)
4045             break;
4046         mp = mp->mad_next;
4047     }
4048     mp->mad_next = tm;
4049 }
4050
4051 void
4052 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
4053 {
4054     if (!o)
4055         return;
4056     addmad(tm, &(o->op_madprop), slot);
4057 }
4058
4059 void
4060 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
4061 {
4062     MADPROP* mp;
4063     if (!tm || !root)
4064         return;
4065     if (slot)
4066         tm->mad_key = slot;
4067     mp = *root;
4068     if (!mp) {
4069         *root = tm;
4070         return;
4071     }
4072     for (;;) {
4073         if (!mp->mad_next)
4074             break;
4075         mp = mp->mad_next;
4076     }
4077     mp->mad_next = tm;
4078 }
4079
4080 MADPROP *
4081 Perl_newMADsv(pTHX_ char key, SV* sv)
4082 {
4083     PERL_ARGS_ASSERT_NEWMADSV;
4084
4085     return newMADPROP(key, MAD_SV, sv, 0);
4086 }
4087
4088 MADPROP *
4089 Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
4090 {
4091     MADPROP *const mp = (MADPROP *) PerlMemShared_malloc(sizeof(MADPROP));
4092     mp->mad_next = 0;
4093     mp->mad_key = key;
4094     mp->mad_vlen = vlen;
4095     mp->mad_type = type;
4096     mp->mad_val = val;
4097 /*    PerlIO_printf(PerlIO_stderr(), "NEW  mp = %0x\n", mp);  */
4098     return mp;
4099 }
4100
4101 void
4102 Perl_mad_free(pTHX_ MADPROP* mp)
4103 {
4104 /*    PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
4105     if (!mp)
4106         return;
4107     if (mp->mad_next)
4108         mad_free(mp->mad_next);
4109 /*    if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
4110         PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
4111     switch (mp->mad_type) {
4112     case MAD_NULL:
4113         break;
4114     case MAD_PV:
4115         Safefree(mp->mad_val);
4116         break;
4117     case MAD_OP:
4118         if (mp->mad_vlen)       /* vlen holds "strong/weak" boolean */
4119             op_free((OP*)mp->mad_val);
4120         break;
4121     case MAD_SV:
4122         sv_free(MUTABLE_SV(mp->mad_val));
4123         break;
4124     default:
4125         PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
4126         break;
4127     }
4128     PerlMemShared_free(mp);
4129 }
4130
4131 #endif
4132
4133 /*
4134 =head1 Optree construction
4135
4136 =for apidoc Am|OP *|newNULLLIST
4137
4138 Constructs, checks, and returns a new C<stub> op, which represents an
4139 empty list expression.
4140
4141 =cut
4142 */
4143
4144 OP *
4145 Perl_newNULLLIST(pTHX)
4146 {
4147     return newOP(OP_STUB, 0);
4148 }
4149
4150 static OP *
4151 S_force_list(pTHX_ OP *o)
4152 {
4153     if (!o || o->op_type != OP_LIST)
4154         o = newLISTOP(OP_LIST, 0, o, NULL);
4155     op_null(o);
4156     return o;
4157 }
4158
4159 /*
4160 =for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
4161
4162 Constructs, checks, and returns an op of any list type.  I<type> is
4163 the opcode.  I<flags> gives the eight bits of C<op_flags>, except that
4164 C<OPf_KIDS> will be set automatically if required.  I<first> and I<last>
4165 supply up to two ops to be direct children of the list op; they are
4166 consumed by this function and become part of the constructed op tree.
4167
4168 =cut
4169 */
4170
4171 OP *
4172 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
4173 {
4174     dVAR;
4175     LISTOP *listop;
4176
4177     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP);
4178
4179     NewOp(1101, listop, 1, LISTOP);
4180
4181     listop->op_type = (OPCODE)type;
4182     listop->op_ppaddr = PL_ppaddr[type];
4183     if (first || last)
4184         flags |= OPf_KIDS;
4185     listop->op_flags = (U8)flags;
4186
4187     if (!last && first)
4188         last = first;
4189     else if (!first && last)
4190         first = last;
4191     else if (first)
4192         first->op_sibling = last;
4193     listop->op_first = first;
4194     listop->op_last = last;
4195     if (type == OP_LIST) {
4196         OP* const pushop = newOP(OP_PUSHMARK, 0);
4197         pushop->op_sibling = first;
4198         listop->op_first = pushop;
4199         listop->op_flags |= OPf_KIDS;
4200         if (!last)
4201             listop->op_last = pushop;
4202     }
4203
4204     return CHECKOP(type, listop);
4205 }
4206
4207 /*
4208 =for apidoc Am|OP *|newOP|I32 type|I32 flags
4209
4210 Constructs, checks, and returns an op of any base type (any type that
4211 has no extra fields).  I<type> is the opcode.  I<flags> gives the
4212 eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
4213 of C<op_private>.
4214
4215 =cut
4216 */
4217
4218 OP *
4219 Perl_newOP(pTHX_ I32 type, I32 flags)
4220 {
4221     dVAR;
4222     OP *o;
4223
4224     if (type == -OP_ENTEREVAL) {
4225         type = OP_ENTEREVAL;
4226         flags |= OPpEVAL_BYTES<<8;
4227     }
4228
4229     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
4230         || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
4231         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
4232         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
4233
4234     NewOp(1101, o, 1, OP);
4235     o->op_type = (OPCODE)type;
4236     o->op_ppaddr = PL_ppaddr[type];
4237     o->op_flags = (U8)flags;
4238
4239     o->op_next = o;
4240     o->op_private = (U8)(0 | (flags >> 8));
4241     if (PL_opargs[type] & OA_RETSCALAR)
4242         scalar(o);
4243     if (PL_opargs[type] & OA_TARGET)
4244         o->op_targ = pad_alloc(type, SVs_PADTMP);
4245     return CHECKOP(type, o);
4246 }
4247
4248 /*
4249 =for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
4250
4251 Constructs, checks, and returns an op of any unary type.  I<type> is
4252 the opcode.  I<flags> gives the eight bits of C<op_flags>, except that
4253 C<OPf_KIDS> will be set automatically if required, and, shifted up eight
4254 bits, the eight bits of C<op_private>, except that the bit with value 1
4255 is automatically set.  I<first> supplies an optional op to be the direct
4256 child of the unary op; it is consumed by this function and become part
4257 of the constructed op tree.
4258
4259 =cut
4260 */
4261
4262 OP *
4263 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
4264 {
4265     dVAR;
4266     UNOP *unop;
4267
4268     if (type == -OP_ENTEREVAL) {
4269         type = OP_ENTEREVAL;
4270         flags |= OPpEVAL_BYTES<<8;
4271     }
4272
4273     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
4274         || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
4275         || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
4276         || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
4277         || type == OP_SASSIGN
4278         || type == OP_ENTERTRY
4279         || type == OP_NULL );
4280
4281     if (!first)
4282         first = newOP(OP_STUB, 0);
4283     if (PL_opargs[type] & OA_MARK)
4284         first = force_list(first);
4285
4286     NewOp(1101, unop, 1, UNOP);
4287     unop->op_type = (OPCODE)type;
4288     unop->op_ppaddr = PL_ppaddr[type];
4289     unop->op_first = first;
4290     unop->op_flags = (U8)(flags | OPf_KIDS);
4291     unop->op_private = (U8)(1 | (flags >> 8));
4292     unop = (UNOP*) CHECKOP(type, unop);
4293     if (unop->op_next)
4294         return (OP*)unop;
4295
4296     return fold_constants(op_integerize(op_std_init((OP *) unop)));
4297 }
4298
4299 /*
4300 =for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
4301
4302 Constructs, checks, and returns an op of any binary type.  I<type>
4303 is the opcode.  I<flags> gives the eight bits of C<op_flags>, except
4304 that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
4305 the eight bits of C<op_private>, except that the bit with value 1 or
4306 2 is automatically set as required.  I<first> and I<last> supply up to
4307 two ops to be the direct children of the binary op; they are consumed
4308 by this function and become part of the constructed op tree.
4309
4310 =cut
4311 */
4312
4313 OP *
4314 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
4315 {
4316     dVAR;
4317     BINOP *binop;
4318
4319     ASSUME((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
4320         || type == OP_SASSIGN || type == OP_NULL );
4321
4322     NewOp(1101, binop, 1, BINOP);
4323
4324     if (!first)
4325         first = newOP(OP_NULL, 0);
4326
4327     binop->op_type = (OPCODE)type;
4328     binop->op_ppaddr = PL_ppaddr[type];
4329     binop->op_first = first;
4330     binop->op_flags = (U8)(flags | OPf_KIDS);
4331     if (!last) {
4332         last = first;
4333         binop->op_private = (U8)(1 | (flags >> 8));
4334     }
4335     else {
4336         binop->op_private = (U8)(2 | (flags >> 8));
4337         first->op_sibling = last;
4338     }
4339
4340     binop = (BINOP*)CHECKOP(type, binop);
4341     if (binop->op_next || binop->op_type != (OPCODE)type)
4342         return (OP*)binop;
4343
4344     binop->op_last = binop->op_first->op_sibling;
4345
4346     return fold_constants(op_integerize(op_std_init((OP *)binop)));
4347 }
4348
4349 static int uvcompare(const void *a, const void *b)
4350     __attribute__nonnull__(1)
4351     __attribute__nonnull__(2)
4352     __attribute__pure__;
4353 static int uvcompare(const void *a, const void *b)
4354 {
4355     if (*((const UV *)a) < (*(const UV *)b))
4356         return -1;
4357     if (*((const UV *)a) > (*(const UV *)b))
4358         return 1;
4359     if (*((const UV *)a+1) < (*(const UV *)b+1))
4360         return -1;
4361     if (*((const UV *)a+1) > (*(const UV *)b+1))
4362         return 1;
4363     return 0;
4364 }
4365
4366 static OP *
4367 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
4368 {
4369     dVAR;
4370     SV * const tstr = ((SVOP*)expr)->op_sv;
4371     SV * const rstr =
4372 #ifdef PERL_MAD
4373                         (repl->op_type == OP_NULL)
4374                             ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
4375 #endif
4376                               ((SVOP*)repl)->op_sv;
4377     STRLEN tlen;
4378     STRLEN rlen;
4379     const U8 *t = (U8*)SvPV_const(tstr, tlen);
4380     const U8 *r = (U8*)SvPV_const(rstr, rlen);
4381     I32 i;
4382     I32 j;
4383     I32 grows = 0;
4384     short *tbl;
4385
4386     const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
4387     const I32 squash     = o->op_private & OPpTRANS_SQUASH;
4388     I32 del              = o->op_private & OPpTRANS_DELETE;
4389     SV* swash;
4390
4391     PERL_ARGS_ASSERT_PMTRANS;
4392
4393     PL_hints |= HINT_BLOCK_SCOPE;
4394
4395     if (SvUTF8(tstr))
4396         o->op_private |= OPpTRANS_FROM_UTF;
4397
4398     if (SvUTF8(rstr))
4399         o->op_private |= OPpTRANS_TO_UTF;
4400
4401     if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
4402         SV* const listsv = newSVpvs("# comment\n");
4403         SV* transv = NULL;
4404         const U8* tend = t + tlen;
4405         const U8* rend = r + rlen;
4406         STRLEN ulen;
4407         UV tfirst = 1;
4408         UV tlast = 0;
4409         IV tdiff;
4410         UV rfirst = 1;
4411         UV rlast = 0;
4412         IV rdiff;
4413         IV diff;
4414         I32 none = 0;
4415         U32 max = 0;
4416         I32 bits;
4417         I32 havefinal = 0;
4418         U32 final = 0;
4419         const I32 from_utf  = o->op_private & OPpTRANS_FROM_UTF;
4420         const I32 to_utf    = o->op_private & OPpTRANS_TO_UTF;
4421         U8* tsave = NULL;
4422         U8* rsave = NULL;
4423         const U32 flags = UTF8_ALLOW_DEFAULT;
4424
4425         if (!from_utf) {
4426             STRLEN len = tlen;
4427             t = tsave = bytes_to_utf8(t, &len);
4428             tend = t + len;
4429         }
4430         if (!to_utf && rlen) {
4431             STRLEN len = rlen;
4432             r = rsave = bytes_to_utf8(r, &len);
4433             rend = r + len;
4434         }
4435
4436 /* There is a  snag with this code on EBCDIC: scan_const() in toke.c has
4437  * encoded chars in native encoding which makes ranges in the EBCDIC 0..255
4438  * odd.  */
4439
4440         if (complement) {
4441             U8 tmpbuf[UTF8_MAXBYTES+1];
4442             UV *cp;
4443             UV nextmin = 0;
4444             Newx(cp, 2*tlen, UV);
4445             i = 0;
4446             transv = newSVpvs("");
4447             while (t < tend) {
4448                 cp[2*i] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
4449                 t += ulen;
4450                 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {
4451                     t++;
4452                     cp[2*i+1] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
4453                     t += ulen;
4454                 }
4455                 else {
4456                  cp[2*i+1] = cp[2*i];
4457                 }
4458                 i++;
4459             }
4460             qsort(cp, i, 2*sizeof(UV), uvcompare);
4461             for (j = 0; j < i; j++) {
4462                 UV  val = cp[2*j];
4463                 diff = val - nextmin;
4464                 if (diff > 0) {
4465                     t = uvchr_to_utf8(tmpbuf,nextmin);
4466                     sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4467                     if (diff > 1) {
4468                         U8  range_mark = ILLEGAL_UTF8_BYTE;
4469                         t = uvchr_to_utf8(tmpbuf, val - 1);
4470                         sv_catpvn(transv, (char *)&range_mark, 1);
4471                         sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4472                     }
4473                 }
4474                 val = cp[2*j+1];
4475                 if (val >= nextmin)
4476                     nextmin = val + 1;
4477             }
4478             t = uvchr_to_utf8(tmpbuf,nextmin);
4479             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4480             {
4481                 U8 range_mark = ILLEGAL_UTF8_BYTE;
4482                 sv_catpvn(transv, (char *)&range_mark, 1);
4483             }
4484             t = uvchr_to_utf8(tmpbuf, 0x7fffffff);
4485             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
4486             t = (const U8*)SvPVX_const(transv);
4487             tlen = SvCUR(transv);
4488             tend = t + tlen;
4489             Safefree(cp);
4490         }
4491         else if (!rlen && !del) {
4492             r = t; rlen = tlen; rend = tend;
4493         }
4494         if (!squash) {
4495                 if ((!rlen && !del) || t == r ||
4496                     (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
4497                 {
4498                     o->op_private |= OPpTRANS_IDENTICAL;
4499                 }
4500         }
4501
4502         while (t < tend || tfirst <= tlast) {
4503             /* see if we need more "t" chars */
4504             if (tfirst > tlast) {
4505                 tfirst = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
4506                 t += ulen;
4507                 if (t < tend && *t == ILLEGAL_UTF8_BYTE) {      /* illegal utf8 val indicates range */
4508                     t++;
4509                     tlast = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
4510                     t += ulen;
4511                 }
4512                 else
4513                     tlast = tfirst;
4514             }
4515
4516             /* now see if we need more "r" chars */
4517             if (rfirst > rlast) {
4518                 if (r < rend) {
4519                     rfirst = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
4520                     r += ulen;
4521                     if (r < rend && *r == ILLEGAL_UTF8_BYTE) {  /* illegal utf8 val indicates range */
4522                         r++;
4523                         rlast = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
4524                         r += ulen;
4525                     }
4526                     else
4527                         rlast = rfirst;
4528                 }
4529                 else {
4530                     if (!havefinal++)
4531                         final = rlast;
4532                     rfirst = rlast = 0xffffffff;
4533                 }
4534             }
4535
4536             /* now see which range will peter our first, if either. */
4537             tdiff = tlast - tfirst;
4538             rdiff = rlast - rfirst;
4539
4540             if (tdiff <= rdiff)
4541                 diff = tdiff;
4542             else
4543                 diff = rdiff;
4544
4545             if (rfirst == 0xffffffff) {
4546                 diff = tdiff;   /* oops, pretend rdiff is infinite */
4547                 if (diff > 0)
4548                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
4549                                    (long)tfirst, (long)tlast);
4550                 else
4551                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
4552             }
4553             else {
4554                 if (diff > 0)
4555                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
4556                                    (long)tfirst, (long)(tfirst + diff),
4557                                    (long)rfirst);
4558                 else
4559                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
4560                                    (long)tfirst, (long)rfirst);
4561
4562                 if (rfirst + diff > max)
4563                     max = rfirst + diff;
4564                 if (!grows)
4565                     grows = (tfirst < rfirst &&
4566                              UNISKIP(tfirst) < UNISKIP(rfirst + diff));
4567                 rfirst += diff + 1;
4568             }
4569             tfirst += diff + 1;
4570         }
4571
4572         none = ++max;
4573         if (del)
4574             del = ++max;
4575
4576         if (max > 0xffff)
4577             bits = 32;
4578         else if (max > 0xff)
4579             bits = 16;
4580         else
4581             bits = 8;
4582
4583         swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
4584 #ifdef USE_ITHREADS
4585         cPADOPo->op_padix = pad_alloc(OP_TRANS, SVf_READONLY);
4586         SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
4587         PAD_SETSV(cPADOPo->op_padix, swash);
4588         SvPADTMP_on(swash);
4589         SvREADONLY_on(swash);
4590 #else
4591         cSVOPo->op_sv = swash;
4592 #endif
4593         SvREFCNT_dec(listsv);
4594         SvREFCNT_dec(transv);
4595
4596         if (!del && havefinal && rlen)
4597             (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
4598                            newSVuv((UV)final), 0);
4599
4600         if (grows)
4601             o->op_private |= OPpTRANS_GROWS;
4602
4603         Safefree(tsave);
4604         Safefree(rsave);
4605
4606 #ifdef PERL_MAD
4607         op_getmad(expr,o,'e');
4608         op_getmad(repl,o,'r');
4609 #else
4610         op_free(expr);
4611         op_free(repl);
4612 #endif
4613         return o;
4614     }
4615
4616     tbl = (short*)PerlMemShared_calloc(
4617         (o->op_private & OPpTRANS_COMPLEMENT) &&
4618             !(o->op_private & OPpTRANS_DELETE) ? 258 : 256,
4619         sizeof(short));
4620     cPVOPo->op_pv = (char*)tbl;
4621     if (complement) {
4622         for (i = 0; i < (I32)tlen; i++)
4623             tbl[t[i]] = -1;
4624         for (i = 0, j = 0; i < 256; i++) {
4625             if (!tbl[i]) {
4626                 if (j >= (I32)rlen) {
4627                     if (del)
4628                         tbl[i] = -2;
4629                     else if (rlen)
4630                         tbl[i] = r[j-1];
4631                     else
4632                         tbl[i] = (short)i;
4633                 }
4634                 else {
4635                     if (i < 128 && r[j] >= 128)
4636                         grows = 1;
4637                     tbl[i] = r[j++];
4638                 }
4639             }
4640         }
4641         if (!del) {
4642             if (!rlen) {
4643                 j = rlen;
4644                 if (!squash)
4645                     o->op_private |= OPpTRANS_IDENTICAL;
4646             }
4647             else if (j >= (I32)rlen)
4648                 j = rlen - 1;
4649             else {
4650                 tbl = 
4651                     (short *)
4652                     PerlMemShared_realloc(tbl,
4653                                           (0x101+rlen-j) * sizeof(short));
4654                 cPVOPo->op_pv = (char*)tbl;
4655             }
4656             tbl[0x100] = (short)(rlen - j);
4657             for (i=0; i < (I32)rlen - j; i++)
4658                 tbl[0x101+i] = r[j+i];
4659         }
4660     }
4661     else {
4662         if (!rlen && !del) {
4663             r = t; rlen = tlen;
4664             if (!squash)
4665                 o->op_private |= OPpTRANS_IDENTICAL;
4666         }
4667         else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
4668             o->op_private |= OPpTRANS_IDENTICAL;
4669         }
4670         for (i = 0; i < 256; i++)
4671             tbl[i] = -1;
4672         for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
4673             if (j >= (I32)rlen) {
4674                 if (del) {
4675                     if (tbl[t[i]] == -1)
4676                         tbl[t[i]] = -2;
4677                     continue;
4678                 }
4679                 --j;
4680             }
4681             if (tbl[t[i]] == -1) {
4682                 if (t[i] < 128 && r[j] >= 128)
4683                     grows = 1;
4684                 tbl[t[i]] = r[j];
4685             }
4686         }
4687     }
4688
4689     if(del && rlen == tlen) {
4690         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator"); 
4691     } else if(rlen > tlen && !complement) {
4692         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
4693     }
4694
4695     if (grows)
4696         o->op_private |= OPpTRANS_GROWS;
4697 #ifdef PERL_MAD
4698     op_getmad(expr,o,'e');
4699     op_getmad(repl,o,'r');
4700 #else
4701     op_free(expr);
4702     op_free(repl);
4703 #endif
4704
4705     return o;
4706 }
4707
4708 /*
4709 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
4710
4711 Constructs, checks, and returns an op of any pattern matching type.
4712 I<type> is the opcode.  I<flags> gives the eight bits of C<op_flags>
4713 and, shifted up eight bits, the eight bits of C<op_private>.
4714
4715 =cut
4716 */
4717
4718 OP *
4719 Perl_newPMOP(pTHX_ I32 type, I32 flags)
4720 {
4721     dVAR;
4722     PMOP *pmop;
4723
4724     assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP);
4725
4726     NewOp(1101, pmop, 1, PMOP);
4727     pmop->op_type = (OPCODE)type;
4728     pmop->op_ppaddr = PL_ppaddr[type];
4729     pmop->op_flags = (U8)flags;
4730     pmop->op_private = (U8)(0 | (flags >> 8));
4731
4732     if (PL_hints & HINT_RE_TAINT)
4733         pmop->op_pmflags |= PMf_RETAINT;
4734     if (IN_LOCALE_COMPILETIME) {
4735         set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
4736     }
4737     else if ((! (PL_hints & HINT_BYTES))
4738                 /* Both UNI_8_BIT and locale :not_characters imply Unicode */
4739              && (PL_hints & (HINT_UNI_8_BIT|HINT_LOCALE_NOT_CHARS)))
4740     {
4741         set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
4742     }
4743     if (PL_hints & HINT_RE_FLAGS) {
4744         SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
4745          PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags"), 0, 0
4746         );
4747         if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
4748         reflags = Perl_refcounted_he_fetch_pvn(aTHX_
4749          PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
4750         );
4751         if (reflags && SvOK(reflags)) {
4752             set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
4753         }
4754     }
4755
4756
4757 #ifdef USE_ITHREADS
4758     assert(SvPOK(PL_regex_pad[0]));
4759     if (SvCUR(PL_regex_pad[0])) {
4760         /* Pop off the "packed" IV from the end.  */
4761         SV *const repointer_list = PL_regex_pad[0];
4762         const char *p = SvEND(repointer_list) - sizeof(IV);
4763         const IV offset = *((IV*)p);
4764
4765         assert(SvCUR(repointer_list) % sizeof(IV) == 0);
4766
4767         SvEND_set(repointer_list, p);
4768
4769         pmop->op_pmoffset = offset;
4770         /* This slot should be free, so assert this:  */
4771         assert(PL_regex_pad[offset] == &PL_sv_undef);
4772     } else {
4773         SV * const repointer = &PL_sv_undef;
4774         av_push(PL_regex_padav, repointer);
4775         pmop->op_pmoffset = av_tindex(PL_regex_padav);
4776         PL_regex_pad = AvARRAY(PL_regex_padav);
4777     }
4778 #endif
4779
4780     return CHECKOP(type, pmop);
4781 }
4782
4783 /* Given some sort of match op o, and an expression expr containing a
4784  * pattern, either compile expr into a regex and attach it to o (if it's
4785  * constant), or convert expr into a runtime regcomp op sequence (if it's
4786  * not)
4787  *
4788  * isreg indicates that the pattern is part of a regex construct, eg
4789  * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
4790  * split "pattern", which aren't. In the former case, expr will be a list
4791  * if the pattern contains more than one term (eg /a$b/) or if it contains
4792  * a replacement, ie s/// or tr///.
4793  *
4794  * When the pattern has been compiled within a new anon CV (for
4795  * qr/(?{...})/ ), then floor indicates the savestack level just before
4796  * the new sub was created
4797  */
4798
4799 OP *
4800 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor)
4801 {
4802     dVAR;
4803     PMOP *pm;
4804     LOGOP *rcop;
4805     I32 repl_has_vars = 0;
4806     OP* repl = NULL;
4807     bool is_trans = (o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
4808     bool is_compiletime;
4809     bool has_code;
4810
4811     PERL_ARGS_ASSERT_PMRUNTIME;
4812
4813     /* for s/// and tr///, last element in list is the replacement; pop it */
4814
4815     if (is_trans || o->op_type == OP_SUBST) {
4816         OP* kid;
4817         repl = cLISTOPx(expr)->op_last;
4818         kid = cLISTOPx(expr)->op_first;
4819         while (kid->op_sibling != repl)
4820             kid = kid->op_sibling;
4821         kid->op_sibling = NULL;
4822         cLISTOPx(expr)->op_last = kid;
4823     }
4824
4825     /* for TRANS, convert LIST/PUSH/CONST into CONST, and pass to pmtrans() */
4826
4827     if (is_trans) {
4828         OP* const oe = expr;
4829         assert(expr->op_type == OP_LIST);
4830         assert(cLISTOPx(expr)->op_first->op_type == OP_PUSHMARK);
4831         assert(cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last);
4832         expr = cLISTOPx(oe)->op_last;
4833         cLISTOPx(oe)->op_first->op_sibling = NULL;
4834         cLISTOPx(oe)->op_last = NULL;
4835         op_free(oe);
4836
4837         return pmtrans(o, expr, repl);
4838     }
4839
4840     /* find whether we have any runtime or code elements;
4841      * at the same time, temporarily set the op_next of each DO block;
4842      * then when we LINKLIST, this will cause the DO blocks to be excluded
4843      * from the op_next chain (and from having LINKLIST recursively
4844      * applied to them). We fix up the DOs specially later */
4845
4846     is_compiletime = 1;
4847     has_code = 0;
4848     if (expr->op_type == OP_LIST) {
4849         OP *o;
4850         for (o = cLISTOPx(expr)->op_first; o; o = o->op_sibling) {
4851             if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) {
4852                 has_code = 1;
4853                 assert(!o->op_next && o->op_sibling);
4854                 o->op_next = o->op_sibling;
4855             }
4856             else if (o->op_type != OP_CONST && o->op_type != OP_PUSHMARK)
4857                 is_compiletime = 0;
4858         }
4859     }
4860     else if (expr->op_type != OP_CONST)
4861         is_compiletime = 0;