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