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