op.c

   1 /*    op.c
   2  *
   3  *    Copyright (c) 1991-2001, 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 #define PERL_IN_OP_C
  20 #include "perl.h"
  21 #include "keywords.h"
  22
  23 /* #define PL_OP_SLAB_ALLOC */
  24
  25 #ifdef PL_OP_SLAB_ALLOC
  26 #define SLAB_SIZE 8192
  27 static char    *PL_OpPtr  = NULL;
  28 static int     PL_OpSpace = 0;
  29 #define NewOp(m,var,c,type) do { if ((PL_OpSpace -= c*sizeof(type)) >= 0)     \
  30                               var =  (type *)(PL_OpPtr -= c*sizeof(type));    \
  31                              else                                             \
  32                               var = (type *) Slab_Alloc(m,c*sizeof(type));    \
  33                            } while (0)
  34
  35 STATIC void *
  36 S_Slab_Alloc(pTHX_ int m, size_t sz)
  37 {
  38  Newz(m,PL_OpPtr,SLAB_SIZE,char);
  39  PL_OpSpace = SLAB_SIZE - sz;
  40  return PL_OpPtr += PL_OpSpace;
  41 }
  42
  43 #else
  44 #define NewOp(m, var, c, type) Newz(m, var, c, type)
  45 #endif
  46 /*
  47  * In the following definition, the ", Nullop" is just to make the compiler
  48  * think the expression is of the right type: croak actually does a Siglongjmp.
  49  */
  50 #define CHECKOP(type,o) \
  51     ((PL_op_mask && PL_op_mask[type])                                   \
  52      ? ( op_free((OP*)o),                                       \
  53          Perl_croak(aTHX_ "%s trapped by operation mask", PL_op_desc[type]),    \
  54          Nullop )                                               \
  55      : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
  56
  57 #define PAD_MAX 999999999
  58 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
  59
  60 STATIC char*
  61 S_gv_ename(pTHX_ GV *gv)
  62 {
  63     STRLEN n_a;
  64     SV* tmpsv = sv_newmortal();
  65     gv_efullname3(tmpsv, gv, Nullch);
  66     return SvPV(tmpsv,n_a);
  67 }
  68
  69 STATIC OP *
  70 S_no_fh_allowed(pTHX_ OP *o)
  71 {
  72     yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
  73                  PL_op_desc[o->op_type]));
  74     return o;
  75 }
  76
  77 STATIC OP *
  78 S_too_few_arguments(pTHX_ OP *o, char *name)
  79 {
  80     yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
  81     return o;
  82 }
  83
  84 STATIC OP *
  85 S_too_many_arguments(pTHX_ OP *o, char *name)
  86 {
  87     yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
  88     return o;
  89 }
  90
  91 STATIC void
  92 S_bad_type(pTHX_ I32 n, char *t, char *name, OP *kid)
  93 {
  94     yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
  95                  (int)n, name, t, PL_op_desc[kid->op_type]));
  96 }
  97
  98 STATIC void
  99 S_no_bareword_allowed(pTHX_ OP *o)
 100 {
 101     qerror(Perl_mess(aTHX_
 102                      "Bareword \"%s\" not allowed while \"strict subs\" in use",
 103                      SvPV_nolen(cSVOPo_sv)));
 104 }
 105
 106 STATIC U8*
 107 S_trlist_upgrade(pTHX_ U8** sp, U8** ep)
 108 {
 109     U8 *s = *sp;
 110     U8 *e = *ep;
 111     U8 *d;
 112
 113     Newz(801, d, (e - s) * 2, U8);
 114     *sp = d;
 115
 116     while (s < e) {
 117         if (*s < 0x80 || *s == 0xff)
 118             *d++ = *s++;
 119         else {
 120             U8 c = *s++;
 121             *d++ = ((c >> 6)         | 0xc0);
 122             *d++ = ((c       & 0x3f) | 0x80);
 123         }
 124     }
 125     *ep = d;
 126     return *sp;
 127 }
 128
 129
 130 /* "register" allocation */
 131
 132 PADOFFSET
 133 Perl_pad_allocmy(pTHX_ char *name)
 134 {
 135     PADOFFSET off;
 136     SV *sv;
 137
 138     if (!(PL_in_my == KEY_our ||
 139           isALPHA(name[1]) ||
 140           (PL_hints & HINT_UTF8 && UTF8_IS_START(name[1])) ||
 141           (name[1] == '_' && (int)strlen(name) > 2)))
 142     {
 143         if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
 144             /* 1999-02-27 mjd@plover.com */
 145             char *p;
 146             p = strchr(name, '\0');
 147             /* The next block assumes the buffer is at least 205 chars
 148                long.  At present, it's always at least 256 chars. */
 149             if (p-name > 200) {
 150                 strcpy(name+200, "...");
 151                 p = name+199;
 152             }
 153             else {
 154                 p[1] = '\0';
 155             }
 156             /* Move everything else down one character */
 157             for (; p-name > 2; p--)
 158                 *p = *(p-1);
 159             name[2] = toCTRL(name[1]);
 160             name[1] = '^';
 161         }
 162         yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
 163     }
 164     if (ckWARN(WARN_MISC) && AvFILLp(PL_comppad_name) >= 0) {
 165         SV **svp = AvARRAY(PL_comppad_name);
 166         HV *ourstash = (PL_curstash ? PL_curstash : PL_defstash);
 167         PADOFFSET top = AvFILLp(PL_comppad_name);
 168         for (off = top; off > PL_comppad_name_floor; off--) {
 169             if ((sv = svp[off])
 170                 && sv != &PL_sv_undef
 171                 && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0)
 172                 && (PL_in_my != KEY_our
 173                     || ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash))
 174                 && strEQ(name, SvPVX(sv)))
 175             {
 176                 Perl_warner(aTHX_ WARN_MISC,
 177                     "\"%s\" variable %s masks earlier declaration in same %s",
 178                     (PL_in_my == KEY_our ? "our" : "my"),
 179                     name,
 180                     (SvIVX(sv) == PAD_MAX ? "scope" : "statement"));
 181                 --off;
 182                 break;
 183             }
 184         }
 185         if (PL_in_my == KEY_our) {
 186             do {
 187                 if ((sv = svp[off])
 188                     && sv != &PL_sv_undef
 189                     && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0)
 190                     && ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash)
 191                     && strEQ(name, SvPVX(sv)))
 192                 {
 193                     Perl_warner(aTHX_ WARN_MISC,
 194                         "\"our\" variable %s redeclared", name);
 195                     Perl_warner(aTHX_ WARN_MISC,
 196                         "\t(Did you mean \"local\" instead of \"our\"?)\n");
 197                     break;
 198                 }
 199             } while ( off-- > 0 );
 200         }
 201     }
 202     off = pad_alloc(OP_PADSV, SVs_PADMY);
 203     sv = NEWSV(1102,0);
 204     sv_upgrade(sv, SVt_PVNV);
 205     sv_setpv(sv, name);
 206     if (PL_in_my_stash) {
 207         if (*name != '$')
 208             yyerror(Perl_form(aTHX_ "Can't declare class for non-scalar %s in \"%s\"",
 209                          name, PL_in_my == KEY_our ? "our" : "my"));
 210         SvOBJECT_on(sv);
 211         (void)SvUPGRADE(sv, SVt_PVMG);
 212         SvSTASH(sv) = (HV*)SvREFCNT_inc(PL_in_my_stash);
 213         PL_sv_objcount++;
 214     }
 215     if (PL_in_my == KEY_our) {
 216         (void)SvUPGRADE(sv, SVt_PVGV);
 217         GvSTASH(sv) = (HV*)SvREFCNT_inc(PL_curstash ? (SV*)PL_curstash : (SV*)PL_defstash);
 218         SvFLAGS(sv) |= SVpad_OUR;
 219     }
 220     av_store(PL_comppad_name, off, sv);
 221     SvNVX(sv) = (NV)PAD_MAX;
 222     SvIVX(sv) = 0;                      /* Not yet introduced--see newSTATEOP */
 223     if (!PL_min_intro_pending)
 224         PL_min_intro_pending = off;
 225     PL_max_intro_pending = off;
 226     if (*name == '@')
 227         av_store(PL_comppad, off, (SV*)newAV());
 228     else if (*name == '%')
 229         av_store(PL_comppad, off, (SV*)newHV());
 230     SvPADMY_on(PL_curpad[off]);
 231     return off;
 232 }
 233
 234 STATIC PADOFFSET
 235 S_pad_addlex(pTHX_ SV *proto_namesv)
 236 {
 237     SV *namesv = NEWSV(1103,0);
 238     PADOFFSET newoff = pad_alloc(OP_PADSV, SVs_PADMY);
 239     sv_upgrade(namesv, SVt_PVNV);
 240     sv_setpv(namesv, SvPVX(proto_namesv));
 241     av_store(PL_comppad_name, newoff, namesv);
 242     SvNVX(namesv) = (NV)PL_curcop->cop_seq;
 243     SvIVX(namesv) = PAD_MAX;                    /* A ref, intro immediately */
 244     SvFAKE_on(namesv);                          /* A ref, not a real var */
 245     if (SvFLAGS(proto_namesv) & SVpad_OUR) {    /* An "our" variable */
 246         SvFLAGS(namesv) |= SVpad_OUR;
 247         (void)SvUPGRADE(namesv, SVt_PVGV);
 248         GvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*)GvSTASH(proto_namesv));
 249     }
 250     if (SvOBJECT(proto_namesv)) {               /* A typed var */
 251         SvOBJECT_on(namesv);
 252         (void)SvUPGRADE(namesv, SVt_PVMG);
 253         SvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*)SvSTASH(proto_namesv));
 254         PL_sv_objcount++;
 255     }
 256     return newoff;
 257 }
 258
 259 #define FINDLEX_NOSEARCH        1               /* don't search outer contexts */
 260
 261 STATIC PADOFFSET
 262 S_pad_findlex(pTHX_ char *name, PADOFFSET newoff, U32 seq, CV* startcv,
 263             I32 cx_ix, I32 saweval, U32 flags)
 264 {
 265     CV *cv;
 266     I32 off;
 267     SV *sv;
 268     register I32 i;
 269     register PERL_CONTEXT *cx;
 270
 271     for (cv = startcv; cv; cv = CvOUTSIDE(cv)) {
 272         AV *curlist = CvPADLIST(cv);
 273         SV **svp = av_fetch(curlist, 0, FALSE);
 274         AV *curname;
 275
 276         if (!svp || *svp == &PL_sv_undef)
 277             continue;
 278         curname = (AV*)*svp;
 279         svp = AvARRAY(curname);
 280         for (off = AvFILLp(curname); off > 0; off--) {
 281             if ((sv = svp[off]) &&
 282                 sv != &PL_sv_undef &&
 283                 seq <= SvIVX(sv) &&
 284                 seq > I_32(SvNVX(sv)) &&
 285                 strEQ(SvPVX(sv), name))
 286             {
 287                 I32 depth;
 288                 AV *oldpad;
 289                 SV *oldsv;
 290
 291                 depth = CvDEPTH(cv);
 292                 if (!depth) {
 293                     if (newoff) {
 294                         if (SvFAKE(sv))
 295                             continue;
 296                         return 0; /* don't clone from inactive stack frame */
 297                     }
 298                     depth = 1;
 299                 }
 300                 oldpad = (AV*)AvARRAY(curlist)[depth];
 301                 oldsv = *av_fetch(oldpad, off, TRUE);
 302                 if (!newoff) {          /* Not a mere clone operation. */
 303                     newoff = pad_addlex(sv);
 304                     if (CvANON(PL_compcv) || SvTYPE(PL_compcv) == SVt_PVFM) {
 305                         /* "It's closures all the way down." */
 306                         CvCLONE_on(PL_compcv);
 307                         if (cv == startcv) {
 308                             if (CvANON(PL_compcv))
 309                                 oldsv = Nullsv; /* no need to keep ref */
 310                         }
 311                         else {
 312                             CV *bcv;
 313                             for (bcv = startcv;
 314                                  bcv && bcv != cv && !CvCLONE(bcv);
 315                                  bcv = CvOUTSIDE(bcv))
 316                             {
 317                                 if (CvANON(bcv)) {
 318                                     /* install the missing pad entry in intervening
 319                                      * nested subs and mark them cloneable.
 320                                      * XXX fix pad_foo() to not use globals */
 321                                     AV *ocomppad_name = PL_comppad_name;
 322                                     AV *ocomppad = PL_comppad;
 323                                     SV **ocurpad = PL_curpad;
 324                                     AV *padlist = CvPADLIST(bcv);
 325                                     PL_comppad_name = (AV*)AvARRAY(padlist)[0];
 326                                     PL_comppad = (AV*)AvARRAY(padlist)[1];
 327                                     PL_curpad = AvARRAY(PL_comppad);
 328                                     pad_addlex(sv);
 329                                     PL_comppad_name = ocomppad_name;
 330                                     PL_comppad = ocomppad;
 331                                     PL_curpad = ocurpad;
 332                                     CvCLONE_on(bcv);
 333                                 }
 334                                 else {
 335                                     if (ckWARN(WARN_CLOSURE)
 336                                         && !CvUNIQUE(bcv) && !CvUNIQUE(cv))
 337                                     {
 338                                         Perl_warner(aTHX_ WARN_CLOSURE,
 339                                           "Variable \"%s\" may be unavailable",
 340                                              name);
 341                                     }
 342                                     break;
 343                                 }
 344                             }
 345                         }
 346                     }
 347                     else if (!CvUNIQUE(PL_compcv)) {
 348                         if (ckWARN(WARN_CLOSURE) && !SvFAKE(sv) && !CvUNIQUE(cv)
 349                             && !(SvFLAGS(sv) & SVpad_OUR))
 350                         {
 351                             Perl_warner(aTHX_ WARN_CLOSURE,
 352                                 "Variable \"%s\" will not stay shared", name);
 353                         }
 354                     }
 355                 }
 356                 av_store(PL_comppad, newoff, SvREFCNT_inc(oldsv));
 357                 return newoff;
 358             }
 359         }
 360     }
 361
 362     if (flags & FINDLEX_NOSEARCH)
 363         return 0;
 364
 365     /* Nothing in current lexical context--try eval's context, if any.
 366      * This is necessary to let the perldb get at lexically scoped variables.
 367      * XXX This will also probably interact badly with eval tree caching.
 368      */
 369
 370     for (i = cx_ix; i >= 0; i--) {
 371         cx = &cxstack[i];
 372         switch (CxTYPE(cx)) {
 373         default:
 374             if (i == 0 && saweval) {
 375                 seq = cxstack[saweval].blk_oldcop->cop_seq;
 376                 return pad_findlex(name, newoff, seq, PL_main_cv, -1, saweval, 0);
 377             }
 378             break;
 379         case CXt_EVAL:
 380             switch (cx->blk_eval.old_op_type) {
 381             case OP_ENTEREVAL:
 382                 if (CxREALEVAL(cx))
 383                     saweval = i;
 384                 break;
 385             case OP_DOFILE:
 386             case OP_REQUIRE:
 387                 /* require/do must have their own scope */
 388                 return 0;
 389             }
 390             break;
 391         case CXt_FORMAT:
 392         case CXt_SUB:
 393             if (!saweval)
 394                 return 0;
 395             cv = cx->blk_sub.cv;
 396             if (PL_debstash && CvSTASH(cv) == PL_debstash) {    /* ignore DB'* scope */
 397                 saweval = i;    /* so we know where we were called from */
 398                 continue;
 399             }
 400             seq = cxstack[saweval].blk_oldcop->cop_seq;
 401             return pad_findlex(name, newoff, seq, cv, i-1, saweval,FINDLEX_NOSEARCH);
 402         }
 403     }
 404
 405     return 0;
 406 }
 407
 408 PADOFFSET
 409 Perl_pad_findmy(pTHX_ char *name)
 410 {
 411     I32 off;
 412     I32 pendoff = 0;
 413     SV *sv;
 414     SV **svp = AvARRAY(PL_comppad_name);
 415     U32 seq = PL_cop_seqmax;
 416     PERL_CONTEXT *cx;
 417     CV *outside;
 418
 419 #ifdef USE_THREADS
 420     /*
 421      * Special case to get lexical (and hence per-thread) @_.
 422      * XXX I need to find out how to tell at parse-time whether use
 423      * of @_ should refer to a lexical (from a sub) or defgv (global
 424      * scope and maybe weird sub-ish things like formats). See
 425      * startsub in perly.y.  It's possible that @_ could be lexical
 426      * (at least from subs) even in non-threaded perl.
 427      */
 428     if (strEQ(name, "@_"))
 429         return 0;               /* success. (NOT_IN_PAD indicates failure) */
 430 #endif /* USE_THREADS */
 431
 432     /* The one we're looking for is probably just before comppad_name_fill. */
 433     for (off = AvFILLp(PL_comppad_name); off > 0; off--) {
 434         if ((sv = svp[off]) &&
 435             sv != &PL_sv_undef &&
 436             (!SvIVX(sv) ||
 437              (seq <= SvIVX(sv) &&
 438               seq > I_32(SvNVX(sv)))) &&
 439             strEQ(SvPVX(sv), name))
 440         {
 441             if (SvIVX(sv) || SvFLAGS(sv) & SVpad_OUR)
 442                 return (PADOFFSET)off;
 443             pendoff = off;      /* this pending def. will override import */
 444         }
 445     }
 446
 447     outside = CvOUTSIDE(PL_compcv);
 448
 449     /* Check if if we're compiling an eval'', and adjust seq to be the
 450      * eval's seq number.  This depends on eval'' having a non-null
 451      * CvOUTSIDE() while it is being compiled.  The eval'' itself is
 452      * identified by CvEVAL being true and CvGV being null. */
 453     if (outside && CvEVAL(PL_compcv) && !CvGV(PL_compcv) && cxstack_ix >= 0) {
 454         cx = &cxstack[cxstack_ix];
 455         if (CxREALEVAL(cx))
 456             seq = cx->blk_oldcop->cop_seq;
 457     }
 458
 459     /* See if it's in a nested scope */
 460     off = pad_findlex(name, 0, seq, outside, cxstack_ix, 0, 0);
 461     if (off) {
 462         /* If there is a pending local definition, this new alias must die */
 463         if (pendoff)
 464             SvIVX(AvARRAY(PL_comppad_name)[off]) = seq;
 465         return off;             /* pad_findlex returns 0 for failure...*/
 466     }
 467     return NOT_IN_PAD;          /* ...but we return NOT_IN_PAD for failure */
 468 }
 469
 470 void
 471 Perl_pad_leavemy(pTHX_ I32 fill)
 472 {
 473     I32 off;
 474     SV **svp = AvARRAY(PL_comppad_name);
 475     SV *sv;
 476     if (PL_min_intro_pending && fill < PL_min_intro_pending) {
 477         for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
 478             if ((sv = svp[off]) && sv != &PL_sv_undef && ckWARN_d(WARN_INTERNAL))
 479                 Perl_warner(aTHX_ WARN_INTERNAL, "%s never introduced", SvPVX(sv));
 480         }
 481     }
 482     /* "Deintroduce" my variables that are leaving with this scope. */
 483     for (off = AvFILLp(PL_comppad_name); off > fill; off--) {
 484         if ((sv = svp[off]) && sv != &PL_sv_undef && SvIVX(sv) == PAD_MAX)
 485             SvIVX(sv) = PL_cop_seqmax;
 486     }
 487 }
 488
 489 PADOFFSET
 490 Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
 491 {
 492     SV *sv;
 493     I32 retval;
 494
 495     if (AvARRAY(PL_comppad) != PL_curpad)
 496         Perl_croak(aTHX_ "panic: pad_alloc");
 497     if (PL_pad_reset_pending)
 498         pad_reset();
 499     if (tmptype & SVs_PADMY) {
 500         do {
 501             sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE);
 502         } while (SvPADBUSY(sv));                /* need a fresh one */
 503         retval = AvFILLp(PL_comppad);
 504     }
 505     else {
 506         SV **names = AvARRAY(PL_comppad_name);
 507         SSize_t names_fill = AvFILLp(PL_comppad_name);
 508         for (;;) {
 509             /*
 510              * "foreach" index vars temporarily become aliases to non-"my"
 511              * values.  Thus we must skip, not just pad values that are
 512              * marked as current pad values, but also those with names.
 513              */
 514             if (++PL_padix <= names_fill &&
 515                    (sv = names[PL_padix]) && sv != &PL_sv_undef)
 516                 continue;
 517             sv = *av_fetch(PL_comppad, PL_padix, TRUE);
 518             if (!(SvFLAGS(sv) & (SVs_PADTMP|SVs_PADMY)) &&
 519                 !IS_PADGV(sv) && !IS_PADCONST(sv))
 520                 break;
 521         }
 522         retval = PL_padix;
 523     }
 524     SvFLAGS(sv) |= tmptype;
 525     PL_curpad = AvARRAY(PL_comppad);
 526 #ifdef USE_THREADS
 527     DEBUG_X(PerlIO_printf(Perl_debug_log,
 528                           "0x%"UVxf" Pad 0x%"UVxf" alloc %ld for %s\n",
 529                           PTR2UV(thr), PTR2UV(PL_curpad),
 530                           (long) retval, PL_op_name[optype]));
 531 #else
 532     DEBUG_X(PerlIO_printf(Perl_debug_log,
 533                           "Pad 0x%"UVxf" alloc %ld for %s\n",
 534                           PTR2UV(PL_curpad),
 535                           (long) retval, PL_op_name[optype]));
 536 #endif /* USE_THREADS */
 537     return (PADOFFSET)retval;
 538 }
 539
 540 SV *
 541 Perl_pad_sv(pTHX_ PADOFFSET po)
 542 {
 543 #ifdef USE_THREADS
 544     DEBUG_X(PerlIO_printf(Perl_debug_log,
 545                           "0x%"UVxf" Pad 0x%"UVxf" sv %"IVdf"\n",
 546                           PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
 547 #else
 548     if (!po)
 549         Perl_croak(aTHX_ "panic: pad_sv po");
 550     DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" sv %"IVdf"\n",
 551                           PTR2UV(PL_curpad), (IV)po));
 552 #endif /* USE_THREADS */
 553     return PL_curpad[po];               /* eventually we'll turn this into a macro */
 554 }
 555
 556 void
 557 Perl_pad_free(pTHX_ PADOFFSET po)
 558 {
 559     if (!PL_curpad)
 560         return;
 561     if (AvARRAY(PL_comppad) != PL_curpad)
 562         Perl_croak(aTHX_ "panic: pad_free curpad");
 563     if (!po)
 564         Perl_croak(aTHX_ "panic: pad_free po");
 565 #ifdef USE_THREADS
 566     DEBUG_X(PerlIO_printf(Perl_debug_log,
 567                           "0x%"UVxf" Pad 0x%"UVxf" free %"IVdf"\n",
 568                           PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
 569 #else
 570     DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" free %"IVdf"\n",
 571                           PTR2UV(PL_curpad), (IV)po));
 572 #endif /* USE_THREADS */
 573     if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef) {
 574         SvPADTMP_off(PL_curpad[po]);
 575 #ifdef USE_ITHREADS
 576         SvREADONLY_off(PL_curpad[po]);  /* could be a freed constant */
 577 #endif
 578     }
 579     if ((I32)po < PL_padix)
 580         PL_padix = po - 1;
 581 }
 582
 583 void
 584 Perl_pad_swipe(pTHX_ PADOFFSET po)
 585 {
 586     if (AvARRAY(PL_comppad) != PL_curpad)
 587         Perl_croak(aTHX_ "panic: pad_swipe curpad");
 588     if (!po)
 589         Perl_croak(aTHX_ "panic: pad_swipe po");
 590 #ifdef USE_THREADS
 591     DEBUG_X(PerlIO_printf(Perl_debug_log,
 592                           "0x%"UVxf" Pad 0x%"UVxf" swipe %"IVdf"\n",
 593                           PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
 594 #else
 595     DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" swipe %"IVdf"\n",
 596                           PTR2UV(PL_curpad), (IV)po));
 597 #endif /* USE_THREADS */
 598     SvPADTMP_off(PL_curpad[po]);
 599     PL_curpad[po] = NEWSV(1107,0);
 600     SvPADTMP_on(PL_curpad[po]);
 601     if ((I32)po < PL_padix)
 602         PL_padix = po - 1;
 603 }
 604
 605 /* XXX pad_reset() is currently disabled because it results in serious bugs.
 606  * It causes pad temp TARGs to be shared between OPs. Since TARGs are pushed
 607  * on the stack by OPs that use them, there are several ways to get an alias
 608  * to  a shared TARG.  Such an alias will change randomly and unpredictably.
 609  * We avoid doing this until we can think of a Better Way.
 610  * GSAR 97-10-29 */
 611 void
 612 Perl_pad_reset(pTHX)
 613 {
 614 #ifdef USE_BROKEN_PAD_RESET
 615     register I32 po;
 616
 617     if (AvARRAY(PL_comppad) != PL_curpad)
 618         Perl_croak(aTHX_ "panic: pad_reset curpad");
 619 #ifdef USE_THREADS
 620     DEBUG_X(PerlIO_printf(Perl_debug_log,
 621                           "0x%"UVxf" Pad 0x%"UVxf" reset\n",
 622                           PTR2UV(thr), PTR2UV(PL_curpad)));
 623 #else
 624     DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" reset\n",
 625                           PTR2UV(PL_curpad)));
 626 #endif /* USE_THREADS */
 627     if (!PL_tainting) { /* Can't mix tainted and non-tainted temporaries. */
 628         for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) {
 629             if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po]))
 630                 SvPADTMP_off(PL_curpad[po]);
 631         }
 632         PL_padix = PL_padix_floor;
 633     }
 634 #endif
 635     PL_pad_reset_pending = FALSE;
 636 }
 637
 638 #ifdef USE_THREADS
 639 /* find_threadsv is not reentrant */
 640 PADOFFSET
 641 Perl_find_threadsv(pTHX_ const char *name)
 642 {
 643     char *p;
 644     PADOFFSET key;
 645     SV **svp;
 646     /* We currently only handle names of a single character */
 647     p = strchr(PL_threadsv_names, *name);
 648     if (!p)
 649         return NOT_IN_PAD;
 650     key = p - PL_threadsv_names;
 651     MUTEX_LOCK(&thr->mutex);
 652     svp = av_fetch(thr->threadsv, key, FALSE);
 653     if (svp)
 654         MUTEX_UNLOCK(&thr->mutex);
 655     else {
 656         SV *sv = NEWSV(0, 0);
 657         av_store(thr->threadsv, key, sv);
 658         thr->threadsvp = AvARRAY(thr->threadsv);
 659         MUTEX_UNLOCK(&thr->mutex);
 660         /*
 661          * Some magic variables used to be automagically initialised
 662          * in gv_fetchpv. Those which are now per-thread magicals get
 663          * initialised here instead.
 664          */
 665         switch (*name) {
 666         case '_':
 667             break;
 668         case ';':
 669             sv_setpv(sv, "\034");
 670             sv_magic(sv, 0, 0, name, 1);
 671             break;
 672         case '&':
 673         case '`':
 674         case '\'':
 675             PL_sawampersand = TRUE;
 676             /* FALL THROUGH */
 677         case '1':
 678         case '2':
 679         case '3':
 680         case '4':
 681         case '5':
 682         case '6':
 683         case '7':
 684         case '8':
 685         case '9':
 686             SvREADONLY_on(sv);
 687             /* FALL THROUGH */
 688
 689         /* XXX %! tied to Errno.pm needs to be added here.
 690          * See gv_fetchpv(). */
 691         /* case '!': */
 692
 693         default:
 694             sv_magic(sv, 0, 0, name, 1);
 695         }
 696         DEBUG_S(PerlIO_printf(Perl_error_log,
 697                               "find_threadsv: new SV %p for $%s%c\n",
 698                               sv, (*name < 32) ? "^" : "",
 699                               (*name < 32) ? toCTRL(*name) : *name));
 700     }
 701     return key;
 702 }
 703 #endif /* USE_THREADS */
 704
 705 /* Destructor */
 706
 707 void
 708 Perl_op_free(pTHX_ OP *o)
 709 {
 710     register OP *kid, *nextkid;
 711     OPCODE type;
 712
 713     if (!o || o->op_seq == (U16)-1)
 714         return;
 715
 716     if (o->op_private & OPpREFCOUNTED) {
 717         switch (o->op_type) {
 718         case OP_LEAVESUB:
 719         case OP_LEAVESUBLV:
 720         case OP_LEAVEEVAL:
 721         case OP_LEAVE:
 722         case OP_SCOPE:
 723         case OP_LEAVEWRITE:
 724             OP_REFCNT_LOCK;
 725             if (OpREFCNT_dec(o)) {
 726                 OP_REFCNT_UNLOCK;
 727                 return;
 728             }
 729             OP_REFCNT_UNLOCK;
 730             break;
 731         default:
 732             break;
 733         }
 734     }
 735
 736     if (o->op_flags & OPf_KIDS) {
 737         for (kid = cUNOPo->op_first; kid; kid = nextkid) {
 738             nextkid = kid->op_sibling; /* Get before next freeing kid */
 739             op_free(kid);
 740         }
 741     }
 742     type = o->op_type;
 743     if (type == OP_NULL)
 744         type = o->op_targ;
 745
 746     /* COP* is not cleared by op_clear() so that we may track line
 747      * numbers etc even after null() */
 748     if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
 749         cop_free((COP*)o);
 750
 751     op_clear(o);
 752
 753 #ifdef PL_OP_SLAB_ALLOC
 754     if ((char *) o == PL_OpPtr)
 755      {
 756      }
 757 #else
 758     Safefree(o);
 759 #endif
 760 }
 761
 762 STATIC void
 763 S_op_clear(pTHX_ OP *o)
 764 {
 765     switch (o->op_type) {
 766     case OP_NULL:       /* Was holding old type, if any. */
 767     case OP_ENTEREVAL:  /* Was holding hints. */
 768 #ifdef USE_THREADS
 769     case OP_THREADSV:   /* Was holding index into thr->threadsv AV. */
 770 #endif
 771         o->op_targ = 0;
 772         break;
 773 #ifdef USE_THREADS
 774     case OP_ENTERITER:
 775         if (!(o->op_flags & OPf_SPECIAL))
 776             break;
 777         /* FALL THROUGH */
 778 #endif /* USE_THREADS */
 779     default:
 780         if (!(o->op_flags & OPf_REF)
 781             || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
 782             break;
 783         /* FALL THROUGH */
 784     case OP_GVSV:
 785     case OP_GV:
 786     case OP_AELEMFAST:
 787 #ifdef USE_ITHREADS
 788         if (cPADOPo->op_padix > 0) {
 789             if (PL_curpad) {
 790                 GV *gv = cGVOPo_gv;
 791                 pad_swipe(cPADOPo->op_padix);
 792                 /* No GvIN_PAD_off(gv) here, because other references may still
 793                  * exist on the pad */
 794                 SvREFCNT_dec(gv);
 795             }
 796             cPADOPo->op_padix = 0;
 797         }
 798 #else
 799         SvREFCNT_dec(cSVOPo->op_sv);
 800         cSVOPo->op_sv = Nullsv;
 801 #endif
 802         break;
 803     case OP_METHOD_NAMED:
 804     case OP_CONST:
 805         SvREFCNT_dec(cSVOPo->op_sv);
 806         cSVOPo->op_sv = Nullsv;
 807         break;
 808     case OP_GOTO:
 809     case OP_NEXT:
 810     case OP_LAST:
 811     case OP_REDO:
 812         if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
 813             break;
 814         /* FALL THROUGH */
 815     case OP_TRANS:
 816         if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
 817             SvREFCNT_dec(cSVOPo->op_sv);
 818             cSVOPo->op_sv = Nullsv;
 819         }
 820         else {
 821             Safefree(cPVOPo->op_pv);
 822             cPVOPo->op_pv = Nullch;
 823         }
 824         break;
 825     case OP_SUBST:
 826         op_free(cPMOPo->op_pmreplroot);
 827         goto clear_pmop;
 828     case OP_PUSHRE:
 829 #ifdef USE_ITHREADS
 830         if ((PADOFFSET)cPMOPo->op_pmreplroot) {
 831             if (PL_curpad) {
 832                 GV *gv = (GV*)PL_curpad[(PADOFFSET)cPMOPo->op_pmreplroot];
 833                 pad_swipe((PADOFFSET)cPMOPo->op_pmreplroot);
 834                 /* No GvIN_PAD_off(gv) here, because other references may still
 835                  * exist on the pad */
 836                 SvREFCNT_dec(gv);
 837             }
 838         }
 839 #else
 840         SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
 841 #endif
 842         /* FALL THROUGH */
 843     case OP_MATCH:
 844     case OP_QR:
 845 clear_pmop:
 846         {
 847             HV *pmstash = PmopSTASH(cPMOPo);
 848             if (pmstash) {
 849                 PMOP *pmop = HvPMROOT(pmstash);
 850                 PMOP *lastpmop = NULL;
 851                 while (pmop) {
 852                     if (cPMOPo == pmop) {
 853                         if (lastpmop)
 854                             lastpmop->op_pmnext = pmop->op_pmnext;
 855                         else
 856                             HvPMROOT(pmstash) = pmop->op_pmnext;
 857                         break;
 858                     }
 859                     lastpmop = pmop;
 860                     pmop = pmop->op_pmnext;
 861                 }
 862 #ifdef USE_ITHREADS
 863                 Safefree(PmopSTASHPV(cPMOPo));
 864 #else
 865                 /* NOTE: PMOP.op_pmstash is not refcounted */
 866 #endif
 867             }
 868         }
 869         cPMOPo->op_pmreplroot = Nullop;
 870         ReREFCNT_dec(cPMOPo->op_pmregexp);
 871         cPMOPo->op_pmregexp = (REGEXP*)NULL;
 872         break;
 873     }
 874
 875     if (o->op_targ > 0) {
 876         pad_free(o->op_targ);
 877         o->op_targ = 0;
 878     }
 879 }
 880
 881 STATIC void
 882 S_cop_free(pTHX_ COP* cop)
 883 {
 884     Safefree(cop->cop_label);
 885 #ifdef USE_ITHREADS
 886     Safefree(CopFILE(cop));             /* XXX share in a pvtable? */
 887     Safefree(CopSTASHPV(cop));          /* XXX share in a pvtable? */
 888 #else
 889     /* NOTE: COP.cop_stash is not refcounted */
 890     SvREFCNT_dec(CopFILEGV(cop));
 891 #endif
 892     if (! specialWARN(cop->cop_warnings))
 893         SvREFCNT_dec(cop->cop_warnings);
 894     if (! specialCopIO(cop->cop_io))
 895         SvREFCNT_dec(cop->cop_io);
 896 }
 897
 898 STATIC void
 899 S_null(pTHX_ OP *o)
 900 {
 901     if (o->op_type == OP_NULL)
 902         return;
 903     op_clear(o);
 904     o->op_targ = o->op_type;
 905     o->op_type = OP_NULL;
 906     o->op_ppaddr = PL_ppaddr[OP_NULL];
 907 }
 908
 909 /* Contextualizers */
 910
 911 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
 912
 913 OP *
 914 Perl_linklist(pTHX_ OP *o)
 915 {
 916     register OP *kid;
 917
 918     if (o->op_next)
 919         return o->op_next;
 920
 921     /* establish postfix order */
 922     if (cUNOPo->op_first) {
 923         o->op_next = LINKLIST(cUNOPo->op_first);
 924         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
 925             if (kid->op_sibling)
 926                 kid->op_next = LINKLIST(kid->op_sibling);
 927             else
 928                 kid->op_next = o;
 929         }
 930     }
 931     else
 932         o->op_next = o;
 933
 934     return o->op_next;
 935 }
 936
 937 OP *
 938 Perl_scalarkids(pTHX_ OP *o)
 939 {
 940     OP *kid;
 941     if (o && o->op_flags & OPf_KIDS) {
 942         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
 943             scalar(kid);
 944     }
 945     return o;
 946 }
 947
 948 STATIC OP *
 949 S_scalarboolean(pTHX_ OP *o)
 950 {
 951     if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
 952         if (ckWARN(WARN_SYNTAX)) {
 953             line_t oldline = CopLINE(PL_curcop);
 954
 955             if (PL_copline != NOLINE)
 956                 CopLINE_set(PL_curcop, PL_copline);
 957             Perl_warner(aTHX_ WARN_SYNTAX, "Found = in conditional, should be ==");
 958             CopLINE_set(PL_curcop, oldline);
 959         }
 960     }
 961     return scalar(o);
 962 }
 963
 964 OP *
 965 Perl_scalar(pTHX_ OP *o)
 966 {
 967     OP *kid;
 968
 969     /* assumes no premature commitment */
 970     if (!o || (o->op_flags & OPf_WANT) || PL_error_count
 971          || o->op_type == OP_RETURN)
 972     {
 973         return o;
 974     }
 975
 976     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
 977
 978     switch (o->op_type) {
 979     case OP_REPEAT:
 980         if (o->op_private & OPpREPEAT_DOLIST)
 981             null(((LISTOP*)cBINOPo->op_first)->op_first);
 982         scalar(cBINOPo->op_first);
 983         break;
 984     case OP_OR:
 985     case OP_AND:
 986     case OP_COND_EXPR:
 987         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
 988             scalar(kid);
 989         break;
 990     case OP_SPLIT:
 991         if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
 992             if (!kPMOP->op_pmreplroot)
 993                 deprecate("implicit split to @_");
 994         }
 995         /* FALL THROUGH */
 996     case OP_MATCH:
 997     case OP_QR:
 998     case OP_SUBST:
 999     case OP_NULL:
1000     default:
1001         if (o->op_flags & OPf_KIDS) {
1002             for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
1003                 scalar(kid);
1004         }
1005         break;
1006     case OP_LEAVE:
1007     case OP_LEAVETRY:
1008         kid = cLISTOPo->op_first;
1009         scalar(kid);
1010         while ((kid = kid->op_sibling)) {
1011             if (kid->op_sibling)
1012                 scalarvoid(kid);
1013             else
1014                 scalar(kid);
1015         }
1016         WITH_THR(PL_curcop = &PL_compiling);
1017         break;
1018     case OP_SCOPE:
1019     case OP_LINESEQ:
1020     case OP_LIST:
1021         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1022             if (kid->op_sibling)
1023                 scalarvoid(kid);
1024             else
1025                 scalar(kid);
1026         }
1027         WITH_THR(PL_curcop = &PL_compiling);
1028         break;
1029     }
1030     return o;
1031 }
1032
1033 OP *
1034 Perl_scalarvoid(pTHX_ OP *o)
1035 {
1036     OP *kid;
1037     char* useless = 0;
1038     SV* sv;
1039     U8 want;
1040
1041     if (o->op_type == OP_NEXTSTATE
1042         || o->op_type == OP_SETSTATE
1043         || o->op_type == OP_DBSTATE
1044         || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1045                                       || o->op_targ == OP_SETSTATE
1046                                       || o->op_targ == OP_DBSTATE)))
1047         PL_curcop = (COP*)o;            /* for warning below */
1048
1049     /* assumes no premature commitment */
1050     want = o->op_flags & OPf_WANT;
1051     if ((want && want != OPf_WANT_SCALAR) || PL_error_count
1052          || o->op_type == OP_RETURN)
1053     {
1054         return o;
1055     }
1056
1057     if ((o->op_private & OPpTARGET_MY)
1058         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1059     {
1060         return scalar(o);                       /* As if inside SASSIGN */
1061     }
1062
1063     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1064
1065     switch (o->op_type) {
1066     default:
1067         if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1068             break;
1069         /* FALL THROUGH */
1070     case OP_REPEAT:
1071         if (o->op_flags & OPf_STACKED)
1072             break;
1073         goto func_ops;
1074     case OP_SUBSTR:
1075         if (o->op_private == 4)
1076             break;
1077         /* FALL THROUGH */
1078     case OP_GVSV:
1079     case OP_WANTARRAY:
1080     case OP_GV:
1081     case OP_PADSV:
1082     case OP_PADAV:
1083     case OP_PADHV:
1084     case OP_PADANY:
1085     case OP_AV2ARYLEN:
1086     case OP_REF:
1087     case OP_REFGEN:
1088     case OP_SREFGEN:
1089     case OP_DEFINED:
1090     case OP_HEX:
1091     case OP_OCT:
1092     case OP_LENGTH:
1093     case OP_VEC:
1094     case OP_INDEX:
1095     case OP_RINDEX:
1096     case OP_SPRINTF:
1097     case OP_AELEM:
1098     case OP_AELEMFAST:
1099     case OP_ASLICE:
1100     case OP_HELEM:
1101     case OP_HSLICE:
1102     case OP_UNPACK:
1103     case OP_PACK:
1104     case OP_JOIN:
1105     case OP_LSLICE:
1106     case OP_ANONLIST:
1107     case OP_ANONHASH:
1108     case OP_SORT:
1109     case OP_REVERSE:
1110     case OP_RANGE:
1111     case OP_FLIP:
1112     case OP_FLOP:
1113     case OP_CALLER:
1114     case OP_FILENO:
1115     case OP_EOF:
1116     case OP_TELL:
1117     case OP_GETSOCKNAME:
1118     case OP_GETPEERNAME:
1119     case OP_READLINK:
1120     case OP_TELLDIR:
1121     case OP_GETPPID:
1122     case OP_GETPGRP:
1123     case OP_GETPRIORITY:
1124     case OP_TIME:
1125     case OP_TMS:
1126     case OP_LOCALTIME:
1127     case OP_GMTIME:
1128     case OP_GHBYNAME:
1129     case OP_GHBYADDR:
1130     case OP_GHOSTENT:
1131     case OP_GNBYNAME:
1132     case OP_GNBYADDR:
1133     case OP_GNETENT:
1134     case OP_GPBYNAME:
1135     case OP_GPBYNUMBER:
1136     case OP_GPROTOENT:
1137     case OP_GSBYNAME:
1138     case OP_GSBYPORT:
1139     case OP_GSERVENT:
1140     case OP_GPWNAM:
1141     case OP_GPWUID:
1142     case OP_GGRNAM:
1143     case OP_GGRGID:
1144     case OP_GETLOGIN:
1145       func_ops:
1146         if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1147             useless = PL_op_desc[o->op_type];
1148         break;
1149
1150     case OP_RV2GV:
1151     case OP_RV2SV:
1152     case OP_RV2AV:
1153     case OP_RV2HV:
1154         if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1155                 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1156             useless = "a variable";
1157         break;
1158
1159     case OP_CONST:
1160         sv = cSVOPo_sv;
1161         if (cSVOPo->op_private & OPpCONST_STRICT)
1162             no_bareword_allowed(o);
1163         else {
1164             if (ckWARN(WARN_VOID)) {
1165                 useless = "a constant";
1166                 if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1167                     useless = 0;
1168                 else if (SvPOK(sv)) {
1169                   /* perl4's way of mixing documentation and code
1170                      (before the invention of POD) was based on a
1171                      trick to mix nroff and perl code. The trick was
1172                      built upon these three nroff macros being used in
1173                      void context. The pink camel has the details in
1174                      the script wrapman near page 319. */
1175                     if (strnEQ(SvPVX(sv), "di", 2) ||
1176                         strnEQ(SvPVX(sv), "ds", 2) ||
1177                         strnEQ(SvPVX(sv), "ig", 2))
1178                             useless = 0;
1179                 }
1180             }
1181         }
1182         null(o);                /* don't execute or even remember it */
1183         break;
1184
1185     case OP_POSTINC:
1186         o->op_type = OP_PREINC;         /* pre-increment is faster */
1187         o->op_ppaddr = PL_ppaddr[OP_PREINC];
1188         break;
1189
1190     case OP_POSTDEC:
1191         o->op_type = OP_PREDEC;         /* pre-decrement is faster */
1192         o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1193         break;
1194
1195     case OP_OR:
1196     case OP_AND:
1197     case OP_COND_EXPR:
1198         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1199             scalarvoid(kid);
1200         break;
1201
1202     case OP_NULL:
1203         if (o->op_flags & OPf_STACKED)
1204             break;
1205         /* FALL THROUGH */
1206     case OP_NEXTSTATE:
1207     case OP_DBSTATE:
1208     case OP_ENTERTRY:
1209     case OP_ENTER:
1210         if (!(o->op_flags & OPf_KIDS))
1211             break;
1212         /* FALL THROUGH */
1213     case OP_SCOPE:
1214     case OP_LEAVE:
1215     case OP_LEAVETRY:
1216     case OP_LEAVELOOP:
1217     case OP_LINESEQ:
1218     case OP_LIST:
1219         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1220             scalarvoid(kid);
1221         break;
1222     case OP_ENTEREVAL:
1223         scalarkids(o);
1224         break;
1225     case OP_REQUIRE:
1226         /* all requires must return a boolean value */
1227         o->op_flags &= ~OPf_WANT;
1228         /* FALL THROUGH */
1229     case OP_SCALAR:
1230         return scalar(o);
1231     case OP_SPLIT:
1232         if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
1233             if (!kPMOP->op_pmreplroot)
1234                 deprecate("implicit split to @_");
1235         }
1236         break;
1237     }
1238     if (useless && ckWARN(WARN_VOID))
1239         Perl_warner(aTHX_ WARN_VOID, "Useless use of %s in void context", useless);
1240     return o;
1241 }
1242
1243 OP *
1244 Perl_listkids(pTHX_ OP *o)
1245 {
1246     OP *kid;
1247     if (o && o->op_flags & OPf_KIDS) {
1248         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1249             list(kid);
1250     }
1251     return o;
1252 }
1253
1254 OP *
1255 Perl_list(pTHX_ OP *o)
1256 {
1257     OP *kid;
1258
1259     /* assumes no premature commitment */
1260     if (!o || (o->op_flags & OPf_WANT) || PL_error_count
1261          || o->op_type == OP_RETURN)
1262     {
1263         return o;
1264     }
1265
1266     if ((o->op_private & OPpTARGET_MY)
1267         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1268     {
1269         return o;                               /* As if inside SASSIGN */
1270     }
1271
1272     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1273
1274     switch (o->op_type) {
1275     case OP_FLOP:
1276     case OP_REPEAT:
1277         list(cBINOPo->op_first);
1278         break;
1279     case OP_OR:
1280     case OP_AND:
1281     case OP_COND_EXPR:
1282         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1283             list(kid);
1284         break;
1285     default:
1286     case OP_MATCH:
1287     case OP_QR:
1288     case OP_SUBST:
1289     case OP_NULL:
1290         if (!(o->op_flags & OPf_KIDS))
1291             break;
1292         if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1293             list(cBINOPo->op_first);
1294             return gen_constant_list(o);
1295         }
1296     case OP_LIST:
1297         listkids(o);
1298         break;
1299     case OP_LEAVE:
1300     case OP_LEAVETRY:
1301         kid = cLISTOPo->op_first;
1302         list(kid);
1303         while ((kid = kid->op_sibling)) {
1304             if (kid->op_sibling)
1305                 scalarvoid(kid);
1306             else
1307                 list(kid);
1308         }
1309         WITH_THR(PL_curcop = &PL_compiling);
1310         break;
1311     case OP_SCOPE:
1312     case OP_LINESEQ:
1313         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1314             if (kid->op_sibling)
1315                 scalarvoid(kid);
1316             else
1317                 list(kid);
1318         }
1319         WITH_THR(PL_curcop = &PL_compiling);
1320         break;
1321     case OP_REQUIRE:
1322         /* all requires must return a boolean value */
1323         o->op_flags &= ~OPf_WANT;
1324         return scalar(o);
1325     }
1326     return o;
1327 }
1328
1329 OP *
1330 Perl_scalarseq(pTHX_ OP *o)
1331 {
1332     OP *kid;
1333
1334     if (o) {
1335         if (o->op_type == OP_LINESEQ ||
1336              o->op_type == OP_SCOPE ||
1337              o->op_type == OP_LEAVE ||
1338              o->op_type == OP_LEAVETRY)
1339         {
1340             for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1341                 if (kid->op_sibling) {
1342                     scalarvoid(kid);
1343                 }
1344             }
1345             PL_curcop = &PL_compiling;
1346         }
1347         o->op_flags &= ~OPf_PARENS;
1348         if (PL_hints & HINT_BLOCK_SCOPE)
1349             o->op_flags |= OPf_PARENS;
1350     }
1351     else
1352         o = newOP(OP_STUB, 0);
1353     return o;
1354 }
1355
1356 STATIC OP *
1357 S_modkids(pTHX_ OP *o, I32 type)
1358 {
1359     OP *kid;
1360     if (o && o->op_flags & OPf_KIDS) {
1361         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1362             mod(kid, type);
1363     }
1364     return o;
1365 }
1366
1367 OP *
1368 Perl_mod(pTHX_ OP *o, I32 type)
1369 {
1370     OP *kid;
1371     STRLEN n_a;
1372
1373     if (!o || PL_error_count)
1374         return o;
1375
1376     if ((o->op_private & OPpTARGET_MY)
1377         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1378     {
1379         return o;
1380     }
1381
1382     switch (o->op_type) {
1383     case OP_UNDEF:
1384         PL_modcount++;
1385         return o;
1386     case OP_CONST:
1387         if (o->op_private & (OPpCONST_BARE) &&
1388                 !(type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)) {
1389             SV *sv = ((SVOP*)o)->op_sv;
1390             GV *gv;
1391
1392             /* Could be a filehandle */
1393             if ((gv = gv_fetchpv(SvPV_nolen(sv), FALSE, SVt_PVIO))) {
1394                 OP* gvio = newUNOP(OP_RV2GV, 0, newGVOP(OP_GV, 0, gv));
1395                 op_free(o);
1396                 o = gvio;
1397             } else {
1398                 /* OK, it's a sub */
1399                 OP* enter;
1400                 gv = gv_fetchpv(SvPV_nolen(sv), TRUE, SVt_PVCV);
1401
1402                 enter = newUNOP(OP_ENTERSUB,0,
1403                         newUNOP(OP_RV2CV, 0,
1404                             newGVOP(OP_GV, 0, gv)
1405                         ));
1406                 enter->op_private |= OPpLVAL_INTRO;
1407                 op_free(o);
1408                 o = enter;
1409             }
1410             break;
1411         }
1412         if (!(o->op_private & (OPpCONST_ARYBASE)))
1413             goto nomod;
1414         if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1415             PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
1416             PL_eval_start = 0;
1417         }
1418         else if (!type) {
1419             SAVEI32(PL_compiling.cop_arybase);
1420             PL_compiling.cop_arybase = 0;
1421         }
1422         else if (type == OP_REFGEN)
1423             goto nomod;
1424         else
1425             Perl_croak(aTHX_ "That use of $[ is unsupported");
1426         break;
1427     case OP_STUB:
1428         if (o->op_flags & OPf_PARENS)
1429             break;
1430         goto nomod;
1431     case OP_ENTERSUB:
1432         if ((type == OP_UNDEF || type == OP_REFGEN) &&
1433             !(o->op_flags & OPf_STACKED)) {
1434             o->op_type = OP_RV2CV;              /* entersub => rv2cv */
1435             o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1436             assert(cUNOPo->op_first->op_type == OP_NULL);
1437             null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1438             break;
1439         }
1440         else {                          /* lvalue subroutine call */
1441             o->op_private |= OPpLVAL_INTRO;
1442             PL_modcount = RETURN_UNLIMITED_NUMBER;
1443             if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1444                 /* Backward compatibility mode: */
1445                 o->op_private |= OPpENTERSUB_INARGS;
1446                 break;
1447             }
1448             else {                      /* Compile-time error message: */
1449                 OP *kid = cUNOPo->op_first;
1450                 CV *cv;
1451                 OP *okid;
1452
1453                 if (kid->op_type == OP_PUSHMARK)
1454                     goto skip_kids;
1455                 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1456                     Perl_croak(aTHX_
1457                                "panic: unexpected lvalue entersub "
1458                                "args: type/targ %ld:%ld",
1459                                (long)kid->op_type,kid->op_targ);
1460                 kid = kLISTOP->op_first;
1461               skip_kids:
1462                 while (kid->op_sibling)
1463                     kid = kid->op_sibling;
1464                 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1465                     /* Indirect call */
1466                     if (kid->op_type == OP_METHOD_NAMED
1467                         || kid->op_type == OP_METHOD)
1468                     {
1469                         UNOP *newop;
1470
1471                         if (kid->op_sibling || kid->op_next != kid) {
1472                             yyerror("panic: unexpected optree near method call");
1473                             break;
1474                         }
1475
1476                         NewOp(1101, newop, 1, UNOP);
1477                         newop->op_type = OP_RV2CV;
1478                         newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1479                         newop->op_first = Nullop;
1480                         newop->op_next = (OP*)newop;
1481                         kid->op_sibling = (OP*)newop;
1482                         newop->op_private |= OPpLVAL_INTRO;
1483                         break;
1484                     }
1485
1486                     if (kid->op_type != OP_RV2CV)
1487                         Perl_croak(aTHX_
1488                                    "panic: unexpected lvalue entersub "
1489                                    "entry via type/targ %ld:%ld",
1490                                    (long)kid->op_type,kid->op_targ);
1491                     kid->op_private |= OPpLVAL_INTRO;
1492                     break;      /* Postpone until runtime */
1493                 }
1494
1495                 okid = kid;
1496                 kid = kUNOP->op_first;
1497                 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1498                     kid = kUNOP->op_first;
1499                 if (kid->op_type == OP_NULL)
1500                     Perl_croak(aTHX_
1501                                "Unexpected constant lvalue entersub "
1502                                "entry via type/targ %ld:%ld",
1503                                (long)kid->op_type,kid->op_targ);
1504                 if (kid->op_type != OP_GV) {
1505                     /* Restore RV2CV to check lvalueness */
1506                   restore_2cv:
1507                     if (kid->op_next && kid->op_next != kid) { /* Happens? */
1508                         okid->op_next = kid->op_next;
1509                         kid->op_next = okid;
1510                     }
1511                     else
1512                         okid->op_next = Nullop;
1513                     okid->op_type = OP_RV2CV;
1514                     okid->op_targ = 0;
1515                     okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1516                     okid->op_private |= OPpLVAL_INTRO;
1517                     break;
1518                 }
1519
1520                 cv = GvCV(kGVOP_gv);
1521                 if (!cv)
1522                     goto restore_2cv;
1523                 if (CvLVALUE(cv))
1524                     break;
1525             }
1526         }
1527         /* FALL THROUGH */
1528     default:
1529       nomod:
1530         /* grep, foreach, subcalls, refgen */
1531         if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1532             break;
1533         yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1534                      (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1535                       ? "do block"
1536                       : (o->op_type == OP_ENTERSUB
1537                         ? "non-lvalue subroutine call"
1538                         : PL_op_desc[o->op_type])),
1539                      type ? PL_op_desc[type] : "local"));
1540         return o;
1541
1542     case OP_PREINC:
1543     case OP_PREDEC:
1544     case OP_POW:
1545     case OP_MULTIPLY:
1546     case OP_DIVIDE:
1547     case OP_MODULO:
1548     case OP_REPEAT:
1549     case OP_ADD:
1550     case OP_SUBTRACT:
1551     case OP_CONCAT:
1552     case OP_LEFT_SHIFT:
1553     case OP_RIGHT_SHIFT:
1554     case OP_BIT_AND:
1555     case OP_BIT_XOR:
1556     case OP_BIT_OR:
1557     case OP_I_MULTIPLY:
1558     case OP_I_DIVIDE:
1559     case OP_I_MODULO:
1560     case OP_I_ADD:
1561     case OP_I_SUBTRACT:
1562         if (!(o->op_flags & OPf_STACKED))
1563             goto nomod;
1564         PL_modcount++;
1565         break;
1566
1567     case OP_COND_EXPR:
1568         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1569             mod(kid, type);
1570         break;
1571
1572     case OP_RV2AV:
1573     case OP_RV2HV:
1574         if (!type && cUNOPo->op_first->op_type != OP_GV)
1575             Perl_croak(aTHX_ "Can't localize through a reference");
1576         if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1577            PL_modcount = RETURN_UNLIMITED_NUMBER;
1578             return o;           /* Treat \(@foo) like ordinary list. */
1579         }
1580         /* FALL THROUGH */
1581     case OP_RV2GV:
1582         if (scalar_mod_type(o, type))
1583             goto nomod;
1584         ref(cUNOPo->op_first, o->op_type);
1585         /* FALL THROUGH */
1586     case OP_ASLICE:
1587     case OP_HSLICE:
1588         if (type == OP_LEAVESUBLV)
1589             o->op_private |= OPpMAYBE_LVSUB;
1590         /* FALL THROUGH */
1591     case OP_AASSIGN:
1592     case OP_NEXTSTATE:
1593     case OP_DBSTATE:
1594     case OP_CHOMP:
1595        PL_modcount = RETURN_UNLIMITED_NUMBER;
1596         break;
1597     case OP_RV2SV:
1598         if (!type && cUNOPo->op_first->op_type != OP_GV)
1599             Perl_croak(aTHX_ "Can't localize through a reference");
1600         ref(cUNOPo->op_first, o->op_type);
1601         /* FALL THROUGH */
1602     case OP_GV:
1603     case OP_AV2ARYLEN:
1604         PL_hints |= HINT_BLOCK_SCOPE;
1605     case OP_SASSIGN:
1606     case OP_ANDASSIGN:
1607     case OP_ORASSIGN:
1608     case OP_AELEMFAST:
1609         PL_modcount++;
1610         break;
1611
1612     case OP_PADAV:
1613     case OP_PADHV:
1614        PL_modcount = RETURN_UNLIMITED_NUMBER;
1615         if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1616             return o;           /* Treat \(@foo) like ordinary list. */
1617         if (scalar_mod_type(o, type))
1618             goto nomod;
1619         if (type == OP_LEAVESUBLV)
1620             o->op_private |= OPpMAYBE_LVSUB;
1621         /* FALL THROUGH */
1622     case OP_PADSV:
1623         PL_modcount++;
1624         if (!type)
1625             Perl_croak(aTHX_ "Can't localize lexical variable %s",
1626                 SvPV(*av_fetch(PL_comppad_name, o->op_targ, 4), n_a));
1627         break;
1628
1629 #ifdef USE_THREADS
1630     case OP_THREADSV:
1631         PL_modcount++;  /* XXX ??? */
1632         break;
1633 #endif /* USE_THREADS */
1634
1635     case OP_PUSHMARK:
1636         break;
1637
1638     case OP_KEYS:
1639         if (type != OP_SASSIGN)
1640             goto nomod;
1641         goto lvalue_func;
1642     case OP_SUBSTR:
1643         if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1644             goto nomod;
1645         /* FALL THROUGH */
1646     case OP_POS:
1647     case OP_VEC:
1648         if (type == OP_LEAVESUBLV)
1649             o->op_private |= OPpMAYBE_LVSUB;
1650       lvalue_func:
1651         pad_free(o->op_targ);
1652         o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1653         assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1654         if (o->op_flags & OPf_KIDS)
1655             mod(cBINOPo->op_first->op_sibling, type);
1656         break;
1657
1658     case OP_AELEM:
1659     case OP_HELEM:
1660         ref(cBINOPo->op_first, o->op_type);
1661         if (type == OP_ENTERSUB &&
1662              !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1663             o->op_private |= OPpLVAL_DEFER;
1664         if (type == OP_LEAVESUBLV)
1665             o->op_private |= OPpMAYBE_LVSUB;
1666         PL_modcount++;
1667         break;
1668
1669     case OP_SCOPE:
1670     case OP_LEAVE:
1671     case OP_ENTER:
1672     case OP_LINESEQ:
1673         if (o->op_flags & OPf_KIDS)
1674             mod(cLISTOPo->op_last, type);
1675         break;
1676
1677     case OP_NULL:
1678         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
1679             goto nomod;
1680         else if (!(o->op_flags & OPf_KIDS))
1681             break;
1682         if (o->op_targ != OP_LIST) {
1683             mod(cBINOPo->op_first, type);
1684             break;
1685         }
1686         /* FALL THROUGH */
1687     case OP_LIST:
1688         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1689             mod(kid, type);
1690         break;
1691
1692     case OP_RETURN:
1693         if (type != OP_LEAVESUBLV)
1694             goto nomod;
1695         break; /* mod()ing was handled by ck_return() */
1696     }
1697     if (type != OP_LEAVESUBLV)
1698         o->op_flags |= OPf_MOD;
1699
1700     if (type == OP_AASSIGN || type == OP_SASSIGN)
1701         o->op_flags |= OPf_SPECIAL|OPf_REF;
1702     else if (!type) {
1703         o->op_private |= OPpLVAL_INTRO;
1704         o->op_flags &= ~OPf_SPECIAL;
1705         PL_hints |= HINT_BLOCK_SCOPE;
1706     }
1707     else if (type != OP_GREPSTART && type != OP_ENTERSUB
1708              && type != OP_LEAVESUBLV)
1709         o->op_flags |= OPf_REF;
1710     return o;
1711 }
1712
1713 STATIC bool
1714 S_scalar_mod_type(pTHX_ OP *o, I32 type)
1715 {
1716     switch (type) {
1717     case OP_SASSIGN:
1718         if (o->op_type == OP_RV2GV)
1719             return FALSE;
1720         /* FALL THROUGH */
1721     case OP_PREINC:
1722     case OP_PREDEC:
1723     case OP_POSTINC:
1724     case OP_POSTDEC:
1725     case OP_I_PREINC:
1726     case OP_I_PREDEC:
1727     case OP_I_POSTINC:
1728     case OP_I_POSTDEC:
1729     case OP_POW:
1730     case OP_MULTIPLY:
1731     case OP_DIVIDE:
1732     case OP_MODULO:
1733     case OP_REPEAT:
1734     case OP_ADD:
1735     case OP_SUBTRACT:
1736     case OP_I_MULTIPLY:
1737     case OP_I_DIVIDE:
1738     case OP_I_MODULO:
1739     case OP_I_ADD:
1740     case OP_I_SUBTRACT:
1741     case OP_LEFT_SHIFT:
1742     case OP_RIGHT_SHIFT:
1743     case OP_BIT_AND:
1744     case OP_BIT_XOR:
1745     case OP_BIT_OR:
1746     case OP_CONCAT:
1747     case OP_SUBST:
1748     case OP_TRANS:
1749     case OP_READ:
1750     case OP_SYSREAD:
1751     case OP_RECV:
1752     case OP_ANDASSIGN:
1753     case OP_ORASSIGN:
1754         return TRUE;
1755     default:
1756         return FALSE;
1757     }
1758 }
1759
1760 STATIC bool
1761 S_is_handle_constructor(pTHX_ OP *o, I32 argnum)
1762 {
1763     switch (o->op_type) {
1764     case OP_PIPE_OP:
1765     case OP_SOCKPAIR:
1766         if (argnum == 2)
1767             return TRUE;
1768         /* FALL THROUGH */
1769     case OP_SYSOPEN:
1770     case OP_OPEN:
1771     case OP_SELECT:             /* XXX c.f. SelectSaver.pm */
1772     case OP_SOCKET:
1773     case OP_OPEN_DIR:
1774     case OP_ACCEPT:
1775         if (argnum == 1)
1776             return TRUE;
1777         /* FALL THROUGH */
1778     default:
1779         return FALSE;
1780     }
1781 }
1782
1783 OP *
1784 Perl_refkids(pTHX_ OP *o, I32 type)
1785 {
1786     OP *kid;
1787     if (o && o->op_flags & OPf_KIDS) {
1788         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1789             ref(kid, type);
1790     }
1791     return o;
1792 }
1793
1794 OP *
1795 Perl_ref(pTHX_ OP *o, I32 type)
1796 {
1797     OP *kid;
1798
1799     if (!o || PL_error_count)
1800         return o;
1801
1802     switch (o->op_type) {
1803     case OP_ENTERSUB:
1804         if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1805             !(o->op_flags & OPf_STACKED)) {
1806             o->op_type = OP_RV2CV;             /* entersub => rv2cv */
1807             o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1808             assert(cUNOPo->op_first->op_type == OP_NULL);
1809             null(((LISTOP*)cUNOPo->op_first)->op_first);        /* disable pushmark */
1810             o->op_flags |= OPf_SPECIAL;
1811         }
1812         break;
1813
1814     case OP_COND_EXPR:
1815         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1816             ref(kid, type);
1817         break;
1818     case OP_RV2SV:
1819         if (type == OP_DEFINED)
1820             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
1821         ref(cUNOPo->op_first, o->op_type);
1822         /* FALL THROUGH */
1823     case OP_PADSV:
1824         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1825             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1826                               : type == OP_RV2HV ? OPpDEREF_HV
1827                               : OPpDEREF_SV);
1828             o->op_flags |= OPf_MOD;
1829         }
1830         break;
1831
1832     case OP_THREADSV:
1833         o->op_flags |= OPf_MOD;         /* XXX ??? */
1834         break;
1835
1836     case OP_RV2AV:
1837     case OP_RV2HV:
1838         o->op_flags |= OPf_REF;
1839         /* FALL THROUGH */
1840     case OP_RV2GV:
1841         if (type == OP_DEFINED)
1842             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
1843         ref(cUNOPo->op_first, o->op_type);
1844         break;
1845
1846     case OP_PADAV:
1847     case OP_PADHV:
1848         o->op_flags |= OPf_REF;
1849         break;
1850
1851     case OP_SCALAR:
1852     case OP_NULL:
1853         if (!(o->op_flags & OPf_KIDS))
1854             break;
1855         ref(cBINOPo->op_first, type);
1856         break;
1857     case OP_AELEM:
1858     case OP_HELEM:
1859         ref(cBINOPo->op_first, o->op_type);
1860         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1861             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1862                               : type == OP_RV2HV ? OPpDEREF_HV
1863                               : OPpDEREF_SV);
1864             o->op_flags |= OPf_MOD;
1865         }
1866         break;
1867
1868     case OP_SCOPE:
1869     case OP_LEAVE:
1870     case OP_ENTER:
1871     case OP_LIST:
1872         if (!(o->op_flags & OPf_KIDS))
1873             break;
1874         ref(cLISTOPo->op_last, type);
1875         break;
1876     default:
1877         break;
1878     }
1879     return scalar(o);
1880
1881 }
1882
1883 STATIC OP *
1884 S_dup_attrlist(pTHX_ OP *o)
1885 {
1886     OP *rop = Nullop;
1887
1888     /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1889      * where the first kid is OP_PUSHMARK and the remaining ones
1890      * are OP_CONST.  We need to push the OP_CONST values.
1891      */
1892     if (o->op_type == OP_CONST)
1893         rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1894     else {
1895         assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1896         for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1897             if (o->op_type == OP_CONST)
1898                 rop = append_elem(OP_LIST, rop,
1899                                   newSVOP(OP_CONST, o->op_flags,
1900                                           SvREFCNT_inc(cSVOPo->op_sv)));
1901         }
1902     }
1903     return rop;
1904 }
1905
1906 STATIC void
1907 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
1908 {
1909     SV *stashsv;
1910
1911     /* fake up C<use attributes $pkg,$rv,@attrs> */
1912     ENTER;              /* need to protect against side-effects of 'use' */
1913     SAVEINT(PL_expect);
1914     if (stash && HvNAME(stash))
1915         stashsv = newSVpv(HvNAME(stash), 0);
1916     else
1917         stashsv = &PL_sv_no;
1918
1919 #define ATTRSMODULE "attributes"
1920
1921     Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1922                      newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1923                      Nullsv,
1924                      prepend_elem(OP_LIST,
1925                                   newSVOP(OP_CONST, 0, stashsv),
1926                                   prepend_elem(OP_LIST,
1927                                                newSVOP(OP_CONST, 0,
1928                                                        newRV(target)),
1929                                                dup_attrlist(attrs))));
1930     LEAVE;
1931 }
1932
1933 void
1934 Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv,
1935                         char *attrstr, STRLEN len)
1936 {
1937     OP *attrs = Nullop;
1938
1939     if (!len) {
1940         len = strlen(attrstr);
1941     }
1942
1943     while (len) {
1944         for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1945         if (len) {
1946             char *sstr = attrstr;
1947             for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1948             attrs = append_elem(OP_LIST, attrs,
1949                                 newSVOP(OP_CONST, 0,
1950                                         newSVpvn(sstr, attrstr-sstr)));
1951         }
1952     }
1953
1954     Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1955                      newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1956                      Nullsv, prepend_elem(OP_LIST,
1957                                   newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1958                                   prepend_elem(OP_LIST,
1959                                                newSVOP(OP_CONST, 0,
1960                                                        newRV((SV*)cv)),
1961                                                attrs)));
1962 }
1963
1964 STATIC OP *
1965 S_my_kid(pTHX_ OP *o, OP *attrs)
1966 {
1967     OP *kid;
1968     I32 type;
1969
1970     if (!o || PL_error_count)
1971         return o;
1972
1973     type = o->op_type;
1974     if (type == OP_LIST) {
1975         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1976             my_kid(kid, attrs);
1977     } else if (type == OP_UNDEF) {
1978         return o;
1979     } else if (type == OP_RV2SV ||      /* "our" declaration */
1980                type == OP_RV2AV ||
1981                type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1982         if (attrs) {
1983             GV *gv = cGVOPx_gv(cUNOPo->op_first);
1984             PL_in_my = FALSE;
1985             PL_in_my_stash = Nullhv;
1986             apply_attrs(GvSTASH(gv),
1987                         (type == OP_RV2SV ? GvSV(gv) :
1988                          type == OP_RV2AV ? (SV*)GvAV(gv) :
1989                          type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1990                         attrs);
1991         }
1992         o->op_private |= OPpOUR_INTRO;
1993         return o;
1994     } else if (type != OP_PADSV &&
1995              type != OP_PADAV &&
1996              type != OP_PADHV &&
1997              type != OP_PUSHMARK)
1998     {
1999         yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
2000                           PL_op_desc[o->op_type],
2001                           PL_in_my == KEY_our ? "our" : "my"));
2002         return o;
2003     }
2004     else if (attrs && type != OP_PUSHMARK) {
2005         HV *stash;
2006         SV *padsv;
2007         SV **namesvp;
2008
2009         PL_in_my = FALSE;
2010         PL_in_my_stash = Nullhv;
2011
2012         /* check for C<my Dog $spot> when deciding package */
2013         namesvp = av_fetch(PL_comppad_name, o->op_targ, FALSE);
2014         if (namesvp && *namesvp && SvOBJECT(*namesvp) && HvNAME(SvSTASH(*namesvp)))
2015             stash = SvSTASH(*namesvp);
2016         else
2017             stash = PL_curstash;
2018         padsv = PAD_SV(o->op_targ);
2019         apply_attrs(stash, padsv, attrs);
2020     }
2021     o->op_flags |= OPf_MOD;
2022     o->op_private |= OPpLVAL_INTRO;
2023     return o;
2024 }
2025
2026 OP *
2027 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2028 {
2029     if (o->op_flags & OPf_PARENS)
2030         list(o);
2031     if (attrs)
2032         SAVEFREEOP(attrs);
2033     o = my_kid(o, attrs);
2034     PL_in_my = FALSE;
2035     PL_in_my_stash = Nullhv;
2036     return o;
2037 }
2038
2039 OP *
2040 Perl_my(pTHX_ OP *o)
2041 {
2042     return my_kid(o, Nullop);
2043 }
2044
2045 OP *
2046 Perl_sawparens(pTHX_ OP *o)
2047 {
2048     if (o)
2049         o->op_flags |= OPf_PARENS;
2050     return o;
2051 }
2052
2053 OP *
2054 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2055 {
2056     OP *o;
2057
2058     if (ckWARN(WARN_MISC) &&
2059       (left->op_type == OP_RV2AV ||
2060        left->op_type == OP_RV2HV ||
2061        left->op_type == OP_PADAV ||
2062        left->op_type == OP_PADHV)) {
2063       char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
2064                             right->op_type == OP_TRANS)
2065                            ? right->op_type : OP_MATCH];
2066       const char *sample = ((left->op_type == OP_RV2AV ||
2067                              left->op_type == OP_PADAV)
2068                             ? "@array" : "%hash");
2069       Perl_warner(aTHX_ WARN_MISC,
2070              "Applying %s to %s will act on scalar(%s)",
2071              desc, sample, sample);
2072     }
2073
2074     if (!(right->op_flags & OPf_STACKED) &&
2075        (right->op_type == OP_MATCH ||
2076         right->op_type == OP_SUBST ||
2077         right->op_type == OP_TRANS)) {
2078         right->op_flags |= OPf_STACKED;
2079         if (right->op_type != OP_MATCH &&
2080             ! (right->op_type == OP_TRANS &&
2081                right->op_private & OPpTRANS_IDENTICAL))
2082             left = mod(left, right->op_type);
2083         if (right->op_type == OP_TRANS)
2084             o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
2085         else
2086             o = prepend_elem(right->op_type, scalar(left), right);
2087         if (type == OP_NOT)
2088             return newUNOP(OP_NOT, 0, scalar(o));
2089         return o;
2090     }
2091     else
2092         return bind_match(type, left,
2093                 pmruntime(newPMOP(OP_MATCH, 0), right, Nullop));
2094 }
2095
2096 OP *
2097 Perl_invert(pTHX_ OP *o)
2098 {
2099     if (!o)
2100         return o;
2101     /* XXX need to optimize away NOT NOT here?  Or do we let optimizer do it? */
2102     return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2103 }
2104
2105 OP *
2106 Perl_scope(pTHX_ OP *o)
2107 {
2108     if (o) {
2109         if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2110             o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2111             o->op_type = OP_LEAVE;
2112             o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2113         }
2114         else {
2115             if (o->op_type == OP_LINESEQ) {
2116                 OP *kid;
2117                 o->op_type = OP_SCOPE;
2118                 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2119                 kid = ((LISTOP*)o)->op_first;
2120                 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
2121                     null(kid);
2122             }
2123             else
2124                 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
2125         }
2126     }
2127     return o;
2128 }
2129
2130 void
2131 Perl_save_hints(pTHX)
2132 {
2133     SAVEI32(PL_hints);
2134     SAVESPTR(GvHV(PL_hintgv));
2135     GvHV(PL_hintgv) = newHVhv(GvHV(PL_hintgv));
2136     SAVEFREESV(GvHV(PL_hintgv));
2137 }
2138
2139 int
2140 Perl_block_start(pTHX_ int full)
2141 {
2142     int retval = PL_savestack_ix;
2143
2144     SAVEI32(PL_comppad_name_floor);
2145     PL_comppad_name_floor = AvFILLp(PL_comppad_name);
2146     if (full)
2147         PL_comppad_name_fill = PL_comppad_name_floor;
2148     if (PL_comppad_name_floor < 0)
2149         PL_comppad_name_floor = 0;
2150     SAVEI32(PL_min_intro_pending);
2151     SAVEI32(PL_max_intro_pending);
2152     PL_min_intro_pending = 0;
2153     SAVEI32(PL_comppad_name_fill);
2154     SAVEI32(PL_padix_floor);
2155     PL_padix_floor = PL_padix;
2156     PL_pad_reset_pending = FALSE;
2157     SAVEHINTS();
2158     PL_hints &= ~HINT_BLOCK_SCOPE;
2159     SAVESPTR(PL_compiling.cop_warnings);
2160     if (! specialWARN(PL_compiling.cop_warnings)) {
2161         PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
2162         SAVEFREESV(PL_compiling.cop_warnings) ;
2163     }
2164     SAVESPTR(PL_compiling.cop_io);
2165     if (! specialCopIO(PL_compiling.cop_io)) {
2166         PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
2167         SAVEFREESV(PL_compiling.cop_io) ;
2168     }
2169     return retval;
2170 }
2171
2172 OP*
2173 Perl_block_end(pTHX_ I32 floor, OP *seq)
2174 {
2175     int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2176     OP* retval = scalarseq(seq);
2177     LEAVE_SCOPE(floor);
2178     PL_pad_reset_pending = FALSE;
2179     PL_compiling.op_private = PL_hints;
2180     if (needblockscope)
2181         PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2182     pad_leavemy(PL_comppad_name_fill);
2183     PL_cop_seqmax++;
2184     return retval;
2185 }
2186
2187 STATIC OP *
2188 S_newDEFSVOP(pTHX)
2189 {
2190 #ifdef USE_THREADS
2191     OP *o = newOP(OP_THREADSV, 0);
2192     o->op_targ = find_threadsv("_");
2193     return o;
2194 #else
2195     return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2196 #endif /* USE_THREADS */
2197 }
2198
2199 void
2200 Perl_newPROG(pTHX_ OP *o)
2201 {
2202     if (PL_in_eval) {
2203         if (PL_eval_root)
2204                 return;
2205         PL_eval_root = newUNOP(OP_LEAVEEVAL,
2206                                ((PL_in_eval & EVAL_KEEPERR)
2207                                 ? OPf_SPECIAL : 0), o);
2208         PL_eval_start = linklist(PL_eval_root);
2209         PL_eval_root->op_private |= OPpREFCOUNTED;
2210         OpREFCNT_set(PL_eval_root, 1);
2211         PL_eval_root->op_next = 0;
2212         peep(PL_eval_start);
2213     }
2214     else {
2215         if (!o)
2216             return;
2217         PL_main_root = scope(sawparens(scalarvoid(o)));
2218         PL_curcop = &PL_compiling;
2219         PL_main_start = LINKLIST(PL_main_root);
2220         PL_main_root->op_private |= OPpREFCOUNTED;
2221         OpREFCNT_set(PL_main_root, 1);
2222         PL_main_root->op_next = 0;
2223         peep(PL_main_start);
2224         PL_compcv = 0;
2225
2226         /* Register with debugger */
2227         if (PERLDB_INTER) {
2228             CV *cv = get_cv("DB::postponed", FALSE);
2229             if (cv) {
2230                 dSP;
2231                 PUSHMARK(SP);
2232                 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2233                 PUTBACK;
2234                 call_sv((SV*)cv, G_DISCARD);
2235             }
2236         }
2237     }
2238 }
2239
2240 OP *
2241 Perl_localize(pTHX_ OP *o, I32 lex)
2242 {
2243     if (o->op_flags & OPf_PARENS)
2244         list(o);
2245     else {
2246         if (ckWARN(WARN_PARENTHESIS) && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',') {
2247             char *s;
2248             for (s = PL_bufptr; *s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s) || strchr("@$%, ",*s)); s++) ;
2249             if (*s == ';' || *s == '=')
2250                 Perl_warner(aTHX_ WARN_PARENTHESIS,
2251                             "Parentheses missing around \"%s\" list",
2252                             lex ? (PL_in_my == KEY_our ? "our" : "my") : "local");
2253         }
2254     }
2255     if (lex)
2256         o = my(o);
2257     else
2258         o = mod(o, OP_NULL);            /* a bit kludgey */
2259     PL_in_my = FALSE;
2260     PL_in_my_stash = Nullhv;
2261     return o;
2262 }
2263
2264 OP *
2265 Perl_jmaybe(pTHX_ OP *o)
2266 {
2267     if (o->op_type == OP_LIST) {
2268         OP *o2;
2269 #ifdef USE_THREADS
2270         o2 = newOP(OP_THREADSV, 0);
2271         o2->op_targ = find_threadsv(";");
2272 #else
2273         o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
2274 #endif /* USE_THREADS */
2275         o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2276     }
2277     return o;
2278 }
2279
2280 OP *
2281 Perl_fold_constants(pTHX_ register OP *o)
2282 {
2283     register OP *curop;
2284     I32 type = o->op_type;
2285     SV *sv;
2286
2287     if (PL_opargs[type] & OA_RETSCALAR)
2288         scalar(o);
2289     if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2290         o->op_targ = pad_alloc(type, SVs_PADTMP);
2291
2292     /* integerize op, unless it happens to be C<-foo>.
2293      * XXX should pp_i_negate() do magic string negation instead? */
2294     if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2295         && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2296              && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2297     {
2298         o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2299     }
2300
2301     if (!(PL_opargs[type] & OA_FOLDCONST))
2302         goto nope;
2303
2304     switch (type) {
2305     case OP_NEGATE:
2306         /* XXX might want a ck_negate() for this */
2307         cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2308         break;
2309     case OP_SPRINTF:
2310     case OP_UCFIRST:
2311     case OP_LCFIRST:
2312     case OP_UC:
2313     case OP_LC:
2314     case OP_SLT:
2315     case OP_SGT:
2316     case OP_SLE:
2317     case OP_SGE:
2318     case OP_SCMP:
2319
2320         if (o->op_private & OPpLOCALE)
2321             goto nope;
2322     }
2323
2324     if (PL_error_count)
2325         goto nope;              /* Don't try to run w/ errors */
2326
2327     for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2328         if ((curop->op_type != OP_CONST ||
2329              (curop->op_private & OPpCONST_BARE)) &&
2330             curop->op_type != OP_LIST &&
2331             curop->op_type != OP_SCALAR &&
2332             curop->op_type != OP_NULL &&
2333             curop->op_type != OP_PUSHMARK)
2334         {
2335             goto nope;
2336         }
2337     }
2338
2339     curop = LINKLIST(o);
2340     o->op_next = 0;
2341     PL_op = curop;
2342     CALLRUNOPS(aTHX);
2343     sv = *(PL_stack_sp--);
2344     if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2345         pad_swipe(o->op_targ);
2346     else if (SvTEMP(sv)) {                      /* grab mortal temp? */
2347         (void)SvREFCNT_inc(sv);
2348         SvTEMP_off(sv);
2349     }
2350     op_free(o);
2351     if (type == OP_RV2GV)
2352         return newGVOP(OP_GV, 0, (GV*)sv);
2353     else {
2354         /* try to smush double to int, but don't smush -2.0 to -2 */
2355         if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK &&
2356             type != OP_NEGATE)
2357         {
2358 #ifdef PERL_PRESERVE_IVUV
2359             /* Only bother to attempt to fold to IV if
2360                most operators will benefit  */
2361             SvIV_please(sv);
2362 #endif
2363         }
2364         return newSVOP(OP_CONST, 0, sv);
2365     }
2366
2367   nope:
2368     if (!(PL_opargs[type] & OA_OTHERINT))
2369         return o;
2370
2371     if (!(PL_hints & HINT_INTEGER)) {
2372         if (type == OP_MODULO
2373             || type == OP_DIVIDE
2374             || !(o->op_flags & OPf_KIDS))
2375         {
2376             return o;
2377         }
2378
2379         for (curop = ((UNOP*)o)->op_first; curop; curop = curop->op_sibling) {
2380             if (curop->op_type == OP_CONST) {
2381                 if (SvIOK(((SVOP*)curop)->op_sv))
2382                     continue;
2383                 return o;
2384             }
2385             if (PL_opargs[curop->op_type] & OA_RETINTEGER)
2386                 continue;
2387             return o;
2388         }
2389         o->op_ppaddr = PL_ppaddr[++(o->op_type)];
2390     }
2391
2392     return o;
2393 }
2394
2395 OP *
2396 Perl_gen_constant_list(pTHX_ register OP *o)
2397 {
2398     register OP *curop;
2399     I32 oldtmps_floor = PL_tmps_floor;
2400
2401     list(o);
2402     if (PL_error_count)
2403         return o;               /* Don't attempt to run with errors */
2404
2405     PL_op = curop = LINKLIST(o);
2406     o->op_next = 0;
2407     peep(curop);
2408     pp_pushmark();
2409     CALLRUNOPS(aTHX);
2410     PL_op = curop;
2411     pp_anonlist();
2412     PL_tmps_floor = oldtmps_floor;
2413
2414     o->op_type = OP_RV2AV;
2415     o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2416     curop = ((UNOP*)o)->op_first;
2417     ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2418     op_free(curop);
2419     linklist(o);
2420     return list(o);
2421 }
2422
2423 OP *
2424 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2425 {
2426     if (!o || o->op_type != OP_LIST)
2427         o = newLISTOP(OP_LIST, 0, o, Nullop);
2428     else
2429         o->op_flags &= ~OPf_WANT;
2430
2431     if (!(PL_opargs[type] & OA_MARK))
2432         null(cLISTOPo->op_first);
2433
2434     o->op_type = type;
2435     o->op_ppaddr = PL_ppaddr[type];
2436     o->op_flags |= flags;
2437
2438     o = CHECKOP(type, o);
2439     if (o->op_type != type)
2440         return o;
2441
2442     return fold_constants(o);
2443 }
2444
2445 /* List constructors */
2446
2447 OP *
2448 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2449 {
2450     if (!first)
2451         return last;
2452
2453     if (!last)
2454         return first;
2455
2456     if (first->op_type != type
2457         || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2458     {
2459         return newLISTOP(type, 0, first, last);
2460     }
2461
2462     if (first->op_flags & OPf_KIDS)
2463         ((LISTOP*)first)->op_last->op_sibling = last;
2464     else {
2465         first->op_flags |= OPf_KIDS;
2466         ((LISTOP*)first)->op_first = last;
2467     }
2468     ((LISTOP*)first)->op_last = last;
2469     return first;
2470 }
2471
2472 OP *
2473 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2474 {
2475     if (!first)
2476         return (OP*)last;
2477
2478     if (!last)
2479         return (OP*)first;
2480
2481     if (first->op_type != type)
2482         return prepend_elem(type, (OP*)first, (OP*)last);
2483
2484     if (last->op_type != type)
2485         return append_elem(type, (OP*)first, (OP*)last);
2486
2487     first->op_last->op_sibling = last->op_first;
2488     first->op_last = last->op_last;
2489     first->op_flags |= (last->op_flags & OPf_KIDS);
2490
2491 #ifdef PL_OP_SLAB_ALLOC
2492 #else
2493     Safefree(last);
2494 #endif
2495     return (OP*)first;
2496 }
2497
2498 OP *
2499 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2500 {
2501     if (!first)
2502         return last;
2503
2504     if (!last)
2505         return first;
2506
2507     if (last->op_type == type) {
2508         if (type == OP_LIST) {  /* already a PUSHMARK there */
2509             first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2510             ((LISTOP*)last)->op_first->op_sibling = first;
2511             if (!(first->op_flags & OPf_PARENS))
2512                 last->op_flags &= ~OPf_PARENS;
2513         }
2514         else {
2515             if (!(last->op_flags & OPf_KIDS)) {
2516                 ((LISTOP*)last)->op_last = first;
2517                 last->op_flags |= OPf_KIDS;
2518             }
2519             first->op_sibling = ((LISTOP*)last)->op_first;
2520             ((LISTOP*)last)->op_first = first;
2521         }
2522         last->op_flags |= OPf_KIDS;
2523         return last;
2524     }
2525
2526     return newLISTOP(type, 0, first, last);
2527 }
2528
2529 /* Constructors */
2530
2531 OP *
2532 Perl_newNULLLIST(pTHX)
2533 {
2534     return newOP(OP_STUB, 0);
2535 }
2536
2537 OP *
2538 Perl_force_list(pTHX_ OP *o)
2539 {
2540     if (!o || o->op_type != OP_LIST)
2541         o = newLISTOP(OP_LIST, 0, o, Nullop);
2542     null(o);
2543     return o;
2544 }
2545
2546 OP *
2547 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2548 {
2549     LISTOP *listop;
2550
2551     NewOp(1101, listop, 1, LISTOP);
2552
2553     listop->op_type = type;
2554     listop->op_ppaddr = PL_ppaddr[type];
2555     if (first || last)
2556         flags |= OPf_KIDS;
2557     listop->op_flags = flags;
2558
2559     if (!last && first)
2560         last = first;
2561     else if (!first && last)
2562         first = last;
2563     else if (first)
2564         first->op_sibling = last;
2565     listop->op_first = first;
2566     listop->op_last = last;
2567     if (type == OP_LIST) {
2568         OP* pushop;
2569         pushop = newOP(OP_PUSHMARK, 0);
2570         pushop->op_sibling = first;
2571         listop->op_first = pushop;
2572         listop->op_flags |= OPf_KIDS;
2573         if (!last)
2574             listop->op_last = pushop;
2575     }
2576
2577     return (OP*)listop;
2578 }
2579
2580 OP *
2581 Perl_newOP(pTHX_ I32 type, I32 flags)
2582 {
2583     OP *o;
2584     NewOp(1101, o, 1, OP);
2585     o->op_type = type;
2586     o->op_ppaddr = PL_ppaddr[type];
2587     o->op_flags = flags;
2588
2589     o->op_next = o;
2590     o->op_private = 0 + (flags >> 8);
2591     if (PL_opargs[type] & OA_RETSCALAR)
2592         scalar(o);
2593     if (PL_opargs[type] & OA_TARGET)
2594         o->op_targ = pad_alloc(type, SVs_PADTMP);
2595     return CHECKOP(type, o);
2596 }
2597
2598 OP *
2599 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2600 {
2601     UNOP *unop;
2602
2603     if (!first)
2604         first = newOP(OP_STUB, 0);
2605     if (PL_opargs[type] & OA_MARK)
2606         first = force_list(first);
2607
2608     NewOp(1101, unop, 1, UNOP);
2609     unop->op_type = type;
2610     unop->op_ppaddr = PL_ppaddr[type];
2611     unop->op_first = first;
2612     unop->op_flags = flags | OPf_KIDS;
2613     unop->op_private = 1 | (flags >> 8);
2614     unop = (UNOP*) CHECKOP(type, unop);
2615     if (unop->op_next)
2616         return (OP*)unop;
2617
2618     return fold_constants((OP *) unop);
2619 }
2620
2621 OP *
2622 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2623 {
2624     BINOP *binop;
2625     NewOp(1101, binop, 1, BINOP);
2626
2627     if (!first)
2628         first = newOP(OP_NULL, 0);
2629
2630     binop->op_type = type;
2631     binop->op_ppaddr = PL_ppaddr[type];
2632     binop->op_first = first;
2633     binop->op_flags = flags | OPf_KIDS;
2634     if (!last) {
2635         last = first;
2636         binop->op_private = 1 | (flags >> 8);
2637     }
2638     else {
2639         binop->op_private = 2 | (flags >> 8);
2640         first->op_sibling = last;
2641     }
2642
2643     binop = (BINOP*)CHECKOP(type, binop);
2644     if (binop->op_next || binop->op_type != type)
2645         return (OP*)binop;
2646
2647     binop->op_last = binop->op_first->op_sibling;
2648
2649     return fold_constants((OP *)binop);
2650 }
2651
2652 static int
2653 utf8compare(const void *a, const void *b)
2654 {
2655     int i;
2656     for (i = 0; i < 10; i++) {
2657         if ((*(U8**)a)[i] < (*(U8**)b)[i])
2658             return -1;
2659         if ((*(U8**)a)[i] > (*(U8**)b)[i])
2660             return 1;
2661     }
2662     return 0;
2663 }
2664
2665 OP *
2666 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2667 {
2668     SV *tstr = ((SVOP*)expr)->op_sv;
2669     SV *rstr = ((SVOP*)repl)->op_sv;
2670     STRLEN tlen;
2671     STRLEN rlen;
2672     U8 *t = (U8*)SvPV(tstr, tlen);
2673     U8 *r = (U8*)SvPV(rstr, rlen);
2674     register I32 i;
2675     register I32 j;
2676     I32 del;
2677     I32 complement;
2678     I32 squash;
2679     I32 grows = 0;
2680     register short *tbl;
2681
2682     complement  = o->op_private & OPpTRANS_COMPLEMENT;
2683     del         = o->op_private & OPpTRANS_DELETE;
2684     squash      = o->op_private & OPpTRANS_SQUASH;
2685
2686     if (SvUTF8(tstr))
2687         o->op_private |= OPpTRANS_FROM_UTF;
2688
2689     if (SvUTF8(rstr))
2690         o->op_private |= OPpTRANS_TO_UTF;
2691
2692     if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2693         SV* listsv = newSVpvn("# comment\n",10);
2694         SV* transv = 0;
2695         U8* tend = t + tlen;
2696         U8* rend = r + rlen;
2697         STRLEN ulen;
2698         U32 tfirst = 1;
2699         U32 tlast = 0;
2700         I32 tdiff;
2701         U32 rfirst = 1;
2702         U32 rlast = 0;
2703         I32 rdiff;
2704         I32 diff;
2705         I32 none = 0;
2706         U32 max = 0;
2707         I32 bits;
2708         I32 havefinal = 0;
2709         U32 final;
2710         I32 from_utf    = o->op_private & OPpTRANS_FROM_UTF;
2711         I32 to_utf      = o->op_private & OPpTRANS_TO_UTF;
2712         U8* tsave = from_utf ? NULL : trlist_upgrade(&t, &tend);
2713         U8* rsave = to_utf   ? NULL : trlist_upgrade(&r, &rend);
2714
2715         if (complement) {
2716             U8 tmpbuf[UTF8_MAXLEN+1];
2717             U8** cp;
2718             UV nextmin = 0;
2719             New(1109, cp, tlen, U8*);
2720             i = 0;
2721             transv = newSVpvn("",0);
2722             while (t < tend) {
2723                 cp[i++] = t;
2724                 t += UTF8SKIP(t);
2725                 if (t < tend && *t == 0xff) {
2726                     t++;
2727                     t += UTF8SKIP(t);
2728                 }
2729             }
2730             qsort(cp, i, sizeof(U8*), utf8compare);
2731             for (j = 0; j < i; j++) {
2732                 U8 *s = cp[j];
2733                 I32 cur = j < i - 1 ? cp[j+1] - s : tend - s;
2734                 /* CHECKME: Use unicode code points for ranges - needs more thought ... NI-S */
2735                 UV  val = utf8n_to_uvuni(s, cur, &ulen, 0);
2736                 s += ulen;
2737                 diff = val - nextmin;
2738                 if (diff > 0) {
2739                     t = uvuni_to_utf8(tmpbuf,nextmin);
2740                     sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2741                     if (diff > 1) {
2742                         t = uvuni_to_utf8(tmpbuf, val - 1);
2743                         sv_catpvn(transv, "\377", 1);
2744                         sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2745                     }
2746                 }
2747                 if (s < tend && *s == 0xff)
2748                     val = utf8n_to_uvuni(s+1, cur - 1, &ulen, 0);
2749                 if (val >= nextmin)
2750                     nextmin = val + 1;
2751             }
2752             t = uvuni_to_utf8(tmpbuf,nextmin);
2753             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2754             t = uvuni_to_utf8(tmpbuf, 0x7fffffff);
2755             sv_catpvn(transv, "\377", 1);
2756             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2757             t = (U8*)SvPVX(transv);
2758             tlen = SvCUR(transv);
2759             tend = t + tlen;
2760             Safefree(cp);
2761         }
2762         else if (!rlen && !del) {
2763             r = t; rlen = tlen; rend = tend;
2764         }
2765         if (!squash) {
2766                 if (t == r ||
2767                     (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2768                 {
2769                     o->op_private |= OPpTRANS_IDENTICAL;
2770                 }
2771         }
2772
2773         while (t < tend || tfirst <= tlast) {
2774             /* see if we need more "t" chars */
2775             if (tfirst > tlast) {
2776                 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2777                 t += ulen;
2778                 if (t < tend && *t == 0xff) {   /* illegal utf8 val indicates range */
2779                     t++;
2780                     tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2781                     t += ulen;
2782                 }
2783                 else
2784                     tlast = tfirst;
2785             }
2786
2787             /* now see if we need more "r" chars */
2788             if (rfirst > rlast) {
2789                 if (r < rend) {
2790                     rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2791                     r += ulen;
2792                     if (r < rend && *r == 0xff) {       /* illegal utf8 val indicates range */
2793                         r++;
2794                         rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2795                         r += ulen;
2796                     }
2797                     else
2798                         rlast = rfirst;
2799                 }
2800                 else {
2801                     if (!havefinal++)
2802                         final = rlast;
2803                     rfirst = rlast = 0xffffffff;
2804                 }
2805             }
2806
2807             /* now see which range will peter our first, if either. */
2808             tdiff = tlast - tfirst;
2809             rdiff = rlast - rfirst;
2810
2811             if (tdiff <= rdiff)
2812                 diff = tdiff;
2813             else
2814                 diff = rdiff;
2815
2816             if (rfirst == 0xffffffff) {
2817                 diff = tdiff;   /* oops, pretend rdiff is infinite */
2818                 if (diff > 0)
2819                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2820                                    (long)tfirst, (long)tlast);
2821                 else
2822                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2823             }
2824             else {
2825                 if (diff > 0)
2826                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2827                                    (long)tfirst, (long)(tfirst + diff),
2828                                    (long)rfirst);
2829                 else
2830                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2831                                    (long)tfirst, (long)rfirst);
2832
2833                 if (rfirst + diff > max)
2834                     max = rfirst + diff;
2835                 rfirst += diff + 1;
2836                 if (!grows)
2837                     grows = (UNISKIP(tfirst) < UNISKIP(rfirst));
2838             }
2839             tfirst += diff + 1;
2840         }
2841
2842         none = ++max;
2843         if (del)
2844             del = ++max;
2845
2846         if (max > 0xffff)
2847             bits = 32;
2848         else if (max > 0xff)
2849             bits = 16;
2850         else
2851             bits = 8;
2852
2853         Safefree(cPVOPo->op_pv);
2854         cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2855         SvREFCNT_dec(listsv);
2856         if (transv)
2857             SvREFCNT_dec(transv);
2858
2859         if (!del && havefinal)
2860             (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2861                            newSVuv((UV)final), 0);
2862
2863         if (grows)
2864             o->op_private |= OPpTRANS_GROWS;
2865
2866         if (tsave)
2867             Safefree(tsave);
2868         if (rsave)
2869             Safefree(rsave);
2870
2871         op_free(expr);
2872         op_free(repl);
2873         return o;
2874     }
2875
2876     tbl = (short*)cPVOPo->op_pv;
2877     if (complement) {
2878         Zero(tbl, 256, short);
2879         for (i = 0; i < tlen; i++)
2880             tbl[t[i]] = -1;
2881         for (i = 0, j = 0; i < 256; i++) {
2882             if (!tbl[i]) {
2883                 if (j >= rlen) {
2884                     if (del)
2885                         tbl[i] = -2;
2886                     else if (rlen)
2887                         tbl[i] = r[j-1];
2888                     else
2889                         tbl[i] = i;
2890                 }
2891                 else {
2892                     if (i < 128 && r[j] >= 128)
2893                         grows = 1;
2894                     tbl[i] = r[j++];
2895                 }
2896             }
2897         }
2898         if (!del) {
2899             if (j >= rlen)
2900                 j = rlen - 1;
2901             else
2902                 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2903             tbl[0x100] = rlen - j;
2904             for (i=0; i < rlen - j; i++)
2905                 tbl[0x101+i] = r[j+i];
2906         }
2907     }
2908     else {
2909         if (!rlen && !del) {
2910             r = t; rlen = tlen;
2911             if (!squash)
2912                 o->op_private |= OPpTRANS_IDENTICAL;
2913         }
2914         for (i = 0; i < 256; i++)
2915             tbl[i] = -1;
2916         for (i = 0, j = 0; i < tlen; i++,j++) {
2917             if (j >= rlen) {
2918                 if (del) {
2919                     if (tbl[t[i]] == -1)
2920                         tbl[t[i]] = -2;
2921                     continue;
2922                 }
2923                 --j;
2924             }
2925             if (tbl[t[i]] == -1) {
2926                 if (t[i] < 128 && r[j] >= 128)
2927                     grows = 1;
2928                 tbl[t[i]] = r[j];
2929             }
2930         }
2931     }
2932     if (grows)
2933         o->op_private |= OPpTRANS_GROWS;
2934     op_free(expr);
2935     op_free(repl);
2936
2937     return o;
2938 }
2939
2940 OP *
2941 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2942 {
2943     PMOP *pmop;
2944
2945     NewOp(1101, pmop, 1, PMOP);
2946     pmop->op_type = type;
2947     pmop->op_ppaddr = PL_ppaddr[type];
2948     pmop->op_flags = flags;
2949     pmop->op_private = 0 | (flags >> 8);
2950
2951     if (PL_hints & HINT_RE_TAINT)
2952         pmop->op_pmpermflags |= PMf_RETAINT;
2953     if (PL_hints & HINT_LOCALE)
2954         pmop->op_pmpermflags |= PMf_LOCALE;
2955     pmop->op_pmflags = pmop->op_pmpermflags;
2956
2957     /* link into pm list */
2958     if (type != OP_TRANS && PL_curstash) {
2959         pmop->op_pmnext = HvPMROOT(PL_curstash);
2960         HvPMROOT(PL_curstash) = pmop;
2961         PmopSTASH_set(pmop,PL_curstash);
2962     }
2963
2964     return (OP*)pmop;
2965 }
2966
2967 OP *
2968 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
2969 {
2970     PMOP *pm;
2971     LOGOP *rcop;
2972     I32 repl_has_vars = 0;
2973
2974     if (o->op_type == OP_TRANS)
2975         return pmtrans(o, expr, repl);
2976
2977     PL_hints |= HINT_BLOCK_SCOPE;
2978     pm = (PMOP*)o;
2979
2980     if (expr->op_type == OP_CONST) {
2981         STRLEN plen;
2982         SV *pat = ((SVOP*)expr)->op_sv;
2983         char *p = SvPV(pat, plen);
2984         if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
2985             sv_setpvn(pat, "\\s+", 3);
2986             p = SvPV(pat, plen);
2987             pm->op_pmflags |= PMf_SKIPWHITE;
2988         }
2989         if ((PL_hints & HINT_UTF8) || DO_UTF8(pat))
2990             pm->op_pmdynflags |= PMdf_UTF8;
2991         pm->op_pmregexp = CALLREGCOMP(aTHX_ p, p + plen, pm);
2992         if (strEQ("\\s+", pm->op_pmregexp->precomp))
2993             pm->op_pmflags |= PMf_WHITE;
2994         op_free(expr);
2995     }
2996     else {
2997         if (PL_hints & HINT_UTF8)
2998             pm->op_pmdynflags |= PMdf_UTF8;
2999         if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3000             expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3001                             ? OP_REGCRESET
3002                             : OP_REGCMAYBE),0,expr);
3003
3004         NewOp(1101, rcop, 1, LOGOP);
3005         rcop->op_type = OP_REGCOMP;
3006         rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3007         rcop->op_first = scalar(expr);
3008         rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
3009                            ? (OPf_SPECIAL | OPf_KIDS)
3010                            : OPf_KIDS);
3011         rcop->op_private = 1;
3012         rcop->op_other = o;
3013
3014         /* establish postfix order */
3015         if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3016             LINKLIST(expr);
3017             rcop->op_next = expr;
3018             ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3019         }
3020         else {
3021             rcop->op_next = LINKLIST(expr);
3022             expr->op_next = (OP*)rcop;
3023         }
3024
3025         prepend_elem(o->op_type, scalar((OP*)rcop), o);
3026     }
3027
3028     if (repl) {
3029         OP *curop;
3030         if (pm->op_pmflags & PMf_EVAL) {
3031             curop = 0;
3032             if (CopLINE(PL_curcop) < PL_multi_end)
3033                 CopLINE_set(PL_curcop, PL_multi_end);
3034         }
3035 #ifdef USE_THREADS
3036         else if (repl->op_type == OP_THREADSV
3037                  && strchr("&`'123456789+",
3038                            PL_threadsv_names[repl->op_targ]))
3039         {
3040             curop = 0;
3041         }
3042 #endif /* USE_THREADS */
3043         else if (repl->op_type == OP_CONST)
3044             curop = repl;
3045         else {
3046             OP *lastop = 0;
3047             for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3048                 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3049 #ifdef USE_THREADS
3050                     if (curop->op_type == OP_THREADSV) {
3051                         repl_has_vars = 1;
3052                         if (strchr("&`'123456789+", curop->op_private))
3053                             break;
3054                     }
3055 #else
3056                     if (curop->op_type == OP_GV) {
3057                         GV *gv = cGVOPx_gv(curop);
3058                         repl_has_vars = 1;
3059                         if (strchr("&`'123456789+", *GvENAME(gv)))
3060                             break;
3061                     }
3062 #endif /* USE_THREADS */
3063                     else if (curop->op_type == OP_RV2CV)
3064                         break;
3065                     else if (curop->op_type == OP_RV2SV ||
3066                              curop->op_type == OP_RV2AV ||
3067                              curop->op_type == OP_RV2HV ||
3068                              curop->op_type == OP_RV2GV) {
3069                         if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3070                             break;
3071                     }
3072                     else if (curop->op_type == OP_PADSV ||
3073                              curop->op_type == OP_PADAV ||
3074                              curop->op_type == OP_PADHV ||
3075                              curop->op_type == OP_PADANY) {
3076                         repl_has_vars = 1;
3077                     }
3078                     else if (curop->op_type == OP_PUSHRE)
3079                         ; /* Okay here, dangerous in newASSIGNOP */
3080                     else
3081                         break;
3082                 }
3083                 lastop = curop;
3084             }
3085         }
3086         if (curop == repl
3087             && !(repl_has_vars
3088                  && (!pm->op_pmregexp
3089                      || pm->op_pmregexp->reganch & ROPT_EVAL_SEEN))) {
3090             pm->op_pmflags |= PMf_CONST;        /* const for long enough */
3091             pm->op_pmpermflags |= PMf_CONST;    /* const for long enough */
3092             prepend_elem(o->op_type, scalar(repl), o);
3093         }
3094         else {
3095             if (curop == repl && !pm->op_pmregexp) { /* Has variables. */
3096                 pm->op_pmflags |= PMf_MAYBE_CONST;
3097                 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3098             }
3099             NewOp(1101, rcop, 1, LOGOP);
3100             rcop->op_type = OP_SUBSTCONT;
3101             rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3102             rcop->op_first = scalar(repl);
3103             rcop->op_flags |= OPf_KIDS;
3104             rcop->op_private = 1;
3105             rcop->op_other = o;
3106
3107             /* establish postfix order */
3108             rcop->op_next = LINKLIST(repl);
3109             repl->op_next = (OP*)rcop;
3110
3111             pm->op_pmreplroot = scalar((OP*)rcop);
3112             pm->op_pmreplstart = LINKLIST(rcop);
3113             rcop->op_next = 0;
3114         }
3115     }
3116
3117     return (OP*)pm;
3118 }
3119
3120 OP *
3121 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3122 {
3123     SVOP *svop;
3124     NewOp(1101, svop, 1, SVOP);
3125     svop->op_type = type;
3126     svop->op_ppaddr = PL_ppaddr[type];
3127     svop->op_sv = sv;
3128     svop->op_next = (OP*)svop;
3129     svop->op_flags = flags;
3130     if (PL_opargs[type] & OA_RETSCALAR)
3131         scalar((OP*)svop);
3132     if (PL_opargs[type] & OA_TARGET)
3133         svop->op_targ = pad_alloc(type, SVs_PADTMP);
3134     return CHECKOP(type, svop);
3135 }
3136
3137 OP *
3138 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3139 {
3140     PADOP *padop;
3141     NewOp(1101, padop, 1, PADOP);
3142     padop->op_type = type;
3143     padop->op_ppaddr = PL_ppaddr[type];
3144     padop->op_padix = pad_alloc(type, SVs_PADTMP);
3145     SvREFCNT_dec(PL_curpad[padop->op_padix]);
3146     PL_curpad[padop->op_padix] = sv;
3147     SvPADTMP_on(sv);
3148     padop->op_next = (OP*)padop;
3149     padop->op_flags = flags;
3150     if (PL_opargs[type] & OA_RETSCALAR)
3151         scalar((OP*)padop);
3152     if (PL_opargs[type] & OA_TARGET)
3153         padop->op_targ = pad_alloc(type, SVs_PADTMP);
3154     return CHECKOP(type, padop);
3155 }
3156
3157 OP *
3158 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3159 {
3160 #ifdef USE_ITHREADS
3161     GvIN_PAD_on(gv);
3162     return newPADOP(type, flags, SvREFCNT_inc(gv));
3163 #else
3164     return newSVOP(type, flags, SvREFCNT_inc(gv));
3165 #endif
3166 }
3167
3168 OP *
3169 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3170 {
3171     PVOP *pvop;
3172     NewOp(1101, pvop, 1, PVOP);
3173     pvop->op_type = type;
3174     pvop->op_ppaddr = PL_ppaddr[type];
3175     pvop->op_pv = pv;
3176     pvop->op_next = (OP*)pvop;
3177     pvop->op_flags = flags;
3178     if (PL_opargs[type] & OA_RETSCALAR)
3179         scalar((OP*)pvop);
3180     if (PL_opargs[type] & OA_TARGET)
3181         pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3182     return CHECKOP(type, pvop);
3183 }
3184
3185 void
3186 Perl_package(pTHX_ OP *o)
3187 {
3188     SV *sv;
3189
3190     save_hptr(&PL_curstash);
3191     save_item(PL_curstname);
3192     if (o) {
3193         STRLEN len;
3194         char *name;
3195         sv = cSVOPo->op_sv;
3196         name = SvPV(sv, len);
3197         PL_curstash = gv_stashpvn(name,len,TRUE);
3198         sv_setpvn(PL_curstname, name, len);
3199         op_free(o);
3200     }
3201     else {
3202         sv_setpv(PL_curstname,"<none>");
3203         PL_curstash = Nullhv;
3204     }
3205     PL_hints |= HINT_BLOCK_SCOPE;
3206     PL_copline = NOLINE;
3207     PL_expect = XSTATE;
3208 }
3209
3210 void
3211 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
3212 {
3213     OP *pack;
3214     OP *rqop;
3215     OP *imop;
3216     OP *veop;
3217     GV *gv;
3218
3219     if (id->op_type != OP_CONST)
3220         Perl_croak(aTHX_ "Module name must be constant");
3221
3222     veop = Nullop;
3223
3224     if (version != Nullop) {
3225         SV *vesv = ((SVOP*)version)->op_sv;
3226
3227         if (arg == Nullop && !SvNIOKp(vesv)) {
3228             arg = version;
3229         }
3230         else {
3231             OP *pack;
3232             SV *meth;
3233
3234             if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3235                 Perl_croak(aTHX_ "Version number must be constant number");
3236
3237             /* Make copy of id so we don't free it twice */
3238             pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3239
3240             /* Fake up a method call to VERSION */
3241             meth = newSVpvn("VERSION",7);
3242             sv_upgrade(meth, SVt_PVIV);
3243             (void)SvIOK_on(meth);
3244             PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3245             veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3246                             append_elem(OP_LIST,
3247                                         prepend_elem(OP_LIST, pack, list(version)),
3248                                         newSVOP(OP_METHOD_NAMED, 0, meth)));
3249         }
3250     }
3251
3252     /* Fake up an import/unimport */
3253     if (arg && arg->op_type == OP_STUB)
3254         imop = arg;             /* no import on explicit () */
3255     else if (SvNIOKp(((SVOP*)id)->op_sv)) {
3256         imop = Nullop;          /* use 5.0; */
3257     }
3258     else {
3259         SV *meth;
3260
3261         /* Make copy of id so we don't free it twice */
3262         pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3263
3264         /* Fake up a method call to import/unimport */
3265         meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);;
3266         sv_upgrade(meth, SVt_PVIV);
3267         (void)SvIOK_on(meth);
3268         PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3269         imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3270                        append_elem(OP_LIST,
3271                                    prepend_elem(OP_LIST, pack, list(arg)),
3272                                    newSVOP(OP_METHOD_NAMED, 0, meth)));
3273     }
3274
3275     /* Fake up a require, handle override, if any */
3276     gv = gv_fetchpv("require", FALSE, SVt_PVCV);
3277     if (!(gv && GvIMPORTED_CV(gv)))
3278         gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
3279
3280     if (gv && GvIMPORTED_CV(gv)) {
3281         rqop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3282                                append_elem(OP_LIST, id,
3283                                            scalar(newUNOP(OP_RV2CV, 0,
3284                                                           newGVOP(OP_GV, 0,
3285                                                                   gv))))));
3286     }
3287     else {
3288         rqop = newUNOP(OP_REQUIRE, 0, id);
3289     }
3290
3291     /* Fake up the BEGIN {}, which does its thing immediately. */
3292     newATTRSUB(floor,
3293         newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
3294         Nullop,
3295         Nullop,
3296         append_elem(OP_LINESEQ,
3297             append_elem(OP_LINESEQ,
3298                 newSTATEOP(0, Nullch, rqop),
3299                 newSTATEOP(0, Nullch, veop)),
3300             newSTATEOP(0, Nullch, imop) ));
3301
3302     PL_hints |= HINT_BLOCK_SCOPE;
3303     PL_copline = NOLINE;
3304     PL_expect = XSTATE;
3305 }
3306
3307 void
3308 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3309 {
3310     va_list args;
3311     va_start(args, ver);
3312     vload_module(flags, name, ver, &args);
3313     va_end(args);
3314 }
3315
3316 #ifdef PERL_IMPLICIT_CONTEXT
3317 void
3318 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3319 {
3320     dTHX;
3321     va_list args;
3322     va_start(args, ver);
3323     vload_module(flags, name, ver, &args);
3324     va_end(args);
3325 }
3326 #endif
3327
3328 void
3329 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3330 {
3331     OP *modname, *veop, *imop;
3332
3333     modname = newSVOP(OP_CONST, 0, name);
3334     modname->op_private |= OPpCONST_BARE;
3335     if (ver) {
3336         veop = newSVOP(OP_CONST, 0, ver);
3337     }
3338     else
3339         veop = Nullop;
3340     if (flags & PERL_LOADMOD_NOIMPORT) {
3341         imop = sawparens(newNULLLIST());
3342     }
3343     else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3344         imop = va_arg(*args, OP*);
3345     }
3346     else {
3347         SV *sv;
3348         imop = Nullop;
3349         sv = va_arg(*args, SV*);
3350         while (sv) {
3351             imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3352             sv = va_arg(*args, SV*);
3353         }
3354     }
3355     {
3356         line_t ocopline = PL_copline;
3357         int oexpect = PL_expect;
3358
3359         utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3360                 veop, modname, imop);
3361         PL_expect = oexpect;
3362         PL_copline = ocopline;
3363     }
3364 }
3365
3366 OP *
3367 Perl_dofile(pTHX_ OP *term)
3368 {
3369     OP *doop;
3370     GV *gv;
3371
3372     gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3373     if (!(gv && GvIMPORTED_CV(gv)))
3374         gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3375
3376     if (gv && GvIMPORTED_CV(gv)) {
3377         doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3378                                append_elem(OP_LIST, term,
3379                                            scalar(newUNOP(OP_RV2CV, 0,
3380                                                           newGVOP(OP_GV, 0,
3381                                                                   gv))))));
3382     }
3383     else {
3384         doop = newUNOP(OP_DOFILE, 0, scalar(term));
3385     }
3386     return doop;
3387 }
3388
3389 OP *
3390 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3391 {
3392     return newBINOP(OP_LSLICE, flags,
3393             list(force_list(subscript)),
3394             list(force_list(listval)) );
3395 }
3396
3397 STATIC I32
3398 S_list_assignment(pTHX_ register OP *o)
3399 {
3400     if (!o)
3401         return TRUE;
3402
3403     if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3404         o = cUNOPo->op_first;
3405
3406     if (o->op_type == OP_COND_EXPR) {
3407         I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3408         I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3409
3410         if (t && f)
3411             return TRUE;
3412         if (t || f)
3413             yyerror("Assignment to both a list and a scalar");
3414         return FALSE;
3415     }
3416
3417     if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3418         o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3419         o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3420         return TRUE;
3421
3422     if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3423         return TRUE;
3424
3425     if (o->op_type == OP_RV2SV)
3426         return FALSE;
3427
3428     return FALSE;
3429 }
3430
3431 OP *
3432 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3433 {
3434     OP *o;
3435
3436     if (optype) {
3437         if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN) {
3438             return newLOGOP(optype, 0,
3439                 mod(scalar(left), optype),
3440                 newUNOP(OP_SASSIGN, 0, scalar(right)));
3441         }
3442         else {
3443             return newBINOP(optype, OPf_STACKED,
3444                 mod(scalar(left), optype), scalar(right));
3445         }
3446     }
3447
3448     if (list_assignment(left)) {
3449         OP *curop;
3450
3451         PL_modcount = 0;
3452         PL_eval_start = right;  /* Grandfathering $[ assignment here.  Bletch.*/
3453         left = mod(left, OP_AASSIGN);
3454         if (PL_eval_start)
3455             PL_eval_start = 0;
3456         else {
3457             op_free(left);
3458             op_free(right);
3459             return Nullop;
3460         }
3461         curop = list(force_list(left));
3462         o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3463         o->op_private = 0 | (flags >> 8);
3464         for (curop = ((LISTOP*)curop)->op_first;
3465              curop; curop = curop->op_sibling)
3466         {
3467             if (curop->op_type == OP_RV2HV &&
3468                 ((UNOP*)curop)->op_first->op_type != OP_GV) {
3469                 o->op_private |= OPpASSIGN_HASH;
3470                 break;
3471             }
3472         }
3473         if (!(left->op_private & OPpLVAL_INTRO)) {
3474             OP *lastop = o;
3475             PL_generation++;
3476             for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3477                 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3478                     if (curop->op_type == OP_GV) {
3479                         GV *gv = cGVOPx_gv(curop);
3480                         if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3481                             break;
3482                         SvCUR(gv) = PL_generation;
3483                     }
3484                     else if (curop->op_type == OP_PADSV ||
3485                              curop->op_type == OP_PADAV ||
3486                              curop->op_type == OP_PADHV ||
3487                              curop->op_type == OP_PADANY) {
3488                         SV **svp = AvARRAY(PL_comppad_name);
3489                         SV *sv = svp[curop->op_targ];
3490                         if (SvCUR(sv) == PL_generation)
3491                             break;
3492                         SvCUR(sv) = PL_generation;      /* (SvCUR not used any more) */
3493                     }
3494                     else if (curop->op_type == OP_RV2CV)
3495                         break;
3496                     else if (curop->op_type == OP_RV2SV ||
3497                              curop->op_type == OP_RV2AV ||
3498                              curop->op_type == OP_RV2HV ||
3499                              curop->op_type == OP_RV2GV) {
3500                         if (lastop->op_type != OP_GV)   /* funny deref? */
3501                             break;
3502                     }
3503                     else if (curop->op_type == OP_PUSHRE) {
3504                         if (((PMOP*)curop)->op_pmreplroot) {
3505 #ifdef USE_ITHREADS
3506                             GV *gv = (GV*)PL_curpad[(PADOFFSET)((PMOP*)curop)->op_pmreplroot];
3507 #else
3508                             GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3509 #endif
3510                             if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3511                                 break;
3512                             SvCUR(gv) = PL_generation;
3513                         }
3514                     }
3515                     else
3516                         break;
3517                 }
3518                 lastop = curop;
3519             }
3520             if (curop != o)
3521                 o->op_private |= OPpASSIGN_COMMON;
3522         }
3523         if (right && right->op_type == OP_SPLIT) {
3524             OP* tmpop;
3525             if ((tmpop = ((LISTOP*)right)->op_first) &&
3526                 tmpop->op_type == OP_PUSHRE)
3527             {
3528                 PMOP *pm = (PMOP*)tmpop;
3529                 if (left->op_type == OP_RV2AV &&
3530                     !(left->op_private & OPpLVAL_INTRO) &&
3531                     !(o->op_private & OPpASSIGN_COMMON) )
3532                 {
3533                     tmpop = ((UNOP*)left)->op_first;
3534                     if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3535 #ifdef USE_ITHREADS
3536                         pm->op_pmreplroot = (OP*)cPADOPx(tmpop)->op_padix;
3537                         cPADOPx(tmpop)->op_padix = 0;   /* steal it */
3538 #else
3539                         pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3540                         cSVOPx(tmpop)->op_sv = Nullsv;  /* steal it */
3541 #endif
3542                         pm->op_pmflags |= PMf_ONCE;
3543                         tmpop = cUNOPo->op_first;       /* to list (nulled) */
3544                         tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3545                         tmpop->op_sibling = Nullop;     /* don't free split */
3546                         right->op_next = tmpop->op_next;  /* fix starting loc */
3547                         op_free(o);                     /* blow off assign */
3548                         right->op_flags &= ~OPf_WANT;
3549                                 /* "I don't know and I don't care." */
3550                         return right;
3551                     }
3552                 }
3553                 else {
3554                    if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3555                       ((LISTOP*)right)->op_last->op_type == OP_CONST)
3556                     {
3557                         SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3558                         if (SvIVX(sv) == 0)
3559                             sv_setiv(sv, PL_modcount+1);
3560                     }
3561                 }
3562             }
3563         }
3564         return o;
3565     }
3566     if (!right)
3567         right = newOP(OP_UNDEF, 0);
3568     if (right->op_type == OP_READLINE) {
3569         right->op_flags |= OPf_STACKED;
3570         return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3571     }
3572     else {
3573         PL_eval_start = right;  /* Grandfathering $[ assignment here.  Bletch.*/
3574         o = newBINOP(OP_SASSIGN, flags,
3575             scalar(right), mod(scalar(left), OP_SASSIGN) );
3576         if (PL_eval_start)
3577             PL_eval_start = 0;
3578         else {
3579             op_free(o);
3580             return Nullop;
3581         }
3582     }
3583     return o;
3584 }
3585
3586 OP *
3587 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3588 {
3589     U32 seq = intro_my();
3590     register COP *cop;
3591
3592     NewOp(1101, cop, 1, COP);
3593     if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3594         cop->op_type = OP_DBSTATE;
3595         cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3596     }
3597     else {
3598         cop->op_type = OP_NEXTSTATE;
3599         cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3600     }
3601     cop->op_flags = flags;
3602     cop->op_private = (PL_hints & HINT_BYTE);
3603 #ifdef NATIVE_HINTS
3604     cop->op_private |= NATIVE_HINTS;
3605 #endif
3606     PL_compiling.op_private = cop->op_private;
3607     cop->op_next = (OP*)cop;
3608
3609     if (label) {
3610         cop->cop_label = label;
3611         PL_hints |= HINT_BLOCK_SCOPE;
3612     }
3613     cop->cop_seq = seq;
3614     cop->cop_arybase = PL_curcop->cop_arybase;
3615     if (specialWARN(PL_curcop->cop_warnings))
3616         cop->cop_warnings = PL_curcop->cop_warnings ;
3617     else
3618         cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3619     if (specialCopIO(PL_curcop->cop_io))
3620         cop->cop_io = PL_curcop->cop_io;
3621     else
3622         cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3623
3624
3625     if (PL_copline == NOLINE)
3626         CopLINE_set(cop, CopLINE(PL_curcop));
3627     else {
3628         CopLINE_set(cop, PL_copline);
3629         PL_copline = NOLINE;
3630     }
3631 #ifdef USE_ITHREADS
3632     CopFILE_set(cop, CopFILE(PL_curcop));       /* XXX share in a pvtable? */
3633 #else
3634     CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3635 #endif
3636     CopSTASH_set(cop, PL_curstash);
3637
3638     if (PERLDB_LINE && PL_curstash != PL_debstash) {
3639         SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3640         if (svp && *svp != &PL_sv_undef && !SvIOK(*svp)) {
3641             (void)SvIOK_on(*svp);
3642             SvIVX(*svp) = PTR2IV(cop);
3643         }
3644     }
3645
3646     return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3647 }
3648
3649 /* "Introduce" my variables to visible status. */
3650 U32
3651 Perl_intro_my(pTHX)
3652 {
3653     SV **svp;
3654     SV *sv;
3655     I32 i;
3656
3657     if (! PL_min_intro_pending)
3658         return PL_cop_seqmax;
3659
3660     svp = AvARRAY(PL_comppad_name);
3661     for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
3662         if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) {
3663             SvIVX(sv) = PAD_MAX;        /* Don't know scope end yet. */
3664             SvNVX(sv) = (NV)PL_cop_seqmax;
3665         }
3666     }
3667     PL_min_intro_pending = 0;
3668     PL_comppad_name_fill = PL_max_intro_pending;        /* Needn't search higher */
3669     return PL_cop_seqmax++;
3670 }
3671
3672 OP *
3673 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3674 {
3675     return new_logop(type, flags, &first, &other);
3676 }
3677
3678 STATIC OP *
3679 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3680 {
3681     LOGOP *logop;
3682     OP *o;
3683     OP *first = *firstp;
3684     OP *other = *otherp;
3685
3686     if (type == OP_XOR)         /* Not short circuit, but here by precedence. */
3687         return newBINOP(type, flags, scalar(first), scalar(other));
3688
3689     scalarboolean(first);
3690     /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3691     if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3692         if (type == OP_AND || type == OP_OR) {
3693             if (type == OP_AND)
3694                 type = OP_OR;
3695             else
3696                 type = OP_AND;
3697             o = first;
3698             first = *firstp = cUNOPo->op_first;
3699             if (o->op_next)
3700                 first->op_next = o->op_next;
3701             cUNOPo->op_first = Nullop;
3702             op_free(o);
3703         }
3704     }
3705     if (first->op_type == OP_CONST) {
3706         if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3707             Perl_warner(aTHX_ WARN_BAREWORD, "Bareword found in conditional");
3708         if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3709             op_free(first);
3710             *firstp = Nullop;
3711             return other;
3712         }
3713         else {
3714             op_free(other);
3715             *otherp = Nullop;
3716             return first;
3717         }
3718     }
3719     else if (first->op_type == OP_WANTARRAY) {
3720         if (type == OP_AND)
3721             list(other);
3722         else
3723             scalar(other);
3724     }
3725     else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
3726         OP *k1 = ((UNOP*)first)->op_first;
3727         OP *k2 = k1->op_sibling;
3728         OPCODE warnop = 0;
3729         switch (first->op_type)
3730         {
3731         case OP_NULL:
3732             if (k2 && k2->op_type == OP_READLINE
3733                   && (k2->op_flags & OPf_STACKED)
3734                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3735             {
3736                 warnop = k2->op_type;
3737             }
3738             break;
3739
3740         case OP_SASSIGN:
3741             if (k1->op_type == OP_READDIR
3742                   || k1->op_type == OP_GLOB
3743                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3744                   || k1->op_type == OP_EACH)
3745             {
3746                 warnop = ((k1->op_type == OP_NULL)
3747                           ? k1->op_targ : k1->op_type);
3748             }
3749             break;
3750         }
3751         if (warnop) {
3752             line_t oldline = CopLINE(PL_curcop);
3753             CopLINE_set(PL_curcop, PL_copline);
3754             Perl_warner(aTHX_ WARN_MISC,
3755                  "Value of %s%s can be \"0\"; test with defined()",
3756                  PL_op_desc[warnop],
3757                  ((warnop == OP_READLINE || warnop == OP_GLOB)
3758                   ? " construct" : "() operator"));
3759             CopLINE_set(PL_curcop, oldline);
3760         }
3761     }
3762
3763     if (!other)
3764         return first;
3765
3766     if (type == OP_ANDASSIGN || type == OP_ORASSIGN)
3767         other->op_private |= OPpASSIGN_BACKWARDS;  /* other is an OP_SASSIGN */
3768
3769     NewOp(1101, logop, 1, LOGOP);
3770
3771     logop->op_type = type;
3772     logop->op_ppaddr = PL_ppaddr[type];
3773     logop->op_first = first;
3774     logop->op_flags = flags | OPf_KIDS;
3775     logop->op_other = LINKLIST(other);
3776     logop->op_private = 1 | (flags >> 8);
3777
3778     /* establish postfix order */
3779     logop->op_next = LINKLIST(first);
3780     first->op_next = (OP*)logop;
3781     first->op_sibling = other;
3782
3783     o = newUNOP(OP_NULL, 0, (OP*)logop);
3784     other->op_next = o;
3785
3786     return o;
3787 }
3788
3789 OP *
3790 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3791 {
3792     LOGOP *logop;
3793     OP *start;
3794     OP *o;
3795
3796     if (!falseop)
3797         return newLOGOP(OP_AND, 0, first, trueop);
3798     if (!trueop)
3799         return newLOGOP(OP_OR, 0, first, falseop);
3800
3801     scalarboolean(first);
3802     if (first->op_type == OP_CONST) {
3803         if (SvTRUE(((SVOP*)first)->op_sv)) {
3804             op_free(first);
3805             op_free(falseop);
3806             return trueop;
3807         }
3808         else {
3809             op_free(first);
3810             op_free(trueop);
3811             return falseop;
3812         }
3813     }
3814     else if (first->op_type == OP_WANTARRAY) {
3815         list(trueop);
3816         scalar(falseop);
3817     }
3818     NewOp(1101, logop, 1, LOGOP);
3819     logop->op_type = OP_COND_EXPR;
3820     logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3821     logop->op_first = first;
3822     logop->op_flags = flags | OPf_KIDS;
3823     logop->op_private = 1 | (flags >> 8);
3824     logop->op_other = LINKLIST(trueop);
3825     logop->op_next = LINKLIST(falseop);
3826
3827
3828     /* establish postfix order */
3829     start = LINKLIST(first);
3830     first->op_next = (OP*)logop;
3831
3832     first->op_sibling = trueop;
3833     trueop->op_sibling = falseop;
3834     o = newUNOP(OP_NULL, 0, (OP*)logop);
3835
3836     trueop->op_next = falseop->op_next = o;
3837
3838     o->op_next = start;
3839     return o;
3840 }
3841
3842 OP *
3843 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3844 {
3845     LOGOP *range;
3846     OP *flip;
3847     OP *flop;
3848     OP *leftstart;
3849     OP *o;
3850
3851     NewOp(1101, range, 1, LOGOP);
3852
3853     range->op_type = OP_RANGE;
3854     range->op_ppaddr = PL_ppaddr[OP_RANGE];
3855     range->op_first = left;
3856     range->op_flags = OPf_KIDS;
3857     leftstart = LINKLIST(left);
3858     range->op_other = LINKLIST(right);
3859     range->op_private = 1 | (flags >> 8);
3860
3861     left->op_sibling = right;
3862
3863     range->op_next = (OP*)range;
3864     flip = newUNOP(OP_FLIP, flags, (OP*)range);
3865     flop = newUNOP(OP_FLOP, 0, flip);
3866     o = newUNOP(OP_NULL, 0, flop);
3867     linklist(flop);
3868     range->op_next = leftstart;
3869
3870     left->op_next = flip;
3871     right->op_next = flop;
3872
3873     range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3874     sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3875     flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3876     sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3877
3878     flip->op_private =  left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3879     flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3880
3881     flip->op_next = o;
3882     if (!flip->op_private || !flop->op_private)
3883         linklist(o);            /* blow off optimizer unless constant */
3884
3885     return o;
3886 }
3887
3888 OP *
3889 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3890 {
3891     OP* listop;
3892     OP* o;
3893     int once = block && block->op_flags & OPf_SPECIAL &&
3894       (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3895
3896     if (expr) {
3897         if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3898             return block;       /* do {} while 0 does once */
3899         if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3900             || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3901             expr = newUNOP(OP_DEFINED, 0,
3902                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3903         } else if (expr->op_flags & OPf_KIDS) {
3904             OP *k1 = ((UNOP*)expr)->op_first;
3905             OP *k2 = (k1) ? k1->op_sibling : NULL;
3906             switch (expr->op_type) {
3907               case OP_NULL:
3908                 if (k2 && k2->op_type == OP_READLINE
3909                       && (k2->op_flags & OPf_STACKED)
3910                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3911                     expr = newUNOP(OP_DEFINED, 0, expr);
3912                 break;
3913
3914               case OP_SASSIGN:
3915                 if (k1->op_type == OP_READDIR
3916                       || k1->op_type == OP_GLOB
3917                       || (k1->op_type == OP_NULL && k1->op_targ == OP_NULL)
3918                       || k1->op_type == OP_EACH)
3919                     expr = newUNOP(OP_DEFINED, 0, expr);
3920                 break;
3921             }
3922         }
3923     }
3924
3925     listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3926     o = new_logop(OP_AND, 0, &expr, &listop);
3927
3928     if (listop)
3929         ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3930
3931     if (once && o != listop)
3932         o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3933
3934     if (o == listop)
3935         o = newUNOP(OP_NULL, 0, o);     /* or do {} while 1 loses outer block */
3936
3937     o->op_flags |= flags;
3938     o = scope(o);
3939     o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3940     return o;
3941 }
3942
3943 OP *
3944 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
3945 {
3946     OP *redo;
3947     OP *next = 0;
3948     OP *listop;
3949     OP *o;
3950     OP *condop;
3951     U8 loopflags = 0;
3952
3953     if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3954                  || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3955         expr = newUNOP(OP_DEFINED, 0,
3956             newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3957     } else if (expr && (expr->op_flags & OPf_KIDS)) {
3958         OP *k1 = ((UNOP*)expr)->op_first;
3959         OP *k2 = (k1) ? k1->op_sibling : NULL;
3960         switch (expr->op_type) {
3961           case OP_NULL:
3962             if (k2 && k2->op_type == OP_READLINE
3963                   && (k2->op_flags & OPf_STACKED)
3964                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3965                 expr = newUNOP(OP_DEFINED, 0, expr);
3966             break;
3967
3968           case OP_SASSIGN:
3969             if (k1->op_type == OP_READDIR
3970                   || k1->op_type == OP_GLOB
3971                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3972                   || k1->op_type == OP_EACH)
3973                 expr = newUNOP(OP_DEFINED, 0, expr);
3974             break;
3975         }
3976     }
3977
3978     if (!block)
3979         block = newOP(OP_NULL, 0);
3980     else if (cont) {
3981         block = scope(block);
3982     }
3983
3984     if (cont) {
3985         next = LINKLIST(cont);
3986     }
3987     if (expr) {
3988         OP *unstack = newOP(OP_UNSTACK, 0);
3989         if (!next)
3990             next = unstack;
3991         cont = append_elem(OP_LINESEQ, cont, unstack);
3992         if ((line_t)whileline != NOLINE) {
3993             PL_copline = whileline;
3994             cont = append_elem(OP_LINESEQ, cont,
3995                                newSTATEOP(0, Nullch, Nullop));
3996         }
3997     }
3998
3999     listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4000     redo = LINKLIST(listop);
4001
4002     if (expr) {
4003         PL_copline = whileline;
4004         scalar(listop);
4005         o = new_logop(OP_AND, 0, &expr, &listop);
4006         if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4007             op_free(expr);              /* oops, it's a while (0) */
4008             op_free((OP*)loop);
4009             return Nullop;              /* listop already freed by new_logop */
4010         }
4011         if (listop)
4012             ((LISTOP*)listop)->op_last->op_next = condop =
4013                 (o == listop ? redo : LINKLIST(o));
4014     }
4015     else
4016         o = listop;
4017
4018     if (!loop) {
4019         NewOp(1101,loop,1,LOOP);
4020         loop->op_type = OP_ENTERLOOP;
4021         loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4022         loop->op_private = 0;
4023         loop->op_next = (OP*)loop;
4024     }
4025
4026     o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4027
4028     loop->op_redoop = redo;
4029     loop->op_lastop = o;
4030     o->op_private |= loopflags;
4031
4032     if (next)
4033         loop->op_nextop = next;
4034     else
4035         loop->op_nextop = o;
4036
4037     o->op_flags |= flags;
4038     o->op_private |= (flags >> 8);
4039     return o;
4040 }
4041
4042 OP *
4043 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
4044 {
4045     LOOP *loop;
4046     OP *wop;
4047     int padoff = 0;
4048     I32 iterflags = 0;
4049
4050     if (sv) {
4051         if (sv->op_type == OP_RV2SV) {  /* symbol table variable */
4052             sv->op_type = OP_RV2GV;
4053             sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4054         }
4055         else if (sv->op_type == OP_PADSV) { /* private variable */
4056             padoff = sv->op_targ;
4057             sv->op_targ = 0;
4058             op_free(sv);
4059             sv = Nullop;
4060         }
4061         else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4062             padoff = sv->op_targ;
4063             sv->op_targ = 0;
4064             iterflags |= OPf_SPECIAL;
4065             op_free(sv);
4066             sv = Nullop;
4067         }
4068         else
4069             Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4070     }
4071     else {
4072 #ifdef USE_THREADS
4073         padoff = find_threadsv("_");
4074         iterflags |= OPf_SPECIAL;
4075 #else
4076         sv = newGVOP(OP_GV, 0, PL_defgv);
4077 #endif
4078     }
4079     if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4080         expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4081         iterflags |= OPf_STACKED;
4082     }
4083     else if (expr->op_type == OP_NULL &&
4084              (expr->op_flags & OPf_KIDS) &&
4085              ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4086     {
4087         /* Basically turn for($x..$y) into the same as for($x,$y), but we
4088          * set the STACKED flag to indicate that these values are to be
4089          * treated as min/max values by 'pp_iterinit'.
4090          */
4091         UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4092         LOGOP* range = (LOGOP*) flip->op_first;
4093         OP* left  = range->op_first;
4094         OP* right = left->op_sibling;
4095         LISTOP* listop;
4096
4097         range->op_flags &= ~OPf_KIDS;
4098         range->op_first = Nullop;
4099
4100         listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4101         listop->op_first->op_next = range->op_next;
4102         left->op_next = range->op_other;
4103         right->op_next = (OP*)listop;
4104         listop->op_next = listop->op_first;
4105
4106         op_free(expr);
4107         expr = (OP*)(listop);
4108         null(expr);
4109         iterflags |= OPf_STACKED;
4110     }
4111     else {
4112         expr = mod(force_list(expr), OP_GREPSTART);
4113     }
4114
4115
4116     loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4117                                append_elem(OP_LIST, expr, scalar(sv))));
4118     assert(!loop->op_next);
4119 #ifdef PL_OP_SLAB_ALLOC
4120     {
4121         LOOP *tmp;
4122         NewOp(1234,tmp,1,LOOP);
4123         Copy(loop,tmp,1,LOOP);
4124         loop = tmp;
4125     }
4126 #else
4127     Renew(loop, 1, LOOP);
4128 #endif
4129     loop->op_targ = padoff;
4130     wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
4131     PL_copline = forline;
4132     return newSTATEOP(0, label, wop);
4133 }
4134
4135 OP*
4136 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4137 {
4138     OP *o;
4139     STRLEN n_a;
4140
4141     if (type != OP_GOTO || label->op_type == OP_CONST) {
4142         /* "last()" means "last" */
4143         if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4144             o = newOP(type, OPf_SPECIAL);
4145         else {
4146             o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4147                                         ? SvPVx(((SVOP*)label)->op_sv, n_a)
4148                                         : ""));
4149         }
4150         op_free(label);
4151     }
4152     else {
4153         if (label->op_type == OP_ENTERSUB)
4154             label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4155         o = newUNOP(type, OPf_STACKED, label);
4156     }
4157     PL_hints |= HINT_BLOCK_SCOPE;
4158     return o;
4159 }
4160
4161 void
4162 Perl_cv_undef(pTHX_ CV *cv)
4163 {
4164 #ifdef USE_THREADS
4165     if (CvMUTEXP(cv)) {
4166         MUTEX_DESTROY(CvMUTEXP(cv));
4167         Safefree(CvMUTEXP(cv));
4168         CvMUTEXP(cv) = 0;
4169     }
4170 #endif /* USE_THREADS */
4171
4172     if (!CvXSUB(cv) && CvROOT(cv)) {
4173 #ifdef USE_THREADS
4174         if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr))
4175             Perl_croak(aTHX_ "Can't undef active subroutine");
4176 #else
4177         if (CvDEPTH(cv))
4178             Perl_croak(aTHX_ "Can't undef active subroutine");
4179 #endif /* USE_THREADS */
4180         ENTER;
4181
4182         SAVEVPTR(PL_curpad);
4183         PL_curpad = 0;
4184
4185         op_free(CvROOT(cv));
4186         CvROOT(cv) = Nullop;
4187         LEAVE;
4188     }
4189     SvPOK_off((SV*)cv);         /* forget prototype */
4190     CvGV(cv) = Nullgv;
4191     /* Since closure prototypes have the same lifetime as the containing
4192      * CV, they don't hold a refcount on the outside CV.  This avoids
4193      * the refcount loop between the outer CV (which keeps a refcount to
4194      * the closure prototype in the pad entry for pp_anoncode()) and the
4195      * closure prototype, and the ensuing memory leak.  --GSAR */
4196     if (!CvANON(cv) || CvCLONED(cv))
4197         SvREFCNT_dec(CvOUTSIDE(cv));
4198     CvOUTSIDE(cv) = Nullcv;
4199     if (CvCONST(cv)) {
4200         SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4201         CvCONST_off(cv);
4202     }
4203     if (CvPADLIST(cv)) {
4204         /* may be during global destruction */
4205         if (SvREFCNT(CvPADLIST(cv))) {
4206             I32 i = AvFILLp(CvPADLIST(cv));
4207             while (i >= 0) {
4208                 SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE);
4209                 SV* sv = svp ? *svp : Nullsv;
4210                 if (!sv)
4211                     continue;
4212                 if (sv == (SV*)PL_comppad_name)
4213                     PL_comppad_name = Nullav;
4214                 else if (sv == (SV*)PL_comppad) {
4215                     PL_comppad = Nullav;
4216                     PL_curpad = Null(SV**);
4217                 }
4218                 SvREFCNT_dec(sv);
4219             }
4220             SvREFCNT_dec((SV*)CvPADLIST(cv));
4221         }
4222         CvPADLIST(cv) = Nullav;
4223     }
4224     CvFLAGS(cv) = 0;
4225 }
4226
4227 #ifdef DEBUG_CLOSURES
4228 STATIC void
4229 S_cv_dump(pTHX_ CV *cv)
4230 {
4231 #ifdef DEBUGGING
4232     CV *outside = CvOUTSIDE(cv);
4233     AV* padlist = CvPADLIST(cv);
4234     AV* pad_name;
4235     AV* pad;
4236     SV** pname;
4237     SV** ppad;
4238     I32 ix;
4239
4240     PerlIO_printf(Perl_debug_log,
4241                   "\tCV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
4242                   PTR2UV(cv),
4243                   (CvANON(cv) ? "ANON"
4244                    : (cv == PL_main_cv) ? "MAIN"
4245                    : CvUNIQUE(cv) ? "UNIQUE"
4246                    : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
4247                   PTR2UV(outside),
4248                   (!outside ? "null"
4249                    : CvANON(outside) ? "ANON"
4250                    : (outside == PL_main_cv) ? "MAIN"
4251                    : CvUNIQUE(outside) ? "UNIQUE"
4252                    : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
4253
4254     if (!padlist)
4255         return;
4256
4257     pad_name = (AV*)*av_fetch(padlist, 0, FALSE);
4258     pad = (AV*)*av_fetch(padlist, 1, FALSE);
4259     pname = AvARRAY(pad_name);
4260     ppad = AvARRAY(pad);
4261
4262     for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
4263         if (SvPOK(pname[ix]))
4264             PerlIO_printf(Perl_debug_log,
4265                           "\t%4d. 0x%"UVxf" (%s\"%s\" %"IVdf"-%"IVdf")\n",
4266                           (int)ix, PTR2UV(ppad[ix]),
4267                           SvFAKE(pname[ix]) ? "FAKE " : "",
4268                           SvPVX(pname[ix]),
4269                           (IV)I_32(SvNVX(pname[ix])),
4270                           SvIVX(pname[ix]));
4271     }
4272 #endif /* DEBUGGING */
4273 }
4274 #endif /* DEBUG_CLOSURES */
4275
4276 STATIC CV *
4277 S_cv_clone2(pTHX_ CV *proto, CV *outside)
4278 {
4279     AV* av;
4280     I32 ix;
4281     AV* protopadlist = CvPADLIST(proto);
4282     AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
4283     AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
4284     SV** pname = AvARRAY(protopad_name);
4285     SV** ppad = AvARRAY(protopad);
4286     I32 fname = AvFILLp(protopad_name);
4287     I32 fpad = AvFILLp(protopad);
4288     AV* comppadlist;
4289     CV* cv;
4290
4291     assert(!CvUNIQUE(proto));
4292
4293     ENTER;
4294     SAVECOMPPAD();
4295     SAVESPTR(PL_comppad_name);
4296     SAVESPTR(PL_compcv);
4297
4298     cv = PL_compcv = (CV*)NEWSV(1104,0);
4299     sv_upgrade((SV *)cv, SvTYPE(proto));
4300     CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
4301     CvCLONED_on(cv);
4302
4303 #ifdef USE_THREADS
4304     New(666, CvMUTEXP(cv), 1, perl_mutex);
4305     MUTEX_INIT(CvMUTEXP(cv));
4306     CvOWNER(cv)         = 0;
4307 #endif /* USE_THREADS */
4308     CvFILE(cv)          = CvFILE(proto);
4309     CvGV(cv)            = CvGV(proto);
4310     CvSTASH(cv)         = CvSTASH(proto);
4311     CvROOT(cv)          = OpREFCNT_inc(CvROOT(proto));
4312     CvSTART(cv)         = CvSTART(proto);
4313     if (outside)
4314         CvOUTSIDE(cv)   = (CV*)SvREFCNT_inc(outside);
4315
4316     if (SvPOK(proto))
4317         sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
4318
4319     PL_comppad_name = newAV();
4320     for (ix = fname; ix >= 0; ix--)
4321         av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
4322
4323     PL_comppad = newAV();
4324
4325     comppadlist = newAV();
4326     AvREAL_off(comppadlist);
4327     av_store(comppadlist, 0, (SV*)PL_comppad_name);
4328     av_store(comppadlist, 1, (SV*)PL_comppad);
4329     CvPADLIST(cv) = comppadlist;
4330     av_fill(PL_comppad, AvFILLp(protopad));
4331     PL_curpad = AvARRAY(PL_comppad);
4332
4333     av = newAV();           /* will be @_ */
4334     av_extend(av, 0);
4335     av_store(PL_comppad, 0, (SV*)av);
4336     AvFLAGS(av) = AVf_REIFY;
4337
4338     for (ix = fpad; ix > 0; ix--) {
4339         SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4340         if (namesv && namesv != &PL_sv_undef) {
4341             char *name = SvPVX(namesv);    /* XXX */
4342             if (SvFLAGS(namesv) & SVf_FAKE) {   /* lexical from outside? */
4343                 I32 off = pad_findlex(name, ix, SvIVX(namesv),
4344                                       CvOUTSIDE(cv), cxstack_ix, 0, 0);
4345                 if (!off)
4346                     PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4347                 else if (off != ix)
4348                     Perl_croak(aTHX_ "panic: cv_clone: %s", name);
4349             }
4350             else {                              /* our own lexical */
4351                 SV* sv;
4352                 if (*name == '&') {
4353                     /* anon code -- we'll come back for it */
4354                     sv = SvREFCNT_inc(ppad[ix]);
4355                 }
4356                 else if (*name == '@')
4357                     sv = (SV*)newAV();
4358                 else if (*name == '%')
4359                     sv = (SV*)newHV();
4360                 else
4361                     sv = NEWSV(0,0);
4362                 if (!SvPADBUSY(sv))
4363                     SvPADMY_on(sv);
4364                 PL_curpad[ix] = sv;
4365             }
4366         }
4367         else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
4368             PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4369         }
4370         else {
4371             SV* sv = NEWSV(0,0);
4372             SvPADTMP_on(sv);
4373             PL_curpad[ix] = sv;
4374         }
4375     }
4376
4377     /* Now that vars are all in place, clone nested closures. */
4378
4379     for (ix = fpad; ix > 0; ix--) {
4380         SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4381         if (namesv
4382             && namesv != &PL_sv_undef
4383             && !(SvFLAGS(namesv) & SVf_FAKE)
4384             && *SvPVX(namesv) == '&'
4385             && CvCLONE(ppad[ix]))
4386         {
4387             CV *kid = cv_clone2((CV*)ppad[ix], cv);
4388             SvREFCNT_dec(ppad[ix]);
4389             CvCLONE_on(kid);
4390             SvPADMY_on(kid);
4391             PL_curpad[ix] = (SV*)kid;
4392         }
4393     }
4394
4395 #ifdef DEBUG_CLOSURES
4396     PerlIO_printf(Perl_debug_log, "Cloned inside:\n");
4397     cv_dump(outside);
4398     PerlIO_printf(Perl_debug_log, "  from:\n");
4399     cv_dump(proto);
4400     PerlIO_printf(Perl_debug_log, "   to:\n");
4401     cv_dump(cv);
4402 #endif
4403
4404     LEAVE;
4405
4406     if (CvCONST(cv)) {
4407         SV* const_sv = op_const_sv(CvSTART(cv), cv);
4408         assert(const_sv);
4409         /* constant sub () { $x } closing over $x - see lib/constant.pm */
4410         SvREFCNT_dec(cv);
4411         cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
4412     }
4413
4414     return cv;
4415 }
4416
4417 CV *
4418 Perl_cv_clone(pTHX_ CV *proto)
4419 {
4420     CV *cv;
4421     LOCK_CRED_MUTEX;                    /* XXX create separate mutex */
4422     cv = cv_clone2(proto, CvOUTSIDE(proto));
4423     UNLOCK_CRED_MUTEX;                  /* XXX create separate mutex */
4424     return cv;
4425 }
4426
4427 void
4428 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
4429 {
4430     if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4431         SV* msg = sv_newmortal();
4432         SV* name = Nullsv;
4433
4434         if (gv)
4435             gv_efullname3(name = sv_newmortal(), gv, Nullch);
4436         sv_setpv(msg, "Prototype mismatch:");
4437         if (name)
4438             Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4439         if (SvPOK(cv))
4440             Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv));
4441         sv_catpv(msg, " vs ");
4442         if (p)
4443             Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4444         else
4445             sv_catpv(msg, "none");
4446         Perl_warner(aTHX_ WARN_PROTOTYPE, "%"SVf, msg);
4447     }
4448 }
4449
4450 static void const_sv_xsub(pTHXo_ CV* cv);
4451
4452 /*
4453 =for apidoc cv_const_sv
4454
4455 If C<cv> is a constant sub eligible for inlining. returns the constant
4456 value returned by the sub.  Otherwise, returns NULL.
4457
4458 Constant subs can be created with C<newCONSTSUB> or as described in
4459 L<perlsub/"Constant Functions">.
4460
4461 =cut
4462 */
4463 SV *
4464 Perl_cv_const_sv(pTHX_ CV *cv)
4465 {
4466     if (!cv || !CvCONST(cv))
4467         return Nullsv;
4468     return (SV*)CvXSUBANY(cv).any_ptr;
4469 }
4470
4471 SV *
4472 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
4473 {
4474     SV *sv = Nullsv;
4475
4476     if (!o)
4477         return Nullsv;
4478
4479     if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4480         o = cLISTOPo->op_first->op_sibling;
4481
4482     for (; o; o = o->op_next) {
4483         OPCODE type = o->op_type;
4484
4485         if (sv && o->op_next == o)
4486             return sv;
4487         if (o->op_next != o) {
4488             if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4489                 continue;
4490             if (type == OP_DBSTATE)
4491                 continue;
4492         }
4493         if (type == OP_LEAVESUB || type == OP_RETURN)
4494             break;
4495         if (sv)
4496             return Nullsv;
4497         if (type == OP_CONST && cSVOPo->op_sv)
4498             sv = cSVOPo->op_sv;
4499         else if ((type == OP_PADSV || type == OP_CONST) && cv) {
4500             AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
4501             sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
4502             if (!sv)
4503                 return Nullsv;
4504             if (CvCONST(cv)) {
4505                 /* We get here only from cv_clone2() while creating a closure.
4506                    Copy the const value here instead of in cv_clone2 so that
4507                    SvREADONLY_on doesn't lead to problems when leaving
4508                    scope.
4509                 */
4510                 sv = newSVsv(sv);
4511             }
4512             if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
4513                 return Nullsv;
4514         }
4515         else
4516             return Nullsv;
4517     }
4518     if (sv)
4519         SvREADONLY_on(sv);
4520     return sv;
4521 }
4522
4523 void
4524 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4525 {
4526     if (o)
4527         SAVEFREEOP(o);
4528     if (proto)
4529         SAVEFREEOP(proto);
4530     if (attrs)
4531         SAVEFREEOP(attrs);
4532     if (block)
4533         SAVEFREEOP(block);
4534     Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4535 }
4536
4537 CV *
4538 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4539 {
4540     return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4541 }
4542
4543 CV *
4544 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4545 {
4546     STRLEN n_a;
4547     char *name;
4548     char *aname;
4549     GV *gv;
4550     char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4551     register CV *cv=0;
4552     I32 ix;
4553     SV *const_sv;
4554
4555     name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4556     if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4557         SV *sv = sv_newmortal();
4558         Perl_sv_setpvf(aTHX_ sv, "__ANON__[%s:%"IVdf"]",
4559                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4560         aname = SvPVX(sv);
4561     }
4562     else
4563         aname = Nullch;
4564     gv = gv_fetchpv(name ? name : (aname ? aname : "__ANON__"),
4565                     GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4566                     SVt_PVCV);
4567
4568     if (o)
4569         SAVEFREEOP(o);
4570     if (proto)
4571         SAVEFREEOP(proto);
4572     if (attrs)
4573         SAVEFREEOP(attrs);
4574
4575     if (SvTYPE(gv) != SVt_PVGV) {       /* Maybe prototype now, and had at
4576                                            maximum a prototype before. */
4577         if (SvTYPE(gv) > SVt_NULL) {
4578             if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4579                 && ckWARN_d(WARN_PROTOTYPE))
4580             {
4581                 Perl_warner(aTHX_ WARN_PROTOTYPE, "Runaway prototype");
4582             }
4583             cv_ckproto((CV*)gv, NULL, ps);
4584         }
4585         if (ps)
4586             sv_setpv((SV*)gv, ps);
4587         else
4588             sv_setiv((SV*)gv, -1);
4589         SvREFCNT_dec(PL_compcv);
4590         cv = PL_compcv = NULL;
4591         PL_sub_generation++;
4592         goto done;
4593     }
4594
4595     cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4596
4597 #ifdef GV_SHARED_CHECK
4598     if (cv && GvSHARED(gv) && SvREADONLY(cv)) {
4599         Perl_croak(aTHX_ "Can't define subroutine %s (GV is shared)", name);
4600     }
4601 #endif
4602
4603     if (!block || !ps || *ps || attrs)
4604         const_sv = Nullsv;
4605     else
4606         const_sv = op_const_sv(block, Nullcv);
4607
4608     if (cv) {
4609         bool exists = CvROOT(cv) || CvXSUB(cv);
4610
4611 #ifdef GV_SHARED_CHECK
4612         if (exists && GvSHARED(gv)) {
4613             Perl_croak(aTHX_ "Can't redefine shared subroutine %s", name);
4614         }
4615 #endif
4616
4617         /* if the subroutine doesn't exist and wasn't pre-declared
4618          * with a prototype, assume it will be AUTOLOADed,
4619          * skipping the prototype check
4620          */
4621         if (exists || SvPOK(cv))
4622             cv_ckproto(cv, gv, ps);
4623         /* already defined (or promised)? */
4624         if (exists || GvASSUMECV(gv)) {
4625             if (!block && !attrs) {
4626                 /* just a "sub foo;" when &foo is already defined */
4627                 SAVEFREESV(PL_compcv);
4628                 goto done;
4629             }
4630             /* ahem, death to those who redefine active sort subs */
4631             if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4632                 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4633             if (block) {
4634                 if (ckWARN(WARN_REDEFINE)
4635                     || (CvCONST(cv)
4636                         && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4637                 {
4638                     line_t oldline = CopLINE(PL_curcop);
4639                     CopLINE_set(PL_curcop, PL_copline);
4640                     Perl_warner(aTHX_ WARN_REDEFINE,
4641                         CvCONST(cv) ? "Constant subroutine %s redefined"
4642                                     : "Subroutine %s redefined", name);
4643                     CopLINE_set(PL_curcop, oldline);
4644                 }
4645                 SvREFCNT_dec(cv);
4646                 cv = Nullcv;
4647             }
4648         }
4649     }
4650     if (const_sv) {
4651         SvREFCNT_inc(const_sv);
4652         if (cv) {
4653             assert(!CvROOT(cv) && !CvCONST(cv));
4654             sv_setpv((SV*)cv, "");  /* prototype is "" */
4655             CvXSUBANY(cv).any_ptr = const_sv;
4656             CvXSUB(cv) = const_sv_xsub;
4657             CvCONST_on(cv);
4658         }
4659         else {
4660             GvCV(gv) = Nullcv;
4661             cv = newCONSTSUB(NULL, name, const_sv);
4662         }
4663         op_free(block);
4664         SvREFCNT_dec(PL_compcv);
4665         PL_compcv = NULL;
4666         PL_sub_generation++;
4667         goto done;
4668     }
4669     if (attrs) {
4670         HV *stash;
4671         SV *rcv;
4672
4673         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4674          * before we clobber PL_compcv.
4675          */
4676         if (cv && !block) {
4677             rcv = (SV*)cv;
4678             if (CvGV(cv) && GvSTASH(CvGV(cv)) && HvNAME(GvSTASH(CvGV(cv))))
4679                 stash = GvSTASH(CvGV(cv));
4680             else if (CvSTASH(cv) && HvNAME(CvSTASH(cv)))
4681                 stash = CvSTASH(cv);
4682             else
4683                 stash = PL_curstash;
4684         }
4685         else {
4686             /* possibly about to re-define existing subr -- ignore old cv */
4687             rcv = (SV*)PL_compcv;
4688             if (name && GvSTASH(gv) && HvNAME(GvSTASH(gv)))
4689                 stash = GvSTASH(gv);
4690             else
4691                 stash = PL_curstash;
4692         }
4693         apply_attrs(stash, rcv, attrs);
4694     }
4695     if (cv) {                           /* must reuse cv if autoloaded */
4696         if (!block) {
4697             /* got here with just attrs -- work done, so bug out */
4698             SAVEFREESV(PL_compcv);
4699             goto done;
4700         }
4701         cv_undef(cv);
4702         CvFLAGS(cv) = CvFLAGS(PL_compcv);
4703         CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4704         CvOUTSIDE(PL_compcv) = 0;
4705         CvPADLIST(cv) = CvPADLIST(PL_compcv);
4706         CvPADLIST(PL_compcv) = 0;
4707         /* inner references to PL_compcv must be fixed up ... */
4708         {
4709             AV *padlist = CvPADLIST(cv);
4710             AV *comppad_name = (AV*)AvARRAY(padlist)[0];
4711             AV *comppad = (AV*)AvARRAY(padlist)[1];
4712             SV **namepad = AvARRAY(comppad_name);
4713             SV **curpad = AvARRAY(comppad);
4714             for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
4715                 SV *namesv = namepad[ix];
4716                 if (namesv && namesv != &PL_sv_undef
4717                     && *SvPVX(namesv) == '&')
4718                 {
4719                     CV *innercv = (CV*)curpad[ix];
4720                     if (CvOUTSIDE(innercv) == PL_compcv) {
4721                         CvOUTSIDE(innercv) = cv;
4722                         if (!CvANON(innercv) || CvCLONED(innercv)) {
4723                             (void)SvREFCNT_inc(cv);
4724                             SvREFCNT_dec(PL_compcv);
4725                         }
4726                     }
4727                 }
4728             }
4729         }
4730         /* ... before we throw it away */
4731         SvREFCNT_dec(PL_compcv);
4732     }
4733     else {
4734         cv = PL_compcv;
4735         if (name) {
4736             GvCV(gv) = cv;
4737             GvCVGEN(gv) = 0;
4738             PL_sub_generation++;
4739         }
4740     }
4741     CvGV(cv) = gv;
4742     CvFILE(cv) = CopFILE(PL_curcop);
4743     CvSTASH(cv) = PL_curstash;
4744 #ifdef USE_THREADS
4745     CvOWNER(cv) = 0;
4746     if (!CvMUTEXP(cv)) {
4747         New(666, CvMUTEXP(cv), 1, perl_mutex);
4748         MUTEX_INIT(CvMUTEXP(cv));
4749     }
4750 #endif /* USE_THREADS */
4751
4752     if (ps)
4753         sv_setpv((SV*)cv, ps);
4754
4755     if (PL_error_count) {
4756         op_free(block);
4757         block = Nullop;
4758         if (name) {
4759             char *s = strrchr(name, ':');
4760             s = s ? s+1 : name;
4761             if (strEQ(s, "BEGIN")) {
4762                 char *not_safe =
4763                     "BEGIN not safe after errors--compilation aborted";
4764                 if (PL_in_eval & EVAL_KEEPERR)
4765                     Perl_croak(aTHX_ not_safe);
4766                 else {
4767                     /* force display of errors found but not reported */
4768                     sv_catpv(ERRSV, not_safe);
4769                     Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
4770                 }
4771             }
4772         }
4773     }
4774     if (!block)
4775         goto done;
4776
4777     if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
4778         av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
4779
4780     if (CvLVALUE(cv)) {
4781         CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4782                              mod(scalarseq(block), OP_LEAVESUBLV));
4783     }
4784     else {
4785         CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4786     }
4787     CvROOT(cv)->op_private |= OPpREFCOUNTED;
4788     OpREFCNT_set(CvROOT(cv), 1);
4789     CvSTART(cv) = LINKLIST(CvROOT(cv));
4790     CvROOT(cv)->op_next = 0;
4791     peep(CvSTART(cv));
4792
4793     /* now that optimizer has done its work, adjust pad values */
4794     if (CvCLONE(cv)) {
4795         SV **namep = AvARRAY(PL_comppad_name);
4796         for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4797             SV *namesv;
4798
4799             if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4800                 continue;
4801             /*
4802              * The only things that a clonable function needs in its
4803              * pad are references to outer lexicals and anonymous subs.
4804              * The rest are created anew during cloning.
4805              */
4806             if (!((namesv = namep[ix]) != Nullsv &&
4807                   namesv != &PL_sv_undef &&
4808                   (SvFAKE(namesv) ||
4809                    *SvPVX(namesv) == '&')))
4810             {
4811                 SvREFCNT_dec(PL_curpad[ix]);
4812                 PL_curpad[ix] = Nullsv;
4813             }
4814         }
4815         assert(!CvCONST(cv));
4816         if (ps && !*ps && op_const_sv(block, cv))
4817             CvCONST_on(cv);
4818     }
4819     else {
4820         AV *av = newAV();                       /* Will be @_ */
4821         av_extend(av, 0);
4822         av_store(PL_comppad, 0, (SV*)av);
4823         AvFLAGS(av) = AVf_REIFY;
4824
4825         for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4826             if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4827                 continue;
4828             if (!SvPADMY(PL_curpad[ix]))
4829                 SvPADTMP_on(PL_curpad[ix]);
4830         }
4831     }
4832
4833     /* If a potential closure prototype, don't keep a refcount on outer CV.
4834      * This is okay as the lifetime of the prototype is tied to the
4835      * lifetime of the outer CV.  Avoids memory leak due to reference
4836      * loop. --GSAR */
4837     if (!name)
4838         SvREFCNT_dec(CvOUTSIDE(cv));
4839
4840     if (name || aname) {
4841         char *s;
4842         char *tname = (name ? name : aname);
4843
4844         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4845             SV *sv = NEWSV(0,0);
4846             SV *tmpstr = sv_newmortal();
4847             GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4848             CV *pcv;
4849             HV *hv;
4850
4851             Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4852                            CopFILE(PL_curcop),
4853                            (long)PL_subline, (long)CopLINE(PL_curcop));
4854             gv_efullname3(tmpstr, gv, Nullch);
4855             hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4856             hv = GvHVn(db_postponed);
4857             if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4858                 && (pcv = GvCV(db_postponed)))
4859             {
4860                 dSP;
4861                 PUSHMARK(SP);
4862                 XPUSHs(tmpstr);
4863                 PUTBACK;
4864                 call_sv((SV*)pcv, G_DISCARD);
4865             }
4866         }
4867
4868         if ((s = strrchr(tname,':')))
4869             s++;
4870         else
4871             s = tname;
4872
4873         if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4874             goto done;
4875
4876         if (strEQ(s, "BEGIN")) {
4877             I32 oldscope = PL_scopestack_ix;
4878             ENTER;
4879             SAVECOPFILE(&PL_compiling);
4880             SAVECOPLINE(&PL_compiling);
4881             save_svref(&PL_rs);
4882             sv_setsv(PL_rs, PL_nrs);
4883
4884             if (!PL_beginav)
4885                 PL_beginav = newAV();
4886             DEBUG_x( dump_sub(gv) );
4887             av_push(PL_beginav, (SV*)cv);
4888             GvCV(gv) = 0;               /* cv has been hijacked */
4889             call_list(oldscope, PL_beginav);
4890
4891             PL_curcop = &PL_compiling;
4892             PL_compiling.op_private = PL_hints;
4893             LEAVE;
4894         }
4895         else if (strEQ(s, "END") && !PL_error_count) {
4896             if (!PL_endav)
4897                 PL_endav = newAV();
4898             DEBUG_x( dump_sub(gv) );
4899             av_unshift(PL_endav, 1);
4900             av_store(PL_endav, 0, (SV*)cv);
4901             GvCV(gv) = 0;               /* cv has been hijacked */
4902         }
4903         else if (strEQ(s, "CHECK") && !PL_error_count) {
4904             if (!PL_checkav)
4905                 PL_checkav = newAV();
4906             DEBUG_x( dump_sub(gv) );
4907             if (PL_main_start && ckWARN(WARN_VOID))
4908                 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
4909             av_unshift(PL_checkav, 1);
4910             av_store(PL_checkav, 0, (SV*)cv);
4911             GvCV(gv) = 0;               /* cv has been hijacked */
4912         }
4913         else if (strEQ(s, "INIT") && !PL_error_count) {
4914             if (!PL_initav)
4915                 PL_initav = newAV();
4916             DEBUG_x( dump_sub(gv) );
4917             if (PL_main_start && ckWARN(WARN_VOID))
4918                 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
4919             av_push(PL_initav, (SV*)cv);
4920             GvCV(gv) = 0;               /* cv has been hijacked */
4921         }
4922     }
4923
4924   done:
4925     PL_copline = NOLINE;
4926     LEAVE_SCOPE(floor);
4927     return cv;
4928 }
4929
4930 /* XXX unsafe for threads if eval_owner isn't held */
4931 /*
4932 =for apidoc newCONSTSUB
4933
4934 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4935 eligible for inlining at compile-time.
4936
4937 =cut
4938 */
4939
4940 CV *
4941 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
4942 {
4943     CV* cv;
4944
4945     ENTER;
4946
4947     SAVECOPLINE(PL_curcop);
4948     CopLINE_set(PL_curcop, PL_copline);
4949
4950     SAVEHINTS();
4951     PL_hints &= ~HINT_BLOCK_SCOPE;
4952
4953     if (stash) {
4954         SAVESPTR(PL_curstash);
4955         SAVECOPSTASH(PL_curcop);
4956         PL_curstash = stash;
4957 #ifdef USE_ITHREADS
4958         CopSTASHPV(PL_curcop) = stash ? HvNAME(stash) : Nullch;
4959 #else
4960         CopSTASH(PL_curcop) = stash;
4961 #endif
4962     }
4963
4964     cv = newXS(name, const_sv_xsub, __FILE__);
4965     CvXSUBANY(cv).any_ptr = sv;
4966     CvCONST_on(cv);
4967     sv_setpv((SV*)cv, "");  /* prototype is "" */
4968
4969     LEAVE;
4970
4971     return cv;
4972 }
4973
4974 /*
4975 =for apidoc U||newXS
4976
4977 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4978
4979 =cut
4980 */
4981
4982 CV *
4983 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
4984 {
4985     GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV);
4986     register CV *cv;
4987
4988     if ((cv = (name ? GvCV(gv) : Nullcv))) {
4989         if (GvCVGEN(gv)) {
4990             /* just a cached method */
4991             SvREFCNT_dec(cv);
4992             cv = 0;
4993         }
4994         else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4995             /* already defined (or promised) */
4996             if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
4997                             && HvNAME(GvSTASH(CvGV(cv)))
4998                             && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
4999                 line_t oldline = CopLINE(PL_curcop);
5000                 if (PL_copline != NOLINE)
5001                     CopLINE_set(PL_curcop, PL_copline);
5002                 Perl_warner(aTHX_ WARN_REDEFINE,
5003                             CvCONST(cv) ? "Constant subroutine %s redefined"
5004                                         : "Subroutine %s redefined"
5005                             ,name);
5006                 CopLINE_set(PL_curcop, oldline);
5007             }
5008             SvREFCNT_dec(cv);
5009             cv = 0;
5010         }
5011     }
5012
5013     if (cv)                             /* must reuse cv if autoloaded */
5014         cv_undef(cv);
5015     else {
5016         cv = (CV*)NEWSV(1105,0);
5017         sv_upgrade((SV *)cv, SVt_PVCV);
5018         if (name) {
5019             GvCV(gv) = cv;
5020             GvCVGEN(gv) = 0;
5021             PL_sub_generation++;
5022         }
5023     }
5024     CvGV(cv) = gv;
5025 #ifdef USE_THREADS
5026     New(666, CvMUTEXP(cv), 1, perl_mutex);
5027     MUTEX_INIT(CvMUTEXP(cv));
5028     CvOWNER(cv) = 0;
5029 #endif /* USE_THREADS */
5030     (void)gv_fetchfile(filename);
5031     CvFILE(cv) = filename;      /* NOTE: not copied, as it is expected to be
5032                                    an external constant string */
5033     CvXSUB(cv) = subaddr;
5034
5035     if (name) {
5036         char *s = strrchr(name,':');
5037         if (s)
5038             s++;
5039         else
5040             s = name;
5041
5042         if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5043             goto done;
5044
5045         if (strEQ(s, "BEGIN")) {
5046             if (!PL_beginav)
5047                 PL_beginav = newAV();
5048             av_push(PL_beginav, (SV*)cv);
5049             GvCV(gv) = 0;               /* cv has been hijacked */
5050         }
5051         else if (strEQ(s, "END")) {
5052             if (!PL_endav)
5053                 PL_endav = newAV();
5054             av_unshift(PL_endav, 1);
5055             av_store(PL_endav, 0, (SV*)cv);
5056             GvCV(gv) = 0;               /* cv has been hijacked */
5057         }
5058         else if (strEQ(s, "CHECK")) {
5059             if (!PL_checkav)
5060                 PL_checkav = newAV();
5061             if (PL_main_start && ckWARN(WARN_VOID))
5062                 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
5063             av_unshift(PL_checkav, 1);
5064             av_store(PL_checkav, 0, (SV*)cv);
5065             GvCV(gv) = 0;               /* cv has been hijacked */
5066         }
5067         else if (strEQ(s, "INIT")) {
5068             if (!PL_initav)
5069                 PL_initav = newAV();
5070             if (PL_main_start && ckWARN(WARN_VOID))
5071                 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
5072             av_push(PL_initav, (SV*)cv);
5073             GvCV(gv) = 0;               /* cv has been hijacked */
5074         }
5075     }
5076     else
5077         CvANON_on(cv);
5078
5079 done:
5080     return cv;
5081 }
5082
5083 void
5084 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5085 {
5086     register CV *cv;
5087     char *name;
5088     GV *gv;
5089     I32 ix;
5090     STRLEN n_a;
5091
5092     if (o)
5093         name = SvPVx(cSVOPo->op_sv, n_a);
5094     else
5095         name = "STDOUT";
5096     gv = gv_fetchpv(name,TRUE, SVt_PVFM);
5097 #ifdef GV_SHARED_CHECK
5098     if (GvSHARED(gv)) {
5099         Perl_croak(aTHX_ "Bad symbol for form (GV is shared)");
5100     }
5101 #endif
5102     GvMULTI_on(gv);
5103     if ((cv = GvFORM(gv))) {
5104         if (ckWARN(WARN_REDEFINE)) {
5105             line_t oldline = CopLINE(PL_curcop);
5106
5107             CopLINE_set(PL_curcop, PL_copline);
5108             Perl_warner(aTHX_ WARN_REDEFINE, "Format %s redefined",name);
5109             CopLINE_set(PL_curcop, oldline);
5110         }
5111         SvREFCNT_dec(cv);
5112     }
5113     cv = PL_compcv;
5114     GvFORM(gv) = cv;
5115     CvGV(cv) = gv;
5116     CvFILE(cv) = CopFILE(PL_curcop);
5117
5118     for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5119         if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
5120             SvPADTMP_on(PL_curpad[ix]);
5121     }
5122
5123     CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5124     CvROOT(cv)->op_private |= OPpREFCOUNTED;
5125     OpREFCNT_set(CvROOT(cv), 1);
5126     CvSTART(cv) = LINKLIST(CvROOT(cv));
5127     CvROOT(cv)->op_next = 0;
5128     peep(CvSTART(cv));
5129     op_free(o);
5130     PL_copline = NOLINE;
5131     LEAVE_SCOPE(floor);
5132 }
5133
5134 OP *
5135 Perl_newANONLIST(pTHX_ OP *o)
5136 {
5137     return newUNOP(OP_REFGEN, 0,
5138         mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5139 }
5140
5141 OP *
5142 Perl_newANONHASH(pTHX_ OP *o)
5143 {
5144     return newUNOP(OP_REFGEN, 0,
5145         mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5146 }
5147
5148 OP *
5149 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5150 {
5151     return newANONATTRSUB(floor, proto, Nullop, block);
5152 }
5153
5154 OP *
5155 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5156 {
5157     return newUNOP(OP_REFGEN, 0,
5158         newSVOP(OP_ANONCODE, 0,
5159                 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5160 }
5161
5162 OP *
5163 Perl_oopsAV(pTHX_ OP *o)
5164 {
5165     switch (o->op_type) {
5166     case OP_PADSV:
5167         o->op_type = OP_PADAV;
5168         o->op_ppaddr = PL_ppaddr[OP_PADAV];
5169         return ref(o, OP_RV2AV);
5170
5171     case OP_RV2SV:
5172         o->op_type = OP_RV2AV;
5173         o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5174         ref(o, OP_RV2AV);
5175         break;
5176
5177     default:
5178         if (ckWARN_d(WARN_INTERNAL))
5179             Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsAV");
5180         break;
5181     }
5182     return o;
5183 }
5184
5185 OP *
5186 Perl_oopsHV(pTHX_ OP *o)
5187 {
5188     switch (o->op_type) {
5189     case OP_PADSV:
5190     case OP_PADAV:
5191         o->op_type = OP_PADHV;
5192         o->op_ppaddr = PL_ppaddr[OP_PADHV];
5193         return ref(o, OP_RV2HV);
5194
5195     case OP_RV2SV:
5196     case OP_RV2AV:
5197         o->op_type = OP_RV2HV;
5198         o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5199         ref(o, OP_RV2HV);
5200         break;
5201
5202     default:
5203         if (ckWARN_d(WARN_INTERNAL))
5204             Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsHV");
5205         break;
5206     }
5207     return o;
5208 }
5209
5210 OP *
5211 Perl_newAVREF(pTHX_ OP *o)
5212 {
5213     if (o->op_type == OP_PADANY) {
5214         o->op_type = OP_PADAV;
5215         o->op_ppaddr = PL_ppaddr[OP_PADAV];
5216         return o;
5217     }
5218     return newUNOP(OP_RV2AV, 0, scalar(o));
5219 }
5220
5221 OP *
5222 Perl_newGVREF(pTHX_ I32 type, OP *o)
5223 {
5224     if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5225         return newUNOP(OP_NULL, 0, o);
5226     return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5227 }
5228
5229 OP *
5230 Perl_newHVREF(pTHX_ OP *o)
5231 {
5232     if (o->op_type == OP_PADANY) {
5233         o->op_type = OP_PADHV;
5234         o->op_ppaddr = PL_ppaddr[OP_PADHV];
5235         return o;
5236     }
5237     return newUNOP(OP_RV2HV, 0, scalar(o));
5238 }
5239
5240 OP *
5241 Perl_oopsCV(pTHX_ OP *o)
5242 {
5243     Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5244     /* STUB */
5245     return o;
5246 }
5247
5248 OP *
5249 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5250 {
5251     return newUNOP(OP_RV2CV, flags, scalar(o));
5252 }
5253
5254 OP *
5255 Perl_newSVREF(pTHX_ OP *o)
5256 {
5257     if (o->op_type == OP_PADANY) {
5258         o->op_type = OP_PADSV;
5259         o->op_ppaddr = PL_ppaddr[OP_PADSV];
5260         return o;
5261     }
5262     else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5263         o->op_flags |= OPpDONE_SVREF;
5264         return o;
5265     }
5266     return newUNOP(OP_RV2SV, 0, scalar(o));
5267 }
5268
5269 /* Check routines. */
5270
5271 OP *
5272 Perl_ck_anoncode(pTHX_ OP *o)
5273 {
5274     PADOFFSET ix;
5275     SV* name;
5276
5277     name = NEWSV(1106,0);
5278     sv_upgrade(name, SVt_PVNV);
5279     sv_setpvn(name, "&", 1);
5280     SvIVX(name) = -1;
5281     SvNVX(name) = 1;
5282     ix = pad_alloc(o->op_type, SVs_PADMY);
5283     av_store(PL_comppad_name, ix, name);
5284     av_store(PL_comppad, ix, cSVOPo->op_sv);
5285     SvPADMY_on(cSVOPo->op_sv);
5286     cSVOPo->op_sv = Nullsv;
5287     cSVOPo->op_targ = ix;
5288     return o;
5289 }
5290
5291 OP *
5292 Perl_ck_bitop(pTHX_ OP *o)
5293 {
5294     o->op_private = PL_hints;
5295     return o;
5296 }
5297
5298 OP *
5299 Perl_ck_concat(pTHX_ OP *o)
5300 {
5301     if (cUNOPo->op_first->op_type == OP_CONCAT)
5302         o->op_flags |= OPf_STACKED;
5303     return o;
5304 }
5305
5306 OP *
5307 Perl_ck_spair(pTHX_ OP *o)
5308 {
5309     if (o->op_flags & OPf_KIDS) {
5310         OP* newop;
5311         OP* kid;
5312         OPCODE type = o->op_type;
5313         o = modkids(ck_fun(o), type);
5314         kid = cUNOPo->op_first;
5315         newop = kUNOP->op_first->op_sibling;
5316         if (newop &&
5317             (newop->op_sibling ||
5318              !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5319              newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5320              newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5321
5322             return o;
5323         }
5324         op_free(kUNOP->op_first);
5325         kUNOP->op_first = newop;
5326     }
5327     o->op_ppaddr = PL_ppaddr[++o->op_type];
5328     return ck_fun(o);
5329 }
5330
5331 OP *
5332 Perl_ck_delete(pTHX_ OP *o)
5333 {
5334     o = ck_fun(o);
5335     o->op_private = 0;
5336     if (o->op_flags & OPf_KIDS) {
5337         OP *kid = cUNOPo->op_first;
5338         switch (kid->op_type) {
5339         case OP_ASLICE:
5340             o->op_flags |= OPf_SPECIAL;
5341             /* FALL THROUGH */
5342         case OP_HSLICE:
5343             o->op_private |= OPpSLICE;
5344             break;
5345         case OP_AELEM:
5346             o->op_flags |= OPf_SPECIAL;
5347             /* FALL THROUGH */
5348         case OP_HELEM:
5349             break;
5350         default:
5351             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5352                   PL_op_desc[o->op_type]);
5353         }
5354         null(kid);
5355     }
5356     return o;
5357 }
5358
5359 OP *
5360 Perl_ck_eof(pTHX_ OP *o)
5361 {
5362     I32 type = o->op_type;
5363
5364     if (o->op_flags & OPf_KIDS) {
5365         if (cLISTOPo->op_first->op_type == OP_STUB) {
5366             op_free(o);
5367             o = newUNOP(type, OPf_SPECIAL,
5368                 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
5369         }
5370         return ck_fun(o);
5371     }
5372     return o;
5373 }
5374
5375 OP *
5376 Perl_ck_eval(pTHX_ OP *o)
5377 {
5378     PL_hints |= HINT_BLOCK_SCOPE;
5379     if (o->op_flags & OPf_KIDS) {
5380         SVOP *kid = (SVOP*)cUNOPo->op_first;
5381
5382         if (!kid) {
5383             o->op_flags &= ~OPf_KIDS;
5384             null(o);
5385         }
5386         else if (kid->op_type == OP_LINESEQ) {
5387             LOGOP *enter;
5388
5389             kid->op_next = o->op_next;
5390             cUNOPo->op_first = 0;
5391             op_free(o);
5392
5393             NewOp(1101, enter, 1, LOGOP);
5394             enter->op_type = OP_ENTERTRY;
5395             enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5396             enter->op_private = 0;
5397
5398             /* establish postfix order */
5399             enter->op_next = (OP*)enter;
5400
5401             o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5402             o->op_type = OP_LEAVETRY;
5403             o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5404             enter->op_other = o;
5405             return o;
5406         }
5407         else
5408             scalar((OP*)kid);
5409     }
5410     else {
5411         op_free(o);
5412         o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5413     }
5414     o->op_targ = (PADOFFSET)PL_hints;
5415     return o;
5416 }
5417
5418 OP *
5419 Perl_ck_exit(pTHX_ OP *o)
5420 {
5421 #ifdef VMS
5422     HV *table = GvHV(PL_hintgv);
5423     if (table) {
5424        SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5425        if (svp && *svp && SvTRUE(*svp))
5426            o->op_private |= OPpEXIT_VMSISH;
5427     }
5428 #endif
5429     return ck_fun(o);
5430 }
5431
5432 OP *
5433 Perl_ck_exec(pTHX_ OP *o)
5434 {
5435     OP *kid;
5436     if (o->op_flags & OPf_STACKED) {
5437         o = ck_fun(o);
5438         kid = cUNOPo->op_first->op_sibling;
5439         if (kid->op_type == OP_RV2GV)
5440             null(kid);
5441     }
5442     else
5443         o = listkids(o);
5444     return o;
5445 }
5446
5447 OP *
5448 Perl_ck_exists(pTHX_ OP *o)
5449 {
5450     o = ck_fun(o);
5451     if (o->op_flags & OPf_KIDS) {
5452         OP *kid = cUNOPo->op_first;
5453         if (kid->op_type == OP_ENTERSUB) {
5454             (void) ref(kid, o->op_type);
5455             if (kid->op_type != OP_RV2CV && !PL_error_count)
5456                 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5457                            PL_op_desc[o->op_type]);
5458             o->op_private |= OPpEXISTS_SUB;
5459         }
5460         else if (kid->op_type == OP_AELEM)
5461             o->op_flags |= OPf_SPECIAL;
5462         else if (kid->op_type != OP_HELEM)
5463             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5464                        PL_op_desc[o->op_type]);
5465         null(kid);
5466     }
5467     return o;
5468 }
5469
5470 #if 0
5471 OP *
5472 Perl_ck_gvconst(pTHX_ register OP *o)
5473 {
5474     o = fold_constants(o);
5475     if (o->op_type == OP_CONST)
5476         o->op_type = OP_GV;
5477     return o;
5478 }
5479 #endif
5480
5481 OP *
5482 Perl_ck_rvconst(pTHX_ register OP *o)
5483 {
5484     SVOP *kid = (SVOP*)cUNOPo->op_first;
5485
5486     o->op_private |= (PL_hints & HINT_STRICT_REFS);
5487     if (kid->op_type == OP_CONST) {
5488         char *name;
5489         int iscv;
5490         GV *gv;
5491         SV *kidsv = kid->op_sv;
5492         STRLEN n_a;
5493
5494         /* Is it a constant from cv_const_sv()? */
5495         if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5496             SV *rsv = SvRV(kidsv);
5497             int svtype = SvTYPE(rsv);
5498             char *badtype = Nullch;
5499
5500             switch (o->op_type) {
5501             case OP_RV2SV:
5502                 if (svtype > SVt_PVMG)
5503                     badtype = "a SCALAR";
5504                 break;
5505             case OP_RV2AV:
5506                 if (svtype != SVt_PVAV)
5507                     badtype = "an ARRAY";
5508                 break;
5509             case OP_RV2HV:
5510                 if (svtype != SVt_PVHV) {
5511                     if (svtype == SVt_PVAV) {   /* pseudohash? */
5512                         SV **ksv = av_fetch((AV*)rsv, 0, FALSE);
5513                         if (ksv && SvROK(*ksv)
5514                             && SvTYPE(SvRV(*ksv)) == SVt_PVHV)
5515                         {
5516                                 break;
5517                         }
5518                     }
5519                     badtype = "a HASH";
5520                 }
5521                 break;
5522             case OP_RV2CV:
5523                 if (svtype != SVt_PVCV)
5524                     badtype = "a CODE";
5525                 break;
5526             }
5527             if (badtype)
5528                 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5529             return o;
5530         }
5531         name = SvPV(kidsv, n_a);
5532         if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5533             char *badthing = Nullch;
5534             switch (o->op_type) {
5535             case OP_RV2SV:
5536                 badthing = "a SCALAR";
5537                 break;
5538             case OP_RV2AV:
5539                 badthing = "an ARRAY";
5540                 break;
5541             case OP_RV2HV:
5542                 badthing = "a HASH";
5543                 break;
5544             }
5545             if (badthing)
5546                 Perl_croak(aTHX_
5547           "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5548                       name, badthing);
5549         }
5550         /*
5551          * This is a little tricky.  We only want to add the symbol if we
5552          * didn't add it in the lexer.  Otherwise we get duplicate strict
5553          * warnings.  But if we didn't add it in the lexer, we must at
5554          * least pretend like we wanted to add it even if it existed before,
5555          * or we get possible typo warnings.  OPpCONST_ENTERED says
5556          * whether the lexer already added THIS instance of this symbol.
5557          */
5558         iscv = (o->op_type == OP_RV2CV) * 2;
5559         do {
5560             gv = gv_fetchpv(name,
5561                 iscv | !(kid->op_private & OPpCONST_ENTERED),
5562                 iscv
5563                     ? SVt_PVCV
5564                     : o->op_type == OP_RV2SV
5565                         ? SVt_PV
5566                         : o->op_type == OP_RV2AV
5567                             ? SVt_PVAV
5568                             : o->op_type == OP_RV2HV
5569                                 ? SVt_PVHV
5570                                 : SVt_PVGV);
5571         } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5572         if (gv) {
5573             kid->op_type = OP_GV;
5574             SvREFCNT_dec(kid->op_sv);
5575 #ifdef USE_ITHREADS
5576             /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5577             kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5578             SvREFCNT_dec(PL_curpad[kPADOP->op_padix]);
5579             GvIN_PAD_on(gv);
5580             PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv);
5581 #else
5582             kid->op_sv = SvREFCNT_inc(gv);
5583 #endif
5584             kid->op_private = 0;
5585             kid->op_ppaddr = PL_ppaddr[OP_GV];
5586         }
5587     }
5588     return o;
5589 }
5590
5591 OP *
5592 Perl_ck_ftst(pTHX_ OP *o)
5593 {
5594     I32 type = o->op_type;
5595
5596     if (o->op_flags & OPf_REF) {
5597         /* nothing */
5598     }
5599     else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5600         SVOP *kid = (SVOP*)cUNOPo->op_first;
5601
5602         if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5603             STRLEN n_a;
5604             OP *newop = newGVOP(type, OPf_REF,
5605                 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5606             op_free(o);
5607             o = newop;
5608         }
5609     }
5610     else {
5611         op_free(o);
5612         if (type == OP_FTTTY)
5613            o =  newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
5614                                 SVt_PVIO));
5615         else
5616             o = newUNOP(type, 0, newDEFSVOP());
5617     }
5618 #ifdef USE_LOCALE
5619     if (type == OP_FTTEXT || type == OP_FTBINARY) {
5620         o->op_private = 0;
5621         if (PL_hints & HINT_LOCALE)
5622             o->op_private |= OPpLOCALE;
5623     }
5624 #endif
5625     return o;
5626 }
5627
5628 OP *
5629 Perl_ck_fun(pTHX_ OP *o)
5630 {
5631     register OP *kid;
5632     OP **tokid;
5633     OP *sibl;
5634     I32 numargs = 0;
5635     int type = o->op_type;
5636     register I32 oa = PL_opargs[type] >> OASHIFT;
5637
5638     if (o->op_flags & OPf_STACKED) {
5639         if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5640             oa &= ~OA_OPTIONAL;
5641         else
5642             return no_fh_allowed(o);
5643     }
5644
5645     if (o->op_flags & OPf_KIDS) {
5646         STRLEN n_a;
5647         tokid = &cLISTOPo->op_first;
5648         kid = cLISTOPo->op_first;
5649         if (kid->op_type == OP_PUSHMARK ||
5650             (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5651         {
5652             tokid = &kid->op_sibling;
5653             kid = kid->op_sibling;
5654         }
5655         if (!kid && PL_opargs[type] & OA_DEFGV)
5656             *tokid = kid = newDEFSVOP();
5657
5658         while (oa && kid) {
5659             numargs++;
5660             sibl = kid->op_sibling;
5661             switch (oa & 7) {
5662             case OA_SCALAR:
5663                 /* list seen where single (scalar) arg expected? */
5664                 if (numargs == 1 && !(oa >> 4)
5665                     && kid->op_type == OP_LIST && type != OP_SCALAR)
5666                 {
5667                     return too_many_arguments(o,PL_op_desc[type]);
5668                 }
5669                 scalar(kid);
5670                 break;
5671             case OA_LIST:
5672                 if (oa < 16) {
5673                     kid = 0;
5674                     continue;
5675                 }
5676                 else
5677                     list(kid);
5678                 break;
5679             case OA_AVREF:
5680                 if (kid->op_type == OP_CONST &&
5681                     (kid->op_private & OPpCONST_BARE))
5682                 {
5683                     char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5684                     OP *newop = newAVREF(newGVOP(OP_GV, 0,
5685                         gv_fetchpv(name, TRUE, SVt_PVAV) ));
5686                     if (ckWARN(WARN_DEPRECATED))
5687                         Perl_warner(aTHX_ WARN_DEPRECATED,
5688                             "Array @%s missing the @ in argument %"IVdf" of %s()",
5689                             name, (IV)numargs, PL_op_desc[type]);
5690                     op_free(kid);
5691                     kid = newop;
5692                     kid->op_sibling = sibl;
5693                     *tokid = kid;
5694                 }
5695                 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5696                     bad_type(numargs, "array", PL_op_desc[type], kid);
5697                 mod(kid, type);
5698                 break;
5699             case OA_HVREF:
5700                 if (kid->op_type == OP_CONST &&
5701                     (kid->op_private & OPpCONST_BARE))
5702                 {
5703                     char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5704                     OP *newop = newHVREF(newGVOP(OP_GV, 0,
5705                         gv_fetchpv(name, TRUE, SVt_PVHV) ));
5706                     if (ckWARN(WARN_DEPRECATED))
5707                         Perl_warner(aTHX_ WARN_DEPRECATED,
5708                             "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5709                             name, (IV)numargs, PL_op_desc[type]);
5710                     op_free(kid);
5711                     kid = newop;
5712                     kid->op_sibling = sibl;
5713                     *tokid = kid;
5714                 }
5715                 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5716                     bad_type(numargs, "hash", PL_op_desc[type], kid);
5717                 mod(kid, type);
5718                 break;
5719             case OA_CVREF:
5720                 {
5721                     OP *newop = newUNOP(OP_NULL, 0, kid);
5722                     kid->op_sibling = 0;
5723                     linklist(kid);
5724                     newop->op_next = newop;
5725                     kid = newop;
5726                     kid->op_sibling = sibl;
5727                     *tokid = kid;
5728                 }
5729                 break;
5730             case OA_FILEREF:
5731                 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5732                     if (kid->op_type == OP_CONST &&
5733                         (kid->op_private & OPpCONST_BARE))
5734                     {
5735                         OP *newop = newGVOP(OP_GV, 0,
5736                             gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5737                                         SVt_PVIO) );
5738                         op_free(kid);
5739                         kid = newop;
5740                     }
5741                     else if (kid->op_type == OP_READLINE) {
5742                         /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5743                         bad_type(numargs, "HANDLE", PL_op_desc[o->op_type], kid);
5744                     }
5745                     else {
5746                         I32 flags = OPf_SPECIAL;
5747                         I32 priv = 0;
5748                         PADOFFSET targ = 0;
5749
5750                         /* is this op a FH constructor? */
5751                         if (is_handle_constructor(o,numargs)) {
5752                             char *name = Nullch;
5753                             STRLEN len;
5754
5755                             flags = 0;
5756                             /* Set a flag to tell rv2gv to vivify
5757                              * need to "prove" flag does not mean something
5758                              * else already - NI-S 1999/05/07
5759                              */
5760                             priv = OPpDEREF;
5761                             if (kid->op_type == OP_PADSV) {
5762                                 SV **namep = av_fetch(PL_comppad_name,
5763                                                       kid->op_targ, 4);
5764                                 if (namep && *namep)
5765                                     name = SvPV(*namep, len);
5766                             }
5767                             else if (kid->op_type == OP_RV2SV
5768                                      && kUNOP->op_first->op_type == OP_GV)
5769                             {
5770                                 GV *gv = cGVOPx_gv(kUNOP->op_first);
5771                                 name = GvNAME(gv);
5772                                 len = GvNAMELEN(gv);
5773                             }
5774                             else if (kid->op_type == OP_AELEM
5775                                      || kid->op_type == OP_HELEM)
5776                             {
5777                                 name = "__ANONIO__";
5778                                 len = 10;
5779                                 mod(kid,type);
5780                             }
5781                             if (name) {
5782                                 SV *namesv;
5783                                 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5784                                 namesv = PL_curpad[targ];
5785                                 (void)SvUPGRADE(namesv, SVt_PV);
5786                                 if (*name != '$')
5787                                     sv_setpvn(namesv, "$", 1);
5788                                 sv_catpvn(namesv, name, len);
5789                             }
5790                         }
5791                         kid->op_sibling = 0;
5792                         kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5793                         kid->op_targ = targ;
5794                         kid->op_private |= priv;
5795                     }
5796                     kid->op_sibling = sibl;
5797                     *tokid = kid;
5798                 }
5799                 scalar(kid);
5800                 break;
5801             case OA_SCALARREF:
5802                 mod(scalar(kid), type);
5803                 break;
5804             }
5805             oa >>= 4;
5806             tokid = &kid->op_sibling;
5807             kid = kid->op_sibling;
5808         }
5809         o->op_private |= numargs;
5810         if (kid)
5811             return too_many_arguments(o,PL_op_desc[o->op_type]);
5812         listkids(o);
5813     }
5814     else if (PL_opargs[type] & OA_DEFGV) {
5815         op_free(o);
5816         return newUNOP(type, 0, newDEFSVOP());
5817     }
5818
5819     if (oa) {
5820         while (oa & OA_OPTIONAL)
5821             oa >>= 4;
5822         if (oa && oa != OA_LIST)
5823             return too_few_arguments(o,PL_op_desc[o->op_type]);
5824     }
5825     return o;
5826 }
5827
5828 OP *
5829 Perl_ck_glob(pTHX_ OP *o)
5830 {
5831     GV *gv;
5832
5833     o = ck_fun(o);
5834     if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5835         append_elem(OP_GLOB, o, newDEFSVOP());
5836
5837     if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV)) && GvIMPORTED_CV(gv)))
5838         gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5839
5840 #if !defined(PERL_EXTERNAL_GLOB)
5841     /* XXX this can be tightened up and made more failsafe. */
5842     if (!gv) {
5843         ENTER;
5844         Perl_load_module(aTHX_ 0, newSVpvn("File::Glob", 10), Nullsv,
5845                          /* null-terminated import list */
5846                          newSVpvn(":globally", 9), Nullsv);
5847         gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5848         LEAVE;
5849     }
5850 #endif /* PERL_EXTERNAL_GLOB */
5851
5852     if (gv && GvIMPORTED_CV(gv)) {
5853         append_elem(OP_GLOB, o,
5854                     newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5855         o->op_type = OP_LIST;
5856         o->op_ppaddr = PL_ppaddr[OP_LIST];
5857         cLISTOPo->op_first->op_type = OP_PUSHMARK;
5858         cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5859         o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5860                     append_elem(OP_LIST, o,
5861                                 scalar(newUNOP(OP_RV2CV, 0,
5862                                                newGVOP(OP_GV, 0, gv)))));
5863         o = newUNOP(OP_NULL, 0, ck_subr(o));
5864         o->op_targ = OP_GLOB;           /* hint at what it used to be */
5865         return o;
5866     }
5867     gv = newGVgen("main");
5868     gv_IOadd(gv);
5869     append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5870     scalarkids(o);
5871     return o;
5872 }
5873
5874 OP *
5875 Perl_ck_grep(pTHX_ OP *o)
5876 {
5877     LOGOP *gwop;
5878     OP *kid;
5879     OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5880
5881     o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5882     NewOp(1101, gwop, 1, LOGOP);
5883
5884     if (o->op_flags & OPf_STACKED) {
5885         OP* k;
5886         o = ck_sort(o);
5887         kid = cLISTOPo->op_first->op_sibling;
5888         for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
5889             kid = k;
5890         }
5891         kid->op_next = (OP*)gwop;
5892         o->op_flags &= ~OPf_STACKED;
5893     }
5894     kid = cLISTOPo->op_first->op_sibling;
5895     if (type == OP_MAPWHILE)
5896         list(kid);
5897     else
5898         scalar(kid);
5899     o = ck_fun(o);
5900     if (PL_error_count)
5901         return o;
5902     kid = cLISTOPo->op_first->op_sibling;
5903     if (kid->op_type != OP_NULL)
5904         Perl_croak(aTHX_ "panic: ck_grep");
5905     kid = kUNOP->op_first;
5906
5907     gwop->op_type = type;
5908     gwop->op_ppaddr = PL_ppaddr[type];
5909     gwop->op_first = listkids(o);
5910     gwop->op_flags |= OPf_KIDS;
5911     gwop->op_private = 1;
5912     gwop->op_other = LINKLIST(kid);
5913     gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5914     kid->op_next = (OP*)gwop;
5915
5916     kid = cLISTOPo->op_first->op_sibling;
5917     if (!kid || !kid->op_sibling)
5918         return too_few_arguments(o,PL_op_desc[o->op_type]);
5919     for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5920         mod(kid, OP_GREPSTART);
5921
5922     return (OP*)gwop;
5923 }
5924
5925 OP *
5926 Perl_ck_index(pTHX_ OP *o)
5927 {
5928     if (o->op_flags & OPf_KIDS) {
5929         OP *kid = cLISTOPo->op_first->op_sibling;       /* get past pushmark */
5930         if (kid)
5931             kid = kid->op_sibling;                      /* get past "big" */
5932         if (kid && kid->op_type == OP_CONST)
5933             fbm_compile(((SVOP*)kid)->op_sv, 0);
5934     }
5935     return ck_fun(o);
5936 }
5937
5938 OP *
5939 Perl_ck_lengthconst(pTHX_ OP *o)
5940 {
5941     /* XXX length optimization goes here */
5942     return ck_fun(o);
5943 }
5944
5945 OP *
5946 Perl_ck_lfun(pTHX_ OP *o)
5947 {
5948     OPCODE type = o->op_type;
5949     return modkids(ck_fun(o), type);
5950 }
5951
5952 OP *
5953 Perl_ck_defined(pTHX_ OP *o)            /* 19990527 MJD */
5954 {
5955     if ((o->op_flags & OPf_KIDS) && ckWARN(WARN_DEPRECATED)) {
5956         switch (cUNOPo->op_first->op_type) {
5957         case OP_RV2AV:
5958             /* This is needed for
5959                if (defined %stash::)
5960                to work.   Do not break Tk.
5961                */
5962             break;                      /* Globals via GV can be undef */
5963         case OP_PADAV:
5964         case OP_AASSIGN:                /* Is this a good idea? */
5965             Perl_warner(aTHX_ WARN_DEPRECATED,
5966                         "defined(@array) is deprecated");
5967             Perl_warner(aTHX_ WARN_DEPRECATED,
5968                         "\t(Maybe you should just omit the defined()?)\n");
5969         break;
5970         case OP_RV2HV:
5971             /* This is needed for
5972                if (defined %stash::)
5973                to work.   Do not break Tk.
5974                */
5975             break;                      /* Globals via GV can be undef */
5976         case OP_PADHV:
5977             Perl_warner(aTHX_ WARN_DEPRECATED,
5978                         "defined(%%hash) is deprecated");
5979             Perl_warner(aTHX_ WARN_DEPRECATED,
5980                         "\t(Maybe you should just omit the defined()?)\n");
5981             break;
5982         default:
5983             /* no warning */
5984             break;
5985         }
5986     }
5987     return ck_rfun(o);
5988 }
5989
5990 OP *
5991 Perl_ck_rfun(pTHX_ OP *o)
5992 {
5993     OPCODE type = o->op_type;
5994     return refkids(ck_fun(o), type);
5995 }
5996
5997 OP *
5998 Perl_ck_listiob(pTHX_ OP *o)
5999 {
6000     register OP *kid;
6001
6002     kid = cLISTOPo->op_first;
6003     if (!kid) {
6004         o = force_list(o);
6005         kid = cLISTOPo->op_first;
6006     }
6007     if (kid->op_type == OP_PUSHMARK)
6008         kid = kid->op_sibling;
6009     if (kid && o->op_flags & OPf_STACKED)
6010         kid = kid->op_sibling;
6011     else if (kid && !kid->op_sibling) {         /* print HANDLE; */
6012         if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6013             o->op_flags |= OPf_STACKED; /* make it a filehandle */
6014             kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6015             cLISTOPo->op_first->op_sibling = kid;
6016             cLISTOPo->op_last = kid;
6017             kid = kid->op_sibling;
6018         }
6019     }
6020
6021     if (!kid)
6022         append_elem(o->op_type, o, newDEFSVOP());
6023
6024     o = listkids(o);
6025
6026     o->op_private = 0;
6027 #ifdef USE_LOCALE
6028     if (PL_hints & HINT_LOCALE)
6029         o->op_private |= OPpLOCALE;
6030 #endif
6031
6032     return o;
6033 }
6034
6035 OP *
6036 Perl_ck_fun_locale(pTHX_ OP *o)
6037 {
6038     o = ck_fun(o);
6039
6040     o->op_private = 0;
6041 #ifdef USE_LOCALE
6042     if (PL_hints & HINT_LOCALE)
6043         o->op_private |= OPpLOCALE;
6044 #endif
6045
6046     return o;
6047 }
6048
6049 OP *
6050 Perl_ck_sassign(pTHX_ OP *o)
6051 {
6052     OP *kid = cLISTOPo->op_first;
6053     /* has a disposable target? */
6054     if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6055         && !(kid->op_flags & OPf_STACKED)
6056         /* Cannot steal the second time! */
6057         && !(kid->op_private & OPpTARGET_MY))
6058     {
6059         OP *kkid = kid->op_sibling;
6060
6061         /* Can just relocate the target. */
6062         if (kkid && kkid->op_type == OP_PADSV
6063             && !(kkid->op_private & OPpLVAL_INTRO))
6064         {
6065             kid->op_targ = kkid->op_targ;
6066             kkid->op_targ = 0;
6067             /* Now we do not need PADSV and SASSIGN. */
6068             kid->op_sibling = o->op_sibling;    /* NULL */
6069             cLISTOPo->op_first = NULL;
6070             op_free(o);
6071             op_free(kkid);
6072             kid->op_private |= OPpTARGET_MY;    /* Used for context settings */
6073             return kid;
6074         }
6075     }
6076     return o;
6077 }
6078
6079 OP *
6080 Perl_ck_scmp(pTHX_ OP *o)
6081 {
6082     o->op_private = 0;
6083 #ifdef USE_LOCALE
6084     if (PL_hints & HINT_LOCALE)
6085         o->op_private |= OPpLOCALE;
6086 #endif
6087
6088     return o;
6089 }
6090
6091 OP *
6092 Perl_ck_match(pTHX_ OP *o)
6093 {
6094     o->op_private |= OPpRUNTIME;
6095     return o;
6096 }
6097
6098 OP *
6099 Perl_ck_method(pTHX_ OP *o)
6100 {
6101     OP *kid = cUNOPo->op_first;
6102     if (kid->op_type == OP_CONST) {
6103         SV* sv = kSVOP->op_sv;
6104         if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
6105             OP *cmop;
6106             if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6107                 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
6108             }
6109             else {
6110                 kSVOP->op_sv = Nullsv;
6111             }
6112             cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6113             op_free(o);
6114             return cmop;
6115         }
6116     }
6117     return o;
6118 }
6119
6120 OP *
6121 Perl_ck_null(pTHX_ OP *o)
6122 {
6123     return o;
6124 }
6125
6126 OP *
6127 Perl_ck_open(pTHX_ OP *o)
6128 {
6129     HV *table = GvHV(PL_hintgv);
6130     if (table) {
6131         SV **svp;
6132         I32 mode;
6133         svp = hv_fetch(table, "open_IN", 7, FALSE);
6134         if (svp && *svp) {
6135             mode = mode_from_discipline(*svp);
6136             if (mode & O_BINARY)
6137                 o->op_private |= OPpOPEN_IN_RAW;
6138             else if (mode & O_TEXT)
6139                 o->op_private |= OPpOPEN_IN_CRLF;
6140         }
6141
6142         svp = hv_fetch(table, "open_OUT", 8, FALSE);
6143         if (svp && *svp) {
6144             mode = mode_from_discipline(*svp);
6145             if (mode & O_BINARY)
6146                 o->op_private |= OPpOPEN_OUT_RAW;
6147             else if (mode & O_TEXT)
6148                 o->op_private |= OPpOPEN_OUT_CRLF;
6149         }
6150     }
6151     if (o->op_type == OP_BACKTICK)
6152         return o;
6153     return ck_fun(o);
6154 }
6155
6156 OP *
6157 Perl_ck_repeat(pTHX_ OP *o)
6158 {
6159     if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6160         o->op_private |= OPpREPEAT_DOLIST;
6161         cBINOPo->op_first = force_list(cBINOPo->op_first);
6162     }
6163     else
6164         scalar(o);
6165     return o;
6166 }
6167
6168 OP *
6169 Perl_ck_require(pTHX_ OP *o)
6170 {
6171     if (o->op_flags & OPf_KIDS) {       /* Shall we supply missing .pm? */
6172         SVOP *kid = (SVOP*)cUNOPo->op_first;
6173
6174         if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6175             char *s;
6176             for (s = SvPVX(kid->op_sv); *s; s++) {
6177                 if (*s == ':' && s[1] == ':') {
6178                     *s = '/';
6179                     Move(s+2, s+1, strlen(s+2)+1, char);
6180                     --SvCUR(kid->op_sv);
6181                 }
6182             }
6183             if (SvREADONLY(kid->op_sv)) {
6184                 SvREADONLY_off(kid->op_sv);
6185                 sv_catpvn(kid->op_sv, ".pm", 3);
6186                 SvREADONLY_on(kid->op_sv);
6187             }
6188             else
6189                 sv_catpvn(kid->op_sv, ".pm", 3);
6190         }
6191     }
6192     return ck_fun(o);
6193 }
6194
6195 OP *
6196 Perl_ck_return(pTHX_ OP *o)
6197 {
6198     OP *kid;
6199     if (CvLVALUE(PL_compcv)) {
6200         for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6201             mod(kid, OP_LEAVESUBLV);
6202     }
6203     return o;
6204 }
6205
6206 #if 0
6207 OP *
6208 Perl_ck_retarget(pTHX_ OP *o)
6209 {
6210     Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
6211     /* STUB */
6212     return o;
6213 }
6214 #endif
6215
6216 OP *
6217 Perl_ck_select(pTHX_ OP *o)
6218 {
6219     OP* kid;
6220     if (o->op_flags & OPf_KIDS) {
6221         kid = cLISTOPo->op_first->op_sibling;   /* get past pushmark */
6222         if (kid && kid->op_sibling) {
6223             o->op_type = OP_SSELECT;
6224             o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6225             o = ck_fun(o);
6226             return fold_constants(o);
6227         }
6228     }
6229     o = ck_fun(o);
6230     kid = cLISTOPo->op_first->op_sibling;    /* get past pushmark */
6231     if (kid && kid->op_type == OP_RV2GV)
6232         kid->op_private &= ~HINT_STRICT_REFS;
6233     return o;
6234 }
6235
6236 OP *
6237 Perl_ck_shift(pTHX_ OP *o)
6238 {
6239     I32 type = o->op_type;
6240
6241     if (!(o->op_flags & OPf_KIDS)) {
6242         OP *argop;
6243
6244         op_free(o);
6245 #ifdef USE_THREADS
6246         if (!CvUNIQUE(PL_compcv)) {
6247             argop = newOP(OP_PADAV, OPf_REF);
6248             argop->op_targ = 0;         /* PL_curpad[0] is @_ */
6249         }
6250         else {
6251             argop = newUNOP(OP_RV2AV, 0,
6252                 scalar(newGVOP(OP_GV, 0,
6253                     gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6254         }
6255 #else
6256         argop = newUNOP(OP_RV2AV, 0,
6257             scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
6258                            PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6259 #endif /* USE_THREADS */
6260         return newUNOP(type, 0, scalar(argop));
6261     }
6262     return scalar(modkids(ck_fun(o), type));
6263 }
6264
6265 OP *
6266 Perl_ck_sort(pTHX_ OP *o)
6267 {
6268     OP *firstkid;
6269     o->op_private = 0;
6270 #ifdef USE_LOCALE
6271     if (PL_hints & HINT_LOCALE)
6272         o->op_private |= OPpLOCALE;
6273 #endif
6274
6275     if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6276         simplify_sort(o);
6277     firstkid = cLISTOPo->op_first->op_sibling;          /* get past pushmark */
6278     if (o->op_flags & OPf_STACKED) {                    /* may have been cleared */
6279         OP *k;
6280         OP *kid = cUNOPx(firstkid)->op_first;           /* get past null */
6281
6282         if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6283             linklist(kid);
6284             if (kid->op_type == OP_SCOPE) {
6285                 k = kid->op_next;
6286                 kid->op_next = 0;
6287             }
6288             else if (kid->op_type == OP_LEAVE) {
6289                 if (o->op_type == OP_SORT) {
6290                     null(kid);                  /* wipe out leave */
6291                     kid->op_next = kid;
6292
6293                     for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6294                         if (k->op_next == kid)
6295                             k->op_next = 0;
6296                         /* don't descend into loops */
6297                         else if (k->op_type == OP_ENTERLOOP
6298                                  || k->op_type == OP_ENTERITER)
6299                         {
6300                             k = cLOOPx(k)->op_lastop;
6301                         }
6302                     }
6303                 }
6304                 else
6305                     kid->op_next = 0;           /* just disconnect the leave */
6306                 k = kLISTOP->op_first;
6307             }
6308             peep(k);
6309
6310             kid = firstkid;
6311             if (o->op_type == OP_SORT) {
6312                 /* provide scalar context for comparison function/block */
6313                 kid = scalar(kid);
6314                 kid->op_next = kid;
6315             }
6316             else
6317                 kid->op_next = k;
6318             o->op_flags |= OPf_SPECIAL;
6319         }
6320         else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6321             null(firstkid);
6322
6323         firstkid = firstkid->op_sibling;
6324     }
6325
6326     /* provide list context for arguments */
6327     if (o->op_type == OP_SORT)
6328         list(firstkid);
6329
6330     return o;
6331 }
6332
6333 STATIC void
6334 S_simplify_sort(pTHX_ OP *o)
6335 {
6336     register OP *kid = cLISTOPo->op_first->op_sibling;  /* get past pushmark */
6337     OP *k;
6338     int reversed;
6339     GV *gv;
6340     if (!(o->op_flags & OPf_STACKED))
6341         return;
6342     GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6343     GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6344     kid = kUNOP->op_first;                              /* get past null */
6345     if (kid->op_type != OP_SCOPE)
6346         return;
6347     kid = kLISTOP->op_last;                             /* get past scope */
6348     switch(kid->op_type) {
6349         case OP_NCMP:
6350         case OP_I_NCMP:
6351         case OP_SCMP:
6352             break;
6353         default:
6354             return;
6355     }
6356     k = kid;                                            /* remember this node*/
6357     if (kBINOP->op_first->op_type != OP_RV2SV)
6358         return;
6359     kid = kBINOP->op_first;                             /* get past cmp */
6360     if (kUNOP->op_first->op_type != OP_GV)
6361         return;
6362     kid = kUNOP->op_first;                              /* get past rv2sv */
6363     gv = kGVOP_gv;
6364     if (GvSTASH(gv) != PL_curstash)
6365         return;
6366     if (strEQ(GvNAME(gv), "a"))
6367         reversed = 0;
6368     else if (strEQ(GvNAME(gv), "b"))
6369         reversed = 1;
6370     else
6371         return;
6372     kid = k;                                            /* back to cmp */
6373     if (kBINOP->op_last->op_type != OP_RV2SV)
6374         return;
6375     kid = kBINOP->op_last;                              /* down to 2nd arg */
6376     if (kUNOP->op_first->op_type != OP_GV)
6377         return;
6378     kid = kUNOP->op_first;                              /* get past rv2sv */
6379     gv = kGVOP_gv;
6380     if (GvSTASH(gv) != PL_curstash
6381         || ( reversed
6382             ? strNE(GvNAME(gv), "a")
6383             : strNE(GvNAME(gv), "b")))
6384         return;
6385     o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6386     if (reversed)
6387         o->op_private |= OPpSORT_REVERSE;
6388     if (k->op_type == OP_NCMP)
6389         o->op_private |= OPpSORT_NUMERIC;
6390     if (k->op_type == OP_I_NCMP)
6391         o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6392     kid = cLISTOPo->op_first->op_sibling;
6393     cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6394     op_free(kid);                                     /* then delete it */
6395 }
6396
6397 OP *
6398 Perl_ck_split(pTHX_ OP *o)
6399 {
6400     register OP *kid;
6401
6402     if (o->op_flags & OPf_STACKED)
6403         return no_fh_allowed(o);
6404
6405     kid = cLISTOPo->op_first;
6406     if (kid->op_type != OP_NULL)
6407         Perl_croak(aTHX_ "panic: ck_split");
6408     kid = kid->op_sibling;
6409     op_free(cLISTOPo->op_first);
6410     cLISTOPo->op_first = kid;
6411     if (!kid) {
6412         cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6413         cLISTOPo->op_last = kid; /* There was only one element previously */
6414     }
6415
6416     if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6417         OP *sibl = kid->op_sibling;
6418         kid->op_sibling = 0;
6419         kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
6420         if (cLISTOPo->op_first == cLISTOPo->op_last)
6421             cLISTOPo->op_last = kid;
6422         cLISTOPo->op_first = kid;
6423         kid->op_sibling = sibl;
6424     }
6425
6426     kid->op_type = OP_PUSHRE;
6427     kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6428     scalar(kid);
6429
6430     if (!kid->op_sibling)
6431         append_elem(OP_SPLIT, o, newDEFSVOP());
6432
6433     kid = kid->op_sibling;
6434     scalar(kid);
6435
6436     if (!kid->op_sibling)
6437         append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6438
6439     kid = kid->op_sibling;
6440     scalar(kid);
6441
6442     if (kid->op_sibling)
6443         return too_many_arguments(o,PL_op_desc[o->op_type]);
6444
6445     return o;
6446 }
6447
6448 OP *
6449 Perl_ck_join(pTHX_ OP *o)
6450 {
6451     if (ckWARN(WARN_SYNTAX)) {
6452         OP *kid = cLISTOPo->op_first->op_sibling;
6453         if (kid && kid->op_type == OP_MATCH) {
6454             char *pmstr = "STRING";
6455             if (kPMOP->op_pmregexp)
6456                 pmstr = kPMOP->op_pmregexp->precomp;
6457             Perl_warner(aTHX_ WARN_SYNTAX,
6458                         "/%s/ should probably be written as \"%s\"",
6459                         pmstr, pmstr);
6460         }
6461     }
6462     return ck_fun(o);
6463 }
6464
6465 OP *
6466 Perl_ck_subr(pTHX_ OP *o)
6467 {
6468     OP *prev = ((cUNOPo->op_first->op_sibling)
6469              ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6470     OP *o2 = prev->op_sibling;
6471     OP *cvop;
6472     char *proto = 0;
6473     CV *cv = 0;
6474     GV *namegv = 0;
6475     int optional = 0;
6476     I32 arg = 0;
6477     STRLEN n_a;
6478
6479     o->op_private |= OPpENTERSUB_HASTARG;
6480     for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6481     if (cvop->op_type == OP_RV2CV) {
6482         SVOP* tmpop;
6483         o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6484         null(cvop);             /* disable rv2cv */
6485         tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6486         if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6487             GV *gv = cGVOPx_gv(tmpop);
6488             cv = GvCVu(gv);
6489             if (!cv)
6490                 tmpop->op_private |= OPpEARLY_CV;
6491             else if (SvPOK(cv)) {
6492                 namegv = CvANON(cv) ? gv : CvGV(cv);
6493                 proto = SvPV((SV*)cv, n_a);
6494             }
6495         }
6496     }
6497     else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6498         if (o2->op_type == OP_CONST)
6499             o2->op_private &= ~OPpCONST_STRICT;
6500         else if (o2->op_type == OP_LIST) {
6501             OP *o = ((UNOP*)o2)->op_first->op_sibling;
6502             if (o && o->op_type == OP_CONST)
6503                 o->op_private &= ~OPpCONST_STRICT;
6504         }
6505     }
6506     o->op_private |= (PL_hints & HINT_STRICT_REFS);
6507     if (PERLDB_SUB && PL_curstash != PL_debstash)
6508         o->op_private |= OPpENTERSUB_DB;
6509     while (o2 != cvop) {
6510         if (proto) {
6511             switch (*proto) {
6512             case '\0':
6513                 return too_many_arguments(o, gv_ename(namegv));
6514             case ';':
6515                 optional = 1;
6516                 proto++;
6517                 continue;
6518             case '$':
6519                 proto++;
6520                 arg++;
6521                 scalar(o2);
6522                 break;
6523             case '%':
6524             case '@':
6525                 list(o2);
6526                 arg++;
6527                 break;
6528             case '&':
6529                 proto++;
6530                 arg++;
6531                 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6532                     bad_type(arg,
6533                         arg == 1 ? "block or sub {}" : "sub {}",
6534                         gv_ename(namegv), o2);
6535                 break;
6536             case '*':
6537                 /* '*' allows any scalar type, including bareword */
6538                 proto++;
6539                 arg++;
6540                 if (o2->op_type == OP_RV2GV)
6541                     goto wrapref;       /* autoconvert GLOB -> GLOBref */
6542                 else if (o2->op_type == OP_CONST)
6543                     o2->op_private &= ~OPpCONST_STRICT;
6544                 else if (o2->op_type == OP_ENTERSUB) {
6545                     /* accidental subroutine, revert to bareword */
6546                     OP *gvop = ((UNOP*)o2)->op_first;
6547                     if (gvop && gvop->op_type == OP_NULL) {
6548                         gvop = ((UNOP*)gvop)->op_first;
6549                         if (gvop) {
6550                             for (; gvop->op_sibling; gvop = gvop->op_sibling)
6551                                 ;
6552                             if (gvop &&
6553                                 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6554                                 (gvop = ((UNOP*)gvop)->op_first) &&
6555                                 gvop->op_type == OP_GV)
6556                             {
6557                                 GV *gv = cGVOPx_gv(gvop);
6558                                 OP *sibling = o2->op_sibling;
6559                                 SV *n = newSVpvn("",0);
6560                                 op_free(o2);
6561                                 gv_fullname3(n, gv, "");
6562                                 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6563                                     sv_chop(n, SvPVX(n)+6);
6564                                 o2 = newSVOP(OP_CONST, 0, n);
6565                                 prev->op_sibling = o2;
6566                                 o2->op_sibling = sibling;
6567                             }
6568                         }
6569                     }
6570                 }
6571                 scalar(o2);
6572                 break;
6573             case '\\':
6574                 proto++;
6575                 arg++;
6576                 switch (*proto++) {
6577                 case '*':
6578                     if (o2->op_type != OP_RV2GV)
6579                         bad_type(arg, "symbol", gv_ename(namegv), o2);
6580                     goto wrapref;
6581                 case '&':
6582                     if (o2->op_type != OP_ENTERSUB)
6583                         bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6584                     goto wrapref;
6585                 case '$':
6586                     if (o2->op_type != OP_RV2SV
6587                         && o2->op_type != OP_PADSV
6588                         && o2->op_type != OP_HELEM
6589                         && o2->op_type != OP_AELEM
6590                         && o2->op_type != OP_THREADSV)
6591                     {
6592                         bad_type(arg, "scalar", gv_ename(namegv), o2);
6593                     }
6594                     goto wrapref;
6595                 case '@':
6596                     if (o2->op_type != OP_RV2AV && o2->op_type != OP_PADAV)
6597                         bad_type(arg, "array", gv_ename(namegv), o2);
6598                     goto wrapref;
6599                 case '%':
6600                     if (o2->op_type != OP_RV2HV && o2->op_type != OP_PADHV)
6601                         bad_type(arg, "hash", gv_ename(namegv), o2);
6602                   wrapref:
6603                     {
6604                         OP* kid = o2;
6605                         OP* sib = kid->op_sibling;
6606                         kid->op_sibling = 0;
6607                         o2 = newUNOP(OP_REFGEN, 0, kid);
6608                         o2->op_sibling = sib;
6609                         prev->op_sibling = o2;
6610                     }
6611                     break;
6612                 default: goto oops;
6613                 }
6614                 break;
6615             case ' ':
6616                 proto++;
6617                 continue;
6618             default:
6619               oops:
6620                 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
6621                         gv_ename(namegv), SvPV((SV*)cv, n_a));
6622             }
6623         }
6624         else
6625             list(o2);
6626         mod(o2, OP_ENTERSUB);
6627         prev = o2;
6628         o2 = o2->op_sibling;
6629     }
6630     if (proto && !optional &&
6631           (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6632         return too_few_arguments(o, gv_ename(namegv));
6633     return o;
6634 }
6635
6636 OP *
6637 Perl_ck_svconst(pTHX_ OP *o)
6638 {
6639     SvREADONLY_on(cSVOPo->op_sv);
6640     return o;
6641 }
6642
6643 OP *
6644 Perl_ck_trunc(pTHX_ OP *o)
6645 {
6646     if (o->op_flags & OPf_KIDS) {
6647         SVOP *kid = (SVOP*)cUNOPo->op_first;
6648
6649         if (kid->op_type == OP_NULL)
6650             kid = (SVOP*)kid->op_sibling;
6651         if (kid && kid->op_type == OP_CONST &&
6652             (kid->op_private & OPpCONST_BARE))
6653         {
6654             o->op_flags |= OPf_SPECIAL;
6655             kid->op_private &= ~OPpCONST_STRICT;
6656         }
6657     }
6658     return ck_fun(o);
6659 }
6660
6661 OP *
6662 Perl_ck_substr(pTHX_ OP *o)
6663 {
6664     o = ck_fun(o);
6665     if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6666         OP *kid = cLISTOPo->op_first;
6667
6668         if (kid->op_type == OP_NULL)
6669             kid = kid->op_sibling;
6670         if (kid)
6671             kid->op_flags |= OPf_MOD;
6672
6673     }
6674     return o;
6675 }
6676
6677 /* A peephole optimizer.  We visit the ops in the order they're to execute. */
6678
6679 void
6680 Perl_peep(pTHX_ register OP *o)
6681 {
6682     register OP* oldop = 0;
6683     STRLEN n_a;
6684
6685     if (!o || o->op_seq)
6686         return;
6687     ENTER;
6688     SAVEOP();
6689     SAVEVPTR(PL_curcop);
6690     for (; o; o = o->op_next) {
6691         if (o->op_seq)
6692             break;
6693         if (!PL_op_seqmax)
6694             PL_op_seqmax++;
6695         PL_op = o;
6696         switch (o->op_type) {
6697         case OP_SETSTATE:
6698         case OP_NEXTSTATE:
6699         case OP_DBSTATE:
6700             PL_curcop = ((COP*)o);              /* for warnings */
6701             o->op_seq = PL_op_seqmax++;
6702             break;
6703
6704         case OP_CONST:
6705             if (cSVOPo->op_private & OPpCONST_STRICT)
6706                 no_bareword_allowed(o);
6707 #ifdef USE_ITHREADS
6708             /* Relocate sv to the pad for thread safety.
6709              * Despite being a "constant", the SV is written to,
6710              * for reference counts, sv_upgrade() etc. */
6711             if (cSVOP->op_sv) {
6712                 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6713                 if (SvPADTMP(cSVOPo->op_sv)) {
6714                     /* If op_sv is already a PADTMP then it is being used by
6715                      * some pad, so make a copy. */
6716                     sv_setsv(PL_curpad[ix],cSVOPo->op_sv);
6717                     SvREADONLY_on(PL_curpad[ix]);
6718                     SvREFCNT_dec(cSVOPo->op_sv);
6719                 }
6720                 else {
6721                     SvREFCNT_dec(PL_curpad[ix]);
6722                     SvPADTMP_on(cSVOPo->op_sv);
6723                     PL_curpad[ix] = cSVOPo->op_sv;
6724                     /* XXX I don't know how this isn't readonly already. */
6725                     SvREADONLY_on(PL_curpad[ix]);
6726                 }
6727                 cSVOPo->op_sv = Nullsv;
6728                 o->op_targ = ix;
6729             }
6730 #endif
6731             o->op_seq = PL_op_seqmax++;
6732             break;
6733
6734         case OP_CONCAT:
6735             if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6736                 if (o->op_next->op_private & OPpTARGET_MY) {
6737                     if (o->op_flags & OPf_STACKED) /* chained concats */
6738                         goto ignore_optimization;
6739                     else {
6740                         /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6741                         o->op_targ = o->op_next->op_targ;
6742                         o->op_next->op_targ = 0;
6743                         o->op_private |= OPpTARGET_MY;
6744                     }
6745                 }
6746                 null(o->op_next);
6747             }
6748           ignore_optimization:
6749             o->op_seq = PL_op_seqmax++;
6750             break;
6751         case OP_STUB:
6752             if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6753                 o->op_seq = PL_op_seqmax++;
6754                 break; /* Scalar stub must produce undef.  List stub is noop */
6755             }
6756             goto nothin;
6757         case OP_NULL:
6758             if (o->op_targ == OP_NEXTSTATE
6759                 || o->op_targ == OP_DBSTATE
6760                 || o->op_targ == OP_SETSTATE)
6761             {
6762                 PL_curcop = ((COP*)o);
6763             }
6764             goto nothin;
6765         case OP_SCALAR:
6766         case OP_LINESEQ:
6767         case OP_SCOPE:
6768           nothin:
6769             if (oldop && o->op_next) {
6770                 oldop->op_next = o->op_next;
6771                 continue;
6772             }
6773             o->op_seq = PL_op_seqmax++;
6774             break;
6775
6776         case OP_GV:
6777             if (o->op_next->op_type == OP_RV2SV) {
6778                 if (!(o->op_next->op_private & OPpDEREF)) {
6779                     null(o->op_next);
6780                     o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6781                                                                | OPpOUR_INTRO);
6782                     o->op_next = o->op_next->op_next;
6783                     o->op_type = OP_GVSV;
6784                     o->op_ppaddr = PL_ppaddr[OP_GVSV];
6785                 }
6786             }
6787             else if (o->op_next->op_type == OP_RV2AV) {
6788                 OP* pop = o->op_next->op_next;
6789                 IV i;
6790                 if (pop->op_type == OP_CONST &&
6791                     (PL_op = pop->op_next) &&
6792                     pop->op_next->op_type == OP_AELEM &&
6793                     !(pop->op_next->op_private &
6794                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6795                     (i = SvIV(((SVOP*)pop)->op_sv) - PL_compiling.cop_arybase)
6796                                 <= 255 &&
6797                     i >= 0)
6798                 {
6799                     GV *gv;
6800                     null(o->op_next);
6801                     null(pop->op_next);
6802                     null(pop);
6803                     o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6804                     o->op_next = pop->op_next->op_next;
6805                     o->op_type = OP_AELEMFAST;
6806                     o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6807                     o->op_private = (U8)i;
6808                     gv = cGVOPo_gv;
6809                     GvAVn(gv);
6810                 }
6811             }
6812             else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6813                 GV *gv = cGVOPo_gv;
6814                 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6815                     /* XXX could check prototype here instead of just carping */
6816                     SV *sv = sv_newmortal();
6817                     gv_efullname3(sv, gv, Nullch);
6818                     Perl_warner(aTHX_ WARN_PROTOTYPE,
6819                                 "%s() called too early to check prototype",
6820                                 SvPV_nolen(sv));
6821                 }
6822             }
6823
6824             o->op_seq = PL_op_seqmax++;
6825             break;
6826
6827         case OP_MAPWHILE:
6828         case OP_GREPWHILE:
6829         case OP_AND:
6830         case OP_OR:
6831         case OP_ANDASSIGN:
6832         case OP_ORASSIGN:
6833         case OP_COND_EXPR:
6834         case OP_RANGE:
6835             o->op_seq = PL_op_seqmax++;
6836             while (cLOGOP->op_other->op_type == OP_NULL)
6837                 cLOGOP->op_other = cLOGOP->op_other->op_next;
6838             peep(cLOGOP->op_other);
6839             break;
6840
6841         case OP_ENTERLOOP:
6842             o->op_seq = PL_op_seqmax++;
6843             while (cLOOP->op_redoop->op_type == OP_NULL)
6844                 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6845             peep(cLOOP->op_redoop);
6846             while (cLOOP->op_nextop->op_type == OP_NULL)
6847                 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6848             peep(cLOOP->op_nextop);
6849             while (cLOOP->op_lastop->op_type == OP_NULL)
6850                 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6851             peep(cLOOP->op_lastop);
6852             break;
6853
6854         case OP_QR:
6855         case OP_MATCH:
6856         case OP_SUBST:
6857             o->op_seq = PL_op_seqmax++;
6858             while (cPMOP->op_pmreplstart &&
6859                    cPMOP->op_pmreplstart->op_type == OP_NULL)
6860                 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6861             peep(cPMOP->op_pmreplstart);
6862             break;
6863
6864         case OP_EXEC:
6865             o->op_seq = PL_op_seqmax++;
6866             if (ckWARN(WARN_SYNTAX) && o->op_next
6867                 && o->op_next->op_type == OP_NEXTSTATE) {
6868                 if (o->op_next->op_sibling &&
6869                         o->op_next->op_sibling->op_type != OP_EXIT &&
6870                         o->op_next->op_sibling->op_type != OP_WARN &&
6871                         o->op_next->op_sibling->op_type != OP_DIE) {
6872                     line_t oldline = CopLINE(PL_curcop);
6873
6874                     CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6875                     Perl_warner(aTHX_ WARN_EXEC,
6876                                 "Statement unlikely to be reached");
6877                     Perl_warner(aTHX_ WARN_EXEC,
6878                                 "\t(Maybe you meant system() when you said exec()?)\n");
6879                     CopLINE_set(PL_curcop, oldline);
6880                 }
6881             }
6882             break;
6883
6884         case OP_HELEM: {
6885             UNOP *rop;
6886             SV *lexname;
6887             GV **fields;
6888             SV **svp, **indsvp, *sv;
6889             I32 ind;
6890             char *key = NULL;
6891             STRLEN keylen;
6892
6893             o->op_seq = PL_op_seqmax++;
6894
6895             if (((BINOP*)o)->op_last->op_type != OP_CONST)
6896                 break;
6897
6898             /* Make the CONST have a shared SV */
6899             svp = cSVOPx_svp(((BINOP*)o)->op_last);
6900             if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6901                 key = SvPV(sv, keylen);
6902                 if (SvUTF8(sv))
6903                   keylen = -keylen;
6904                 lexname = newSVpvn_share(key, keylen, 0);
6905                 SvREFCNT_dec(sv);
6906                 *svp = lexname;
6907             }
6908
6909             if ((o->op_private & (OPpLVAL_INTRO)))
6910                 break;
6911
6912             rop = (UNOP*)((BINOP*)o)->op_first;
6913             if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6914                 break;
6915             lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6916             if (!SvOBJECT(lexname))
6917                 break;
6918             fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6919             if (!fields || !GvHV(*fields))
6920                 break;
6921             key = SvPV(*svp, keylen);
6922             if (SvUTF8(*svp))
6923                 keylen = -keylen;
6924             indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE);
6925             if (!indsvp) {
6926                 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s",
6927                       key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
6928             }
6929             ind = SvIV(*indsvp);
6930             if (ind < 1)
6931                 Perl_croak(aTHX_ "Bad index while coercing array into hash");
6932             rop->op_type = OP_RV2AV;
6933             rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
6934             o->op_type = OP_AELEM;
6935             o->op_ppaddr = PL_ppaddr[OP_AELEM];
6936             sv = newSViv(ind);
6937             if (SvREADONLY(*svp))
6938                 SvREADONLY_on(sv);
6939             SvFLAGS(sv) |= (SvFLAGS(*svp)
6940                             & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
6941             SvREFCNT_dec(*svp);
6942             *svp = sv;
6943             break;
6944         }
6945
6946         case OP_HSLICE: {
6947             UNOP *rop;
6948             SV *lexname;
6949             GV **fields;
6950             SV **svp, **indsvp, *sv;
6951             I32 ind;
6952             char *key;
6953             STRLEN keylen;
6954             SVOP *first_key_op, *key_op;
6955
6956             o->op_seq = PL_op_seqmax++;
6957             if ((o->op_private & (OPpLVAL_INTRO))
6958                 /* I bet there's always a pushmark... */
6959                 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
6960                 /* hmmm, no optimization if list contains only one key. */
6961                 break;
6962             rop = (UNOP*)((LISTOP*)o)->op_last;
6963             if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6964                 break;
6965             lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6966             if (!SvOBJECT(lexname))
6967                 break;
6968             fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6969             if (!fields || !GvHV(*fields))
6970                 break;
6971             /* Again guessing that the pushmark can be jumped over.... */
6972             first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
6973                 ->op_first->op_sibling;
6974             /* Check that the key list contains only constants. */
6975             for (key_op = first_key_op; key_op;
6976                  key_op = (SVOP*)key_op->op_sibling)
6977                 if (key_op->op_type != OP_CONST)
6978                     break;
6979             if (key_op)
6980                 break;
6981             rop->op_type = OP_RV2AV;
6982             rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
6983             o->op_type = OP_ASLICE;
6984             o->op_ppaddr = PL_ppaddr[OP_ASLICE];
6985             for (key_op = first_key_op; key_op;
6986                  key_op = (SVOP*)key_op->op_sibling) {
6987                 svp = cSVOPx_svp(key_op);
6988                 key = SvPV(*svp, keylen);
6989                 if (SvUTF8(*svp))
6990                     keylen = -keylen;
6991                 indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE);
6992                 if (!indsvp) {
6993                     Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
6994                                "in variable %s of type %s",
6995                           key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
6996                 }
6997                 ind = SvIV(*indsvp);
6998                 if (ind < 1)
6999                     Perl_croak(aTHX_ "Bad index while coercing array into hash");
7000                 sv = newSViv(ind);
7001                 if (SvREADONLY(*svp))
7002                     SvREADONLY_on(sv);
7003                 SvFLAGS(sv) |= (SvFLAGS(*svp)
7004                                 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
7005                 SvREFCNT_dec(*svp);
7006                 *svp = sv;
7007             }
7008             break;
7009         }
7010
7011         default:
7012             o->op_seq = PL_op_seqmax++;
7013             break;
7014         }
7015         oldop = o;
7016     }
7017     LEAVE;
7018 }
7019
7020 #include "XSUB.h"
7021
7022 /* Efficient sub that returns a constant scalar value. */
7023 static void
7024 const_sv_xsub(pTHXo_ CV* cv)
7025 {
7026     dXSARGS;
7027     if (items != 0) {
7028 #if 0
7029         Perl_croak(aTHX_ "usage: %s::%s()",
7030                    HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7031 #endif
7032     }
7033     EXTEND(sp, 1);
7034     ST(0) = (SV*)XSANY.any_ptr;
7035     XSRETURN(1);
7036 }