op.c

   1 /*    op.c
   2  *
   3  *    Copyright (c) 1991-1997, Larry Wall
   4  *
   5  *    You may distribute under the terms of either the GNU General Public
   6  *    License or the Artistic License, as specified in the README file.
   7  *
   8  */
   9
  10 /*
  11  * "You see: Mr. Drogo, he married poor Miss Primula Brandybuck.  She was
  12  * our Mr. Bilbo's first cousin on the mother's side (her mother being the
  13  * youngest of the Old Took's daughters); and Mr. Drogo was his second
  14  * cousin.  So Mr. Frodo is his first *and* second cousin, once removed
  15  * either way, as the saying is, if you follow me."  --the Gaffer
  16  */
  17
  18 #include "EXTERN.h"
  19 #include "perl.h"
  20
  21 #ifdef PERL_OBJECT
  22 #define CHECKCALL this->*check
  23 #else
  24 #define CHECKCALL *check
  25 #endif
  26
  27 /*
  28  * In the following definition, the ", Nullop" is just to make the compiler
  29  * think the expression is of the right type: croak actually does a Siglongjmp.
  30  */
  31 #define CHECKOP(type,o) \
  32     ((PL_op_mask && PL_op_mask[type])                                   \
  33      ? ( op_free((OP*)o),                                       \
  34          croak("%s trapped by operation mask", op_desc[type]),  \
  35          Nullop )                                               \
  36      : (CHECKCALL[type])((OP*)o))
  37
  38 #define PAD_MAX 999999999
  39
  40 static bool scalar_mod_type _((OP *o, I32 type));
  41 #ifndef PERL_OBJECT
  42 static I32 list_assignment _((OP *o));
  43 static void bad_type _((I32 n, char *t, char *name, OP *kid));
  44 static OP *modkids _((OP *o, I32 type));
  45 static OP *no_fh_allowed _((OP *o));
  46 static OP *scalarboolean _((OP *o));
  47 static OP *too_few_arguments _((OP *o, char* name));
  48 static OP *too_many_arguments _((OP *o, char* name));
  49 static void null _((OP* o));
  50 static PADOFFSET pad_findlex _((char* name, PADOFFSET newoff, U32 seq,
  51         CV* startcv, I32 cx_ix, I32 saweval));
  52 static OP *newDEFSVOP _((void));
  53 static OP *new_logop _((I32 type, I32 flags, OP **firstp, OP **otherp));
  54 #endif
  55
  56 STATIC char*
  57 gv_ename(GV *gv)
  58 {
  59     SV* tmpsv = sv_newmortal();
  60     gv_efullname3(tmpsv, gv, Nullch);
  61     return SvPV(tmpsv,PL_na);
  62 }
  63
  64 STATIC OP *
  65 no_fh_allowed(OP *o)
  66 {
  67     yyerror(form("Missing comma after first argument to %s function",
  68                  op_desc[o->op_type]));
  69     return o;
  70 }
  71
  72 STATIC OP *
  73 too_few_arguments(OP *o, char *name)
  74 {
  75     yyerror(form("Not enough arguments for %s", name));
  76     return o;
  77 }
  78
  79 STATIC OP *
  80 too_many_arguments(OP *o, char *name)
  81 {
  82     yyerror(form("Too many arguments for %s", name));
  83     return o;
  84 }
  85
  86 STATIC void
  87 bad_type(I32 n, char *t, char *name, OP *kid)
  88 {
  89     yyerror(form("Type of arg %d to %s must be %s (not %s)",
  90                  (int)n, name, t, op_desc[kid->op_type]));
  91 }
  92
  93 void
  94 assertref(OP *o)
  95 {
  96     int type = o->op_type;
  97     if (type != OP_AELEM && type != OP_HELEM && type != OP_GELEM) {
  98         yyerror(form("Can't use subscript on %s", op_desc[type]));
  99         if (type == OP_ENTERSUB || type == OP_RV2HV || type == OP_PADHV) {
 100             dTHR;
 101             SV *msg = sv_2mortal(
 102                         newSVpvf("(Did you mean $ or @ instead of %c?)\n",
 103                                  type == OP_ENTERSUB ? '&' : '%'));
 104             if (PL_in_eval & 2)
 105                 warn("%_", msg);
 106             else if (PL_in_eval)
 107                 sv_catsv(GvSV(PL_errgv), msg);
 108             else
 109                 PerlIO_write(PerlIO_stderr(), SvPVX(msg), SvCUR(msg));
 110         }
 111     }
 112 }
 113
 114 /* "register" allocation */
 115
 116 PADOFFSET
 117 pad_allocmy(char *name)
 118 {
 119     dTHR;
 120     PADOFFSET off;
 121     SV *sv;
 122
 123     if (!(isALPHA(name[1]) || name[1] == '_' && (int)strlen(name) > 2)) {
 124         if (!isPRINT(name[1])) {
 125             name[3] = '\0';
 126             name[2] = toCTRL(name[1]);
 127             name[1] = '^';
 128         }
 129         croak("Can't use global %s in \"my\"",name);
 130     }
 131     if (ckWARN(WARN_UNSAFE) && AvFILLp(PL_comppad_name) >= 0) {
 132         SV **svp = AvARRAY(PL_comppad_name);
 133         for (off = AvFILLp(PL_comppad_name); off > PL_comppad_name_floor; off--) {
 134             if ((sv = svp[off])
 135                 && sv != &PL_sv_undef
 136                 && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0)
 137                 && strEQ(name, SvPVX(sv)))
 138             {
 139                 warner(WARN_UNSAFE,
 140                         "\"my\" variable %s masks earlier declaration in same %s",
 141                         name, (SvIVX(sv) == PAD_MAX ? "scope" : "statement"));
 142                 break;
 143             }
 144         }
 145     }
 146     off = pad_alloc(OP_PADSV, SVs_PADMY);
 147     sv = NEWSV(1102,0);
 148     sv_upgrade(sv, SVt_PVNV);
 149     sv_setpv(sv, name);
 150     if (PL_in_my_stash) {
 151         if (*name != '$')
 152             croak("Can't declare class for non-scalar %s in \"my\"",name);
 153         SvOBJECT_on(sv);
 154         (void)SvUPGRADE(sv, SVt_PVMG);
 155         SvSTASH(sv) = (HV*)SvREFCNT_inc(PL_in_my_stash);
 156         PL_sv_objcount++;
 157     }
 158     av_store(PL_comppad_name, off, sv);
 159     SvNVX(sv) = (double)PAD_MAX;
 160     SvIVX(sv) = 0;                      /* Not yet introduced--see newSTATEOP */
 161     if (!PL_min_intro_pending)
 162         PL_min_intro_pending = off;
 163     PL_max_intro_pending = off;
 164     if (*name == '@')
 165         av_store(PL_comppad, off, (SV*)newAV());
 166     else if (*name == '%')
 167         av_store(PL_comppad, off, (SV*)newHV());
 168     SvPADMY_on(PL_curpad[off]);
 169     return off;
 170 }
 171
 172 STATIC PADOFFSET
 173 pad_findlex(char *name, PADOFFSET newoff, U32 seq, CV* startcv, I32 cx_ix, I32 saweval)
 174 {
 175     dTHR;
 176     CV *cv;
 177     I32 off;
 178     SV *sv;
 179     register I32 i;
 180     register PERL_CONTEXT *cx;
 181
 182     for (cv = startcv; cv; cv = CvOUTSIDE(cv)) {
 183         AV *curlist = CvPADLIST(cv);
 184         SV **svp = av_fetch(curlist, 0, FALSE);
 185         AV *curname;
 186
 187         if (!svp || *svp == &PL_sv_undef)
 188             continue;
 189         curname = (AV*)*svp;
 190         svp = AvARRAY(curname);
 191         for (off = AvFILLp(curname); off > 0; off--) {
 192             if ((sv = svp[off]) &&
 193                 sv != &PL_sv_undef &&
 194                 seq <= SvIVX(sv) &&
 195                 seq > I_32(SvNVX(sv)) &&
 196                 strEQ(SvPVX(sv), name))
 197             {
 198                 I32 depth;
 199                 AV *oldpad;
 200                 SV *oldsv;
 201
 202                 depth = CvDEPTH(cv);
 203                 if (!depth) {
 204                     if (newoff) {
 205                         if (SvFAKE(sv))
 206                             continue;
 207                         return 0; /* don't clone from inactive stack frame */
 208                     }
 209                     depth = 1;
 210                 }
 211                 oldpad = (AV*)*av_fetch(curlist, depth, FALSE);
 212                 oldsv = *av_fetch(oldpad, off, TRUE);
 213                 if (!newoff) {          /* Not a mere clone operation. */
 214                     SV *namesv = NEWSV(1103,0);
 215                     newoff = pad_alloc(OP_PADSV, SVs_PADMY);
 216                     sv_upgrade(namesv, SVt_PVNV);
 217                     sv_setpv(namesv, name);
 218                     av_store(PL_comppad_name, newoff, namesv);
 219                     SvNVX(namesv) = (double)PL_curcop->cop_seq;
 220                     SvIVX(namesv) = PAD_MAX;    /* A ref, intro immediately */
 221                     SvFAKE_on(namesv);          /* A ref, not a real var */
 222                     if (CvANON(PL_compcv) || SvTYPE(PL_compcv) == SVt_PVFM) {
 223                         /* "It's closures all the way down." */
 224                         CvCLONE_on(PL_compcv);
 225                         if (cv == startcv) {
 226                             if (CvANON(PL_compcv))
 227                                 oldsv = Nullsv; /* no need to keep ref */
 228                         }
 229                         else {
 230                             CV *bcv;
 231                             for (bcv = startcv;
 232                                  bcv && bcv != cv && !CvCLONE(bcv);
 233                                  bcv = CvOUTSIDE(bcv))
 234                             {
 235                                 if (CvANON(bcv))
 236                                     CvCLONE_on(bcv);
 237                                 else {
 238                                     if (ckWARN(WARN_CLOSURE)
 239                                         && !CvUNIQUE(bcv) && !CvUNIQUE(cv))
 240                                     {
 241                                         warner(WARN_CLOSURE,
 242                                           "Variable \"%s\" may be unavailable",
 243                                              name);
 244                                     }
 245                                     break;
 246                                 }
 247                             }
 248                         }
 249                     }
 250                     else if (!CvUNIQUE(PL_compcv)) {
 251                         if (ckWARN(WARN_CLOSURE) && !SvFAKE(sv) && !CvUNIQUE(cv))
 252                             warner(WARN_CLOSURE,
 253                                 "Variable \"%s\" will not stay shared", name);
 254                     }
 255                 }
 256                 av_store(PL_comppad, newoff, SvREFCNT_inc(oldsv));
 257                 return newoff;
 258             }
 259         }
 260     }
 261
 262     /* Nothing in current lexical context--try eval's context, if any.
 263      * This is necessary to let the perldb get at lexically scoped variables.
 264      * XXX This will also probably interact badly with eval tree caching.
 265      */
 266
 267     for (i = cx_ix; i >= 0; i--) {
 268         cx = &cxstack[i];
 269         switch (CxTYPE(cx)) {
 270         default:
 271             if (i == 0 && saweval) {
 272                 seq = cxstack[saweval].blk_oldcop->cop_seq;
 273                 return pad_findlex(name, newoff, seq, PL_main_cv, -1, saweval);
 274             }
 275             break;
 276         case CXt_EVAL:
 277             switch (cx->blk_eval.old_op_type) {
 278             case OP_ENTEREVAL:
 279                 if (CxREALEVAL(cx))
 280                     saweval = i;
 281                 break;
 282             case OP_REQUIRE:
 283                 /* require must have its own scope */
 284                 return 0;
 285             }
 286             break;
 287         case CXt_SUB:
 288             if (!saweval)
 289                 return 0;
 290             cv = cx->blk_sub.cv;
 291             if (PL_debstash && CvSTASH(cv) == PL_debstash) {    /* ignore DB'* scope */
 292                 saweval = i;    /* so we know where we were called from */
 293                 continue;
 294             }
 295             seq = cxstack[saweval].blk_oldcop->cop_seq;
 296             return pad_findlex(name, newoff, seq, cv, i-1, saweval);
 297         }
 298     }
 299
 300     return 0;
 301 }
 302
 303 PADOFFSET
 304 pad_findmy(char *name)
 305 {
 306     dTHR;
 307     I32 off;
 308     I32 pendoff = 0;
 309     SV *sv;
 310     SV **svp = AvARRAY(PL_comppad_name);
 311     U32 seq = PL_cop_seqmax;
 312     PERL_CONTEXT *cx;
 313     CV *outside;
 314
 315 #ifdef USE_THREADS
 316     /*
 317      * Special case to get lexical (and hence per-thread) @_.
 318      * XXX I need to find out how to tell at parse-time whether use
 319      * of @_ should refer to a lexical (from a sub) or defgv (global
 320      * scope and maybe weird sub-ish things like formats). See
 321      * startsub in perly.y.  It's possible that @_ could be lexical
 322      * (at least from subs) even in non-threaded perl.
 323      */
 324     if (strEQ(name, "@_"))
 325         return 0;               /* success. (NOT_IN_PAD indicates failure) */
 326 #endif /* USE_THREADS */
 327
 328     /* The one we're looking for is probably just before comppad_name_fill. */
 329     for (off = AvFILLp(PL_comppad_name); off > 0; off--) {
 330         if ((sv = svp[off]) &&
 331             sv != &PL_sv_undef &&
 332             (!SvIVX(sv) ||
 333              (seq <= SvIVX(sv) &&
 334               seq > I_32(SvNVX(sv)))) &&
 335             strEQ(SvPVX(sv), name))
 336         {
 337             if (SvIVX(sv))
 338                 return (PADOFFSET)off;
 339             pendoff = off;      /* this pending def. will override import */
 340         }
 341     }
 342
 343     outside = CvOUTSIDE(PL_compcv);
 344
 345     /* Check if if we're compiling an eval'', and adjust seq to be the
 346      * eval's seq number.  This depends on eval'' having a non-null
 347      * CvOUTSIDE() while it is being compiled.  The eval'' itself is
 348      * identified by CvUNIQUE being set and CvGV being null. */
 349     if (outside && CvUNIQUE(PL_compcv) && !CvGV(PL_compcv) && cxstack_ix >= 0) {
 350         cx = &cxstack[cxstack_ix];
 351         if (CxREALEVAL(cx))
 352             seq = cx->blk_oldcop->cop_seq;
 353     }
 354
 355     /* See if it's in a nested scope */
 356     off = pad_findlex(name, 0, seq, outside, cxstack_ix, 0);
 357     if (off) {
 358         /* If there is a pending local definition, this new alias must die */
 359         if (pendoff)
 360             SvIVX(AvARRAY(PL_comppad_name)[off]) = seq;
 361         return off;             /* pad_findlex returns 0 for failure...*/
 362     }
 363     return NOT_IN_PAD;          /* ...but we return NOT_IN_PAD for failure */
 364 }
 365
 366 void
 367 pad_leavemy(I32 fill)
 368 {
 369     I32 off;
 370     SV **svp = AvARRAY(PL_comppad_name);
 371     SV *sv;
 372     if (PL_min_intro_pending && fill < PL_min_intro_pending) {
 373         for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
 374             if ((sv = svp[off]) && sv != &PL_sv_undef)
 375                 warn("%s never introduced", SvPVX(sv));
 376         }
 377     }
 378     /* "Deintroduce" my variables that are leaving with this scope. */
 379     for (off = AvFILLp(PL_comppad_name); off > fill; off--) {
 380         if ((sv = svp[off]) && sv != &PL_sv_undef && SvIVX(sv) == PAD_MAX)
 381             SvIVX(sv) = PL_cop_seqmax;
 382     }
 383 }
 384
 385 PADOFFSET
 386 pad_alloc(I32 optype, U32 tmptype)
 387 {
 388     dTHR;
 389     SV *sv;
 390     I32 retval;
 391
 392     if (AvARRAY(PL_comppad) != PL_curpad)
 393         croak("panic: pad_alloc");
 394     if (PL_pad_reset_pending)
 395         pad_reset();
 396     if (tmptype & SVs_PADMY) {
 397         do {
 398             sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE);
 399         } while (SvPADBUSY(sv));                /* need a fresh one */
 400         retval = AvFILLp(PL_comppad);
 401     }
 402     else {
 403         SV **names = AvARRAY(PL_comppad_name);
 404         SSize_t names_fill = AvFILLp(PL_comppad_name);
 405         for (;;) {
 406             /*
 407              * "foreach" index vars temporarily become aliases to non-"my"
 408              * values.  Thus we must skip, not just pad values that are
 409              * marked as current pad values, but also those with names.
 410              */
 411             if (++PL_padix <= names_fill &&
 412                    (sv = names[PL_padix]) && sv != &PL_sv_undef)
 413                 continue;
 414             sv = *av_fetch(PL_comppad, PL_padix, TRUE);
 415             if (!(SvFLAGS(sv) & (SVs_PADTMP|SVs_PADMY)))
 416                 break;
 417         }
 418         retval = PL_padix;
 419     }
 420     SvFLAGS(sv) |= tmptype;
 421     PL_curpad = AvARRAY(PL_comppad);
 422 #ifdef USE_THREADS
 423     DEBUG_X(PerlIO_printf(Perl_debug_log, "0x%lx Pad 0x%lx alloc %ld for %s\n",
 424                           (unsigned long) thr, (unsigned long) PL_curpad,
 425                           (long) retval, op_name[optype]));
 426 #else
 427     DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%lx alloc %ld for %s\n",
 428                           (unsigned long) PL_curpad,
 429                           (long) retval, op_name[optype]));
 430 #endif /* USE_THREADS */
 431     return (PADOFFSET)retval;
 432 }
 433
 434 SV *
 435 pad_sv(PADOFFSET po)
 436 {
 437     dTHR;
 438 #ifdef USE_THREADS
 439     DEBUG_X(PerlIO_printf(Perl_debug_log, "0x%lx Pad 0x%lx sv %d\n",
 440                           (unsigned long) thr, (unsigned long) PL_curpad, po));
 441 #else
 442     if (!po)
 443         croak("panic: pad_sv po");
 444     DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%lx sv %d\n",
 445                           (unsigned long) PL_curpad, po));
 446 #endif /* USE_THREADS */
 447     return PL_curpad[po];               /* eventually we'll turn this into a macro */
 448 }
 449
 450 void
 451 pad_free(PADOFFSET po)
 452 {
 453     dTHR;
 454     if (!PL_curpad)
 455         return;
 456     if (AvARRAY(PL_comppad) != PL_curpad)
 457         croak("panic: pad_free curpad");
 458     if (!po)
 459         croak("panic: pad_free po");
 460 #ifdef USE_THREADS
 461     DEBUG_X(PerlIO_printf(Perl_debug_log, "0x%lx Pad 0x%lx free %d\n",
 462                           (unsigned long) thr, (unsigned long) PL_curpad, po));
 463 #else
 464     DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%lx free %d\n",
 465                           (unsigned long) PL_curpad, po));
 466 #endif /* USE_THREADS */
 467     if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef)
 468         SvPADTMP_off(PL_curpad[po]);
 469     if ((I32)po < PL_padix)
 470         PL_padix = po - 1;
 471 }
 472
 473 void
 474 pad_swipe(PADOFFSET po)
 475 {
 476     dTHR;
 477     if (AvARRAY(PL_comppad) != PL_curpad)
 478         croak("panic: pad_swipe curpad");
 479     if (!po)
 480         croak("panic: pad_swipe po");
 481 #ifdef USE_THREADS
 482     DEBUG_X(PerlIO_printf(Perl_debug_log, "0x%lx Pad 0x%lx swipe %d\n",
 483                           (unsigned long) thr, (unsigned long) PL_curpad, po));
 484 #else
 485     DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%lx swipe %d\n",
 486                           (unsigned long) PL_curpad, po));
 487 #endif /* USE_THREADS */
 488     SvPADTMP_off(PL_curpad[po]);
 489     PL_curpad[po] = NEWSV(1107,0);
 490     SvPADTMP_on(PL_curpad[po]);
 491     if ((I32)po < PL_padix)
 492         PL_padix = po - 1;
 493 }
 494
 495 /* XXX pad_reset() is currently disabled because it results in serious bugs.
 496  * It causes pad temp TARGs to be shared between OPs. Since TARGs are pushed
 497  * on the stack by OPs that use them, there are several ways to get an alias
 498  * to  a shared TARG.  Such an alias will change randomly and unpredictably.
 499  * We avoid doing this until we can think of a Better Way.
 500  * GSAR 97-10-29 */
 501 void
 502 pad_reset(void)
 503 {
 504 #ifdef USE_BROKEN_PAD_RESET
 505     dTHR;
 506     register I32 po;
 507
 508     if (AvARRAY(PL_comppad) != PL_curpad)
 509         croak("panic: pad_reset curpad");
 510 #ifdef USE_THREADS
 511     DEBUG_X(PerlIO_printf(Perl_debug_log, "0x%lx Pad 0x%lx reset\n",
 512                           (unsigned long) thr, (unsigned long) PL_curpad));
 513 #else
 514     DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%lx reset\n",
 515                           (unsigned long) PL_curpad));
 516 #endif /* USE_THREADS */
 517     if (!PL_tainting) { /* Can't mix tainted and non-tainted temporaries. */
 518         for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) {
 519             if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po]))
 520                 SvPADTMP_off(PL_curpad[po]);
 521         }
 522         PL_padix = PL_padix_floor;
 523     }
 524 #endif
 525     PL_pad_reset_pending = FALSE;
 526 }
 527
 528 #ifdef USE_THREADS
 529 /* find_threadsv is not reentrant */
 530 PADOFFSET
 531 find_threadsv(char *name)
 532 {
 533     dTHR;
 534     char *p;
 535     PADOFFSET key;
 536     SV **svp;
 537     /* We currently only handle names of a single character */
 538     p = strchr(PL_threadsv_names, *name);
 539     if (!p)
 540         return NOT_IN_PAD;
 541     key = p - PL_threadsv_names;
 542     svp = av_fetch(thr->threadsv, key, FALSE);
 543     if (!svp) {
 544         SV *sv = NEWSV(0, 0);
 545         av_store(thr->threadsv, key, sv);
 546         thr->threadsvp = AvARRAY(thr->threadsv);
 547         /*
 548          * Some magic variables used to be automagically initialised
 549          * in gv_fetchpv. Those which are now per-thread magicals get
 550          * initialised here instead.
 551          */
 552         switch (*name) {
 553         case '_':
 554             break;
 555         case ';':
 556             sv_setpv(sv, "\034");
 557             sv_magic(sv, 0, 0, name, 1);
 558             break;
 559         case '&':
 560         case '`':
 561         case '\'':
 562             PL_sawampersand = TRUE;
 563             SvREADONLY_on(sv);
 564             /* FALL THROUGH */
 565
 566         /* XXX %! tied to Errno.pm needs to be added here.
 567          * See gv_fetchpv(). */
 568         /* case '!': */
 569
 570         default:
 571             sv_magic(sv, 0, 0, name, 1);
 572         }
 573         DEBUG_S(PerlIO_printf(PerlIO_stderr(),
 574                               "find_threadsv: new SV %p for $%s%c\n",
 575                               sv, (*name < 32) ? "^" : "",
 576                               (*name < 32) ? toCTRL(*name) : *name));
 577     }
 578     return key;
 579 }
 580 #endif /* USE_THREADS */
 581
 582 /* Destructor */
 583
 584 void
 585 op_free(OP *o)
 586 {
 587     register OP *kid, *nextkid;
 588
 589     if (!o || o->op_seq == (U16)-1)
 590         return;
 591
 592     if (o->op_flags & OPf_KIDS) {
 593         for (kid = cUNOPo->op_first; kid; kid = nextkid) {
 594             nextkid = kid->op_sibling; /* Get before next freeing kid */
 595             op_free(kid);
 596         }
 597     }
 598
 599     switch (o->op_type) {
 600     case OP_NULL:
 601         o->op_targ = 0; /* Was holding old type, if any. */
 602         break;
 603     case OP_ENTEREVAL:
 604         o->op_targ = 0; /* Was holding hints. */
 605         break;
 606 #ifdef USE_THREADS
 607     case OP_ENTERITER:
 608         if (!(o->op_flags & OPf_SPECIAL))
 609             break;
 610         /* FALL THROUGH */
 611     case OP_THREADSV:
 612         o->op_targ = 0; /* Was holding index into thr->threadsv AV. */
 613         break;
 614 #endif /* USE_THREADS */
 615     default:
 616         if (!(o->op_flags & OPf_REF)
 617             || (check[o->op_type] != FUNC_NAME_TO_PTR(ck_ftst)))
 618             break;
 619         /* FALL THROUGH */
 620     case OP_GVSV:
 621     case OP_GV:
 622     case OP_AELEMFAST:
 623         SvREFCNT_dec(cGVOPo->op_gv);
 624         break;
 625     case OP_NEXTSTATE:
 626     case OP_DBSTATE:
 627         Safefree(cCOPo->cop_label);
 628         SvREFCNT_dec(cCOPo->cop_filegv);
 629         if (cCOPo->cop_warnings != WARN_NONE && cCOPo->cop_warnings != WARN_ALL)
 630             SvREFCNT_dec(cCOPo->cop_warnings);
 631         break;
 632     case OP_CONST:
 633         SvREFCNT_dec(cSVOPo->op_sv);
 634         break;
 635     case OP_GOTO:
 636     case OP_NEXT:
 637     case OP_LAST:
 638     case OP_REDO:
 639         if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
 640             break;
 641         /* FALL THROUGH */
 642     case OP_TRANS:
 643         if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF))
 644             SvREFCNT_dec(cSVOPo->op_sv);
 645         else
 646             Safefree(cPVOPo->op_pv);
 647         break;
 648     case OP_SUBST:
 649         op_free(cPMOPo->op_pmreplroot);
 650         /* FALL THROUGH */
 651     case OP_PUSHRE:
 652     case OP_MATCH:
 653     case OP_QR:
 654         ReREFCNT_dec(cPMOPo->op_pmregexp);
 655         break;
 656     }
 657
 658     if (o->op_targ > 0)
 659         pad_free(o->op_targ);
 660
 661     Safefree(o);
 662 }
 663
 664 STATIC void
 665 null(OP *o)
 666 {
 667     if (o->op_type != OP_NULL && o->op_type != OP_THREADSV && o->op_targ > 0)
 668         pad_free(o->op_targ);
 669     o->op_targ = o->op_type;
 670     o->op_type = OP_NULL;
 671     o->op_ppaddr = ppaddr[OP_NULL];
 672 }
 673
 674 /* Contextualizers */
 675
 676 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
 677
 678 OP *
 679 linklist(OP *o)
 680 {
 681     register OP *kid;
 682
 683     if (o->op_next)
 684         return o->op_next;
 685
 686     /* establish postfix order */
 687     if (cUNOPo->op_first) {
 688         o->op_next = LINKLIST(cUNOPo->op_first);
 689         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
 690             if (kid->op_sibling)
 691                 kid->op_next = LINKLIST(kid->op_sibling);
 692             else
 693                 kid->op_next = o;
 694         }
 695     }
 696     else
 697         o->op_next = o;
 698
 699     return o->op_next;
 700 }
 701
 702 OP *
 703 scalarkids(OP *o)
 704 {
 705     OP *kid;
 706     if (o && o->op_flags & OPf_KIDS) {
 707         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
 708             scalar(kid);
 709     }
 710     return o;
 711 }
 712
 713 STATIC OP *
 714 scalarboolean(OP *o)
 715 {
 716     if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
 717         dTHR;
 718         if (ckWARN(WARN_SYNTAX)) {
 719             line_t oldline = PL_curcop->cop_line;
 720
 721             if (PL_copline != NOLINE)
 722                 PL_curcop->cop_line = PL_copline;
 723             warner(WARN_SYNTAX, "Found = in conditional, should be ==");
 724             PL_curcop->cop_line = oldline;
 725         }
 726     }
 727     return scalar(o);
 728 }
 729
 730 OP *
 731 scalar(OP *o)
 732 {
 733     OP *kid;
 734
 735     /* assumes no premature commitment */
 736     if (!o || (o->op_flags & OPf_WANT) || PL_error_count
 737          || o->op_type == OP_RETURN)
 738         return o;
 739
 740     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
 741
 742     switch (o->op_type) {
 743     case OP_REPEAT:
 744         if (o->op_private & OPpREPEAT_DOLIST)
 745             null(((LISTOP*)cBINOPo->op_first)->op_first);
 746         scalar(cBINOPo->op_first);
 747         break;
 748     case OP_OR:
 749     case OP_AND:
 750     case OP_COND_EXPR:
 751         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
 752             scalar(kid);
 753         break;
 754     case OP_SPLIT:
 755         if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
 756             if (!kPMOP->op_pmreplroot)
 757                 deprecate("implicit split to @_");
 758         }
 759         /* FALL THROUGH */
 760     case OP_MATCH:
 761     case OP_QR:
 762     case OP_SUBST:
 763     case OP_NULL:
 764     default:
 765         if (o->op_flags & OPf_KIDS) {
 766             for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
 767                 scalar(kid);
 768         }
 769         break;
 770     case OP_LEAVE:
 771     case OP_LEAVETRY:
 772         kid = cLISTOPo->op_first;
 773         scalar(kid);
 774         while (kid = kid->op_sibling) {
 775             if (kid->op_sibling)
 776                 scalarvoid(kid);
 777             else
 778                 scalar(kid);
 779         }
 780         WITH_THR(PL_curcop = &PL_compiling);
 781         break;
 782     case OP_SCOPE:
 783     case OP_LINESEQ:
 784     case OP_LIST:
 785         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
 786             if (kid->op_sibling)
 787                 scalarvoid(kid);
 788             else
 789                 scalar(kid);
 790         }
 791         WITH_THR(PL_curcop = &PL_compiling);
 792         break;
 793     }
 794     return o;
 795 }
 796
 797 OP *
 798 scalarvoid(OP *o)
 799 {
 800     OP *kid;
 801     char* useless = 0;
 802     SV* sv;
 803
 804     /* assumes no premature commitment */
 805     if (!o || (o->op_flags & OPf_WANT) == OPf_WANT_LIST || PL_error_count
 806          || o->op_type == OP_RETURN)
 807         return o;
 808
 809     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
 810
 811     switch (o->op_type) {
 812     default:
 813         if (!(opargs[o->op_type] & OA_FOLDCONST))
 814             break;
 815         /* FALL THROUGH */
 816     case OP_REPEAT:
 817         if (o->op_flags & OPf_STACKED)
 818             break;
 819         goto func_ops;
 820     case OP_SUBSTR:
 821         if (o->op_private == 4)
 822             break;
 823         /* FALL THROUGH */
 824     case OP_GVSV:
 825     case OP_WANTARRAY:
 826     case OP_GV:
 827     case OP_PADSV:
 828     case OP_PADAV:
 829     case OP_PADHV:
 830     case OP_PADANY:
 831     case OP_AV2ARYLEN:
 832     case OP_REF:
 833     case OP_REFGEN:
 834     case OP_SREFGEN:
 835     case OP_DEFINED:
 836     case OP_HEX:
 837     case OP_OCT:
 838     case OP_LENGTH:
 839     case OP_VEC:
 840     case OP_INDEX:
 841     case OP_RINDEX:
 842     case OP_SPRINTF:
 843     case OP_AELEM:
 844     case OP_AELEMFAST:
 845     case OP_ASLICE:
 846     case OP_HELEM:
 847     case OP_HSLICE:
 848     case OP_UNPACK:
 849     case OP_PACK:
 850     case OP_JOIN:
 851     case OP_LSLICE:
 852     case OP_ANONLIST:
 853     case OP_ANONHASH:
 854     case OP_SORT:
 855     case OP_REVERSE:
 856     case OP_RANGE:
 857     case OP_FLIP:
 858     case OP_FLOP:
 859     case OP_CALLER:
 860     case OP_FILENO:
 861     case OP_EOF:
 862     case OP_TELL:
 863     case OP_GETSOCKNAME:
 864     case OP_GETPEERNAME:
 865     case OP_READLINK:
 866     case OP_TELLDIR:
 867     case OP_GETPPID:
 868     case OP_GETPGRP:
 869     case OP_GETPRIORITY:
 870     case OP_TIME:
 871     case OP_TMS:
 872     case OP_LOCALTIME:
 873     case OP_GMTIME:
 874     case OP_GHBYNAME:
 875     case OP_GHBYADDR:
 876     case OP_GHOSTENT:
 877     case OP_GNBYNAME:
 878     case OP_GNBYADDR:
 879     case OP_GNETENT:
 880     case OP_GPBYNAME:
 881     case OP_GPBYNUMBER:
 882     case OP_GPROTOENT:
 883     case OP_GSBYNAME:
 884     case OP_GSBYPORT:
 885     case OP_GSERVENT:
 886     case OP_GPWNAM:
 887     case OP_GPWUID:
 888     case OP_GGRNAM:
 889     case OP_GGRGID:
 890     case OP_GETLOGIN:
 891       func_ops:
 892         if (!(o->op_private & OPpLVAL_INTRO))
 893             useless = op_desc[o->op_type];
 894         break;
 895
 896     case OP_RV2GV:
 897     case OP_RV2SV:
 898     case OP_RV2AV:
 899     case OP_RV2HV:
 900         if (!(o->op_private & OPpLVAL_INTRO) &&
 901                 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
 902             useless = "a variable";
 903         break;
 904
 905     case OP_NEXTSTATE:
 906     case OP_DBSTATE:
 907         WITH_THR(PL_curcop = ((COP*)o));                /* for warning below */
 908         break;
 909
 910     case OP_CONST:
 911         sv = cSVOPo->op_sv;
 912         {
 913             dTHR;
 914             if (ckWARN(WARN_VOID)) {
 915                 useless = "a constant";
 916                 if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
 917                     useless = 0;
 918                 else if (SvPOK(sv)) {
 919                     if (strnEQ(SvPVX(sv), "di", 2) ||
 920                         strnEQ(SvPVX(sv), "ds", 2) ||
 921                         strnEQ(SvPVX(sv), "ig", 2))
 922                             useless = 0;
 923                 }
 924             }
 925         }
 926         null(o);                /* don't execute a constant */
 927         SvREFCNT_dec(sv);       /* don't even remember it */
 928         break;
 929
 930     case OP_POSTINC:
 931         o->op_type = OP_PREINC;         /* pre-increment is faster */
 932         o->op_ppaddr = ppaddr[OP_PREINC];
 933         break;
 934
 935     case OP_POSTDEC:
 936         o->op_type = OP_PREDEC;         /* pre-decrement is faster */
 937         o->op_ppaddr = ppaddr[OP_PREDEC];
 938         break;
 939
 940     case OP_OR:
 941     case OP_AND:
 942     case OP_COND_EXPR:
 943         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
 944             scalarvoid(kid);
 945         break;
 946
 947     case OP_NULL:
 948         if (o->op_targ == OP_NEXTSTATE || o->op_targ == OP_DBSTATE)
 949             WITH_THR(PL_curcop = ((COP*)o));    /* for warning below */
 950         if (o->op_flags & OPf_STACKED)
 951             break;
 952         /* FALL THROUGH */
 953     case OP_ENTERTRY:
 954     case OP_ENTER:
 955     case OP_SCALAR:
 956         if (!(o->op_flags & OPf_KIDS))
 957             break;
 958         /* FALL THROUGH */
 959     case OP_SCOPE:
 960     case OP_LEAVE:
 961     case OP_LEAVETRY:
 962     case OP_LEAVELOOP:
 963     case OP_LINESEQ:
 964     case OP_LIST:
 965         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
 966             scalarvoid(kid);
 967         break;
 968     case OP_ENTEREVAL:
 969         scalarkids(o);
 970         break;
 971     case OP_REQUIRE:
 972         /* all requires must return a boolean value */
 973         o->op_flags &= ~OPf_WANT;
 974         return scalar(o);
 975     case OP_SPLIT:
 976         if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
 977             if (!kPMOP->op_pmreplroot)
 978                 deprecate("implicit split to @_");
 979         }
 980         break;
 981     }
 982     if (useless) {
 983         dTHR;
 984         if (ckWARN(WARN_VOID))
 985             warner(WARN_VOID, "Useless use of %s in void context", useless);
 986     }
 987     return o;
 988 }
 989
 990 OP *
 991 listkids(OP *o)
 992 {
 993     OP *kid;
 994     if (o && o->op_flags & OPf_KIDS) {
 995         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
 996             list(kid);
 997     }
 998     return o;
 999 }
