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