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