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