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