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