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