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