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