op.c

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