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