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