op.c

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