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