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             Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
3888         if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3889             op_free(first);
3890             *firstp = Nullop;
3891             return other;
3892         }
3893         else {
3894             op_free(other);
3895             *otherp = Nullop;
3896             return first;
3897         }
3898     }
3899     else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
3900         OP *k1 = ((UNOP*)first)->op_first;
3901         OP *k2 = k1->op_sibling;
3902         OPCODE warnop = 0;
3903         switch (first->op_type)
3904         {
3905         case OP_NULL:
3906             if (k2 && k2->op_type == OP_READLINE
3907                   && (k2->op_flags & OPf_STACKED)
3908                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3909             {
3910                 warnop = k2->op_type;
3911             }
3912             break;
3913
3914         case OP_SASSIGN:
3915             if (k1->op_type == OP_READDIR
3916                   || k1->op_type == OP_GLOB
3917                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3918                   || k1->op_type == OP_EACH)
3919             {
3920                 warnop = ((k1->op_type == OP_NULL)
3921                           ? (OPCODE)k1->op_targ : k1->op_type);
3922             }
3923             break;
3924         }
3925         if (warnop) {
3926             line_t oldline = CopLINE(PL_curcop);
3927             CopLINE_set(PL_curcop, PL_copline);
3928             Perl_warner(aTHX_ packWARN(WARN_MISC),
3929                  "Value of %s%s can be \"0\"; test with defined()",
3930                  PL_op_desc[warnop],
3931                  ((warnop == OP_READLINE || warnop == OP_GLOB)
3932                   ? " construct" : "() operator"));
3933             CopLINE_set(PL_curcop, oldline);
3934         }
3935     }
3936
3937     if (!other)
3938         return first;
3939
3940     if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
3941         other->op_private |= OPpASSIGN_BACKWARDS;  /* other is an OP_SASSIGN */
3942
3943     NewOp(1101, logop, 1, LOGOP);
3944
3945     logop->op_type = (OPCODE)type;
3946     logop->op_ppaddr = PL_ppaddr[type];
3947     logop->op_first = first;
3948     logop->op_flags = flags | OPf_KIDS;
3949     logop->op_other = LINKLIST(other);
3950     logop->op_private = (U8)(1 | (flags >> 8));
3951
3952     /* establish postfix order */
3953     logop->op_next = LINKLIST(first);
3954     first->op_next = (OP*)logop;
3955     first->op_sibling = other;
3956
3957     o = newUNOP(OP_NULL, 0, (OP*)logop);
3958     other->op_next = o;
3959
3960     return o;
3961 }
3962
3963 OP *
3964 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3965 {
3966     LOGOP *logop;
3967     OP *start;
3968     OP *o;
3969
3970     if (!falseop)
3971         return newLOGOP(OP_AND, 0, first, trueop);
3972     if (!trueop)
3973         return newLOGOP(OP_OR, 0, first, falseop);
3974
3975     scalarboolean(first);
3976     if (first->op_type == OP_CONST) {
3977         if (first->op_private & OPpCONST_BARE &&
3978            first->op_private & OPpCONST_STRICT) {
3979            no_bareword_allowed(first);
3980        }
3981         if (SvTRUE(((SVOP*)first)->op_sv)) {
3982             op_free(first);
3983             op_free(falseop);
3984             return trueop;
3985         }
3986         else {
3987             op_free(first);
3988             op_free(trueop);
3989             return falseop;
3990         }
3991     }
3992     NewOp(1101, logop, 1, LOGOP);
3993     logop->op_type = OP_COND_EXPR;
3994     logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
3995     logop->op_first = first;
3996     logop->op_flags = flags | OPf_KIDS;
3997     logop->op_private = (U8)(1 | (flags >> 8));
3998     logop->op_other = LINKLIST(trueop);
3999     logop->op_next = LINKLIST(falseop);
4000
4001
4002     /* establish postfix order */
4003     start = LINKLIST(first);
4004     first->op_next = (OP*)logop;
4005
4006     first->op_sibling = trueop;
4007     trueop->op_sibling = falseop;
4008     o = newUNOP(OP_NULL, 0, (OP*)logop);
4009
4010     trueop->op_next = falseop->op_next = o;
4011
4012     o->op_next = start;
4013     return o;
4014 }
4015
4016 OP *
4017 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4018 {
4019     LOGOP *range;
4020     OP *flip;
4021     OP *flop;
4022     OP *leftstart;
4023     OP *o;
4024
4025     NewOp(1101, range, 1, LOGOP);
4026
4027     range->op_type = OP_RANGE;
4028     range->op_ppaddr = PL_ppaddr[OP_RANGE];
4029     range->op_first = left;
4030     range->op_flags = OPf_KIDS;
4031     leftstart = LINKLIST(left);
4032     range->op_other = LINKLIST(right);
4033     range->op_private = (U8)(1 | (flags >> 8));
4034
4035     left->op_sibling = right;
4036
4037     range->op_next = (OP*)range;
4038     flip = newUNOP(OP_FLIP, flags, (OP*)range);
4039     flop = newUNOP(OP_FLOP, 0, flip);
4040     o = newUNOP(OP_NULL, 0, flop);
4041     linklist(flop);
4042     range->op_next = leftstart;
4043
4044     left->op_next = flip;
4045     right->op_next = flop;
4046
4047     range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4048     sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4049     flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4050     sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4051
4052     flip->op_private =  left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4053     flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4054
4055     flip->op_next = o;
4056     if (!flip->op_private || !flop->op_private)
4057         linklist(o);            /* blow off optimizer unless constant */
4058
4059     return o;
4060 }
4061
4062 OP *
4063 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4064 {
4065     OP* listop;
4066     OP* o;
4067     int once = block && block->op_flags & OPf_SPECIAL &&
4068       (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4069
4070     if (expr) {
4071         if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4072             return block;       /* do {} while 0 does once */
4073         if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4074             || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4075             expr = newUNOP(OP_DEFINED, 0,
4076                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4077         } else if (expr->op_flags & OPf_KIDS) {
4078             OP *k1 = ((UNOP*)expr)->op_first;
4079             OP *k2 = (k1) ? k1->op_sibling : NULL;
4080             switch (expr->op_type) {
4081               case OP_NULL:
4082                 if (k2 && k2->op_type == OP_READLINE
4083                       && (k2->op_flags & OPf_STACKED)
4084                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4085                     expr = newUNOP(OP_DEFINED, 0, expr);
4086                 break;
4087
4088               case OP_SASSIGN:
4089                 if (k1->op_type == OP_READDIR
4090                       || k1->op_type == OP_GLOB
4091                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4092                       || k1->op_type == OP_EACH)
4093                     expr = newUNOP(OP_DEFINED, 0, expr);
4094                 break;
4095             }
4096         }
4097     }
4098
4099     listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4100     o = new_logop(OP_AND, 0, &expr, &listop);
4101
4102     if (listop)
4103         ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4104
4105     if (once && o != listop)
4106         o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4107
4108     if (o == listop)
4109         o = newUNOP(OP_NULL, 0, o);     /* or do {} while 1 loses outer block */
4110
4111     o->op_flags |= flags;
4112     o = scope(o);
4113     o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4114     return o;
4115 }
4116
4117 OP *
4118 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
4119 {
4120     OP *redo;
4121     OP *next = 0;
4122     OP *listop;
4123     OP *o;
4124     U8 loopflags = 0;
4125
4126     if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4127                  || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
4128         expr = newUNOP(OP_DEFINED, 0,
4129             newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4130     } else if (expr && (expr->op_flags & OPf_KIDS)) {
4131         OP *k1 = ((UNOP*)expr)->op_first;
4132         OP *k2 = (k1) ? k1->op_sibling : NULL;
4133         switch (expr->op_type) {
4134           case OP_NULL:
4135             if (k2 && k2->op_type == OP_READLINE
4136                   && (k2->op_flags & OPf_STACKED)
4137                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4138                 expr = newUNOP(OP_DEFINED, 0, expr);
4139             break;
4140
4141           case OP_SASSIGN:
4142             if (k1->op_type == OP_READDIR
4143                   || k1->op_type == OP_GLOB
4144                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4145                   || k1->op_type == OP_EACH)
4146                 expr = newUNOP(OP_DEFINED, 0, expr);
4147             break;
4148         }
4149     }
4150
4151     if (!block)
4152         block = newOP(OP_NULL, 0);
4153     else if (cont) {
4154         block = scope(block);
4155     }
4156
4157     if (cont) {
4158         next = LINKLIST(cont);
4159     }
4160     if (expr) {
4161         OP *unstack = newOP(OP_UNSTACK, 0);
4162         if (!next)
4163             next = unstack;
4164         cont = append_elem(OP_LINESEQ, cont, unstack);
4165         if ((line_t)whileline != NOLINE) {
4166             PL_copline = (line_t)whileline;
4167             cont = append_elem(OP_LINESEQ, cont,
4168                                newSTATEOP(0, Nullch, Nullop));
4169         }
4170     }
4171
4172     listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4173     redo = LINKLIST(listop);
4174
4175     if (expr) {
4176         PL_copline = (line_t)whileline;
4177         scalar(listop);
4178         o = new_logop(OP_AND, 0, &expr, &listop);
4179         if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4180             op_free(expr);              /* oops, it's a while (0) */
4181             op_free((OP*)loop);
4182             return Nullop;              /* listop already freed by new_logop */
4183         }
4184         if (listop)
4185             ((LISTOP*)listop)->op_last->op_next =
4186                 (o == listop ? redo : LINKLIST(o));
4187     }
4188     else
4189         o = listop;
4190
4191     if (!loop) {
4192         NewOp(1101,loop,1,LOOP);
4193         loop->op_type = OP_ENTERLOOP;
4194         loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4195         loop->op_private = 0;
4196         loop->op_next = (OP*)loop;
4197     }
4198
4199     o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4200
4201     loop->op_redoop = redo;
4202     loop->op_lastop = o;
4203     o->op_private |= loopflags;
4204
4205     if (next)
4206         loop->op_nextop = next;
4207     else
4208         loop->op_nextop = o;
4209
4210     o->op_flags |= flags;
4211     o->op_private |= (flags >> 8);
4212     return o;
4213 }
4214
4215 OP *
4216 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
4217 {
4218     LOOP *loop;
4219     OP *wop;
4220     PADOFFSET padoff = 0;
4221     I32 iterflags = 0;
4222
4223     if (sv) {
4224         if (sv->op_type == OP_RV2SV) {  /* symbol table variable */
4225             sv->op_type = OP_RV2GV;
4226             sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4227         }
4228         else if (sv->op_type == OP_PADSV) { /* private variable */
4229             padoff = sv->op_targ;
4230             sv->op_targ = 0;
4231             op_free(sv);
4232             sv = Nullop;
4233         }
4234         else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4235             padoff = sv->op_targ;
4236             sv->op_targ = 0;
4237             iterflags |= OPf_SPECIAL;
4238             op_free(sv);
4239             sv = Nullop;
4240         }
4241         else
4242             Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4243     }
4244     else {
4245 #ifdef USE_5005THREADS
4246         padoff = find_threadsv("_");
4247         iterflags |= OPf_SPECIAL;
4248 #else
4249         sv = newGVOP(OP_GV, 0, PL_defgv);
4250 #endif
4251     }
4252     if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4253         expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4254         iterflags |= OPf_STACKED;
4255     }
4256     else if (expr->op_type == OP_NULL &&
4257              (expr->op_flags & OPf_KIDS) &&
4258              ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4259     {
4260         /* Basically turn for($x..$y) into the same as for($x,$y), but we
4261          * set the STACKED flag to indicate that these values are to be
4262          * treated as min/max values by 'pp_iterinit'.
4263          */
4264         UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4265         LOGOP* range = (LOGOP*) flip->op_first;
4266         OP* left  = range->op_first;
4267         OP* right = left->op_sibling;
4268         LISTOP* listop;
4269
4270         range->op_flags &= ~OPf_KIDS;
4271         range->op_first = Nullop;
4272
4273         listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4274         listop->op_first->op_next = range->op_next;
4275         left->op_next = range->op_other;
4276         right->op_next = (OP*)listop;
4277         listop->op_next = listop->op_first;
4278
4279         op_free(expr);
4280         expr = (OP*)(listop);
4281         op_null(expr);
4282         iterflags |= OPf_STACKED;
4283     }
4284     else {
4285         expr = mod(force_list(expr), OP_GREPSTART);
4286     }
4287
4288
4289     loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4290                                append_elem(OP_LIST, expr, scalar(sv))));
4291     assert(!loop->op_next);
4292 #ifdef PL_OP_SLAB_ALLOC
4293     {
4294         LOOP *tmp;
4295         NewOp(1234,tmp,1,LOOP);
4296         Copy(loop,tmp,1,LOOP);
4297         FreeOp(loop);
4298         loop = tmp;
4299     }
4300 #else
4301     Renew(loop, 1, LOOP);
4302 #endif
4303     loop->op_targ = padoff;
4304     wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
4305     PL_copline = forline;
4306     return newSTATEOP(0, label, wop);
4307 }
4308
4309 OP*
4310 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4311 {
4312     OP *o;
4313     STRLEN n_a;
4314
4315     if (type != OP_GOTO || label->op_type == OP_CONST) {
4316         /* "last()" means "last" */
4317         if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4318             o = newOP(type, OPf_SPECIAL);
4319         else {
4320             o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4321                                         ? SvPVx(((SVOP*)label)->op_sv, n_a)
4322                                         : ""));
4323         }
4324         op_free(label);
4325     }
4326     else {
4327         if (label->op_type == OP_ENTERSUB)
4328             label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4329         o = newUNOP(type, OPf_STACKED, label);
4330     }
4331     PL_hints |= HINT_BLOCK_SCOPE;
4332     return o;
4333 }
4334
4335 void
4336 Perl_cv_undef(pTHX_ CV *cv)
4337 {
4338     CV *outsidecv;
4339     CV *freecv = Nullcv;
4340     bool is_eval = CvEVAL(cv) && !CvGV(cv);     /* is this eval"" ? */
4341
4342 #ifdef USE_5005THREADS
4343     if (CvMUTEXP(cv)) {
4344         MUTEX_DESTROY(CvMUTEXP(cv));
4345         Safefree(CvMUTEXP(cv));
4346         CvMUTEXP(cv) = 0;
4347     }
4348 #endif /* USE_5005THREADS */
4349
4350 #ifdef USE_ITHREADS
4351     if (CvFILE(cv) && !CvXSUB(cv)) {
4352         /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4353         Safefree(CvFILE(cv));
4354     }
4355     CvFILE(cv) = 0;
4356 #endif
4357
4358     if (!CvXSUB(cv) && CvROOT(cv)) {
4359 #ifdef USE_5005THREADS
4360         if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr))
4361             Perl_croak(aTHX_ "Can't undef active subroutine");
4362 #else
4363         if (CvDEPTH(cv))
4364             Perl_croak(aTHX_ "Can't undef active subroutine");
4365 #endif /* USE_5005THREADS */
4366         ENTER;
4367
4368         SAVEVPTR(PL_curpad);
4369         PL_curpad = 0;
4370
4371         op_free(CvROOT(cv));
4372         CvROOT(cv) = Nullop;
4373         LEAVE;
4374     }
4375     SvPOK_off((SV*)cv);         /* forget prototype */
4376     CvGV(cv) = Nullgv;
4377     outsidecv = CvOUTSIDE(cv);
4378     /* Since closure prototypes have the same lifetime as the containing
4379      * CV, they don't hold a refcount on the outside CV.  This avoids
4380      * the refcount loop between the outer CV (which keeps a refcount to
4381      * the closure prototype in the pad entry for pp_anoncode()) and the
4382      * closure prototype, and the ensuing memory leak.  --GSAR */
4383     if (!CvANON(cv) || CvCLONED(cv))
4384         freecv = outsidecv;
4385     CvOUTSIDE(cv) = Nullcv;
4386     if (CvCONST(cv)) {
4387         SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4388         CvCONST_off(cv);
4389     }
4390     if (CvPADLIST(cv)) {
4391         /* may be during global destruction */
4392         if (SvREFCNT(CvPADLIST(cv))) {
4393             AV *padlist = CvPADLIST(cv);
4394             I32 ix;
4395             /* pads may be cleared out already during global destruction */
4396             if (is_eval && !PL_dirty) {
4397                 /* inner references to eval's cv must be fixed up */
4398                 AV *comppad_name = (AV*)AvARRAY(padlist)[0];
4399                 AV *comppad = (AV*)AvARRAY(padlist)[1];
4400                 SV **namepad = AvARRAY(comppad_name);
4401                 SV **curpad = AvARRAY(comppad);
4402                 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
4403                     SV *namesv = namepad[ix];
4404                     if (namesv && namesv != &PL_sv_undef
4405                         && *SvPVX(namesv) == '&'
4406                         && ix <= AvFILLp(comppad))
4407                     {
4408                         CV *innercv = (CV*)curpad[ix];
4409                         if (innercv && SvTYPE(innercv) == SVt_PVCV
4410                             && CvOUTSIDE(innercv) == cv)
4411                         {
4412                             CvOUTSIDE(innercv) = outsidecv;
4413                             if (!CvANON(innercv) || CvCLONED(innercv)) {
4414                                 (void)SvREFCNT_inc(outsidecv);
4415                                 if (SvREFCNT(cv))
4416                                     SvREFCNT_dec(cv);
4417                             }
4418                         }
4419                     }
4420                 }
4421             }
4422             if (freecv)
4423                 SvREFCNT_dec(freecv);
4424             ix = AvFILLp(padlist);
4425             while (ix >= 0) {
4426                 SV* sv = AvARRAY(padlist)[ix--];
4427                 if (!sv)
4428                     continue;
4429                 if (sv == (SV*)PL_comppad_name)
4430                     PL_comppad_name = Nullav;
4431                 else if (sv == (SV*)PL_comppad) {
4432                     PL_comppad = Nullav;
4433                     PL_curpad = Null(SV**);
4434                 }
4435                 SvREFCNT_dec(sv);
4436             }
4437             SvREFCNT_dec((SV*)CvPADLIST(cv));
4438         }
4439         CvPADLIST(cv) = Nullav;
4440     }
4441     else if (freecv)
4442         SvREFCNT_dec(freecv);
4443     if (CvXSUB(cv)) {
4444         CvXSUB(cv) = 0;
4445     }
4446     CvFLAGS(cv) = 0;
4447 }
4448
4449 #ifdef DEBUG_CLOSURES
4450 STATIC void
4451 S_cv_dump(pTHX_ CV *cv)
4452 {
4453 #ifdef DEBUGGING
4454     CV *outside = CvOUTSIDE(cv);
4455     AV* padlist = CvPADLIST(cv);
4456     AV* pad_name;
4457     AV* pad;
4458     SV** pname;
4459     SV** ppad;
4460     I32 ix;
4461
4462     PerlIO_printf(Perl_debug_log,
4463                   "\tCV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
4464                   PTR2UV(cv),
4465                   (CvANON(cv) ? "ANON"
4466                    : (cv == PL_main_cv) ? "MAIN"
4467                    : CvUNIQUE(cv) ? "UNIQUE"
4468                    : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
4469                   PTR2UV(outside),
4470                   (!outside ? "null"
4471                    : CvANON(outside) ? "ANON"
4472                    : (outside == PL_main_cv) ? "MAIN"
4473                    : CvUNIQUE(outside) ? "UNIQUE"
4474                    : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
4475
4476     if (!padlist)
4477         return;
4478
4479     pad_name = (AV*)*av_fetch(padlist, 0, FALSE);
4480     pad = (AV*)*av_fetch(padlist, 1, FALSE);
4481     pname = AvARRAY(pad_name);
4482     ppad = AvARRAY(pad);
4483
4484     for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
4485         if (SvPOK(pname[ix]))
4486             PerlIO_printf(Perl_debug_log,
4487                           "\t%4d. 0x%"UVxf" (%s\"%s\" %"IVdf"-%"IVdf")\n",
4488                           (int)ix, PTR2UV(ppad[ix]),
4489                           SvFAKE(pname[ix]) ? "FAKE " : "",
4490                           SvPVX(pname[ix]),
4491                           (IV)I_32(SvNVX(pname[ix])),
4492                           SvIVX(pname[ix]));
4493     }
4494 #endif /* DEBUGGING */
4495 }
4496 #endif /* DEBUG_CLOSURES */
4497
4498 STATIC CV *
4499 S_cv_clone2(pTHX_ CV *proto, CV *outside)
4500 {
4501     AV* av;
4502     I32 ix;
4503     AV* protopadlist = CvPADLIST(proto);
4504     AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
4505     AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
4506     SV** pname = AvARRAY(protopad_name);
4507     SV** ppad = AvARRAY(protopad);
4508     I32 fname = AvFILLp(protopad_name);
4509     I32 fpad = AvFILLp(protopad);
4510     AV* comppadlist;
4511     CV* cv;
4512
4513     assert(!CvUNIQUE(proto));
4514
4515     ENTER;
4516     SAVECOMPPAD();
4517     SAVESPTR(PL_comppad_name);
4518     SAVESPTR(PL_compcv);
4519
4520     cv = PL_compcv = (CV*)NEWSV(1104,0);
4521     sv_upgrade((SV *)cv, SvTYPE(proto));
4522     CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
4523     CvCLONED_on(cv);
4524
4525 #ifdef USE_5005THREADS
4526     New(666, CvMUTEXP(cv), 1, perl_mutex);
4527     MUTEX_INIT(CvMUTEXP(cv));
4528     CvOWNER(cv)         = 0;
4529 #endif /* USE_5005THREADS */
4530 #ifdef USE_ITHREADS
4531     CvFILE(cv)          = CvXSUB(proto) ? CvFILE(proto)
4532                                         : savepv(CvFILE(proto));
4533 #else
4534     CvFILE(cv)          = CvFILE(proto);
4535 #endif
4536     CvGV(cv)            = CvGV(proto);
4537     CvSTASH(cv)         = CvSTASH(proto);
4538     CvROOT(cv)          = OpREFCNT_inc(CvROOT(proto));
4539     CvSTART(cv)         = CvSTART(proto);
4540     if (outside)
4541         CvOUTSIDE(cv)   = (CV*)SvREFCNT_inc(outside);
4542
4543     if (SvPOK(proto))
4544         sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
4545
4546     PL_comppad_name = newAV();
4547     for (ix = fname; ix >= 0; ix--)
4548         av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
4549
4550     PL_comppad = newAV();
4551
4552     comppadlist = newAV();
4553     AvREAL_off(comppadlist);
4554     av_store(comppadlist, 0, (SV*)PL_comppad_name);
4555     av_store(comppadlist, 1, (SV*)PL_comppad);
4556     CvPADLIST(cv) = comppadlist;
4557     av_fill(PL_comppad, AvFILLp(protopad));
4558     PL_curpad = AvARRAY(PL_comppad);
4559
4560     av = newAV();           /* will be @_ */
4561     av_extend(av, 0);
4562     av_store(PL_comppad, 0, (SV*)av);
4563     AvFLAGS(av) = AVf_REIFY;
4564
4565     for (ix = fpad; ix > 0; ix--) {
4566         SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4567         if (namesv && namesv != &PL_sv_undef) {
4568             char *name = SvPVX(namesv);    /* XXX */
4569             if (SvFLAGS(namesv) & SVf_FAKE) {   /* lexical from outside? */
4570                 I32 off = pad_findlex(name, ix, SvIVX(namesv),
4571                                       CvOUTSIDE(cv), cxstack_ix, 0, 0);
4572                 if (!off)
4573                     PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4574                 else if (off != ix)
4575                     Perl_croak(aTHX_ "panic: cv_clone: %s", name);
4576             }
4577             else {                              /* our own lexical */
4578                 SV* sv;
4579                 if (*name == '&') {
4580                     /* anon code -- we'll come back for it */
4581                     sv = SvREFCNT_inc(ppad[ix]);
4582                 }
4583                 else if (*name == '@')
4584                     sv = (SV*)newAV();
4585                 else if (*name == '%')
4586                     sv = (SV*)newHV();
4587                 else
4588                     sv = NEWSV(0,0);
4589                 if (!SvPADBUSY(sv))
4590                     SvPADMY_on(sv);
4591                 PL_curpad[ix] = sv;
4592             }
4593         }
4594         else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
4595             PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4596         }
4597         else {
4598             SV* sv = NEWSV(0,0);
4599             SvPADTMP_on(sv);
4600             PL_curpad[ix] = sv;
4601         }
4602     }
4603
4604     /* Now that vars are all in place, clone nested closures. */
4605
4606     for (ix = fpad; ix > 0; ix--) {
4607         SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4608         if (namesv
4609             && namesv != &PL_sv_undef
4610             && !(SvFLAGS(namesv) & SVf_FAKE)
4611             && *SvPVX(namesv) == '&'
4612             && CvCLONE(ppad[ix]))
4613         {
4614             CV *kid = cv_clone2((CV*)ppad[ix], cv);
4615             SvREFCNT_dec(ppad[ix]);
4616             CvCLONE_on(kid);
4617             SvPADMY_on(kid);
4618             PL_curpad[ix] = (SV*)kid;
4619         }
4620     }
4621
4622 #ifdef DEBUG_CLOSURES
4623     PerlIO_printf(Perl_debug_log, "Cloned inside:\n");
4624     cv_dump(outside);
4625     PerlIO_printf(Perl_debug_log, "  from:\n");
4626     cv_dump(proto);
4627     PerlIO_printf(Perl_debug_log, "   to:\n");
4628     cv_dump(cv);
4629 #endif
4630
4631     LEAVE;
4632
4633     if (CvCONST(cv)) {
4634         SV* const_sv = op_const_sv(CvSTART(cv), cv);
4635         assert(const_sv);
4636         /* constant sub () { $x } closing over $x - see lib/constant.pm */
4637         SvREFCNT_dec(cv);
4638         cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
4639     }
4640
4641     return cv;
4642 }
4643
4644 CV *
4645 Perl_cv_clone(pTHX_ CV *proto)
4646 {
4647     CV *cv;
4648     LOCK_CRED_MUTEX;                    /* XXX create separate mutex */
4649     cv = cv_clone2(proto, CvOUTSIDE(proto));
4650     UNLOCK_CRED_MUTEX;                  /* XXX create separate mutex */
4651     return cv;
4652 }
4653
4654 void
4655 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
4656 {
4657     if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4658         SV* msg = sv_newmortal();
4659         SV* name = Nullsv;
4660
4661         if (gv)
4662             gv_efullname3(name = sv_newmortal(), gv, Nullch);
4663         sv_setpv(msg, "Prototype mismatch:");
4664         if (name)
4665             Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4666         if (SvPOK(cv))
4667             Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv));
4668         sv_catpv(msg, " vs ");
4669         if (p)
4670             Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4671         else
4672             sv_catpv(msg, "none");
4673         Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
4674     }
4675 }
4676
4677 static void const_sv_xsub(pTHX_ CV* cv);
4678
4679 /*
4680
4681 =head1 Optree Manipulation Functions
4682
4683 =for apidoc cv_const_sv
4684
4685 If C<cv> is a constant sub eligible for inlining. returns the constant
4686 value returned by the sub.  Otherwise, returns NULL.
4687
4688 Constant subs can be created with C<newCONSTSUB> or as described in
4689 L<perlsub/"Constant Functions">.
4690
4691 =cut
4692 */
4693 SV *
4694 Perl_cv_const_sv(pTHX_ CV *cv)
4695 {
4696     if (!cv || !CvCONST(cv))
4697         return Nullsv;
4698     return (SV*)CvXSUBANY(cv).any_ptr;
4699 }
4700
4701 SV *
4702 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
4703 {
4704     SV *sv = Nullsv;
4705
4706     if (!o)
4707         return Nullsv;
4708
4709     if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4710         o = cLISTOPo->op_first->op_sibling;
4711
4712     for (; o; o = o->op_next) {
4713         OPCODE type = o->op_type;
4714
4715         if (sv && o->op_next == o)
4716             return sv;
4717         if (o->op_next != o) {
4718             if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4719                 continue;
4720             if (type == OP_DBSTATE)
4721                 continue;
4722         }
4723         if (type == OP_LEAVESUB || type == OP_RETURN)
4724             break;
4725         if (sv)
4726             return Nullsv;
4727         if (type == OP_CONST && cSVOPo->op_sv)
4728             sv = cSVOPo->op_sv;
4729         else if ((type == OP_PADSV || type == OP_CONST) && cv) {
4730             AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
4731             sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
4732             if (!sv)
4733                 return Nullsv;
4734             if (CvCONST(cv)) {
4735                 /* We get here only from cv_clone2() while creating a closure.
4736                    Copy the const value here instead of in cv_clone2 so that
4737                    SvREADONLY_on doesn't lead to problems when leaving
4738                    scope.
4739                 */
4740                 sv = newSVsv(sv);
4741             }
4742             if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
4743                 return Nullsv;
4744         }
4745         else
4746             return Nullsv;
4747     }
4748     if (sv)
4749         SvREADONLY_on(sv);
4750     return sv;
4751 }
4752
4753 void
4754 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4755 {
4756     if (o)
4757         SAVEFREEOP(o);
4758     if (proto)
4759         SAVEFREEOP(proto);
4760     if (attrs)
4761         SAVEFREEOP(attrs);
4762     if (block)
4763         SAVEFREEOP(block);
4764     Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4765 }
4766
4767 CV *
4768 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4769 {
4770     return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4771 }
4772
4773 CV *
4774 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4775 {
4776     STRLEN n_a;
4777     char *name;
4778     char *aname;
4779     GV *gv;
4780     char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4781     register CV *cv=0;
4782     I32 ix;
4783     SV *const_sv;
4784
4785     name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4786     if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4787         SV *sv = sv_newmortal();
4788         Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4789                        PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
4790                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4791         aname = SvPVX(sv);
4792     }
4793     else
4794         aname = Nullch;
4795     gv = gv_fetchpv(name ? name : (aname ? aname :
4796                     (PL_curstash ? "__ANON__" : "__ANON__::__ANON__")),
4797                     GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4798                     SVt_PVCV);
4799
4800     if (o)
4801         SAVEFREEOP(o);
4802     if (proto)
4803         SAVEFREEOP(proto);
4804     if (attrs)
4805         SAVEFREEOP(attrs);
4806
4807     if (SvTYPE(gv) != SVt_PVGV) {       /* Maybe prototype now, and had at
4808                                            maximum a prototype before. */
4809         if (SvTYPE(gv) > SVt_NULL) {
4810             if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4811                 && ckWARN_d(WARN_PROTOTYPE))
4812             {
4813                 Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
4814             }
4815             cv_ckproto((CV*)gv, NULL, ps);
4816         }
4817         if (ps)
4818             sv_setpv((SV*)gv, ps);
4819         else
4820             sv_setiv((SV*)gv, -1);
4821         SvREFCNT_dec(PL_compcv);
4822         cv = PL_compcv = NULL;
4823         PL_sub_generation++;
4824         goto done;
4825     }
4826
4827     cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4828
4829 #ifdef GV_UNIQUE_CHECK
4830     if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4831         Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4832     }
4833 #endif
4834
4835     if (!block || !ps || *ps || attrs)
4836         const_sv = Nullsv;
4837     else
4838         const_sv = op_const_sv(block, Nullcv);
4839
4840     if (cv) {
4841         bool exists = CvROOT(cv) || CvXSUB(cv);
4842
4843 #ifdef GV_UNIQUE_CHECK
4844         if (exists && GvUNIQUE(gv)) {
4845             Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4846         }
4847 #endif
4848
4849         /* if the subroutine doesn't exist and wasn't pre-declared
4850          * with a prototype, assume it will be AUTOLOADed,
4851          * skipping the prototype check
4852          */
4853         if (exists || SvPOK(cv))
4854             cv_ckproto(cv, gv, ps);
4855         /* already defined (or promised)? */
4856         if (exists || GvASSUMECV(gv)) {
4857             if (!block && !attrs) {
4858                 if (CvFLAGS(PL_compcv)) {
4859                     /* might have had built-in attrs applied */
4860                     CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4861                 }
4862                 /* just a "sub foo;" when &foo is already defined */
4863                 SAVEFREESV(PL_compcv);
4864                 goto done;
4865             }
4866             /* ahem, death to those who redefine active sort subs */
4867             if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4868                 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4869             if (block) {
4870                 if (ckWARN(WARN_REDEFINE)
4871                     || (CvCONST(cv)
4872                         && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4873                 {
4874                     line_t oldline = CopLINE(PL_curcop);
4875                     if (PL_copline != NOLINE)
4876                         CopLINE_set(PL_curcop, PL_copline);
4877                     Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
4878                         CvCONST(cv) ? "Constant subroutine %s redefined"
4879                                     : "Subroutine %s redefined", name);
4880                     CopLINE_set(PL_curcop, oldline);
4881                 }
4882                 SvREFCNT_dec(cv);
4883                 cv = Nullcv;
4884             }
4885         }
4886     }
4887     if (const_sv) {
4888         SvREFCNT_inc(const_sv);
4889         if (cv) {
4890             assert(!CvROOT(cv) && !CvCONST(cv));
4891             sv_setpv((SV*)cv, "");  /* prototype is "" */
4892             CvXSUBANY(cv).any_ptr = const_sv;
4893             CvXSUB(cv) = const_sv_xsub;
4894             CvCONST_on(cv);
4895         }
4896         else {
4897             GvCV(gv) = Nullcv;
4898             cv = newCONSTSUB(NULL, name, const_sv);
4899         }
4900         op_free(block);
4901         SvREFCNT_dec(PL_compcv);
4902         PL_compcv = NULL;
4903         PL_sub_generation++;
4904         goto done;
4905     }
4906     if (attrs) {
4907         HV *stash;
4908         SV *rcv;
4909
4910         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4911          * before we clobber PL_compcv.
4912          */
4913         if (cv && !block) {
4914             rcv = (SV*)cv;
4915             /* Might have had built-in attributes applied -- propagate them. */
4916             CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
4917             if (CvGV(cv) && GvSTASH(CvGV(cv)))
4918                 stash = GvSTASH(CvGV(cv));
4919             else if (CvSTASH(cv))
4920                 stash = CvSTASH(cv);
4921             else
4922                 stash = PL_curstash;
4923         }
4924         else {
4925             /* possibly about to re-define existing subr -- ignore old cv */
4926             rcv = (SV*)PL_compcv;
4927             if (name && GvSTASH(gv))
4928                 stash = GvSTASH(gv);
4929             else
4930                 stash = PL_curstash;
4931         }
4932         apply_attrs(stash, rcv, attrs, FALSE);
4933     }
4934     if (cv) {                           /* must reuse cv if autoloaded */
4935         if (!block) {
4936             /* got here with just attrs -- work done, so bug out */
4937             SAVEFREESV(PL_compcv);
4938             goto done;
4939         }
4940         cv_undef(cv);
4941         CvFLAGS(cv) = CvFLAGS(PL_compcv);
4942         CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4943         CvOUTSIDE(PL_compcv) = 0;
4944         CvPADLIST(cv) = CvPADLIST(PL_compcv);
4945         CvPADLIST(PL_compcv) = 0;
4946         /* inner references to PL_compcv must be fixed up ... */
4947         {
4948             AV *padlist = CvPADLIST(cv);
4949             AV *comppad_name = (AV*)AvARRAY(padlist)[0];
4950             AV *comppad = (AV*)AvARRAY(padlist)[1];
4951             SV **namepad = AvARRAY(comppad_name);
4952             SV **curpad = AvARRAY(comppad);
4953             for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
4954                 SV *namesv = namepad[ix];
4955                 if (namesv && namesv != &PL_sv_undef
4956                     && *SvPVX(namesv) == '&')
4957                 {
4958                     CV *innercv = (CV*)curpad[ix];
4959                     if (CvOUTSIDE(innercv) == PL_compcv) {
4960                         CvOUTSIDE(innercv) = cv;
4961                         if (!CvANON(innercv) || CvCLONED(innercv)) {
4962                             (void)SvREFCNT_inc(cv);
4963                             SvREFCNT_dec(PL_compcv);
4964                         }
4965                     }
4966                 }
4967             }
4968         }
4969         /* ... before we throw it away */
4970         SvREFCNT_dec(PL_compcv);
4971         if (PERLDB_INTER)/* Advice debugger on the new sub. */
4972           ++PL_sub_generation;
4973     }
4974     else {
4975         cv = PL_compcv;
4976         if (name) {
4977             GvCV(gv) = cv;
4978             GvCVGEN(gv) = 0;
4979             PL_sub_generation++;
4980         }
4981     }
4982     CvGV(cv) = gv;
4983     CvFILE_set_from_cop(cv, PL_curcop);
4984     CvSTASH(cv) = PL_curstash;
4985 #ifdef USE_5005THREADS
4986     CvOWNER(cv) = 0;
4987     if (!CvMUTEXP(cv)) {
4988         New(666, CvMUTEXP(cv), 1, perl_mutex);
4989         MUTEX_INIT(CvMUTEXP(cv));
4990     }
4991 #endif /* USE_5005THREADS */
4992
4993     if (ps)
4994         sv_setpv((SV*)cv, ps);
4995
4996     if (PL_error_count) {
4997         op_free(block);
4998         block = Nullop;
4999         if (name) {
5000             char *s = strrchr(name, ':');
5001             s = s ? s+1 : name;
5002             if (strEQ(s, "BEGIN")) {
5003                 char *not_safe =
5004                     "BEGIN not safe after errors--compilation aborted";
5005                 if (PL_in_eval & EVAL_KEEPERR)
5006                     Perl_croak(aTHX_ not_safe);
5007                 else {
5008                     /* force display of errors found but not reported */
5009                     sv_catpv(ERRSV, not_safe);
5010                     Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
5011                 }
5012             }
5013         }
5014     }
5015     if (!block)
5016         goto done;
5017
5018     if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
5019         av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
5020
5021     if (CvLVALUE(cv)) {
5022         CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5023                              mod(scalarseq(block), OP_LEAVESUBLV));
5024     }
5025     else {
5026         CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5027     }
5028     CvROOT(cv)->op_private |= OPpREFCOUNTED;
5029     OpREFCNT_set(CvROOT(cv), 1);
5030     CvSTART(cv) = LINKLIST(CvROOT(cv));
5031     CvROOT(cv)->op_next = 0;
5032     CALL_PEEP(CvSTART(cv));
5033
5034     /* now that optimizer has done its work, adjust pad values */
5035     if (CvCLONE(cv)) {
5036         SV **namep = AvARRAY(PL_comppad_name);
5037         for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5038             SV *namesv;
5039
5040             if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
5041                 continue;
5042             /*
5043              * The only things that a clonable function needs in its
5044              * pad are references to outer lexicals and anonymous subs.
5045              * The rest are created anew during cloning.
5046              */
5047             if (!((namesv = namep[ix]) != Nullsv &&
5048                   namesv != &PL_sv_undef &&
5049                   (SvFAKE(namesv) ||
5050                    *SvPVX(namesv) == '&')))
5051             {
5052                 SvREFCNT_dec(PL_curpad[ix]);
5053                 PL_curpad[ix] = Nullsv;
5054             }
5055         }
5056         assert(!CvCONST(cv));
5057         if (ps && !*ps && op_const_sv(block, cv))
5058             CvCONST_on(cv);
5059     }
5060     else {
5061         AV *av = newAV();                       /* Will be @_ */
5062         av_extend(av, 0);
5063         av_store(PL_comppad, 0, (SV*)av);
5064         AvFLAGS(av) = AVf_REIFY;
5065
5066         for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5067             if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
5068                 continue;
5069             if (!SvPADMY(PL_curpad[ix]))
5070                 SvPADTMP_on(PL_curpad[ix]);
5071         }
5072     }
5073
5074     /* If a potential closure prototype, don't keep a refcount on outer CV.
5075      * This is okay as the lifetime of the prototype is tied to the
5076      * lifetime of the outer CV.  Avoids memory leak due to reference
5077      * loop. --GSAR */
5078     if (!name)
5079         SvREFCNT_dec(CvOUTSIDE(cv));
5080
5081     if (name || aname) {
5082         char *s;
5083         char *tname = (name ? name : aname);
5084
5085         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5086             SV *sv = NEWSV(0,0);
5087             SV *tmpstr = sv_newmortal();
5088             GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
5089             CV *pcv;
5090             HV *hv;
5091
5092             Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5093                            CopFILE(PL_curcop),
5094                            (long)PL_subline, (long)CopLINE(PL_curcop));
5095             gv_efullname3(tmpstr, gv, Nullch);
5096             hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
5097             hv = GvHVn(db_postponed);
5098             if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
5099                 && (pcv = GvCV(db_postponed)))
5100             {
5101                 dSP;
5102                 PUSHMARK(SP);
5103                 XPUSHs(tmpstr);
5104                 PUTBACK;
5105                 call_sv((SV*)pcv, G_DISCARD);
5106             }
5107         }
5108
5109         if ((s = strrchr(tname,':')))
5110             s++;
5111         else
5112             s = tname;
5113
5114         if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5115             goto done;
5116
5117         if (strEQ(s, "BEGIN")) {
5118             I32 oldscope = PL_scopestack_ix;
5119             ENTER;
5120             SAVECOPFILE(&PL_compiling);
5121             SAVECOPLINE(&PL_compiling);
5122
5123             if (!PL_beginav)
5124                 PL_beginav = newAV();
5125             DEBUG_x( dump_sub(gv) );
5126             av_push(PL_beginav, (SV*)cv);
5127             GvCV(gv) = 0;               /* cv has been hijacked */
5128             call_list(oldscope, PL_beginav);
5129
5130             PL_curcop = &PL_compiling;
5131             PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
5132             LEAVE;
5133         }
5134         else if (strEQ(s, "END") && !PL_error_count) {
5135             if (!PL_endav)
5136                 PL_endav = newAV();
5137             DEBUG_x( dump_sub(gv) );
5138             av_unshift(PL_endav, 1);
5139             av_store(PL_endav, 0, (SV*)cv);
5140             GvCV(gv) = 0;               /* cv has been hijacked */
5141         }
5142         else if (strEQ(s, "CHECK") && !PL_error_count) {
5143             if (!PL_checkav)
5144                 PL_checkav = newAV();
5145             DEBUG_x( dump_sub(gv) );
5146             if (PL_main_start && ckWARN(WARN_VOID))
5147                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
5148             av_unshift(PL_checkav, 1);
5149             av_store(PL_checkav, 0, (SV*)cv);
5150             GvCV(gv) = 0;               /* cv has been hijacked */
5151         }
5152         else if (strEQ(s, "INIT") && !PL_error_count) {
5153             if (!PL_initav)
5154                 PL_initav = newAV();
5155             DEBUG_x( dump_sub(gv) );
5156             if (PL_main_start && ckWARN(WARN_VOID))
5157                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
5158             av_push(PL_initav, (SV*)cv);
5159             GvCV(gv) = 0;               /* cv has been hijacked */
5160         }
5161     }
5162
5163   done:
5164     PL_copline = NOLINE;
5165     LEAVE_SCOPE(floor);
5166     return cv;
5167 }
5168
5169 /* XXX unsafe for threads if eval_owner isn't held */
5170 /*
5171 =for apidoc newCONSTSUB
5172
5173 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5174 eligible for inlining at compile-time.
5175
5176 =cut
5177 */
5178
5179 CV *
5180 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
5181 {
5182     CV* cv;
5183
5184     ENTER;
5185
5186     SAVECOPLINE(PL_curcop);
5187     CopLINE_set(PL_curcop, PL_copline);
5188
5189     SAVEHINTS();
5190     PL_hints &= ~HINT_BLOCK_SCOPE;
5191
5192     if (stash) {
5193         SAVESPTR(PL_curstash);
5194         SAVECOPSTASH(PL_curcop);
5195         PL_curstash = stash;
5196         CopSTASH_set(PL_curcop,stash);
5197     }
5198
5199     cv = newXS(name, const_sv_xsub, __FILE__);
5200     CvXSUBANY(cv).any_ptr = sv;
5201     CvCONST_on(cv);
5202     sv_setpv((SV*)cv, "");  /* prototype is "" */
5203
5204     LEAVE;
5205
5206     return cv;
5207 }
5208
5209 /*
5210 =for apidoc U||newXS
5211
5212 Used by C<xsubpp> to hook up XSUBs as Perl subs.
5213
5214 =cut
5215 */
5216
5217 CV *
5218 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
5219 {
5220     GV *gv = gv_fetchpv(name ? name :
5221                         (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5222                         GV_ADDMULTI, SVt_PVCV);
5223     register CV *cv;
5224
5225     if (!subaddr)
5226         Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
5227
5228     if ((cv = (name ? GvCV(gv) : Nullcv))) {
5229         if (GvCVGEN(gv)) {
5230             /* just a cached method */
5231             SvREFCNT_dec(cv);
5232             cv = 0;
5233         }
5234         else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5235             /* already defined (or promised) */
5236             if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
5237                             && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
5238                 line_t oldline = CopLINE(PL_curcop);
5239                 if (PL_copline != NOLINE)
5240                     CopLINE_set(PL_curcop, PL_copline);
5241                 Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
5242                             CvCONST(cv) ? "Constant subroutine %s redefined"
5243                                         : "Subroutine %s redefined"
5244                             ,name);
5245                 CopLINE_set(PL_curcop, oldline);
5246             }
5247             SvREFCNT_dec(cv);
5248             cv = 0;
5249         }
5250     }
5251
5252     if (cv)                             /* must reuse cv if autoloaded */
5253         cv_undef(cv);
5254     else {
5255         cv = (CV*)NEWSV(1105,0);
5256         sv_upgrade((SV *)cv, SVt_PVCV);
5257         if (name) {
5258             GvCV(gv) = cv;
5259             GvCVGEN(gv) = 0;
5260             PL_sub_generation++;
5261         }
5262     }
5263     CvGV(cv) = gv;
5264 #ifdef USE_5005THREADS
5265     New(666, CvMUTEXP(cv), 1, perl_mutex);
5266     MUTEX_INIT(CvMUTEXP(cv));
5267     CvOWNER(cv) = 0;
5268 #endif /* USE_5005THREADS */
5269     (void)gv_fetchfile(filename);
5270     CvFILE(cv) = filename;      /* NOTE: not copied, as it is expected to be
5271                                    an external constant string */
5272     CvXSUB(cv) = subaddr;
5273
5274     if (name) {
5275         char *s = strrchr(name,':');
5276         if (s)
5277             s++;
5278         else
5279             s = name;
5280
5281         if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5282             goto done;
5283
5284         if (strEQ(s, "BEGIN")) {
5285             if (!PL_beginav)
5286                 PL_beginav = newAV();
5287             av_push(PL_beginav, (SV*)cv);
5288             GvCV(gv) = 0;               /* cv has been hijacked */
5289         }
5290         else if (strEQ(s, "END")) {
5291             if (!PL_endav)
5292                 PL_endav = newAV();
5293             av_unshift(PL_endav, 1);
5294             av_store(PL_endav, 0, (SV*)cv);
5295             GvCV(gv) = 0;               /* cv has been hijacked */
5296         }
5297         else if (strEQ(s, "CHECK")) {
5298             if (!PL_checkav)
5299                 PL_checkav = newAV();
5300             if (PL_main_start && ckWARN(WARN_VOID))
5301                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
5302             av_unshift(PL_checkav, 1);
5303             av_store(PL_checkav, 0, (SV*)cv);
5304             GvCV(gv) = 0;               /* cv has been hijacked */
5305         }
5306         else if (strEQ(s, "INIT")) {
5307             if (!PL_initav)
5308                 PL_initav = newAV();
5309             if (PL_main_start && ckWARN(WARN_VOID))
5310                 Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
5311             av_push(PL_initav, (SV*)cv);
5312             GvCV(gv) = 0;               /* cv has been hijacked */
5313         }
5314     }
5315     else
5316         CvANON_on(cv);
5317
5318 done:
5319     return cv;
5320 }
5321
5322 void
5323 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5324 {
5325     register CV *cv;
5326     char *name;
5327     GV *gv;
5328     I32 ix;
5329     STRLEN n_a;
5330
5331     if (o)
5332         name = SvPVx(cSVOPo->op_sv, n_a);
5333     else
5334         name = "STDOUT";
5335     gv = gv_fetchpv(name,TRUE, SVt_PVFM);
5336 #ifdef GV_UNIQUE_CHECK
5337     if (GvUNIQUE(gv)) {
5338         Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5339     }
5340 #endif
5341     GvMULTI_on(gv);
5342     if ((cv = GvFORM(gv))) {
5343         if (ckWARN(WARN_REDEFINE)) {
5344             line_t oldline = CopLINE(PL_curcop);
5345             if (PL_copline != NOLINE)
5346                 CopLINE_set(PL_curcop, PL_copline);
5347             Perl_warner(aTHX_ packWARN(WARN_REDEFINE), "Format %s redefined",name);
5348             CopLINE_set(PL_curcop, oldline);
5349         }
5350         SvREFCNT_dec(cv);
5351     }
5352     cv = PL_compcv;
5353     GvFORM(gv) = cv;
5354     CvGV(cv) = gv;
5355     CvFILE_set_from_cop(cv, PL_curcop);
5356
5357     for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5358         if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
5359             SvPADTMP_on(PL_curpad[ix]);
5360     }
5361
5362     CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5363     CvROOT(cv)->op_private |= OPpREFCOUNTED;
5364     OpREFCNT_set(CvROOT(cv), 1);
5365     CvSTART(cv) = LINKLIST(CvROOT(cv));
5366     CvROOT(cv)->op_next = 0;
5367     CALL_PEEP(CvSTART(cv));
5368     op_free(o);
5369     PL_copline = NOLINE;
5370     LEAVE_SCOPE(floor);
5371 }
5372
5373 OP *
5374 Perl_newANONLIST(pTHX_ OP *o)
5375 {
5376     return newUNOP(OP_REFGEN, 0,
5377         mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5378 }
5379
5380 OP *
5381 Perl_newANONHASH(pTHX_ OP *o)
5382 {
5383     return newUNOP(OP_REFGEN, 0,
5384         mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5385 }
5386
5387 OP *
5388 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5389 {
5390     return newANONATTRSUB(floor, proto, Nullop, block);
5391 }
5392
5393 OP *
5394 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5395 {
5396     return newUNOP(OP_REFGEN, 0,
5397         newSVOP(OP_ANONCODE, 0,
5398                 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5399 }
5400
5401 OP *
5402 Perl_oopsAV(pTHX_ OP *o)
5403 {
5404     switch (o->op_type) {
5405     case OP_PADSV:
5406         o->op_type = OP_PADAV;
5407         o->op_ppaddr = PL_ppaddr[OP_PADAV];
5408         return ref(o, OP_RV2AV);
5409
5410     case OP_RV2SV:
5411         o->op_type = OP_RV2AV;
5412         o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5413         ref(o, OP_RV2AV);
5414         break;
5415
5416     default:
5417         if (ckWARN_d(WARN_INTERNAL))
5418             Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
5419         break;
5420     }
5421     return o;
5422 }
5423
5424 OP *
5425 Perl_oopsHV(pTHX_ OP *o)
5426 {
5427     switch (o->op_type) {
5428     case OP_PADSV:
5429     case OP_PADAV:
5430         o->op_type = OP_PADHV;
5431         o->op_ppaddr = PL_ppaddr[OP_PADHV];
5432         return ref(o, OP_RV2HV);
5433
5434     case OP_RV2SV:
5435     case OP_RV2AV:
5436         o->op_type = OP_RV2HV;
5437         o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5438         ref(o, OP_RV2HV);
5439         break;
5440
5441     default:
5442         if (ckWARN_d(WARN_INTERNAL))
5443             Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
5444         break;
5445     }
5446     return o;
5447 }
5448
5449 OP *
5450 Perl_newAVREF(pTHX_ OP *o)
5451 {
5452     if (o->op_type == OP_PADANY) {
5453         o->op_type = OP_PADAV;
5454         o->op_ppaddr = PL_ppaddr[OP_PADAV];
5455         return o;
5456     }
5457     else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5458                 && ckWARN(WARN_DEPRECATED)) {
5459         Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5460                 "Using an array as a reference is deprecated");
5461     }
5462     return newUNOP(OP_RV2AV, 0, scalar(o));
5463 }
5464
5465 OP *
5466 Perl_newGVREF(pTHX_ I32 type, OP *o)
5467 {
5468     if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5469         return newUNOP(OP_NULL, 0, o);
5470     return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5471 }
5472
5473 OP *
5474 Perl_newHVREF(pTHX_ OP *o)
5475 {
5476     if (o->op_type == OP_PADANY) {
5477         o->op_type = OP_PADHV;
5478         o->op_ppaddr = PL_ppaddr[OP_PADHV];
5479         return o;
5480     }
5481     else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5482                 && ckWARN(WARN_DEPRECATED)) {
5483         Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
5484                 "Using a hash as a reference is deprecated");
5485     }
5486     return newUNOP(OP_RV2HV, 0, scalar(o));
5487 }
5488
5489 OP *
5490 Perl_oopsCV(pTHX_ OP *o)
5491 {
5492     Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5493     /* STUB */
5494     return o;
5495 }
5496
5497 OP *
5498 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5499 {
5500     return newUNOP(OP_RV2CV, flags, scalar(o));
5501 }
5502
5503 OP *
5504 Perl_newSVREF(pTHX_ OP *o)
5505 {
5506     if (o->op_type == OP_PADANY) {
5507         o->op_type = OP_PADSV;
5508         o->op_ppaddr = PL_ppaddr[OP_PADSV];
5509         return o;
5510     }
5511     else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5512         o->op_flags |= OPpDONE_SVREF;
5513         return o;
5514     }
5515     return newUNOP(OP_RV2SV, 0, scalar(o));
5516 }
5517
5518 /* Check routines. */
5519
5520 OP *
5521 Perl_ck_anoncode(pTHX_ OP *o)
5522 {
5523     PADOFFSET ix;
5524     SV* name;
5525
5526     name = NEWSV(1106,0);
5527     sv_upgrade(name, SVt_PVNV);
5528     sv_setpvn(name, "&", 1);
5529     SvIVX(name) = -1;
5530     SvNVX(name) = 1;
5531     ix = pad_alloc(o->op_type, SVs_PADMY);
5532     av_store(PL_comppad_name, ix, name);
5533     av_store(PL_comppad, ix, cSVOPo->op_sv);
5534     SvPADMY_on(cSVOPo->op_sv);
5535     cSVOPo->op_sv = Nullsv;
5536     cSVOPo->op_targ = ix;
5537     return o;
5538 }
5539
5540 OP *
5541 Perl_ck_bitop(pTHX_ OP *o)
5542 {
5543     o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
5544     return o;
5545 }
5546
5547 OP *
5548 Perl_ck_concat(pTHX_ OP *o)
5549 {
5550     if (cUNOPo->op_first->op_type == OP_CONCAT)
5551         o->op_flags |= OPf_STACKED;
5552     return o;
5553 }
5554
5555 OP *
5556 Perl_ck_spair(pTHX_ OP *o)
5557 {
5558     if (o->op_flags & OPf_KIDS) {
5559         OP* newop;
5560         OP* kid;
5561         OPCODE type = o->op_type;
5562         o = modkids(ck_fun(o), type);
5563         kid = cUNOPo->op_first;
5564         newop = kUNOP->op_first->op_sibling;
5565         if (newop &&
5566             (newop->op_sibling ||
5567              !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5568              newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5569              newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5570
5571             return o;
5572         }
5573         op_free(kUNOP->op_first);
5574         kUNOP->op_first = newop;
5575     }
5576     o->op_ppaddr = PL_ppaddr[++o->op_type];
5577     return ck_fun(o);
5578 }
5579
5580 OP *
5581 Perl_ck_delete(pTHX_ OP *o)
5582 {
5583     o = ck_fun(o);
5584     o->op_private = 0;
5585     if (o->op_flags & OPf_KIDS) {
5586         OP *kid = cUNOPo->op_first;
5587         switch (kid->op_type) {
5588         case OP_ASLICE:
5589             o->op_flags |= OPf_SPECIAL;
5590             /* FALL THROUGH */
5591         case OP_HSLICE:
5592             o->op_private |= OPpSLICE;
5593             break;
5594         case OP_AELEM:
5595             o->op_flags |= OPf_SPECIAL;
5596             /* FALL THROUGH */
5597         case OP_HELEM:
5598             break;
5599         default:
5600             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5601                   OP_DESC(o));
5602         }
5603         op_null(kid);
5604     }
5605     return o;
5606 }
5607
5608 OP *
5609 Perl_ck_die(pTHX_ OP *o)
5610 {
5611 #ifdef VMS
5612     if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5613 #endif
5614     return ck_fun(o);
5615 }
5616
5617 OP *
5618 Perl_ck_eof(pTHX_ OP *o)
5619 {
5620     I32 type = o->op_type;
5621
5622     if (o->op_flags & OPf_KIDS) {
5623         if (cLISTOPo->op_first->op_type == OP_STUB) {
5624             op_free(o);
5625             o = newUNOP(type, OPf_SPECIAL,
5626                 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
5627         }
5628         return ck_fun(o);
5629     }
5630     return o;
5631 }
5632
5633 OP *
5634 Perl_ck_eval(pTHX_ OP *o)
5635 {
5636     PL_hints |= HINT_BLOCK_SCOPE;
5637     if (o->op_flags & OPf_KIDS) {
5638         SVOP *kid = (SVOP*)cUNOPo->op_first;
5639
5640         if (!kid) {
5641             o->op_flags &= ~OPf_KIDS;
5642             op_null(o);
5643         }
5644         else if (kid->op_type == OP_LINESEQ) {
5645             LOGOP *enter;
5646
5647             kid->op_next = o->op_next;
5648             cUNOPo->op_first = 0;
5649             op_free(o);
5650
5651             NewOp(1101, enter, 1, LOGOP);
5652             enter->op_type = OP_ENTERTRY;
5653             enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5654             enter->op_private = 0;
5655
5656             /* establish postfix order */
5657             enter->op_next = (OP*)enter;
5658
5659             o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5660             o->op_type = OP_LEAVETRY;
5661             o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5662             enter->op_other = o;
5663             return o;
5664         }
5665         else
5666             scalar((OP*)kid);
5667     }
5668     else {
5669         op_free(o);
5670         o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5671     }
5672     o->op_targ = (PADOFFSET)PL_hints;
5673     return o;
5674 }
5675
5676 OP *
5677 Perl_ck_exit(pTHX_ OP *o)
5678 {
5679 #ifdef VMS
5680     HV *table = GvHV(PL_hintgv);
5681     if (table) {
5682        SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5683        if (svp && *svp && SvTRUE(*svp))
5684            o->op_private |= OPpEXIT_VMSISH;
5685     }
5686     if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5687 #endif
5688     return ck_fun(o);
5689 }
5690
5691 OP *
5692 Perl_ck_exec(pTHX_ OP *o)
5693 {
5694     OP *kid;
5695     if (o->op_flags & OPf_STACKED) {
5696         o = ck_fun(o);
5697         kid = cUNOPo->op_first->op_sibling;
5698         if (kid->op_type == OP_RV2GV)
5699             op_null(kid);
5700     }
5701     else
5702         o = listkids(o);
5703     return o;
5704 }
5705
5706 OP *
5707 Perl_ck_exists(pTHX_ OP *o)
5708 {
5709     o = ck_fun(o);
5710     if (o->op_flags & OPf_KIDS) {
5711         OP *kid = cUNOPo->op_first;
5712         if (kid->op_type == OP_ENTERSUB) {
5713             (void) ref(kid, o->op_type);
5714             if (kid->op_type != OP_RV2CV && !PL_error_count)
5715                 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5716                             OP_DESC(o));
5717             o->op_private |= OPpEXISTS_SUB;
5718         }
5719         else if (kid->op_type == OP_AELEM)
5720             o->op_flags |= OPf_SPECIAL;
5721         else if (kid->op_type != OP_HELEM)
5722             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5723                         OP_DESC(o));
5724         op_null(kid);
5725     }
5726     return o;
5727 }
5728
5729 #if 0
5730 OP *
5731 Perl_ck_gvconst(pTHX_ register OP *o)
5732 {
5733     o = fold_constants(o);
5734     if (o->op_type == OP_CONST)
5735         o->op_type = OP_GV;
5736     return o;
5737 }
5738 #endif
5739
5740 OP *
5741 Perl_ck_rvconst(pTHX_ register OP *o)
5742 {
5743     SVOP *kid = (SVOP*)cUNOPo->op_first;
5744
5745     o->op_private |= (PL_hints & HINT_STRICT_REFS);
5746     if (kid->op_type == OP_CONST) {
5747         char *name;
5748         int iscv;
5749         GV *gv;
5750         SV *kidsv = kid->op_sv;
5751         STRLEN n_a;
5752
5753         /* Is it a constant from cv_const_sv()? */
5754         if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5755             SV *rsv = SvRV(kidsv);
5756             int svtype = SvTYPE(rsv);
5757             char *badtype = Nullch;
5758
5759             switch (o->op_type) {
5760             case OP_RV2SV:
5761                 if (svtype > SVt_PVMG)
5762                     badtype = "a SCALAR";
5763                 break;
5764             case OP_RV2AV:
5765                 if (svtype != SVt_PVAV)
5766                     badtype = "an ARRAY";
5767                 break;
5768             case OP_RV2HV:
5769                 if (svtype != SVt_PVHV)
5770                     badtype = "a HASH";
5771                 break;
5772             case OP_RV2CV:
5773                 if (svtype != SVt_PVCV)
5774                     badtype = "a CODE";
5775                 break;
5776             }
5777             if (badtype)
5778                 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5779             return o;
5780         }
5781         name = SvPV(kidsv, n_a);
5782         if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5783             char *badthing = Nullch;
5784             switch (o->op_type) {
5785             case OP_RV2SV:
5786                 badthing = "a SCALAR";
5787                 break;
5788             case OP_RV2AV:
5789                 badthing = "an ARRAY";
5790                 break;
5791             case OP_RV2HV:
5792                 badthing = "a HASH";
5793                 break;
5794             }
5795             if (badthing)
5796                 Perl_croak(aTHX_
5797           "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5798                       name, badthing);
5799         }
5800         /*
5801          * This is a little tricky.  We only want to add the symbol if we
5802          * didn't add it in the lexer.  Otherwise we get duplicate strict
5803          * warnings.  But if we didn't add it in the lexer, we must at
5804          * least pretend like we wanted to add it even if it existed before,
5805          * or we get possible typo warnings.  OPpCONST_ENTERED says
5806          * whether the lexer already added THIS instance of this symbol.
5807          */
5808         iscv = (o->op_type == OP_RV2CV) * 2;
5809         do {
5810             gv = gv_fetchpv(name,
5811                 iscv | !(kid->op_private & OPpCONST_ENTERED),
5812                 iscv
5813                     ? SVt_PVCV
5814                     : o->op_type == OP_RV2SV
5815                         ? SVt_PV
5816                         : o->op_type == OP_RV2AV
5817                             ? SVt_PVAV
5818                             : o->op_type == OP_RV2HV
5819                                 ? SVt_PVHV
5820                                 : SVt_PVGV);
5821         } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5822         if (gv) {
5823             kid->op_type = OP_GV;
5824             SvREFCNT_dec(kid->op_sv);
5825 #ifdef USE_ITHREADS
5826             /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5827             kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5828             SvREFCNT_dec(PL_curpad[kPADOP->op_padix]);
5829             GvIN_PAD_on(gv);
5830             PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv);
5831 #else
5832             kid->op_sv = SvREFCNT_inc(gv);
5833 #endif
5834             kid->op_private = 0;
5835             kid->op_ppaddr = PL_ppaddr[OP_GV];
5836         }
5837     }
5838     return o;
5839 }
5840
5841 OP *
5842 Perl_ck_ftst(pTHX_ OP *o)
5843 {
5844     I32 type = o->op_type;
5845
5846     if (o->op_flags & OPf_REF) {
5847         /* nothing */
5848     }
5849     else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5850         SVOP *kid = (SVOP*)cUNOPo->op_first;
5851
5852         if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5853             STRLEN n_a;
5854             OP *newop = newGVOP(type, OPf_REF,
5855                 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5856             op_free(o);
5857             o = newop;
5858         }
5859     }
5860     else {
5861         op_free(o);
5862         if (type == OP_FTTTY)
5863            o =  newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
5864                                 SVt_PVIO));
5865         else
5866             o = newUNOP(type, 0, newDEFSVOP());
5867     }
5868     return o;
5869 }
5870
5871 OP *
5872 Perl_ck_fun(pTHX_ OP *o)
5873 {
5874     register OP *kid;
5875     OP **tokid;
5876     OP *sibl;
5877     I32 numargs = 0;
5878     int type = o->op_type;
5879     register I32 oa = PL_opargs[type] >> OASHIFT;
5880
5881     if (o->op_flags & OPf_STACKED) {
5882         if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5883             oa &= ~OA_OPTIONAL;
5884         else
5885             return no_fh_allowed(o);
5886     }
5887
5888     if (o->op_flags & OPf_KIDS) {
5889         STRLEN n_a;
5890         tokid = &cLISTOPo->op_first;
5891         kid = cLISTOPo->op_first;
5892         if (kid->op_type == OP_PUSHMARK ||
5893             (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5894         {
5895             tokid = &kid->op_sibling;
5896             kid = kid->op_sibling;
5897         }
5898         if (!kid && PL_opargs[type] & OA_DEFGV)
5899             *tokid = kid = newDEFSVOP();
5900
5901         while (oa && kid) {
5902             numargs++;
5903             sibl = kid->op_sibling;
5904             switch (oa & 7) {
5905             case OA_SCALAR:
5906                 /* list seen where single (scalar) arg expected? */
5907                 if (numargs == 1 && !(oa >> 4)
5908                     && kid->op_type == OP_LIST && type != OP_SCALAR)
5909                 {
5910                     return too_many_arguments(o,PL_op_desc[type]);
5911                 }
5912                 scalar(kid);
5913                 break;
5914             case OA_LIST:
5915                 if (oa < 16) {
5916                     kid = 0;
5917                     continue;
5918                 }
5919                 else
5920                     list(kid);
5921                 break;
5922             case OA_AVREF:
5923                 if ((type == OP_PUSH || type == OP_UNSHIFT)
5924                     && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5925                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5926                         "Useless use of %s with no values",
5927                         PL_op_desc[type]);
5928
5929                 if (kid->op_type == OP_CONST &&
5930                     (kid->op_private & OPpCONST_BARE))
5931                 {
5932                     char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5933                     OP *newop = newAVREF(newGVOP(OP_GV, 0,
5934                         gv_fetchpv(name, TRUE, SVt_PVAV) ));
5935                     if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5936                         Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5937                             "Array @%s missing the @ in argument %"IVdf" of %s()",
5938                             name, (IV)numargs, PL_op_desc[type]);
5939                     op_free(kid);
5940                     kid = newop;
5941                     kid->op_sibling = sibl;
5942                     *tokid = kid;
5943                 }
5944                 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5945                     bad_type(numargs, "array", PL_op_desc[type], kid);
5946                 mod(kid, type);
5947                 break;
5948             case OA_HVREF:
5949                 if (kid->op_type == OP_CONST &&
5950                     (kid->op_private & OPpCONST_BARE))
5951                 {
5952                     char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5953                     OP *newop = newHVREF(newGVOP(OP_GV, 0,
5954                         gv_fetchpv(name, TRUE, SVt_PVHV) ));
5955                     if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5956                         Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5957                             "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5958                             name, (IV)numargs, PL_op_desc[type]);
5959                     op_free(kid);
5960                     kid = newop;
5961                     kid->op_sibling = sibl;
5962                     *tokid = kid;
5963                 }
5964                 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5965                     bad_type(numargs, "hash", PL_op_desc[type], kid);
5966                 mod(kid, type);
5967                 break;
5968             case OA_CVREF:
5969                 {
5970                     OP *newop = newUNOP(OP_NULL, 0, kid);
5971                     kid->op_sibling = 0;
5972                     linklist(kid);
5973                     newop->op_next = newop;
5974                     kid = newop;
5975                     kid->op_sibling = sibl;
5976                     *tokid = kid;
5977                 }
5978                 break;
5979             case OA_FILEREF:
5980                 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5981                     if (kid->op_type == OP_CONST &&
5982                         (kid->op_private & OPpCONST_BARE))
5983                     {
5984                         OP *newop = newGVOP(OP_GV, 0,
5985                             gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5986                                         SVt_PVIO) );
5987                         if (!(o->op_private & 1) && /* if not unop */
5988                             kid == cLISTOPo->op_last)
5989                             cLISTOPo->op_last = newop;
5990                         op_free(kid);
5991                         kid = newop;
5992                     }
5993                     else if (kid->op_type == OP_READLINE) {
5994                         /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5995                         bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5996                     }
5997                     else {
5998                         I32 flags = OPf_SPECIAL;
5999                         I32 priv = 0;
6000                         PADOFFSET targ = 0;
6001
6002                         /* is this op a FH constructor? */
6003                         if (is_handle_constructor(o,numargs)) {
6004                             char *name = Nullch;
6005                             STRLEN len;
6006
6007                             flags = 0;
6008                             /* Set a flag to tell rv2gv to vivify
6009                              * need to "prove" flag does not mean something
6010                              * else already - NI-S 1999/05/07
6011                              */
6012                             priv = OPpDEREF;
6013                             if (kid->op_type == OP_PADSV) {
6014                                 SV **namep = av_fetch(PL_comppad_name,
6015                                                       kid->op_targ, 4);
6016                                 if (namep && *namep)
6017                                     name = SvPV(*namep, len);
6018                             }
6019                             else if (kid->op_type == OP_RV2SV
6020                                      && kUNOP->op_first->op_type == OP_GV)
6021                             {
6022                                 GV *gv = cGVOPx_gv(kUNOP->op_first);
6023                                 name = GvNAME(gv);
6024                                 len = GvNAMELEN(gv);
6025                             }
6026                             else if (kid->op_type == OP_AELEM
6027                                      || kid->op_type == OP_HELEM)
6028                             {
6029                                 name = "__ANONIO__";
6030                                 len = 10;
6031                                 mod(kid,type);
6032                             }
6033                             if (name) {
6034                                 SV *namesv;
6035                                 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
6036                                 namesv = PL_curpad[targ];
6037                                 (void)SvUPGRADE(namesv, SVt_PV);
6038                                 if (*name != '$')
6039                                     sv_setpvn(namesv, "$", 1);
6040                                 sv_catpvn(namesv, name, len);
6041                             }
6042                         }
6043                         kid->op_sibling = 0;
6044                         kid = newUNOP(OP_RV2GV, flags, scalar(kid));
6045                         kid->op_targ = targ;
6046                         kid->op_private |= priv;
6047                     }
6048                     kid->op_sibling = sibl;
6049                     *tokid = kid;
6050                 }
6051                 scalar(kid);
6052                 break;
6053             case OA_SCALARREF:
6054                 mod(scalar(kid), type);
6055                 break;
6056             }
6057             oa >>= 4;
6058             tokid = &kid->op_sibling;
6059             kid = kid->op_sibling;
6060         }
6061         o->op_private |= numargs;
6062         if (kid)
6063             return too_many_arguments(o,OP_DESC(o));
6064         listkids(o);
6065     }
6066     else if (PL_opargs[type] & OA_DEFGV) {
6067         op_free(o);
6068         return newUNOP(type, 0, newDEFSVOP());
6069     }
6070
6071     if (oa) {
6072         while (oa & OA_OPTIONAL)
6073             oa >>= 4;
6074         if (oa && oa != OA_LIST)
6075             return too_few_arguments(o,OP_DESC(o));
6076     }
6077     return o;
6078 }
6079
6080 OP *
6081 Perl_ck_glob(pTHX_ OP *o)
6082 {
6083     GV *gv;
6084
6085     o = ck_fun(o);
6086     if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
6087         append_elem(OP_GLOB, o, newDEFSVOP());
6088
6089     if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
6090           && GvCVu(gv) && GvIMPORTED_CV(gv)))
6091     {
6092         gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
6093     }
6094
6095 #if !defined(PERL_EXTERNAL_GLOB)
6096     /* XXX this can be tightened up and made more failsafe. */
6097     if (!gv) {
6098         GV *glob_gv;
6099         ENTER;
6100         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
6101                 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
6102         gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
6103         glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
6104         GvCV(gv) = GvCV(glob_gv);
6105         SvREFCNT_inc((SV*)GvCV(gv));
6106         GvIMPORTED_CV_on(gv);
6107         LEAVE;
6108     }
6109 #endif /* PERL_EXTERNAL_GLOB */
6110
6111     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6112         append_elem(OP_GLOB, o,
6113                     newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
6114         o->op_type = OP_LIST;
6115         o->op_ppaddr = PL_ppaddr[OP_LIST];
6116         cLISTOPo->op_first->op_type = OP_PUSHMARK;
6117         cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
6118         o = newUNOP(OP_ENTERSUB, OPf_STACKED,
6119                     append_elem(OP_LIST, o,
6120                                 scalar(newUNOP(OP_RV2CV, 0,
6121                                                newGVOP(OP_GV, 0, gv)))));
6122         o = newUNOP(OP_NULL, 0, ck_subr(o));
6123         o->op_targ = OP_GLOB;           /* hint at what it used to be */
6124         return o;
6125     }
6126     gv = newGVgen("main");
6127     gv_IOadd(gv);
6128     append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
6129     scalarkids(o);
6130     return o;
6131 }
6132
6133 OP *
6134 Perl_ck_grep(pTHX_ OP *o)
6135 {
6136     LOGOP *gwop;
6137     OP *kid;
6138     OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
6139
6140     o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
6141     NewOp(1101, gwop, 1, LOGOP);
6142
6143     if (o->op_flags & OPf_STACKED) {
6144         OP* k;
6145         o = ck_sort(o);
6146         kid = cLISTOPo->op_first->op_sibling;
6147         for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
6148             kid = k;
6149         }
6150         kid->op_next = (OP*)gwop;
6151         o->op_flags &= ~OPf_STACKED;
6152     }
6153     kid = cLISTOPo->op_first->op_sibling;
6154     if (type == OP_MAPWHILE)
6155         list(kid);
6156     else
6157         scalar(kid);
6158     o = ck_fun(o);
6159     if (PL_error_count)
6160         return o;
6161     kid = cLISTOPo->op_first->op_sibling;
6162     if (kid->op_type != OP_NULL)
6163         Perl_croak(aTHX_ "panic: ck_grep");
6164     kid = kUNOP->op_first;
6165
6166     gwop->op_type = type;
6167     gwop->op_ppaddr = PL_ppaddr[type];
6168     gwop->op_first = listkids(o);
6169     gwop->op_flags |= OPf_KIDS;
6170     gwop->op_private = 1;
6171     gwop->op_other = LINKLIST(kid);
6172     gwop->op_targ = pad_alloc(type, SVs_PADTMP);
6173     kid->op_next = (OP*)gwop;
6174
6175     kid = cLISTOPo->op_first->op_sibling;
6176     if (!kid || !kid->op_sibling)
6177         return too_few_arguments(o,OP_DESC(o));
6178     for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
6179         mod(kid, OP_GREPSTART);
6180
6181     return (OP*)gwop;
6182 }
6183
6184 OP *
6185 Perl_ck_index(pTHX_ OP *o)
6186 {
6187     if (o->op_flags & OPf_KIDS) {
6188         OP *kid = cLISTOPo->op_first->op_sibling;       /* get past pushmark */
6189         if (kid)
6190             kid = kid->op_sibling;                      /* get past "big" */
6191         if (kid && kid->op_type == OP_CONST)
6192             fbm_compile(((SVOP*)kid)->op_sv, 0);
6193     }
6194     return ck_fun(o);
6195 }
6196
6197 OP *
6198 Perl_ck_lengthconst(pTHX_ OP *o)
6199 {
6200     /* XXX length optimization goes here */
6201     return ck_fun(o);
6202 }
6203
6204 OP *
6205 Perl_ck_lfun(pTHX_ OP *o)
6206 {
6207     OPCODE type = o->op_type;
6208     return modkids(ck_fun(o), type);
6209 }
6210
6211 OP *
6212 Perl_ck_defined(pTHX_ OP *o)            /* 19990527 MJD */
6213 {
6214     if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
6215         switch (cUNOPo->op_first->op_type) {
6216         case OP_RV2AV:
6217             /* This is needed for
6218                if (defined %stash::)
6219                to work.   Do not break Tk.
6220                */
6221             break;                      /* Globals via GV can be undef */
6222         case OP_PADAV:
6223         case OP_AASSIGN:                /* Is this a good idea? */
6224             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6225                         "defined(@array) is deprecated");
6226             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6227                         "\t(Maybe you should just omit the defined()?)\n");
6228         break;
6229         case OP_RV2HV:
6230             /* This is needed for
6231                if (defined %stash::)
6232                to work.   Do not break Tk.
6233                */
6234             break;                      /* Globals via GV can be undef */
6235         case OP_PADHV:
6236             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6237                         "defined(%%hash) is deprecated");
6238             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6239                         "\t(Maybe you should just omit the defined()?)\n");
6240             break;
6241         default:
6242             /* no warning */
6243             break;
6244         }
6245     }
6246     return ck_rfun(o);
6247 }
6248
6249 OP *
6250 Perl_ck_rfun(pTHX_ OP *o)
6251 {
6252     OPCODE type = o->op_type;
6253     return refkids(ck_fun(o), type);
6254 }
6255
6256 OP *
6257 Perl_ck_listiob(pTHX_ OP *o)
6258 {
6259     register OP *kid;
6260
6261     kid = cLISTOPo->op_first;
6262     if (!kid) {
6263         o = force_list(o);
6264         kid = cLISTOPo->op_first;
6265     }
6266     if (kid->op_type == OP_PUSHMARK)
6267         kid = kid->op_sibling;
6268     if (kid && o->op_flags & OPf_STACKED)
6269         kid = kid->op_sibling;
6270     else if (kid && !kid->op_sibling) {         /* print HANDLE; */
6271         if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6272             o->op_flags |= OPf_STACKED; /* make it a filehandle */
6273             kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6274             cLISTOPo->op_first->op_sibling = kid;
6275             cLISTOPo->op_last = kid;
6276             kid = kid->op_sibling;
6277         }
6278     }
6279
6280     if (!kid)
6281         append_elem(o->op_type, o, newDEFSVOP());
6282
6283     return listkids(o);
6284 }
6285
6286 OP *
6287 Perl_ck_sassign(pTHX_ OP *o)
6288 {
6289     OP *kid = cLISTOPo->op_first;
6290     /* has a disposable target? */
6291     if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6292         && !(kid->op_flags & OPf_STACKED)
6293         /* Cannot steal the second time! */
6294         && !(kid->op_private & OPpTARGET_MY))
6295     {
6296         OP *kkid = kid->op_sibling;
6297
6298         /* Can just relocate the target. */
6299         if (kkid && kkid->op_type == OP_PADSV
6300             && !(kkid->op_private & OPpLVAL_INTRO))
6301         {
6302             kid->op_targ = kkid->op_targ;
6303             kkid->op_targ = 0;
6304             /* Now we do not need PADSV and SASSIGN. */
6305             kid->op_sibling = o->op_sibling;    /* NULL */
6306             cLISTOPo->op_first = NULL;
6307             op_free(o);
6308             op_free(kkid);
6309             kid->op_private |= OPpTARGET_MY;    /* Used for context settings */
6310             return kid;
6311         }
6312     }
6313     return o;
6314 }
6315
6316 OP *
6317 Perl_ck_match(pTHX_ OP *o)
6318 {
6319     o->op_private |= OPpRUNTIME;
6320     return o;
6321 }
6322
6323 OP *
6324 Perl_ck_method(pTHX_ OP *o)
6325 {
6326     OP *kid = cUNOPo->op_first;
6327     if (kid->op_type == OP_CONST) {
6328         SV* sv = kSVOP->op_sv;
6329         if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
6330             OP *cmop;
6331             if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6332                 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
6333             }
6334             else {
6335                 kSVOP->op_sv = Nullsv;
6336             }
6337             cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6338             op_free(o);
6339             return cmop;
6340         }
6341     }
6342     return o;
6343 }
6344
6345 OP *
6346 Perl_ck_null(pTHX_ OP *o)
6347 {
6348     return o;
6349 }
6350
6351 OP *
6352 Perl_ck_open(pTHX_ OP *o)
6353 {
6354     HV *table = GvHV(PL_hintgv);
6355     if (table) {
6356         SV **svp;
6357         I32 mode;
6358         svp = hv_fetch(table, "open_IN", 7, FALSE);
6359         if (svp && *svp) {
6360             mode = mode_from_discipline(*svp);
6361             if (mode & O_BINARY)
6362                 o->op_private |= OPpOPEN_IN_RAW;
6363             else if (mode & O_TEXT)
6364                 o->op_private |= OPpOPEN_IN_CRLF;
6365         }
6366
6367         svp = hv_fetch(table, "open_OUT", 8, FALSE);
6368         if (svp && *svp) {
6369             mode = mode_from_discipline(*svp);
6370             if (mode & O_BINARY)
6371                 o->op_private |= OPpOPEN_OUT_RAW;
6372             else if (mode & O_TEXT)
6373                 o->op_private |= OPpOPEN_OUT_CRLF;
6374         }
6375     }
6376     if (o->op_type == OP_BACKTICK)
6377         return o;
6378     return ck_fun(o);
6379 }
6380
6381 OP *
6382 Perl_ck_repeat(pTHX_ OP *o)
6383 {
6384     if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6385         o->op_private |= OPpREPEAT_DOLIST;
6386         cBINOPo->op_first = force_list(cBINOPo->op_first);
6387     }
6388     else
6389         scalar(o);
6390     return o;
6391 }
6392
6393 OP *
6394 Perl_ck_require(pTHX_ OP *o)
6395 {
6396     GV* gv;
6397
6398     if (o->op_flags & OPf_KIDS) {       /* Shall we supply missing .pm? */
6399         SVOP *kid = (SVOP*)cUNOPo->op_first;
6400
6401         if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6402             char *s;
6403             for (s = SvPVX(kid->op_sv); *s; s++) {
6404                 if (*s == ':' && s[1] == ':') {
6405                     *s = '/';
6406                     Move(s+2, s+1, strlen(s+2)+1, char);
6407                     --SvCUR(kid->op_sv);
6408                 }
6409             }
6410             if (SvREADONLY(kid->op_sv)) {
6411                 SvREADONLY_off(kid->op_sv);
6412                 sv_catpvn(kid->op_sv, ".pm", 3);
6413                 SvREADONLY_on(kid->op_sv);
6414             }
6415             else
6416                 sv_catpvn(kid->op_sv, ".pm", 3);
6417         }
6418     }
6419
6420     /* handle override, if any */
6421     gv = gv_fetchpv("require", FALSE, SVt_PVCV);
6422     if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
6423         gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
6424
6425     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6426         OP *kid = cUNOPo->op_first;
6427         cUNOPo->op_first = 0;
6428         op_free(o);
6429         return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
6430                                append_elem(OP_LIST, kid,
6431                                            scalar(newUNOP(OP_RV2CV, 0,
6432                                                           newGVOP(OP_GV, 0,
6433                                                                   gv))))));
6434     }
6435
6436     return ck_fun(o);
6437 }
6438
6439 OP *
6440 Perl_ck_return(pTHX_ OP *o)
6441 {
6442     OP *kid;
6443     if (CvLVALUE(PL_compcv)) {
6444         for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6445             mod(kid, OP_LEAVESUBLV);
6446     }
6447     return o;
6448 }
6449
6450 #if 0
6451 OP *
6452 Perl_ck_retarget(pTHX_ OP *o)
6453 {
6454     Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
6455     /* STUB */
6456     return o;
6457 }
6458 #endif
6459
6460 OP *
6461 Perl_ck_select(pTHX_ OP *o)
6462 {
6463     OP* kid;
6464     if (o->op_flags & OPf_KIDS) {
6465         kid = cLISTOPo->op_first->op_sibling;   /* get past pushmark */
6466         if (kid && kid->op_sibling) {
6467             o->op_type = OP_SSELECT;
6468             o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6469             o = ck_fun(o);
6470             return fold_constants(o);
6471         }
6472     }
6473     o = ck_fun(o);
6474     kid = cLISTOPo->op_first->op_sibling;    /* get past pushmark */
6475     if (kid && kid->op_type == OP_RV2GV)
6476         kid->op_private &= ~HINT_STRICT_REFS;
6477     return o;
6478 }
6479
6480 OP *
6481 Perl_ck_shift(pTHX_ OP *o)
6482 {
6483     I32 type = o->op_type;
6484
6485     if (!(o->op_flags & OPf_KIDS)) {
6486         OP *argop;
6487
6488         op_free(o);
6489 #ifdef USE_5005THREADS
6490         if (!CvUNIQUE(PL_compcv)) {
6491             argop = newOP(OP_PADAV, OPf_REF);
6492             argop->op_targ = 0;         /* PL_curpad[0] is @_ */
6493         }
6494         else {
6495             argop = newUNOP(OP_RV2AV, 0,
6496                 scalar(newGVOP(OP_GV, 0,
6497                     gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6498         }
6499 #else
6500         argop = newUNOP(OP_RV2AV, 0,
6501             scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
6502                            PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6503 #endif /* USE_5005THREADS */
6504         return newUNOP(type, 0, scalar(argop));
6505     }
6506     return scalar(modkids(ck_fun(o), type));
6507 }
6508
6509 OP *
6510 Perl_ck_sort(pTHX_ OP *o)
6511 {
6512     OP *firstkid;
6513
6514     if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6515         simplify_sort(o);
6516     firstkid = cLISTOPo->op_first->op_sibling;          /* get past pushmark */
6517     if (o->op_flags & OPf_STACKED) {                    /* may have been cleared */
6518         OP *k = NULL;
6519         OP *kid = cUNOPx(firstkid)->op_first;           /* get past null */
6520
6521         if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6522             linklist(kid);
6523             if (kid->op_type == OP_SCOPE) {
6524                 k = kid->op_next;
6525                 kid->op_next = 0;
6526             }
6527             else if (kid->op_type == OP_LEAVE) {
6528                 if (o->op_type == OP_SORT) {
6529                     op_null(kid);                       /* wipe out leave */
6530                     kid->op_next = kid;
6531
6532                     for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6533                         if (k->op_next == kid)
6534                             k->op_next = 0;
6535                         /* don't descend into loops */
6536                         else if (k->op_type == OP_ENTERLOOP
6537                                  || k->op_type == OP_ENTERITER)
6538                         {
6539                             k = cLOOPx(k)->op_lastop;
6540                         }
6541                     }
6542                 }
6543                 else
6544                     kid->op_next = 0;           /* just disconnect the leave */
6545                 k = kLISTOP->op_first;
6546             }
6547             CALL_PEEP(k);
6548
6549             kid = firstkid;
6550             if (o->op_type == OP_SORT) {
6551                 /* provide scalar context for comparison function/block */
6552                 kid = scalar(kid);
6553                 kid->op_next = kid;
6554             }
6555             else
6556                 kid->op_next = k;
6557             o->op_flags |= OPf_SPECIAL;
6558         }
6559         else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6560             op_null(firstkid);
6561
6562         firstkid = firstkid->op_sibling;
6563     }
6564
6565     /* provide list context for arguments */
6566     if (o->op_type == OP_SORT)
6567         list(firstkid);
6568
6569     return o;
6570 }
6571
6572 STATIC void
6573 S_simplify_sort(pTHX_ OP *o)
6574 {
6575     register OP *kid = cLISTOPo->op_first->op_sibling;  /* get past pushmark */
6576     OP *k;
6577     int reversed;
6578     GV *gv;
6579     if (!(o->op_flags & OPf_STACKED))
6580         return;
6581     GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6582     GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6583     kid = kUNOP->op_first;                              /* get past null */
6584     if (kid->op_type != OP_SCOPE)
6585         return;
6586     kid = kLISTOP->op_last;                             /* get past scope */
6587     switch(kid->op_type) {
6588         case OP_NCMP:
6589         case OP_I_NCMP:
6590         case OP_SCMP:
6591             break;
6592         default:
6593             return;
6594     }
6595     k = kid;                                            /* remember this node*/
6596     if (kBINOP->op_first->op_type != OP_RV2SV)
6597         return;
6598     kid = kBINOP->op_first;                             /* get past cmp */
6599     if (kUNOP->op_first->op_type != OP_GV)
6600         return;
6601     kid = kUNOP->op_first;                              /* get past rv2sv */
6602     gv = kGVOP_gv;
6603     if (GvSTASH(gv) != PL_curstash)
6604         return;
6605     if (strEQ(GvNAME(gv), "a"))
6606         reversed = 0;
6607     else if (strEQ(GvNAME(gv), "b"))
6608         reversed = 1;
6609     else
6610         return;
6611     kid = k;                                            /* back to cmp */
6612     if (kBINOP->op_last->op_type != OP_RV2SV)
6613         return;
6614     kid = kBINOP->op_last;                              /* down to 2nd arg */
6615     if (kUNOP->op_first->op_type != OP_GV)
6616         return;
6617     kid = kUNOP->op_first;                              /* get past rv2sv */
6618     gv = kGVOP_gv;
6619     if (GvSTASH(gv) != PL_curstash
6620         || ( reversed
6621             ? strNE(GvNAME(gv), "a")
6622             : strNE(GvNAME(gv), "b")))
6623         return;
6624     o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6625     if (reversed)
6626         o->op_private |= OPpSORT_REVERSE;
6627     if (k->op_type == OP_NCMP)
6628         o->op_private |= OPpSORT_NUMERIC;
6629     if (k->op_type == OP_I_NCMP)
6630         o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6631     kid = cLISTOPo->op_first->op_sibling;
6632     cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6633     op_free(kid);                                     /* then delete it */
6634 }
6635
6636 OP *
6637 Perl_ck_split(pTHX_ OP *o)
6638 {
6639     register OP *kid;
6640
6641     if (o->op_flags & OPf_STACKED)
6642         return no_fh_allowed(o);
6643
6644     kid = cLISTOPo->op_first;
6645     if (kid->op_type != OP_NULL)
6646         Perl_croak(aTHX_ "panic: ck_split");
6647     kid = kid->op_sibling;
6648     op_free(cLISTOPo->op_first);
6649     cLISTOPo->op_first = kid;
6650     if (!kid) {
6651         cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6652         cLISTOPo->op_last = kid; /* There was only one element previously */
6653     }
6654
6655     if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6656         OP *sibl = kid->op_sibling;
6657         kid->op_sibling = 0;
6658         kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
6659         if (cLISTOPo->op_first == cLISTOPo->op_last)
6660             cLISTOPo->op_last = kid;
6661         cLISTOPo->op_first = kid;
6662         kid->op_sibling = sibl;
6663     }
6664
6665     kid->op_type = OP_PUSHRE;
6666     kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6667     scalar(kid);
6668     if (ckWARN(WARN_REGEXP) && ((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
6669       Perl_warner(aTHX_ packWARN(WARN_REGEXP),
6670                   "Use of /g modifier is meaningless in split");
6671     }
6672
6673     if (!kid->op_sibling)
6674         append_elem(OP_SPLIT, o, newDEFSVOP());
6675
6676     kid = kid->op_sibling;
6677     scalar(kid);
6678
6679     if (!kid->op_sibling)
6680         append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6681
6682     kid = kid->op_sibling;
6683     scalar(kid);
6684
6685     if (kid->op_sibling)
6686         return too_many_arguments(o,OP_DESC(o));
6687
6688     return o;
6689 }
6690
6691 OP *
6692 Perl_ck_join(pTHX_ OP *o)
6693 {
6694     if (ckWARN(WARN_SYNTAX)) {
6695         OP *kid = cLISTOPo->op_first->op_sibling;
6696         if (kid && kid->op_type == OP_MATCH) {
6697             char *pmstr = "STRING";
6698             if (PM_GETRE(kPMOP))
6699                 pmstr = PM_GETRE(kPMOP)->precomp;
6700             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6701                         "/%s/ should probably be written as \"%s\"",
6702                         pmstr, pmstr);
6703         }
6704     }
6705     return ck_fun(o);
6706 }
6707
6708 OP *
6709 Perl_ck_subr(pTHX_ OP *o)
6710 {
6711     OP *prev = ((cUNOPo->op_first->op_sibling)
6712              ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6713     OP *o2 = prev->op_sibling;
6714     OP *cvop;
6715     char *proto = 0;
6716     CV *cv = 0;
6717     GV *namegv = 0;
6718     int optional = 0;
6719     I32 arg = 0;
6720     I32 contextclass = 0;
6721     char *e = 0;
6722     STRLEN n_a;
6723
6724     o->op_private |= OPpENTERSUB_HASTARG;
6725     for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6726     if (cvop->op_type == OP_RV2CV) {
6727         SVOP* tmpop;
6728         o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6729         op_null(cvop);          /* disable rv2cv */
6730         tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6731         if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6732             GV *gv = cGVOPx_gv(tmpop);
6733             cv = GvCVu(gv);
6734             if (!cv)
6735                 tmpop->op_private |= OPpEARLY_CV;
6736             else if (SvPOK(cv)) {
6737                 namegv = CvANON(cv) ? gv : CvGV(cv);
6738                 proto = SvPV((SV*)cv, n_a);
6739             }
6740         }
6741     }
6742     else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6743         if (o2->op_type == OP_CONST)
6744             o2->op_private &= ~OPpCONST_STRICT;
6745         else if (o2->op_type == OP_LIST) {
6746             OP *o = ((UNOP*)o2)->op_first->op_sibling;
6747             if (o && o->op_type == OP_CONST)
6748                 o->op_private &= ~OPpCONST_STRICT;
6749         }
6750     }
6751     o->op_private |= (PL_hints & HINT_STRICT_REFS);
6752     if (PERLDB_SUB && PL_curstash != PL_debstash)
6753         o->op_private |= OPpENTERSUB_DB;
6754     while (o2 != cvop) {
6755         if (proto) {
6756             switch (*proto) {
6757             case '\0':
6758                 return too_many_arguments(o, gv_ename(namegv));
6759             case ';':
6760                 optional = 1;
6761                 proto++;
6762                 continue;
6763             case '$':
6764                 proto++;
6765                 arg++;
6766                 scalar(o2);
6767                 break;
6768             case '%':
6769             case '@':
6770                 list(o2);
6771                 arg++;
6772                 break;
6773             case '&':
6774                 proto++;
6775                 arg++;
6776                 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6777                     bad_type(arg,
6778                         arg == 1 ? "block or sub {}" : "sub {}",
6779                         gv_ename(namegv), o2);
6780                 break;
6781             case '*':
6782                 /* '*' allows any scalar type, including bareword */
6783                 proto++;
6784                 arg++;
6785                 if (o2->op_type == OP_RV2GV)
6786                     goto wrapref;       /* autoconvert GLOB -> GLOBref */
6787                 else if (o2->op_type == OP_CONST)
6788                     o2->op_private &= ~OPpCONST_STRICT;
6789                 else if (o2->op_type == OP_ENTERSUB) {
6790                     /* accidental subroutine, revert to bareword */
6791                     OP *gvop = ((UNOP*)o2)->op_first;
6792                     if (gvop && gvop->op_type == OP_NULL) {
6793                         gvop = ((UNOP*)gvop)->op_first;
6794                         if (gvop) {
6795                             for (; gvop->op_sibling; gvop = gvop->op_sibling)
6796                                 ;
6797                             if (gvop &&
6798                                 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6799                                 (gvop = ((UNOP*)gvop)->op_first) &&
6800                                 gvop->op_type == OP_GV)
6801                             {
6802                                 GV *gv = cGVOPx_gv(gvop);
6803                                 OP *sibling = o2->op_sibling;
6804                                 SV *n = newSVpvn("",0);
6805                                 op_free(o2);
6806                                 gv_fullname3(n, gv, "");
6807                                 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6808                                     sv_chop(n, SvPVX(n)+6);
6809                                 o2 = newSVOP(OP_CONST, 0, n);
6810                                 prev->op_sibling = o2;
6811                                 o2->op_sibling = sibling;
6812                             }
6813                         }
6814                     }
6815                 }
6816                 scalar(o2);
6817                 break;
6818             case '[': case ']':
6819                  goto oops;
6820                  break;
6821             case '\\':
6822                 proto++;
6823                 arg++;
6824             again:
6825                 switch (*proto++) {
6826                 case '[':
6827                      if (contextclass++ == 0) {
6828                           e = strchr(proto, ']');
6829                           if (!e || e == proto)
6830                                goto oops;
6831                      }
6832                      else
6833                           goto oops;
6834                      goto again;
6835                      break;
6836                 case ']':
6837                      if (contextclass) {
6838                          char *p = proto;
6839                          char s = *p;
6840                          contextclass = 0;
6841                          *p = '\0';
6842                          while (*--p != '[');
6843                          bad_type(arg, Perl_form(aTHX_ "one of %s", p),
6844                                  gv_ename(namegv), o2);
6845                          *proto = s;
6846                      } else
6847                           goto oops;
6848                      break;
6849                 case '*':
6850                      if (o2->op_type == OP_RV2GV)
6851                           goto wrapref;
6852                      if (!contextclass)
6853                           bad_type(arg, "symbol", gv_ename(namegv), o2);
6854                      break;
6855                 case '&':
6856                      if (o2->op_type == OP_ENTERSUB)
6857                           goto wrapref;
6858                      if (!contextclass)
6859                           bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6860                      break;
6861                 case '$':
6862                     if (o2->op_type == OP_RV2SV ||
6863                         o2->op_type == OP_PADSV ||
6864                         o2->op_type == OP_HELEM ||
6865                         o2->op_type == OP_AELEM ||
6866                         o2->op_type == OP_THREADSV)
6867                          goto wrapref;
6868                     if (!contextclass)
6869                         bad_type(arg, "scalar", gv_ename(namegv), o2);
6870                      break;
6871                 case '@':
6872                     if (o2->op_type == OP_RV2AV ||
6873                         o2->op_type == OP_PADAV)
6874                          goto wrapref;
6875                     if (!contextclass)
6876                         bad_type(arg, "array", gv_ename(namegv), o2);
6877                     break;
6878                 case '%':
6879                     if (o2->op_type == OP_RV2HV ||
6880                         o2->op_type == OP_PADHV)
6881                          goto wrapref;
6882                     if (!contextclass)
6883                          bad_type(arg, "hash", gv_ename(namegv), o2);
6884                     break;
6885                 wrapref:
6886                     {
6887                         OP* kid = o2;
6888                         OP* sib = kid->op_sibling;
6889                         kid->op_sibling = 0;
6890                         o2 = newUNOP(OP_REFGEN, 0, kid);
6891                         o2->op_sibling = sib;
6892                         prev->op_sibling = o2;
6893                     }
6894                     if (contextclass && e) {
6895                          proto = e + 1;
6896                          contextclass = 0;
6897                     }
6898                     break;
6899                 default: goto oops;
6900                 }
6901                 if (contextclass)
6902                      goto again;
6903                 break;
6904             case ' ':
6905                 proto++;
6906                 continue;
6907             default:
6908               oops:
6909                 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
6910                            gv_ename(namegv), SvPV((SV*)cv, n_a));
6911             }
6912         }
6913         else
6914             list(o2);
6915         mod(o2, OP_ENTERSUB);
6916         prev = o2;
6917         o2 = o2->op_sibling;
6918     }
6919     if (proto && !optional &&
6920           (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6921         return too_few_arguments(o, gv_ename(namegv));
6922     return o;
6923 }
6924
6925 OP *
6926 Perl_ck_svconst(pTHX_ OP *o)
6927 {
6928     SvREADONLY_on(cSVOPo->op_sv);
6929     return o;
6930 }
6931
6932 OP *
6933 Perl_ck_trunc(pTHX_ OP *o)
6934 {
6935     if (o->op_flags & OPf_KIDS) {
6936         SVOP *kid = (SVOP*)cUNOPo->op_first;
6937
6938         if (kid->op_type == OP_NULL)
6939             kid = (SVOP*)kid->op_sibling;
6940         if (kid && kid->op_type == OP_CONST &&
6941             (kid->op_private & OPpCONST_BARE))
6942         {
6943             o->op_flags |= OPf_SPECIAL;
6944             kid->op_private &= ~OPpCONST_STRICT;
6945         }
6946     }
6947     return ck_fun(o);
6948 }
6949
6950 OP *
6951 Perl_ck_substr(pTHX_ OP *o)
6952 {
6953     o = ck_fun(o);
6954     if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6955         OP *kid = cLISTOPo->op_first;
6956
6957         if (kid->op_type == OP_NULL)
6958             kid = kid->op_sibling;
6959         if (kid)
6960             kid->op_flags |= OPf_MOD;
6961
6962     }
6963     return o;
6964 }
6965
6966 /* A peephole optimizer.  We visit the ops in the order they're to execute. */
6967
6968 void
6969 Perl_peep(pTHX_ register OP *o)
6970 {
6971     register OP* oldop = 0;
6972
6973     if (!o || o->op_seq)
6974         return;
6975     ENTER;
6976     SAVEOP();
6977     SAVEVPTR(PL_curcop);
6978     for (; o; o = o->op_next) {
6979         if (o->op_seq)
6980             break;
6981         if (!PL_op_seqmax)
6982             PL_op_seqmax++;
6983         PL_op = o;
6984         switch (o->op_type) {
6985         case OP_SETSTATE:
6986         case OP_NEXTSTATE:
6987         case OP_DBSTATE:
6988             PL_curcop = ((COP*)o);              /* for warnings */
6989             o->op_seq = PL_op_seqmax++;
6990             break;
6991
6992         case OP_CONST:
6993             if (cSVOPo->op_private & OPpCONST_STRICT)
6994                 no_bareword_allowed(o);
6995 #ifdef USE_ITHREADS
6996             /* Relocate sv to the pad for thread safety.
6997              * Despite being a "constant", the SV is written to,
6998              * for reference counts, sv_upgrade() etc. */
6999             if (cSVOP->op_sv) {
7000                 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
7001                 if (SvPADTMP(cSVOPo->op_sv)) {
7002                     /* If op_sv is already a PADTMP then it is being used by
7003                      * some pad, so make a copy. */
7004                     sv_setsv(PL_curpad[ix],cSVOPo->op_sv);
7005                     SvREADONLY_on(PL_curpad[ix]);
7006                     SvREFCNT_dec(cSVOPo->op_sv);
7007                 }
7008                 else {
7009                     SvREFCNT_dec(PL_curpad[ix]);
7010                     SvPADTMP_on(cSVOPo->op_sv);
7011                     PL_curpad[ix] = cSVOPo->op_sv;
7012                     /* XXX I don't know how this isn't readonly already. */
7013                     SvREADONLY_on(PL_curpad[ix]);
7014                 }
7015                 cSVOPo->op_sv = Nullsv;
7016                 o->op_targ = ix;
7017             }
7018 #endif
7019             o->op_seq = PL_op_seqmax++;
7020             break;
7021
7022         case OP_CONCAT:
7023             if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
7024                 if (o->op_next->op_private & OPpTARGET_MY) {
7025                     if (o->op_flags & OPf_STACKED) /* chained concats */
7026                         goto ignore_optimization;
7027                     else {
7028                         /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
7029                         o->op_targ = o->op_next->op_targ;
7030                         o->op_next->op_targ = 0;
7031                         o->op_private |= OPpTARGET_MY;
7032                     }
7033                 }
7034                 op_null(o->op_next);
7035             }
7036           ignore_optimization:
7037             o->op_seq = PL_op_seqmax++;
7038             break;
7039         case OP_STUB:
7040             if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
7041                 o->op_seq = PL_op_seqmax++;
7042                 break; /* Scalar stub must produce undef.  List stub is noop */
7043             }
7044             goto nothin;
7045         case OP_NULL:
7046             if (o->op_targ == OP_NEXTSTATE
7047                 || o->op_targ == OP_DBSTATE
7048                 || o->op_targ == OP_SETSTATE)
7049             {
7050                 PL_curcop = ((COP*)o);
7051             }
7052             /* XXX: We avoid setting op_seq here to prevent later calls
7053                to peep() from mistakenly concluding that optimisation
7054                has already occurred. This doesn't fix the real problem,
7055                though (See 20010220.007). AMS 20010719 */
7056             if (oldop && o->op_next) {
7057                 oldop->op_next = o->op_next;
7058                 continue;
7059             }
7060             break;
7061         case OP_SCALAR:
7062         case OP_LINESEQ:
7063         case OP_SCOPE:
7064           nothin:
7065             if (oldop && o->op_next) {
7066                 oldop->op_next = o->op_next;
7067                 continue;
7068             }
7069             o->op_seq = PL_op_seqmax++;
7070             break;
7071
7072         case OP_GV:
7073             if (o->op_next->op_type == OP_RV2SV) {
7074                 if (!(o->op_next->op_private & OPpDEREF)) {
7075                     op_null(o->op_next);
7076                     o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
7077                                                                | OPpOUR_INTRO);
7078                     o->op_next = o->op_next->op_next;
7079                     o->op_type = OP_GVSV;
7080                     o->op_ppaddr = PL_ppaddr[OP_GVSV];
7081                 }
7082             }
7083             else if (o->op_next->op_type == OP_RV2AV) {
7084                 OP* pop = o->op_next->op_next;
7085                 IV i;
7086                 if (pop && pop->op_type == OP_CONST &&
7087                     (PL_op = pop->op_next) &&
7088                     pop->op_next->op_type == OP_AELEM &&
7089                     !(pop->op_next->op_private &
7090                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
7091                     (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
7092                                 <= 255 &&
7093                     i >= 0)
7094                 {
7095                     GV *gv;
7096                     op_null(o->op_next);
7097                     op_null(pop->op_next);
7098                     op_null(pop);
7099                     o->op_flags |= pop->op_next->op_flags & OPf_MOD;
7100                     o->op_next = pop->op_next->op_next;
7101                     o->op_type = OP_AELEMFAST;
7102                     o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
7103                     o->op_private = (U8)i;
7104                     gv = cGVOPo_gv;
7105                     GvAVn(gv);
7106                 }
7107             }
7108             else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
7109                 GV *gv = cGVOPo_gv;
7110                 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
7111                     /* XXX could check prototype here instead of just carping */
7112                     SV *sv = sv_newmortal();
7113                     gv_efullname3(sv, gv, Nullch);
7114                     Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
7115                                 "%s() called too early to check prototype",
7116                                 SvPV_nolen(sv));
7117                 }
7118             }
7119             else if (o->op_next->op_type == OP_READLINE
7120                     && o->op_next->op_next->op_type == OP_CONCAT
7121                     && (o->op_next->op_next->op_flags & OPf_STACKED))
7122             {
7123                 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
7124                 o->op_type   = OP_RCATLINE;
7125                 o->op_flags |= OPf_STACKED;
7126                 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
7127                 op_null(o->op_next->op_next);
7128                 op_null(o->op_next);
7129             }
7130
7131             o->op_seq = PL_op_seqmax++;
7132             break;
7133
7134         case OP_MAPWHILE:
7135         case OP_GREPWHILE:
7136         case OP_AND:
7137         case OP_OR:
7138         case OP_DOR:
7139         case OP_ANDASSIGN:
7140         case OP_ORASSIGN:
7141         case OP_DORASSIGN:
7142         case OP_COND_EXPR:
7143         case OP_RANGE:
7144             o->op_seq = PL_op_seqmax++;
7145             while (cLOGOP->op_other->op_type == OP_NULL)
7146                 cLOGOP->op_other = cLOGOP->op_other->op_next;
7147             peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
7148             break;
7149
7150         case OP_ENTERLOOP:
7151         case OP_ENTERITER:
7152             o->op_seq = PL_op_seqmax++;
7153             while (cLOOP->op_redoop->op_type == OP_NULL)
7154                 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
7155             peep(cLOOP->op_redoop);
7156             while (cLOOP->op_nextop->op_type == OP_NULL)
7157                 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
7158             peep(cLOOP->op_nextop);
7159             while (cLOOP->op_lastop->op_type == OP_NULL)
7160                 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
7161             peep(cLOOP->op_lastop);
7162             break;
7163
7164         case OP_QR:
7165         case OP_MATCH:
7166         case OP_SUBST:
7167             o->op_seq = PL_op_seqmax++;
7168             while (cPMOP->op_pmreplstart &&
7169                    cPMOP->op_pmreplstart->op_type == OP_NULL)
7170                 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
7171             peep(cPMOP->op_pmreplstart);
7172             break;
7173
7174         case OP_EXEC:
7175             o->op_seq = PL_op_seqmax++;
7176             if (ckWARN(WARN_SYNTAX) && o->op_next
7177                 && o->op_next->op_type == OP_NEXTSTATE) {
7178                 if (o->op_next->op_sibling &&
7179                         o->op_next->op_sibling->op_type != OP_EXIT &&
7180                         o->op_next->op_sibling->op_type != OP_WARN &&
7181                         o->op_next->op_sibling->op_type != OP_DIE) {
7182                     line_t oldline = CopLINE(PL_curcop);
7183
7184                     CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
7185                     Perl_warner(aTHX_ packWARN(WARN_EXEC),
7186                                 "Statement unlikely to be reached");
7187                     Perl_warner(aTHX_ packWARN(WARN_EXEC),
7188                                 "\t(Maybe you meant system() when you said exec()?)\n");
7189                     CopLINE_set(PL_curcop, oldline);
7190                 }
7191             }
7192             break;
7193
7194         case OP_HELEM: {
7195             SV *lexname;
7196             SV **svp, *sv;
7197             char *key = NULL;
7198             STRLEN keylen;
7199
7200             o->op_seq = PL_op_seqmax++;
7201
7202             if (((BINOP*)o)->op_last->op_type != OP_CONST)
7203                 break;
7204
7205             /* Make the CONST have a shared SV */
7206             svp = cSVOPx_svp(((BINOP*)o)->op_last);
7207             if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
7208                 key = SvPV(sv, keylen);
7209                 lexname = newSVpvn_share(key,
7210                                          SvUTF8(sv) ? -(I32)keylen : keylen,
7211                                          0);
7212                 SvREFCNT_dec(sv);
7213                 *svp = lexname;
7214             }
7215             break;
7216         }
7217
7218         default:
7219             o->op_seq = PL_op_seqmax++;
7220             break;
7221         }
7222         oldop = o;
7223     }
7224     LEAVE;
7225 }
7226
7227
7228
7229 char* Perl_custom_op_name(pTHX_ OP* o)
7230 {
7231     IV  index = PTR2IV(o->op_ppaddr);
7232     SV* keysv;
7233     HE* he;
7234
7235     if (!PL_custom_op_names) /* This probably shouldn't happen */
7236         return PL_op_name[OP_CUSTOM];
7237
7238     keysv = sv_2mortal(newSViv(index));
7239
7240     he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
7241     if (!he)
7242         return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
7243
7244     return SvPV_nolen(HeVAL(he));
7245 }
7246
7247 char* Perl_custom_op_desc(pTHX_ OP* o)
7248 {
7249     IV  index = PTR2IV(o->op_ppaddr);
7250     SV* keysv;
7251     HE* he;
7252
7253     if (!PL_custom_op_descs)
7254         return PL_op_desc[OP_CUSTOM];
7255
7256     keysv = sv_2mortal(newSViv(index));
7257
7258     he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
7259     if (!he)
7260         return PL_op_desc[OP_CUSTOM];
7261
7262     return SvPV_nolen(HeVAL(he));
7263 }
7264
7265
7266 #include "XSUB.h"
7267
7268 /* Efficient sub that returns a constant scalar value. */
7269 static void
7270 const_sv_xsub(pTHX_ CV* cv)
7271 {
7272     dXSARGS;
7273     if (items != 0) {
7274 #if 0
7275         Perl_croak(aTHX_ "usage: %s::%s()",
7276                    HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7277 #endif
7278     }
7279     EXTEND(sp, 1);
7280     ST(0) = (SV*)XSANY.any_ptr;
7281     XSRETURN(1);
7282 }