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