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