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