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