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