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