Teach B::Deparse about in-place reverse
[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     /* check for duplicate declaration */
410     pad_check_dup(name, len, is_our ? pad_add_OUR : 0,
411                   (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash));
412
413     /* allocate a spare slot and store the name in that slot */
414
415     off = pad_add_name(name, len,
416                        PL_parser->in_my == KEY_state ? pad_add_STATE : 0,
417                     PL_parser->in_my_stash,
418                     (is_our
419                         /* $_ is always in main::, even with our */
420                         ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
421                         : NULL
422                     )
423     );
424     /* anon sub prototypes contains state vars should always be cloned,
425      * otherwise the state var would be shared between anon subs */
426
427     if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
428         CvCLONE_on(PL_compcv);
429
430     return off;
431 }
432
433 /* free the body of an op without examining its contents.
434  * Always use this rather than FreeOp directly */
435
436 static void
437 S_op_destroy(pTHX_ OP *o)
438 {
439     if (o->op_latefree) {
440         o->op_latefreed = 1;
441         return;
442     }
443     FreeOp(o);
444 }
445
446 #ifdef USE_ITHREADS
447 #  define forget_pmop(a,b)      S_forget_pmop(aTHX_ a,b)
448 #else
449 #  define forget_pmop(a,b)      S_forget_pmop(aTHX_ a)
450 #endif
451
452 /* Destructor */
453
454 void
455 Perl_op_free(pTHX_ OP *o)
456 {
457     dVAR;
458     OPCODE type;
459
460     if (!o)
461         return;
462     if (o->op_latefreed) {
463         if (o->op_latefree)
464             return;
465         goto do_free;
466     }
467
468     type = o->op_type;
469     if (o->op_private & OPpREFCOUNTED) {
470         switch (type) {
471         case OP_LEAVESUB:
472         case OP_LEAVESUBLV:
473         case OP_LEAVEEVAL:
474         case OP_LEAVE:
475         case OP_SCOPE:
476         case OP_LEAVEWRITE:
477             {
478             PADOFFSET refcnt;
479             OP_REFCNT_LOCK;
480             refcnt = OpREFCNT_dec(o);
481             OP_REFCNT_UNLOCK;
482             if (refcnt) {
483                 /* Need to find and remove any pattern match ops from the list
484                    we maintain for reset().  */
485                 find_and_forget_pmops(o);
486                 return;
487             }
488             }
489             break;
490         default:
491             break;
492         }
493     }
494
495     /* Call the op_free hook if it has been set. Do it now so that it's called
496      * at the right time for refcounted ops, but still before all of the kids
497      * are freed. */
498     CALL_OPFREEHOOK(o);
499
500     if (o->op_flags & OPf_KIDS) {
501         register OP *kid, *nextkid;
502         for (kid = cUNOPo->op_first; kid; kid = nextkid) {
503             nextkid = kid->op_sibling; /* Get before next freeing kid */
504             op_free(kid);
505         }
506     }
507
508 #ifdef PERL_DEBUG_READONLY_OPS
509     Slab_to_rw(o);
510 #endif
511
512     /* COP* is not cleared by op_clear() so that we may track line
513      * numbers etc even after null() */
514     if (type == OP_NEXTSTATE || type == OP_DBSTATE
515             || (type == OP_NULL /* the COP might have been null'ed */
516                 && ((OPCODE)o->op_targ == OP_NEXTSTATE
517                     || (OPCODE)o->op_targ == OP_DBSTATE))) {
518         cop_free((COP*)o);
519     }
520
521     if (type == OP_NULL)
522         type = (OPCODE)o->op_targ;
523
524     op_clear(o);
525     if (o->op_latefree) {
526         o->op_latefreed = 1;
527         return;
528     }
529   do_free:
530     FreeOp(o);
531 #ifdef DEBUG_LEAKING_SCALARS
532     if (PL_op == o)
533         PL_op = NULL;
534 #endif
535 }
536
537 void
538 Perl_op_clear(pTHX_ OP *o)
539 {
540
541     dVAR;
542
543     PERL_ARGS_ASSERT_OP_CLEAR;
544
545 #ifdef PERL_MAD
546     /* if (o->op_madprop && o->op_madprop->mad_next)
547        abort(); */
548     /* FIXME for MAD - if I uncomment these two lines t/op/pack.t fails with
549        "modification of a read only value" for a reason I can't fathom why.
550        It's the "" stringification of $_, where $_ was set to '' in a foreach
551        loop, but it defies simplification into a small test case.
552        However, commenting them out has caused ext/List/Util/t/weak.t to fail
553        the last test.  */
554     /*
555       mad_free(o->op_madprop);
556       o->op_madprop = 0;
557     */
558 #endif    
559
560  retry:
561     switch (o->op_type) {
562     case OP_NULL:       /* Was holding old type, if any. */
563         if (PL_madskills && o->op_targ != OP_NULL) {
564             o->op_type = (Optype)o->op_targ;
565             o->op_targ = 0;
566             goto retry;
567         }
568     case OP_ENTEREVAL:  /* Was holding hints. */
569         o->op_targ = 0;
570         break;
571     default:
572         if (!(o->op_flags & OPf_REF)
573             || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
574             break;
575         /* FALL THROUGH */
576     case OP_GVSV:
577     case OP_GV:
578     case OP_AELEMFAST:
579         if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
580             /* not an OP_PADAV replacement */
581             GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV)
582 #ifdef USE_ITHREADS
583                         && PL_curpad
584 #endif
585                         ? cGVOPo_gv : NULL;
586             /* It's possible during global destruction that the GV is freed
587                before the optree. Whilst the SvREFCNT_inc is happy to bump from
588                0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
589                will trigger an assertion failure, because the entry to sv_clear
590                checks that the scalar is not already freed.  A check of for
591                !SvIS_FREED(gv) turns out to be invalid, because during global
592                destruction the reference count can be forced down to zero
593                (with SVf_BREAK set).  In which case raising to 1 and then
594                dropping to 0 triggers cleanup before it should happen.  I
595                *think* that this might actually be a general, systematic,
596                weakness of the whole idea of SVf_BREAK, in that code *is*
597                allowed to raise and lower references during global destruction,
598                so any *valid* code that happens to do this during global
599                destruction might well trigger premature cleanup.  */
600             bool still_valid = gv && SvREFCNT(gv);
601
602             if (still_valid)
603                 SvREFCNT_inc_simple_void(gv);
604 #ifdef USE_ITHREADS
605             if (cPADOPo->op_padix > 0) {
606                 /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
607                  * may still exist on the pad */
608                 pad_swipe(cPADOPo->op_padix, TRUE);
609                 cPADOPo->op_padix = 0;
610             }
611 #else
612             SvREFCNT_dec(cSVOPo->op_sv);
613             cSVOPo->op_sv = NULL;
614 #endif
615             if (still_valid) {
616                 int try_downgrade = SvREFCNT(gv) == 2;
617                 SvREFCNT_dec(gv);
618                 if (try_downgrade)
619                     gv_try_downgrade(gv);
620             }
621         }
622         break;
623     case OP_METHOD_NAMED:
624     case OP_CONST:
625     case OP_HINTSEVAL:
626         SvREFCNT_dec(cSVOPo->op_sv);
627         cSVOPo->op_sv = NULL;
628 #ifdef USE_ITHREADS
629         /** Bug #15654
630           Even if op_clear does a pad_free for the target of the op,
631           pad_free doesn't actually remove the sv that exists in the pad;
632           instead it lives on. This results in that it could be reused as 
633           a target later on when the pad was reallocated.
634         **/
635         if(o->op_targ) {
636           pad_swipe(o->op_targ,1);
637           o->op_targ = 0;
638         }
639 #endif
640         break;
641     case OP_GOTO:
642     case OP_NEXT:
643     case OP_LAST:
644     case OP_REDO:
645         if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
646             break;
647         /* FALL THROUGH */
648     case OP_TRANS:
649         if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
650 #ifdef USE_ITHREADS
651             if (cPADOPo->op_padix > 0) {
652                 pad_swipe(cPADOPo->op_padix, TRUE);
653                 cPADOPo->op_padix = 0;
654             }
655 #else
656             SvREFCNT_dec(cSVOPo->op_sv);
657             cSVOPo->op_sv = NULL;
658 #endif
659         }
660         else {
661             PerlMemShared_free(cPVOPo->op_pv);
662             cPVOPo->op_pv = NULL;
663         }
664         break;
665     case OP_SUBST:
666         op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
667         goto clear_pmop;
668     case OP_PUSHRE:
669 #ifdef USE_ITHREADS
670         if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
671             /* No GvIN_PAD_off here, because other references may still
672              * exist on the pad */
673             pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
674         }
675 #else
676         SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv));
677 #endif
678         /* FALL THROUGH */
679     case OP_MATCH:
680     case OP_QR:
681 clear_pmop:
682         forget_pmop(cPMOPo, 1);
683         cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
684         /* we use the same protection as the "SAFE" version of the PM_ macros
685          * here since sv_clean_all might release some PMOPs
686          * after PL_regex_padav has been cleared
687          * and the clearing of PL_regex_padav needs to
688          * happen before sv_clean_all
689          */
690 #ifdef USE_ITHREADS
691         if(PL_regex_pad) {        /* We could be in destruction */
692             const IV offset = (cPMOPo)->op_pmoffset;
693             ReREFCNT_dec(PM_GETRE(cPMOPo));
694             PL_regex_pad[offset] = &PL_sv_undef;
695             sv_catpvn_nomg(PL_regex_pad[0], (const char *)&offset,
696                            sizeof(offset));
697         }
698 #else
699         ReREFCNT_dec(PM_GETRE(cPMOPo));
700         PM_SETRE(cPMOPo, NULL);
701 #endif
702
703         break;
704     }
705
706     if (o->op_targ > 0) {
707         pad_free(o->op_targ);
708         o->op_targ = 0;
709     }
710 }
711
712 STATIC void
713 S_cop_free(pTHX_ COP* cop)
714 {
715     PERL_ARGS_ASSERT_COP_FREE;
716
717     CopFILE_free(cop);
718     CopSTASH_free(cop);
719     if (! specialWARN(cop->cop_warnings))
720         PerlMemShared_free(cop->cop_warnings);
721     Perl_refcounted_he_free(aTHX_ cop->cop_hints_hash);
722 }
723
724 STATIC void
725 S_forget_pmop(pTHX_ PMOP *const o
726 #ifdef USE_ITHREADS
727               , U32 flags
728 #endif
729               )
730 {
731     HV * const pmstash = PmopSTASH(o);
732
733     PERL_ARGS_ASSERT_FORGET_PMOP;
734
735     if (pmstash && !SvIS_FREED(pmstash)) {
736         MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab);
737         if (mg) {
738             PMOP **const array = (PMOP**) mg->mg_ptr;
739             U32 count = mg->mg_len / sizeof(PMOP**);
740             U32 i = count;
741
742             while (i--) {
743                 if (array[i] == o) {
744                     /* Found it. Move the entry at the end to overwrite it.  */
745                     array[i] = array[--count];
746                     mg->mg_len = count * sizeof(PMOP**);
747                     /* Could realloc smaller at this point always, but probably
748                        not worth it. Probably worth free()ing if we're the
749                        last.  */
750                     if(!count) {
751                         Safefree(mg->mg_ptr);
752                         mg->mg_ptr = NULL;
753                     }
754                     break;
755                 }
756             }
757         }
758     }
759     if (PL_curpm == o) 
760         PL_curpm = NULL;
761 #ifdef USE_ITHREADS
762     if (flags)
763         PmopSTASH_free(o);
764 #endif
765 }
766
767 STATIC void
768 S_find_and_forget_pmops(pTHX_ OP *o)
769 {
770     PERL_ARGS_ASSERT_FIND_AND_FORGET_PMOPS;
771
772     if (o->op_flags & OPf_KIDS) {
773         OP *kid = cUNOPo->op_first;
774         while (kid) {
775             switch (kid->op_type) {
776             case OP_SUBST:
777             case OP_PUSHRE:
778             case OP_MATCH:
779             case OP_QR:
780                 forget_pmop((PMOP*)kid, 0);
781             }
782             find_and_forget_pmops(kid);
783             kid = kid->op_sibling;
784         }
785     }
786 }
787
788 void
789 Perl_op_null(pTHX_ OP *o)
790 {
791     dVAR;
792
793     PERL_ARGS_ASSERT_OP_NULL;
794
795     if (o->op_type == OP_NULL)
796         return;
797     if (!PL_madskills)
798         op_clear(o);
799     o->op_targ = o->op_type;
800     o->op_type = OP_NULL;
801     o->op_ppaddr = PL_ppaddr[OP_NULL];
802 }
803
804 void
805 Perl_op_refcnt_lock(pTHX)
806 {
807     dVAR;
808     PERL_UNUSED_CONTEXT;
809     OP_REFCNT_LOCK;
810 }
811
812 void
813 Perl_op_refcnt_unlock(pTHX)
814 {
815     dVAR;
816     PERL_UNUSED_CONTEXT;
817     OP_REFCNT_UNLOCK;
818 }
819
820 /* Contextualizers */
821
822 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
823
824 static OP *
825 S_linklist(pTHX_ OP *o)
826 {
827     OP *first;
828
829     PERL_ARGS_ASSERT_LINKLIST;
830
831     if (o->op_next)
832         return o->op_next;
833
834     /* establish postfix order */
835     first = cUNOPo->op_first;
836     if (first) {
837         register OP *kid;
838         o->op_next = LINKLIST(first);
839         kid = first;
840         for (;;) {
841             if (kid->op_sibling) {
842                 kid->op_next = LINKLIST(kid->op_sibling);
843                 kid = kid->op_sibling;
844             } else {
845                 kid->op_next = o;
846                 break;
847             }
848         }
849     }
850     else
851         o->op_next = o;
852
853     return o->op_next;
854 }
855
856 static OP *
857 S_scalarkids(pTHX_ OP *o)
858 {
859     if (o && o->op_flags & OPf_KIDS) {
860         OP *kid;
861         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
862             scalar(kid);
863     }
864     return o;
865 }
866
867 STATIC OP *
868 S_scalarboolean(pTHX_ OP *o)
869 {
870     dVAR;
871
872     PERL_ARGS_ASSERT_SCALARBOOLEAN;
873
874     if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
875         if (ckWARN(WARN_SYNTAX)) {
876             const line_t oldline = CopLINE(PL_curcop);
877
878             if (PL_parser && PL_parser->copline != NOLINE)
879                 CopLINE_set(PL_curcop, PL_parser->copline);
880             Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
881             CopLINE_set(PL_curcop, oldline);
882         }
883     }
884     return scalar(o);
885 }
886
887 OP *
888 Perl_scalar(pTHX_ OP *o)
889 {
890     dVAR;
891     OP *kid;
892
893     /* assumes no premature commitment */
894     if (!o || (PL_parser && PL_parser->error_count)
895          || (o->op_flags & OPf_WANT)
896          || o->op_type == OP_RETURN)
897     {
898         return o;
899     }
900
901     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
902
903     switch (o->op_type) {
904     case OP_REPEAT:
905         scalar(cBINOPo->op_first);
906         break;
907     case OP_OR:
908     case OP_AND:
909     case OP_COND_EXPR:
910         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
911             scalar(kid);
912         break;
913         /* FALL THROUGH */
914     case OP_SPLIT:
915     case OP_MATCH:
916     case OP_QR:
917     case OP_SUBST:
918     case OP_NULL:
919     default:
920         if (o->op_flags & OPf_KIDS) {
921             for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
922                 scalar(kid);
923         }
924         break;
925     case OP_LEAVE:
926     case OP_LEAVETRY:
927         kid = cLISTOPo->op_first;
928         scalar(kid);
929         while ((kid = kid->op_sibling)) {
930             if (kid->op_sibling)
931                 scalarvoid(kid);
932             else
933                 scalar(kid);
934         }
935         PL_curcop = &PL_compiling;
936         break;
937     case OP_SCOPE:
938     case OP_LINESEQ:
939     case OP_LIST:
940         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
941             if (kid->op_sibling)
942                 scalarvoid(kid);
943             else
944                 scalar(kid);
945         }
946         PL_curcop = &PL_compiling;
947         break;
948     case OP_SORT:
949         Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
950         break;
951     }
952     return o;
953 }
954
955 OP *
956 Perl_scalarvoid(pTHX_ OP *o)
957 {
958     dVAR;
959     OP *kid;
960     const char* useless = NULL;
961     SV* sv;
962     U8 want;
963
964     PERL_ARGS_ASSERT_SCALARVOID;
965
966     /* trailing mad null ops don't count as "there" for void processing */
967     if (PL_madskills &&
968         o->op_type != OP_NULL &&
969         o->op_sibling &&
970         o->op_sibling->op_type == OP_NULL)
971     {
972         OP *sib;
973         for (sib = o->op_sibling;
974                 sib && sib->op_type == OP_NULL;
975                 sib = sib->op_sibling) ;
976         
977         if (!sib)
978             return o;
979     }
980
981     if (o->op_type == OP_NEXTSTATE
982         || o->op_type == OP_DBSTATE
983         || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
984                                       || o->op_targ == OP_DBSTATE)))
985         PL_curcop = (COP*)o;            /* for warning below */
986
987     /* assumes no premature commitment */
988     want = o->op_flags & OPf_WANT;
989     if ((want && want != OPf_WANT_SCALAR)
990          || (PL_parser && PL_parser->error_count)
991          || o->op_type == OP_RETURN)
992     {
993         return o;
994     }
995
996     if ((o->op_private & OPpTARGET_MY)
997         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
998     {
999         return scalar(o);                       /* As if inside SASSIGN */
1000     }
1001
1002     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1003
1004     switch (o->op_type) {
1005     default:
1006         if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1007             break;
1008         /* FALL THROUGH */
1009     case OP_REPEAT:
1010         if (o->op_flags & OPf_STACKED)
1011             break;
1012         goto func_ops;
1013     case OP_SUBSTR:
1014         if (o->op_private == 4)
1015             break;
1016         /* FALL THROUGH */
1017     case OP_GVSV:
1018     case OP_WANTARRAY:
1019     case OP_GV:
1020     case OP_SMARTMATCH:
1021     case OP_PADSV:
1022     case OP_PADAV:
1023     case OP_PADHV:
1024     case OP_PADANY:
1025     case OP_AV2ARYLEN:
1026     case OP_REF:
1027     case OP_REFGEN:
1028     case OP_SREFGEN:
1029     case OP_DEFINED:
1030     case OP_HEX:
1031     case OP_OCT:
1032     case OP_LENGTH:
1033     case OP_VEC:
1034     case OP_INDEX:
1035     case OP_RINDEX:
1036     case OP_SPRINTF:
1037     case OP_AELEM:
1038     case OP_AELEMFAST:
1039     case OP_ASLICE:
1040     case OP_HELEM:
1041     case OP_HSLICE:
1042     case OP_UNPACK:
1043     case OP_PACK:
1044     case OP_JOIN:
1045     case OP_LSLICE:
1046     case OP_ANONLIST:
1047     case OP_ANONHASH:
1048     case OP_SORT:
1049     case OP_REVERSE:
1050     case OP_RANGE:
1051     case OP_FLIP:
1052     case OP_FLOP:
1053     case OP_CALLER:
1054     case OP_FILENO:
1055     case OP_EOF:
1056     case OP_TELL:
1057     case OP_GETSOCKNAME:
1058     case OP_GETPEERNAME:
1059     case OP_READLINK:
1060     case OP_TELLDIR:
1061     case OP_GETPPID:
1062     case OP_GETPGRP:
1063     case OP_GETPRIORITY:
1064     case OP_TIME:
1065     case OP_TMS:
1066     case OP_LOCALTIME:
1067     case OP_GMTIME:
1068     case OP_GHBYNAME:
1069     case OP_GHBYADDR:
1070     case OP_GHOSTENT:
1071     case OP_GNBYNAME:
1072     case OP_GNBYADDR:
1073     case OP_GNETENT:
1074     case OP_GPBYNAME:
1075     case OP_GPBYNUMBER:
1076     case OP_GPROTOENT:
1077     case OP_GSBYNAME:
1078     case OP_GSBYPORT:
1079     case OP_GSERVENT:
1080     case OP_GPWNAM:
1081     case OP_GPWUID:
1082     case OP_GGRNAM:
1083     case OP_GGRGID:
1084     case OP_GETLOGIN:
1085     case OP_PROTOTYPE:
1086       func_ops:
1087         if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1088             /* Otherwise it's "Useless use of grep iterator" */
1089             useless = OP_DESC(o);
1090         break;
1091
1092     case OP_NOT:
1093        kid = cUNOPo->op_first;
1094        if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
1095            kid->op_type != OP_TRANS) {
1096                 goto func_ops;
1097        }
1098        useless = "negative pattern binding (!~)";
1099        break;
1100
1101     case OP_RV2GV:
1102     case OP_RV2SV:
1103     case OP_RV2AV:
1104     case OP_RV2HV:
1105         if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1106                 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1107             useless = "a variable";
1108         break;
1109
1110     case OP_CONST:
1111         sv = cSVOPo_sv;
1112         if (cSVOPo->op_private & OPpCONST_STRICT)
1113             no_bareword_allowed(o);
1114         else {
1115             if (ckWARN(WARN_VOID)) {
1116                 if (SvOK(sv)) {
1117                     SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_
1118                                 "a constant (%"SVf")", sv));
1119                     useless = SvPV_nolen(msv);
1120                 }
1121                 else
1122                     useless = "a constant (undef)";
1123                 if (o->op_private & OPpCONST_ARYBASE)
1124                     useless = NULL;
1125                 /* don't warn on optimised away booleans, eg 
1126                  * use constant Foo, 5; Foo || print; */
1127                 if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
1128                     useless = NULL;
1129                 /* the constants 0 and 1 are permitted as they are
1130                    conventionally used as dummies in constructs like
1131                         1 while some_condition_with_side_effects;  */
1132                 else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1133                     useless = NULL;
1134                 else if (SvPOK(sv)) {
1135                   /* perl4's way of mixing documentation and code
1136                      (before the invention of POD) was based on a
1137                      trick to mix nroff and perl code. The trick was
1138                      built upon these three nroff macros being used in
1139                      void context. The pink camel has the details in
1140                      the script wrapman near page 319. */
1141                     const char * const maybe_macro = SvPVX_const(sv);
1142                     if (strnEQ(maybe_macro, "di", 2) ||
1143                         strnEQ(maybe_macro, "ds", 2) ||
1144                         strnEQ(maybe_macro, "ig", 2))
1145                             useless = NULL;
1146                 }
1147             }
1148         }
1149         op_null(o);             /* don't execute or even remember it */
1150         break;
1151
1152     case OP_POSTINC:
1153         o->op_type = OP_PREINC;         /* pre-increment is faster */
1154         o->op_ppaddr = PL_ppaddr[OP_PREINC];
1155         break;
1156
1157     case OP_POSTDEC:
1158         o->op_type = OP_PREDEC;         /* pre-decrement is faster */
1159         o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1160         break;
1161
1162     case OP_I_POSTINC:
1163         o->op_type = OP_I_PREINC;       /* pre-increment is faster */
1164         o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
1165         break;
1166
1167     case OP_I_POSTDEC:
1168         o->op_type = OP_I_PREDEC;       /* pre-decrement is faster */
1169         o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
1170         break;
1171
1172     case OP_OR:
1173     case OP_AND:
1174         kid = cLOGOPo->op_first;
1175         if (kid->op_type == OP_NOT
1176             && (kid->op_flags & OPf_KIDS)
1177             && !PL_madskills) {
1178             if (o->op_type == OP_AND) {
1179                 o->op_type = OP_OR;
1180                 o->op_ppaddr = PL_ppaddr[OP_OR];
1181             } else {
1182                 o->op_type = OP_AND;
1183                 o->op_ppaddr = PL_ppaddr[OP_AND];
1184             }
1185             op_null(kid);
1186         }
1187
1188     case OP_DOR:
1189     case OP_COND_EXPR:
1190     case OP_ENTERGIVEN:
1191     case OP_ENTERWHEN:
1192         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1193             scalarvoid(kid);
1194         break;
1195
1196     case OP_NULL:
1197         if (o->op_flags & OPf_STACKED)
1198             break;
1199         /* FALL THROUGH */
1200     case OP_NEXTSTATE:
1201     case OP_DBSTATE:
1202     case OP_ENTERTRY:
1203     case OP_ENTER:
1204         if (!(o->op_flags & OPf_KIDS))
1205             break;
1206         /* FALL THROUGH */
1207     case OP_SCOPE:
1208     case OP_LEAVE:
1209     case OP_LEAVETRY:
1210     case OP_LEAVELOOP:
1211     case OP_LINESEQ:
1212     case OP_LIST:
1213     case OP_LEAVEGIVEN:
1214     case OP_LEAVEWHEN:
1215         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1216             scalarvoid(kid);
1217         break;
1218     case OP_ENTEREVAL:
1219         scalarkids(o);
1220         break;
1221     case OP_REQUIRE:
1222         /* all requires must return a boolean value */
1223         o->op_flags &= ~OPf_WANT;
1224         /* FALL THROUGH */
1225     case OP_SCALAR:
1226         return scalar(o);
1227     }
1228     if (useless)
1229         Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
1230     return o;
1231 }
1232
1233 static OP *
1234 S_listkids(pTHX_ OP *o)
1235 {
1236     if (o && o->op_flags & OPf_KIDS) {
1237         OP *kid;
1238         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1239             list(kid);
1240     }
1241     return o;
1242 }
1243
1244 OP *
1245 Perl_list(pTHX_ OP *o)
1246 {
1247     dVAR;
1248     OP *kid;
1249
1250     /* assumes no premature commitment */
1251     if (!o || (o->op_flags & OPf_WANT)
1252          || (PL_parser && PL_parser->error_count)
1253          || o->op_type == OP_RETURN)
1254     {
1255         return o;
1256     }
1257
1258     if ((o->op_private & OPpTARGET_MY)
1259         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1260     {
1261         return o;                               /* As if inside SASSIGN */
1262     }
1263
1264     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1265
1266     switch (o->op_type) {
1267     case OP_FLOP:
1268     case OP_REPEAT:
1269         list(cBINOPo->op_first);
1270         break;
1271     case OP_OR:
1272     case OP_AND:
1273     case OP_COND_EXPR:
1274         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1275             list(kid);
1276         break;
1277     default:
1278     case OP_MATCH:
1279     case OP_QR:
1280     case OP_SUBST:
1281     case OP_NULL:
1282         if (!(o->op_flags & OPf_KIDS))
1283             break;
1284         if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1285             list(cBINOPo->op_first);
1286             return gen_constant_list(o);
1287         }
1288     case OP_LIST:
1289         listkids(o);
1290         break;
1291     case OP_LEAVE:
1292     case OP_LEAVETRY:
1293         kid = cLISTOPo->op_first;
1294         list(kid);
1295         while ((kid = kid->op_sibling)) {
1296             if (kid->op_sibling)
1297                 scalarvoid(kid);
1298             else
1299                 list(kid);
1300         }
1301         PL_curcop = &PL_compiling;
1302         break;
1303     case OP_SCOPE:
1304     case OP_LINESEQ:
1305         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1306             if (kid->op_sibling)
1307                 scalarvoid(kid);
1308             else
1309                 list(kid);
1310         }
1311         PL_curcop = &PL_compiling;
1312         break;
1313     case OP_REQUIRE:
1314         /* all requires must return a boolean value */
1315         o->op_flags &= ~OPf_WANT;
1316         return scalar(o);
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     NewOp(1101, listop, 1, LISTOP);
3027
3028     listop->op_type = (OPCODE)type;
3029     listop->op_ppaddr = PL_ppaddr[type];
3030     if (first || last)
3031         flags |= OPf_KIDS;
3032     listop->op_flags = (U8)flags;
3033
3034     if (!last && first)
3035         last = first;
3036     else if (!first && last)
3037         first = last;
3038     else if (first)
3039         first->op_sibling = last;
3040     listop->op_first = first;
3041     listop->op_last = last;
3042     if (type == OP_LIST) {
3043         OP* const pushop = newOP(OP_PUSHMARK, 0);
3044         pushop->op_sibling = first;
3045         listop->op_first = pushop;
3046         listop->op_flags |= OPf_KIDS;
3047         if (!last)
3048             listop->op_last = pushop;
3049     }
3050
3051     return CHECKOP(type, listop);
3052 }
3053
3054 OP *
3055 Perl_newOP(pTHX_ I32 type, I32 flags)
3056 {
3057     dVAR;
3058     OP *o;
3059     NewOp(1101, o, 1, OP);
3060     o->op_type = (OPCODE)type;
3061     o->op_ppaddr = PL_ppaddr[type];
3062     o->op_flags = (U8)flags;
3063     o->op_latefree = 0;
3064     o->op_latefreed = 0;
3065     o->op_attached = 0;
3066
3067     o->op_next = o;
3068     o->op_private = (U8)(0 | (flags >> 8));
3069     if (PL_opargs[type] & OA_RETSCALAR)
3070         scalar(o);
3071     if (PL_opargs[type] & OA_TARGET)
3072         o->op_targ = pad_alloc(type, SVs_PADTMP);
3073     return CHECKOP(type, o);
3074 }
3075
3076 OP *
3077 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
3078 {
3079     dVAR;
3080     UNOP *unop;
3081
3082     if (!first)
3083         first = newOP(OP_STUB, 0);
3084     if (PL_opargs[type] & OA_MARK)
3085         first = force_list(first);
3086
3087     NewOp(1101, unop, 1, UNOP);
3088     unop->op_type = (OPCODE)type;
3089     unop->op_ppaddr = PL_ppaddr[type];
3090     unop->op_first = first;
3091     unop->op_flags = (U8)(flags | OPf_KIDS);
3092     unop->op_private = (U8)(1 | (flags >> 8));
3093     unop = (UNOP*) CHECKOP(type, unop);
3094     if (unop->op_next)
3095         return (OP*)unop;
3096
3097     return fold_constants((OP *) unop);
3098 }
3099
3100 OP *
3101 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
3102 {
3103     dVAR;
3104     BINOP *binop;
3105     NewOp(1101, binop, 1, BINOP);
3106
3107     if (!first)
3108         first = newOP(OP_NULL, 0);
3109
3110     binop->op_type = (OPCODE)type;
3111     binop->op_ppaddr = PL_ppaddr[type];
3112     binop->op_first = first;
3113     binop->op_flags = (U8)(flags | OPf_KIDS);
3114     if (!last) {
3115         last = first;
3116         binop->op_private = (U8)(1 | (flags >> 8));
3117     }
3118     else {
3119         binop->op_private = (U8)(2 | (flags >> 8));
3120         first->op_sibling = last;
3121     }
3122
3123     binop = (BINOP*)CHECKOP(type, binop);
3124     if (binop->op_next || binop->op_type != (OPCODE)type)
3125         return (OP*)binop;
3126
3127     binop->op_last = binop->op_first->op_sibling;
3128
3129     return fold_constants((OP *)binop);
3130 }
3131
3132 static int uvcompare(const void *a, const void *b)
3133     __attribute__nonnull__(1)
3134     __attribute__nonnull__(2)
3135     __attribute__pure__;
3136 static int uvcompare(const void *a, const void *b)
3137 {
3138     if (*((const UV *)a) < (*(const UV *)b))
3139         return -1;
3140     if (*((const UV *)a) > (*(const UV *)b))
3141         return 1;
3142     if (*((const UV *)a+1) < (*(const UV *)b+1))
3143         return -1;
3144     if (*((const UV *)a+1) > (*(const UV *)b+1))
3145         return 1;
3146     return 0;
3147 }
3148
3149 static OP *
3150 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
3151 {
3152     dVAR;
3153     SV * const tstr = ((SVOP*)expr)->op_sv;
3154     SV * const rstr =
3155 #ifdef PERL_MAD
3156                         (repl->op_type == OP_NULL)
3157                             ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv :
3158 #endif
3159                               ((SVOP*)repl)->op_sv;
3160     STRLEN tlen;
3161     STRLEN rlen;
3162     const U8 *t = (U8*)SvPV_const(tstr, tlen);
3163     const U8 *r = (U8*)SvPV_const(rstr, rlen);
3164     register I32 i;
3165     register I32 j;
3166     I32 grows = 0;
3167     register short *tbl;
3168
3169     const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
3170     const I32 squash     = o->op_private & OPpTRANS_SQUASH;
3171     I32 del              = o->op_private & OPpTRANS_DELETE;
3172     SV* swash;
3173
3174     PERL_ARGS_ASSERT_PMTRANS;
3175
3176     PL_hints |= HINT_BLOCK_SCOPE;
3177
3178     if (SvUTF8(tstr))
3179         o->op_private |= OPpTRANS_FROM_UTF;
3180
3181     if (SvUTF8(rstr))
3182         o->op_private |= OPpTRANS_TO_UTF;
3183
3184     if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
3185         SV* const listsv = newSVpvs("# comment\n");
3186         SV* transv = NULL;
3187         const U8* tend = t + tlen;
3188         const U8* rend = r + rlen;
3189         STRLEN ulen;
3190         UV tfirst = 1;
3191         UV tlast = 0;
3192         IV tdiff;
3193         UV rfirst = 1;
3194         UV rlast = 0;
3195         IV rdiff;
3196         IV diff;
3197         I32 none = 0;
3198         U32 max = 0;
3199         I32 bits;
3200         I32 havefinal = 0;
3201         U32 final = 0;
3202         const I32 from_utf  = o->op_private & OPpTRANS_FROM_UTF;
3203         const I32 to_utf    = o->op_private & OPpTRANS_TO_UTF;
3204         U8* tsave = NULL;
3205         U8* rsave = NULL;
3206         const U32 flags = UTF8_ALLOW_DEFAULT;
3207
3208         if (!from_utf) {
3209             STRLEN len = tlen;
3210             t = tsave = bytes_to_utf8(t, &len);
3211             tend = t + len;
3212         }
3213         if (!to_utf && rlen) {
3214             STRLEN len = rlen;
3215             r = rsave = bytes_to_utf8(r, &len);
3216             rend = r + len;
3217         }
3218
3219 /* There are several snags with this code on EBCDIC:
3220    1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
3221    2. scan_const() in toke.c has encoded chars in native encoding which makes
3222       ranges at least in EBCDIC 0..255 range the bottom odd.
3223 */
3224
3225         if (complement) {
3226             U8 tmpbuf[UTF8_MAXBYTES+1];
3227             UV *cp;
3228             UV nextmin = 0;
3229             Newx(cp, 2*tlen, UV);
3230             i = 0;
3231             transv = newSVpvs("");
3232             while (t < tend) {
3233                 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3234                 t += ulen;
3235                 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
3236                     t++;
3237                     cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
3238                     t += ulen;
3239                 }
3240                 else {
3241                  cp[2*i+1] = cp[2*i];
3242                 }
3243                 i++;
3244             }
3245             qsort(cp, i, 2*sizeof(UV), uvcompare);
3246             for (j = 0; j < i; j++) {
3247                 UV  val = cp[2*j];
3248                 diff = val - nextmin;
3249                 if (diff > 0) {
3250                     t = uvuni_to_utf8(tmpbuf,nextmin);
3251                     sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3252                     if (diff > 1) {
3253                         U8  range_mark = UTF_TO_NATIVE(0xff);
3254                         t = uvuni_to_utf8(tmpbuf, val - 1);
3255                         sv_catpvn(transv, (char *)&range_mark, 1);
3256                         sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3257                     }
3258                 }
3259                 val = cp[2*j+1];
3260                 if (val >= nextmin)
3261                     nextmin = val + 1;
3262             }
3263             t = uvuni_to_utf8(tmpbuf,nextmin);
3264             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3265             {
3266                 U8 range_mark = UTF_TO_NATIVE(0xff);
3267                 sv_catpvn(transv, (char *)&range_mark, 1);
3268             }
3269             t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
3270                                     UNICODE_ALLOW_SUPER);
3271             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
3272             t = (const U8*)SvPVX_const(transv);
3273             tlen = SvCUR(transv);
3274             tend = t + tlen;
3275             Safefree(cp);
3276         }
3277         else if (!rlen && !del) {
3278             r = t; rlen = tlen; rend = tend;
3279         }
3280         if (!squash) {
3281                 if ((!rlen && !del) || t == r ||
3282                     (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
3283                 {
3284                     o->op_private |= OPpTRANS_IDENTICAL;
3285                 }
3286         }
3287
3288         while (t < tend || tfirst <= tlast) {
3289             /* see if we need more "t" chars */
3290             if (tfirst > tlast) {
3291                 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3292                 t += ulen;
3293                 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {    /* illegal utf8 val indicates range */
3294                     t++;
3295                     tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
3296                     t += ulen;
3297                 }
3298                 else
3299                     tlast = tfirst;
3300             }
3301
3302             /* now see if we need more "r" chars */
3303             if (rfirst > rlast) {
3304                 if (r < rend) {
3305                     rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3306                     r += ulen;
3307                     if (r < rend && NATIVE_TO_UTF(*r) == 0xff) {        /* illegal utf8 val indicates range */
3308                         r++;
3309                         rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
3310                         r += ulen;
3311                     }
3312                     else
3313                         rlast = rfirst;
3314                 }
3315                 else {
3316                     if (!havefinal++)
3317                         final = rlast;
3318                     rfirst = rlast = 0xffffffff;
3319                 }
3320             }
3321
3322             /* now see which range will peter our first, if either. */
3323             tdiff = tlast - tfirst;
3324             rdiff = rlast - rfirst;
3325
3326             if (tdiff <= rdiff)
3327                 diff = tdiff;
3328             else
3329                 diff = rdiff;
3330
3331             if (rfirst == 0xffffffff) {
3332                 diff = tdiff;   /* oops, pretend rdiff is infinite */
3333                 if (diff > 0)
3334                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
3335                                    (long)tfirst, (long)tlast);
3336                 else
3337                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
3338             }
3339             else {
3340                 if (diff > 0)
3341                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
3342                                    (long)tfirst, (long)(tfirst + diff),
3343                                    (long)rfirst);
3344                 else
3345                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
3346                                    (long)tfirst, (long)rfirst);
3347
3348                 if (rfirst + diff > max)
3349                     max = rfirst + diff;
3350                 if (!grows)
3351                     grows = (tfirst < rfirst &&
3352                              UNISKIP(tfirst) < UNISKIP(rfirst + diff));
3353                 rfirst += diff + 1;
3354             }
3355             tfirst += diff + 1;
3356         }
3357
3358         none = ++max;
3359         if (del)
3360             del = ++max;
3361
3362         if (max > 0xffff)
3363             bits = 32;
3364         else if (max > 0xff)
3365             bits = 16;
3366         else
3367             bits = 8;
3368
3369         PerlMemShared_free(cPVOPo->op_pv);
3370         cPVOPo->op_pv = NULL;
3371
3372         swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
3373 #ifdef USE_ITHREADS
3374         cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
3375         SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
3376         PAD_SETSV(cPADOPo->op_padix, swash);
3377         SvPADTMP_on(swash);
3378         SvREADONLY_on(swash);
3379 #else
3380         cSVOPo->op_sv = swash;
3381 #endif
3382         SvREFCNT_dec(listsv);
3383         SvREFCNT_dec(transv);
3384
3385         if (!del && havefinal && rlen)
3386             (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5,
3387                            newSVuv((UV)final), 0);
3388
3389         if (grows)
3390             o->op_private |= OPpTRANS_GROWS;
3391
3392         Safefree(tsave);
3393         Safefree(rsave);
3394
3395 #ifdef PERL_MAD
3396         op_getmad(expr,o,'e');
3397         op_getmad(repl,o,'r');
3398 #else
3399         op_free(expr);
3400         op_free(repl);
3401 #endif
3402         return o;
3403     }
3404
3405     tbl = (short*)cPVOPo->op_pv;
3406     if (complement) {
3407         Zero(tbl, 256, short);
3408         for (i = 0; i < (I32)tlen; i++)
3409             tbl[t[i]] = -1;
3410         for (i = 0, j = 0; i < 256; i++) {
3411             if (!tbl[i]) {
3412                 if (j >= (I32)rlen) {
3413                     if (del)
3414                         tbl[i] = -2;
3415                     else if (rlen)
3416                         tbl[i] = r[j-1];
3417                     else
3418                         tbl[i] = (short)i;
3419                 }
3420                 else {
3421                     if (i < 128 && r[j] >= 128)
3422                         grows = 1;
3423                     tbl[i] = r[j++];
3424                 }
3425             }
3426         }
3427         if (!del) {
3428             if (!rlen) {
3429                 j = rlen;
3430                 if (!squash)
3431                     o->op_private |= OPpTRANS_IDENTICAL;
3432             }
3433             else if (j >= (I32)rlen)
3434                 j = rlen - 1;
3435             else {
3436                 tbl = 
3437                     (short *)
3438                     PerlMemShared_realloc(tbl,
3439                                           (0x101+rlen-j) * sizeof(short));
3440                 cPVOPo->op_pv = (char*)tbl;
3441             }
3442             tbl[0x100] = (short)(rlen - j);
3443             for (i=0; i < (I32)rlen - j; i++)
3444                 tbl[0x101+i] = r[j+i];
3445         }
3446     }
3447     else {
3448         if (!rlen && !del) {
3449             r = t; rlen = tlen;
3450             if (!squash)
3451                 o->op_private |= OPpTRANS_IDENTICAL;
3452         }
3453         else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3454             o->op_private |= OPpTRANS_IDENTICAL;
3455         }
3456         for (i = 0; i < 256; i++)
3457             tbl[i] = -1;
3458         for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3459             if (j >= (I32)rlen) {
3460                 if (del) {
3461                     if (tbl[t[i]] == -1)
3462                         tbl[t[i]] = -2;
3463                     continue;
3464                 }
3465                 --j;
3466             }
3467             if (tbl[t[i]] == -1) {
3468                 if (t[i] < 128 && r[j] >= 128)
3469                     grows = 1;
3470                 tbl[t[i]] = r[j];
3471             }
3472         }
3473     }
3474
3475     if(del && rlen == tlen) {
3476         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator"); 
3477     } else if(rlen > tlen) {
3478         Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
3479     }
3480
3481     if (grows)
3482         o->op_private |= OPpTRANS_GROWS;
3483 #ifdef PERL_MAD
3484     op_getmad(expr,o,'e');
3485     op_getmad(repl,o,'r');
3486 #else
3487     op_free(expr);
3488     op_free(repl);
3489 #endif
3490
3491     return o;
3492 }
3493
3494 OP *
3495 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3496 {
3497     dVAR;
3498     PMOP *pmop;
3499
3500     NewOp(1101, pmop, 1, PMOP);
3501     pmop->op_type = (OPCODE)type;
3502     pmop->op_ppaddr = PL_ppaddr[type];
3503     pmop->op_flags = (U8)flags;
3504     pmop->op_private = (U8)(0 | (flags >> 8));
3505
3506     if (PL_hints & HINT_RE_TAINT)
3507         pmop->op_pmflags |= PMf_RETAINT;
3508     if (PL_hints & HINT_LOCALE)
3509         pmop->op_pmflags |= PMf_LOCALE;
3510
3511
3512 #ifdef USE_ITHREADS
3513     assert(SvPOK(PL_regex_pad[0]));
3514     if (SvCUR(PL_regex_pad[0])) {
3515         /* Pop off the "packed" IV from the end.  */
3516         SV *const repointer_list = PL_regex_pad[0];
3517         const char *p = SvEND(repointer_list) - sizeof(IV);
3518         const IV offset = *((IV*)p);
3519
3520         assert(SvCUR(repointer_list) % sizeof(IV) == 0);
3521
3522         SvEND_set(repointer_list, p);
3523
3524         pmop->op_pmoffset = offset;
3525         /* This slot should be free, so assert this:  */
3526         assert(PL_regex_pad[offset] == &PL_sv_undef);
3527     } else {
3528         SV * const repointer = &PL_sv_undef;
3529         av_push(PL_regex_padav, repointer);
3530         pmop->op_pmoffset = av_len(PL_regex_padav);
3531         PL_regex_pad = AvARRAY(PL_regex_padav);
3532     }
3533 #endif
3534
3535     return CHECKOP(type, pmop);
3536 }
3537
3538 /* Given some sort of match op o, and an expression expr containing a
3539  * pattern, either compile expr into a regex and attach it to o (if it's
3540  * constant), or convert expr into a runtime regcomp op sequence (if it's
3541  * not)
3542  *
3543  * isreg indicates that the pattern is part of a regex construct, eg
3544  * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3545  * split "pattern", which aren't. In the former case, expr will be a list
3546  * if the pattern contains more than one term (eg /a$b/) or if it contains
3547  * a replacement, ie s/// or tr///.
3548  */
3549
3550 OP *
3551 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
3552 {
3553     dVAR;
3554     PMOP *pm;
3555     LOGOP *rcop;
3556     I32 repl_has_vars = 0;
3557     OP* repl = NULL;
3558     bool reglist;
3559
3560     PERL_ARGS_ASSERT_PMRUNTIME;
3561
3562     if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
3563         /* last element in list is the replacement; pop it */
3564         OP* kid;
3565         repl = cLISTOPx(expr)->op_last;
3566         kid = cLISTOPx(expr)->op_first;
3567         while (kid->op_sibling != repl)
3568             kid = kid->op_sibling;
3569         kid->op_sibling = NULL;
3570         cLISTOPx(expr)->op_last = kid;
3571     }
3572
3573     if (isreg && expr->op_type == OP_LIST &&
3574         cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3575     {
3576         /* convert single element list to element */
3577         OP* const oe = expr;
3578         expr = cLISTOPx(oe)->op_first->op_sibling;
3579         cLISTOPx(oe)->op_first->op_sibling = NULL;
3580         cLISTOPx(oe)->op_last = NULL;
3581         op_free(oe);
3582     }
3583
3584     if (o->op_type == OP_TRANS) {
3585         return pmtrans(o, expr, repl);
3586     }
3587
3588     reglist = isreg && expr->op_type == OP_LIST;
3589     if (reglist)
3590         op_null(expr);
3591
3592     PL_hints |= HINT_BLOCK_SCOPE;
3593     pm = (PMOP*)o;
3594
3595     if (expr->op_type == OP_CONST) {
3596         SV *pat = ((SVOP*)expr)->op_sv;
3597         U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
3598
3599         if (o->op_flags & OPf_SPECIAL)
3600             pm_flags |= RXf_SPLIT;
3601
3602         if (DO_UTF8(pat)) {
3603             assert (SvUTF8(pat));
3604         } else if (SvUTF8(pat)) {
3605             /* Not doing UTF-8, despite what the SV says. Is this only if we're
3606                trapped in use 'bytes'?  */
3607             /* Make a copy of the octet sequence, but without the flag on, as
3608                the compiler now honours the SvUTF8 flag on pat.  */
3609             STRLEN len;
3610             const char *const p = SvPV(pat, len);
3611             pat = newSVpvn_flags(p, len, SVs_TEMP);
3612         }
3613
3614         PM_SETRE(pm, CALLREGCOMP(pat, pm_flags));
3615
3616 #ifdef PERL_MAD
3617         op_getmad(expr,(OP*)pm,'e');
3618 #else
3619         op_free(expr);
3620 #endif
3621     }
3622     else {
3623         if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3624             expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3625                             ? OP_REGCRESET
3626                             : OP_REGCMAYBE),0,expr);
3627
3628         NewOp(1101, rcop, 1, LOGOP);
3629         rcop->op_type = OP_REGCOMP;
3630         rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3631         rcop->op_first = scalar(expr);
3632         rcop->op_flags |= OPf_KIDS
3633                             | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3634                             | (reglist ? OPf_STACKED : 0);
3635         rcop->op_private = 1;
3636         rcop->op_other = o;
3637         if (reglist)
3638             rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3639
3640         /* /$x/ may cause an eval, since $x might be qr/(?{..})/  */
3641         PL_cv_has_eval = 1;
3642
3643         /* establish postfix order */
3644         if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3645             LINKLIST(expr);
3646             rcop->op_next = expr;
3647             ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3648         }
3649         else {
3650             rcop->op_next = LINKLIST(expr);
3651             expr->op_next = (OP*)rcop;
3652         }
3653
3654         prepend_elem(o->op_type, scalar((OP*)rcop), o);
3655     }
3656
3657     if (repl) {
3658         OP *curop;
3659         if (pm->op_pmflags & PMf_EVAL) {
3660             curop = NULL;
3661             if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
3662                 CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
3663         }
3664         else if (repl->op_type == OP_CONST)
3665             curop = repl;
3666         else {
3667             OP *lastop = NULL;
3668             for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3669                 if (curop->op_type == OP_SCOPE
3670                         || curop->op_type == OP_LEAVE
3671                         || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
3672                     if (curop->op_type == OP_GV) {
3673                         GV * const gv = cGVOPx_gv(curop);
3674                         repl_has_vars = 1;
3675                         if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3676                             break;
3677                     }
3678                     else if (curop->op_type == OP_RV2CV)
3679                         break;
3680                     else if (curop->op_type == OP_RV2SV ||
3681                              curop->op_type == OP_RV2AV ||
3682                              curop->op_type == OP_RV2HV ||
3683                              curop->op_type == OP_RV2GV) {
3684                         if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3685                             break;
3686                     }
3687                     else if (curop->op_type == OP_PADSV ||
3688                              curop->op_type == OP_PADAV ||
3689                              curop->op_type == OP_PADHV ||
3690                              curop->op_type == OP_PADANY)
3691                     {
3692                         repl_has_vars = 1;
3693                     }
3694                     else if (curop->op_type == OP_PUSHRE)
3695                         NOOP; /* Okay here, dangerous in newASSIGNOP */
3696                     else
3697                         break;
3698                 }
3699                 lastop = curop;
3700             }
3701         }
3702         if (curop == repl
3703             && !(repl_has_vars
3704                  && (!PM_GETRE(pm)
3705                      || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
3706         {
3707             pm->op_pmflags |= PMf_CONST;        /* const for long enough */
3708             prepend_elem(o->op_type, scalar(repl), o);
3709         }
3710         else {
3711             if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3712                 pm->op_pmflags |= PMf_MAYBE_CONST;
3713             }
3714             NewOp(1101, rcop, 1, LOGOP);
3715             rcop->op_type = OP_SUBSTCONT;
3716             rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3717             rcop->op_first = scalar(repl);
3718             rcop->op_flags |= OPf_KIDS;
3719             rcop->op_private = 1;
3720             rcop->op_other = o;
3721
3722             /* establish postfix order */
3723             rcop->op_next = LINKLIST(repl);
3724             repl->op_next = (OP*)rcop;
3725
3726             pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
3727             assert(!(pm->op_pmflags & PMf_ONCE));
3728             pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
3729             rcop->op_next = 0;
3730         }
3731     }
3732
3733     return (OP*)pm;
3734 }
3735
3736 OP *
3737 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3738 {
3739     dVAR;
3740     SVOP *svop;
3741
3742     PERL_ARGS_ASSERT_NEWSVOP;
3743
3744     NewOp(1101, svop, 1, SVOP);
3745     svop->op_type = (OPCODE)type;
3746     svop->op_ppaddr = PL_ppaddr[type];
3747     svop->op_sv = sv;
3748     svop->op_next = (OP*)svop;
3749     svop->op_flags = (U8)flags;
3750     if (PL_opargs[type] & OA_RETSCALAR)
3751         scalar((OP*)svop);
3752     if (PL_opargs[type] & OA_TARGET)
3753         svop->op_targ = pad_alloc(type, SVs_PADTMP);
3754     return CHECKOP(type, svop);
3755 }
3756
3757 #ifdef USE_ITHREADS
3758 OP *
3759 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3760 {
3761     dVAR;
3762     PADOP *padop;
3763
3764     PERL_ARGS_ASSERT_NEWPADOP;
3765
3766     NewOp(1101, padop, 1, PADOP);
3767     padop->op_type = (OPCODE)type;
3768     padop->op_ppaddr = PL_ppaddr[type];
3769     padop->op_padix = pad_alloc(type, SVs_PADTMP);
3770     SvREFCNT_dec(PAD_SVl(padop->op_padix));
3771     PAD_SETSV(padop->op_padix, sv);
3772     assert(sv);
3773     SvPADTMP_on(sv);
3774     padop->op_next = (OP*)padop;
3775     padop->op_flags = (U8)flags;
3776     if (PL_opargs[type] & OA_RETSCALAR)
3777         scalar((OP*)padop);
3778     if (PL_opargs[type] & OA_TARGET)
3779         padop->op_targ = pad_alloc(type, SVs_PADTMP);
3780     return CHECKOP(type, padop);
3781 }
3782 #endif
3783
3784 OP *
3785 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3786 {
3787     dVAR;
3788
3789     PERL_ARGS_ASSERT_NEWGVOP;
3790
3791 #ifdef USE_ITHREADS
3792     GvIN_PAD_on(gv);
3793     return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3794 #else
3795     return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
3796 #endif
3797 }
3798
3799 OP *
3800 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3801 {
3802     dVAR;
3803     PVOP *pvop;
3804     NewOp(1101, pvop, 1, PVOP);
3805     pvop->op_type = (OPCODE)type;
3806     pvop->op_ppaddr = PL_ppaddr[type];
3807     pvop->op_pv = pv;
3808     pvop->op_next = (OP*)pvop;
3809     pvop->op_flags = (U8)flags;
3810     if (PL_opargs[type] & OA_RETSCALAR)
3811         scalar((OP*)pvop);
3812     if (PL_opargs[type] & OA_TARGET)
3813         pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3814     return CHECKOP(type, pvop);
3815 }
3816
3817 #ifdef PERL_MAD
3818 OP*
3819 #else
3820 void
3821 #endif
3822 Perl_package(pTHX_ OP *o)
3823 {
3824     dVAR;
3825     SV *const sv = cSVOPo->op_sv;
3826 #ifdef PERL_MAD
3827     OP *pegop;
3828 #endif
3829
3830     PERL_ARGS_ASSERT_PACKAGE;
3831
3832     save_hptr(&PL_curstash);
3833     save_item(PL_curstname);
3834
3835     PL_curstash = gv_stashsv(sv, GV_ADD);
3836
3837     sv_setsv(PL_curstname, sv);
3838
3839     PL_hints |= HINT_BLOCK_SCOPE;
3840     PL_parser->copline = NOLINE;
3841     PL_parser->expect = XSTATE;
3842
3843 #ifndef PERL_MAD
3844     op_free(o);
3845 #else
3846     if (!PL_madskills) {
3847         op_free(o);
3848         return NULL;
3849     }
3850
3851     pegop = newOP(OP_NULL,0);
3852     op_getmad(o,pegop,'P');
3853     return pegop;
3854 #endif
3855 }
3856
3857 void
3858 Perl_package_version( pTHX_ OP *v )
3859 {
3860     dVAR;
3861     U32 savehints = PL_hints;
3862     PERL_ARGS_ASSERT_PACKAGE_VERSION;
3863     PL_hints &= ~HINT_STRICT_VARS;
3864     sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv );
3865     PL_hints = savehints;
3866     op_free(v);
3867 }
3868
3869 #ifdef PERL_MAD
3870 OP*
3871 #else
3872 void
3873 #endif
3874 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3875 {
3876     dVAR;
3877     OP *pack;
3878     OP *imop;
3879     OP *veop;
3880 #ifdef PERL_MAD
3881     OP *pegop = newOP(OP_NULL,0);
3882 #endif
3883
3884     PERL_ARGS_ASSERT_UTILIZE;
3885
3886     if (idop->op_type != OP_CONST)
3887         Perl_croak(aTHX_ "Module name must be constant");
3888
3889     if (PL_madskills)
3890         op_getmad(idop,pegop,'U');
3891
3892     veop = NULL;
3893
3894     if (version) {
3895         SV * const vesv = ((SVOP*)version)->op_sv;
3896
3897         if (PL_madskills)
3898             op_getmad(version,pegop,'V');
3899         if (!arg && !SvNIOKp(vesv)) {
3900             arg = version;
3901         }
3902         else {
3903             OP *pack;
3904             SV *meth;
3905
3906             if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3907                 Perl_croak(aTHX_ "Version number must be a constant number");
3908
3909             /* Make copy of idop so we don't free it twice */
3910             pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3911
3912             /* Fake up a method call to VERSION */
3913             meth = newSVpvs_share("VERSION");
3914             veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3915                             append_elem(OP_LIST,
3916                                         prepend_elem(OP_LIST, pack, list(version)),
3917                                         newSVOP(OP_METHOD_NAMED, 0, meth)));
3918         }
3919     }
3920
3921     /* Fake up an import/unimport */
3922     if (arg && arg->op_type == OP_STUB) {
3923         if (PL_madskills)
3924             op_getmad(arg,pegop,'S');
3925         imop = arg;             /* no import on explicit () */
3926     }
3927     else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3928         imop = NULL;            /* use 5.0; */
3929         if (!aver)
3930             idop->op_private |= OPpCONST_NOVER;
3931     }
3932     else {
3933         SV *meth;
3934
3935         if (PL_madskills)
3936             op_getmad(arg,pegop,'A');
3937
3938         /* Make copy of idop so we don't free it twice */
3939         pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3940
3941         /* Fake up a method call to import/unimport */
3942         meth = aver
3943             ? newSVpvs_share("import") : newSVpvs_share("unimport");
3944         imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3945                        append_elem(OP_LIST,
3946                                    prepend_elem(OP_LIST, pack, list(arg)),
3947                                    newSVOP(OP_METHOD_NAMED, 0, meth)));
3948     }
3949
3950     /* Fake up the BEGIN {}, which does its thing immediately. */
3951     newATTRSUB(floor,
3952         newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
3953         NULL,
3954         NULL,
3955         append_elem(OP_LINESEQ,
3956             append_elem(OP_LINESEQ,
3957                 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
3958                 newSTATEOP(0, NULL, veop)),
3959             newSTATEOP(0, NULL, imop) ));
3960
3961     /* The "did you use incorrect case?" warning used to be here.
3962      * The problem is that on case-insensitive filesystems one
3963      * might get false positives for "use" (and "require"):
3964      * "use Strict" or "require CARP" will work.  This causes
3965      * portability problems for the script: in case-strict
3966      * filesystems the script will stop working.
3967      *
3968      * The "incorrect case" warning checked whether "use Foo"
3969      * imported "Foo" to your namespace, but that is wrong, too:
3970      * there is no requirement nor promise in the language that
3971      * a Foo.pm should or would contain anything in package "Foo".
3972      *
3973      * There is very little Configure-wise that can be done, either:
3974      * the case-sensitivity of the build filesystem of Perl does not
3975      * help in guessing the case-sensitivity of the runtime environment.
3976      */
3977
3978     PL_hints |= HINT_BLOCK_SCOPE;
3979     PL_parser->copline = NOLINE;
3980     PL_parser->expect = XSTATE;
3981     PL_cop_seqmax++; /* Purely for B::*'s benefit */
3982
3983 #ifdef PERL_MAD
3984     if (!PL_madskills) {
3985         /* FIXME - don't allocate pegop if !PL_madskills */
3986         op_free(pegop);
3987         return NULL;
3988     }
3989     return pegop;
3990 #endif
3991 }
3992
3993 /*
3994 =head1 Embedding Functions
3995
3996 =for apidoc load_module
3997
3998 Loads the module whose name is pointed to by the string part of name.
3999 Note that the actual module name, not its filename, should be given.
4000 Eg, "Foo::Bar" instead of "Foo/Bar.pm".  flags can be any of
4001 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
4002 (or 0 for no flags). ver, if specified, provides version semantics
4003 similar to C<use Foo::Bar VERSION>.  The optional trailing SV*
4004 arguments can be used to specify arguments to the module's import()
4005 method, similar to C<use Foo::Bar VERSION LIST>.  They must be
4006 terminated with a final NULL pointer.  Note that this list can only
4007 be omitted when the PERL_LOADMOD_NOIMPORT flag has been used.
4008 Otherwise at least a single NULL pointer to designate the default
4009 import list is required.
4010
4011 =cut */
4012
4013 void
4014 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
4015 {
4016     va_list args;
4017
4018     PERL_ARGS_ASSERT_LOAD_MODULE;
4019
4020     va_start(args, ver);
4021     vload_module(flags, name, ver, &args);
4022     va_end(args);
4023 }
4024
4025 #ifdef PERL_IMPLICIT_CONTEXT
4026 void
4027 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
4028 {
4029     dTHX;
4030     va_list args;
4031     PERL_ARGS_ASSERT_LOAD_MODULE_NOCONTEXT;
4032     va_start(args, ver);
4033     vload_module(flags, name, ver, &args);
4034     va_end(args);
4035 }
4036 #endif
4037
4038 void
4039 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
4040 {
4041     dVAR;
4042     OP *veop, *imop;
4043     OP * const modname = newSVOP(OP_CONST, 0, name);
4044
4045     PERL_ARGS_ASSERT_VLOAD_MODULE;
4046
4047     modname->op_private |= OPpCONST_BARE;
4048     if (ver) {
4049         veop = newSVOP(OP_CONST, 0, ver);
4050     }
4051     else
4052         veop = NULL;
4053     if (flags & PERL_LOADMOD_NOIMPORT) {
4054         imop = sawparens(newNULLLIST());
4055     }
4056     else if (flags & PERL_LOADMOD_IMPORT_OPS) {
4057         imop = va_arg(*args, OP*);
4058     }
4059     else {
4060         SV *sv;
4061         imop = NULL;
4062         sv = va_arg(*args, SV*);
4063         while (sv) {
4064             imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
4065             sv = va_arg(*args, SV*);
4066         }
4067     }
4068
4069     /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
4070      * that it has a PL_parser to play with while doing that, and also
4071      * that it doesn't mess with any existing parser, by creating a tmp
4072      * new parser with lex_start(). This won't actually be used for much,
4073      * since pp_require() will create another parser for the real work. */
4074
4075     ENTER;
4076     SAVEVPTR(PL_curcop);
4077     lex_start(NULL, NULL, FALSE);
4078     utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
4079             veop, modname, imop);
4080     LEAVE;
4081 }
4082
4083 OP *
4084 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
4085 {
4086     dVAR;
4087     OP *doop;
4088     GV *gv = NULL;
4089
4090     PERL_ARGS_ASSERT_DOFILE;
4091
4092     if (!force_builtin) {
4093         gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
4094         if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
4095             GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
4096             gv = gvp ? *gvp : NULL;
4097         }
4098     }
4099
4100     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
4101         doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
4102                                append_elem(OP_LIST, term,
4103                                            scalar(newUNOP(OP_RV2CV, 0,
4104                                                           newGVOP(OP_GV, 0, gv))))));
4105     }
4106     else {
4107         doop = newUNOP(OP_DOFILE, 0, scalar(term));
4108     }
4109     return doop;
4110 }
4111
4112 OP *
4113 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
4114 {
4115     return newBINOP(OP_LSLICE, flags,
4116             list(force_list(subscript)),
4117             list(force_list(listval)) );
4118 }
4119
4120 STATIC I32
4121 S_is_list_assignment(pTHX_ register const OP *o)
4122 {
4123     unsigned type;
4124     U8 flags;
4125
4126     if (!o)
4127         return TRUE;
4128
4129     if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
4130         o = cUNOPo->op_first;
4131
4132     flags = o->op_flags;
4133     type = o->op_type;
4134     if (type == OP_COND_EXPR) {
4135         const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
4136         const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
4137
4138         if (t && f)
4139             return TRUE;
4140         if (t || f)
4141             yyerror("Assignment to both a list and a scalar");
4142         return FALSE;
4143     }
4144
4145     if (type == OP_LIST &&
4146         (flags & OPf_WANT) == OPf_WANT_SCALAR &&
4147         o->op_private & OPpLVAL_INTRO)
4148         return FALSE;
4149
4150     if (type == OP_LIST || flags & OPf_PARENS ||
4151         type == OP_RV2AV || type == OP_RV2HV ||
4152         type == OP_ASLICE || type == OP_HSLICE)
4153         return TRUE;
4154
4155     if (type == OP_PADAV || type == OP_PADHV)
4156         return TRUE;
4157
4158     if (type == OP_RV2SV)
4159         return FALSE;
4160
4161     return FALSE;
4162 }
4163
4164 OP *
4165 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
4166 {
4167     dVAR;
4168     OP *o;
4169
4170     if (optype) {
4171         if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
4172             return newLOGOP(optype, 0,
4173                 mod(scalar(left), optype),
4174                 newUNOP(OP_SASSIGN, 0, scalar(right)));
4175         }
4176         else {
4177             return newBINOP(optype, OPf_STACKED,
4178                 mod(scalar(left), optype), scalar(right));
4179         }
4180     }
4181
4182     if (is_list_assignment(left)) {
4183         static const char no_list_state[] = "Initialization of state variables"
4184             " in list context currently forbidden";
4185         OP *curop;
4186         bool maybe_common_vars = TRUE;
4187
4188         PL_modcount = 0;
4189         /* Grandfathering $[ assignment here.  Bletch.*/
4190         /* Only simple assignments like C<< ($[) = 1 >> are allowed */
4191         PL_eval_start = (left->op_type == OP_CONST) ? right : NULL;
4192         left = mod(left, OP_AASSIGN);
4193         if (PL_eval_start)
4194             PL_eval_start = 0;
4195         else if (left->op_type == OP_CONST) {
4196             /* FIXME for MAD */
4197             /* Result of assignment is always 1 (or we'd be dead already) */
4198             return newSVOP(OP_CONST, 0, newSViv(1));
4199         }
4200         curop = list(force_list(left));
4201         o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
4202         o->op_private = (U8)(0 | (flags >> 8));
4203
4204         if ((left->op_type == OP_LIST
4205              || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
4206         {
4207             OP* lop = ((LISTOP*)left)->op_first;
4208             maybe_common_vars = FALSE;
4209             while (lop) {
4210                 if (lop->op_type == OP_PADSV ||
4211                     lop->op_type == OP_PADAV ||
4212                     lop->op_type == OP_PADHV ||
4213                     lop->op_type == OP_PADANY) {
4214                     if (!(lop->op_private & OPpLVAL_INTRO))
4215                         maybe_common_vars = TRUE;
4216
4217                     if (lop->op_private & OPpPAD_STATE) {
4218                         if (left->op_private & OPpLVAL_INTRO) {
4219                             /* Each variable in state($a, $b, $c) = ... */
4220                         }
4221                         else {
4222                             /* Each state variable in
4223                                (state $a, my $b, our $c, $d, undef) = ... */
4224                         }
4225                         yyerror(no_list_state);
4226                     } else {
4227                         /* Each my variable in
4228                            (state $a, my $b, our $c, $d, undef) = ... */
4229                     }
4230                 } else if (lop->op_type == OP_UNDEF ||
4231                            lop->op_type == OP_PUSHMARK) {
4232                     /* undef may be interesting in
4233                        (state $a, undef, state $c) */
4234                 } else {
4235                     /* Other ops in the list. */
4236                     maybe_common_vars = TRUE;
4237                 }
4238                 lop = lop->op_sibling;
4239             }
4240         }
4241         else if ((left->op_private & OPpLVAL_INTRO)
4242                 && (   left->op_type == OP_PADSV
4243                     || left->op_type == OP_PADAV
4244                     || left->op_type == OP_PADHV
4245                     || left->op_type == OP_PADANY))
4246         {
4247             maybe_common_vars = FALSE;
4248             if (left->op_private & OPpPAD_STATE) {
4249                 /* All single variable list context state assignments, hence
4250                    state ($a) = ...
4251                    (state $a) = ...
4252                    state @a = ...
4253                    state (@a) = ...
4254                    (state @a) = ...
4255                    state %a = ...
4256                    state (%a) = ...
4257                    (state %a) = ...
4258                 */
4259                 yyerror(no_list_state);
4260             }
4261         }
4262
4263         /* PL_generation sorcery:
4264          * an assignment like ($a,$b) = ($c,$d) is easier than
4265          * ($a,$b) = ($c,$a), since there is no need for temporary vars.
4266          * To detect whether there are common vars, the global var
4267          * PL_generation is incremented for each assign op we compile.
4268          * Then, while compiling the assign op, we run through all the
4269          * variables on both sides of the assignment, setting a spare slot
4270          * in each of them to PL_generation. If any of them already have
4271          * that value, we know we've got commonality.  We could use a
4272          * single bit marker, but then we'd have to make 2 passes, first
4273          * to clear the flag, then to test and set it.  To find somewhere
4274          * to store these values, evil chicanery is done with SvUVX().
4275          */
4276
4277         if (maybe_common_vars) {
4278             OP *lastop = o;
4279             PL_generation++;
4280             for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
4281                 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
4282                     if (curop->op_type == OP_GV) {
4283                         GV *gv = cGVOPx_gv(curop);
4284                         if (gv == PL_defgv
4285                             || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4286                             break;
4287                         GvASSIGN_GENERATION_set(gv, PL_generation);
4288                     }
4289                     else if (curop->op_type == OP_PADSV ||
4290                              curop->op_type == OP_PADAV ||
4291                              curop->op_type == OP_PADHV ||
4292                              curop->op_type == OP_PADANY)
4293                     {
4294                         if (PAD_COMPNAME_GEN(curop->op_targ)
4295                                                     == (STRLEN)PL_generation)
4296                             break;
4297                         PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
4298
4299                     }
4300                     else if (curop->op_type == OP_RV2CV)
4301                         break;
4302                     else if (curop->op_type == OP_RV2SV ||
4303                              curop->op_type == OP_RV2AV ||
4304                              curop->op_type == OP_RV2HV ||
4305                              curop->op_type == OP_RV2GV) {
4306                         if (lastop->op_type != OP_GV)   /* funny deref? */
4307                             break;
4308                     }
4309                     else if (curop->op_type == OP_PUSHRE) {
4310 #ifdef USE_ITHREADS
4311                         if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
4312                             GV *const gv = MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff));
4313                             if (gv == PL_defgv
4314                                 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4315                                 break;
4316                             GvASSIGN_GENERATION_set(gv, PL_generation);
4317                         }
4318 #else
4319                         GV *const gv
4320                             = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
4321                         if (gv) {
4322                             if (gv == PL_defgv
4323                                 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
4324                                 break;
4325                             GvASSIGN_GENERATION_set(gv, PL_generation);
4326                         }
4327 #endif
4328                     }
4329                     else
4330                         break;
4331                 }
4332                 lastop = curop;
4333             }
4334             if (curop != o)
4335                 o->op_private |= OPpASSIGN_COMMON;
4336         }
4337
4338         if (right && right->op_type == OP_SPLIT && !PL_madskills) {
4339             OP* tmpop = ((LISTOP*)right)->op_first;
4340             if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
4341                 PMOP * const pm = (PMOP*)tmpop;
4342                 if (left->op_type == OP_RV2AV &&
4343                     !(left->op_private & OPpLVAL_INTRO) &&
4344                     !(o->op_private & OPpASSIGN_COMMON) )
4345                 {
4346                     tmpop = ((UNOP*)left)->op_first;
4347                     if (tmpop->op_type == OP_GV
4348 #ifdef USE_ITHREADS
4349                         && !pm->op_pmreplrootu.op_pmtargetoff
4350 #else
4351                         && !pm->op_pmreplrootu.op_pmtargetgv
4352 #endif
4353                         ) {
4354 #ifdef USE_ITHREADS
4355                         pm->op_pmreplrootu.op_pmtargetoff
4356                             = cPADOPx(tmpop)->op_padix;
4357                         cPADOPx(tmpop)->op_padix = 0;   /* steal it */
4358 #else
4359                         pm->op_pmreplrootu.op_pmtargetgv
4360                             = MUTABLE_GV(cSVOPx(tmpop)->op_sv);
4361                         cSVOPx(tmpop)->op_sv = NULL;    /* steal it */
4362 #endif
4363                         pm->op_pmflags |= PMf_ONCE;
4364                         tmpop = cUNOPo->op_first;       /* to list (nulled) */
4365                         tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
4366                         tmpop->op_sibling = NULL;       /* don't free split */
4367                         right->op_next = tmpop->op_next;  /* fix starting loc */
4368                         op_free(o);                     /* blow off assign */
4369                         right->op_flags &= ~OPf_WANT;
4370                                 /* "I don't know and I don't care." */
4371                         return right;
4372                     }
4373                 }
4374                 else {
4375                    if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
4376                       ((LISTOP*)right)->op_last->op_type == OP_CONST)
4377                     {
4378                         SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
4379                         if (SvIOK(sv) && SvIVX(sv) == 0)
4380                             sv_setiv(sv, PL_modcount+1);
4381                     }
4382                 }
4383             }
4384         }
4385         return o;
4386     }
4387     if (!right)
4388         right = newOP(OP_UNDEF, 0);
4389     if (right->op_type == OP_READLINE) {
4390         right->op_flags |= OPf_STACKED;
4391         return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
4392     }
4393     else {
4394         PL_eval_start = right;  /* Grandfathering $[ assignment here.  Bletch.*/
4395         o = newBINOP(OP_SASSIGN, flags,
4396             scalar(right), mod(scalar(left), OP_SASSIGN) );
4397         if (PL_eval_start)
4398             PL_eval_start = 0;
4399         else {
4400             if (!PL_madskills) { /* assignment to $[ is ignored when making a mad dump */
4401                 deprecate("assignment to $[");
4402                 op_free(o);
4403                 o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
4404                 o->op_private |= OPpCONST_ARYBASE;
4405             }
4406         }
4407     }
4408     return o;
4409 }
4410
4411 OP *
4412 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
4413 {
4414     dVAR;
4415     const U32 seq = intro_my();
4416     register COP *cop;
4417
4418     NewOp(1101, cop, 1, COP);
4419     if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
4420         cop->op_type = OP_DBSTATE;
4421         cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
4422     }
4423     else {
4424         cop->op_type = OP_NEXTSTATE;
4425         cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
4426     }
4427     cop->op_flags = (U8)flags;
4428     CopHINTS_set(cop, PL_hints);
4429 #ifdef NATIVE_HINTS
4430     cop->op_private |= NATIVE_HINTS;
4431 #endif
4432     CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
4433     cop->op_next = (OP*)cop;
4434
4435     cop->cop_seq = seq;
4436     /* CopARYBASE is now "virtual", in that it's stored as a flag bit in
4437        CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
4438     */
4439     cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
4440     cop->cop_hints_hash = PL_curcop->cop_hints_hash;
4441     if (cop->cop_hints_hash) {
4442         HINTS_REFCNT_LOCK;
4443         cop->cop_hints_hash->refcounted_he_refcnt++;
4444         HINTS_REFCNT_UNLOCK;
4445     }
4446     if (label) {
4447         cop->cop_hints_hash
4448             = Perl_store_cop_label(aTHX_ cop->cop_hints_hash, label);
4449                                                      
4450         PL_hints |= HINT_BLOCK_SCOPE;
4451         /* It seems that we need to defer freeing this pointer, as other parts
4452            of the grammar end up wanting to copy it after this op has been
4453            created. */
4454         SAVEFREEPV(label);
4455     }
4456
4457     if (PL_parser && PL_parser->copline == NOLINE)
4458         CopLINE_set(cop, CopLINE(PL_curcop));
4459     else {
4460         CopLINE_set(cop, PL_parser->copline);
4461         if (PL_parser)
4462             PL_parser->copline = NOLINE;
4463     }
4464 #ifdef USE_ITHREADS
4465     CopFILE_set(cop, CopFILE(PL_curcop));       /* XXX share in a pvtable? */
4466 #else
4467     CopFILEGV_set(cop, CopFILEGV(PL_curcop));
4468 #endif
4469     CopSTASH_set(cop, PL_curstash);
4470
4471     if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash) {
4472         /* this line can have a breakpoint - store the cop in IV */
4473         AV *av = CopFILEAVx(PL_curcop);
4474         if (av) {
4475             SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
4476             if (svp && *svp != &PL_sv_undef ) {
4477                 (void)SvIOK_on(*svp);
4478                 SvIV_set(*svp, PTR2IV(cop));
4479             }
4480         }
4481     }
4482
4483     if (flags & OPf_SPECIAL)
4484         op_null((OP*)cop);
4485     return prepend_elem(OP_LINESEQ, (OP*)cop, o);
4486 }
4487
4488
4489 OP *
4490 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
4491 {
4492     dVAR;
4493
4494     PERL_ARGS_ASSERT_NEWLOGOP;
4495
4496     return new_logop(type, flags, &first, &other);
4497 }
4498
4499 STATIC OP *
4500 S_search_const(pTHX_ OP *o)
4501 {
4502     PERL_ARGS_ASSERT_SEARCH_CONST;
4503
4504     switch (o->op_type) {
4505         case OP_CONST:
4506             return o;
4507         case OP_NULL:
4508             if (o->op_flags & OPf_KIDS)
4509                 return search_const(cUNOPo->op_first);
4510             break;
4511         case OP_LEAVE:
4512         case OP_SCOPE:
4513         case OP_LINESEQ:
4514         {
4515             OP *kid;
4516             if (!(o->op_flags & OPf_KIDS))
4517                 return NULL;
4518             kid = cLISTOPo->op_first;
4519             do {
4520                 switch (kid->op_type) {
4521                     case OP_ENTER:
4522                     case OP_NULL:
4523                     case OP_NEXTSTATE:
4524                         kid = kid->op_sibling;
4525                         break;
4526                     default:
4527                         if (kid != cLISTOPo->op_last)
4528                             return NULL;
4529                         goto last;
4530                 }
4531             } while (kid);
4532             if (!kid)
4533                 kid = cLISTOPo->op_last;
4534 last:
4535             return search_const(kid);
4536         }
4537     }
4538
4539     return NULL;
4540 }
4541
4542 STATIC OP *
4543 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
4544 {
4545     dVAR;
4546     LOGOP *logop;
4547     OP *o;
4548     OP *first;
4549     OP *other;
4550     OP *cstop = NULL;
4551     int prepend_not = 0;
4552
4553     PERL_ARGS_ASSERT_NEW_LOGOP;
4554
4555     first = *firstp;
4556     other = *otherp;
4557
4558     if (type == OP_XOR)         /* Not short circuit, but here by precedence. */
4559         return newBINOP(type, flags, scalar(first), scalar(other));
4560
4561     scalarboolean(first);
4562     /* optimize AND and OR ops that have NOTs as children */
4563     if (first->op_type == OP_NOT
4564         && (first->op_flags & OPf_KIDS)
4565         && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
4566             || (other->op_type == OP_NOT))  /* if (!$x && !$y) { } */
4567         && !PL_madskills) {
4568         if (type == OP_AND || type == OP_OR) {
4569             if (type == OP_AND)
4570                 type = OP_OR;
4571             else
4572                 type = OP_AND;
4573             op_null(first);
4574             if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
4575                 op_null(other);
4576                 prepend_not = 1; /* prepend a NOT op later */
4577             }
4578         }
4579     }
4580     /* search for a constant op that could let us fold the test */
4581     if ((cstop = search_const(first))) {
4582         if (cstop->op_private & OPpCONST_STRICT)
4583             no_bareword_allowed(cstop);
4584         else if ((cstop->op_private & OPpCONST_BARE))
4585                 Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
4586         if ((type == OP_AND &&  SvTRUE(((SVOP*)cstop)->op_sv)) ||
4587             (type == OP_OR  && !SvTRUE(((SVOP*)cstop)->op_sv)) ||
4588             (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) {
4589             *firstp = NULL;
4590             if (other->op_type == OP_CONST)
4591                 other->op_private |= OPpCONST_SHORTCIRCUIT;
4592             if (PL_madskills) {
4593                 OP *newop = newUNOP(OP_NULL, 0, other);
4594                 op_getmad(first, newop, '1');
4595                 newop->op_targ = type;  /* set "was" field */
4596                 return newop;
4597             }
4598             op_free(first);
4599             if (other->op_type == OP_LEAVE)
4600                 other = newUNOP(OP_NULL, OPf_SPECIAL, other);
4601             return other;
4602         }
4603         else {
4604             /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
4605             const OP *o2 = other;
4606             if ( ! (o2->op_type == OP_LIST
4607                     && (( o2 = cUNOPx(o2)->op_first))
4608                     && o2->op_type == OP_PUSHMARK
4609                     && (( o2 = o2->op_sibling)) )
4610             )
4611                 o2 = other;
4612             if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
4613                         || o2->op_type == OP_PADHV)
4614                 && o2->op_private & OPpLVAL_INTRO
4615                 && !(o2->op_private & OPpPAD_STATE))
4616             {
4617                 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
4618                                  "Deprecated use of my() in false conditional");
4619             }
4620
4621             *otherp = NULL;
4622             if (first->op_type == OP_CONST)
4623                 first->op_private |= OPpCONST_SHORTCIRCUIT;
4624             if (PL_madskills) {
4625                 first = newUNOP(OP_NULL, 0, first);
4626                 op_getmad(other, first, '2');
4627                 first->op_targ = type;  /* set "was" field */
4628             }
4629             else
4630                 op_free(other);
4631             return first;
4632         }
4633     }
4634     else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
4635         && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
4636     {
4637         const OP * const k1 = ((UNOP*)first)->op_first;
4638         const OP * const k2 = k1->op_sibling;
4639         OPCODE warnop = 0;
4640         switch (first->op_type)
4641         {
4642         case OP_NULL:
4643             if (k2 && k2->op_type == OP_READLINE
4644                   && (k2->op_flags & OPf_STACKED)
4645                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4646             {
4647                 warnop = k2->op_type;
4648             }
4649             break;
4650
4651         case OP_SASSIGN:
4652             if (k1->op_type == OP_READDIR
4653                   || k1->op_type == OP_GLOB
4654                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4655                   || k1->op_type == OP_EACH)
4656             {
4657                 warnop = ((k1->op_type == OP_NULL)
4658                           ? (OPCODE)k1->op_targ : k1->op_type);
4659             }
4660             break;
4661         }
4662         if (warnop) {
4663             const line_t oldline = CopLINE(PL_curcop);
4664             CopLINE_set(PL_curcop, PL_parser->copline);
4665             Perl_warner(aTHX_ packWARN(WARN_MISC),
4666                  "Value of %s%s can be \"0\"; test with defined()",
4667                  PL_op_desc[warnop],
4668                  ((warnop == OP_READLINE || warnop == OP_GLOB)
4669                   ? " construct" : "() operator"));
4670             CopLINE_set(PL_curcop, oldline);
4671         }
4672     }
4673
4674     if (!other)
4675         return first;
4676
4677     if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
4678         other->op_private |= OPpASSIGN_BACKWARDS;  /* other is an OP_SASSIGN */
4679
4680     NewOp(1101, logop, 1, LOGOP);
4681
4682     logop->op_type = (OPCODE)type;
4683     logop->op_ppaddr = PL_ppaddr[type];
4684     logop->op_first = first;
4685     logop->op_flags = (U8)(flags | OPf_KIDS);
4686     logop->op_other = LINKLIST(other);
4687     logop->op_private = (U8)(1 | (flags >> 8));
4688
4689     /* establish postfix order */
4690     logop->op_next = LINKLIST(first);
4691     first->op_next = (OP*)logop;
4692     first->op_sibling = other;
4693
4694     CHECKOP(type,logop);
4695
4696     o = newUNOP(prepend_not ? OP_NOT : OP_NULL, 0, (OP*)logop);
4697     other->op_next = o;
4698
4699     return o;
4700 }
4701
4702 OP *
4703 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
4704 {
4705     dVAR;
4706     LOGOP *logop;
4707     OP *start;
4708     OP *o;
4709     OP *cstop;
4710
4711     PERL_ARGS_ASSERT_NEWCONDOP;
4712
4713     if (!falseop)
4714         return newLOGOP(OP_AND, 0, first, trueop);
4715     if (!trueop)
4716         return newLOGOP(OP_OR, 0, first, falseop);
4717
4718     scalarboolean(first);
4719     if ((cstop = search_const(first))) {
4720         /* Left or right arm of the conditional?  */
4721         const bool left = SvTRUE(((SVOP*)cstop)->op_sv);
4722         OP *live = left ? trueop : falseop;
4723         OP *const dead = left ? falseop : trueop;
4724         if (cstop->op_private & OPpCONST_BARE &&
4725             cstop->op_private & OPpCONST_STRICT) {
4726             no_bareword_allowed(cstop);
4727         }
4728         if (PL_madskills) {
4729             /* This is all dead code when PERL_MAD is not defined.  */
4730             live = newUNOP(OP_NULL, 0, live);
4731             op_getmad(first, live, 'C');
4732             op_getmad(dead, live, left ? 'e' : 't');
4733         } else {
4734             op_free(first);
4735             op_free(dead);
4736         }
4737         if (live->op_type == OP_LEAVE)
4738             live = newUNOP(OP_NULL, OPf_SPECIAL, live);
4739         return live;
4740     }
4741     NewOp(1101, logop, 1, LOGOP);
4742     logop->op_type = OP_COND_EXPR;
4743     logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4744     logop->op_first = first;
4745     logop->op_flags = (U8)(flags | OPf_KIDS);
4746     logop->op_private = (U8)(1 | (flags >> 8));
4747     logop->op_other = LINKLIST(trueop);
4748     logop->op_next = LINKLIST(falseop);
4749
4750     CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
4751             logop);
4752
4753     /* establish postfix order */
4754     start = LINKLIST(first);
4755     first->op_next = (OP*)logop;
4756
4757     first->op_sibling = trueop;
4758     trueop->op_sibling = falseop;
4759     o = newUNOP(OP_NULL, 0, (OP*)logop);
4760
4761     trueop->op_next = falseop->op_next = o;
4762
4763     o->op_next = start;
4764     return o;
4765 }
4766
4767 OP *
4768 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4769 {
4770     dVAR;
4771     LOGOP *range;
4772     OP *flip;
4773     OP *flop;
4774     OP *leftstart;
4775     OP *o;
4776
4777     PERL_ARGS_ASSERT_NEWRANGE;
4778
4779     NewOp(1101, range, 1, LOGOP);
4780
4781     range->op_type = OP_RANGE;
4782     range->op_ppaddr = PL_ppaddr[OP_RANGE];
4783     range->op_first = left;
4784     range->op_flags = OPf_KIDS;
4785     leftstart = LINKLIST(left);
4786     range->op_other = LINKLIST(right);
4787     range->op_private = (U8)(1 | (flags >> 8));
4788
4789     left->op_sibling = right;
4790
4791     range->op_next = (OP*)range;
4792     flip = newUNOP(OP_FLIP, flags, (OP*)range);
4793     flop = newUNOP(OP_FLOP, 0, flip);
4794     o = newUNOP(OP_NULL, 0, flop);
4795     linklist(flop);
4796     range->op_next = leftstart;
4797
4798     left->op_next = flip;
4799     right->op_next = flop;
4800
4801     range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4802     sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4803     flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4804     sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4805
4806     flip->op_private =  left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4807     flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4808
4809     flip->op_next = o;
4810     if (!flip->op_private || !flop->op_private)
4811         linklist(o);            /* blow off optimizer unless constant */
4812
4813     return o;
4814 }
4815
4816 OP *
4817 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4818 {
4819     dVAR;
4820     OP* listop;
4821     OP* o;
4822     const bool once = block && block->op_flags & OPf_SPECIAL &&
4823       (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4824
4825     PERL_UNUSED_ARG(debuggable);
4826
4827     if (expr) {
4828         if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4829             return block;       /* do {} while 0 does once */
4830         if (expr->op_type == OP_READLINE
4831             || expr->op_type == OP_READDIR
4832             || expr->op_type == OP_GLOB
4833             || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4834             expr = newUNOP(OP_DEFINED, 0,
4835                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4836         } else if (expr->op_flags & OPf_KIDS) {
4837             const OP * const k1 = ((UNOP*)expr)->op_first;
4838             const OP * const k2 = k1 ? k1->op_sibling : NULL;
4839             switch (expr->op_type) {
4840               case OP_NULL:
4841                 if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
4842                       && (k2->op_flags & OPf_STACKED)
4843                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))