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