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     if (!block || !ps || *ps || attrs)
4552         const_sv = Nullsv;
4553     else
4554         const_sv = op_const_sv(block, Nullcv);
4555
4556     if (cv) {
4557         bool exists = CvROOT(cv) || CvXSUB(cv);
4558         /* if the subroutine doesn't exist and wasn't pre-declared
4559          * with a prototype, assume it will be AUTOLOADed,
4560          * skipping the prototype check
4561          */
4562         if (exists || SvPOK(cv))
4563             cv_ckproto(cv, gv, ps);
4564         /* already defined (or promised)? */
4565         if (exists || GvASSUMECV(gv)) {
4566             if (!block && !attrs) {
4567                 /* just a "sub foo;" when &foo is already defined */
4568                 SAVEFREESV(PL_compcv);
4569                 goto done;
4570             }
4571             /* ahem, death to those who redefine active sort subs */
4572             if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4573                 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4574             if (block) {
4575                 if (ckWARN(WARN_REDEFINE)
4576                     || (CvCONST(cv)
4577                         && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4578                 {
4579                     line_t oldline = CopLINE(PL_curcop);
4580                     CopLINE_set(PL_curcop, PL_copline);
4581                     Perl_warner(aTHX_ WARN_REDEFINE,
4582                         CvCONST(cv) ? "Constant subroutine %s redefined"
4583                                     : "Subroutine %s redefined", name);
4584                     CopLINE_set(PL_curcop, oldline);
4585                 }
4586                 SvREFCNT_dec(cv);
4587                 cv = Nullcv;
4588             }
4589         }
4590     }
4591     if (const_sv) {
4592         SvREFCNT_inc(const_sv);
4593         if (cv) {
4594             assert(!CvROOT(cv) && !CvCONST(cv));
4595             sv_setpv((SV*)cv, "");  /* prototype is "" */
4596             CvXSUBANY(cv).any_ptr = const_sv;
4597             CvXSUB(cv) = const_sv_xsub;
4598             CvCONST_on(cv);
4599         }
4600         else {
4601             GvCV(gv) = Nullcv;
4602             cv = newCONSTSUB(NULL, name, const_sv);
4603         }
4604         op_free(block);
4605         SvREFCNT_dec(PL_compcv);
4606         PL_compcv = NULL;
4607         PL_sub_generation++;
4608         goto done;
4609     }
4610     if (attrs) {
4611         HV *stash;
4612         SV *rcv;
4613
4614         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4615          * before we clobber PL_compcv.
4616          */
4617         if (cv && !block) {
4618             rcv = (SV*)cv;
4619             if (CvGV(cv) && GvSTASH(CvGV(cv)) && HvNAME(GvSTASH(CvGV(cv))))
4620                 stash = GvSTASH(CvGV(cv));
4621             else if (CvSTASH(cv) && HvNAME(CvSTASH(cv)))
4622                 stash = CvSTASH(cv);
4623             else
4624                 stash = PL_curstash;
4625         }
4626         else {
4627             /* possibly about to re-define existing subr -- ignore old cv */
4628             rcv = (SV*)PL_compcv;
4629             if (name && GvSTASH(gv) && HvNAME(GvSTASH(gv)))
4630                 stash = GvSTASH(gv);
4631             else
4632                 stash = PL_curstash;
4633         }
4634         apply_attrs(stash, rcv, attrs);
4635     }
4636     if (cv) {                           /* must reuse cv if autoloaded */
4637         if (!block) {
4638             /* got here with just attrs -- work done, so bug out */
4639             SAVEFREESV(PL_compcv);
4640             goto done;
4641         }
4642         cv_undef(cv);
4643         CvFLAGS(cv) = CvFLAGS(PL_compcv);
4644         CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4645         CvOUTSIDE(PL_compcv) = 0;
4646         CvPADLIST(cv) = CvPADLIST(PL_compcv);
4647         CvPADLIST(PL_compcv) = 0;
4648         if (SvREFCNT(PL_compcv) > 1) /* XXX Make closures transit through stub. */
4649             CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc((SV*)cv);
4650         SvREFCNT_dec(PL_compcv);
4651     }
4652     else {
4653         cv = PL_compcv;
4654         if (name) {
4655             GvCV(gv) = cv;
4656             GvCVGEN(gv) = 0;
4657             PL_sub_generation++;
4658         }
4659     }
4660     CvGV(cv) = (GV*)SvREFCNT_inc(gv);
4661     CvFILE(cv) = CopFILE(PL_curcop);
4662     CvSTASH(cv) = PL_curstash;
4663 #ifdef USE_THREADS
4664     CvOWNER(cv) = 0;
4665     if (!CvMUTEXP(cv)) {
4666         New(666, CvMUTEXP(cv), 1, perl_mutex);
4667         MUTEX_INIT(CvMUTEXP(cv));
4668     }
4669 #endif /* USE_THREADS */
4670
4671     if (ps)
4672         sv_setpv((SV*)cv, ps);
4673
4674     if (PL_error_count) {
4675         op_free(block);
4676         block = Nullop;
4677         if (name) {
4678             char *s = strrchr(name, ':');
4679             s = s ? s+1 : name;
4680             if (strEQ(s, "BEGIN")) {
4681                 char *not_safe =
4682                     "BEGIN not safe after errors--compilation aborted";
4683                 if (PL_in_eval & EVAL_KEEPERR)
4684                     Perl_croak(aTHX_ not_safe);
4685                 else {
4686                     /* force display of errors found but not reported */
4687                     sv_catpv(ERRSV, not_safe);
4688                     Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
4689                 }
4690             }
4691         }
4692     }
4693     if (!block)
4694         goto done;
4695
4696     if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
4697         av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
4698
4699     if (CvLVALUE(cv)) {
4700         CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4701                              mod(scalarseq(block), OP_LEAVESUBLV));
4702     }
4703     else {
4704         CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
4705     }
4706     CvROOT(cv)->op_private |= OPpREFCOUNTED;
4707     OpREFCNT_set(CvROOT(cv), 1);
4708     CvSTART(cv) = LINKLIST(CvROOT(cv));
4709     CvROOT(cv)->op_next = 0;
4710     peep(CvSTART(cv));
4711
4712     /* now that optimizer has done its work, adjust pad values */
4713     if (CvCLONE(cv)) {
4714         SV **namep = AvARRAY(PL_comppad_name);
4715         for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4716             SV *namesv;
4717
4718             if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4719                 continue;
4720             /*
4721              * The only things that a clonable function needs in its
4722              * pad are references to outer lexicals and anonymous subs.
4723              * The rest are created anew during cloning.
4724              */
4725             if (!((namesv = namep[ix]) != Nullsv &&
4726                   namesv != &PL_sv_undef &&
4727                   (SvFAKE(namesv) ||
4728                    *SvPVX(namesv) == '&')))
4729             {
4730                 SvREFCNT_dec(PL_curpad[ix]);
4731                 PL_curpad[ix] = Nullsv;
4732             }
4733         }
4734         assert(!CvCONST(cv));
4735         if (ps && !*ps && op_const_sv(block, cv))
4736             CvCONST_on(cv);
4737     }
4738     else {
4739         AV *av = newAV();                       /* Will be @_ */
4740         av_extend(av, 0);
4741         av_store(PL_comppad, 0, (SV*)av);
4742         AvFLAGS(av) = AVf_REIFY;
4743
4744         for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
4745             if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
4746                 continue;
4747             if (!SvPADMY(PL_curpad[ix]))
4748                 SvPADTMP_on(PL_curpad[ix]);
4749         }
4750     }
4751
4752     if (name || aname) {
4753         char *s;
4754         char *tname = (name ? name : aname);
4755
4756         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
4757             SV *sv = NEWSV(0,0);
4758             SV *tmpstr = sv_newmortal();
4759             GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
4760             CV *pcv;
4761             HV *hv;
4762
4763             Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
4764                            CopFILE(PL_curcop),
4765                            (long)PL_subline, (long)CopLINE(PL_curcop));
4766             gv_efullname3(tmpstr, gv, Nullch);
4767             hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
4768             hv = GvHVn(db_postponed);
4769             if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
4770                 && (pcv = GvCV(db_postponed)))
4771             {
4772                 dSP;
4773                 PUSHMARK(SP);
4774                 XPUSHs(tmpstr);
4775                 PUTBACK;
4776                 call_sv((SV*)pcv, G_DISCARD);
4777             }
4778         }
4779
4780         if ((s = strrchr(tname,':')))
4781             s++;
4782         else
4783             s = tname;
4784
4785         if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4786             goto done;
4787
4788         if (strEQ(s, "BEGIN")) {
4789             I32 oldscope = PL_scopestack_ix;
4790             ENTER;
4791             SAVECOPFILE(&PL_compiling);
4792             SAVECOPLINE(&PL_compiling);
4793             save_svref(&PL_rs);
4794             sv_setsv(PL_rs, PL_nrs);
4795
4796             if (!PL_beginav)
4797                 PL_beginav = newAV();
4798             DEBUG_x( dump_sub(gv) );
4799             av_push(PL_beginav, (SV*)cv);
4800             GvCV(gv) = 0;               /* cv has been hijacked */
4801             call_list(oldscope, PL_beginav);
4802
4803             PL_curcop = &PL_compiling;
4804             PL_compiling.op_private = PL_hints;
4805             LEAVE;
4806         }
4807         else if (strEQ(s, "END") && !PL_error_count) {
4808             if (!PL_endav)
4809                 PL_endav = newAV();
4810             DEBUG_x( dump_sub(gv) );
4811             av_unshift(PL_endav, 1);
4812             av_store(PL_endav, 0, (SV*)cv);
4813             GvCV(gv) = 0;               /* cv has been hijacked */
4814         }
4815         else if (strEQ(s, "CHECK") && !PL_error_count) {
4816             if (!PL_checkav)
4817                 PL_checkav = newAV();
4818             DEBUG_x( dump_sub(gv) );
4819             if (PL_main_start && ckWARN(WARN_VOID))
4820                 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
4821             av_unshift(PL_checkav, 1);
4822             av_store(PL_checkav, 0, (SV*)cv);
4823             GvCV(gv) = 0;               /* cv has been hijacked */
4824         }
4825         else if (strEQ(s, "INIT") && !PL_error_count) {
4826             if (!PL_initav)
4827                 PL_initav = newAV();
4828             DEBUG_x( dump_sub(gv) );
4829             if (PL_main_start && ckWARN(WARN_VOID))
4830                 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
4831             av_push(PL_initav, (SV*)cv);
4832             GvCV(gv) = 0;               /* cv has been hijacked */
4833         }
4834     }
4835
4836   done:
4837     PL_copline = NOLINE;
4838     LEAVE_SCOPE(floor);
4839     return cv;
4840 }
4841
4842 /* XXX unsafe for threads if eval_owner isn't held */
4843 /*
4844 =for apidoc newCONSTSUB
4845
4846 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
4847 eligible for inlining at compile-time.
4848
4849 =cut
4850 */
4851
4852 CV *
4853 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
4854 {
4855     CV* cv;
4856
4857     ENTER;
4858
4859     SAVECOPLINE(PL_curcop);
4860     CopLINE_set(PL_curcop, PL_copline);
4861
4862     SAVEHINTS();
4863     PL_hints &= ~HINT_BLOCK_SCOPE;
4864
4865     if (stash) {
4866         SAVESPTR(PL_curstash);
4867         SAVECOPSTASH(PL_curcop);
4868         PL_curstash = stash;
4869 #ifdef USE_ITHREADS
4870         CopSTASHPV(PL_curcop) = stash ? HvNAME(stash) : Nullch;
4871 #else
4872         CopSTASH(PL_curcop) = stash;
4873 #endif
4874     }
4875
4876     cv = newXS(name, const_sv_xsub, __FILE__);
4877     CvXSUBANY(cv).any_ptr = sv;
4878     CvCONST_on(cv);
4879     sv_setpv((SV*)cv, "");  /* prototype is "" */
4880
4881     LEAVE;
4882
4883     return cv;
4884 }
4885
4886 /*
4887 =for apidoc U||newXS
4888
4889 Used by C<xsubpp> to hook up XSUBs as Perl subs.
4890
4891 =cut
4892 */
4893
4894 CV *
4895 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
4896 {
4897     GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV);
4898     register CV *cv;
4899
4900     if ((cv = (name ? GvCV(gv) : Nullcv))) {
4901         if (GvCVGEN(gv)) {
4902             /* just a cached method */
4903             SvREFCNT_dec(cv);
4904             cv = 0;
4905         }
4906         else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
4907             /* already defined (or promised) */
4908             if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
4909                             && HvNAME(GvSTASH(CvGV(cv)))
4910                             && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
4911                 line_t oldline = CopLINE(PL_curcop);
4912                 if (PL_copline != NOLINE)
4913                     CopLINE_set(PL_curcop, PL_copline);
4914                 Perl_warner(aTHX_ WARN_REDEFINE,
4915                             CvCONST(cv) ? "Constant subroutine %s redefined"
4916                                         : "Subroutine %s redefined"
4917                             ,name);
4918                 CopLINE_set(PL_curcop, oldline);
4919             }
4920             SvREFCNT_dec(cv);
4921             cv = 0;
4922         }
4923     }
4924
4925     if (cv)                             /* must reuse cv if autoloaded */
4926         cv_undef(cv);
4927     else {
4928         cv = (CV*)NEWSV(1105,0);
4929         sv_upgrade((SV *)cv, SVt_PVCV);
4930         if (name) {
4931             GvCV(gv) = cv;
4932             GvCVGEN(gv) = 0;
4933             PL_sub_generation++;
4934         }
4935     }
4936     CvGV(cv) = (GV*)SvREFCNT_inc(gv);
4937 #ifdef USE_THREADS
4938     New(666, CvMUTEXP(cv), 1, perl_mutex);
4939     MUTEX_INIT(CvMUTEXP(cv));
4940     CvOWNER(cv) = 0;
4941 #endif /* USE_THREADS */
4942     (void)gv_fetchfile(filename);
4943     CvFILE(cv) = filename;      /* NOTE: not copied, as it is expected to be
4944                                    an external constant string */
4945     CvXSUB(cv) = subaddr;
4946
4947     if (name) {
4948         char *s = strrchr(name,':');
4949         if (s)
4950             s++;
4951         else
4952             s = name;
4953
4954         if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
4955             goto done;
4956
4957         if (strEQ(s, "BEGIN")) {
4958             if (!PL_beginav)
4959                 PL_beginav = newAV();
4960             av_push(PL_beginav, (SV*)cv);
4961             GvCV(gv) = 0;               /* cv has been hijacked */
4962         }
4963         else if (strEQ(s, "END")) {
4964             if (!PL_endav)
4965                 PL_endav = newAV();
4966             av_unshift(PL_endav, 1);
4967             av_store(PL_endav, 0, (SV*)cv);
4968             GvCV(gv) = 0;               /* cv has been hijacked */
4969         }
4970         else if (strEQ(s, "CHECK")) {
4971             if (!PL_checkav)
4972                 PL_checkav = newAV();
4973             if (PL_main_start && ckWARN(WARN_VOID))
4974                 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
4975             av_unshift(PL_checkav, 1);
4976             av_store(PL_checkav, 0, (SV*)cv);
4977             GvCV(gv) = 0;               /* cv has been hijacked */
4978         }
4979         else if (strEQ(s, "INIT")) {
4980             if (!PL_initav)
4981                 PL_initav = newAV();
4982             if (PL_main_start && ckWARN(WARN_VOID))
4983                 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
4984             av_push(PL_initav, (SV*)cv);
4985             GvCV(gv) = 0;               /* cv has been hijacked */
4986         }
4987     }
4988     else
4989         CvANON_on(cv);
4990
4991 done:
4992     return cv;
4993 }
4994
4995 void
4996 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
4997 {
4998     register CV *cv;
4999     char *name;
5000     GV *gv;
5001     I32 ix;
5002     STRLEN n_a;
5003
5004     if (o)
5005         name = SvPVx(cSVOPo->op_sv, n_a);
5006     else
5007         name = "STDOUT";
5008     gv = gv_fetchpv(name,TRUE, SVt_PVFM);
5009     GvMULTI_on(gv);
5010     if ((cv = GvFORM(gv))) {
5011         if (ckWARN(WARN_REDEFINE)) {
5012             line_t oldline = CopLINE(PL_curcop);
5013
5014             CopLINE_set(PL_curcop, PL_copline);
5015             Perl_warner(aTHX_ WARN_REDEFINE, "Format %s redefined",name);
5016             CopLINE_set(PL_curcop, oldline);
5017         }
5018         SvREFCNT_dec(cv);
5019     }
5020     cv = PL_compcv;
5021     GvFORM(gv) = cv;
5022     CvGV(cv) = (GV*)SvREFCNT_inc(gv);
5023     CvFILE(cv) = CopFILE(PL_curcop);
5024
5025     for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5026         if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
5027             SvPADTMP_on(PL_curpad[ix]);
5028     }
5029
5030     CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5031     CvROOT(cv)->op_private |= OPpREFCOUNTED;
5032     OpREFCNT_set(CvROOT(cv), 1);
5033     CvSTART(cv) = LINKLIST(CvROOT(cv));
5034     CvROOT(cv)->op_next = 0;
5035     peep(CvSTART(cv));
5036     op_free(o);
5037     PL_copline = NOLINE;
5038     LEAVE_SCOPE(floor);
5039 }
5040
5041 OP *
5042 Perl_newANONLIST(pTHX_ OP *o)
5043 {
5044     return newUNOP(OP_REFGEN, 0,
5045         mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5046 }
5047
5048 OP *
5049 Perl_newANONHASH(pTHX_ OP *o)
5050 {
5051     return newUNOP(OP_REFGEN, 0,
5052         mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5053 }
5054
5055 OP *
5056 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5057 {
5058     return newANONATTRSUB(floor, proto, Nullop, block);
5059 }
5060
5061 OP *
5062 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5063 {
5064     return newUNOP(OP_REFGEN, 0,
5065         newSVOP(OP_ANONCODE, 0,
5066                 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5067 }
5068
5069 OP *
5070 Perl_oopsAV(pTHX_ OP *o)
5071 {
5072     switch (o->op_type) {
5073     case OP_PADSV:
5074         o->op_type = OP_PADAV;
5075         o->op_ppaddr = PL_ppaddr[OP_PADAV];
5076         return ref(o, OP_RV2AV);
5077
5078     case OP_RV2SV:
5079         o->op_type = OP_RV2AV;
5080         o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5081         ref(o, OP_RV2AV);
5082         break;
5083
5084     default:
5085         if (ckWARN_d(WARN_INTERNAL))
5086             Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsAV");
5087         break;
5088     }
5089     return o;
5090 }
5091
5092 OP *
5093 Perl_oopsHV(pTHX_ OP *o)
5094 {
5095     switch (o->op_type) {
5096     case OP_PADSV:
5097     case OP_PADAV:
5098         o->op_type = OP_PADHV;
5099         o->op_ppaddr = PL_ppaddr[OP_PADHV];
5100         return ref(o, OP_RV2HV);
5101
5102     case OP_RV2SV:
5103     case OP_RV2AV:
5104         o->op_type = OP_RV2HV;
5105         o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5106         ref(o, OP_RV2HV);
5107         break;
5108
5109     default:
5110         if (ckWARN_d(WARN_INTERNAL))
5111             Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsHV");
5112         break;
5113     }
5114     return o;
5115 }
5116
5117 OP *
5118 Perl_newAVREF(pTHX_ OP *o)
5119 {
5120     if (o->op_type == OP_PADANY) {
5121         o->op_type = OP_PADAV;
5122         o->op_ppaddr = PL_ppaddr[OP_PADAV];
5123         return o;
5124     }
5125     return newUNOP(OP_RV2AV, 0, scalar(o));
5126 }
5127
5128 OP *
5129 Perl_newGVREF(pTHX_ I32 type, OP *o)
5130 {
5131     if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5132         return newUNOP(OP_NULL, 0, o);
5133     return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5134 }
5135
5136 OP *
5137 Perl_newHVREF(pTHX_ OP *o)
5138 {
5139     if (o->op_type == OP_PADANY) {
5140         o->op_type = OP_PADHV;
5141         o->op_ppaddr = PL_ppaddr[OP_PADHV];
5142         return o;
5143     }
5144     return newUNOP(OP_RV2HV, 0, scalar(o));
5145 }
5146
5147 OP *
5148 Perl_oopsCV(pTHX_ OP *o)
5149 {
5150     Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5151     /* STUB */
5152     return o;
5153 }
5154
5155 OP *
5156 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5157 {
5158     return newUNOP(OP_RV2CV, flags, scalar(o));
5159 }
5160
5161 OP *
5162 Perl_newSVREF(pTHX_ OP *o)
5163 {
5164     if (o->op_type == OP_PADANY) {
5165         o->op_type = OP_PADSV;
5166         o->op_ppaddr = PL_ppaddr[OP_PADSV];
5167         return o;
5168     }
5169     else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5170         o->op_flags |= OPpDONE_SVREF;
5171         return o;
5172     }
5173     return newUNOP(OP_RV2SV, 0, scalar(o));
5174 }
5175
5176 /* Check routines. */
5177
5178 OP *
5179 Perl_ck_anoncode(pTHX_ OP *o)
5180 {
5181     PADOFFSET ix;
5182     SV* name;
5183
5184     name = NEWSV(1106,0);
5185     sv_upgrade(name, SVt_PVNV);
5186     sv_setpvn(name, "&", 1);
5187     SvIVX(name) = -1;
5188     SvNVX(name) = 1;
5189     ix = pad_alloc(o->op_type, SVs_PADMY);
5190     av_store(PL_comppad_name, ix, name);
5191     av_store(PL_comppad, ix, cSVOPo->op_sv);
5192     SvPADMY_on(cSVOPo->op_sv);
5193     cSVOPo->op_sv = Nullsv;
5194     cSVOPo->op_targ = ix;
5195     return o;
5196 }
5197
5198 OP *
5199 Perl_ck_bitop(pTHX_ OP *o)
5200 {
5201     o->op_private = PL_hints;
5202     return o;
5203 }
5204
5205 OP *
5206 Perl_ck_concat(pTHX_ OP *o)
5207 {
5208     if (cUNOPo->op_first->op_type == OP_CONCAT)
5209         o->op_flags |= OPf_STACKED;
5210     return o;
5211 }
5212
5213 OP *
5214 Perl_ck_spair(pTHX_ OP *o)
5215 {
5216     if (o->op_flags & OPf_KIDS) {
5217         OP* newop;
5218         OP* kid;
5219         OPCODE type = o->op_type;
5220         o = modkids(ck_fun(o), type);
5221         kid = cUNOPo->op_first;
5222         newop = kUNOP->op_first->op_sibling;
5223         if (newop &&
5224             (newop->op_sibling ||
5225              !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5226              newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5227              newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5228
5229             return o;
5230         }
5231         op_free(kUNOP->op_first);
5232         kUNOP->op_first = newop;
5233     }
5234     o->op_ppaddr = PL_ppaddr[++o->op_type];
5235     return ck_fun(o);
5236 }
5237
5238 OP *
5239 Perl_ck_delete(pTHX_ OP *o)
5240 {
5241     o = ck_fun(o);
5242     o->op_private = 0;
5243     if (o->op_flags & OPf_KIDS) {
5244         OP *kid = cUNOPo->op_first;
5245         switch (kid->op_type) {
5246         case OP_ASLICE:
5247             o->op_flags |= OPf_SPECIAL;
5248             /* FALL THROUGH */
5249         case OP_HSLICE:
5250             o->op_private |= OPpSLICE;
5251             break;
5252         case OP_AELEM:
5253             o->op_flags |= OPf_SPECIAL;
5254             /* FALL THROUGH */
5255         case OP_HELEM:
5256             break;
5257         default:
5258             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5259                   PL_op_desc[o->op_type]);
5260         }
5261         null(kid);
5262     }
5263     return o;
5264 }
5265
5266 OP *
5267 Perl_ck_eof(pTHX_ OP *o)
5268 {
5269     I32 type = o->op_type;
5270
5271     if (o->op_flags & OPf_KIDS) {
5272         if (cLISTOPo->op_first->op_type == OP_STUB) {
5273             op_free(o);
5274             o = newUNOP(type, OPf_SPECIAL,
5275                 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
5276         }
5277         return ck_fun(o);
5278     }
5279     return o;
5280 }
5281
5282 OP *
5283 Perl_ck_eval(pTHX_ OP *o)
5284 {
5285     PL_hints |= HINT_BLOCK_SCOPE;
5286     if (o->op_flags & OPf_KIDS) {
5287         SVOP *kid = (SVOP*)cUNOPo->op_first;
5288
5289         if (!kid) {
5290             o->op_flags &= ~OPf_KIDS;
5291             null(o);
5292         }
5293         else if (kid->op_type == OP_LINESEQ) {
5294             LOGOP *enter;
5295
5296             kid->op_next = o->op_next;
5297             cUNOPo->op_first = 0;
5298             op_free(o);
5299
5300             NewOp(1101, enter, 1, LOGOP);
5301             enter->op_type = OP_ENTERTRY;
5302             enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5303             enter->op_private = 0;
5304
5305             /* establish postfix order */
5306             enter->op_next = (OP*)enter;
5307
5308             o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5309             o->op_type = OP_LEAVETRY;
5310             o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5311             enter->op_other = o;
5312             return o;
5313         }
5314         else
5315             scalar((OP*)kid);
5316     }
5317     else {
5318         op_free(o);
5319         o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5320     }
5321     o->op_targ = (PADOFFSET)PL_hints;
5322     return o;
5323 }
5324
5325 OP *
5326 Perl_ck_exit(pTHX_ OP *o)
5327 {
5328 #ifdef VMS
5329     HV *table = GvHV(PL_hintgv);
5330     if (table) {
5331        SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5332        if (svp && *svp && SvTRUE(*svp))
5333            o->op_private |= OPpEXIT_VMSISH;
5334     }
5335 #endif
5336     return ck_fun(o);
5337 }
5338
5339 OP *
5340 Perl_ck_exec(pTHX_ OP *o)
5341 {
5342     OP *kid;
5343     if (o->op_flags & OPf_STACKED) {
5344         o = ck_fun(o);
5345         kid = cUNOPo->op_first->op_sibling;
5346         if (kid->op_type == OP_RV2GV)
5347             null(kid);
5348     }
5349     else
5350         o = listkids(o);
5351     return o;
5352 }
5353
5354 OP *
5355 Perl_ck_exists(pTHX_ OP *o)
5356 {
5357     o = ck_fun(o);
5358     if (o->op_flags & OPf_KIDS) {
5359         OP *kid = cUNOPo->op_first;
5360         if (kid->op_type == OP_ENTERSUB) {
5361             (void) ref(kid, o->op_type);
5362             if (kid->op_type != OP_RV2CV && !PL_error_count)
5363                 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5364                            PL_op_desc[o->op_type]);
5365             o->op_private |= OPpEXISTS_SUB;
5366         }
5367         else if (kid->op_type == OP_AELEM)
5368             o->op_flags |= OPf_SPECIAL;
5369         else if (kid->op_type != OP_HELEM)
5370             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5371                        PL_op_desc[o->op_type]);
5372         null(kid);
5373     }
5374     return o;
5375 }
5376
5377 #if 0
5378 OP *
5379 Perl_ck_gvconst(pTHX_ register OP *o)
5380 {
5381     o = fold_constants(o);
5382     if (o->op_type == OP_CONST)
5383         o->op_type = OP_GV;
5384     return o;
5385 }
5386 #endif
5387
5388 OP *
5389 Perl_ck_rvconst(pTHX_ register OP *o)
5390 {
5391     SVOP *kid = (SVOP*)cUNOPo->op_first;
5392
5393     o->op_private |= (PL_hints & HINT_STRICT_REFS);
5394     if (kid->op_type == OP_CONST) {
5395         char *name;
5396         int iscv;
5397         GV *gv;
5398         SV *kidsv = kid->op_sv;
5399         STRLEN n_a;
5400
5401         /* Is it a constant from cv_const_sv()? */
5402         if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5403             SV *rsv = SvRV(kidsv);
5404             int svtype = SvTYPE(rsv);
5405             char *badtype = Nullch;
5406
5407             switch (o->op_type) {
5408             case OP_RV2SV:
5409                 if (svtype > SVt_PVMG)
5410                     badtype = "a SCALAR";
5411                 break;
5412             case OP_RV2AV:
5413                 if (svtype != SVt_PVAV)
5414                     badtype = "an ARRAY";
5415                 break;
5416             case OP_RV2HV:
5417                 if (svtype != SVt_PVHV) {
5418                     if (svtype == SVt_PVAV) {   /* pseudohash? */
5419                         SV **ksv = av_fetch((AV*)rsv, 0, FALSE);
5420                         if (ksv && SvROK(*ksv)
5421                             && SvTYPE(SvRV(*ksv)) == SVt_PVHV)
5422                         {
5423                                 break;
5424                         }
5425                     }
5426                     badtype = "a HASH";
5427                 }
5428                 break;
5429             case OP_RV2CV:
5430                 if (svtype != SVt_PVCV)
5431                     badtype = "a CODE";
5432                 break;
5433             }
5434             if (badtype)
5435                 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5436             return o;
5437         }
5438         name = SvPV(kidsv, n_a);
5439         if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5440             char *badthing = Nullch;
5441             switch (o->op_type) {
5442             case OP_RV2SV:
5443                 badthing = "a SCALAR";
5444                 break;
5445             case OP_RV2AV:
5446                 badthing = "an ARRAY";
5447                 break;
5448             case OP_RV2HV:
5449                 badthing = "a HASH";
5450                 break;
5451             }
5452             if (badthing)
5453                 Perl_croak(aTHX_
5454           "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5455                       name, badthing);
5456         }
5457         /*
5458          * This is a little tricky.  We only want to add the symbol if we
5459          * didn't add it in the lexer.  Otherwise we get duplicate strict
5460          * warnings.  But if we didn't add it in the lexer, we must at
5461          * least pretend like we wanted to add it even if it existed before,
5462          * or we get possible typo warnings.  OPpCONST_ENTERED says
5463          * whether the lexer already added THIS instance of this symbol.
5464          */
5465         iscv = (o->op_type == OP_RV2CV) * 2;
5466         do {
5467             gv = gv_fetchpv(name,
5468                 iscv | !(kid->op_private & OPpCONST_ENTERED),
5469                 iscv
5470                     ? SVt_PVCV
5471                     : o->op_type == OP_RV2SV
5472                         ? SVt_PV
5473                         : o->op_type == OP_RV2AV
5474                             ? SVt_PVAV
5475                             : o->op_type == OP_RV2HV
5476                                 ? SVt_PVHV
5477                                 : SVt_PVGV);
5478         } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5479         if (gv) {
5480             kid->op_type = OP_GV;
5481             SvREFCNT_dec(kid->op_sv);
5482 #ifdef USE_ITHREADS
5483             /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5484             kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5485             SvREFCNT_dec(PL_curpad[kPADOP->op_padix]);
5486             GvIN_PAD_on(gv);
5487             PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv);
5488 #else
5489             kid->op_sv = SvREFCNT_inc(gv);
5490 #endif
5491             kid->op_private = 0;
5492             kid->op_ppaddr = PL_ppaddr[OP_GV];
5493         }
5494     }
5495     return o;
5496 }
5497
5498 OP *
5499 Perl_ck_ftst(pTHX_ OP *o)
5500 {
5501     I32 type = o->op_type;
5502
5503     if (o->op_flags & OPf_REF) {
5504         /* nothing */
5505     }
5506     else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5507         SVOP *kid = (SVOP*)cUNOPo->op_first;
5508
5509         if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5510             STRLEN n_a;
5511             OP *newop = newGVOP(type, OPf_REF,
5512                 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5513             op_free(o);
5514             o = newop;
5515         }
5516     }
5517     else {
5518         op_free(o);
5519         if (type == OP_FTTTY)
5520            o =  newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
5521                                 SVt_PVIO));
5522         else
5523             o = newUNOP(type, 0, newDEFSVOP());
5524     }
5525 #ifdef USE_LOCALE
5526     if (type == OP_FTTEXT || type == OP_FTBINARY) {
5527         o->op_private = 0;
5528         if (PL_hints & HINT_LOCALE)
5529             o->op_private |= OPpLOCALE;
5530     }
5531 #endif
5532     return o;
5533 }
5534
5535 OP *
5536 Perl_ck_fun(pTHX_ OP *o)
5537 {
5538     register OP *kid;
5539     OP **tokid;
5540     OP *sibl;
5541     I32 numargs = 0;
5542     int type = o->op_type;
5543     register I32 oa = PL_opargs[type] >> OASHIFT;
5544
5545     if (o->op_flags & OPf_STACKED) {
5546         if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5547             oa &= ~OA_OPTIONAL;
5548         else
5549             return no_fh_allowed(o);
5550     }
5551
5552     if (o->op_flags & OPf_KIDS) {
5553         STRLEN n_a;
5554         tokid = &cLISTOPo->op_first;
5555         kid = cLISTOPo->op_first;
5556         if (kid->op_type == OP_PUSHMARK ||
5557             (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5558         {
5559             tokid = &kid->op_sibling;
5560             kid = kid->op_sibling;
5561         }
5562         if (!kid && PL_opargs[type] & OA_DEFGV)
5563             *tokid = kid = newDEFSVOP();
5564
5565         while (oa && kid) {
5566             numargs++;
5567             sibl = kid->op_sibling;
5568             switch (oa & 7) {
5569             case OA_SCALAR:
5570                 /* list seen where single (scalar) arg expected? */
5571                 if (numargs == 1 && !(oa >> 4)
5572                     && kid->op_type == OP_LIST && type != OP_SCALAR)
5573                 {
5574                     return too_many_arguments(o,PL_op_desc[type]);
5575                 }
5576                 scalar(kid);
5577                 break;
5578             case OA_LIST:
5579                 if (oa < 16) {
5580                     kid = 0;
5581                     continue;
5582                 }
5583                 else
5584                     list(kid);
5585                 break;
5586             case OA_AVREF:
5587                 if (kid->op_type == OP_CONST &&
5588                     (kid->op_private & OPpCONST_BARE))
5589                 {
5590                     char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5591                     OP *newop = newAVREF(newGVOP(OP_GV, 0,
5592                         gv_fetchpv(name, TRUE, SVt_PVAV) ));
5593                     if (ckWARN(WARN_DEPRECATED))
5594                         Perl_warner(aTHX_ WARN_DEPRECATED,
5595                             "Array @%s missing the @ in argument %"IVdf" of %s()",
5596                             name, (IV)numargs, PL_op_desc[type]);
5597                     op_free(kid);
5598                     kid = newop;
5599                     kid->op_sibling = sibl;
5600                     *tokid = kid;
5601                 }
5602                 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5603                     bad_type(numargs, "array", PL_op_desc[type], kid);
5604                 mod(kid, type);
5605                 break;
5606             case OA_HVREF:
5607                 if (kid->op_type == OP_CONST &&
5608                     (kid->op_private & OPpCONST_BARE))
5609                 {
5610                     char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5611                     OP *newop = newHVREF(newGVOP(OP_GV, 0,
5612                         gv_fetchpv(name, TRUE, SVt_PVHV) ));
5613                     if (ckWARN(WARN_DEPRECATED))
5614                         Perl_warner(aTHX_ WARN_DEPRECATED,
5615                             "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5616                             name, (IV)numargs, PL_op_desc[type]);
5617                     op_free(kid);
5618                     kid = newop;
5619                     kid->op_sibling = sibl;
5620                     *tokid = kid;
5621                 }
5622                 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5623                     bad_type(numargs, "hash", PL_op_desc[type], kid);
5624                 mod(kid, type);
5625                 break;
5626             case OA_CVREF:
5627                 {
5628                     OP *newop = newUNOP(OP_NULL, 0, kid);
5629                     kid->op_sibling = 0;
5630                     linklist(kid);
5631                     newop->op_next = newop;
5632                     kid = newop;
5633                     kid->op_sibling = sibl;
5634                     *tokid = kid;
5635                 }
5636                 break;
5637             case OA_FILEREF:
5638                 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5639                     if (kid->op_type == OP_CONST &&
5640                         (kid->op_private & OPpCONST_BARE))
5641                     {
5642                         OP *newop = newGVOP(OP_GV, 0,
5643                             gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5644                                         SVt_PVIO) );
5645                         op_free(kid);
5646                         kid = newop;
5647                     }
5648                     else if (kid->op_type == OP_READLINE) {
5649                         /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5650                         bad_type(numargs, "HANDLE", PL_op_desc[o->op_type], kid);
5651                     }
5652                     else {
5653                         I32 flags = OPf_SPECIAL;
5654                         I32 priv = 0;
5655                         PADOFFSET targ = 0;
5656
5657                         /* is this op a FH constructor? */
5658                         if (is_handle_constructor(o,numargs)) {
5659                             char *name = Nullch;
5660                             STRLEN len;
5661
5662                             flags = 0;
5663                             /* Set a flag to tell rv2gv to vivify
5664                              * need to "prove" flag does not mean something
5665                              * else already - NI-S 1999/05/07
5666                              */
5667                             priv = OPpDEREF;
5668                             if (kid->op_type == OP_PADSV) {
5669                                 SV **namep = av_fetch(PL_comppad_name,
5670                                                       kid->op_targ, 4);
5671                                 if (namep && *namep)
5672                                     name = SvPV(*namep, len);
5673                             }
5674                             else if (kid->op_type == OP_RV2SV
5675                                      && kUNOP->op_first->op_type == OP_GV)
5676                             {
5677                                 GV *gv = cGVOPx_gv(kUNOP->op_first);
5678                                 name = GvNAME(gv);
5679                                 len = GvNAMELEN(gv);
5680                             }
5681                             else if (kid->op_type == OP_AELEM
5682                                      || kid->op_type == OP_HELEM)
5683                             {
5684                                 name = "__ANONIO__";
5685                                 len = 10;
5686                                 mod(kid,type);
5687                             }
5688                             if (name) {
5689                                 SV *namesv;
5690                                 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
5691                                 namesv = PL_curpad[targ];
5692                                 (void)SvUPGRADE(namesv, SVt_PV);
5693                                 if (*name != '$')
5694                                     sv_setpvn(namesv, "$", 1);
5695                                 sv_catpvn(namesv, name, len);
5696                             }
5697                         }
5698                         kid->op_sibling = 0;
5699                         kid = newUNOP(OP_RV2GV, flags, scalar(kid));
5700                         kid->op_targ = targ;
5701                         kid->op_private |= priv;
5702                     }
5703                     kid->op_sibling = sibl;
5704                     *tokid = kid;
5705                 }
5706                 scalar(kid);
5707                 break;
5708             case OA_SCALARREF:
5709                 mod(scalar(kid), type);
5710                 break;
5711             }
5712             oa >>= 4;
5713             tokid = &kid->op_sibling;
5714             kid = kid->op_sibling;
5715         }
5716         o->op_private |= numargs;
5717         if (kid)
5718             return too_many_arguments(o,PL_op_desc[o->op_type]);
5719         listkids(o);
5720     }
5721     else if (PL_opargs[type] & OA_DEFGV) {
5722         op_free(o);
5723         return newUNOP(type, 0, newDEFSVOP());
5724     }
5725
5726     if (oa) {
5727         while (oa & OA_OPTIONAL)
5728             oa >>= 4;
5729         if (oa && oa != OA_LIST)
5730             return too_few_arguments(o,PL_op_desc[o->op_type]);
5731     }
5732     return o;
5733 }
5734
5735 OP *
5736 Perl_ck_glob(pTHX_ OP *o)
5737 {
5738     GV *gv;
5739
5740     o = ck_fun(o);
5741     if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
5742         append_elem(OP_GLOB, o, newDEFSVOP());
5743
5744     if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV)) && GvIMPORTED_CV(gv)))
5745         gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5746
5747 #if !defined(PERL_EXTERNAL_GLOB)
5748     /* XXX this can be tightened up and made more failsafe. */
5749     if (!gv) {
5750         ENTER;
5751         Perl_load_module(aTHX_ 0, newSVpvn("File::Glob", 10), Nullsv,
5752                          /* null-terminated import list */
5753                          newSVpvn(":globally", 9), Nullsv);
5754         gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
5755         LEAVE;
5756     }
5757 #endif /* PERL_EXTERNAL_GLOB */
5758
5759     if (gv && GvIMPORTED_CV(gv)) {
5760         append_elem(OP_GLOB, o,
5761                     newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
5762         o->op_type = OP_LIST;
5763         o->op_ppaddr = PL_ppaddr[OP_LIST];
5764         cLISTOPo->op_first->op_type = OP_PUSHMARK;
5765         cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
5766         o = newUNOP(OP_ENTERSUB, OPf_STACKED,
5767                     append_elem(OP_LIST, o,
5768                                 scalar(newUNOP(OP_RV2CV, 0,
5769                                                newGVOP(OP_GV, 0, gv)))));
5770         o = newUNOP(OP_NULL, 0, ck_subr(o));
5771         o->op_targ = OP_GLOB;           /* hint at what it used to be */
5772         return o;
5773     }
5774     gv = newGVgen("main");
5775     gv_IOadd(gv);
5776     append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
5777     scalarkids(o);
5778     return o;
5779 }
5780
5781 OP *
5782 Perl_ck_grep(pTHX_ OP *o)
5783 {
5784     LOGOP *gwop;
5785     OP *kid;
5786     OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
5787
5788     o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
5789     NewOp(1101, gwop, 1, LOGOP);
5790
5791     if (o->op_flags & OPf_STACKED) {
5792         OP* k;
5793         o = ck_sort(o);
5794         kid = cLISTOPo->op_first->op_sibling;
5795         for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
5796             kid = k;
5797         }
5798         kid->op_next = (OP*)gwop;
5799         o->op_flags &= ~OPf_STACKED;
5800     }
5801     kid = cLISTOPo->op_first->op_sibling;
5802     if (type == OP_MAPWHILE)
5803         list(kid);
5804     else
5805         scalar(kid);
5806     o = ck_fun(o);
5807     if (PL_error_count)
5808         return o;
5809     kid = cLISTOPo->op_first->op_sibling;
5810     if (kid->op_type != OP_NULL)
5811         Perl_croak(aTHX_ "panic: ck_grep");
5812     kid = kUNOP->op_first;
5813
5814     gwop->op_type = type;
5815     gwop->op_ppaddr = PL_ppaddr[type];
5816     gwop->op_first = listkids(o);
5817     gwop->op_flags |= OPf_KIDS;
5818     gwop->op_private = 1;
5819     gwop->op_other = LINKLIST(kid);
5820     gwop->op_targ = pad_alloc(type, SVs_PADTMP);
5821     kid->op_next = (OP*)gwop;
5822
5823     kid = cLISTOPo->op_first->op_sibling;
5824     if (!kid || !kid->op_sibling)
5825         return too_few_arguments(o,PL_op_desc[o->op_type]);
5826     for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
5827         mod(kid, OP_GREPSTART);
5828
5829     return (OP*)gwop;
5830 }
5831
5832 OP *
5833 Perl_ck_index(pTHX_ OP *o)
5834 {
5835     if (o->op_flags & OPf_KIDS) {
5836         OP *kid = cLISTOPo->op_first->op_sibling;       /* get past pushmark */
5837         if (kid)
5838             kid = kid->op_sibling;                      /* get past "big" */
5839         if (kid && kid->op_type == OP_CONST)
5840             fbm_compile(((SVOP*)kid)->op_sv, 0);
5841     }
5842     return ck_fun(o);
5843 }
5844
5845 OP *
5846 Perl_ck_lengthconst(pTHX_ OP *o)
5847 {
5848     /* XXX length optimization goes here */
5849     return ck_fun(o);
5850 }
5851
5852 OP *
5853 Perl_ck_lfun(pTHX_ OP *o)
5854 {
5855     OPCODE type = o->op_type;
5856     return modkids(ck_fun(o), type);
5857 }
5858
5859 OP *
5860 Perl_ck_defined(pTHX_ OP *o)            /* 19990527 MJD */
5861 {
5862     if ((o->op_flags & OPf_KIDS) && ckWARN(WARN_DEPRECATED)) {
5863         switch (cUNOPo->op_first->op_type) {
5864         case OP_RV2AV:
5865             /* This is needed for
5866                if (defined %stash::)
5867                to work.   Do not break Tk.
5868                */
5869             break;                      /* Globals via GV can be undef */
5870         case OP_PADAV:
5871         case OP_AASSIGN:                /* Is this a good idea? */
5872             Perl_warner(aTHX_ WARN_DEPRECATED,
5873                         "defined(@array) is deprecated");
5874             Perl_warner(aTHX_ WARN_DEPRECATED,
5875                         "\t(Maybe you should just omit the defined()?)\n");
5876         break;
5877         case OP_RV2HV:
5878             /* This is needed for
5879                if (defined %stash::)
5880                to work.   Do not break Tk.
5881                */
5882             break;                      /* Globals via GV can be undef */
5883         case OP_PADHV:
5884             Perl_warner(aTHX_ WARN_DEPRECATED,
5885                         "defined(%%hash) is deprecated");
5886             Perl_warner(aTHX_ WARN_DEPRECATED,
5887                         "\t(Maybe you should just omit the defined()?)\n");
5888             break;
5889         default:
5890             /* no warning */
5891             break;
5892         }
5893     }
5894     return ck_rfun(o);
5895 }
5896
5897 OP *
5898 Perl_ck_rfun(pTHX_ OP *o)
5899 {
5900     OPCODE type = o->op_type;
5901     return refkids(ck_fun(o), type);
5902 }
5903
5904 OP *
5905 Perl_ck_listiob(pTHX_ OP *o)
5906 {
5907     register OP *kid;
5908
5909     kid = cLISTOPo->op_first;
5910     if (!kid) {
5911         o = force_list(o);
5912         kid = cLISTOPo->op_first;
5913     }
5914     if (kid->op_type == OP_PUSHMARK)
5915         kid = kid->op_sibling;
5916     if (kid && o->op_flags & OPf_STACKED)
5917         kid = kid->op_sibling;
5918     else if (kid && !kid->op_sibling) {         /* print HANDLE; */
5919         if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
5920             o->op_flags |= OPf_STACKED; /* make it a filehandle */
5921             kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
5922             cLISTOPo->op_first->op_sibling = kid;
5923             cLISTOPo->op_last = kid;
5924             kid = kid->op_sibling;
5925         }
5926     }
5927
5928     if (!kid)
5929         append_elem(o->op_type, o, newDEFSVOP());
5930
5931     o = listkids(o);
5932
5933     o->op_private = 0;
5934 #ifdef USE_LOCALE
5935     if (PL_hints & HINT_LOCALE)
5936         o->op_private |= OPpLOCALE;
5937 #endif
5938
5939     return o;
5940 }
5941
5942 OP *
5943 Perl_ck_fun_locale(pTHX_ OP *o)
5944 {
5945     o = ck_fun(o);
5946
5947     o->op_private = 0;
5948 #ifdef USE_LOCALE
5949     if (PL_hints & HINT_LOCALE)
5950         o->op_private |= OPpLOCALE;
5951 #endif
5952
5953     return o;
5954 }
5955
5956 OP *
5957 Perl_ck_sassign(pTHX_ OP *o)
5958 {
5959     OP *kid = cLISTOPo->op_first;
5960     /* has a disposable target? */
5961     if ((PL_opargs[kid->op_type] & OA_TARGLEX)
5962         && !(kid->op_flags & OPf_STACKED)
5963         /* Cannot steal the second time! */
5964         && !(kid->op_private & OPpTARGET_MY))
5965     {
5966         OP *kkid = kid->op_sibling;
5967
5968         /* Can just relocate the target. */
5969         if (kkid && kkid->op_type == OP_PADSV
5970             && !(kkid->op_private & OPpLVAL_INTRO))
5971         {
5972             kid->op_targ = kkid->op_targ;
5973             kkid->op_targ = 0;
5974             /* Now we do not need PADSV and SASSIGN. */
5975             kid->op_sibling = o->op_sibling;    /* NULL */
5976             cLISTOPo->op_first = NULL;
5977             op_free(o);
5978             op_free(kkid);
5979             kid->op_private |= OPpTARGET_MY;    /* Used for context settings */
5980             return kid;
5981         }
5982     }
5983     return o;
5984 }
5985
5986 OP *
5987 Perl_ck_scmp(pTHX_ OP *o)
5988 {
5989     o->op_private = 0;
5990 #ifdef USE_LOCALE
5991     if (PL_hints & HINT_LOCALE)
5992         o->op_private |= OPpLOCALE;
5993 #endif
5994
5995     return o;
5996 }
5997
5998 OP *
5999 Perl_ck_match(pTHX_ OP *o)
6000 {
6001     o->op_private |= OPpRUNTIME;
6002     return o;
6003 }
6004
6005 OP *
6006 Perl_ck_method(pTHX_ OP *o)
6007 {
6008     OP *kid = cUNOPo->op_first;
6009     if (kid->op_type == OP_CONST) {
6010         SV* sv = kSVOP->op_sv;
6011         if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
6012             OP *cmop;
6013             if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6014                 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
6015             }
6016             else {
6017                 kSVOP->op_sv = Nullsv;
6018             }
6019             cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6020             op_free(o);
6021             return cmop;
6022         }
6023     }
6024     return o;
6025 }
6026
6027 OP *
6028 Perl_ck_null(pTHX_ OP *o)
6029 {
6030     return o;
6031 }
6032
6033 OP *
6034 Perl_ck_open(pTHX_ OP *o)
6035 {
6036     HV *table = GvHV(PL_hintgv);
6037     if (table) {
6038         SV **svp;
6039         I32 mode;
6040         svp = hv_fetch(table, "open_IN", 7, FALSE);
6041         if (svp && *svp) {
6042             mode = mode_from_discipline(*svp);
6043             if (mode & O_BINARY)
6044                 o->op_private |= OPpOPEN_IN_RAW;
6045             else if (mode & O_TEXT)
6046                 o->op_private |= OPpOPEN_IN_CRLF;
6047         }
6048
6049         svp = hv_fetch(table, "open_OUT", 8, FALSE);
6050         if (svp && *svp) {
6051             mode = mode_from_discipline(*svp);
6052             if (mode & O_BINARY)
6053                 o->op_private |= OPpOPEN_OUT_RAW;
6054             else if (mode & O_TEXT)
6055                 o->op_private |= OPpOPEN_OUT_CRLF;
6056         }
6057     }
6058     if (o->op_type == OP_BACKTICK)
6059         return o;
6060     return ck_fun(o);
6061 }
6062
6063 OP *
6064 Perl_ck_repeat(pTHX_ OP *o)
6065 {
6066     if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6067         o->op_private |= OPpREPEAT_DOLIST;
6068         cBINOPo->op_first = force_list(cBINOPo->op_first);
6069     }
6070     else
6071         scalar(o);
6072     return o;
6073 }
6074
6075 OP *
6076 Perl_ck_require(pTHX_ OP *o)
6077 {
6078     if (o->op_flags & OPf_KIDS) {       /* Shall we supply missing .pm? */
6079         SVOP *kid = (SVOP*)cUNOPo->op_first;
6080
6081         if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6082             char *s;
6083             for (s = SvPVX(kid->op_sv); *s; s++) {
6084                 if (*s == ':' && s[1] == ':') {
6085                     *s = '/';
6086                     Move(s+2, s+1, strlen(s+2)+1, char);
6087                     --SvCUR(kid->op_sv);
6088                 }
6089             }
6090             if (SvREADONLY(kid->op_sv)) {
6091                 SvREADONLY_off(kid->op_sv);
6092                 sv_catpvn(kid->op_sv, ".pm", 3);
6093                 SvREADONLY_on(kid->op_sv);
6094             }
6095             else
6096                 sv_catpvn(kid->op_sv, ".pm", 3);
6097         }
6098     }
6099     return ck_fun(o);
6100 }
6101
6102 OP *
6103 Perl_ck_return(pTHX_ OP *o)
6104 {
6105     OP *kid;
6106     if (CvLVALUE(PL_compcv)) {
6107         for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6108             mod(kid, OP_LEAVESUBLV);
6109     }
6110     return o;
6111 }
6112
6113 #if 0
6114 OP *
6115 Perl_ck_retarget(pTHX_ OP *o)
6116 {
6117     Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
6118     /* STUB */
6119     return o;
6120 }
6121 #endif
6122
6123 OP *
6124 Perl_ck_select(pTHX_ OP *o)
6125 {
6126     OP* kid;
6127     if (o->op_flags & OPf_KIDS) {
6128         kid = cLISTOPo->op_first->op_sibling;   /* get past pushmark */
6129         if (kid && kid->op_sibling) {
6130             o->op_type = OP_SSELECT;
6131             o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6132             o = ck_fun(o);
6133             return fold_constants(o);
6134         }
6135     }
6136     o = ck_fun(o);
6137     kid = cLISTOPo->op_first->op_sibling;    /* get past pushmark */
6138     if (kid && kid->op_type == OP_RV2GV)
6139         kid->op_private &= ~HINT_STRICT_REFS;
6140     return o;
6141 }
6142
6143 OP *
6144 Perl_ck_shift(pTHX_ OP *o)
6145 {
6146     I32 type = o->op_type;
6147
6148     if (!(o->op_flags & OPf_KIDS)) {
6149         OP *argop;
6150
6151         op_free(o);
6152 #ifdef USE_THREADS
6153         if (!CvUNIQUE(PL_compcv)) {
6154             argop = newOP(OP_PADAV, OPf_REF);
6155             argop->op_targ = 0;         /* PL_curpad[0] is @_ */
6156         }
6157         else {
6158             argop = newUNOP(OP_RV2AV, 0,
6159                 scalar(newGVOP(OP_GV, 0,
6160                     gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6161         }
6162 #else
6163         argop = newUNOP(OP_RV2AV, 0,
6164             scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
6165                            PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6166 #endif /* USE_THREADS */
6167         return newUNOP(type, 0, scalar(argop));
6168     }
6169     return scalar(modkids(ck_fun(o), type));
6170 }
6171
6172 OP *
6173 Perl_ck_sort(pTHX_ OP *o)
6174 {
6175     OP *firstkid;
6176     o->op_private = 0;
6177 #ifdef USE_LOCALE
6178     if (PL_hints & HINT_LOCALE)
6179         o->op_private |= OPpLOCALE;
6180 #endif
6181
6182     if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6183         simplify_sort(o);
6184     firstkid = cLISTOPo->op_first->op_sibling;          /* get past pushmark */
6185     if (o->op_flags & OPf_STACKED) {                    /* may have been cleared */
6186         OP *k;
6187         OP *kid = cUNOPx(firstkid)->op_first;           /* get past null */
6188
6189         if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6190             linklist(kid);
6191             if (kid->op_type == OP_SCOPE) {
6192                 k = kid->op_next;
6193                 kid->op_next = 0;
6194             }
6195             else if (kid->op_type == OP_LEAVE) {
6196                 if (o->op_type == OP_SORT) {
6197                     null(kid);                  /* wipe out leave */
6198                     kid->op_next = kid;
6199
6200                     for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6201                         if (k->op_next == kid)
6202                             k->op_next = 0;
6203                         /* don't descend into loops */
6204                         else if (k->op_type == OP_ENTERLOOP
6205                                  || k->op_type == OP_ENTERITER)
6206                         {
6207                             k = cLOOPx(k)->op_lastop;
6208                         }
6209                     }
6210                 }
6211                 else
6212                     kid->op_next = 0;           /* just disconnect the leave */
6213                 k = kLISTOP->op_first;
6214             }
6215             peep(k);
6216
6217             kid = firstkid;
6218             if (o->op_type == OP_SORT) {
6219                 /* provide scalar context for comparison function/block */
6220                 kid = scalar(kid);
6221                 kid->op_next = kid;
6222             }
6223             else
6224                 kid->op_next = k;
6225             o->op_flags |= OPf_SPECIAL;
6226         }
6227         else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6228             null(firstkid);
6229
6230         firstkid = firstkid->op_sibling;
6231     }
6232
6233     /* provide list context for arguments */
6234     if (o->op_type == OP_SORT)
6235         list(firstkid);
6236
6237     return o;
6238 }
6239
6240 STATIC void
6241 S_simplify_sort(pTHX_ OP *o)
6242 {
6243     register OP *kid = cLISTOPo->op_first->op_sibling;  /* get past pushmark */
6244     OP *k;
6245     int reversed;
6246     GV *gv;
6247     if (!(o->op_flags & OPf_STACKED))
6248         return;
6249     GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6250     GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6251     kid = kUNOP->op_first;                              /* get past null */
6252     if (kid->op_type != OP_SCOPE)
6253         return;
6254     kid = kLISTOP->op_last;                             /* get past scope */
6255     switch(kid->op_type) {
6256         case OP_NCMP:
6257         case OP_I_NCMP:
6258         case OP_SCMP:
6259             break;
6260         default:
6261             return;
6262     }
6263     k = kid;                                            /* remember this node*/
6264     if (kBINOP->op_first->op_type != OP_RV2SV)
6265         return;
6266     kid = kBINOP->op_first;                             /* get past cmp */
6267     if (kUNOP->op_first->op_type != OP_GV)
6268         return;
6269     kid = kUNOP->op_first;                              /* get past rv2sv */
6270     gv = kGVOP_gv;
6271     if (GvSTASH(gv) != PL_curstash)
6272         return;
6273     if (strEQ(GvNAME(gv), "a"))
6274         reversed = 0;
6275     else if (strEQ(GvNAME(gv), "b"))
6276         reversed = 1;
6277     else
6278         return;
6279     kid = k;                                            /* back to cmp */
6280     if (kBINOP->op_last->op_type != OP_RV2SV)
6281         return;
6282     kid = kBINOP->op_last;                              /* down to 2nd arg */
6283     if (kUNOP->op_first->op_type != OP_GV)
6284         return;
6285     kid = kUNOP->op_first;                              /* get past rv2sv */
6286     gv = kGVOP_gv;
6287     if (GvSTASH(gv) != PL_curstash
6288         || ( reversed
6289             ? strNE(GvNAME(gv), "a")
6290             : strNE(GvNAME(gv), "b")))
6291         return;
6292     o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6293     if (reversed)
6294         o->op_private |= OPpSORT_REVERSE;
6295     if (k->op_type == OP_NCMP)
6296         o->op_private |= OPpSORT_NUMERIC;
6297     if (k->op_type == OP_I_NCMP)
6298         o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6299     kid = cLISTOPo->op_first->op_sibling;
6300     cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6301     op_free(kid);                                     /* then delete it */
6302 }
6303
6304 OP *
6305 Perl_ck_split(pTHX_ OP *o)
6306 {
6307     register OP *kid;
6308
6309     if (o->op_flags & OPf_STACKED)
6310         return no_fh_allowed(o);
6311
6312     kid = cLISTOPo->op_first;
6313     if (kid->op_type != OP_NULL)
6314         Perl_croak(aTHX_ "panic: ck_split");
6315     kid = kid->op_sibling;
6316     op_free(cLISTOPo->op_first);
6317     cLISTOPo->op_first = kid;
6318     if (!kid) {
6319         cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6320         cLISTOPo->op_last = kid; /* There was only one element previously */
6321     }
6322
6323     if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6324         OP *sibl = kid->op_sibling;
6325         kid->op_sibling = 0;
6326         kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
6327         if (cLISTOPo->op_first == cLISTOPo->op_last)
6328             cLISTOPo->op_last = kid;
6329         cLISTOPo->op_first = kid;
6330         kid->op_sibling = sibl;
6331     }
6332
6333     kid->op_type = OP_PUSHRE;
6334     kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6335     scalar(kid);
6336
6337     if (!kid->op_sibling)
6338         append_elem(OP_SPLIT, o, newDEFSVOP());
6339
6340     kid = kid->op_sibling;
6341     scalar(kid);
6342
6343     if (!kid->op_sibling)
6344         append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6345
6346     kid = kid->op_sibling;
6347     scalar(kid);
6348
6349     if (kid->op_sibling)
6350         return too_many_arguments(o,PL_op_desc[o->op_type]);
6351
6352     return o;
6353 }
6354
6355 OP *
6356 Perl_ck_join(pTHX_ OP *o)
6357 {
6358     if (ckWARN(WARN_SYNTAX)) {
6359         OP *kid = cLISTOPo->op_first->op_sibling;
6360         if (kid && kid->op_type == OP_MATCH) {
6361             char *pmstr = "STRING";
6362             if (kPMOP->op_pmregexp)
6363                 pmstr = kPMOP->op_pmregexp->precomp;
6364             Perl_warner(aTHX_ WARN_SYNTAX,
6365                         "/%s/ should probably be written as \"%s\"",
6366                         pmstr, pmstr);
6367         }
6368     }
6369     return ck_fun(o);
6370 }
6371
6372 OP *
6373 Perl_ck_subr(pTHX_ OP *o)
6374 {
6375     OP *prev = ((cUNOPo->op_first->op_sibling)
6376              ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6377     OP *o2 = prev->op_sibling;
6378     OP *cvop;
6379     char *proto = 0;
6380     CV *cv = 0;
6381     GV *namegv = 0;
6382     int optional = 0;
6383     I32 arg = 0;
6384     STRLEN n_a;
6385
6386     o->op_private |= OPpENTERSUB_HASTARG;
6387     for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6388     if (cvop->op_type == OP_RV2CV) {
6389         SVOP* tmpop;
6390         o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6391         null(cvop);             /* disable rv2cv */
6392         tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6393         if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6394             GV *gv = cGVOPx_gv(tmpop);
6395             cv = GvCVu(gv);
6396             if (!cv)
6397                 tmpop->op_private |= OPpEARLY_CV;
6398             else if (SvPOK(cv)) {
6399                 namegv = CvANON(cv) ? gv : CvGV(cv);
6400                 proto = SvPV((SV*)cv, n_a);
6401             }
6402         }
6403     }
6404     else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6405         if (o2->op_type == OP_CONST)
6406             o2->op_private &= ~OPpCONST_STRICT;
6407         else if (o2->op_type == OP_LIST) {
6408             OP *o = ((UNOP*)o2)->op_first->op_sibling;
6409             if (o && o->op_type == OP_CONST)
6410                 o->op_private &= ~OPpCONST_STRICT;
6411         }
6412     }
6413     o->op_private |= (PL_hints & HINT_STRICT_REFS);
6414     if (PERLDB_SUB && PL_curstash != PL_debstash)
6415         o->op_private |= OPpENTERSUB_DB;
6416     while (o2 != cvop) {
6417         if (proto) {
6418             switch (*proto) {
6419             case '\0':
6420                 return too_many_arguments(o, gv_ename(namegv));
6421             case ';':
6422                 optional = 1;
6423                 proto++;
6424                 continue;
6425             case '$':
6426                 proto++;
6427                 arg++;
6428                 scalar(o2);
6429                 break;
6430             case '%':
6431             case '@':
6432                 list(o2);
6433                 arg++;
6434                 break;
6435             case '&':
6436                 proto++;
6437                 arg++;
6438                 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6439                     bad_type(arg,
6440                         arg == 1 ? "block or sub {}" : "sub {}",
6441                         gv_ename(namegv), o2);
6442                 break;
6443             case '*':
6444                 /* '*' allows any scalar type, including bareword */
6445                 proto++;
6446                 arg++;
6447                 if (o2->op_type == OP_RV2GV)
6448                     goto wrapref;       /* autoconvert GLOB -> GLOBref */
6449                 else if (o2->op_type == OP_CONST)
6450                     o2->op_private &= ~OPpCONST_STRICT;
6451                 else if (o2->op_type == OP_ENTERSUB) {
6452                     /* accidental subroutine, revert to bareword */
6453                     OP *gvop = ((UNOP*)o2)->op_first;
6454                     if (gvop && gvop->op_type == OP_NULL) {
6455                         gvop = ((UNOP*)gvop)->op_first;
6456                         if (gvop) {
6457                             for (; gvop->op_sibling; gvop = gvop->op_sibling)
6458                                 ;
6459                             if (gvop &&
6460                                 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6461                                 (gvop = ((UNOP*)gvop)->op_first) &&
6462                                 gvop->op_type == OP_GV)
6463                             {
6464                                 GV *gv = cGVOPx_gv(gvop);
6465                                 OP *sibling = o2->op_sibling;
6466                                 SV *n = newSVpvn("",0);
6467                                 op_free(o2);
6468                                 gv_fullname3(n, gv, "");
6469                                 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6470                                     sv_chop(n, SvPVX(n)+6);
6471                                 o2 = newSVOP(OP_CONST, 0, n);
6472                                 prev->op_sibling = o2;
6473                                 o2->op_sibling = sibling;
6474                             }
6475                         }
6476                     }
6477                 }
6478                 scalar(o2);
6479                 break;
6480             case '\\':
6481                 proto++;
6482                 arg++;
6483                 switch (*proto++) {
6484                 case '*':
6485                     if (o2->op_type != OP_RV2GV)
6486                         bad_type(arg, "symbol", gv_ename(namegv), o2);
6487                     goto wrapref;
6488                 case '&':
6489                     if (o2->op_type != OP_ENTERSUB)
6490                         bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6491                     goto wrapref;
6492                 case '$':
6493                     if (o2->op_type != OP_RV2SV
6494                         && o2->op_type != OP_PADSV
6495                         && o2->op_type != OP_HELEM
6496                         && o2->op_type != OP_AELEM
6497                         && o2->op_type != OP_THREADSV)
6498                     {
6499                         bad_type(arg, "scalar", gv_ename(namegv), o2);
6500                     }
6501                     goto wrapref;
6502                 case '@':
6503                     if (o2->op_type != OP_RV2AV && o2->op_type != OP_PADAV)
6504                         bad_type(arg, "array", gv_ename(namegv), o2);
6505                     goto wrapref;
6506                 case '%':
6507                     if (o2->op_type != OP_RV2HV && o2->op_type != OP_PADHV)
6508                         bad_type(arg, "hash", gv_ename(namegv), o2);
6509                   wrapref:
6510                     {
6511                         OP* kid = o2;
6512                         OP* sib = kid->op_sibling;
6513                         kid->op_sibling = 0;
6514                         o2 = newUNOP(OP_REFGEN, 0, kid);
6515                         o2->op_sibling = sib;
6516                         prev->op_sibling = o2;
6517                     }
6518                     break;
6519                 default: goto oops;
6520                 }
6521                 break;
6522             case ' ':
6523                 proto++;
6524                 continue;
6525             default:
6526               oops:
6527                 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
6528                         gv_ename(namegv), SvPV((SV*)cv, n_a));
6529             }
6530         }
6531         else
6532             list(o2);
6533         mod(o2, OP_ENTERSUB);
6534         prev = o2;
6535         o2 = o2->op_sibling;
6536     }
6537     if (proto && !optional &&
6538           (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6539         return too_few_arguments(o, gv_ename(namegv));
6540     return o;
6541 }
6542
6543 OP *
6544 Perl_ck_svconst(pTHX_ OP *o)
6545 {
6546     SvREADONLY_on(cSVOPo->op_sv);
6547     return o;
6548 }
6549
6550 OP *
6551 Perl_ck_trunc(pTHX_ OP *o)
6552 {
6553     if (o->op_flags & OPf_KIDS) {
6554         SVOP *kid = (SVOP*)cUNOPo->op_first;
6555
6556         if (kid->op_type == OP_NULL)
6557             kid = (SVOP*)kid->op_sibling;
6558         if (kid && kid->op_type == OP_CONST &&
6559             (kid->op_private & OPpCONST_BARE))
6560         {
6561             o->op_flags |= OPf_SPECIAL;
6562             kid->op_private &= ~OPpCONST_STRICT;
6563         }
6564     }
6565     return ck_fun(o);
6566 }
6567
6568 OP *
6569 Perl_ck_substr(pTHX_ OP *o)
6570 {
6571     o = ck_fun(o);
6572     if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6573         OP *kid = cLISTOPo->op_first;
6574
6575         if (kid->op_type == OP_NULL)
6576             kid = kid->op_sibling;
6577         if (kid)
6578             kid->op_flags |= OPf_MOD;
6579
6580     }
6581     return o;
6582 }
6583
6584 /* A peephole optimizer.  We visit the ops in the order they're to execute. */
6585
6586 void
6587 Perl_peep(pTHX_ register OP *o)
6588 {
6589     register OP* oldop = 0;
6590     STRLEN n_a;
6591
6592     if (!o || o->op_seq)
6593         return;
6594     ENTER;
6595     SAVEOP();
6596     SAVEVPTR(PL_curcop);
6597     for (; o; o = o->op_next) {
6598         if (o->op_seq)
6599             break;
6600         if (!PL_op_seqmax)
6601             PL_op_seqmax++;
6602         PL_op = o;
6603         switch (o->op_type) {
6604         case OP_SETSTATE:
6605         case OP_NEXTSTATE:
6606         case OP_DBSTATE:
6607             PL_curcop = ((COP*)o);              /* for warnings */
6608             o->op_seq = PL_op_seqmax++;
6609             break;
6610
6611         case OP_CONST:
6612             if (cSVOPo->op_private & OPpCONST_STRICT)
6613                 no_bareword_allowed(o);
6614 #ifdef USE_ITHREADS
6615             /* Relocate sv to the pad for thread safety.
6616              * Despite being a "constant", the SV is written to,
6617              * for reference counts, sv_upgrade() etc. */
6618             if (cSVOP->op_sv) {
6619                 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6620                 if (SvPADTMP(cSVOPo->op_sv)) {
6621                     /* If op_sv is already a PADTMP then it is being used by
6622                      * some pad, so make a copy. */
6623                     sv_setsv(PL_curpad[ix],cSVOPo->op_sv);
6624                     SvREADONLY_on(PL_curpad[ix]);
6625                     SvREFCNT_dec(cSVOPo->op_sv);
6626                 }
6627                 else {
6628                     SvREFCNT_dec(PL_curpad[ix]);
6629                     SvPADTMP_on(cSVOPo->op_sv);
6630                     PL_curpad[ix] = cSVOPo->op_sv;
6631                     /* XXX I don't know how this isn't readonly already. */
6632                     SvREADONLY_on(PL_curpad[ix]);
6633                 }
6634                 cSVOPo->op_sv = Nullsv;
6635                 o->op_targ = ix;
6636             }
6637 #endif
6638             o->op_seq = PL_op_seqmax++;
6639             break;
6640
6641         case OP_CONCAT:
6642             if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
6643                 if (o->op_next->op_private & OPpTARGET_MY) {
6644                     if (o->op_flags & OPf_STACKED) /* chained concats */
6645                         goto ignore_optimization;
6646                     else {
6647                         /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
6648                         o->op_targ = o->op_next->op_targ;
6649                         o->op_next->op_targ = 0;
6650                         o->op_private |= OPpTARGET_MY;
6651                     }
6652                 }
6653                 null(o->op_next);
6654             }
6655           ignore_optimization:
6656             o->op_seq = PL_op_seqmax++;
6657             break;
6658         case OP_STUB:
6659             if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
6660                 o->op_seq = PL_op_seqmax++;
6661                 break; /* Scalar stub must produce undef.  List stub is noop */
6662             }
6663             goto nothin;
6664         case OP_NULL:
6665             if (o->op_targ == OP_NEXTSTATE
6666                 || o->op_targ == OP_DBSTATE
6667                 || o->op_targ == OP_SETSTATE)
6668             {
6669                 PL_curcop = ((COP*)o);
6670             }
6671             goto nothin;
6672         case OP_SCALAR:
6673         case OP_LINESEQ:
6674         case OP_SCOPE:
6675           nothin:
6676             if (oldop && o->op_next) {
6677                 oldop->op_next = o->op_next;
6678                 continue;
6679             }
6680             o->op_seq = PL_op_seqmax++;
6681             break;
6682
6683         case OP_GV:
6684             if (o->op_next->op_type == OP_RV2SV) {
6685                 if (!(o->op_next->op_private & OPpDEREF)) {
6686                     null(o->op_next);
6687                     o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
6688                                                                | OPpOUR_INTRO);
6689                     o->op_next = o->op_next->op_next;
6690                     o->op_type = OP_GVSV;
6691                     o->op_ppaddr = PL_ppaddr[OP_GVSV];
6692                 }
6693             }
6694             else if (o->op_next->op_type == OP_RV2AV) {
6695                 OP* pop = o->op_next->op_next;
6696                 IV i;
6697                 if (pop->op_type == OP_CONST &&
6698                     (PL_op = pop->op_next) &&
6699                     pop->op_next->op_type == OP_AELEM &&
6700                     !(pop->op_next->op_private &
6701                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
6702                     (i = SvIV(((SVOP*)pop)->op_sv) - PL_compiling.cop_arybase)
6703                                 <= 255 &&
6704                     i >= 0)
6705                 {
6706                     GV *gv;
6707                     null(o->op_next);
6708                     null(pop->op_next);
6709                     null(pop);
6710                     o->op_flags |= pop->op_next->op_flags & OPf_MOD;
6711                     o->op_next = pop->op_next->op_next;
6712                     o->op_type = OP_AELEMFAST;
6713                     o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
6714                     o->op_private = (U8)i;
6715                     gv = cGVOPo_gv;
6716                     GvAVn(gv);
6717                 }
6718             }
6719             else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
6720                 GV *gv = cGVOPo_gv;
6721                 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
6722                     /* XXX could check prototype here instead of just carping */
6723                     SV *sv = sv_newmortal();
6724                     gv_efullname3(sv, gv, Nullch);
6725                     Perl_warner(aTHX_ WARN_PROTOTYPE,
6726                                 "%s() called too early to check prototype",
6727                                 SvPV_nolen(sv));
6728                 }
6729             }
6730
6731             o->op_seq = PL_op_seqmax++;
6732             break;
6733
6734         case OP_MAPWHILE:
6735         case OP_GREPWHILE:
6736         case OP_AND:
6737         case OP_OR:
6738         case OP_ANDASSIGN:
6739         case OP_ORASSIGN:
6740         case OP_COND_EXPR:
6741         case OP_RANGE:
6742             o->op_seq = PL_op_seqmax++;
6743             while (cLOGOP->op_other->op_type == OP_NULL)
6744                 cLOGOP->op_other = cLOGOP->op_other->op_next;
6745             peep(cLOGOP->op_other);
6746             break;
6747
6748         case OP_ENTERLOOP:
6749             o->op_seq = PL_op_seqmax++;
6750             while (cLOOP->op_redoop->op_type == OP_NULL)
6751                 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
6752             peep(cLOOP->op_redoop);
6753             while (cLOOP->op_nextop->op_type == OP_NULL)
6754                 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
6755             peep(cLOOP->op_nextop);
6756             while (cLOOP->op_lastop->op_type == OP_NULL)
6757                 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
6758             peep(cLOOP->op_lastop);
6759             break;
6760
6761         case OP_QR:
6762         case OP_MATCH:
6763         case OP_SUBST:
6764             o->op_seq = PL_op_seqmax++;
6765             while (cPMOP->op_pmreplstart &&
6766                    cPMOP->op_pmreplstart->op_type == OP_NULL)
6767                 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
6768             peep(cPMOP->op_pmreplstart);
6769             break;
6770
6771         case OP_EXEC:
6772             o->op_seq = PL_op_seqmax++;
6773             if (ckWARN(WARN_SYNTAX) && o->op_next
6774                 && o->op_next->op_type == OP_NEXTSTATE) {
6775                 if (o->op_next->op_sibling &&
6776                         o->op_next->op_sibling->op_type != OP_EXIT &&
6777                         o->op_next->op_sibling->op_type != OP_WARN &&
6778                         o->op_next->op_sibling->op_type != OP_DIE) {
6779                     line_t oldline = CopLINE(PL_curcop);
6780
6781                     CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
6782                     Perl_warner(aTHX_ WARN_EXEC,
6783                                 "Statement unlikely to be reached");
6784                     Perl_warner(aTHX_ WARN_EXEC,
6785                                 "\t(Maybe you meant system() when you said exec()?)\n");
6786                     CopLINE_set(PL_curcop, oldline);
6787                 }
6788             }
6789             break;
6790
6791         case OP_HELEM: {
6792             UNOP *rop;
6793             SV *lexname;
6794             GV **fields;
6795             SV **svp, **indsvp, *sv;
6796             I32 ind;
6797             char *key = NULL;
6798             STRLEN keylen;
6799
6800             o->op_seq = PL_op_seqmax++;
6801
6802             if (((BINOP*)o)->op_last->op_type != OP_CONST)
6803                 break;
6804
6805             /* Make the CONST have a shared SV */
6806             svp = cSVOPx_svp(((BINOP*)o)->op_last);
6807             if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
6808                 key = SvPV(sv, keylen);
6809                 if (SvUTF8(sv))
6810                   keylen = -keylen;
6811                 lexname = newSVpvn_share(key, keylen, 0);
6812                 SvREFCNT_dec(sv);
6813                 *svp = lexname;
6814             }
6815
6816             if ((o->op_private & (OPpLVAL_INTRO)))
6817                 break;
6818
6819             rop = (UNOP*)((BINOP*)o)->op_first;
6820             if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6821                 break;
6822             lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6823             if (!SvOBJECT(lexname))
6824                 break;
6825             fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6826             if (!fields || !GvHV(*fields))
6827                 break;
6828             key = SvPV(*svp, keylen);
6829             if (SvUTF8(*svp))
6830                 keylen = -keylen;
6831             indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE);
6832             if (!indsvp) {
6833                 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s",
6834                       key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
6835             }
6836             ind = SvIV(*indsvp);
6837             if (ind < 1)
6838                 Perl_croak(aTHX_ "Bad index while coercing array into hash");
6839             rop->op_type = OP_RV2AV;
6840             rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
6841             o->op_type = OP_AELEM;
6842             o->op_ppaddr = PL_ppaddr[OP_AELEM];
6843             sv = newSViv(ind);
6844             if (SvREADONLY(*svp))
6845                 SvREADONLY_on(sv);
6846             SvFLAGS(sv) |= (SvFLAGS(*svp)
6847                             & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
6848             SvREFCNT_dec(*svp);
6849             *svp = sv;
6850             break;
6851         }
6852
6853         case OP_HSLICE: {
6854             UNOP *rop;
6855             SV *lexname;
6856             GV **fields;
6857             SV **svp, **indsvp, *sv;
6858             I32 ind;
6859             char *key;
6860             STRLEN keylen;
6861             SVOP *first_key_op, *key_op;
6862
6863             o->op_seq = PL_op_seqmax++;
6864             if ((o->op_private & (OPpLVAL_INTRO))
6865                 /* I bet there's always a pushmark... */
6866                 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
6867                 /* hmmm, no optimization if list contains only one key. */
6868                 break;
6869             rop = (UNOP*)((LISTOP*)o)->op_last;
6870             if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
6871                 break;
6872             lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
6873             if (!SvOBJECT(lexname))
6874                 break;
6875             fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
6876             if (!fields || !GvHV(*fields))
6877                 break;
6878             /* Again guessing that the pushmark can be jumped over.... */
6879             first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
6880                 ->op_first->op_sibling;
6881             /* Check that the key list contains only constants. */
6882             for (key_op = first_key_op; key_op;
6883                  key_op = (SVOP*)key_op->op_sibling)
6884                 if (key_op->op_type != OP_CONST)
6885                     break;
6886             if (key_op)
6887                 break;
6888             rop->op_type = OP_RV2AV;
6889             rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
6890             o->op_type = OP_ASLICE;
6891             o->op_ppaddr = PL_ppaddr[OP_ASLICE];
6892             for (key_op = first_key_op; key_op;
6893                  key_op = (SVOP*)key_op->op_sibling) {
6894                 svp = cSVOPx_svp(key_op);
6895                 key = SvPV(*svp, keylen);
6896                 if (SvUTF8(*svp))
6897                     keylen = -keylen;
6898                 indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE);
6899                 if (!indsvp) {
6900                     Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
6901                                "in variable %s of type %s",
6902                           key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
6903                 }
6904                 ind = SvIV(*indsvp);
6905                 if (ind < 1)
6906                     Perl_croak(aTHX_ "Bad index while coercing array into hash");
6907                 sv = newSViv(ind);
6908                 if (SvREADONLY(*svp))
6909                     SvREADONLY_on(sv);
6910                 SvFLAGS(sv) |= (SvFLAGS(*svp)
6911                                 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
6912                 SvREFCNT_dec(*svp);
6913                 *svp = sv;
6914             }
6915             break;
6916         }
6917
6918         default:
6919             o->op_seq = PL_op_seqmax++;
6920             break;
6921         }
6922         oldop = o;
6923     }
6924     LEAVE;
6925 }
6926
6927 #include "XSUB.h"
6928
6929 /* Efficient sub that returns a constant scalar value. */
6930 static void
6931 const_sv_xsub(pTHXo_ CV* cv)
6932 {
6933     dXSARGS;
6934     EXTEND(sp, 1);
6935     ST(0) = (SV*)XSANY.any_ptr;
6936     XSRETURN(1);
6937 }