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