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