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