op.c

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