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