op.c

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