op.c

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