op.c

   1 /*    op.c
   2  *
   3  *    Copyright (c) 1991-2001, Larry Wall
   4  *
   5  *    You may distribute under the terms of either the GNU General Public
   6  *    License or the Artistic License, as specified in the README file.
   7  *
   8  */
   9
  10 /*
  11  * "You see: Mr. Drogo, he married poor Miss Primula Brandybuck.  She was
  12  * our Mr. Bilbo's first cousin on the mother's side (her mother being the
  13  * youngest of the Old Took's daughters); and Mr. Drogo was his second
  14  * cousin.  So Mr. Frodo is his first *and* second cousin, once removed
  15  * either way, as the saying is, if you follow me."  --the Gaffer
  16  */
  17
  18 #include "EXTERN.h"
  19 #define PERL_IN_OP_C
  20 #include "perl.h"
  21 #include "keywords.h"
  22
  23 /* #define PL_OP_SLAB_ALLOC */
  24
  25 #ifdef PL_OP_SLAB_ALLOC
  26 #define SLAB_SIZE 8192
  27 static char    *PL_OpPtr  = NULL;
  28 static int     PL_OpSpace = 0;
  29 #define NewOp(m,var,c,type) do { if ((PL_OpSpace -= c*sizeof(type)) >= 0)     \
  30                               var =  (type *)(PL_OpPtr -= c*sizeof(type));    \
  31                              else                                             \
  32                               var = (type *) Slab_Alloc(m,c*sizeof(type));    \
  33                            } while (0)
  34
  35 STATIC void *
  36 S_Slab_Alloc(pTHX_ int m, size_t sz)
  37 {
  38  Newz(m,PL_OpPtr,SLAB_SIZE,char);
  39  PL_OpSpace = SLAB_SIZE - sz;
  40  return PL_OpPtr += PL_OpSpace;
  41 }
  42
  43 #else
  44 #define NewOp(m, var, c, type) Newz(m, var, c, type)
  45 #endif
  46 /*
  47  * In the following definition, the ", Nullop" is just to make the compiler
  48  * think the expression is of the right type: croak actually does a Siglongjmp.
  49  */
  50 #define CHECKOP(type,o) \
  51     ((PL_op_mask && PL_op_mask[type])                                   \
  52      ? ( op_free((OP*)o),                                       \
  53          Perl_croak(aTHX_ "%s trapped by operation mask", PL_op_desc[type]),    \
  54          Nullop )                                               \
  55      : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
  56
  57 #define PAD_MAX 999999999
  58 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
  59
  60 STATIC char*
  61 S_gv_ename(pTHX_ GV *gv)
  62 {
  63     STRLEN n_a;
  64     SV* tmpsv = sv_newmortal();
  65     gv_efullname3(tmpsv, gv, Nullch);
  66     return SvPV(tmpsv,n_a);
  67 }
  68
  69 STATIC OP *
  70 S_no_fh_allowed(pTHX_ OP *o)
  71 {
  72     yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
  73                  PL_op_desc[o->op_type]));
  74     return o;
  75 }
  76
  77 STATIC OP *
  78 S_too_few_arguments(pTHX_ OP *o, char *name)
  79 {
  80     yyerror(Perl_form(aTHX_ "Not enough arguments for %s", name));
  81     return o;
  82 }
  83
  84 STATIC OP *
  85 S_too_many_arguments(pTHX_ OP *o, char *name)
  86 {
  87     yyerror(Perl_form(aTHX_ "Too many arguments for %s", name));
  88     return o;
  89 }
  90
  91 STATIC void
  92 S_bad_type(pTHX_ I32 n, char *t, char *name, OP *kid)
  93 {
  94     yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
  95                  (int)n, name, t, PL_op_desc[kid->op_type]));
  96 }
  97
  98 STATIC void
  99 S_no_bareword_allowed(pTHX_ OP *o)
 100 {
 101     qerror(Perl_mess(aTHX_
 102                      "Bareword \"%s\" not allowed while \"strict subs\" in use",
 103                      SvPV_nolen(cSVOPo_sv)));
 104 }
 105
 106 STATIC U8*
 107 S_trlist_upgrade(pTHX_ U8** sp, U8** ep)
 108 {
 109     U8 *s = *sp;
 110     U8 *e = *ep;
 111     U8 *d;
 112
 113     Newz(801, d, (e - s) * 2, U8);
 114     *sp = d;
 115
 116     while (s < e) {
 117         if (*s < 0x80 || *s == 0xff)
 118             *d++ = *s++;
 119         else {
 120             U8 c = *s++;
 121             *d++ = ((c >> 6)         | 0xc0);
 122             *d++ = ((c       & 0x3f) | 0x80);
 123         }
 124     }
 125     *ep = d;
 126     return *sp;
 127 }
 128
 129
 130 /* "register" allocation */
 131
 132 PADOFFSET
 133 Perl_pad_allocmy(pTHX_ char *name)
 134 {
 135     PADOFFSET off;
 136     SV *sv;
 137
 138     if (!(PL_in_my == KEY_our ||
 139           isALPHA(name[1]) ||
 140           (PL_hints & HINT_UTF8 && UTF8_IS_START(name[1])) ||
 141           (name[1] == '_' && (int)strlen(name) > 2)))
 142     {
 143         if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
 144             /* 1999-02-27 mjd@plover.com */
 145             char *p;
 146             p = strchr(name, '\0');
 147             /* The next block assumes the buffer is at least 205 chars
 148                long.  At present, it's always at least 256 chars. */
 149             if (p-name > 200) {
 150                 strcpy(name+200, "...");
 151                 p = name+199;
 152             }
 153             else {
 154                 p[1] = '\0';
 155             }
 156             /* Move everything else down one character */
 157             for (; p-name > 2; p--)
 158                 *p = *(p-1);
 159             name[2] = toCTRL(name[1]);
 160             name[1] = '^';
 161         }
 162         yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
 163     }
 164     if (ckWARN(WARN_MISC) && AvFILLp(PL_comppad_name) >= 0) {
 165         SV **svp = AvARRAY(PL_comppad_name);
 166         HV *ourstash = (PL_curstash ? PL_curstash : PL_defstash);
 167         PADOFFSET top = AvFILLp(PL_comppad_name);
 168         for (off = top; off > PL_comppad_name_floor; off--) {
 169             if ((sv = svp[off])
 170                 && sv != &PL_sv_undef
 171                 && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0)
 172                 && (PL_in_my != KEY_our
 173                     || ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash))
 174                 && strEQ(name, SvPVX(sv)))
 175             {
 176                 Perl_warner(aTHX_ WARN_MISC,
 177                     "\"%s\" variable %s masks earlier declaration in same %s",
 178                     (PL_in_my == KEY_our ? "our" : "my"),
 179                     name,
 180                     (SvIVX(sv) == PAD_MAX ? "scope" : "statement"));
 181                 --off;
 182                 break;
 183             }
 184         }
 185         if (PL_in_my == KEY_our) {
 186             do {
 187                 if ((sv = svp[off])
 188                     && sv != &PL_sv_undef
 189                     && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0)
 190                     && ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash)
 191                     && strEQ(name, SvPVX(sv)))
 192                 {
 193                     Perl_warner(aTHX_ WARN_MISC,
 194                         "\"our\" variable %s redeclared", name);
 195                     Perl_warner(aTHX_ WARN_MISC,
 196                         "\t(Did you mean \"local\" instead of \"our\"?)\n");
 197                     break;
 198                 }
 199             } while ( off-- > 0 );
 200         }
 201     }
 202     off = pad_alloc(OP_PADSV, SVs_PADMY);
 203     sv = NEWSV(1102,0);
 204     sv_upgrade(sv, SVt_PVNV);
 205     sv_setpv(sv, name);
 206     if (PL_in_my_stash) {
 207         if (*name != '$')
 208             yyerror(Perl_form(aTHX_ "Can't declare class for non-scalar %s in \"%s\"",
 209                          name, PL_in_my == KEY_our ? "our" : "my"));
 210         SvOBJECT_on(sv);
 211         (void)SvUPGRADE(sv, SVt_PVMG);
 212         SvSTASH(sv) = (HV*)SvREFCNT_inc(PL_in_my_stash);
 213         PL_sv_objcount++;
 214     }
 215     if (PL_in_my == KEY_our) {
 216         (void)SvUPGRADE(sv, SVt_PVGV);
 217         GvSTASH(sv) = (HV*)SvREFCNT_inc(PL_curstash ? (SV*)PL_curstash : (SV*)PL_defstash);
 218         SvFLAGS(sv) |= SVpad_OUR;
 219     }
 220     av_store(PL_comppad_name, off, sv);
 221     SvNVX(sv) = (NV)PAD_MAX;
 222     SvIVX(sv) = 0;                      /* Not yet introduced--see newSTATEOP */
 223     if (!PL_min_intro_pending)
 224         PL_min_intro_pending = off;
 225     PL_max_intro_pending = off;
 226     if (*name == '@')
 227         av_store(PL_comppad, off, (SV*)newAV());
 228     else if (*name == '%')
 229         av_store(PL_comppad, off, (SV*)newHV());
 230     SvPADMY_on(PL_curpad[off]);
 231     return off;
 232 }
 233
 234 STATIC PADOFFSET
 235 S_pad_addlex(pTHX_ SV *proto_namesv)
 236 {
 237     SV *namesv = NEWSV(1103,0);
 238     PADOFFSET newoff = pad_alloc(OP_PADSV, SVs_PADMY);
 239     sv_upgrade(namesv, SVt_PVNV);
 240     sv_setpv(namesv, SvPVX(proto_namesv));
 241     av_store(PL_comppad_name, newoff, namesv);
 242     SvNVX(namesv) = (NV)PL_curcop->cop_seq;
 243     SvIVX(namesv) = PAD_MAX;                    /* A ref, intro immediately */
 244     SvFAKE_on(namesv);                          /* A ref, not a real var */
 245     if (SvFLAGS(proto_namesv) & SVpad_OUR) {    /* An "our" variable */
 246         SvFLAGS(namesv) |= SVpad_OUR;
 247         (void)SvUPGRADE(namesv, SVt_PVGV);
 248         GvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*)GvSTASH(proto_namesv));
 249     }
 250     if (SvOBJECT(proto_namesv)) {               /* A typed var */
 251         SvOBJECT_on(namesv);
 252         (void)SvUPGRADE(namesv, SVt_PVMG);
 253         SvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*)SvSTASH(proto_namesv));
 254         PL_sv_objcount++;
 255     }
 256     return newoff;
 257 }
 258
 259 #define FINDLEX_NOSEARCH        1               /* don't search outer contexts */
 260
 261 STATIC PADOFFSET
 262 S_pad_findlex(pTHX_ char *name, PADOFFSET newoff, U32 seq, CV* startcv,
 263             I32 cx_ix, I32 saweval, U32 flags)
 264 {
 265     CV *cv;
 266     I32 off;
 267     SV *sv;
 268     register I32 i;
 269     register PERL_CONTEXT *cx;
 270
 271     for (cv = startcv; cv; cv = CvOUTSIDE(cv)) {
 272         AV *curlist = CvPADLIST(cv);
 273         SV **svp = av_fetch(curlist, 0, FALSE);
 274         AV *curname;
 275
 276         if (!svp || *svp == &PL_sv_undef)
 277             continue;
 278         curname = (AV*)*svp;
 279         svp = AvARRAY(curname);
 280         for (off = AvFILLp(curname); off > 0; off--) {
 281             if ((sv = svp[off]) &&
 282                 sv != &PL_sv_undef &&
 283                 seq <= SvIVX(sv) &&
 284                 seq > I_32(SvNVX(sv)) &&
 285                 strEQ(SvPVX(sv), name))
 286             {
 287                 I32 depth;
 288                 AV *oldpad;
 289                 SV *oldsv;
 290
 291                 depth = CvDEPTH(cv);
 292                 if (!depth) {
 293                     if (newoff) {
 294                         if (SvFAKE(sv))
 295                             continue;
 296                         return 0; /* don't clone from inactive stack frame */
 297                     }
 298                     depth = 1;
 299                 }
 300                 oldpad = (AV*)AvARRAY(curlist)[depth];
 301                 oldsv = *av_fetch(oldpad, off, TRUE);
 302                 if (!newoff) {          /* Not a mere clone operation. */
 303                     newoff = pad_addlex(sv);
 304                     if (CvANON(PL_compcv) || SvTYPE(PL_compcv) == SVt_PVFM) {
 305                         /* "It's closures all the way down." */
 306                         CvCLONE_on(PL_compcv);
 307                         if (cv == startcv) {
 308                             if (CvANON(PL_compcv))
 309                                 oldsv = Nullsv; /* no need to keep ref */
 310                         }
 311                         else {
 312                             CV *bcv;
 313                             for (bcv = startcv;
 314                                  bcv && bcv != cv && !CvCLONE(bcv);
 315                                  bcv = CvOUTSIDE(bcv))
 316                             {
 317                                 if (CvANON(bcv)) {
 318                                     /* install the missing pad entry in intervening
 319                                      * nested subs and mark them cloneable.
 320                                      * XXX fix pad_foo() to not use globals */
 321                                     AV *ocomppad_name = PL_comppad_name;
 322                                     AV *ocomppad = PL_comppad;
 323                                     SV **ocurpad = PL_curpad;
 324                                     AV *padlist = CvPADLIST(bcv);
 325                                     PL_comppad_name = (AV*)AvARRAY(padlist)[0];
 326                                     PL_comppad = (AV*)AvARRAY(padlist)[1];
 327                                     PL_curpad = AvARRAY(PL_comppad);
 328                                     pad_addlex(sv);
 329                                     PL_comppad_name = ocomppad_name;
 330                                     PL_comppad = ocomppad;
 331                                     PL_curpad = ocurpad;
 332                                     CvCLONE_on(bcv);
 333                                 }
 334                                 else {
 335                                     if (ckWARN(WARN_CLOSURE)
 336                                         && !CvUNIQUE(bcv) && !CvUNIQUE(cv))
 337                                     {
 338                                         Perl_warner(aTHX_ WARN_CLOSURE,
 339                                           "Variable \"%s\" may be unavailable",
 340                                              name);
 341                                     }
 342                                     break;
 343                                 }
 344                             }
 345                         }
 346                     }
 347                     else if (!CvUNIQUE(PL_compcv)) {
 348                         if (ckWARN(WARN_CLOSURE) && !SvFAKE(sv) && !CvUNIQUE(cv)
 349                             && !(SvFLAGS(sv) & SVpad_OUR))
 350                         {
 351                             Perl_warner(aTHX_ WARN_CLOSURE,
 352                                 "Variable \"%s\" will not stay shared", name);
 353                         }
 354                     }
 355                 }
 356                 av_store(PL_comppad, newoff, SvREFCNT_inc(oldsv));
 357                 return newoff;
 358             }
 359         }
 360     }
 361
 362     if (flags & FINDLEX_NOSEARCH)
 363         return 0;
 364
 365     /* Nothing in current lexical context--try eval's context, if any.
 366      * This is necessary to let the perldb get at lexically scoped variables.
 367      * XXX This will also probably interact badly with eval tree caching.
 368      */
 369
 370     for (i = cx_ix; i >= 0; i--) {
 371         cx = &cxstack[i];
 372         switch (CxTYPE(cx)) {
 373         default:
 374             if (i == 0 && saweval) {
 375                 seq = cxstack[saweval].blk_oldcop->cop_seq;
 376                 return pad_findlex(name, newoff, seq, PL_main_cv, -1, saweval, 0);
 377             }
 378             break;
 379         case CXt_EVAL:
 380             switch (cx->blk_eval.old_op_type) {
 381             case OP_ENTEREVAL:
 382                 if (CxREALEVAL(cx))
 383                     saweval = i;
 384                 break;
 385             case OP_DOFILE:
 386             case OP_REQUIRE:
 387                 /* require/do must have their own scope */
 388                 return 0;
 389             }
 390             break;
 391         case CXt_FORMAT:
 392         case CXt_SUB:
 393             if (!saweval)
 394                 return 0;
 395             cv = cx->blk_sub.cv;
 396             if (PL_debstash && CvSTASH(cv) == PL_debstash) {    /* ignore DB'* scope */
 397                 saweval = i;    /* so we know where we were called from */
 398                 continue;
 399             }
 400             seq = cxstack[saweval].blk_oldcop->cop_seq;
 401             return pad_findlex(name, newoff, seq, cv, i-1, saweval,FINDLEX_NOSEARCH);
 402         }
 403     }
 404
 405     return 0;
 406 }
 407
 408 PADOFFSET
 409 Perl_pad_findmy(pTHX_ char *name)
 410 {
 411     I32 off;
 412     I32 pendoff = 0;
 413     SV *sv;
 414     SV **svp = AvARRAY(PL_comppad_name);
 415     U32 seq = PL_cop_seqmax;
 416     PERL_CONTEXT *cx;
 417     CV *outside;
 418
 419 #ifdef USE_THREADS
 420     /*
 421      * Special case to get lexical (and hence per-thread) @_.
 422      * XXX I need to find out how to tell at parse-time whether use
 423      * of @_ should refer to a lexical (from a sub) or defgv (global
 424      * scope and maybe weird sub-ish things like formats). See
 425      * startsub in perly.y.  It's possible that @_ could be lexical
 426      * (at least from subs) even in non-threaded perl.
 427      */
 428     if (strEQ(name, "@_"))
 429         return 0;               /* success. (NOT_IN_PAD indicates failure) */
 430 #endif /* USE_THREADS */
 431
 432     /* The one we're looking for is probably just before comppad_name_fill. */
 433     for (off = AvFILLp(PL_comppad_name); off > 0; off--) {
 434         if ((sv = svp[off]) &&
 435             sv != &PL_sv_undef &&
 436             (!SvIVX(sv) ||
 437              (seq <= SvIVX(sv) &&
 438               seq > I_32(SvNVX(sv)))) &&
 439             strEQ(SvPVX(sv), name))
 440         {
 441             if (SvIVX(sv) || SvFLAGS(sv) & SVpad_OUR)
 442                 return (PADOFFSET)off;
 443             pendoff = off;      /* this pending def. will override import */
 444         }
 445     }
 446
 447     outside = CvOUTSIDE(PL_compcv);
 448
 449     /* Check if if we're compiling an eval'', and adjust seq to be the
 450      * eval's seq number.  This depends on eval'' having a non-null
 451      * CvOUTSIDE() while it is being compiled.  The eval'' itself is
 452      * identified by CvEVAL being true and CvGV being null. */
 453     if (outside && CvEVAL(PL_compcv) && !CvGV(PL_compcv) && cxstack_ix >= 0) {
 454         cx = &cxstack[cxstack_ix];
 455         if (CxREALEVAL(cx))
 456             seq = cx->blk_oldcop->cop_seq;
 457     }
 458
 459     /* See if it's in a nested scope */
 460     off = pad_findlex(name, 0, seq, outside, cxstack_ix, 0, 0);
 461     if (off) {
 462         /* If there is a pending local definition, this new alias must die */
 463         if (pendoff)
 464             SvIVX(AvARRAY(PL_comppad_name)[off]) = seq;
 465         return off;             /* pad_findlex returns 0 for failure...*/
 466     }
 467     return NOT_IN_PAD;          /* ...but we return NOT_IN_PAD for failure */
 468 }
 469
 470 void
 471 Perl_pad_leavemy(pTHX_ I32 fill)
 472 {
 473     I32 off;
 474     SV **svp = AvARRAY(PL_comppad_name);
 475     SV *sv;
 476     if (PL_min_intro_pending && fill < PL_min_intro_pending) {
 477         for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
 478             if ((sv = svp[off]) && sv != &PL_sv_undef && ckWARN_d(WARN_INTERNAL))
 479                 Perl_warner(aTHX_ WARN_INTERNAL, "%s never introduced", SvPVX(sv));
 480         }
 481     }
 482     /* "Deintroduce" my variables that are leaving with this scope. */
 483     for (off = AvFILLp(PL_comppad_name); off > fill; off--) {
 484         if ((sv = svp[off]) && sv != &PL_sv_undef && SvIVX(sv) == PAD_MAX)
 485             SvIVX(sv) = PL_cop_seqmax;
 486     }
 487 }
 488
 489 PADOFFSET
 490 Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype)
 491 {
 492     SV *sv;
 493     I32 retval;
 494
 495     if (AvARRAY(PL_comppad) != PL_curpad)
 496         Perl_croak(aTHX_ "panic: pad_alloc");
 497     if (PL_pad_reset_pending)
 498         pad_reset();
 499     if (tmptype & SVs_PADMY) {
 500         do {
 501             sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE);
 502         } while (SvPADBUSY(sv));                /* need a fresh one */
 503         retval = AvFILLp(PL_comppad);
 504     }
 505     else {
 506         SV **names = AvARRAY(PL_comppad_name);
 507         SSize_t names_fill = AvFILLp(PL_comppad_name);
 508         for (;;) {
 509             /*
 510              * "foreach" index vars temporarily become aliases to non-"my"
 511              * values.  Thus we must skip, not just pad values that are
 512              * marked as current pad values, but also those with names.
 513              */
 514             if (++PL_padix <= names_fill &&
 515                    (sv = names[PL_padix]) && sv != &PL_sv_undef)
 516                 continue;
 517             sv = *av_fetch(PL_comppad, PL_padix, TRUE);
 518             if (!(SvFLAGS(sv) & (SVs_PADTMP|SVs_PADMY)) &&
 519                 !IS_PADGV(sv) && !IS_PADCONST(sv))
 520                 break;
 521         }
 522         retval = PL_padix;
 523     }
 524     SvFLAGS(sv) |= tmptype;
 525     PL_curpad = AvARRAY(PL_comppad);
 526 #ifdef USE_THREADS
 527     DEBUG_X(PerlIO_printf(Perl_debug_log,
 528                           "0x%"UVxf" Pad 0x%"UVxf" alloc %ld for %s\n",
 529                           PTR2UV(thr), PTR2UV(PL_curpad),
 530                           (long) retval, PL_op_name[optype]));
 531 #else
 532     DEBUG_X(PerlIO_printf(Perl_debug_log,
 533                           "Pad 0x%"UVxf" alloc %ld for %s\n",
 534                           PTR2UV(PL_curpad),
 535                           (long) retval, PL_op_name[optype]));
 536 #endif /* USE_THREADS */
 537     return (PADOFFSET)retval;
 538 }
 539
 540 SV *
 541 Perl_pad_sv(pTHX_ PADOFFSET po)
 542 {
 543 #ifdef USE_THREADS
 544     DEBUG_X(PerlIO_printf(Perl_debug_log,
 545                           "0x%"UVxf" Pad 0x%"UVxf" sv %"IVdf"\n",
 546                           PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
 547 #else
 548     if (!po)
 549         Perl_croak(aTHX_ "panic: pad_sv po");
 550     DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" sv %"IVdf"\n",
 551                           PTR2UV(PL_curpad), (IV)po));
 552 #endif /* USE_THREADS */
 553     return PL_curpad[po];               /* eventually we'll turn this into a macro */
 554 }
 555
 556 void
 557 Perl_pad_free(pTHX_ PADOFFSET po)
 558 {
 559     if (!PL_curpad)
 560         return;
 561     if (AvARRAY(PL_comppad) != PL_curpad)
 562         Perl_croak(aTHX_ "panic: pad_free curpad");
 563     if (!po)
 564         Perl_croak(aTHX_ "panic: pad_free po");
 565 #ifdef USE_THREADS
 566     DEBUG_X(PerlIO_printf(Perl_debug_log,
 567                           "0x%"UVxf" Pad 0x%"UVxf" free %"IVdf"\n",
 568                           PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
 569 #else
 570     DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" free %"IVdf"\n",
 571                           PTR2UV(PL_curpad), (IV)po));
 572 #endif /* USE_THREADS */
 573     if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef) {
 574         SvPADTMP_off(PL_curpad[po]);
 575 #ifdef USE_ITHREADS
 576         SvREADONLY_off(PL_curpad[po]);  /* could be a freed constant */
 577 #endif
 578     }
 579     if ((I32)po < PL_padix)
 580         PL_padix = po - 1;
 581 }
 582
 583 void
 584 Perl_pad_swipe(pTHX_ PADOFFSET po)
 585 {
 586     if (AvARRAY(PL_comppad) != PL_curpad)
 587         Perl_croak(aTHX_ "panic: pad_swipe curpad");
 588     if (!po)
 589         Perl_croak(aTHX_ "panic: pad_swipe po");
 590 #ifdef USE_THREADS
 591     DEBUG_X(PerlIO_printf(Perl_debug_log,
 592                           "0x%"UVxf" Pad 0x%"UVxf" swipe %"IVdf"\n",
 593                           PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
 594 #else
 595     DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" swipe %"IVdf"\n",
 596                           PTR2UV(PL_curpad), (IV)po));
 597 #endif /* USE_THREADS */
 598     SvPADTMP_off(PL_curpad[po]);
 599     PL_curpad[po] = NEWSV(1107,0);
 600     SvPADTMP_on(PL_curpad[po]);
 601     if ((I32)po < PL_padix)
 602         PL_padix = po - 1;
 603 }
 604
 605 /* XXX pad_reset() is currently disabled because it results in serious bugs.
 606  * It causes pad temp TARGs to be shared between OPs. Since TARGs are pushed
 607  * on the stack by OPs that use them, there are several ways to get an alias
 608  * to  a shared TARG.  Such an alias will change randomly and unpredictably.
 609  * We avoid doing this until we can think of a Better Way.
 610  * GSAR 97-10-29 */
 611 void
 612 Perl_pad_reset(pTHX)
 613 {
 614 #ifdef USE_BROKEN_PAD_RESET
 615     register I32 po;
 616
 617     if (AvARRAY(PL_comppad) != PL_curpad)
 618         Perl_croak(aTHX_ "panic: pad_reset curpad");
 619 #ifdef USE_THREADS
 620     DEBUG_X(PerlIO_printf(Perl_debug_log,
 621                           "0x%"UVxf" Pad 0x%"UVxf" reset\n",
 622                           PTR2UV(thr), PTR2UV(PL_curpad)));
 623 #else
 624     DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" reset\n",
 625                           PTR2UV(PL_curpad)));
 626 #endif /* USE_THREADS */
 627     if (!PL_tainting) { /* Can't mix tainted and non-tainted temporaries. */
 628         for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) {
 629             if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po]))
 630                 SvPADTMP_off(PL_curpad[po]);
 631         }
 632         PL_padix = PL_padix_floor;
 633     }
 634 #endif
 635     PL_pad_reset_pending = FALSE;
 636 }
 637
 638 #ifdef USE_THREADS
 639 /* find_threadsv is not reentrant */
 640 PADOFFSET
 641 Perl_find_threadsv(pTHX_ const char *name)
 642 {
 643     char *p;
 644     PADOFFSET key;
 645     SV **svp;
 646     /* We currently only handle names of a single character */
 647     p = strchr(PL_threadsv_names, *name);
 648     if (!p)
 649         return NOT_IN_PAD;
 650     key = p - PL_threadsv_names;
 651     MUTEX_LOCK(&thr->mutex);
 652     svp = av_fetch(thr->threadsv, key, FALSE);
 653     if (svp)
 654         MUTEX_UNLOCK(&thr->mutex);
 655     else {
 656         SV *sv = NEWSV(0, 0);
 657         av_store(thr->threadsv, key, sv);
 658         thr->threadsvp = AvARRAY(thr->threadsv);
 659         MUTEX_UNLOCK(&thr->mutex);
 660         /*
 661          * Some magic variables used to be automagically initialised
 662          * in gv_fetchpv. Those which are now per-thread magicals get
 663          * initialised here instead.
 664          */
 665         switch (*name) {
 666         case '_':
 667             break;
 668         case ';':
 669             sv_setpv(sv, "\034");
 670             sv_magic(sv, 0, 0, name, 1);
 671             break;
 672         case '&':
 673         case '`':
 674         case '\'':
 675             PL_sawampersand = TRUE;
 676             /* FALL THROUGH */
 677         case '1':
 678         case '2':
 679         case '3':
 680         case '4':
 681         case '5':
 682         case '6':
 683         case '7':
 684         case '8':
 685         case '9':
 686             SvREADONLY_on(sv);
 687             /* FALL THROUGH */
 688
 689         /* XXX %! tied to Errno.pm needs to be added here.
 690          * See gv_fetchpv(). */
 691         /* case '!': */
 692
 693         default:
 694             sv_magic(sv, 0, 0, name, 1);
 695         }
 696         DEBUG_S(PerlIO_printf(Perl_error_log,
 697                               "find_threadsv: new SV %p for $%s%c\n",
 698                               sv, (*name < 32) ? "^" : "",
 699                               (*name < 32) ? toCTRL(*name) : *name));
 700     }
 701     return key;
 702 }
 703 #endif /* USE_THREADS */
 704
 705 /* Destructor */
 706
 707 void
 708 Perl_op_free(pTHX_ OP *o)
 709 {
 710     register OP *kid, *nextkid;
 711     OPCODE type;
 712
 713     if (!o || o->op_seq == (U16)-1)
 714         return;
 715
 716     if (o->op_private & OPpREFCOUNTED) {
 717         switch (o->op_type) {
 718         case OP_LEAVESUB:
 719         case OP_LEAVESUBLV:
 720         case OP_LEAVEEVAL:
 721         case OP_LEAVE:
 722         case OP_SCOPE:
 723         case OP_LEAVEWRITE:
 724             OP_REFCNT_LOCK;
 725             if (OpREFCNT_dec(o)) {
 726                 OP_REFCNT_UNLOCK;
 727                 return;
 728             }
 729             OP_REFCNT_UNLOCK;
 730             break;
 731         default:
 732             break;
 733         }
 734     }
 735
 736     if (o->op_flags & OPf_KIDS) {
 737         for (kid = cUNOPo->op_first; kid; kid = nextkid) {
 738             nextkid = kid->op_sibling; /* Get before next freeing kid */
 739             op_free(kid);
 740         }
 741     }
 742     type = o->op_type;
 743     if (type == OP_NULL)
 744         type = o->op_targ;
 745
 746     /* COP* is not cleared by op_clear() so that we may track line
 747      * numbers etc even after null() */
 748     if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
 749         cop_free((COP*)o);
 750
 751     op_clear(o);
 752
 753 #ifdef PL_OP_SLAB_ALLOC
 754     if ((char *) o == PL_OpPtr)
 755      {
 756      }
 757 #else
 758     Safefree(o);
 759 #endif
 760 }
 761
 762 STATIC void
 763 S_op_clear(pTHX_ OP *o)
 764 {
 765     switch (o->op_type) {
 766     case OP_NULL:       /* Was holding old type, if any. */
 767     case OP_ENTEREVAL:  /* Was holding hints. */
 768 #ifdef USE_THREADS
 769     case OP_THREADSV:   /* Was holding index into thr->threadsv AV. */
 770 #endif
 771         o->op_targ = 0;
 772         break;
 773 #ifdef USE_THREADS
 774     case OP_ENTERITER:
 775         if (!(o->op_flags & OPf_SPECIAL))
 776             break;
 777         /* FALL THROUGH */
 778 #endif /* USE_THREADS */
 779     default:
 780         if (!(o->op_flags & OPf_REF)
 781             || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
 782             break;
 783         /* FALL THROUGH */
 784     case OP_GVSV:
 785     case OP_GV:
 786     case OP_AELEMFAST:
 787 #ifdef USE_ITHREADS
 788         if (cPADOPo->op_padix > 0) {
 789             if (PL_curpad) {
 790                 GV *gv = cGVOPo_gv;
 791                 pad_swipe(cPADOPo->op_padix);
 792                 /* No GvIN_PAD_off(gv) here, because other references may still
 793                  * exist on the pad */
 794                 SvREFCNT_dec(gv);
 795             }
 796             cPADOPo->op_padix = 0;
 797         }
 798 #else
 799         SvREFCNT_dec(cSVOPo->op_sv);
 800         cSVOPo->op_sv = Nullsv;
 801 #endif
 802         break;
 803     case OP_METHOD_NAMED:
 804     case OP_CONST:
 805         SvREFCNT_dec(cSVOPo->op_sv);
 806         cSVOPo->op_sv = Nullsv;
 807         break;
 808     case OP_GOTO:
 809     case OP_NEXT:
 810     case OP_LAST:
 811     case OP_REDO:
 812         if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
 813             break;
 814         /* FALL THROUGH */
 815     case OP_TRANS:
 816         if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
 817             SvREFCNT_dec(cSVOPo->op_sv);
 818             cSVOPo->op_sv = Nullsv;
 819         }
 820         else {
 821             Safefree(cPVOPo->op_pv);
 822             cPVOPo->op_pv = Nullch;
 823         }
 824         break;
 825     case OP_SUBST:
 826         op_free(cPMOPo->op_pmreplroot);
 827         goto clear_pmop;
 828     case OP_PUSHRE:
 829 #ifdef USE_ITHREADS
 830         if ((PADOFFSET)cPMOPo->op_pmreplroot) {
 831             if (PL_curpad) {
 832                 GV *gv = (GV*)PL_curpad[(PADOFFSET)cPMOPo->op_pmreplroot];
 833                 pad_swipe((PADOFFSET)cPMOPo->op_pmreplroot);
 834                 /* No GvIN_PAD_off(gv) here, because other references may still
 835                  * exist on the pad */
 836                 SvREFCNT_dec(gv);
 837             }
 838         }
 839 #else
 840         SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
 841 #endif
 842         /* FALL THROUGH */
 843     case OP_MATCH:
 844     case OP_QR:
 845 clear_pmop:
 846         cPMOPo->op_pmreplroot = Nullop;
 847         ReREFCNT_dec(cPMOPo->op_pmregexp);
 848         cPMOPo->op_pmregexp = (REGEXP*)NULL;
 849         break;
 850     }
 851
 852     if (o->op_targ > 0) {
 853         pad_free(o->op_targ);
 854         o->op_targ = 0;
 855     }
 856 }
 857
 858 STATIC void
 859 S_cop_free(pTHX_ COP* cop)
 860 {
 861     Safefree(cop->cop_label);
 862 #ifdef USE_ITHREADS
 863     Safefree(CopFILE(cop));             /* XXX share in a pvtable? */
 864     Safefree(CopSTASHPV(cop));          /* XXX share in a pvtable? */
 865 #else
 866     /* NOTE: COP.cop_stash is not refcounted */
 867     SvREFCNT_dec(CopFILEGV(cop));
 868 #endif
 869     if (! specialWARN(cop->cop_warnings))
 870         SvREFCNT_dec(cop->cop_warnings);
 871     if (! specialCopIO(cop->cop_io))
 872         SvREFCNT_dec(cop->cop_io);
 873 }
 874
 875 STATIC void
 876 S_null(pTHX_ OP *o)
 877 {
 878     if (o->op_type == OP_NULL)
 879         return;
 880     op_clear(o);
 881     o->op_targ = o->op_type;
 882     o->op_type = OP_NULL;
 883     o->op_ppaddr = PL_ppaddr[OP_NULL];
 884 }
 885
 886 /* Contextualizers */
 887
 888 #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
 889
 890 OP *
 891 Perl_linklist(pTHX_ OP *o)
 892 {
 893     register OP *kid;
 894
 895     if (o->op_next)
 896         return o->op_next;
 897
 898     /* establish postfix order */
 899     if (cUNOPo->op_first) {
 900         o->op_next = LINKLIST(cUNOPo->op_first);
 901         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
 902             if (kid->op_sibling)
 903                 kid->op_next = LINKLIST(kid->op_sibling);
 904             else
 905                 kid->op_next = o;
 906         }
 907     }
 908     else
 909         o->op_next = o;
 910
 911     return o->op_next;
 912 }
 913
 914 OP *
 915 Perl_scalarkids(pTHX_ OP *o)
 916 {
 917     OP *kid;
 918     if (o && o->op_flags & OPf_KIDS) {
 919         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
 920             scalar(kid);
 921     }
 922     return o;
 923 }
 924
 925 STATIC OP *
 926 S_scalarboolean(pTHX_ OP *o)
 927 {
 928     if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
 929         if (ckWARN(WARN_SYNTAX)) {
 930             line_t oldline = CopLINE(PL_curcop);
 931
 932             if (PL_copline != NOLINE)
 933                 CopLINE_set(PL_curcop, PL_copline);
 934             Perl_warner(aTHX_ WARN_SYNTAX, "Found = in conditional, should be ==");
 935             CopLINE_set(PL_curcop, oldline);
 936         }
 937     }
 938     return scalar(o);
 939 }
 940
 941 OP *
 942 Perl_scalar(pTHX_ OP *o)
 943 {
 944     OP *kid;
 945
 946     /* assumes no premature commitment */
 947     if (!o || (o->op_flags & OPf_WANT) || PL_error_count
 948          || o->op_type == OP_RETURN)
 949     {
 950         return o;
 951     }
 952
 953     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
 954
 955     switch (o->op_type) {
 956     case OP_REPEAT:
 957         if (o->op_private & OPpREPEAT_DOLIST)
 958             null(((LISTOP*)cBINOPo->op_first)->op_first);
 959         scalar(cBINOPo->op_first);
 960         break;
 961     case OP_OR:
 962     case OP_AND:
 963     case OP_COND_EXPR:
 964         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
 965             scalar(kid);
 966         break;
 967     case OP_SPLIT:
 968         if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
 969             if (!kPMOP->op_pmreplroot)
 970                 deprecate("implicit split to @_");
 971         }
 972         /* FALL THROUGH */
 973     case OP_MATCH:
 974     case OP_QR:
 975     case OP_SUBST:
 976     case OP_NULL:
 977     default:
 978         if (o->op_flags & OPf_KIDS) {
 979             for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
 980                 scalar(kid);
 981         }
 982         break;
 983     case OP_LEAVE:
 984     case OP_LEAVETRY:
 985         kid = cLISTOPo->op_first;
 986         scalar(kid);
 987         while ((kid = kid->op_sibling)) {
 988             if (kid->op_sibling)
 989                 scalarvoid(kid);
 990             else
 991                 scalar(kid);
 992         }
 993         WITH_THR(PL_curcop = &PL_compiling);
 994         break;
 995     case OP_SCOPE:
 996     case OP_LINESEQ:
 997     case OP_LIST:
 998         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
 999             if (kid->op_sibling)
1000                 scalarvoid(kid);
1001             else
1002                 scalar(kid);
1003         }
1004         WITH_THR(PL_curcop = &PL_compiling);
1005         break;
1006     }
1007     return o;
1008 }
1009
1010 OP *
1011 Perl_scalarvoid(pTHX_ OP *o)
1012 {
1013     OP *kid;
1014     char* useless = 0;
1015     SV* sv;
1016     U8 want;
1017
1018     if (o->op_type == OP_NEXTSTATE
1019         || o->op_type == OP_SETSTATE
1020         || o->op_type == OP_DBSTATE
1021         || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
1022                                       || o->op_targ == OP_SETSTATE
1023                                       || o->op_targ == OP_DBSTATE)))
1024         PL_curcop = (COP*)o;            /* for warning below */
1025
1026     /* assumes no premature commitment */
1027     want = o->op_flags & OPf_WANT;
1028     if ((want && want != OPf_WANT_SCALAR) || PL_error_count
1029          || o->op_type == OP_RETURN)
1030     {
1031         return o;
1032     }
1033
1034     if ((o->op_private & OPpTARGET_MY)
1035         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1036     {
1037         return scalar(o);                       /* As if inside SASSIGN */
1038     }
1039
1040     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
1041
1042     switch (o->op_type) {
1043     default:
1044         if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
1045             break;
1046         /* FALL THROUGH */
1047     case OP_REPEAT:
1048         if (o->op_flags & OPf_STACKED)
1049             break;
1050         goto func_ops;
1051     case OP_SUBSTR:
1052         if (o->op_private == 4)
1053             break;
1054         /* FALL THROUGH */
1055     case OP_GVSV:
1056     case OP_WANTARRAY:
1057     case OP_GV:
1058     case OP_PADSV:
1059     case OP_PADAV:
1060     case OP_PADHV:
1061     case OP_PADANY:
1062     case OP_AV2ARYLEN:
1063     case OP_REF:
1064     case OP_REFGEN:
1065     case OP_SREFGEN:
1066     case OP_DEFINED:
1067     case OP_HEX:
1068     case OP_OCT:
1069     case OP_LENGTH:
1070     case OP_VEC:
1071     case OP_INDEX:
1072     case OP_RINDEX:
1073     case OP_SPRINTF:
1074     case OP_AELEM:
1075     case OP_AELEMFAST:
1076     case OP_ASLICE:
1077     case OP_HELEM:
1078     case OP_HSLICE:
1079     case OP_UNPACK:
1080     case OP_PACK:
1081     case OP_JOIN:
1082     case OP_LSLICE:
1083     case OP_ANONLIST:
1084     case OP_ANONHASH:
1085     case OP_SORT:
1086     case OP_REVERSE:
1087     case OP_RANGE:
1088     case OP_FLIP:
1089     case OP_FLOP:
1090     case OP_CALLER:
1091     case OP_FILENO:
1092     case OP_EOF:
1093     case OP_TELL:
1094     case OP_GETSOCKNAME:
1095     case OP_GETPEERNAME:
1096     case OP_READLINK:
1097     case OP_TELLDIR:
1098     case OP_GETPPID:
1099     case OP_GETPGRP:
1100     case OP_GETPRIORITY:
1101     case OP_TIME:
1102     case OP_TMS:
1103     case OP_LOCALTIME:
1104     case OP_GMTIME:
1105     case OP_GHBYNAME:
1106     case OP_GHBYADDR:
1107     case OP_GHOSTENT:
1108     case OP_GNBYNAME:
1109     case OP_GNBYADDR:
1110     case OP_GNETENT:
1111     case OP_GPBYNAME:
1112     case OP_GPBYNUMBER:
1113     case OP_GPROTOENT:
1114     case OP_GSBYNAME:
1115     case OP_GSBYPORT:
1116     case OP_GSERVENT:
1117     case OP_GPWNAM:
1118     case OP_GPWUID:
1119     case OP_GGRNAM:
1120     case OP_GGRGID:
1121     case OP_GETLOGIN:
1122       func_ops:
1123         if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
1124             useless = PL_op_desc[o->op_type];
1125         break;
1126
1127     case OP_RV2GV:
1128     case OP_RV2SV:
1129     case OP_RV2AV:
1130     case OP_RV2HV:
1131         if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
1132                 (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
1133             useless = "a variable";
1134         break;
1135
1136     case OP_CONST:
1137         sv = cSVOPo_sv;
1138         if (cSVOPo->op_private & OPpCONST_STRICT)
1139             no_bareword_allowed(o);
1140         else {
1141             if (ckWARN(WARN_VOID)) {
1142                 useless = "a constant";
1143                 if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
1144                     useless = 0;
1145                 else if (SvPOK(sv)) {
1146                   /* perl4's way of mixing documentation and code
1147                      (before the invention of POD) was based on a
1148                      trick to mix nroff and perl code. The trick was
1149                      built upon these three nroff macros being used in
1150                      void context. The pink camel has the details in
1151                      the script wrapman near page 319. */
1152                     if (strnEQ(SvPVX(sv), "di", 2) ||
1153                         strnEQ(SvPVX(sv), "ds", 2) ||
1154                         strnEQ(SvPVX(sv), "ig", 2))
1155                             useless = 0;
1156                 }
1157             }
1158         }
1159         null(o);                /* don't execute or even remember it */
1160         break;
1161
1162     case OP_POSTINC:
1163         o->op_type = OP_PREINC;         /* pre-increment is faster */
1164         o->op_ppaddr = PL_ppaddr[OP_PREINC];
1165         break;
1166
1167     case OP_POSTDEC:
1168         o->op_type = OP_PREDEC;         /* pre-decrement is faster */
1169         o->op_ppaddr = PL_ppaddr[OP_PREDEC];
1170         break;
1171
1172     case OP_OR:
1173     case OP_AND:
1174     case OP_COND_EXPR:
1175         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1176             scalarvoid(kid);
1177         break;
1178
1179     case OP_NULL:
1180         if (o->op_flags & OPf_STACKED)
1181             break;
1182         /* FALL THROUGH */
1183     case OP_NEXTSTATE:
1184     case OP_DBSTATE:
1185     case OP_ENTERTRY:
1186     case OP_ENTER:
1187         if (!(o->op_flags & OPf_KIDS))
1188             break;
1189         /* FALL THROUGH */
1190     case OP_SCOPE:
1191     case OP_LEAVE:
1192     case OP_LEAVETRY:
1193     case OP_LEAVELOOP:
1194     case OP_LINESEQ:
1195     case OP_LIST:
1196         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1197             scalarvoid(kid);
1198         break;
1199     case OP_ENTEREVAL:
1200         scalarkids(o);
1201         break;
1202     case OP_REQUIRE:
1203         /* all requires must return a boolean value */
1204         o->op_flags &= ~OPf_WANT;
1205         /* FALL THROUGH */
1206     case OP_SCALAR:
1207         return scalar(o);
1208     case OP_SPLIT:
1209         if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
1210             if (!kPMOP->op_pmreplroot)
1211                 deprecate("implicit split to @_");
1212         }
1213         break;
1214     }
1215     if (useless && ckWARN(WARN_VOID))
1216         Perl_warner(aTHX_ WARN_VOID, "Useless use of %s in void context", useless);
1217     return o;
1218 }
1219
1220 OP *
1221 Perl_listkids(pTHX_ OP *o)
1222 {
1223     OP *kid;
1224     if (o && o->op_flags & OPf_KIDS) {
1225         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1226             list(kid);
1227     }
1228     return o;
1229 }
1230
1231 OP *
1232 Perl_list(pTHX_ OP *o)
1233 {
1234     OP *kid;
1235
1236     /* assumes no premature commitment */
1237     if (!o || (o->op_flags & OPf_WANT) || PL_error_count
1238          || o->op_type == OP_RETURN)
1239     {
1240         return o;
1241     }
1242
1243     if ((o->op_private & OPpTARGET_MY)
1244         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1245     {
1246         return o;                               /* As if inside SASSIGN */
1247     }
1248
1249     o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
1250
1251     switch (o->op_type) {
1252     case OP_FLOP:
1253     case OP_REPEAT:
1254         list(cBINOPo->op_first);
1255         break;
1256     case OP_OR:
1257     case OP_AND:
1258     case OP_COND_EXPR:
1259         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1260             list(kid);
1261         break;
1262     default:
1263     case OP_MATCH:
1264     case OP_QR:
1265     case OP_SUBST:
1266     case OP_NULL:
1267         if (!(o->op_flags & OPf_KIDS))
1268             break;
1269         if (!o->op_next && cUNOPo->op_first->op_type == OP_FLOP) {
1270             list(cBINOPo->op_first);
1271             return gen_constant_list(o);
1272         }
1273     case OP_LIST:
1274         listkids(o);
1275         break;
1276     case OP_LEAVE:
1277     case OP_LEAVETRY:
1278         kid = cLISTOPo->op_first;
1279         list(kid);
1280         while ((kid = kid->op_sibling)) {
1281             if (kid->op_sibling)
1282                 scalarvoid(kid);
1283             else
1284                 list(kid);
1285         }
1286         WITH_THR(PL_curcop = &PL_compiling);
1287         break;
1288     case OP_SCOPE:
1289     case OP_LINESEQ:
1290         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1291             if (kid->op_sibling)
1292                 scalarvoid(kid);
1293             else
1294                 list(kid);
1295         }
1296         WITH_THR(PL_curcop = &PL_compiling);
1297         break;
1298     case OP_REQUIRE:
1299         /* all requires must return a boolean value */
1300         o->op_flags &= ~OPf_WANT;
1301         return scalar(o);
1302     }
1303     return o;
1304 }
1305
1306 OP *
1307 Perl_scalarseq(pTHX_ OP *o)
1308 {
1309     OP *kid;
1310
1311     if (o) {
1312         if (o->op_type == OP_LINESEQ ||
1313              o->op_type == OP_SCOPE ||
1314              o->op_type == OP_LEAVE ||
1315              o->op_type == OP_LEAVETRY)
1316         {
1317             for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
1318                 if (kid->op_sibling) {
1319                     scalarvoid(kid);
1320                 }
1321             }
1322             PL_curcop = &PL_compiling;
1323         }
1324         o->op_flags &= ~OPf_PARENS;
1325         if (PL_hints & HINT_BLOCK_SCOPE)
1326             o->op_flags |= OPf_PARENS;
1327     }
1328     else
1329         o = newOP(OP_STUB, 0);
1330     return o;
1331 }
1332
1333 STATIC OP *
1334 S_modkids(pTHX_ OP *o, I32 type)
1335 {
1336     OP *kid;
1337     if (o && o->op_flags & OPf_KIDS) {
1338         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1339             mod(kid, type);
1340     }
1341     return o;
1342 }
1343
1344 OP *
1345 Perl_mod(pTHX_ OP *o, I32 type)
1346 {
1347     OP *kid;
1348     STRLEN n_a;
1349
1350     if (!o || PL_error_count)
1351         return o;
1352
1353     if ((o->op_private & OPpTARGET_MY)
1354         && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
1355     {
1356         return o;
1357     }
1358
1359     switch (o->op_type) {
1360     case OP_UNDEF:
1361         PL_modcount++;
1362         return o;
1363     case OP_CONST:
1364         if (o->op_private & (OPpCONST_BARE) &&
1365                 !(type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)) {
1366             SV *sv = ((SVOP*)o)->op_sv;
1367             GV *gv;
1368
1369             /* Could be a filehandle */
1370             if ((gv = gv_fetchpv(SvPV_nolen(sv), FALSE, SVt_PVIO))) {
1371                 OP* gvio = newUNOP(OP_RV2GV, 0, newGVOP(OP_GV, 0, gv));
1372                 op_free(o);
1373                 o = gvio;
1374             } else {
1375                 /* OK, it's a sub */
1376                 OP* enter;
1377                 gv = gv_fetchpv(SvPV_nolen(sv), TRUE, SVt_PVCV);
1378
1379                 enter = newUNOP(OP_ENTERSUB,0,
1380                         newUNOP(OP_RV2CV, 0,
1381                             newGVOP(OP_GV, 0, gv)
1382                         ));
1383                 enter->op_private |= OPpLVAL_INTRO;
1384                 op_free(o);
1385                 o = enter;
1386             }
1387             break;
1388         }
1389         if (!(o->op_private & (OPpCONST_ARYBASE)))
1390             goto nomod;
1391         if (PL_eval_start && PL_eval_start->op_type == OP_CONST) {
1392             PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv);
1393             PL_eval_start = 0;
1394         }
1395         else if (!type) {
1396             SAVEI32(PL_compiling.cop_arybase);
1397             PL_compiling.cop_arybase = 0;
1398         }
1399         else if (type == OP_REFGEN)
1400             goto nomod;
1401         else
1402             Perl_croak(aTHX_ "That use of $[ is unsupported");
1403         break;
1404     case OP_STUB:
1405         if (o->op_flags & OPf_PARENS)
1406             break;
1407         goto nomod;
1408     case OP_ENTERSUB:
1409         if ((type == OP_UNDEF || type == OP_REFGEN) &&
1410             !(o->op_flags & OPf_STACKED)) {
1411             o->op_type = OP_RV2CV;              /* entersub => rv2cv */
1412             o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1413             assert(cUNOPo->op_first->op_type == OP_NULL);
1414             null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
1415             break;
1416         }
1417         else {                          /* lvalue subroutine call */
1418             o->op_private |= OPpLVAL_INTRO;
1419             PL_modcount = RETURN_UNLIMITED_NUMBER;
1420             if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
1421                 /* Backward compatibility mode: */
1422                 o->op_private |= OPpENTERSUB_INARGS;
1423                 break;
1424             }
1425             else {                      /* Compile-time error message: */
1426                 OP *kid = cUNOPo->op_first;
1427                 CV *cv;
1428                 OP *okid;
1429
1430                 if (kid->op_type == OP_PUSHMARK)
1431                     goto skip_kids;
1432                 if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
1433                     Perl_croak(aTHX_
1434                                "panic: unexpected lvalue entersub "
1435                                "args: type/targ %ld:%ld",
1436                                (long)kid->op_type,kid->op_targ);
1437                 kid = kLISTOP->op_first;
1438               skip_kids:
1439                 while (kid->op_sibling)
1440                     kid = kid->op_sibling;
1441                 if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
1442                     /* Indirect call */
1443                     if (kid->op_type == OP_METHOD_NAMED
1444                         || kid->op_type == OP_METHOD)
1445                     {
1446                         UNOP *newop;
1447
1448                         if (kid->op_sibling || kid->op_next != kid) {
1449                             yyerror("panic: unexpected optree near method call");
1450                             break;
1451                         }
1452
1453                         NewOp(1101, newop, 1, UNOP);
1454                         newop->op_type = OP_RV2CV;
1455                         newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
1456                         newop->op_first = Nullop;
1457                         newop->op_next = (OP*)newop;
1458                         kid->op_sibling = (OP*)newop;
1459                         newop->op_private |= OPpLVAL_INTRO;
1460                         break;
1461                     }
1462
1463                     if (kid->op_type != OP_RV2CV)
1464                         Perl_croak(aTHX_
1465                                    "panic: unexpected lvalue entersub "
1466                                    "entry via type/targ %ld:%ld",
1467                                    (long)kid->op_type,kid->op_targ);
1468                     kid->op_private |= OPpLVAL_INTRO;
1469                     break;      /* Postpone until runtime */
1470                 }
1471
1472                 okid = kid;
1473                 kid = kUNOP->op_first;
1474                 if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
1475                     kid = kUNOP->op_first;
1476                 if (kid->op_type == OP_NULL)
1477                     Perl_croak(aTHX_
1478                                "Unexpected constant lvalue entersub "
1479                                "entry via type/targ %ld:%ld",
1480                                (long)kid->op_type,kid->op_targ);
1481                 if (kid->op_type != OP_GV) {
1482                     /* Restore RV2CV to check lvalueness */
1483                   restore_2cv:
1484                     if (kid->op_next && kid->op_next != kid) { /* Happens? */
1485                         okid->op_next = kid->op_next;
1486                         kid->op_next = okid;
1487                     }
1488                     else
1489                         okid->op_next = Nullop;
1490                     okid->op_type = OP_RV2CV;
1491                     okid->op_targ = 0;
1492                     okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
1493                     okid->op_private |= OPpLVAL_INTRO;
1494                     break;
1495                 }
1496
1497                 cv = GvCV(kGVOP_gv);
1498                 if (!cv)
1499                     goto restore_2cv;
1500                 if (CvLVALUE(cv))
1501                     break;
1502             }
1503         }
1504         /* FALL THROUGH */
1505     default:
1506       nomod:
1507         /* grep, foreach, subcalls, refgen */
1508         if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
1509             break;
1510         yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
1511                      (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
1512                       ? "do block"
1513                       : (o->op_type == OP_ENTERSUB
1514                         ? "non-lvalue subroutine call"
1515                         : PL_op_desc[o->op_type])),
1516                      type ? PL_op_desc[type] : "local"));
1517         return o;
1518
1519     case OP_PREINC:
1520     case OP_PREDEC:
1521     case OP_POW:
1522     case OP_MULTIPLY:
1523     case OP_DIVIDE:
1524     case OP_MODULO:
1525     case OP_REPEAT:
1526     case OP_ADD:
1527     case OP_SUBTRACT:
1528     case OP_CONCAT:
1529     case OP_LEFT_SHIFT:
1530     case OP_RIGHT_SHIFT:
1531     case OP_BIT_AND:
1532     case OP_BIT_XOR:
1533     case OP_BIT_OR:
1534     case OP_I_MULTIPLY:
1535     case OP_I_DIVIDE:
1536     case OP_I_MODULO:
1537     case OP_I_ADD:
1538     case OP_I_SUBTRACT:
1539         if (!(o->op_flags & OPf_STACKED))
1540             goto nomod;
1541         PL_modcount++;
1542         break;
1543
1544     case OP_COND_EXPR:
1545         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1546             mod(kid, type);
1547         break;
1548
1549     case OP_RV2AV:
1550     case OP_RV2HV:
1551         if (!type && cUNOPo->op_first->op_type != OP_GV)
1552             Perl_croak(aTHX_ "Can't localize through a reference");
1553         if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
1554            PL_modcount = RETURN_UNLIMITED_NUMBER;
1555             return o;           /* Treat \(@foo) like ordinary list. */
1556         }
1557         /* FALL THROUGH */
1558     case OP_RV2GV:
1559         if (scalar_mod_type(o, type))
1560             goto nomod;
1561         ref(cUNOPo->op_first, o->op_type);
1562         /* FALL THROUGH */
1563     case OP_ASLICE:
1564     case OP_HSLICE:
1565         if (type == OP_LEAVESUBLV)
1566             o->op_private |= OPpMAYBE_LVSUB;
1567         /* FALL THROUGH */
1568     case OP_AASSIGN:
1569     case OP_NEXTSTATE:
1570     case OP_DBSTATE:
1571     case OP_CHOMP:
1572        PL_modcount = RETURN_UNLIMITED_NUMBER;
1573         break;
1574     case OP_RV2SV:
1575         if (!type && cUNOPo->op_first->op_type != OP_GV)
1576             Perl_croak(aTHX_ "Can't localize through a reference");
1577         ref(cUNOPo->op_first, o->op_type);
1578         /* FALL THROUGH */
1579     case OP_GV:
1580     case OP_AV2ARYLEN:
1581         PL_hints |= HINT_BLOCK_SCOPE;
1582     case OP_SASSIGN:
1583     case OP_ANDASSIGN:
1584     case OP_ORASSIGN:
1585     case OP_AELEMFAST:
1586         PL_modcount++;
1587         break;
1588
1589     case OP_PADAV:
1590     case OP_PADHV:
1591        PL_modcount = RETURN_UNLIMITED_NUMBER;
1592         if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
1593             return o;           /* Treat \(@foo) like ordinary list. */
1594         if (scalar_mod_type(o, type))
1595             goto nomod;
1596         if (type == OP_LEAVESUBLV)
1597             o->op_private |= OPpMAYBE_LVSUB;
1598         /* FALL THROUGH */
1599     case OP_PADSV:
1600         PL_modcount++;
1601         if (!type)
1602             Perl_croak(aTHX_ "Can't localize lexical variable %s",
1603                 SvPV(*av_fetch(PL_comppad_name, o->op_targ, 4), n_a));
1604         break;
1605
1606 #ifdef USE_THREADS
1607     case OP_THREADSV:
1608         PL_modcount++;  /* XXX ??? */
1609         break;
1610 #endif /* USE_THREADS */
1611
1612     case OP_PUSHMARK:
1613         break;
1614
1615     case OP_KEYS:
1616         if (type != OP_SASSIGN)
1617             goto nomod;
1618         goto lvalue_func;
1619     case OP_SUBSTR:
1620         if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
1621             goto nomod;
1622         /* FALL THROUGH */
1623     case OP_POS:
1624     case OP_VEC:
1625         if (type == OP_LEAVESUBLV)
1626             o->op_private |= OPpMAYBE_LVSUB;
1627       lvalue_func:
1628         pad_free(o->op_targ);
1629         o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
1630         assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
1631         if (o->op_flags & OPf_KIDS)
1632             mod(cBINOPo->op_first->op_sibling, type);
1633         break;
1634
1635     case OP_AELEM:
1636     case OP_HELEM:
1637         ref(cBINOPo->op_first, o->op_type);
1638         if (type == OP_ENTERSUB &&
1639              !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
1640             o->op_private |= OPpLVAL_DEFER;
1641         if (type == OP_LEAVESUBLV)
1642             o->op_private |= OPpMAYBE_LVSUB;
1643         PL_modcount++;
1644         break;
1645
1646     case OP_SCOPE:
1647     case OP_LEAVE:
1648     case OP_ENTER:
1649     case OP_LINESEQ:
1650         if (o->op_flags & OPf_KIDS)
1651             mod(cLISTOPo->op_last, type);
1652         break;
1653
1654     case OP_NULL:
1655         if (o->op_flags & OPf_SPECIAL)          /* do BLOCK */
1656             goto nomod;
1657         else if (!(o->op_flags & OPf_KIDS))
1658             break;
1659         if (o->op_targ != OP_LIST) {
1660             mod(cBINOPo->op_first, type);
1661             break;
1662         }
1663         /* FALL THROUGH */
1664     case OP_LIST:
1665         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1666             mod(kid, type);
1667         break;
1668
1669     case OP_RETURN:
1670         if (type != OP_LEAVESUBLV)
1671             goto nomod;
1672         break; /* mod()ing was handled by ck_return() */
1673     }
1674     if (type != OP_LEAVESUBLV)
1675         o->op_flags |= OPf_MOD;
1676
1677     if (type == OP_AASSIGN || type == OP_SASSIGN)
1678         o->op_flags |= OPf_SPECIAL|OPf_REF;
1679     else if (!type) {
1680         o->op_private |= OPpLVAL_INTRO;
1681         o->op_flags &= ~OPf_SPECIAL;
1682         PL_hints |= HINT_BLOCK_SCOPE;
1683     }
1684     else if (type != OP_GREPSTART && type != OP_ENTERSUB
1685              && type != OP_LEAVESUBLV)
1686         o->op_flags |= OPf_REF;
1687     return o;
1688 }
1689
1690 STATIC bool
1691 S_scalar_mod_type(pTHX_ OP *o, I32 type)
1692 {
1693     switch (type) {
1694     case OP_SASSIGN:
1695         if (o->op_type == OP_RV2GV)
1696             return FALSE;
1697         /* FALL THROUGH */
1698     case OP_PREINC:
1699     case OP_PREDEC:
1700     case OP_POSTINC:
1701     case OP_POSTDEC:
1702     case OP_I_PREINC:
1703     case OP_I_PREDEC:
1704     case OP_I_POSTINC:
1705     case OP_I_POSTDEC:
1706     case OP_POW:
1707     case OP_MULTIPLY:
1708     case OP_DIVIDE:
1709     case OP_MODULO:
1710     case OP_REPEAT:
1711     case OP_ADD:
1712     case OP_SUBTRACT:
1713     case OP_I_MULTIPLY:
1714     case OP_I_DIVIDE:
1715     case OP_I_MODULO:
1716     case OP_I_ADD:
1717     case OP_I_SUBTRACT:
1718     case OP_LEFT_SHIFT:
1719     case OP_RIGHT_SHIFT:
1720     case OP_BIT_AND:
1721     case OP_BIT_XOR:
1722     case OP_BIT_OR:
1723     case OP_CONCAT:
1724     case OP_SUBST:
1725     case OP_TRANS:
1726     case OP_READ:
1727     case OP_SYSREAD:
1728     case OP_RECV:
1729     case OP_ANDASSIGN:
1730     case OP_ORASSIGN:
1731         return TRUE;
1732     default:
1733         return FALSE;
1734     }
1735 }
1736
1737 STATIC bool
1738 S_is_handle_constructor(pTHX_ OP *o, I32 argnum)
1739 {
1740     switch (o->op_type) {
1741     case OP_PIPE_OP:
1742     case OP_SOCKPAIR:
1743         if (argnum == 2)
1744             return TRUE;
1745         /* FALL THROUGH */
1746     case OP_SYSOPEN:
1747     case OP_OPEN:
1748     case OP_SELECT:             /* XXX c.f. SelectSaver.pm */
1749     case OP_SOCKET:
1750     case OP_OPEN_DIR:
1751     case OP_ACCEPT:
1752         if (argnum == 1)
1753             return TRUE;
1754         /* FALL THROUGH */
1755     default:
1756         return FALSE;
1757     }
1758 }
1759
1760 OP *
1761 Perl_refkids(pTHX_ OP *o, I32 type)
1762 {
1763     OP *kid;
1764     if (o && o->op_flags & OPf_KIDS) {
1765         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1766             ref(kid, type);
1767     }
1768     return o;
1769 }
1770
1771 OP *
1772 Perl_ref(pTHX_ OP *o, I32 type)
1773 {
1774     OP *kid;
1775
1776     if (!o || PL_error_count)
1777         return o;
1778
1779     switch (o->op_type) {
1780     case OP_ENTERSUB:
1781         if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) &&
1782             !(o->op_flags & OPf_STACKED)) {
1783             o->op_type = OP_RV2CV;             /* entersub => rv2cv */
1784             o->op_ppaddr = PL_ppaddr[OP_RV2CV];
1785             assert(cUNOPo->op_first->op_type == OP_NULL);
1786             null(((LISTOP*)cUNOPo->op_first)->op_first);        /* disable pushmark */
1787             o->op_flags |= OPf_SPECIAL;
1788         }
1789         break;
1790
1791     case OP_COND_EXPR:
1792         for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
1793             ref(kid, type);
1794         break;
1795     case OP_RV2SV:
1796         if (type == OP_DEFINED)
1797             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
1798         ref(cUNOPo->op_first, o->op_type);
1799         /* FALL THROUGH */
1800     case OP_PADSV:
1801         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1802             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1803                               : type == OP_RV2HV ? OPpDEREF_HV
1804                               : OPpDEREF_SV);
1805             o->op_flags |= OPf_MOD;
1806         }
1807         break;
1808
1809     case OP_THREADSV:
1810         o->op_flags |= OPf_MOD;         /* XXX ??? */
1811         break;
1812
1813     case OP_RV2AV:
1814     case OP_RV2HV:
1815         o->op_flags |= OPf_REF;
1816         /* FALL THROUGH */
1817     case OP_RV2GV:
1818         if (type == OP_DEFINED)
1819             o->op_flags |= OPf_SPECIAL;         /* don't create GV */
1820         ref(cUNOPo->op_first, o->op_type);
1821         break;
1822
1823     case OP_PADAV:
1824     case OP_PADHV:
1825         o->op_flags |= OPf_REF;
1826         break;
1827
1828     case OP_SCALAR:
1829     case OP_NULL:
1830         if (!(o->op_flags & OPf_KIDS))
1831             break;
1832         ref(cBINOPo->op_first, type);
1833         break;
1834     case OP_AELEM:
1835     case OP_HELEM:
1836         ref(cBINOPo->op_first, o->op_type);
1837         if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
1838             o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
1839                               : type == OP_RV2HV ? OPpDEREF_HV
1840                               : OPpDEREF_SV);
1841             o->op_flags |= OPf_MOD;
1842         }
1843         break;
1844
1845     case OP_SCOPE:
1846     case OP_LEAVE:
1847     case OP_ENTER:
1848     case OP_LIST:
1849         if (!(o->op_flags & OPf_KIDS))
1850             break;
1851         ref(cLISTOPo->op_last, type);
1852         break;
1853     default:
1854         break;
1855     }
1856     return scalar(o);
1857
1858 }
1859
1860 STATIC OP *
1861 S_dup_attrlist(pTHX_ OP *o)
1862 {
1863     OP *rop = Nullop;
1864
1865     /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
1866      * where the first kid is OP_PUSHMARK and the remaining ones
1867      * are OP_CONST.  We need to push the OP_CONST values.
1868      */
1869     if (o->op_type == OP_CONST)
1870         rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
1871     else {
1872         assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
1873         for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
1874             if (o->op_type == OP_CONST)
1875                 rop = append_elem(OP_LIST, rop,
1876                                   newSVOP(OP_CONST, o->op_flags,
1877                                           SvREFCNT_inc(cSVOPo->op_sv)));
1878         }
1879     }
1880     return rop;
1881 }
1882
1883 STATIC void
1884 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
1885 {
1886     SV *stashsv;
1887
1888     /* fake up C<use attributes $pkg,$rv,@attrs> */
1889     ENTER;              /* need to protect against side-effects of 'use' */
1890     SAVEINT(PL_expect);
1891     if (stash && HvNAME(stash))
1892         stashsv = newSVpv(HvNAME(stash), 0);
1893     else
1894         stashsv = &PL_sv_no;
1895
1896 #define ATTRSMODULE "attributes"
1897
1898     Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1899                      newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1900                      Nullsv,
1901                      prepend_elem(OP_LIST,
1902                                   newSVOP(OP_CONST, 0, stashsv),
1903                                   prepend_elem(OP_LIST,
1904                                                newSVOP(OP_CONST, 0,
1905                                                        newRV(target)),
1906                                                dup_attrlist(attrs))));
1907     LEAVE;
1908 }
1909
1910 void
1911 Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv,
1912                         char *attrstr, STRLEN len)
1913 {
1914     OP *attrs = Nullop;
1915
1916     if (!len) {
1917         len = strlen(attrstr);
1918     }
1919
1920     while (len) {
1921         for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
1922         if (len) {
1923             char *sstr = attrstr;
1924             for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
1925             attrs = append_elem(OP_LIST, attrs,
1926                                 newSVOP(OP_CONST, 0,
1927                                         newSVpvn(sstr, attrstr-sstr)));
1928         }
1929     }
1930
1931     Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
1932                      newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
1933                      Nullsv, prepend_elem(OP_LIST,
1934                                   newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
1935                                   prepend_elem(OP_LIST,
1936                                                newSVOP(OP_CONST, 0,
1937                                                        newRV((SV*)cv)),
1938                                                attrs)));
1939 }
1940
1941 STATIC OP *
1942 S_my_kid(pTHX_ OP *o, OP *attrs)
1943 {
1944     OP *kid;
1945     I32 type;
1946
1947     if (!o || PL_error_count)
1948         return o;
1949
1950     type = o->op_type;
1951     if (type == OP_LIST) {
1952         for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
1953             my_kid(kid, attrs);
1954     } else if (type == OP_UNDEF) {
1955         return o;
1956     } else if (type == OP_RV2SV ||      /* "our" declaration */
1957                type == OP_RV2AV ||
1958                type == OP_RV2HV) { /* XXX does this let anything illegal in? */
1959         if (attrs) {
1960             GV *gv = cGVOPx_gv(cUNOPo->op_first);
1961             PL_in_my = FALSE;
1962             PL_in_my_stash = Nullhv;
1963             apply_attrs(GvSTASH(gv),
1964                         (type == OP_RV2SV ? GvSV(gv) :
1965                          type == OP_RV2AV ? (SV*)GvAV(gv) :
1966                          type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
1967                         attrs);
1968         }
1969         o->op_private |= OPpOUR_INTRO;
1970         return o;
1971     } else if (type != OP_PADSV &&
1972              type != OP_PADAV &&
1973              type != OP_PADHV &&
1974              type != OP_PUSHMARK)
1975     {
1976         yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
1977                           PL_op_desc[o->op_type],
1978                           PL_in_my == KEY_our ? "our" : "my"));
1979         return o;
1980     }
1981     else if (attrs && type != OP_PUSHMARK) {
1982         HV *stash;
1983         SV *padsv;
1984         SV **namesvp;
1985
1986         PL_in_my = FALSE;
1987         PL_in_my_stash = Nullhv;
1988
1989         /* check for C<my Dog $spot> when deciding package */
1990         namesvp = av_fetch(PL_comppad_name, o->op_targ, FALSE);
1991         if (namesvp && *namesvp && SvOBJECT(*namesvp) && HvNAME(SvSTASH(*namesvp)))
1992             stash = SvSTASH(*namesvp);
1993         else
1994             stash = PL_curstash;
1995         padsv = PAD_SV(o->op_targ);
1996         apply_attrs(stash, padsv, attrs);
1997     }
1998     o->op_flags |= OPf_MOD;
1999     o->op_private |= OPpLVAL_INTRO;
2000     return o;
2001 }
2002
2003 OP *
2004 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
2005 {
2006     if (o->op_flags & OPf_PARENS)
2007         list(o);
2008     if (attrs)
2009         SAVEFREEOP(attrs);
2010     o = my_kid(o, attrs);
2011     PL_in_my = FALSE;
2012     PL_in_my_stash = Nullhv;
2013     return o;
2014 }
2015
2016 OP *
2017 Perl_my(pTHX_ OP *o)
2018 {
2019     return my_kid(o, Nullop);
2020 }
2021
2022 OP *
2023 Perl_sawparens(pTHX_ OP *o)
2024 {
2025     if (o)
2026         o->op_flags |= OPf_PARENS;
2027     return o;
2028 }
2029
2030 OP *
2031 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
2032 {
2033     OP *o;
2034
2035     if (ckWARN(WARN_MISC) &&
2036       (left->op_type == OP_RV2AV ||
2037        left->op_type == OP_RV2HV ||
2038        left->op_type == OP_PADAV ||
2039        left->op_type == OP_PADHV)) {
2040       char *desc = PL_op_desc[(right->op_type == OP_SUBST ||
2041                             right->op_type == OP_TRANS)
2042                            ? right->op_type : OP_MATCH];
2043       const char *sample = ((left->op_type == OP_RV2AV ||
2044                              left->op_type == OP_PADAV)
2045                             ? "@array" : "%hash");
2046       Perl_warner(aTHX_ WARN_MISC,
2047              "Applying %s to %s will act on scalar(%s)",
2048              desc, sample, sample);
2049     }
2050
2051     if (!(right->op_flags & OPf_STACKED) &&
2052        (right->op_type == OP_MATCH ||
2053         right->op_type == OP_SUBST ||
2054         right->op_type == OP_TRANS)) {
2055         right->op_flags |= OPf_STACKED;
2056         if (right->op_type != OP_MATCH &&
2057             ! (right->op_type == OP_TRANS &&
2058                right->op_private & OPpTRANS_IDENTICAL))
2059             left = mod(left, right->op_type);
2060         if (right->op_type == OP_TRANS)
2061             o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
2062         else
2063             o = prepend_elem(right->op_type, scalar(left), right);
2064         if (type == OP_NOT)
2065             return newUNOP(OP_NOT, 0, scalar(o));
2066         return o;
2067     }
2068     else
2069         return bind_match(type, left,
2070                 pmruntime(newPMOP(OP_MATCH, 0), right, Nullop));
2071 }
2072
2073 OP *
2074 Perl_invert(pTHX_ OP *o)
2075 {
2076     if (!o)
2077         return o;
2078     /* XXX need to optimize away NOT NOT here?  Or do we let optimizer do it? */
2079     return newUNOP(OP_NOT, OPf_SPECIAL, scalar(o));
2080 }
2081
2082 OP *
2083 Perl_scope(pTHX_ OP *o)
2084 {
2085     if (o) {
2086         if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
2087             o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
2088             o->op_type = OP_LEAVE;
2089             o->op_ppaddr = PL_ppaddr[OP_LEAVE];
2090         }
2091         else {
2092             if (o->op_type == OP_LINESEQ) {
2093                 OP *kid;
2094                 o->op_type = OP_SCOPE;
2095                 o->op_ppaddr = PL_ppaddr[OP_SCOPE];
2096                 kid = ((LISTOP*)o)->op_first;
2097                 if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
2098                     null(kid);
2099             }
2100             else
2101                 o = newLISTOP(OP_SCOPE, 0, o, Nullop);
2102         }
2103     }
2104     return o;
2105 }
2106
2107 void
2108 Perl_save_hints(pTHX)
2109 {
2110     SAVEI32(PL_hints);
2111     SAVESPTR(GvHV(PL_hintgv));
2112     GvHV(PL_hintgv) = newHVhv(GvHV(PL_hintgv));
2113     SAVEFREESV(GvHV(PL_hintgv));
2114 }
2115
2116 int
2117 Perl_block_start(pTHX_ int full)
2118 {
2119     int retval = PL_savestack_ix;
2120
2121     SAVEI32(PL_comppad_name_floor);
2122     PL_comppad_name_floor = AvFILLp(PL_comppad_name);
2123     if (full)
2124         PL_comppad_name_fill = PL_comppad_name_floor;
2125     if (PL_comppad_name_floor < 0)
2126         PL_comppad_name_floor = 0;
2127     SAVEI32(PL_min_intro_pending);
2128     SAVEI32(PL_max_intro_pending);
2129     PL_min_intro_pending = 0;
2130     SAVEI32(PL_comppad_name_fill);
2131     SAVEI32(PL_padix_floor);
2132     PL_padix_floor = PL_padix;
2133     PL_pad_reset_pending = FALSE;
2134     SAVEHINTS();
2135     PL_hints &= ~HINT_BLOCK_SCOPE;
2136     SAVESPTR(PL_compiling.cop_warnings);
2137     if (! specialWARN(PL_compiling.cop_warnings)) {
2138         PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
2139         SAVEFREESV(PL_compiling.cop_warnings) ;
2140     }
2141     SAVESPTR(PL_compiling.cop_io);
2142     if (! specialCopIO(PL_compiling.cop_io)) {
2143         PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
2144         SAVEFREESV(PL_compiling.cop_io) ;
2145     }
2146     return retval;
2147 }
2148
2149 OP*
2150 Perl_block_end(pTHX_ I32 floor, OP *seq)
2151 {
2152     int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
2153     OP* retval = scalarseq(seq);
2154     LEAVE_SCOPE(floor);
2155     PL_pad_reset_pending = FALSE;
2156     PL_compiling.op_private = PL_hints;
2157     if (needblockscope)
2158         PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
2159     pad_leavemy(PL_comppad_name_fill);
2160     PL_cop_seqmax++;
2161     return retval;
2162 }
2163
2164 STATIC OP *
2165 S_newDEFSVOP(pTHX)
2166 {
2167 #ifdef USE_THREADS
2168     OP *o = newOP(OP_THREADSV, 0);
2169     o->op_targ = find_threadsv("_");
2170     return o;
2171 #else
2172     return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
2173 #endif /* USE_THREADS */
2174 }
2175
2176 void
2177 Perl_newPROG(pTHX_ OP *o)
2178 {
2179     if (PL_in_eval) {
2180         if (PL_eval_root)
2181                 return;
2182         PL_eval_root = newUNOP(OP_LEAVEEVAL,
2183                                ((PL_in_eval & EVAL_KEEPERR)
2184                                 ? OPf_SPECIAL : 0), o);
2185         PL_eval_start = linklist(PL_eval_root);
2186         PL_eval_root->op_private |= OPpREFCOUNTED;
2187         OpREFCNT_set(PL_eval_root, 1);
2188         PL_eval_root->op_next = 0;
2189         peep(PL_eval_start);
2190     }
2191     else {
2192         if (!o)
2193             return;
2194         PL_main_root = scope(sawparens(scalarvoid(o)));
2195         PL_curcop = &PL_compiling;
2196         PL_main_start = LINKLIST(PL_main_root);
2197         PL_main_root->op_private |= OPpREFCOUNTED;
2198         OpREFCNT_set(PL_main_root, 1);
2199         PL_main_root->op_next = 0;
2200         peep(PL_main_start);
2201         PL_compcv = 0;
2202
2203         /* Register with debugger */
2204         if (PERLDB_INTER) {
2205             CV *cv = get_cv("DB::postponed", FALSE);
2206             if (cv) {
2207                 dSP;
2208                 PUSHMARK(SP);
2209                 XPUSHs((SV*)CopFILEGV(&PL_compiling));
2210                 PUTBACK;
2211                 call_sv((SV*)cv, G_DISCARD);
2212             }
2213         }
2214     }
2215 }
2216
2217 OP *
2218 Perl_localize(pTHX_ OP *o, I32 lex)
2219 {
2220     if (o->op_flags & OPf_PARENS)
2221         list(o);
2222     else {
2223         if (ckWARN(WARN_PARENTHESIS) && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',') {
2224             char *s;
2225             for (s = PL_bufptr; *s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s) || strchr("@$%, ",*s)); s++) ;
2226             if (*s == ';' || *s == '=')
2227                 Perl_warner(aTHX_ WARN_PARENTHESIS,
2228                             "Parentheses missing around \"%s\" list",
2229                             lex ? (PL_in_my == KEY_our ? "our" : "my") : "local");
2230         }
2231     }
2232     if (lex)
2233         o = my(o);
2234     else
2235         o = mod(o, OP_NULL);            /* a bit kludgey */
2236     PL_in_my = FALSE;
2237     PL_in_my_stash = Nullhv;
2238     return o;
2239 }
2240
2241 OP *
2242 Perl_jmaybe(pTHX_ OP *o)
2243 {
2244     if (o->op_type == OP_LIST) {
2245         OP *o2;
2246 #ifdef USE_THREADS
2247         o2 = newOP(OP_THREADSV, 0);
2248         o2->op_targ = find_threadsv(";");
2249 #else
2250         o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
2251 #endif /* USE_THREADS */
2252         o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
2253     }
2254     return o;
2255 }
2256
2257 OP *
2258 Perl_fold_constants(pTHX_ register OP *o)
2259 {
2260     register OP *curop;
2261     I32 type = o->op_type;
2262     SV *sv;
2263
2264     if (PL_opargs[type] & OA_RETSCALAR)
2265         scalar(o);
2266     if (PL_opargs[type] & OA_TARGET && !o->op_targ)
2267         o->op_targ = pad_alloc(type, SVs_PADTMP);
2268
2269     /* integerize op, unless it happens to be C<-foo>.
2270      * XXX should pp_i_negate() do magic string negation instead? */
2271     if ((PL_opargs[type] & OA_OTHERINT) && (PL_hints & HINT_INTEGER)
2272         && !(type == OP_NEGATE && cUNOPo->op_first->op_type == OP_CONST
2273              && (cUNOPo->op_first->op_private & OPpCONST_BARE)))
2274     {
2275         o->op_ppaddr = PL_ppaddr[type = ++(o->op_type)];
2276     }
2277
2278     if (!(PL_opargs[type] & OA_FOLDCONST))
2279         goto nope;
2280
2281     switch (type) {
2282     case OP_NEGATE:
2283         /* XXX might want a ck_negate() for this */
2284         cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
2285         break;
2286     case OP_SPRINTF:
2287     case OP_UCFIRST:
2288     case OP_LCFIRST:
2289     case OP_UC:
2290     case OP_LC:
2291     case OP_SLT:
2292     case OP_SGT:
2293     case OP_SLE:
2294     case OP_SGE:
2295     case OP_SCMP:
2296
2297         if (o->op_private & OPpLOCALE)
2298             goto nope;
2299     }
2300
2301     if (PL_error_count)
2302         goto nope;              /* Don't try to run w/ errors */
2303
2304     for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
2305         if ((curop->op_type != OP_CONST ||
2306              (curop->op_private & OPpCONST_BARE)) &&
2307             curop->op_type != OP_LIST &&
2308             curop->op_type != OP_SCALAR &&
2309             curop->op_type != OP_NULL &&
2310             curop->op_type != OP_PUSHMARK)
2311         {
2312             goto nope;
2313         }
2314     }
2315
2316     curop = LINKLIST(o);
2317     o->op_next = 0;
2318     PL_op = curop;
2319     CALLRUNOPS(aTHX);
2320     sv = *(PL_stack_sp--);
2321     if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
2322         pad_swipe(o->op_targ);
2323     else if (SvTEMP(sv)) {                      /* grab mortal temp? */
2324         (void)SvREFCNT_inc(sv);
2325         SvTEMP_off(sv);
2326     }
2327     op_free(o);
2328     if (type == OP_RV2GV)
2329         return newGVOP(OP_GV, 0, (GV*)sv);
2330     else {
2331         /* try to smush double to int, but don't smush -2.0 to -2 */
2332         if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK &&
2333             type != OP_NEGATE)
2334         {
2335 #ifdef PERL_PRESERVE_IVUV
2336             /* Only bother to attempt to fold to IV if
2337                most operators will benefit  */
2338             SvIV_please(sv);
2339 #endif
2340         }
2341         return newSVOP(OP_CONST, 0, sv);
2342     }
2343
2344   nope:
2345     if (!(PL_opargs[type] & OA_OTHERINT))
2346         return o;
2347
2348     if (!(PL_hints & HINT_INTEGER)) {
2349         if (type == OP_MODULO
2350             || type == OP_DIVIDE
2351             || !(o->op_flags & OPf_KIDS))
2352         {
2353             return o;
2354         }
2355
2356         for (curop = ((UNOP*)o)->op_first; curop; curop = curop->op_sibling) {
2357             if (curop->op_type == OP_CONST) {
2358                 if (SvIOK(((SVOP*)curop)->op_sv))
2359                     continue;
2360                 return o;
2361             }
2362             if (PL_opargs[curop->op_type] & OA_RETINTEGER)
2363                 continue;
2364             return o;
2365         }
2366         o->op_ppaddr = PL_ppaddr[++(o->op_type)];
2367     }
2368
2369     return o;
2370 }
2371
2372 OP *
2373 Perl_gen_constant_list(pTHX_ register OP *o)
2374 {
2375     register OP *curop;
2376     I32 oldtmps_floor = PL_tmps_floor;
2377
2378     list(o);
2379     if (PL_error_count)
2380         return o;               /* Don't attempt to run with errors */
2381
2382     PL_op = curop = LINKLIST(o);
2383     o->op_next = 0;
2384     peep(curop);
2385     pp_pushmark();
2386     CALLRUNOPS(aTHX);
2387     PL_op = curop;
2388     pp_anonlist();
2389     PL_tmps_floor = oldtmps_floor;
2390
2391     o->op_type = OP_RV2AV;
2392     o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2393     curop = ((UNOP*)o)->op_first;
2394     ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2395     op_free(curop);
2396     linklist(o);
2397     return list(o);
2398 }
2399
2400 OP *
2401 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2402 {
2403     if (!o || o->op_type != OP_LIST)
2404         o = newLISTOP(OP_LIST, 0, o, Nullop);
2405     else
2406         o->op_flags &= ~OPf_WANT;
2407
2408     if (!(PL_opargs[type] & OA_MARK))
2409         null(cLISTOPo->op_first);
2410
2411     o->op_type = type;
2412     o->op_ppaddr = PL_ppaddr[type];
2413     o->op_flags |= flags;
2414
2415     o = CHECKOP(type, o);
2416     if (o->op_type != type)
2417         return o;
2418
2419     return fold_constants(o);
2420 }
2421
2422 /* List constructors */
2423
2424 OP *
2425 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2426 {
2427     if (!first)
2428         return last;
2429
2430     if (!last)
2431         return first;
2432
2433     if (first->op_type != type
2434         || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2435     {
2436         return newLISTOP(type, 0, first, last);
2437     }
2438
2439     if (first->op_flags & OPf_KIDS)
2440         ((LISTOP*)first)->op_last->op_sibling = last;
2441     else {
2442         first->op_flags |= OPf_KIDS;
2443         ((LISTOP*)first)->op_first = last;
2444     }
2445     ((LISTOP*)first)->op_last = last;
2446     return first;
2447 }
2448
2449 OP *
2450 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2451 {
2452     if (!first)
2453         return (OP*)last;
2454
2455     if (!last)
2456         return (OP*)first;
2457
2458     if (first->op_type != type)
2459         return prepend_elem(type, (OP*)first, (OP*)last);
2460
2461     if (last->op_type != type)
2462         return append_elem(type, (OP*)first, (OP*)last);
2463
2464     first->op_last->op_sibling = last->op_first;
2465     first->op_last = last->op_last;
2466     first->op_flags |= (last->op_flags & OPf_KIDS);
2467
2468 #ifdef PL_OP_SLAB_ALLOC
2469 #else
2470     Safefree(last);
2471 #endif
2472     return (OP*)first;
2473 }
2474
2475 OP *
2476 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2477 {
2478     if (!first)
2479         return last;
2480
2481     if (!last)
2482         return first;
2483
2484     if (last->op_type == type) {
2485         if (type == OP_LIST) {  /* already a PUSHMARK there */
2486             first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2487             ((LISTOP*)last)->op_first->op_sibling = first;
2488             if (!(first->op_flags & OPf_PARENS))
2489                 last->op_flags &= ~OPf_PARENS;
2490         }
2491         else {
2492             if (!(last->op_flags & OPf_KIDS)) {
2493                 ((LISTOP*)last)->op_last = first;
2494                 last->op_flags |= OPf_KIDS;
2495             }
2496             first->op_sibling = ((LISTOP*)last)->op_first;
2497             ((LISTOP*)last)->op_first = first;
2498         }
2499         last->op_flags |= OPf_KIDS;
2500         return last;
2501     }
2502
2503     return newLISTOP(type, 0, first, last);
2504 }
2505
2506 /* Constructors */
2507
2508 OP *
2509 Perl_newNULLLIST(pTHX)
2510 {
2511     return newOP(OP_STUB, 0);
2512 }
2513
2514 OP *
2515 Perl_force_list(pTHX_ OP *o)
2516 {
2517     if (!o || o->op_type != OP_LIST)
2518         o = newLISTOP(OP_LIST, 0, o, Nullop);
2519     null(o);
2520     return o;
2521 }
2522
2523 OP *
2524 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2525 {
2526     LISTOP *listop;
2527
2528     NewOp(1101, listop, 1, LISTOP);
2529
2530     listop->op_type = type;
2531     listop->op_ppaddr = PL_ppaddr[type];
2532     if (first || last)
2533         flags |= OPf_KIDS;
2534     listop->op_flags = flags;
2535
2536     if (!last && first)
2537         last = first;
2538     else if (!first && last)
2539         first = last;
2540     else if (first)
2541         first->op_sibling = last;
2542     listop->op_first = first;
2543     listop->op_last = last;
2544     if (type == OP_LIST) {
2545         OP* pushop;
2546         pushop = newOP(OP_PUSHMARK, 0);
2547         pushop->op_sibling = first;
2548         listop->op_first = pushop;
2549         listop->op_flags |= OPf_KIDS;
2550         if (!last)
2551             listop->op_last = pushop;
2552     }
2553
2554     return (OP*)listop;
2555 }
2556
2557 OP *
2558 Perl_newOP(pTHX_ I32 type, I32 flags)
2559 {
2560     OP *o;
2561     NewOp(1101, o, 1, OP);
2562     o->op_type = type;
2563     o->op_ppaddr = PL_ppaddr[type];
2564     o->op_flags = flags;
2565
2566     o->op_next = o;
2567     o->op_private = 0 + (flags >> 8);
2568     if (PL_opargs[type] & OA_RETSCALAR)
2569         scalar(o);
2570     if (PL_opargs[type] & OA_TARGET)
2571         o->op_targ = pad_alloc(type, SVs_PADTMP);
2572     return CHECKOP(type, o);
2573 }
2574
2575 OP *
2576 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2577 {
2578     UNOP *unop;
2579
2580     if (!first)
2581         first = newOP(OP_STUB, 0);
2582     if (PL_opargs[type] & OA_MARK)
2583         first = force_list(first);
2584
2585     NewOp(1101, unop, 1, UNOP);
2586     unop->op_type = type;
2587     unop->op_ppaddr = PL_ppaddr[type];
2588     unop->op_first = first;
2589     unop->op_flags = flags | OPf_KIDS;
2590     unop->op_private = 1 | (flags >> 8);
2591     unop = (UNOP*) CHECKOP(type, unop);
2592     if (unop->op_next)
2593         return (OP*)unop;
2594
2595     return fold_constants((OP *) unop);
2596 }
2597
2598 OP *
2599 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2600 {
2601     BINOP *binop;
2602     NewOp(1101, binop, 1, BINOP);
2603
2604     if (!first)
2605         first = newOP(OP_NULL, 0);
2606
2607     binop->op_type = type;
2608     binop->op_ppaddr = PL_ppaddr[type];
2609     binop->op_first = first;
2610     binop->op_flags = flags | OPf_KIDS;
2611     if (!last) {
2612         last = first;
2613         binop->op_private = 1 | (flags >> 8);
2614     }
2615     else {
2616         binop->op_private = 2 | (flags >> 8);
2617         first->op_sibling = last;
2618     }
2619
2620     binop = (BINOP*)CHECKOP(type, binop);
2621     if (binop->op_next || binop->op_type != type)
2622         return (OP*)binop;
2623
2624     binop->op_last = binop->op_first->op_sibling;
2625
2626     return fold_constants((OP *)binop);
2627 }
2628
2629 static int
2630 utf8compare(const void *a, const void *b)
2631 {
2632     int i;
2633     for (i = 0; i < 10; i++) {
2634         if ((*(U8**)a)[i] < (*(U8**)b)[i])
2635             return -1;
2636         if ((*(U8**)a)[i] > (*(U8**)b)[i])
2637             return 1;
2638     }
2639     return 0;
2640 }
2641
2642 OP *
2643 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2644 {
2645     SV *tstr = ((SVOP*)expr)->op_sv;
2646     SV *rstr = ((SVOP*)repl)->op_sv;
2647     STRLEN tlen;
2648     STRLEN rlen;
2649     U8 *t = (U8*)SvPV(tstr, tlen);
2650     U8 *r = (U8*)SvPV(rstr, rlen);
2651     register I32 i;
2652     register I32 j;
2653     I32 del;
2654     I32 complement;
2655     I32 squash;
2656     I32 grows = 0;
2657     register short *tbl;
2658
2659     complement  = o->op_private & OPpTRANS_COMPLEMENT;
2660     del         = o->op_private & OPpTRANS_DELETE;
2661     squash      = o->op_private & OPpTRANS_SQUASH;
2662
2663     if (SvUTF8(tstr))
2664         o->op_private |= OPpTRANS_FROM_UTF;
2665
2666     if (SvUTF8(rstr))
2667         o->op_private |= OPpTRANS_TO_UTF;
2668
2669     if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2670         SV* listsv = newSVpvn("# comment\n",10);
2671         SV* transv = 0;
2672         U8* tend = t + tlen;
2673         U8* rend = r + rlen;
2674         STRLEN ulen;
2675         U32 tfirst = 1;
2676         U32 tlast = 0;
2677         I32 tdiff;
2678         U32 rfirst = 1;
2679         U32 rlast = 0;
2680         I32 rdiff;
2681         I32 diff;
2682         I32 none = 0;
2683         U32 max = 0;
2684         I32 bits;
2685         I32 havefinal = 0;
2686         U32 final;
2687         I32 from_utf    = o->op_private & OPpTRANS_FROM_UTF;
2688         I32 to_utf      = o->op_private & OPpTRANS_TO_UTF;
2689         U8* tsave = from_utf ? NULL : trlist_upgrade(&t, &tend);
2690         U8* rsave = to_utf   ? NULL : trlist_upgrade(&r, &rend);
2691
2692         if (complement) {
2693             U8 tmpbuf[UTF8_MAXLEN+1];
2694             U8** cp;
2695             UV nextmin = 0;
2696             New(1109, cp, tlen, U8*);
2697             i = 0;
2698             transv = newSVpvn("",0);
2699             while (t < tend) {
2700                 cp[i++] = t;
2701                 t += UTF8SKIP(t);
2702                 if (t < tend && *t == 0xff) {
2703                     t++;
2704                     t += UTF8SKIP(t);
2705                 }
2706             }
2707             qsort(cp, i, sizeof(U8*), utf8compare);
2708             for (j = 0; j < i; j++) {
2709                 U8 *s = cp[j];
2710                 I32 cur = j < i - 1 ? cp[j+1] - s : tend - s;
2711                 UV  val = utf8_to_uv(s, cur, &ulen, 0);
2712                 s += ulen;
2713                 diff = val - nextmin;
2714                 if (diff > 0) {
2715                     t = uv_to_utf8(tmpbuf,nextmin);
2716                     sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2717                     if (diff > 1) {
2718                         t = uv_to_utf8(tmpbuf, val - 1);
2719                         sv_catpvn(transv, "\377", 1);
2720                         sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2721                     }
2722                 }
2723                 if (s < tend && *s == 0xff)
2724                     val = utf8_to_uv(s+1, cur - 1, &ulen, 0);
2725                 if (val >= nextmin)
2726                     nextmin = val + 1;
2727             }
2728             t = uv_to_utf8(tmpbuf,nextmin);
2729             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2730             t = uv_to_utf8(tmpbuf, 0x7fffffff);
2731             sv_catpvn(transv, "\377", 1);
2732             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2733             t = (U8*)SvPVX(transv);
2734             tlen = SvCUR(transv);
2735             tend = t + tlen;
2736             Safefree(cp);
2737         }
2738         else if (!rlen && !del) {
2739             r = t; rlen = tlen; rend = tend;
2740         }
2741         if (!squash) {
2742                 if (t == r ||
2743                     (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2744                 {
2745                     o->op_private |= OPpTRANS_IDENTICAL;
2746                 }
2747         }
2748
2749         while (t < tend || tfirst <= tlast) {
2750             /* see if we need more "t" chars */
2751             if (tfirst > tlast) {
2752                 tfirst = (I32)utf8_to_uv(t, tend - t, &ulen, 0);
2753                 t += ulen;
2754                 if (t < tend && *t == 0xff) {   /* illegal utf8 val indicates range */
2755                     t++;
2756                     tlast = (I32)utf8_to_uv(t, tend - t, &ulen, 0);
2757                     t += ulen;
2758                 }
2759                 else
2760                     tlast = tfirst;
2761             }
2762
2763             /* now see if we need more "r" chars */
2764             if (rfirst > rlast) {
2765                 if (r < rend) {
2766                     rfirst = (I32)utf8_to_uv(r, rend - r, &ulen, 0);
2767                     r += ulen;
2768                     if (r < rend && *r == 0xff) {       /* illegal utf8 val indicates range */
2769                         r++;
2770                         rlast = (I32)utf8_to_uv(r, rend - r, &ulen, 0);
2771                         r += ulen;
2772                     }
2773                     else
2774                         rlast = rfirst;
2775                 }
2776                 else {
2777                     if (!havefinal++)
2778                         final = rlast;
2779                     rfirst = rlast = 0xffffffff;
2780                 }
2781             }
2782
2783             /* now see which range will peter our first, if either. */
2784             tdiff = tlast - tfirst;
2785             rdiff = rlast - rfirst;
2786
2787             if (tdiff <= rdiff)
2788                 diff = tdiff;
2789             else
2790                 diff = rdiff;
2791
2792             if (rfirst == 0xffffffff) {
2793                 diff = tdiff;   /* oops, pretend rdiff is infinite */
2794                 if (diff > 0)
2795                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2796                                    (long)tfirst, (long)tlast);
2797                 else
2798                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2799             }
2800             else {
2801                 if (diff > 0)
2802                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2803                                    (long)tfirst, (long)(tfirst + diff),
2804                                    (long)rfirst);
2805                 else
2806                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2807                                    (long)tfirst, (long)rfirst);
2808
2809                 if (rfirst + diff > max)
2810                     max = rfirst + diff;
2811                 rfirst += diff + 1;
2812                 if (!grows)
2813                     grows = (UNISKIP(tfirst) < UNISKIP(rfirst));
2814             }
2815             tfirst += diff + 1;
2816         }
2817
2818         none = ++max;
2819         if (del)
2820             del = ++max;
2821
2822         if (max > 0xffff)
2823             bits = 32;
2824         else if (max > 0xff)
2825             bits = 16;
2826         else
2827             bits = 8;
2828
2829         Safefree(cPVOPo->op_pv);
2830         cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2831         SvREFCNT_dec(listsv);
2832         if (transv)
2833             SvREFCNT_dec(transv);
2834
2835         if (!del && havefinal)
2836             (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2837                            newSVuv((UV)final), 0);
2838
2839         if (grows)
2840             o->op_private |= OPpTRANS_GROWS;
2841
2842         if (tsave)
2843             Safefree(tsave);
2844         if (rsave)
2845             Safefree(rsave);
2846
2847         op_free(expr);
2848         op_free(repl);
2849         return o;
2850     }
2851
2852     tbl = (short*)cPVOPo->op_pv;
2853     if (complement) {
2854         Zero(tbl, 256, short);
2855         for (i = 0; i < tlen; i++)
2856             tbl[t[i]] = -1;
2857         for (i = 0, j = 0; i < 256; i++) {
2858             if (!tbl[i]) {
2859                 if (j >= rlen) {
2860                     if (del)
2861                         tbl[i] = -2;
2862                     else if (rlen)
2863                         tbl[i] = r[j-1];
2864                     else
2865                         tbl[i] = i;
2866                 }
2867                 else {
2868                     if (i < 128 && r[j] >= 128)
2869                         grows = 1;
2870                     tbl[i] = r[j++];
2871                 }
2872             }
2873         }
2874     }
2875     else {
2876         if (!rlen && !del) {
2877             r = t; rlen = tlen;
2878             if (!squash)
2879                 o->op_private |= OPpTRANS_IDENTICAL;
2880         }
2881         for (i = 0; i < 256; i++)
2882             tbl[i] = -1;
2883         for (i = 0, j = 0; i < tlen; i++,j++) {
2884             if (j >= rlen) {
2885                 if (del) {
2886                     if (tbl[t[i]] == -1)
2887                         tbl[t[i]] = -2;
2888                     continue;
2889                 }
2890                 --j;
2891             }
2892             if (tbl[t[i]] == -1) {
2893                 if (t[i] < 128 && r[j] >= 128)
2894                     grows = 1;
2895                 tbl[t[i]] = r[j];
2896             }
2897         }
2898     }
2899     if (grows)
2900         o->op_private |= OPpTRANS_GROWS;
2901     op_free(expr);
2902     op_free(repl);
2903
2904     return o;
2905 }
2906
2907 OP *
2908 Perl_newPMOP(pTHX_ I32 type, I32 flags)
2909 {
2910     PMOP *pmop;
2911
2912     NewOp(1101, pmop, 1, PMOP);
2913     pmop->op_type = type;
2914     pmop->op_ppaddr = PL_ppaddr[type];
2915     pmop->op_flags = flags;
2916     pmop->op_private = 0 | (flags >> 8);
2917
2918     if (PL_hints & HINT_RE_TAINT)
2919         pmop->op_pmpermflags |= PMf_RETAINT;
2920     if (PL_hints & HINT_LOCALE)
2921         pmop->op_pmpermflags |= PMf_LOCALE;
2922     pmop->op_pmflags = pmop->op_pmpermflags;
2923
2924     /* link into pm list */
2925     if (type != OP_TRANS && PL_curstash) {
2926         pmop->op_pmnext = HvPMROOT(PL_curstash);
2927         HvPMROOT(PL_curstash) = pmop;
2928     }
2929
2930     return (OP*)pmop;
2931 }
2932
2933 OP *
2934 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
2935 {
2936     PMOP *pm;
2937     LOGOP *rcop;
2938     I32 repl_has_vars = 0;
2939
2940     if (o->op_type == OP_TRANS)
2941         return pmtrans(o, expr, repl);
2942
2943     PL_hints |= HINT_BLOCK_SCOPE;
2944     pm = (PMOP*)o;
2945
2946     if (expr->op_type == OP_CONST) {
2947         STRLEN plen;
2948         SV *pat = ((SVOP*)expr)->op_sv;
2949         char *p = SvPV(pat, plen);
2950         if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
2951             sv_setpvn(pat, "\\s+", 3);
2952             p = SvPV(pat, plen);
2953             pm->op_pmflags |= PMf_SKIPWHITE;
2954         }
2955         if ((PL_hints & HINT_UTF8) || DO_UTF8(pat))
2956             pm->op_pmdynflags |= PMdf_UTF8;
2957         pm->op_pmregexp = CALLREGCOMP(aTHX_ p, p + plen, pm);
2958         if (strEQ("\\s+", pm->op_pmregexp->precomp))
2959             pm->op_pmflags |= PMf_WHITE;
2960         op_free(expr);
2961     }
2962     else {
2963         if (PL_hints & HINT_UTF8)
2964             pm->op_pmdynflags |= PMdf_UTF8;
2965         if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
2966             expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
2967                             ? OP_REGCRESET
2968                             : OP_REGCMAYBE),0,expr);
2969
2970         NewOp(1101, rcop, 1, LOGOP);
2971         rcop->op_type = OP_REGCOMP;
2972         rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
2973         rcop->op_first = scalar(expr);
2974         rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
2975                            ? (OPf_SPECIAL | OPf_KIDS)
2976                            : OPf_KIDS);
2977         rcop->op_private = 1;
2978         rcop->op_other = o;
2979
2980         /* establish postfix order */
2981         if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
2982             LINKLIST(expr);
2983             rcop->op_next = expr;
2984             ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
2985         }
2986         else {
2987             rcop->op_next = LINKLIST(expr);
2988             expr->op_next = (OP*)rcop;
2989         }
2990
2991         prepend_elem(o->op_type, scalar((OP*)rcop), o);
2992     }
2993
2994     if (repl) {
2995         OP *curop;
2996         if (pm->op_pmflags & PMf_EVAL) {
2997             curop = 0;
2998             if (CopLINE(PL_curcop) < PL_multi_end)
2999                 CopLINE_set(PL_curcop, PL_multi_end);
3000         }
3001 #ifdef USE_THREADS
3002         else if (repl->op_type == OP_THREADSV
3003                  && strchr("&`'123456789+",
3004                            PL_threadsv_names[repl->op_targ]))
3005         {
3006             curop = 0;
3007         }
3008 #endif /* USE_THREADS */
3009         else if (repl->op_type == OP_CONST)
3010             curop = repl;
3011         else {
3012             OP *lastop = 0;
3013             for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3014                 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3015 #ifdef USE_THREADS
3016                     if (curop->op_type == OP_THREADSV) {
3017                         repl_has_vars = 1;
3018                         if (strchr("&`'123456789+", curop->op_private))
3019                             break;
3020                     }
3021 #else
3022                     if (curop->op_type == OP_GV) {
3023                         GV *gv = cGVOPx_gv(curop);
3024                         repl_has_vars = 1;
3025                         if (strchr("&`'123456789+", *GvENAME(gv)))
3026                             break;
3027                     }
3028 #endif /* USE_THREADS */
3029                     else if (curop->op_type == OP_RV2CV)
3030                         break;
3031                     else if (curop->op_type == OP_RV2SV ||
3032                              curop->op_type == OP_RV2AV ||
3033                              curop->op_type == OP_RV2HV ||
3034                              curop->op_type == OP_RV2GV) {
3035                         if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3036                             break;
3037                     }
3038                     else if (curop->op_type == OP_PADSV ||
3039                              curop->op_type == OP_PADAV ||
3040                              curop->op_type == OP_PADHV ||
3041                              curop->op_type == OP_PADANY) {
3042                         repl_has_vars = 1;
3043                     }
3044                     else if (curop->op_type == OP_PUSHRE)
3045                         ; /* Okay here, dangerous in newASSIGNOP */
3046                     else
3047                         break;
3048                 }
3049                 lastop = curop;
3050             }
3051         }
3052         if (curop == repl
3053             && !(repl_has_vars
3054                  && (!pm->op_pmregexp
3055                      || pm->op_pmregexp->reganch & ROPT_EVAL_SEEN))) {
3056             pm->op_pmflags |= PMf_CONST;        /* const for long enough */
3057             pm->op_pmpermflags |= PMf_CONST;    /* const for long enough */
3058             prepend_elem(o->op_type, scalar(repl), o);
3059         }
3060         else {
3061             if (curop == repl && !pm->op_pmregexp) { /* Has variables. */
3062                 pm->op_pmflags |= PMf_MAYBE_CONST;
3063                 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3064             }
3065             NewOp(1101, rcop, 1, LOGOP);
3066             rcop->op_type = OP_SUBSTCONT;
3067             rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3068             rcop->op_first = scalar(repl);
3069             rcop->op_flags |= OPf_KIDS;
3070             rcop->op_private = 1;
3071             rcop->op_other = o;
3072
3073             /* establish postfix order */
3074             rcop->op_next = LINKLIST(repl);
3075             repl->op_next = (OP*)rcop;
3076
3077             pm->op_pmreplroot = scalar((OP*)rcop);
3078             pm->op_pmreplstart = LINKLIST(rcop);
3079             rcop->op_next = 0;
3080         }
3081     }
3082
3083     return (OP*)pm;
3084 }
3085
3086 OP *
3087 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3088 {
3089     SVOP *svop;
3090     NewOp(1101, svop, 1, SVOP);
3091     svop->op_type = type;
3092     svop->op_ppaddr = PL_ppaddr[type];
3093     svop->op_sv = sv;
3094     svop->op_next = (OP*)svop;
3095     svop->op_flags = flags;
3096     if (PL_opargs[type] & OA_RETSCALAR)
3097         scalar((OP*)svop);
3098     if (PL_opargs[type] & OA_TARGET)
3099         svop->op_targ = pad_alloc(type, SVs_PADTMP);
3100     return CHECKOP(type, svop);
3101 }
3102
3103 OP *
3104 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3105 {
3106     PADOP *padop;
3107     NewOp(1101, padop, 1, PADOP);
3108     padop->op_type = type;
3109     padop->op_ppaddr = PL_ppaddr[type];
3110     padop->op_padix = pad_alloc(type, SVs_PADTMP);
3111     SvREFCNT_dec(PL_curpad[padop->op_padix]);
3112     PL_curpad[padop->op_padix] = sv;
3113     SvPADTMP_on(sv);
3114     padop->op_next = (OP*)padop;
3115     padop->op_flags = flags;
3116     if (PL_opargs[type] & OA_RETSCALAR)
3117         scalar((OP*)padop);
3118     if (PL_opargs[type] & OA_TARGET)
3119         padop->op_targ = pad_alloc(type, SVs_PADTMP);
3120     return CHECKOP(type, padop);
3121 }
3122
3123 OP *
3124 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3125 {
3126 #ifdef USE_ITHREADS
3127     GvIN_PAD_on(gv);
3128     return newPADOP(type, flags, SvREFCNT_inc(gv));
3129 #else
3130     return newSVOP(type, flags, SvREFCNT_inc(gv));
3131 #endif
3132 }
3133
3134 OP *
3135 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3136 {
3137     PVOP *pvop;
3138     NewOp(1101, pvop, 1, PVOP);
3139     pvop->op_type = type;
3140     pvop->op_ppaddr = PL_ppaddr[type];
3141     pvop->op_pv = pv;
3142     pvop->op_next = (OP*)pvop;
3143     pvop->op_flags = flags;
3144     if (PL_opargs[type] & OA_RETSCALAR)
3145         scalar((OP*)pvop);
3146     if (PL_opargs[type] & OA_TARGET)
3147         pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3148     return CHECKOP(type, pvop);
3149 }
3150
3151 void
3152 Perl_package(pTHX_ OP *o)
3153 {
3154     SV *sv;
3155
3156     save_hptr(&PL_curstash);
3157     save_item(PL_curstname);
3158     if (o) {
3159         STRLEN len;
3160         char *name;
3161         sv = cSVOPo->op_sv;
3162         name = SvPV(sv, len);
3163         PL_curstash = gv_stashpvn(name,len,TRUE);
3164         sv_setpvn(PL_curstname, name, len);
3165         op_free(o);
3166     }
3167     else {
3168         sv_setpv(PL_curstname,"<none>");
3169         PL_curstash = Nullhv;
3170     }
3171     PL_hints |= HINT_BLOCK_SCOPE;
3172     PL_copline = NOLINE;
3173     PL_expect = XSTATE;
3174 }
3175
3176 void
3177 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
3178 {
3179     OP *pack;
3180     OP *rqop;
3181     OP *imop;
3182     OP *veop;
3183     GV *gv;
3184
3185     if (id->op_type != OP_CONST)
3186         Perl_croak(aTHX_ "Module name must be constant");
3187
3188     veop = Nullop;
3189
3190     if (version != Nullop) {
3191         SV *vesv = ((SVOP*)version)->op_sv;
3192
3193         if (arg == Nullop && !SvNIOKp(vesv)) {
3194             arg = version;
3195         }
3196         else {
3197             OP *pack;
3198             SV *meth;
3199
3200             if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3201                 Perl_croak(aTHX_ "Version number must be constant number");
3202
3203             /* Make copy of id so we don't free it twice */
3204             pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3205
3206             /* Fake up a method call to VERSION */
3207             meth = newSVpvn("VERSION",7);
3208             sv_upgrade(meth, SVt_PVIV);
3209             (void)SvIOK_on(meth);
3210             PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3211             veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3212                             append_elem(OP_LIST,
3213                                         prepend_elem(OP_LIST, pack, list(version)),
3214                                         newSVOP(OP_METHOD_NAMED, 0, meth)));
3215         }
3216     }
3217
3218     /* Fake up an import/unimport */
3219     if (arg && arg->op_type == OP_STUB)
3220         imop = arg;             /* no import on explicit () */
3221     else if (SvNIOKp(((SVOP*)id)->op_sv)) {
3222         imop = Nullop;          /* use 5.0; */
3223     }
3224     else {
3225         SV *meth;
3226
3227         /* Make copy of id so we don't free it twice */
3228         pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3229
3230         /* Fake up a method call to import/unimport */
3231         meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);;
3232         sv_upgrade(meth, SVt_PVIV);
3233         (void)SvIOK_on(meth);
3234         PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3235         imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3236                        append_elem(OP_LIST,
3237                                    prepend_elem(OP_LIST, pack, list(arg)),
3238                                    newSVOP(OP_METHOD_NAMED, 0, meth)));
3239     }
3240
3241     /* Fake up a require, handle override, if any */
3242     gv = gv_fetchpv("require", FALSE, SVt_PVCV);
3243     if (!(gv && GvIMPORTED_CV(gv)))
3244         gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
3245
3246     if (gv && GvIMPORTED_CV(gv)) {
3247         rqop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3248                                append_elem(OP_LIST, id,
3249                                            scalar(newUNOP(OP_RV2CV, 0,
3250                                                           newGVOP(OP_GV, 0,
3251                                                                   gv))))));
3252     }
3253     else {
3254         rqop = newUNOP(OP_REQUIRE, 0, id);
3255     }
3256
3257     /* Fake up the BEGIN {}, which does its thing immediately. */
3258     newATTRSUB(floor,
3259         newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
3260         Nullop,
3261         Nullop,
3262         append_elem(OP_LINESEQ,
3263             append_elem(OP_LINESEQ,
3264                 newSTATEOP(0, Nullch, rqop),
3265                 newSTATEOP(0, Nullch, veop)),
3266             newSTATEOP(0, Nullch, imop) ));
3267
3268     PL_hints |= HINT_BLOCK_SCOPE;
3269     PL_copline = NOLINE;
3270     PL_expect = XSTATE;
3271 }
3272
3273 void
3274 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3275 {
3276     va_list args;
3277     va_start(args, ver);
3278     vload_module(flags, name, ver, &args);
3279     va_end(args);
3280 }
3281
3282 #ifdef PERL_IMPLICIT_CONTEXT
3283 void
3284 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3285 {
3286     dTHX;
3287     va_list args;
3288     va_start(args, ver);
3289     vload_module(flags, name, ver, &args);
3290     va_end(args);
3291 }
3292 #endif
3293
3294 void
3295 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3296 {
3297     OP *modname, *veop, *imop;
3298
3299     modname = newSVOP(OP_CONST, 0, name);
3300     modname->op_private |= OPpCONST_BARE;
3301     if (ver) {
3302         veop = newSVOP(OP_CONST, 0, ver);
3303     }
3304     else
3305         veop = Nullop;
3306     if (flags & PERL_LOADMOD_NOIMPORT) {
3307         imop = sawparens(newNULLLIST());
3308     }
3309     else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3310         imop = va_arg(*args, OP*);
3311     }
3312     else {
3313         SV *sv;
3314         imop = Nullop;
3315         sv = va_arg(*args, SV*);
3316         while (sv) {
3317             imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3318             sv = va_arg(*args, SV*);
3319         }
3320     }
3321     {
3322         line_t ocopline = PL_copline;
3323         int oexpect = PL_expect;
3324
3325         utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3326                 veop, modname, imop);
3327         PL_expect = oexpect;
3328         PL_copline = ocopline;
3329     }
3330 }
3331
3332 OP *
3333 Perl_dofile(pTHX_ OP *term)
3334 {
3335     OP *doop;
3336     GV *gv;
3337
3338     gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3339     if (!(gv && GvIMPORTED_CV(gv)))
3340         gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3341
3342     if (gv && GvIMPORTED_CV(gv)) {
3343         doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3344                                append_elem(OP_LIST, term,
3345                                            scalar(newUNOP(OP_RV2CV, 0,
3346                                                           newGVOP(OP_GV, 0,
3347                                                                   gv))))));
3348     }
3349     else {
3350         doop = newUNOP(OP_DOFILE, 0, scalar(term));
3351     }
3352     return doop;
3353 }
3354
3355 OP *
3356 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3357 {
3358     return newBINOP(OP_LSLICE, flags,
3359             list(force_list(subscript)),
3360             list(force_list(listval)) );
3361 }
3362
3363 STATIC I32
3364 S_list_assignment(pTHX_ register OP *o)
3365 {
3366     if (!o)
3367         return TRUE;
3368
3369     if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3370         o = cUNOPo->op_first;
3371
3372     if (o->op_type == OP_COND_EXPR) {
3373         I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3374         I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3375
3376         if (t && f)
3377             return TRUE;
3378         if (t || f)
3379             yyerror("Assignment to both a list and a scalar");
3380         return FALSE;
3381     }
3382
3383     if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3384         o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3385         o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3386         return TRUE;
3387
3388     if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3389         return TRUE;
3390
3391     if (o->op_type == OP_RV2SV)
3392         return FALSE;
3393
3394     return FALSE;
3395 }
3396
3397 OP *
3398 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3399 {
3400     OP *o;
3401
3402     if (optype) {
3403         if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN) {
3404             return newLOGOP(optype, 0,
3405                 mod(scalar(left), optype),
3406                 newUNOP(OP_SASSIGN, 0, scalar(right)));
3407         }
3408         else {
3409             return newBINOP(optype, OPf_STACKED,
3410                 mod(scalar(left), optype), scalar(right));
3411         }
3412     }
3413
3414     if (list_assignment(left)) {
3415         OP *curop;
3416
3417         PL_modcount = 0;
3418         PL_eval_start = right;  /* Grandfathering $[ assignment here.  Bletch.*/
3419         left = mod(left, OP_AASSIGN);
3420         if (PL_eval_start)
3421             PL_eval_start = 0;
3422         else {
3423             op_free(left);
3424             op_free(right);
3425             return Nullop;
3426         }
3427         curop = list(force_list(left));
3428         o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3429         o->op_private = 0 | (flags >> 8);
3430         for (curop = ((LISTOP*)curop)->op_first;
3431              curop; curop = curop->op_sibling)
3432         {
3433             if (curop->op_type == OP_RV2HV &&
3434                 ((UNOP*)curop)->op_first->op_type != OP_GV) {
3435                 o->op_private |= OPpASSIGN_HASH;
3436                 break;
3437             }
3438         }
3439         if (!(left->op_private & OPpLVAL_INTRO)) {
3440             OP *lastop = o;
3441             PL_generation++;
3442             for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3443                 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3444                     if (curop->op_type == OP_GV) {
3445                         GV *gv = cGVOPx_gv(curop);
3446                         if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3447                             break;
3448                         SvCUR(gv) = PL_generation;
3449                     }
3450                     else if (curop->op_type == OP_PADSV ||
3451                              curop->op_type == OP_PADAV ||
3452                              curop->op_type == OP_PADHV ||
3453                              curop->op_type == OP_PADANY) {
3454                         SV **svp = AvARRAY(PL_comppad_name);
3455                         SV *sv = svp[curop->op_targ];
3456                         if (SvCUR(sv) == PL_generation)
3457                             break;
3458                         SvCUR(sv) = PL_generation;      /* (SvCUR not used any more) */
3459                     }
3460                     else if (curop->op_type == OP_RV2CV)
3461                         break;
3462                     else if (curop->op_type == OP_RV2SV ||
3463                              curop->op_type == OP_RV2AV ||
3464                              curop->op_type == OP_RV2HV ||
3465                              curop->op_type == OP_RV2GV) {
3466                         if (lastop->op_type != OP_GV)   /* funny deref? */
3467                             break;
3468                     }
3469                     else if (curop->op_type == OP_PUSHRE) {
3470                         if (((PMOP*)curop)->op_pmreplroot) {
3471 #ifdef USE_ITHREADS
3472                             GV *gv = (GV*)PL_curpad[(PADOFFSET)((PMOP*)curop)->op_pmreplroot];
3473 #else
3474                             GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3475 #endif
3476                             if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3477                                 break;
3478                             SvCUR(gv) = PL_generation;
3479                         }
3480                     }
3481                     else
3482                         break;
3483                 }
3484                 lastop = curop;
3485             }
3486             if (curop != o)
3487                 o->op_private |= OPpASSIGN_COMMON;
3488         }
3489         if (right && right->op_type == OP_SPLIT) {
3490             OP* tmpop;
3491             if ((tmpop = ((LISTOP*)right)->op_first) &&
3492                 tmpop->op_type == OP_PUSHRE)
3493             {
3494                 PMOP *pm = (PMOP*)tmpop;
3495                 if (left->op_type == OP_RV2AV &&
3496                     !(left->op_private & OPpLVAL_INTRO) &&
3497                     !(o->op_private & OPpASSIGN_COMMON) )
3498                 {
3499                     tmpop = ((UNOP*)left)->op_first;
3500                     if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3501 #ifdef USE_ITHREADS
3502                         pm->op_pmreplroot = (OP*)cPADOPx(tmpop)->op_padix;
3503                         cPADOPx(tmpop)->op_padix = 0;   /* steal it */
3504 #else
3505                         pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3506                         cSVOPx(tmpop)->op_sv = Nullsv;  /* steal it */
3507 #endif
3508                         pm->op_pmflags |= PMf_ONCE;
3509                         tmpop = cUNOPo->op_first;       /* to list (nulled) */
3510                         tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3511                         tmpop->op_sibling = Nullop;     /* don't free split */
3512                         right->op_next = tmpop->op_next;  /* fix starting loc */
3513                         op_free(o);                     /* blow off assign */
3514                         right->op_flags &= ~OPf_WANT;
3515                                 /* "I don't know and I don't care." */
3516                         return right;
3517                     }
3518                 }
3519                 else {
3520                    if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3521                       ((LISTOP*)right)->op_last->op_type == OP_CONST)
3522                     {
3523                         SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3524                         if (SvIVX(sv) == 0)
3525                             sv_setiv(sv, PL_modcount+1);
3526                     }
3527                 }
3528             }
3529         }
3530         return o;
3531     }
3532     if (!right)
3533         right = newOP(OP_UNDEF, 0);
3534     if (right->op_type == OP_READLINE) {
3535         right->op_flags |= OPf_STACKED;
3536         return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3537     }
3538     else {
3539         PL_eval_start = right;  /* Grandfathering $[ assignment here.  Bletch.*/
3540         o = newBINOP(OP_SASSIGN, flags,
3541             scalar(right), mod(scalar(left), OP_SASSIGN) );
3542         if (PL_eval_start)
3543             PL_eval_start = 0;
3544         else {
3545             op_free(o);
3546             return Nullop;
3547         }
3548     }
3549     return o;
3550 }
3551
3552 OP *
3553 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3554 {
3555     U32 seq = intro_my();
3556     register COP *cop;
3557
3558     NewOp(1101, cop, 1, COP);
3559     if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3560         cop->op_type = OP_DBSTATE;
3561         cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3562     }
3563     else {
3564         cop->op_type = OP_NEXTSTATE;
3565         cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3566     }
3567     cop->op_flags = flags;
3568     cop->op_private = (PL_hints & HINT_BYTE);
3569 #ifdef NATIVE_HINTS
3570     cop->op_private |= NATIVE_HINTS;
3571 #endif
3572     PL_compiling.op_private = cop->op_private;
3573     cop->op_next = (OP*)cop;
3574
3575     if (label) {
3576         cop->cop_label = label;
3577         PL_hints |= HINT_BLOCK_SCOPE;
3578     }
3579     cop->cop_seq = seq;
3580     cop->cop_arybase = PL_curcop->cop_arybase;
3581     if (specialWARN(PL_curcop->cop_warnings))
3582         cop->cop_warnings = PL_curcop->cop_warnings ;
3583     else
3584         cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3585     if (specialCopIO(PL_curcop->cop_io))
3586         cop->cop_io = PL_curcop->cop_io;
3587     else
3588         cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3589
3590
3591     if (PL_copline == NOLINE)
3592         CopLINE_set(cop, CopLINE(PL_curcop));
3593     else {
3594         CopLINE_set(cop, PL_copline);
3595         PL_copline = NOLINE;
3596     }
3597 #ifdef USE_ITHREADS
3598     CopFILE_set(cop, CopFILE(PL_curcop));       /* XXX share in a pvtable? */
3599 #else
3600     CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3601 #endif
3602     CopSTASH_set(cop, PL_curstash);
3603
3604     if (PERLDB_LINE && PL_curstash != PL_debstash) {
3605         SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3606         if (svp && *svp != &PL_sv_undef && !SvIOK(*svp)) {
3607             (void)SvIOK_on(*svp);
3608             SvIVX(*svp) = PTR2IV(cop);
3609         }
3610     }
3611
3612     return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3613 }
3614
3615 /* "Introduce" my variables to visible status. */
3616 U32
3617 Perl_intro_my(pTHX)
3618 {
3619     SV **svp;
3620     SV *sv;
3621     I32 i;
3622
3623     if (! PL_min_intro_pending)
3624         return PL_cop_seqmax;
3625
3626     svp = AvARRAY(PL_comppad_name);
3627     for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
3628         if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) {
3629             SvIVX(sv) = PAD_MAX;        /* Don't know scope end yet. */
3630             SvNVX(sv) = (NV)PL_cop_seqmax;
3631         }
3632     }
3633     PL_min_intro_pending = 0;
3634     PL_comppad_name_fill = PL_max_intro_pending;        /* Needn't search higher */
3635     return PL_cop_seqmax++;
3636 }
3637
3638 OP *
3639 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3640 {
3641     return new_logop(type, flags, &first, &other);
3642 }
3643
3644 STATIC OP *
3645 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3646 {
3647     LOGOP *logop;
3648     OP *o;
3649     OP *first = *firstp;
3650     OP *other = *otherp;
3651
3652     if (type == OP_XOR)         /* Not short circuit, but here by precedence. */
3653         return newBINOP(type, flags, scalar(first), scalar(other));
3654
3655     scalarboolean(first);
3656     /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3657     if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3658         if (type == OP_AND || type == OP_OR) {
3659             if (type == OP_AND)
3660                 type = OP_OR;
3661             else
3662                 type = OP_AND;
3663             o = first;
3664             first = *firstp = cUNOPo->op_first;
3665             if (o->op_next)
3666                 first->op_next = o->op_next;
3667             cUNOPo->op_first = Nullop;
3668             op_free(o);
3669         }
3670     }
3671     if (first->op_type == OP_CONST) {
3672         if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3673             Perl_warner(aTHX_ WARN_BAREWORD, "Bareword found in conditional");
3674         if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3675             op_free(first);
3676             *firstp = Nullop;
3677             return other;
3678         }
3679         else {
3680             op_free(other);
3681             *otherp = Nullop;
3682             return first;
3683         }
3684     }
3685     else if (first->op_type == OP_WANTARRAY) {
3686         if (type == OP_AND)
3687             list(other);
3688         else
3689             scalar(other);
3690     }
3691     else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
3692         OP *k1 = ((UNOP*)first)->op_first;
3693         OP *k2 = k1->op_sibling;
3694         OPCODE warnop = 0;
3695         switch (first->op_type)
3696         {
3697         case OP_NULL:
3698             if (k2 && k2->op_type == OP_READLINE
3699                   && (k2->op_flags & OPf_STACKED)
3700                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3701             {
3702                 warnop = k2->op_type;
3703             }
3704             break;
3705
3706         case OP_SASSIGN:
3707             if (k1->op_type == OP_READDIR
3708                   || k1->op_type == OP_GLOB
3709                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3710                   || k1->op_type == OP_EACH)
3711             {
3712                 warnop = ((k1->op_type == OP_NULL)
3713                           ? k1->op_targ : k1->op_type);
3714             }
3715             break;
3716         }
3717         if (warnop) {
3718             line_t oldline = CopLINE(PL_curcop);
3719             CopLINE_set(PL_curcop, PL_copline);
3720             Perl_warner(aTHX_ WARN_MISC,
3721                  "Value of %s%s can be \"0\"; test with defined()",
3722                  PL_op_desc[warnop],
3723                  ((warnop == OP_READLINE || warnop == OP_GLOB)
3724                   ? " construct" : "() operator"));
3725             CopLINE_set(PL_curcop, oldline);
3726         }
3727     }
3728
3729     if (!other)
3730         return first;
3731
3732     if (type == OP_ANDASSIGN || type == OP_ORASSIGN)
3733         other->op_private |= OPpASSIGN_BACKWARDS;  /* other is an OP_SASSIGN */
3734
3735     NewOp(1101, logop, 1, LOGOP);
3736
3737     logop->op_type = type;
3738     logop->op_ppaddr = PL_ppaddr[type];
3739     logop->op_first = first;
3740     logop->op_flags = flags | OPf_KIDS;
3741     logop->op_other = LINKLIST(other);
3742     logop->op_private = 1 | (flags >> 8);
3743
3744     /* establish postfix order */
3745     logop->op_next = LINKLIST(first);
3746     first->op_next = (OP*)logop;
3747     first->op_sibling = other;
3748
3749     o = newUNOP(OP_NULL, 0, (OP*)logop);
3750     other->op_next = o;
3751
3752     return o;
3753 }
3754
3755 OP *
3756 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3757 {
3758     LOGOP *logop;
3759     OP *start;
3760     OP *o;
3761
3762     if (!falseop)
3763         return newLOGOP(OP_AND, 0, first, trueop);
3764     if (!trueop)
3765         return newLOGOP(OP_OR, 0, first, falseop);
3766
3767     scalarboolean(first);
3768     if (first->op_type == OP_CONST) {
3769         if (SvTRUE(((SVOP*)first)->op_sv)) {
3770             op_free(first);
3771             op_free(falseop);
3772             return trueop;
3773         }
3774         else {
3775             op_free(first);
3776             op_free(trueop);
3777             return falseop;
3778         }
3779     }
3780     else if (first->op_type == OP_WANTARRAY) {
3781         list(trueop);
3782         scalar(falseop);
3783     }
3784     NewOp(1101, logop, 1, LOGOP);
3785     logop->op_type = OP_COND_EXPR;
3786     logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3787     logop->op_first = first;
3788     logop->op_flags = flags | OPf_KIDS;
3789     logop->op_private = 1 | (flags >> 8);
3790     logop->op_other = LINKLIST(trueop);
3791     logop->op_next = LINKLIST(falseop);
3792
3793
3794     /* establish postfix order */
3795     start = LINKLIST(first);
3796     first->op_next = (OP*)logop;
3797
3798     first->op_sibling = trueop;
3799     trueop->op_sibling = falseop;
3800     o = newUNOP(OP_NULL, 0, (OP*)logop);
3801
3802     trueop->op_next = falseop->op_next = o;
3803
3804     o->op_next = start;
3805     return o;
3806 }
3807
3808 OP *
3809 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
3810 {
3811     LOGOP *range;
3812     OP *flip;
3813     OP *flop;
3814     OP *leftstart;
3815     OP *o;
3816
3817     NewOp(1101, range, 1, LOGOP);
3818
3819     range->op_type = OP_RANGE;
3820     range->op_ppaddr = PL_ppaddr[OP_RANGE];
3821     range->op_first = left;
3822     range->op_flags = OPf_KIDS;
3823     leftstart = LINKLIST(left);
3824     range->op_other = LINKLIST(right);
3825     range->op_private = 1 | (flags >> 8);
3826
3827     left->op_sibling = right;
3828
3829     range->op_next = (OP*)range;
3830     flip = newUNOP(OP_FLIP, flags, (OP*)range);
3831     flop = newUNOP(OP_FLOP, 0, flip);
3832     o = newUNOP(OP_NULL, 0, flop);
3833     linklist(flop);
3834     range->op_next = leftstart;
3835
3836     left->op_next = flip;
3837     right->op_next = flop;
3838
3839     range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3840     sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
3841     flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
3842     sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
3843
3844     flip->op_private =  left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3845     flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
3846
3847     flip->op_next = o;
3848     if (!flip->op_private || !flop->op_private)
3849         linklist(o);            /* blow off optimizer unless constant */
3850
3851     return o;
3852 }
3853
3854 OP *
3855 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
3856 {
3857     OP* listop;
3858     OP* o;
3859     int once = block && block->op_flags & OPf_SPECIAL &&
3860       (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
3861
3862     if (expr) {
3863         if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
3864             return block;       /* do {} while 0 does once */
3865         if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3866             || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
3867             expr = newUNOP(OP_DEFINED, 0,
3868                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3869         } else if (expr->op_flags & OPf_KIDS) {
3870             OP *k1 = ((UNOP*)expr)->op_first;
3871             OP *k2 = (k1) ? k1->op_sibling : NULL;
3872             switch (expr->op_type) {
3873               case OP_NULL:
3874                 if (k2 && k2->op_type == OP_READLINE
3875                       && (k2->op_flags & OPf_STACKED)
3876                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3877                     expr = newUNOP(OP_DEFINED, 0, expr);
3878                 break;
3879
3880               case OP_SASSIGN:
3881                 if (k1->op_type == OP_READDIR
3882                       || k1->op_type == OP_GLOB
3883                       || (k1->op_type == OP_NULL && k1->op_targ == OP_NULL)
3884                       || k1->op_type == OP_EACH)
3885                     expr = newUNOP(OP_DEFINED, 0, expr);
3886                 break;
3887             }
3888         }
3889     }
3890
3891     listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
3892     o = new_logop(OP_AND, 0, &expr, &listop);
3893
3894     if (listop)
3895         ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
3896
3897     if (once && o != listop)
3898         o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
3899
3900     if (o == listop)
3901         o = newUNOP(OP_NULL, 0, o);     /* or do {} while 1 loses outer block */
3902
3903     o->op_flags |= flags;
3904     o = scope(o);
3905     o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
3906     return o;
3907 }
3908
3909 OP *
3910 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
3911 {
3912     OP *redo;
3913     OP *next = 0;
3914     OP *listop;
3915     OP *o;
3916     OP *condop;
3917     U8 loopflags = 0;
3918
3919     if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
3920                  || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
3921         expr = newUNOP(OP_DEFINED, 0,
3922             newASSIGNOP(0, newDEFSVOP(), 0, expr) );
3923     } else if (expr && (expr->op_flags & OPf_KIDS)) {
3924         OP *k1 = ((UNOP*)expr)->op_first;
3925         OP *k2 = (k1) ? k1->op_sibling : NULL;
3926         switch (expr->op_type) {
3927           case OP_NULL:
3928             if (k2 && k2->op_type == OP_READLINE
3929                   && (k2->op_flags & OPf_STACKED)
3930                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3931                 expr = newUNOP(OP_DEFINED, 0, expr);
3932             break;
3933
3934           case OP_SASSIGN:
3935             if (k1->op_type == OP_READDIR
3936                   || k1->op_type == OP_GLOB
3937                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3938                   || k1->op_type == OP_EACH)
3939                 expr = newUNOP(OP_DEFINED, 0, expr);
3940             break;
3941         }
3942     }
3943
3944     if (!block)
3945         block = newOP(OP_NULL, 0);
3946     else if (cont) {
3947         block = scope(block);
3948     }
3949
3950     if (cont) {
3951         next = LINKLIST(cont);
3952     }
3953     if (expr) {
3954         OP *unstack = newOP(OP_UNSTACK, 0);
3955         if (!next)
3956             next = unstack;
3957         cont = append_elem(OP_LINESEQ, cont, unstack);
3958         if ((line_t)whileline != NOLINE) {
3959             PL_copline = whileline;
3960             cont = append_elem(OP_LINESEQ, cont,
3961                                newSTATEOP(0, Nullch, Nullop));
3962         }
3963     }
3964
3965     listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
3966     redo = LINKLIST(listop);
3967
3968     if (expr) {
3969         PL_copline = whileline;
3970         scalar(listop);
3971         o = new_logop(OP_AND, 0, &expr, &listop);
3972         if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
3973             op_free(expr);              /* oops, it's a while (0) */
3974             op_free((OP*)loop);
3975             return Nullop;              /* listop already freed by new_logop */
3976         }
3977         if (listop)
3978             ((LISTOP*)listop)->op_last->op_next = condop =
3979                 (o == listop ? redo : LINKLIST(o));
3980     }
3981     else
3982         o = listop;
3983
3984     if (!loop) {
3985         NewOp(1101,loop,1,LOOP);
3986         loop->op_type = OP_ENTERLOOP;
3987         loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
3988         loop->op_private = 0;
3989         loop->op_next = (OP*)loop;
3990     }
3991
3992     o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
3993
3994     loop->op_redoop = redo;
3995     loop->op_lastop = o;
3996     o->op_private |= loopflags;
3997
3998     if (next)
3999         loop->op_nextop = next;
4000     else
4001         loop->op_nextop = o;
4002
4003     o->op_flags |= flags;
4004     o->op_private |= (flags >> 8);
4005     return o;
4006 }
4007
4008 OP *
4009 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
4010 {
4011     LOOP *loop;
4012     OP *wop;
4013     int padoff = 0;
4014     I32 iterflags = 0;
4015
4016     if (sv) {
4017         if (sv->op_type == OP_RV2SV) {  /* symbol table variable */
4018             sv->op_type = OP_RV2GV;
4019             sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4020         }
4021         else if (sv->op_type == OP_PADSV) { /* private variable */
4022             padoff = sv->op_targ;
4023             sv->op_targ = 0;
4024             op_free(sv);
4025             sv = Nullop;
4026         }
4027         else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4028             padoff = sv->op_targ;
4029             sv->op_targ = 0;
4030             iterflags |= OPf_SPECIAL;
4031             op_free(sv);
4032             sv = Nullop;
4033         }
4034         else
4035             Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4036     }
4037     else {
4038 #ifdef USE_THREADS
4039         padoff = find_threadsv("_");
4040         iterflags |= OPf_SPECIAL;
4041 #else
4042         sv = newGVOP(OP_GV, 0, PL_defgv);
4043 #endif
4044     }
4045     if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4046         expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4047         iterflags |= OPf_STACKED;
4048     }
4049     else if (expr->op_type == OP_NULL &&
4050              (expr->op_flags & OPf_KIDS) &&
4051              ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4052     {
4053         /* Basically turn for($x..$y) into the same as for($x,$y), but we
4054          * set the STACKED flag to indicate that these values are to be
4055          * treated as min/max values by 'pp_iterinit'.
4056          */
4057         UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4058         LOGOP* range = (LOGOP*) flip->op_first;
4059         OP* left  = range->op_first;
4060         OP* right = left->op_sibling;
4061         LISTOP* listop;
4062
4063         range->op_flags &= ~OPf_KIDS;
4064         range->op_first = Nullop;
4065
4066         listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4067         listop->op_first->op_next = range->op_next;
4068         left->op_next = range->op_other;
4069         right->op_next = (OP*)listop;
4070         listop->op_next = listop->op_first;
4071
4072         op_free(expr);
4073         expr = (OP*)(listop);
4074         null(expr);
4075         iterflags |= OPf_STACKED;
4076     }
4077     else {
4078         expr = mod(force_list(expr), OP_GREPSTART);
4079     }
4080
4081
4082     loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4083                                append_elem(OP_LIST, expr, scalar(sv))));
4084     assert(!loop->op_next);
4085 #ifdef PL_OP_SLAB_ALLOC
4086     {
4087         LOOP *tmp;
4088         NewOp(1234,tmp,1,LOOP);
4089         Copy(loop,tmp,1,LOOP);
4090         loop = tmp;
4091     }
4092 #else
4093     Renew(loop, 1, LOOP);
4094 #endif
4095     loop->op_targ = padoff;
4096     wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
4097     PL_copline = forline;
4098     return newSTATEOP(0, label, wop);
4099 }
4100
4101 OP*
4102 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4103 {
4104     OP *o;
4105     STRLEN n_a;
4106
4107     if (type != OP_GOTO || label->op_type == OP_CONST) {
4108         /* "last()" means "last" */
4109         if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4110             o = newOP(type, OPf_SPECIAL);
4111         else {
4112             o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4113                                         ? SvPVx(((SVOP*)label)->op_sv, n_a)
4114                                         : ""));
4115         }
4116         op_free(label);
4117     }
4118     else {
4119         if (label->op_type == OP_ENTERSUB)
4120             label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4121         o = newUNOP(type, OPf_STACKED, label);
4122     }
4123     PL_hints |= HINT_BLOCK_SCOPE;
4124     return o;
4125 }
4126
4127 void
4128 Perl_cv_undef(pTHX_ CV *cv)
4129 {
4130 #ifdef USE_THREADS
4131     if (CvMUTEXP(cv)) {
4132         MUTEX_DESTROY(CvMUTEXP(cv));
4133         Safefree(CvMUTEXP(cv));
4134         CvMUTEXP(cv) = 0;
4135     }
4136 #endif /* USE_THREADS */
4137
4138     if (!CvXSUB(cv) && CvROOT(cv)) {
4139 #ifdef USE_THREADS
4140         if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr))
4141             Perl_croak(aTHX_ "Can't undef active subroutine");
4142 #else
4143         if (CvDEPTH(cv))
4144             Perl_croak(aTHX_ "Can't undef active subroutine");
4145 #endif /* USE_THREADS */
4146         ENTER;
4147
4148         SAVEVPTR(PL_curpad);
4149         PL_curpad = 0;
4150
4151         if (!CvCLONED(cv))
4152             op_free(CvROOT(cv));
4153         CvROOT(cv) = Nullop;
4154         LEAVE;
4155     }
4156     SvPOK_off((SV*)cv);         /* forget prototype */
4157     CvFLAGS(cv) = 0;
4158     SvREFCNT_dec(CvGV(cv));
4159     CvGV(cv) = Nullgv;
4160     SvREFCNT_dec(CvOUTSIDE(cv));
4161     CvOUTSIDE(cv) = Nullcv;
4162     if (CvCONST(cv)) {
4163         SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4164         CvCONST_off(cv);
4165     }
4166     if (CvPADLIST(cv)) {
4167         /* may be during global destruction */
4168         if (SvREFCNT(CvPADLIST(cv))) {
4169             I32 i = AvFILLp(CvPADLIST(cv));
4170             while (i >= 0) {
4171                 SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE);
4172                 SV* sv = svp ? *svp : Nullsv;
4173                 if (!sv)
4174                     continue;
4175                 if (sv == (SV*)PL_comppad_name)
4176                     PL_comppad_name = Nullav;
4177                 else if (sv == (SV*)PL_comppad) {
4178                     PL_comppad = Nullav;
4179                     PL_curpad = Null(SV**);
4180                 }
4181                 SvREFCNT_dec(sv);
4182             }
4183             SvREFCNT_dec((SV*)CvPADLIST(cv));
4184         }
4185         CvPADLIST(cv) = Nullav;
4186     }
4187 }
4188
4189 #ifdef DEBUG_CLOSURES
4190 STATIC void
4191 S_cv_dump(pTHX_ CV *cv)
4192 {
4193 #ifdef DEBUGGING
4194     CV *outside = CvOUTSIDE(cv);
4195     AV* padlist = CvPADLIST(cv);
4196     AV* pad_name;
4197     AV* pad;
4198     SV** pname;
4199     SV** ppad;
4200     I32 ix;
4201
4202     PerlIO_printf(Perl_debug_log,
4203                   "\tCV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
4204                   PTR2UV(cv),
4205                   (CvANON(cv) ? "ANON"
4206                    : (cv == PL_main_cv) ? "MAIN"
4207                    : CvUNIQUE(cv) ? "UNIQUE"
4208                    : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
4209                   PTR2UV(outside),
4210                   (!outside ? "null"
4211                    : CvANON(outside) ? "ANON"
4212                    : (outside == PL_main_cv) ? "MAIN"
4213                    : CvUNIQUE(outside) ? "UNIQUE"
4214                    : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
4215
4216     if (!padlist)
4217         return;
4218
4219     pad_name = (AV*)*av_fetch(padlist, 0, FALSE);
4220     pad = (AV*)*av_fetch(padlist, 1, FALSE);
4221     pname = AvARRAY(pad_name);
4222     ppad = AvARRAY(pad);
4223
4224     for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
4225         if (SvPOK(pname[ix]))
4226             PerlIO_printf(Perl_debug_log,
4227                           "\t%4d. 0x%"UVxf" (%s\"%s\" %"IVdf"-%"IVdf")\n",
4228                           (int)ix, PTR2UV(ppad[ix]),
4229                           SvFAKE(pname[ix]) ? "FAKE " : "",
4230                           SvPVX(pname[ix]),
4231                           (IV)I_32(SvNVX(pname[ix])),
4232                           SvIVX(pname[ix]));
4233     }
4234 #endif /* DEBUGGING */
4235 }
4236 #endif /* DEBUG_CLOSURES */
4237
4238 STATIC CV *
4239 S_cv_clone2(pTHX_ CV *proto, CV *outside)
4240 {
4241     AV* av;
4242     I32 ix;
4243     AV* protopadlist = CvPADLIST(proto);
4244     AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
4245     AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
4246     SV** pname = AvARRAY(protopad_name);
4247     SV** ppad = AvARRAY(protopad);
4248     I32 fname = AvFILLp(protopad_name);
4249     I32 fpad = AvFILLp(protopad);
4250     AV* comppadlist;
4251     CV* cv;
4252
4253     assert(!CvUNIQUE(proto));
4254
4255     ENTER;
4256     SAVECOMPPAD();
4257     SAVESPTR(PL_comppad_name);
4258     SAVESPTR(PL_compcv);
4259
4260     cv = PL_compcv = (CV*)NEWSV(1104,0);
4261     sv_upgrade((SV *)cv, SvTYPE(proto));
4262     CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
4263     CvCLONED_on(cv);
4264
4265 #ifdef USE_THREADS
4266     New(666, CvMUTEXP(cv), 1, perl_mutex);
4267     MUTEX_INIT(CvMUTEXP(cv));
4268     CvOWNER(cv)         = 0;
4269 #endif /* USE_THREADS */
4270     CvFILE(cv)          = CvFILE(proto);
4271     CvGV(cv)            = (GV*)SvREFCNT_inc(CvGV(proto));
4272     CvSTASH(cv)         = CvSTASH(proto);
4273     CvROOT(cv)          = CvROOT(proto);
4274     CvSTART(cv)         = CvSTART(proto);
4275     if (outside)
4276         CvOUTSIDE(cv)   = (CV*)SvREFCNT_inc(outside);
4277
4278     if (SvPOK(proto))
4279         sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
4280
4281     PL_comppad_name = newAV();
4282     for (ix = fname; ix >= 0; ix--)
4283         av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
4284
4285     PL_comppad = newAV();
4286
4287     comppadlist = newAV();
4288     AvREAL_off(comppadlist);
4289     av_store(comppadlist, 0, (SV*)PL_comppad_name);
4290     av_store(comppadlist, 1, (SV*)PL_comppad);
4291     CvPADLIST(cv) = comppadlist;
4292     av_fill(PL_comppad, AvFILLp(protopad));
4293     PL_curpad = AvARRAY(PL_comppad);
4294
4295     av = newAV();           /* will be @_ */
4296     av_extend(av, 0);
4297     av_store(PL_comppad, 0, (SV*)av);
4298     AvFLAGS(av) = AVf_REIFY;
4299
4300     for (ix = fpad; ix > 0; ix--) {
4301         SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4302         if (namesv && namesv != &PL_sv_undef) {
4303             char *name = SvPVX(namesv);    /* XXX */
4304             if (SvFLAGS(namesv) & SVf_FAKE) {   /* lexical from outside? */
4305                 I32 off = pad_findlex(name, ix, SvIVX(namesv),
4306                                       CvOUTSIDE(cv), cxstack_ix, 0, 0);
4307                 if (!off)
4308                     PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4309                 else if (off != ix)
4310                     Perl_croak(aTHX_ "panic: cv_clone: %s", name);
4311             }
4312             else {                              /* our own lexical */
4313                 SV* sv;
4314                 if (*name == '&') {
4315                     /* anon code -- we'll come back for it */
4316                     sv = SvREFCNT_inc(ppad[ix]);
4317                 }
4318                 else if (*name == '@')
4319                     sv = (SV*)newAV();
4320                 else if (*name == '%')
4321                     sv = (SV*)newHV();
4322                 else
4323                     sv = NEWSV(0,0);
4324                 if (!SvPADBUSY(sv))
4325                     SvPADMY_on(sv);
4326                 PL_curpad[ix] = sv;
4327             }
4328         }
4329         else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
4330             PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4331         }
4332         else {
4333             SV* sv = NEWSV(0,0);
4334             SvPADTMP_on(sv);
4335             PL_curpad[ix] = sv;
4336         }
4337     }
4338
4339     /* Now that vars are all in place, clone nested closures. */
4340
4341     for (ix = fpad; ix > 0; ix--) {
4342         SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4343         if (namesv
4344             && namesv != &PL_sv_undef
4345             && !(SvFLAGS(namesv) & SVf_FAKE)
4346             && *SvPVX(namesv) == '&'
4347             && CvCLONE(ppad[ix]))
4348         {
4349             CV *kid = cv_clone2((CV*)ppad[ix], cv);
4350             SvREFCNT_dec(ppad[ix]);
4351             CvCLONE_on(kid);
4352             SvPADMY_on(kid);
4353             PL_curpad[ix] = (SV*)kid;
4354         }
4355     }
4356
4357 #ifdef DEBUG_CLOSURES
4358     PerlIO_printf(Perl_debug_log, "Cloned inside:\n");
4359     cv_dump(outside);
4360     PerlIO_printf(Perl_debug_log, "  from:\n");
4361     cv_dump(proto);
4362     PerlIO_printf(Perl_debug_log, "   to:\n");
4363     cv_dump(cv);
4364 #endif
4365
4366     LEAVE;
4367
4368     if (CvCONST(cv)) {
4369         SV* const_sv = op_const_sv(CvSTART(cv), cv);
4370         assert(const_sv);
4371         /* constant sub () { $x } closing over $x - see lib/constant.pm */
4372         SvREFCNT_dec(cv);
4373         cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
4374     }
4375
4376     return cv;
4377 }
4378
4379 CV *
4380 Perl_cv_clone(pTHX_ CV *proto)
4381 {
4382     CV *cv;
4383     LOCK_CRED_MUTEX;                    /* XXX create separate mutex */
4384     cv = cv_clone2(proto, CvOUTSIDE(proto));
4385     UNLOCK_CRED_MUTEX;                  /* XXX create separate mutex */
4386     return cv;
4387 }
4388
4389 void
4390 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
4391 {
4392     if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4393         SV* msg = sv_newmortal();
4394         SV* name = Nullsv;
4395
4396         if (gv)
4397             gv_efullname3(name = sv_newmortal(), gv, Nullch);
4398         sv_setpv(msg, "Prototype mismatch:");
4399         if (name)
4400             Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4401         if (SvPOK(cv))
4402             Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv));
4403         sv_catpv(msg, " vs ");
4404         if (p)
4405             Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4406         else
4407             sv_catpv(msg, "none");
4408         Perl_warner(aTHX_ WARN_PROTOTYPE, "%"SVf, msg);
4409     }
4410 }
4411
4412 static void const_sv_xsub(pTHXo_ CV* cv);
4413
4414 /*
4415 =for apidoc cv_const_sv
4416
4417 If C<cv> is a constant sub eligible for inlining. returns the constant
4418 value returned by the sub.  Otherwise, returns NULL.
4419
4420 Constant subs can be created with C<newCONSTSUB> or as described in
4421 L<perlsub/"Constant Functions">.
4422
4423 =cut
4424 */
4425 SV *
4426 Perl_cv_const_sv(pTHX_ CV *cv)
4427 {
4428     if (!cv || !CvCONST(cv))
4429         return Nullsv;
4430     return (SV*)CvXSUBANY(cv).any_ptr;
4431 }
4432
4433 SV *
4434 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
4435 {
4436     SV *sv = Nullsv;
4437
4438     if (!o)
4439         return Nullsv;
4440
4441     if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4442         o = cLISTOPo->op_first->op_sibling;
4443
4444     for (; o; o = o->op_next) {
4445         OPCODE type = o->op_type;
4446
4447         if (sv && o->op_next == o)
4448             return sv;
4449         if (o->op_next != o) {
4450             if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4451                 continue;
4452             if (type == OP_DBSTATE)
4453                 continue;
4454         }
4455         if (type == OP_LEAVESUB || type == OP_RETURN)
4456             break;
4457         if (sv)
4458             return Nullsv;
4459         if (type == OP_CONST && cSVOPo->op_sv)
4460             sv = cSVOPo->op_sv;
4461         else if ((type == OP_PADSV || type == OP_CONST) && cv) {
4462             AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
4463             sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
4464             if (!sv)
4465                 return Nullsv;
4466             if (CvCONST(cv)) {
4467                 /* We get here only from cv_clone2() while creating a closure.
4468                    Copy the const value here instead of in cv_clone2 so that
4469                    SvREADONLY_on doesn't lead to problems when leaving
4470                    scope.
4471                 */
4472                 sv = newSVsv(sv);
4473             }
4474             if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
4475                 return Nullsv;
4476         }
4477         else
4478             return Nullsv;
4479     }
4480     if (sv)
4481         SvREADONLY_on(sv);
4482     return sv;
4483 }
4484
4485 void
4486 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4487 {
4488     if (o)
4489         SAVEFREEOP(o);
4490     if (proto)
4491         SAVEFREEOP(proto);
4492     if (attrs)
4493         SAVEFREEOP(attrs);
4494     if (block)
4495         SAVEFREEOP(block);
4496     Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4497 }
4498
4499 CV *
4500 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4501 {
4502     return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4503 }
4504
4505 CV *
4506 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4507 {
4508     STRLEN n_a;
4509     char *name;
4510     char *aname;
4511     GV *gv;
4512     char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4513     register CV *cv=0;
4514     I32 ix;
4515     SV *const_sv;
4516
4517     name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4518     if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4519         SV *sv = sv_newmortal();
4520         Perl_sv_setpvf(aTHX_ sv, "__ANON__[%s:%"IVdf"]",
4521                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4522         aname = SvPVX(sv);
4523     }
4524     else
4525         aname = Nullch;
4526     gv = gv_fetchpv(name ? name : (aname ? aname : "__ANON__"),
4527                     GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4528                     SVt_PVCV);
4529
4530     if (o)
4531         SAVEFREEOP(o);
4532     if (proto)
4533         SAVEFREEOP(proto);
4534     if (attrs)
4535         SAVEFREEOP(attrs);
4536
4537     if (SvTYPE(gv) != SVt_PVGV) {       /* Maybe prototype now, and had at
4538                                            maximum a prototype before. */
4539         if (SvTYPE(gv) > SVt_NULL) {
4540             if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4541                 && ckWARN_d(WARN_PROTOTYPE))
4542             {
4543                 Perl_warner(aTHX_ WARN_PROTOTYPE, "Runaway prototype");
4544             }
4545             cv_ckproto((CV*)gv, NULL, ps);
4546         }
4547         if (ps)
4548             sv_setpv((SV*)gv, ps);
4549         else
4550             sv_setiv((SV*)gv, -1);
4551         SvREFCNT_dec(PL_compcv);
4552         cv = PL_compcv = NULL;
4553         PL_sub_generation++;
4554         goto done;
4555     }
4556
4557     cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4558
4559 #ifdef GV_SHARED_CHECK
4560     if (cv && GvSHARED(gv) && SvREADONLY(cv)) {
4561         Perl_croak(aTHX_ "Can't define subroutine %s (GV is shared)", name);
4562     }
4563 #endif
4564
4565     if (!block || !ps || *ps || attrs)
4566         const_sv = Nullsv;
4567     else
4568         const_sv = op_const_sv(block, Nullcv);
4569
4570     if (cv) {
4571         bool exists = CvROOT(cv) || CvXSUB(cv);
4572
4573 #ifdef GV_SHARED_CHECK
4574         if (exists && GvSHARED(gv)) {
4575             Perl_croak(aTHX_ "Can't redefine shared subroutine %s", name);
4576         }
4577 #endif
4578
4579         /* if the subroutine doesn't exist and wasn't pre-declared
4580          * with a prototype, assume it will be AUTOLOADed,
4581          * skipping the prototype check
4582          */
4583         if (exists || SvPOK(cv))
4584             cv_ckproto(cv, gv, ps);
4585         /* already defined (or promised)? */
4586         if (exists || GvASSUMECV(gv)) {
4587             if (!block && !attrs) {
4588                 /* just a "sub foo;" when &foo is already defined */
4589                 SAVEFREESV(PL_compcv);
4590                 goto done;
4591             }
4592             /* ahem, death to those who redefine active sort subs */
4593             if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4594                 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4595             if (block) {
4596                 if (ckWARN(WARN_REDEFINE)
4597                     || (CvCONST(cv)
4598                         && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4599                 {
4600                     line_t oldline = CopLINE(PL_curcop);
4601                     CopLINE_set(PL_curcop, PL_copline);
4602                     Perl_warner(aTHX_ WARN_REDEFINE,
4603                         CvCONST(cv) ? "Constant subroutine %s redefined"
4604                                     : "Subroutine %s redefined", name);
4605                     CopLINE_set(PL_curcop, oldline);
4606                 }
4607                 SvREFCNT_dec(cv);
4608                 cv = Nullcv;
4609             }
4610         }
4611     }
4612     if (const_sv) {
4613         SvREFCNT_inc(const_sv);
4614         if (cv) {
4615             assert(!CvROOT(cv) && !CvCONST(cv));
4616             sv_setpv((SV*)cv, "");  /* prototype is "" */
4617             CvXSUBANY(cv).any_ptr = const_sv;
4618             CvXSUB(cv) = const_sv_xsub;
4619             CvCONST_on(cv);
4620         }
4621         else {
4622             GvCV(gv) = Nullcv;
4623             cv = newCONSTSUB(NULL, name, const_sv);
4624         }
4625         op_free(block);
4626         SvREFCNT_dec(PL_compcv);
4627         PL_compcv = NULL;
4628         PL_sub_generation++;
4629         goto done;
4630     }
4631     if (attrs) {
4632         HV *stash;
4633         SV *rcv;
4634
4635         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4636          * before we clobber PL_compcv.
4637          */
4638         if (cv && !block) {
4639             rcv = (SV*)cv;
4640             if (CvGV(cv) && GvSTASH(CvGV(cv)) && HvNAME(GvSTASH(CvGV(cv))))
4641                 stash = GvSTASH(CvGV(cv));
4642             else if (CvSTASH(cv) && HvNAME(CvSTASH(cv)))
4643                 stash = CvSTASH(cv);
4644             else
4645                 stash = PL_curstash;
4646         }
4647         else {
4648             /* possibly about to re-define existing subr -- ignore old cv */
4649             rcv = (SV*)PL_compcv;
4650             if (name && GvSTASH(gv) && HvNAME(GvSTASH(gv)))
4651                 stash = GvSTASH(gv);
4652             else
4653                 stash = PL_curstash;
4654         }
4655         apply_attrs(stash, rcv, attrs);
4656     }
4657     if (cv) {                           /* must reuse cv if autoloaded */
4658         if (!block) {
4659             /* got here with just attrs -- work done, so bug out */
4660             SAVEFREESV(PL_compcv);
4661             goto done;
4662         }
4663         cv_undef(cv);
4664         CvFLAGS(cv) = CvFLAGS(PL_compcv);
4665         CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4666         CvOUTSIDE(PL_compcv) = 0;
4667         CvPADLIST(cv) = CvPADLIST(PL_compcv);
4668         CvPADLIST(PL_compcv) = 0;
4669         if (SvREFCNT(PL_compcv) > 1) /* XXX Make closures transit through stub. */
4670             CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc((SV*)cv);
4671         SvREFCNT_dec(PL_compcv);
4672     }
4673     else {
4674         cv = PL_compcv;
4675         if (name) {
4676             GvCV(gv) = cv;
4677             GvCVGEN(gv) = 0;
4678             PL_sub_generation++;
4679         }
4680     }
4681     CvGV(cv) = (GV*)SvREFCNT_inc(gv);
4682     CvFILE(cv) = CopFILE(PL_curcop);
4683     CvSTASH(cv) = PL_curstash;
4684 #ifdef USE_THREADS
4685     CvOWNER(cv) = 0;
4686     if (!CvMUTEXP(cv)) {
4687         New(666, CvMUTEXP(cv), 1, perl_mutex);
4688         MUTEX_INIT(CvMUTEXP(cv));
4689     }
4690 #endif /* USE_THREADS */
4691
4692     if (ps)
4693         sv_setpv((SV*)cv, ps);
4694
4695     if (PL_error_count) {
4696         op_free(block);
4697         block = Nullop;
4698         if (name) {
4699             char *s = strrchr(name, ':');
4700             s = s ? s+1 : name;
4701             if (strEQ(s, "BEGIN")) {
4702                 char *not_safe =
4703                     "BEGIN not safe after errors--compilation aborted";
4704                 if (PL_in_eval & EVAL_KEEPERR)
4705                     Perl_croak(aTHX_ not_safe);
4706                 else {
4707                     /* force display of errors found but not reported */
4708                     sv_catpv(ERRSV, not_safe);
4709                     Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
4710                 }
4711             }
4712         }
4713     }
4714     if (!block)
4715         goto done;
4716
4717     if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
4718         av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
4719
4720     if (CvLVALUE(cv)) {
4721         CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4722                              mod(scalarseq(block), OP_LEAVESUBLV));
4723     }
4724     else {
4725         CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4726     }
4727     CvROOT(cv)->op_private |= OPpREFCOUNTED;
4728     OpREFCNT_set(CvROOT(cv), 1);
4729     CvSTART(cv) = LINKLIST(CvROOT(cv));
4730     CvROOT(cv)->op_next = 0;
4731     peep(CvSTART(cv));
4732
4733     /* now that optimizer has done its work, adjust pad values */
4734     if (CvCLONE(cv)) {
4735         SV **namep = AvARRAY(PL_comppad_name);
4736         for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4737             SV *namesv;
4738
4739             if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4740                 continue;
4741             /*
4742              * The only things that a clonable function needs in its
4743              * pad are references to outer lexicals and anonymous subs.
4744              * The rest are created anew during cloning.
4745              */
4746             if (!((namesv = namep[ix]) != Nullsv &&
4747                   namesv != &PL_sv_undef &&
4748                   (SvFAKE(namesv) ||
4749                    *SvPVX(namesv) == '&')))
4750             {
4751                 SvREFCNT_dec(PL_curpad[ix]);
4752                 PL_curpad[ix] = Nullsv;
4753             }
4754         }
4755         assert(!CvCONST(cv));
4756         if (ps && !*ps && op_const_sv(block, cv))
4757             CvCONST_on(cv);
4758     }
4759     else {
4760         AV *av = newAV();                       /* Will be @_ */
4761         av_extend(av, 0);
4762         av_store(PL_comppad, 0, (SV*)av);
4763         AvFLAGS(av) = AVf_REIFY;
4764
4765         for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4766             if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4767                 continue;
4768             if (!SvPADMY(PL_curpad[ix]))
4769                 SvPADTMP_on(PL_curpad[ix]);
4770         }
4771     }
4772
4773     if (name || aname) {
4774         char *s;
4775         char *tname = (name ? name : aname);
4776
4777         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4778             SV *sv = NEWSV(0,0);
4779             SV *tmpstr = sv_newmortal();
4780             GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4781             CV *pcv;
4782             HV *hv;
4783
4784             Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4785                            CopFILE(PL_curcop),
4786                            (long)PL_subline, (long)CopLINE(PL_curcop));
4787             gv_efullname3(tmpstr, gv, Nullch);
4788             hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4789             hv = GvHVn(db_postponed);
4790             if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4791                 && (pcv = GvCV(db_postponed)))
4792             {
4793                 dSP;
4794                 PUSHMARK(SP);
4795                 XPUSHs(tmpstr);
4796                 PUTBACK;
4797                 call_sv((SV*)pcv, G_DISCARD);
4798             }
4799         }
4800
4801         if ((s = strrchr(tname,':')))
4802             s++;
4803         else
4804             s = tname;
4805
4806         if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4807             goto done;
4808
4809         if (strEQ(s, "BEGIN")) {
4810             I32 oldscope = PL_scopestack_ix;
4811             ENTER;
4812             SAVECOPFILE(&PL_compiling);
4813             SAVECOPLINE(&PL_compiling);
4814             save_svref(&PL_rs);
4815             sv_setsv(PL_rs, PL_nrs);
4816
4817             if (!PL_beginav)
4818                 PL_beginav = newAV();
4819             DEBUG_x( dump_sub(gv) );
4820             av_push(PL_beginav, (SV*)cv);
4821             GvCV(gv) = 0;               /* cv has been hijacked */
4822             call_list(oldscope, PL_beginav);
4823
4824             PL_curcop = &PL_compiling;
4825             PL_compiling.op_private = PL_hints;
4826             LEAVE;
4827         }
4828         else if (strEQ(s, "END") && !PL_error_count) {
4829             if (!PL_endav)
4830                 PL_endav = newAV();
4831             DEBUG_x( dump_sub(gv) );
4832             av_unshift(PL_endav, 1);
4833             av_store(PL_endav, 0, (SV*)cv);
4834             GvCV(gv) = 0;               /* cv has been hijacked */
4835         }
4836         else if (strEQ(s, "CHECK") && !PL_error_count) {
4837             if (!PL_checkav)
4838                 PL_checkav = newAV();
4839             DEBUG_x( dump_sub(gv) );
4840             if (PL_main_start && ckWARN(WARN_VOID))
4841                 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
4842             av_unshift(PL_checkav, 1);
4843             av_store(PL_checkav, 0, (SV*)cv);
4844             GvCV(gv) = 0;               /* cv has been hijacked */
4845         }
4846         else if (strEQ(s, "INIT") && !PL_error_count) {
4847             if (!PL_initav)
4848                 PL_initav = newAV();
4849             DEBUG_x( dump_sub(gv) );
4850             if (PL_main_start && ckWARN(WARN_VOID))
4851                 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
4852             av_push(PL_initav, (SV*)cv);
4853             GvCV(gv) = 0;               /* cv has been hijacked */
4854         }
4855     }
4856
4857   done:
4858     PL_copline = NOLINE;
4859     LEAVE_SCOPE(floor);
4860     return cv;
4861 }
4862
4863 /* XXX unsafe for threads if eval_owner isn't held */
4864 /*
4865 =for apidoc newCONSTSUB
4866
4867 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4868 eligible for inlining at compile-time.
4869
4870 =cut
4871 */
4872
4873 CV *
4874 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
4875 {
4876     CV* cv;
4877
4878     ENTER;
4879
4880     SAVECOPLINE(PL_curcop);
4881     CopLINE_set(PL_curcop, PL_copline);
4882
4883     SAVEHINTS();
4884     PL_hints &= ~HINT_BLOCK_SCOPE;
4885
4886     if (stash) {
4887         SAVESPTR(PL_curstash);
4888         SAVECOPSTASH(PL_curcop);
4889         PL_curstash = stash;
4890 #ifdef USE_ITHREADS
4891         CopSTASHPV(PL_curcop) = stash ? HvNAME(stash) : Nullch;
4892 #else
4893         CopSTASH(PL_curcop) = stash;
4894 #endif
4895     }
4896
4897     cv = newXS(name, const_sv_xsub, __FILE__);
4898     CvXSUBANY(cv).any_ptr = sv;
4899     CvCONST_on(cv);
4900     sv_setpv((SV*)cv, "");  /* prototype is "" */
4901
4902     LEAVE;
4903
4904     return cv;
4905 }
4906
4907 /*
4908 =for apidoc U||newXS
4909
4910 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4911
4912 =cut
4913 */
4914
4915 CV *
4916 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
4917 {
4918     GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV);
4919     register CV *cv;
4920
4921     if ((cv = (name ? GvCV(gv) : Nullcv))) {
4922         if (GvCVGEN(gv)) {
4923             /* just a cached method */
4924             SvREFCNT_dec(cv);
4925             cv = 0;
4926         }
4927         else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4928             /* already defined (or promised) */
4929             if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
4930                             && HvNAME(GvSTASH(CvGV(cv)))
4931                             && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
4932                 line_t oldline = CopLINE(PL_curcop);
4933                 if (PL_copline != NOLINE)
4934                     CopLINE_set(PL_curcop, PL_copline);
4935                 Perl_warner(aTHX_ WARN_REDEFINE,
4936                             CvCONST(cv) ? "Constant subroutine %s redefined"
4937                                         : "Subroutine %s redefined"
4938                             ,name);
4939                 CopLINE_set(PL_curcop, oldline);
4940             }
4941             SvREFCNT_dec(cv);
4942             cv = 0;
4943         }
4944     }
4945
4946     if (cv)                             /* must reuse cv if autoloaded */
4947         cv_undef(cv);
4948     else {
4949         cv = (CV*)NEWSV(1105,0);
4950         sv_upgrade((SV *)cv, SVt_PVCV);
4951         if (name) {
4952             GvCV(gv) = cv;
4953             GvCVGEN(gv) = 0;
4954             PL_sub_generation++;
4955         }
4956     }
4957     CvGV(cv) = (GV*)SvREFCNT_inc(gv);
4958 #ifdef USE_THREADS
4959     New(666, CvMUTEXP(cv), 1, perl_mutex);
4960     MUTEX_INIT(CvMUTEXP(cv));
4961     CvOWNER(cv) = 0;
4962 #endif /* USE_THREADS */
4963     (void)gv_fetchfile(filename);
4964     CvFILE(cv) = filename;      /* NOTE: not copied, as it is expected to be
4965                                    an external constant string */
4966     CvXSUB(cv) = subaddr;
4967
4968     if (name) {
4969         char *s = strrchr(name,':');
4970         if (s)
4971             s++;
4972         else
4973             s = name;
4974
4975         if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4976             goto done;
4977
4978         if (strEQ(s, "BEGIN")) {
4979             if (!PL_beginav)
4980                 PL_beginav = newAV();
4981             av_push(PL_beginav, (SV*)cv);
4982             GvCV(gv) = 0;               /* cv has been hijacked */
4983         }
4984         else if (strEQ(s, "END")) {
4985             if (!PL_endav)
4986                 PL_endav = newAV();
4987             av_unshift(PL_endav, 1);
4988             av_store(PL_endav, 0, (SV*)cv);
4989             GvCV(gv) = 0;               /* cv has been hijacked */
4990         }
4991         else if (strEQ(s, "CHECK")) {
4992             if (!PL_checkav)
4993                 PL_checkav = newAV();
4994             if (PL_main_start && ckWARN(WARN_VOID))
4995                 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
4996             av_unshift(PL_checkav, 1);
4997             av_store(PL_checkav, 0, (SV*)cv);
4998             GvCV(gv) = 0;               /* cv has been hijacked */
4999         }
5000         else if (strEQ(s, "INIT")) {
5001             if (!PL_initav)
5002                 PL_initav = newAV();
5003             if (PL_main_start && ckWARN(WARN_VOID))
5004                 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
5005             av_push(PL_initav, (SV*)cv);
5006             GvCV(gv) = 0;               /* cv has been hijacked */
5007         }
5008     }
5009     else
5010         CvANON_on(cv);
5011
5012 done:
5013     return cv;
5014 }
5015
5016 void
5017 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5018 {
5019     register CV *cv;
5020     char *name;
5021     GV *gv;
5022     I32 ix;
5023     STRLEN n_a;
5024
5025     if (o)
5026         name = SvPVx(cSVOPo->op_sv, n_a);
5027     else
5028         name = "STDOUT";
5029     gv = gv_fetchpv(name,TRUE, SVt_PVFM);
5030 #ifdef GV_SHARED_CHECK
5031     if (GvSHARED(gv)) {
5032         Perl_croak(aTHX_ "Bad symbol for form (GV is shared)");
5033     }
5034 #endif
5035     GvMULTI_on(gv);
5036     if ((cv = GvFORM(gv))) {
5037         if (ckWARN(WARN_REDEFINE)) {
5038             line_t oldline = CopLINE(PL_curcop);
5039
5040             CopLINE_set(PL_curcop, PL_copline);
5041             Perl_warner(aTHX_ WARN_REDEFINE, "Format %s redefined",name);
5042             CopLINE_set(PL_curcop, oldline);
5043         }
5044         SvREFCNT_dec(cv);
5045     }
5046     cv = PL_compcv;
5047     GvFORM(gv) = cv;
5048     CvGV(cv) = (GV*)SvREFCNT_inc(gv);
5049     CvFILE(cv) = CopFILE(PL_curcop);
5050
5051     for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5052         if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
5053             SvPADTMP_on(PL_curpad[ix]);
5054     }
5055
5056     CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5057     CvROOT(cv)->op_private |= OPpREFCOUNTED;
5058     OpREFCNT_set(CvROOT(cv), 1);
5059     CvSTART(cv) = LINKLIST(CvROOT(cv));
5060     CvROOT(cv)->op_next = 0;
5061     peep(CvSTART(cv));
5062     op_free(o);
5063     PL_copline = NOLINE;
5064     LEAVE_SCOPE(floor);
5065 }
5066
5067 OP *
5068 Perl_newANONLIST(pTHX_ OP *o)
5069 {
5070     return newUNOP(OP_REFGEN, 0,
5071         mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5072 }
5073
5074 OP *
5075 Perl_newANONHASH(pTHX_ OP *o)
5076 {
5077     return newUNOP(OP_REFGEN, 0,
5078         mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5079 }
5080
5081 OP *
5082 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5083 {
5084     return newANONATTRSUB(floor, proto, Nullop, block);
5085 }
5086
5087 OP *
5088 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5089 {
5090     return newUNOP(OP_REFGEN, 0,
5091         newSVOP(OP_ANONCODE, 0,
5092                 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5093 }
5094
5095 OP *
5096 Perl_oopsAV(pTHX_ OP *o)
5097 {
5098     switch (o->op_type) {
5099     case OP_PADSV:
5100         o->op_type = OP_PADAV;
5101         o->op_ppaddr = PL_ppaddr[OP_PADAV];
5102         return ref(o, OP_RV2AV);
5103
5104     case OP_RV2SV:
5105         o->op_type = OP_RV2AV;
5106         o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5107         ref(o, OP_RV2AV);
5108         break;
5109
5110     default:
5111         if (ckWARN_d(WARN_INTERNAL))
5112             Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsAV");
5113         break;
5114     }
5115     return o;
5116 }
5117
5118 OP *
5119 Perl_oopsHV(pTHX_ OP *o)
5120 {
5121     switch (o->op_type) {
5122     case OP_PADSV:
5123     case OP_PADAV:
5124         o->op_type = OP_PADHV;
5125         o->op_ppaddr = PL_ppaddr[OP_PADHV];
5126         return ref(o, OP_RV2HV);
5127
5128     case OP_RV2SV:
5129     case OP_RV2AV:
5130         o->op_type = OP_RV2HV;
5131         o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5132         ref(o, OP_RV2HV);
5133         break;
5134
5135     default:
5136         if (ckWARN_d(WARN_INTERNAL))
5137             Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsHV");
5138         break;
5139     }
5140     return o;
5141 }
5142
5143 OP *
5144 Perl_newAVREF(pTHX_ OP *o)
5145 {
5146     if (o->op_type == OP_PADANY) {
5147         o->op_type = OP_PADAV;
5148         o->op_ppaddr = PL_ppaddr[OP_PADAV];
5149         return o;
5150     }
5151     return newUNOP(OP_RV2AV, 0, scalar(o));
5152 }
5153
5154 OP *
5155 Perl_newGVREF(pTHX_ I32 type, OP *o)
5156 {
5157     if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5158         return newUNOP(OP_NULL, 0, o);
5159     return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5160 }
5161
5162 OP *
5163 Perl_newHVREF(pTHX_ OP *o)
5164 {
5165     if (o->op_type == OP_PADANY) {
5166         o->op_type = OP_PADHV;
5167         o->op_ppaddr = PL_ppaddr[OP_PADHV];
5168         return o;
5169     }
5170     return newUNOP(OP_RV2HV, 0, scalar(o));
5171 }
5172
5173 OP *
5174 Perl_oopsCV(pTHX_ OP *o)
5175 {
5176     Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5177     /* STUB */
5178     return o;
5179 }
5180
5181 OP *
5182 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5183 {
5184     return newUNOP(OP_RV2CV, flags, scalar(o));
5185 }
5186
5187 OP *
5188 Perl_newSVREF(pTHX_ OP *o)
5189 {
5190     if (o->op_type == OP_PADANY) {
5191         o->op_type = OP_PADSV;
5192         o->op_ppaddr = PL_ppaddr[OP_PADSV];
5193         return o;
5194     }
5195     else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5196         o->op_flags |= OPpDONE_SVREF;
5197         return o;
5198     }
5199     return newUNOP(OP_RV2SV, 0, scalar(o));
5200 }
5201
5202 /* Check routines. */
5203
5204 OP *
5205 Perl_ck_anoncode(pTHX_ OP *o)
5206 {
5207     PADOFFSET ix;
5208     SV* name;
5209
5210     name = NEWSV(1106,0);
5211     sv_upgrade(name, SVt_PVNV);
5212     sv_setpvn(name, "&", 1);
5213     SvIVX(name) = -1;
5214     SvNVX(name) = 1;
5215     ix = pad_alloc(o->op_type, SVs_PADMY);
5216     av_store(PL_comppad_name, ix, name);
5217     av_store(PL_comppad, ix, cSVOPo->op_sv);
5218     SvPADMY_on(cSVOPo->op_sv);
5219     cSVOPo->op_sv = Nullsv;
5220     cSVOPo->op_targ = ix;
5221     return o;
5222 }
5223
5224 OP *
5225 Perl_ck_bitop(pTHX_ OP *o)
5226 {
5227     o->op_private = PL_hints;
5228     return o;
5229 }
5230
5231 OP *
5232 Perl_ck_concat(pTHX_ OP *o)
5233 {
5234     if (cUNOPo->op_first->op_type == OP_CONCAT)
5235         o->op_flags |= OPf_STACKED;
5236     return o;
5237 }
5238
5239 OP *
5240 Perl_ck_spair(pTHX_ OP *o)
5241 {
5242     if (o->op_flags & OPf_KIDS) {
5243         OP* newop;
5244         OP* kid;
5245         OPCODE type = o->op_type;
5246         o = modkids(ck_fun(o), type);
5247         kid = cUNOPo->op_first;
5248         newop = kUNOP->op_first->op_sibling;
5249         if (newop &&
5250             (newop->op_sibling ||
5251              !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5252              newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5253              newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5254
5255             return o;
5256         }
5257         op_free(kUNOP->op_first);
5258         kUNOP->op_first = newop;
5259     }
5260     o->op_ppaddr = PL_ppaddr[++o->op_type];
5261     return ck_fun(o);
5262 }
5263
5264 OP *
5265 Perl_ck_delete(pTHX_ OP *o)
5266 {
5267     o = ck_fun(o);
5268     o->op_private = 0;
5269     if (o->op_flags & OPf_KIDS) {
5270         OP *kid = cUNOPo->op_first;
5271         switch (kid->op_type) {
5272         case OP_ASLICE:
5273             o->op_flags |= OPf_SPECIAL;
5274             /* FALL THROUGH */
5275         case OP_HSLICE:
5276             o->op_private |= OPpSLICE;
5277             break;
5278         case OP_AELEM:
5279             o->op_flags |= OPf_SPECIAL;
5280             /* FALL THROUGH */
5281         case OP_HELEM:
5282             break;
5283         default:
5284             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5285                   PL_op_desc[o->op_type]);
5286         }
5287         null(kid);
5288     }
5289     return o;
5290 }
5291
5292 OP *
5293 Perl_ck_eof(pTHX_ OP *o)
5294 {
5295     I32 type = o->op_type;
5296
5297     if (o->op_flags & OPf_KIDS) {
5298         if (cLISTOPo->op_first->op_type == OP_STUB) {
5299             op_free(o);
5300             o = newUNOP(type, OPf_SPECIAL,
5301                 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
5302         }
5303         return ck_fun(o);
5304     }
5305     return o;
5306 }
5307
5308 OP *
5309 Perl_ck_eval(pTHX_ OP *o)
5310 {
5311     PL_hints |= HINT_BLOCK_SCOPE;
5312     if (o->op_flags & OPf_KIDS) {
5313         SVOP *kid = (SVOP*)cUNOPo->op_first;
5314
5315         if (!kid) {
5316             o->op_flags &= ~OPf_KIDS;
5317             null(o);
5318         }
5319         else if (kid->op_type == OP_LINESEQ) {
5320             LOGOP *enter;
5321
5322             kid->op_next = o->op_next;
5323             cUNOPo->op_first = 0;
5324             op_free(o);
5325
5326             NewOp(1101, enter, 1, LOGOP);
5327             enter->op_type = OP_ENTERTRY;
5328             enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5329             enter->op_private = 0;
5330
5331             /* establish postfix order */
5332             enter->op_next = (OP*)enter;
5333
5334             o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5335             o->op_type = OP_LEAVETRY;
5336             o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5337             enter->op_other = o;
5338             return o;
5339         }
5340         else
5341             scalar((OP*)kid);
5342     }
5343     else {
5344         op_free(o);
5345         o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5346     }
5347     o->op_targ = (PADOFFSET)PL_hints;
5348     return o;
5349 }
5350
5351 OP *
5352 Perl_ck_exit(pTHX_ OP *o)
5353 {
5354 #ifdef VMS
5355     HV *table = GvHV(PL_hintgv);
5356     if (table) {
5357        SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5358        if (svp && *svp && SvTRUE(*svp))
5359            o->op_private |= OPpEXIT_VMSISH;
5360     }
5361 #endif
5362     return ck_fun(o);
5363 }
5364
5365 OP *
5366 Perl_ck_exec(pTHX_ OP *o)
5367 {
5368     OP *kid;
5369     if (o->op_flags & OPf_STACKED) {
5370         o = ck_fun(o);
5371         kid = cUNOPo->op_first->op_sibling;
5372         if (kid->op_type == OP_RV2GV)
5373             null(kid);
5374     }
5375     else
5376         o = listkids(o);
5377     return o;
5378 }
5379
5380 OP *
5381 Perl_ck_exists(pTHX_ OP *o)
5382 {
5383     o = ck_fun(o);
5384     if (o->op_flags & OPf_KIDS) {
5385         OP *kid = cUNOPo->op_first;
5386         if (kid->op_type == OP_ENTERSUB) {
5387             (void) ref(kid, o->op_type);
5388             if (kid->op_type != OP_RV2CV && !PL_error_count)
5389                 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5390                            PL_op_desc[o->op_type]);
5391             o->op_private |= OPpEXISTS_SUB;
5392         }
5393         else if (kid->op_type == OP_AELEM)
5394             o->op_flags |= OPf_SPECIAL;
5395         else if (kid->op_type != OP_HELEM)
5396             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5397                        PL_op_desc[o->op_type]);
5398         null(kid);
5399     }
5400     return o;
5401 }
5402
5403 #if 0
5404 OP *
5405 Perl_ck_gvconst(pTHX_ register OP *o)
5406 {
5407     o = fold_constants(o);
5408     if (o->op_type == OP_CONST)
5409         o->op_type = OP_GV;
5410     return o;
5411 }
5412 #endif
5413
5414 OP *
5415 Perl_ck_rvconst(pTHX_ register OP *o)
5416 {
5417     SVOP *kid = (SVOP*)cUNOPo->op_first;
5418
5419     o->op_private |= (PL_hints & HINT_STRICT_REFS);
5420     if (kid->op_type == OP_CONST) {
5421         char *name;
5422         int iscv;
5423         GV *gv;
5424         SV *kidsv = kid->op_sv;
5425         STRLEN n_a;
5426
5427         /* Is it a constant from cv_const_sv()? */
5428         if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5429             SV *rsv = SvRV(kidsv);
5430             int svtype = SvTYPE(rsv);
5431             char *badtype = Nullch;
5432
5433             switch (o->op_type) {
5434             case OP_RV2SV:
5435                 if (svtype > SVt_PVMG)
5436                     badtype = "a SCALAR";
5437                 break;
5438             case OP_RV2AV:
5439                 if (svtype != SVt_PVAV)
5440                     badtype = "an ARRAY";
5441                 break;
5442             case OP_RV2HV:
5443                 if (svtype != SVt_PVHV) {
5444                     if (svtype == SVt_PVAV) {   /* pseudohash? */
5445                         SV **ksv = av_fetch((AV*)rsv, 0, FALSE);
5446                         if (ksv && SvROK(*ksv)
5447                             && SvTYPE(SvRV(*ksv)) == SVt_PVHV)
5448                         {
5449                                 break;
5450                         }
5451                     }
5452                     badtype = "a HASH";
5453                 }
5454                 break;
5455             case OP_RV2CV:
5456                 if (svtype != SVt_PVCV)
5457                     badtype = "a CODE";
5458                 break;
5459             }
5460             if (badtype)
5461                 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5462             return o;
5463         }
5464         name = SvPV(kidsv, n_a);
5465         if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5466             char *badthing = Nullch;
5467             switch (o->op_type) {
5468             case OP_RV2SV:
5469                 badthing = "a SCALAR";
5470                 break;
5471             case OP_RV2AV:
5472                 badthing = "an ARRAY";
5473                 break;
5474             case OP_RV2HV:
5475                 badthing = "a HASH";
5476                 break;
5477             }
5478             if (badthing)
5479                 Perl_croak(aTHX_
5480           "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5481                       name, badthing);
5482         }
5483         /*
5484          * This is a little tricky.  We only want to add the symbol if we
5485          * didn't add it in the lexer.  Otherwise we get duplicate strict
5486          * warnings.  But if we didn't add it in the lexer, we must at
5487          * least pretend like we wanted to add it even if it existed before,
5488          * or we get possible typo warnings.  OPpCONST_ENTERED says
5489          * whether the lexer already added THIS instance of this symbol.
5490          */
5491         iscv = (o->op_type == OP_RV2CV) * 2;
5492         do {
5493             gv = gv_fetchpv(name,
5494                 iscv | !(kid->op_private & OPpCONST_ENTERED),
5495                 iscv
5496                     ? SVt_PVCV
5497                     : o->op_type == OP_RV2SV
5498                         ? SVt_PV
5499                         : o->op_type == OP_RV2AV
5500                             ? SVt_PVAV
5501                             : o->op_type == OP_RV2HV
5502                                 ? SVt_PVHV
5503                                 : SVt_PVGV);
5504         } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5505         if (gv) {
5506             kid->op_type = OP_GV;
5507             SvREFCNT_dec(kid->op_sv);
5508 #ifdef USE_ITHREADS
5509             /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5510             kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5511             SvREFCNT_dec(PL_curpad[kPADOP->op_padix]);
5512             GvIN_PAD_on(gv);
5513             PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv);
5514 #else
5515             kid->op_sv = SvREFCNT_inc(gv);
5516 #endif
5517             kid->op_private = 0;
5518             kid->op_ppaddr = PL_ppaddr[OP_GV];
5519         }
5520     }
5521     return o;
5522 }
5523
5524 OP *
5525 Perl_ck_ftst(pTHX_ OP *o)
5526 {
5527     I32 type = o->op_type;
5528
5529     if (o->op_flags & OPf_REF) {
5530         /* nothing */
5531     }
5532     else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5533         SVOP *kid = (SVOP*)cUNOPo->op_first;
5534
5535         if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5536             STRLEN n_a;
5537             OP *newop = newGVOP(type, OPf_REF,
5538                 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5539             op_free(o);
5540             o = newop;
5541         }
5542     }
5543     else {
5544         op_free(o);
5545         if (type == OP_FTTTY)
5546            o =  newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
5547                                 SVt_PVIO));
5548         else
5549             o = newUNOP(type, 0, newDEFSVOP());
5550     }
5551 #ifdef USE_LOCALE
5552     if (type == OP_FTTEXT || type == OP_FTBINARY) {
5553         o->op_private = 0;
5554         if (PL_hints & HINT_LOCALE)
5555             o->op_private |= OPpLOCALE;
5556     }
5557 #endif
5558     return o;
5559 }
5560
5561 OP *
5562 Perl_ck_fun(pTHX_ OP *o)
5563 {
5564     register OP *kid;
5565     OP **tokid;
5566     OP *sibl;
5567     I32 numargs = 0;
5568     int type = o->op_type;
5569     register I32 oa = PL_opargs[type] >> OASHIFT;
5570
5571     if (o->op_flags & OPf_STACKED) {
5572         if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5573             oa &= ~OA_OPTIONAL;
5574         else
5575             return no_fh_allowed(o);
5576     }
5577
5578     if (o->op_flags & OPf_KIDS) {
5579         STRLEN n_a;
5580         tokid = &cLISTOPo->op_first;
5581         kid = cLISTOPo->op_first;
5582         if (kid->op_type == OP_PUSHMARK ||
5583             (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5584         {
5585             tokid = &kid->op_sibling;
5586             kid = kid->op_sibling;
5587         }
5588         if (!kid && PL_opargs[type] & OA_DEFGV)
5589             *tokid = kid = newDEFSVOP();
5590
5591         while (oa && kid) {
5592             numargs++;
5593             sibl = kid->op_sibling;
5594             switch (oa & 7) {
5595             case OA_SCALAR:
5596                 /* list seen where single (scalar) arg expected? */
5597                 if (numargs == 1 && !(oa >> 4)
5598                     && kid->op_type == OP_LIST && type != OP_SCALAR)
5599                 {
5600                     return too_many_arguments(o,PL_op_desc[type]);
5601                 }
5602                 scalar(kid);
5603                 break;
5604             case OA_LIST:
5605                 if (oa < 16) {
5606                     kid = 0;
5607                     continue;
5608                 }
5609                 else
5610                     list(kid);
5611                 break;
5612             case OA_AVREF:
5613                 if (kid->op_type == OP_CONST &&
5614                     (kid->op_private & OPpCONST_BARE))
5615                 {
5616                     char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5617                     OP *newop = newAVREF(newGVOP(OP_GV, 0,
5618                         gv_fetchpv(name, TRUE, SVt_PVAV) ));
5619                     if (ckWARN(WARN_DEPRECATED))
5620                         Perl_warner(aTHX_ WARN_DEPRECATED,
5621                             "Array @%s missing the @ in argument %"IVdf" of %s()",
5622                             name, (IV)numargs, PL_op_desc[type]);
5623                     op_free(kid);
5624                     kid = newop;
5625                     kid->op_sibling = sibl;
5626                     *tokid = kid;
5627                 }
5628                 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5629                     bad_type(numargs, "array", PL_op_desc[type], kid);
5630                 mod(kid, type);
5631                 break;
5632             case OA_HVREF:
5633                 if (kid->op_type == OP_CONST &&
5634                     (kid->op_private & OPpCONST_BARE))
5635                 {
5636                     char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5637                     OP *newop = newHVREF(newGVOP(OP_GV, 0,
5638                         gv_fetchpv(name, TRUE, SVt_PVHV) ));
5639                     if (ckWARN(WARN_DEPRECATED))
5640                         Perl_warner(aTHX_ WARN_DEPRECATED,
5641                             "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5642                             name, (IV)numargs, PL_op_desc[type]);
5643                     op_free(kid);
5644                     kid = newop;
5645                     kid->op_sibling = sibl;
5646                     *tokid = kid;
5647                 }
5648                 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5649                     bad_type(numargs, "hash", PL_op_desc[type], kid);
5650                 mod(kid, type);
5651                 break;
5652             case OA_CVREF:
5653                 {
5654                     OP *newop = newUNOP(OP_NULL, 0, kid);
5655                     kid->op_sibling = 0;
5656                     linklist(kid);
5657                     newop->op_next = newop;
5658                     kid = newop;
5659                     kid->op_sibling = sibl;
5660                     *tokid = kid;
5661                 }
5662                 break;
5663             case OA_FILEREF:
5664                 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5665                     if (kid->op_type == OP_CONST &&
5666                         (kid->op_private & OPpCONST_BARE))
5667                     {
5668                         OP *newop = newGVOP(OP_GV, 0,
5669                             gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5670                                         SVt_PVIO) );
5671                         op_free(kid);
5672                         kid = newop;
5673                     }
5674                     else if (kid->op_type == OP_READLINE) {
5675                         /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5676                         bad_type(numargs, "HANDLE", PL_op_desc[o->op_type], kid);
5677                     }
5678                     else {
5679                         I32 flags = OPf_SPECIAL;
5680                         I32 priv = 0;
5681                         PADOFFSET targ = 0;
5682
5683                         /* is this op a FH constructor? */
5684                         if (is_handle_constructor(o,numargs)) {
5685                             char *name = Nullch;
5686                             STRLEN len;
5687
5688                             flags = 0;
5689                             /* Set a flag to tell rv2gv to vivify
5690                              * need to "prove" flag does not mean something
5691                              * else already - NI-S 1999/05/07
5692                              */
5693                             priv = OPpDEREF;
5694                             if (kid->op_type == OP_PADSV) {
5695                                 SV **namep = av_fetch(PL_comppad_name,
5696                                                       kid->op_targ, 4);
5697                                 if (namep && *namep)
5698                                     name = SvPV(*namep, len);
5699                             }
5700                             else if (kid->op_type == OP_RV2SV
5701                                      && kUNOP->op_first->op_type == OP_GV)
5702                             {
5703                                 GV *gv = cGVOPx_gv(kUNOP->op_first);
5704                                 name = GvNAME(gv);
5705                                 len = GvNAMELEN(gv);
5706                             }
5707                             else if (kid->op_type == OP_AELEM
5708                                      || kid->op_type == OP_HELEM)
5709                             {
5710                                 name = "__ANONIO__";
5711                                 len = 10;
5712                                 mod(kid,type);
5713                             }
5714                             if (name) {
5715                                 SV *namesv;
5716                                 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5717                                 namesv = PL_curpad[targ];
5718                                 (void)SvUPGRADE(namesv, SVt_PV);
5719                                 if (*name != '$')
5720                                     sv_setpvn(namesv, "$", 1);
5721                                 sv_catpvn(namesv, name, len);
5722                             }
5723                         }
5724                         kid->op_sibling = 0;
5725                         kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5726                         kid->op_targ = targ;
5727                         kid->op_private |= priv;
5728                     }
5729                     kid->op_sibling = sibl;
5730                     *tokid = kid;
5731                 }
5732                 scalar(kid);
5733                 break;
5734             case OA_SCALARREF:
5735                 mod(scalar(kid), type);
5736                 break;
5737             }
5738             oa >>= 4;
5739             tokid = &kid->op_sibling;
5740             kid = kid->op_sibling;
5741         }
5742         o->op_private |= numargs;
5743         if (kid)
5744             return too_many_arguments(o,PL_op_desc[o->op_type]);
5745         listkids(o);
5746     }
5747     else if (PL_opargs[type] & OA_DEFGV) {
5748         op_free(o);
5749         return newUNOP(type, 0, newDEFSVOP());
5750     }
5751
5752     if (oa) {
5753         while (oa & OA_OPTIONAL)
5754             oa >>= 4;
5755         if (oa && oa != OA_LIST)
5756             return too_few_arguments(o,PL_op_desc[o->op_type]);
5757     }
5758     return o;
5759 }
5760
5761 OP *
5762 Perl_ck_glob(pTHX_ OP *o)
5763 {
5764     GV *gv;
5765
5766     o = ck_fun(o);
5767     if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5768         append_elem(OP_GLOB, o, newDEFSVOP());
5769
5770     if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV)) && GvIMPORTED_CV(gv)))
5771         gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5772
5773 #if !defined(PERL_EXTERNAL_GLOB)
5774     /* XXX this can be tightened up and made more failsafe. */
5775     if (!gv) {
5776         ENTER;
5777         Perl_load_module(aTHX_ 0, newSVpvn("File::Glob", 10), Nullsv,
5778                          /* null-terminated import list */
5779                          newSVpvn(":globally", 9), Nullsv);
5780         gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5781         LEAVE;
5782     }
5783 #endif /* PERL_EXTERNAL_GLOB */
5784
5785     if (gv && GvIMPORTED_CV(gv)) {
5786         append_elem(OP_GLOB, o,
5787                     newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5788         o->op_type = OP_LIST;
5789         o->op_ppaddr = PL_ppaddr[OP_LIST];
5790         cLISTOPo->op_first->op_type = OP_PUSHMARK;
5791         cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5792         o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5793                     append_elem(OP_LIST, o,
5794                                 scalar(newUNOP(OP_RV2CV, 0,
5795                                                newGVOP(OP_GV, 0, gv)))));
5796         o = newUNOP(OP_NULL, 0, ck_subr(o));
5797         o->op_targ = OP_GLOB;           /* hint at what it used to be */
5798         return o;
5799     }
5800     gv = newGVgen("main");
5801     gv_IOadd(gv);
5802     append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5803     scalarkids(o);
5804     return o;
5805 }
5806
5807 OP *
5808 Perl_ck_grep(pTHX_ OP *o)
5809 {
5810     LOGOP *gwop;
5811     OP *kid;
5812     OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5813
5814     o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5815     NewOp(1101, gwop, 1, LOGOP);
5816
5817     if (o->op_flags & OPf_STACKED) {
5818         OP* k;
5819         o = ck_sort(o);
5820         kid = cLISTOPo->op_first->op_sibling;
5821         for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
5822             kid = k;
5823         }
5824         kid->op_next = (OP*)gwop;
5825         o->op_flags &= ~OPf_STACKED;
5826     }
5827     kid = cLISTOPo->op_first->op_sibling;
5828     if (type == OP_MAPWHILE)
5829         list(kid);
5830     else
5831         scalar(kid);
5832     o = ck_fun(o);
5833     if (PL_error_count)
5834         return o;
5835     kid = cLISTOPo->op_first->op_sibling;
5836     if (kid->op_type != OP_NULL)
5837         Perl_croak(aTHX_ "panic: ck_grep");
5838     kid = kUNOP->op_first;
5839
5840     gwop->op_type = type;
5841     gwop->op_ppaddr = PL_ppaddr[type];
5842     gwop->op_first = listkids(o);
5843     gwop->op_flags |= OPf_KIDS;
5844     gwop->op_private = 1;
5845     gwop->op_other = LINKLIST(kid);
5846     gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5847     kid->op_next = (OP*)gwop;
5848
5849     kid = cLISTOPo->op_first->op_sibling;
5850     if (!kid || !kid->op_sibling)
5851         return too_few_arguments(o,PL_op_desc[o->op_type]);
5852     for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5853         mod(kid, OP_GREPSTART);
5854
5855     return (OP*)gwop;
5856 }
5857
5858 OP *
5859 Perl_ck_index(pTHX_ OP *o)
5860 {
5861     if (o->op_flags & OPf_KIDS) {
5862         OP *kid = cLISTOPo->op_first->op_sibling;       /* get past pushmark */
5863         if (kid)
5864             kid = kid->op_sibling;                      /* get past "big" */
5865         if (kid && kid->op_type == OP_CONST)
5866             fbm_compile(((SVOP*)kid)->op_sv, 0);
5867     }
5868     return ck_fun(o);
5869 }
5870
5871 OP *
5872 Perl_ck_lengthconst(pTHX_ OP *o)
5873 {
5874     /* XXX length optimization goes here */
5875     return ck_fun(o);
5876 }
5877
5878 OP *
5879 Perl_ck_lfun(pTHX_ OP *o)
5880 {
5881     OPCODE type = o->op_type;
5882     return modkids(ck_fun(o), type);
5883 }
5884
5885 OP *
5886 Perl_ck_defined(pTHX_ OP *o)            /* 19990527 MJD */
5887 {
5888     if ((o->op_flags & OPf_KIDS) && ckWARN(WARN_DEPRECATED)) {
5889         switch (cUNOPo->op_first->op_type) {
5890         case OP_RV2AV:
5891             /* This is needed for
5892                if (defined %stash::)
5893                to work.   Do not break Tk.
5894                */
5895             break;                      /* Globals via GV can be undef */
5896         case OP_PADAV:
5897         case OP_AASSIGN:                /* Is this a good idea? */
5898             Perl_warner(aTHX_ WARN_DEPRECATED,
5899                         "defined(@array) is deprecated");
5900             Perl_warner(aTHX_ WARN_DEPRECATED,
5901                         "\t(Maybe you should just omit the defined()?)\n");
5902         break;
5903         case OP_RV2HV:
5904             /* This is needed for
5905                if (defined %stash::)
5906                to work.   Do not break Tk.
5907                */
5908             break;                      /* Globals via GV can be undef */
5909         case OP_PADHV:
5910             Perl_warner(aTHX_ WARN_DEPRECATED,
5911                         "defined(%%hash) is deprecated");
5912             Perl_warner(aTHX_ WARN_DEPRECATED,
5913                         "\t(Maybe you should just omit the defined()?)\n");
5914             break;
5915         default:
5916             /* no warning */
5917             break;
5918         }
5919     }
5920     return ck_rfun(o);
5921 }
5922
5923 OP *
5924 Perl_ck_rfun(pTHX_ OP *o)
5925 {
5926     OPCODE type = o->op_type;
5927     return refkids(ck_fun(o), type);
5928 }
5929
5930 OP *
5931 Perl_ck_listiob(pTHX_ OP *o)
5932 {
5933     register OP *kid;
5934
5935     kid = cLISTOPo->op_first;
5936     if (!kid) {
5937         o = force_list(o);
5938         kid = cLISTOPo->op_first;
5939     }
5940     if (kid->op_type == OP_PUSHMARK)
5941         kid = kid->op_sibling;
5942     if (kid && o->op_flags & OPf_STACKED)
5943         kid = kid->op_sibling;
5944     else if (kid && !kid->op_sibling) {         /* print HANDLE; */
5945         if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5946             o->op_flags |= OPf_STACKED; /* make it a filehandle */
5947             kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5948             cLISTOPo->op_first->op_sibling = kid;
5949             cLISTOPo->op_last = kid;
5950             kid = kid->op_sibling;
5951         }
5952     }
5953
5954     if (!kid)
5955         append_elem(o->op_type, o, newDEFSVOP());
5956
5957     o = listkids(o);
5958
5959     o->op_private = 0;
5960 #ifdef USE_LOCALE
5961     if (PL_hints & HINT_LOCALE)
5962         o->op_private |= OPpLOCALE;
5963 #endif
5964
5965     return o;
5966 }
5967
5968 OP *
5969 Perl_ck_fun_locale(pTHX_ OP *o)
5970 {
5971     o = ck_fun(o);
5972
5973     o->op_private = 0;
5974 #ifdef USE_LOCALE
5975     if (PL_hints & HINT_LOCALE)
5976         o->op_private |= OPpLOCALE;
5977 #endif
5978
5979     return o;
5980 }
5981
5982 OP *
5983 Perl_ck_sassign(pTHX_ OP *o)
5984 {
5985     OP *kid = cLISTOPo->op_first;
5986     /* has a disposable target? */
5987     if ((PL_opargs[kid->op_type] & OA_TARGLEX)
5988         && !(kid->op_flags & OPf_STACKED)
5989         /* Cannot steal the second time! */
5990         && !(kid->op_private & OPpTARGET_MY))
5991     {
5992         OP *kkid = kid->op_sibling;
5993
5994         /* Can just relocate the target. */
5995         if (kkid && kkid->op_type == OP_PADSV
5996             && !(kkid->op_private & OPpLVAL_INTRO))
5997         {
5998             kid->op_targ = kkid->op_targ;
5999             kkid->op_targ = 0;
6000             /* Now we do not need PADSV and SASSIGN. */
6001             kid->op_sibling = o->op_sibling;    /* NULL */
6002             cLISTOPo->op_first = NULL;
6003             op_free(o);
6004             op_free(kkid);
6005             kid->op_private |= OPpTARGET_MY;    /* Used for context settings */
6006             return kid;
6007         }
6008     }
6009     return o;
6010 }
6011
6012 OP *
6013 Perl_ck_scmp(pTHX_ OP *o)
6014 {
6015     o->op_private = 0;
6016 #ifdef USE_LOCALE
6017     if (PL_hints & HINT_LOCALE)
6018         o->op_private |= OPpLOCALE;
6019 #endif
6020
6021     return o;
6022 }
6023
6024 OP *
6025 Perl_ck_match(pTHX_ OP *o)
6026 {
6027     o->op_private |= OPpRUNTIME;
6028     return o;
6029 }
6030
6031 OP *
6032 Perl_ck_method(pTHX_ OP *o)
6033 {
6034     OP *kid = cUNOPo->op_first;
6035     if (kid->op_type == OP_CONST) {
6036         SV* sv = kSVOP->op_sv;
6037         if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
6038             OP *cmop;
6039             if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6040                 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
6041             }
6042             else {
6043                 kSVOP->op_sv = Nullsv;
6044             }
6045             cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6046             op_free(o);
6047             return cmop;
6048         }
6049     }
6050     return o;
6051 }
6052
6053 OP *
6054 Perl_ck_null(pTHX_ OP *o)
6055 {
6056     return o;
6057 }
6058
6059 OP *
6060 Perl_ck_open(pTHX_ OP *o)
6061 {
6062     HV *table = GvHV(PL_hintgv);
6063     if (table) {
6064         SV **svp;
6065         I32 mode;
6066         svp = hv_fetch(table, "open_IN", 7, FALSE);
6067         if (svp && *svp) {
6068             mode = mode_from_discipline(*svp);
6069             if (mode & O_BINARY)
6070                 o->op_private |= OPpOPEN_IN_RAW;
6071             else if (mode & O_TEXT)
6072                 o->op_private |= OPpOPEN_IN_CRLF;
6073         }
6074
6075         svp = hv_fetch(table, "open_OUT", 8, FALSE);
6076         if (svp && *svp) {
6077             mode = mode_from_discipline(*svp);
6078             if (mode & O_BINARY)
6079                 o->op_private |= OPpOPEN_OUT_RAW;
6080             else if (mode & O_TEXT)
6081                 o->op_private |= OPpOPEN_OUT_CRLF;
6082         }
6083     }
6084     if (o->op_type == OP_BACKTICK)
6085         return o;
6086     return ck_fun(o);
6087 }
6088
6089 OP *
6090 Perl_ck_repeat(pTHX_ OP *o)
6091 {
6092     if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6093         o->op_private |= OPpREPEAT_DOLIST;
6094         cBINOPo->op_first = force_list(cBINOPo->op_first);
6095     }
6096     else
6097         scalar(o);
6098     return o;
6099 }
6100
6101 OP *
6102 Perl_ck_require(pTHX_ OP *o)
6103 {
6104     if (o->op_flags & OPf_KIDS) {       /* Shall we supply missing .pm? */
6105         SVOP *kid = (SVOP*)cUNOPo->op_first;
6106
6107         if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6108             char *s;
6109             for (s = SvPVX(kid->op_sv); *s; s++) {
6110                 if (*s == ':' && s[1] == ':') {
6111                     *s = '/';
6112                     Move(s+2, s+1, strlen(s+2)+1, char);
6113                     --SvCUR(kid->op_sv);
6114                 }
6115             }
6116             if (SvREADONLY(kid->op_sv)) {
6117                 SvREADONLY_off(kid->op_sv);
6118                 sv_catpvn(kid->op_sv, ".pm", 3);
6119                 SvREADONLY_on(kid->op_sv);
6120             }
6121             else
6122                 sv_catpvn(kid->op_sv, ".pm", 3);
6123         }
6124     }
6125     return ck_fun(o);
6126 }
6127
6128 OP *
6129 Perl_ck_return(pTHX_ OP *o)
6130 {
6131     OP *kid;
6132     if (CvLVALUE(PL_compcv)) {
6133         for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6134             mod(kid, OP_LEAVESUBLV);
6135     }
6136     return o;
6137 }
6138
6139 #if 0
6140 OP *
6141 Perl_ck_retarget(pTHX_ OP *o)
6142 {
6143     Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
6144     /* STUB */
6145     return o;
6146 }
6147 #endif
6148
6149 OP *
6150 Perl_ck_select(pTHX_ OP *o)
6151 {
6152     OP* kid;
6153     if (o->op_flags & OPf_KIDS) {
6154         kid = cLISTOPo->op_first->op_sibling;   /* get past pushmark */
6155         if (kid && kid->op_sibling) {
6156             o->op_type = OP_SSELECT;
6157             o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6158             o = ck_fun(o);
6159             return fold_constants(o);
6160         }
6161     }
6162     o = ck_fun(o);
6163     kid = cLISTOPo->op_first->op_sibling;    /* get past pushmark */
6164     if (kid && kid->op_type == OP_RV2GV)
6165         kid->op_private &= ~HINT_STRICT_REFS;
6166     return o;
6167 }
6168
6169 OP *
6170 Perl_ck_shift(pTHX_ OP *o)
6171 {
6172     I32 type = o->op_type;
6173
6174     if (!(o->op_flags & OPf_KIDS)) {
6175         OP *argop;
6176
6177         op_free(o);
6178 #ifdef USE_THREADS
6179         if (!CvUNIQUE(PL_compcv)) {
6180             argop = newOP(OP_PADAV, OPf_REF);
6181             argop->op_targ = 0;         /* PL_curpad[0] is @_ */
6182         }
6183         else {
6184             argop = newUNOP(OP_RV2AV, 0,
6185                 scalar(newGVOP(OP_GV, 0,
6186                     gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6187         }
6188 #else
6189         argop = newUNOP(OP_RV2AV, 0,
6190             scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
6191                            PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6192 #endif /* USE_THREADS */
6193         return newUNOP(type, 0, scalar(argop));
6194     }
6195     return scalar(modkids(ck_fun(o), type));
6196 }
6197
6198 OP *
6199 Perl_ck_sort(pTHX_ OP *o)
6200 {
6201     OP *firstkid;
6202     o->op_private = 0;
6203 #ifdef USE_LOCALE
6204     if (PL_hints & HINT_LOCALE)
6205         o->op_private |= OPpLOCALE;
6206 #endif
6207
6208     if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6209         simplify_sort(o);
6210     firstkid = cLISTOPo->op_first->op_sibling;          /* get past pushmark */
6211     if (o->op_flags & OPf_STACKED) {                    /* may have been cleared */
6212         OP *k;
6213         OP *kid = cUNOPx(firstkid)->op_first;           /* get past null */
6214
6215         if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6216             linklist(kid);
6217             if (kid->op_type == OP_SCOPE) {
6218                 k = kid->op_next;
6219                 kid->op_next = 0;
6220             }
6221             else if (kid->op_type == OP_LEAVE) {
6222                 if (o->op_type == OP_SORT) {
6223                     null(kid);                  /* wipe out leave */
6224                     kid->op_next = kid;
6225
6226                     for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6227                         if (k->op_next == kid)
6228                             k->op_next = 0;
6229                         /* don't descend into loops */
6230                         else if (k->op_type == OP_ENTERLOOP
6231                                  || k->op_type == OP_ENTERITER)
6232                         {
6233                             k = cLOOPx(k)->op_lastop;
6234                         }
6235                     }
6236                 }
6237                 else
6238                     kid->op_next = 0;           /* just disconnect the leave */
6239                 k = kLISTOP->op_first;
6240             }
6241             peep(k);
6242
6243             kid = firstkid;
6244             if (o->op_type == OP_SORT) {
6245                 /* provide scalar context for comparison function/block */
6246                 kid = scalar(kid);
6247                 kid->op_next = kid;
6248             }
6249             else
6250                 kid->op_next = k;
6251             o->op_flags |= OPf_SPECIAL;
6252         }
6253         else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6254             null(firstkid);
6255
6256         firstkid = firstkid->op_sibling;
6257     }
6258
6259     /* provide list context for arguments */
6260     if (o->op_type == OP_SORT)
6261         list(firstkid);
6262
6263     return o;
6264 }
6265
6266 STATIC void
6267 S_simplify_sort(pTHX_ OP *o)
6268 {
6269     register OP *kid = cLISTOPo->op_first->op_sibling;  /* get past pushmark */
6270     OP *k;
6271     int reversed;
6272     GV *gv;
6273     if (!(o->op_flags & OPf_STACKED))
6274         return;
6275     GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6276     GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6277     kid = kUNOP->op_first;                              /* get past null */
6278     if (kid->op_type != OP_SCOPE)
6279         return;
6280     kid = kLISTOP->op_last;                             /* get past scope */
6281     switch(kid->op_type) {
6282         case OP_NCMP:
6283         case OP_I_NCMP:
6284         case OP_SCMP:
6285             break;
6286         default:
6287             return;
6288     }
6289     k = kid;                                            /* remember this node*/
6290     if (kBINOP->op_first->op_type != OP_RV2SV)
6291         return;
6292     kid = kBINOP->op_first;                             /* get past cmp */
6293     if (kUNOP->op_first->op_type != OP_GV)
6294         return;
6295     kid = kUNOP->op_first;                              /* get past rv2sv */
6296     gv = kGVOP_gv;
6297     if (GvSTASH(gv) != PL_curstash)
6298         return;
6299     if (strEQ(GvNAME(gv), "a"))
6300         reversed = 0;
6301     else if (strEQ(GvNAME(gv), "b"))
6302         reversed = 1;
6303     else
6304         return;
6305     kid = k;                                            /* back to cmp */
6306     if (kBINOP->op_last->op_type != OP_RV2SV)
6307         return;
6308     kid = kBINOP->op_last;                              /* down to 2nd arg */
6309     if (kUNOP->op_first->op_type != OP_GV)
6310         return;
6311     kid = kUNOP->op_first;                              /* get past rv2sv */
6312     gv = kGVOP_gv;
6313     if (GvSTASH(gv) != PL_curstash
6314         || ( reversed
6315             ? strNE(GvNAME(gv), "a")
6316             : strNE(GvNAME(gv), "b")))
6317         return;
6318     o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6319     if (reversed)
6320         o->op_private |= OPpSORT_REVERSE;
6321     if (k->op_type == OP_NCMP)
6322         o->op_private |= OPpSORT_NUMERIC;
6323     if (k->op_type == OP_I_NCMP)
6324         o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6325     kid = cLISTOPo->op_first->op_sibling;
6326     cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6327     op_free(kid);                                     /* then delete it */
6328 }
6329
6330 OP *
6331 Perl_ck_split(pTHX_ OP *o)
6332 {
6333     register OP *kid;
6334
6335     if (o->op_flags & OPf_STACKED)
6336         return no_fh_allowed(o);
6337
6338     kid = cLISTOPo->op_first;
6339     if (kid->op_type != OP_NULL)
6340         Perl_croak(aTHX_ "panic: ck_split");
6341     kid = kid->op_sibling;
6342     op_free(cLISTOPo->op_first);
6343     cLISTOPo->op_first = kid;
6344     if (!kid) {
6345         cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6346         cLISTOPo->op_last = kid; /* There was only one element previously */
6347     }
6348
6349     if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6350         OP *sibl = kid->op_sibling;
6351         kid->op_sibling = 0;
6352         kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
6353         if (cLISTOPo->op_first == cLISTOPo->op_last)
6354             cLISTOPo->op_last = kid;
6355         cLISTOPo->op_first = kid;
6356         kid->op_sibling = sibl;
6357     }
6358
6359     kid->op_type = OP_PUSHRE;
6360     kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6361     scalar(kid);
6362
6363     if (!kid->op_sibling)
6364         append_elem(OP_SPLIT, o, newDEFSVOP());
6365
6366     kid = kid->op_sibling;
6367     scalar(kid);
6368
6369     if (!kid->op_sibling)
6370         append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6371
6372     kid = kid->op_sibling;
6373     scalar(kid);
6374
6375     if (kid->op_sibling)
6376         return too_many_arguments(o,PL_op_desc[o->op_type]);
6377
6378     return o;
6379 }
6380
6381 OP *
6382 Perl_ck_join(pTHX_ OP *o)
6383 {
6384     if (ckWARN(WARN_SYNTAX)) {
6385         OP *kid = cLISTOPo->op_first->op_sibling;
6386         if (kid && kid->op_type == OP_MATCH) {
6387             char *pmstr = "STRING";
6388             if (kPMOP->op_pmregexp)
6389                 pmstr = kPMOP->op_pmregexp->precomp;
6390             Perl_warner(aTHX_ WARN_SYNTAX,
6391                         "/%s/ should probably be written as \"%s\"",
6392                         pmstr, pmstr);
6393         }
6394     }
6395     return ck_fun(o);
6396 }
6397
6398 OP *
6399 Perl_ck_subr(pTHX_ OP *o)
6400 {
6401     OP *prev = ((cUNOPo->op_first->op_sibling)
6402              ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6403     OP *o2 = prev->op_sibling;
6404     OP *cvop;
6405     char *proto = 0;
6406     CV *cv = 0;
6407     GV *namegv = 0;
6408     int optional = 0;
6409     I32 arg = 0;
6410     STRLEN n_a;
6411
6412     o->op_private |= OPpENTERSUB_HASTARG;
6413     for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6414     if (cvop->op_type == OP_RV2CV) {
6415         SVOP* tmpop;
6416         o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6417         null(cvop);             /* disable rv2cv */
6418         tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6419         if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6420             GV *gv = cGVOPx_gv(tmpop);
6421             cv = GvCVu(gv);
6422             if (!cv)
6423                 tmpop->op_private |= OPpEARLY_CV;
6424             else if (SvPOK(cv)) {
6425                 namegv = CvANON(cv) ? gv : CvGV(cv);
6426                 proto = SvPV((SV*)cv, n_a);
6427             }
6428         }
6429     }
6430     else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6431         if (o2->op_type == OP_CONST)
6432             o2->op_private &= ~OPpCONST_STRICT;
6433         else if (o2->op_type == OP_LIST) {
6434             OP *o = ((UNOP*)o2)->op_first->op_sibling;
6435             if (o && o->op_type == OP_CONST)
6436                 o->op_private &= ~OPpCONST_STRICT;
6437         }
6438     }
6439     o->op_private |= (PL_hints & HINT_STRICT_REFS);
6440     if (PERLDB_SUB && PL_curstash != PL_debstash)
6441         o->op_private |= OPpENTERSUB_DB;
6442     while (o2 != cvop) {
6443         if (proto) {
6444             switch (*proto) {
6445             case '\0':
6446                 return too_many_arguments(o, gv_ename(namegv));
6447             case ';':
6448                 optional = 1;
6449                 proto++;
6450                 continue;
6451             case '$':
6452                 proto++;
6453                 arg++;
6454                 scalar(o2);
6455                 break;
6456             case '%':
6457             case '@':
6458                 list(o2);
6459                 arg++;
6460                 break;
6461             case '&':
6462                 proto++;
6463                 arg++;
6464                 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6465                     bad_type(arg,
6466                         arg == 1 ? "block or sub {}" : "sub {}",
6467                         gv_ename(namegv), o2);
6468                 break;
6469             case '*':
6470                 /* '*' allows any scalar type, including bareword */
6471                 proto++;
6472                 arg++;
6473                 if (o2->op_type == OP_RV2GV)
6474                     goto wrapref;       /* autoconvert GLOB -> GLOBref */
6475                 else if (o2->op_type == OP_CONST)
6476                     o2->op_private &= ~OPpCONST_STRICT;
6477                 else if (o2->op_type == OP_ENTERSUB) {
6478                     /* accidental subroutine, revert to bareword */
6479                     OP *gvop = ((UNOP*)o2)->op_first;
6480                     if (gvop && gvop->op_type == OP_NULL) {
6481                         gvop = ((UNOP*)gvop)->op_first;
6482                         if (gvop) {
6483                             for (; gvop->op_sibling; gvop = gvop->op_sibling)
6484                                 ;
6485                             if (gvop &&
6486                                 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6487                                 (gvop = ((UNOP*)gvop)->op_first) &&
6488                                 gvop->op_type == OP_GV)
6489                             {
6490                                 GV *gv = cGVOPx_gv(gvop);
6491                                 OP *sibling = o2->op_sibling;
6492                                 SV *n = newSVpvn("",0);
6493                                 op_free(o2);
6494                                 gv_fullname3(n, gv, "");
6495                                 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6496                                     sv_chop(n, SvPVX(n)+6);
6497                                 o2 = newSVOP(OP_CONST, 0, n);
6498                                 prev->op_sibling = o2;
6499                                 o2->op_sibling = sibling;
6500                             }
6501                         }
6502                     }
6503                 }
6504                 scalar(o2);
6505                 break;
6506             case '\\':
6507                 proto++;
6508                 arg++;
6509                 switch (*proto++) {
6510                 case '*':
6511                     if (o2->op_type != OP_RV2GV)
6512                         bad_type(arg, "symbol", gv_ename(namegv), o2);
6513                     goto wrapref;
6514                 case '&':
6515                     if (o2->op_type != OP_ENTERSUB)
6516                         bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6517                     goto wrapref;
6518                 case '$':
6519                     if (o2->op_type != OP_RV2SV
6520                         && o2->op_type != OP_PADSV
6521                         && o2->op_type != OP_HELEM
6522                         && o2->op_type != OP_AELEM
6523                         && o2->op_type != OP_THREADSV)
6524                     {
6525                         bad_type(arg, "scalar", gv_ename(namegv), o2);
6526                     }
6527                     goto wrapref;
6528                 case '@':
6529                     if (o2->op_type != OP_RV2AV && o2->op_type != OP_PADAV)
6530                         bad_type(arg, "array", gv_ename(namegv), o2);
6531                     goto wrapref;
6532                 case '%':
6533                     if (o2->op_type != OP_RV2HV && o2->op_type != OP_PADHV)
6534                         bad_type(arg, "hash", gv_ename(namegv), o2);
6535                   wrapref:
6536                     {
6537                         OP* kid = o2;
6538                         OP* sib = kid->op_sibling;
6539                         kid->op_sibling = 0;
6540                         o2 = newUNOP(OP_REFGEN, 0, kid);
6541                         o2->op_sibling = sib;
6542                         prev->op_sibling = o2;
6543                     }
6544                     break;
6545                 default: goto oops;
6546                 }
6547                 break;
6548             case ' ':
6549                 proto++;
6550                 continue;
6551             default:
6552               oops:
6553                 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
6554                         gv_ename(namegv), SvPV((SV*)cv, n_a));
6555             }
6556         }
6557         else
6558             list(o2);
6559         mod(o2, OP_ENTERSUB);
6560         prev = o2;
6561         o2 = o2->op_sibling;
6562     }
6563     if (proto && !optional &&
6564           (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6565         return too_few_arguments(o, gv_ename(namegv));
6566     return o;
6567 }
6568
6569 OP *
6570 Perl_ck_svconst(pTHX_ OP *o)
6571 {
6572     SvREADONLY_on(cSVOPo->op_sv);
6573     return o;
6574 }
6575
6576 OP *
6577 Perl_ck_trunc(pTHX_ OP *o)
6578 {
6579     if (o->op_flags & OPf_KIDS) {
6580         SVOP *kid = (SVOP*)cUNOPo->op_first;
6581
6582         if (kid->op_type == OP_NULL)
6583             kid = (SVOP*)kid->op_sibling;
6584         if (kid && kid->op_type == OP_CONST &&
6585             (kid->op_private & OPpCONST_BARE))
6586         {
6587             o->op_flags |= OPf_SPECIAL;
6588             kid->op_private &= ~OPpCONST_STRICT;
6589         }
6590     }
6591     return ck_fun(o);
6592 }
6593
6594 OP *
6595 Perl_ck_substr(pTHX_ OP *o)
6596 {
6597     o = ck_fun(o);
6598     if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6599         OP *kid = cLISTOPo->op_first;
6600
6601         if (kid->op_type == OP_NULL)
6602             kid = kid->op_sibling;
6603         if (kid)
6604             kid->op_flags |= OPf_MOD;
6605
6606     }
6607     return o;
6608 }
6609
6610 /* A peephole optimizer.  We visit the ops in the order they're to execute. */
6611
6612 void
6613 Perl_peep(pTHX_ register OP *o)
6614 {
6615     register OP* oldop = 0;
6616     STRLEN n_a;
6617
6618     if (!o || o->op_seq)
6619         return;
6620     ENTER;
6621     SAVEOP();
6622     SAVEVPTR(PL_curcop);
6623     for (; o; o = o->op_next) {
6624         if (o->op_seq)
6625             break;
6626         if (!PL_op_seqmax)
6627             PL_op_seqmax++;
6628         PL_op = o;
6629         switch (o->op_type) {
6630         case OP_SETSTATE:
6631         case OP_NEXTSTATE:
6632         case OP_DBSTATE:
6633             PL_curcop = ((COP*)o);              /* for warnings */
6634             o->op_seq = PL_op_seqmax++;
6635             break;
6636
6637         case OP_CONST:
6638             if (cSVOPo->op_private & OPpCONST_STRICT)
6639                 no_bareword_allowed(o);
6640 #ifdef USE_ITHREADS
6641             /* Relocate sv to the pad for thread safety.
6642              * Despite being a "constant", the SV is written to,
6643              * for reference counts, sv_upgrade() etc. */
6644             if (cSVOP->op_sv) {
6645                 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6646                 if (SvPADTMP(cSVOPo->op_sv)) {
6647                     /* If op_sv is already a PADTMP then it is being used by
6648                      * some pad, so make a copy. */
6649                     sv_setsv(PL_curpad[ix],cSVOPo->op_sv);
6650                     SvREADONLY_on(PL_curpad[ix]);
6651                     SvREFCNT_dec(cSVOPo->op_sv);
6652                 }
6653                 else {
6654                     SvREFCNT_dec(PL_curpad[ix]);
6655                     SvPADTMP_on(cSVOPo->op_sv);
6656                     PL_curpad[ix] = cSVOPo->op_sv;
6657                     /* XXX I don't know how this isn't readonly already. */
6658                     SvREADONLY_on(PL_curpad[ix]);
6659                 }
6660                 cSVOPo->op_sv = Nullsv;
6661                 o->op_targ = ix;
6662             }
6663 #endif
6664             o->op_seq = PL_op_seqmax++;
6665             break;
6666
6667         case OP_CONCAT:
6668             if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6669                 if (o->op_next->op_private & OPpTARGET_MY) {
6670                     if (o->op_flags & OPf_STACKED) /* chained concats */
6671                         goto ignore_optimization;
6672                     else {
6673                         /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6674                         o->op_targ = o->op_next->op_targ;
6675                         o->op_next->op_targ = 0;
6676                         o->op_private |= OPpTARGET_MY;
6677                     }
6678                 }
6679                 null(o->op_next);
6680             }
6681           ignore_optimization:
6682             o->op_seq = PL_op_seqmax++;
6683             break;
6684         case OP_STUB:
6685             if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6686                 o->op_seq = PL_op_seqmax++;
6687                 break; /* Scalar stub must produce undef.  List stub is noop */
6688             }
6689             goto nothin;
6690         case OP_NULL:
6691             if (o->op_targ == OP_NEXTSTATE
6692                 || o->op_targ == OP_DBSTATE
6693                 || o->op_targ == OP_SETSTATE)
6694             {
6695                 PL_curcop = ((COP*)o);
6696             }
6697             goto nothin;
6698         case OP_SCALAR:
6699         case OP_LINESEQ:
6700         case OP_SCOPE:
6701           nothin:
6702             if (oldop && o->op_next) {
6703                 oldop->op_next = o->op_next;
6704                 continue;
6705             }
6706             o->op_seq = PL_op_seqmax++;
6707             break;
6708
6709         case OP_GV:
6710             if (o->op_next->op_type == OP_RV2SV) {
6711                 if (!(o->op_next->op_private & OPpDEREF)) {
6712                     null(o->op_next);
6713                     o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6714                                                                | OPpOUR_INTRO);
6715                     o->op_next = o->op_next->op_next;
6716                     o->op_type = OP_GVSV;
6717                     o->op_ppaddr = PL_ppaddr[OP_GVSV];
6718                 }
6719             }
6720             else if (o->op_next->op_type == OP_RV2AV) {
6721                 OP* pop = o->op_next->op_next;
6722                 IV i;
6723                 if (pop->op_type == OP_CONST &&
6724                     (PL_op = pop->op_next) &&
6725                     pop->op_next->op_type == OP_AELEM &&
6726                     !(pop->op_next->op_private &
6727                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6728                     (i = SvIV(((SVOP*)pop)->op_sv) - PL_compiling.cop_arybase)
6729                                 <= 255 &&
6730                     i >= 0)
6731                 {
6732                     GV *gv;
6733                     null(o->op_next);
6734                     null(pop->op_next);
6735                     null(pop);
6736                     o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6737                     o->op_next = pop->op_next->op_next;
6738                     o->op_type = OP_AELEMFAST;
6739                     o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6740                     o->op_private = (U8)i;
6741                     gv = cGVOPo_gv;
6742                     GvAVn(gv);
6743                 }
6744             }
6745             else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6746                 GV *gv = cGVOPo_gv;
6747                 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6748                     /* XXX could check prototype here instead of just carping */
6749                     SV *sv = sv_newmortal();
6750                     gv_efullname3(sv, gv, Nullch);
6751                     Perl_warner(aTHX_ WARN_PROTOTYPE,
6752                                 "%s() called too early to check prototype",
6753                                 SvPV_nolen(sv));
6754                 }
6755             }
6756
6757             o->op_seq = PL_op_seqmax++;
6758             break;
6759
6760         case OP_MAPWHILE:
6761         case OP_GREPWHILE:
6762         case OP_AND:
6763         case OP_OR:
6764         case OP_ANDASSIGN:
6765         case OP_ORASSIGN:
6766         case OP_COND_EXPR:
6767         case OP_RANGE:
6768             o->op_seq = PL_op_seqmax++;
6769             while (cLOGOP->op_other->op_type == OP_NULL)
6770                 cLOGOP->op_other = cLOGOP->op_other->op_next;
6771             peep(cLOGOP->op_other);
6772             break;
6773
6774         case OP_ENTERLOOP:
6775             o->op_seq = PL_op_seqmax++;
6776             while (cLOOP->op_redoop->op_type == OP_NULL)
6777                 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6778             peep(cLOOP->op_redoop);
6779             while (cLOOP->op_nextop->op_type == OP_NULL)
6780                 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6781             peep(cLOOP->op_nextop);
6782             while (cLOOP->op_lastop->op_type == OP_NULL)
6783                 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6784             peep(cLOOP->op_lastop);
6785             break;
6786
6787         case OP_QR:
6788         case OP_MATCH:
6789         case OP_SUBST:
6790             o->op_seq = PL_op_seqmax++;
6791             while (cPMOP->op_pmreplstart &&
6792                    cPMOP->op_pmreplstart->op_type == OP_NULL)
6793                 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6794             peep(cPMOP->op_pmreplstart);
6795             break;
6796
6797         case OP_EXEC:
6798             o->op_seq = PL_op_seqmax++;
6799             if (ckWARN(WARN_SYNTAX) && o->op_next
6800                 && o->op_next->op_type == OP_NEXTSTATE) {
6801                 if (o->op_next->op_sibling &&
6802                         o->op_next->op_sibling->op_type != OP_EXIT &&
6803                         o->op_next->op_sibling->op_type != OP_WARN &&
6804                         o->op_next->op_sibling->op_type != OP_DIE) {
6805                     line_t oldline = CopLINE(PL_curcop);
6806
6807                     CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6808                     Perl_warner(aTHX_ WARN_EXEC,
6809                                 "Statement unlikely to be reached");
6810                     Perl_warner(aTHX_ WARN_EXEC,
6811                                 "\t(Maybe you meant system() when you said exec()?)\n");
6812                     CopLINE_set(PL_curcop, oldline);
6813                 }
6814             }
6815             break;
6816
6817         case OP_HELEM: {
6818             UNOP *rop;
6819             SV *lexname;
6820             GV **fields;
6821             SV **svp, **indsvp, *sv;
6822             I32 ind;
6823             char *key = NULL;
6824             STRLEN keylen;
6825
6826             o->op_seq = PL_op_seqmax++;
6827
6828             if (((BINOP*)o)->op_last->op_type != OP_CONST)
6829                 break;
6830
6831             /* Make the CONST have a shared SV */
6832             svp = cSVOPx_svp(((BINOP*)o)->op_last);
6833             if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6834                 key = SvPV(sv, keylen);
6835                 if (SvUTF8(sv))
6836                   keylen = -keylen;
6837                 lexname = newSVpvn_share(key, keylen, 0);
6838                 SvREFCNT_dec(sv);
6839                 *svp = lexname;
6840             }
6841
6842             if ((o->op_private & (OPpLVAL_INTRO)))
6843                 break;
6844
6845             rop = (UNOP*)((BINOP*)o)->op_first;
6846             if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6847                 break;
6848             lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6849             if (!SvOBJECT(lexname))
6850                 break;
6851             fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6852             if (!fields || !GvHV(*fields))
6853                 break;
6854             key = SvPV(*svp, keylen);
6855             if (SvUTF8(*svp))
6856                 keylen = -keylen;
6857             indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE);
6858             if (!indsvp) {
6859                 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s",
6860                       key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
6861             }
6862             ind = SvIV(*indsvp);
6863             if (ind < 1)
6864                 Perl_croak(aTHX_ "Bad index while coercing array into hash");
6865             rop->op_type = OP_RV2AV;
6866             rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
6867             o->op_type = OP_AELEM;
6868             o->op_ppaddr = PL_ppaddr[OP_AELEM];
6869             sv = newSViv(ind);
6870             if (SvREADONLY(*svp))
6871                 SvREADONLY_on(sv);
6872             SvFLAGS(sv) |= (SvFLAGS(*svp)
6873                             & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
6874             SvREFCNT_dec(*svp);
6875             *svp = sv;
6876             break;
6877         }
6878
6879         case OP_HSLICE: {
6880             UNOP *rop;
6881             SV *lexname;
6882             GV **fields;
6883             SV **svp, **indsvp, *sv;
6884             I32 ind;
6885             char *key;
6886             STRLEN keylen;
6887             SVOP *first_key_op, *key_op;
6888
6889             o->op_seq = PL_op_seqmax++;
6890             if ((o->op_private & (OPpLVAL_INTRO))
6891                 /* I bet there's always a pushmark... */
6892                 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
6893                 /* hmmm, no optimization if list contains only one key. */
6894                 break;
6895             rop = (UNOP*)((LISTOP*)o)->op_last;
6896             if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6897                 break;
6898             lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6899             if (!SvOBJECT(lexname))
6900                 break;
6901             fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6902             if (!fields || !GvHV(*fields))
6903                 break;
6904             /* Again guessing that the pushmark can be jumped over.... */
6905             first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
6906                 ->op_first->op_sibling;
6907             /* Check that the key list contains only constants. */
6908             for (key_op = first_key_op; key_op;
6909                  key_op = (SVOP*)key_op->op_sibling)
6910                 if (key_op->op_type != OP_CONST)
6911                     break;
6912             if (key_op)
6913                 break;
6914             rop->op_type = OP_RV2AV;
6915             rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
6916             o->op_type = OP_ASLICE;
6917             o->op_ppaddr = PL_ppaddr[OP_ASLICE];
6918             for (key_op = first_key_op; key_op;
6919                  key_op = (SVOP*)key_op->op_sibling) {
6920                 svp = cSVOPx_svp(key_op);
6921                 key = SvPV(*svp, keylen);
6922                 if (SvUTF8(*svp))
6923                     keylen = -keylen;
6924                 indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE);
6925                 if (!indsvp) {
6926                     Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
6927                                "in variable %s of type %s",
6928                           key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
6929                 }
6930                 ind = SvIV(*indsvp);
6931                 if (ind < 1)
6932                     Perl_croak(aTHX_ "Bad index while coercing array into hash");
6933                 sv = newSViv(ind);
6934                 if (SvREADONLY(*svp))
6935                     SvREADONLY_on(sv);
6936                 SvFLAGS(sv) |= (SvFLAGS(*svp)
6937                                 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
6938                 SvREFCNT_dec(*svp);
6939                 *svp = sv;
6940             }
6941             break;
6942         }
6943
6944         default:
6945             o->op_seq = PL_op_seqmax++;
6946             break;
6947         }
6948         oldop = o;
6949     }
6950     LEAVE;
6951 }
6952
6953 #include "XSUB.h"
6954
6955 /* Efficient sub that returns a constant scalar value. */
6956 static void
6957 const_sv_xsub(pTHXo_ CV* cv)
6958 {
6959     dXSARGS;
6960     if (items != 0) {
6961 #if 0
6962         Perl_croak(aTHX_ "usage: %s::%s()",
6963                    HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
6964 #endif
6965     }
6966     EXTEND(sp, 1);
6967     ST(0) = (SV*)XSANY.any_ptr;
6968     XSRETURN(1);
6969 }