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                 UV  val = utf8_to_uv(s, cur, &ulen, 0);
2735                 s += ulen;
2736                 diff = val - nextmin;
2737                 if (diff > 0) {
2738                     t = uv_to_utf8(tmpbuf,nextmin);
2739                     sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2740                     if (diff > 1) {
2741                         t = uv_to_utf8(tmpbuf, val - 1);
2742                         sv_catpvn(transv, "\377", 1);
2743                         sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2744                     }
2745                 }
2746                 if (s < tend && *s == 0xff)
2747                     val = utf8_to_uv(s+1, cur - 1, &ulen, 0);
2748                 if (val >= nextmin)
2749                     nextmin = val + 1;
2750             }
2751             t = uv_to_utf8(tmpbuf,nextmin);
2752             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2753             t = uv_to_utf8(tmpbuf, 0x7fffffff);
2754             sv_catpvn(transv, "\377", 1);
2755             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2756             t = (U8*)SvPVX(transv);
2757             tlen = SvCUR(transv);
2758             tend = t + tlen;
2759             Safefree(cp);
2760         }
2761         else if (!rlen && !del) {
2762             r = t; rlen = tlen; rend = tend;
2763         }
2764         if (!squash) {
2765                 if (t == r ||
2766                     (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2767                 {
2768                     o->op_private |= OPpTRANS_IDENTICAL;
2769                 }
2770         }
2771
2772         while (t < tend || tfirst <= tlast) {
2773             /* see if we need more "t" chars */
2774             if (tfirst > tlast) {
2775                 tfirst = (I32)utf8_to_uv(t, tend - t, &ulen, 0);
2776                 t += ulen;
2777                 if (t < tend && *t == 0xff) {   /* illegal utf8 val indicates range */
2778                     t++;
2779                     tlast = (I32)utf8_to_uv(t, tend - t, &ulen, 0);
2780                     t += ulen;
2781                 }
2782                 else
2783                     tlast = tfirst;
2784             }
2785
2786             /* now see if we need more "r" chars */
2787             if (rfirst > rlast) {
2788                 if (r < rend) {
2789                     rfirst = (I32)utf8_to_uv(r, rend - r, &ulen, 0);
2790                     r += ulen;
2791                     if (r < rend && *r == 0xff) {       /* illegal utf8 val indicates range */
2792                         r++;
2793                         rlast = (I32)utf8_to_uv(r, rend - r, &ulen, 0);
2794                         r += ulen;
2795                     }
2796                     else
2797                         rlast = rfirst;
2798                 }
2799                 else {
2800                     if (!havefinal++)
2801                         final = rlast;
2802                     rfirst = rlast = 0xffffffff;
2803                 }
2804             }
2805
2806             /* now see which range will peter our first, if either. */
2807             tdiff = tlast - tfirst;
2808             rdiff = rlast - rfirst;
2809
2810             if (tdiff <= rdiff)
2811                 diff = tdiff;
2812             else
2813                 diff = rdiff;
2814
2815             if (rfirst == 0xffffffff) {
2816                 diff = tdiff;   /* oops, pretend rdiff is infinite */
2817                 if (diff > 0)
2818                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2819                                    (long)tfirst, (long)tlast);
2820                 else
2821                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2822             }
2823             else {
2824                 if (diff > 0)
2825                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2826                                    (long)tfirst, (long)(tfirst + diff),
2827                                    (long)rfirst);
2828                 else
2829                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2830                                    (long)tfirst, (long)rfirst);
2831
2832                 if (rfirst + diff > max)
2833                     max = rfirst + diff;
2834                 rfirst += diff + 1;
2835                 if (!grows)
2836                     grows = (UNISKIP(tfirst) < UNISKIP(rfirst));
2837             }
2838             tfirst += diff + 1;
2839         }
2840
2841         none = ++max;
2842         if (del)
2843             del = ++max;
2844
2845         if (max > 0xffff)
2846             bits = 32;
2847         else if (max > 0xff)
2848             bits = 16;
2849         else
2850             bits = 8;
2851
2852         Safefree(cPVOPo->op_pv);
2853         cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2854         SvREFCNT_dec(listsv);
2855         if (transv)
2856             SvREFCNT_dec(transv);
2857
2858         if (!del && havefinal)
2859             (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2860                            newSVuv((UV)final), 0);
2861
2862         if (grows)
2863             o->op_private |= OPpTRANS_GROWS;
2864
2865         if (tsave)
2866             Safefree(tsave);
2867         if (rsave)
2868             Safefree(rsave);
2869
2870         op_free(expr);
2871         op_free(repl);
2872         return o;
2873     }
2874
2875     tbl = (short*)cPVOPo->op_pv;
2876     if (complement) {
2877         Zero(tbl, 256, short);
2878         for (i = 0; i < tlen; i++)
2879             tbl[t[i]] = -1;
2880         for (i = 0, j = 0; i < 256; i++) {
2881             if (!tbl[i]) {
2882                 if (j >= rlen) {
2883                     if (del)
2884                         tbl[i] = -2;
2885                     else if (rlen)
2886                         tbl[i] = r[j-1];
2887                     else
2888                         tbl[i] = i;
2889                 }
2890                 else {
2891                     if (i < 128 && r[j] >= 128)
2892                         grows = 1;
2893                     tbl[i] = r[j++];
2894                 }
2895             }
2896         }
2897         if (!del) {
2898             if (j >= rlen)
2899                 j = rlen - 1;
2900             else
2901                 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
2902             tbl[0x100] = rlen - j;
2903             for (i=0; i < rlen - j; i++)
2904                 tbl[0x101+i] = r[j+i];
2905         }
2906     }
2907     else {
2908         if (!rlen && !del) {
2909             r = t; rlen = tlen;
2910             if (!squash)
2911                 o->op_private |= OPpTRANS_IDENTICAL;
2912         }
2913         for (i = 0; i < 256; i++)
2914             tbl[i] = -1;
2915         for (i = 0, j = 0; i < tlen; i++,j++) {
2916             if (j >= rlen) {
2917                 if (del) {
2918                     if (tbl[t[i]] == -1)
2919                         tbl[t[i]] = -2;
2920                     continue;
2921                 }
2922                 --j;
2923             }
2924             if (tbl[t[i]] == -1) {
2925                 if (t[i] < 128 && r[j] >= 128)
2926                     grows = 1;
2927                 tbl[t[i]] = r[j];
2928             }
2929         }
2930     }
2931     if (grows)
2932         o->op_private |= OPpTRANS_GROWS;
2933     op_free(expr);
2934     op_free(repl);
2935
2936     return o;
2937 }
2938
2939 OP *
2940 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2941 {
2942     PMOP *pmop;
2943
2944     NewOp(1101, pmop, 1, PMOP);
2945     pmop->op_type = type;
2946     pmop->op_ppaddr = PL_ppaddr[type];
2947     pmop->op_flags = flags;
2948     pmop->op_private = 0 | (flags >> 8);
2949
2950     if (PL_hints & HINT_RE_TAINT)
2951         pmop->op_pmpermflags |= PMf_RETAINT;
2952     if (PL_hints & HINT_LOCALE)
2953         pmop->op_pmpermflags |= PMf_LOCALE;
2954     pmop->op_pmflags = pmop->op_pmpermflags;
2955
2956     /* link into pm list */
2957     if (type != OP_TRANS && PL_curstash) {
2958         pmop->op_pmnext = HvPMROOT(PL_curstash);
2959         HvPMROOT(PL_curstash) = pmop;
2960         PmopSTASH_set(pmop,PL_curstash);
2961     }
2962
2963     return (OP*)pmop;
2964 }
2965
2966 OP *
2967 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
2968 {
2969     PMOP *pm;
2970     LOGOP *rcop;
2971     I32 repl_has_vars = 0;
2972
2973     if (o->op_type == OP_TRANS)
2974         return pmtrans(o, expr, repl);
2975
2976     PL_hints |= HINT_BLOCK_SCOPE;
2977     pm = (PMOP*)o;
2978
2979     if (expr->op_type == OP_CONST) {
2980         STRLEN plen;
2981         SV *pat = ((SVOP*)expr)->op_sv;
2982         char *p = SvPV(pat, plen);
2983         if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
2984             sv_setpvn(pat, "\\s+", 3);
2985             p = SvPV(pat, plen);
2986             pm->op_pmflags |= PMf_SKIPWHITE;
2987         }
2988         if ((PL_hints & HINT_UTF8) || DO_UTF8(pat))
2989             pm->op_pmdynflags |= PMdf_UTF8;
2990         pm->op_pmregexp = CALLREGCOMP(aTHX_ p, p + plen, pm);
2991         if (strEQ("\\s+", pm->op_pmregexp->precomp))
2992             pm->op_pmflags |= PMf_WHITE;
2993         op_free(expr);
2994     }
2995     else {
2996         if (PL_hints & HINT_UTF8)
2997             pm->op_pmdynflags |= PMdf_UTF8;
2998         if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
2999             expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3000                             ? OP_REGCRESET
3001                             : OP_REGCMAYBE),0,expr);
3002
3003         NewOp(1101, rcop, 1, LOGOP);
3004         rcop->op_type = OP_REGCOMP;
3005         rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3006         rcop->op_first = scalar(expr);
3007         rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
3008                            ? (OPf_SPECIAL | OPf_KIDS)
3009                            : OPf_KIDS);
3010         rcop->op_private = 1;
3011         rcop->op_other = o;
3012
3013         /* establish postfix order */
3014         if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3015             LINKLIST(expr);
3016             rcop->op_next = expr;
3017             ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3018         }
3019         else {
3020             rcop->op_next = LINKLIST(expr);
3021             expr->op_next = (OP*)rcop;
3022         }
3023
3024         prepend_elem(o->op_type, scalar((OP*)rcop), o);
3025     }
3026
3027     if (repl) {
3028         OP *curop;
3029         if (pm->op_pmflags & PMf_EVAL) {
3030             curop = 0;
3031             if (CopLINE(PL_curcop) < PL_multi_end)
3032                 CopLINE_set(PL_curcop, PL_multi_end);
3033         }
3034 #ifdef USE_THREADS
3035         else if (repl->op_type == OP_THREADSV
3036                  && strchr("&`'123456789+",
3037                            PL_threadsv_names[repl->op_targ]))
3038         {
3039             curop = 0;
3040         }
3041 #endif /* USE_THREADS */
3042         else if (repl->op_type == OP_CONST)
3043             curop = repl;
3044         else {
3045             OP *lastop = 0;
3046             for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3047                 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3048 #ifdef USE_THREADS
3049                     if (curop->op_type == OP_THREADSV) {
3050                         repl_has_vars = 1;
3051                         if (strchr("&`'123456789+", curop->op_private))
3052                             break;
3053                     }
3054 #else
3055                     if (curop->op_type == OP_GV) {
3056                         GV *gv = cGVOPx_gv(curop);
3057                         repl_has_vars = 1;
3058                         if (strchr("&`'123456789+", *GvENAME(gv)))
3059                             break;
3060                     }
3061 #endif /* USE_THREADS */
3062                     else if (curop->op_type == OP_RV2CV)
3063                         break;
3064                     else if (curop->op_type == OP_RV2SV ||
3065                              curop->op_type == OP_RV2AV ||
3066                              curop->op_type == OP_RV2HV ||
3067                              curop->op_type == OP_RV2GV) {
3068                         if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3069                             break;
3070                     }
3071                     else if (curop->op_type == OP_PADSV ||
3072                              curop->op_type == OP_PADAV ||
3073                              curop->op_type == OP_PADHV ||
3074                              curop->op_type == OP_PADANY) {
3075                         repl_has_vars = 1;
3076                     }
3077                     else if (curop->op_type == OP_PUSHRE)
3078                         ; /* Okay here, dangerous in newASSIGNOP */
3079                     else
3080                         break;
3081                 }
3082                 lastop = curop;
3083             }
3084         }
3085         if (curop == repl
3086             && !(repl_has_vars
3087                  && (!pm->op_pmregexp
3088                      || pm->op_pmregexp->reganch & ROPT_EVAL_SEEN))) {
3089             pm->op_pmflags |= PMf_CONST;        /* const for long enough */
3090             pm->op_pmpermflags |= PMf_CONST;    /* const for long enough */
3091             prepend_elem(o->op_type, scalar(repl), o);
3092         }
3093         else {
3094             if (curop == repl && !pm->op_pmregexp) { /* Has variables. */
3095                 pm->op_pmflags |= PMf_MAYBE_CONST;
3096                 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3097             }
3098             NewOp(1101, rcop, 1, LOGOP);
3099             rcop->op_type = OP_SUBSTCONT;
3100             rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3101             rcop->op_first = scalar(repl);
3102             rcop->op_flags |= OPf_KIDS;
3103             rcop->op_private = 1;
3104             rcop->op_other = o;
3105
3106             /* establish postfix order */
3107             rcop->op_next = LINKLIST(repl);
3108             repl->op_next = (OP*)rcop;
3109
3110             pm->op_pmreplroot = scalar((OP*)rcop);
3111             pm->op_pmreplstart = LINKLIST(rcop);
3112             rcop->op_next = 0;
3113         }
3114     }
3115
3116     return (OP*)pm;
3117 }
3118
3119 OP *
3120 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3121 {
3122     SVOP *svop;
3123     NewOp(1101, svop, 1, SVOP);
3124     svop->op_type = type;
3125     svop->op_ppaddr = PL_ppaddr[type];
3126     svop->op_sv = sv;
3127     svop->op_next = (OP*)svop;
3128     svop->op_flags = flags;
3129     if (PL_opargs[type] & OA_RETSCALAR)
3130         scalar((OP*)svop);
3131     if (PL_opargs[type] & OA_TARGET)
3132         svop->op_targ = pad_alloc(type, SVs_PADTMP);
3133     return CHECKOP(type, svop);
3134 }
3135
3136 OP *
3137 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3138 {
3139     PADOP *padop;
3140     NewOp(1101, padop, 1, PADOP);
3141     padop->op_type = type;
3142     padop->op_ppaddr = PL_ppaddr[type];
3143     padop->op_padix = pad_alloc(type, SVs_PADTMP);
3144     SvREFCNT_dec(PL_curpad[padop->op_padix]);
3145     PL_curpad[padop->op_padix] = sv;
3146     SvPADTMP_on(sv);
3147     padop->op_next = (OP*)padop;
3148     padop->op_flags = flags;
3149     if (PL_opargs[type] & OA_RETSCALAR)
3150         scalar((OP*)padop);
3151     if (PL_opargs[type] & OA_TARGET)
3152         padop->op_targ = pad_alloc(type, SVs_PADTMP);
3153     return CHECKOP(type, padop);
3154 }
3155
3156 OP *
3157 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3158 {
3159 #ifdef USE_ITHREADS
3160     GvIN_PAD_on(gv);
3161     return newPADOP(type, flags, SvREFCNT_inc(gv));
3162 #else
3163     return newSVOP(type, flags, SvREFCNT_inc(gv));
3164 #endif
3165 }
3166
3167 OP *
3168 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3169 {
3170     PVOP *pvop;
3171     NewOp(1101, pvop, 1, PVOP);
3172     pvop->op_type = type;
3173     pvop->op_ppaddr = PL_ppaddr[type];
3174     pvop->op_pv = pv;
3175     pvop->op_next = (OP*)pvop;
3176     pvop->op_flags = flags;
3177     if (PL_opargs[type] & OA_RETSCALAR)
3178         scalar((OP*)pvop);
3179     if (PL_opargs[type] & OA_TARGET)
3180         pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3181     return CHECKOP(type, pvop);
3182 }
3183
3184 void
3185 Perl_package(pTHX_ OP *o)
3186 {
3187     SV *sv;
3188
3189     save_hptr(&PL_curstash);
3190     save_item(PL_curstname);
3191     if (o) {
3192         STRLEN len;
3193         char *name;
3194         sv = cSVOPo->op_sv;
3195         name = SvPV(sv, len);
3196         PL_curstash = gv_stashpvn(name,len,TRUE);
3197         sv_setpvn(PL_curstname, name, len);
3198         op_free(o);
3199     }
3200     else {
3201         sv_setpv(PL_curstname,"<none>");
3202         PL_curstash = Nullhv;
3203     }
3204     PL_hints |= HINT_BLOCK_SCOPE;
3205     PL_copline = NOLINE;
3206     PL_expect = XSTATE;
3207 }
3208
3209 void
3210 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
3211 {
3212     OP *pack;
3213     OP *rqop;
3214     OP *imop;
3215     OP *veop;
3216     GV *gv;
3217
3218     if (id->op_type != OP_CONST)
3219         Perl_croak(aTHX_ "Module name must be constant");
3220
3221     veop = Nullop;
3222
3223     if (version != Nullop) {
3224         SV *vesv = ((SVOP*)version)->op_sv;
3225
3226         if (arg == Nullop && !SvNIOKp(vesv)) {
3227             arg = version;
3228         }
3229         else {
3230             OP *pack;
3231             SV *meth;
3232
3233             if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3234                 Perl_croak(aTHX_ "Version number must be constant number");
3235
3236             /* Make copy of id so we don't free it twice */
3237             pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3238
3239             /* Fake up a method call to VERSION */
3240             meth = newSVpvn("VERSION",7);
3241             sv_upgrade(meth, SVt_PVIV);
3242             (void)SvIOK_on(meth);
3243             PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3244             veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3245                             append_elem(OP_LIST,
3246                                         prepend_elem(OP_LIST, pack, list(version)),
3247                                         newSVOP(OP_METHOD_NAMED, 0, meth)));
3248         }
3249     }
3250
3251     /* Fake up an import/unimport */
3252     if (arg && arg->op_type == OP_STUB)
3253         imop = arg;             /* no import on explicit () */
3254     else if (SvNIOKp(((SVOP*)id)->op_sv)) {
3255         imop = Nullop;          /* use 5.0; */
3256     }
3257     else {
3258         SV *meth;
3259
3260         /* Make copy of id so we don't free it twice */
3261         pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3262
3263         /* Fake up a method call to import/unimport */
3264         meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);;
3265         sv_upgrade(meth, SVt_PVIV);
3266         (void)SvIOK_on(meth);
3267         PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3268         imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3269                        append_elem(OP_LIST,
3270                                    prepend_elem(OP_LIST, pack, list(arg)),
3271                                    newSVOP(OP_METHOD_NAMED, 0, meth)));
3272     }
3273
3274     /* Fake up a require, handle override, if any */
3275     gv = gv_fetchpv("require", FALSE, SVt_PVCV);
3276     if (!(gv && GvIMPORTED_CV(gv)))
3277         gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
3278
3279     if (gv && GvIMPORTED_CV(gv)) {
3280         rqop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3281                                append_elem(OP_LIST, id,
3282                                            scalar(newUNOP(OP_RV2CV, 0,
3283                                                           newGVOP(OP_GV, 0,
3284                                                                   gv))))));
3285     }
3286     else {
3287         rqop = newUNOP(OP_REQUIRE, 0, id);
3288     }
3289
3290     /* Fake up the BEGIN {}, which does its thing immediately. */
3291     newATTRSUB(floor,
3292         newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
3293         Nullop,
3294         Nullop,
3295         append_elem(OP_LINESEQ,
3296             append_elem(OP_LINESEQ,
3297                 newSTATEOP(0, Nullch, rqop),
3298                 newSTATEOP(0, Nullch, veop)),
3299             newSTATEOP(0, Nullch, imop) ));
3300
3301     PL_hints |= HINT_BLOCK_SCOPE;
3302     PL_copline = NOLINE;
3303     PL_expect = XSTATE;
3304 }
3305
3306 void
3307 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3308 {
3309     va_list args;
3310     va_start(args, ver);
3311     vload_module(flags, name, ver, &args);
3312     va_end(args);
3313 }
3314
3315 #ifdef PERL_IMPLICIT_CONTEXT
3316 void
3317 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3318 {
3319     dTHX;
3320     va_list args;
3321     va_start(args, ver);
3322     vload_module(flags, name, ver, &args);
3323     va_end(args);
3324 }
3325 #endif
3326
3327 void
3328 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3329 {
3330     OP *modname, *veop, *imop;
3331
3332     modname = newSVOP(OP_CONST, 0, name);
3333     modname->op_private |= OPpCONST_BARE;
3334     if (ver) {
3335         veop = newSVOP(OP_CONST, 0, ver);
3336     }
3337     else
3338         veop = Nullop;
3339     if (flags & PERL_LOADMOD_NOIMPORT) {
3340         imop = sawparens(newNULLLIST());
3341     }
3342     else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3343         imop = va_arg(*args, OP*);
3344     }
3345     else {
3346         SV *sv;
3347         imop = Nullop;
3348         sv = va_arg(*args, SV*);
3349         while (sv) {
3350             imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3351             sv = va_arg(*args, SV*);
3352         }
3353     }
3354     {
3355         line_t ocopline = PL_copline;
3356         int oexpect = PL_expect;
3357
3358         utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3359                 veop, modname, imop);
3360         PL_expect = oexpect;
3361         PL_copline = ocopline;
3362     }
3363 }
3364
3365 OP *
3366 Perl_dofile(pTHX_ OP *term)
3367 {
3368     OP *doop;
3369     GV *gv;
3370
3371     gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3372     if (!(gv && GvIMPORTED_CV(gv)))
3373         gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3374
3375     if (gv && GvIMPORTED_CV(gv)) {
3376         doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3377                                append_elem(OP_LIST, term,
3378                                            scalar(newUNOP(OP_RV2CV, 0,
3379                                                           newGVOP(OP_GV, 0,
3380                                                                   gv))))));
3381     }
3382     else {
3383         doop = newUNOP(OP_DOFILE, 0, scalar(term));
3384     }
3385     return doop;
3386 }
3387
3388 OP *
3389 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3390 {
3391     return newBINOP(OP_LSLICE, flags,
3392             list(force_list(subscript)),
3393             list(force_list(listval)) );
3394 }
3395
3396 STATIC I32
3397 S_list_assignment(pTHX_ register OP *o)
3398 {
3399     if (!o)
3400         return TRUE;
3401
3402     if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3403         o = cUNOPo->op_first;
3404
3405     if (o->op_type == OP_COND_EXPR) {
3406         I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3407         I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3408
3409         if (t && f)
3410             return TRUE;
3411         if (t || f)
3412             yyerror("Assignment to both a list and a scalar");
3413         return FALSE;
3414     }
3415
3416     if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3417         o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3418         o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3419         return TRUE;
3420
3421     if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3422         return TRUE;
3423
3424     if (o->op_type == OP_RV2SV)
3425         return FALSE;
3426
3427     return FALSE;
3428 }
3429
3430 OP *
3431 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3432 {
3433     OP *o;
3434
3435     if (optype) {
3436         if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN) {
3437             return newLOGOP(optype, 0,
3438                 mod(scalar(left), optype),
3439                 newUNOP(OP_SASSIGN, 0, scalar(right)));
3440         }
3441         else {
3442             return newBINOP(optype, OPf_STACKED,
3443                 mod(scalar(left), optype), scalar(right));
3444         }
3445     }
3446
3447     if (list_assignment(left)) {
3448         OP *curop;
3449
3450         PL_modcount = 0;
3451         PL_eval_start = right;  /* Grandfathering $[ assignment here.  Bletch.*/
3452         left = mod(left, OP_AASSIGN);
3453         if (PL_eval_start)
3454             PL_eval_start = 0;
3455         else {
3456             op_free(left);
3457             op_free(right);
3458             return Nullop;
3459         }
3460         curop = list(force_list(left));
3461         o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3462         o->op_private = 0 | (flags >> 8);
3463         for (curop = ((LISTOP*)curop)->op_first;
3464              curop; curop = curop->op_sibling)
3465         {
3466             if (curop->op_type == OP_RV2HV &&
3467                 ((UNOP*)curop)->op_first->op_type != OP_GV) {
3468                 o->op_private |= OPpASSIGN_HASH;
3469                 break;
3470             }
3471         }
3472         if (!(left->op_private & OPpLVAL_INTRO)) {
3473             OP *lastop = o;
3474             PL_generation++;
3475             for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3476                 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3477                     if (curop->op_type == OP_GV) {
3478                         GV *gv = cGVOPx_gv(curop);
3479                         if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3480                             break;
3481                         SvCUR(gv) = PL_generation;
3482                     }
3483                     else if (curop->op_type == OP_PADSV ||
3484                              curop->op_type == OP_PADAV ||
3485                              curop->op_type == OP_PADHV ||
3486                              curop->op_type == OP_PADANY) {
3487                         SV **svp = AvARRAY(PL_comppad_name);
3488                         SV *sv = svp[curop->op_targ];
3489                         if (SvCUR(sv) == PL_generation)
3490                             break;
3491                         SvCUR(sv) = PL_generation;      /* (SvCUR not used any more) */
3492                     }
3493                     else if (curop->op_type == OP_RV2CV)
3494                         break;
3495                     else if (curop->op_type == OP_RV2SV ||
3496                              curop->op_type == OP_RV2AV ||
3497                              curop->op_type == OP_RV2HV ||
3498                              curop->op_type == OP_RV2GV) {
3499                         if (lastop->op_type != OP_GV)   /* funny deref? */
3500                             break;
3501                     }
3502                     else if (curop->op_type == OP_PUSHRE) {
3503                         if (((PMOP*)curop)->op_pmreplroot) {
3504 #ifdef USE_ITHREADS
3505                             GV *gv = (GV*)PL_curpad[(PADOFFSET)((PMOP*)curop)->op_pmreplroot];
3506 #else
3507                             GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3508 #endif
3509                             if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3510                                 break;
3511                             SvCUR(gv) = PL_generation;
3512                         }
3513                     }
3514                     else
3515                         break;
3516                 }
3517                 lastop = curop;
3518             }
3519             if (curop != o)
3520                 o->op_private |= OPpASSIGN_COMMON;
3521         }
3522         if (right && right->op_type == OP_SPLIT) {
3523             OP* tmpop;
3524             if ((tmpop = ((LISTOP*)right)->op_first) &&
3525                 tmpop->op_type == OP_PUSHRE)
3526             {
3527                 PMOP *pm = (PMOP*)tmpop;
3528                 if (left->op_type == OP_RV2AV &&
3529                     !(left->op_private & OPpLVAL_INTRO) &&
3530                     !(o->op_private & OPpASSIGN_COMMON) )
3531                 {
3532                     tmpop = ((UNOP*)left)->op_first;
3533                     if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3534 #ifdef USE_ITHREADS
3535                         pm->op_pmreplroot = (OP*)cPADOPx(tmpop)->op_padix;
3536                         cPADOPx(tmpop)->op_padix = 0;   /* steal it */
3537 #else
3538                         pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3539                         cSVOPx(tmpop)->op_sv = Nullsv;  /* steal it */
3540 #endif
3541                         pm->op_pmflags |= PMf_ONCE;
3542                         tmpop = cUNOPo->op_first;       /* to list (nulled) */
3543                         tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3544                         tmpop->op_sibling = Nullop;     /* don't free split */
3545                         right->op_next = tmpop->op_next;  /* fix starting loc */
3546                         op_free(o);                     /* blow off assign */
3547                         right->op_flags &= ~OPf_WANT;
3548                                 /* "I don't know and I don't care." */
3549                         return right;
3550                     }
3551                 }
3552                 else {
3553                    if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3554                       ((LISTOP*)right)->op_last->op_type == OP_CONST)
3555                     {
3556                         SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3557                         if (SvIVX(sv) == 0)
3558                             sv_setiv(sv, PL_modcount+1);
3559                     }
3560                 }
3561             }
3562         }
3563         return o;
3564     }
3565     if (!right)
3566         right = newOP(OP_UNDEF, 0);
3567     if (right->op_type == OP_READLINE) {
3568         right->op_flags |= OPf_STACKED;
3569         return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3570     }
3571     else {
3572         PL_eval_start = right;  /* Grandfathering $[ assignment here.  Bletch.*/
3573         o = newBINOP(OP_SASSIGN, flags,
3574             scalar(right), mod(scalar(left), OP_SASSIGN) );
3575         if (PL_eval_start)
3576             PL_eval_start = 0;
3577         else {
3578             op_free(o);
3579             return Nullop;
3580         }
3581     }
3582     return o;
3583 }
3584
3585 OP *
3586 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3587 {
3588     U32 seq = intro_my();
3589     register COP *cop;
3590
3591     NewOp(1101, cop, 1, COP);
3592     if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3593         cop->op_type = OP_DBSTATE;
3594         cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3595     }
3596     else {
3597         cop->op_type = OP_NEXTSTATE;
3598         cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3599     }
3600     cop->op_flags = flags;
3601     cop->op_private = (PL_hints & HINT_BYTE);
3602 #ifdef NATIVE_HINTS
3603     cop->op_private |= NATIVE_HINTS;
3604 #endif
3605     PL_compiling.op_private = cop->op_private;
3606     cop->op_next = (OP*)cop;
3607
3608     if (label) {
3609         cop->cop_label = label;
3610         PL_hints |= HINT_BLOCK_SCOPE;
3611     }
3612     cop->cop_seq = seq;
3613     cop->cop_arybase = PL_curcop->cop_arybase;
3614     if (specialWARN(PL_curcop->cop_warnings))
3615         cop->cop_warnings = PL_curcop->cop_warnings ;
3616     else
3617         cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3618     if (specialCopIO(PL_curcop->cop_io))
3619         cop->cop_io = PL_curcop->cop_io;
3620     else
3621         cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3622
3623
3624     if (PL_copline == NOLINE)
3625         CopLINE_set(cop, CopLINE(PL_curcop));
3626     else {
3627         CopLINE_set(cop, PL_copline);
3628         PL_copline = NOLINE;
3629     }
3630 #ifdef USE_ITHREADS
3631     CopFILE_set(cop, CopFILE(PL_curcop));       /* XXX share in a pvtable? */
3632 #else
3633     CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3634 #endif
3635     CopSTASH_set(cop, PL_curstash);
3636
3637     if (PERLDB_LINE && PL_curstash != PL_debstash) {
3638         SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3639         if (svp && *svp != &PL_sv_undef && !SvIOK(*svp)) {
3640             (void)SvIOK_on(*svp);
3641             SvIVX(*svp) = PTR2IV(cop);
3642         }
3643     }
3644
3645     return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3646 }
3647
3648 /* "Introduce" my variables to visible status. */
3649 U32
3650 Perl_intro_my(pTHX)
3651 {
3652     SV **svp;
3653     SV *sv;
3654     I32 i;
3655
3656     if (! PL_min_intro_pending)
3657         return PL_cop_seqmax;
3658
3659     svp = AvARRAY(PL_comppad_name);
3660     for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
3661         if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) {
3662             SvIVX(sv) = PAD_MAX;        /* Don't know scope end yet. */
3663             SvNVX(sv) = (NV)PL_cop_seqmax;
3664         }
3665     }
3666     PL_min_intro_pending = 0;
3667     PL_comppad_name_fill = PL_max_intro_pending;        /* Needn't search higher */
3668     return PL_cop_seqmax++;
3669 }
3670
3671 OP *
3672 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3673 {
3674     return new_logop(type, flags, &first, &other);
3675 }
3676
3677 STATIC OP *
3678 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3679 {
3680     LOGOP *logop;
3681     OP *o;
3682     OP *first = *firstp;
3683     OP *other = *otherp;
3684
3685     if (type == OP_XOR)         /* Not short circuit, but here by precedence. */
3686         return newBINOP(type, flags, scalar(first), scalar(other));
3687
3688     scalarboolean(first);
3689     /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3690     if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3691         if (type == OP_AND || type == OP_OR) {
3692             if (type == OP_AND)
3693                 type = OP_OR;
3694             else
3695                 type = OP_AND;
3696             o = first;
3697             first = *firstp = cUNOPo->op_first;
3698             if (o->op_next)
3699                 first->op_next = o->op_next;
3700             cUNOPo->op_first = Nullop;
3701             op_free(o);
3702         }
3703     }
3704     if (first->op_type == OP_CONST) {
3705         if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3706             Perl_warner(aTHX_ WARN_BAREWORD, "Bareword found in conditional");
3707         if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3708             op_free(first);
3709             *firstp = Nullop;
3710             return other;
3711         }
3712         else {
3713             op_free(other);
3714             *otherp = Nullop;
3715             return first;
3716         }
3717     }
3718     else if (first->op_type == OP_WANTARRAY) {
3719         if (type == OP_AND)
3720             list(other);
3721         else
3722             scalar(other);
3723     }
3724     else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
3725         OP *k1 = ((UNOP*)first)->op_first;
3726         OP *k2 = k1->op_sibling;
3727         OPCODE warnop = 0;
3728         switch (first->op_type)
3729         {
3730         case OP_NULL:
3731             if (k2 && k2->op_type == OP_READLINE
3732                   && (k2->op_flags & OPf_STACKED)
3733                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3734             {
3735                 warnop = k2->op_type;
3736             }
3737             break;
3738
3739         case OP_SASSIGN:
3740             if (k1->op_type == OP_READDIR
3741                   || k1->op_type == OP_GLOB
3742                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3743                   || k1->op_type == OP_EACH)
3744             {
3745                 warnop = ((k1->op_type == OP_NULL)
3746                           ? k1->op_targ : k1->op_type);
3747             }
3748             break;
3749         }
3750         if (warnop) {
3751             line_t oldline = CopLINE(PL_curcop);
3752             CopLINE_set(PL_curcop, PL_copline);
3753             Perl_warner(aTHX_ WARN_MISC,
3754                  "Value of %s%s can be \"0\"; test with defined()",
3755                  PL_op_desc[warnop],
3756                  ((warnop == OP_READLINE || warnop == OP_GLOB)
3757                   ? " construct" : "() operator"));
3758             CopLINE_set(PL_curcop, oldline);
3759         }
3760     }
3761
3762     if (!other)
3763         return first;
3764
3765     if (type == OP_ANDASSIGN || type == OP_ORASSIGN)
3766         other->op_private |= OPpASSIGN_BACKWARDS;  /* other is an OP_SASSIGN */
3767
3768     NewOp(1101, logop, 1, LOGOP);
3769
3770     logop->op_type = type;
3771     logop->op_ppaddr = PL_ppaddr[type];
3772     logop->op_first = first;
3773     logop->op_flags = flags | OPf_KIDS;
3774     logop->op_other = LINKLIST(other);
3775     logop->op_private = 1 | (flags >> 8);
3776
3777     /* establish postfix order */
3778     logop->op_next = LINKLIST(first);
3779     first->op_next = (OP*)logop;
3780     first->op_sibling = other;
3781
3782     o = newUNOP(OP_NULL, 0, (OP*)logop);
3783     other->op_next = o;
3784
3785     return o;
3786 }
3787
3788 OP *
3789 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3790 {
3791     LOGOP *logop;
3792     OP *start;
3793     OP *o;
3794
3795     if (!falseop)
3796         return newLOGOP(OP_AND, 0, first, trueop);
3797     if (!trueop)
3798         return newLOGOP(OP_OR, 0, first, falseop);
3799
3800     scalarboolean(first);
3801     if (first->op_type == OP_CONST) {
3802         if (SvTRUE(((SVOP*)first)->op_sv)) {
3803             op_free(first);
3804             op_free(falseop);
3805             return trueop;
3806         }
3807         else {
3808             op_free(first);
3809             op_free(trueop);
3810             return falseop;
3811         }
3812     }
3813     else if (first->op_type == OP_WANTARRAY) {
3814         list(trueop);
3815         scalar(falseop);
3816     }
3817     NewOp(1101, logop, 1, LOGOP);
3818     logop->op_type = OP_COND_EXPR;
3819     logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3820     logop->op_first = first;
3821     logop->op_flags = flags | OPf_KIDS;
3822     logop->op_private = 1 | (flags >> 8);
3823     logop->op_other = LINKLIST(trueop);
3824     logop->op_next = LINKLIST(falseop);
3825
3826
3827     /* establish postfix order */
3828     start = LINKLIST(first);
3829     first->op_next = (OP*)logop;
3830
3831     first->op_sibling = trueop;
3832     trueop->op_sibling = falseop;
3833     o = newUNOP(OP_NULL, 0, (OP*)logop);
3834
3835     trueop->op_next = falseop->op_next = o;
3836
3837     o->op_next = start;
3838     return o;
3839 }
3840
3841 OP *
3842 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3843 {
3844     LOGOP *range;
3845     OP *flip;
3846     OP *flop;
3847     OP *leftstart;
3848     OP *o;
3849
3850     NewOp(1101, range, 1, LOGOP);
3851
3852     range->op_type = OP_RANGE;
3853     range->op_ppaddr = PL_ppaddr[OP_RANGE];
3854     range->op_first = left;
3855     range->op_flags = OPf_KIDS;
3856     leftstart = LINKLIST(left);
3857     range->op_other = LINKLIST(right);
3858     range->op_private = 1 | (flags >> 8);
3859
3860     left->op_sibling = right;
3861
3862     range->op_next = (OP*)range;
3863     flip = newUNOP(OP_FLIP, flags, (OP*)range);
3864     flop = newUNOP(OP_FLOP, 0, flip);
3865     o = newUNOP(OP_NULL, 0, flop);
3866     linklist(flop);
3867     range->op_next = leftstart;
3868
3869     left->op_next = flip;
3870     right->op_next = flop;
3871
3872     range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3873     sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3874     flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3875     sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3876
3877     flip->op_private =  left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3878     flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3879
3880     flip->op_next = o;
3881     if (!flip->op_private || !flop->op_private)
3882         linklist(o);            /* blow off optimizer unless constant */
3883
3884     return o;
3885 }
3886
3887 OP *
3888 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3889 {
3890     OP* listop;
3891     OP* o;
3892     int once = block && block->op_flags & OPf_SPECIAL &&
3893       (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3894
3895     if (expr) {
3896         if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3897             return block;       /* do {} while 0 does once */
3898         if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3899             || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3900             expr = newUNOP(OP_DEFINED, 0,
3901                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3902         } else if (expr->op_flags & OPf_KIDS) {
3903             OP *k1 = ((UNOP*)expr)->op_first;
3904             OP *k2 = (k1) ? k1->op_sibling : NULL;
3905             switch (expr->op_type) {
3906               case OP_NULL:
3907                 if (k2 && k2->op_type == OP_READLINE
3908                       && (k2->op_flags & OPf_STACKED)
3909                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3910                     expr = newUNOP(OP_DEFINED, 0, expr);
3911                 break;
3912
3913               case OP_SASSIGN:
3914                 if (k1->op_type == OP_READDIR
3915                       || k1->op_type == OP_GLOB
3916                       || (k1->op_type == OP_NULL && k1->op_targ == OP_NULL)
3917                       || k1->op_type == OP_EACH)
3918                     expr = newUNOP(OP_DEFINED, 0, expr);
3919                 break;
3920             }
3921         }
3922     }
3923
3924     listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3925     o = new_logop(OP_AND, 0, &expr, &listop);
3926
3927     if (listop)
3928         ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3929
3930     if (once && o != listop)
3931         o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3932
3933     if (o == listop)
3934         o = newUNOP(OP_NULL, 0, o);     /* or do {} while 1 loses outer block */
3935
3936     o->op_flags |= flags;
3937     o = scope(o);
3938     o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3939     return o;
3940 }
3941
3942 OP *
3943 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
3944 {
3945     OP *redo;
3946     OP *next = 0;
3947     OP *listop;
3948     OP *o;
3949     OP *condop;
3950     U8 loopflags = 0;
3951
3952     if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3953                  || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3954         expr = newUNOP(OP_DEFINED, 0,
3955             newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3956     } else if (expr && (expr->op_flags & OPf_KIDS)) {
3957         OP *k1 = ((UNOP*)expr)->op_first;
3958         OP *k2 = (k1) ? k1->op_sibling : NULL;
3959         switch (expr->op_type) {
3960           case OP_NULL:
3961             if (k2 && k2->op_type == OP_READLINE
3962                   && (k2->op_flags & OPf_STACKED)
3963                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3964                 expr = newUNOP(OP_DEFINED, 0, expr);
3965             break;
3966
3967           case OP_SASSIGN:
3968             if (k1->op_type == OP_READDIR
3969                   || k1->op_type == OP_GLOB
3970                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3971                   || k1->op_type == OP_EACH)
3972                 expr = newUNOP(OP_DEFINED, 0, expr);
3973             break;
3974         }
3975     }
3976
3977     if (!block)
3978         block = newOP(OP_NULL, 0);
3979     else if (cont) {
3980         block = scope(block);
3981     }
3982
3983     if (cont) {
3984         next = LINKLIST(cont);
3985     }
3986     if (expr) {
3987         OP *unstack = newOP(OP_UNSTACK, 0);
3988         if (!next)
3989             next = unstack;
3990         cont = append_elem(OP_LINESEQ, cont, unstack);
3991         if ((line_t)whileline != NOLINE) {
3992             PL_copline = whileline;
3993             cont = append_elem(OP_LINESEQ, cont,
3994                                newSTATEOP(0, Nullch, Nullop));
3995         }
3996     }
3997
3998     listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3999     redo = LINKLIST(listop);
4000
4001     if (expr) {
4002         PL_copline = whileline;
4003         scalar(listop);
4004         o = new_logop(OP_AND, 0, &expr, &listop);
4005         if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4006             op_free(expr);              /* oops, it's a while (0) */
4007             op_free((OP*)loop);
4008             return Nullop;              /* listop already freed by new_logop */
4009         }
4010         if (listop)
4011             ((LISTOP*)listop)->op_last->op_next = condop =
4012                 (o == listop ? redo : LINKLIST(o));
4013     }
4014     else
4015         o = listop;
4016
4017     if (!loop) {
4018         NewOp(1101,loop,1,LOOP);
4019         loop->op_type = OP_ENTERLOOP;
4020         loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4021         loop->op_private = 0;
4022         loop->op_next = (OP*)loop;
4023     }
4024
4025     o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4026
4027     loop->op_redoop = redo;
4028     loop->op_lastop = o;
4029     o->op_private |= loopflags;
4030
4031     if (next)
4032         loop->op_nextop = next;
4033     else
4034         loop->op_nextop = o;
4035
4036     o->op_flags |= flags;
4037     o->op_private |= (flags >> 8);
4038     return o;
4039 }
4040
4041 OP *
4042 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
4043 {
4044     LOOP *loop;
4045     OP *wop;
4046     int padoff = 0;
4047     I32 iterflags = 0;
4048
4049     if (sv) {
4050         if (sv->op_type == OP_RV2SV) {  /* symbol table variable */
4051             sv->op_type = OP_RV2GV;
4052             sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4053         }
4054         else if (sv->op_type == OP_PADSV) { /* private variable */
4055             padoff = sv->op_targ;
4056             sv->op_targ = 0;
4057             op_free(sv);
4058             sv = Nullop;
4059         }
4060         else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4061             padoff = sv->op_targ;
4062             sv->op_targ = 0;
4063             iterflags |= OPf_SPECIAL;
4064             op_free(sv);
4065             sv = Nullop;
4066         }
4067         else
4068             Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4069     }
4070     else {
4071 #ifdef USE_THREADS
4072         padoff = find_threadsv("_");
4073         iterflags |= OPf_SPECIAL;
4074 #else
4075         sv = newGVOP(OP_GV, 0, PL_defgv);
4076 #endif
4077     }
4078     if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4079         expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4080         iterflags |= OPf_STACKED;
4081     }
4082     else if (expr->op_type == OP_NULL &&
4083              (expr->op_flags & OPf_KIDS) &&
4084              ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4085     {
4086         /* Basically turn for($x..$y) into the same as for($x,$y), but we
4087          * set the STACKED flag to indicate that these values are to be
4088          * treated as min/max values by 'pp_iterinit'.
4089          */
4090         UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4091         LOGOP* range = (LOGOP*) flip->op_first;
4092         OP* left  = range->op_first;
4093         OP* right = left->op_sibling;
4094         LISTOP* listop;
4095
4096         range->op_flags &= ~OPf_KIDS;
4097         range->op_first = Nullop;
4098
4099         listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4100         listop->op_first->op_next = range->op_next;
4101         left->op_next = range->op_other;
4102         right->op_next = (OP*)listop;
4103         listop->op_next = listop->op_first;
4104
4105         op_free(expr);
4106         expr = (OP*)(listop);
4107         null(expr);
4108         iterflags |= OPf_STACKED;
4109     }
4110     else {
4111         expr = mod(force_list(expr), OP_GREPSTART);
4112     }
4113
4114
4115     loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4116                                append_elem(OP_LIST, expr, scalar(sv))));
4117     assert(!loop->op_next);
4118 #ifdef PL_OP_SLAB_ALLOC
4119     {
4120         LOOP *tmp;
4121         NewOp(1234,tmp,1,LOOP);
4122         Copy(loop,tmp,1,LOOP);
4123         loop = tmp;
4124     }
4125 #else
4126     Renew(loop, 1, LOOP);
4127 #endif
4128     loop->op_targ = padoff;
4129     wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
4130     PL_copline = forline;
4131     return newSTATEOP(0, label, wop);
4132 }
4133
4134 OP*
4135 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4136 {
4137     OP *o;
4138     STRLEN n_a;
4139
4140     if (type != OP_GOTO || label->op_type == OP_CONST) {
4141         /* "last()" means "last" */
4142         if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4143             o = newOP(type, OPf_SPECIAL);
4144         else {
4145             o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4146                                         ? SvPVx(((SVOP*)label)->op_sv, n_a)
4147                                         : ""));
4148         }
4149         op_free(label);
4150     }
4151     else {
4152         if (label->op_type == OP_ENTERSUB)
4153             label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4154         o = newUNOP(type, OPf_STACKED, label);
4155     }
4156     PL_hints |= HINT_BLOCK_SCOPE;
4157     return o;
4158 }
4159
4160 void
4161 Perl_cv_undef(pTHX_ CV *cv)
4162 {
4163 #ifdef USE_THREADS
4164     if (CvMUTEXP(cv)) {
4165         MUTEX_DESTROY(CvMUTEXP(cv));
4166         Safefree(CvMUTEXP(cv));
4167         CvMUTEXP(cv) = 0;
4168     }
4169 #endif /* USE_THREADS */
4170
4171     if (!CvXSUB(cv) && CvROOT(cv)) {
4172 #ifdef USE_THREADS
4173         if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr))
4174             Perl_croak(aTHX_ "Can't undef active subroutine");
4175 #else
4176         if (CvDEPTH(cv))
4177             Perl_croak(aTHX_ "Can't undef active subroutine");
4178 #endif /* USE_THREADS */
4179         ENTER;
4180
4181         SAVEVPTR(PL_curpad);
4182         PL_curpad = 0;
4183
4184         if (!CvCLONED(cv))
4185             op_free(CvROOT(cv));
4186         CvROOT(cv) = Nullop;
4187         LEAVE;
4188     }
4189     SvPOK_off((SV*)cv);         /* forget prototype */
4190     CvGV(cv) = Nullgv;
4191     SvREFCNT_dec(CvOUTSIDE(cv));
4192     CvOUTSIDE(cv) = Nullcv;
4193     if (CvCONST(cv)) {
4194         SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4195         CvCONST_off(cv);
4196     }
4197     if (CvPADLIST(cv)) {
4198         /* may be during global destruction */
4199         if (SvREFCNT(CvPADLIST(cv))) {
4200             I32 i = AvFILLp(CvPADLIST(cv));
4201             while (i >= 0) {
4202                 SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE);
4203                 SV* sv = svp ? *svp : Nullsv;
4204                 if (!sv)
4205                     continue;
4206                 if (sv == (SV*)PL_comppad_name)
4207                     PL_comppad_name = Nullav;
4208                 else if (sv == (SV*)PL_comppad) {
4209                     PL_comppad = Nullav;
4210                     PL_curpad = Null(SV**);
4211                 }
4212                 SvREFCNT_dec(sv);
4213             }
4214             SvREFCNT_dec((SV*)CvPADLIST(cv));
4215         }
4216         CvPADLIST(cv) = Nullav;
4217     }
4218     CvFLAGS(cv) = 0;
4219 }
4220
4221 #ifdef DEBUG_CLOSURES
4222 STATIC void
4223 S_cv_dump(pTHX_ CV *cv)
4224 {
4225 #ifdef DEBUGGING
4226     CV *outside = CvOUTSIDE(cv);
4227     AV* padlist = CvPADLIST(cv);
4228     AV* pad_name;
4229     AV* pad;
4230     SV** pname;
4231     SV** ppad;
4232     I32 ix;
4233
4234     PerlIO_printf(Perl_debug_log,
4235                   "\tCV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
4236                   PTR2UV(cv),
4237                   (CvANON(cv) ? "ANON"
4238                    : (cv == PL_main_cv) ? "MAIN"
4239                    : CvUNIQUE(cv) ? "UNIQUE"
4240                    : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
4241                   PTR2UV(outside),
4242                   (!outside ? "null"
4243                    : CvANON(outside) ? "ANON"
4244                    : (outside == PL_main_cv) ? "MAIN"
4245                    : CvUNIQUE(outside) ? "UNIQUE"
4246                    : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
4247
4248     if (!padlist)
4249         return;
4250
4251     pad_name = (AV*)*av_fetch(padlist, 0, FALSE);
4252     pad = (AV*)*av_fetch(padlist, 1, FALSE);
4253     pname = AvARRAY(pad_name);
4254     ppad = AvARRAY(pad);
4255
4256     for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
4257         if (SvPOK(pname[ix]))
4258             PerlIO_printf(Perl_debug_log,
4259                           "\t%4d. 0x%"UVxf" (%s\"%s\" %"IVdf"-%"IVdf")\n",
4260                           (int)ix, PTR2UV(ppad[ix]),
4261                           SvFAKE(pname[ix]) ? "FAKE " : "",
4262                           SvPVX(pname[ix]),
4263                           (IV)I_32(SvNVX(pname[ix])),
4264                           SvIVX(pname[ix]));
4265     }
4266 #endif /* DEBUGGING */
4267 }
4268 #endif /* DEBUG_CLOSURES */
4269
4270 STATIC CV *
4271 S_cv_clone2(pTHX_ CV *proto, CV *outside)
4272 {
4273     AV* av;
4274     I32 ix;
4275     AV* protopadlist = CvPADLIST(proto);
4276     AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
4277     AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
4278     SV** pname = AvARRAY(protopad_name);
4279     SV** ppad = AvARRAY(protopad);
4280     I32 fname = AvFILLp(protopad_name);
4281     I32 fpad = AvFILLp(protopad);
4282     AV* comppadlist;
4283     CV* cv;
4284
4285     assert(!CvUNIQUE(proto));
4286
4287     ENTER;
4288     SAVECOMPPAD();
4289     SAVESPTR(PL_comppad_name);
4290     SAVESPTR(PL_compcv);
4291
4292     cv = PL_compcv = (CV*)NEWSV(1104,0);
4293     sv_upgrade((SV *)cv, SvTYPE(proto));
4294     CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
4295     CvCLONED_on(cv);
4296
4297 #ifdef USE_THREADS
4298     New(666, CvMUTEXP(cv), 1, perl_mutex);
4299     MUTEX_INIT(CvMUTEXP(cv));
4300     CvOWNER(cv)         = 0;
4301 #endif /* USE_THREADS */
4302     CvFILE(cv)          = CvFILE(proto);
4303     CvGV(cv)            = CvGV(proto);
4304     CvSTASH(cv)         = CvSTASH(proto);
4305     CvROOT(cv)          = CvROOT(proto);
4306     CvSTART(cv)         = CvSTART(proto);
4307     if (outside)
4308         CvOUTSIDE(cv)   = (CV*)SvREFCNT_inc(outside);
4309
4310     if (SvPOK(proto))
4311         sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
4312
4313     PL_comppad_name = newAV();
4314     for (ix = fname; ix >= 0; ix--)
4315         av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
4316
4317     PL_comppad = newAV();
4318
4319     comppadlist = newAV();
4320     AvREAL_off(comppadlist);
4321     av_store(comppadlist, 0, (SV*)PL_comppad_name);
4322     av_store(comppadlist, 1, (SV*)PL_comppad);
4323     CvPADLIST(cv) = comppadlist;
4324     av_fill(PL_comppad, AvFILLp(protopad));
4325     PL_curpad = AvARRAY(PL_comppad);
4326
4327     av = newAV();           /* will be @_ */
4328     av_extend(av, 0);
4329     av_store(PL_comppad, 0, (SV*)av);
4330     AvFLAGS(av) = AVf_REIFY;
4331
4332     for (ix = fpad; ix > 0; ix--) {
4333         SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4334         if (namesv && namesv != &PL_sv_undef) {
4335             char *name = SvPVX(namesv);    /* XXX */
4336             if (SvFLAGS(namesv) & SVf_FAKE) {   /* lexical from outside? */
4337                 I32 off = pad_findlex(name, ix, SvIVX(namesv),
4338                                       CvOUTSIDE(cv), cxstack_ix, 0, 0);
4339                 if (!off)
4340                     PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4341                 else if (off != ix)
4342                     Perl_croak(aTHX_ "panic: cv_clone: %s", name);
4343             }
4344             else {                              /* our own lexical */
4345                 SV* sv;
4346                 if (*name == '&') {
4347                     /* anon code -- we'll come back for it */
4348                     sv = SvREFCNT_inc(ppad[ix]);
4349                 }
4350                 else if (*name == '@')
4351                     sv = (SV*)newAV();
4352                 else if (*name == '%')
4353                     sv = (SV*)newHV();
4354                 else
4355                     sv = NEWSV(0,0);
4356                 if (!SvPADBUSY(sv))
4357                     SvPADMY_on(sv);
4358                 PL_curpad[ix] = sv;
4359             }
4360         }
4361         else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
4362             PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4363         }
4364         else {
4365             SV* sv = NEWSV(0,0);
4366             SvPADTMP_on(sv);
4367             PL_curpad[ix] = sv;
4368         }
4369     }
4370
4371     /* Now that vars are all in place, clone nested closures. */
4372
4373     for (ix = fpad; ix > 0; ix--) {
4374         SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4375         if (namesv
4376             && namesv != &PL_sv_undef
4377             && !(SvFLAGS(namesv) & SVf_FAKE)
4378             && *SvPVX(namesv) == '&'
4379             && CvCLONE(ppad[ix]))
4380         {
4381             CV *kid = cv_clone2((CV*)ppad[ix], cv);
4382             SvREFCNT_dec(ppad[ix]);
4383             CvCLONE_on(kid);
4384             SvPADMY_on(kid);
4385             PL_curpad[ix] = (SV*)kid;
4386         }
4387     }
4388
4389 #ifdef DEBUG_CLOSURES
4390     PerlIO_printf(Perl_debug_log, "Cloned inside:\n");
4391     cv_dump(outside);
4392     PerlIO_printf(Perl_debug_log, "  from:\n");
4393     cv_dump(proto);
4394     PerlIO_printf(Perl_debug_log, "   to:\n");
4395     cv_dump(cv);
4396 #endif
4397
4398     LEAVE;
4399
4400     if (CvCONST(cv)) {
4401         SV* const_sv = op_const_sv(CvSTART(cv), cv);
4402         assert(const_sv);
4403         /* constant sub () { $x } closing over $x - see lib/constant.pm */
4404         SvREFCNT_dec(cv);
4405         cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
4406     }
4407
4408     return cv;
4409 }
4410
4411 CV *
4412 Perl_cv_clone(pTHX_ CV *proto)
4413 {
4414     CV *cv;
4415     LOCK_CRED_MUTEX;                    /* XXX create separate mutex */
4416     cv = cv_clone2(proto, CvOUTSIDE(proto));
4417     UNLOCK_CRED_MUTEX;                  /* XXX create separate mutex */
4418     return cv;
4419 }
4420
4421 void
4422 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
4423 {
4424     if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4425         SV* msg = sv_newmortal();
4426         SV* name = Nullsv;
4427
4428         if (gv)
4429             gv_efullname3(name = sv_newmortal(), gv, Nullch);
4430         sv_setpv(msg, "Prototype mismatch:");
4431         if (name)
4432             Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4433         if (SvPOK(cv))
4434             Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv));
4435         sv_catpv(msg, " vs ");
4436         if (p)
4437             Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4438         else
4439             sv_catpv(msg, "none");
4440         Perl_warner(aTHX_ WARN_PROTOTYPE, "%"SVf, msg);
4441     }
4442 }
4443
4444 static void const_sv_xsub(pTHXo_ CV* cv);
4445
4446 /*
4447 =for apidoc cv_const_sv
4448
4449 If C<cv> is a constant sub eligible for inlining. returns the constant
4450 value returned by the sub.  Otherwise, returns NULL.
4451
4452 Constant subs can be created with C<newCONSTSUB> or as described in
4453 L<perlsub/"Constant Functions">.
4454
4455 =cut
4456 */
4457 SV *
4458 Perl_cv_const_sv(pTHX_ CV *cv)
4459 {
4460     if (!cv || !CvCONST(cv))
4461         return Nullsv;
4462     return (SV*)CvXSUBANY(cv).any_ptr;
4463 }
4464
4465 SV *
4466 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
4467 {
4468     SV *sv = Nullsv;
4469
4470     if (!o)
4471         return Nullsv;
4472
4473     if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4474         o = cLISTOPo->op_first->op_sibling;
4475
4476     for (; o; o = o->op_next) {
4477         OPCODE type = o->op_type;
4478
4479         if (sv && o->op_next == o)
4480             return sv;
4481         if (o->op_next != o) {
4482             if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4483                 continue;
4484             if (type == OP_DBSTATE)
4485                 continue;
4486         }
4487         if (type == OP_LEAVESUB || type == OP_RETURN)
4488             break;
4489         if (sv)
4490             return Nullsv;
4491         if (type == OP_CONST && cSVOPo->op_sv)
4492             sv = cSVOPo->op_sv;
4493         else if ((type == OP_PADSV || type == OP_CONST) && cv) {
4494             AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
4495             sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
4496             if (!sv)
4497                 return Nullsv;
4498             if (CvCONST(cv)) {
4499                 /* We get here only from cv_clone2() while creating a closure.
4500                    Copy the const value here instead of in cv_clone2 so that
4501                    SvREADONLY_on doesn't lead to problems when leaving
4502                    scope.
4503                 */
4504                 sv = newSVsv(sv);
4505             }
4506             if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
4507                 return Nullsv;
4508         }
4509         else
4510             return Nullsv;
4511     }
4512     if (sv)
4513         SvREADONLY_on(sv);
4514     return sv;
4515 }
4516
4517 void
4518 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4519 {
4520     if (o)
4521         SAVEFREEOP(o);
4522     if (proto)
4523         SAVEFREEOP(proto);
4524     if (attrs)
4525         SAVEFREEOP(attrs);
4526     if (block)
4527         SAVEFREEOP(block);
4528     Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4529 }
4530
4531 CV *
4532 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4533 {
4534     return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4535 }
4536
4537 CV *
4538 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4539 {
4540     STRLEN n_a;
4541     char *name;
4542     char *aname;
4543     GV *gv;
4544     char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4545     register CV *cv=0;
4546     I32 ix;
4547     SV *const_sv;
4548
4549     name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4550     if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4551         SV *sv = sv_newmortal();
4552         Perl_sv_setpvf(aTHX_ sv, "__ANON__[%s:%"IVdf"]",
4553                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4554         aname = SvPVX(sv);
4555     }
4556     else
4557         aname = Nullch;
4558     gv = gv_fetchpv(name ? name : (aname ? aname : "__ANON__"),
4559                     GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4560                     SVt_PVCV);
4561
4562     if (o)
4563         SAVEFREEOP(o);
4564     if (proto)
4565         SAVEFREEOP(proto);
4566     if (attrs)
4567         SAVEFREEOP(attrs);
4568
4569     if (SvTYPE(gv) != SVt_PVGV) {       /* Maybe prototype now, and had at
4570                                            maximum a prototype before. */
4571         if (SvTYPE(gv) > SVt_NULL) {
4572             if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4573                 && ckWARN_d(WARN_PROTOTYPE))
4574             {
4575                 Perl_warner(aTHX_ WARN_PROTOTYPE, "Runaway prototype");
4576             }
4577             cv_ckproto((CV*)gv, NULL, ps);
4578         }
4579         if (ps)
4580             sv_setpv((SV*)gv, ps);
4581         else
4582             sv_setiv((SV*)gv, -1);
4583         SvREFCNT_dec(PL_compcv);
4584         cv = PL_compcv = NULL;
4585         PL_sub_generation++;
4586         goto done;
4587     }
4588
4589     cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4590
4591 #ifdef GV_SHARED_CHECK
4592     if (cv && GvSHARED(gv) && SvREADONLY(cv)) {
4593         Perl_croak(aTHX_ "Can't define subroutine %s (GV is shared)", name);
4594     }
4595 #endif
4596
4597     if (!block || !ps || *ps || attrs)
4598         const_sv = Nullsv;
4599     else
4600         const_sv = op_const_sv(block, Nullcv);
4601
4602     if (cv) {
4603         bool exists = CvROOT(cv) || CvXSUB(cv);
4604
4605 #ifdef GV_SHARED_CHECK
4606         if (exists && GvSHARED(gv)) {
4607             Perl_croak(aTHX_ "Can't redefine shared subroutine %s", name);
4608         }
4609 #endif
4610
4611         /* if the subroutine doesn't exist and wasn't pre-declared
4612          * with a prototype, assume it will be AUTOLOADed,
4613          * skipping the prototype check
4614          */
4615         if (exists || SvPOK(cv))
4616             cv_ckproto(cv, gv, ps);
4617         /* already defined (or promised)? */
4618         if (exists || GvASSUMECV(gv)) {
4619             if (!block && !attrs) {
4620                 /* just a "sub foo;" when &foo is already defined */
4621                 SAVEFREESV(PL_compcv);
4622                 goto done;
4623             }
4624             /* ahem, death to those who redefine active sort subs */
4625             if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4626                 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4627             if (block) {
4628                 if (ckWARN(WARN_REDEFINE)
4629                     || (CvCONST(cv)
4630                         && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4631                 {
4632                     line_t oldline = CopLINE(PL_curcop);
4633                     CopLINE_set(PL_curcop, PL_copline);
4634                     Perl_warner(aTHX_ WARN_REDEFINE,
4635                         CvCONST(cv) ? "Constant subroutine %s redefined"
4636                                     : "Subroutine %s redefined", name);
4637                     CopLINE_set(PL_curcop, oldline);
4638                 }
4639                 SvREFCNT_dec(cv);
4640                 cv = Nullcv;
4641             }
4642         }
4643     }
4644     if (const_sv) {
4645         SvREFCNT_inc(const_sv);
4646         if (cv) {
4647             assert(!CvROOT(cv) && !CvCONST(cv));
4648             sv_setpv((SV*)cv, "");  /* prototype is "" */
4649             CvXSUBANY(cv).any_ptr = const_sv;
4650             CvXSUB(cv) = const_sv_xsub;
4651             CvCONST_on(cv);
4652         }
4653         else {
4654             GvCV(gv) = Nullcv;
4655             cv = newCONSTSUB(NULL, name, const_sv);
4656         }
4657         op_free(block);
4658         SvREFCNT_dec(PL_compcv);
4659         PL_compcv = NULL;
4660         PL_sub_generation++;
4661         goto done;
4662     }
4663     if (attrs) {
4664         HV *stash;
4665         SV *rcv;
4666
4667         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4668          * before we clobber PL_compcv.
4669          */
4670         if (cv && !block) {
4671             rcv = (SV*)cv;
4672             if (CvGV(cv) && GvSTASH(CvGV(cv)) && HvNAME(GvSTASH(CvGV(cv))))
4673                 stash = GvSTASH(CvGV(cv));
4674             else if (CvSTASH(cv) && HvNAME(CvSTASH(cv)))
4675                 stash = CvSTASH(cv);
4676             else
4677                 stash = PL_curstash;
4678         }
4679         else {
4680             /* possibly about to re-define existing subr -- ignore old cv */
4681             rcv = (SV*)PL_compcv;
4682             if (name && GvSTASH(gv) && HvNAME(GvSTASH(gv)))
4683                 stash = GvSTASH(gv);
4684             else
4685                 stash = PL_curstash;
4686         }
4687         apply_attrs(stash, rcv, attrs);
4688     }
4689     if (cv) {                           /* must reuse cv if autoloaded */
4690         if (!block) {
4691             /* got here with just attrs -- work done, so bug out */
4692             SAVEFREESV(PL_compcv);
4693             goto done;
4694         }
4695         cv_undef(cv);
4696         CvFLAGS(cv) = CvFLAGS(PL_compcv);
4697         CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4698         CvOUTSIDE(PL_compcv) = 0;
4699         CvPADLIST(cv) = CvPADLIST(PL_compcv);
4700         CvPADLIST(PL_compcv) = 0;
4701         if (SvREFCNT(PL_compcv) > 1) /* XXX Make closures transit through stub. */
4702             CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc((SV*)cv);
4703         SvREFCNT_dec(PL_compcv);
4704     }
4705     else {
4706         cv = PL_compcv;
4707         if (name) {
4708             GvCV(gv) = cv;
4709             GvCVGEN(gv) = 0;
4710             PL_sub_generation++;
4711         }
4712     }
4713     CvGV(cv) = gv;
4714     CvFILE(cv) = CopFILE(PL_curcop);
4715     CvSTASH(cv) = PL_curstash;
4716 #ifdef USE_THREADS
4717     CvOWNER(cv) = 0;
4718     if (!CvMUTEXP(cv)) {
4719         New(666, CvMUTEXP(cv), 1, perl_mutex);
4720         MUTEX_INIT(CvMUTEXP(cv));
4721     }
4722 #endif /* USE_THREADS */
4723
4724     if (ps)
4725         sv_setpv((SV*)cv, ps);
4726
4727     if (PL_error_count) {
4728         op_free(block);
4729         block = Nullop;
4730         if (name) {
4731             char *s = strrchr(name, ':');
4732             s = s ? s+1 : name;
4733             if (strEQ(s, "BEGIN")) {
4734                 char *not_safe =
4735                     "BEGIN not safe after errors--compilation aborted";
4736                 if (PL_in_eval & EVAL_KEEPERR)
4737                     Perl_croak(aTHX_ not_safe);
4738                 else {
4739                     /* force display of errors found but not reported */
4740                     sv_catpv(ERRSV, not_safe);
4741                     Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
4742                 }
4743             }
4744         }
4745     }
4746     if (!block)
4747         goto done;
4748
4749     if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
4750         av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
4751
4752     if (CvLVALUE(cv)) {
4753         CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4754                              mod(scalarseq(block), OP_LEAVESUBLV));
4755     }
4756     else {
4757         CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4758     }
4759     CvROOT(cv)->op_private |= OPpREFCOUNTED;
4760     OpREFCNT_set(CvROOT(cv), 1);
4761     CvSTART(cv) = LINKLIST(CvROOT(cv));
4762     CvROOT(cv)->op_next = 0;
4763     peep(CvSTART(cv));
4764
4765     /* now that optimizer has done its work, adjust pad values */
4766     if (CvCLONE(cv)) {
4767         SV **namep = AvARRAY(PL_comppad_name);
4768         for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4769             SV *namesv;
4770
4771             if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4772                 continue;
4773             /*
4774              * The only things that a clonable function needs in its
4775              * pad are references to outer lexicals and anonymous subs.
4776              * The rest are created anew during cloning.
4777              */
4778             if (!((namesv = namep[ix]) != Nullsv &&
4779                   namesv != &PL_sv_undef &&
4780                   (SvFAKE(namesv) ||
4781                    *SvPVX(namesv) == '&')))
4782             {
4783                 SvREFCNT_dec(PL_curpad[ix]);
4784                 PL_curpad[ix] = Nullsv;
4785             }
4786         }
4787         assert(!CvCONST(cv));
4788         if (ps && !*ps && op_const_sv(block, cv))
4789             CvCONST_on(cv);
4790     }
4791     else {
4792         AV *av = newAV();                       /* Will be @_ */
4793         av_extend(av, 0);
4794         av_store(PL_comppad, 0, (SV*)av);
4795         AvFLAGS(av) = AVf_REIFY;
4796
4797         for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4798             if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4799                 continue;
4800             if (!SvPADMY(PL_curpad[ix]))
4801                 SvPADTMP_on(PL_curpad[ix]);
4802         }
4803     }
4804
4805     if (name || aname) {
4806         char *s;
4807         char *tname = (name ? name : aname);
4808
4809         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4810             SV *sv = NEWSV(0,0);
4811             SV *tmpstr = sv_newmortal();
4812             GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4813             CV *pcv;
4814             HV *hv;
4815
4816             Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4817                            CopFILE(PL_curcop),
4818                            (long)PL_subline, (long)CopLINE(PL_curcop));
4819             gv_efullname3(tmpstr, gv, Nullch);
4820             hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4821             hv = GvHVn(db_postponed);
4822             if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4823                 && (pcv = GvCV(db_postponed)))
4824             {
4825                 dSP;
4826                 PUSHMARK(SP);
4827                 XPUSHs(tmpstr);
4828                 PUTBACK;
4829                 call_sv((SV*)pcv, G_DISCARD);
4830             }
4831         }
4832
4833         if ((s = strrchr(tname,':')))
4834             s++;
4835         else
4836             s = tname;
4837
4838         if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4839             goto done;
4840
4841         if (strEQ(s, "BEGIN")) {
4842             I32 oldscope = PL_scopestack_ix;
4843             ENTER;
4844             SAVECOPFILE(&PL_compiling);
4845             SAVECOPLINE(&PL_compiling);
4846             save_svref(&PL_rs);
4847             sv_setsv(PL_rs, PL_nrs);
4848
4849             if (!PL_beginav)
4850                 PL_beginav = newAV();
4851             DEBUG_x( dump_sub(gv) );
4852             av_push(PL_beginav, (SV*)cv);
4853             GvCV(gv) = 0;               /* cv has been hijacked */
4854             call_list(oldscope, PL_beginav);
4855
4856             PL_curcop = &PL_compiling;
4857             PL_compiling.op_private = PL_hints;
4858             LEAVE;
4859         }
4860         else if (strEQ(s, "END") && !PL_error_count) {
4861             if (!PL_endav)
4862                 PL_endav = newAV();
4863             DEBUG_x( dump_sub(gv) );
4864             av_unshift(PL_endav, 1);
4865             av_store(PL_endav, 0, (SV*)cv);
4866             GvCV(gv) = 0;               /* cv has been hijacked */
4867         }
4868         else if (strEQ(s, "CHECK") && !PL_error_count) {
4869             if (!PL_checkav)
4870                 PL_checkav = newAV();
4871             DEBUG_x( dump_sub(gv) );
4872             if (PL_main_start && ckWARN(WARN_VOID))
4873                 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
4874             av_unshift(PL_checkav, 1);
4875             av_store(PL_checkav, 0, (SV*)cv);
4876             GvCV(gv) = 0;               /* cv has been hijacked */
4877         }
4878         else if (strEQ(s, "INIT") && !PL_error_count) {
4879             if (!PL_initav)
4880                 PL_initav = newAV();
4881             DEBUG_x( dump_sub(gv) );
4882             if (PL_main_start && ckWARN(WARN_VOID))
4883                 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
4884             av_push(PL_initav, (SV*)cv);
4885             GvCV(gv) = 0;               /* cv has been hijacked */
4886         }
4887     }
4888
4889   done:
4890     PL_copline = NOLINE;
4891     LEAVE_SCOPE(floor);
4892     return cv;
4893 }
4894
4895 /* XXX unsafe for threads if eval_owner isn't held */
4896 /*
4897 =for apidoc newCONSTSUB
4898
4899 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4900 eligible for inlining at compile-time.
4901
4902 =cut
4903 */
4904
4905 CV *
4906 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
4907 {
4908     CV* cv;
4909
4910     ENTER;
4911
4912     SAVECOPLINE(PL_curcop);
4913     CopLINE_set(PL_curcop, PL_copline);
4914
4915     SAVEHINTS();
4916     PL_hints &= ~HINT_BLOCK_SCOPE;
4917
4918     if (stash) {
4919         SAVESPTR(PL_curstash);
4920         SAVECOPSTASH(PL_curcop);
4921         PL_curstash = stash;
4922 #ifdef USE_ITHREADS
4923         CopSTASHPV(PL_curcop) = stash ? HvNAME(stash) : Nullch;
4924 #else
4925         CopSTASH(PL_curcop) = stash;
4926 #endif
4927     }
4928
4929     cv = newXS(name, const_sv_xsub, __FILE__);
4930     CvXSUBANY(cv).any_ptr = sv;
4931     CvCONST_on(cv);
4932     sv_setpv((SV*)cv, "");  /* prototype is "" */
4933
4934     LEAVE;
4935
4936     return cv;
4937 }
4938
4939 /*
4940 =for apidoc U||newXS
4941
4942 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4943
4944 =cut
4945 */
4946
4947 CV *
4948 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
4949 {
4950     GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV);
4951     register CV *cv;
4952
4953     if ((cv = (name ? GvCV(gv) : Nullcv))) {
4954         if (GvCVGEN(gv)) {
4955             /* just a cached method */
4956             SvREFCNT_dec(cv);
4957             cv = 0;
4958         }
4959         else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4960             /* already defined (or promised) */
4961             if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
4962                             && HvNAME(GvSTASH(CvGV(cv)))
4963                             && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
4964                 line_t oldline = CopLINE(PL_curcop);
4965                 if (PL_copline != NOLINE)
4966                     CopLINE_set(PL_curcop, PL_copline);
4967                 Perl_warner(aTHX_ WARN_REDEFINE,
4968                             CvCONST(cv) ? "Constant subroutine %s redefined"
4969                                         : "Subroutine %s redefined"
4970                             ,name);
4971                 CopLINE_set(PL_curcop, oldline);
4972             }
4973             SvREFCNT_dec(cv);
4974             cv = 0;
4975         }
4976     }
4977
4978     if (cv)                             /* must reuse cv if autoloaded */
4979         cv_undef(cv);
4980     else {
4981         cv = (CV*)NEWSV(1105,0);
4982         sv_upgrade((SV *)cv, SVt_PVCV);
4983         if (name) {
4984             GvCV(gv) = cv;
4985             GvCVGEN(gv) = 0;
4986             PL_sub_generation++;
4987         }
4988     }
4989     CvGV(cv) = gv;
4990 #ifdef USE_THREADS
4991     New(666, CvMUTEXP(cv), 1, perl_mutex);
4992     MUTEX_INIT(CvMUTEXP(cv));
4993     CvOWNER(cv) = 0;
4994 #endif /* USE_THREADS */
4995     (void)gv_fetchfile(filename);
4996     CvFILE(cv) = filename;      /* NOTE: not copied, as it is expected to be
4997                                    an external constant string */
4998     CvXSUB(cv) = subaddr;
4999
5000     if (name) {
5001         char *s = strrchr(name,':');
5002         if (s)
5003             s++;
5004         else
5005             s = name;
5006
5007         if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5008             goto done;
5009
5010         if (strEQ(s, "BEGIN")) {
5011             if (!PL_beginav)
5012                 PL_beginav = newAV();
5013             av_push(PL_beginav, (SV*)cv);
5014             GvCV(gv) = 0;               /* cv has been hijacked */
5015         }
5016         else if (strEQ(s, "END")) {
5017             if (!PL_endav)
5018                 PL_endav = newAV();
5019             av_unshift(PL_endav, 1);
5020             av_store(PL_endav, 0, (SV*)cv);
5021             GvCV(gv) = 0;               /* cv has been hijacked */
5022         }
5023         else if (strEQ(s, "CHECK")) {
5024             if (!PL_checkav)
5025                 PL_checkav = newAV();
5026             if (PL_main_start && ckWARN(WARN_VOID))
5027                 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
5028             av_unshift(PL_checkav, 1);
5029             av_store(PL_checkav, 0, (SV*)cv);
5030             GvCV(gv) = 0;               /* cv has been hijacked */
5031         }
5032         else if (strEQ(s, "INIT")) {
5033             if (!PL_initav)
5034                 PL_initav = newAV();
5035             if (PL_main_start && ckWARN(WARN_VOID))
5036                 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
5037             av_push(PL_initav, (SV*)cv);
5038             GvCV(gv) = 0;               /* cv has been hijacked */
5039         }
5040     }
5041     else
5042         CvANON_on(cv);
5043
5044 done:
5045     return cv;
5046 }
5047
5048 void
5049 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5050 {
5051     register CV *cv;
5052     char *name;
5053     GV *gv;
5054     I32 ix;
5055     STRLEN n_a;
5056
5057     if (o)
5058         name = SvPVx(cSVOPo->op_sv, n_a);
5059     else
5060         name = "STDOUT";
5061     gv = gv_fetchpv(name,TRUE, SVt_PVFM);
5062 #ifdef GV_SHARED_CHECK
5063     if (GvSHARED(gv)) {
5064         Perl_croak(aTHX_ "Bad symbol for form (GV is shared)");
5065     }
5066 #endif
5067     GvMULTI_on(gv);
5068     if ((cv = GvFORM(gv))) {
5069         if (ckWARN(WARN_REDEFINE)) {
5070             line_t oldline = CopLINE(PL_curcop);
5071
5072             CopLINE_set(PL_curcop, PL_copline);
5073             Perl_warner(aTHX_ WARN_REDEFINE, "Format %s redefined",name);
5074             CopLINE_set(PL_curcop, oldline);
5075         }
5076         SvREFCNT_dec(cv);
5077     }
5078     cv = PL_compcv;
5079     GvFORM(gv) = cv;
5080     CvGV(cv) = gv;
5081     CvFILE(cv) = CopFILE(PL_curcop);
5082
5083     for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5084         if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
5085             SvPADTMP_on(PL_curpad[ix]);
5086     }
5087
5088     CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5089     CvROOT(cv)->op_private |= OPpREFCOUNTED;
5090     OpREFCNT_set(CvROOT(cv), 1);
5091     CvSTART(cv) = LINKLIST(CvROOT(cv));
5092     CvROOT(cv)->op_next = 0;
5093     peep(CvSTART(cv));
5094     op_free(o);
5095     PL_copline = NOLINE;
5096     LEAVE_SCOPE(floor);
5097 }
5098
5099 OP *
5100 Perl_newANONLIST(pTHX_ OP *o)
5101 {
5102     return newUNOP(OP_REFGEN, 0,
5103         mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5104 }
5105
5106 OP *
5107 Perl_newANONHASH(pTHX_ OP *o)
5108 {
5109     return newUNOP(OP_REFGEN, 0,
5110         mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5111 }
5112
5113 OP *
5114 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5115 {
5116     return newANONATTRSUB(floor, proto, Nullop, block);
5117 }
5118
5119 OP *
5120 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5121 {
5122     return newUNOP(OP_REFGEN, 0,
5123         newSVOP(OP_ANONCODE, 0,
5124                 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5125 }
5126
5127 OP *
5128 Perl_oopsAV(pTHX_ OP *o)
5129 {
5130     switch (o->op_type) {
5131     case OP_PADSV:
5132         o->op_type = OP_PADAV;
5133         o->op_ppaddr = PL_ppaddr[OP_PADAV];
5134         return ref(o, OP_RV2AV);
5135
5136     case OP_RV2SV:
5137         o->op_type = OP_RV2AV;
5138         o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5139         ref(o, OP_RV2AV);
5140         break;
5141
5142     default:
5143         if (ckWARN_d(WARN_INTERNAL))
5144             Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsAV");
5145         break;
5146     }
5147     return o;
5148 }
5149
5150 OP *
5151 Perl_oopsHV(pTHX_ OP *o)
5152 {
5153     switch (o->op_type) {
5154     case OP_PADSV:
5155     case OP_PADAV:
5156         o->op_type = OP_PADHV;
5157         o->op_ppaddr = PL_ppaddr[OP_PADHV];
5158         return ref(o, OP_RV2HV);
5159
5160     case OP_RV2SV:
5161     case OP_RV2AV:
5162         o->op_type = OP_RV2HV;
5163         o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5164         ref(o, OP_RV2HV);
5165         break;
5166
5167     default:
5168         if (ckWARN_d(WARN_INTERNAL))
5169             Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsHV");
5170         break;
5171     }
5172     return o;
5173 }
5174
5175 OP *
5176 Perl_newAVREF(pTHX_ OP *o)
5177 {
5178     if (o->op_type == OP_PADANY) {
5179         o->op_type = OP_PADAV;
5180         o->op_ppaddr = PL_ppaddr[OP_PADAV];
5181         return o;
5182     }
5183     return newUNOP(OP_RV2AV, 0, scalar(o));
5184 }
5185
5186 OP *
5187 Perl_newGVREF(pTHX_ I32 type, OP *o)
5188 {
5189     if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5190         return newUNOP(OP_NULL, 0, o);
5191     return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5192 }
5193
5194 OP *
5195 Perl_newHVREF(pTHX_ OP *o)
5196 {
5197     if (o->op_type == OP_PADANY) {
5198         o->op_type = OP_PADHV;
5199         o->op_ppaddr = PL_ppaddr[OP_PADHV];
5200         return o;
5201     }
5202     return newUNOP(OP_RV2HV, 0, scalar(o));
5203 }
5204
5205 OP *
5206 Perl_oopsCV(pTHX_ OP *o)
5207 {
5208     Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5209     /* STUB */
5210     return o;
5211 }
5212
5213 OP *
5214 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5215 {
5216     return newUNOP(OP_RV2CV, flags, scalar(o));
5217 }
5218
5219 OP *
5220 Perl_newSVREF(pTHX_ OP *o)
5221 {
5222     if (o->op_type == OP_PADANY) {
5223         o->op_type = OP_PADSV;
5224         o->op_ppaddr = PL_ppaddr[OP_PADSV];
5225         return o;
5226     }
5227     else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5228         o->op_flags |= OPpDONE_SVREF;
5229         return o;
5230     }
5231     return newUNOP(OP_RV2SV, 0, scalar(o));
5232 }
5233
5234 /* Check routines. */
5235
5236 OP *
5237 Perl_ck_anoncode(pTHX_ OP *o)
5238 {
5239     PADOFFSET ix;
5240     SV* name;
5241
5242     name = NEWSV(1106,0);
5243     sv_upgrade(name, SVt_PVNV);
5244     sv_setpvn(name, "&", 1);
5245     SvIVX(name) = -1;
5246     SvNVX(name) = 1;
5247     ix = pad_alloc(o->op_type, SVs_PADMY);
5248     av_store(PL_comppad_name, ix, name);
5249     av_store(PL_comppad, ix, cSVOPo->op_sv);
5250     SvPADMY_on(cSVOPo->op_sv);
5251     cSVOPo->op_sv = Nullsv;
5252     cSVOPo->op_targ = ix;
5253     return o;
5254 }
5255
5256 OP *
5257 Perl_ck_bitop(pTHX_ OP *o)
5258 {
5259     o->op_private = PL_hints;
5260     return o;
5261 }
5262
5263 OP *
5264 Perl_ck_concat(pTHX_ OP *o)
5265 {
5266     if (cUNOPo->op_first->op_type == OP_CONCAT)
5267         o->op_flags |= OPf_STACKED;
5268     return o;
5269 }
5270
5271 OP *
5272 Perl_ck_spair(pTHX_ OP *o)
5273 {
5274     if (o->op_flags & OPf_KIDS) {
5275         OP* newop;
5276         OP* kid;
5277         OPCODE type = o->op_type;
5278         o = modkids(ck_fun(o), type);
5279         kid = cUNOPo->op_first;
5280         newop = kUNOP->op_first->op_sibling;
5281         if (newop &&
5282             (newop->op_sibling ||
5283              !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5284              newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5285              newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5286
5287             return o;
5288         }
5289         op_free(kUNOP->op_first);
5290         kUNOP->op_first = newop;
5291     }
5292     o->op_ppaddr = PL_ppaddr[++o->op_type];
5293     return ck_fun(o);
5294 }
5295
5296 OP *
5297 Perl_ck_delete(pTHX_ OP *o)
5298 {
5299     o = ck_fun(o);
5300     o->op_private = 0;
5301     if (o->op_flags & OPf_KIDS) {
5302         OP *kid = cUNOPo->op_first;
5303         switch (kid->op_type) {
5304         case OP_ASLICE:
5305             o->op_flags |= OPf_SPECIAL;
5306             /* FALL THROUGH */
5307         case OP_HSLICE:
5308             o->op_private |= OPpSLICE;
5309             break;
5310         case OP_AELEM:
5311             o->op_flags |= OPf_SPECIAL;
5312             /* FALL THROUGH */
5313         case OP_HELEM:
5314             break;
5315         default:
5316             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5317                   PL_op_desc[o->op_type]);
5318         }
5319         null(kid);
5320     }
5321     return o;
5322 }
5323
5324 OP *
5325 Perl_ck_eof(pTHX_ OP *o)
5326 {
5327     I32 type = o->op_type;
5328
5329     if (o->op_flags & OPf_KIDS) {
5330         if (cLISTOPo->op_first->op_type == OP_STUB) {
5331             op_free(o);
5332             o = newUNOP(type, OPf_SPECIAL,
5333                 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
5334         }
5335         return ck_fun(o);
5336     }
5337     return o;
5338 }
5339
5340 OP *
5341 Perl_ck_eval(pTHX_ OP *o)
5342 {
5343     PL_hints |= HINT_BLOCK_SCOPE;
5344     if (o->op_flags & OPf_KIDS) {
5345         SVOP *kid = (SVOP*)cUNOPo->op_first;
5346
5347         if (!kid) {
5348             o->op_flags &= ~OPf_KIDS;
5349             null(o);
5350         }
5351         else if (kid->op_type == OP_LINESEQ) {
5352             LOGOP *enter;
5353
5354             kid->op_next = o->op_next;
5355             cUNOPo->op_first = 0;
5356             op_free(o);
5357
5358             NewOp(1101, enter, 1, LOGOP);
5359             enter->op_type = OP_ENTERTRY;
5360             enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5361             enter->op_private = 0;
5362
5363             /* establish postfix order */
5364             enter->op_next = (OP*)enter;
5365
5366             o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5367             o->op_type = OP_LEAVETRY;
5368             o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5369             enter->op_other = o;
5370             return o;
5371         }
5372         else
5373             scalar((OP*)kid);
5374     }
5375     else {
5376         op_free(o);
5377         o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5378     }
5379     o->op_targ = (PADOFFSET)PL_hints;
5380     return o;
5381 }
5382
5383 OP *
5384 Perl_ck_exit(pTHX_ OP *o)
5385 {
5386 #ifdef VMS
5387     HV *table = GvHV(PL_hintgv);
5388     if (table) {
5389        SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5390        if (svp && *svp && SvTRUE(*svp))
5391            o->op_private |= OPpEXIT_VMSISH;
5392     }
5393 #endif
5394     return ck_fun(o);
5395 }
5396
5397 OP *
5398 Perl_ck_exec(pTHX_ OP *o)
5399 {
5400     OP *kid;
5401     if (o->op_flags & OPf_STACKED) {
5402         o = ck_fun(o);
5403         kid = cUNOPo->op_first->op_sibling;
5404         if (kid->op_type == OP_RV2GV)
5405             null(kid);
5406     }
5407     else
5408         o = listkids(o);
5409     return o;
5410 }
5411
5412 OP *
5413 Perl_ck_exists(pTHX_ OP *o)
5414 {
5415     o = ck_fun(o);
5416     if (o->op_flags & OPf_KIDS) {
5417         OP *kid = cUNOPo->op_first;
5418         if (kid->op_type == OP_ENTERSUB) {
5419             (void) ref(kid, o->op_type);
5420             if (kid->op_type != OP_RV2CV && !PL_error_count)
5421                 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5422                            PL_op_desc[o->op_type]);
5423             o->op_private |= OPpEXISTS_SUB;
5424         }
5425         else if (kid->op_type == OP_AELEM)
5426             o->op_flags |= OPf_SPECIAL;
5427         else if (kid->op_type != OP_HELEM)
5428             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5429                        PL_op_desc[o->op_type]);
5430         null(kid);
5431     }
5432     return o;
5433 }
5434
5435 #if 0
5436 OP *
5437 Perl_ck_gvconst(pTHX_ register OP *o)
5438 {
5439     o = fold_constants(o);
5440     if (o->op_type == OP_CONST)
5441         o->op_type = OP_GV;
5442     return o;
5443 }
5444 #endif
5445
5446 OP *
5447 Perl_ck_rvconst(pTHX_ register OP *o)
5448 {
5449     SVOP *kid = (SVOP*)cUNOPo->op_first;
5450
5451     o->op_private |= (PL_hints & HINT_STRICT_REFS);
5452     if (kid->op_type == OP_CONST) {
5453         char *name;
5454         int iscv;
5455         GV *gv;
5456         SV *kidsv = kid->op_sv;
5457         STRLEN n_a;
5458
5459         /* Is it a constant from cv_const_sv()? */
5460         if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5461             SV *rsv = SvRV(kidsv);
5462             int svtype = SvTYPE(rsv);
5463             char *badtype = Nullch;
5464
5465             switch (o->op_type) {
5466             case OP_RV2SV:
5467                 if (svtype > SVt_PVMG)
5468                     badtype = "a SCALAR";
5469                 break;
5470             case OP_RV2AV:
5471                 if (svtype != SVt_PVAV)
5472                     badtype = "an ARRAY";
5473                 break;
5474             case OP_RV2HV:
5475                 if (svtype != SVt_PVHV) {
5476                     if (svtype == SVt_PVAV) {   /* pseudohash? */
5477                         SV **ksv = av_fetch((AV*)rsv, 0, FALSE);
5478                         if (ksv && SvROK(*ksv)
5479                             && SvTYPE(SvRV(*ksv)) == SVt_PVHV)
5480                         {
5481                                 break;
5482                         }
5483                     }
5484                     badtype = "a HASH";
5485                 }
5486                 break;
5487             case OP_RV2CV:
5488                 if (svtype != SVt_PVCV)
5489                     badtype = "a CODE";
5490                 break;
5491             }
5492             if (badtype)
5493                 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5494             return o;
5495         }
5496         name = SvPV(kidsv, n_a);
5497         if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5498             char *badthing = Nullch;
5499             switch (o->op_type) {
5500             case OP_RV2SV:
5501                 badthing = "a SCALAR";
5502                 break;
5503             case OP_RV2AV:
5504                 badthing = "an ARRAY";
5505                 break;
5506             case OP_RV2HV:
5507                 badthing = "a HASH";
5508                 break;
5509             }
5510             if (badthing)
5511                 Perl_croak(aTHX_
5512           "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5513                       name, badthing);
5514         }
5515         /*
5516          * This is a little tricky.  We only want to add the symbol if we
5517          * didn't add it in the lexer.  Otherwise we get duplicate strict
5518          * warnings.  But if we didn't add it in the lexer, we must at
5519          * least pretend like we wanted to add it even if it existed before,
5520          * or we get possible typo warnings.  OPpCONST_ENTERED says
5521          * whether the lexer already added THIS instance of this symbol.
5522          */
5523         iscv = (o->op_type == OP_RV2CV) * 2;
5524         do {
5525             gv = gv_fetchpv(name,
5526                 iscv | !(kid->op_private & OPpCONST_ENTERED),
5527                 iscv
5528                     ? SVt_PVCV
5529                     : o->op_type == OP_RV2SV
5530                         ? SVt_PV
5531                         : o->op_type == OP_RV2AV
5532                             ? SVt_PVAV
5533                             : o->op_type == OP_RV2HV
5534                                 ? SVt_PVHV
5535                                 : SVt_PVGV);
5536         } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5537         if (gv) {
5538             kid->op_type = OP_GV;
5539             SvREFCNT_dec(kid->op_sv);
5540 #ifdef USE_ITHREADS
5541             /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5542             kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5543             SvREFCNT_dec(PL_curpad[kPADOP->op_padix]);
5544             GvIN_PAD_on(gv);
5545             PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv);
5546 #else
5547             kid->op_sv = SvREFCNT_inc(gv);
5548 #endif
5549             kid->op_private = 0;
5550             kid->op_ppaddr = PL_ppaddr[OP_GV];
5551         }
5552     }
5553     return o;
5554 }
5555
5556 OP *
5557 Perl_ck_ftst(pTHX_ OP *o)
5558 {
5559     I32 type = o->op_type;
5560
5561     if (o->op_flags & OPf_REF) {
5562         /* nothing */
5563     }
5564     else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5565         SVOP *kid = (SVOP*)cUNOPo->op_first;
5566
5567         if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5568             STRLEN n_a;
5569             OP *newop = newGVOP(type, OPf_REF,
5570                 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5571             op_free(o);
5572             o = newop;
5573         }
5574     }
5575     else {
5576         op_free(o);
5577         if (type == OP_FTTTY)
5578            o =  newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
5579                                 SVt_PVIO));
5580         else
5581             o = newUNOP(type, 0, newDEFSVOP());
5582     }
5583 #ifdef USE_LOCALE
5584     if (type == OP_FTTEXT || type == OP_FTBINARY) {
5585         o->op_private = 0;
5586         if (PL_hints & HINT_LOCALE)
5587             o->op_private |= OPpLOCALE;
5588     }
5589 #endif
5590     return o;
5591 }
5592
5593 OP *
5594 Perl_ck_fun(pTHX_ OP *o)
5595 {
5596     register OP *kid;
5597     OP **tokid;
5598     OP *sibl;
5599     I32 numargs = 0;
5600     int type = o->op_type;
5601     register I32 oa = PL_opargs[type] >> OASHIFT;
5602
5603     if (o->op_flags & OPf_STACKED) {
5604         if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5605             oa &= ~OA_OPTIONAL;
5606         else
5607             return no_fh_allowed(o);
5608     }
5609
5610     if (o->op_flags & OPf_KIDS) {
5611         STRLEN n_a;
5612         tokid = &cLISTOPo->op_first;
5613         kid = cLISTOPo->op_first;
5614         if (kid->op_type == OP_PUSHMARK ||
5615             (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5616         {
5617             tokid = &kid->op_sibling;
5618             kid = kid->op_sibling;
5619         }
5620         if (!kid && PL_opargs[type] & OA_DEFGV)
5621             *tokid = kid = newDEFSVOP();
5622
5623         while (oa && kid) {
5624             numargs++;
5625             sibl = kid->op_sibling;
5626             switch (oa & 7) {
5627             case OA_SCALAR:
5628                 /* list seen where single (scalar) arg expected? */
5629                 if (numargs == 1 && !(oa >> 4)
5630                     && kid->op_type == OP_LIST && type != OP_SCALAR)
5631                 {
5632                     return too_many_arguments(o,PL_op_desc[type]);
5633                 }
5634                 scalar(kid);
5635                 break;
5636             case OA_LIST:
5637                 if (oa < 16) {
5638                     kid = 0;
5639                     continue;
5640                 }
5641                 else
5642                     list(kid);
5643                 break;
5644             case OA_AVREF:
5645                 if (kid->op_type == OP_CONST &&
5646                     (kid->op_private & OPpCONST_BARE))
5647                 {
5648                     char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5649                     OP *newop = newAVREF(newGVOP(OP_GV, 0,
5650                         gv_fetchpv(name, TRUE, SVt_PVAV) ));
5651                     if (ckWARN(WARN_DEPRECATED))
5652                         Perl_warner(aTHX_ WARN_DEPRECATED,
5653                             "Array @%s missing the @ in argument %"IVdf" of %s()",
5654                             name, (IV)numargs, PL_op_desc[type]);
5655                     op_free(kid);
5656                     kid = newop;
5657                     kid->op_sibling = sibl;
5658                     *tokid = kid;
5659                 }
5660                 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5661                     bad_type(numargs, "array", PL_op_desc[type], kid);
5662                 mod(kid, type);
5663                 break;
5664             case OA_HVREF:
5665                 if (kid->op_type == OP_CONST &&
5666                     (kid->op_private & OPpCONST_BARE))
5667                 {
5668                     char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5669                     OP *newop = newHVREF(newGVOP(OP_GV, 0,
5670                         gv_fetchpv(name, TRUE, SVt_PVHV) ));
5671                     if (ckWARN(WARN_DEPRECATED))
5672                         Perl_warner(aTHX_ WARN_DEPRECATED,
5673                             "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5674                             name, (IV)numargs, PL_op_desc[type]);
5675                     op_free(kid);
5676                     kid = newop;
5677                     kid->op_sibling = sibl;
5678                     *tokid = kid;
5679                 }
5680                 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5681                     bad_type(numargs, "hash", PL_op_desc[type], kid);
5682                 mod(kid, type);
5683                 break;
5684             case OA_CVREF:
5685                 {
5686                     OP *newop = newUNOP(OP_NULL, 0, kid);
5687                     kid->op_sibling = 0;
5688                     linklist(kid);
5689                     newop->op_next = newop;
5690                     kid = newop;
5691                     kid->op_sibling = sibl;
5692                     *tokid = kid;
5693                 }
5694                 break;
5695             case OA_FILEREF:
5696                 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5697                     if (kid->op_type == OP_CONST &&
5698                         (kid->op_private & OPpCONST_BARE))
5699                     {
5700                         OP *newop = newGVOP(OP_GV, 0,
5701                             gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5702                                         SVt_PVIO) );
5703                         op_free(kid);
5704                         kid = newop;
5705                     }
5706                     else if (kid->op_type == OP_READLINE) {
5707                         /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5708                         bad_type(numargs, "HANDLE", PL_op_desc[o->op_type], kid);
5709                     }
5710                     else {
5711                         I32 flags = OPf_SPECIAL;
5712                         I32 priv = 0;
5713                         PADOFFSET targ = 0;
5714
5715                         /* is this op a FH constructor? */
5716                         if (is_handle_constructor(o,numargs)) {
5717                             char *name = Nullch;
5718                             STRLEN len;
5719
5720                             flags = 0;
5721                             /* Set a flag to tell rv2gv to vivify
5722                              * need to "prove" flag does not mean something
5723                              * else already - NI-S 1999/05/07
5724                              */
5725                             priv = OPpDEREF;
5726                             if (kid->op_type == OP_PADSV) {
5727                                 SV **namep = av_fetch(PL_comppad_name,
5728                                                       kid->op_targ, 4);
5729                                 if (namep && *namep)
5730                                     name = SvPV(*namep, len);
5731                             }
5732                             else if (kid->op_type == OP_RV2SV
5733                                      && kUNOP->op_first->op_type == OP_GV)
5734                             {
5735                                 GV *gv = cGVOPx_gv(kUNOP->op_first);
5736                                 name = GvNAME(gv);
5737                                 len = GvNAMELEN(gv);
5738                             }
5739                             else if (kid->op_type == OP_AELEM
5740                                      || kid->op_type == OP_HELEM)
5741                             {
5742                                 name = "__ANONIO__";
5743                                 len = 10;
5744                                 mod(kid,type);
5745                             }
5746                             if (name) {
5747                                 SV *namesv;
5748                                 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5749                                 namesv = PL_curpad[targ];
5750                                 (void)SvUPGRADE(namesv, SVt_PV);
5751                                 if (*name != '$')
5752                                     sv_setpvn(namesv, "$", 1);
5753                                 sv_catpvn(namesv, name, len);
5754                             }
5755                         }
5756                         kid->op_sibling = 0;
5757                         kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5758                         kid->op_targ = targ;
5759                         kid->op_private |= priv;
5760                     }
5761                     kid->op_sibling = sibl;
5762                     *tokid = kid;
5763                 }
5764                 scalar(kid);
5765                 break;
5766             case OA_SCALARREF:
5767                 mod(scalar(kid), type);
5768                 break;
5769             }
5770             oa >>= 4;
5771             tokid = &kid->op_sibling;
5772             kid = kid->op_sibling;
5773         }
5774         o->op_private |= numargs;
5775         if (kid)
5776             return too_many_arguments(o,PL_op_desc[o->op_type]);
5777         listkids(o);
5778     }
5779     else if (PL_opargs[type] & OA_DEFGV) {
5780         op_free(o);
5781         return newUNOP(type, 0, newDEFSVOP());
5782     }
5783
5784     if (oa) {
5785         while (oa & OA_OPTIONAL)
5786             oa >>= 4;
5787         if (oa && oa != OA_LIST)
5788             return too_few_arguments(o,PL_op_desc[o->op_type]);
5789     }
5790     return o;
5791 }
5792
5793 OP *
5794 Perl_ck_glob(pTHX_ OP *o)
5795 {
5796     GV *gv;
5797
5798     o = ck_fun(o);
5799     if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5800         append_elem(OP_GLOB, o, newDEFSVOP());
5801
5802     if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV)) && GvIMPORTED_CV(gv)))
5803         gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5804
5805 #if !defined(PERL_EXTERNAL_GLOB)
5806     /* XXX this can be tightened up and made more failsafe. */
5807     if (!gv) {
5808         ENTER;
5809         Perl_load_module(aTHX_ 0, newSVpvn("File::Glob", 10), Nullsv,
5810                          /* null-terminated import list */
5811                          newSVpvn(":globally", 9), Nullsv);
5812         gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5813         LEAVE;
5814     }
5815 #endif /* PERL_EXTERNAL_GLOB */
5816
5817     if (gv && GvIMPORTED_CV(gv)) {
5818         append_elem(OP_GLOB, o,
5819                     newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5820         o->op_type = OP_LIST;
5821         o->op_ppaddr = PL_ppaddr[OP_LIST];
5822         cLISTOPo->op_first->op_type = OP_PUSHMARK;
5823         cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5824         o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5825                     append_elem(OP_LIST, o,
5826                                 scalar(newUNOP(OP_RV2CV, 0,
5827                                                newGVOP(OP_GV, 0, gv)))));
5828         o = newUNOP(OP_NULL, 0, ck_subr(o));
5829         o->op_targ = OP_GLOB;           /* hint at what it used to be */
5830         return o;
5831     }
5832     gv = newGVgen("main");
5833     gv_IOadd(gv);
5834     append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5835     scalarkids(o);
5836     return o;
5837 }
5838
5839 OP *
5840 Perl_ck_grep(pTHX_ OP *o)
5841 {
5842     LOGOP *gwop;
5843     OP *kid;
5844     OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5845
5846     o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5847     NewOp(1101, gwop, 1, LOGOP);
5848
5849     if (o->op_flags & OPf_STACKED) {
5850         OP* k;
5851         o = ck_sort(o);
5852         kid = cLISTOPo->op_first->op_sibling;
5853         for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
5854             kid = k;
5855         }
5856         kid->op_next = (OP*)gwop;
5857         o->op_flags &= ~OPf_STACKED;
5858     }
5859     kid = cLISTOPo->op_first->op_sibling;
5860     if (type == OP_MAPWHILE)
5861         list(kid);
5862     else
5863         scalar(kid);
5864     o = ck_fun(o);
5865     if (PL_error_count)
5866         return o;
5867     kid = cLISTOPo->op_first->op_sibling;
5868     if (kid->op_type != OP_NULL)
5869         Perl_croak(aTHX_ "panic: ck_grep");
5870     kid = kUNOP->op_first;
5871
5872     gwop->op_type = type;
5873     gwop->op_ppaddr = PL_ppaddr[type];
5874     gwop->op_first = listkids(o);
5875     gwop->op_flags |= OPf_KIDS;
5876     gwop->op_private = 1;
5877     gwop->op_other = LINKLIST(kid);
5878     gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5879     kid->op_next = (OP*)gwop;
5880
5881     kid = cLISTOPo->op_first->op_sibling;
5882     if (!kid || !kid->op_sibling)
5883         return too_few_arguments(o,PL_op_desc[o->op_type]);
5884     for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5885         mod(kid, OP_GREPSTART);
5886
5887     return (OP*)gwop;
5888 }
5889
5890 OP *
5891 Perl_ck_index(pTHX_ OP *o)
5892 {
5893     if (o->op_flags & OPf_KIDS) {
5894         OP *kid = cLISTOPo->op_first->op_sibling;       /* get past pushmark */
5895         if (kid)
5896             kid = kid->op_sibling;                      /* get past "big" */
5897         if (kid && kid->op_type == OP_CONST)
5898             fbm_compile(((SVOP*)kid)->op_sv, 0);
5899     }
5900     return ck_fun(o);
5901 }
5902
5903 OP *
5904 Perl_ck_lengthconst(pTHX_ OP *o)
5905 {
5906     /* XXX length optimization goes here */
5907     return ck_fun(o);
5908 }
5909
5910 OP *
5911 Perl_ck_lfun(pTHX_ OP *o)
5912 {
5913     OPCODE type = o->op_type;
5914     return modkids(ck_fun(o), type);
5915 }
5916
5917 OP *
5918 Perl_ck_defined(pTHX_ OP *o)            /* 19990527 MJD */
5919 {
5920     if ((o->op_flags & OPf_KIDS) && ckWARN(WARN_DEPRECATED)) {
5921         switch (cUNOPo->op_first->op_type) {
5922         case OP_RV2AV:
5923             /* This is needed for
5924                if (defined %stash::)
5925                to work.   Do not break Tk.
5926                */
5927             break;                      /* Globals via GV can be undef */
5928         case OP_PADAV:
5929         case OP_AASSIGN:                /* Is this a good idea? */
5930             Perl_warner(aTHX_ WARN_DEPRECATED,
5931                         "defined(@array) is deprecated");
5932             Perl_warner(aTHX_ WARN_DEPRECATED,
5933                         "\t(Maybe you should just omit the defined()?)\n");
5934         break;
5935         case OP_RV2HV:
5936             /* This is needed for
5937                if (defined %stash::)
5938                to work.   Do not break Tk.
5939                */
5940             break;                      /* Globals via GV can be undef */
5941         case OP_PADHV:
5942             Perl_warner(aTHX_ WARN_DEPRECATED,
5943                         "defined(%%hash) is deprecated");
5944             Perl_warner(aTHX_ WARN_DEPRECATED,
5945                         "\t(Maybe you should just omit the defined()?)\n");
5946             break;
5947         default:
5948             /* no warning */
5949             break;
5950         }
5951     }
5952     return ck_rfun(o);
5953 }
5954
5955 OP *
5956 Perl_ck_rfun(pTHX_ OP *o)
5957 {
5958     OPCODE type = o->op_type;
5959     return refkids(ck_fun(o), type);
5960 }
5961
5962 OP *
5963 Perl_ck_listiob(pTHX_ OP *o)
5964 {
5965     register OP *kid;
5966
5967     kid = cLISTOPo->op_first;
5968     if (!kid) {
5969         o = force_list(o);
5970         kid = cLISTOPo->op_first;
5971     }
5972     if (kid->op_type == OP_PUSHMARK)
5973         kid = kid->op_sibling;
5974     if (kid && o->op_flags & OPf_STACKED)
5975         kid = kid->op_sibling;
5976     else if (kid && !kid->op_sibling) {         /* print HANDLE; */
5977         if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5978             o->op_flags |= OPf_STACKED; /* make it a filehandle */
5979             kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5980             cLISTOPo->op_first->op_sibling = kid;
5981             cLISTOPo->op_last = kid;
5982             kid = kid->op_sibling;
5983         }
5984     }
5985
5986     if (!kid)
5987         append_elem(o->op_type, o, newDEFSVOP());
5988
5989     o = listkids(o);
5990
5991     o->op_private = 0;
5992 #ifdef USE_LOCALE
5993     if (PL_hints & HINT_LOCALE)
5994         o->op_private |= OPpLOCALE;
5995 #endif
5996
5997     return o;
5998 }
5999
6000 OP *
6001 Perl_ck_fun_locale(pTHX_ OP *o)
6002 {
6003     o = ck_fun(o);
6004
6005     o->op_private = 0;
6006 #ifdef USE_LOCALE
6007     if (PL_hints & HINT_LOCALE)
6008         o->op_private |= OPpLOCALE;
6009 #endif
6010
6011     return o;
6012 }
6013
6014 OP *
6015 Perl_ck_sassign(pTHX_ OP *o)
6016 {
6017     OP *kid = cLISTOPo->op_first;
6018     /* has a disposable target? */
6019     if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6020         && !(kid->op_flags & OPf_STACKED)
6021         /* Cannot steal the second time! */
6022         && !(kid->op_private & OPpTARGET_MY))
6023     {
6024         OP *kkid = kid->op_sibling;
6025
6026         /* Can just relocate the target. */
6027         if (kkid && kkid->op_type == OP_PADSV
6028             && !(kkid->op_private & OPpLVAL_INTRO))
6029         {
6030             kid->op_targ = kkid->op_targ;
6031             kkid->op_targ = 0;
6032             /* Now we do not need PADSV and SASSIGN. */
6033             kid->op_sibling = o->op_sibling;    /* NULL */
6034             cLISTOPo->op_first = NULL;
6035             op_free(o);
6036             op_free(kkid);
6037             kid->op_private |= OPpTARGET_MY;    /* Used for context settings */
6038             return kid;
6039         }
6040     }
6041     return o;
6042 }
6043
6044 OP *
6045 Perl_ck_scmp(pTHX_ OP *o)
6046 {
6047     o->op_private = 0;
6048 #ifdef USE_LOCALE
6049     if (PL_hints & HINT_LOCALE)
6050         o->op_private |= OPpLOCALE;
6051 #endif
6052
6053     return o;
6054 }
6055
6056 OP *
6057 Perl_ck_match(pTHX_ OP *o)
6058 {
6059     o->op_private |= OPpRUNTIME;
6060     return o;
6061 }
6062
6063 OP *
6064 Perl_ck_method(pTHX_ OP *o)
6065 {
6066     OP *kid = cUNOPo->op_first;
6067     if (kid->op_type == OP_CONST) {
6068         SV* sv = kSVOP->op_sv;
6069         if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
6070             OP *cmop;
6071             if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6072                 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
6073             }
6074             else {
6075                 kSVOP->op_sv = Nullsv;
6076             }
6077             cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6078             op_free(o);
6079             return cmop;
6080         }
6081     }
6082     return o;
6083 }
6084
6085 OP *
6086 Perl_ck_null(pTHX_ OP *o)
6087 {
6088     return o;
6089 }
6090
6091 OP *
6092 Perl_ck_open(pTHX_ OP *o)
6093 {
6094     HV *table = GvHV(PL_hintgv);
6095     if (table) {
6096         SV **svp;
6097         I32 mode;
6098         svp = hv_fetch(table, "open_IN", 7, FALSE);
6099         if (svp && *svp) {
6100             mode = mode_from_discipline(*svp);
6101             if (mode & O_BINARY)
6102                 o->op_private |= OPpOPEN_IN_RAW;
6103             else if (mode & O_TEXT)
6104                 o->op_private |= OPpOPEN_IN_CRLF;
6105         }
6106
6107         svp = hv_fetch(table, "open_OUT", 8, FALSE);
6108         if (svp && *svp) {
6109             mode = mode_from_discipline(*svp);
6110             if (mode & O_BINARY)
6111                 o->op_private |= OPpOPEN_OUT_RAW;
6112             else if (mode & O_TEXT)
6113                 o->op_private |= OPpOPEN_OUT_CRLF;
6114         }
6115     }
6116     if (o->op_type == OP_BACKTICK)
6117         return o;
6118     return ck_fun(o);
6119 }
6120
6121 OP *
6122 Perl_ck_repeat(pTHX_ OP *o)
6123 {
6124     if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6125         o->op_private |= OPpREPEAT_DOLIST;
6126         cBINOPo->op_first = force_list(cBINOPo->op_first);
6127     }
6128     else
6129         scalar(o);
6130     return o;
6131 }
6132
6133 OP *
6134 Perl_ck_require(pTHX_ OP *o)
6135 {
6136     if (o->op_flags & OPf_KIDS) {       /* Shall we supply missing .pm? */
6137         SVOP *kid = (SVOP*)cUNOPo->op_first;
6138
6139         if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6140             char *s;
6141             for (s = SvPVX(kid->op_sv); *s; s++) {
6142                 if (*s == ':' && s[1] == ':') {
6143                     *s = '/';
6144                     Move(s+2, s+1, strlen(s+2)+1, char);
6145                     --SvCUR(kid->op_sv);
6146                 }
6147             }
6148             if (SvREADONLY(kid->op_sv)) {
6149                 SvREADONLY_off(kid->op_sv);
6150                 sv_catpvn(kid->op_sv, ".pm", 3);
6151                 SvREADONLY_on(kid->op_sv);
6152             }
6153             else
6154                 sv_catpvn(kid->op_sv, ".pm", 3);
6155         }
6156     }
6157     return ck_fun(o);
6158 }
6159
6160 OP *
6161 Perl_ck_return(pTHX_ OP *o)
6162 {
6163     OP *kid;
6164     if (CvLVALUE(PL_compcv)) {
6165         for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6166             mod(kid, OP_LEAVESUBLV);
6167     }
6168     return o;
6169 }
6170
6171 #if 0
6172 OP *
6173 Perl_ck_retarget(pTHX_ OP *o)
6174 {
6175     Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
6176     /* STUB */
6177     return o;
6178 }
6179 #endif
6180
6181 OP *
6182 Perl_ck_select(pTHX_ OP *o)
6183 {
6184     OP* kid;
6185     if (o->op_flags & OPf_KIDS) {
6186         kid = cLISTOPo->op_first->op_sibling;   /* get past pushmark */
6187         if (kid && kid->op_sibling) {
6188             o->op_type = OP_SSELECT;
6189             o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6190             o = ck_fun(o);
6191             return fold_constants(o);
6192         }
6193     }
6194     o = ck_fun(o);
6195     kid = cLISTOPo->op_first->op_sibling;    /* get past pushmark */
6196     if (kid && kid->op_type == OP_RV2GV)
6197         kid->op_private &= ~HINT_STRICT_REFS;
6198     return o;
6199 }
6200
6201 OP *
6202 Perl_ck_shift(pTHX_ OP *o)
6203 {
6204     I32 type = o->op_type;
6205
6206     if (!(o->op_flags & OPf_KIDS)) {
6207         OP *argop;
6208
6209         op_free(o);
6210 #ifdef USE_THREADS
6211         if (!CvUNIQUE(PL_compcv)) {
6212             argop = newOP(OP_PADAV, OPf_REF);
6213             argop->op_targ = 0;         /* PL_curpad[0] is @_ */
6214         }
6215         else {
6216             argop = newUNOP(OP_RV2AV, 0,
6217                 scalar(newGVOP(OP_GV, 0,
6218                     gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6219         }
6220 #else
6221         argop = newUNOP(OP_RV2AV, 0,
6222             scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
6223                            PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6224 #endif /* USE_THREADS */
6225         return newUNOP(type, 0, scalar(argop));
6226     }
6227     return scalar(modkids(ck_fun(o), type));
6228 }
6229
6230 OP *
6231 Perl_ck_sort(pTHX_ OP *o)
6232 {
6233     OP *firstkid;
6234     o->op_private = 0;
6235 #ifdef USE_LOCALE
6236     if (PL_hints & HINT_LOCALE)
6237         o->op_private |= OPpLOCALE;
6238 #endif
6239
6240     if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6241         simplify_sort(o);
6242     firstkid = cLISTOPo->op_first->op_sibling;          /* get past pushmark */
6243     if (o->op_flags & OPf_STACKED) {                    /* may have been cleared */
6244         OP *k;
6245         OP *kid = cUNOPx(firstkid)->op_first;           /* get past null */
6246
6247         if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6248             linklist(kid);
6249             if (kid->op_type == OP_SCOPE) {
6250                 k = kid->op_next;
6251                 kid->op_next = 0;
6252             }
6253             else if (kid->op_type == OP_LEAVE) {
6254                 if (o->op_type == OP_SORT) {
6255                     null(kid);                  /* wipe out leave */
6256                     kid->op_next = kid;
6257
6258                     for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6259                         if (k->op_next == kid)
6260                             k->op_next = 0;
6261                         /* don't descend into loops */
6262                         else if (k->op_type == OP_ENTERLOOP
6263                                  || k->op_type == OP_ENTERITER)
6264                         {
6265                             k = cLOOPx(k)->op_lastop;
6266                         }
6267                     }
6268                 }
6269                 else
6270                     kid->op_next = 0;           /* just disconnect the leave */
6271                 k = kLISTOP->op_first;
6272             }
6273             peep(k);
6274
6275             kid = firstkid;
6276             if (o->op_type == OP_SORT) {
6277                 /* provide scalar context for comparison function/block */
6278                 kid = scalar(kid);
6279                 kid->op_next = kid;
6280             }
6281             else
6282                 kid->op_next = k;
6283             o->op_flags |= OPf_SPECIAL;
6284         }
6285         else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6286             null(firstkid);
6287
6288         firstkid = firstkid->op_sibling;
6289     }
6290
6291     /* provide list context for arguments */
6292     if (o->op_type == OP_SORT)
6293         list(firstkid);
6294
6295     return o;
6296 }
6297
6298 STATIC void
6299 S_simplify_sort(pTHX_ OP *o)
6300 {
6301     register OP *kid = cLISTOPo->op_first->op_sibling;  /* get past pushmark */
6302     OP *k;
6303     int reversed;
6304     GV *gv;
6305     if (!(o->op_flags & OPf_STACKED))
6306         return;
6307     GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6308     GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6309     kid = kUNOP->op_first;                              /* get past null */
6310     if (kid->op_type != OP_SCOPE)
6311         return;
6312     kid = kLISTOP->op_last;                             /* get past scope */
6313     switch(kid->op_type) {
6314         case OP_NCMP:
6315         case OP_I_NCMP:
6316         case OP_SCMP:
6317             break;
6318         default:
6319             return;
6320     }
6321     k = kid;                                            /* remember this node*/
6322     if (kBINOP->op_first->op_type != OP_RV2SV)
6323         return;
6324     kid = kBINOP->op_first;                             /* get past cmp */
6325     if (kUNOP->op_first->op_type != OP_GV)
6326         return;
6327     kid = kUNOP->op_first;                              /* get past rv2sv */
6328     gv = kGVOP_gv;
6329     if (GvSTASH(gv) != PL_curstash)
6330         return;
6331     if (strEQ(GvNAME(gv), "a"))
6332         reversed = 0;
6333     else if (strEQ(GvNAME(gv), "b"))
6334         reversed = 1;
6335     else
6336         return;
6337     kid = k;                                            /* back to cmp */
6338     if (kBINOP->op_last->op_type != OP_RV2SV)
6339         return;
6340     kid = kBINOP->op_last;                              /* down to 2nd arg */
6341     if (kUNOP->op_first->op_type != OP_GV)
6342         return;
6343     kid = kUNOP->op_first;                              /* get past rv2sv */
6344     gv = kGVOP_gv;
6345     if (GvSTASH(gv) != PL_curstash
6346         || ( reversed
6347             ? strNE(GvNAME(gv), "a")
6348             : strNE(GvNAME(gv), "b")))
6349         return;
6350     o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6351     if (reversed)
6352         o->op_private |= OPpSORT_REVERSE;
6353     if (k->op_type == OP_NCMP)
6354         o->op_private |= OPpSORT_NUMERIC;
6355     if (k->op_type == OP_I_NCMP)
6356         o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6357     kid = cLISTOPo->op_first->op_sibling;
6358     cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6359     op_free(kid);                                     /* then delete it */
6360 }
6361
6362 OP *
6363 Perl_ck_split(pTHX_ OP *o)
6364 {
6365     register OP *kid;
6366
6367     if (o->op_flags & OPf_STACKED)
6368         return no_fh_allowed(o);
6369
6370     kid = cLISTOPo->op_first;
6371     if (kid->op_type != OP_NULL)
6372         Perl_croak(aTHX_ "panic: ck_split");
6373     kid = kid->op_sibling;
6374     op_free(cLISTOPo->op_first);
6375     cLISTOPo->op_first = kid;
6376     if (!kid) {
6377         cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6378         cLISTOPo->op_last = kid; /* There was only one element previously */
6379     }
6380
6381     if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6382         OP *sibl = kid->op_sibling;
6383         kid->op_sibling = 0;
6384         kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
6385         if (cLISTOPo->op_first == cLISTOPo->op_last)
6386             cLISTOPo->op_last = kid;
6387         cLISTOPo->op_first = kid;
6388         kid->op_sibling = sibl;
6389     }
6390
6391     kid->op_type = OP_PUSHRE;
6392     kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6393     scalar(kid);
6394
6395     if (!kid->op_sibling)
6396         append_elem(OP_SPLIT, o, newDEFSVOP());
6397
6398     kid = kid->op_sibling;
6399     scalar(kid);
6400
6401     if (!kid->op_sibling)
6402         append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6403
6404     kid = kid->op_sibling;
6405     scalar(kid);
6406
6407     if (kid->op_sibling)
6408         return too_many_arguments(o,PL_op_desc[o->op_type]);
6409
6410     return o;
6411 }
6412
6413 OP *
6414 Perl_ck_join(pTHX_ OP *o)
6415 {
6416     if (ckWARN(WARN_SYNTAX)) {
6417         OP *kid = cLISTOPo->op_first->op_sibling;
6418         if (kid && kid->op_type == OP_MATCH) {
6419             char *pmstr = "STRING";
6420             if (kPMOP->op_pmregexp)
6421                 pmstr = kPMOP->op_pmregexp->precomp;
6422             Perl_warner(aTHX_ WARN_SYNTAX,
6423                         "/%s/ should probably be written as \"%s\"",
6424                         pmstr, pmstr);
6425         }
6426     }
6427     return ck_fun(o);
6428 }
6429
6430 OP *
6431 Perl_ck_subr(pTHX_ OP *o)
6432 {
6433     OP *prev = ((cUNOPo->op_first->op_sibling)
6434              ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6435     OP *o2 = prev->op_sibling;
6436     OP *cvop;
6437     char *proto = 0;
6438     CV *cv = 0;
6439     GV *namegv = 0;
6440     int optional = 0;
6441     I32 arg = 0;
6442     STRLEN n_a;
6443
6444     o->op_private |= OPpENTERSUB_HASTARG;
6445     for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6446     if (cvop->op_type == OP_RV2CV) {
6447         SVOP* tmpop;
6448         o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6449         null(cvop);             /* disable rv2cv */
6450         tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6451         if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6452             GV *gv = cGVOPx_gv(tmpop);
6453             cv = GvCVu(gv);
6454             if (!cv)
6455                 tmpop->op_private |= OPpEARLY_CV;
6456             else if (SvPOK(cv)) {
6457                 namegv = CvANON(cv) ? gv : CvGV(cv);
6458                 proto = SvPV((SV*)cv, n_a);
6459             }
6460         }
6461     }
6462     else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6463         if (o2->op_type == OP_CONST)
6464             o2->op_private &= ~OPpCONST_STRICT;
6465         else if (o2->op_type == OP_LIST) {
6466             OP *o = ((UNOP*)o2)->op_first->op_sibling;
6467             if (o && o->op_type == OP_CONST)
6468                 o->op_private &= ~OPpCONST_STRICT;
6469         }
6470     }
6471     o->op_private |= (PL_hints & HINT_STRICT_REFS);
6472     if (PERLDB_SUB && PL_curstash != PL_debstash)
6473         o->op_private |= OPpENTERSUB_DB;
6474     while (o2 != cvop) {
6475         if (proto) {
6476             switch (*proto) {
6477             case '\0':
6478                 return too_many_arguments(o, gv_ename(namegv));
6479             case ';':
6480                 optional = 1;
6481                 proto++;
6482                 continue;
6483             case '$':
6484                 proto++;
6485                 arg++;
6486                 scalar(o2);
6487                 break;
6488             case '%':
6489             case '@':
6490                 list(o2);
6491                 arg++;
6492                 break;
6493             case '&':
6494                 proto++;
6495                 arg++;
6496                 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6497                     bad_type(arg,
6498                         arg == 1 ? "block or sub {}" : "sub {}",
6499                         gv_ename(namegv), o2);
6500                 break;
6501             case '*':
6502                 /* '*' allows any scalar type, including bareword */
6503                 proto++;
6504                 arg++;
6505                 if (o2->op_type == OP_RV2GV)
6506                     goto wrapref;       /* autoconvert GLOB -> GLOBref */
6507                 else if (o2->op_type == OP_CONST)
6508                     o2->op_private &= ~OPpCONST_STRICT;
6509                 else if (o2->op_type == OP_ENTERSUB) {
6510                     /* accidental subroutine, revert to bareword */
6511                     OP *gvop = ((UNOP*)o2)->op_first;
6512                     if (gvop && gvop->op_type == OP_NULL) {
6513                         gvop = ((UNOP*)gvop)->op_first;
6514                         if (gvop) {
6515                             for (; gvop->op_sibling; gvop = gvop->op_sibling)
6516                                 ;
6517                             if (gvop &&
6518                                 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6519                                 (gvop = ((UNOP*)gvop)->op_first) &&
6520                                 gvop->op_type == OP_GV)
6521                             {
6522                                 GV *gv = cGVOPx_gv(gvop);
6523                                 OP *sibling = o2->op_sibling;
6524                                 SV *n = newSVpvn("",0);
6525                                 op_free(o2);
6526                                 gv_fullname3(n, gv, "");
6527                                 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6528                                     sv_chop(n, SvPVX(n)+6);
6529                                 o2 = newSVOP(OP_CONST, 0, n);
6530                                 prev->op_sibling = o2;
6531                                 o2->op_sibling = sibling;
6532                             }
6533                         }
6534                     }
6535                 }
6536                 scalar(o2);
6537                 break;
6538             case '\\':
6539                 proto++;
6540                 arg++;
6541                 switch (*proto++) {
6542                 case '*':
6543                     if (o2->op_type != OP_RV2GV)
6544                         bad_type(arg, "symbol", gv_ename(namegv), o2);
6545                     goto wrapref;
6546                 case '&':
6547                     if (o2->op_type != OP_ENTERSUB)
6548                         bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6549                     goto wrapref;
6550                 case '$':
6551                     if (o2->op_type != OP_RV2SV
6552                         && o2->op_type != OP_PADSV
6553                         && o2->op_type != OP_HELEM
6554                         && o2->op_type != OP_AELEM
6555                         && o2->op_type != OP_THREADSV)
6556                     {
6557                         bad_type(arg, "scalar", gv_ename(namegv), o2);
6558                     }
6559                     goto wrapref;
6560                 case '@':
6561                     if (o2->op_type != OP_RV2AV && o2->op_type != OP_PADAV)
6562                         bad_type(arg, "array", gv_ename(namegv), o2);
6563                     goto wrapref;
6564                 case '%':
6565                     if (o2->op_type != OP_RV2HV && o2->op_type != OP_PADHV)
6566                         bad_type(arg, "hash", gv_ename(namegv), o2);
6567                   wrapref:
6568                     {
6569                         OP* kid = o2;
6570                         OP* sib = kid->op_sibling;
6571                         kid->op_sibling = 0;
6572                         o2 = newUNOP(OP_REFGEN, 0, kid);
6573                         o2->op_sibling = sib;
6574                         prev->op_sibling = o2;
6575                     }
6576                     break;
6577                 default: goto oops;
6578                 }
6579                 break;
6580             case ' ':
6581                 proto++;
6582                 continue;
6583             default:
6584               oops:
6585                 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
6586                         gv_ename(namegv), SvPV((SV*)cv, n_a));
6587             }
6588         }
6589         else
6590             list(o2);
6591         mod(o2, OP_ENTERSUB);
6592         prev = o2;
6593         o2 = o2->op_sibling;
6594     }
6595     if (proto && !optional &&
6596           (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6597         return too_few_arguments(o, gv_ename(namegv));
6598     return o;
6599 }
6600
6601 OP *
6602 Perl_ck_svconst(pTHX_ OP *o)
6603 {
6604     SvREADONLY_on(cSVOPo->op_sv);
6605     return o;
6606 }
6607
6608 OP *
6609 Perl_ck_trunc(pTHX_ OP *o)
6610 {
6611     if (o->op_flags & OPf_KIDS) {
6612         SVOP *kid = (SVOP*)cUNOPo->op_first;
6613
6614         if (kid->op_type == OP_NULL)
6615             kid = (SVOP*)kid->op_sibling;
6616         if (kid && kid->op_type == OP_CONST &&
6617             (kid->op_private & OPpCONST_BARE))
6618         {
6619             o->op_flags |= OPf_SPECIAL;
6620             kid->op_private &= ~OPpCONST_STRICT;
6621         }
6622     }
6623     return ck_fun(o);
6624 }
6625
6626 OP *
6627 Perl_ck_substr(pTHX_ OP *o)
6628 {
6629     o = ck_fun(o);
6630     if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6631         OP *kid = cLISTOPo->op_first;
6632
6633         if (kid->op_type == OP_NULL)
6634             kid = kid->op_sibling;
6635         if (kid)
6636             kid->op_flags |= OPf_MOD;
6637
6638     }
6639     return o;
6640 }
6641
6642 /* A peephole optimizer.  We visit the ops in the order they're to execute. */
6643
6644 void
6645 Perl_peep(pTHX_ register OP *o)
6646 {
6647     register OP* oldop = 0;
6648     STRLEN n_a;
6649
6650     if (!o || o->op_seq)
6651         return;
6652     ENTER;
6653     SAVEOP();
6654     SAVEVPTR(PL_curcop);
6655     for (; o; o = o->op_next) {
6656         if (o->op_seq)
6657             break;
6658         if (!PL_op_seqmax)
6659             PL_op_seqmax++;
6660         PL_op = o;
6661         switch (o->op_type) {
6662         case OP_SETSTATE:
6663         case OP_NEXTSTATE:
6664         case OP_DBSTATE:
6665             PL_curcop = ((COP*)o);              /* for warnings */
6666             o->op_seq = PL_op_seqmax++;
6667             break;
6668
6669         case OP_CONST:
6670             if (cSVOPo->op_private & OPpCONST_STRICT)
6671                 no_bareword_allowed(o);
6672 #ifdef USE_ITHREADS
6673             /* Relocate sv to the pad for thread safety.
6674              * Despite being a "constant", the SV is written to,
6675              * for reference counts, sv_upgrade() etc. */
6676             if (cSVOP->op_sv) {
6677                 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6678                 if (SvPADTMP(cSVOPo->op_sv)) {
6679                     /* If op_sv is already a PADTMP then it is being used by
6680                      * some pad, so make a copy. */
6681                     sv_setsv(PL_curpad[ix],cSVOPo->op_sv);
6682                     SvREADONLY_on(PL_curpad[ix]);
6683                     SvREFCNT_dec(cSVOPo->op_sv);
6684                 }
6685                 else {
6686                     SvREFCNT_dec(PL_curpad[ix]);
6687                     SvPADTMP_on(cSVOPo->op_sv);
6688                     PL_curpad[ix] = cSVOPo->op_sv;
6689                     /* XXX I don't know how this isn't readonly already. */
6690                     SvREADONLY_on(PL_curpad[ix]);
6691                 }
6692                 cSVOPo->op_sv = Nullsv;
6693                 o->op_targ = ix;
6694             }
6695 #endif
6696             o->op_seq = PL_op_seqmax++;
6697             break;
6698
6699         case OP_CONCAT:
6700             if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6701                 if (o->op_next->op_private & OPpTARGET_MY) {
6702                     if (o->op_flags & OPf_STACKED) /* chained concats */
6703                         goto ignore_optimization;
6704                     else {
6705                         /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6706                         o->op_targ = o->op_next->op_targ;
6707                         o->op_next->op_targ = 0;
6708                         o->op_private |= OPpTARGET_MY;
6709                     }
6710                 }
6711                 null(o->op_next);
6712             }
6713           ignore_optimization:
6714             o->op_seq = PL_op_seqmax++;
6715             break;
6716         case OP_STUB:
6717             if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6718                 o->op_seq = PL_op_seqmax++;
6719                 break; /* Scalar stub must produce undef.  List stub is noop */
6720             }
6721             goto nothin;
6722         case OP_NULL:
6723             if (o->op_targ == OP_NEXTSTATE
6724                 || o->op_targ == OP_DBSTATE
6725                 || o->op_targ == OP_SETSTATE)
6726             {
6727                 PL_curcop = ((COP*)o);
6728             }
6729             goto nothin;
6730         case OP_SCALAR:
6731         case OP_LINESEQ:
6732         case OP_SCOPE:
6733           nothin:
6734             if (oldop && o->op_next) {
6735                 oldop->op_next = o->op_next;
6736                 continue;
6737             }
6738             o->op_seq = PL_op_seqmax++;
6739             break;
6740
6741         case OP_GV:
6742             if (o->op_next->op_type == OP_RV2SV) {
6743                 if (!(o->op_next->op_private & OPpDEREF)) {
6744                     null(o->op_next);
6745                     o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6746                                                                | OPpOUR_INTRO);
6747                     o->op_next = o->op_next->op_next;
6748                     o->op_type = OP_GVSV;
6749                     o->op_ppaddr = PL_ppaddr[OP_GVSV];
6750                 }
6751             }
6752             else if (o->op_next->op_type == OP_RV2AV) {
6753                 OP* pop = o->op_next->op_next;
6754                 IV i;
6755                 if (pop->op_type == OP_CONST &&
6756                     (PL_op = pop->op_next) &&
6757                     pop->op_next->op_type == OP_AELEM &&
6758                     !(pop->op_next->op_private &
6759                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6760                     (i = SvIV(((SVOP*)pop)->op_sv) - PL_compiling.cop_arybase)
6761                                 <= 255 &&
6762                     i >= 0)
6763                 {
6764                     GV *gv;
6765                     null(o->op_next);
6766                     null(pop->op_next);
6767                     null(pop);
6768                     o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6769                     o->op_next = pop->op_next->op_next;
6770                     o->op_type = OP_AELEMFAST;
6771                     o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6772                     o->op_private = (U8)i;
6773                     gv = cGVOPo_gv;
6774                     GvAVn(gv);
6775                 }
6776             }
6777             else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6778                 GV *gv = cGVOPo_gv;
6779                 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6780                     /* XXX could check prototype here instead of just carping */
6781                     SV *sv = sv_newmortal();
6782                     gv_efullname3(sv, gv, Nullch);
6783                     Perl_warner(aTHX_ WARN_PROTOTYPE,
6784                                 "%s() called too early to check prototype",
6785                                 SvPV_nolen(sv));
6786                 }
6787             }
6788
6789             o->op_seq = PL_op_seqmax++;
6790             break;
6791
6792         case OP_MAPWHILE:
6793         case OP_GREPWHILE:
6794         case OP_AND:
6795         case OP_OR:
6796         case OP_ANDASSIGN:
6797         case OP_ORASSIGN:
6798         case OP_COND_EXPR:
6799         case OP_RANGE:
6800             o->op_seq = PL_op_seqmax++;
6801             while (cLOGOP->op_other->op_type == OP_NULL)
6802                 cLOGOP->op_other = cLOGOP->op_other->op_next;
6803             peep(cLOGOP->op_other);
6804             break;
6805
6806         case OP_ENTERLOOP:
6807             o->op_seq = PL_op_seqmax++;
6808             while (cLOOP->op_redoop->op_type == OP_NULL)
6809                 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6810             peep(cLOOP->op_redoop);
6811             while (cLOOP->op_nextop->op_type == OP_NULL)
6812                 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6813             peep(cLOOP->op_nextop);
6814             while (cLOOP->op_lastop->op_type == OP_NULL)
6815                 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6816             peep(cLOOP->op_lastop);
6817             break;
6818
6819         case OP_QR:
6820         case OP_MATCH:
6821         case OP_SUBST:
6822             o->op_seq = PL_op_seqmax++;
6823             while (cPMOP->op_pmreplstart &&
6824                    cPMOP->op_pmreplstart->op_type == OP_NULL)
6825                 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6826             peep(cPMOP->op_pmreplstart);
6827             break;
6828
6829         case OP_EXEC:
6830             o->op_seq = PL_op_seqmax++;
6831             if (ckWARN(WARN_SYNTAX) && o->op_next
6832                 && o->op_next->op_type == OP_NEXTSTATE) {
6833                 if (o->op_next->op_sibling &&
6834                         o->op_next->op_sibling->op_type != OP_EXIT &&
6835                         o->op_next->op_sibling->op_type != OP_WARN &&
6836                         o->op_next->op_sibling->op_type != OP_DIE) {
6837                     line_t oldline = CopLINE(PL_curcop);
6838
6839                     CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6840                     Perl_warner(aTHX_ WARN_EXEC,
6841                                 "Statement unlikely to be reached");
6842                     Perl_warner(aTHX_ WARN_EXEC,
6843                                 "\t(Maybe you meant system() when you said exec()?)\n");
6844                     CopLINE_set(PL_curcop, oldline);
6845                 }
6846             }
6847             break;
6848
6849         case OP_HELEM: {
6850             UNOP *rop;
6851             SV *lexname;
6852             GV **fields;
6853             SV **svp, **indsvp, *sv;
6854             I32 ind;
6855             char *key = NULL;
6856             STRLEN keylen;
6857
6858             o->op_seq = PL_op_seqmax++;
6859
6860             if (((BINOP*)o)->op_last->op_type != OP_CONST)
6861                 break;
6862
6863             /* Make the CONST have a shared SV */
6864             svp = cSVOPx_svp(((BINOP*)o)->op_last);
6865             if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6866                 key = SvPV(sv, keylen);
6867                 if (SvUTF8(sv))
6868                   keylen = -keylen;
6869                 lexname = newSVpvn_share(key, keylen, 0);
6870                 SvREFCNT_dec(sv);
6871                 *svp = lexname;
6872             }
6873
6874             if ((o->op_private & (OPpLVAL_INTRO)))
6875                 break;
6876
6877             rop = (UNOP*)((BINOP*)o)->op_first;
6878             if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6879                 break;
6880             lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6881             if (!SvOBJECT(lexname))
6882                 break;
6883             fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6884             if (!fields || !GvHV(*fields))
6885                 break;
6886             key = SvPV(*svp, keylen);
6887             if (SvUTF8(*svp))
6888                 keylen = -keylen;
6889             indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE);
6890             if (!indsvp) {
6891                 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s",
6892                       key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
6893             }
6894             ind = SvIV(*indsvp);
6895             if (ind < 1)
6896                 Perl_croak(aTHX_ "Bad index while coercing array into hash");
6897             rop->op_type = OP_RV2AV;
6898             rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
6899             o->op_type = OP_AELEM;
6900             o->op_ppaddr = PL_ppaddr[OP_AELEM];
6901             sv = newSViv(ind);
6902             if (SvREADONLY(*svp))
6903                 SvREADONLY_on(sv);
6904             SvFLAGS(sv) |= (SvFLAGS(*svp)
6905                             & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
6906             SvREFCNT_dec(*svp);
6907             *svp = sv;
6908             break;
6909         }
6910
6911         case OP_HSLICE: {
6912             UNOP *rop;
6913             SV *lexname;
6914             GV **fields;
6915             SV **svp, **indsvp, *sv;
6916             I32 ind;
6917             char *key;
6918             STRLEN keylen;
6919             SVOP *first_key_op, *key_op;
6920
6921             o->op_seq = PL_op_seqmax++;
6922             if ((o->op_private & (OPpLVAL_INTRO))
6923                 /* I bet there's always a pushmark... */
6924                 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
6925                 /* hmmm, no optimization if list contains only one key. */
6926                 break;
6927             rop = (UNOP*)((LISTOP*)o)->op_last;
6928             if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6929                 break;
6930             lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6931             if (!SvOBJECT(lexname))
6932                 break;
6933             fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6934             if (!fields || !GvHV(*fields))
6935                 break;
6936             /* Again guessing that the pushmark can be jumped over.... */
6937             first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
6938                 ->op_first->op_sibling;
6939             /* Check that the key list contains only constants. */
6940             for (key_op = first_key_op; key_op;
6941                  key_op = (SVOP*)key_op->op_sibling)
6942                 if (key_op->op_type != OP_CONST)
6943                     break;
6944             if (key_op)
6945                 break;
6946             rop->op_type = OP_RV2AV;
6947             rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
6948             o->op_type = OP_ASLICE;
6949             o->op_ppaddr = PL_ppaddr[OP_ASLICE];
6950             for (key_op = first_key_op; key_op;
6951                  key_op = (SVOP*)key_op->op_sibling) {
6952                 svp = cSVOPx_svp(key_op);
6953                 key = SvPV(*svp, keylen);
6954                 if (SvUTF8(*svp))
6955                     keylen = -keylen;
6956                 indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE);
6957                 if (!indsvp) {
6958                     Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
6959                                "in variable %s of type %s",
6960                           key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
6961                 }
6962                 ind = SvIV(*indsvp);
6963                 if (ind < 1)
6964                     Perl_croak(aTHX_ "Bad index while coercing array into hash");
6965                 sv = newSViv(ind);
6966                 if (SvREADONLY(*svp))
6967                     SvREADONLY_on(sv);
6968                 SvFLAGS(sv) |= (SvFLAGS(*svp)
6969                                 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
6970                 SvREFCNT_dec(*svp);
6971                 *svp = sv;
6972             }
6973             break;
6974         }
6975
6976         default:
6977             o->op_seq = PL_op_seqmax++;
6978             break;
6979         }
6980         oldop = o;
6981     }
6982     LEAVE;
6983 }
6984
6985 #include "XSUB.h"
6986
6987 /* Efficient sub that returns a constant scalar value. */
6988 static void
6989 const_sv_xsub(pTHXo_ CV* cv)
6990 {
6991     dXSARGS;
6992     if (items != 0) {
6993 #if 0
6994         Perl_croak(aTHX_ "usage: %s::%s()",
6995                    HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
6996 #endif
6997     }
6998     EXTEND(sp, 1);
6999     ST(0) = (SV*)XSANY.any_ptr;
7000     XSRETURN(1);
7001 }