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