op.c

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