1000
1001 OP *
1002 list(OP *o)
1003 {
1004     OP *kid;
1005
1006     /* assumes no premature commitment */
1007     if (!o || (o->op_flags & OPf_WANT) || PL_error_count
1008          || o->op_type == OP_RETURN)
1009         return o;
1010
1011     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1012
1013     switch (o->op_type) {
1014     case OP_FLOP:
1015     case OP_REPEAT:
1016         list(cBINOPo->op_first);
1017         break;
1018     case OP_OR:
1019     case OP_AND:
1020     case OP_COND_EXPR:
1021         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1022             list(kid);
1023         break;
1024     default:
1025     case OP_MATCH:
1026     case OP_QR:
1027     case OP_SUBST:
1028     case OP_NULL:
1029         if (!(o->op_flags & OPf_KIDS))
1030             break;
1031         if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1032             list(cBINOPo->op_first);
1033             return gen_constant_list(o);
1034         }
1035     case OP_LIST:
1036         listkids(o);
1037         break;
1038     case OP_LEAVE:
1039     case OP_LEAVETRY:
1040         kid = cLISTOPo->op_first;
1041         list(kid);
1042         while (kid = kid->op_sibling) {
1043             if (kid->op_sibling)
1044                 scalarvoid(kid);
1045             else
1046                 list(kid);
1047         }
1048         WITH_THR(PL_curcop = &PL_compiling);
1049         break;
1050     case OP_SCOPE:
1051     case OP_LINESEQ:
1052         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1053             if (kid->op_sibling)
1054                 scalarvoid(kid);
1055             else
1056                 list(kid);
1057         }
1058         WITH_THR(PL_curcop = &PL_compiling);
1059         break;
1060     case OP_REQUIRE:
1061         /* all requires must return a boolean value */
1062         o->op_flags &= ~OPf_WANT;
1063         return scalar(o);
1064     }
1065     return o;
1066 }
1067
1068 OP *
1069 scalarseq(OP *o)
1070 {
1071     OP *kid;
1072
1073     if (o) {
1074         if (o->op_type == OP_LINESEQ ||
1075              o->op_type == OP_SCOPE ||
1076              o->op_type == OP_LEAVE ||
1077              o->op_type == OP_LEAVETRY)
1078         {
1079             dTHR;
1080             for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1081                 if (kid->op_sibling) {
1082                     scalarvoid(kid);
1083                 }
1084             }
1085             PL_curcop = &PL_compiling;
1086         }
1087         o->op_flags &= ~OPf_PARENS;
1088         if (PL_hints & HINT_BLOCK_SCOPE)
1089             o->op_flags |= OPf_PARENS;
1090     }
1091     else
1092         o = newOP(OP_STUB, 0);
1093     return o;
1094 }
1095
1096 STATIC OP *
1097 modkids(OP *o, I32 type)
1098 {
1099     OP *kid;
1100     if (o && o->op_flags & OPf_KIDS) {
1101         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1102             mod(kid, type);
1103     }
1104     return o;
1105 }
1106
1107 OP *
1108 mod(OP *o, I32 type)
1109 {
1110     dTHR;
1111     OP *kid;
1112     SV *sv;
1113
1114     if (!o || PL_error_count)
1115         return o;
1116
1117     switch (o->op_type) {
1118     case OP_UNDEF:
1119         PL_modcount++;
1120         return o;
1121     case OP_CONST:
1122         if (!(o->op_private & (OPpCONST_ARYBASE)))
1123             goto nomod;
1124         if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1125             PL_compiling.cop_arybase = (I32)SvIV(((SVOP*)PL_eval_start)->op_sv);
1126             PL_eval_start = 0;
1127         }
1128         else if (!type) {
1129             SAVEI32(PL_compiling.cop_arybase);
1130             PL_compiling.cop_arybase = 0;
1131         }
1132         else if (type == OP_REFGEN)
1133             goto nomod;
1134         else
1135             croak("That use of $[ is unsupported");
1136         break;
1137     case OP_STUB:
1138         if (o->op_flags & OPf_PARENS)
1139             break;
1140         goto nomod;
1141     case OP_ENTERSUB:
1142         if ((type == OP_UNDEF || type == OP_REFGEN) &&
1143             !(o->op_flags & OPf_STACKED)) {
1144             o->op_type = OP_RV2CV;              /* entersub => rv2cv */
1145             o->op_ppaddr = ppaddr[OP_RV2CV];
1146             assert(cUNOPo->op_first->op_type == OP_NULL);
1147             null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1148             break;
1149         }
1150         /* FALL THROUGH */
1151     default:
1152       nomod:
1153         /* grep, foreach, subcalls, refgen */
1154         if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1155             break;
1156         yyerror(form("Can't modify %s in %s",
1157                      (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1158                       ? "do block" : op_desc[o->op_type]),
1159                      type ? op_desc[type] : "local"));
1160         return o;
1161
1162     case OP_PREINC:
1163     case OP_PREDEC:
1164     case OP_POW:
1165     case OP_MULTIPLY:
1166     case OP_DIVIDE:
1167     case OP_MODULO:
1168     case OP_REPEAT:
1169     case OP_ADD:
1170     case OP_SUBTRACT:
1171     case OP_CONCAT:
1172     case OP_LEFT_SHIFT:
1173     case OP_RIGHT_SHIFT:
1174     case OP_BIT_AND:
1175     case OP_BIT_XOR:
1176     case OP_BIT_OR:
1177     case OP_I_MULTIPLY:
1178     case OP_I_DIVIDE:
1179     case OP_I_MODULO:
1180     case OP_I_ADD:
1181     case OP_I_SUBTRACT:
1182         if (!(o->op_flags & OPf_STACKED))
1183             goto nomod;
1184         PL_modcount++;
1185         break;
1186
1187     case OP_COND_EXPR:
1188         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1189             mod(kid, type);
1190         break;
1191
1192     case OP_RV2AV:
1193     case OP_RV2HV:
1194         if (!type && cUNOPo->op_first->op_type != OP_GV)
1195             croak("Can't localize through a reference");
1196         if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1197             PL_modcount = 10000;
1198             return o;           /* Treat \(@foo) like ordinary list. */
1199         }
1200         /* FALL THROUGH */
1201     case OP_RV2GV:
1202         if (scalar_mod_type(o, type))
1203             goto nomod;
1204         ref(cUNOPo->op_first, o->op_type);
1205         /* FALL THROUGH */
1206     case OP_AASSIGN:
1207     case OP_ASLICE:
1208     case OP_HSLICE:
1209     case OP_NEXTSTATE:
1210     case OP_DBSTATE:
1211     case OP_REFGEN:
1212     case OP_CHOMP:
1213         PL_modcount = 10000;
1214         break;
1215     case OP_RV2SV:
1216         if (!type && cUNOPo->op_first->op_type != OP_GV)
1217             croak("Can't localize through a reference");
1218         ref(cUNOPo->op_first, o->op_type);
1219         /* FALL THROUGH */
1220     case OP_GV:
1221     case OP_AV2ARYLEN:
1222         PL_hints |= HINT_BLOCK_SCOPE;
1223     case OP_SASSIGN:
1224     case OP_AELEMFAST:
1225         PL_modcount++;
1226         break;
1227
1228     case OP_PADAV:
1229     case OP_PADHV:
1230         PL_modcount = 10000;
1231         if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1232             return o;           /* Treat \(@foo) like ordinary list. */
1233         if (scalar_mod_type(o, type))
1234             goto nomod;
1235         /* FALL THROUGH */
1236     case OP_PADSV:
1237         PL_modcount++;
1238         if (!type)
1239             croak("Can't localize lexical variable %s",
1240                 SvPV(*av_fetch(PL_comppad_name, o->op_targ, 4), PL_na));
1241         break;
1242
1243 #ifdef USE_THREADS
1244     case OP_THREADSV:
1245         PL_modcount++;  /* XXX ??? */
1246         break;
1247 #endif /* USE_THREADS */
1248
1249     case OP_PUSHMARK:
1250         break;
1251
1252     case OP_KEYS:
1253         if (type != OP_SASSIGN)
1254             goto nomod;
1255         goto lvalue_func;
1256     case OP_SUBSTR:
1257         if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1258             goto nomod;
1259         /* FALL THROUGH */
1260     case OP_POS:
1261     case OP_VEC:
1262       lvalue_func:
1263         pad_free(o->op_targ);
1264         o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1265         assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1266         if (o->op_flags & OPf_KIDS)
1267             mod(cBINOPo->op_first->op_sibling, type);
1268         break;
1269
1270     case OP_AELEM:
1271     case OP_HELEM:
1272         ref(cBINOPo->op_first, o->op_type);
1273         if (type == OP_ENTERSUB &&
1274              !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1275             o->op_private |= OPpLVAL_DEFER;
1276         PL_modcount++;
1277         break;
1278
1279     case OP_SCOPE:
1280     case OP_LEAVE:
1281     case OP_ENTER:
1282         if (o->op_flags & OPf_KIDS)
1283             mod(cLISTOPo->op_last, type);
1284         break;
1285
1286     case OP_NULL:
1287         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
1288             goto nomod;
1289         else if (!(o->op_flags & OPf_KIDS))
1290             break;
1291         if (o->op_targ != OP_LIST) {
1292             mod(cBINOPo->op_first, type);
1293             break;
1294         }
1295         /* FALL THROUGH */
1296     case OP_LIST:
1297         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1298             mod(kid, type);
1299         break;
1300     }
1301     o->op_flags |= OPf_MOD;
1302
1303     if (type == OP_AASSIGN || type == OP_SASSIGN)
1304         o->op_flags |= OPf_SPECIAL|OPf_REF;
1305     else if (!type) {
1306         o->op_private |= OPpLVAL_INTRO;
1307         o->op_flags &= ~OPf_SPECIAL;
1308         PL_hints |= HINT_BLOCK_SCOPE;
1309     }
1310     else if (type != OP_GREPSTART && type != OP_ENTERSUB)
1311         o->op_flags |= OPf_REF;
1312     return o;
1313 }
1314
1315 static bool
1316 scalar_mod_type(OP *o, I32 type)
1317 {
1318     switch (type) {
1319     case OP_SASSIGN:
1320         if (o->op_type == OP_RV2GV)
1321             return FALSE;
1322         /* FALL THROUGH */
1323     case OP_PREINC:
1324     case OP_PREDEC:
1325     case OP_POSTINC:
1326     case OP_POSTDEC:
1327     case OP_I_PREINC:
1328     case OP_I_PREDEC:
1329     case OP_I_POSTINC:
1330     case OP_I_POSTDEC:
1331     case OP_POW:
1332     case OP_MULTIPLY:
1333     case OP_DIVIDE:
1334     case OP_MODULO:
1335     case OP_REPEAT:
1336     case OP_ADD:
1337     case OP_SUBTRACT:
1338     case OP_I_MULTIPLY:
1339     case OP_I_DIVIDE:
1340     case OP_I_MODULO:
1341     case OP_I_ADD:
1342     case OP_I_SUBTRACT:
1343     case OP_LEFT_SHIFT:
1344     case OP_RIGHT_SHIFT:
1345     case OP_BIT_AND:
1346     case OP_BIT_XOR:
1347     case OP_BIT_OR:
1348     case OP_CONCAT:
1349     case OP_SUBST:
1350     case OP_TRANS:
1351     case OP_READ:
1352     case OP_SYSREAD:
1353     case OP_RECV:
1354     case OP_ANDASSIGN:  /* may work later */
1355     case OP_ORASSIGN:   /* may work later */
1356         return TRUE;
1357     default:
1358         return FALSE;
1359     }
1360 }
1361
1362 OP *
1363 refkids(OP *o, I32 type)
1364 {
1365     OP *kid;
1366     if (o && o->op_flags & OPf_KIDS) {
1367         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1368             ref(kid, type);
1369     }
1370     return o;
1371 }
1372
1373 OP *
1374 ref(OP *o, I32 type)
1375 {
1376     OP *kid;
1377
1378     if (!o || PL_error_count)
1379         return o;
1380
1381     switch (o->op_type) {
1382     case OP_ENTERSUB:
1383         if ((type == OP_DEFINED || type == OP_LOCK) &&
1384             !(o->op_flags & OPf_STACKED)) {
1385             o->op_type = OP_RV2CV;             /* entersub => rv2cv */
1386             o->op_ppaddr = ppaddr[OP_RV2CV];
1387             assert(cUNOPo->op_first->op_type == OP_NULL);
1388             null(((LISTOP*)cUNOPo->op_first)->op_first);        /* disable pushmark */
1389             o->op_flags |= OPf_SPECIAL;
1390         }
1391         break;
1392
1393     case OP_COND_EXPR:
1394         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1395             ref(kid, type);
1396         break;
1397     case OP_RV2SV:
1398         ref(cUNOPo->op_first, o->op_type);
1399         /* FALL THROUGH */
1400     case OP_PADSV:
1401         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1402             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1403                               : type == OP_RV2HV ? OPpDEREF_HV
1404                               : OPpDEREF_SV);
1405             o->op_flags |= OPf_MOD;
1406         }
1407         break;
1408
1409     case OP_THREADSV:
1410         o->op_flags |= OPf_MOD;         /* XXX ??? */
1411         break;
1412
1413     case OP_RV2AV:
1414     case OP_RV2HV:
1415         o->op_flags |= OPf_REF;
1416         /* FALL THROUGH */
1417     case OP_RV2GV:
1418         ref(cUNOPo->op_first, o->op_type);
1419         break;
1420
1421     case OP_PADAV:
1422     case OP_PADHV:
1423         o->op_flags |= OPf_REF;
1424         break;
1425
1426     case OP_SCALAR:
1427     case OP_NULL:
1428         if (!(o->op_flags & OPf_KIDS))
1429             break;
1430         ref(cBINOPo->op_first, type);
1431         break;
1432     case OP_AELEM:
1433     case OP_HELEM:
1434         ref(cBINOPo->op_first, o->op_type);
1435         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1436             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1437                               : type == OP_RV2HV ? OPpDEREF_HV
1438                               : OPpDEREF_SV);
1439             o->op_flags |= OPf_MOD;
1440         }
1441         break;
1442
1443     case OP_SCOPE:
1444     case OP_LEAVE:
1445     case OP_ENTER:
1446     case OP_LIST:
1447         if (!(o->op_flags & OPf_KIDS))
1448             break;
1449         ref(cLISTOPo->op_last, type);
1450         break;
1451     default:
1452         break;
1453     }
1454     return scalar(o);
1455
1456 }
1457
1458 OP *
1459 my(OP *o)
1460 {
1461     OP *kid;
1462     I32 type;
1463
1464     if (!o || PL_error_count)
1465         return o;
1466
1467     type = o->op_type;
1468     if (type == OP_LIST) {
1469         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1470             my(kid);
1471     } else if (type == OP_UNDEF) {
1472         return o;
1473     } else if (type != OP_PADSV &&
1474              type != OP_PADAV &&
1475              type != OP_PADHV &&
1476              type != OP_PUSHMARK)
1477     {
1478         yyerror(form("Can't declare %s in my", op_desc[o->op_type]));
1479         return o;
1480     }
1481     o->op_flags |= OPf_MOD;
1482     o->op_private |= OPpLVAL_INTRO;
1483     return o;
1484 }
1485
1486 OP *
1487 sawparens(OP *o)
1488 {
1489     if (o)
1490         o->op_flags |= OPf_PARENS;
1491     return o;
1492 }
1493
1494 OP *
1495 bind_match(I32 type, OP *left, OP *right)
1496 {
1497     dTHR;
1498     OP *o;
1499
1500     if (ckWARN(WARN_UNSAFE) &&
1501       (left->op_type == OP_RV2AV ||
1502        left->op_type == OP_RV2HV ||
1503        left->op_type == OP_PADAV ||
1504        left->op_type == OP_PADHV)) {
1505       char *desc = op_desc[(right->op_type == OP_SUBST ||
1506                             right->op_type == OP_TRANS)
1507                            ? right->op_type : OP_MATCH];
1508       char *sample = ((left->op_type == OP_RV2AV ||
1509                        left->op_type == OP_PADAV)
1510                       ? "@array" : "%hash");
1511       warner(WARN_UNSAFE,
1512              "Applying %s to %s will act on scalar(%s)",
1513              desc, sample, sample);
1514     }
1515
1516     if (right->op_type == OP_MATCH ||
1517         right->op_type == OP_SUBST ||
1518         right->op_type == OP_TRANS) {
1519         right->op_flags |= OPf_STACKED;
1520         if (right->op_type != OP_MATCH)
1521             left = mod(left, right->op_type);
1522         if (right->op_type == OP_TRANS)
1523             o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
1524         else
1525             o = prepend_elem(right->op_type, scalar(left), right);
1526         if (type == OP_NOT)
1527             return newUNOP(OP_NOT, 0, scalar(o));
1528         return o;
1529     }
1530     else
1531         return bind_match(type, left,
1532                 pmruntime(newPMOP(OP_MATCH, 0), right, Nullop));
1533 }
1534
1535 OP *
1536 invert(OP *o)
1537 {
1538     if (!o)
1539         return o;
1540     /* XXX need to optimize away NOT NOT here?  Or do we let optimizer do it? */
1541     return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
1542 }
1543
1544 OP *
1545 scope(OP *o)
1546 {
1547     if (o) {
1548         if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
1549             o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
1550             o->op_type = OP_LEAVE;
1551             o->op_ppaddr = ppaddr[OP_LEAVE];
1552         }
1553         else {
1554             if (o->op_type == OP_LINESEQ) {
1555                 OP *kid;
1556                 o->op_type = OP_SCOPE;
1557                 o->op_ppaddr = ppaddr[OP_SCOPE];
1558                 kid = ((LISTOP*)o)->op_first;
1559                 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE){
1560                     SvREFCNT_dec(((COP*)kid)->cop_filegv);
1561                     null(kid);
1562                 }
1563             }
1564             else
1565                 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
1566         }
1567     }
1568     return o;
1569 }
1570
1571 void
1572 save_hints(void)
1573 {
1574     SAVEI32(PL_hints);
1575     SAVESPTR(GvHV(PL_hintgv));
1576     GvHV(PL_hintgv) = newHVhv(GvHV(PL_hintgv));
1577     SAVEFREESV(GvHV(PL_hintgv));
1578 }
1579
1580 int
1581 block_start(int full)
1582 {
1583     dTHR;
1584     int retval = PL_savestack_ix;
1585
1586     SAVEI32(PL_comppad_name_floor);
1587     if (full) {
1588         if ((PL_comppad_name_fill = AvFILLp(PL_comppad_name)) > 0)
1589             PL_comppad_name_floor = PL_comppad_name_fill;
1590         else
1591             PL_comppad_name_floor = 0;
1592     }
1593     SAVEI32(PL_min_intro_pending);
1594     SAVEI32(PL_max_intro_pending);
1595     PL_min_intro_pending = 0;
1596     SAVEI32(PL_comppad_name_fill);
1597     SAVEI32(PL_padix_floor);
1598     PL_padix_floor = PL_padix;
1599     PL_pad_reset_pending = FALSE;
1600     SAVEHINTS();
1601     PL_hints &= ~HINT_BLOCK_SCOPE;
1602     SAVEPPTR(PL_compiling.cop_warnings);
1603     if (PL_compiling.cop_warnings != WARN_ALL &&
1604        PL_compiling.cop_warnings != WARN_NONE) {
1605         PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
1606         SAVEFREESV(PL_compiling.cop_warnings) ;
1607     }
1608
1609
1610     return retval;
1611 }
1612
1613 OP*
1614 block_end(I32 floor, OP *seq)
1615 {
1616     dTHR;
1617     int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
1618     OP* retval = scalarseq(seq);
1619     LEAVE_SCOPE(floor);
1620     PL_pad_reset_pending = FALSE;
1621     PL_compiling.op_private = PL_hints;
1622     if (needblockscope)
1623         PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
1624     pad_leavemy(PL_comppad_name_fill);
1625     PL_cop_seqmax++;
1626     return retval;
1627 }
1628
1629 STATIC OP *
1630 newDEFSVOP(void)
1631 {
1632 #ifdef USE_THREADS
1633     OP *o = newOP(OP_THREADSV, 0);
1634     o->op_targ = find_threadsv("_");
1635     return o;
1636 #else
1637     return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
1638 #endif /* USE_THREADS */
1639 }
1640
1641 void
1642 newPROG(OP *o)
1643 {
1644     dTHR;
1645     if (PL_in_eval) {
1646         PL_eval_root = newUNOP(OP_LEAVEEVAL, ((PL_in_eval & 4) ? OPf_SPECIAL : 0), o);
1647         PL_eval_start = linklist(PL_eval_root);
1648         PL_eval_root->op_next = 0;
1649         peep(PL_eval_start);
1650     }
1651     else {
1652         if (!o)
1653             return;
1654         PL_main_root = scope(sawparens(scalarvoid(o)));
1655         PL_curcop = &PL_compiling;
1656         PL_main_start = LINKLIST(PL_main_root);
1657         PL_main_root->op_next = 0;
1658         peep(PL_main_start);
1659         PL_compcv = 0;
1660
1661         /* Register with debugger */
1662         if (PERLDB_INTER) {
1663             CV *cv = perl_get_cv("DB::postponed", FALSE);
1664             if (cv) {
1665                 dSP;
1666                 PUSHMARK(SP);
1667                 XPUSHs((SV*)PL_compiling.cop_filegv);
1668                 PUTBACK;
1669                 perl_call_sv((SV*)cv, G_DISCARD);
1670             }
1671         }
1672     }
1673 }
1674
1675 OP *
1676 localize(OP *o, I32 lex)
1677 {
1678     if (o->op_flags & OPf_PARENS)
1679         list(o);
1680     else {
1681         dTHR;
1682         if (ckWARN(WARN_PARENTHESIS) && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',') {
1683             char *s;
1684             for (s = PL_bufptr; *s && (isALNUM(*s) || strchr("@$%, ",*s)); s++) ;
1685             if (*s == ';' || *s == '=')
1686                 warner(WARN_PARENTHESIS, "Parens missing around \"%s\" list",
1687                                 lex ? "my" : "local");
1688         }
1689     }
1690     PL_in_my = FALSE;
1691     PL_in_my_stash = Nullhv;
1692     if (lex)
1693         return my(o);
1694     else
1695         return mod(o, OP_NULL);         /* a bit kludgey */
1696 }
1697
1698 OP *
1699 jmaybe(OP *o)
1700 {
1701     if (o->op_type == OP_LIST) {
1702         OP *o2;
1703 #ifdef USE_THREADS
1704         o2 = newOP(OP_THREADSV, 0);
1705         o2->op_targ = find_threadsv(";");
1706 #else
1707         o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
1708 #endif /* USE_THREADS */
1709         o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
1710     }
1711     return o;
1712 }
1713
1714 OP *
1715 fold_constants(register OP *o)
1716 {
1717     dTHR;
1718     register OP *curop;
1719     I32 type = o->op_type;
1720     SV *sv;
1721
1722     if (opargs[type] & OA_RETSCALAR)
1723         scalar(o);
1724     if (opargs[type] & OA_TARGET)
1725         o->op_targ = pad_alloc(type, SVs_PADTMP);
1726
1727     if ((opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER))
1728         o->op_ppaddr = ppaddr[type = ++(o->op_type)];
1729
1730     if (!(opargs[type] & OA_FOLDCONST))
1731         goto nope;
1732
1733     switch (type) {
1734     case OP_SPRINTF:
1735     case OP_UCFIRST:
1736     case OP_LCFIRST:
1737     case OP_UC:
1738     case OP_LC:
1739     case OP_SLT:
1740     case OP_SGT:
1741     case OP_SLE:
1742     case OP_SGE:
1743     case OP_SCMP:
1744
1745         if (o->op_private & OPpLOCALE)
1746             goto nope;
1747     }
1748
1749     if (PL_error_count)
1750         goto nope;              /* Don't try to run w/ errors */
1751
1752     for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
1753         if (curop->op_type != OP_CONST &&
1754                 curop->op_type != OP_LIST &&
1755                 curop->op_type != OP_SCALAR &&
1756                 curop->op_type != OP_NULL &&
1757                 curop->op_type != OP_PUSHMARK) {
1758             goto nope;
1759         }
1760     }
1761
1762     curop = LINKLIST(o);
1763     o->op_next = 0;
1764     PL_op = curop;
1765     CALLRUNOPS();
1766     sv = *(PL_stack_sp--);
1767     if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
1768         pad_swipe(o->op_targ);
1769     else if (SvTEMP(sv)) {                      /* grab mortal temp? */
1770         (void)SvREFCNT_inc(sv);
1771         SvTEMP_off(sv);
1772     }
1773     op_free(o);
1774     if (type == OP_RV2GV)
1775         return newGVOP(OP_GV, 0, (GV*)sv);
1776     else {
1777         /* try to smush double to int, but don't smush -2.0 to -2 */
1778         if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK &&
1779             type != OP_NEGATE)
1780         {
1781             IV iv = SvIV(sv);
1782             if ((double)iv == SvNV(sv)) {
1783                 SvREFCNT_dec(sv);
1784                 sv = newSViv(iv);
1785             }
1786             else
1787                 SvIOK_off(sv);                  /* undo SvIV() damage */
1788         }
1789         return newSVOP(OP_CONST, 0, sv);
1790     }
1791
1792   nope:
1793     if (!(opargs[type] & OA_OTHERINT))
1794         return o;
1795
1796     if (!(PL_hints & HINT_INTEGER)) {
1797         if (type == OP_DIVIDE || !(o->op_flags & OPf_KIDS))
1798             return o;
1799
1800         for (curop = ((UNOP*)o)->op_first; curop; curop = curop->op_sibling) {
1801             if (curop->op_type == OP_CONST) {
1802                 if (SvIOK(((SVOP*)curop)->op_sv))
1803                     continue;
1804                 return o;
1805             }
1806             if (opargs[curop->op_type] & OA_RETINTEGER)
1807                 continue;
1808             return o;
1809         }
1810         o->op_ppaddr = ppaddr[++(o->op_type)];
1811     }
1812
1813     return o;
1814 }
1815
1816 OP *
1817 gen_constant_list(register OP *o)
1818 {
1819     dTHR;
1820     register OP *curop;
1821     I32 oldtmps_floor = PL_tmps_floor;
1822
1823     list(o);
1824     if (PL_error_count)
1825         return o;               /* Don't attempt to run with errors */
1826
1827     PL_op = curop = LINKLIST(o);
1828     o->op_next = 0;
1829     pp_pushmark(ARGS);
1830     CALLRUNOPS();
1831     PL_op = curop;
1832     pp_anonlist(ARGS);
1833     PL_tmps_floor = oldtmps_floor;
1834
1835     o->op_type = OP_RV2AV;
1836     o->op_ppaddr = ppaddr[OP_RV2AV];
1837     curop = ((UNOP*)o)->op_first;
1838     ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
1839     op_free(curop);
1840     linklist(o);
1841     return list(o);
1842 }
1843
1844 OP *
1845 convert(I32 type, I32 flags, OP *o)
1846 {
1847     OP *kid;
1848     OP *last = 0;
1849
1850     if (!o || o->op_type != OP_LIST)
1851         o = newLISTOP(OP_LIST, 0, o, Nullop);
1852     else
1853         o->op_flags &= ~OPf_WANT;
1854
1855     if (!(opargs[type] & OA_MARK))
1856         null(cLISTOPo->op_first);
1857
1858     o->op_type = type;
1859     o->op_ppaddr = ppaddr[type];
1860     o->op_flags |= flags;
1861
1862     o = CHECKOP(type, o);
1863     if (o->op_type != type)
1864         return o;
1865
1866     if (cLISTOPo->op_children < 7) {
1867         /* XXX do we really need to do this if we're done appending?? */
1868         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1869             last = kid;
1870         cLISTOPo->op_last = last;       /* in case check substituted last arg */
1871     }
1872
1873     return fold_constants(o);
1874 }
1875
1876 /* List constructors */
1877
1878 OP *
1879 append_elem(I32 type, OP *first, OP *last)
1880 {
1881     if (!first)
1882         return last;
1883
1884     if (!last)
1885         return first;
1886
1887     if (first->op_type != type || type==OP_LIST && first->op_flags & OPf_PARENS)
1888             return newLISTOP(type, 0, first, last);
1889
1890     if (first->op_flags & OPf_KIDS)
1891         ((LISTOP*)first)->op_last->op_sibling = last;
1892     else {
1893         first->op_flags |= OPf_KIDS;
1894         ((LISTOP*)first)->op_first = last;
1895     }
1896     ((LISTOP*)first)->op_last = last;
1897     ((LISTOP*)first)->op_children++;
1898     return first;
1899 }
1900
1901 OP *
1902 append_list(I32 type, LISTOP *first, LISTOP *last)
1903 {
1904     if (!first)
1905         return (OP*)last;
1906
1907     if (!last)
1908         return (OP*)first;
1909
1910     if (first->op_type != type)
1911         return prepend_elem(type, (OP*)first, (OP*)last);
1912
1913     if (last->op_type != type)
1914         return append_elem(type, (OP*)first, (OP*)last);
1915
1916     first->op_last->op_sibling = last->op_first;
1917     first->op_last = last->op_last;
1918     first->op_children += last->op_children;
1919     if (first->op_children)
1920         first->op_flags |= OPf_KIDS;
1921
1922     Safefree(last);
1923     return (OP*)first;
1924 }
1925
1926 OP *
1927 prepend_elem(I32 type, OP *first, OP *last)
1928 {
1929     if (!first)
1930         return last;
1931
1932     if (!last)
1933         return first;
1934
1935     if (last->op_type == type) {
1936         if (type == OP_LIST) {  /* already a PUSHMARK there */
1937             first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
1938             ((LISTOP*)last)->op_first->op_sibling = first;
1939         }
1940         else {
1941             if (!(last->op_flags & OPf_KIDS)) {
1942                 ((LISTOP*)last)->op_last = first;
1943                 last->op_flags |= OPf_KIDS;
1944             }
1945             first->op_sibling = ((LISTOP*)last)->op_first;
1946             ((LISTOP*)last)->op_first = first;
1947         }
1948         ((LISTOP*)last)->op_children++;
1949         return last;
1950     }
1951
1952     return newLISTOP(type, 0, first, last);
1953 }
1954
1955 /* Constructors */
1956
1957 OP *
1958 newNULLLIST(void)
1959 {
1960     return newOP(OP_STUB, 0);
1961 }
1962
1963 OP *
1964 force_list(OP *o)
1965 {
1966     if (!o || o->op_type != OP_LIST)
1967         o = newLISTOP(OP_LIST, 0, o, Nullop);
1968     null(o);
1969     return o;
1970 }
1971
1972 OP *
1973 newLISTOP(I32 type, I32 flags, OP *first, OP *last)
1974 {
1975     LISTOP *listop;
1976
1977     Newz(1101, listop, 1, LISTOP);
1978
1979     listop->op_type = type;
1980     listop->op_ppaddr = ppaddr[type];
1981     listop->op_children = (first != 0) + (last != 0);
1982     listop->op_flags = flags;
1983
1984     if (!last && first)
1985         last = first;
1986     else if (!first && last)
1987         first = last;
1988     else if (first)
1989         first->op_sibling = last;
1990     listop->op_first = first;
1991     listop->op_last = last;
1992     if (type == OP_LIST) {
1993         OP* pushop;
1994         pushop = newOP(OP_PUSHMARK, 0);
1995         pushop->op_sibling = first;
1996         listop->op_first = pushop;
1997         listop->op_flags |= OPf_KIDS;
1998         if (!last)
1999             listop->op_last = pushop;
2000     }
2001     else if (listop->op_children)
2002         listop->op_flags |= OPf_KIDS;
2003
2004     return (OP*)listop;
2005 }
2006
2007 OP *
2008 newOP(I32 type, I32 flags)
2009 {
2010     OP *o;
2011     Newz(1101, o, 1, OP);
2012     o->op_type = type;
2013     o->op_ppaddr = ppaddr[type];
2014     o->op_flags = flags;
2015
2016     o->op_next = o;
2017     o->op_private = 0 + (flags >> 8);
2018     if (opargs[type] & OA_RETSCALAR)
2019         scalar(o);
2020     if (opargs[type] & OA_TARGET)
2021         o->op_targ = pad_alloc(type, SVs_PADTMP);
2022     return CHECKOP(type, o);
2023 }
2024
2025 OP *
2026 newUNOP(I32 type, I32 flags, OP *first)
2027 {
2028     UNOP *unop;
2029
2030     if (!first)
2031         first = newOP(OP_STUB, 0);
2032     if (opargs[type] & OA_MARK)
2033         first = force_list(first);
2034
2035     Newz(1101, unop, 1, UNOP);
2036     unop->op_type = type;
2037     unop->op_ppaddr = ppaddr[type];
2038     unop->op_first = first;
2039     unop->op_flags = flags | OPf_KIDS;
2040     unop->op_private = 1 | (flags >> 8);
2041     unop = (UNOP*) CHECKOP(type, unop);
2042     if (unop->op_next)
2043         return (OP*)unop;
2044
2045     return fold_constants((OP *) unop);
2046 }
2047
2048 OP *
2049 newBINOP(I32 type, I32 flags, OP *first, OP *last)
2050 {
2051     BINOP *binop;
2052     Newz(1101, binop, 1, BINOP);
2053
2054     if (!first)
2055         first = newOP(OP_NULL, 0);
2056
2057     binop->op_type = type;
2058     binop->op_ppaddr = ppaddr[type];
2059     binop->op_first = first;
2060     binop->op_flags = flags | OPf_KIDS;
2061     if (!last) {
2062         last = first;
2063         binop->op_private = 1 | (flags >> 8);
2064     }
2065     else {
2066         binop->op_private = 2 | (flags >> 8);
2067         first->op_sibling = last;
2068     }
2069
2070     binop = (BINOP*)CHECKOP(type, binop);
2071     if (binop->op_next)
2072         return (OP*)binop;
2073
2074     binop->op_last = last = binop->op_first->op_sibling;
2075
2076     return fold_constants((OP *)binop);
2077 }
2078
2079 static int
2080 utf8compare(const void *a, const void *b)
2081 {
2082     int i;
2083     for (i = 0; i < 10; i++) {
2084         if ((*(U8**)a)[i] < (*(U8**)b)[i])
2085             return -1;
2086         if ((*(U8**)a)[i] > (*(U8**)b)[i])
2087             return 1;
2088     }
2089     return 0;
2090 }
2091
2092 OP *
2093 pmtrans(OP *o, OP *expr, OP *repl)
2094 {
2095     SV *tstr = ((SVOP*)expr)->op_sv;
2096     SV *rstr = ((SVOP*)repl)->op_sv;
2097     STRLEN tlen;
2098     STRLEN rlen;
2099     register U8 *t = (U8*)SvPV(tstr, tlen);
2100     register U8 *r = (U8*)SvPV(rstr, rlen);
2101     register I32 i;
2102     register I32 j;
2103     I32 del;
2104     I32 complement;
2105     I32 squash;
2106     register short *tbl;
2107
2108     complement  = o->op_private & OPpTRANS_COMPLEMENT;
2109     del         = o->op_private & OPpTRANS_DELETE;
2110     squash      = o->op_private & OPpTRANS_SQUASH;
2111
2112     if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2113         SV* listsv = newSVpv("# comment\n",0);
2114         SV* transv = 0;
2115         U8* tend = t + tlen;
2116         U8* rend = r + rlen;
2117         I32 ulen;
2118         U32 tfirst = 1;
2119         U32 tlast = 0;
2120         I32 tdiff;
2121         U32 rfirst = 1;
2122         U32 rlast = 0;
2123         I32 rdiff;
2124         I32 diff;
2125         I32 none = 0;
2126         U32 max = 0;
2127         I32 bits;
2128         I32 grows = 0;
2129         I32 havefinal = 0;
2130         U32 final;
2131         HV *hv;
2132         I32 from_utf    = o->op_private & OPpTRANS_FROM_UTF;
2133         I32 to_utf      = o->op_private & OPpTRANS_TO_UTF;
2134
2135         if (complement) {
2136             U8 tmpbuf[10];
2137             U8** cp;
2138             UV nextmin = 0;
2139             New(1109, cp, tlen, U8*);
2140             i = 0;
2141             transv = newSVpv("",0);
2142             while (t < tend) {
2143                 cp[i++] = t;
2144                 t += UTF8SKIP(t);
2145                 if (*t == 0xff) {
2146                     t++;
2147                     t += UTF8SKIP(t);
2148                 }
2149             }
2150             qsort(cp, i, sizeof(U8*), utf8compare);
2151             for (j = 0; j < i; j++) {
2152                 U8 *s = cp[j];
2153                 UV val = utf8_to_uv(s, &ulen);
2154                 s += ulen;
2155                 diff = val - nextmin;
2156                 if (diff > 0) {
2157                     t = uv_to_utf8(tmpbuf,nextmin);
2158                     sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2159                     if (diff > 1) {
2160                         t = uv_to_utf8(tmpbuf, val - 1);
2161                         sv_catpvn(transv, "\377", 1);
2162                         sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2163                     }
2164                 }
2165                 if (*s == 0xff)
2166                     val = utf8_to_uv(s+1, &ulen);
2167                 if (val >= nextmin)
2168                     nextmin = val + 1;
2169             }
2170             t = uv_to_utf8(tmpbuf,nextmin);
2171             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2172             t = uv_to_utf8(tmpbuf, 0x7fffffff);
2173             sv_catpvn(transv, "\377", 1);
2174             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2175             t = (U8*)SvPVX(transv);
2176             tlen = SvCUR(transv);
2177             tend = t + tlen;
2178         }
2179         else if (!rlen && !del) {
2180             r = t; rlen = tlen; rend = tend;
2181         }
2182         if (!squash) {
2183             if (to_utf && from_utf) {   /* only counting characters */
2184                 if (t == r || (tlen == rlen && memEQ(t, r, tlen)))
2185                     o->op_private |= OPpTRANS_IDENTICAL;
2186             }
2187             else {      /* straight latin-1 translation */
2188                 if (tlen == 4 && memEQ(t, "\0\377\303\277", 4) &&
2189                     rlen == 4 && memEQ(r, "\0\377\303\277", 4))
2190                     o->op_private |= OPpTRANS_IDENTICAL;
2191             }
2192         }
2193
2194         while (t < tend || tfirst <= tlast) {
2195             /* see if we need more "t" chars */
2196             if (tfirst > tlast) {
2197                 tfirst = (I32)utf8_to_uv(t, &ulen);
2198                 t += ulen;
2199                 if (t < tend && *t == 0xff) {   /* illegal utf8 val indicates range */
2200                     tlast = (I32)utf8_to_uv(++t, &ulen);
2201                     t += ulen;
2202                 }
2203                 else
2204                     tlast = tfirst;
2205             }
2206
2207             /* now see if we need more "r" chars */
2208             if (rfirst > rlast) {
2209                 if (r < rend) {
2210                     rfirst = (I32)utf8_to_uv(r, &ulen);
2211                     r += ulen;
2212                     if (r < rend && *r == 0xff) {       /* illegal utf8 val indicates range */
2213                         rlast = (I32)utf8_to_uv(++r, &ulen);
2214                         r += ulen;
2215                     }
2216                     else
2217                         rlast = rfirst;
2218                 }
2219                 else {
2220                     if (!havefinal++)
2221                         final = rlast;
2222                     rfirst = rlast = 0xffffffff;
2223                 }
2224             }
2225
2226             /* now see which range will peter our first, if either. */
2227             tdiff = tlast - tfirst;
2228             rdiff = rlast - rfirst;
2229
2230             if (tdiff <= rdiff)
2231                 diff = tdiff;
2232             else
2233                 diff = rdiff;
2234
2235             if (rfirst == 0xffffffff) {
2236                 diff = tdiff;   /* oops, pretend rdiff is infinite */
2237                 if (diff > 0)
2238                     sv_catpvf(listsv, "%04x\t%04x\tXXXX\n", tfirst, tlast);
2239                 else
2240                     sv_catpvf(listsv, "%04x\t\tXXXX\n", tfirst);
2241             }
2242             else {
2243                 if (diff > 0)
2244                     sv_catpvf(listsv, "%04x\t%04x\t%04x\n", tfirst, tfirst + diff, rfirst);
2245                 else
2246                     sv_catpvf(listsv, "%04x\t\t%04x\n", tfirst, rfirst);
2247
2248                 if (rfirst + diff > max)
2249                     max = rfirst + diff;
2250                 rfirst += diff + 1;
2251                 if (!grows) {
2252                     if (rfirst <= 0x80)
2253                         ;
2254                     else if (rfirst <= 0x800)
2255                         grows |= (tfirst < 0x80);
2256                     else if (rfirst <= 0x10000)
2257                         grows |= (tfirst < 0x800);
2258                     else if (rfirst <= 0x200000)
2259                         grows |= (tfirst < 0x10000);
2260                     else if (rfirst <= 0x4000000)
2261                         grows |= (tfirst < 0x200000);
2262                     else if (rfirst <= 0x80000000)
2263                         grows |= (tfirst < 0x4000000);
2264                 }
2265             }
2266             tfirst += diff + 1;
2267         }
2268
2269         none = ++max;
2270         if (del)
2271             del = ++max;
2272
2273         if (max > 0xffff)
2274             bits = 32;
2275         else if (max > 0xff)
2276             bits = 16;
2277         else
2278             bits = 8;
2279
2280         cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2281         SvREFCNT_dec(listsv);
2282         if (transv)
2283             SvREFCNT_dec(transv);
2284
2285         if (!del && havefinal)
2286             (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5, newSViv((IV)final), 0);
2287
2288         if (grows && to_utf)
2289             o->op_private |= OPpTRANS_GROWS;
2290
2291         op_free(expr);
2292         op_free(repl);
2293         return o;
2294     }
2295
2296     tbl = (short*)cPVOPo->op_pv;
2297     if (complement) {
2298         Zero(tbl, 256, short);
2299         for (i = 0; i < tlen; i++)
2300             tbl[t[i]] = -1;
2301         for (i = 0, j = 0; i < 256; i++) {
2302             if (!tbl[i]) {
2303                 if (j >= rlen) {
2304                     if (del)
2305                         tbl[i] = -2;
2306                     else if (rlen)
2307                         tbl[i] = r[j-1];
2308                     else
2309                         tbl[i] = i;
2310                 }
2311                 else
2312                     tbl[i] = r[j++];
2313             }
2314         }
2315     }
2316     else {
2317         if (!rlen && !del) {
2318             r = t; rlen = tlen;
2319             if (!squash)
2320                 o->op_private |= OPpTRANS_IDENTICAL;
2321         }
2322         for (i = 0; i < 256; i++)
2323             tbl[i] = -1;
2324         for (i = 0, j = 0; i < tlen; i++,j++) {
2325             if (j >= rlen) {
2326                 if (del) {
2327                     if (tbl[t[i]] == -1)
2328                         tbl[t[i]] = -2;
2329                     continue;
2330                 }
2331                 --j;
2332             }
2333             if (tbl[t[i]] == -1)
2334                 tbl[t[i]] = r[j];
2335         }
2336     }
2337     op_free(expr);
2338     op_free(repl);
2339
2340     return o;
2341 }
2342
2343 OP *
2344 newPMOP(I32 type, I32 flags)
2345 {
2346     dTHR;
2347     PMOP *pmop;
2348
2349     Newz(1101, pmop, 1, PMOP);
2350     pmop->op_type = type;
2351     pmop->op_ppaddr = ppaddr[type];
2352     pmop->op_flags = flags;
2353     pmop->op_private = 0 | (flags >> 8);
2354
2355     if (PL_hints & HINT_RE_TAINT)
2356         pmop->op_pmpermflags |= PMf_RETAINT;
2357     if (PL_hints & HINT_LOCALE)
2358         pmop->op_pmpermflags |= PMf_LOCALE;
2359     pmop->op_pmflags = pmop->op_pmpermflags;
2360
2361     /* link into pm list */
2362     if (type != OP_TRANS && PL_curstash) {
2363         pmop->op_pmnext = HvPMROOT(PL_curstash);
2364         HvPMROOT(PL_curstash) = pmop;
2365     }
2366
2367     return (OP*)pmop;
2368 }
2369
2370 OP *
2371 pmruntime(OP *o, OP *expr, OP *repl)
2372 {
2373     dTHR;
2374     PMOP *pm;
2375     LOGOP *rcop;
2376     I32 repl_has_vars = 0;
2377
2378     if (o->op_type == OP_TRANS)
2379         return pmtrans(o, expr, repl);
2380
2381     PL_hints |= HINT_BLOCK_SCOPE;
2382     pm = (PMOP*)o;
2383
2384     if (expr->op_type == OP_CONST) {
2385         STRLEN plen;
2386         SV *pat = ((SVOP*)expr)->op_sv;
2387         char *p = SvPV(pat, plen);
2388         if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
2389             sv_setpvn(pat, "\\s+", 3);
2390             p = SvPV(pat, plen);
2391             pm->op_pmflags |= PMf_SKIPWHITE;
2392         }
2393         pm->op_pmregexp = CALLREGCOMP(p, p + plen, pm);
2394         if (strEQ("\\s+", pm->op_pmregexp->precomp))
2395             pm->op_pmflags |= PMf_WHITE;
2396         op_free(expr);
2397     }
2398     else {
2399         if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
2400             expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2401                             ? OP_REGCRESET
2402                             : OP_REGCMAYBE),0,expr);
2403
2404         Newz(1101, rcop, 1, LOGOP);
2405         rcop->op_type = OP_REGCOMP;
2406         rcop->op_ppaddr = ppaddr[OP_REGCOMP];
2407         rcop->op_first = scalar(expr);
2408         rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
2409                            ? (OPf_SPECIAL | OPf_KIDS)
2410                            : OPf_KIDS);
2411         rcop->op_private = 1;
2412         rcop->op_other = o;
2413
2414         /* establish postfix order */
2415         if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
2416             LINKLIST(expr);
2417             rcop->op_next = expr;
2418             ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
2419         }
2420         else {
2421             rcop->op_next = LINKLIST(expr);
2422             expr->op_next = (OP*)rcop;
2423         }
2424
2425         prepend_elem(o->op_type, scalar((OP*)rcop), o);
2426     }
2427
2428     if (repl) {
2429         OP *curop;
2430         if (pm->op_pmflags & PMf_EVAL)
2431             curop = 0;
2432 #ifdef USE_THREADS
2433         else if (repl->op_type == OP_THREADSV
2434                  && strchr("&`'123456789+",
2435                            PL_threadsv_names[repl->op_targ]))
2436         {
2437             curop = 0;
2438         }
2439 #endif /* USE_THREADS */
2440         else if (repl->op_type == OP_CONST)
2441             curop = repl;
2442         else {
2443             OP *lastop = 0;
2444             for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
2445                 if (opargs[curop->op_type] & OA_DANGEROUS) {
2446 #ifdef USE_THREADS
2447                     if (curop->op_type == OP_THREADSV) {
2448                         repl_has_vars = 1;
2449                         if (strchr("&`'123456789+", curop->op_private))
2450                             break;
2451                     }
2452 #else
2453                     if (curop->op_type == OP_GV) {
2454                         GV *gv = ((GVOP*)curop)->op_gv;
2455                         repl_has_vars = 1;
2456                         if (strchr("&`'123456789+", *GvENAME(gv)))
2457                             break;
2458                     }
2459 #endif /* USE_THREADS */
2460                     else if (curop->op_type == OP_RV2CV)
2461                         break;
2462                     else if (curop->op_type == OP_RV2SV ||
2463                              curop->op_type == OP_RV2AV ||
2464                              curop->op_type == OP_RV2HV ||
2465                              curop->op_type == OP_RV2GV) {
2466                         if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
2467                             break;
2468                     }
2469                     else if (curop->op_type == OP_PADSV ||
2470                              curop->op_type == OP_PADAV ||
2471                              curop->op_type == OP_PADHV ||
2472                              curop->op_type == OP_PADANY) {
2473                         repl_has_vars = 1;
2474                     }
2475                     else if (curop->op_type == OP_PUSHRE)
2476                         ; /* Okay here, dangerous in newASSIGNOP */
2477                     else
2478                         break;
2479                 }
2480                 lastop = curop;
2481             }
2482         }
2483         if (curop == repl
2484             && !(repl_has_vars
2485                  && (!pm->op_pmregexp
2486                      || pm->op_pmregexp->reganch & ROPT_EVAL_SEEN))) {
2487             pm->op_pmflags |= PMf_CONST;        /* const for long enough */
2488             pm->op_pmpermflags |= PMf_CONST;    /* const for long enough */
2489             prepend_elem(o->op_type, scalar(repl), o);
2490         }
2491         else {
2492             if (curop == repl && !pm->op_pmregexp) { /* Has variables. */
2493                 pm->op_pmflags |= PMf_MAYBE_CONST;
2494                 pm->op_pmpermflags |= PMf_MAYBE_CONST;
2495             }
2496             Newz(1101, rcop, 1, LOGOP);
2497             rcop->op_type = OP_SUBSTCONT;
2498             rcop->op_ppaddr = ppaddr[OP_SUBSTCONT];
2499             rcop->op_first = scalar(repl);
2500             rcop->op_flags |= OPf_KIDS;
2501             rcop->op_private = 1;
2502             rcop->op_other = o;
2503
2504             /* establish postfix order */
2505             rcop->op_next = LINKLIST(repl);
2506             repl->op_next = (OP*)rcop;
2507
2508             pm->op_pmreplroot = scalar((OP*)rcop);
2509             pm->op_pmreplstart = LINKLIST(rcop);
2510             rcop->op_next = 0;
2511         }
2512     }
2513
2514     return (OP*)pm;
2515 }
2516
2517 OP *
2518 newSVOP(I32 type, I32 flags, SV *sv)
2519 {
2520     SVOP *svop;
2521     Newz(1101, svop, 1, SVOP);
2522     svop->op_type = type;
2523     svop->op_ppaddr = ppaddr[type];
2524     svop->op_sv = sv;
2525     svop->op_next = (OP*)svop;
2526     svop->op_flags = flags;
2527     if (opargs[type] & OA_RETSCALAR)
2528         scalar((OP*)svop);
2529     if (opargs[type] & OA_TARGET)
2530         svop->op_targ = pad_alloc(type, SVs_PADTMP);
2531     return CHECKOP(type, svop);
2532 }
2533
2534 OP *
2535 newGVOP(I32 type, I32 flags, GV *gv)
2536 {
2537     dTHR;
2538     GVOP *gvop;
2539     Newz(1101, gvop, 1, GVOP);
2540     gvop->op_type = type;
2541     gvop->op_ppaddr = ppaddr[type];
2542     gvop->op_gv = (GV*)SvREFCNT_inc(gv);
2543     gvop->op_next = (OP*)gvop;
2544     gvop->op_flags = flags;
2545     if (opargs[type] & OA_RETSCALAR)
2546         scalar((OP*)gvop);
2547     if (opargs[type] & OA_TARGET)
2548         gvop->op_targ = pad_alloc(type, SVs_PADTMP);
2549     return CHECKOP(type, gvop);
2550 }
2551
2552 OP *
2553 newPVOP(I32 type, I32 flags, char *pv)
2554 {
2555     PVOP *pvop;
2556     Newz(1101, pvop, 1, PVOP);
2557     pvop->op_type = type;
2558     pvop->op_ppaddr = ppaddr[type];
2559     pvop->op_pv = pv;
2560     pvop->op_next = (OP*)pvop;
2561     pvop->op_flags = flags;
2562     if (opargs[type] & OA_RETSCALAR)
2563         scalar((OP*)pvop);
2564     if (opargs[type] & OA_TARGET)
2565         pvop->op_targ = pad_alloc(type, SVs_PADTMP);
2566     return CHECKOP(type, pvop);
2567 }
2568
2569 void
2570 package(OP *o)
2571 {
2572     dTHR;
2573     SV *sv;
2574
2575     save_hptr(&PL_curstash);
2576     save_item(PL_curstname);
2577     if (o) {
2578         STRLEN len;
2579         char *name;
2580         sv = cSVOPo->op_sv;
2581         name = SvPV(sv, len);
2582         PL_curstash = gv_stashpvn(name,len,TRUE);
2583         sv_setpvn(PL_curstname, name, len);
2584         op_free(o);
2585     }
2586     else {
2587         sv_setpv(PL_curstname,"<none>");
2588         PL_curstash = Nullhv;
2589     }
2590     PL_copline = NOLINE;
2591     PL_expect = XSTATE;
2592 }
2593
2594 void
2595 utilize(int aver, I32 floor, OP *version, OP *id, OP *arg)
2596 {
2597     OP *pack;
2598     OP *meth;
2599     OP *rqop;
2600     OP *imop;
2601     OP *veop;
2602     GV *gv;
2603
2604     if (id->op_type != OP_CONST)
2605         croak("Module name must be constant");
2606
2607     veop = Nullop;
2608
2609     if(version != Nullop) {
2610         SV *vesv = ((SVOP*)version)->op_sv;
2611
2612         if (arg == Nullop && !SvNIOK(vesv)) {
2613             arg = version;
2614         }
2615         else {
2616             OP *pack;
2617             OP *meth;
2618
2619             if (version->op_type != OP_CONST || !SvNIOK(vesv))
2620                 croak("Version number must be constant number");
2621
2622             /* Make copy of id so we don't free it twice */
2623             pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
2624
2625             /* Fake up a method call to VERSION */
2626             meth = newSVOP(OP_CONST, 0, newSVpv("VERSION", 7));
2627             veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
2628                             append_elem(OP_LIST,
2629                             prepend_elem(OP_LIST, pack, list(version)),
2630                             newUNOP(OP_METHOD, 0, meth)));
2631         }
2632     }
2633
2634     /* Fake up an import/unimport */
2635     if (arg && arg->op_type == OP_STUB)
2636         imop = arg;             /* no import on explicit () */
2637     else if(SvNIOK(((SVOP*)id)->op_sv)) {
2638         imop = Nullop;          /* use 5.0; */
2639     }
2640     else {
2641         /* Make copy of id so we don't free it twice */
2642         pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
2643         meth = newSVOP(OP_CONST, 0,
2644             aver
2645                 ? newSVpv("import", 6)
2646                 : newSVpv("unimport", 8)
2647             );
2648         imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
2649                     append_elem(OP_LIST,
2650                         prepend_elem(OP_LIST, pack, list(arg)),
2651                         newUNOP(OP_METHOD, 0, meth)));
2652     }
2653
2654     /* Fake up a require, handle override, if any */
2655     gv = gv_fetchpv("require", FALSE, SVt_PVCV);
2656     if (!(gv && GvIMPORTED_CV(gv)))
2657         gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
2658
2659     if (gv && GvIMPORTED_CV(gv)) {
2660         rqop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
2661                                append_elem(OP_LIST, id,
2662                                            scalar(newUNOP(OP_RV2CV, 0,
2663                                                           newGVOP(OP_GV, 0,
2664                                                                   gv))))));
2665     }
2666     else {
2667         rqop = newUNOP(OP_REQUIRE, 0, id);
2668     }
2669
2670     /* Fake up the BEGIN {}, which does its thing immediately. */
2671     newSUB(floor,
2672         newSVOP(OP_CONST, 0, newSVpv("BEGIN", 5)),
2673         Nullop,
2674         append_elem(OP_LINESEQ,
2675             append_elem(OP_LINESEQ,
2676                 newSTATEOP(0, Nullch, rqop),
2677                 newSTATEOP(0, Nullch, veop)),
2678             newSTATEOP(0, Nullch, imop) ));
2679
2680     PL_copline = NOLINE;
2681     PL_expect = XSTATE;
2682 }
2683
2684 OP *
2685 dofile(OP *term)
2686 {
2687     OP *doop;
2688     GV *gv;
2689
2690     gv = gv_fetchpv("do", FALSE, SVt_PVCV);
2691     if (!(gv && GvIMPORTED_CV(gv)))
2692         gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
2693
2694     if (gv && GvIMPORTED_CV(gv)) {
2695         doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
2696                                append_elem(OP_LIST, term,
2697                                            scalar(newUNOP(OP_RV2CV, 0,
2698                                                           newGVOP(OP_GV, 0,
2699                                                                   gv))))));
2700     }
2701     else {
2702         doop = newUNOP(OP_DOFILE, 0, scalar(term));
2703     }
2704     return doop;
2705 }
2706
2707 OP *
2708 newSLICEOP(I32 flags, OP *subscript, OP *listval)
2709 {
2710     return newBINOP(OP_LSLICE, flags,
2711             list(force_list(subscript)),
2712             list(force_list(listval)) );
2713 }
2714
2715 STATIC I32
2716 list_assignment(register OP *o)
2717 {
2718     if (!o)
2719         return TRUE;
2720
2721     if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
2722         o = cUNOPo->op_first;
2723
2724     if (o->op_type == OP_COND_EXPR) {
2725         I32 t = list_assignment(cCONDOPo->op_first->op_sibling);
2726         I32 f = list_assignment(cCONDOPo->op_first->op_sibling->op_sibling);
2727
2728         if (t && f)
2729             return TRUE;
2730         if (t || f)
2731             yyerror("Assignment to both a list and a scalar");
2732         return FALSE;
2733     }
2734
2735     if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
2736         o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
2737         o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
2738         return TRUE;
2739
2740     if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
2741         return TRUE;
2742
2743     if (o->op_type == OP_RV2SV)
2744         return FALSE;
2745
2746     return FALSE;
2747 }
2748
2749 OP *
2750 newASSIGNOP(I32 flags, OP *left, I32 optype, OP *right)
2751 {
2752     OP *o;
2753
2754     if (optype) {
2755         if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN) {
2756             return newLOGOP(optype, 0,
2757                 mod(scalar(left), optype),
2758                 newUNOP(OP_SASSIGN, 0, scalar(right)));
2759         }
2760         else {
2761             return newBINOP(optype, OPf_STACKED,
2762                 mod(scalar(left), optype), scalar(right));
2763         }
2764     }
2765
2766     if (list_assignment(left)) {
2767         dTHR;
2768         PL_modcount = 0;
2769         PL_eval_start = right;  /* Grandfathering $[ assignment here.  Bletch.*/
2770         left = mod(left, OP_AASSIGN);
2771         if (PL_eval_start)
2772             PL_eval_start = 0;
2773         else {
2774             op_free(left);
2775             op_free(right);
2776             return Nullop;
2777         }
2778         o = newBINOP(OP_AASSIGN, flags,
2779                 list(force_list(right)),
2780                 list(force_list(left)) );
2781         o->op_private = 0 | (flags >> 8);
2782         if (!(left->op_private & OPpLVAL_INTRO)) {
2783             OP *curop;
2784             OP *lastop = o;
2785             PL_generation++;
2786             for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2787                 if (opargs[curop->op_type] & OA_DANGEROUS) {
2788                     if (curop->op_type == OP_GV) {
2789                         GV *gv = ((GVOP*)curop)->op_gv;
2790                         if (gv == PL_defgv || SvCUR(gv) == PL_generation)
2791                             break;
2792                         SvCUR(gv) = PL_generation;
2793                     }
2794                     else if (curop->op_type == OP_PADSV ||
2795                              curop->op_type == OP_PADAV ||
2796                              curop->op_type == OP_PADHV ||
2797                              curop->op_type == OP_PADANY) {
2798                         SV **svp = AvARRAY(PL_comppad_name);
2799                         SV *sv = svp[curop->op_targ];
2800                         if (SvCUR(sv) == PL_generation)
2801                             break;
2802                         SvCUR(sv) = PL_generation;      /* (SvCUR not used any more) */
2803                     }
2804                     else if (curop->op_type == OP_RV2CV)
2805                         break;
2806                     else if (curop->op_type == OP_RV2SV ||
2807                              curop->op_type == OP_RV2AV ||
2808                              curop->op_type == OP_RV2HV ||
2809                              curop->op_type == OP_RV2GV) {
2810                         if (lastop->op_type != OP_GV)   /* funny deref? */
2811                             break;
2812                     }
2813                     else if (curop->op_type == OP_PUSHRE) {
2814                         if (((PMOP*)curop)->op_pmreplroot) {
2815                             GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
2816                             if (gv == PL_defgv || SvCUR(gv) == PL_generation)
2817                                 break;
2818                             SvCUR(gv) = PL_generation;
2819                         }
2820                     }
2821                     else
2822                         break;
2823                 }
2824                 lastop = curop;
2825             }
2826             if (curop != o)
2827                 o->op_private = OPpASSIGN_COMMON;
2828         }
2829         if (right && right->op_type == OP_SPLIT) {
2830             OP* tmpop;
2831             if ((tmpop = ((LISTOP*)right)->op_first) &&
2832                 tmpop->op_type == OP_PUSHRE)
2833             {
2834                 PMOP *pm = (PMOP*)tmpop;
2835                 if (left->op_type == OP_RV2AV &&
2836                     !(left->op_private & OPpLVAL_INTRO) &&
2837                     !(o->op_private & OPpASSIGN_COMMON) )
2838                 {
2839                     tmpop = ((UNOP*)left)->op_first;
2840                     if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
2841                         pm->op_pmreplroot = (OP*)((GVOP*)tmpop)->op_gv;
2842                         pm->op_pmflags |= PMf_ONCE;
2843                         tmpop = cUNOPo->op_first;       /* to list (nulled) */
2844                         tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
2845                         tmpop->op_sibling = Nullop;     /* don't free split */
2846                         right->op_next = tmpop->op_next;  /* fix starting loc */
2847                         op_free(o);                     /* blow off assign */
2848                         right->op_flags &= ~OPf_WANT;
2849                                 /* "I don't know and I don't care." */
2850                         return right;
2851                     }
2852                 }
2853                 else {
2854                     if (PL_modcount < 10000 &&
2855                       ((LISTOP*)right)->op_last->op_type == OP_CONST)
2856                     {
2857                         SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
2858                         if (SvIVX(sv) == 0)
2859                             sv_setiv(sv, PL_modcount+1);
2860                     }
2861                 }
2862             }
2863         }
2864         return o;
2865     }
2866     if (!right)
2867         right = newOP(OP_UNDEF, 0);
2868     if (right->op_type == OP_READLINE) {
2869         right->op_flags |= OPf_STACKED;
2870         return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
2871     }
2872     else {
2873         PL_eval_start = right;  /* Grandfathering $[ assignment here.  Bletch.*/
2874         o = newBINOP(OP_SASSIGN, flags,
2875             scalar(right), mod(scalar(left), OP_SASSIGN) );
2876         if (PL_eval_start)
2877             PL_eval_start = 0;
2878         else {
2879             op_free(o);
2880             return Nullop;
2881         }
2882     }
2883     return o;
2884 }
2885
2886 OP *
2887 newSTATEOP(I32 flags, char *label, OP *o)
2888 {
2889     dTHR;
2890     U32 seq = intro_my();
2891     register COP *cop;
2892
2893     Newz(1101, cop, 1, COP);
2894     if (PERLDB_LINE && PL_curcop->cop_line && PL_curstash != PL_debstash) {
2895         cop->op_type = OP_DBSTATE;
2896         cop->op_ppaddr = ppaddr[ OP_DBSTATE ];
2897     }
2898     else {
2899         cop->op_type = OP_NEXTSTATE;
2900         cop->op_ppaddr = ppaddr[ OP_NEXTSTATE ];
2901     }
2902     cop->op_flags = flags;
2903     cop->op_private = (PL_hints & HINT_UTF8);
2904 #ifdef NATIVE_HINTS
2905     cop->op_private |= NATIVE_HINTS;
2906 #endif
2907     PL_compiling.op_private = cop->op_private;
2908     cop->op_next = (OP*)cop;
2909
2910     if (label) {
2911         cop->cop_label = label;
2912         PL_hints |= HINT_BLOCK_SCOPE;
2913     }
2914     cop->cop_seq = seq;
2915     cop->cop_arybase = PL_curcop->cop_arybase;
2916     if (PL_curcop->cop_warnings == WARN_NONE
2917         || PL_curcop->cop_warnings == WARN_ALL)
2918         cop->cop_warnings = PL_curcop->cop_warnings ;
2919     else
2920         cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
2921
2922
2923     if (PL_copline == NOLINE)
2924         cop->cop_line = PL_curcop->cop_line;
2925     else {
2926         cop->cop_line = PL_copline;
2927         PL_copline = NOLINE;
2928     }
2929     cop->cop_filegv = (GV*)SvREFCNT_inc(PL_curcop->cop_filegv);
2930     cop->cop_stash = PL_curstash;
2931
2932     if (PERLDB_LINE && PL_curstash != PL_debstash) {
2933         SV **svp = av_fetch(GvAV(PL_curcop->cop_filegv),(I32)cop->cop_line, FALSE);
2934         if (svp && *svp != &PL_sv_undef && !SvIOK(*svp)) {
2935             (void)SvIOK_on(*svp);
2936             SvIVX(*svp) = 1;
2937             SvSTASH(*svp) = (HV*)cop;
2938         }
2939     }
2940
2941     return prepend_elem(OP_LINESEQ, (OP*)cop, o);
2942 }
2943
2944 /* "Introduce" my variables to visible status. */
2945 U32
2946 intro_my(void)
2947 {
2948     SV **svp;
2949     SV *sv;
2950     I32 i;
2951
2952     if (! PL_min_intro_pending)
2953         return PL_cop_seqmax;
2954
2955     svp = AvARRAY(PL_comppad_name);
2956     for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
2957         if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) {
2958             SvIVX(sv) = PAD_MAX;        /* Don't know scope end yet. */
2959             SvNVX(sv) = (double)PL_cop_seqmax;
2960         }
2961     }
2962     PL_min_intro_pending = 0;
2963     PL_comppad_name_fill = PL_max_intro_pending;        /* Needn't search higher */
2964     return PL_cop_seqmax++;
2965 }
2966
2967 OP *
2968 newLOGOP(I32 type, I32 flags, OP *first, OP *other)
2969 {
2970     return new_logop(type, flags, &first, &other);
2971 }
2972
2973 STATIC OP *
2974 new_logop(I32 type, I32 flags, OP** firstp, OP** otherp)
2975 {
2976     dTHR;
2977     LOGOP *logop;
2978     OP *o;
2979     OP *first = *firstp;
2980     OP *other = *otherp;
2981
2982     if (type == OP_XOR)         /* Not short circuit, but here by precedence. */
2983         return newBINOP(type, flags, scalar(first), scalar(other));
2984
2985     scalarboolean(first);
2986     /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
2987     if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
2988         if (type == OP_AND || type == OP_OR) {
2989             if (type == OP_AND)
2990                 type = OP_OR;
2991             else
2992                 type = OP_AND;
2993             o = first;
2994             first = *firstp = cUNOPo->op_first;
2995             if (o->op_next)
2996                 first->op_next = o->op_next;
2997             cUNOPo->op_first = Nullop;
2998             op_free(o);
2999         }
3000     }
3001     if (first->op_type == OP_CONST) {
3002         if (ckWARN(WARN_PRECEDENCE) && (first->op_private & OPpCONST_BARE))
3003             warner(WARN_PRECEDENCE, "Probable precedence problem on %s",
3004                         op_desc[type]);
3005         if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3006             op_free(first);
3007             *firstp = Nullop;
3008             return other;
3009         }
3010         else {
3011             op_free(other);
3012             *otherp = Nullop;
3013             return first;
3014         }
3015     }
3016     else if (first->op_type == OP_WANTARRAY) {
3017         if (type == OP_AND)
3018             list(other);
3019         else
3020             scalar(other);
3021     }
3022     else if (ckWARN(WARN_UNSAFE) && (first->op_flags & OPf_KIDS)) {
3023         OP *k1 = ((UNOP*)first)->op_first;
3024         OP *k2 = k1->op_sibling;
3025         OPCODE warnop = 0;
3026         switch (first->op_type)
3027         {
3028         case OP_NULL:
3029             if (k2 && k2->op_type == OP_READLINE
3030                   && (k2->op_flags & OPf_STACKED)
3031                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3032                 warnop = k2->op_type;
3033             break;
3034
3035         case OP_SASSIGN:
3036             if (k1->op_type == OP_READDIR
3037                   || k1->op_type == OP_GLOB
3038                   || k1->op_type == OP_EACH)
3039                 warnop = k1->op_type;
3040             break;
3041         }
3042         if (warnop) {
3043             line_t oldline = PL_curcop->cop_line;
3044             PL_curcop->cop_line = PL_copline;
3045             warner(WARN_UNSAFE,
3046                  "Value of %s%s can be \"0\"; test with defined()",
3047                  op_desc[warnop],
3048                  ((warnop == OP_READLINE || warnop == OP_GLOB)
3049                   ? " construct" : "() operator"));
3050             PL_curcop->cop_line = oldline;
3051         }
3052     }
3053
3054     if (!other)
3055         return first;
3056
3057     if (type == OP_ANDASSIGN || type == OP_ORASSIGN)
3058         other->op_private |= OPpASSIGN_BACKWARDS;  /* other is an OP_SASSIGN */
3059
3060     Newz(1101, logop, 1, LOGOP);
3061
3062     logop->op_type = type;
3063     logop->op_ppaddr = ppaddr[type];
3064     logop->op_first = first;
3065     logop->op_flags = flags | OPf_KIDS;
3066     logop->op_other = LINKLIST(other);
3067     logop->op_private = 1 | (flags >> 8);
3068
3069     /* establish postfix order */
3070     logop->op_next = LINKLIST(first);
3071     first->op_next = (OP*)logop;
3072     first->op_sibling = other;
3073
3074     o = newUNOP(OP_NULL, 0, (OP*)logop);
3075     other->op_next = o;
3076
3077     return o;
3078 }
3079
3080 OP *
3081 newCONDOP(I32 flags, OP *first, OP *trueop, OP *falseop)
3082 {
3083     dTHR;
3084     CONDOP *condop;
3085     OP *o;
3086
3087     if (!falseop)
3088         return newLOGOP(OP_AND, 0, first, trueop);
3089     if (!trueop)
3090         return newLOGOP(OP_OR, 0, first, falseop);
3091
3092     scalarboolean(first);
3093     if (first->op_type == OP_CONST) {
3094         if (SvTRUE(((SVOP*)first)->op_sv)) {
3095             op_free(first);
3096             op_free(falseop);
3097             return trueop;
3098         }
3099         else {
3100             op_free(first);
3101             op_free(trueop);
3102             return falseop;
3103         }
3104     }
3105     else if (first->op_type == OP_WANTARRAY) {
3106         list(trueop);
3107         scalar(falseop);
3108     }
3109     Newz(1101, condop, 1, CONDOP);
3110
3111     condop->op_type = OP_COND_EXPR;
3112     condop->op_ppaddr = ppaddr[OP_COND_EXPR];
3113     condop->op_first = first;
3114     condop->op_flags = flags | OPf_KIDS;
3115     condop->op_true = LINKLIST(trueop);
3116     condop->op_false = LINKLIST(falseop);
3117     condop->op_private = 1 | (flags >> 8);
3118
3119     /* establish postfix order */
3120     condop->op_next = LINKLIST(first);
3121     first->op_next = (OP*)condop;
3122
3123     first->op_sibling = trueop;
3124     trueop->op_sibling = falseop;
3125     o = newUNOP(OP_NULL, 0, (OP*)condop);
3126
3127     trueop->op_next = o;
3128     falseop->op_next = o;
3129
3130     return o;
3131 }
3132
3133 OP *
3134 newRANGE(I32 flags, OP *left, OP *right)
3135 {
3136     dTHR;
3137     CONDOP *condop;
3138     OP *flip;
3139     OP *flop;
3140     OP *o;
3141
3142     Newz(1101, condop, 1, CONDOP);
3143
3144     condop->op_type = OP_RANGE;
3145     condop->op_ppaddr = ppaddr[OP_RANGE];
3146     condop->op_first = left;
3147     condop->op_flags = OPf_KIDS;
3148     condop->op_true = LINKLIST(left);
3149     condop->op_false = LINKLIST(right);
3150     condop->op_private = 1 | (flags >> 8);
3151
3152     left->op_sibling = right;
3153
3154     condop->op_next = (OP*)condop;
3155     flip = newUNOP(OP_FLIP, flags, (OP*)condop);
3156     flop = newUNOP(OP_FLOP, 0, flip);
3157     o = newUNOP(OP_NULL, 0, flop);
3158     linklist(flop);
3159
3160     left->op_next = flip;
3161     right->op_next = flop;
3162
3163     condop->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3164     sv_upgrade(PAD_SV(condop->op_targ), SVt_PVNV);
3165     flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3166     sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3167
3168     flip->op_private =  left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3169     flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3170
3171     flip->op_next = o;
3172     if (!flip->op_private || !flop->op_private)
3173         linklist(o);            /* blow off optimizer unless constant */
3174
3175     return o;
3176 }
3177
3178 OP *
3179 newLOOPOP(I32 flags, I32 debuggable, OP *expr, OP *block)
3180 {
3181     dTHR;
3182     OP* listop;
3183     OP* o;
3184     int once = block && block->op_flags & OPf_SPECIAL &&
3185       (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3186
3187     if (expr) {
3188         if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3189             return block;       /* do {} while 0 does once */
3190         if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3191             || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3192             expr = newUNOP(OP_DEFINED, 0,
3193                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3194         } else if (expr->op_flags & OPf_KIDS) {
3195             OP *k1 = ((UNOP*)expr)->op_first;
3196             OP *k2 = (k1) ? k1->op_sibling : NULL;
3197             switch (expr->op_type) {
3198               case OP_NULL:
3199                 if (k2 && k2->op_type == OP_READLINE
3200                       && (k2->op_flags & OPf_STACKED)
3201                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3202                     expr = newUNOP(OP_DEFINED, 0, expr);
3203                 break;
3204
3205               case OP_SASSIGN:
3206                 if (k1->op_type == OP_READDIR
3207                       || k1->op_type == OP_GLOB
3208                       || k1->op_type == OP_EACH)
3209                     expr = newUNOP(OP_DEFINED, 0, expr);
3210                 break;
3211             }
3212         }
3213     }
3214
3215     listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3216     o = new_logop(OP_AND, 0, &expr, &listop);
3217
3218     if (listop)
3219         ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3220
3221     if (once && o != listop)
3222         o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3223
3224     if (o == listop)
3225         o = newUNOP(OP_NULL, 0, o);     /* or do {} while 1 loses outer block */
3226
3227     o->op_flags |= flags;
3228     o = scope(o);
3229     o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3230     return o;
3231 }
3232
3233 OP *
3234 newWHILEOP(I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
3235 {
3236     dTHR;
3237     OP *redo;
3238     OP *next = 0;
3239     OP *listop;
3240     OP *o;
3241     OP *condop;
3242
3243     if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3244                  || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3245         expr = newUNOP(OP_DEFINED, 0,
3246             newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3247     } else if (expr && (expr->op_flags & OPf_KIDS)) {
3248         OP *k1 = ((UNOP*)expr)->op_first;
3249         OP *k2 = (k1) ? k1->op_sibling : NULL;
3250         switch (expr->op_type) {
3251           case OP_NULL:
3252             if (k2 && k2->op_type == OP_READLINE
3253                   && (k2->op_flags & OPf_STACKED)
3254                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3255                 expr = newUNOP(OP_DEFINED, 0, expr);
3256             break;
3257
3258           case OP_SASSIGN:
3259             if (k1->op_type == OP_READDIR
3260                   || k1->op_type == OP_GLOB
3261                   || k1->op_type == OP_EACH)
3262                 expr = newUNOP(OP_DEFINED, 0, expr);
3263             break;
3264         }
3265     }
3266
3267     if (!block)
3268         block = newOP(OP_NULL, 0);
3269
3270     if (cont)
3271         next = LINKLIST(cont);
3272     if (expr) {
3273         cont = append_elem(OP_LINESEQ, cont, newOP(OP_UNSTACK, 0));
3274         if ((line_t)whileline != NOLINE) {
3275             PL_copline = whileline;
3276             cont = append_elem(OP_LINESEQ, cont,
3277                                newSTATEOP(0, Nullch, Nullop));
3278         }
3279     }
3280
3281     listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3282     redo = LINKLIST(listop);
3283
3284     if (expr) {
3285         PL_copline = whileline;
3286         scalar(listop);
3287         o = new_logop(OP_AND, 0, &expr, &listop);
3288         if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3289             op_free(expr);              /* oops, it's a while (0) */
3290             op_free((OP*)loop);
3291             return Nullop;              /* listop already freed by new_logop */
3292         }
3293         if (listop)
3294             ((LISTOP*)listop)->op_last->op_next = condop =
3295                 (o == listop ? redo : LINKLIST(o));
3296         if (!next)
3297             next = condop;
3298     }
3299     else
3300         o = listop;
3301
3302     if (!loop) {
3303         Newz(1101,loop,1,LOOP);
3304         loop->op_type = OP_ENTERLOOP;
3305         loop->op_ppaddr = ppaddr[OP_ENTERLOOP];
3306         loop->op_private = 0;
3307         loop->op_next = (OP*)loop;
3308     }
3309
3310     o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
3311
3312     loop->op_redoop = redo;
3313     loop->op_lastop = o;
3314
3315     if (next)
3316         loop->op_nextop = next;
3317     else
3318         loop->op_nextop = o;
3319
3320     o->op_flags |= flags;
3321     o->op_private |= (flags >> 8);
3322     return o;
3323 }
3324
3325 OP *
3326 newFOROP(I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
3327 {
3328     LOOP *loop;
3329     OP *wop;
3330     int padoff = 0;
3331     I32 iterflags = 0;
3332
3333     if (sv) {
3334         if (sv->op_type == OP_RV2SV) {  /* symbol table variable */
3335             sv->op_type = OP_RV2GV;
3336             sv->op_ppaddr = ppaddr[OP_RV2GV];
3337         }
3338         else if (sv->op_type == OP_PADSV) { /* private variable */
3339             padoff = sv->op_targ;
3340             op_free(sv);
3341             sv = Nullop;
3342         }
3343         else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
3344             padoff = sv->op_targ;
3345             iterflags |= OPf_SPECIAL;
3346             op_free(sv);
3347             sv = Nullop;
3348         }
3349         else
3350             croak("Can't use %s for loop variable", op_desc[sv->op_type]);
3351     }
3352     else {
3353 #ifdef USE_THREADS
3354         padoff = find_threadsv("_");
3355         iterflags |= OPf_SPECIAL;
3356 #else
3357         sv = newGVOP(OP_GV, 0, PL_defgv);
3358 #endif
3359     }
3360     if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
3361         expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
3362         iterflags |= OPf_STACKED;
3363     }
3364     else if (expr->op_type == OP_NULL &&
3365              (expr->op_flags & OPf_KIDS) &&
3366              ((BINOP*)expr)->op_first->op_type == OP_FLOP)
3367     {
3368         /* Basically turn for($x..$y) into the same as for($x,$y), but we
3369          * set the STACKED flag to indicate that these values are to be
3370          * treated as min/max values by 'pp_iterinit'.
3371          */
3372         UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
3373         CONDOP* range = (CONDOP*) flip->op_first;
3374         OP* left  = range->op_first;
3375         OP* right = left->op_sibling;
3376         LISTOP* listop;
3377
3378         range->op_flags &= ~OPf_KIDS;
3379         range->op_first = Nullop;
3380
3381         listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
3382         listop->op_first->op_next = range->op_true;
3383         left->op_next = range->op_false;
3384         right->op_next = (OP*)listop;
3385         listop->op_next = listop->op_first;
3386
3387         op_free(expr);
3388         expr = (OP*)(listop);
3389         null(expr);
3390         iterflags |= OPf_STACKED;
3391     }
3392     else {
3393         expr = mod(force_list(expr), OP_GREPSTART);
3394     }
3395
3396
3397     loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
3398                                append_elem(OP_LIST, expr, scalar(sv))));
3399     assert(!loop->op_next);
3400     Renew(loop, 1, LOOP);
3401     loop->op_targ = padoff;
3402     wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
3403     PL_copline = forline;
3404     return newSTATEOP(0, label, wop);
3405 }
3406
3407 OP*
3408 newLOOPEX(I32 type, OP *label)
3409 {
3410     dTHR;
3411     OP *o;
3412     if (type != OP_GOTO || label->op_type == OP_CONST) {
3413         /* "last()" means "last" */
3414         if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
3415             o = newOP(type, OPf_SPECIAL);
3416         else {
3417             o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
3418                                         ? SvPVx(((SVOP*)label)->op_sv, PL_na)
3419                                         : ""));
3420         }
3421         op_free(label);
3422     }
3423     else {
3424         if (label->op_type == OP_ENTERSUB)
3425             label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
3426         o = newUNOP(type, OPf_STACKED, label);
3427     }
3428     PL_hints |= HINT_BLOCK_SCOPE;
3429     return o;
3430 }
3431
3432 void
3433 cv_undef(CV *cv)
3434 {
3435     dTHR;
3436 #ifdef USE_THREADS
3437     if (CvMUTEXP(cv)) {
3438         MUTEX_DESTROY(CvMUTEXP(cv));
3439         Safefree(CvMUTEXP(cv));
3440         CvMUTEXP(cv) = 0;
3441     }
3442 #endif /* USE_THREADS */
3443
3444     if (!CvXSUB(cv) && CvROOT(cv)) {
3445 #ifdef USE_THREADS
3446         if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr))
3447             croak("Can't undef active subroutine");
3448 #else
3449         if (CvDEPTH(cv))
3450             croak("Can't undef active subroutine");
3451 #endif /* USE_THREADS */
3452         ENTER;
3453
3454         SAVESPTR(PL_curpad);
3455         PL_curpad = 0;
3456
3457         if (!CvCLONED(cv))
3458             op_free(CvROOT(cv));
3459         CvROOT(cv) = Nullop;
3460         LEAVE;
3461     }
3462     SvPOK_off((SV*)cv);         /* forget prototype */
3463     CvFLAGS(cv) = 0;
3464     SvREFCNT_dec(CvGV(cv));
3465     CvGV(cv) = Nullgv;
3466     SvREFCNT_dec(CvOUTSIDE(cv));
3467     CvOUTSIDE(cv) = Nullcv;
3468     if (CvPADLIST(cv)) {
3469         /* may be during global destruction */
3470         if (SvREFCNT(CvPADLIST(cv))) {
3471             I32 i = AvFILLp(CvPADLIST(cv));
3472             while (i >= 0) {
3473                 SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE);
3474                 SV* sv = svp ? *svp : Nullsv;
3475                 if (!sv)
3476                     continue;
3477                 if (sv == (SV*)PL_comppad_name)
3478                     PL_comppad_name = Nullav;
3479                 else if (sv == (SV*)PL_comppad) {
3480                     PL_comppad = Nullav;
3481                     PL_curpad = Null(SV**);
3482                 }
3483                 SvREFCNT_dec(sv);
3484             }
3485             SvREFCNT_dec((SV*)CvPADLIST(cv));
3486         }
3487         CvPADLIST(cv) = Nullav;
3488     }
3489 }
3490
3491 #ifdef DEBUG_CLOSURES
3492 STATIC void
3493 cv_dump(cv)
3494 CV* cv;
3495 {
3496     CV *outside = CvOUTSIDE(cv);
3497     AV* padlist = CvPADLIST(cv);
3498     AV* pad_name;
3499     AV* pad;
3500     SV** pname;
3501     SV** ppad;
3502     I32 ix;
3503
3504     PerlIO_printf(Perl_debug_log, "\tCV=0x%lx (%s), OUTSIDE=0x%lx (%s)\n",
3505                   cv,
3506                   (CvANON(cv) ? "ANON"
3507                    : (cv == PL_main_cv) ? "MAIN"
3508                    : CvUNIQUE(cv) ? "UNIQUE"
3509                    : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
3510                   outside,
3511                   (!outside ? "null"
3512                    : CvANON(outside) ? "ANON"
3513                    : (outside == PL_main_cv) ? "MAIN"
3514                    : CvUNIQUE(outside) ? "UNIQUE"
3515                    : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
3516
3517     if (!padlist)
3518         return;
3519
3520     pad_name = (AV*)*av_fetch(padlist, 0, FALSE);
3521     pad = (AV*)*av_fetch(padlist, 1, FALSE);
3522     pname = AvARRAY(pad_name);
3523     ppad = AvARRAY(pad);
3524
3525     for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
3526         if (SvPOK(pname[ix]))
3527             PerlIO_printf(Perl_debug_log, "\t%4d. 0x%lx (%s\"%s\" %ld-%ld)\n",
3528                           ix, ppad[ix],
3529                           SvFAKE(pname[ix]) ? "FAKE " : "",
3530                           SvPVX(pname[ix]),
3531                           (long)I_32(SvNVX(pname[ix])),
3532                           (long)SvIVX(pname[ix]));
3533     }
3534 }
3535 #endif /* DEBUG_CLOSURES */
3536
3537 STATIC CV *
3538 cv_clone2(CV *proto, CV *outside)
3539 {
3540     dTHR;
3541     AV* av;
3542     I32 ix;
3543     AV* protopadlist = CvPADLIST(proto);
3544     AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
3545     AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
3546     SV** pname = AvARRAY(protopad_name);
3547     SV** ppad = AvARRAY(protopad);
3548     I32 fname = AvFILLp(protopad_name);
3549     I32 fpad = AvFILLp(protopad);
3550     AV* comppadlist;
3551     CV* cv;
3552
3553     assert(!CvUNIQUE(proto));
3554
3555     ENTER;
3556     SAVESPTR(PL_curpad);
3557     SAVESPTR(PL_comppad);
3558     SAVESPTR(PL_comppad_name);
3559     SAVESPTR(PL_compcv);
3560
3561     cv = PL_compcv = (CV*)NEWSV(1104,0);
3562     sv_upgrade((SV *)cv, SvTYPE(proto));
3563     CvCLONED_on(cv);
3564     if (CvANON(proto))
3565         CvANON_on(cv);
3566
3567 #ifdef USE_THREADS
3568     New(666, CvMUTEXP(cv), 1, perl_mutex);
3569     MUTEX_INIT(CvMUTEXP(cv));
3570     CvOWNER(cv)         = 0;
3571 #endif /* USE_THREADS */
3572     CvFILEGV(cv)        = CvFILEGV(proto);
3573     CvGV(cv)            = (GV*)SvREFCNT_inc(CvGV(proto));
3574     CvSTASH(cv)         = CvSTASH(proto);
3575     CvROOT(cv)          = CvROOT(proto);
3576     CvSTART(cv)         = CvSTART(proto);
3577     if (outside)
3578         CvOUTSIDE(cv)   = (CV*)SvREFCNT_inc(outside);
3579
3580     if (SvPOK(proto))
3581         sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
3582
3583     PL_comppad_name = newAV();
3584     for (ix = fname; ix >= 0; ix--)
3585         av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
3586
3587     PL_comppad = newAV();
3588
3589     comppadlist = newAV();
3590     AvREAL_off(comppadlist);
3591     av_store(comppadlist, 0, (SV*)PL_comppad_name);
3592     av_store(comppadlist, 1, (SV*)PL_comppad);
3593     CvPADLIST(cv) = comppadlist;
3594     av_fill(PL_comppad, AvFILLp(protopad));
3595     PL_curpad = AvARRAY(PL_comppad);
3596
3597     av = newAV();           /* will be @_ */
3598     av_extend(av, 0);
3599     av_store(PL_comppad, 0, (SV*)av);
3600     AvFLAGS(av) = AVf_REIFY;
3601
3602     for (ix = fpad; ix > 0; ix--) {
3603         SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
3604         if (namesv && namesv != &PL_sv_undef) {
3605             char *name = SvPVX(namesv);    /* XXX */
3606             if (SvFLAGS(namesv) & SVf_FAKE) {   /* lexical from outside? */
3607                 I32 off = pad_findlex(name, ix, SvIVX(namesv),
3608                                       CvOUTSIDE(cv), cxstack_ix, 0);
3609                 if (!off)
3610                     PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
3611                 else if (off != ix)
3612                     croak("panic: cv_clone: %s", name);
3613             }
3614             else {                              /* our own lexical */
3615                 SV* sv;
3616                 if (*name == '&') {
3617                     /* anon code -- we'll come back for it */
3618                     sv = SvREFCNT_inc(ppad[ix]);
3619                 }
3620                 else if (*name == '@')
3621                     sv = (SV*)newAV();
3622                 else if (*name == '%')
3623                     sv = (SV*)newHV();
3624                 else
3625                     sv = NEWSV(0,0);
3626                 if (!SvPADBUSY(sv))
3627                     SvPADMY_on(sv);
3628                 PL_curpad[ix] = sv;
3629             }
3630         }
3631         else {
3632             SV* sv = NEWSV(0,0);
3633             SvPADTMP_on(sv);
3634             PL_curpad[ix] = sv;
3635         }
3636     }
3637
3638     /* Now that vars are all in place, clone nested closures. */
3639
3640     for (ix = fpad; ix > 0; ix--) {
3641         SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
3642         if (namesv
3643             && namesv != &PL_sv_undef
3644             && !(SvFLAGS(namesv) & SVf_FAKE)
3645             && *SvPVX(namesv) == '&'
3646             && CvCLONE(ppad[ix]))
3647         {
3648             CV *kid = cv_clone2((CV*)ppad[ix], cv);
3649             SvREFCNT_dec(ppad[ix]);
3650             CvCLONE_on(kid);
3651             SvPADMY_on(kid);
3652             PL_curpad[ix] = (SV*)kid;
3653         }
3654     }
3655
3656 #ifdef DEBUG_CLOSURES
3657     PerlIO_printf(Perl_debug_log, "Cloned inside:\n");
3658     cv_dump(outside);
3659     PerlIO_printf(Perl_debug_log, "  from:\n");
3660     cv_dump(proto);
3661     PerlIO_printf(Perl_debug_log, "   to:\n");
3662     cv_dump(cv);
3663 #endif
3664
3665     LEAVE;
3666     return cv;
3667 }
3668
3669 CV *
3670 cv_clone(CV *proto)
3671 {
3672     return cv_clone2(proto, CvOUTSIDE(proto));
3673 }
3674
3675 void
3676 cv_ckproto(CV *cv, GV *gv, char *p)
3677 {
3678     if ((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) {
3679         SV* msg = sv_newmortal();
3680         SV* name = Nullsv;
3681
3682         if (gv)
3683             gv_efullname3(name = sv_newmortal(), gv, Nullch);
3684         sv_setpv(msg, "Prototype mismatch:");
3685         if (name)
3686             sv_catpvf(msg, " sub %_", name);
3687         if (SvPOK(cv))
3688             sv_catpvf(msg, " (%s)", SvPVX(cv));
3689         sv_catpv(msg, " vs ");
3690         if (p)
3691             sv_catpvf(msg, "(%s)", p);
3692         else
3693             sv_catpv(msg, "none");
3694         warn("%_", msg);
3695     }
3696 }
3697
3698 SV *
3699 cv_const_sv(CV *cv)
3700 {
3701     if (!cv || !SvPOK(cv) || SvCUR(cv))
3702         return Nullsv;
3703     return op_const_sv(CvSTART(cv), cv);
3704 }
3705
3706 SV *
3707 op_const_sv(OP *o, CV *cv)
3708 {
3709     SV *sv = Nullsv;
3710
3711     if(!o)
3712         return Nullsv;
3713
3714     if(o->op_type == OP_LINESEQ && cLISTOPo->op_first)
3715         o = cLISTOPo->op_first->op_sibling;
3716
3717     for (; o; o = o->op_next) {
3718         OPCODE type = o->op_type;
3719
3720         if(sv && o->op_next == o)
3721             return sv;
3722         if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
3723             continue;
3724         if (type == OP_LEAVESUB || type == OP_RETURN)
3725             break;
3726         if (sv)
3727             return Nullsv;
3728         if (type == OP_CONST)
3729             sv = cSVOPo->op_sv;
3730         else if (type == OP_PADSV && cv) {
3731             AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
3732             sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
3733             if (!sv || (!SvREADONLY(sv) && SvREFCNT(sv) > 1))
3734                 return Nullsv;
3735         }
3736         else
3737             return Nullsv;
3738     }
3739     if (sv)
3740         SvREADONLY_on(sv);
3741     return sv;
3742 }
3743
3744 CV *
3745 newSUB(I32 floor, OP *o, OP *proto, OP *block)
3746 {
3747     dTHR;
3748     char *name = o ? SvPVx(cSVOPo->op_sv, PL_na) : Nullch;
3749     GV *gv = gv_fetchpv(name ? name : "__ANON__",
3750                         GV_ADDMULTI | (block ? 0 : GV_NOINIT), SVt_PVCV);
3751     char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, PL_na) : Nullch;
3752     register CV *cv=0;
3753     I32 ix;
3754
3755     if (o)
3756         SAVEFREEOP(o);
3757     if (proto)
3758         SAVEFREEOP(proto);
3759
3760     if (SvTYPE(gv) != SVt_PVGV) {       /* Prototype now, and had
3761                                            maximum a prototype before. */
3762         if (SvTYPE(gv) > SVt_NULL) {
3763             if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1))
3764                 warn("Runaway prototype");
3765             cv_ckproto((CV*)gv, NULL, ps);
3766         }
3767         if (ps)
3768             sv_setpv((SV*)gv, ps);
3769         else
3770             sv_setiv((SV*)gv, -1);
3771         SvREFCNT_dec(PL_compcv);
3772         cv = PL_compcv = NULL;
3773         PL_sub_generation++;
3774         goto noblock;
3775     }
3776
3777     if (!name || GvCVGEN(gv))
3778         cv = Nullcv;
3779     else if (cv = GvCV(gv)) {
3780         cv_ckproto(cv, gv, ps);
3781         /* already defined (or promised)? */
3782         if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
3783             SV* const_sv;
3784             bool const_changed = TRUE;
3785             if (!block) {
3786                 /* just a "sub foo;" when &foo is already defined */
3787                 SAVEFREESV(PL_compcv);
3788                 goto done;
3789             }
3790             /* ahem, death to those who redefine active sort subs */
3791             if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
3792                 croak("Can't redefine active sort subroutine %s", name);
3793             if(const_sv = cv_const_sv(cv))
3794                 const_changed = sv_cmp(const_sv, op_const_sv(block, Nullcv));
3795             if ((const_sv && const_changed) || ckWARN(WARN_REDEFINE)
3796                                         && !(CvGV(cv) && GvSTASH(CvGV(cv))
3797                                         && HvNAME(GvSTASH(CvGV(cv)))
3798                                         && strEQ(HvNAME(GvSTASH(CvGV(cv))),
3799                                                  "autouse"))) {
3800                 line_t oldline = PL_curcop->cop_line;
3801                 PL_curcop->cop_line = PL_copline;
3802                 warner(WARN_REDEFINE,
3803                         const_sv ? "Constant subroutine %s redefined"
3804                                  : "Subroutine %s redefined", name);
3805                 PL_curcop->cop_line = oldline;
3806             }
3807             SvREFCNT_dec(cv);
3808             cv = Nullcv;
3809         }
3810     }
3811     if (cv) {                           /* must reuse cv if autoloaded */
3812         cv_undef(cv);
3813         CvFLAGS(cv) = CvFLAGS(PL_compcv);
3814         CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
3815         CvOUTSIDE(PL_compcv) = 0;
3816         CvPADLIST(cv) = CvPADLIST(PL_compcv);
3817         CvPADLIST(PL_compcv) = 0;
3818         if (SvREFCNT(PL_compcv) > 1) /* XXX Make closures transit through stub. */
3819             CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc((SV*)cv);
3820         SvREFCNT_dec(PL_compcv);
3821     }
3822     else {
3823         cv = PL_compcv;
3824         if (name) {
3825             GvCV(gv) = cv;
3826             GvCVGEN(gv) = 0;
3827             PL_sub_generation++;
3828         }
3829     }
3830     CvGV(cv) = (GV*)SvREFCNT_inc(gv);
3831     CvFILEGV(cv) = PL_curcop->cop_filegv;
3832     CvSTASH(cv) = PL_curstash;
3833 #ifdef USE_THREADS
3834     CvOWNER(cv) = 0;
3835     if (!CvMUTEXP(cv))
3836         New(666, CvMUTEXP(cv), 1, perl_mutex);
3837     MUTEX_INIT(CvMUTEXP(cv));
3838 #endif /* USE_THREADS */
3839
3840     if (ps)
3841         sv_setpv((SV*)cv, ps);
3842
3843     if (PL_error_count) {
3844         op_free(block);
3845         block = Nullop;
3846         if (name) {
3847             char *s = strrchr(name, ':');
3848             s = s ? s+1 : name;
3849             if (strEQ(s, "BEGIN")) {
3850                 char *not_safe =
3851                     "BEGIN not safe after errors--compilation aborted";
3852                 if (PL_in_eval & 4)
3853                     croak(not_safe);
3854                 else {
3855                     /* force display of errors found but not reported */
3856                     sv_catpv(ERRSV, not_safe);
3857                     croak("%s", SvPVx(ERRSV, PL_na));
3858                 }
3859             }
3860         }
3861     }
3862     if (!block) {
3863       noblock:
3864         PL_copline = NOLINE;
3865         LEAVE_SCOPE(floor);
3866         return cv;
3867     }
3868
3869     if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
3870         av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
3871
3872     if (CvCLONE(cv)) {
3873         SV **namep = AvARRAY(PL_comppad_name);
3874         for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
3875             SV *namesv;
3876
3877             if (SvIMMORTAL(PL_curpad[ix]))
3878                 continue;
3879             /*
3880              * The only things that a clonable function needs in its
3881              * pad are references to outer lexicals and anonymous subs.
3882              * The rest are created anew during cloning.
3883              */
3884             if (!((namesv = namep[ix]) != Nullsv &&
3885                   namesv != &PL_sv_undef &&
3886                   (SvFAKE(namesv) ||
3887                    *SvPVX(namesv) == '&')))
3888             {
3889                 SvREFCNT_dec(PL_curpad[ix]);
3890                 PL_curpad[ix] = Nullsv;
3891             }
3892         }
3893     }
3894     else {
3895         AV *av = newAV();                       /* Will be @_ */
3896         av_extend(av, 0);
3897         av_store(PL_comppad, 0, (SV*)av);
3898         AvFLAGS(av) = AVf_REIFY;
3899
3900         for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
3901             if (SvIMMORTAL(PL_curpad[ix]))
3902                 continue;
3903             if (!SvPADMY(PL_curpad[ix]))
3904                 SvPADTMP_on(PL_curpad[ix]);
3905         }
3906     }
3907
3908     CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
3909     CvSTART(cv) = LINKLIST(CvROOT(cv));
3910     CvROOT(cv)->op_next = 0;
3911     peep(CvSTART(cv));
3912
3913     if (name) {
3914         char *s;
3915
3916         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
3917             SV *sv = NEWSV(0,0);
3918             SV *tmpstr = sv_newmortal();
3919             GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
3920             CV *cv;
3921             HV *hv;
3922
3923             sv_setpvf(sv, "%_:%ld-%ld",
3924                     GvSV(PL_curcop->cop_filegv),
3925                     (long)PL_subline, (long)PL_curcop->cop_line);
3926             gv_efullname3(tmpstr, gv, Nullch);
3927             hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
3928             hv = GvHVn(db_postponed);
3929             if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
3930                   && (cv = GvCV(db_postponed))) {
3931                 dSP;
3932                 PUSHMARK(SP);
3933                 XPUSHs(tmpstr);
3934                 PUTBACK;
3935                 perl_call_sv((SV*)cv, G_DISCARD);
3936             }
3937         }
3938
3939         if ((s = strrchr(name,':')))
3940             s++;
3941         else
3942             s = name;
3943         if (strEQ(s, "BEGIN")) {
3944             I32 oldscope = PL_scopestack_ix;
3945             ENTER;
3946             SAVESPTR(PL_compiling.cop_filegv);
3947             SAVEI16(PL_compiling.cop_line);
3948             save_svref(&PL_rs);
3949             sv_setsv(PL_rs, PL_nrs);
3950
3951             if (!PL_beginav)
3952                 PL_beginav = newAV();
3953             DEBUG_x( dump_sub(gv) );
3954             av_push(PL_beginav, (SV *)cv);
3955             GvCV(gv) = 0;
3956             call_list(oldscope, PL_beginav);
3957
3958             PL_curcop = &PL_compiling;
3959             PL_compiling.op_private = PL_hints;
3960             LEAVE;
3961         }
3962         else if (strEQ(s, "END") && !PL_error_count) {
3963             if (!PL_endav)
3964                 PL_endav = newAV();
3965             av_unshift(PL_endav, 1);
3966             av_store(PL_endav, 0, (SV *)cv);
3967             GvCV(gv) = 0;
3968         }
3969         else if (strEQ(s, "INIT") && !PL_error_count) {
3970             if (!PL_initav)
3971                 PL_initav = newAV();
3972             av_push(PL_initav, SvREFCNT_inc(cv));
3973             GvCV(gv) = 0;
3974         }
3975     }
3976
3977   done:
3978     PL_copline = NOLINE;
3979     LEAVE_SCOPE(floor);
3980     return cv;
3981 }
3982
3983 void
3984 newCONSTSUB(HV *stash, char *name, SV *sv)
3985 {
3986     dTHR;
3987     U32 oldhints = PL_hints;
3988     HV *old_cop_stash = PL_curcop->cop_stash;
3989     HV *old_curstash = PL_curstash;
3990     line_t oldline = PL_curcop->cop_line;
3991     PL_curcop->cop_line = PL_copline;
3992
3993     PL_hints &= ~HINT_BLOCK_SCOPE;
3994     if(stash)
3995         PL_curstash = PL_curcop->cop_stash = stash;
3996
3997     newSUB(
3998         start_subparse(FALSE, 0),
3999         newSVOP(OP_CONST, 0, newSVpv(name,0)),
4000         newSVOP(OP_CONST, 0, &PL_sv_no),        /* SvPV(&PL_sv_no) == "" -- GMB */
4001         newSTATEOP(0, Nullch, newSVOP(OP_CONST, 0, sv))
4002     );
4003
4004     PL_hints = oldhints;
4005     PL_curcop->cop_stash = old_cop_stash;
4006     PL_curstash = old_curstash;
4007     PL_curcop->cop_line = oldline;
4008 }
4009
4010 CV *
4011 newXS(char *name, void (*subaddr) (CV * _CPERLproto), char *filename)
4012 {
4013     dTHR;
4014     GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV);
4015     register CV *cv;
4016
4017     if (cv = (name ? GvCV(gv) : Nullcv)) {
4018         if (GvCVGEN(gv)) {
4019             /* just a cached method */
4020             SvREFCNT_dec(cv);
4021             cv = 0;
4022         }
4023         else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4024             /* already defined (or promised) */
4025             if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
4026                             && HvNAME(GvSTASH(CvGV(cv)))
4027                             && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
4028                 line_t oldline = PL_curcop->cop_line;
4029                 PL_curcop->cop_line = PL_copline;
4030                 warner(WARN_REDEFINE, "Subroutine %s redefined",name);
4031                 PL_curcop->cop_line = oldline;
4032             }
4033             SvREFCNT_dec(cv);
4034             cv = 0;
4035         }
4036     }
4037
4038     if (cv)                             /* must reuse cv if autoloaded */
4039         cv_undef(cv);
4040     else {
4041         cv = (CV*)NEWSV(1105,0);
4042         sv_upgrade((SV *)cv, SVt_PVCV);
4043         if (name) {
4044             GvCV(gv) = cv;
4045             GvCVGEN(gv) = 0;
4046             PL_sub_generation++;
4047         }
4048     }
4049     CvGV(cv) = (GV*)SvREFCNT_inc(gv);
4050 #ifdef USE_THREADS
4051     New(666, CvMUTEXP(cv), 1, perl_mutex);
4052     MUTEX_INIT(CvMUTEXP(cv));
4053     CvOWNER(cv) = 0;
4054 #endif /* USE_THREADS */
4055     CvFILEGV(cv) = gv_fetchfile(filename);
4056     CvXSUB(cv) = subaddr;
4057
4058     if (name) {
4059         char *s = strrchr(name,':');
4060         if (s)
4061             s++;
4062         else
4063             s = name;
4064         if (strEQ(s, "BEGIN")) {
4065             if (!PL_beginav)
4066                 PL_beginav = newAV();
4067             av_push(PL_beginav, (SV *)cv);
4068             GvCV(gv) = 0;
4069         }
4070         else if (strEQ(s, "END")) {
4071             if (!PL_endav)
4072                 PL_endav = newAV();
4073             av_unshift(PL_endav, 1);
4074             av_store(PL_endav, 0, (SV *)cv);
4075             GvCV(gv) = 0;
4076         }
4077         else if (strEQ(s, "INIT")) {
4078             if (!PL_initav)
4079                 PL_initav = newAV();
4080             av_push(PL_initav, (SV *)cv);
4081             GvCV(gv) = 0;
4082         }
4083     }
4084     else
4085         CvANON_on(cv);
4086
4087     return cv;
4088 }
4089
4090 void
4091 newFORM(I32 floor, OP *o, OP *block)
4092 {
4093     dTHR;
4094     register CV *cv;
4095     char *name;
4096     GV *gv;
4097     I32 ix;
4098
4099     if (o)
4100         name = SvPVx(cSVOPo->op_sv, PL_na);
4101     else
4102         name = "STDOUT";
4103     gv = gv_fetchpv(name,TRUE, SVt_PVFM);
4104     GvMULTI_on(gv);
4105     if (cv = GvFORM(gv)) {
4106         if (ckWARN(WARN_REDEFINE)) {
4107             line_t oldline = PL_curcop->cop_line;
4108
4109             PL_curcop->cop_line = PL_copline;
4110             warner(WARN_REDEFINE, "Format %s redefined",name);
4111             PL_curcop->cop_line = oldline;
4112         }
4113         SvREFCNT_dec(cv);
4114     }
4115     cv = PL_compcv;
4116     GvFORM(gv) = cv;
4117     CvGV(cv) = (GV*)SvREFCNT_inc(gv);
4118     CvFILEGV(cv) = PL_curcop->cop_filegv;
4119
4120     for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4121         if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
4122             SvPADTMP_on(PL_curpad[ix]);
4123     }
4124
4125     CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
4126     CvSTART(cv) = LINKLIST(CvROOT(cv));
4127     CvROOT(cv)->op_next = 0;
4128     peep(CvSTART(cv));
4129     op_free(o);
4130     PL_copline = NOLINE;
4131     LEAVE_SCOPE(floor);
4132 }
4133
4134 OP *
4135 newANONLIST(OP *o)
4136 {
4137     return newUNOP(OP_REFGEN, 0,
4138         mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
4139 }
4140
4141 OP *
4142 newANONHASH(OP *o)
4143 {
4144     return newUNOP(OP_REFGEN, 0,
4145         mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
4146 }
4147
4148 OP *
4149 newANONSUB(I32 floor, OP *proto, OP *block)
4150 {
4151     return newUNOP(OP_REFGEN, 0,
4152         newSVOP(OP_ANONCODE, 0, (SV*)newSUB(floor, 0, proto, block)));
4153 }
4154
4155 OP *
4156 oopsAV(OP *o)
4157 {
4158     switch (o->op_type) {
4159     case OP_PADSV:
4160         o->op_type = OP_PADAV;
4161         o->op_ppaddr = ppaddr[OP_PADAV];
4162         return ref(o, OP_RV2AV);
4163
4164     case OP_RV2SV:
4165         o->op_type = OP_RV2AV;
4166         o->op_ppaddr = ppaddr[OP_RV2AV];
4167         ref(o, OP_RV2AV);
4168         break;
4169
4170     default:
4171         warn("oops: oopsAV");
4172         break;
4173     }
4174     return o;
4175 }
4176
4177 OP *
4178 oopsHV(OP *o)
4179 {
4180     switch (o->op_type) {
4181     case OP_PADSV:
4182     case OP_PADAV:
4183         o->op_type = OP_PADHV;
4184         o->op_ppaddr = ppaddr[OP_PADHV];
4185         return ref(o, OP_RV2HV);
4186
4187     case OP_RV2SV:
4188     case OP_RV2AV:
4189         o->op_type = OP_RV2HV;
4190         o->op_ppaddr = ppaddr[OP_RV2HV];
4191         ref(o, OP_RV2HV);
4192         break;
4193
4194     default:
4195         warn("oops: oopsHV");
4196         break;
4197     }
4198     return o;
4199 }
4200
4201 OP *
4202 newAVREF(OP *o)
4203 {
4204     if (o->op_type == OP_PADANY) {
4205         o->op_type = OP_PADAV;
4206         o->op_ppaddr = ppaddr[OP_PADAV];
4207         return o;
4208     }
4209     return newUNOP(OP_RV2AV, 0, scalar(o));
4210 }
4211
4212 OP *
4213 newGVREF(I32 type, OP *o)
4214 {
4215     if (type == OP_MAPSTART)
4216         return newUNOP(OP_NULL, 0, o);
4217     return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
4218 }
4219
4220 OP *
4221 newHVREF(OP *o)
4222 {
4223     if (o->op_type == OP_PADANY) {
4224         o->op_type = OP_PADHV;
4225         o->op_ppaddr = ppaddr[OP_PADHV];
4226         return o;
4227     }
4228     return newUNOP(OP_RV2HV, 0, scalar(o));
4229 }
4230
4231 OP *
4232 oopsCV(OP *o)
4233 {
4234     croak("NOT IMPL LINE %d",__LINE__);
4235     /* STUB */
4236     return o;
4237 }
4238
4239 OP *
4240 newCVREF(I32 flags, OP *o)
4241 {
4242     return newUNOP(OP_RV2CV, flags, scalar(o));
4243 }
4244
4245 OP *
4246 newSVREF(OP *o)
4247 {
4248     if (o->op_type == OP_PADANY) {
4249         o->op_type = OP_PADSV;
4250         o->op_ppaddr = ppaddr[OP_PADSV];
4251         return o;
4252     }
4253     else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
4254         o->op_flags |= OPpDONE_SVREF;
4255         return o;
4256     }
4257     return newUNOP(OP_RV2SV, 0, scalar(o));
4258 }
4259
4260 /* Check routines. */
4261
4262 OP *
4263 ck_anoncode(OP *o)
4264 {
4265     PADOFFSET ix;
4266     SV* name;
4267
4268     name = NEWSV(1106,0);
4269     sv_upgrade(name, SVt_PVNV);
4270     sv_setpvn(name, "&", 1);
4271     SvIVX(name) = -1;
4272     SvNVX(name) = 1;
4273     ix = pad_alloc(o->op_type, SVs_PADMY);
4274     av_store(PL_comppad_name, ix, name);
4275     av_store(PL_comppad, ix, cSVOPo->op_sv);
4276     SvPADMY_on(cSVOPo->op_sv);
4277     cSVOPo->op_sv = Nullsv;
4278     cSVOPo->op_targ = ix;
4279     return o;
4280 }
4281
4282 OP *
4283 ck_bitop(OP *o)
4284 {
4285     o->op_private = PL_hints;
4286     return o;
4287 }
4288
4289 OP *
4290 ck_concat(OP *o)
4291 {
4292     if (cUNOPo->op_first->op_type == OP_CONCAT)
4293         o->op_flags |= OPf_STACKED;
4294     return o;
4295 }
4296
4297 OP *
4298 ck_spair(OP *o)
4299 {
4300     if (o->op_flags & OPf_KIDS) {
4301         OP* newop;
4302         OP* kid;
4303         OPCODE type = o->op_type;
4304         o = modkids(ck_fun(o), type);
4305         kid = cUNOPo->op_first;
4306         newop = kUNOP->op_first->op_sibling;
4307         if (newop &&
4308             (newop->op_sibling ||
4309              !(opargs[newop->op_type] & OA_RETSCALAR) ||
4310              newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
4311              newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
4312
4313             return o;
4314         }
4315         op_free(kUNOP->op_first);
4316         kUNOP->op_first = newop;
4317     }
4318     o->op_ppaddr = ppaddr[++o->op_type];
4319     return ck_fun(o);
4320 }
4321
4322 OP *
4323 ck_delete(OP *o)
4324 {
4325     o = ck_fun(o);
4326     o->op_private = 0;
4327     if (o->op_flags & OPf_KIDS) {
4328         OP *kid = cUNOPo->op_first;
4329         if (kid->op_type == OP_HSLICE)
4330             o->op_private |= OPpSLICE;
4331         else if (kid->op_type != OP_HELEM)
4332             croak("%s argument is not a HASH element or slice",
4333                   op_desc[o->op_type]);
4334         null(kid);
4335     }
4336     return o;
4337 }
4338
4339 OP *
4340 ck_eof(OP *o)
4341 {
4342     I32 type = o->op_type;
4343
4344     if (o->op_flags & OPf_KIDS) {
4345         if (cLISTOPo->op_first->op_type == OP_STUB) {
4346             op_free(o);
4347             o = newUNOP(type, OPf_SPECIAL,
4348                 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
4349         }
4350         return ck_fun(o);
4351     }
4352     return o;
4353 }
4354
4355 OP *
4356 ck_eval(OP *o)
4357 {
4358     PL_hints |= HINT_BLOCK_SCOPE;
4359     if (o->op_flags & OPf_KIDS) {
4360         SVOP *kid = (SVOP*)cUNOPo->op_first;
4361
4362         if (!kid) {
4363             o->op_flags &= ~OPf_KIDS;
4364             null(o);
4365         }
4366         else if (kid->op_type == OP_LINESEQ) {
4367             LOGOP *enter;
4368
4369             kid->op_next = o->op_next;
4370             cUNOPo->op_first = 0;
4371             op_free(o);
4372
4373             Newz(1101, enter, 1, LOGOP);
4374             enter->op_type = OP_ENTERTRY;
4375             enter->op_ppaddr = ppaddr[OP_ENTERTRY];
4376             enter->op_private = 0;
4377
4378             /* establish postfix order */
4379             enter->op_next = (OP*)enter;
4380
4381             o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
4382             o->op_type = OP_LEAVETRY;
4383             o->op_ppaddr = ppaddr[OP_LEAVETRY];
4384             enter->op_other = o;
4385             return o;
4386         }
4387         else
4388             scalar((OP*)kid);
4389     }
4390     else {
4391         op_free(o);
4392         o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
4393     }
4394     o->op_targ = (PADOFFSET)PL_hints;
4395     return o;
4396 }
4397
4398 OP *
4399 ck_exec(OP *o)
4400 {
4401     OP *kid;
4402     if (o->op_flags & OPf_STACKED) {
4403         o = ck_fun(o);
4404         kid = cUNOPo->op_first->op_sibling;
4405         if (kid->op_type == OP_RV2GV)
4406             null(kid);
4407     }
4408     else
4409         o = listkids(o);
4410     return o;
4411 }
4412
4413 OP *
4414 ck_exists(OP *o)
4415 {
4416     o = ck_fun(o);
4417     if (o->op_flags & OPf_KIDS) {
4418         OP *kid = cUNOPo->op_first;
4419         if (kid->op_type != OP_HELEM)
4420             croak("%s argument is not a HASH element", op_desc[o->op_type]);
4421         null(kid);
4422     }
4423     return o;
4424 }
4425
4426 OP *
4427 ck_gvconst(register OP *o)
4428 {
4429     o = fold_constants(o);
4430     if (o->op_type == OP_CONST)
4431         o->op_type = OP_GV;
4432     return o;
4433 }
4434
4435 OP *
4436 ck_rvconst(register OP *o)
4437 {
4438     dTHR;
4439     SVOP *kid = (SVOP*)cUNOPo->op_first;
4440
4441     o->op_private |= (PL_hints & HINT_STRICT_REFS);
4442     if (kid->op_type == OP_CONST) {
4443         char *name;
4444         int iscv;
4445         GV *gv;
4446
4447         name = SvPV(kid->op_sv, PL_na);
4448         if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
4449             char *badthing = Nullch;
4450             switch (o->op_type) {
4451             case OP_RV2SV:
4452                 badthing = "a SCALAR";
4453                 break;
4454             case OP_RV2AV:
4455                 badthing = "an ARRAY";
4456                 break;
4457             case OP_RV2HV:
4458                 badthing = "a HASH";
4459                 break;
4460             }
4461             if (badthing)
4462                 croak(
4463           "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
4464                       name, badthing);
4465         }
4466         /*
4467          * This is a little tricky.  We only want to add the symbol if we
4468          * didn't add it in the lexer.  Otherwise we get duplicate strict
4469          * warnings.  But if we didn't add it in the lexer, we must at
4470          * least pretend like we wanted to add it even if it existed before,
4471          * or we get possible typo warnings.  OPpCONST_ENTERED says
4472          * whether the lexer already added THIS instance of this symbol.
4473          */
4474         iscv = (o->op_type == OP_RV2CV) * 2;
4475         do {
4476             gv = gv_fetchpv(name,
4477                 iscv | !(kid->op_private & OPpCONST_ENTERED),
4478                 iscv
4479                     ? SVt_PVCV
4480                     : o->op_type == OP_RV2SV
4481                         ? SVt_PV
4482                         : o->op_type == OP_RV2AV
4483                             ? SVt_PVAV
4484                             : o->op_type == OP_RV2HV
4485                                 ? SVt_PVHV
4486                                 : SVt_PVGV);
4487         } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
4488         if (gv) {
4489             kid->op_type = OP_GV;
4490             SvREFCNT_dec(kid->op_sv);
4491             kid->op_sv = SvREFCNT_inc(gv);
4492         }
4493     }
4494     return o;
4495 }
4496
4497 OP *
4498 ck_ftst(OP *o)
4499 {
4500     dTHR;
4501     I32 type = o->op_type;
4502
4503     if (o->op_flags & OPf_REF)
4504         return o;
4505
4506     if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
4507         SVOP *kid = (SVOP*)cUNOPo->op_first;
4508
4509         if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
4510             OP *newop = newGVOP(type, OPf_REF,
4511                 gv_fetchpv(SvPVx(kid->op_sv, PL_na), TRUE, SVt_PVIO));
4512             op_free(o);
4513             return newop;
4514         }
4515     }
4516     else {
4517         op_free(o);
4518         if (type == OP_FTTTY)
4519            return newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
4520                                 SVt_PVIO));
4521         else
4522             return newUNOP(type, 0, newDEFSVOP());
4523     }
4524     return o;
4525 }
4526
4527 OP *
4528 ck_fun(OP *o)
4529 {
4530     dTHR;
4531     register OP *kid;
4532     OP **tokid;
4533     OP *sibl;
4534     I32 numargs = 0;
4535     int type = o->op_type;
4536     register I32 oa = opargs[type] >> OASHIFT;
4537
4538     if (o->op_flags & OPf_STACKED) {
4539         if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
4540             oa &= ~OA_OPTIONAL;
4541         else
4542             return no_fh_allowed(o);
4543     }
4544
4545     if (o->op_flags & OPf_KIDS) {
4546         tokid = &cLISTOPo->op_first;
4547         kid = cLISTOPo->op_first;
4548         if (kid->op_type == OP_PUSHMARK ||
4549             kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK)
4550         {
4551             tokid = &kid->op_sibling;
4552             kid = kid->op_sibling;
4553         }
4554         if (!kid && opargs[type] & OA_DEFGV)
4555             *tokid = kid = newDEFSVOP();
4556
4557         while (oa && kid) {
4558             numargs++;
4559             sibl = kid->op_sibling;
4560             switch (oa & 7) {
4561             case OA_SCALAR:
4562                 scalar(kid);
4563                 break;
4564             case OA_LIST:
4565                 if (oa < 16) {
4566                     kid = 0;
4567                     continue;
4568                 }
4569                 else
4570                     list(kid);
4571                 break;
4572             case OA_AVREF:
4573                 if (kid->op_type == OP_CONST &&
4574                   (kid->op_private & OPpCONST_BARE)) {
4575                     char *name = SvPVx(((SVOP*)kid)->op_sv, PL_na);
4576                     OP *newop = newAVREF(newGVOP(OP_GV, 0,
4577                         gv_fetchpv(name, TRUE, SVt_PVAV) ));
4578                     if (ckWARN(WARN_SYNTAX))
4579                         warner(WARN_SYNTAX,
4580                             "Array @%s missing the @ in argument %ld of %s()",
4581                             name, (long)numargs, op_desc[type]);
4582                     op_free(kid);
4583                     kid = newop;
4584                     kid->op_sibling = sibl;
4585                     *tokid = kid;
4586                 }
4587                 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
4588                     bad_type(numargs, "array", op_desc[o->op_type], kid);
4589                 mod(kid, type);
4590                 break;
4591             case OA_HVREF:
4592                 if (kid->op_type == OP_CONST &&
4593                   (kid->op_private & OPpCONST_BARE)) {
4594                     char *name = SvPVx(((SVOP*)kid)->op_sv, PL_na);
4595                     OP *newop = newHVREF(newGVOP(OP_GV, 0,
4596                         gv_fetchpv(name, TRUE, SVt_PVHV) ));
4597                     if (ckWARN(WARN_SYNTAX))
4598                         warner(WARN_SYNTAX,
4599                             "Hash %%%s missing the %% in argument %ld of %s()",
4600                             name, (long)numargs, op_desc[type]);
4601                     op_free(kid);
4602                     kid = newop;
4603                     kid->op_sibling = sibl;
4604                     *tokid = kid;
4605                 }
4606                 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
4607                     bad_type(numargs, "hash", op_desc[o->op_type], kid);
4608                 mod(kid, type);
4609                 break;
4610             case OA_CVREF:
4611                 {
4612                     OP *newop = newUNOP(OP_NULL, 0, kid);
4613                     kid->op_sibling = 0;
4614                     linklist(kid);
4615                     newop->op_next = newop;
4616                     kid = newop;
4617                     kid->op_sibling = sibl;
4618                     *tokid = kid;
4619                 }
4620                 break;
4621             case OA_FILEREF:
4622                 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
4623                     if (kid->op_type == OP_CONST &&
4624                       (kid->op_private & OPpCONST_BARE)) {
4625                         OP *newop = newGVOP(OP_GV, 0,
4626                             gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, PL_na), TRUE,
4627                                         SVt_PVIO) );
4628                         op_free(kid);
4629                         kid = newop;
4630                     }
4631                     else {
4632                         kid->op_sibling = 0;
4633                         kid = newUNOP(OP_RV2GV, 0, scalar(kid));
4634                     }
4635                     kid->op_sibling = sibl;
4636                     *tokid = kid;
4637                 }
4638                 scalar(kid);
4639                 break;
4640             case OA_SCALARREF:
4641                 mod(scalar(kid), type);
4642                 break;
4643             }
4644             oa >>= 4;
4645             tokid = &kid->op_sibling;
4646             kid = kid->op_sibling;
4647         }
4648         o->op_private |= numargs;
4649         if (kid)
4650             return too_many_arguments(o,op_desc[o->op_type]);
4651         listkids(o);
4652     }
4653     else if (opargs[type] & OA_DEFGV) {
4654         op_free(o);
4655         return newUNOP(type, 0, newDEFSVOP());
4656     }
4657
4658     if (oa) {
4659         while (oa & OA_OPTIONAL)
4660             oa >>= 4;
4661         if (oa && oa != OA_LIST)
4662             return too_few_arguments(o,op_desc[o->op_type]);
4663     }
4664     return o;
4665 }
4666
4667 OP *
4668 ck_glob(OP *o)
4669 {
4670     GV *gv;
4671
4672     if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
4673         append_elem(OP_GLOB, o, newDEFSVOP());
4674
4675     if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV)) && GvIMPORTED_CV(gv)))
4676         gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
4677
4678     if (gv && GvIMPORTED_CV(gv)) {
4679         static int glob_index;
4680
4681         append_elem(OP_GLOB, o,
4682                     newSVOP(OP_CONST, 0, newSViv(glob_index++)));
4683         o->op_type = OP_LIST;
4684         o->op_ppaddr = ppaddr[OP_LIST];
4685         cLISTOPo->op_first->op_type = OP_PUSHMARK;
4686         cLISTOPo->op_first->op_ppaddr = ppaddr[OP_PUSHMARK];
4687         o = newUNOP(OP_ENTERSUB, OPf_STACKED,
4688                     append_elem(OP_LIST, o,
4689                                 scalar(newUNOP(OP_RV2CV, 0,
4690                                                newGVOP(OP_GV, 0, gv)))));
4691         o = newUNOP(OP_NULL, 0, ck_subr(o));
4692         o->op_targ = OP_GLOB;           /* hint at what it used to be */
4693         return o;
4694     }
4695     gv = newGVgen("main");
4696     gv_IOadd(gv);
4697     append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
4698     scalarkids(o);
4699     return ck_fun(o);
4700 }
4701
4702 OP *
4703 ck_grep(OP *o)
4704 {
4705     LOGOP *gwop;
4706     OP *kid;
4707     OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
4708
4709     o->op_ppaddr = ppaddr[OP_GREPSTART];
4710     Newz(1101, gwop, 1, LOGOP);
4711
4712     if (o->op_flags & OPf_STACKED) {
4713         OP* k;
4714         o = ck_sort(o);
4715         kid = cLISTOPo->op_first->op_sibling;
4716         for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
4717             kid = k;
4718         }
4719         kid->op_next = (OP*)gwop;
4720         o->op_flags &= ~OPf_STACKED;
4721     }
4722     kid = cLISTOPo->op_first->op_sibling;
4723     if (type == OP_MAPWHILE)
4724         list(kid);
4725     else
4726         scalar(kid);
4727     o = ck_fun(o);
4728     if (PL_error_count)
4729         return o;
4730     kid = cLISTOPo->op_first->op_sibling;
4731     if (kid->op_type != OP_NULL)
4732         croak("panic: ck_grep");
4733     kid = kUNOP->op_first;
4734
4735     gwop->op_type = type;
4736     gwop->op_ppaddr = ppaddr[type];
4737     gwop->op_first = listkids(o);
4738     gwop->op_flags |= OPf_KIDS;
4739     gwop->op_private = 1;
4740     gwop->op_other = LINKLIST(kid);
4741     gwop->op_targ = pad_alloc(type, SVs_PADTMP);
4742     kid->op_next = (OP*)gwop;
4743
4744     kid = cLISTOPo->op_first->op_sibling;
4745     if (!kid || !kid->op_sibling)
4746         return too_few_arguments(o,op_desc[o->op_type]);
4747     for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
4748         mod(kid, OP_GREPSTART);
4749
4750     return (OP*)gwop;
4751 }
4752
4753 OP *
4754 ck_index(OP *o)
4755 {
4756     if (o->op_flags & OPf_KIDS) {
4757         OP *kid = cLISTOPo->op_first->op_sibling;       /* get past pushmark */
4758         if (kid)
4759             kid = kid->op_sibling;                      /* get past "big" */
4760         if (kid && kid->op_type == OP_CONST)
4761             fbm_compile(((SVOP*)kid)->op_sv, 0);
4762     }
4763     return ck_fun(o);
4764 }
4765
4766 OP *
4767 ck_lengthconst(OP *o)
4768 {
4769     /* XXX length optimization goes here */
4770     return ck_fun(o);
4771 }
4772
4773 OP *
4774 ck_lfun(OP *o)
4775 {
4776     OPCODE type = o->op_type;
4777     return modkids(ck_fun(o), type);
4778 }
4779
4780 OP *
4781 ck_rfun(OP *o)
4782 {
4783     OPCODE type = o->op_type;
4784     return refkids(ck_fun(o), type);
4785 }
4786
4787 OP *
4788 ck_listiob(OP *o)
4789 {
4790     register OP *kid;
4791
4792     kid = cLISTOPo->op_first;
4793     if (!kid) {
4794         o = force_list(o);
4795         kid = cLISTOPo->op_first;
4796     }
4797     if (kid->op_type == OP_PUSHMARK)
4798         kid = kid->op_sibling;
4799     if (kid && o->op_flags & OPf_STACKED)
4800         kid = kid->op_sibling;
4801     else if (kid && !kid->op_sibling) {         /* print HANDLE; */
4802         if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
4803             o->op_flags |= OPf_STACKED; /* make it a filehandle */
4804             kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
4805             cLISTOPo->op_first->op_sibling = kid;
4806             cLISTOPo->op_last = kid;
4807             kid = kid->op_sibling;
4808         }
4809     }
4810
4811     if (!kid)
4812         append_elem(o->op_type, o, newDEFSVOP());
4813
4814     o = listkids(o);
4815
4816     o->op_private = 0;
4817 #ifdef USE_LOCALE
4818     if (PL_hints & HINT_LOCALE)
4819         o->op_private |= OPpLOCALE;
4820 #endif
4821
4822     return o;
4823 }
4824
4825 OP *
4826 ck_fun_locale(OP *o)
4827 {
4828     o = ck_fun(o);
4829
4830     o->op_private = 0;
4831 #ifdef USE_LOCALE
4832     if (PL_hints & HINT_LOCALE)
4833         o->op_private |= OPpLOCALE;
4834 #endif
4835
4836     return o;
4837 }
4838
4839 OP *
4840 ck_scmp(OP *o)
4841 {
4842     o->op_private = 0;
4843 #ifdef USE_LOCALE
4844     if (PL_hints & HINT_LOCALE)
4845         o->op_private |= OPpLOCALE;
4846 #endif
4847
4848     return o;
4849 }
4850
4851 OP *
4852 ck_match(OP *o)
4853 {
4854     o->op_private |= OPpRUNTIME;
4855     return o;
4856 }
4857
4858 OP *
4859 ck_null(OP *o)
4860 {
4861     return o;
4862 }
4863
4864 OP *
4865 ck_repeat(OP *o)
4866 {
4867     if (cBINOPo->op_first->op_flags & OPf_PARENS) {
4868         o->op_private |= OPpREPEAT_DOLIST;
4869         cBINOPo->op_first = force_list(cBINOPo->op_first);
4870     }
4871     else
4872         scalar(o);
4873     return o;
4874 }
4875
4876 OP *
4877 ck_require(OP *o)
4878 {
4879     if (o->op_flags & OPf_KIDS) {       /* Shall we supply missing .pm? */
4880         SVOP *kid = (SVOP*)cUNOPo->op_first;
4881
4882         if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
4883             char *s;
4884             for (s = SvPVX(kid->op_sv); *s; s++) {
4885                 if (*s == ':' && s[1] == ':') {
4886                     *s = '/';
4887                     Move(s+2, s+1, strlen(s+2)+1, char);
4888                     --SvCUR(kid->op_sv);
4889                 }
4890             }
4891             sv_catpvn(kid->op_sv, ".pm", 3);
4892         }
4893     }
4894     return ck_fun(o);
4895 }
4896
4897 OP *
4898 ck_retarget(OP *o)
4899 {
4900     croak("NOT IMPL LINE %d",__LINE__);
4901     /* STUB */
4902     return o;
4903 }
4904
4905 OP *
4906 ck_select(OP *o)
4907 {
4908     OP* kid;
4909     if (o->op_flags & OPf_KIDS) {
4910         kid = cLISTOPo->op_first->op_sibling;   /* get past pushmark */
4911         if (kid && kid->op_sibling) {
4912             o->op_type = OP_SSELECT;
4913             o->op_ppaddr = ppaddr[OP_SSELECT];
4914             o = ck_fun(o);
4915             return fold_constants(o);
4916         }
4917     }
4918     o = ck_fun(o);
4919     kid = cLISTOPo->op_first->op_sibling;    /* get past pushmark */
4920     if (kid && kid->op_type == OP_RV2GV)
4921         kid->op_private &= ~HINT_STRICT_REFS;
4922     return o;
4923 }
4924
4925 OP *
4926 ck_shift(OP *o)
4927 {
4928     I32 type = o->op_type;
4929
4930     if (!(o->op_flags & OPf_KIDS)) {
4931         OP *argop;
4932
4933         op_free(o);
4934 #ifdef USE_THREADS
4935         if (!CvUNIQUE(PL_compcv)) {
4936             argop = newOP(OP_PADAV, OPf_REF);
4937             argop->op_targ = 0;         /* PL_curpad[0] is @_ */
4938         }
4939         else {
4940             argop = newUNOP(OP_RV2AV, 0,
4941                 scalar(newGVOP(OP_GV, 0,
4942                     gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
4943         }
4944 #else
4945         argop = newUNOP(OP_RV2AV, 0,
4946             scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
4947                            PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
4948 #endif /* USE_THREADS */
4949         return newUNOP(type, 0, scalar(argop));
4950     }
4951     return scalar(modkids(ck_fun(o), type));
4952 }
4953
4954 OP *
4955 ck_sort(OP *o)
4956 {
4957     o->op_private = 0;
4958 #ifdef USE_LOCALE
4959     if (PL_hints & HINT_LOCALE)
4960         o->op_private |= OPpLOCALE;
4961 #endif
4962
4963     if (o->op_flags & OPf_STACKED) {
4964         OP *kid = cLISTOPo->op_first->op_sibling;       /* get past pushmark */
4965         OP *k;
4966         kid = kUNOP->op_first;                          /* get past rv2gv */
4967
4968         if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
4969             linklist(kid);
4970             if (kid->op_type == OP_SCOPE) {
4971                 k = kid->op_next;
4972                 kid->op_next = 0;
4973             }
4974             else if (kid->op_type == OP_LEAVE) {
4975                 if (o->op_type == OP_SORT) {
4976                     null(kid);                  /* wipe out leave */
4977                     kid->op_next = kid;
4978
4979                     for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
4980                         if (k->op_next == kid)
4981                             k->op_next = 0;
4982                     }
4983                 }
4984                 else
4985                     kid->op_next = 0;           /* just disconnect the leave */
4986                 k = kLISTOP->op_first;
4987             }
4988             peep(k);
4989
4990             kid = cLISTOPo->op_first->op_sibling;       /* get past pushmark */
4991             null(kid);                                  /* wipe out rv2gv */
4992             if (o->op_type == OP_SORT)
4993                 kid->op_next = kid;
4994             else
4995                 kid->op_next = k;
4996             o->op_flags |= OPf_SPECIAL;
4997         }
4998     }
4999
5000     return o;
5001 }
5002
5003 OP *
5004 ck_split(OP *o)
5005 {
5006     register OP *kid;
5007
5008     if (o->op_flags & OPf_STACKED)
5009         return no_fh_allowed(o);
5010
5011     kid = cLISTOPo->op_first;
5012     if (kid->op_type != OP_NULL)
5013         croak("panic: ck_split");
5014     kid = kid->op_sibling;
5015     op_free(cLISTOPo->op_first);
5016     cLISTOPo->op_first = kid;
5017     if (!kid) {
5018         cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpv(" ", 1));
5019         cLISTOPo->op_last = kid; /* There was only one element previously */
5020     }
5021
5022     if (kid->op_type != OP_MATCH) {
5023         OP *sibl = kid->op_sibling;
5024         kid->op_sibling = 0;
5025         kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
5026         if (cLISTOPo->op_first == cLISTOPo->op_last)
5027             cLISTOPo->op_last = kid;
5028         cLISTOPo->op_first = kid;
5029         kid->op_sibling = sibl;
5030     }
5031
5032     kid->op_type = OP_PUSHRE;
5033     kid->op_ppaddr = ppaddr[OP_PUSHRE];
5034     scalar(kid);
5035
5036     if (!kid->op_sibling)
5037         append_elem(OP_SPLIT, o, newDEFSVOP());
5038
5039     kid = kid->op_sibling;
5040     scalar(kid);
5041
5042     if (!kid->op_sibling)
5043         append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
5044
5045     kid = kid->op_sibling;
5046     scalar(kid);
5047
5048     if (kid->op_sibling)
5049         return too_many_arguments(o,op_desc[o->op_type]);
5050
5051     return o;
5052 }
5053
5054 OP *
5055 ck_subr(OP *o)
5056 {
5057     dTHR;
5058     OP *prev = ((cUNOPo->op_first->op_sibling)
5059              ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
5060     OP *o2 = prev->op_sibling;
5061     OP *cvop;
5062     char *proto = 0;
5063     CV *cv = 0;
5064     GV *namegv = 0;
5065     int optional = 0;
5066     I32 arg = 0;
5067
5068     for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
5069     if (cvop->op_type == OP_RV2CV) {
5070         SVOP* tmpop;
5071         o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
5072         null(cvop);             /* disable rv2cv */
5073         tmpop = (SVOP*)((UNOP*)cvop)->op_first;
5074         if (tmpop->op_type == OP_GV) {
5075             cv = GvCVu(tmpop->op_sv);
5076             if (cv && SvPOK(cv) && !(o->op_private & OPpENTERSUB_AMPER)) {
5077                 namegv = CvANON(cv) ? (GV*)tmpop->op_sv : CvGV(cv);
5078                 proto = SvPV((SV*)cv, PL_na);
5079             }
5080         }
5081     }
5082     o->op_private |= (PL_hints & HINT_STRICT_REFS);
5083     if (PERLDB_SUB && PL_curstash != PL_debstash)
5084         o->op_private |= OPpENTERSUB_DB;
5085     while (o2 != cvop) {
5086         if (proto) {
5087             switch (*proto) {
5088             case '\0':
5089                 return too_many_arguments(o, gv_ename(namegv));
5090             case ';':
5091                 optional = 1;
5092                 proto++;
5093                 continue;
5094             case '$':
5095                 proto++;
5096                 arg++;
5097                 scalar(o2);
5098                 break;
5099             case '%':
5100             case '@':
5101                 list(o2);
5102                 arg++;
5103                 break;
5104             case '&':
5105                 proto++;
5106                 arg++;
5107                 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
5108                     bad_type(arg, "block", gv_ename(namegv), o2);
5109                 break;
5110             case '*':
5111                 proto++;
5112                 arg++;
5113                 if (o2->op_type == OP_RV2GV)
5114                     goto wrapref;
5115                 {
5116                     OP* kid = o2;
5117                     OP* sib = kid->op_sibling;
5118                     kid->op_sibling = 0;
5119                     o2 = newUNOP(OP_RV2GV, 0, kid);
5120                     o2->op_sibling = sib;
5121                     prev->op_sibling = o2;
5122                 }
5123                 goto wrapref;
5124             case '\\':
5125                 proto++;
5126                 arg++;
5127                 switch (*proto++) {
5128                 case '*':
5129                     if (o2->op_type != OP_RV2GV)
5130                         bad_type(arg, "symbol", gv_ename(namegv), o2);
5131                     goto wrapref;
5132                 case '&':
5133                     if (o2->op_type != OP_RV2CV)
5134                         bad_type(arg, "sub", gv_ename(namegv), o2);
5135                     goto wrapref;
5136                 case '$':
5137                     if (o2->op_type != OP_RV2SV
5138                         && o2->op_type != OP_PADSV
5139                         && o2->op_type != OP_THREADSV)
5140                     {
5141                         bad_type(arg, "scalar", gv_ename(namegv), o2);
5142                     }
5143                     goto wrapref;
5144                 case '@':
5145                     if (o2->op_type != OP_RV2AV && o2->op_type != OP_PADAV)
5146                         bad_type(arg, "array", gv_ename(namegv), o2);
5147                     goto wrapref;
5148                 case '%':
5149                     if (o2->op_type != OP_RV2HV && o2->op_type != OP_PADHV)
5150                         bad_type(arg, "hash", gv_ename(namegv), o2);
5151                   wrapref:
5152                     {
5153                         OP* kid = o2;
5154                         OP* sib = kid->op_sibling;
5155                         kid->op_sibling = 0;
5156                         o2 = newUNOP(OP_REFGEN, 0, kid);
5157                         o2->op_sibling = sib;
5158                         prev->op_sibling = o2;
5159                     }
5160                     break;
5161                 default: goto oops;
5162                 }
5163                 break;
5164             case ' ':
5165                 proto++;
5166                 continue;
5167             default:
5168               oops:
5169                 croak("Malformed prototype for %s: %s",
5170                         gv_ename(namegv), SvPV((SV*)cv, PL_na));
5171             }
5172         }
5173         else
5174             list(o2);
5175         mod(o2, OP_ENTERSUB);
5176         prev = o2;
5177         o2 = o2->op_sibling;
5178     }
5179     if (proto && !optional &&
5180           (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
5181         return too_few_arguments(o, gv_ename(namegv));
5182     return o;
5183 }
5184
5185 OP *
5186 ck_svconst(OP *o)
5187 {
5188     SvREADONLY_on(cSVOPo->op_sv);
5189     return o;
5190 }
5191
5192 OP *
5193 ck_trunc(OP *o)
5194 {
5195     if (o->op_flags & OPf_KIDS) {
5196         SVOP *kid = (SVOP*)cUNOPo->op_first;
5197
5198         if (kid->op_type == OP_NULL)
5199             kid = (SVOP*)kid->op_sibling;
5200         if (kid &&
5201           kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE))
5202             o->op_flags |= OPf_SPECIAL;
5203     }
5204     return ck_fun(o);
5205 }
5206
5207 /* A peephole optimizer.  We visit the ops in the order they're to execute. */
5208
5209 void
5210 peep(register OP *o)
5211 {
5212     dTHR;
5213     register OP* oldop = 0;
5214     if (!o || o->op_seq)
5215         return;
5216     ENTER;
5217     SAVEOP();
5218     SAVESPTR(PL_curcop);
5219     for (; o; o = o->op_next) {
5220         if (o->op_seq)
5221             break;
5222         if (!PL_op_seqmax)
5223             PL_op_seqmax++;
5224         PL_op = o;
5225         switch (o->op_type) {
5226         case OP_NEXTSTATE:
5227         case OP_DBSTATE:
5228             PL_curcop = ((COP*)o);              /* for warnings */
5229             o->op_seq = PL_op_seqmax++;
5230             break;
5231
5232         case OP_CONCAT:
5233         case OP_CONST:
5234         case OP_JOIN:
5235         case OP_UC:
5236         case OP_UCFIRST:
5237         case OP_LC:
5238         case OP_LCFIRST:
5239         case OP_QUOTEMETA:
5240             if (o->op_next && o->op_next->op_type == OP_STRINGIFY)
5241                 null(o->op_next);
5242             o->op_seq = PL_op_seqmax++;
5243             break;
5244         case OP_STUB:
5245             if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
5246                 o->op_seq = PL_op_seqmax++;
5247                 break; /* Scalar stub must produce undef.  List stub is noop */
5248             }
5249             goto nothin;
5250         case OP_NULL:
5251             if (o->op_targ == OP_NEXTSTATE || o->op_targ == OP_DBSTATE)
5252                 PL_curcop = ((COP*)o);
5253             goto nothin;
5254         case OP_SCALAR:
5255         case OP_LINESEQ:
5256         case OP_SCOPE:
5257           nothin:
5258             if (oldop && o->op_next) {
5259                 oldop->op_next = o->op_next;
5260                 continue;
5261             }
5262             o->op_seq = PL_op_seqmax++;
5263             break;
5264
5265         case OP_GV:
5266             if (o->op_next->op_type == OP_RV2SV) {
5267                 if (!(o->op_next->op_private & OPpDEREF)) {
5268                     null(o->op_next);
5269                     o->op_private |= o->op_next->op_private & OPpLVAL_INTRO;
5270                     o->op_next = o->op_next->op_next;
5271                     o->op_type = OP_GVSV;
5272                     o->op_ppaddr = ppaddr[OP_GVSV];
5273                 }
5274             }
5275             else if (o->op_next->op_type == OP_RV2AV) {
5276                 OP* pop = o->op_next->op_next;
5277                 IV i;
5278                 if (pop->op_type == OP_CONST &&
5279                     (PL_op = pop->op_next) &&
5280                     pop->op_next->op_type == OP_AELEM &&
5281                     !(pop->op_next->op_private &
5282                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF)) &&
5283                     (i = SvIV(((SVOP*)pop)->op_sv) - PL_compiling.cop_arybase)
5284                                 <= 255 &&
5285                     i >= 0)
5286                 {
5287                     SvREFCNT_dec(((SVOP*)pop)->op_sv);
5288                     null(o->op_next);
5289                     null(pop->op_next);
5290                     null(pop);
5291                     o->op_flags |= pop->op_next->op_flags & OPf_MOD;
5292                     o->op_next = pop->op_next->op_next;
5293                     o->op_type = OP_AELEMFAST;
5294                     o->op_ppaddr = ppaddr[OP_AELEMFAST];
5295                     o->op_private = (U8)i;
5296                     GvAVn(((GVOP*)o)->op_gv);
5297                 }
5298             }
5299             o->op_seq = PL_op_seqmax++;
5300             break;
5301
5302         case OP_MAPWHILE:
5303         case OP_GREPWHILE:
5304         case OP_AND:
5305         case OP_OR:
5306             o->op_seq = PL_op_seqmax++;
5307             while (cLOGOP->op_other->op_type == OP_NULL)
5308                 cLOGOP->op_other = cLOGOP->op_other->op_next;
5309             peep(cLOGOP->op_other);
5310             break;
5311
5312         case OP_COND_EXPR:
5313             o->op_seq = PL_op_seqmax++;
5314             peep(cCONDOP->op_true);
5315             peep(cCONDOP->op_false);
5316             break;
5317
5318         case OP_ENTERLOOP:
5319             o->op_seq = PL_op_seqmax++;
5320             peep(cLOOP->op_redoop);
5321             peep(cLOOP->op_nextop);
5322             peep(cLOOP->op_lastop);
5323             break;
5324
5325         case OP_QR:
5326         case OP_MATCH:
5327         case OP_SUBST:
5328             o->op_seq = PL_op_seqmax++;
5329             peep(cPMOP->op_pmreplstart);
5330             break;
5331
5332         case OP_EXEC:
5333             o->op_seq = PL_op_seqmax++;
5334             if (ckWARN(WARN_SYNTAX) && o->op_next
5335                 && o->op_next->op_type == OP_NEXTSTATE) {
5336                 if (o->op_next->op_sibling &&
5337                         o->op_next->op_sibling->op_type != OP_EXIT &&
5338                         o->op_next->op_sibling->op_type != OP_WARN &&
5339                         o->op_next->op_sibling->op_type != OP_DIE) {
5340                     line_t oldline = PL_curcop->cop_line;
5341
5342                     PL_curcop->cop_line = ((COP*)o->op_next)->cop_line;
5343                     warner(WARN_SYNTAX, "Statement unlikely to be reached");
5344                     warner(WARN_SYNTAX, "(Maybe you meant system() when you said exec()?)\n");
5345                     PL_curcop->cop_line = oldline;
5346                 }
5347             }
5348             break;
5349
5350         case OP_HELEM: {
5351             UNOP *rop;
5352             SV *lexname;
5353             GV **fields;
5354             SV **svp, **indsvp;
5355             I32 ind;
5356             char *key;
5357             STRLEN keylen;
5358
5359             if (o->op_private & (OPpDEREF_HV|OPpDEREF_AV|OPpLVAL_INTRO)
5360                 || ((BINOP*)o)->op_last->op_type != OP_CONST)
5361                 break;
5362             rop = (UNOP*)((BINOP*)o)->op_first;
5363             if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
5364                 break;
5365             lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
5366             if (!SvOBJECT(lexname))
5367                 break;
5368             fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
5369             if (!fields || !GvHV(*fields))
5370                 break;
5371             svp = &((SVOP*)((BINOP*)o)->op_last)->op_sv;
5372             key = SvPV(*svp, keylen);
5373             indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE);
5374             if (!indsvp) {
5375                 croak("No such field \"%s\" in variable %s of type %s",
5376                       key, SvPV(lexname, PL_na), HvNAME(SvSTASH(lexname)));
5377             }
5378             ind = SvIV(*indsvp);
5379             if (ind < 1)
5380                 croak("Bad index while coercing array into hash");
5381             rop->op_type = OP_RV2AV;
5382             rop->op_ppaddr = ppaddr[OP_RV2AV];
5383             o->op_type = OP_AELEM;
5384             o->op_ppaddr = ppaddr[OP_AELEM];
5385             SvREFCNT_dec(*svp);
5386             *svp = newSViv(ind);
5387             break;
5388         }
5389
5390         default:
5391             o->op_seq = PL_op_seqmax++;
5392             break;
5393         }
5394         oldop = o;
5395     }
5396     LEAVE;
5397 }