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