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