This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Simplify the non-printable name error reporting code in Perl_allocmy().
[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_ char *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     dJMPENV;
2139
2140     if (PL_opargs[type] & OA_RETSCALAR)
2141         scalar(o);
2142     if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2143         o->op_targ = pad_alloc(type, SVs_PADTMP);
2144
2145     /* integerize op, unless it happens to be C<-foo>.
2146      * XXX should pp_i_negate() do magic string negation instead? */
2147     if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2148         && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2149              && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2150     {
2151         o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2152     }
2153
2154     if (!(PL_opargs[type] & OA_FOLDCONST))
2155         goto nope;
2156
2157     switch (type) {
2158     case OP_NEGATE:
2159         /* XXX might want a ck_negate() for this */
2160         cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2161         break;
2162     case OP_UCFIRST:
2163     case OP_LCFIRST:
2164     case OP_UC:
2165     case OP_LC:
2166     case OP_SLT:
2167     case OP_SGT:
2168     case OP_SLE:
2169     case OP_SGE:
2170     case OP_SCMP:
2171         /* XXX what about the numeric ops? */
2172         if (PL_hints & HINT_LOCALE)
2173             goto nope;
2174     }
2175
2176     if (PL_error_count)
2177         goto nope;              /* Don't try to run w/ errors */
2178
2179     for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2180         const OPCODE type = curop->op_type;
2181         if ((type != OP_CONST || (curop->op_private & OPpCONST_BARE)) &&
2182             type != OP_LIST &&
2183             type != OP_SCALAR &&
2184             type != OP_NULL &&
2185             type != OP_PUSHMARK)
2186         {
2187             goto nope;
2188         }
2189     }
2190
2191     curop = LINKLIST(o);
2192     old_next = o->op_next;
2193     o->op_next = 0;
2194     PL_op = curop;
2195
2196     oldscope = PL_scopestack_ix;
2197     create_eval_scope(G_FAKINGEVAL);
2198
2199     JMPENV_PUSH(ret);
2200
2201     switch (ret) {
2202     case 0:
2203         CALLRUNOPS(aTHX);
2204         sv = *(PL_stack_sp--);
2205         if (o->op_targ && sv == PAD_SV(o->op_targ))     /* grab pad temp? */
2206             pad_swipe(o->op_targ,  FALSE);
2207         else if (SvTEMP(sv)) {                  /* grab mortal temp? */
2208             SvREFCNT_inc_simple_void(sv);
2209             SvTEMP_off(sv);
2210         }
2211         break;
2212     case 2:
2213         /* my_exit() was called; propagate it */
2214         JMPENV_POP;
2215         JMPENV_JUMP(2);
2216         /* NOTREACHED */
2217     case 3:
2218         /* Something tried to die.  Abandon constant folding.  */
2219         /* Pretend the error never happened.  */
2220         sv_setpvn(ERRSV,"",0);
2221         o->op_next = old_next;
2222         break;
2223     default:
2224         JMPENV_POP;
2225         /* Don't expect 1 (setjmp failed) */
2226         Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
2227     }
2228
2229     JMPENV_POP;
2230
2231     if (PL_scopestack_ix > oldscope)
2232         delete_eval_scope();
2233
2234     if (ret)
2235         goto nope;
2236
2237 #ifndef PERL_MAD
2238     op_free(o);
2239 #endif
2240     assert(sv);
2241     if (type == OP_RV2GV)
2242         newop = newGVOP(OP_GV, 0, (GV*)sv);
2243     else
2244         newop = newSVOP(OP_CONST, 0, sv);
2245     op_getmad(o,newop,'f');
2246     return newop;
2247
2248  nope:
2249     return o;
2250 }
2251
2252 OP *
2253 Perl_gen_constant_list(pTHX_ register OP *o)
2254 {
2255     dVAR;
2256     register OP *curop;
2257     const I32 oldtmps_floor = PL_tmps_floor;
2258
2259     list(o);
2260     if (PL_error_count)
2261         return o;               /* Don't attempt to run with errors */
2262
2263     PL_op = curop = LINKLIST(o);
2264     o->op_next = 0;
2265     CALL_PEEP(curop);
2266     pp_pushmark();
2267     CALLRUNOPS(aTHX);
2268     PL_op = curop;
2269     pp_anonlist();
2270     PL_tmps_floor = oldtmps_floor;
2271
2272     o->op_type = OP_RV2AV;
2273     o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2274     o->op_flags &= ~OPf_REF;    /* treat \(1..2) like an ordinary list */
2275     o->op_flags |= OPf_PARENS;  /* and flatten \(1..2,3) */
2276     o->op_opt = 0;              /* needs to be revisited in peep() */
2277     curop = ((UNOP*)o)->op_first;
2278     ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
2279 #ifdef PERL_MAD
2280     op_getmad(curop,o,'O');
2281 #else
2282     op_free(curop);
2283 #endif
2284     linklist(o);
2285     return list(o);
2286 }
2287
2288 OP *
2289 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2290 {
2291     dVAR;
2292     if (!o || o->op_type != OP_LIST)
2293         o = newLISTOP(OP_LIST, 0, o, NULL);
2294     else
2295         o->op_flags &= ~OPf_WANT;
2296
2297     if (!(PL_opargs[type] & OA_MARK))
2298         op_null(cLISTOPo->op_first);
2299
2300     o->op_type = (OPCODE)type;
2301     o->op_ppaddr = PL_ppaddr[type];
2302     o->op_flags |= flags;
2303
2304     o = CHECKOP(type, o);
2305     if (o->op_type != (unsigned)type)
2306         return o;
2307
2308     return fold_constants(o);
2309 }
2310
2311 /* List constructors */
2312
2313 OP *
2314 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2315 {
2316     if (!first)
2317         return last;
2318
2319     if (!last)
2320         return first;
2321
2322     if (first->op_type != (unsigned)type
2323         || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2324     {
2325         return newLISTOP(type, 0, first, last);
2326     }
2327
2328     if (first->op_flags & OPf_KIDS)
2329         ((LISTOP*)first)->op_last->op_sibling = last;
2330     else {
2331         first->op_flags |= OPf_KIDS;
2332         ((LISTOP*)first)->op_first = last;
2333     }
2334     ((LISTOP*)first)->op_last = last;
2335     return first;
2336 }
2337
2338 OP *
2339 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2340 {
2341     if (!first)
2342         return (OP*)last;
2343
2344     if (!last)
2345         return (OP*)first;
2346
2347     if (first->op_type != (unsigned)type)
2348         return prepend_elem(type, (OP*)first, (OP*)last);
2349
2350     if (last->op_type != (unsigned)type)
2351         return append_elem(type, (OP*)first, (OP*)last);
2352
2353     first->op_last->op_sibling = last->op_first;
2354     first->op_last = last->op_last;
2355     first->op_flags |= (last->op_flags & OPf_KIDS);
2356
2357 #ifdef PERL_MAD
2358     if (last->op_first && first->op_madprop) {
2359         MADPROP *mp = last->op_first->op_madprop;
2360         if (mp) {
2361             while (mp->mad_next)
2362                 mp = mp->mad_next;
2363             mp->mad_next = first->op_madprop;
2364         }
2365         else {
2366             last->op_first->op_madprop = first->op_madprop;
2367         }
2368     }
2369     first->op_madprop = last->op_madprop;
2370     last->op_madprop = 0;
2371 #endif
2372
2373     FreeOp(last);
2374
2375     return (OP*)first;
2376 }
2377
2378 OP *
2379 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2380 {
2381     if (!first)
2382         return last;
2383
2384     if (!last)
2385         return first;
2386
2387     if (last->op_type == (unsigned)type) {
2388         if (type == OP_LIST) {  /* already a PUSHMARK there */
2389             first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2390             ((LISTOP*)last)->op_first->op_sibling = first;
2391             if (!(first->op_flags & OPf_PARENS))
2392                 last->op_flags &= ~OPf_PARENS;
2393         }
2394         else {
2395             if (!(last->op_flags & OPf_KIDS)) {
2396                 ((LISTOP*)last)->op_last = first;
2397                 last->op_flags |= OPf_KIDS;
2398             }
2399             first->op_sibling = ((LISTOP*)last)->op_first;
2400             ((LISTOP*)last)->op_first = first;
2401         }
2402         last->op_flags |= OPf_KIDS;
2403         return last;
2404     }
2405
2406     return newLISTOP(type, 0, first, last);
2407 }
2408
2409 /* Constructors */
2410
2411 #ifdef PERL_MAD
2412  
2413 TOKEN *
2414 Perl_newTOKEN(pTHX_ I32 optype, YYSTYPE lval, MADPROP* madprop)
2415 {
2416     TOKEN *tk;
2417     Newxz(tk, 1, TOKEN);
2418     tk->tk_type = (OPCODE)optype;
2419     tk->tk_type = 12345;
2420     tk->tk_lval = lval;
2421     tk->tk_mad = madprop;
2422     return tk;
2423 }
2424
2425 void
2426 Perl_token_free(pTHX_ TOKEN* tk)
2427 {
2428     if (tk->tk_type != 12345)
2429         return;
2430     mad_free(tk->tk_mad);
2431     Safefree(tk);
2432 }
2433
2434 void
2435 Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot)
2436 {
2437     MADPROP* mp;
2438     MADPROP* tm;
2439     if (tk->tk_type != 12345) {
2440         Perl_warner(aTHX_ packWARN(WARN_MISC),
2441              "Invalid TOKEN object ignored");
2442         return;
2443     }
2444     tm = tk->tk_mad;
2445     if (!tm)
2446         return;
2447
2448     /* faked up qw list? */
2449     if (slot == '(' &&
2450         tm->mad_type == MAD_SV &&
2451         SvPVX((SV*)tm->mad_val)[0] == 'q')
2452             slot = 'x';
2453
2454     if (o) {
2455         mp = o->op_madprop;
2456         if (mp) {
2457             for (;;) {
2458                 /* pretend constant fold didn't happen? */
2459                 if (mp->mad_key == 'f' &&
2460                     (o->op_type == OP_CONST ||
2461                      o->op_type == OP_GV) )
2462                 {
2463                     token_getmad(tk,(OP*)mp->mad_val,slot);
2464                     return;
2465                 }
2466                 if (!mp->mad_next)
2467                     break;
2468                 mp = mp->mad_next;
2469             }
2470             mp->mad_next = tm;
2471             mp = mp->mad_next;
2472         }
2473         else {
2474             o->op_madprop = tm;
2475             mp = o->op_madprop;
2476         }
2477         if (mp->mad_key == 'X')
2478             mp->mad_key = slot; /* just change the first one */
2479
2480         tk->tk_mad = 0;
2481     }
2482     else
2483         mad_free(tm);
2484     Safefree(tk);
2485 }
2486
2487 void
2488 Perl_op_getmad_weak(pTHX_ OP* from, OP* o, char slot)
2489 {
2490     MADPROP* mp;
2491     if (!from)
2492         return;
2493     if (o) {
2494         mp = o->op_madprop;
2495         if (mp) {
2496             for (;;) {
2497                 /* pretend constant fold didn't happen? */
2498                 if (mp->mad_key == 'f' &&
2499                     (o->op_type == OP_CONST ||
2500                      o->op_type == OP_GV) )
2501                 {
2502                     op_getmad(from,(OP*)mp->mad_val,slot);
2503                     return;
2504                 }
2505                 if (!mp->mad_next)
2506                     break;
2507                 mp = mp->mad_next;
2508             }
2509             mp->mad_next = newMADPROP(slot,MAD_OP,from,0);
2510         }
2511         else {
2512             o->op_madprop = newMADPROP(slot,MAD_OP,from,0);
2513         }
2514     }
2515 }
2516
2517 void
2518 Perl_op_getmad(pTHX_ OP* from, OP* o, char slot)
2519 {
2520     MADPROP* mp;
2521     if (!from)
2522         return;
2523     if (o) {
2524         mp = o->op_madprop;
2525         if (mp) {
2526             for (;;) {
2527                 /* pretend constant fold didn't happen? */
2528                 if (mp->mad_key == 'f' &&
2529                     (o->op_type == OP_CONST ||
2530                      o->op_type == OP_GV) )
2531                 {
2532                     op_getmad(from,(OP*)mp->mad_val,slot);
2533                     return;
2534                 }
2535                 if (!mp->mad_next)
2536                     break;
2537                 mp = mp->mad_next;
2538             }
2539             mp->mad_next = newMADPROP(slot,MAD_OP,from,1);
2540         }
2541         else {
2542             o->op_madprop = newMADPROP(slot,MAD_OP,from,1);
2543         }
2544     }
2545     else {
2546         PerlIO_printf(PerlIO_stderr(),
2547                       "DESTROYING op = %0"UVxf"\n", PTR2UV(from));
2548         op_free(from);
2549     }
2550 }
2551
2552 void
2553 Perl_prepend_madprops(pTHX_ MADPROP* mp, OP* o, char slot)
2554 {
2555     MADPROP* tm;
2556     if (!mp || !o)
2557         return;
2558     if (slot)
2559         mp->mad_key = slot;
2560     tm = o->op_madprop;
2561     o->op_madprop = mp;
2562     for (;;) {
2563         if (!mp->mad_next)
2564             break;
2565         mp = mp->mad_next;
2566     }
2567     mp->mad_next = tm;
2568 }
2569
2570 void
2571 Perl_append_madprops(pTHX_ MADPROP* tm, OP* o, char slot)
2572 {
2573     if (!o)
2574         return;
2575     addmad(tm, &(o->op_madprop), slot);
2576 }
2577
2578 void
2579 Perl_addmad(pTHX_ MADPROP* tm, MADPROP** root, char slot)
2580 {
2581     MADPROP* mp;
2582     if (!tm || !root)
2583         return;
2584     if (slot)
2585         tm->mad_key = slot;
2586     mp = *root;
2587     if (!mp) {
2588         *root = tm;
2589         return;
2590     }
2591     for (;;) {
2592         if (!mp->mad_next)
2593             break;
2594         mp = mp->mad_next;
2595     }
2596     mp->mad_next = tm;
2597 }
2598
2599 MADPROP *
2600 Perl_newMADsv(pTHX_ char key, SV* sv)
2601 {
2602     return newMADPROP(key, MAD_SV, sv, 0);
2603 }
2604
2605 MADPROP *
2606 Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
2607 {
2608     MADPROP *mp;
2609     Newxz(mp, 1, MADPROP);
2610     mp->mad_next = 0;
2611     mp->mad_key = key;
2612     mp->mad_vlen = vlen;
2613     mp->mad_type = type;
2614     mp->mad_val = val;
2615 /*    PerlIO_printf(PerlIO_stderr(), "NEW  mp = %0x\n", mp);  */
2616     return mp;
2617 }
2618
2619 void
2620 Perl_mad_free(pTHX_ MADPROP* mp)
2621 {
2622 /*    PerlIO_printf(PerlIO_stderr(), "FREE mp = %0x\n", mp); */
2623     if (!mp)
2624         return;
2625     if (mp->mad_next)
2626         mad_free(mp->mad_next);
2627 /*    if (PL_lex_state != LEX_NOTPARSING && mp->mad_vlen)
2628         PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
2629     switch (mp->mad_type) {
2630     case MAD_NULL:
2631         break;
2632     case MAD_PV:
2633         Safefree((char*)mp->mad_val);
2634         break;
2635     case MAD_OP:
2636         if (mp->mad_vlen)       /* vlen holds "strong/weak" boolean */
2637             op_free((OP*)mp->mad_val);
2638         break;
2639     case MAD_SV:
2640         sv_free((SV*)mp->mad_val);
2641         break;
2642     default:
2643         PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
2644         break;
2645     }
2646     Safefree(mp);
2647 }
2648
2649 #endif
2650
2651 OP *
2652 Perl_newNULLLIST(pTHX)
2653 {
2654     return newOP(OP_STUB, 0);
2655 }
2656
2657 OP *
2658 Perl_force_list(pTHX_ OP *o)
2659 {
2660     if (!o || o->op_type != OP_LIST)
2661         o = newLISTOP(OP_LIST, 0, o, NULL);
2662     op_null(o);
2663     return o;
2664 }
2665
2666 OP *
2667 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2668 {
2669     dVAR;
2670     LISTOP *listop;
2671
2672     NewOp(1101, listop, 1, LISTOP);
2673
2674     listop->op_type = (OPCODE)type;
2675     listop->op_ppaddr = PL_ppaddr[type];
2676     if (first || last)
2677         flags |= OPf_KIDS;
2678     listop->op_flags = (U8)flags;
2679
2680     if (!last && first)
2681         last = first;
2682     else if (!first && last)
2683         first = last;
2684     else if (first)
2685         first->op_sibling = last;
2686     listop->op_first = first;
2687     listop->op_last = last;
2688     if (type == OP_LIST) {
2689         OP* const pushop = newOP(OP_PUSHMARK, 0);
2690         pushop->op_sibling = first;
2691         listop->op_first = pushop;
2692         listop->op_flags |= OPf_KIDS;
2693         if (!last)
2694             listop->op_last = pushop;
2695     }
2696
2697     return CHECKOP(type, listop);
2698 }
2699
2700 OP *
2701 Perl_newOP(pTHX_ I32 type, I32 flags)
2702 {
2703     dVAR;
2704     OP *o;
2705     NewOp(1101, o, 1, OP);
2706     o->op_type = (OPCODE)type;
2707     o->op_ppaddr = PL_ppaddr[type];
2708     o->op_flags = (U8)flags;
2709
2710     o->op_next = o;
2711     o->op_private = (U8)(0 | (flags >> 8));
2712     if (PL_opargs[type] & OA_RETSCALAR)
2713         scalar(o);
2714     if (PL_opargs[type] & OA_TARGET)
2715         o->op_targ = pad_alloc(type, SVs_PADTMP);
2716     return CHECKOP(type, o);
2717 }
2718
2719 OP *
2720 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2721 {
2722     dVAR;
2723     UNOP *unop;
2724
2725     if (!first)
2726         first = newOP(OP_STUB, 0);
2727     if (PL_opargs[type] & OA_MARK)
2728         first = force_list(first);
2729
2730     NewOp(1101, unop, 1, UNOP);
2731     unop->op_type = (OPCODE)type;
2732     unop->op_ppaddr = PL_ppaddr[type];
2733     unop->op_first = first;
2734     unop->op_flags = (U8)(flags | OPf_KIDS);
2735     unop->op_private = (U8)(1 | (flags >> 8));
2736     unop = (UNOP*) CHECKOP(type, unop);
2737     if (unop->op_next)
2738         return (OP*)unop;
2739
2740     return fold_constants((OP *) unop);
2741 }
2742
2743 OP *
2744 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2745 {
2746     dVAR;
2747     BINOP *binop;
2748     NewOp(1101, binop, 1, BINOP);
2749
2750     if (!first)
2751         first = newOP(OP_NULL, 0);
2752
2753     binop->op_type = (OPCODE)type;
2754     binop->op_ppaddr = PL_ppaddr[type];
2755     binop->op_first = first;
2756     binop->op_flags = (U8)(flags | OPf_KIDS);
2757     if (!last) {
2758         last = first;
2759         binop->op_private = (U8)(1 | (flags >> 8));
2760     }
2761     else {
2762         binop->op_private = (U8)(2 | (flags >> 8));
2763         first->op_sibling = last;
2764     }
2765
2766     binop = (BINOP*)CHECKOP(type, binop);
2767     if (binop->op_next || binop->op_type != (OPCODE)type)
2768         return (OP*)binop;
2769
2770     binop->op_last = binop->op_first->op_sibling;
2771
2772     return fold_constants((OP *)binop);
2773 }
2774
2775 static int uvcompare(const void *a, const void *b)
2776     __attribute__nonnull__(1)
2777     __attribute__nonnull__(2)
2778     __attribute__pure__;
2779 static int uvcompare(const void *a, const void *b)
2780 {
2781     if (*((const UV *)a) < (*(const UV *)b))
2782         return -1;
2783     if (*((const UV *)a) > (*(const UV *)b))
2784         return 1;
2785     if (*((const UV *)a+1) < (*(const UV *)b+1))
2786         return -1;
2787     if (*((const UV *)a+1) > (*(const UV *)b+1))
2788         return 1;
2789     return 0;
2790 }
2791
2792 OP *
2793 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2794 {
2795     dVAR;
2796     SV * const tstr = ((SVOP*)expr)->op_sv;
2797     SV * const rstr = ((SVOP*)repl)->op_sv;
2798     STRLEN tlen;
2799     STRLEN rlen;
2800     const U8 *t = (U8*)SvPV_const(tstr, tlen);
2801     const U8 *r = (U8*)SvPV_const(rstr, rlen);
2802     register I32 i;
2803     register I32 j;
2804     I32 grows = 0;
2805     register short *tbl;
2806
2807     const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
2808     const I32 squash     = o->op_private & OPpTRANS_SQUASH;
2809     I32 del              = o->op_private & OPpTRANS_DELETE;
2810     PL_hints |= HINT_BLOCK_SCOPE;
2811
2812     if (SvUTF8(tstr))
2813         o->op_private |= OPpTRANS_FROM_UTF;
2814
2815     if (SvUTF8(rstr))
2816         o->op_private |= OPpTRANS_TO_UTF;
2817
2818     if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2819         SV* const listsv = newSVpvs("# comment\n");
2820         SV* transv = NULL;
2821         const U8* tend = t + tlen;
2822         const U8* rend = r + rlen;
2823         STRLEN ulen;
2824         UV tfirst = 1;
2825         UV tlast = 0;
2826         IV tdiff;
2827         UV rfirst = 1;
2828         UV rlast = 0;
2829         IV rdiff;
2830         IV diff;
2831         I32 none = 0;
2832         U32 max = 0;
2833         I32 bits;
2834         I32 havefinal = 0;
2835         U32 final = 0;
2836         const I32 from_utf  = o->op_private & OPpTRANS_FROM_UTF;
2837         const I32 to_utf    = o->op_private & OPpTRANS_TO_UTF;
2838         U8* tsave = NULL;
2839         U8* rsave = NULL;
2840         const U32 flags = UTF8_ALLOW_DEFAULT;
2841
2842         if (!from_utf) {
2843             STRLEN len = tlen;
2844             t = tsave = bytes_to_utf8(t, &len);
2845             tend = t + len;
2846         }
2847         if (!to_utf && rlen) {
2848             STRLEN len = rlen;
2849             r = rsave = bytes_to_utf8(r, &len);
2850             rend = r + len;
2851         }
2852
2853 /* There are several snags with this code on EBCDIC:
2854    1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2855    2. scan_const() in toke.c has encoded chars in native encoding which makes
2856       ranges at least in EBCDIC 0..255 range the bottom odd.
2857 */
2858
2859         if (complement) {
2860             U8 tmpbuf[UTF8_MAXBYTES+1];
2861             UV *cp;
2862             UV nextmin = 0;
2863             Newx(cp, 2*tlen, UV);
2864             i = 0;
2865             transv = newSVpvs("");
2866             while (t < tend) {
2867                 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
2868                 t += ulen;
2869                 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2870                     t++;
2871                     cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
2872                     t += ulen;
2873                 }
2874                 else {
2875                  cp[2*i+1] = cp[2*i];
2876                 }
2877                 i++;
2878             }
2879             qsort(cp, i, 2*sizeof(UV), uvcompare);
2880             for (j = 0; j < i; j++) {
2881                 UV  val = cp[2*j];
2882                 diff = val - nextmin;
2883                 if (diff > 0) {
2884                     t = uvuni_to_utf8(tmpbuf,nextmin);
2885                     sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2886                     if (diff > 1) {
2887                         U8  range_mark = UTF_TO_NATIVE(0xff);
2888                         t = uvuni_to_utf8(tmpbuf, val - 1);
2889                         sv_catpvn(transv, (char *)&range_mark, 1);
2890                         sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2891                     }
2892                 }
2893                 val = cp[2*j+1];
2894                 if (val >= nextmin)
2895                     nextmin = val + 1;
2896             }
2897             t = uvuni_to_utf8(tmpbuf,nextmin);
2898             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2899             {
2900                 U8 range_mark = UTF_TO_NATIVE(0xff);
2901                 sv_catpvn(transv, (char *)&range_mark, 1);
2902             }
2903             t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2904                                     UNICODE_ALLOW_SUPER);
2905             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2906             t = (const U8*)SvPVX_const(transv);
2907             tlen = SvCUR(transv);
2908             tend = t + tlen;
2909             Safefree(cp);
2910         }
2911         else if (!rlen && !del) {
2912             r = t; rlen = tlen; rend = tend;
2913         }
2914         if (!squash) {
2915                 if ((!rlen && !del) || t == r ||
2916                     (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2917                 {
2918                     o->op_private |= OPpTRANS_IDENTICAL;
2919                 }
2920         }
2921
2922         while (t < tend || tfirst <= tlast) {
2923             /* see if we need more "t" chars */
2924             if (tfirst > tlast) {
2925                 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
2926                 t += ulen;
2927                 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {    /* illegal utf8 val indicates range */
2928                     t++;
2929                     tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
2930                     t += ulen;
2931                 }
2932                 else
2933                     tlast = tfirst;
2934             }
2935
2936             /* now see if we need more "r" chars */
2937             if (rfirst > rlast) {
2938                 if (r < rend) {
2939                     rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
2940                     r += ulen;
2941                     if (r < rend && NATIVE_TO_UTF(*r) == 0xff) {        /* illegal utf8 val indicates range */
2942                         r++;
2943                         rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
2944                         r += ulen;
2945                     }
2946                     else
2947                         rlast = rfirst;
2948                 }
2949                 else {
2950                     if (!havefinal++)
2951                         final = rlast;
2952                     rfirst = rlast = 0xffffffff;
2953                 }
2954             }
2955
2956             /* now see which range will peter our first, if either. */
2957             tdiff = tlast - tfirst;
2958             rdiff = rlast - rfirst;
2959
2960             if (tdiff <= rdiff)
2961                 diff = tdiff;
2962             else
2963                 diff = rdiff;
2964
2965             if (rfirst == 0xffffffff) {
2966                 diff = tdiff;   /* oops, pretend rdiff is infinite */
2967                 if (diff > 0)
2968                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2969                                    (long)tfirst, (long)tlast);
2970                 else
2971                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2972             }
2973             else {
2974                 if (diff > 0)
2975                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2976                                    (long)tfirst, (long)(tfirst + diff),
2977                                    (long)rfirst);
2978                 else
2979                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2980                                    (long)tfirst, (long)rfirst);
2981
2982                 if (rfirst + diff > max)
2983                     max = rfirst + diff;
2984                 if (!grows)
2985                     grows = (tfirst < rfirst &&
2986                              UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2987                 rfirst += diff + 1;
2988             }
2989             tfirst += diff + 1;
2990         }
2991
2992         none = ++max;
2993         if (del)
2994             del = ++max;
2995
2996         if (max > 0xffff)
2997             bits = 32;
2998         else if (max > 0xff)
2999             bits = 16;
3000         else
3001             bits = 8;
3002
3003         Safefree(cPVOPo->op_pv);
3004         cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
3005         SvREFCNT_dec(listsv);
3006         SvREFCNT_dec(transv);
3007
3008         if (!del && havefinal && rlen)
3009             (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
3010                            newSVuv((UV)final), 0);
3011
3012         if (grows)
3013             o->op_private |= OPpTRANS_GROWS;
3014
3015         Safefree(tsave);
3016         Safefree(rsave);
3017
3018 #ifdef PERL_MAD
3019         op_getmad(expr,o,'e');
3020         op_getmad(repl,o,'r');
3021 #else
3022         op_free(expr);
3023         op_free(repl);
3024 #endif
3025         return o;
3026     }
3027
3028     tbl = (short*)cPVOPo->op_pv;
3029     if (complement) {
3030         Zero(tbl, 256, short);
3031         for (i = 0; i < (I32)tlen; i++)
3032             tbl[t[i]] = -1;
3033         for (i = 0, j = 0; i < 256; i++) {
3034             if (!tbl[i]) {
3035                 if (j >= (I32)rlen) {
3036                     if (del)
3037                         tbl[i] = -2;
3038                     else if (rlen)
3039                         tbl[i] = r[j-1];
3040                     else
3041                         tbl[i] = (short)i;
3042                 }
3043                 else {
3044                     if (i < 128 && r[j] >= 128)
3045                         grows = 1;
3046                     tbl[i] = r[j++];
3047                 }
3048             }
3049         }
3050         if (!del) {
3051             if (!rlen) {
3052                 j = rlen;
3053                 if (!squash)
3054                     o->op_private |= OPpTRANS_IDENTICAL;
3055             }
3056             else if (j >= (I32)rlen)
3057                 j = rlen - 1;
3058             else
3059                 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
3060             tbl[0x100] = (short)(rlen - j);
3061             for (i=0; i < (I32)rlen - j; i++)
3062                 tbl[0x101+i] = r[j+i];
3063         }
3064     }
3065     else {
3066         if (!rlen && !del) {
3067             r = t; rlen = tlen;
3068             if (!squash)
3069                 o->op_private |= OPpTRANS_IDENTICAL;
3070         }
3071         else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3072             o->op_private |= OPpTRANS_IDENTICAL;
3073         }
3074         for (i = 0; i < 256; i++)
3075             tbl[i] = -1;
3076         for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
3077             if (j >= (I32)rlen) {
3078                 if (del) {
3079                     if (tbl[t[i]] == -1)
3080                         tbl[t[i]] = -2;
3081                     continue;
3082                 }
3083                 --j;
3084             }
3085             if (tbl[t[i]] == -1) {
3086                 if (t[i] < 128 && r[j] >= 128)
3087                     grows = 1;
3088                 tbl[t[i]] = r[j];
3089             }
3090         }
3091     }
3092     if (grows)
3093         o->op_private |= OPpTRANS_GROWS;
3094 #ifdef PERL_MAD
3095     op_getmad(expr,o,'e');
3096     op_getmad(repl,o,'r');
3097 #else
3098     op_free(expr);
3099     op_free(repl);
3100 #endif
3101
3102     return o;
3103 }
3104
3105 OP *
3106 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3107 {
3108     dVAR;
3109     PMOP *pmop;
3110
3111     NewOp(1101, pmop, 1, PMOP);
3112     pmop->op_type = (OPCODE)type;
3113     pmop->op_ppaddr = PL_ppaddr[type];
3114     pmop->op_flags = (U8)flags;
3115     pmop->op_private = (U8)(0 | (flags >> 8));
3116
3117     if (PL_hints & HINT_RE_TAINT)
3118         pmop->op_pmpermflags |= PMf_RETAINT;
3119     if (PL_hints & HINT_LOCALE)
3120         pmop->op_pmpermflags |= PMf_LOCALE;
3121     pmop->op_pmflags = pmop->op_pmpermflags;
3122
3123 #ifdef USE_ITHREADS
3124     if (av_len((AV*) PL_regex_pad[0]) > -1) {
3125         SV * const repointer = av_pop((AV*)PL_regex_pad[0]);
3126         pmop->op_pmoffset = SvIV(repointer);
3127         SvREPADTMP_off(repointer);
3128         sv_setiv(repointer,0);
3129     } else {
3130         SV * const repointer = newSViv(0);
3131         av_push(PL_regex_padav, SvREFCNT_inc_simple_NN(repointer));
3132         pmop->op_pmoffset = av_len(PL_regex_padav);
3133         PL_regex_pad = AvARRAY(PL_regex_padav);
3134     }
3135 #endif
3136
3137         /* link into pm list */
3138     if (type != OP_TRANS && PL_curstash) {
3139         MAGIC *mg = mg_find((SV*)PL_curstash, PERL_MAGIC_symtab);
3140
3141         if (!mg) {
3142             mg = sv_magicext((SV*)PL_curstash, 0, PERL_MAGIC_symtab, 0, 0, 0);
3143         }
3144         pmop->op_pmnext = (PMOP*)mg->mg_obj;
3145         mg->mg_obj = (SV*)pmop;
3146         PmopSTASH_set(pmop,PL_curstash);
3147     }
3148
3149     return CHECKOP(type, pmop);
3150 }
3151
3152 /* Given some sort of match op o, and an expression expr containing a
3153  * pattern, either compile expr into a regex and attach it to o (if it's
3154  * constant), or convert expr into a runtime regcomp op sequence (if it's
3155  * not)
3156  *
3157  * isreg indicates that the pattern is part of a regex construct, eg
3158  * $x =~ /pattern/ or split /pattern/, as opposed to $x =~ $pattern or
3159  * split "pattern", which aren't. In the former case, expr will be a list
3160  * if the pattern contains more than one term (eg /a$b/) or if it contains
3161  * a replacement, ie s/// or tr///.
3162  */
3163
3164 OP *
3165 Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
3166 {
3167     dVAR;
3168     PMOP *pm;
3169     LOGOP *rcop;
3170     I32 repl_has_vars = 0;
3171     OP* repl = NULL;
3172     bool reglist;
3173
3174     if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
3175         /* last element in list is the replacement; pop it */
3176         OP* kid;
3177         repl = cLISTOPx(expr)->op_last;
3178         kid = cLISTOPx(expr)->op_first;
3179         while (kid->op_sibling != repl)
3180             kid = kid->op_sibling;
3181         kid->op_sibling = NULL;
3182         cLISTOPx(expr)->op_last = kid;
3183     }
3184
3185     if (isreg && expr->op_type == OP_LIST &&
3186         cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
3187     {
3188         /* convert single element list to element */
3189         OP* const oe = expr;
3190         expr = cLISTOPx(oe)->op_first->op_sibling;
3191         cLISTOPx(oe)->op_first->op_sibling = NULL;
3192         cLISTOPx(oe)->op_last = NULL;
3193         op_free(oe);
3194     }
3195
3196     if (o->op_type == OP_TRANS) {
3197         return pmtrans(o, expr, repl);
3198     }
3199
3200     reglist = isreg && expr->op_type == OP_LIST;
3201     if (reglist)
3202         op_null(expr);
3203
3204     PL_hints |= HINT_BLOCK_SCOPE;
3205     pm = (PMOP*)o;
3206
3207     if (expr->op_type == OP_CONST) {
3208         STRLEN plen;
3209         SV * const pat = ((SVOP*)expr)->op_sv;
3210         const char *p = SvPV_const(pat, plen);
3211         if ((o->op_flags & OPf_SPECIAL) && (*p == ' ' && p[1] == '\0')) {
3212             U32 was_readonly = SvREADONLY(pat);
3213
3214             if (was_readonly) {
3215                 if (SvFAKE(pat)) {
3216                     sv_force_normal_flags(pat, 0);
3217                     assert(!SvREADONLY(pat));
3218                     was_readonly = 0;
3219                 } else {
3220                     SvREADONLY_off(pat);
3221                 }
3222             }   
3223
3224             sv_setpvn(pat, "\\s+", 3);
3225
3226             SvFLAGS(pat) |= was_readonly;
3227
3228             p = SvPV_const(pat, plen);
3229             pm->op_pmflags |= PMf_SKIPWHITE;
3230         }
3231         if (DO_UTF8(pat))
3232             pm->op_pmdynflags |= PMdf_UTF8;
3233         /* FIXME - can we make this function take const char * args?  */
3234         PM_SETRE(pm, CALLREGCOMP(aTHX_ (char*)p, (char*)p + plen, pm));
3235         if (strEQ("\\s+", PM_GETRE(pm)->precomp))
3236             pm->op_pmflags |= PMf_WHITE;
3237 #ifdef PERL_MAD
3238         op_getmad(expr,(OP*)pm,'e');
3239 #else
3240         op_free(expr);
3241 #endif
3242     }
3243     else {
3244         if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3245             expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3246                             ? OP_REGCRESET
3247                             : OP_REGCMAYBE),0,expr);
3248
3249         NewOp(1101, rcop, 1, LOGOP);
3250         rcop->op_type = OP_REGCOMP;
3251         rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3252         rcop->op_first = scalar(expr);
3253         rcop->op_flags |= OPf_KIDS
3254                             | ((PL_hints & HINT_RE_EVAL) ? OPf_SPECIAL : 0)
3255                             | (reglist ? OPf_STACKED : 0);
3256         rcop->op_private = 1;
3257         rcop->op_other = o;
3258         if (reglist)
3259             rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
3260
3261         /* /$x/ may cause an eval, since $x might be qr/(?{..})/  */
3262         PL_cv_has_eval = 1;
3263
3264         /* establish postfix order */
3265         if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3266             LINKLIST(expr);
3267             rcop->op_next = expr;
3268             ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3269         }
3270         else {
3271             rcop->op_next = LINKLIST(expr);
3272             expr->op_next = (OP*)rcop;
3273         }
3274
3275         prepend_elem(o->op_type, scalar((OP*)rcop), o);
3276     }
3277
3278     if (repl) {
3279         OP *curop;
3280         if (pm->op_pmflags & PMf_EVAL) {
3281             curop = NULL;
3282             if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
3283                 CopLINE_set(PL_curcop, (line_t)PL_multi_end);
3284         }
3285         else if (repl->op_type == OP_CONST)
3286             curop = repl;
3287         else {
3288             OP *lastop = NULL;
3289             for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3290                 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3291                     if (curop->op_type == OP_GV) {
3292                         GV * const gv = cGVOPx_gv(curop);
3293                         repl_has_vars = 1;
3294                         if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
3295                             break;
3296                     }
3297                     else if (curop->op_type == OP_RV2CV)
3298                         break;
3299                     else if (curop->op_type == OP_RV2SV ||
3300                              curop->op_type == OP_RV2AV ||
3301                              curop->op_type == OP_RV2HV ||
3302                              curop->op_type == OP_RV2GV) {
3303                         if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3304                             break;
3305                     }
3306                     else if (curop->op_type == OP_PADSV ||
3307                              curop->op_type == OP_PADAV ||
3308                              curop->op_type == OP_PADHV ||
3309                              curop->op_type == OP_PADANY) {
3310                         repl_has_vars = 1;
3311                     }
3312                     else if (curop->op_type == OP_PUSHRE)
3313                         NOOP; /* Okay here, dangerous in newASSIGNOP */
3314                     else
3315                         break;
3316                 }
3317                 lastop = curop;
3318             }
3319         }
3320         if (curop == repl
3321             && !(repl_has_vars
3322                  && (!PM_GETRE(pm)
3323                      || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
3324             pm->op_pmflags |= PMf_CONST;        /* const for long enough */
3325             pm->op_pmpermflags |= PMf_CONST;    /* const for long enough */
3326             prepend_elem(o->op_type, scalar(repl), o);
3327         }
3328         else {
3329             if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3330                 pm->op_pmflags |= PMf_MAYBE_CONST;
3331                 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3332             }
3333             NewOp(1101, rcop, 1, LOGOP);
3334             rcop->op_type = OP_SUBSTCONT;
3335             rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3336             rcop->op_first = scalar(repl);
3337             rcop->op_flags |= OPf_KIDS;
3338             rcop->op_private = 1;
3339             rcop->op_other = o;
3340
3341             /* establish postfix order */
3342             rcop->op_next = LINKLIST(repl);
3343             repl->op_next = (OP*)rcop;
3344
3345             pm->op_pmreplroot = scalar((OP*)rcop);
3346             pm->op_pmreplstart = LINKLIST(rcop);
3347             rcop->op_next = 0;
3348         }
3349     }
3350
3351     return (OP*)pm;
3352 }
3353
3354 OP *
3355 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3356 {
3357     dVAR;
3358     SVOP *svop;
3359     NewOp(1101, svop, 1, SVOP);
3360     svop->op_type = (OPCODE)type;
3361     svop->op_ppaddr = PL_ppaddr[type];
3362     svop->op_sv = sv;
3363     svop->op_next = (OP*)svop;
3364     svop->op_flags = (U8)flags;
3365     if (PL_opargs[type] & OA_RETSCALAR)
3366         scalar((OP*)svop);
3367     if (PL_opargs[type] & OA_TARGET)
3368         svop->op_targ = pad_alloc(type, SVs_PADTMP);
3369     return CHECKOP(type, svop);
3370 }
3371
3372 OP *
3373 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3374 {
3375     dVAR;
3376     PADOP *padop;
3377     NewOp(1101, padop, 1, PADOP);
3378     padop->op_type = (OPCODE)type;
3379     padop->op_ppaddr = PL_ppaddr[type];
3380     padop->op_padix = pad_alloc(type, SVs_PADTMP);
3381     SvREFCNT_dec(PAD_SVl(padop->op_padix));
3382     PAD_SETSV(padop->op_padix, sv);
3383     if (sv)
3384         SvPADTMP_on(sv);
3385     padop->op_next = (OP*)padop;
3386     padop->op_flags = (U8)flags;
3387     if (PL_opargs[type] & OA_RETSCALAR)
3388         scalar((OP*)padop);
3389     if (PL_opargs[type] & OA_TARGET)
3390         padop->op_targ = pad_alloc(type, SVs_PADTMP);
3391     return CHECKOP(type, padop);
3392 }
3393
3394 OP *
3395 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3396 {
3397     dVAR;
3398 #ifdef USE_ITHREADS
3399     if (gv)
3400         GvIN_PAD_on(gv);
3401     return newPADOP(type, flags, SvREFCNT_inc_simple(gv));
3402 #else
3403     return newSVOP(type, flags, SvREFCNT_inc_simple(gv));
3404 #endif
3405 }
3406
3407 OP *
3408 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3409 {
3410     dVAR;
3411     PVOP *pvop;
3412     NewOp(1101, pvop, 1, PVOP);
3413     pvop->op_type = (OPCODE)type;
3414     pvop->op_ppaddr = PL_ppaddr[type];
3415     pvop->op_pv = pv;
3416     pvop->op_next = (OP*)pvop;
3417     pvop->op_flags = (U8)flags;
3418     if (PL_opargs[type] & OA_RETSCALAR)
3419         scalar((OP*)pvop);
3420     if (PL_opargs[type] & OA_TARGET)
3421         pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3422     return CHECKOP(type, pvop);
3423 }
3424
3425 #ifdef PERL_MAD
3426 OP*
3427 #else
3428 void
3429 #endif
3430 Perl_package(pTHX_ OP *o)
3431 {
3432     dVAR;
3433     const char *name;
3434     STRLEN len;
3435 #ifdef PERL_MAD
3436     OP *pegop;
3437 #endif
3438
3439     save_hptr(&PL_curstash);
3440     save_item(PL_curstname);
3441
3442     name = SvPV_const(cSVOPo->op_sv, len);
3443     PL_curstash = gv_stashpvn(name, len, TRUE);
3444     sv_setpvn(PL_curstname, name, len);
3445
3446     PL_hints |= HINT_BLOCK_SCOPE;
3447     PL_copline = NOLINE;
3448     PL_expect = XSTATE;
3449
3450 #ifndef PERL_MAD
3451     op_free(o);
3452 #else
3453     if (!PL_madskills) {
3454         op_free(o);
3455         return NULL;
3456     }
3457
3458     pegop = newOP(OP_NULL,0);
3459     op_getmad(o,pegop,'P');
3460     return pegop;
3461 #endif
3462 }
3463
3464 #ifdef PERL_MAD
3465 OP*
3466 #else
3467 void
3468 #endif
3469 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
3470 {
3471     dVAR;
3472     OP *pack;
3473     OP *imop;
3474     OP *veop;
3475 #ifdef PERL_MAD
3476     OP *pegop = newOP(OP_NULL,0);
3477 #endif
3478
3479     if (idop->op_type != OP_CONST)
3480         Perl_croak(aTHX_ "Module name must be constant");
3481
3482     if (PL_madskills)
3483         op_getmad(idop,pegop,'U');
3484
3485     veop = NULL;
3486
3487     if (version) {
3488         SV * const vesv = ((SVOP*)version)->op_sv;
3489
3490         if (PL_madskills)
3491             op_getmad(version,pegop,'V');
3492         if (!arg && !SvNIOKp(vesv)) {
3493             arg = version;
3494         }
3495         else {
3496             OP *pack;
3497             SV *meth;
3498
3499             if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3500                 Perl_croak(aTHX_ "Version number must be constant number");
3501
3502             /* Make copy of idop so we don't free it twice */
3503             pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3504
3505             /* Fake up a method call to VERSION */
3506             meth = newSVpvs_share("VERSION");
3507             veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3508                             append_elem(OP_LIST,
3509                                         prepend_elem(OP_LIST, pack, list(version)),
3510                                         newSVOP(OP_METHOD_NAMED, 0, meth)));
3511         }
3512     }
3513
3514     /* Fake up an import/unimport */
3515     if (arg && arg->op_type == OP_STUB) {
3516         if (PL_madskills)
3517             op_getmad(arg,pegop,'S');
3518         imop = arg;             /* no import on explicit () */
3519     }
3520     else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
3521         imop = NULL;            /* use 5.0; */
3522         if (!aver)
3523             idop->op_private |= OPpCONST_NOVER;
3524     }
3525     else {
3526         SV *meth;
3527
3528         if (PL_madskills)
3529             op_getmad(arg,pegop,'A');
3530
3531         /* Make copy of idop so we don't free it twice */
3532         pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
3533
3534         /* Fake up a method call to import/unimport */
3535         meth = aver
3536             ? newSVpvs_share("import") : newSVpvs_share("unimport");
3537         imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3538                        append_elem(OP_LIST,
3539                                    prepend_elem(OP_LIST, pack, list(arg)),
3540                                    newSVOP(OP_METHOD_NAMED, 0, meth)));
3541     }
3542
3543     /* Fake up the BEGIN {}, which does its thing immediately. */
3544     newATTRSUB(floor,
3545         newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
3546         NULL,
3547         NULL,
3548         append_elem(OP_LINESEQ,
3549             append_elem(OP_LINESEQ,
3550                 newSTATEOP(0, NULL, newUNOP(OP_REQUIRE, 0, idop)),
3551                 newSTATEOP(0, NULL, veop)),
3552             newSTATEOP(0, NULL, imop) ));
3553
3554     /* The "did you use incorrect case?" warning used to be here.
3555      * The problem is that on case-insensitive filesystems one
3556      * might get false positives for "use" (and "require"):
3557      * "use Strict" or "require CARP" will work.  This causes
3558      * portability problems for the script: in case-strict
3559      * filesystems the script will stop working.
3560      *
3561      * The "incorrect case" warning checked whether "use Foo"
3562      * imported "Foo" to your namespace, but that is wrong, too:
3563      * there is no requirement nor promise in the language that
3564      * a Foo.pm should or would contain anything in package "Foo".
3565      *
3566      * There is very little Configure-wise that can be done, either:
3567      * the case-sensitivity of the build filesystem of Perl does not
3568      * help in guessing the case-sensitivity of the runtime environment.
3569      */
3570
3571     PL_hints |= HINT_BLOCK_SCOPE;
3572     PL_copline = NOLINE;
3573     PL_expect = XSTATE;
3574     PL_cop_seqmax++; /* Purely for B::*'s benefit */
3575
3576 #ifdef PERL_MAD
3577     if (!PL_madskills) {
3578         /* FIXME - don't allocate pegop if !PL_madskills */
3579         op_free(pegop);
3580         return NULL;
3581     }
3582     return pegop;
3583 #endif
3584 }
3585
3586 /*
3587 =head1 Embedding Functions
3588
3589 =for apidoc load_module
3590
3591 Loads the module whose name is pointed to by the string part of name.
3592 Note that the actual module name, not its filename, should be given.
3593 Eg, "Foo::Bar" instead of "Foo/Bar.pm".  flags can be any of
3594 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3595 (or 0 for no flags). ver, if specified, provides version semantics
3596 similar to C<use Foo::Bar VERSION>.  The optional trailing SV*
3597 arguments can be used to specify arguments to the module's import()
3598 method, similar to C<use Foo::Bar VERSION LIST>.
3599
3600 =cut */
3601
3602 void
3603 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3604 {
3605     va_list args;
3606     va_start(args, ver);
3607     vload_module(flags, name, ver, &args);
3608     va_end(args);
3609 }
3610
3611 #ifdef PERL_IMPLICIT_CONTEXT
3612 void
3613 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3614 {
3615     dTHX;
3616     va_list args;
3617     va_start(args, ver);
3618     vload_module(flags, name, ver, &args);
3619     va_end(args);
3620 }
3621 #endif
3622
3623 void
3624 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3625 {
3626     dVAR;
3627     OP *veop, *imop;
3628
3629     OP * const modname = newSVOP(OP_CONST, 0, name);
3630     modname->op_private |= OPpCONST_BARE;
3631     if (ver) {
3632         veop = newSVOP(OP_CONST, 0, ver);
3633     }
3634     else
3635         veop = NULL;
3636     if (flags & PERL_LOADMOD_NOIMPORT) {
3637         imop = sawparens(newNULLLIST());
3638     }
3639     else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3640         imop = va_arg(*args, OP*);
3641     }
3642     else {
3643         SV *sv;
3644         imop = NULL;
3645         sv = va_arg(*args, SV*);
3646         while (sv) {
3647             imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3648             sv = va_arg(*args, SV*);
3649         }
3650     }
3651     {
3652         const line_t ocopline = PL_copline;
3653         COP * const ocurcop = PL_curcop;
3654         const int oexpect = PL_expect;
3655
3656         utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3657                 veop, modname, imop);
3658         PL_expect = oexpect;
3659         PL_copline = ocopline;
3660         PL_curcop = ocurcop;
3661     }
3662 }
3663
3664 OP *
3665 Perl_dofile(pTHX_ OP *term, I32 force_builtin)
3666 {
3667     dVAR;
3668     OP *doop;
3669     GV *gv = NULL;
3670
3671     if (!force_builtin) {
3672         gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
3673         if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
3674             GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", FALSE);
3675             gv = gvp ? *gvp : NULL;
3676         }
3677     }
3678
3679     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3680         doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3681                                append_elem(OP_LIST, term,
3682                                            scalar(newUNOP(OP_RV2CV, 0,
3683                                                           newGVOP(OP_GV, 0, gv))))));
3684     }
3685     else {
3686         doop = newUNOP(OP_DOFILE, 0, scalar(term));
3687     }
3688     return doop;
3689 }
3690
3691 OP *
3692 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3693 {
3694     return newBINOP(OP_LSLICE, flags,
3695             list(force_list(subscript)),
3696             list(force_list(listval)) );
3697 }
3698
3699 STATIC I32
3700 S_is_list_assignment(pTHX_ register const OP *o)
3701 {
3702     unsigned type;
3703     U8 flags;
3704
3705     if (!o)
3706         return TRUE;
3707
3708     if ((o->op_type == OP_NULL) && (o->op_flags & OPf_KIDS))
3709         o = cUNOPo->op_first;
3710
3711     flags = o->op_flags;
3712     type = o->op_type;
3713     if (type == OP_COND_EXPR) {
3714         const I32 t = is_list_assignment(cLOGOPo->op_first->op_sibling);
3715         const I32 f = is_list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3716
3717         if (t && f)
3718             return TRUE;
3719         if (t || f)
3720             yyerror("Assignment to both a list and a scalar");
3721         return FALSE;
3722     }
3723
3724     if (type == OP_LIST &&
3725         (flags & OPf_WANT) == OPf_WANT_SCALAR &&
3726         o->op_private & OPpLVAL_INTRO)
3727         return FALSE;
3728
3729     if (type == OP_LIST || flags & OPf_PARENS ||
3730         type == OP_RV2AV || type == OP_RV2HV ||
3731         type == OP_ASLICE || type == OP_HSLICE)
3732         return TRUE;
3733
3734     if (type == OP_PADAV || type == OP_PADHV)
3735         return TRUE;
3736
3737     if (type == OP_RV2SV)
3738         return FALSE;
3739
3740     return FALSE;
3741 }
3742
3743 OP *
3744 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3745 {
3746     dVAR;
3747     OP *o;
3748
3749     if (optype) {
3750         if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
3751             return newLOGOP(optype, 0,
3752                 mod(scalar(left), optype),
3753                 newUNOP(OP_SASSIGN, 0, scalar(right)));
3754         }
3755         else {
3756             return newBINOP(optype, OPf_STACKED,
3757                 mod(scalar(left), optype), scalar(right));
3758         }
3759     }
3760
3761     if (is_list_assignment(left)) {
3762         OP *curop;
3763
3764         PL_modcount = 0;
3765         /* Grandfathering $[ assignment here.  Bletch.*/
3766         /* Only simple assignments like C<< ($[) = 1 >> are allowed */
3767         PL_eval_start = (left->op_type == OP_CONST) ? right : 0;
3768         left = mod(left, OP_AASSIGN);
3769         if (PL_eval_start)
3770             PL_eval_start = 0;
3771         else if (left->op_type == OP_CONST) {
3772             /* FIXME for MAD */
3773             /* Result of assignment is always 1 (or we'd be dead already) */
3774             return newSVOP(OP_CONST, 0, newSViv(1));
3775         }
3776         curop = list(force_list(left));
3777         o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3778         o->op_private = (U8)(0 | (flags >> 8));
3779
3780         /* PL_generation sorcery:
3781          * an assignment like ($a,$b) = ($c,$d) is easier than
3782          * ($a,$b) = ($c,$a), since there is no need for temporary vars.
3783          * To detect whether there are common vars, the global var
3784          * PL_generation is incremented for each assign op we compile.
3785          * Then, while compiling the assign op, we run through all the
3786          * variables on both sides of the assignment, setting a spare slot
3787          * in each of them to PL_generation. If any of them already have
3788          * that value, we know we've got commonality.  We could use a
3789          * single bit marker, but then we'd have to make 2 passes, first
3790          * to clear the flag, then to test and set it.  To find somewhere
3791          * to store these values, evil chicanery is done with SvCUR().
3792          */
3793
3794         if (!(left->op_private & OPpLVAL_INTRO)) {
3795             OP *lastop = o;
3796             PL_generation++;
3797             for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3798                 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3799                     if (curop->op_type == OP_GV) {
3800                         GV *gv = cGVOPx_gv(curop);
3801                         if (gv == PL_defgv
3802                             || (int)GvASSIGN_GENERATION(gv) == PL_generation)
3803                             break;
3804                         GvASSIGN_GENERATION_set(gv, PL_generation);
3805                     }
3806                     else if (curop->op_type == OP_PADSV ||
3807                              curop->op_type == OP_PADAV ||
3808                              curop->op_type == OP_PADHV ||
3809                              curop->op_type == OP_PADANY)
3810                     {
3811                         if (PAD_COMPNAME_GEN(curop->op_targ)
3812                                                     == (STRLEN)PL_generation)
3813                             break;
3814                         PAD_COMPNAME_GEN_set(curop->op_targ, PL_generation);
3815
3816                     }
3817                     else if (curop->op_type == OP_RV2CV)
3818                         break;
3819                     else if (curop->op_type == OP_RV2SV ||
3820                              curop->op_type == OP_RV2AV ||
3821                              curop->op_type == OP_RV2HV ||
3822                              curop->op_type == OP_RV2GV) {
3823                         if (lastop->op_type != OP_GV)   /* funny deref? */
3824                             break;
3825                     }
3826                     else if (curop->op_type == OP_PUSHRE) {
3827                         if (((PMOP*)curop)->op_pmreplroot) {
3828 #ifdef USE_ITHREADS
3829                             GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
3830                                         ((PMOP*)curop)->op_pmreplroot));
3831 #else
3832                             GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3833 #endif
3834                             if (gv == PL_defgv
3835                                 || (int)GvASSIGN_GENERATION(gv) == PL_generation)
3836                                 break;
3837                             GvASSIGN_GENERATION_set(gv, PL_generation);
3838                             GvASSIGN_GENERATION_set(gv, PL_generation);
3839                         }
3840                     }
3841                     else
3842                         break;
3843                 }
3844                 lastop = curop;
3845             }
3846             if (curop != o)
3847                 o->op_private |= OPpASSIGN_COMMON;
3848         }
3849         if (right && right->op_type == OP_SPLIT) {
3850             OP* tmpop = ((LISTOP*)right)->op_first;
3851             if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
3852                 PMOP * const pm = (PMOP*)tmpop;
3853                 if (left->op_type == OP_RV2AV &&
3854                     !(left->op_private & OPpLVAL_INTRO) &&
3855                     !(o->op_private & OPpASSIGN_COMMON) )
3856                 {
3857                     tmpop = ((UNOP*)left)->op_first;
3858                     if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3859 #ifdef USE_ITHREADS
3860                         pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3861                         cPADOPx(tmpop)->op_padix = 0;   /* steal it */
3862 #else
3863                         pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3864                         cSVOPx(tmpop)->op_sv = NULL;    /* steal it */
3865 #endif
3866                         pm->op_pmflags |= PMf_ONCE;
3867                         tmpop = cUNOPo->op_first;       /* to list (nulled) */
3868                         tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3869                         tmpop->op_sibling = NULL;       /* don't free split */
3870                         right->op_next = tmpop->op_next;  /* fix starting loc */
3871 #ifdef PERL_MAD
3872                         op_getmad(o,right,'R');         /* blow off assign */
3873 #else
3874                         op_free(o);                     /* blow off assign */
3875 #endif
3876                         right->op_flags &= ~OPf_WANT;
3877                                 /* "I don't know and I don't care." */
3878                         return right;
3879                     }
3880                 }
3881                 else {
3882                    if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3883                       ((LISTOP*)right)->op_last->op_type == OP_CONST)
3884                     {
3885                         SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3886                         if (SvIVX(sv) == 0)
3887                             sv_setiv(sv, PL_modcount+1);
3888                     }
3889                 }
3890             }
3891         }
3892         return o;
3893     }
3894     if (!right)
3895         right = newOP(OP_UNDEF, 0);
3896     if (right->op_type == OP_READLINE) {
3897         right->op_flags |= OPf_STACKED;
3898         return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3899     }
3900     else {
3901         PL_eval_start = right;  /* Grandfathering $[ assignment here.  Bletch.*/
3902         o = newBINOP(OP_SASSIGN, flags,
3903             scalar(right), mod(scalar(left), OP_SASSIGN) );
3904         if (PL_eval_start)
3905             PL_eval_start = 0;
3906         else {
3907             /* FIXME for MAD */
3908             op_free(o);
3909             o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
3910             o->op_private |= OPpCONST_ARYBASE;
3911         }
3912     }
3913     return o;
3914 }
3915
3916 OP *
3917 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3918 {
3919     dVAR;
3920     const U32 seq = intro_my();
3921     register COP *cop;
3922
3923     NewOp(1101, cop, 1, COP);
3924     if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3925         cop->op_type = OP_DBSTATE;
3926         cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3927     }
3928     else {
3929         cop->op_type = OP_NEXTSTATE;
3930         cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3931     }
3932     cop->op_flags = (U8)flags;
3933     CopHINTS_set(cop, PL_hints);
3934 #ifdef NATIVE_HINTS
3935     cop->op_private |= NATIVE_HINTS;
3936 #endif
3937     CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
3938     cop->op_next = (OP*)cop;
3939
3940     if (label) {
3941         cop->cop_label = label;
3942         PL_hints |= HINT_BLOCK_SCOPE;
3943     }
3944     cop->cop_seq = seq;
3945     CopARYBASE_set(cop, CopARYBASE_get(PL_curcop));
3946     cop->cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
3947     if (specialCopIO(PL_curcop->cop_io))
3948         cop->cop_io = PL_curcop->cop_io;
3949     else
3950         cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3951     cop->cop_hints = PL_curcop->cop_hints;
3952     if (cop->cop_hints) {
3953         HINTS_REFCNT_LOCK;
3954         cop->cop_hints->refcounted_he_refcnt++;
3955         HINTS_REFCNT_UNLOCK;
3956     }
3957
3958     if (PL_copline == NOLINE)
3959         CopLINE_set(cop, CopLINE(PL_curcop));
3960     else {
3961         CopLINE_set(cop, PL_copline);
3962         PL_copline = NOLINE;
3963     }
3964 #ifdef USE_ITHREADS
3965     CopFILE_set(cop, CopFILE(PL_curcop));       /* XXX share in a pvtable? */
3966 #else
3967     CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3968 #endif
3969     CopSTASH_set(cop, PL_curstash);
3970
3971     if (PERLDB_LINE && PL_curstash != PL_debstash) {
3972         SV * const * const svp = av_fetch(CopFILEAVx(PL_curcop), (I32)CopLINE(cop), FALSE);
3973         if (svp && *svp != &PL_sv_undef ) {
3974             (void)SvIOK_on(*svp);
3975             SvIV_set(*svp, PTR2IV(cop));
3976         }
3977     }
3978
3979     return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3980 }
3981
3982
3983 OP *
3984 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3985 {
3986     dVAR;
3987     return new_logop(type, flags, &first, &other);
3988 }
3989
3990 STATIC OP *
3991 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3992 {
3993     dVAR;
3994     LOGOP *logop;
3995     OP *o;
3996     OP *first = *firstp;
3997     OP * const other = *otherp;
3998
3999     if (type == OP_XOR)         /* Not short circuit, but here by precedence. */
4000         return newBINOP(type, flags, scalar(first), scalar(other));
4001
4002     scalarboolean(first);
4003     /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
4004     if (first->op_type == OP_NOT
4005         && (first->op_flags & OPf_SPECIAL)
4006         && (first->op_flags & OPf_KIDS)) {
4007         if (type == OP_AND || type == OP_OR) {
4008             if (type == OP_AND)
4009                 type = OP_OR;
4010             else
4011                 type = OP_AND;
4012             o = first;
4013             first = *firstp = cUNOPo->op_first;
4014             if (o->op_next)
4015                 first->op_next = o->op_next;
4016             cUNOPo->op_first = NULL;
4017 #ifdef PERL_MAD
4018             op_getmad(o,first,'O');
4019 #else
4020             op_free(o);
4021 #endif
4022         }
4023     }
4024     if (first->op_type == OP_CONST) {
4025         if (first->op_private & OPpCONST_STRICT)
4026             no_bareword_allowed(first);
4027         else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD))
4028                 Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
4029         if ((type == OP_AND &&  SvTRUE(((SVOP*)first)->op_sv)) ||
4030             (type == OP_OR  && !SvTRUE(((SVOP*)first)->op_sv)) ||
4031             (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) {
4032             *firstp = NULL;
4033             if (other->op_type == OP_CONST)
4034                 other->op_private |= OPpCONST_SHORTCIRCUIT;
4035             if (PL_madskills) {
4036                 OP *newop = newUNOP(OP_NULL, 0, other);
4037                 op_getmad(first, newop, '1');
4038                 newop->op_targ = type;  /* set "was" field */
4039                 return newop;
4040             }
4041             op_free(first);
4042             return other;
4043         }
4044         else {
4045             /* check for C<my $x if 0>, or C<my($x,$y) if 0> */
4046             const OP *o2 = other;
4047             if ( ! (o2->op_type == OP_LIST
4048                     && (( o2 = cUNOPx(o2)->op_first))
4049                     && o2->op_type == OP_PUSHMARK
4050                     && (( o2 = o2->op_sibling)) )
4051             )
4052                 o2 = other;
4053             if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
4054                         || o2->op_type == OP_PADHV)
4055                 && o2->op_private & OPpLVAL_INTRO
4056                 && ckWARN(WARN_DEPRECATED))
4057             {
4058                 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
4059                             "Deprecated use of my() in false conditional");
4060             }
4061
4062             *otherp = NULL;
4063             if (first->op_type == OP_CONST)
4064                 first->op_private |= OPpCONST_SHORTCIRCUIT;
4065             if (PL_madskills) {
4066                 first = newUNOP(OP_NULL, 0, first);
4067                 op_getmad(other, first, '2');
4068                 first->op_targ = type;  /* set "was" field */
4069             }
4070             else
4071                 op_free(other);
4072             return first;
4073         }
4074     }
4075     else if ((first->op_flags & OPf_KIDS) && type != OP_DOR
4076         && ckWARN(WARN_MISC)) /* [#24076] Don't warn for <FH> err FOO. */
4077     {
4078         const OP * const k1 = ((UNOP*)first)->op_first;
4079         const OP * const k2 = k1->op_sibling;
4080         OPCODE warnop = 0;
4081         switch (first->op_type)
4082         {
4083         case OP_NULL:
4084             if (k2 && k2->op_type == OP_READLINE
4085                   && (k2->op_flags & OPf_STACKED)
4086                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4087             {
4088                 warnop = k2->op_type;
4089             }
4090             break;
4091
4092         case OP_SASSIGN:
4093             if (k1->op_type == OP_READDIR
4094                   || k1->op_type == OP_GLOB
4095                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4096                   || k1->op_type == OP_EACH)
4097             {
4098                 warnop = ((k1->op_type == OP_NULL)
4099                           ? (OPCODE)k1->op_targ : k1->op_type);
4100             }
4101             break;
4102         }
4103         if (warnop) {
4104             const line_t oldline = CopLINE(PL_curcop);
4105             CopLINE_set(PL_curcop, PL_copline);
4106             Perl_warner(aTHX_ packWARN(WARN_MISC),
4107                  "Value of %s%s can be \"0\"; test with defined()",
4108                  PL_op_desc[warnop],
4109                  ((warnop == OP_READLINE || warnop == OP_GLOB)
4110                   ? " construct" : "() operator"));
4111             CopLINE_set(PL_curcop, oldline);
4112         }
4113     }
4114
4115     if (!other)
4116         return first;
4117
4118     if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
4119         other->op_private |= OPpASSIGN_BACKWARDS;  /* other is an OP_SASSIGN */
4120
4121     NewOp(1101, logop, 1, LOGOP);
4122
4123     logop->op_type = (OPCODE)type;
4124     logop->op_ppaddr = PL_ppaddr[type];
4125     logop->op_first = first;
4126     logop->op_flags = (U8)(flags | OPf_KIDS);
4127     logop->op_other = LINKLIST(other);
4128     logop->op_private = (U8)(1 | (flags >> 8));
4129
4130     /* establish postfix order */
4131     logop->op_next = LINKLIST(first);
4132     first->op_next = (OP*)logop;
4133     first->op_sibling = other;
4134
4135     CHECKOP(type,logop);
4136
4137     o = newUNOP(OP_NULL, 0, (OP*)logop);
4138     other->op_next = o;
4139
4140     return o;
4141 }
4142
4143 OP *
4144 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
4145 {
4146     dVAR;
4147     LOGOP *logop;
4148     OP *start;
4149     OP *o;
4150
4151     if (!falseop)
4152         return newLOGOP(OP_AND, 0, first, trueop);
4153     if (!trueop)
4154         return newLOGOP(OP_OR, 0, first, falseop);
4155
4156     scalarboolean(first);
4157     if (first->op_type == OP_CONST) {
4158         if (first->op_private & OPpCONST_BARE &&
4159             first->op_private & OPpCONST_STRICT) {
4160             no_bareword_allowed(first);
4161         }
4162         if (SvTRUE(((SVOP*)first)->op_sv)) {
4163 #ifdef PERL_MAD
4164             if (PL_madskills) {
4165                 trueop = newUNOP(OP_NULL, 0, trueop);
4166                 op_getmad(first,trueop,'C');
4167                 op_getmad(falseop,trueop,'e');
4168             }
4169             /* FIXME for MAD - should there be an ELSE here?  */
4170 #else
4171             op_free(first);
4172             op_free(falseop);
4173 #endif
4174             return trueop;
4175         }
4176         else {
4177 #ifdef PERL_MAD
4178             if (PL_madskills) {
4179                 falseop = newUNOP(OP_NULL, 0, falseop);
4180                 op_getmad(first,falseop,'C');
4181                 op_getmad(trueop,falseop,'t');
4182             }
4183             /* FIXME for MAD - should there be an ELSE here?  */
4184 #else
4185             op_free(first);
4186             op_free(trueop);
4187 #endif
4188             return falseop;
4189         }
4190     }
4191     NewOp(1101, logop, 1, LOGOP);
4192     logop->op_type = OP_COND_EXPR;
4193     logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4194     logop->op_first = first;
4195     logop->op_flags = (U8)(flags | OPf_KIDS);
4196     logop->op_private = (U8)(1 | (flags >> 8));
4197     logop->op_other = LINKLIST(trueop);
4198     logop->op_next = LINKLIST(falseop);
4199
4200     CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
4201             logop);
4202
4203     /* establish postfix order */
4204     start = LINKLIST(first);
4205     first->op_next = (OP*)logop;
4206
4207     first->op_sibling = trueop;
4208     trueop->op_sibling = falseop;
4209     o = newUNOP(OP_NULL, 0, (OP*)logop);
4210
4211     trueop->op_next = falseop->op_next = o;
4212
4213     o->op_next = start;
4214     return o;
4215 }
4216
4217 OP *
4218 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4219 {
4220     dVAR;
4221     LOGOP *range;
4222     OP *flip;
4223     OP *flop;
4224     OP *leftstart;
4225     OP *o;
4226
4227     NewOp(1101, range, 1, LOGOP);
4228
4229     range->op_type = OP_RANGE;
4230     range->op_ppaddr = PL_ppaddr[OP_RANGE];
4231     range->op_first = left;
4232     range->op_flags = OPf_KIDS;
4233     leftstart = LINKLIST(left);
4234     range->op_other = LINKLIST(right);
4235     range->op_private = (U8)(1 | (flags >> 8));
4236
4237     left->op_sibling = right;
4238
4239     range->op_next = (OP*)range;
4240     flip = newUNOP(OP_FLIP, flags, (OP*)range);
4241     flop = newUNOP(OP_FLOP, 0, flip);
4242     o = newUNOP(OP_NULL, 0, flop);
4243     linklist(flop);
4244     range->op_next = leftstart;
4245
4246     left->op_next = flip;
4247     right->op_next = flop;
4248
4249     range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4250     sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4251     flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4252     sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4253
4254     flip->op_private =  left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4255     flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4256
4257     flip->op_next = o;
4258     if (!flip->op_private || !flop->op_private)
4259         linklist(o);            /* blow off optimizer unless constant */
4260
4261     return o;
4262 }
4263
4264 OP *
4265 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4266 {
4267     dVAR;
4268     OP* listop;
4269     OP* o;
4270     const bool once = block && block->op_flags & OPf_SPECIAL &&
4271       (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4272
4273     PERL_UNUSED_ARG(debuggable);
4274
4275     if (expr) {
4276         if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4277             return block;       /* do {} while 0 does once */
4278         if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4279             || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4280             expr = newUNOP(OP_DEFINED, 0,
4281                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4282         } else if (expr->op_flags & OPf_KIDS) {
4283             const OP * const k1 = ((UNOP*)expr)->op_first;
4284             const OP * const k2 = k1 ? k1->op_sibling : NULL;
4285             switch (expr->op_type) {
4286               case OP_NULL:
4287                 if (k2 && k2->op_type == OP_READLINE
4288                       && (k2->op_flags & OPf_STACKED)
4289                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4290                     expr = newUNOP(OP_DEFINED, 0, expr);
4291                 break;
4292
4293               case OP_SASSIGN:
4294                 if (k1 && (k1->op_type == OP_READDIR
4295                       || k1->op_type == OP_GLOB
4296                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4297                       || k1->op_type == OP_EACH))
4298                     expr = newUNOP(OP_DEFINED, 0, expr);
4299                 break;
4300             }
4301         }
4302     }
4303
4304     /* if block is null, the next append_elem() would put UNSTACK, a scalar
4305      * op, in listop. This is wrong. [perl #27024] */
4306     if (!block)
4307         block = newOP(OP_NULL, 0);
4308     listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4309     o = new_logop(OP_AND, 0, &expr, &listop);
4310
4311     if (listop)
4312         ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4313
4314     if (once && o != listop)
4315         o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4316
4317     if (o == listop)
4318         o = newUNOP(OP_NULL, 0, o);     /* or do {} while 1 loses outer block */
4319
4320     o->op_flags |= flags;
4321     o = scope(o);
4322     o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4323     return o;
4324 }
4325
4326 OP *
4327 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
4328 whileline, OP *expr, OP *block, OP *cont, I32 has_my)
4329 {
4330     dVAR;
4331     OP *redo;
4332     OP *next = NULL;
4333     OP *listop;
4334     OP *o;
4335     U8 loopflags = 0;
4336
4337     PERL_UNUSED_ARG(debuggable);
4338
4339     if (expr) {
4340         if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4341                      || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4342             expr = newUNOP(OP_DEFINED, 0,
4343                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4344         } else if (expr->op_flags & OPf_KIDS) {
4345             const OP * const k1 = ((UNOP*)expr)->op_first;
4346             const OP * const k2 = (k1) ? k1->op_sibling : NULL;
4347             switch (expr->op_type) {
4348               case OP_NULL:
4349                 if (k2 && k2->op_type == OP_READLINE
4350                       && (k2->op_flags & OPf_STACKED)
4351                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4352                     expr = newUNOP(OP_DEFINED, 0, expr);
4353                 break;
4354
4355               case OP_SASSIGN:
4356                 if (k1 && (k1->op_type == OP_READDIR
4357                       || k1->op_type == OP_GLOB
4358                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4359                       || k1->op_type == OP_EACH))
4360                     expr = newUNOP(OP_DEFINED, 0, expr);
4361                 break;
4362             }
4363         }
4364     }
4365
4366     if (!block)
4367         block = newOP(OP_NULL, 0);
4368     else if (cont || has_my) {
4369         block = scope(block);
4370     }
4371
4372     if (cont) {
4373         next = LINKLIST(cont);
4374     }
4375     if (expr) {
4376         OP * const unstack = newOP(OP_UNSTACK, 0);
4377         if (!next)
4378             next = unstack;
4379         cont = append_elem(OP_LINESEQ, cont, unstack);
4380     }
4381
4382     assert(block);
4383     listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4384     assert(listop);
4385     redo = LINKLIST(listop);
4386
4387     if (expr) {
4388         PL_copline = (line_t)whileline;
4389         scalar(listop);
4390         o = new_logop(OP_AND, 0, &expr, &listop);
4391         if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4392             op_free(expr);              /* oops, it's a while (0) */
4393             op_free((OP*)loop);
4394             return NULL;                /* listop already freed by new_logop */
4395         }
4396         if (listop)
4397             ((LISTOP*)listop)->op_last->op_next =
4398                 (o == listop ? redo : LINKLIST(o));
4399     }
4400     else
4401         o = listop;
4402
4403     if (!loop) {
4404         NewOp(1101,loop,1,LOOP);
4405         loop->op_type = OP_ENTERLOOP;
4406         loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4407         loop->op_private = 0;
4408         loop->op_next = (OP*)loop;
4409     }
4410
4411     o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4412
4413     loop->op_redoop = redo;
4414     loop->op_lastop = o;
4415     o->op_private |= loopflags;
4416
4417     if (next)
4418         loop->op_nextop = next;
4419     else
4420         loop->op_nextop = o;
4421
4422     o->op_flags |= flags;
4423     o->op_private |= (flags >> 8);
4424     return o;
4425 }
4426
4427 OP *
4428 Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
4429 {
4430     dVAR;
4431     LOOP *loop;
4432     OP *wop;
4433     PADOFFSET padoff = 0;
4434     I32 iterflags = 0;
4435     I32 iterpflags = 0;
4436     OP *madsv = NULL;
4437
4438     if (sv) {
4439         if (sv->op_type == OP_RV2SV) {  /* symbol table variable */
4440             iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
4441             sv->op_type = OP_RV2GV;
4442             sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4443             if (cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
4444                 iterpflags |= OPpITER_DEF;
4445         }
4446         else if (sv->op_type == OP_PADSV) { /* private variable */
4447             iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
4448             padoff = sv->op_targ;
4449             if (PL_madskills)
4450                 madsv = sv;
4451             else {
4452                 sv->op_targ = 0;
4453                 op_free(sv);
4454             }
4455             sv = NULL;
4456         }
4457         else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4458             padoff = sv->op_targ;
4459             if (PL_madskills)
4460                 madsv = sv;
4461             else {
4462                 sv->op_targ = 0;
4463                 iterflags |= OPf_SPECIAL;
4464                 op_free(sv);
4465             }
4466             sv = NULL;
4467         }
4468         else
4469             Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4470         if (padoff && strEQ(PAD_COMPNAME_PV(padoff), "$_"))
4471             iterpflags |= OPpITER_DEF;
4472     }
4473     else {
4474         const PADOFFSET offset = pad_findmy("$_");
4475         if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
4476             sv = newGVOP(OP_GV, 0, PL_defgv);
4477         }
4478         else {
4479             padoff = offset;
4480         }
4481         iterpflags |= OPpITER_DEF;
4482     }
4483     if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4484         expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4485         iterflags |= OPf_STACKED;
4486     }
4487     else if (expr->op_type == OP_NULL &&
4488              (expr->op_flags & OPf_KIDS) &&
4489              ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4490     {
4491         /* Basically turn for($x..$y) into the same as for($x,$y), but we
4492          * set the STACKED flag to indicate that these values are to be
4493          * treated as min/max values by 'pp_iterinit'.
4494          */
4495         const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4496         LOGOP* const range = (LOGOP*) flip->op_first;
4497         OP* const left  = range->op_first;
4498         OP* const right = left->op_sibling;
4499         LISTOP* listop;
4500
4501         range->op_flags &= ~OPf_KIDS;
4502         range->op_first = NULL;
4503
4504         listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4505         listop->op_first->op_next = range->op_next;
4506         left->op_next = range->op_other;
4507         right->op_next = (OP*)listop;
4508         listop->op_next = listop->op_first;
4509
4510 #ifdef PERL_MAD
4511         op_getmad(expr,(OP*)listop,'O');
4512 #else
4513         op_free(expr);
4514 #endif
4515         expr = (OP*)(listop);
4516         op_null(expr);
4517         iterflags |= OPf_STACKED;
4518     }
4519     else {
4520         expr = mod(force_list(expr), OP_GREPSTART);
4521     }
4522
4523     loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4524                                append_elem(OP_LIST, expr, scalar(sv))));
4525     assert(!loop->op_next);
4526     /* for my  $x () sets OPpLVAL_INTRO;
4527      * for our $x () sets OPpOUR_INTRO */
4528     loop->op_private = (U8)iterpflags;
4529 #ifdef PL_OP_SLAB_ALLOC
4530     {
4531         LOOP *tmp;
4532         NewOp(1234,tmp,1,LOOP);
4533         Copy(loop,tmp,1,LISTOP);
4534         FreeOp(loop);
4535         loop = tmp;
4536     }
4537 #else
4538     loop = PerlMemShared_realloc(loop, sizeof(LOOP));
4539 #endif
4540     loop->op_targ = padoff;
4541     wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
4542     if (madsv)
4543         op_getmad(madsv, (OP*)loop, 'v');
4544     PL_copline = forline;
4545     return newSTATEOP(0, label, wop);
4546 }
4547
4548 OP*
4549 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4550 {
4551     dVAR;
4552     OP *o;
4553
4554     if (type != OP_GOTO || label->op_type == OP_CONST) {
4555         /* "last()" means "last" */
4556         if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4557             o = newOP(type, OPf_SPECIAL);
4558         else {
4559             o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4560                                         ? SvPVx_nolen_const(((SVOP*)label)->op_sv)
4561                                         : ""));
4562         }
4563 #ifdef PERL_MAD
4564         op_getmad(label,o,'L');
4565 #else
4566         op_free(label);
4567 #endif
4568     }
4569     else {
4570         /* Check whether it's going to be a goto &function */
4571         if (label->op_type == OP_ENTERSUB
4572                 && !(label->op_flags & OPf_STACKED))
4573             label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4574         o = newUNOP(type, OPf_STACKED, label);
4575     }
4576     PL_hints |= HINT_BLOCK_SCOPE;
4577     return o;
4578 }
4579
4580 /* if the condition is a literal array or hash
4581    (or @{ ... } etc), make a reference to it.
4582  */
4583 STATIC OP *
4584 S_ref_array_or_hash(pTHX_ OP *cond)
4585 {
4586     if (cond
4587     && (cond->op_type == OP_RV2AV
4588     ||  cond->op_type == OP_PADAV
4589     ||  cond->op_type == OP_RV2HV
4590     ||  cond->op_type == OP_PADHV))
4591
4592         return newUNOP(OP_REFGEN,
4593             0, mod(cond, OP_REFGEN));
4594
4595     else
4596         return cond;
4597 }
4598
4599 /* These construct the optree fragments representing given()
4600    and when() blocks.
4601
4602    entergiven and enterwhen are LOGOPs; the op_other pointer
4603    points up to the associated leave op. We need this so we
4604    can put it in the context and make break/continue work.
4605    (Also, of course, pp_enterwhen will jump straight to
4606    op_other if the match fails.)
4607  */
4608
4609 STATIC
4610 OP *
4611 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
4612                    I32 enter_opcode, I32 leave_opcode,
4613                    PADOFFSET entertarg)
4614 {
4615     dVAR;
4616     LOGOP *enterop;
4617     OP *o;
4618
4619     NewOp(1101, enterop, 1, LOGOP);
4620     enterop->op_type = enter_opcode;
4621     enterop->op_ppaddr = PL_ppaddr[enter_opcode];
4622     enterop->op_flags =  (U8) OPf_KIDS;
4623     enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
4624     enterop->op_private = 0;
4625
4626     o = newUNOP(leave_opcode, 0, (OP *) enterop);
4627
4628     if (cond) {
4629         enterop->op_first = scalar(cond);
4630         cond->op_sibling = block;
4631
4632         o->op_next = LINKLIST(cond);
4633         cond->op_next = (OP *) enterop;
4634     }
4635     else {
4636         /* This is a default {} block */
4637         enterop->op_first = block;
4638         enterop->op_flags |= OPf_SPECIAL;
4639
4640         o->op_next = (OP *) enterop;
4641     }
4642
4643     CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
4644                                        entergiven and enterwhen both
4645                                        use ck_null() */
4646
4647     enterop->op_next = LINKLIST(block);
4648     block->op_next = enterop->op_other = o;
4649
4650     return o;
4651 }
4652
4653 /* Does this look like a boolean operation? For these purposes
4654    a boolean operation is:
4655      - a subroutine call [*]
4656      - a logical connective
4657      - a comparison operator
4658      - a filetest operator, with the exception of -s -M -A -C
4659      - defined(), exists() or eof()
4660      - /$re/ or $foo =~ /$re/
4661    
4662    [*] possibly surprising
4663  */
4664 STATIC
4665 bool
4666 S_looks_like_bool(pTHX_ const OP *o)
4667 {
4668     dVAR;
4669     switch(o->op_type) {
4670         case OP_OR:
4671             return looks_like_bool(cLOGOPo->op_first);
4672
4673         case OP_AND:
4674             return (
4675                 looks_like_bool(cLOGOPo->op_first)
4676              && looks_like_bool(cLOGOPo->op_first->op_sibling));
4677
4678         case OP_ENTERSUB:
4679
4680         case OP_NOT:    case OP_XOR:
4681         /* Note that OP_DOR is not here */
4682
4683         case OP_EQ:     case OP_NE:     case OP_LT:
4684         case OP_GT:     case OP_LE:     case OP_GE:
4685
4686         case OP_I_EQ:   case OP_I_NE:   case OP_I_LT:
4687         case OP_I_GT:   case OP_I_LE:   case OP_I_GE:
4688
4689         case OP_SEQ:    case OP_SNE:    case OP_SLT:
4690         case OP_SGT:    case OP_SLE:    case OP_SGE:
4691         
4692         case OP_SMARTMATCH:
4693         
4694         case OP_FTRREAD:  case OP_FTRWRITE: case OP_FTREXEC:
4695         case OP_FTEREAD:  case OP_FTEWRITE: case OP_FTEEXEC:
4696         case OP_FTIS:     case OP_FTEOWNED: case OP_FTROWNED:
4697         case OP_FTZERO:   case OP_FTSOCK:   case OP_FTCHR:
4698         case OP_FTBLK:    case OP_FTFILE:   case OP_FTDIR:
4699         case OP_FTPIPE:   case OP_FTLINK:   case OP_FTSUID:
4700         case OP_FTSGID:   case OP_FTSVTX:   case OP_FTTTY:
4701         case OP_FTTEXT:   case OP_FTBINARY:
4702         
4703         case OP_DEFINED: case OP_EXISTS:
4704         case OP_MATCH:   case OP_EOF:
4705
4706             return TRUE;
4707         
4708         case OP_CONST:
4709             /* Detect comparisons that have been optimized away */
4710             if (cSVOPo->op_sv == &PL_sv_yes
4711             ||  cSVOPo->op_sv == &PL_sv_no)
4712             
4713                 return TRUE;
4714                 
4715         /* FALL THROUGH */
4716         default:
4717             return FALSE;
4718     }
4719 }
4720
4721 OP *
4722 Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
4723 {
4724     dVAR;
4725     assert( cond );
4726     return newGIVWHENOP(
4727         ref_array_or_hash(cond),
4728         block,
4729         OP_ENTERGIVEN, OP_LEAVEGIVEN,
4730         defsv_off);
4731 }
4732
4733 /* If cond is null, this is a default {} block */
4734 OP *
4735 Perl_newWHENOP(pTHX_ OP *cond, OP *block)
4736 {
4737     const bool cond_llb = (!cond || looks_like_bool(cond));
4738     OP *cond_op;
4739
4740     if (cond_llb)
4741         cond_op = cond;
4742     else {
4743         cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
4744                 newDEFSVOP(),
4745                 scalar(ref_array_or_hash(cond)));
4746     }
4747     
4748     return newGIVWHENOP(
4749         cond_op,
4750         append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
4751         OP_ENTERWHEN, OP_LEAVEWHEN, 0);
4752 }
4753
4754 /*
4755 =for apidoc cv_undef
4756
4757 Clear out all the active components of a CV. This can happen either
4758 by an explicit C<undef &foo>, or by the reference count going to zero.
4759 In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
4760 children can still follow the full lexical scope chain.
4761
4762 =cut
4763 */
4764
4765 void
4766 Perl_cv_undef(pTHX_ CV *cv)
4767 {
4768     dVAR;
4769 #ifdef USE_ITHREADS
4770     if (CvFILE(cv) && !CvISXSUB(cv)) {
4771         /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4772         Safefree(CvFILE(cv));
4773     }
4774     CvFILE(cv) = 0;
4775 #endif
4776
4777     if (!CvISXSUB(cv) && CvROOT(cv)) {
4778         if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
4779             Perl_croak(aTHX_ "Can't undef active subroutine");
4780         ENTER;
4781
4782         PAD_SAVE_SETNULLPAD();
4783
4784         op_free(CvROOT(cv));
4785         CvROOT(cv) = NULL;
4786         CvSTART(cv) = NULL;
4787         LEAVE;
4788     }
4789     SvPOK_off((SV*)cv);         /* forget prototype */
4790     CvGV(cv) = NULL;
4791
4792     pad_undef(cv);
4793
4794     /* remove CvOUTSIDE unless this is an undef rather than a free */
4795     if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
4796         if (!CvWEAKOUTSIDE(cv))
4797             SvREFCNT_dec(CvOUTSIDE(cv));
4798         CvOUTSIDE(cv) = NULL;
4799     }
4800     if (CvCONST(cv)) {
4801         SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4802         CvCONST_off(cv);
4803     }
4804     if (CvISXSUB(cv) && CvXSUB(cv)) {
4805         CvXSUB(cv) = NULL;
4806     }
4807     /* delete all flags except WEAKOUTSIDE */
4808     CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
4809 }
4810
4811 void
4812 Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
4813                     const STRLEN len)
4814 {
4815     /* Can't just use a strcmp on the prototype, as CONSTSUBs "cheat" by
4816        relying on SvCUR, and doubling up the buffer to hold CvFILE().  */
4817     if (((!p != !SvPOK(cv)) /* One has prototype, one has not.  */
4818          || (p && (len != SvCUR(cv) /* Not the same length.  */
4819                    || memNE(p, SvPVX_const(cv), len))))
4820          && ckWARN_d(WARN_PROTOTYPE)) {
4821         SV* const msg = sv_newmortal();
4822         SV* name = NULL;
4823
4824         if (gv)
4825             gv_efullname3(name = sv_newmortal(), gv, NULL);
4826         sv_setpv(msg, "Prototype mismatch:");
4827         if (name)
4828             Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, (void*)name);
4829         if (SvPOK(cv))
4830             Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (void*)cv);
4831         else
4832             sv_catpvs(msg, ": none");
4833         sv_catpvs(msg, " vs ");
4834         if (p)
4835             Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p);
4836         else
4837             sv_catpvs(msg, "none");
4838         Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, (void*)msg);
4839     }
4840 }
4841
4842 static void const_sv_xsub(pTHX_ CV* cv);
4843
4844 /*
4845
4846 =head1 Optree Manipulation Functions
4847
4848 =for apidoc cv_const_sv
4849
4850 If C<cv> is a constant sub eligible for inlining. returns the constant
4851 value returned by the sub.  Otherwise, returns NULL.
4852
4853 Constant subs can be created with C<newCONSTSUB> or as described in
4854 L<perlsub/"Constant Functions">.
4855
4856 =cut