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