op.c

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