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