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