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