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