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