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