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