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