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