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