op.c

   1 /*    op.c
   2  *
   3  *    Copyright (c) 1991-2002, Larry Wall
   4  *
   5  *    You may distribute under the terms of either the GNU General Public
   6  *    License or the Artistic License, as specified in the README file.
   7  *
   8  */
   9
  10 /*
  11  * "You see: Mr. Drogo, he married poor Miss Primula Brandybuck.  She was
  12  * our Mr. Bilbo's first cousin on the mother's side (her mother being the
  13  * youngest of the Old Took's daughters); and Mr. Drogo was his second
  14  * cousin.  So Mr. Frodo is his first *and* second cousin, once removed
  15  * either way, as the saying is, if you follow me."  --the Gaffer
  16  */
  17
  18
  19 #include "EXTERN.h"
  20 #define PERL_IN_OP_C
  21 #include "perl.h"
  22 #include "keywords.h"
  23
  24 #define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
  25
  26 #if defined(PL_OP_SLAB_ALLOC)
  27
  28 #ifndef PERL_SLAB_SIZE
  29 #define PERL_SLAB_SIZE 2048
  30 #endif
  31
  32 #define NewOp(m,var,c,type) \
  33         STMT_START { var = (type *) Slab_Alloc(m,c*sizeof(type)); } STMT_END
  34
  35 #define FreeOp(p) Slab_Free(p)
  36
  37 STATIC void *
  38 S_Slab_Alloc(pTHX_ int m, size_t sz)
  39 {
  40     /*
  41      * To make incrementing use count easy PL_OpSlab is an I32 *
  42      * To make inserting the link to slab PL_OpPtr is I32 **
  43      * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
  44      * Add an overhead for pointer to slab and round up as a number of pointers
  45      */
  46     sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
  47     if ((PL_OpSpace -= sz) < 0) {
  48         PL_OpPtr = (I32 **) PerlMemShared_malloc(PERL_SLAB_SIZE*sizeof(I32*));
  49         if (!PL_OpPtr) {
  50             return NULL;
  51         }
  52         Zero(PL_OpPtr,PERL_SLAB_SIZE,I32 **);
  53         /* We reserve the 0'th I32 sized chunk as a use count */
  54         PL_OpSlab = (I32 *) PL_OpPtr;
  55         /* Reduce size by the use count word, and by the size we need.
  56          * Latter is to mimic the '-=' in the if() above
  57          */
  58         PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
  59         /* Allocation pointer starts at the top.
  60            Theory: because we build leaves before trunk allocating at end
  61            means that at run time access is cache friendly upward
  62          */
  63         PL_OpPtr += PERL_SLAB_SIZE;
  64     }
  65     assert( PL_OpSpace >= 0 );
  66     /* Move the allocation pointer down */
  67     PL_OpPtr   -= sz;
  68     assert( PL_OpPtr > (I32 **) PL_OpSlab );
  69     *PL_OpPtr   = PL_OpSlab;    /* Note which slab it belongs to */
  70     (*PL_OpSlab)++;             /* Increment use count of slab */
  71     assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
  72     assert( *PL_OpSlab > 0 );
  73     return (void *)(PL_OpPtr + 1);
  74 }
  75
  76 STATIC void
  77 S_Slab_Free(pTHX_ void *op)
  78 {
  79     I32 **ptr = (I32 **) op;
  80     I32 *slab = ptr[-1];
  81     assert( ptr-1 > (I32 **) slab );
  82     assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
  83     assert( *slab > 0 );
  84     if (--(*slab) == 0) {
  85         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     CV *outsidecv;
4369     CV *freecv = Nullcv;
4370     bool is_eval = CvEVAL(cv) && !CvGV(cv);     /* is this eval"" ? */
4371
4372 #ifdef USE_5005THREADS
4373     if (CvMUTEXP(cv)) {
4374         MUTEX_DESTROY(CvMUTEXP(cv));
4375         Safefree(CvMUTEXP(cv));
4376         CvMUTEXP(cv) = 0;
4377     }
4378 #endif /* USE_5005THREADS */
4379
4380 #ifdef USE_ITHREADS
4381     if (CvFILE(cv) && !CvXSUB(cv)) {
4382         /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4383         Safefree(CvFILE(cv));
4384     }
4385     CvFILE(cv) = 0;
4386 #endif
4387
4388     if (!CvXSUB(cv) && CvROOT(cv)) {
4389 #ifdef USE_5005THREADS
4390         if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr))
4391             Perl_croak(aTHX_ "Can't undef active subroutine");
4392 #else
4393         if (CvDEPTH(cv))
4394             Perl_croak(aTHX_ "Can't undef active subroutine");
4395 #endif /* USE_5005THREADS */
4396         ENTER;
4397
4398         SAVEVPTR(PL_curpad);
4399         PL_curpad = 0;
4400
4401         op_free(CvROOT(cv));
4402         CvROOT(cv) = Nullop;
4403         LEAVE;
4404     }
4405     SvPOK_off((SV*)cv);         /* forget prototype */
4406     CvGV(cv) = Nullgv;
4407     outsidecv = CvOUTSIDE(cv);
4408     /* Since closure prototypes have the same lifetime as the containing
4409      * CV, they don't hold a refcount on the outside CV.  This avoids
4410      * the refcount loop between the outer CV (which keeps a refcount to
4411      * the closure prototype in the pad entry for pp_anoncode()) and the
4412      * closure prototype, and the ensuing memory leak.  --GSAR */
4413     if (!CvANON(cv) || CvCLONED(cv))
4414         freecv = outsidecv;
4415     CvOUTSIDE(cv) = Nullcv;
4416     if (CvCONST(cv)) {
4417         SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4418         CvCONST_off(cv);
4419     }
4420     if (CvPADLIST(cv)) {
4421         /* may be during global destruction */
4422         if (SvREFCNT(CvPADLIST(cv))) {
4423             AV *padlist = CvPADLIST(cv);
4424             I32 ix;
4425             if (is_eval) {
4426                 /* inner references to eval's cv must be fixed up */
4427                 AV *comppad_name = (AV*)AvARRAY(padlist)[0];
4428                 AV *comppad = (AV*)AvARRAY(padlist)[1];
4429                 SV **namepad = AvARRAY(comppad_name);
4430                 SV **curpad = AvARRAY(comppad);
4431                 for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
4432                     SV *namesv = namepad[ix];
4433                     if (namesv && namesv != &PL_sv_undef
4434                         && *SvPVX(namesv) == '&'
4435                         && ix <= AvFILLp(comppad))
4436                     {
4437                         CV *innercv = (CV*)curpad[ix];
4438                         if (innercv && SvTYPE(innercv) == SVt_PVCV
4439                             && CvOUTSIDE(innercv) == cv)
4440                         {
4441                             CvOUTSIDE(innercv) = outsidecv;
4442                             if (!CvANON(innercv) || CvCLONED(innercv)) {
4443                                 (void)SvREFCNT_inc(outsidecv);
4444                                 if (SvREFCNT(cv))
4445                                     SvREFCNT_dec(cv);
4446                             }
4447                         }
4448                     }
4449                 }
4450             }
4451             if (freecv)
4452                 SvREFCNT_dec(freecv);
4453             ix = AvFILLp(padlist);
4454             while (ix >= 0) {
4455                 SV* sv = AvARRAY(padlist)[ix--];
4456                 if (!sv)
4457                     continue;
4458                 if (sv == (SV*)PL_comppad_name)
4459                     PL_comppad_name = Nullav;
4460                 else if (sv == (SV*)PL_comppad) {
4461                     PL_comppad = Nullav;
4462                     PL_curpad = Null(SV**);
4463                 }
4464                 SvREFCNT_dec(sv);
4465             }
4466             SvREFCNT_dec((SV*)CvPADLIST(cv));
4467         }
4468         CvPADLIST(cv) = Nullav;
4469     }
4470     else if (freecv)
4471         SvREFCNT_dec(freecv);
4472     if (CvXSUB(cv)) {
4473         CvXSUB(cv) = 0;
4474     }
4475     CvFLAGS(cv) = 0;
4476 }
4477
4478 #ifdef DEBUG_CLOSURES
4479 STATIC void
4480 S_cv_dump(pTHX_ CV *cv)
4481 {
4482 #ifdef DEBUGGING
4483     CV *outside = CvOUTSIDE(cv);
4484     AV* padlist = CvPADLIST(cv);
4485     AV* pad_name;
4486     AV* pad;
4487     SV** pname;
4488     SV** ppad;
4489     I32 ix;
4490
4491     PerlIO_printf(Perl_debug_log,
4492                   "\tCV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
4493                   PTR2UV(cv),
4494                   (CvANON(cv) ? "ANON"
4495                    : (cv == PL_main_cv) ? "MAIN"
4496                    : CvUNIQUE(cv) ? "UNIQUE"
4497                    : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
4498                   PTR2UV(outside),
4499                   (!outside ? "null"
4500                    : CvANON(outside) ? "ANON"
4501                    : (outside == PL_main_cv) ? "MAIN"
4502                    : CvUNIQUE(outside) ? "UNIQUE"
4503                    : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
4504
4505     if (!padlist)
4506         return;
4507
4508     pad_name = (AV*)*av_fetch(padlist, 0, FALSE);
4509     pad = (AV*)*av_fetch(padlist, 1, FALSE);
4510     pname = AvARRAY(pad_name);
4511     ppad = AvARRAY(pad);
4512
4513     for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
4514         if (SvPOK(pname[ix]))
4515             PerlIO_printf(Perl_debug_log,
4516                           "\t%4d. 0x%"UVxf" (%s\"%s\" %"IVdf"-%"IVdf")\n",
4517                           (int)ix, PTR2UV(ppad[ix]),
4518                           SvFAKE(pname[ix]) ? "FAKE " : "",
4519                           SvPVX(pname[ix]),
4520                           (IV)I_32(SvNVX(pname[ix])),
4521                           SvIVX(pname[ix]));
4522     }
4523 #endif /* DEBUGGING */
4524 }
4525 #endif /* DEBUG_CLOSURES */
4526
4527 STATIC CV *
4528 S_cv_clone2(pTHX_ CV *proto, CV *outside)
4529 {
4530     AV* av;
4531     I32 ix;
4532     AV* protopadlist = CvPADLIST(proto);
4533     AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
4534     AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
4535     SV** pname = AvARRAY(protopad_name);
4536     SV** ppad = AvARRAY(protopad);
4537     I32 fname = AvFILLp(protopad_name);
4538     I32 fpad = AvFILLp(protopad);
4539     AV* comppadlist;
4540     CV* cv;
4541
4542     assert(!CvUNIQUE(proto));
4543
4544     ENTER;
4545     SAVECOMPPAD();
4546     SAVESPTR(PL_comppad_name);
4547     SAVESPTR(PL_compcv);
4548
4549     cv = PL_compcv = (CV*)NEWSV(1104,0);
4550     sv_upgrade((SV *)cv, SvTYPE(proto));
4551     CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
4552     CvCLONED_on(cv);
4553
4554 #ifdef USE_5005THREADS
4555     New(666, CvMUTEXP(cv), 1, perl_mutex);
4556     MUTEX_INIT(CvMUTEXP(cv));
4557     CvOWNER(cv)         = 0;
4558 #endif /* USE_5005THREADS */
4559 #ifdef USE_ITHREADS
4560     CvFILE(cv)          = CvXSUB(proto) ? CvFILE(proto)
4561                                         : savepv(CvFILE(proto));
4562 #else
4563     CvFILE(cv)          = CvFILE(proto);
4564 #endif
4565     CvGV(cv)            = CvGV(proto);
4566     CvSTASH(cv)         = CvSTASH(proto);
4567     CvROOT(cv)          = OpREFCNT_inc(CvROOT(proto));
4568     CvSTART(cv)         = CvSTART(proto);
4569     if (outside)
4570         CvOUTSIDE(cv)   = (CV*)SvREFCNT_inc(outside);
4571
4572     if (SvPOK(proto))
4573         sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
4574
4575     PL_comppad_name = newAV();
4576     for (ix = fname; ix >= 0; ix--)
4577         av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
4578
4579     PL_comppad = newAV();
4580
4581     comppadlist = newAV();
4582     AvREAL_off(comppadlist);
4583     av_store(comppadlist, 0, (SV*)PL_comppad_name);
4584     av_store(comppadlist, 1, (SV*)PL_comppad);
4585     CvPADLIST(cv) = comppadlist;
4586     av_fill(PL_comppad, AvFILLp(protopad));
4587     PL_curpad = AvARRAY(PL_comppad);
4588
4589     av = newAV();           /* will be @_ */
4590     av_extend(av, 0);
4591     av_store(PL_comppad, 0, (SV*)av);
4592     AvFLAGS(av) = AVf_REIFY;
4593
4594     for (ix = fpad; ix > 0; ix--) {
4595         SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4596         if (namesv && namesv != &PL_sv_undef) {
4597             char *name = SvPVX(namesv);    /* XXX */
4598             if (SvFLAGS(namesv) & SVf_FAKE) {   /* lexical from outside? */
4599                 I32 off = pad_findlex(name, ix, SvIVX(namesv),
4600                                       CvOUTSIDE(cv), cxstack_ix, 0, 0);
4601                 if (!off)
4602                     PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4603                 else if (off != ix)
4604                     Perl_croak(aTHX_ "panic: cv_clone: %s", name);
4605             }
4606             else {                              /* our own lexical */
4607                 SV* sv;
4608                 if (*name == '&') {
4609                     /* anon code -- we'll come back for it */
4610                     sv = SvREFCNT_inc(ppad[ix]);
4611                 }
4612                 else if (*name == '@')
4613                     sv = (SV*)newAV();
4614                 else if (*name == '%')
4615                     sv = (SV*)newHV();
4616                 else
4617                     sv = NEWSV(0,0);
4618                 if (!SvPADBUSY(sv))
4619                     SvPADMY_on(sv);
4620                 PL_curpad[ix] = sv;
4621             }
4622         }
4623         else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
4624             PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4625         }
4626         else {
4627             SV* sv = NEWSV(0,0);
4628             SvPADTMP_on(sv);
4629             PL_curpad[ix] = sv;
4630         }
4631     }
4632
4633     /* Now that vars are all in place, clone nested closures. */
4634
4635     for (ix = fpad; ix > 0; ix--) {
4636         SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4637         if (namesv
4638             && namesv != &PL_sv_undef
4639             && !(SvFLAGS(namesv) & SVf_FAKE)
4640             && *SvPVX(namesv) == '&'
4641             && CvCLONE(ppad[ix]))
4642         {
4643             CV *kid = cv_clone2((CV*)ppad[ix], cv);
4644             SvREFCNT_dec(ppad[ix]);
4645             CvCLONE_on(kid);
4646             SvPADMY_on(kid);
4647             PL_curpad[ix] = (SV*)kid;
4648         }
4649     }
4650
4651 #ifdef DEBUG_CLOSURES
4652     PerlIO_printf(Perl_debug_log, "Cloned inside:\n");
4653     cv_dump(outside);
4654     PerlIO_printf(Perl_debug_log, "  from:\n");
4655     cv_dump(proto);
4656     PerlIO_printf(Perl_debug_log, "   to:\n");
4657     cv_dump(cv);
4658 #endif
4659
4660     LEAVE;
4661
4662     if (CvCONST(cv)) {
4663         SV* const_sv = op_const_sv(CvSTART(cv), cv);
4664         assert(const_sv);
4665         /* constant sub () { $x } closing over $x - see lib/constant.pm */
4666         SvREFCNT_dec(cv);
4667         cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
4668     }
4669
4670     return cv;
4671 }
4672
4673 CV *
4674 Perl_cv_clone(pTHX_ CV *proto)
4675 {
4676     CV *cv;
4677     LOCK_CRED_MUTEX;                    /* XXX create separate mutex */
4678     cv = cv_clone2(proto, CvOUTSIDE(proto));
4679     UNLOCK_CRED_MUTEX;                  /* XXX create separate mutex */
4680     return cv;
4681 }
4682
4683 void
4684 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
4685 {
4686     if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4687         SV* msg = sv_newmortal();
4688         SV* name = Nullsv;
4689
4690         if (gv)
4691             gv_efullname3(name = sv_newmortal(), gv, Nullch);
4692         sv_setpv(msg, "Prototype mismatch:");
4693         if (name)
4694             Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4695         if (SvPOK(cv))
4696             Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv));
4697         sv_catpv(msg, " vs ");
4698         if (p)
4699             Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4700         else
4701             sv_catpv(msg, "none");
4702         Perl_warner(aTHX_ WARN_PROTOTYPE, "%"SVf, msg);
4703     }
4704 }
4705
4706 static void const_sv_xsub(pTHX_ CV* cv);
4707
4708 /*
4709
4710 =head1 Optree Manipulation Functions
4711
4712 =for apidoc cv_const_sv
4713
4714 If C<cv> is a constant sub eligible for inlining. returns the constant
4715 value returned by the sub.  Otherwise, returns NULL.
4716
4717 Constant subs can be created with C<newCONSTSUB> or as described in
4718 L<perlsub/"Constant Functions">.
4719
4720 =cut
4721 */
4722 SV *
4723 Perl_cv_const_sv(pTHX_ CV *cv)
4724 {
4725     if (!cv || !CvCONST(cv))
4726         return Nullsv;
4727     return (SV*)CvXSUBANY(cv).any_ptr;
4728 }
4729
4730 SV *
4731 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
4732 {
4733     SV *sv = Nullsv;
4734
4735     if (!o)
4736         return Nullsv;
4737
4738     if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4739         o = cLISTOPo->op_first->op_sibling;
4740
4741     for (; o; o = o->op_next) {
4742         OPCODE type = o->op_type;
4743
4744         if (sv && o->op_next == o)
4745             return sv;
4746         if (o->op_next != o) {
4747             if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4748                 continue;
4749             if (type == OP_DBSTATE)
4750                 continue;
4751         }
4752         if (type == OP_LEAVESUB || type == OP_RETURN)
4753             break;
4754         if (sv)
4755             return Nullsv;
4756         if (type == OP_CONST && cSVOPo->op_sv)
4757             sv = cSVOPo->op_sv;
4758         else if ((type == OP_PADSV || type == OP_CONST) && cv) {
4759             AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
4760             sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
4761             if (!sv)
4762                 return Nullsv;
4763             if (CvCONST(cv)) {
4764                 /* We get here only from cv_clone2() while creating a closure.
4765                    Copy the const value here instead of in cv_clone2 so that
4766                    SvREADONLY_on doesn't lead to problems when leaving
4767                    scope.
4768                 */
4769                 sv = newSVsv(sv);
4770             }
4771             if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
4772                 return Nullsv;
4773         }
4774         else
4775             return Nullsv;
4776     }
4777     if (sv)
4778         SvREADONLY_on(sv);
4779     return sv;
4780 }
4781
4782 void
4783 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4784 {
4785     if (o)
4786         SAVEFREEOP(o);
4787     if (proto)
4788         SAVEFREEOP(proto);
4789     if (attrs)
4790         SAVEFREEOP(attrs);
4791     if (block)
4792         SAVEFREEOP(block);
4793     Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4794 }
4795
4796 CV *
4797 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4798 {
4799     return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4800 }
4801
4802 CV *
4803 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4804 {
4805     STRLEN n_a;
4806     char *name;
4807     char *aname;
4808     GV *gv;
4809     char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4810     register CV *cv=0;
4811     I32 ix;
4812     SV *const_sv;
4813
4814     name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4815     if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4816         SV *sv = sv_newmortal();
4817         Perl_sv_setpvf(aTHX_ sv, "__ANON__[%s:%"IVdf"]",
4818                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4819         aname = SvPVX(sv);
4820     }
4821     else
4822         aname = Nullch;
4823     gv = gv_fetchpv(name ? name : (aname ? aname : "__ANON__"),
4824                     GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4825                     SVt_PVCV);
4826
4827     if (o)
4828         SAVEFREEOP(o);
4829     if (proto)
4830         SAVEFREEOP(proto);
4831     if (attrs)
4832         SAVEFREEOP(attrs);
4833
4834     if (SvTYPE(gv) != SVt_PVGV) {       /* Maybe prototype now, and had at
4835                                            maximum a prototype before. */
4836         if (SvTYPE(gv) > SVt_NULL) {
4837             if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4838                 && ckWARN_d(WARN_PROTOTYPE))
4839             {
4840                 Perl_warner(aTHX_ WARN_PROTOTYPE, "Runaway prototype");
4841             }
4842             cv_ckproto((CV*)gv, NULL, ps);
4843         }
4844         if (ps)
4845             sv_setpv((SV*)gv, ps);
4846         else
4847             sv_setiv((SV*)gv, -1);
4848         SvREFCNT_dec(PL_compcv);
4849         cv = PL_compcv = NULL;
4850         PL_sub_generation++;
4851         goto done;
4852     }
4853
4854     cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4855
4856 #ifdef GV_UNIQUE_CHECK
4857     if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4858         Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4859     }
4860 #endif
4861
4862     if (!block || !ps || *ps || attrs)
4863         const_sv = Nullsv;
4864     else
4865         const_sv = op_const_sv(block, Nullcv);
4866
4867     if (cv) {
4868         bool exists = CvROOT(cv) || CvXSUB(cv);
4869
4870 #ifdef GV_UNIQUE_CHECK
4871         if (exists && GvUNIQUE(gv)) {
4872             Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4873         }
4874 #endif
4875
4876         /* if the subroutine doesn't exist and wasn't pre-declared
4877          * with a prototype, assume it will be AUTOLOADed,
4878          * skipping the prototype check
4879          */
4880         if (exists || SvPOK(cv))
4881             cv_ckproto(cv, gv, ps);
4882         /* already defined (or promised)? */
4883         if (exists || GvASSUMECV(gv)) {
4884             if (!block && !attrs) {
4885                 /* just a "sub foo;" when &foo is already defined */
4886                 SAVEFREESV(PL_compcv);
4887                 goto done;
4888             }
4889             /* ahem, death to those who redefine active sort subs */
4890             if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4891                 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4892             if (block) {
4893                 if (ckWARN(WARN_REDEFINE)
4894                     || (CvCONST(cv)
4895                         && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4896                 {
4897                     line_t oldline = CopLINE(PL_curcop);
4898                     if (PL_copline != NOLINE)
4899                         CopLINE_set(PL_curcop, PL_copline);
4900                     Perl_warner(aTHX_ WARN_REDEFINE,
4901                         CvCONST(cv) ? "Constant subroutine %s redefined"
4902                                     : "Subroutine %s redefined", name);
4903                     CopLINE_set(PL_curcop, oldline);
4904                 }
4905                 SvREFCNT_dec(cv);
4906                 cv = Nullcv;
4907             }
4908         }
4909     }
4910     if (const_sv) {
4911         SvREFCNT_inc(const_sv);
4912         if (cv) {
4913             assert(!CvROOT(cv) && !CvCONST(cv));
4914             sv_setpv((SV*)cv, "");  /* prototype is "" */
4915             CvXSUBANY(cv).any_ptr = const_sv;
4916             CvXSUB(cv) = const_sv_xsub;
4917             CvCONST_on(cv);
4918         }
4919         else {
4920             GvCV(gv) = Nullcv;
4921             cv = newCONSTSUB(NULL, name, const_sv);
4922         }
4923         op_free(block);
4924         SvREFCNT_dec(PL_compcv);
4925         PL_compcv = NULL;
4926         PL_sub_generation++;
4927         goto done;
4928     }
4929     if (attrs) {
4930         HV *stash;
4931         SV *rcv;
4932
4933         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4934          * before we clobber PL_compcv.
4935          */
4936         if (cv && !block) {
4937             rcv = (SV*)cv;
4938             if (CvGV(cv) && GvSTASH(CvGV(cv)))
4939                 stash = GvSTASH(CvGV(cv));
4940             else if (CvSTASH(cv))
4941                 stash = CvSTASH(cv);
4942             else
4943                 stash = PL_curstash;
4944         }
4945         else {
4946             /* possibly about to re-define existing subr -- ignore old cv */
4947             rcv = (SV*)PL_compcv;
4948             if (name && GvSTASH(gv))
4949                 stash = GvSTASH(gv);
4950             else
4951                 stash = PL_curstash;
4952         }
4953         apply_attrs(stash, rcv, attrs, FALSE);
4954     }
4955     if (cv) {                           /* must reuse cv if autoloaded */
4956         if (!block) {
4957             /* got here with just attrs -- work done, so bug out */
4958             SAVEFREESV(PL_compcv);
4959             goto done;
4960         }
4961         cv_undef(cv);
4962         CvFLAGS(cv) = CvFLAGS(PL_compcv);
4963         CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4964         CvOUTSIDE(PL_compcv) = 0;
4965         CvPADLIST(cv) = CvPADLIST(PL_compcv);
4966         CvPADLIST(PL_compcv) = 0;
4967         /* inner references to PL_compcv must be fixed up ... */
4968         {
4969             AV *padlist = CvPADLIST(cv);
4970             AV *comppad_name = (AV*)AvARRAY(padlist)[0];
4971             AV *comppad = (AV*)AvARRAY(padlist)[1];
4972             SV **namepad = AvARRAY(comppad_name);
4973             SV **curpad = AvARRAY(comppad);
4974             for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
4975                 SV *namesv = namepad[ix];
4976                 if (namesv && namesv != &PL_sv_undef
4977                     && *SvPVX(namesv) == '&')
4978                 {
4979                     CV *innercv = (CV*)curpad[ix];
4980                     if (CvOUTSIDE(innercv) == PL_compcv) {
4981                         CvOUTSIDE(innercv) = cv;
4982                         if (!CvANON(innercv) || CvCLONED(innercv)) {
4983                             (void)SvREFCNT_inc(cv);
4984                             SvREFCNT_dec(PL_compcv);
4985                         }
4986                     }
4987                 }
4988             }
4989         }
4990         /* ... before we throw it away */
4991         SvREFCNT_dec(PL_compcv);
4992         if (PERLDB_INTER)/* Advice debugger on the new sub. */
4993           ++PL_sub_generation;
4994     }
4995     else {
4996         cv = PL_compcv;
4997         if (name) {
4998             GvCV(gv) = cv;
4999             GvCVGEN(gv) = 0;
5000             PL_sub_generation++;
5001         }
5002     }
5003     CvGV(cv) = gv;
5004     CvFILE_set_from_cop(cv, PL_curcop);
5005     CvSTASH(cv) = PL_curstash;
5006 #ifdef USE_5005THREADS
5007     CvOWNER(cv) = 0;
5008     if (!CvMUTEXP(cv)) {
5009         New(666, CvMUTEXP(cv), 1, perl_mutex);
5010         MUTEX_INIT(CvMUTEXP(cv));
5011     }
5012 #endif /* USE_5005THREADS */
5013
5014     if (ps)
5015         sv_setpv((SV*)cv, ps);
5016
5017     if (PL_error_count) {
5018         op_free(block);
5019         block = Nullop;
5020         if (name) {
5021             char *s = strrchr(name, ':');
5022             s = s ? s+1 : name;
5023             if (strEQ(s, "BEGIN")) {
5024                 char *not_safe =
5025                     "BEGIN not safe after errors--compilation aborted";
5026                 if (PL_in_eval & EVAL_KEEPERR)
5027                     Perl_croak(aTHX_ not_safe);
5028                 else {
5029                     /* force display of errors found but not reported */
5030                     sv_catpv(ERRSV, not_safe);
5031                     Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
5032                 }
5033             }
5034         }
5035     }
5036     if (!block)
5037         goto done;
5038
5039     if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
5040         av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
5041
5042     if (CvLVALUE(cv)) {
5043         CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
5044                              mod(scalarseq(block), OP_LEAVESUBLV));
5045     }
5046     else {
5047         CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5048     }
5049     CvROOT(cv)->op_private |= OPpREFCOUNTED;
5050     OpREFCNT_set(CvROOT(cv), 1);
5051     CvSTART(cv) = LINKLIST(CvROOT(cv));
5052     CvROOT(cv)->op_next = 0;
5053     CALL_PEEP(CvSTART(cv));
5054
5055     /* now that optimizer has done its work, adjust pad values */
5056     if (CvCLONE(cv)) {
5057         SV **namep = AvARRAY(PL_comppad_name);
5058         for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5059             SV *namesv;
5060
5061             if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
5062                 continue;
5063             /*
5064              * The only things that a clonable function needs in its
5065              * pad are references to outer lexicals and anonymous subs.
5066              * The rest are created anew during cloning.
5067              */
5068             if (!((namesv = namep[ix]) != Nullsv &&
5069                   namesv != &PL_sv_undef &&
5070                   (SvFAKE(namesv) ||
5071                    *SvPVX(namesv) == '&')))
5072             {
5073                 SvREFCNT_dec(PL_curpad[ix]);
5074                 PL_curpad[ix] = Nullsv;
5075             }
5076         }
5077         assert(!CvCONST(cv));
5078         if (ps && !*ps && op_const_sv(block, cv))
5079             CvCONST_on(cv);
5080     }
5081     else {
5082         AV *av = newAV();                       /* Will be @_ */
5083         av_extend(av, 0);
5084         av_store(PL_comppad, 0, (SV*)av);
5085         AvFLAGS(av) = AVf_REIFY;
5086
5087         for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5088             if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
5089                 continue;
5090             if (!SvPADMY(PL_curpad[ix]))
5091                 SvPADTMP_on(PL_curpad[ix]);
5092         }
5093     }
5094
5095     /* If a potential closure prototype, don't keep a refcount on outer CV.
5096      * This is okay as the lifetime of the prototype is tied to the
5097      * lifetime of the outer CV.  Avoids memory leak due to reference
5098      * loop. --GSAR */
5099     if (!name)
5100         SvREFCNT_dec(CvOUTSIDE(cv));
5101
5102     if (name || aname) {
5103         char *s;
5104         char *tname = (name ? name : aname);
5105
5106         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5107             SV *sv = NEWSV(0,0);
5108             SV *tmpstr = sv_newmortal();
5109             GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
5110             CV *pcv;
5111             HV *hv;
5112
5113             Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5114                            CopFILE(PL_curcop),
5115                            (long)PL_subline, (long)CopLINE(PL_curcop));
5116             gv_efullname3(tmpstr, gv, Nullch);
5117             hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
5118             hv = GvHVn(db_postponed);
5119             if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
5120                 && (pcv = GvCV(db_postponed)))
5121             {
5122                 dSP;
5123                 PUSHMARK(SP);
5124                 XPUSHs(tmpstr);
5125                 PUTBACK;
5126                 call_sv((SV*)pcv, G_DISCARD);
5127             }
5128         }
5129
5130         if ((s = strrchr(tname,':')))
5131             s++;
5132         else
5133             s = tname;
5134
5135         if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5136             goto done;
5137
5138         if (strEQ(s, "BEGIN")) {
5139             I32 oldscope = PL_scopestack_ix;
5140             ENTER;
5141             SAVECOPFILE(&PL_compiling);
5142             SAVECOPLINE(&PL_compiling);
5143
5144             if (!PL_beginav)
5145                 PL_beginav = newAV();
5146             DEBUG_x( dump_sub(gv) );
5147             av_push(PL_beginav, (SV*)cv);
5148             GvCV(gv) = 0;               /* cv has been hijacked */
5149             call_list(oldscope, PL_beginav);
5150
5151             PL_curcop = &PL_compiling;
5152             PL_compiling.op_private = PL_hints;
5153             LEAVE;
5154         }
5155         else if (strEQ(s, "END") && !PL_error_count) {
5156             if (!PL_endav)
5157                 PL_endav = newAV();
5158             DEBUG_x( dump_sub(gv) );
5159             av_unshift(PL_endav, 1);
5160             av_store(PL_endav, 0, (SV*)cv);
5161             GvCV(gv) = 0;               /* cv has been hijacked */
5162         }
5163         else if (strEQ(s, "CHECK") && !PL_error_count) {
5164             if (!PL_checkav)
5165                 PL_checkav = newAV();
5166             DEBUG_x( dump_sub(gv) );
5167             if (PL_main_start && ckWARN(WARN_VOID))
5168                 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
5169             av_unshift(PL_checkav, 1);
5170             av_store(PL_checkav, 0, (SV*)cv);
5171             GvCV(gv) = 0;               /* cv has been hijacked */
5172         }
5173         else if (strEQ(s, "INIT") && !PL_error_count) {
5174             if (!PL_initav)
5175                 PL_initav = newAV();
5176             DEBUG_x( dump_sub(gv) );
5177             if (PL_main_start && ckWARN(WARN_VOID))
5178                 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
5179             av_push(PL_initav, (SV*)cv);
5180             GvCV(gv) = 0;               /* cv has been hijacked */
5181         }
5182     }
5183
5184   done:
5185     PL_copline = NOLINE;
5186     LEAVE_SCOPE(floor);
5187     return cv;
5188 }
5189
5190 /* XXX unsafe for threads if eval_owner isn't held */
5191 /*
5192 =for apidoc newCONSTSUB
5193
5194 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5195 eligible for inlining at compile-time.
5196
5197 =cut
5198 */
5199
5200 CV *
5201 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
5202 {
5203     CV* cv;
5204
5205     ENTER;
5206
5207     SAVECOPLINE(PL_curcop);
5208     CopLINE_set(PL_curcop, PL_copline);
5209
5210     SAVEHINTS();
5211     PL_hints &= ~HINT_BLOCK_SCOPE;
5212
5213     if (stash) {
5214         SAVESPTR(PL_curstash);
5215         SAVECOPSTASH(PL_curcop);
5216         PL_curstash = stash;
5217         CopSTASH_set(PL_curcop,stash);
5218     }
5219
5220     cv = newXS(name, const_sv_xsub, __FILE__);
5221     CvXSUBANY(cv).any_ptr = sv;
5222     CvCONST_on(cv);
5223     sv_setpv((SV*)cv, "");  /* prototype is "" */
5224
5225     LEAVE;
5226
5227     return cv;
5228 }
5229
5230 /*
5231 =for apidoc U||newXS
5232
5233 Used by C<xsubpp> to hook up XSUBs as Perl subs.
5234
5235 =cut
5236 */
5237
5238 CV *
5239 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
5240 {
5241     GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV);
5242     register CV *cv;
5243
5244     if ((cv = (name ? GvCV(gv) : Nullcv))) {
5245         if (GvCVGEN(gv)) {
5246             /* just a cached method */
5247             SvREFCNT_dec(cv);
5248             cv = 0;
5249         }
5250         else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5251             /* already defined (or promised) */
5252             if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
5253                             && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
5254                 line_t oldline = CopLINE(PL_curcop);
5255                 if (PL_copline != NOLINE)
5256                     CopLINE_set(PL_curcop, PL_copline);
5257                 Perl_warner(aTHX_ WARN_REDEFINE,
5258                             CvCONST(cv) ? "Constant subroutine %s redefined"
5259                                         : "Subroutine %s redefined"
5260                             ,name);
5261                 CopLINE_set(PL_curcop, oldline);
5262             }
5263             SvREFCNT_dec(cv);
5264             cv = 0;
5265         }
5266     }
5267
5268     if (cv)                             /* must reuse cv if autoloaded */
5269         cv_undef(cv);
5270     else {
5271         cv = (CV*)NEWSV(1105,0);
5272         sv_upgrade((SV *)cv, SVt_PVCV);
5273         if (name) {
5274             GvCV(gv) = cv;
5275             GvCVGEN(gv) = 0;
5276             PL_sub_generation++;
5277         }
5278     }
5279     CvGV(cv) = gv;
5280 #ifdef USE_5005THREADS
5281     New(666, CvMUTEXP(cv), 1, perl_mutex);
5282     MUTEX_INIT(CvMUTEXP(cv));
5283     CvOWNER(cv) = 0;
5284 #endif /* USE_5005THREADS */
5285     (void)gv_fetchfile(filename);
5286     CvFILE(cv) = filename;      /* NOTE: not copied, as it is expected to be
5287                                    an external constant string */
5288     CvXSUB(cv) = subaddr;
5289
5290     if (name) {
5291         char *s = strrchr(name,':');
5292         if (s)
5293             s++;
5294         else
5295             s = name;
5296
5297         if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5298             goto done;
5299
5300         if (strEQ(s, "BEGIN")) {
5301             if (!PL_beginav)
5302                 PL_beginav = newAV();
5303             av_push(PL_beginav, (SV*)cv);
5304             GvCV(gv) = 0;               /* cv has been hijacked */
5305         }
5306         else if (strEQ(s, "END")) {
5307             if (!PL_endav)
5308                 PL_endav = newAV();
5309             av_unshift(PL_endav, 1);
5310             av_store(PL_endav, 0, (SV*)cv);
5311             GvCV(gv) = 0;               /* cv has been hijacked */
5312         }
5313         else if (strEQ(s, "CHECK")) {
5314             if (!PL_checkav)
5315                 PL_checkav = newAV();
5316             if (PL_main_start && ckWARN(WARN_VOID))
5317                 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
5318             av_unshift(PL_checkav, 1);
5319             av_store(PL_checkav, 0, (SV*)cv);
5320             GvCV(gv) = 0;               /* cv has been hijacked */
5321         }
5322         else if (strEQ(s, "INIT")) {
5323             if (!PL_initav)
5324                 PL_initav = newAV();
5325             if (PL_main_start && ckWARN(WARN_VOID))
5326                 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
5327             av_push(PL_initav, (SV*)cv);
5328             GvCV(gv) = 0;               /* cv has been hijacked */
5329         }
5330     }
5331     else
5332         CvANON_on(cv);
5333
5334 done:
5335     return cv;
5336 }
5337
5338 void
5339 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5340 {
5341     register CV *cv;
5342     char *name;
5343     GV *gv;
5344     I32 ix;
5345     STRLEN n_a;
5346
5347     if (o)
5348         name = SvPVx(cSVOPo->op_sv, n_a);
5349     else
5350         name = "STDOUT";
5351     gv = gv_fetchpv(name,TRUE, SVt_PVFM);
5352 #ifdef GV_UNIQUE_CHECK
5353     if (GvUNIQUE(gv)) {
5354         Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5355     }
5356 #endif
5357     GvMULTI_on(gv);
5358     if ((cv = GvFORM(gv))) {
5359         if (ckWARN(WARN_REDEFINE)) {
5360             line_t oldline = CopLINE(PL_curcop);
5361             if (PL_copline != NOLINE)
5362                 CopLINE_set(PL_curcop, PL_copline);
5363             Perl_warner(aTHX_ WARN_REDEFINE, "Format %s redefined",name);
5364             CopLINE_set(PL_curcop, oldline);
5365         }
5366         SvREFCNT_dec(cv);
5367     }
5368     cv = PL_compcv;
5369     GvFORM(gv) = cv;
5370     CvGV(cv) = gv;
5371     CvFILE_set_from_cop(cv, PL_curcop);
5372
5373     for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5374         if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
5375             SvPADTMP_on(PL_curpad[ix]);
5376     }
5377
5378     CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5379     CvROOT(cv)->op_private |= OPpREFCOUNTED;
5380     OpREFCNT_set(CvROOT(cv), 1);
5381     CvSTART(cv) = LINKLIST(CvROOT(cv));
5382     CvROOT(cv)->op_next = 0;
5383     CALL_PEEP(CvSTART(cv));
5384     op_free(o);
5385     PL_copline = NOLINE;
5386     LEAVE_SCOPE(floor);
5387 }
5388
5389 OP *
5390 Perl_newANONLIST(pTHX_ OP *o)
5391 {
5392     return newUNOP(OP_REFGEN, 0,
5393         mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5394 }
5395
5396 OP *
5397 Perl_newANONHASH(pTHX_ OP *o)
5398 {
5399     return newUNOP(OP_REFGEN, 0,
5400         mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5401 }
5402
5403 OP *
5404 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5405 {
5406     return newANONATTRSUB(floor, proto, Nullop, block);
5407 }
5408
5409 OP *
5410 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5411 {
5412     return newUNOP(OP_REFGEN, 0,
5413         newSVOP(OP_ANONCODE, 0,
5414                 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5415 }
5416
5417 OP *
5418 Perl_oopsAV(pTHX_ OP *o)
5419 {
5420     switch (o->op_type) {
5421     case OP_PADSV:
5422         o->op_type = OP_PADAV;
5423         o->op_ppaddr = PL_ppaddr[OP_PADAV];
5424         return ref(o, OP_RV2AV);
5425
5426     case OP_RV2SV:
5427         o->op_type = OP_RV2AV;
5428         o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5429         ref(o, OP_RV2AV);
5430         break;
5431
5432     default:
5433         if (ckWARN_d(WARN_INTERNAL))
5434             Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsAV");
5435         break;
5436     }
5437     return o;
5438 }
5439
5440 OP *
5441 Perl_oopsHV(pTHX_ OP *o)
5442 {
5443     switch (o->op_type) {
5444     case OP_PADSV:
5445     case OP_PADAV:
5446         o->op_type = OP_PADHV;
5447         o->op_ppaddr = PL_ppaddr[OP_PADHV];
5448         return ref(o, OP_RV2HV);
5449
5450     case OP_RV2SV:
5451     case OP_RV2AV:
5452         o->op_type = OP_RV2HV;
5453         o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5454         ref(o, OP_RV2HV);
5455         break;
5456
5457     default:
5458         if (ckWARN_d(WARN_INTERNAL))
5459             Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsHV");
5460         break;
5461     }
5462     return o;
5463 }
5464
5465 OP *
5466 Perl_newAVREF(pTHX_ OP *o)
5467 {
5468     if (o->op_type == OP_PADANY) {
5469         o->op_type = OP_PADAV;
5470         o->op_ppaddr = PL_ppaddr[OP_PADAV];
5471         return o;
5472     }
5473     else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5474                 && ckWARN(WARN_DEPRECATED)) {
5475         Perl_warner(aTHX_ WARN_DEPRECATED,
5476                 "Using an array as a reference is deprecated");
5477     }
5478     return newUNOP(OP_RV2AV, 0, scalar(o));
5479 }
5480
5481 OP *
5482 Perl_newGVREF(pTHX_ I32 type, OP *o)
5483 {
5484     if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5485         return newUNOP(OP_NULL, 0, o);
5486     return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5487 }
5488
5489 OP *
5490 Perl_newHVREF(pTHX_ OP *o)
5491 {
5492     if (o->op_type == OP_PADANY) {
5493         o->op_type = OP_PADHV;
5494         o->op_ppaddr = PL_ppaddr[OP_PADHV];
5495         return o;
5496     }
5497     else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5498                 && ckWARN(WARN_DEPRECATED)) {
5499         Perl_warner(aTHX_ WARN_DEPRECATED,
5500                 "Using a hash as a reference is deprecated");
5501     }
5502     return newUNOP(OP_RV2HV, 0, scalar(o));
5503 }
5504
5505 OP *
5506 Perl_oopsCV(pTHX_ OP *o)
5507 {
5508     Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5509     /* STUB */
5510     return o;
5511 }
5512
5513 OP *
5514 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5515 {
5516     return newUNOP(OP_RV2CV, flags, scalar(o));
5517 }
5518
5519 OP *
5520 Perl_newSVREF(pTHX_ OP *o)
5521 {
5522     if (o->op_type == OP_PADANY) {
5523         o->op_type = OP_PADSV;
5524         o->op_ppaddr = PL_ppaddr[OP_PADSV];
5525         return o;
5526     }
5527     else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5528         o->op_flags |= OPpDONE_SVREF;
5529         return o;
5530     }
5531     return newUNOP(OP_RV2SV, 0, scalar(o));
5532 }
5533
5534 /* Check routines. */
5535
5536 OP *
5537 Perl_ck_anoncode(pTHX_ OP *o)
5538 {
5539     PADOFFSET ix;
5540     SV* name;
5541
5542     name = NEWSV(1106,0);
5543     sv_upgrade(name, SVt_PVNV);
5544     sv_setpvn(name, "&", 1);
5545     SvIVX(name) = -1;
5546     SvNVX(name) = 1;
5547     ix = pad_alloc(o->op_type, SVs_PADMY);
5548     av_store(PL_comppad_name, ix, name);
5549     av_store(PL_comppad, ix, cSVOPo->op_sv);
5550     SvPADMY_on(cSVOPo->op_sv);
5551     cSVOPo->op_sv = Nullsv;
5552     cSVOPo->op_targ = ix;
5553     return o;
5554 }
5555
5556 OP *
5557 Perl_ck_bitop(pTHX_ OP *o)
5558 {
5559     o->op_private = PL_hints;
5560     return o;
5561 }
5562
5563 OP *
5564 Perl_ck_concat(pTHX_ OP *o)
5565 {
5566     if (cUNOPo->op_first->op_type == OP_CONCAT)
5567         o->op_flags |= OPf_STACKED;
5568     return o;
5569 }
5570
5571 OP *
5572 Perl_ck_spair(pTHX_ OP *o)
5573 {
5574     if (o->op_flags & OPf_KIDS) {
5575         OP* newop;
5576         OP* kid;
5577         OPCODE type = o->op_type;
5578         o = modkids(ck_fun(o), type);
5579         kid = cUNOPo->op_first;
5580         newop = kUNOP->op_first->op_sibling;
5581         if (newop &&
5582             (newop->op_sibling ||
5583              !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5584              newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5585              newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5586
5587             return o;
5588         }
5589         op_free(kUNOP->op_first);
5590         kUNOP->op_first = newop;
5591     }
5592     o->op_ppaddr = PL_ppaddr[++o->op_type];
5593     return ck_fun(o);
5594 }
5595
5596 OP *
5597 Perl_ck_delete(pTHX_ OP *o)
5598 {
5599     o = ck_fun(o);
5600     o->op_private = 0;
5601     if (o->op_flags & OPf_KIDS) {
5602         OP *kid = cUNOPo->op_first;
5603         switch (kid->op_type) {
5604         case OP_ASLICE:
5605             o->op_flags |= OPf_SPECIAL;
5606             /* FALL THROUGH */
5607         case OP_HSLICE:
5608             o->op_private |= OPpSLICE;
5609             break;
5610         case OP_AELEM:
5611             o->op_flags |= OPf_SPECIAL;
5612             /* FALL THROUGH */
5613         case OP_HELEM:
5614             break;
5615         default:
5616             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5617                   OP_DESC(o));
5618         }
5619         op_null(kid);
5620     }
5621     return o;
5622 }
5623
5624 OP *
5625 Perl_ck_die(pTHX_ OP *o)
5626 {
5627 #ifdef VMS
5628     if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5629 #endif
5630     return ck_fun(o);
5631 }
5632
5633 OP *
5634 Perl_ck_eof(pTHX_ OP *o)
5635 {
5636     I32 type = o->op_type;
5637
5638     if (o->op_flags & OPf_KIDS) {
5639         if (cLISTOPo->op_first->op_type == OP_STUB) {
5640             op_free(o);
5641             o = newUNOP(type, OPf_SPECIAL,
5642                 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
5643         }
5644         return ck_fun(o);
5645     }
5646     return o;
5647 }
5648
5649 OP *
5650 Perl_ck_eval(pTHX_ OP *o)
5651 {
5652     PL_hints |= HINT_BLOCK_SCOPE;
5653     if (o->op_flags & OPf_KIDS) {
5654         SVOP *kid = (SVOP*)cUNOPo->op_first;
5655
5656         if (!kid) {
5657             o->op_flags &= ~OPf_KIDS;
5658             op_null(o);
5659         }
5660         else if (kid->op_type == OP_LINESEQ) {
5661             LOGOP *enter;
5662
5663             kid->op_next = o->op_next;
5664             cUNOPo->op_first = 0;
5665             op_free(o);
5666
5667             NewOp(1101, enter, 1, LOGOP);
5668             enter->op_type = OP_ENTERTRY;
5669             enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5670             enter->op_private = 0;
5671
5672             /* establish postfix order */
5673             enter->op_next = (OP*)enter;
5674
5675             o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5676             o->op_type = OP_LEAVETRY;
5677             o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5678             enter->op_other = o;
5679             return o;
5680         }
5681         else
5682             scalar((OP*)kid);
5683     }
5684     else {
5685         op_free(o);
5686         o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5687     }
5688     o->op_targ = (PADOFFSET)PL_hints;
5689     return o;
5690 }
5691
5692 OP *
5693 Perl_ck_exit(pTHX_ OP *o)
5694 {
5695 #ifdef VMS
5696     HV *table = GvHV(PL_hintgv);
5697     if (table) {
5698        SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5699        if (svp && *svp && SvTRUE(*svp))
5700            o->op_private |= OPpEXIT_VMSISH;
5701     }
5702     if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5703 #endif
5704     return ck_fun(o);
5705 }
5706
5707 OP *
5708 Perl_ck_exec(pTHX_ OP *o)
5709 {
5710     OP *kid;
5711     if (o->op_flags & OPf_STACKED) {
5712         o = ck_fun(o);
5713         kid = cUNOPo->op_first->op_sibling;
5714         if (kid->op_type == OP_RV2GV)
5715             op_null(kid);
5716     }
5717     else
5718         o = listkids(o);
5719     return o;
5720 }
5721
5722 OP *
5723 Perl_ck_exists(pTHX_ OP *o)
5724 {
5725     o = ck_fun(o);
5726     if (o->op_flags & OPf_KIDS) {
5727         OP *kid = cUNOPo->op_first;
5728         if (kid->op_type == OP_ENTERSUB) {
5729             (void) ref(kid, o->op_type);
5730             if (kid->op_type != OP_RV2CV && !PL_error_count)
5731                 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5732                             OP_DESC(o));
5733             o->op_private |= OPpEXISTS_SUB;
5734         }
5735         else if (kid->op_type == OP_AELEM)
5736             o->op_flags |= OPf_SPECIAL;
5737         else if (kid->op_type != OP_HELEM)
5738             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5739                         OP_DESC(o));
5740         op_null(kid);
5741     }
5742     return o;
5743 }
5744
5745 #if 0
5746 OP *
5747 Perl_ck_gvconst(pTHX_ register OP *o)
5748 {
5749     o = fold_constants(o);
5750     if (o->op_type == OP_CONST)
5751         o->op_type = OP_GV;
5752     return o;
5753 }
5754 #endif
5755
5756 OP *
5757 Perl_ck_rvconst(pTHX_ register OP *o)
5758 {
5759     SVOP *kid = (SVOP*)cUNOPo->op_first;
5760
5761     o->op_private |= (PL_hints & HINT_STRICT_REFS);
5762     if (kid->op_type == OP_CONST) {
5763         char *name;
5764         int iscv;
5765         GV *gv;
5766         SV *kidsv = kid->op_sv;
5767         STRLEN n_a;
5768
5769         /* Is it a constant from cv_const_sv()? */
5770         if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5771             SV *rsv = SvRV(kidsv);
5772             int svtype = SvTYPE(rsv);
5773             char *badtype = Nullch;
5774
5775             switch (o->op_type) {
5776             case OP_RV2SV:
5777                 if (svtype > SVt_PVMG)
5778                     badtype = "a SCALAR";
5779                 break;
5780             case OP_RV2AV:
5781                 if (svtype != SVt_PVAV)
5782                     badtype = "an ARRAY";
5783                 break;
5784             case OP_RV2HV:
5785                 if (svtype != SVt_PVHV) {
5786                     if (svtype == SVt_PVAV) {   /* pseudohash? */
5787                         SV **ksv = av_fetch((AV*)rsv, 0, FALSE);
5788                         if (ksv && SvROK(*ksv)
5789                             && SvTYPE(SvRV(*ksv)) == SVt_PVHV)
5790                         {
5791                                 break;
5792                         }
5793                     }
5794                     badtype = "a HASH";
5795                 }
5796                 break;
5797             case OP_RV2CV:
5798                 if (svtype != SVt_PVCV)
5799                     badtype = "a CODE";
5800                 break;
5801             }
5802             if (badtype)
5803                 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5804             return o;
5805         }
5806         name = SvPV(kidsv, n_a);
5807         if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5808             char *badthing = Nullch;
5809             switch (o->op_type) {
5810             case OP_RV2SV:
5811                 badthing = "a SCALAR";
5812                 break;
5813             case OP_RV2AV:
5814                 badthing = "an ARRAY";
5815                 break;
5816             case OP_RV2HV:
5817                 badthing = "a HASH";
5818                 break;
5819             }
5820             if (badthing)
5821                 Perl_croak(aTHX_
5822           "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5823                       name, badthing);
5824         }
5825         /*
5826          * This is a little tricky.  We only want to add the symbol if we
5827          * didn't add it in the lexer.  Otherwise we get duplicate strict
5828          * warnings.  But if we didn't add it in the lexer, we must at
5829          * least pretend like we wanted to add it even if it existed before,
5830          * or we get possible typo warnings.  OPpCONST_ENTERED says
5831          * whether the lexer already added THIS instance of this symbol.
5832          */
5833         iscv = (o->op_type == OP_RV2CV) * 2;
5834         do {
5835             gv = gv_fetchpv(name,
5836                 iscv | !(kid->op_private & OPpCONST_ENTERED),
5837                 iscv
5838                     ? SVt_PVCV
5839                     : o->op_type == OP_RV2SV
5840                         ? SVt_PV
5841                         : o->op_type == OP_RV2AV
5842                             ? SVt_PVAV
5843                             : o->op_type == OP_RV2HV
5844                                 ? SVt_PVHV
5845                                 : SVt_PVGV);
5846         } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5847         if (gv) {
5848             kid->op_type = OP_GV;
5849             SvREFCNT_dec(kid->op_sv);
5850 #ifdef USE_ITHREADS
5851             /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5852             kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5853             SvREFCNT_dec(PL_curpad[kPADOP->op_padix]);
5854             GvIN_PAD_on(gv);
5855             PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv);
5856 #else
5857             kid->op_sv = SvREFCNT_inc(gv);
5858 #endif
5859             kid->op_private = 0;
5860             kid->op_ppaddr = PL_ppaddr[OP_GV];
5861         }
5862     }
5863     return o;
5864 }
5865
5866 OP *
5867 Perl_ck_ftst(pTHX_ OP *o)
5868 {
5869     I32 type = o->op_type;
5870
5871     if (o->op_flags & OPf_REF) {
5872         /* nothing */
5873     }
5874     else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5875         SVOP *kid = (SVOP*)cUNOPo->op_first;
5876
5877         if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5878             STRLEN n_a;
5879             OP *newop = newGVOP(type, OPf_REF,
5880                 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5881             op_free(o);
5882             o = newop;
5883         }
5884     }
5885     else {
5886         op_free(o);
5887         if (type == OP_FTTTY)
5888            o =  newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
5889                                 SVt_PVIO));
5890         else
5891             o = newUNOP(type, 0, newDEFSVOP());
5892     }
5893     return o;
5894 }
5895
5896 OP *
5897 Perl_ck_fun(pTHX_ OP *o)
5898 {
5899     register OP *kid;
5900     OP **tokid;
5901     OP *sibl;
5902     I32 numargs = 0;
5903     int type = o->op_type;
5904     register I32 oa = PL_opargs[type] >> OASHIFT;
5905
5906     if (o->op_flags & OPf_STACKED) {
5907         if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5908             oa &= ~OA_OPTIONAL;
5909         else
5910             return no_fh_allowed(o);
5911     }
5912
5913     if (o->op_flags & OPf_KIDS) {
5914         STRLEN n_a;
5915         tokid = &cLISTOPo->op_first;
5916         kid = cLISTOPo->op_first;
5917         if (kid->op_type == OP_PUSHMARK ||
5918             (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5919         {
5920             tokid = &kid->op_sibling;
5921             kid = kid->op_sibling;
5922         }
5923         if (!kid && PL_opargs[type] & OA_DEFGV)
5924             *tokid = kid = newDEFSVOP();
5925
5926         while (oa && kid) {
5927             numargs++;
5928             sibl = kid->op_sibling;
5929             switch (oa & 7) {
5930             case OA_SCALAR:
5931                 /* list seen where single (scalar) arg expected? */
5932                 if (numargs == 1 && !(oa >> 4)
5933                     && kid->op_type == OP_LIST && type != OP_SCALAR)
5934                 {
5935                     return too_many_arguments(o,PL_op_desc[type]);
5936                 }
5937                 scalar(kid);
5938                 break;
5939             case OA_LIST:
5940                 if (oa < 16) {
5941                     kid = 0;
5942                     continue;
5943                 }
5944                 else
5945                     list(kid);
5946                 break;
5947             case OA_AVREF:
5948                 if ((type == OP_PUSH || type == OP_UNSHIFT)
5949                     && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5950                     Perl_warner(aTHX_ WARN_SYNTAX,
5951                         "Useless use of %s with no values",
5952                         PL_op_desc[type]);
5953
5954                 if (kid->op_type == OP_CONST &&
5955                     (kid->op_private & OPpCONST_BARE))
5956                 {
5957                     char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5958                     OP *newop = newAVREF(newGVOP(OP_GV, 0,
5959                         gv_fetchpv(name, TRUE, SVt_PVAV) ));
5960                     if (ckWARN(WARN_DEPRECATED))
5961                         Perl_warner(aTHX_ WARN_DEPRECATED,
5962                             "Array @%s missing the @ in argument %"IVdf" of %s()",
5963                             name, (IV)numargs, PL_op_desc[type]);
5964                     op_free(kid);
5965                     kid = newop;
5966                     kid->op_sibling = sibl;
5967                     *tokid = kid;
5968                 }
5969                 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5970                     bad_type(numargs, "array", PL_op_desc[type], kid);
5971                 mod(kid, type);
5972                 break;
5973             case OA_HVREF:
5974                 if (kid->op_type == OP_CONST &&
5975                     (kid->op_private & OPpCONST_BARE))
5976                 {
5977                     char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5978                     OP *newop = newHVREF(newGVOP(OP_GV, 0,
5979                         gv_fetchpv(name, TRUE, SVt_PVHV) ));
5980                     if (ckWARN(WARN_DEPRECATED))
5981                         Perl_warner(aTHX_ WARN_DEPRECATED,
5982                             "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5983                             name, (IV)numargs, PL_op_desc[type]);
5984                     op_free(kid);
5985                     kid = newop;
5986                     kid->op_sibling = sibl;
5987                     *tokid = kid;
5988                 }
5989                 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5990                     bad_type(numargs, "hash", PL_op_desc[type], kid);
5991                 mod(kid, type);
5992                 break;
5993             case OA_CVREF:
5994                 {
5995                     OP *newop = newUNOP(OP_NULL, 0, kid);
5996                     kid->op_sibling = 0;
5997                     linklist(kid);
5998                     newop->op_next = newop;
5999                     kid = newop;
6000                     kid->op_sibling = sibl;
6001                     *tokid = kid;
6002                 }
6003                 break;
6004             case OA_FILEREF:
6005                 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
6006                     if (kid->op_type == OP_CONST &&
6007                         (kid->op_private & OPpCONST_BARE))
6008                     {
6009                         OP *newop = newGVOP(OP_GV, 0,
6010                             gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
6011                                         SVt_PVIO) );
6012                         if (kid == cLISTOPo->op_last)
6013                             cLISTOPo->op_last = newop;
6014                         op_free(kid);
6015                         kid = newop;
6016                     }
6017                     else if (kid->op_type == OP_READLINE) {
6018                         /* neophyte patrol: open(<FH>), close(<FH>) etc. */
6019                         bad_type(numargs, "HANDLE", OP_DESC(o), kid);
6020                     }
6021                     else {
6022                         I32 flags = OPf_SPECIAL;
6023                         I32 priv = 0;
6024                         PADOFFSET targ = 0;
6025
6026                         /* is this op a FH constructor? */
6027                         if (is_handle_constructor(o,numargs)) {
6028                             char *name = Nullch;
6029                             STRLEN len;
6030
6031                             flags = 0;
6032                             /* Set a flag to tell rv2gv to vivify
6033                              * need to "prove" flag does not mean something
6034                              * else already - NI-S 1999/05/07
6035                              */
6036                             priv = OPpDEREF;
6037                             if (kid->op_type == OP_PADSV) {
6038                                 SV **namep = av_fetch(PL_comppad_name,
6039                                                       kid->op_targ, 4);
6040                                 if (namep && *namep)
6041                                     name = SvPV(*namep, len);
6042                             }
6043                             else if (kid->op_type == OP_RV2SV
6044                                      && kUNOP->op_first->op_type == OP_GV)
6045                             {
6046                                 GV *gv = cGVOPx_gv(kUNOP->op_first);
6047                                 name = GvNAME(gv);
6048                                 len = GvNAMELEN(gv);
6049                             }
6050                             else if (kid->op_type == OP_AELEM
6051                                      || kid->op_type == OP_HELEM)
6052                             {
6053                                 name = "__ANONIO__";
6054                                 len = 10;
6055                                 mod(kid,type);
6056                             }
6057                             if (name) {
6058                                 SV *namesv;
6059                                 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
6060                                 namesv = PL_curpad[targ];
6061                                 (void)SvUPGRADE(namesv, SVt_PV);
6062                                 if (*name != '$')
6063                                     sv_setpvn(namesv, "$", 1);
6064                                 sv_catpvn(namesv, name, len);
6065                             }
6066                         }
6067                         kid->op_sibling = 0;
6068                         kid = newUNOP(OP_RV2GV, flags, scalar(kid));
6069                         kid->op_targ = targ;
6070                         kid->op_private |= priv;
6071                     }
6072                     kid->op_sibling = sibl;
6073                     *tokid = kid;
6074                 }
6075                 scalar(kid);
6076                 break;
6077             case OA_SCALARREF:
6078                 mod(scalar(kid), type);
6079                 break;
6080             }
6081             oa >>= 4;
6082             tokid = &kid->op_sibling;
6083             kid = kid->op_sibling;
6084         }
6085         o->op_private |= numargs;
6086         if (kid)
6087             return too_many_arguments(o,OP_DESC(o));
6088         listkids(o);
6089     }
6090     else if (PL_opargs[type] & OA_DEFGV) {
6091         op_free(o);
6092         return newUNOP(type, 0, newDEFSVOP());
6093     }
6094
6095     if (oa) {
6096         while (oa & OA_OPTIONAL)
6097             oa >>= 4;
6098         if (oa && oa != OA_LIST)
6099             return too_few_arguments(o,OP_DESC(o));
6100     }
6101     return o;
6102 }
6103
6104 OP *
6105 Perl_ck_glob(pTHX_ OP *o)
6106 {
6107     GV *gv;
6108
6109     o = ck_fun(o);
6110     if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
6111         append_elem(OP_GLOB, o, newDEFSVOP());
6112
6113     if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
6114           && GvCVu(gv) && GvIMPORTED_CV(gv)))
6115     {
6116         gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
6117     }
6118
6119 #if !defined(PERL_EXTERNAL_GLOB)
6120     /* XXX this can be tightened up and made more failsafe. */
6121     if (!gv) {
6122         GV *glob_gv;
6123         ENTER;
6124         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
6125                 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
6126         gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
6127         glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
6128         GvCV(gv) = GvCV(glob_gv);
6129         SvREFCNT_inc((SV*)GvCV(gv));
6130         GvIMPORTED_CV_on(gv);
6131         LEAVE;
6132     }
6133 #endif /* PERL_EXTERNAL_GLOB */
6134
6135     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6136         append_elem(OP_GLOB, o,
6137                     newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
6138         o->op_type = OP_LIST;
6139         o->op_ppaddr = PL_ppaddr[OP_LIST];
6140         cLISTOPo->op_first->op_type = OP_PUSHMARK;
6141         cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
6142         o = newUNOP(OP_ENTERSUB, OPf_STACKED,
6143                     append_elem(OP_LIST, o,
6144                                 scalar(newUNOP(OP_RV2CV, 0,
6145                                                newGVOP(OP_GV, 0, gv)))));
6146         o = newUNOP(OP_NULL, 0, ck_subr(o));
6147         o->op_targ = OP_GLOB;           /* hint at what it used to be */
6148         return o;
6149     }
6150     gv = newGVgen("main");
6151     gv_IOadd(gv);
6152     append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
6153     scalarkids(o);
6154     return o;
6155 }
6156
6157 OP *
6158 Perl_ck_grep(pTHX_ OP *o)
6159 {
6160     LOGOP *gwop;
6161     OP *kid;
6162     OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
6163
6164     o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
6165     NewOp(1101, gwop, 1, LOGOP);
6166
6167     if (o->op_flags & OPf_STACKED) {
6168         OP* k;
6169         o = ck_sort(o);
6170         kid = cLISTOPo->op_first->op_sibling;
6171         for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
6172             kid = k;
6173         }
6174         kid->op_next = (OP*)gwop;
6175         o->op_flags &= ~OPf_STACKED;
6176     }
6177     kid = cLISTOPo->op_first->op_sibling;
6178     if (type == OP_MAPWHILE)
6179         list(kid);
6180     else
6181         scalar(kid);
6182     o = ck_fun(o);
6183     if (PL_error_count)
6184         return o;
6185     kid = cLISTOPo->op_first->op_sibling;
6186     if (kid->op_type != OP_NULL)
6187         Perl_croak(aTHX_ "panic: ck_grep");
6188     kid = kUNOP->op_first;
6189
6190     gwop->op_type = type;
6191     gwop->op_ppaddr = PL_ppaddr[type];
6192     gwop->op_first = listkids(o);
6193     gwop->op_flags |= OPf_KIDS;
6194     gwop->op_private = 1;
6195     gwop->op_other = LINKLIST(kid);
6196     gwop->op_targ = pad_alloc(type, SVs_PADTMP);
6197     kid->op_next = (OP*)gwop;
6198
6199     kid = cLISTOPo->op_first->op_sibling;
6200     if (!kid || !kid->op_sibling)
6201         return too_few_arguments(o,OP_DESC(o));
6202     for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
6203         mod(kid, OP_GREPSTART);
6204
6205     return (OP*)gwop;
6206 }
6207
6208 OP *
6209 Perl_ck_index(pTHX_ OP *o)
6210 {
6211     if (o->op_flags & OPf_KIDS) {
6212         OP *kid = cLISTOPo->op_first->op_sibling;       /* get past pushmark */
6213         if (kid)
6214             kid = kid->op_sibling;                      /* get past "big" */
6215         if (kid && kid->op_type == OP_CONST)
6216             fbm_compile(((SVOP*)kid)->op_sv, 0);
6217     }
6218     return ck_fun(o);
6219 }
6220
6221 OP *
6222 Perl_ck_lengthconst(pTHX_ OP *o)
6223 {
6224     /* XXX length optimization goes here */
6225     return ck_fun(o);
6226 }
6227
6228 OP *
6229 Perl_ck_lfun(pTHX_ OP *o)
6230 {
6231     OPCODE type = o->op_type;
6232     return modkids(ck_fun(o), type);
6233 }
6234
6235 OP *
6236 Perl_ck_defined(pTHX_ OP *o)            /* 19990527 MJD */
6237 {
6238     if ((o->op_flags & OPf_KIDS) && ckWARN(WARN_DEPRECATED)) {
6239         switch (cUNOPo->op_first->op_type) {
6240         case OP_RV2AV:
6241             /* This is needed for
6242                if (defined %stash::)
6243                to work.   Do not break Tk.
6244                */
6245             break;                      /* Globals via GV can be undef */
6246         case OP_PADAV:
6247         case OP_AASSIGN:                /* Is this a good idea? */
6248             Perl_warner(aTHX_ WARN_DEPRECATED,
6249                         "defined(@array) is deprecated");
6250             Perl_warner(aTHX_ WARN_DEPRECATED,
6251                         "\t(Maybe you should just omit the defined()?)\n");
6252         break;
6253         case OP_RV2HV:
6254             /* This is needed for
6255                if (defined %stash::)
6256                to work.   Do not break Tk.
6257                */
6258             break;                      /* Globals via GV can be undef */
6259         case OP_PADHV:
6260             Perl_warner(aTHX_ WARN_DEPRECATED,
6261                         "defined(%%hash) is deprecated");
6262             Perl_warner(aTHX_ WARN_DEPRECATED,
6263                         "\t(Maybe you should just omit the defined()?)\n");
6264             break;
6265         default:
6266             /* no warning */
6267             break;
6268         }
6269     }
6270     return ck_rfun(o);
6271 }
6272
6273 OP *
6274 Perl_ck_rfun(pTHX_ OP *o)
6275 {
6276     OPCODE type = o->op_type;
6277     return refkids(ck_fun(o), type);
6278 }
6279
6280 OP *
6281 Perl_ck_listiob(pTHX_ OP *o)
6282 {
6283     register OP *kid;
6284
6285     kid = cLISTOPo->op_first;
6286     if (!kid) {
6287         o = force_list(o);
6288         kid = cLISTOPo->op_first;
6289     }
6290     if (kid->op_type == OP_PUSHMARK)
6291         kid = kid->op_sibling;
6292     if (kid && o->op_flags & OPf_STACKED)
6293         kid = kid->op_sibling;
6294     else if (kid && !kid->op_sibling) {         /* print HANDLE; */
6295         if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6296             o->op_flags |= OPf_STACKED; /* make it a filehandle */
6297             kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6298             cLISTOPo->op_first->op_sibling = kid;
6299             cLISTOPo->op_last = kid;
6300             kid = kid->op_sibling;
6301         }
6302     }
6303
6304     if (!kid)
6305         append_elem(o->op_type, o, newDEFSVOP());
6306
6307     return listkids(o);
6308 }
6309
6310 OP *
6311 Perl_ck_sassign(pTHX_ OP *o)
6312 {
6313     OP *kid = cLISTOPo->op_first;
6314     /* has a disposable target? */
6315     if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6316         && !(kid->op_flags & OPf_STACKED)
6317         /* Cannot steal the second time! */
6318         && !(kid->op_private & OPpTARGET_MY))
6319     {
6320         OP *kkid = kid->op_sibling;
6321
6322         /* Can just relocate the target. */
6323         if (kkid && kkid->op_type == OP_PADSV
6324             && !(kkid->op_private & OPpLVAL_INTRO))
6325         {
6326             kid->op_targ = kkid->op_targ;
6327             kkid->op_targ = 0;
6328             /* Now we do not need PADSV and SASSIGN. */
6329             kid->op_sibling = o->op_sibling;    /* NULL */
6330             cLISTOPo->op_first = NULL;
6331             op_free(o);
6332             op_free(kkid);
6333             kid->op_private |= OPpTARGET_MY;    /* Used for context settings */
6334             return kid;
6335         }
6336     }
6337     return o;
6338 }
6339
6340 OP *
6341 Perl_ck_match(pTHX_ OP *o)
6342 {
6343     o->op_private |= OPpRUNTIME;
6344     return o;
6345 }
6346
6347 OP *
6348 Perl_ck_method(pTHX_ OP *o)
6349 {
6350     OP *kid = cUNOPo->op_first;
6351     if (kid->op_type == OP_CONST) {
6352         SV* sv = kSVOP->op_sv;
6353         if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
6354             OP *cmop;
6355             if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6356                 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
6357             }
6358             else {
6359                 kSVOP->op_sv = Nullsv;
6360             }
6361             cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6362             op_free(o);
6363             return cmop;
6364         }
6365     }
6366     return o;
6367 }
6368
6369 OP *
6370 Perl_ck_null(pTHX_ OP *o)
6371 {
6372     return o;
6373 }
6374
6375 OP *
6376 Perl_ck_open(pTHX_ OP *o)
6377 {
6378     HV *table = GvHV(PL_hintgv);
6379     if (table) {
6380         SV **svp;
6381         I32 mode;
6382         svp = hv_fetch(table, "open_IN", 7, FALSE);
6383         if (svp && *svp) {
6384             mode = mode_from_discipline(*svp);
6385             if (mode & O_BINARY)
6386                 o->op_private |= OPpOPEN_IN_RAW;
6387             else if (mode & O_TEXT)
6388                 o->op_private |= OPpOPEN_IN_CRLF;
6389         }
6390
6391         svp = hv_fetch(table, "open_OUT", 8, FALSE);
6392         if (svp && *svp) {
6393             mode = mode_from_discipline(*svp);
6394             if (mode & O_BINARY)
6395                 o->op_private |= OPpOPEN_OUT_RAW;
6396             else if (mode & O_TEXT)
6397                 o->op_private |= OPpOPEN_OUT_CRLF;
6398         }
6399     }
6400     if (o->op_type == OP_BACKTICK)
6401         return o;
6402     return ck_fun(o);
6403 }
6404
6405 OP *
6406 Perl_ck_repeat(pTHX_ OP *o)
6407 {
6408     if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6409         o->op_private |= OPpREPEAT_DOLIST;
6410         cBINOPo->op_first = force_list(cBINOPo->op_first);
6411     }
6412     else
6413         scalar(o);
6414     return o;
6415 }
6416
6417 OP *
6418 Perl_ck_require(pTHX_ OP *o)
6419 {
6420     GV* gv;
6421
6422     if (o->op_flags & OPf_KIDS) {       /* Shall we supply missing .pm? */
6423         SVOP *kid = (SVOP*)cUNOPo->op_first;
6424
6425         if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6426             char *s;
6427             for (s = SvPVX(kid->op_sv); *s; s++) {
6428                 if (*s == ':' && s[1] == ':') {
6429                     *s = '/';
6430                     Move(s+2, s+1, strlen(s+2)+1, char);
6431                     --SvCUR(kid->op_sv);
6432                 }
6433             }
6434             if (SvREADONLY(kid->op_sv)) {
6435                 SvREADONLY_off(kid->op_sv);
6436                 sv_catpvn(kid->op_sv, ".pm", 3);
6437                 SvREADONLY_on(kid->op_sv);
6438             }
6439             else
6440                 sv_catpvn(kid->op_sv, ".pm", 3);
6441         }
6442     }
6443
6444     /* handle override, if any */
6445     gv = gv_fetchpv("require", FALSE, SVt_PVCV);
6446     if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
6447         gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
6448
6449     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6450         OP *kid = cUNOPo->op_first;
6451         cUNOPo->op_first = 0;
6452         op_free(o);
6453         return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
6454                                append_elem(OP_LIST, kid,
6455                                            scalar(newUNOP(OP_RV2CV, 0,
6456                                                           newGVOP(OP_GV, 0,
6457                                                                   gv))))));
6458     }
6459
6460     return ck_fun(o);
6461 }
6462
6463 OP *
6464 Perl_ck_return(pTHX_ OP *o)
6465 {
6466     OP *kid;
6467     if (CvLVALUE(PL_compcv)) {
6468         for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6469             mod(kid, OP_LEAVESUBLV);
6470     }
6471     return o;
6472 }
6473
6474 #if 0
6475 OP *
6476 Perl_ck_retarget(pTHX_ OP *o)
6477 {
6478     Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
6479     /* STUB */
6480     return o;
6481 }
6482 #endif
6483
6484 OP *
6485 Perl_ck_select(pTHX_ OP *o)
6486 {
6487     OP* kid;
6488     if (o->op_flags & OPf_KIDS) {
6489         kid = cLISTOPo->op_first->op_sibling;   /* get past pushmark */
6490         if (kid && kid->op_sibling) {
6491             o->op_type = OP_SSELECT;
6492             o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6493             o = ck_fun(o);
6494             return fold_constants(o);
6495         }
6496     }
6497     o = ck_fun(o);
6498     kid = cLISTOPo->op_first->op_sibling;    /* get past pushmark */
6499     if (kid && kid->op_type == OP_RV2GV)
6500         kid->op_private &= ~HINT_STRICT_REFS;
6501     return o;
6502 }
6503
6504 OP *
6505 Perl_ck_shift(pTHX_ OP *o)
6506 {
6507     I32 type = o->op_type;
6508
6509     if (!(o->op_flags & OPf_KIDS)) {
6510         OP *argop;
6511
6512         op_free(o);
6513 #ifdef USE_5005THREADS
6514         if (!CvUNIQUE(PL_compcv)) {
6515             argop = newOP(OP_PADAV, OPf_REF);
6516             argop->op_targ = 0;         /* PL_curpad[0] is @_ */
6517         }
6518         else {
6519             argop = newUNOP(OP_RV2AV, 0,
6520                 scalar(newGVOP(OP_GV, 0,
6521                     gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6522         }
6523 #else
6524         argop = newUNOP(OP_RV2AV, 0,
6525             scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
6526                            PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6527 #endif /* USE_5005THREADS */
6528         return newUNOP(type, 0, scalar(argop));
6529     }
6530     return scalar(modkids(ck_fun(o), type));
6531 }
6532
6533 OP *
6534 Perl_ck_sort(pTHX_ OP *o)
6535 {
6536     OP *firstkid;
6537
6538     if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6539         simplify_sort(o);
6540     firstkid = cLISTOPo->op_first->op_sibling;          /* get past pushmark */
6541     if (o->op_flags & OPf_STACKED) {                    /* may have been cleared */
6542         OP *k = NULL;
6543         OP *kid = cUNOPx(firstkid)->op_first;           /* get past null */
6544
6545         if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6546             linklist(kid);
6547             if (kid->op_type == OP_SCOPE) {
6548                 k = kid->op_next;
6549                 kid->op_next = 0;
6550             }
6551             else if (kid->op_type == OP_LEAVE) {
6552                 if (o->op_type == OP_SORT) {
6553                     op_null(kid);                       /* wipe out leave */
6554                     kid->op_next = kid;
6555
6556                     for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6557                         if (k->op_next == kid)
6558                             k->op_next = 0;
6559                         /* don't descend into loops */
6560                         else if (k->op_type == OP_ENTERLOOP
6561                                  || k->op_type == OP_ENTERITER)
6562                         {
6563                             k = cLOOPx(k)->op_lastop;
6564                         }
6565                     }
6566                 }
6567                 else
6568                     kid->op_next = 0;           /* just disconnect the leave */
6569                 k = kLISTOP->op_first;
6570             }
6571             CALL_PEEP(k);
6572
6573             kid = firstkid;
6574             if (o->op_type == OP_SORT) {
6575                 /* provide scalar context for comparison function/block */
6576                 kid = scalar(kid);
6577                 kid->op_next = kid;
6578             }
6579             else
6580                 kid->op_next = k;
6581             o->op_flags |= OPf_SPECIAL;
6582         }
6583         else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6584             op_null(firstkid);
6585
6586         firstkid = firstkid->op_sibling;
6587     }
6588
6589     /* provide list context for arguments */
6590     if (o->op_type == OP_SORT)
6591         list(firstkid);
6592
6593     return o;
6594 }
6595
6596 STATIC void
6597 S_simplify_sort(pTHX_ OP *o)
6598 {
6599     register OP *kid = cLISTOPo->op_first->op_sibling;  /* get past pushmark */
6600     OP *k;
6601     int reversed;
6602     GV *gv;
6603     if (!(o->op_flags & OPf_STACKED))
6604         return;
6605     GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6606     GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6607     kid = kUNOP->op_first;                              /* get past null */
6608     if (kid->op_type != OP_SCOPE)
6609         return;
6610     kid = kLISTOP->op_last;                             /* get past scope */
6611     switch(kid->op_type) {
6612         case OP_NCMP:
6613         case OP_I_NCMP:
6614         case OP_SCMP:
6615             break;
6616         default:
6617             return;
6618     }
6619     k = kid;                                            /* remember this node*/
6620     if (kBINOP->op_first->op_type != OP_RV2SV)
6621         return;
6622     kid = kBINOP->op_first;                             /* get past cmp */
6623     if (kUNOP->op_first->op_type != OP_GV)
6624         return;
6625     kid = kUNOP->op_first;                              /* get past rv2sv */
6626     gv = kGVOP_gv;
6627     if (GvSTASH(gv) != PL_curstash)
6628         return;
6629     if (strEQ(GvNAME(gv), "a"))
6630         reversed = 0;
6631     else if (strEQ(GvNAME(gv), "b"))
6632         reversed = 1;
6633     else
6634         return;
6635     kid = k;                                            /* back to cmp */
6636     if (kBINOP->op_last->op_type != OP_RV2SV)
6637         return;
6638     kid = kBINOP->op_last;                              /* down to 2nd arg */
6639     if (kUNOP->op_first->op_type != OP_GV)
6640         return;
6641     kid = kUNOP->op_first;                              /* get past rv2sv */
6642     gv = kGVOP_gv;
6643     if (GvSTASH(gv) != PL_curstash
6644         || ( reversed
6645             ? strNE(GvNAME(gv), "a")
6646             : strNE(GvNAME(gv), "b")))
6647         return;
6648     o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6649     if (reversed)
6650         o->op_private |= OPpSORT_REVERSE;
6651     if (k->op_type == OP_NCMP)
6652         o->op_private |= OPpSORT_NUMERIC;
6653     if (k->op_type == OP_I_NCMP)
6654         o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6655     kid = cLISTOPo->op_first->op_sibling;
6656     cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6657     op_free(kid);                                     /* then delete it */
6658 }
6659
6660 OP *
6661 Perl_ck_split(pTHX_ OP *o)
6662 {
6663     register OP *kid;
6664
6665     if (o->op_flags & OPf_STACKED)
6666         return no_fh_allowed(o);
6667
6668     kid = cLISTOPo->op_first;
6669     if (kid->op_type != OP_NULL)
6670         Perl_croak(aTHX_ "panic: ck_split");
6671     kid = kid->op_sibling;
6672     op_free(cLISTOPo->op_first);
6673     cLISTOPo->op_first = kid;
6674     if (!kid) {
6675         cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6676         cLISTOPo->op_last = kid; /* There was only one element previously */
6677     }
6678
6679     if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6680         OP *sibl = kid->op_sibling;
6681         kid->op_sibling = 0;
6682         kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
6683         if (cLISTOPo->op_first == cLISTOPo->op_last)
6684             cLISTOPo->op_last = kid;
6685         cLISTOPo->op_first = kid;
6686         kid->op_sibling = sibl;
6687     }
6688
6689     kid->op_type = OP_PUSHRE;
6690     kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6691     scalar(kid);
6692
6693     if (!kid->op_sibling)
6694         append_elem(OP_SPLIT, o, newDEFSVOP());
6695
6696     kid = kid->op_sibling;
6697     scalar(kid);
6698
6699     if (!kid->op_sibling)
6700         append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6701
6702     kid = kid->op_sibling;
6703     scalar(kid);
6704
6705     if (kid->op_sibling)
6706         return too_many_arguments(o,OP_DESC(o));
6707
6708     return o;
6709 }
6710
6711 OP *
6712 Perl_ck_join(pTHX_ OP *o)
6713 {
6714     if (ckWARN(WARN_SYNTAX)) {
6715         OP *kid = cLISTOPo->op_first->op_sibling;
6716         if (kid && kid->op_type == OP_MATCH) {
6717             char *pmstr = "STRING";
6718             if (PM_GETRE(kPMOP))
6719                 pmstr = PM_GETRE(kPMOP)->precomp;
6720             Perl_warner(aTHX_ WARN_SYNTAX,
6721                         "/%s/ should probably be written as \"%s\"",
6722                         pmstr, pmstr);
6723         }
6724     }
6725     return ck_fun(o);
6726 }
6727
6728 OP *
6729 Perl_ck_subr(pTHX_ OP *o)
6730 {
6731     OP *prev = ((cUNOPo->op_first->op_sibling)
6732              ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6733     OP *o2 = prev->op_sibling;
6734     OP *cvop;
6735     char *proto = 0;
6736     CV *cv = 0;
6737     GV *namegv = 0;
6738     int optional = 0;
6739     I32 arg = 0;
6740     I32 contextclass = 0;
6741     char *e = 0;
6742     STRLEN n_a;
6743
6744     o->op_private |= OPpENTERSUB_HASTARG;
6745     for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6746     if (cvop->op_type == OP_RV2CV) {
6747         SVOP* tmpop;
6748         o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6749         op_null(cvop);          /* disable rv2cv */
6750         tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6751         if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6752             GV *gv = cGVOPx_gv(tmpop);
6753             cv = GvCVu(gv);
6754             if (!cv)
6755                 tmpop->op_private |= OPpEARLY_CV;
6756             else if (SvPOK(cv)) {
6757                 namegv = CvANON(cv) ? gv : CvGV(cv);
6758                 proto = SvPV((SV*)cv, n_a);
6759             }
6760         }
6761     }
6762     else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6763         if (o2->op_type == OP_CONST)
6764             o2->op_private &= ~OPpCONST_STRICT;
6765         else if (o2->op_type == OP_LIST) {
6766             OP *o = ((UNOP*)o2)->op_first->op_sibling;
6767             if (o && o->op_type == OP_CONST)
6768                 o->op_private &= ~OPpCONST_STRICT;
6769         }
6770     }
6771     o->op_private |= (PL_hints & HINT_STRICT_REFS);
6772     if (PERLDB_SUB && PL_curstash != PL_debstash)
6773         o->op_private |= OPpENTERSUB_DB;
6774     while (o2 != cvop) {
6775         if (proto) {
6776             switch (*proto) {
6777             case '\0':
6778                 return too_many_arguments(o, gv_ename(namegv));
6779             case ';':
6780                 optional = 1;
6781                 proto++;
6782                 continue;
6783             case '$':
6784                 proto++;
6785                 arg++;
6786                 scalar(o2);
6787                 break;
6788             case '%':
6789             case '@':
6790                 list(o2);
6791                 arg++;
6792                 break;
6793             case '&':
6794                 proto++;
6795                 arg++;
6796                 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6797                     bad_type(arg,
6798                         arg == 1 ? "block or sub {}" : "sub {}",
6799                         gv_ename(namegv), o2);
6800                 break;
6801             case '*':
6802                 /* '*' allows any scalar type, including bareword */
6803                 proto++;
6804                 arg++;
6805                 if (o2->op_type == OP_RV2GV)
6806                     goto wrapref;       /* autoconvert GLOB -> GLOBref */
6807                 else if (o2->op_type == OP_CONST)
6808                     o2->op_private &= ~OPpCONST_STRICT;
6809                 else if (o2->op_type == OP_ENTERSUB) {
6810                     /* accidental subroutine, revert to bareword */
6811                     OP *gvop = ((UNOP*)o2)->op_first;
6812                     if (gvop && gvop->op_type == OP_NULL) {
6813                         gvop = ((UNOP*)gvop)->op_first;
6814                         if (gvop) {
6815                             for (; gvop->op_sibling; gvop = gvop->op_sibling)
6816                                 ;
6817                             if (gvop &&
6818                                 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6819                                 (gvop = ((UNOP*)gvop)->op_first) &&
6820                                 gvop->op_type == OP_GV)
6821                             {
6822                                 GV *gv = cGVOPx_gv(gvop);
6823                                 OP *sibling = o2->op_sibling;
6824                                 SV *n = newSVpvn("",0);
6825                                 op_free(o2);
6826                                 gv_fullname3(n, gv, "");
6827                                 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6828                                     sv_chop(n, SvPVX(n)+6);
6829                                 o2 = newSVOP(OP_CONST, 0, n);
6830                                 prev->op_sibling = o2;
6831                                 o2->op_sibling = sibling;
6832                             }
6833                         }
6834                     }
6835                 }
6836                 scalar(o2);
6837                 break;
6838             case '[': case ']':
6839                  goto oops;
6840                  break;
6841             case '\\':
6842                 proto++;
6843                 arg++;
6844             again:
6845                 switch (*proto++) {
6846                 case '[':
6847                      if (contextclass++ == 0) {
6848                           e = strchr(proto, ']');
6849                           if (!e || e == proto)
6850                                goto oops;
6851                      }
6852                      else
6853                           goto oops;
6854                      goto again;
6855                      break;
6856                 case ']':
6857                      if (contextclass) {
6858                          char *p = proto;
6859                          char s = *p;
6860                          contextclass = 0;
6861                          *p = '\0';
6862                          while (*--p != '[');
6863                          bad_type(arg, Perl_form(aTHX_ "one of %s", p),
6864                                  gv_ename(namegv), o2);
6865                          *proto = s;
6866                      } else
6867                           goto oops;
6868                      break;
6869                 case '*':
6870                      if (o2->op_type == OP_RV2GV)
6871                           goto wrapref;
6872                      if (!contextclass)
6873                           bad_type(arg, "symbol", gv_ename(namegv), o2);
6874                      break;
6875                 case '&':
6876                      if (o2->op_type == OP_ENTERSUB)
6877                           goto wrapref;
6878                      if (!contextclass)
6879                           bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6880                      break;
6881                 case '$':
6882                     if (o2->op_type == OP_RV2SV ||
6883                         o2->op_type == OP_PADSV ||
6884                         o2->op_type == OP_HELEM ||
6885                         o2->op_type == OP_AELEM ||
6886                         o2->op_type == OP_THREADSV)
6887                          goto wrapref;
6888                     if (!contextclass)
6889                         bad_type(arg, "scalar", gv_ename(namegv), o2);
6890                      break;
6891                 case '@':
6892                     if (o2->op_type == OP_RV2AV ||
6893                         o2->op_type == OP_PADAV)
6894                          goto wrapref;
6895                     if (!contextclass)
6896                         bad_type(arg, "array", gv_ename(namegv), o2);
6897                     break;
6898                 case '%':
6899                     if (o2->op_type == OP_RV2HV ||
6900                         o2->op_type == OP_PADHV)
6901                          goto wrapref;
6902                     if (!contextclass)
6903                          bad_type(arg, "hash", gv_ename(namegv), o2);
6904                     break;
6905                 wrapref:
6906                     {
6907                         OP* kid = o2;
6908                         OP* sib = kid->op_sibling;
6909                         kid->op_sibling = 0;
6910                         o2 = newUNOP(OP_REFGEN, 0, kid);
6911                         o2->op_sibling = sib;
6912                         prev->op_sibling = o2;
6913                     }
6914                     if (contextclass && e) {
6915                          proto = e + 1;
6916                          contextclass = 0;
6917                     }
6918                     break;
6919                 default: goto oops;
6920                 }
6921                 if (contextclass)
6922                      goto again;
6923                 break;
6924             case ' ':
6925                 proto++;
6926                 continue;
6927             default:
6928               oops:
6929                 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
6930                            gv_ename(namegv), SvPV((SV*)cv, n_a));
6931             }
6932         }
6933         else
6934             list(o2);
6935         mod(o2, OP_ENTERSUB);
6936         prev = o2;
6937         o2 = o2->op_sibling;
6938     }
6939     if (proto && !optional &&
6940           (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6941         return too_few_arguments(o, gv_ename(namegv));
6942     return o;
6943 }
6944
6945 OP *
6946 Perl_ck_svconst(pTHX_ OP *o)
6947 {
6948     SvREADONLY_on(cSVOPo->op_sv);
6949     return o;
6950 }
6951
6952 OP *
6953 Perl_ck_trunc(pTHX_ OP *o)
6954 {
6955     if (o->op_flags & OPf_KIDS) {
6956         SVOP *kid = (SVOP*)cUNOPo->op_first;
6957
6958         if (kid->op_type == OP_NULL)
6959             kid = (SVOP*)kid->op_sibling;
6960         if (kid && kid->op_type == OP_CONST &&
6961             (kid->op_private & OPpCONST_BARE))
6962         {
6963             o->op_flags |= OPf_SPECIAL;
6964             kid->op_private &= ~OPpCONST_STRICT;
6965         }
6966     }
6967     return ck_fun(o);
6968 }
6969
6970 OP *
6971 Perl_ck_substr(pTHX_ OP *o)
6972 {
6973     o = ck_fun(o);
6974     if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6975         OP *kid = cLISTOPo->op_first;
6976
6977         if (kid->op_type == OP_NULL)
6978             kid = kid->op_sibling;
6979         if (kid)
6980             kid->op_flags |= OPf_MOD;
6981
6982     }
6983     return o;
6984 }
6985
6986 /* A peephole optimizer.  We visit the ops in the order they're to execute. */
6987
6988 void
6989 Perl_peep(pTHX_ register OP *o)
6990 {
6991     register OP* oldop = 0;
6992     STRLEN n_a;
6993
6994     if (!o || o->op_seq)
6995         return;
6996     ENTER;
6997     SAVEOP();
6998     SAVEVPTR(PL_curcop);
6999     for (; o; o = o->op_next) {
7000         if (o->op_seq)
7001             break;
7002         if (!PL_op_seqmax)
7003             PL_op_seqmax++;
7004         PL_op = o;
7005         switch (o->op_type) {
7006         case OP_SETSTATE:
7007         case OP_NEXTSTATE:
7008         case OP_DBSTATE:
7009             PL_curcop = ((COP*)o);              /* for warnings */
7010             o->op_seq = PL_op_seqmax++;
7011             break;
7012
7013         case OP_CONST:
7014             if (cSVOPo->op_private & OPpCONST_STRICT)
7015                 no_bareword_allowed(o);
7016 #ifdef USE_ITHREADS
7017             /* Relocate sv to the pad for thread safety.
7018              * Despite being a "constant", the SV is written to,
7019              * for reference counts, sv_upgrade() etc. */
7020             if (cSVOP->op_sv) {
7021                 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
7022                 if (SvPADTMP(cSVOPo->op_sv)) {
7023                     /* If op_sv is already a PADTMP then it is being used by
7024                      * some pad, so make a copy. */
7025                     sv_setsv(PL_curpad[ix],cSVOPo->op_sv);
7026                     SvREADONLY_on(PL_curpad[ix]);
7027                     SvREFCNT_dec(cSVOPo->op_sv);
7028                 }
7029                 else {
7030                     SvREFCNT_dec(PL_curpad[ix]);
7031                     SvPADTMP_on(cSVOPo->op_sv);
7032                     PL_curpad[ix] = cSVOPo->op_sv;
7033                     /* XXX I don't know how this isn't readonly already. */
7034                     SvREADONLY_on(PL_curpad[ix]);
7035                 }
7036                 cSVOPo->op_sv = Nullsv;
7037                 o->op_targ = ix;
7038             }
7039 #endif
7040             o->op_seq = PL_op_seqmax++;
7041             break;
7042
7043         case OP_CONCAT:
7044             if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
7045                 if (o->op_next->op_private & OPpTARGET_MY) {
7046                     if (o->op_flags & OPf_STACKED) /* chained concats */
7047                         goto ignore_optimization;
7048                     else {
7049                         /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
7050                         o->op_targ = o->op_next->op_targ;
7051                         o->op_next->op_targ = 0;
7052                         o->op_private |= OPpTARGET_MY;
7053                     }
7054                 }
7055                 op_null(o->op_next);
7056             }
7057           ignore_optimization:
7058             o->op_seq = PL_op_seqmax++;
7059             break;
7060         case OP_STUB:
7061             if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
7062                 o->op_seq = PL_op_seqmax++;
7063                 break; /* Scalar stub must produce undef.  List stub is noop */
7064             }
7065             goto nothin;
7066         case OP_NULL:
7067             if (o->op_targ == OP_NEXTSTATE
7068                 || o->op_targ == OP_DBSTATE
7069                 || o->op_targ == OP_SETSTATE)
7070             {
7071                 PL_curcop = ((COP*)o);
7072             }
7073             /* XXX: We avoid setting op_seq here to prevent later calls
7074                to peep() from mistakenly concluding that optimisation
7075                has already occurred. This doesn't fix the real problem,
7076                though (See 20010220.007). AMS 20010719 */
7077             if (oldop && o->op_next) {
7078                 oldop->op_next = o->op_next;
7079                 continue;
7080             }
7081             break;
7082         case OP_SCALAR:
7083         case OP_LINESEQ:
7084         case OP_SCOPE:
7085           nothin:
7086             if (oldop && o->op_next) {
7087                 oldop->op_next = o->op_next;
7088                 continue;
7089             }
7090             o->op_seq = PL_op_seqmax++;
7091             break;
7092
7093         case OP_GV:
7094             if (o->op_next->op_type == OP_RV2SV) {
7095                 if (!(o->op_next->op_private & OPpDEREF)) {
7096                     op_null(o->op_next);
7097                     o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
7098                                                                | OPpOUR_INTRO);
7099                     o->op_next = o->op_next->op_next;
7100                     o->op_type = OP_GVSV;
7101                     o->op_ppaddr = PL_ppaddr[OP_GVSV];
7102                 }
7103             }
7104             else if (o->op_next->op_type == OP_RV2AV) {
7105                 OP* pop = o->op_next->op_next;
7106                 IV i;
7107                 if (pop && pop->op_type == OP_CONST &&
7108                     (PL_op = pop->op_next) &&
7109                     pop->op_next->op_type == OP_AELEM &&
7110                     !(pop->op_next->op_private &
7111                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
7112                     (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
7113                                 <= 255 &&
7114                     i >= 0)
7115                 {
7116                     GV *gv;
7117                     op_null(o->op_next);
7118                     op_null(pop->op_next);
7119                     op_null(pop);
7120                     o->op_flags |= pop->op_next->op_flags & OPf_MOD;
7121                     o->op_next = pop->op_next->op_next;
7122                     o->op_type = OP_AELEMFAST;
7123                     o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
7124                     o->op_private = (U8)i;
7125                     gv = cGVOPo_gv;
7126                     GvAVn(gv);
7127                 }
7128             }
7129             else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
7130                 GV *gv = cGVOPo_gv;
7131                 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
7132                     /* XXX could check prototype here instead of just carping */
7133                     SV *sv = sv_newmortal();
7134                     gv_efullname3(sv, gv, Nullch);
7135                     Perl_warner(aTHX_ WARN_PROTOTYPE,
7136                                 "%s() called too early to check prototype",
7137                                 SvPV_nolen(sv));
7138                 }
7139             }
7140             else if (o->op_next->op_type == OP_READLINE
7141                     && o->op_next->op_next->op_type == OP_CONCAT
7142                     && (o->op_next->op_next->op_flags & OPf_STACKED))
7143             {
7144                 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
7145                 o->op_type   = OP_RCATLINE;
7146                 o->op_flags |= OPf_STACKED;
7147                 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
7148                 op_null(o->op_next->op_next);
7149                 op_null(o->op_next);
7150             }
7151
7152             o->op_seq = PL_op_seqmax++;
7153             break;
7154
7155         case OP_MAPWHILE:
7156         case OP_GREPWHILE:
7157         case OP_AND:
7158         case OP_OR:
7159         case OP_ANDASSIGN:
7160         case OP_ORASSIGN:
7161         case OP_COND_EXPR:
7162         case OP_RANGE:
7163             o->op_seq = PL_op_seqmax++;
7164             while (cLOGOP->op_other->op_type == OP_NULL)
7165                 cLOGOP->op_other = cLOGOP->op_other->op_next;
7166             peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
7167             break;
7168
7169         case OP_ENTERLOOP:
7170         case OP_ENTERITER:
7171             o->op_seq = PL_op_seqmax++;
7172             while (cLOOP->op_redoop->op_type == OP_NULL)
7173                 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
7174             peep(cLOOP->op_redoop);
7175             while (cLOOP->op_nextop->op_type == OP_NULL)
7176                 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
7177             peep(cLOOP->op_nextop);
7178             while (cLOOP->op_lastop->op_type == OP_NULL)
7179                 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
7180             peep(cLOOP->op_lastop);
7181             break;
7182
7183         case OP_QR:
7184         case OP_MATCH:
7185         case OP_SUBST:
7186             o->op_seq = PL_op_seqmax++;
7187             while (cPMOP->op_pmreplstart &&
7188                    cPMOP->op_pmreplstart->op_type == OP_NULL)
7189                 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
7190             peep(cPMOP->op_pmreplstart);
7191             break;
7192
7193         case OP_EXEC:
7194             o->op_seq = PL_op_seqmax++;
7195             if (ckWARN(WARN_SYNTAX) && o->op_next
7196                 && o->op_next->op_type == OP_NEXTSTATE) {
7197                 if (o->op_next->op_sibling &&
7198                         o->op_next->op_sibling->op_type != OP_EXIT &&
7199                         o->op_next->op_sibling->op_type != OP_WARN &&
7200                         o->op_next->op_sibling->op_type != OP_DIE) {
7201                     line_t oldline = CopLINE(PL_curcop);
7202
7203                     CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
7204                     Perl_warner(aTHX_ WARN_EXEC,
7205                                 "Statement unlikely to be reached");
7206                     Perl_warner(aTHX_ WARN_EXEC,
7207                                 "\t(Maybe you meant system() when you said exec()?)\n");
7208                     CopLINE_set(PL_curcop, oldline);
7209                 }
7210             }
7211             break;
7212
7213         case OP_HELEM: {
7214             UNOP *rop;
7215             SV *lexname;
7216             GV **fields;
7217             SV **svp, **indsvp, *sv;
7218             I32 ind;
7219             char *key = NULL;
7220             STRLEN keylen;
7221
7222             o->op_seq = PL_op_seqmax++;
7223
7224             if (((BINOP*)o)->op_last->op_type != OP_CONST)
7225                 break;
7226
7227             /* Make the CONST have a shared SV */
7228             svp = cSVOPx_svp(((BINOP*)o)->op_last);
7229             if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
7230                 key = SvPV(sv, keylen);
7231                 lexname = newSVpvn_share(key,
7232                                          SvUTF8(sv) ? -(I32)keylen : keylen,
7233                                          0);
7234                 SvREFCNT_dec(sv);
7235                 *svp = lexname;
7236             }
7237
7238             if ((o->op_private & (OPpLVAL_INTRO)))
7239                 break;
7240
7241             rop = (UNOP*)((BINOP*)o)->op_first;
7242             if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7243                 break;
7244             lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7245             if (!(SvFLAGS(lexname) & SVpad_TYPED))
7246                 break;
7247             fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
7248             if (!fields || !GvHV(*fields))
7249                 break;
7250             key = SvPV(*svp, keylen);
7251             indsvp = hv_fetch(GvHV(*fields), key,
7252                               SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
7253             if (!indsvp) {
7254                 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s",
7255                       key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
7256             }
7257             ind = SvIV(*indsvp);
7258             if (ind < 1)
7259                 Perl_croak(aTHX_ "Bad index while coercing array into hash");
7260             rop->op_type = OP_RV2AV;
7261             rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
7262             o->op_type = OP_AELEM;
7263             o->op_ppaddr = PL_ppaddr[OP_AELEM];
7264             sv = newSViv(ind);
7265             if (SvREADONLY(*svp))
7266                 SvREADONLY_on(sv);
7267             SvFLAGS(sv) |= (SvFLAGS(*svp)
7268                             & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
7269             SvREFCNT_dec(*svp);
7270             *svp = sv;
7271             break;
7272         }
7273
7274         case OP_HSLICE: {
7275             UNOP *rop;
7276             SV *lexname;
7277             GV **fields;
7278             SV **svp, **indsvp, *sv;
7279             I32 ind;
7280             char *key;
7281             STRLEN keylen;
7282             SVOP *first_key_op, *key_op;
7283
7284             o->op_seq = PL_op_seqmax++;
7285             if ((o->op_private & (OPpLVAL_INTRO))
7286                 /* I bet there's always a pushmark... */
7287                 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
7288                 /* hmmm, no optimization if list contains only one key. */
7289                 break;
7290             rop = (UNOP*)((LISTOP*)o)->op_last;
7291             if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7292                 break;
7293             lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7294             if (!(SvFLAGS(lexname) & SVpad_TYPED))
7295                 break;
7296             fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
7297             if (!fields || !GvHV(*fields))
7298                 break;
7299             /* Again guessing that the pushmark can be jumped over.... */
7300             first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
7301                 ->op_first->op_sibling;
7302             /* Check that the key list contains only constants. */
7303             for (key_op = first_key_op; key_op;
7304                  key_op = (SVOP*)key_op->op_sibling)
7305                 if (key_op->op_type != OP_CONST)
7306                     break;
7307             if (key_op)
7308                 break;
7309             rop->op_type = OP_RV2AV;
7310             rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
7311             o->op_type = OP_ASLICE;
7312             o->op_ppaddr = PL_ppaddr[OP_ASLICE];
7313             for (key_op = first_key_op; key_op;
7314                  key_op = (SVOP*)key_op->op_sibling) {
7315                 svp = cSVOPx_svp(key_op);
7316                 key = SvPV(*svp, keylen);
7317                 indsvp = hv_fetch(GvHV(*fields), key,
7318                                   SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
7319                 if (!indsvp) {
7320                     Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
7321                                "in variable %s of type %s",
7322                           key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
7323                 }
7324                 ind = SvIV(*indsvp);
7325                 if (ind < 1)
7326                     Perl_croak(aTHX_ "Bad index while coercing array into hash");
7327                 sv = newSViv(ind);
7328                 if (SvREADONLY(*svp))
7329                     SvREADONLY_on(sv);
7330                 SvFLAGS(sv) |= (SvFLAGS(*svp)
7331                                 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
7332                 SvREFCNT_dec(*svp);
7333                 *svp = sv;
7334             }
7335             break;
7336         }
7337
7338         default:
7339             o->op_seq = PL_op_seqmax++;
7340             break;
7341         }
7342         oldop = o;
7343     }
7344     LEAVE;
7345 }
7346
7347
7348
7349 char* Perl_custom_op_name(pTHX_ OP* o)
7350 {
7351     IV  index = PTR2IV(o->op_ppaddr);
7352     SV* keysv;
7353     HE* he;
7354
7355     if (!PL_custom_op_names) /* This probably shouldn't happen */
7356         return PL_op_name[OP_CUSTOM];
7357
7358     keysv = sv_2mortal(newSViv(index));
7359
7360     he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
7361     if (!he)
7362         return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
7363
7364     return SvPV_nolen(HeVAL(he));
7365 }
7366
7367 char* Perl_custom_op_desc(pTHX_ OP* o)
7368 {
7369     IV  index = PTR2IV(o->op_ppaddr);
7370     SV* keysv;
7371     HE* he;
7372
7373     if (!PL_custom_op_descs)
7374         return PL_op_desc[OP_CUSTOM];
7375
7376     keysv = sv_2mortal(newSViv(index));
7377
7378     he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
7379     if (!he)
7380         return PL_op_desc[OP_CUSTOM];
7381
7382     return SvPV_nolen(HeVAL(he));
7383 }
7384
7385
7386 #include "XSUB.h"
7387
7388 /* Efficient sub that returns a constant scalar value. */
7389 static void
7390 const_sv_xsub(pTHX_ CV* cv)
7391 {
7392     dXSARGS;
7393     if (items != 0) {
7394 #if 0
7395         Perl_croak(aTHX_ "usage: %s::%s()",
7396                    HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7397 #endif
7398     }
7399     EXTEND(sp, 1);
7400     ST(0) = (SV*)XSANY.any_ptr;
7401     XSRETURN(1);
7402 }