op.c

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