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