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