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