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