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