op.c

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