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