op.c

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