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