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