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