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