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