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_old("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_old("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     return o;
2502 }
2503
2504 OP *
2505 Perl_gen_constant_list(pTHX_ register OP *o)
2506 {
2507     register OP *curop;
2508     I32 oldtmps_floor = PL_tmps_floor;
2509
2510     list(o);
2511     if (PL_error_count)
2512         return o;               /* Don't attempt to run with errors */
2513
2514     PL_op = curop = LINKLIST(o);
2515     o->op_next = 0;
2516     CALL_PEEP(curop);
2517     pp_pushmark();
2518     CALLRUNOPS(aTHX);
2519     PL_op = curop;
2520     pp_anonlist();
2521     PL_tmps_floor = oldtmps_floor;
2522
2523     o->op_type = OP_RV2AV;
2524     o->op_ppaddr = PL_ppaddr[OP_RV2AV];
2525     o->op_seq = 0;              /* needs to be revisited in peep() */
2526     curop = ((UNOP*)o)->op_first;
2527     ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
2528     op_free(curop);
2529     linklist(o);
2530     return list(o);
2531 }
2532
2533 OP *
2534 Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
2535 {
2536     if (!o || o->op_type != OP_LIST)
2537         o = newLISTOP(OP_LIST, 0, o, Nullop);
2538     else
2539         o->op_flags &= ~OPf_WANT;
2540
2541     if (!(PL_opargs[type] & OA_MARK))
2542         op_null(cLISTOPo->op_first);
2543
2544     o->op_type = type;
2545     o->op_ppaddr = PL_ppaddr[type];
2546     o->op_flags |= flags;
2547
2548     o = CHECKOP(type, o);
2549     if (o->op_type != type)
2550         return o;
2551
2552     return fold_constants(o);
2553 }
2554
2555 /* List constructors */
2556
2557 OP *
2558 Perl_append_elem(pTHX_ I32 type, OP *first, OP *last)
2559 {
2560     if (!first)
2561         return last;
2562
2563     if (!last)
2564         return first;
2565
2566     if (first->op_type != type
2567         || (type == OP_LIST && (first->op_flags & OPf_PARENS)))
2568     {
2569         return newLISTOP(type, 0, first, last);
2570     }
2571
2572     if (first->op_flags & OPf_KIDS)
2573         ((LISTOP*)first)->op_last->op_sibling = last;
2574     else {
2575         first->op_flags |= OPf_KIDS;
2576         ((LISTOP*)first)->op_first = last;
2577     }
2578     ((LISTOP*)first)->op_last = last;
2579     return first;
2580 }
2581
2582 OP *
2583 Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last)
2584 {
2585     if (!first)
2586         return (OP*)last;
2587
2588     if (!last)
2589         return (OP*)first;
2590
2591     if (first->op_type != type)
2592         return prepend_elem(type, (OP*)first, (OP*)last);
2593
2594     if (last->op_type != type)
2595         return append_elem(type, (OP*)first, (OP*)last);
2596
2597     first->op_last->op_sibling = last->op_first;
2598     first->op_last = last->op_last;
2599     first->op_flags |= (last->op_flags & OPf_KIDS);
2600
2601     FreeOp(last);
2602
2603     return (OP*)first;
2604 }
2605
2606 OP *
2607 Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last)
2608 {
2609     if (!first)
2610         return last;
2611
2612     if (!last)
2613         return first;
2614
2615     if (last->op_type == type) {
2616         if (type == OP_LIST) {  /* already a PUSHMARK there */
2617             first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
2618             ((LISTOP*)last)->op_first->op_sibling = first;
2619             if (!(first->op_flags & OPf_PARENS))
2620                 last->op_flags &= ~OPf_PARENS;
2621         }
2622         else {
2623             if (!(last->op_flags & OPf_KIDS)) {
2624                 ((LISTOP*)last)->op_last = first;
2625                 last->op_flags |= OPf_KIDS;
2626             }
2627             first->op_sibling = ((LISTOP*)last)->op_first;
2628             ((LISTOP*)last)->op_first = first;
2629         }
2630         last->op_flags |= OPf_KIDS;
2631         return last;
2632     }
2633
2634     return newLISTOP(type, 0, first, last);
2635 }
2636
2637 /* Constructors */
2638
2639 OP *
2640 Perl_newNULLLIST(pTHX)
2641 {
2642     return newOP(OP_STUB, 0);
2643 }
2644
2645 OP *
2646 Perl_force_list(pTHX_ OP *o)
2647 {
2648     if (!o || o->op_type != OP_LIST)
2649         o = newLISTOP(OP_LIST, 0, o, Nullop);
2650     op_null(o);
2651     return o;
2652 }
2653
2654 OP *
2655 Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2656 {
2657     LISTOP *listop;
2658
2659     NewOp(1101, listop, 1, LISTOP);
2660
2661     listop->op_type = type;
2662     listop->op_ppaddr = PL_ppaddr[type];
2663     if (first || last)
2664         flags |= OPf_KIDS;
2665     listop->op_flags = flags;
2666
2667     if (!last && first)
2668         last = first;
2669     else if (!first && last)
2670         first = last;
2671     else if (first)
2672         first->op_sibling = last;
2673     listop->op_first = first;
2674     listop->op_last = last;
2675     if (type == OP_LIST) {
2676         OP* pushop;
2677         pushop = newOP(OP_PUSHMARK, 0);
2678         pushop->op_sibling = first;
2679         listop->op_first = pushop;
2680         listop->op_flags |= OPf_KIDS;
2681         if (!last)
2682             listop->op_last = pushop;
2683     }
2684
2685     return (OP*)listop;
2686 }
2687
2688 OP *
2689 Perl_newOP(pTHX_ I32 type, I32 flags)
2690 {
2691     OP *o;
2692     NewOp(1101, o, 1, OP);
2693     o->op_type = type;
2694     o->op_ppaddr = PL_ppaddr[type];
2695     o->op_flags = flags;
2696
2697     o->op_next = o;
2698     o->op_private = 0 + (flags >> 8);
2699     if (PL_opargs[type] & OA_RETSCALAR)
2700         scalar(o);
2701     if (PL_opargs[type] & OA_TARGET)
2702         o->op_targ = pad_alloc(type, SVs_PADTMP);
2703     return CHECKOP(type, o);
2704 }
2705
2706 OP *
2707 Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
2708 {
2709     UNOP *unop;
2710
2711     if (!first)
2712         first = newOP(OP_STUB, 0);
2713     if (PL_opargs[type] & OA_MARK)
2714         first = force_list(first);
2715
2716     NewOp(1101, unop, 1, UNOP);
2717     unop->op_type = type;
2718     unop->op_ppaddr = PL_ppaddr[type];
2719     unop->op_first = first;
2720     unop->op_flags = flags | OPf_KIDS;
2721     unop->op_private = 1 | (flags >> 8);
2722     unop = (UNOP*) CHECKOP(type, unop);
2723     if (unop->op_next)
2724         return (OP*)unop;
2725
2726     return fold_constants((OP *) unop);
2727 }
2728
2729 OP *
2730 Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
2731 {
2732     BINOP *binop;
2733     NewOp(1101, binop, 1, BINOP);
2734
2735     if (!first)
2736         first = newOP(OP_NULL, 0);
2737
2738     binop->op_type = type;
2739     binop->op_ppaddr = PL_ppaddr[type];
2740     binop->op_first = first;
2741     binop->op_flags = flags | OPf_KIDS;
2742     if (!last) {
2743         last = first;
2744         binop->op_private = 1 | (flags >> 8);
2745     }
2746     else {
2747         binop->op_private = 2 | (flags >> 8);
2748         first->op_sibling = last;
2749     }
2750
2751     binop = (BINOP*)CHECKOP(type, binop);
2752     if (binop->op_next || binop->op_type != type)
2753         return (OP*)binop;
2754
2755     binop->op_last = binop->op_first->op_sibling;
2756
2757     return fold_constants((OP *)binop);
2758 }
2759
2760 static int
2761 uvcompare(const void *a, const void *b)
2762 {
2763     if (*((UV *)a) < (*(UV *)b))
2764         return -1;
2765     if (*((UV *)a) > (*(UV *)b))
2766         return 1;
2767     if (*((UV *)a+1) < (*(UV *)b+1))
2768         return -1;
2769     if (*((UV *)a+1) > (*(UV *)b+1))
2770         return 1;
2771     return 0;
2772 }
2773
2774 OP *
2775 Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
2776 {
2777     SV *tstr = ((SVOP*)expr)->op_sv;
2778     SV *rstr = ((SVOP*)repl)->op_sv;
2779     STRLEN tlen;
2780     STRLEN rlen;
2781     U8 *t = (U8*)SvPV(tstr, tlen);
2782     U8 *r = (U8*)SvPV(rstr, rlen);
2783     register I32 i;
2784     register I32 j;
2785     I32 del;
2786     I32 complement;
2787     I32 squash;
2788     I32 grows = 0;
2789     register short *tbl;
2790
2791     PL_hints |= HINT_BLOCK_SCOPE;
2792     complement  = o->op_private & OPpTRANS_COMPLEMENT;
2793     del         = o->op_private & OPpTRANS_DELETE;
2794     squash      = o->op_private & OPpTRANS_SQUASH;
2795
2796     if (SvUTF8(tstr))
2797         o->op_private |= OPpTRANS_FROM_UTF;
2798
2799     if (SvUTF8(rstr))
2800         o->op_private |= OPpTRANS_TO_UTF;
2801
2802     if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
2803         SV* listsv = newSVpvn("# comment\n",10);
2804         SV* transv = 0;
2805         U8* tend = t + tlen;
2806         U8* rend = r + rlen;
2807         STRLEN ulen;
2808         U32 tfirst = 1;
2809         U32 tlast = 0;
2810         I32 tdiff;
2811         U32 rfirst = 1;
2812         U32 rlast = 0;
2813         I32 rdiff;
2814         I32 diff;
2815         I32 none = 0;
2816         U32 max = 0;
2817         I32 bits;
2818         I32 havefinal = 0;
2819         U32 final = 0;
2820         I32 from_utf    = o->op_private & OPpTRANS_FROM_UTF;
2821         I32 to_utf      = o->op_private & OPpTRANS_TO_UTF;
2822         U8* tsave = NULL;
2823         U8* rsave = NULL;
2824
2825         if (!from_utf) {
2826             STRLEN len = tlen;
2827             tsave = t = bytes_to_utf8(t, &len);
2828             tend = t + len;
2829         }
2830         if (!to_utf && rlen) {
2831             STRLEN len = rlen;
2832             rsave = r = bytes_to_utf8(r, &len);
2833             rend = r + len;
2834         }
2835
2836 /* There are several snags with this code on EBCDIC:
2837    1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
2838    2. scan_const() in toke.c has encoded chars in native encoding which makes
2839       ranges at least in EBCDIC 0..255 range the bottom odd.
2840 */
2841
2842         if (complement) {
2843             U8 tmpbuf[UTF8_MAXLEN+1];
2844             UV *cp;
2845             UV nextmin = 0;
2846             New(1109, cp, 2*tlen, UV);
2847             i = 0;
2848             transv = newSVpvn("",0);
2849             while (t < tend) {
2850                 cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2851                 t += ulen;
2852                 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
2853                     t++;
2854                     cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
2855                     t += ulen;
2856                 }
2857                 else {
2858                  cp[2*i+1] = cp[2*i];
2859                 }
2860                 i++;
2861             }
2862             qsort(cp, i, 2*sizeof(UV), uvcompare);
2863             for (j = 0; j < i; j++) {
2864                 UV  val = cp[2*j];
2865                 diff = val - nextmin;
2866                 if (diff > 0) {
2867                     t = uvuni_to_utf8(tmpbuf,nextmin);
2868                     sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2869                     if (diff > 1) {
2870                         U8  range_mark = UTF_TO_NATIVE(0xff);
2871                         t = uvuni_to_utf8(tmpbuf, val - 1);
2872                         sv_catpvn(transv, (char *)&range_mark, 1);
2873                         sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2874                     }
2875                 }
2876                 val = cp[2*j+1];
2877                 if (val >= nextmin)
2878                     nextmin = val + 1;
2879             }
2880             t = uvuni_to_utf8(tmpbuf,nextmin);
2881             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2882             {
2883                 U8 range_mark = UTF_TO_NATIVE(0xff);
2884                 sv_catpvn(transv, (char *)&range_mark, 1);
2885             }
2886             t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
2887                                     UNICODE_ALLOW_SUPER);
2888             sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
2889             t = (U8*)SvPVX(transv);
2890             tlen = SvCUR(transv);
2891             tend = t + tlen;
2892             Safefree(cp);
2893         }
2894         else if (!rlen && !del) {
2895             r = t; rlen = tlen; rend = tend;
2896         }
2897         if (!squash) {
2898                 if ((!rlen && !del) || t == r ||
2899                     (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
2900                 {
2901                     o->op_private |= OPpTRANS_IDENTICAL;
2902                 }
2903         }
2904
2905         while (t < tend || tfirst <= tlast) {
2906             /* see if we need more "t" chars */
2907             if (tfirst > tlast) {
2908                 tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2909                 t += ulen;
2910                 if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {    /* illegal utf8 val indicates range */
2911                     t++;
2912                     tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
2913                     t += ulen;
2914                 }
2915                 else
2916                     tlast = tfirst;
2917             }
2918
2919             /* now see if we need more "r" chars */
2920             if (rfirst > rlast) {
2921                 if (r < rend) {
2922                     rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2923                     r += ulen;
2924                     if (r < rend && NATIVE_TO_UTF(*r) == 0xff) {        /* illegal utf8 val indicates range */
2925                         r++;
2926                         rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
2927                         r += ulen;
2928                     }
2929                     else
2930                         rlast = rfirst;
2931                 }
2932                 else {
2933                     if (!havefinal++)
2934                         final = rlast;
2935                     rfirst = rlast = 0xffffffff;
2936                 }
2937             }
2938
2939             /* now see which range will peter our first, if either. */
2940             tdiff = tlast - tfirst;
2941             rdiff = rlast - rfirst;
2942
2943             if (tdiff <= rdiff)
2944                 diff = tdiff;
2945             else
2946                 diff = rdiff;
2947
2948             if (rfirst == 0xffffffff) {
2949                 diff = tdiff;   /* oops, pretend rdiff is infinite */
2950                 if (diff > 0)
2951                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n",
2952                                    (long)tfirst, (long)tlast);
2953                 else
2954                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst);
2955             }
2956             else {
2957                 if (diff > 0)
2958                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n",
2959                                    (long)tfirst, (long)(tfirst + diff),
2960                                    (long)rfirst);
2961                 else
2962                     Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n",
2963                                    (long)tfirst, (long)rfirst);
2964
2965                 if (rfirst + diff > max)
2966                     max = rfirst + diff;
2967                 if (!grows)
2968                     grows = (tfirst < rfirst &&
2969                              UNISKIP(tfirst) < UNISKIP(rfirst + diff));
2970                 rfirst += diff + 1;
2971             }
2972             tfirst += diff + 1;
2973         }
2974
2975         none = ++max;
2976         if (del)
2977             del = ++max;
2978
2979         if (max > 0xffff)
2980             bits = 32;
2981         else if (max > 0xff)
2982             bits = 16;
2983         else
2984             bits = 8;
2985
2986         Safefree(cPVOPo->op_pv);
2987         cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
2988         SvREFCNT_dec(listsv);
2989         if (transv)
2990             SvREFCNT_dec(transv);
2991
2992         if (!del && havefinal && rlen)
2993             (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
2994                            newSVuv((UV)final), 0);
2995
2996         if (grows)
2997             o->op_private |= OPpTRANS_GROWS;
2998
2999         if (tsave)
3000             Safefree(tsave);
3001         if (rsave)
3002             Safefree(rsave);
3003
3004         op_free(expr);
3005         op_free(repl);
3006         return o;
3007     }
3008
3009     tbl = (short*)cPVOPo->op_pv;
3010     if (complement) {
3011         Zero(tbl, 256, short);
3012         for (i = 0; i < tlen; i++)
3013             tbl[t[i]] = -1;
3014         for (i = 0, j = 0; i < 256; i++) {
3015             if (!tbl[i]) {
3016                 if (j >= rlen) {
3017                     if (del)
3018                         tbl[i] = -2;
3019                     else if (rlen)
3020                         tbl[i] = r[j-1];
3021                     else
3022                         tbl[i] = i;
3023                 }
3024                 else {
3025                     if (i < 128 && r[j] >= 128)
3026                         grows = 1;
3027                     tbl[i] = r[j++];
3028                 }
3029             }
3030         }
3031         if (!del) {
3032             if (!rlen) {
3033                 j = rlen;
3034                 if (!squash)
3035                     o->op_private |= OPpTRANS_IDENTICAL;
3036             }
3037             else if (j >= rlen)
3038                 j = rlen - 1;
3039             else
3040                 cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
3041             tbl[0x100] = rlen - j;
3042             for (i=0; i < rlen - j; i++)
3043                 tbl[0x101+i] = r[j+i];
3044         }
3045     }
3046     else {
3047         if (!rlen && !del) {
3048             r = t; rlen = tlen;
3049             if (!squash)
3050                 o->op_private |= OPpTRANS_IDENTICAL;
3051         }
3052         else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
3053             o->op_private |= OPpTRANS_IDENTICAL;
3054         }
3055         for (i = 0; i < 256; i++)
3056             tbl[i] = -1;
3057         for (i = 0, j = 0; i < tlen; i++,j++) {
3058             if (j >= rlen) {
3059                 if (del) {
3060                     if (tbl[t[i]] == -1)
3061                         tbl[t[i]] = -2;
3062                     continue;
3063                 }
3064                 --j;
3065             }
3066             if (tbl[t[i]] == -1) {
3067                 if (t[i] < 128 && r[j] >= 128)
3068                     grows = 1;
3069                 tbl[t[i]] = r[j];
3070             }
3071         }
3072     }
3073     if (grows)
3074         o->op_private |= OPpTRANS_GROWS;
3075     op_free(expr);
3076     op_free(repl);
3077
3078     return o;
3079 }
3080
3081 OP *
3082 Perl_newPMOP(pTHX_ I32 type, I32 flags)
3083 {
3084     PMOP *pmop;
3085
3086     NewOp(1101, pmop, 1, PMOP);
3087     pmop->op_type = type;
3088     pmop->op_ppaddr = PL_ppaddr[type];
3089     pmop->op_flags = flags;
3090     pmop->op_private = 0 | (flags >> 8);
3091
3092     if (PL_hints & HINT_RE_TAINT)
3093         pmop->op_pmpermflags |= PMf_RETAINT;
3094     if (PL_hints & HINT_LOCALE)
3095         pmop->op_pmpermflags |= PMf_LOCALE;
3096     pmop->op_pmflags = pmop->op_pmpermflags;
3097
3098 #ifdef USE_ITHREADS
3099     {
3100         SV* repointer;
3101         if(av_len((AV*) PL_regex_pad[0]) > -1) {
3102             repointer = av_pop((AV*)PL_regex_pad[0]);
3103             pmop->op_pmoffset = SvIV(repointer);
3104             SvREPADTMP_off(repointer);
3105             sv_setiv(repointer,0);
3106         } else {
3107             repointer = newSViv(0);
3108             av_push(PL_regex_padav,SvREFCNT_inc(repointer));
3109             pmop->op_pmoffset = av_len(PL_regex_padav);
3110             PL_regex_pad = AvARRAY(PL_regex_padav);
3111         }
3112     }
3113 #endif
3114
3115         /* link into pm list */
3116     if (type != OP_TRANS && PL_curstash) {
3117         pmop->op_pmnext = HvPMROOT(PL_curstash);
3118         HvPMROOT(PL_curstash) = pmop;
3119         PmopSTASH_set(pmop,PL_curstash);
3120     }
3121
3122     return (OP*)pmop;
3123 }
3124
3125 OP *
3126 Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
3127 {
3128     PMOP *pm;
3129     LOGOP *rcop;
3130     I32 repl_has_vars = 0;
3131
3132     if (o->op_type == OP_TRANS)
3133         return pmtrans(o, expr, repl);
3134
3135     PL_hints |= HINT_BLOCK_SCOPE;
3136     pm = (PMOP*)o;
3137
3138     if (expr->op_type == OP_CONST) {
3139         STRLEN plen;
3140         SV *pat = ((SVOP*)expr)->op_sv;
3141         char *p = SvPV(pat, plen);
3142         if ((o->op_flags & OPf_SPECIAL) && strEQ(p, " ")) {
3143             sv_setpvn(pat, "\\s+", 3);
3144             p = SvPV(pat, plen);
3145             pm->op_pmflags |= PMf_SKIPWHITE;
3146         }
3147         if (DO_UTF8(pat))
3148             pm->op_pmdynflags |= PMdf_UTF8;
3149         PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
3150         if (strEQ("\\s+", PM_GETRE(pm)->precomp))
3151             pm->op_pmflags |= PMf_WHITE;
3152         op_free(expr);
3153     }
3154     else {
3155         if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
3156             expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
3157                             ? OP_REGCRESET
3158                             : OP_REGCMAYBE),0,expr);
3159
3160         NewOp(1101, rcop, 1, LOGOP);
3161         rcop->op_type = OP_REGCOMP;
3162         rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP];
3163         rcop->op_first = scalar(expr);
3164         rcop->op_flags |= ((PL_hints & HINT_RE_EVAL)
3165                            ? (OPf_SPECIAL | OPf_KIDS)
3166                            : OPf_KIDS);
3167         rcop->op_private = 1;
3168         rcop->op_other = o;
3169
3170         /* establish postfix order */
3171         if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
3172             LINKLIST(expr);
3173             rcop->op_next = expr;
3174             ((UNOP*)expr)->op_first->op_next = (OP*)rcop;
3175         }
3176         else {
3177             rcop->op_next = LINKLIST(expr);
3178             expr->op_next = (OP*)rcop;
3179         }
3180
3181         prepend_elem(o->op_type, scalar((OP*)rcop), o);
3182     }
3183
3184     if (repl) {
3185         OP *curop;
3186         if (pm->op_pmflags & PMf_EVAL) {
3187             curop = 0;
3188             if (CopLINE(PL_curcop) < PL_multi_end)
3189                 CopLINE_set(PL_curcop, PL_multi_end);
3190         }
3191 #ifdef USE_5005THREADS
3192         else if (repl->op_type == OP_THREADSV
3193                  && strchr("&`'123456789+",
3194                            PL_threadsv_names[repl->op_targ]))
3195         {
3196             curop = 0;
3197         }
3198 #endif /* USE_5005THREADS */
3199         else if (repl->op_type == OP_CONST)
3200             curop = repl;
3201         else {
3202             OP *lastop = 0;
3203             for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
3204                 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3205 #ifdef USE_5005THREADS
3206                     if (curop->op_type == OP_THREADSV) {
3207                         repl_has_vars = 1;
3208                         if (strchr("&`'123456789+", curop->op_private))
3209                             break;
3210                     }
3211 #else
3212                     if (curop->op_type == OP_GV) {
3213                         GV *gv = cGVOPx_gv(curop);
3214                         repl_has_vars = 1;
3215                         if (strchr("&`'123456789+", *GvENAME(gv)))
3216                             break;
3217                     }
3218 #endif /* USE_5005THREADS */
3219                     else if (curop->op_type == OP_RV2CV)
3220                         break;
3221                     else if (curop->op_type == OP_RV2SV ||
3222                              curop->op_type == OP_RV2AV ||
3223                              curop->op_type == OP_RV2HV ||
3224                              curop->op_type == OP_RV2GV) {
3225                         if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
3226                             break;
3227                     }
3228                     else if (curop->op_type == OP_PADSV ||
3229                              curop->op_type == OP_PADAV ||
3230                              curop->op_type == OP_PADHV ||
3231                              curop->op_type == OP_PADANY) {
3232                         repl_has_vars = 1;
3233                     }
3234                     else if (curop->op_type == OP_PUSHRE)
3235                         ; /* Okay here, dangerous in newASSIGNOP */
3236                     else
3237                         break;
3238                 }
3239                 lastop = curop;
3240             }
3241         }
3242         if (curop == repl
3243             && !(repl_has_vars
3244                  && (!PM_GETRE(pm)
3245                      || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
3246             pm->op_pmflags |= PMf_CONST;        /* const for long enough */
3247             pm->op_pmpermflags |= PMf_CONST;    /* const for long enough */
3248             prepend_elem(o->op_type, scalar(repl), o);
3249         }
3250         else {
3251             if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
3252                 pm->op_pmflags |= PMf_MAYBE_CONST;
3253                 pm->op_pmpermflags |= PMf_MAYBE_CONST;
3254             }
3255             NewOp(1101, rcop, 1, LOGOP);
3256             rcop->op_type = OP_SUBSTCONT;
3257             rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
3258             rcop->op_first = scalar(repl);
3259             rcop->op_flags |= OPf_KIDS;
3260             rcop->op_private = 1;
3261             rcop->op_other = o;
3262
3263             /* establish postfix order */
3264             rcop->op_next = LINKLIST(repl);
3265             repl->op_next = (OP*)rcop;
3266
3267             pm->op_pmreplroot = scalar((OP*)rcop);
3268             pm->op_pmreplstart = LINKLIST(rcop);
3269             rcop->op_next = 0;
3270         }
3271     }
3272
3273     return (OP*)pm;
3274 }
3275
3276 OP *
3277 Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
3278 {
3279     SVOP *svop;
3280     NewOp(1101, svop, 1, SVOP);
3281     svop->op_type = type;
3282     svop->op_ppaddr = PL_ppaddr[type];
3283     svop->op_sv = sv;
3284     svop->op_next = (OP*)svop;
3285     svop->op_flags = flags;
3286     if (PL_opargs[type] & OA_RETSCALAR)
3287         scalar((OP*)svop);
3288     if (PL_opargs[type] & OA_TARGET)
3289         svop->op_targ = pad_alloc(type, SVs_PADTMP);
3290     return CHECKOP(type, svop);
3291 }
3292
3293 OP *
3294 Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
3295 {
3296     PADOP *padop;
3297     NewOp(1101, padop, 1, PADOP);
3298     padop->op_type = type;
3299     padop->op_ppaddr = PL_ppaddr[type];
3300     padop->op_padix = pad_alloc(type, SVs_PADTMP);
3301     SvREFCNT_dec(PL_curpad[padop->op_padix]);
3302     PL_curpad[padop->op_padix] = sv;
3303     SvPADTMP_on(sv);
3304     padop->op_next = (OP*)padop;
3305     padop->op_flags = flags;
3306     if (PL_opargs[type] & OA_RETSCALAR)
3307         scalar((OP*)padop);
3308     if (PL_opargs[type] & OA_TARGET)
3309         padop->op_targ = pad_alloc(type, SVs_PADTMP);
3310     return CHECKOP(type, padop);
3311 }
3312
3313 OP *
3314 Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
3315 {
3316 #ifdef USE_ITHREADS
3317     GvIN_PAD_on(gv);
3318     return newPADOP(type, flags, SvREFCNT_inc(gv));
3319 #else
3320     return newSVOP(type, flags, SvREFCNT_inc(gv));
3321 #endif
3322 }
3323
3324 OP *
3325 Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
3326 {
3327     PVOP *pvop;
3328     NewOp(1101, pvop, 1, PVOP);
3329     pvop->op_type = type;
3330     pvop->op_ppaddr = PL_ppaddr[type];
3331     pvop->op_pv = pv;
3332     pvop->op_next = (OP*)pvop;
3333     pvop->op_flags = flags;
3334     if (PL_opargs[type] & OA_RETSCALAR)
3335         scalar((OP*)pvop);
3336     if (PL_opargs[type] & OA_TARGET)
3337         pvop->op_targ = pad_alloc(type, SVs_PADTMP);
3338     return CHECKOP(type, pvop);
3339 }
3340
3341 void
3342 Perl_package(pTHX_ OP *o)
3343 {
3344     SV *sv;
3345
3346     save_hptr(&PL_curstash);
3347     save_item(PL_curstname);
3348     if (o) {
3349         STRLEN len;
3350         char *name;
3351         sv = cSVOPo->op_sv;
3352         name = SvPV(sv, len);
3353         PL_curstash = gv_stashpvn(name,len,TRUE);
3354         sv_setpvn(PL_curstname, name, len);
3355         op_free(o);
3356     }
3357     else {
3358         deprecate_old("\"package\" with no arguments");
3359         sv_setpv(PL_curstname,"<none>");
3360         PL_curstash = Nullhv;
3361     }
3362     PL_hints |= HINT_BLOCK_SCOPE;
3363     PL_copline = NOLINE;
3364     PL_expect = XSTATE;
3365 }
3366
3367 void
3368 Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
3369 {
3370     OP *pack;
3371     OP *imop;
3372     OP *veop;
3373     char *packname = Nullch;
3374     STRLEN packlen = 0;
3375     SV *packsv;
3376
3377     if (id->op_type != OP_CONST)
3378         Perl_croak(aTHX_ "Module name must be constant");
3379
3380     veop = Nullop;
3381
3382     if (version != Nullop) {
3383         SV *vesv = ((SVOP*)version)->op_sv;
3384
3385         if (arg == Nullop && !SvNIOKp(vesv)) {
3386             arg = version;
3387         }
3388         else {
3389             OP *pack;
3390             SV *meth;
3391
3392             if (version->op_type != OP_CONST || !SvNIOKp(vesv))
3393                 Perl_croak(aTHX_ "Version number must be constant number");
3394
3395             /* Make copy of id so we don't free it twice */
3396             pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3397
3398             /* Fake up a method call to VERSION */
3399             meth = newSVpvn("VERSION",7);
3400             sv_upgrade(meth, SVt_PVIV);
3401             (void)SvIOK_on(meth);
3402             PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3403             veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3404                             append_elem(OP_LIST,
3405                                         prepend_elem(OP_LIST, pack, list(version)),
3406                                         newSVOP(OP_METHOD_NAMED, 0, meth)));
3407         }
3408     }
3409
3410     /* Fake up an import/unimport */
3411     if (arg && arg->op_type == OP_STUB)
3412         imop = arg;             /* no import on explicit () */
3413     else if (SvNIOKp(((SVOP*)id)->op_sv)) {
3414         imop = Nullop;          /* use 5.0; */
3415     }
3416     else {
3417         SV *meth;
3418
3419         /* Make copy of id so we don't free it twice */
3420         pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
3421
3422         /* Fake up a method call to import/unimport */
3423         meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);;
3424         (void)SvUPGRADE(meth, SVt_PVIV);
3425         (void)SvIOK_on(meth);
3426         PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
3427         imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
3428                        append_elem(OP_LIST,
3429                                    prepend_elem(OP_LIST, pack, list(arg)),
3430                                    newSVOP(OP_METHOD_NAMED, 0, meth)));
3431     }
3432
3433     if (ckWARN(WARN_MISC) &&
3434         imop && (imop != arg) && /* no warning on use 5.0; or explicit () */
3435         SvPOK(packsv = ((SVOP*)id)->op_sv))
3436     {
3437         /* BEGIN will free the ops, so we need to make a copy */
3438         packlen = SvCUR(packsv);
3439         packname = savepvn(SvPVX(packsv), packlen);
3440     }
3441
3442     /* Fake up the BEGIN {}, which does its thing immediately. */
3443     newATTRSUB(floor,
3444         newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
3445         Nullop,
3446         Nullop,
3447         append_elem(OP_LINESEQ,
3448             append_elem(OP_LINESEQ,
3449                 newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, id)),
3450                 newSTATEOP(0, Nullch, veop)),
3451             newSTATEOP(0, Nullch, imop) ));
3452
3453     if (packname) {
3454          /* The "did you use incorrect case?" warning used to be here.
3455           * The problem is that on case-insensitive filesystems one
3456           * might get false positives for "use" (and "require"):
3457           * "use Strict" or "require CARP" will work.  This causes
3458           * portability problems for the script: in case-strict
3459           * filesystems the script will stop working.
3460           *
3461           * The "incorrect case" warning checked whether "use Foo"
3462           * imported "Foo" to your namespace, but that is wrong, too:
3463           * there is no requirement nor promise in the language that
3464           * a Foo.pm should or would contain anything in package "Foo".
3465           *
3466           * There is very little Configure-wise that can be done, either:
3467           * the case-sensitivity of the build filesystem of Perl does not
3468           * help in guessing the case-sensitivity of the runtime environment.
3469           */
3470         safefree(packname);
3471     }
3472
3473     PL_hints |= HINT_BLOCK_SCOPE;
3474     PL_copline = NOLINE;
3475     PL_expect = XSTATE;
3476 }
3477
3478 /*
3479 =head1 Embedding Functions
3480
3481 =for apidoc load_module
3482
3483 Loads the module whose name is pointed to by the string part of name.
3484 Note that the actual module name, not its filename, should be given.
3485 Eg, "Foo::Bar" instead of "Foo/Bar.pm".  flags can be any of
3486 PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
3487 (or 0 for no flags). ver, if specified, provides version semantics
3488 similar to C<use Foo::Bar VERSION>.  The optional trailing SV*
3489 arguments can be used to specify arguments to the module's import()
3490 method, similar to C<use Foo::Bar VERSION LIST>.
3491
3492 =cut */
3493
3494 void
3495 Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
3496 {
3497     va_list args;
3498     va_start(args, ver);
3499     vload_module(flags, name, ver, &args);
3500     va_end(args);
3501 }
3502
3503 #ifdef PERL_IMPLICIT_CONTEXT
3504 void
3505 Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
3506 {
3507     dTHX;
3508     va_list args;
3509     va_start(args, ver);
3510     vload_module(flags, name, ver, &args);
3511     va_end(args);
3512 }
3513 #endif
3514
3515 void
3516 Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
3517 {
3518     OP *modname, *veop, *imop;
3519
3520     modname = newSVOP(OP_CONST, 0, name);
3521     modname->op_private |= OPpCONST_BARE;
3522     if (ver) {
3523         veop = newSVOP(OP_CONST, 0, ver);
3524     }
3525     else
3526         veop = Nullop;
3527     if (flags & PERL_LOADMOD_NOIMPORT) {
3528         imop = sawparens(newNULLLIST());
3529     }
3530     else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3531         imop = va_arg(*args, OP*);
3532     }
3533     else {
3534         SV *sv;
3535         imop = Nullop;
3536         sv = va_arg(*args, SV*);
3537         while (sv) {
3538             imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3539             sv = va_arg(*args, SV*);
3540         }
3541     }
3542     {
3543         line_t ocopline = PL_copline;
3544         int oexpect = PL_expect;
3545
3546         utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3547                 veop, modname, imop);
3548         PL_expect = oexpect;
3549         PL_copline = ocopline;
3550     }
3551 }
3552
3553 OP *
3554 Perl_dofile(pTHX_ OP *term)
3555 {
3556     OP *doop;
3557     GV *gv;
3558
3559     gv = gv_fetchpv("do", FALSE, SVt_PVCV);
3560     if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
3561         gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
3562
3563     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
3564         doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
3565                                append_elem(OP_LIST, term,
3566                                            scalar(newUNOP(OP_RV2CV, 0,
3567                                                           newGVOP(OP_GV, 0,
3568                                                                   gv))))));
3569     }
3570     else {
3571         doop = newUNOP(OP_DOFILE, 0, scalar(term));
3572     }
3573     return doop;
3574 }
3575
3576 OP *
3577 Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
3578 {
3579     return newBINOP(OP_LSLICE, flags,
3580             list(force_list(subscript)),
3581             list(force_list(listval)) );
3582 }
3583
3584 STATIC I32
3585 S_list_assignment(pTHX_ register OP *o)
3586 {
3587     if (!o)
3588         return TRUE;
3589
3590     if (o->op_type == OP_NULL && o->op_flags & OPf_KIDS)
3591         o = cUNOPo->op_first;
3592
3593     if (o->op_type == OP_COND_EXPR) {
3594         I32 t = list_assignment(cLOGOPo->op_first->op_sibling);
3595         I32 f = list_assignment(cLOGOPo->op_first->op_sibling->op_sibling);
3596
3597         if (t && f)
3598             return TRUE;
3599         if (t || f)
3600             yyerror("Assignment to both a list and a scalar");
3601         return FALSE;
3602     }
3603
3604     if (o->op_type == OP_LIST &&
3605         (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
3606         o->op_private & OPpLVAL_INTRO)
3607         return FALSE;
3608
3609     if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
3610         o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
3611         o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
3612         return TRUE;
3613
3614     if (o->op_type == OP_PADAV || o->op_type == OP_PADHV)
3615         return TRUE;
3616
3617     if (o->op_type == OP_RV2SV)
3618         return FALSE;
3619
3620     return FALSE;
3621 }
3622
3623 OP *
3624 Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
3625 {
3626     OP *o;
3627
3628     if (optype) {
3629         if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN) {
3630             return newLOGOP(optype, 0,
3631                 mod(scalar(left), optype),
3632                 newUNOP(OP_SASSIGN, 0, scalar(right)));
3633         }
3634         else {
3635             return newBINOP(optype, OPf_STACKED,
3636                 mod(scalar(left), optype), scalar(right));
3637         }
3638     }
3639
3640     if (list_assignment(left)) {
3641         OP *curop;
3642
3643         PL_modcount = 0;
3644         PL_eval_start = right;  /* Grandfathering $[ assignment here.  Bletch.*/
3645         left = mod(left, OP_AASSIGN);
3646         if (PL_eval_start)
3647             PL_eval_start = 0;
3648         else {
3649             op_free(left);
3650             op_free(right);
3651             return Nullop;
3652         }
3653         curop = list(force_list(left));
3654         o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
3655         o->op_private = 0 | (flags >> 8);
3656         for (curop = ((LISTOP*)curop)->op_first;
3657              curop; curop = curop->op_sibling)
3658         {
3659             if (curop->op_type == OP_RV2HV &&
3660                 ((UNOP*)curop)->op_first->op_type != OP_GV) {
3661                 o->op_private |= OPpASSIGN_HASH;
3662                 break;
3663             }
3664         }
3665         if (!(left->op_private & OPpLVAL_INTRO)) {
3666             OP *lastop = o;
3667             PL_generation++;
3668             for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
3669                 if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
3670                     if (curop->op_type == OP_GV) {
3671                         GV *gv = cGVOPx_gv(curop);
3672                         if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3673                             break;
3674                         SvCUR(gv) = PL_generation;
3675                     }
3676                     else if (curop->op_type == OP_PADSV ||
3677                              curop->op_type == OP_PADAV ||
3678                              curop->op_type == OP_PADHV ||
3679                              curop->op_type == OP_PADANY) {
3680                         SV **svp = AvARRAY(PL_comppad_name);
3681                         SV *sv = svp[curop->op_targ];
3682                         if (SvCUR(sv) == PL_generation)
3683                             break;
3684                         SvCUR(sv) = PL_generation;      /* (SvCUR not used any more) */
3685                     }
3686                     else if (curop->op_type == OP_RV2CV)
3687                         break;
3688                     else if (curop->op_type == OP_RV2SV ||
3689                              curop->op_type == OP_RV2AV ||
3690                              curop->op_type == OP_RV2HV ||
3691                              curop->op_type == OP_RV2GV) {
3692                         if (lastop->op_type != OP_GV)   /* funny deref? */
3693                             break;
3694                     }
3695                     else if (curop->op_type == OP_PUSHRE) {
3696                         if (((PMOP*)curop)->op_pmreplroot) {
3697 #ifdef USE_ITHREADS
3698                             GV *gv = (GV*)PL_curpad[INT2PTR(PADOFFSET,((PMOP*)curop)->op_pmreplroot)];
3699 #else
3700                             GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
3701 #endif
3702                             if (gv == PL_defgv || SvCUR(gv) == PL_generation)
3703                                 break;
3704                             SvCUR(gv) = PL_generation;
3705                         }
3706                     }
3707                     else
3708                         break;
3709                 }
3710                 lastop = curop;
3711             }
3712             if (curop != o)
3713                 o->op_private |= OPpASSIGN_COMMON;
3714         }
3715         if (right && right->op_type == OP_SPLIT) {
3716             OP* tmpop;
3717             if ((tmpop = ((LISTOP*)right)->op_first) &&
3718                 tmpop->op_type == OP_PUSHRE)
3719             {
3720                 PMOP *pm = (PMOP*)tmpop;
3721                 if (left->op_type == OP_RV2AV &&
3722                     !(left->op_private & OPpLVAL_INTRO) &&
3723                     !(o->op_private & OPpASSIGN_COMMON) )
3724                 {
3725                     tmpop = ((UNOP*)left)->op_first;
3726                     if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
3727 #ifdef USE_ITHREADS
3728                         pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
3729                         cPADOPx(tmpop)->op_padix = 0;   /* steal it */
3730 #else
3731                         pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
3732                         cSVOPx(tmpop)->op_sv = Nullsv;  /* steal it */
3733 #endif
3734                         pm->op_pmflags |= PMf_ONCE;
3735                         tmpop = cUNOPo->op_first;       /* to list (nulled) */
3736                         tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
3737                         tmpop->op_sibling = Nullop;     /* don't free split */
3738                         right->op_next = tmpop->op_next;  /* fix starting loc */
3739                         op_free(o);                     /* blow off assign */
3740                         right->op_flags &= ~OPf_WANT;
3741                                 /* "I don't know and I don't care." */
3742                         return right;
3743                     }
3744                 }
3745                 else {
3746                    if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
3747                       ((LISTOP*)right)->op_last->op_type == OP_CONST)
3748                     {
3749                         SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
3750                         if (SvIVX(sv) == 0)
3751                             sv_setiv(sv, PL_modcount+1);
3752                     }
3753                 }
3754             }
3755         }
3756         return o;
3757     }
3758     if (!right)
3759         right = newOP(OP_UNDEF, 0);
3760     if (right->op_type == OP_READLINE) {
3761         right->op_flags |= OPf_STACKED;
3762         return newBINOP(OP_NULL, flags, mod(scalar(left), OP_SASSIGN), scalar(right));
3763     }
3764     else {
3765         PL_eval_start = right;  /* Grandfathering $[ assignment here.  Bletch.*/
3766         o = newBINOP(OP_SASSIGN, flags,
3767             scalar(right), mod(scalar(left), OP_SASSIGN) );
3768         if (PL_eval_start)
3769             PL_eval_start = 0;
3770         else {
3771             op_free(o);
3772             return Nullop;
3773         }
3774     }
3775     return o;
3776 }
3777
3778 OP *
3779 Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
3780 {
3781     U32 seq = intro_my();
3782     register COP *cop;
3783
3784     NewOp(1101, cop, 1, COP);
3785     if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) {
3786         cop->op_type = OP_DBSTATE;
3787         cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ];
3788     }
3789     else {
3790         cop->op_type = OP_NEXTSTATE;
3791         cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
3792     }
3793     cop->op_flags = flags;
3794     cop->op_private = (PL_hints & HINT_PRIVATE_MASK);
3795 #ifdef NATIVE_HINTS
3796     cop->op_private |= NATIVE_HINTS;
3797 #endif
3798     PL_compiling.op_private = cop->op_private;
3799     cop->op_next = (OP*)cop;
3800
3801     if (label) {
3802         cop->cop_label = label;
3803         PL_hints |= HINT_BLOCK_SCOPE;
3804     }
3805     cop->cop_seq = seq;
3806     cop->cop_arybase = PL_curcop->cop_arybase;
3807     if (specialWARN(PL_curcop->cop_warnings))
3808         cop->cop_warnings = PL_curcop->cop_warnings ;
3809     else
3810         cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
3811     if (specialCopIO(PL_curcop->cop_io))
3812         cop->cop_io = PL_curcop->cop_io;
3813     else
3814         cop->cop_io = newSVsv(PL_curcop->cop_io) ;
3815
3816
3817     if (PL_copline == NOLINE)
3818         CopLINE_set(cop, CopLINE(PL_curcop));
3819     else {
3820         CopLINE_set(cop, PL_copline);
3821         PL_copline = NOLINE;
3822     }
3823 #ifdef USE_ITHREADS
3824     CopFILE_set(cop, CopFILE(PL_curcop));       /* XXX share in a pvtable? */
3825 #else
3826     CopFILEGV_set(cop, CopFILEGV(PL_curcop));
3827 #endif
3828     CopSTASH_set(cop, PL_curstash);
3829
3830     if (PERLDB_LINE && PL_curstash != PL_debstash) {
3831         SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
3832         if (svp && *svp != &PL_sv_undef ) {
3833            (void)SvIOK_on(*svp);
3834             SvIVX(*svp) = PTR2IV(cop);
3835         }
3836     }
3837
3838     return prepend_elem(OP_LINESEQ, (OP*)cop, o);
3839 }
3840
3841 /* "Introduce" my variables to visible status. */
3842 U32
3843 Perl_intro_my(pTHX)
3844 {
3845     SV **svp;
3846     SV *sv;
3847     I32 i;
3848
3849     if (! PL_min_intro_pending)
3850         return PL_cop_seqmax;
3851
3852     svp = AvARRAY(PL_comppad_name);
3853     for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
3854         if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) {
3855             SvIVX(sv) = PAD_MAX;        /* Don't know scope end yet. */
3856             SvNVX(sv) = (NV)PL_cop_seqmax;
3857         }
3858     }
3859     PL_min_intro_pending = 0;
3860     PL_comppad_name_fill = PL_max_intro_pending;        /* Needn't search higher */
3861     return PL_cop_seqmax++;
3862 }
3863
3864 OP *
3865 Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
3866 {
3867     return new_logop(type, flags, &first, &other);
3868 }
3869
3870 STATIC OP *
3871 S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
3872 {
3873     LOGOP *logop;
3874     OP *o;
3875     OP *first = *firstp;
3876     OP *other = *otherp;
3877
3878     if (type == OP_XOR)         /* Not short circuit, but here by precedence. */
3879         return newBINOP(type, flags, scalar(first), scalar(other));
3880
3881     scalarboolean(first);
3882     /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
3883     if (first->op_type == OP_NOT && (first->op_flags & OPf_SPECIAL)) {
3884         if (type == OP_AND || type == OP_OR) {
3885             if (type == OP_AND)
3886                 type = OP_OR;
3887             else
3888                 type = OP_AND;
3889             o = first;
3890             first = *firstp = cUNOPo->op_first;
3891             if (o->op_next)
3892                 first->op_next = o->op_next;
3893             cUNOPo->op_first = Nullop;
3894             op_free(o);
3895         }
3896     }
3897     if (first->op_type == OP_CONST) {
3898         if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
3899             Perl_warner(aTHX_ WARN_BAREWORD, "Bareword found in conditional");
3900         if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
3901             op_free(first);
3902             *firstp = Nullop;
3903             return other;
3904         }
3905         else {
3906             op_free(other);
3907             *otherp = Nullop;
3908             return first;
3909         }
3910     }
3911     else if (first->op_type == OP_WANTARRAY) {
3912         if (type == OP_AND)
3913             list(other);
3914         else
3915             scalar(other);
3916     }
3917     else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
3918         OP *k1 = ((UNOP*)first)->op_first;
3919         OP *k2 = k1->op_sibling;
3920         OPCODE warnop = 0;
3921         switch (first->op_type)
3922         {
3923         case OP_NULL:
3924             if (k2 && k2->op_type == OP_READLINE
3925                   && (k2->op_flags & OPf_STACKED)
3926                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
3927             {
3928                 warnop = k2->op_type;
3929             }
3930             break;
3931
3932         case OP_SASSIGN:
3933             if (k1->op_type == OP_READDIR
3934                   || k1->op_type == OP_GLOB
3935                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
3936                   || k1->op_type == OP_EACH)
3937             {
3938                 warnop = ((k1->op_type == OP_NULL)
3939                           ? k1->op_targ : k1->op_type);
3940             }
3941             break;
3942         }
3943         if (warnop) {
3944             line_t oldline = CopLINE(PL_curcop);
3945             CopLINE_set(PL_curcop, PL_copline);
3946             Perl_warner(aTHX_ WARN_MISC,
3947                  "Value of %s%s can be \"0\"; test with defined()",
3948                  PL_op_desc[warnop],
3949                  ((warnop == OP_READLINE || warnop == OP_GLOB)
3950                   ? " construct" : "() operator"));
3951             CopLINE_set(PL_curcop, oldline);
3952         }
3953     }
3954
3955     if (!other)
3956         return first;
3957
3958     if (type == OP_ANDASSIGN || type == OP_ORASSIGN)
3959         other->op_private |= OPpASSIGN_BACKWARDS;  /* other is an OP_SASSIGN */
3960
3961     NewOp(1101, logop, 1, LOGOP);
3962
3963     logop->op_type = type;
3964     logop->op_ppaddr = PL_ppaddr[type];
3965     logop->op_first = first;
3966     logop->op_flags = flags | OPf_KIDS;
3967     logop->op_other = LINKLIST(other);
3968     logop->op_private = 1 | (flags >> 8);
3969
3970     /* establish postfix order */
3971     logop->op_next = LINKLIST(first);
3972     first->op_next = (OP*)logop;
3973     first->op_sibling = other;
3974
3975     o = newUNOP(OP_NULL, 0, (OP*)logop);
3976     other->op_next = o;
3977
3978     return o;
3979 }
3980
3981 OP *
3982 Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
3983 {
3984     LOGOP *logop;
3985     OP *start;
3986     OP *o;
3987
3988     if (!falseop)
3989         return newLOGOP(OP_AND, 0, first, trueop);
3990     if (!trueop)
3991         return newLOGOP(OP_OR, 0, first, falseop);
3992
3993     scalarboolean(first);
3994     if (first->op_type == OP_CONST) {
3995         if (SvTRUE(((SVOP*)first)->op_sv)) {
3996             op_free(first);
3997             op_free(falseop);
3998             return trueop;
3999         }
4000         else {
4001             op_free(first);
4002             op_free(trueop);
4003             return falseop;
4004         }
4005     }
4006     else if (first->op_type == OP_WANTARRAY) {
4007         list(trueop);
4008         scalar(falseop);
4009     }
4010     NewOp(1101, logop, 1, LOGOP);
4011     logop->op_type = OP_COND_EXPR;
4012     logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
4013     logop->op_first = first;
4014     logop->op_flags = flags | OPf_KIDS;
4015     logop->op_private = 1 | (flags >> 8);
4016     logop->op_other = LINKLIST(trueop);
4017     logop->op_next = LINKLIST(falseop);
4018
4019
4020     /* establish postfix order */
4021     start = LINKLIST(first);
4022     first->op_next = (OP*)logop;
4023
4024     first->op_sibling = trueop;
4025     trueop->op_sibling = falseop;
4026     o = newUNOP(OP_NULL, 0, (OP*)logop);
4027
4028     trueop->op_next = falseop->op_next = o;
4029
4030     o->op_next = start;
4031     return o;
4032 }
4033
4034 OP *
4035 Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
4036 {
4037     LOGOP *range;
4038     OP *flip;
4039     OP *flop;
4040     OP *leftstart;
4041     OP *o;
4042
4043     NewOp(1101, range, 1, LOGOP);
4044
4045     range->op_type = OP_RANGE;
4046     range->op_ppaddr = PL_ppaddr[OP_RANGE];
4047     range->op_first = left;
4048     range->op_flags = OPf_KIDS;
4049     leftstart = LINKLIST(left);
4050     range->op_other = LINKLIST(right);
4051     range->op_private = 1 | (flags >> 8);
4052
4053     left->op_sibling = right;
4054
4055     range->op_next = (OP*)range;
4056     flip = newUNOP(OP_FLIP, flags, (OP*)range);
4057     flop = newUNOP(OP_FLOP, 0, flip);
4058     o = newUNOP(OP_NULL, 0, flop);
4059     linklist(flop);
4060     range->op_next = leftstart;
4061
4062     left->op_next = flip;
4063     right->op_next = flop;
4064
4065     range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4066     sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
4067     flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
4068     sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
4069
4070     flip->op_private =  left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4071     flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
4072
4073     flip->op_next = o;
4074     if (!flip->op_private || !flop->op_private)
4075         linklist(o);            /* blow off optimizer unless constant */
4076
4077     return o;
4078 }
4079
4080 OP *
4081 Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
4082 {
4083     OP* listop;
4084     OP* o;
4085     int once = block && block->op_flags & OPf_SPECIAL &&
4086       (block->op_type == OP_ENTERSUB || block->op_type == OP_NULL);
4087
4088     if (expr) {
4089         if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
4090             return block;       /* do {} while 0 does once */
4091         if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4092             || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
4093             expr = newUNOP(OP_DEFINED, 0,
4094                 newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4095         } else if (expr->op_flags & OPf_KIDS) {
4096             OP *k1 = ((UNOP*)expr)->op_first;
4097             OP *k2 = (k1) ? k1->op_sibling : NULL;
4098             switch (expr->op_type) {
4099               case OP_NULL:
4100                 if (k2 && k2->op_type == OP_READLINE
4101                       && (k2->op_flags & OPf_STACKED)
4102                       && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4103                     expr = newUNOP(OP_DEFINED, 0, expr);
4104                 break;
4105
4106               case OP_SASSIGN:
4107                 if (k1->op_type == OP_READDIR
4108                       || k1->op_type == OP_GLOB
4109                       || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4110                       || k1->op_type == OP_EACH)
4111                     expr = newUNOP(OP_DEFINED, 0, expr);
4112                 break;
4113             }
4114         }
4115     }
4116
4117     listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
4118     o = new_logop(OP_AND, 0, &expr, &listop);
4119
4120     if (listop)
4121         ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
4122
4123     if (once && o != listop)
4124         o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
4125
4126     if (o == listop)
4127         o = newUNOP(OP_NULL, 0, o);     /* or do {} while 1 loses outer block */
4128
4129     o->op_flags |= flags;
4130     o = scope(o);
4131     o->op_flags |= OPf_SPECIAL; /* suppress POPBLOCK curpm restoration*/
4132     return o;
4133 }
4134
4135 OP *
4136 Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont)
4137 {
4138     OP *redo;
4139     OP *next = 0;
4140     OP *listop;
4141     OP *o;
4142     U8 loopflags = 0;
4143
4144     if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
4145                  || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
4146         expr = newUNOP(OP_DEFINED, 0,
4147             newASSIGNOP(0, newDEFSVOP(), 0, expr) );
4148     } else if (expr && (expr->op_flags & OPf_KIDS)) {
4149         OP *k1 = ((UNOP*)expr)->op_first;
4150         OP *k2 = (k1) ? k1->op_sibling : NULL;
4151         switch (expr->op_type) {
4152           case OP_NULL:
4153             if (k2 && k2->op_type == OP_READLINE
4154                   && (k2->op_flags & OPf_STACKED)
4155                   && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
4156                 expr = newUNOP(OP_DEFINED, 0, expr);
4157             break;
4158
4159           case OP_SASSIGN:
4160             if (k1->op_type == OP_READDIR
4161                   || k1->op_type == OP_GLOB
4162                   || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
4163                   || k1->op_type == OP_EACH)
4164                 expr = newUNOP(OP_DEFINED, 0, expr);
4165             break;
4166         }
4167     }
4168
4169     if (!block)
4170         block = newOP(OP_NULL, 0);
4171     else if (cont) {
4172         block = scope(block);
4173     }
4174
4175     if (cont) {
4176         next = LINKLIST(cont);
4177     }
4178     if (expr) {
4179         OP *unstack = newOP(OP_UNSTACK, 0);
4180         if (!next)
4181             next = unstack;
4182         cont = append_elem(OP_LINESEQ, cont, unstack);
4183         if ((line_t)whileline != NOLINE) {
4184             PL_copline = whileline;
4185             cont = append_elem(OP_LINESEQ, cont,
4186                                newSTATEOP(0, Nullch, Nullop));
4187         }
4188     }
4189
4190     listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
4191     redo = LINKLIST(listop);
4192
4193     if (expr) {
4194         PL_copline = whileline;
4195         scalar(listop);
4196         o = new_logop(OP_AND, 0, &expr, &listop);
4197         if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
4198             op_free(expr);              /* oops, it's a while (0) */
4199             op_free((OP*)loop);
4200             return Nullop;              /* listop already freed by new_logop */
4201         }
4202         if (listop)
4203             ((LISTOP*)listop)->op_last->op_next =
4204                 (o == listop ? redo : LINKLIST(o));
4205     }
4206     else
4207         o = listop;
4208
4209     if (!loop) {
4210         NewOp(1101,loop,1,LOOP);
4211         loop->op_type = OP_ENTERLOOP;
4212         loop->op_ppaddr = PL_ppaddr[OP_ENTERLOOP];
4213         loop->op_private = 0;
4214         loop->op_next = (OP*)loop;
4215     }
4216
4217     o = newBINOP(OP_LEAVELOOP, 0, (OP*)loop, o);
4218
4219     loop->op_redoop = redo;
4220     loop->op_lastop = o;
4221     o->op_private |= loopflags;
4222
4223     if (next)
4224         loop->op_nextop = next;
4225     else
4226         loop->op_nextop = o;
4227
4228     o->op_flags |= flags;
4229     o->op_private |= (flags >> 8);
4230     return o;
4231 }
4232
4233 OP *
4234 Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont)
4235 {
4236     LOOP *loop;
4237     OP *wop;
4238     int padoff = 0;
4239     I32 iterflags = 0;
4240
4241     if (sv) {
4242         if (sv->op_type == OP_RV2SV) {  /* symbol table variable */
4243             sv->op_type = OP_RV2GV;
4244             sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
4245         }
4246         else if (sv->op_type == OP_PADSV) { /* private variable */
4247             padoff = sv->op_targ;
4248             sv->op_targ = 0;
4249             op_free(sv);
4250             sv = Nullop;
4251         }
4252         else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
4253             padoff = sv->op_targ;
4254             sv->op_targ = 0;
4255             iterflags |= OPf_SPECIAL;
4256             op_free(sv);
4257             sv = Nullop;
4258         }
4259         else
4260             Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
4261     }
4262     else {
4263 #ifdef USE_5005THREADS
4264         padoff = find_threadsv("_");
4265         iterflags |= OPf_SPECIAL;
4266 #else
4267         sv = newGVOP(OP_GV, 0, PL_defgv);
4268 #endif
4269     }
4270     if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
4271         expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
4272         iterflags |= OPf_STACKED;
4273     }
4274     else if (expr->op_type == OP_NULL &&
4275              (expr->op_flags & OPf_KIDS) &&
4276              ((BINOP*)expr)->op_first->op_type == OP_FLOP)
4277     {
4278         /* Basically turn for($x..$y) into the same as for($x,$y), but we
4279          * set the STACKED flag to indicate that these values are to be
4280          * treated as min/max values by 'pp_iterinit'.
4281          */
4282         UNOP* flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
4283         LOGOP* range = (LOGOP*) flip->op_first;
4284         OP* left  = range->op_first;
4285         OP* right = left->op_sibling;
4286         LISTOP* listop;
4287
4288         range->op_flags &= ~OPf_KIDS;
4289         range->op_first = Nullop;
4290
4291         listop = (LISTOP*)newLISTOP(OP_LIST, 0, left, right);
4292         listop->op_first->op_next = range->op_next;
4293         left->op_next = range->op_other;
4294         right->op_next = (OP*)listop;
4295         listop->op_next = listop->op_first;
4296
4297         op_free(expr);
4298         expr = (OP*)(listop);
4299         op_null(expr);
4300         iterflags |= OPf_STACKED;
4301     }
4302     else {
4303         expr = mod(force_list(expr), OP_GREPSTART);
4304     }
4305
4306
4307     loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
4308                                append_elem(OP_LIST, expr, scalar(sv))));
4309     assert(!loop->op_next);
4310 #ifdef PL_OP_SLAB_ALLOC
4311     {
4312         LOOP *tmp;
4313         NewOp(1234,tmp,1,LOOP);
4314         Copy(loop,tmp,1,LOOP);
4315         FreeOp(loop);
4316         loop = tmp;
4317     }
4318 #else
4319     Renew(loop, 1, LOOP);
4320 #endif
4321     loop->op_targ = padoff;
4322     wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
4323     PL_copline = forline;
4324     return newSTATEOP(0, label, wop);
4325 }
4326
4327 OP*
4328 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
4329 {
4330     OP *o;
4331     STRLEN n_a;
4332
4333     if (type != OP_GOTO || label->op_type == OP_CONST) {
4334         /* "last()" means "last" */
4335         if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
4336             o = newOP(type, OPf_SPECIAL);
4337         else {
4338             o = newPVOP(type, 0, savepv(label->op_type == OP_CONST
4339                                         ? SvPVx(((SVOP*)label)->op_sv, n_a)
4340                                         : ""));
4341         }
4342         op_free(label);
4343     }
4344     else {
4345         if (label->op_type == OP_ENTERSUB)
4346             label = newUNOP(OP_REFGEN, 0, mod(label, OP_REFGEN));
4347         o = newUNOP(type, OPf_STACKED, label);
4348     }
4349     PL_hints |= HINT_BLOCK_SCOPE;
4350     return o;
4351 }
4352
4353 void
4354 Perl_cv_undef(pTHX_ CV *cv)
4355 {
4356 #ifdef USE_5005THREADS
4357     if (CvMUTEXP(cv)) {
4358         MUTEX_DESTROY(CvMUTEXP(cv));
4359         Safefree(CvMUTEXP(cv));
4360         CvMUTEXP(cv) = 0;
4361     }
4362 #endif /* USE_5005THREADS */
4363
4364 #ifdef USE_ITHREADS
4365     if (CvFILE(cv) && !CvXSUB(cv)) {
4366         /* for XSUBs CvFILE point directly to static memory; __FILE__ */
4367         Safefree(CvFILE(cv));
4368     }
4369     CvFILE(cv) = 0;
4370 #endif
4371
4372     if (!CvXSUB(cv) && CvROOT(cv)) {
4373 #ifdef USE_5005THREADS
4374         if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr))
4375             Perl_croak(aTHX_ "Can't undef active subroutine");
4376 #else
4377         if (CvDEPTH(cv))
4378             Perl_croak(aTHX_ "Can't undef active subroutine");
4379 #endif /* USE_5005THREADS */
4380         ENTER;
4381
4382         SAVEVPTR(PL_curpad);
4383         PL_curpad = 0;
4384
4385         op_free(CvROOT(cv));
4386         CvROOT(cv) = Nullop;
4387         LEAVE;
4388     }
4389     SvPOK_off((SV*)cv);         /* forget prototype */
4390     CvGV(cv) = Nullgv;
4391     /* Since closure prototypes have the same lifetime as the containing
4392      * CV, they don't hold a refcount on the outside CV.  This avoids
4393      * the refcount loop between the outer CV (which keeps a refcount to
4394      * the closure prototype in the pad entry for pp_anoncode()) and the
4395      * closure prototype, and the ensuing memory leak.  --GSAR */
4396     if (!CvANON(cv) || CvCLONED(cv))
4397         SvREFCNT_dec(CvOUTSIDE(cv));
4398     CvOUTSIDE(cv) = Nullcv;
4399     if (CvCONST(cv)) {
4400         SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
4401         CvCONST_off(cv);
4402     }
4403     if (CvPADLIST(cv)) {
4404         /* may be during global destruction */
4405         if (SvREFCNT(CvPADLIST(cv))) {
4406             I32 i = AvFILLp(CvPADLIST(cv));
4407             while (i >= 0) {
4408                 SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE);
4409                 SV* sv = svp ? *svp : Nullsv;
4410                 if (!sv)
4411                     continue;
4412                 if (sv == (SV*)PL_comppad_name)
4413                     PL_comppad_name = Nullav;
4414                 else if (sv == (SV*)PL_comppad) {
4415                     PL_comppad = Nullav;
4416                     PL_curpad = Null(SV**);
4417                 }
4418                 SvREFCNT_dec(sv);
4419             }
4420             SvREFCNT_dec((SV*)CvPADLIST(cv));
4421         }
4422         CvPADLIST(cv) = Nullav;
4423     }
4424     if (CvXSUB(cv)) {
4425         CvXSUB(cv) = 0;
4426     }
4427     CvFLAGS(cv) = 0;
4428 }
4429
4430 #ifdef DEBUG_CLOSURES
4431 STATIC void
4432 S_cv_dump(pTHX_ CV *cv)
4433 {
4434 #ifdef DEBUGGING
4435     CV *outside = CvOUTSIDE(cv);
4436     AV* padlist = CvPADLIST(cv);
4437     AV* pad_name;
4438     AV* pad;
4439     SV** pname;
4440     SV** ppad;
4441     I32 ix;
4442
4443     PerlIO_printf(Perl_debug_log,
4444                   "\tCV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n",
4445                   PTR2UV(cv),
4446                   (CvANON(cv) ? "ANON"
4447                    : (cv == PL_main_cv) ? "MAIN"
4448                    : CvUNIQUE(cv) ? "UNIQUE"
4449                    : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
4450                   PTR2UV(outside),
4451                   (!outside ? "null"
4452                    : CvANON(outside) ? "ANON"
4453                    : (outside == PL_main_cv) ? "MAIN"
4454                    : CvUNIQUE(outside) ? "UNIQUE"
4455                    : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED"));
4456
4457     if (!padlist)
4458         return;
4459
4460     pad_name = (AV*)*av_fetch(padlist, 0, FALSE);
4461     pad = (AV*)*av_fetch(padlist, 1, FALSE);
4462     pname = AvARRAY(pad_name);
4463     ppad = AvARRAY(pad);
4464
4465     for (ix = 1; ix <= AvFILLp(pad_name); ix++) {
4466         if (SvPOK(pname[ix]))
4467             PerlIO_printf(Perl_debug_log,
4468                           "\t%4d. 0x%"UVxf" (%s\"%s\" %"IVdf"-%"IVdf")\n",
4469                           (int)ix, PTR2UV(ppad[ix]),
4470                           SvFAKE(pname[ix]) ? "FAKE " : "",
4471                           SvPVX(pname[ix]),
4472                           (IV)I_32(SvNVX(pname[ix])),
4473                           SvIVX(pname[ix]));
4474     }
4475 #endif /* DEBUGGING */
4476 }
4477 #endif /* DEBUG_CLOSURES */
4478
4479 STATIC CV *
4480 S_cv_clone2(pTHX_ CV *proto, CV *outside)
4481 {
4482     AV* av;
4483     I32 ix;
4484     AV* protopadlist = CvPADLIST(proto);
4485     AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE);
4486     AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE);
4487     SV** pname = AvARRAY(protopad_name);
4488     SV** ppad = AvARRAY(protopad);
4489     I32 fname = AvFILLp(protopad_name);
4490     I32 fpad = AvFILLp(protopad);
4491     AV* comppadlist;
4492     CV* cv;
4493
4494     assert(!CvUNIQUE(proto));
4495
4496     ENTER;
4497     SAVECOMPPAD();
4498     SAVESPTR(PL_comppad_name);
4499     SAVESPTR(PL_compcv);
4500
4501     cv = PL_compcv = (CV*)NEWSV(1104,0);
4502     sv_upgrade((SV *)cv, SvTYPE(proto));
4503     CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
4504     CvCLONED_on(cv);
4505
4506 #ifdef USE_5005THREADS
4507     New(666, CvMUTEXP(cv), 1, perl_mutex);
4508     MUTEX_INIT(CvMUTEXP(cv));
4509     CvOWNER(cv)         = 0;
4510 #endif /* USE_5005THREADS */
4511 #ifdef USE_ITHREADS
4512     CvFILE(cv)          = CvXSUB(proto) ? CvFILE(proto)
4513                                         : savepv(CvFILE(proto));
4514 #else
4515     CvFILE(cv)          = CvFILE(proto);
4516 #endif
4517     CvGV(cv)            = CvGV(proto);
4518     CvSTASH(cv)         = CvSTASH(proto);
4519     CvROOT(cv)          = OpREFCNT_inc(CvROOT(proto));
4520     CvSTART(cv)         = CvSTART(proto);
4521     if (outside)
4522         CvOUTSIDE(cv)   = (CV*)SvREFCNT_inc(outside);
4523
4524     if (SvPOK(proto))
4525         sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
4526
4527     PL_comppad_name = newAV();
4528     for (ix = fname; ix >= 0; ix--)
4529         av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix]));
4530
4531     PL_comppad = newAV();
4532
4533     comppadlist = newAV();
4534     AvREAL_off(comppadlist);
4535     av_store(comppadlist, 0, (SV*)PL_comppad_name);
4536     av_store(comppadlist, 1, (SV*)PL_comppad);
4537     CvPADLIST(cv) = comppadlist;
4538     av_fill(PL_comppad, AvFILLp(protopad));
4539     PL_curpad = AvARRAY(PL_comppad);
4540
4541     av = newAV();           /* will be @_ */
4542     av_extend(av, 0);
4543     av_store(PL_comppad, 0, (SV*)av);
4544     AvFLAGS(av) = AVf_REIFY;
4545
4546     for (ix = fpad; ix > 0; ix--) {
4547         SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4548         if (namesv && namesv != &PL_sv_undef) {
4549             char *name = SvPVX(namesv);    /* XXX */
4550             if (SvFLAGS(namesv) & SVf_FAKE) {   /* lexical from outside? */
4551                 I32 off = pad_findlex(name, ix, SvIVX(namesv),
4552                                       CvOUTSIDE(cv), cxstack_ix, 0, 0);
4553                 if (!off)
4554                     PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4555                 else if (off != ix)
4556                     Perl_croak(aTHX_ "panic: cv_clone: %s", name);
4557             }
4558             else {                              /* our own lexical */
4559                 SV* sv;
4560                 if (*name == '&') {
4561                     /* anon code -- we'll come back for it */
4562                     sv = SvREFCNT_inc(ppad[ix]);
4563                 }
4564                 else if (*name == '@')
4565                     sv = (SV*)newAV();
4566                 else if (*name == '%')
4567                     sv = (SV*)newHV();
4568                 else
4569                     sv = NEWSV(0,0);
4570                 if (!SvPADBUSY(sv))
4571                     SvPADMY_on(sv);
4572                 PL_curpad[ix] = sv;
4573             }
4574         }
4575         else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) {
4576             PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
4577         }
4578         else {
4579             SV* sv = NEWSV(0,0);
4580             SvPADTMP_on(sv);
4581             PL_curpad[ix] = sv;
4582         }
4583     }
4584
4585     /* Now that vars are all in place, clone nested closures. */
4586
4587     for (ix = fpad; ix > 0; ix--) {
4588         SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
4589         if (namesv
4590             && namesv != &PL_sv_undef
4591             && !(SvFLAGS(namesv) & SVf_FAKE)
4592             && *SvPVX(namesv) == '&'
4593             && CvCLONE(ppad[ix]))
4594         {
4595             CV *kid = cv_clone2((CV*)ppad[ix], cv);
4596             SvREFCNT_dec(ppad[ix]);
4597             CvCLONE_on(kid);
4598             SvPADMY_on(kid);
4599             PL_curpad[ix] = (SV*)kid;
4600         }
4601     }
4602
4603 #ifdef DEBUG_CLOSURES
4604     PerlIO_printf(Perl_debug_log, "Cloned inside:\n");
4605     cv_dump(outside);
4606     PerlIO_printf(Perl_debug_log, "  from:\n");
4607     cv_dump(proto);
4608     PerlIO_printf(Perl_debug_log, "   to:\n");
4609     cv_dump(cv);
4610 #endif
4611
4612     LEAVE;
4613
4614     if (CvCONST(cv)) {
4615         SV* const_sv = op_const_sv(CvSTART(cv), cv);
4616         assert(const_sv);
4617         /* constant sub () { $x } closing over $x - see lib/constant.pm */
4618         SvREFCNT_dec(cv);
4619         cv = newCONSTSUB(CvSTASH(proto), 0, const_sv);
4620     }
4621
4622     return cv;
4623 }
4624
4625 CV *
4626 Perl_cv_clone(pTHX_ CV *proto)
4627 {
4628     CV *cv;
4629     LOCK_CRED_MUTEX;                    /* XXX create separate mutex */
4630     cv = cv_clone2(proto, CvOUTSIDE(proto));
4631     UNLOCK_CRED_MUTEX;                  /* XXX create separate mutex */
4632     return cv;
4633 }
4634
4635 void
4636 Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p)
4637 {
4638     if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) {
4639         SV* msg = sv_newmortal();
4640         SV* name = Nullsv;
4641
4642         if (gv)
4643             gv_efullname3(name = sv_newmortal(), gv, Nullch);
4644         sv_setpv(msg, "Prototype mismatch:");
4645         if (name)
4646             Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name);
4647         if (SvPOK(cv))
4648             Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv));
4649         sv_catpv(msg, " vs ");
4650         if (p)
4651             Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
4652         else
4653             sv_catpv(msg, "none");
4654         Perl_warner(aTHX_ WARN_PROTOTYPE, "%"SVf, msg);
4655     }
4656 }
4657
4658 static void const_sv_xsub(pTHX_ CV* cv);
4659
4660 /*
4661
4662 =head1 Optree Manipulation Functions
4663
4664 =for apidoc cv_const_sv
4665
4666 If C<cv> is a constant sub eligible for inlining. returns the constant
4667 value returned by the sub.  Otherwise, returns NULL.
4668
4669 Constant subs can be created with C<newCONSTSUB> or as described in
4670 L<perlsub/"Constant Functions">.
4671
4672 =cut
4673 */
4674 SV *
4675 Perl_cv_const_sv(pTHX_ CV *cv)
4676 {
4677     if (!cv || !CvCONST(cv))
4678         return Nullsv;
4679     return (SV*)CvXSUBANY(cv).any_ptr;
4680 }
4681
4682 SV *
4683 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
4684 {
4685     SV *sv = Nullsv;
4686
4687     if (!o)
4688         return Nullsv;
4689
4690     if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
4691         o = cLISTOPo->op_first->op_sibling;
4692
4693     for (; o; o = o->op_next) {
4694         OPCODE type = o->op_type;
4695
4696         if (sv && o->op_next == o)
4697             return sv;
4698         if (o->op_next != o) {
4699             if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
4700                 continue;
4701             if (type == OP_DBSTATE)
4702                 continue;
4703         }
4704         if (type == OP_LEAVESUB || type == OP_RETURN)
4705             break;
4706         if (sv)
4707             return Nullsv;
4708         if (type == OP_CONST && cSVOPo->op_sv)
4709             sv = cSVOPo->op_sv;
4710         else if ((type == OP_PADSV || type == OP_CONST) && cv) {
4711             AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
4712             sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
4713             if (!sv)
4714                 return Nullsv;
4715             if (CvCONST(cv)) {
4716                 /* We get here only from cv_clone2() while creating a closure.
4717                    Copy the const value here instead of in cv_clone2 so that
4718                    SvREADONLY_on doesn't lead to problems when leaving
4719                    scope.
4720                 */
4721                 sv = newSVsv(sv);
4722             }
4723             if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
4724                 return Nullsv;
4725         }
4726         else
4727             return Nullsv;
4728     }
4729     if (sv)
4730         SvREADONLY_on(sv);
4731     return sv;
4732 }
4733
4734 void
4735 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4736 {
4737     if (o)
4738         SAVEFREEOP(o);
4739     if (proto)
4740         SAVEFREEOP(proto);
4741     if (attrs)
4742         SAVEFREEOP(attrs);
4743     if (block)
4744         SAVEFREEOP(block);
4745     Perl_croak(aTHX_ "\"my sub\" not yet implemented");
4746 }
4747
4748 CV *
4749 Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
4750 {
4751     return Perl_newATTRSUB(aTHX_ floor, o, proto, Nullop, block);
4752 }
4753
4754 CV *
4755 Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
4756 {
4757     STRLEN n_a;
4758     char *name;
4759     char *aname;
4760     GV *gv;
4761     char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
4762     register CV *cv=0;
4763     I32 ix;
4764     SV *const_sv;
4765
4766     name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
4767     if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
4768         SV *sv = sv_newmortal();
4769         Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
4770                        PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
4771                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4772         aname = SvPVX(sv);
4773     }
4774     else
4775         aname = Nullch;
4776     gv = gv_fetchpv(name ? name : (aname ? aname :
4777                     (PL_curstash ? "__ANON__" : "__ANON__::__ANON__")),
4778                     GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
4779                     SVt_PVCV);
4780
4781     if (o)
4782         SAVEFREEOP(o);
4783     if (proto)
4784         SAVEFREEOP(proto);
4785     if (attrs)
4786         SAVEFREEOP(attrs);
4787
4788     if (SvTYPE(gv) != SVt_PVGV) {       /* Maybe prototype now, and had at
4789                                            maximum a prototype before. */
4790         if (SvTYPE(gv) > SVt_NULL) {
4791             if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
4792                 && ckWARN_d(WARN_PROTOTYPE))
4793             {
4794                 Perl_warner(aTHX_ WARN_PROTOTYPE, "Runaway prototype");
4795             }
4796             cv_ckproto((CV*)gv, NULL, ps);
4797         }
4798         if (ps)
4799             sv_setpv((SV*)gv, ps);
4800         else
4801             sv_setiv((SV*)gv, -1);
4802         SvREFCNT_dec(PL_compcv);
4803         cv = PL_compcv = NULL;
4804         PL_sub_generation++;
4805         goto done;
4806     }
4807
4808     cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
4809
4810 #ifdef GV_UNIQUE_CHECK
4811     if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
4812         Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
4813     }
4814 #endif
4815
4816     if (!block || !ps || *ps || attrs)
4817         const_sv = Nullsv;
4818     else
4819         const_sv = op_const_sv(block, Nullcv);
4820
4821     if (cv) {
4822         bool exists = CvROOT(cv) || CvXSUB(cv);
4823
4824 #ifdef GV_UNIQUE_CHECK
4825         if (exists && GvUNIQUE(gv)) {
4826             Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
4827         }
4828 #endif
4829
4830         /* if the subroutine doesn't exist and wasn't pre-declared
4831          * with a prototype, assume it will be AUTOLOADed,
4832          * skipping the prototype check
4833          */
4834         if (exists || SvPOK(cv))
4835             cv_ckproto(cv, gv, ps);
4836         /* already defined (or promised)? */
4837         if (exists || GvASSUMECV(gv)) {
4838             if (!block && !attrs) {
4839                 /* just a "sub foo;" when &foo is already defined */
4840                 SAVEFREESV(PL_compcv);
4841                 goto done;
4842             }
4843             /* ahem, death to those who redefine active sort subs */
4844             if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
4845                 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
4846             if (block) {
4847                 if (ckWARN(WARN_REDEFINE)
4848                     || (CvCONST(cv)
4849                         && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
4850                 {
4851                     line_t oldline = CopLINE(PL_curcop);
4852                     if (PL_copline != NOLINE)
4853                         CopLINE_set(PL_curcop, PL_copline);
4854                     Perl_warner(aTHX_ WARN_REDEFINE,
4855                         CvCONST(cv) ? "Constant subroutine %s redefined"
4856                                     : "Subroutine %s redefined", name);
4857                     CopLINE_set(PL_curcop, oldline);
4858                 }
4859                 SvREFCNT_dec(cv);
4860                 cv = Nullcv;
4861             }
4862         }
4863     }
4864     if (const_sv) {
4865         SvREFCNT_inc(const_sv);
4866         if (cv) {
4867             assert(!CvROOT(cv) && !CvCONST(cv));
4868             sv_setpv((SV*)cv, "");  /* prototype is "" */
4869             CvXSUBANY(cv).any_ptr = const_sv;
4870             CvXSUB(cv) = const_sv_xsub;
4871             CvCONST_on(cv);
4872         }
4873         else {
4874             GvCV(gv) = Nullcv;
4875             cv = newCONSTSUB(NULL, name, const_sv);
4876         }
4877         op_free(block);
4878         SvREFCNT_dec(PL_compcv);
4879         PL_compcv = NULL;
4880         PL_sub_generation++;
4881         goto done;
4882     }
4883     if (attrs) {
4884         HV *stash;
4885         SV *rcv;
4886
4887         /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>
4888          * before we clobber PL_compcv.
4889          */
4890         if (cv && !block) {
4891             rcv = (SV*)cv;
4892             if (CvGV(cv) && GvSTASH(CvGV(cv)))
4893                 stash = GvSTASH(CvGV(cv));
4894             else if (CvSTASH(cv))
4895                 stash = CvSTASH(cv);
4896             else
4897                 stash = PL_curstash;
4898         }
4899         else {
4900             /* possibly about to re-define existing subr -- ignore old cv */
4901             rcv = (SV*)PL_compcv;
4902             if (name && GvSTASH(gv))
4903                 stash = GvSTASH(gv);
4904             else
4905                 stash = PL_curstash;
4906         }
4907         apply_attrs(stash, rcv, attrs, FALSE);
4908     }
4909     if (cv) {                           /* must reuse cv if autoloaded */
4910         if (!block) {
4911             /* got here with just attrs -- work done, so bug out */
4912             SAVEFREESV(PL_compcv);
4913             goto done;
4914         }
4915         cv_undef(cv);
4916         CvFLAGS(cv) = CvFLAGS(PL_compcv);
4917         CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
4918         CvOUTSIDE(PL_compcv) = 0;
4919         CvPADLIST(cv) = CvPADLIST(PL_compcv);
4920         CvPADLIST(PL_compcv) = 0;
4921         /* inner references to PL_compcv must be fixed up ... */
4922         {
4923             AV *padlist = CvPADLIST(cv);
4924             AV *comppad_name = (AV*)AvARRAY(padlist)[0];
4925             AV *comppad = (AV*)AvARRAY(padlist)[1];
4926             SV **namepad = AvARRAY(comppad_name);
4927             SV **curpad = AvARRAY(comppad);
4928             for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
4929                 SV *namesv = namepad[ix];
4930                 if (namesv && namesv != &PL_sv_undef
4931                     && *SvPVX(namesv) == '&')
4932                 {
4933                     CV *innercv = (CV*)curpad[ix];
4934                     if (CvOUTSIDE(innercv) == PL_compcv) {
4935                         CvOUTSIDE(innercv) = cv;
4936                         if (!CvANON(innercv) || CvCLONED(innercv)) {
4937                             (void)SvREFCNT_inc(cv);
4938                             SvREFCNT_dec(PL_compcv);
4939                         }
4940                     }
4941                 }
4942             }
4943         }
4944         /* ... before we throw it away */
4945         SvREFCNT_dec(PL_compcv);
4946         if (PERLDB_INTER)/* Advice debugger on the new sub. */
4947           ++PL_sub_generation;
4948     }
4949     else {
4950         cv = PL_compcv;
4951         if (name) {
4952             GvCV(gv) = cv;
4953             GvCVGEN(gv) = 0;
4954             PL_sub_generation++;
4955         }
4956     }
4957     CvGV(cv) = gv;
4958     CvFILE_set_from_cop(cv, PL_curcop);
4959     CvSTASH(cv) = PL_curstash;
4960 #ifdef USE_5005THREADS
4961     CvOWNER(cv) = 0;
4962     if (!CvMUTEXP(cv)) {
4963         New(666, CvMUTEXP(cv), 1, perl_mutex);
4964         MUTEX_INIT(CvMUTEXP(cv));
4965     }
4966 #endif /* USE_5005THREADS */
4967
4968     if (ps)
4969         sv_setpv((SV*)cv, ps);
4970
4971     if (PL_error_count) {
4972         op_free(block);
4973         block = Nullop;
4974         if (name) {
4975             char *s = strrchr(name, ':');
4976             s = s ? s+1 : name;
4977             if (strEQ(s, "BEGIN")) {
4978                 char *not_safe =
4979                     "BEGIN not safe after errors--compilation aborted";
4980                 if (PL_in_eval & EVAL_KEEPERR)
4981                     Perl_croak(aTHX_ not_safe);
4982                 else {
4983                     /* force display of errors found but not reported */
4984                     sv_catpv(ERRSV, not_safe);
4985                     Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a));
4986                 }
4987             }
4988         }
4989     }
4990     if (!block)
4991         goto done;
4992
4993     if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad))
4994         av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
4995
4996     if (CvLVALUE(cv)) {
4997         CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
4998                              mod(scalarseq(block), OP_LEAVESUBLV));
4999     }
5000     else {
5001         CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
5002     }
5003     CvROOT(cv)->op_private |= OPpREFCOUNTED;
5004     OpREFCNT_set(CvROOT(cv), 1);
5005     CvSTART(cv) = LINKLIST(CvROOT(cv));
5006     CvROOT(cv)->op_next = 0;
5007     CALL_PEEP(CvSTART(cv));
5008
5009     /* now that optimizer has done its work, adjust pad values */
5010     if (CvCLONE(cv)) {
5011         SV **namep = AvARRAY(PL_comppad_name);
5012         for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5013             SV *namesv;
5014
5015             if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
5016                 continue;
5017             /*
5018              * The only things that a clonable function needs in its
5019              * pad are references to outer lexicals and anonymous subs.
5020              * The rest are created anew during cloning.
5021              */
5022             if (!((namesv = namep[ix]) != Nullsv &&
5023                   namesv != &PL_sv_undef &&
5024                   (SvFAKE(namesv) ||
5025                    *SvPVX(namesv) == '&')))
5026             {
5027                 SvREFCNT_dec(PL_curpad[ix]);
5028                 PL_curpad[ix] = Nullsv;
5029             }
5030         }
5031         assert(!CvCONST(cv));
5032         if (ps && !*ps && op_const_sv(block, cv))
5033             CvCONST_on(cv);
5034     }
5035     else {
5036         AV *av = newAV();                       /* Will be @_ */
5037         av_extend(av, 0);
5038         av_store(PL_comppad, 0, (SV*)av);
5039         AvFLAGS(av) = AVf_REIFY;
5040
5041         for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5042             if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix]))
5043                 continue;
5044             if (!SvPADMY(PL_curpad[ix]))
5045                 SvPADTMP_on(PL_curpad[ix]);
5046         }
5047     }
5048
5049     /* If a potential closure prototype, don't keep a refcount on outer CV.
5050      * This is okay as the lifetime of the prototype is tied to the
5051      * lifetime of the outer CV.  Avoids memory leak due to reference
5052      * loop. --GSAR */
5053     if (!name)
5054         SvREFCNT_dec(CvOUTSIDE(cv));
5055
5056     if (name || aname) {
5057         char *s;
5058         char *tname = (name ? name : aname);
5059
5060         if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
5061             SV *sv = NEWSV(0,0);
5062             SV *tmpstr = sv_newmortal();
5063             GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
5064             CV *pcv;
5065             HV *hv;
5066
5067             Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
5068                            CopFILE(PL_curcop),
5069                            (long)PL_subline, (long)CopLINE(PL_curcop));
5070             gv_efullname3(tmpstr, gv, Nullch);
5071             hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
5072             hv = GvHVn(db_postponed);
5073             if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
5074                 && (pcv = GvCV(db_postponed)))
5075             {
5076                 dSP;
5077                 PUSHMARK(SP);
5078                 XPUSHs(tmpstr);
5079                 PUTBACK;
5080                 call_sv((SV*)pcv, G_DISCARD);
5081             }
5082         }
5083
5084         if ((s = strrchr(tname,':')))
5085             s++;
5086         else
5087             s = tname;
5088
5089         if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5090             goto done;
5091
5092         if (strEQ(s, "BEGIN")) {
5093             I32 oldscope = PL_scopestack_ix;
5094             ENTER;
5095             SAVECOPFILE(&PL_compiling);
5096             SAVECOPLINE(&PL_compiling);
5097
5098             if (!PL_beginav)
5099                 PL_beginav = newAV();
5100             DEBUG_x( dump_sub(gv) );
5101             av_push(PL_beginav, (SV*)cv);
5102             GvCV(gv) = 0;               /* cv has been hijacked */
5103             call_list(oldscope, PL_beginav);
5104
5105             PL_curcop = &PL_compiling;
5106             PL_compiling.op_private = PL_hints;
5107             LEAVE;
5108         }
5109         else if (strEQ(s, "END") && !PL_error_count) {
5110             if (!PL_endav)
5111                 PL_endav = newAV();
5112             DEBUG_x( dump_sub(gv) );
5113             av_unshift(PL_endav, 1);
5114             av_store(PL_endav, 0, (SV*)cv);
5115             GvCV(gv) = 0;               /* cv has been hijacked */
5116         }
5117         else if (strEQ(s, "CHECK") && !PL_error_count) {
5118             if (!PL_checkav)
5119                 PL_checkav = newAV();
5120             DEBUG_x( dump_sub(gv) );
5121             if (PL_main_start && ckWARN(WARN_VOID))
5122                 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
5123             av_unshift(PL_checkav, 1);
5124             av_store(PL_checkav, 0, (SV*)cv);
5125             GvCV(gv) = 0;               /* cv has been hijacked */
5126         }
5127         else if (strEQ(s, "INIT") && !PL_error_count) {
5128             if (!PL_initav)
5129                 PL_initav = newAV();
5130             DEBUG_x( dump_sub(gv) );
5131             if (PL_main_start && ckWARN(WARN_VOID))
5132                 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
5133             av_push(PL_initav, (SV*)cv);
5134             GvCV(gv) = 0;               /* cv has been hijacked */
5135         }
5136     }
5137
5138   done:
5139     PL_copline = NOLINE;
5140     LEAVE_SCOPE(floor);
5141     return cv;
5142 }
5143
5144 /* XXX unsafe for threads if eval_owner isn't held */
5145 /*
5146 =for apidoc newCONSTSUB
5147
5148 Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
5149 eligible for inlining at compile-time.
5150
5151 =cut
5152 */
5153
5154 CV *
5155 Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
5156 {
5157     CV* cv;
5158
5159     ENTER;
5160
5161     SAVECOPLINE(PL_curcop);
5162     CopLINE_set(PL_curcop, PL_copline);
5163
5164     SAVEHINTS();
5165     PL_hints &= ~HINT_BLOCK_SCOPE;
5166
5167     if (stash) {
5168         SAVESPTR(PL_curstash);
5169         SAVECOPSTASH(PL_curcop);
5170         PL_curstash = stash;
5171         CopSTASH_set(PL_curcop,stash);
5172     }
5173
5174     cv = newXS(name, const_sv_xsub, __FILE__);
5175     CvXSUBANY(cv).any_ptr = sv;
5176     CvCONST_on(cv);
5177     sv_setpv((SV*)cv, "");  /* prototype is "" */
5178
5179     LEAVE;
5180
5181     return cv;
5182 }
5183
5184 /*
5185 =for apidoc U||newXS
5186
5187 Used by C<xsubpp> to hook up XSUBs as Perl subs.
5188
5189 =cut
5190 */
5191
5192 CV *
5193 Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
5194 {
5195     GV *gv = gv_fetchpv(name ? name :
5196                         (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
5197                         GV_ADDMULTI, SVt_PVCV);
5198     register CV *cv;
5199
5200     if ((cv = (name ? GvCV(gv) : Nullcv))) {
5201         if (GvCVGEN(gv)) {
5202             /* just a cached method */
5203             SvREFCNT_dec(cv);
5204             cv = 0;
5205         }
5206         else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
5207             /* already defined (or promised) */
5208             if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
5209                             && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
5210                 line_t oldline = CopLINE(PL_curcop);
5211                 if (PL_copline != NOLINE)
5212                     CopLINE_set(PL_curcop, PL_copline);
5213                 Perl_warner(aTHX_ WARN_REDEFINE,
5214                             CvCONST(cv) ? "Constant subroutine %s redefined"
5215                                         : "Subroutine %s redefined"
5216                             ,name);
5217                 CopLINE_set(PL_curcop, oldline);
5218             }
5219             SvREFCNT_dec(cv);
5220             cv = 0;
5221         }
5222     }
5223
5224     if (cv)                             /* must reuse cv if autoloaded */
5225         cv_undef(cv);
5226     else {
5227         cv = (CV*)NEWSV(1105,0);
5228         sv_upgrade((SV *)cv, SVt_PVCV);
5229         if (name) {
5230             GvCV(gv) = cv;
5231             GvCVGEN(gv) = 0;
5232             PL_sub_generation++;
5233         }
5234     }
5235     CvGV(cv) = gv;
5236 #ifdef USE_5005THREADS
5237     New(666, CvMUTEXP(cv), 1, perl_mutex);
5238     MUTEX_INIT(CvMUTEXP(cv));
5239     CvOWNER(cv) = 0;
5240 #endif /* USE_5005THREADS */
5241     (void)gv_fetchfile(filename);
5242     CvFILE(cv) = filename;      /* NOTE: not copied, as it is expected to be
5243                                    an external constant string */
5244     CvXSUB(cv) = subaddr;
5245
5246     if (name) {
5247         char *s = strrchr(name,':');
5248         if (s)
5249             s++;
5250         else
5251             s = name;
5252
5253         if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
5254             goto done;
5255
5256         if (strEQ(s, "BEGIN")) {
5257             if (!PL_beginav)
5258                 PL_beginav = newAV();
5259             av_push(PL_beginav, (SV*)cv);
5260             GvCV(gv) = 0;               /* cv has been hijacked */
5261         }
5262         else if (strEQ(s, "END")) {
5263             if (!PL_endav)
5264                 PL_endav = newAV();
5265             av_unshift(PL_endav, 1);
5266             av_store(PL_endav, 0, (SV*)cv);
5267             GvCV(gv) = 0;               /* cv has been hijacked */
5268         }
5269         else if (strEQ(s, "CHECK")) {
5270             if (!PL_checkav)
5271                 PL_checkav = newAV();
5272             if (PL_main_start && ckWARN(WARN_VOID))
5273                 Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
5274             av_unshift(PL_checkav, 1);
5275             av_store(PL_checkav, 0, (SV*)cv);
5276             GvCV(gv) = 0;               /* cv has been hijacked */
5277         }
5278         else if (strEQ(s, "INIT")) {
5279             if (!PL_initav)
5280                 PL_initav = newAV();
5281             if (PL_main_start && ckWARN(WARN_VOID))
5282                 Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
5283             av_push(PL_initav, (SV*)cv);
5284             GvCV(gv) = 0;               /* cv has been hijacked */
5285         }
5286     }
5287     else
5288         CvANON_on(cv);
5289
5290 done:
5291     return cv;
5292 }
5293
5294 void
5295 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
5296 {
5297     register CV *cv;
5298     char *name;
5299     GV *gv;
5300     I32 ix;
5301     STRLEN n_a;
5302
5303     if (o)
5304         name = SvPVx(cSVOPo->op_sv, n_a);
5305     else
5306         name = "STDOUT";
5307     gv = gv_fetchpv(name,TRUE, SVt_PVFM);
5308 #ifdef GV_UNIQUE_CHECK
5309     if (GvUNIQUE(gv)) {
5310         Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
5311     }
5312 #endif
5313     GvMULTI_on(gv);
5314     if ((cv = GvFORM(gv))) {
5315         if (ckWARN(WARN_REDEFINE)) {
5316             line_t oldline = CopLINE(PL_curcop);
5317             if (PL_copline != NOLINE)
5318                 CopLINE_set(PL_curcop, PL_copline);
5319             Perl_warner(aTHX_ WARN_REDEFINE, "Format %s redefined",name);
5320             CopLINE_set(PL_curcop, oldline);
5321         }
5322         SvREFCNT_dec(cv);
5323     }
5324     cv = PL_compcv;
5325     GvFORM(gv) = cv;
5326     CvGV(cv) = gv;
5327     CvFILE_set_from_cop(cv, PL_curcop);
5328
5329     for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
5330         if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
5331             SvPADTMP_on(PL_curpad[ix]);
5332     }
5333
5334     CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block));
5335     CvROOT(cv)->op_private |= OPpREFCOUNTED;
5336     OpREFCNT_set(CvROOT(cv), 1);
5337     CvSTART(cv) = LINKLIST(CvROOT(cv));
5338     CvROOT(cv)->op_next = 0;
5339     CALL_PEEP(CvSTART(cv));
5340     op_free(o);
5341     PL_copline = NOLINE;
5342     LEAVE_SCOPE(floor);
5343 }
5344
5345 OP *
5346 Perl_newANONLIST(pTHX_ OP *o)
5347 {
5348     return newUNOP(OP_REFGEN, 0,
5349         mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
5350 }
5351
5352 OP *
5353 Perl_newANONHASH(pTHX_ OP *o)
5354 {
5355     return newUNOP(OP_REFGEN, 0,
5356         mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
5357 }
5358
5359 OP *
5360 Perl_newANONSUB(pTHX_ I32 floor, OP *proto, OP *block)
5361 {
5362     return newANONATTRSUB(floor, proto, Nullop, block);
5363 }
5364
5365 OP *
5366 Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block)
5367 {
5368     return newUNOP(OP_REFGEN, 0,
5369         newSVOP(OP_ANONCODE, 0,
5370                 (SV*)newATTRSUB(floor, 0, proto, attrs, block)));
5371 }
5372
5373 OP *
5374 Perl_oopsAV(pTHX_ OP *o)
5375 {
5376     switch (o->op_type) {
5377     case OP_PADSV:
5378         o->op_type = OP_PADAV;
5379         o->op_ppaddr = PL_ppaddr[OP_PADAV];
5380         return ref(o, OP_RV2AV);
5381
5382     case OP_RV2SV:
5383         o->op_type = OP_RV2AV;
5384         o->op_ppaddr = PL_ppaddr[OP_RV2AV];
5385         ref(o, OP_RV2AV);
5386         break;
5387
5388     default:
5389         if (ckWARN_d(WARN_INTERNAL))
5390             Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsAV");
5391         break;
5392     }
5393     return o;
5394 }
5395
5396 OP *
5397 Perl_oopsHV(pTHX_ OP *o)
5398 {
5399     switch (o->op_type) {
5400     case OP_PADSV:
5401     case OP_PADAV:
5402         o->op_type = OP_PADHV;
5403         o->op_ppaddr = PL_ppaddr[OP_PADHV];
5404         return ref(o, OP_RV2HV);
5405
5406     case OP_RV2SV:
5407     case OP_RV2AV:
5408         o->op_type = OP_RV2HV;
5409         o->op_ppaddr = PL_ppaddr[OP_RV2HV];
5410         ref(o, OP_RV2HV);
5411         break;
5412
5413     default:
5414         if (ckWARN_d(WARN_INTERNAL))
5415             Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsHV");
5416         break;
5417     }
5418     return o;
5419 }
5420
5421 OP *
5422 Perl_newAVREF(pTHX_ OP *o)
5423 {
5424     if (o->op_type == OP_PADANY) {
5425         o->op_type = OP_PADAV;
5426         o->op_ppaddr = PL_ppaddr[OP_PADAV];
5427         return o;
5428     }
5429     else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
5430                 && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
5431         Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5432                 "Using an array as a reference is deprecated");
5433     }
5434     return newUNOP(OP_RV2AV, 0, scalar(o));
5435 }
5436
5437 OP *
5438 Perl_newGVREF(pTHX_ I32 type, OP *o)
5439 {
5440     if (type == OP_MAPSTART || type == OP_GREPSTART || type == OP_SORT)
5441         return newUNOP(OP_NULL, 0, o);
5442     return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
5443 }
5444
5445 OP *
5446 Perl_newHVREF(pTHX_ OP *o)
5447 {
5448     if (o->op_type == OP_PADANY) {
5449         o->op_type = OP_PADHV;
5450         o->op_ppaddr = PL_ppaddr[OP_PADHV];
5451         return o;
5452     }
5453     else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
5454                 && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
5455         Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5456                 "Using a hash as a reference is deprecated");
5457     }
5458     return newUNOP(OP_RV2HV, 0, scalar(o));
5459 }
5460
5461 OP *
5462 Perl_oopsCV(pTHX_ OP *o)
5463 {
5464     Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
5465     /* STUB */
5466     return o;
5467 }
5468
5469 OP *
5470 Perl_newCVREF(pTHX_ I32 flags, OP *o)
5471 {
5472     return newUNOP(OP_RV2CV, flags, scalar(o));
5473 }
5474
5475 OP *
5476 Perl_newSVREF(pTHX_ OP *o)
5477 {
5478     if (o->op_type == OP_PADANY) {
5479         o->op_type = OP_PADSV;
5480         o->op_ppaddr = PL_ppaddr[OP_PADSV];
5481         return o;
5482     }
5483     else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
5484         o->op_flags |= OPpDONE_SVREF;
5485         return o;
5486     }
5487     return newUNOP(OP_RV2SV, 0, scalar(o));
5488 }
5489
5490 /* Check routines. */
5491
5492 OP *
5493 Perl_ck_anoncode(pTHX_ OP *o)
5494 {
5495     PADOFFSET ix;
5496     SV* name;
5497
5498     name = NEWSV(1106,0);
5499     sv_upgrade(name, SVt_PVNV);
5500     sv_setpvn(name, "&", 1);
5501     SvIVX(name) = -1;
5502     SvNVX(name) = 1;
5503     ix = pad_alloc(o->op_type, SVs_PADMY);
5504     av_store(PL_comppad_name, ix, name);
5505     av_store(PL_comppad, ix, cSVOPo->op_sv);
5506     SvPADMY_on(cSVOPo->op_sv);
5507     cSVOPo->op_sv = Nullsv;
5508     cSVOPo->op_targ = ix;
5509     return o;
5510 }
5511
5512 OP *
5513 Perl_ck_bitop(pTHX_ OP *o)
5514 {
5515     o->op_private = PL_hints;
5516     return o;
5517 }
5518
5519 OP *
5520 Perl_ck_concat(pTHX_ OP *o)
5521 {
5522     if (cUNOPo->op_first->op_type == OP_CONCAT)
5523         o->op_flags |= OPf_STACKED;
5524     return o;
5525 }
5526
5527 OP *
5528 Perl_ck_spair(pTHX_ OP *o)
5529 {
5530     if (o->op_flags & OPf_KIDS) {
5531         OP* newop;
5532         OP* kid;
5533         OPCODE type = o->op_type;
5534         o = modkids(ck_fun(o), type);
5535         kid = cUNOPo->op_first;
5536         newop = kUNOP->op_first->op_sibling;
5537         if (newop &&
5538             (newop->op_sibling ||
5539              !(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
5540              newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
5541              newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
5542
5543             return o;
5544         }
5545         op_free(kUNOP->op_first);
5546         kUNOP->op_first = newop;
5547     }
5548     o->op_ppaddr = PL_ppaddr[++o->op_type];
5549     return ck_fun(o);
5550 }
5551
5552 OP *
5553 Perl_ck_delete(pTHX_ OP *o)
5554 {
5555     o = ck_fun(o);
5556     o->op_private = 0;
5557     if (o->op_flags & OPf_KIDS) {
5558         OP *kid = cUNOPo->op_first;
5559         switch (kid->op_type) {
5560         case OP_ASLICE:
5561             o->op_flags |= OPf_SPECIAL;
5562             /* FALL THROUGH */
5563         case OP_HSLICE:
5564             o->op_private |= OPpSLICE;
5565             break;
5566         case OP_AELEM:
5567             o->op_flags |= OPf_SPECIAL;
5568             /* FALL THROUGH */
5569         case OP_HELEM:
5570             break;
5571         default:
5572             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
5573                   OP_DESC(o));
5574         }
5575         op_null(kid);
5576     }
5577     return o;
5578 }
5579
5580 OP *
5581 Perl_ck_die(pTHX_ OP *o)
5582 {
5583 #ifdef VMS
5584     if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5585 #endif
5586     return ck_fun(o);
5587 }
5588
5589 OP *
5590 Perl_ck_eof(pTHX_ OP *o)
5591 {
5592     I32 type = o->op_type;
5593
5594     if (o->op_flags & OPf_KIDS) {
5595         if (cLISTOPo->op_first->op_type == OP_STUB) {
5596             op_free(o);
5597             o = newUNOP(type, OPf_SPECIAL,
5598                 newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
5599         }
5600         return ck_fun(o);
5601     }
5602     return o;
5603 }
5604
5605 OP *
5606 Perl_ck_eval(pTHX_ OP *o)
5607 {
5608     PL_hints |= HINT_BLOCK_SCOPE;
5609     if (o->op_flags & OPf_KIDS) {
5610         SVOP *kid = (SVOP*)cUNOPo->op_first;
5611
5612         if (!kid) {
5613             o->op_flags &= ~OPf_KIDS;
5614             op_null(o);
5615         }
5616         else if (kid->op_type == OP_LINESEQ) {
5617             LOGOP *enter;
5618
5619             kid->op_next = o->op_next;
5620             cUNOPo->op_first = 0;
5621             op_free(o);
5622
5623             NewOp(1101, enter, 1, LOGOP);
5624             enter->op_type = OP_ENTERTRY;
5625             enter->op_ppaddr = PL_ppaddr[OP_ENTERTRY];
5626             enter->op_private = 0;
5627
5628             /* establish postfix order */
5629             enter->op_next = (OP*)enter;
5630
5631             o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
5632             o->op_type = OP_LEAVETRY;
5633             o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
5634             enter->op_other = o;
5635             return o;
5636         }
5637         else
5638             scalar((OP*)kid);
5639     }
5640     else {
5641         op_free(o);
5642         o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
5643     }
5644     o->op_targ = (PADOFFSET)PL_hints;
5645     return o;
5646 }
5647
5648 OP *
5649 Perl_ck_exit(pTHX_ OP *o)
5650 {
5651 #ifdef VMS
5652     HV *table = GvHV(PL_hintgv);
5653     if (table) {
5654        SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
5655        if (svp && *svp && SvTRUE(*svp))
5656            o->op_private |= OPpEXIT_VMSISH;
5657     }
5658     if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
5659 #endif
5660     return ck_fun(o);
5661 }
5662
5663 OP *
5664 Perl_ck_exec(pTHX_ OP *o)
5665 {
5666     OP *kid;
5667     if (o->op_flags & OPf_STACKED) {
5668         o = ck_fun(o);
5669         kid = cUNOPo->op_first->op_sibling;
5670         if (kid->op_type == OP_RV2GV)
5671             op_null(kid);
5672     }
5673     else
5674         o = listkids(o);
5675     return o;
5676 }
5677
5678 OP *
5679 Perl_ck_exists(pTHX_ OP *o)
5680 {
5681     o = ck_fun(o);
5682     if (o->op_flags & OPf_KIDS) {
5683         OP *kid = cUNOPo->op_first;
5684         if (kid->op_type == OP_ENTERSUB) {
5685             (void) ref(kid, o->op_type);
5686             if (kid->op_type != OP_RV2CV && !PL_error_count)
5687                 Perl_croak(aTHX_ "%s argument is not a subroutine name",
5688                             OP_DESC(o));
5689             o->op_private |= OPpEXISTS_SUB;
5690         }
5691         else if (kid->op_type == OP_AELEM)
5692             o->op_flags |= OPf_SPECIAL;
5693         else if (kid->op_type != OP_HELEM)
5694             Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
5695                         OP_DESC(o));
5696         op_null(kid);
5697     }
5698     return o;
5699 }
5700
5701 #if 0
5702 OP *
5703 Perl_ck_gvconst(pTHX_ register OP *o)
5704 {
5705     o = fold_constants(o);
5706     if (o->op_type == OP_CONST)
5707         o->op_type = OP_GV;
5708     return o;
5709 }
5710 #endif
5711
5712 OP *
5713 Perl_ck_rvconst(pTHX_ register OP *o)
5714 {
5715     SVOP *kid = (SVOP*)cUNOPo->op_first;
5716
5717     o->op_private |= (PL_hints & HINT_STRICT_REFS);
5718     if (kid->op_type == OP_CONST) {
5719         char *name;
5720         int iscv;
5721         GV *gv;
5722         SV *kidsv = kid->op_sv;
5723         STRLEN n_a;
5724
5725         /* Is it a constant from cv_const_sv()? */
5726         if (SvROK(kidsv) && SvREADONLY(kidsv)) {
5727             SV *rsv = SvRV(kidsv);
5728             int svtype = SvTYPE(rsv);
5729             char *badtype = Nullch;
5730
5731             switch (o->op_type) {
5732             case OP_RV2SV:
5733                 if (svtype > SVt_PVMG)
5734                     badtype = "a SCALAR";
5735                 break;
5736             case OP_RV2AV:
5737                 if (svtype != SVt_PVAV)
5738                     badtype = "an ARRAY";
5739                 break;
5740             case OP_RV2HV:
5741                 if (svtype != SVt_PVHV) {
5742                     if (svtype == SVt_PVAV) {   /* pseudohash? */
5743                         SV **ksv = av_fetch((AV*)rsv, 0, FALSE);
5744                         if (ksv && SvROK(*ksv)
5745                             && SvTYPE(SvRV(*ksv)) == SVt_PVHV)
5746                         {
5747                                 break;
5748                         }
5749                     }
5750                     badtype = "a HASH";
5751                 }
5752                 break;
5753             case OP_RV2CV:
5754                 if (svtype != SVt_PVCV)
5755                     badtype = "a CODE";
5756                 break;
5757             }
5758             if (badtype)
5759                 Perl_croak(aTHX_ "Constant is not %s reference", badtype);
5760             return o;
5761         }
5762         name = SvPV(kidsv, n_a);
5763         if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
5764             char *badthing = Nullch;
5765             switch (o->op_type) {
5766             case OP_RV2SV:
5767                 badthing = "a SCALAR";
5768                 break;
5769             case OP_RV2AV:
5770                 badthing = "an ARRAY";
5771                 break;
5772             case OP_RV2HV:
5773                 badthing = "a HASH";
5774                 break;
5775             }
5776             if (badthing)
5777                 Perl_croak(aTHX_
5778           "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use",
5779                       name, badthing);
5780         }
5781         /*
5782          * This is a little tricky.  We only want to add the symbol if we
5783          * didn't add it in the lexer.  Otherwise we get duplicate strict
5784          * warnings.  But if we didn't add it in the lexer, we must at
5785          * least pretend like we wanted to add it even if it existed before,
5786          * or we get possible typo warnings.  OPpCONST_ENTERED says
5787          * whether the lexer already added THIS instance of this symbol.
5788          */
5789         iscv = (o->op_type == OP_RV2CV) * 2;
5790         do {
5791             gv = gv_fetchpv(name,
5792                 iscv | !(kid->op_private & OPpCONST_ENTERED),
5793                 iscv
5794                     ? SVt_PVCV
5795                     : o->op_type == OP_RV2SV
5796                         ? SVt_PV
5797                         : o->op_type == OP_RV2AV
5798                             ? SVt_PVAV
5799                             : o->op_type == OP_RV2HV
5800                                 ? SVt_PVHV
5801                                 : SVt_PVGV);
5802         } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
5803         if (gv) {
5804             kid->op_type = OP_GV;
5805             SvREFCNT_dec(kid->op_sv);
5806 #ifdef USE_ITHREADS
5807             /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
5808             kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
5809             SvREFCNT_dec(PL_curpad[kPADOP->op_padix]);
5810             GvIN_PAD_on(gv);
5811             PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv);
5812 #else
5813             kid->op_sv = SvREFCNT_inc(gv);
5814 #endif
5815             kid->op_private = 0;
5816             kid->op_ppaddr = PL_ppaddr[OP_GV];
5817         }
5818     }
5819     return o;
5820 }
5821
5822 OP *
5823 Perl_ck_ftst(pTHX_ OP *o)
5824 {
5825     I32 type = o->op_type;
5826
5827     if (o->op_flags & OPf_REF) {
5828         /* nothing */
5829     }
5830     else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) {
5831         SVOP *kid = (SVOP*)cUNOPo->op_first;
5832
5833         if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
5834             STRLEN n_a;
5835             OP *newop = newGVOP(type, OPf_REF,
5836                 gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO));
5837             op_free(o);
5838             o = newop;
5839         }
5840     }
5841     else {
5842         op_free(o);
5843         if (type == OP_FTTTY)
5844            o =  newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
5845                                 SVt_PVIO));
5846         else
5847             o = newUNOP(type, 0, newDEFSVOP());
5848     }
5849     return o;
5850 }
5851
5852 OP *
5853 Perl_ck_fun(pTHX_ OP *o)
5854 {
5855     register OP *kid;
5856     OP **tokid;
5857     OP *sibl;
5858     I32 numargs = 0;
5859     int type = o->op_type;
5860     register I32 oa = PL_opargs[type] >> OASHIFT;
5861
5862     if (o->op_flags & OPf_STACKED) {
5863         if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL))
5864             oa &= ~OA_OPTIONAL;
5865         else
5866             return no_fh_allowed(o);
5867     }
5868
5869     if (o->op_flags & OPf_KIDS) {
5870         STRLEN n_a;
5871         tokid = &cLISTOPo->op_first;
5872         kid = cLISTOPo->op_first;
5873         if (kid->op_type == OP_PUSHMARK ||
5874             (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
5875         {
5876             tokid = &kid->op_sibling;
5877             kid = kid->op_sibling;
5878         }
5879         if (!kid && PL_opargs[type] & OA_DEFGV)
5880             *tokid = kid = newDEFSVOP();
5881
5882         while (oa && kid) {
5883             numargs++;
5884             sibl = kid->op_sibling;
5885             switch (oa & 7) {
5886             case OA_SCALAR:
5887                 /* list seen where single (scalar) arg expected? */
5888                 if (numargs == 1 && !(oa >> 4)
5889                     && kid->op_type == OP_LIST && type != OP_SCALAR)
5890                 {
5891                     return too_many_arguments(o,PL_op_desc[type]);
5892                 }
5893                 scalar(kid);
5894                 break;
5895             case OA_LIST:
5896                 if (oa < 16) {
5897                     kid = 0;
5898                     continue;
5899                 }
5900                 else
5901                     list(kid);
5902                 break;
5903             case OA_AVREF:
5904                 if ((type == OP_PUSH || type == OP_UNSHIFT)
5905                     && !kid->op_sibling && ckWARN(WARN_SYNTAX))
5906                     Perl_warner(aTHX_ WARN_SYNTAX,
5907                         "Useless use of %s with no values",
5908                         PL_op_desc[type]);
5909
5910                 if (kid->op_type == OP_CONST &&
5911                     (kid->op_private & OPpCONST_BARE))
5912                 {
5913                     char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5914                     OP *newop = newAVREF(newGVOP(OP_GV, 0,
5915                         gv_fetchpv(name, TRUE, SVt_PVAV) ));
5916                     if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5917                         Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5918                             "Array @%s missing the @ in argument %"IVdf" of %s()",
5919                             name, (IV)numargs, PL_op_desc[type]);
5920                     op_free(kid);
5921                     kid = newop;
5922                     kid->op_sibling = sibl;
5923                     *tokid = kid;
5924                 }
5925                 else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
5926                     bad_type(numargs, "array", PL_op_desc[type], kid);
5927                 mod(kid, type);
5928                 break;
5929             case OA_HVREF:
5930                 if (kid->op_type == OP_CONST &&
5931                     (kid->op_private & OPpCONST_BARE))
5932                 {
5933                     char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
5934                     OP *newop = newHVREF(newGVOP(OP_GV, 0,
5935                         gv_fetchpv(name, TRUE, SVt_PVHV) ));
5936                     if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
5937                         Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
5938                             "Hash %%%s missing the %% in argument %"IVdf" of %s()",
5939                             name, (IV)numargs, PL_op_desc[type]);
5940                     op_free(kid);
5941                     kid = newop;
5942                     kid->op_sibling = sibl;
5943                     *tokid = kid;
5944                 }
5945                 else if (kid->op_type != OP_RV2HV && kid->op_type != OP_PADHV)
5946                     bad_type(numargs, "hash", PL_op_desc[type], kid);
5947                 mod(kid, type);
5948                 break;
5949             case OA_CVREF:
5950                 {
5951                     OP *newop = newUNOP(OP_NULL, 0, kid);
5952                     kid->op_sibling = 0;
5953                     linklist(kid);
5954                     newop->op_next = newop;
5955                     kid = newop;
5956                     kid->op_sibling = sibl;
5957                     *tokid = kid;
5958                 }
5959                 break;
5960             case OA_FILEREF:
5961                 if (kid->op_type != OP_GV && kid->op_type != OP_RV2GV) {
5962                     if (kid->op_type == OP_CONST &&
5963                         (kid->op_private & OPpCONST_BARE))
5964                     {
5965                         OP *newop = newGVOP(OP_GV, 0,
5966                             gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
5967                                         SVt_PVIO) );
5968                         if (kid == cLISTOPo->op_last)
5969                             cLISTOPo->op_last = newop;
5970                         op_free(kid);
5971                         kid = newop;
5972                     }
5973                     else if (kid->op_type == OP_READLINE) {
5974                         /* neophyte patrol: open(<FH>), close(<FH>) etc. */
5975                         bad_type(numargs, "HANDLE", OP_DESC(o), kid);
5976                     }
5977                     else {
5978                         I32 flags = OPf_SPECIAL;
5979                         I32 priv = 0;
5980                         PADOFFSET targ = 0;
5981
5982                         /* is this op a FH constructor? */
5983                         if (is_handle_constructor(o,numargs)) {
5984                             char *name = Nullch;
5985                             STRLEN len;
5986
5987                             flags = 0;
5988                             /* Set a flag to tell rv2gv to vivify
5989                              * need to "prove" flag does not mean something
5990                              * else already - NI-S 1999/05/07
5991                              */
5992                             priv = OPpDEREF;
5993                             if (kid->op_type == OP_PADSV) {
5994                                 SV **namep = av_fetch(PL_comppad_name,
5995                                                       kid->op_targ, 4);
5996                                 if (namep && *namep)
5997                                     name = SvPV(*namep, len);
5998                             }
5999                             else if (kid->op_type == OP_RV2SV
6000                                      && kUNOP->op_first->op_type == OP_GV)
6001                             {
6002                                 GV *gv = cGVOPx_gv(kUNOP->op_first);
6003                                 name = GvNAME(gv);
6004                                 len = GvNAMELEN(gv);
6005                             }
6006                             else if (kid->op_type == OP_AELEM
6007                                      || kid->op_type == OP_HELEM)
6008                             {
6009                                 name = "__ANONIO__";
6010                                 len = 10;
6011                                 mod(kid,type);
6012                             }
6013                             if (name) {
6014                                 SV *namesv;
6015                                 targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
6016                                 namesv = PL_curpad[targ];
6017                                 (void)SvUPGRADE(namesv, SVt_PV);
6018                                 if (*name != '$')
6019                                     sv_setpvn(namesv, "$", 1);
6020                                 sv_catpvn(namesv, name, len);
6021                             }
6022                         }
6023                         kid->op_sibling = 0;
6024                         kid = newUNOP(OP_RV2GV, flags, scalar(kid));
6025                         kid->op_targ = targ;
6026                         kid->op_private |= priv;
6027                     }
6028                     kid->op_sibling = sibl;
6029                     *tokid = kid;
6030                 }
6031                 scalar(kid);
6032                 break;
6033             case OA_SCALARREF:
6034                 mod(scalar(kid), type);
6035                 break;
6036             }
6037             oa >>= 4;
6038             tokid = &kid->op_sibling;
6039             kid = kid->op_sibling;
6040         }
6041         o->op_private |= numargs;
6042         if (kid)
6043             return too_many_arguments(o,OP_DESC(o));
6044         listkids(o);
6045     }
6046     else if (PL_opargs[type] & OA_DEFGV) {
6047         op_free(o);
6048         return newUNOP(type, 0, newDEFSVOP());
6049     }
6050
6051     if (oa) {
6052         while (oa & OA_OPTIONAL)
6053             oa >>= 4;
6054         if (oa && oa != OA_LIST)
6055             return too_few_arguments(o,OP_DESC(o));
6056     }
6057     return o;
6058 }
6059
6060 OP *
6061 Perl_ck_glob(pTHX_ OP *o)
6062 {
6063     GV *gv;
6064
6065     o = ck_fun(o);
6066     if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
6067         append_elem(OP_GLOB, o, newDEFSVOP());
6068
6069     if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
6070           && GvCVu(gv) && GvIMPORTED_CV(gv)))
6071     {
6072         gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
6073     }
6074
6075 #if !defined(PERL_EXTERNAL_GLOB)
6076     /* XXX this can be tightened up and made more failsafe. */
6077     if (!gv) {
6078         GV *glob_gv;
6079         ENTER;
6080         Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
6081                 newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
6082         gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
6083         glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
6084         GvCV(gv) = GvCV(glob_gv);
6085         SvREFCNT_inc((SV*)GvCV(gv));
6086         GvIMPORTED_CV_on(gv);
6087         LEAVE;
6088     }
6089 #endif /* PERL_EXTERNAL_GLOB */
6090
6091     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6092         append_elem(OP_GLOB, o,
6093                     newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
6094         o->op_type = OP_LIST;
6095         o->op_ppaddr = PL_ppaddr[OP_LIST];
6096         cLISTOPo->op_first->op_type = OP_PUSHMARK;
6097         cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
6098         o = newUNOP(OP_ENTERSUB, OPf_STACKED,
6099                     append_elem(OP_LIST, o,
6100                                 scalar(newUNOP(OP_RV2CV, 0,
6101                                                newGVOP(OP_GV, 0, gv)))));
6102         o = newUNOP(OP_NULL, 0, ck_subr(o));
6103         o->op_targ = OP_GLOB;           /* hint at what it used to be */
6104         return o;
6105     }
6106     gv = newGVgen("main");
6107     gv_IOadd(gv);
6108     append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
6109     scalarkids(o);
6110     return o;
6111 }
6112
6113 OP *
6114 Perl_ck_grep(pTHX_ OP *o)
6115 {
6116     LOGOP *gwop;
6117     OP *kid;
6118     OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
6119
6120     o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
6121     NewOp(1101, gwop, 1, LOGOP);
6122
6123     if (o->op_flags & OPf_STACKED) {
6124         OP* k;
6125         o = ck_sort(o);
6126         kid = cLISTOPo->op_first->op_sibling;
6127         for (k = cLISTOPo->op_first->op_sibling->op_next; k; k = k->op_next) {
6128             kid = k;
6129         }
6130         kid->op_next = (OP*)gwop;
6131         o->op_flags &= ~OPf_STACKED;
6132     }
6133     kid = cLISTOPo->op_first->op_sibling;
6134     if (type == OP_MAPWHILE)
6135         list(kid);
6136     else
6137         scalar(kid);
6138     o = ck_fun(o);
6139     if (PL_error_count)
6140         return o;
6141     kid = cLISTOPo->op_first->op_sibling;
6142     if (kid->op_type != OP_NULL)
6143         Perl_croak(aTHX_ "panic: ck_grep");
6144     kid = kUNOP->op_first;
6145
6146     gwop->op_type = type;
6147     gwop->op_ppaddr = PL_ppaddr[type];
6148     gwop->op_first = listkids(o);
6149     gwop->op_flags |= OPf_KIDS;
6150     gwop->op_private = 1;
6151     gwop->op_other = LINKLIST(kid);
6152     gwop->op_targ = pad_alloc(type, SVs_PADTMP);
6153     kid->op_next = (OP*)gwop;
6154
6155     kid = cLISTOPo->op_first->op_sibling;
6156     if (!kid || !kid->op_sibling)
6157         return too_few_arguments(o,OP_DESC(o));
6158     for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
6159         mod(kid, OP_GREPSTART);
6160
6161     return (OP*)gwop;
6162 }
6163
6164 OP *
6165 Perl_ck_index(pTHX_ OP *o)
6166 {
6167     if (o->op_flags & OPf_KIDS) {
6168         OP *kid = cLISTOPo->op_first->op_sibling;       /* get past pushmark */
6169         if (kid)
6170             kid = kid->op_sibling;                      /* get past "big" */
6171         if (kid && kid->op_type == OP_CONST)
6172             fbm_compile(((SVOP*)kid)->op_sv, 0);
6173     }
6174     return ck_fun(o);
6175 }
6176
6177 OP *
6178 Perl_ck_lengthconst(pTHX_ OP *o)
6179 {
6180     /* XXX length optimization goes here */
6181     return ck_fun(o);
6182 }
6183
6184 OP *
6185 Perl_ck_lfun(pTHX_ OP *o)
6186 {
6187     OPCODE type = o->op_type;
6188     return modkids(ck_fun(o), type);
6189 }
6190
6191 OP *
6192 Perl_ck_defined(pTHX_ OP *o)            /* 19990527 MJD */
6193 {
6194     if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
6195         switch (cUNOPo->op_first->op_type) {
6196         case OP_RV2AV:
6197             /* This is needed for
6198                if (defined %stash::)
6199                to work.   Do not break Tk.
6200                */
6201             break;                      /* Globals via GV can be undef */
6202         case OP_PADAV:
6203         case OP_AASSIGN:                /* Is this a good idea? */
6204             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6205                         "defined(@array) is deprecated");
6206             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6207                         "\t(Maybe you should just omit the defined()?)\n");
6208         break;
6209         case OP_RV2HV:
6210             /* This is needed for
6211                if (defined %stash::)
6212                to work.   Do not break Tk.
6213                */
6214             break;                      /* Globals via GV can be undef */
6215         case OP_PADHV:
6216             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6217                         "defined(%%hash) is deprecated");
6218             Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
6219                         "\t(Maybe you should just omit the defined()?)\n");
6220             break;
6221         default:
6222             /* no warning */
6223             break;
6224         }
6225     }
6226     return ck_rfun(o);
6227 }
6228
6229 OP *
6230 Perl_ck_rfun(pTHX_ OP *o)
6231 {
6232     OPCODE type = o->op_type;
6233     return refkids(ck_fun(o), type);
6234 }
6235
6236 OP *
6237 Perl_ck_listiob(pTHX_ OP *o)
6238 {
6239     register OP *kid;
6240
6241     kid = cLISTOPo->op_first;
6242     if (!kid) {
6243         o = force_list(o);
6244         kid = cLISTOPo->op_first;
6245     }
6246     if (kid->op_type == OP_PUSHMARK)
6247         kid = kid->op_sibling;
6248     if (kid && o->op_flags & OPf_STACKED)
6249         kid = kid->op_sibling;
6250     else if (kid && !kid->op_sibling) {         /* print HANDLE; */
6251         if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) {
6252             o->op_flags |= OPf_STACKED; /* make it a filehandle */
6253             kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
6254             cLISTOPo->op_first->op_sibling = kid;
6255             cLISTOPo->op_last = kid;
6256             kid = kid->op_sibling;
6257         }
6258     }
6259
6260     if (!kid)
6261         append_elem(o->op_type, o, newDEFSVOP());
6262
6263     return listkids(o);
6264 }
6265
6266 OP *
6267 Perl_ck_sassign(pTHX_ OP *o)
6268 {
6269     OP *kid = cLISTOPo->op_first;
6270     /* has a disposable target? */
6271     if ((PL_opargs[kid->op_type] & OA_TARGLEX)
6272         && !(kid->op_flags & OPf_STACKED)
6273         /* Cannot steal the second time! */
6274         && !(kid->op_private & OPpTARGET_MY))
6275     {
6276         OP *kkid = kid->op_sibling;
6277
6278         /* Can just relocate the target. */
6279         if (kkid && kkid->op_type == OP_PADSV
6280             && !(kkid->op_private & OPpLVAL_INTRO))
6281         {
6282             kid->op_targ = kkid->op_targ;
6283             kkid->op_targ = 0;
6284             /* Now we do not need PADSV and SASSIGN. */
6285             kid->op_sibling = o->op_sibling;    /* NULL */
6286             cLISTOPo->op_first = NULL;
6287             op_free(o);
6288             op_free(kkid);
6289             kid->op_private |= OPpTARGET_MY;    /* Used for context settings */
6290             return kid;
6291         }
6292     }
6293     return o;
6294 }
6295
6296 OP *
6297 Perl_ck_match(pTHX_ OP *o)
6298 {
6299     o->op_private |= OPpRUNTIME;
6300     return o;
6301 }
6302
6303 OP *
6304 Perl_ck_method(pTHX_ OP *o)
6305 {
6306     OP *kid = cUNOPo->op_first;
6307     if (kid->op_type == OP_CONST) {
6308         SV* sv = kSVOP->op_sv;
6309         if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) {
6310             OP *cmop;
6311             if (!SvREADONLY(sv) || !SvFAKE(sv)) {
6312                 sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0);
6313             }
6314             else {
6315                 kSVOP->op_sv = Nullsv;
6316             }
6317             cmop = newSVOP(OP_METHOD_NAMED, 0, sv);
6318             op_free(o);
6319             return cmop;
6320         }
6321     }
6322     return o;
6323 }
6324
6325 OP *
6326 Perl_ck_null(pTHX_ OP *o)
6327 {
6328     return o;
6329 }
6330
6331 OP *
6332 Perl_ck_open(pTHX_ OP *o)
6333 {
6334     HV *table = GvHV(PL_hintgv);
6335     if (table) {
6336         SV **svp;
6337         I32 mode;
6338         svp = hv_fetch(table, "open_IN", 7, FALSE);
6339         if (svp && *svp) {
6340             mode = mode_from_discipline(*svp);
6341             if (mode & O_BINARY)
6342                 o->op_private |= OPpOPEN_IN_RAW;
6343             else if (mode & O_TEXT)
6344                 o->op_private |= OPpOPEN_IN_CRLF;
6345         }
6346
6347         svp = hv_fetch(table, "open_OUT", 8, FALSE);
6348         if (svp && *svp) {
6349             mode = mode_from_discipline(*svp);
6350             if (mode & O_BINARY)
6351                 o->op_private |= OPpOPEN_OUT_RAW;
6352             else if (mode & O_TEXT)
6353                 o->op_private |= OPpOPEN_OUT_CRLF;
6354         }
6355     }
6356     if (o->op_type == OP_BACKTICK)
6357         return o;
6358     return ck_fun(o);
6359 }
6360
6361 OP *
6362 Perl_ck_repeat(pTHX_ OP *o)
6363 {
6364     if (cBINOPo->op_first->op_flags & OPf_PARENS) {
6365         o->op_private |= OPpREPEAT_DOLIST;
6366         cBINOPo->op_first = force_list(cBINOPo->op_first);
6367     }
6368     else
6369         scalar(o);
6370     return o;
6371 }
6372
6373 OP *
6374 Perl_ck_require(pTHX_ OP *o)
6375 {
6376     GV* gv;
6377
6378     if (o->op_flags & OPf_KIDS) {       /* Shall we supply missing .pm? */
6379         SVOP *kid = (SVOP*)cUNOPo->op_first;
6380
6381         if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
6382             char *s;
6383             for (s = SvPVX(kid->op_sv); *s; s++) {
6384                 if (*s == ':' && s[1] == ':') {
6385                     *s = '/';
6386                     Move(s+2, s+1, strlen(s+2)+1, char);
6387                     --SvCUR(kid->op_sv);
6388                 }
6389             }
6390             if (SvREADONLY(kid->op_sv)) {
6391                 SvREADONLY_off(kid->op_sv);
6392                 sv_catpvn(kid->op_sv, ".pm", 3);
6393                 SvREADONLY_on(kid->op_sv);
6394             }
6395             else
6396                 sv_catpvn(kid->op_sv, ".pm", 3);
6397         }
6398     }
6399
6400     /* handle override, if any */
6401     gv = gv_fetchpv("require", FALSE, SVt_PVCV);
6402     if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
6403         gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
6404
6405     if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
6406         OP *kid = cUNOPo->op_first;
6407         cUNOPo->op_first = 0;
6408         op_free(o);
6409         return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
6410                                append_elem(OP_LIST, kid,
6411                                            scalar(newUNOP(OP_RV2CV, 0,
6412                                                           newGVOP(OP_GV, 0,
6413                                                                   gv))))));
6414     }
6415
6416     return ck_fun(o);
6417 }
6418
6419 OP *
6420 Perl_ck_return(pTHX_ OP *o)
6421 {
6422     OP *kid;
6423     if (CvLVALUE(PL_compcv)) {
6424         for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
6425             mod(kid, OP_LEAVESUBLV);
6426     }
6427     return o;
6428 }
6429
6430 #if 0
6431 OP *
6432 Perl_ck_retarget(pTHX_ OP *o)
6433 {
6434     Perl_croak(aTHX_ "NOT IMPL LINE %d",__LINE__);
6435     /* STUB */
6436     return o;
6437 }
6438 #endif
6439
6440 OP *
6441 Perl_ck_select(pTHX_ OP *o)
6442 {
6443     OP* kid;
6444     if (o->op_flags & OPf_KIDS) {
6445         kid = cLISTOPo->op_first->op_sibling;   /* get past pushmark */
6446         if (kid && kid->op_sibling) {
6447             o->op_type = OP_SSELECT;
6448             o->op_ppaddr = PL_ppaddr[OP_SSELECT];
6449             o = ck_fun(o);
6450             return fold_constants(o);
6451         }
6452     }
6453     o = ck_fun(o);
6454     kid = cLISTOPo->op_first->op_sibling;    /* get past pushmark */
6455     if (kid && kid->op_type == OP_RV2GV)
6456         kid->op_private &= ~HINT_STRICT_REFS;
6457     return o;
6458 }
6459
6460 OP *
6461 Perl_ck_shift(pTHX_ OP *o)
6462 {
6463     I32 type = o->op_type;
6464
6465     if (!(o->op_flags & OPf_KIDS)) {
6466         OP *argop;
6467
6468         op_free(o);
6469 #ifdef USE_5005THREADS
6470         if (!CvUNIQUE(PL_compcv)) {
6471             argop = newOP(OP_PADAV, OPf_REF);
6472             argop->op_targ = 0;         /* PL_curpad[0] is @_ */
6473         }
6474         else {
6475             argop = newUNOP(OP_RV2AV, 0,
6476                 scalar(newGVOP(OP_GV, 0,
6477                     gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6478         }
6479 #else
6480         argop = newUNOP(OP_RV2AV, 0,
6481             scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
6482                            PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
6483 #endif /* USE_5005THREADS */
6484         return newUNOP(type, 0, scalar(argop));
6485     }
6486     return scalar(modkids(ck_fun(o), type));
6487 }
6488
6489 OP *
6490 Perl_ck_sort(pTHX_ OP *o)
6491 {
6492     OP *firstkid;
6493
6494     if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
6495         simplify_sort(o);
6496     firstkid = cLISTOPo->op_first->op_sibling;          /* get past pushmark */
6497     if (o->op_flags & OPf_STACKED) {                    /* may have been cleared */
6498         OP *k = NULL;
6499         OP *kid = cUNOPx(firstkid)->op_first;           /* get past null */
6500
6501         if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
6502             linklist(kid);
6503             if (kid->op_type == OP_SCOPE) {
6504                 k = kid->op_next;
6505                 kid->op_next = 0;
6506             }
6507             else if (kid->op_type == OP_LEAVE) {
6508                 if (o->op_type == OP_SORT) {
6509                     op_null(kid);                       /* wipe out leave */
6510                     kid->op_next = kid;
6511
6512                     for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
6513                         if (k->op_next == kid)
6514                             k->op_next = 0;
6515                         /* don't descend into loops */
6516                         else if (k->op_type == OP_ENTERLOOP
6517                                  || k->op_type == OP_ENTERITER)
6518                         {
6519                             k = cLOOPx(k)->op_lastop;
6520                         }
6521                     }
6522                 }
6523                 else
6524                     kid->op_next = 0;           /* just disconnect the leave */
6525                 k = kLISTOP->op_first;
6526             }
6527             CALL_PEEP(k);
6528
6529             kid = firstkid;
6530             if (o->op_type == OP_SORT) {
6531                 /* provide scalar context for comparison function/block */
6532                 kid = scalar(kid);
6533                 kid->op_next = kid;
6534             }
6535             else
6536                 kid->op_next = k;
6537             o->op_flags |= OPf_SPECIAL;
6538         }
6539         else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
6540             op_null(firstkid);
6541
6542         firstkid = firstkid->op_sibling;
6543     }
6544
6545     /* provide list context for arguments */
6546     if (o->op_type == OP_SORT)
6547         list(firstkid);
6548
6549     return o;
6550 }
6551
6552 STATIC void
6553 S_simplify_sort(pTHX_ OP *o)
6554 {
6555     register OP *kid = cLISTOPo->op_first->op_sibling;  /* get past pushmark */
6556     OP *k;
6557     int reversed;
6558     GV *gv;
6559     if (!(o->op_flags & OPf_STACKED))
6560         return;
6561     GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
6562     GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
6563     kid = kUNOP->op_first;                              /* get past null */
6564     if (kid->op_type != OP_SCOPE)
6565         return;
6566     kid = kLISTOP->op_last;                             /* get past scope */
6567     switch(kid->op_type) {
6568         case OP_NCMP:
6569         case OP_I_NCMP:
6570         case OP_SCMP:
6571             break;
6572         default:
6573             return;
6574     }
6575     k = kid;                                            /* remember this node*/
6576     if (kBINOP->op_first->op_type != OP_RV2SV)
6577         return;
6578     kid = kBINOP->op_first;                             /* get past cmp */
6579     if (kUNOP->op_first->op_type != OP_GV)
6580         return;
6581     kid = kUNOP->op_first;                              /* get past rv2sv */
6582     gv = kGVOP_gv;
6583     if (GvSTASH(gv) != PL_curstash)
6584         return;
6585     if (strEQ(GvNAME(gv), "a"))
6586         reversed = 0;
6587     else if (strEQ(GvNAME(gv), "b"))
6588         reversed = 1;
6589     else
6590         return;
6591     kid = k;                                            /* back to cmp */
6592     if (kBINOP->op_last->op_type != OP_RV2SV)
6593         return;
6594     kid = kBINOP->op_last;                              /* down to 2nd arg */
6595     if (kUNOP->op_first->op_type != OP_GV)
6596         return;
6597     kid = kUNOP->op_first;                              /* get past rv2sv */
6598     gv = kGVOP_gv;
6599     if (GvSTASH(gv) != PL_curstash
6600         || ( reversed
6601             ? strNE(GvNAME(gv), "a")
6602             : strNE(GvNAME(gv), "b")))
6603         return;
6604     o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL);
6605     if (reversed)
6606         o->op_private |= OPpSORT_REVERSE;
6607     if (k->op_type == OP_NCMP)
6608         o->op_private |= OPpSORT_NUMERIC;
6609     if (k->op_type == OP_I_NCMP)
6610         o->op_private |= OPpSORT_NUMERIC | OPpSORT_INTEGER;
6611     kid = cLISTOPo->op_first->op_sibling;
6612     cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
6613     op_free(kid);                                     /* then delete it */
6614 }
6615
6616 OP *
6617 Perl_ck_split(pTHX_ OP *o)
6618 {
6619     register OP *kid;
6620
6621     if (o->op_flags & OPf_STACKED)
6622         return no_fh_allowed(o);
6623
6624     kid = cLISTOPo->op_first;
6625     if (kid->op_type != OP_NULL)
6626         Perl_croak(aTHX_ "panic: ck_split");
6627     kid = kid->op_sibling;
6628     op_free(cLISTOPo->op_first);
6629     cLISTOPo->op_first = kid;
6630     if (!kid) {
6631         cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
6632         cLISTOPo->op_last = kid; /* There was only one element previously */
6633     }
6634
6635     if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
6636         OP *sibl = kid->op_sibling;
6637         kid->op_sibling = 0;
6638         kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop);
6639         if (cLISTOPo->op_first == cLISTOPo->op_last)
6640             cLISTOPo->op_last = kid;
6641         cLISTOPo->op_first = kid;
6642         kid->op_sibling = sibl;
6643     }
6644
6645     kid->op_type = OP_PUSHRE;
6646     kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
6647     scalar(kid);
6648
6649     if (!kid->op_sibling)
6650         append_elem(OP_SPLIT, o, newDEFSVOP());
6651
6652     kid = kid->op_sibling;
6653     scalar(kid);
6654
6655     if (!kid->op_sibling)
6656         append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
6657
6658     kid = kid->op_sibling;
6659     scalar(kid);
6660
6661     if (kid->op_sibling)
6662         return too_many_arguments(o,OP_DESC(o));
6663
6664     return o;
6665 }
6666
6667 OP *
6668 Perl_ck_join(pTHX_ OP *o)
6669 {
6670     if (ckWARN(WARN_SYNTAX)) {
6671         OP *kid = cLISTOPo->op_first->op_sibling;
6672         if (kid && kid->op_type == OP_MATCH) {
6673             char *pmstr = "STRING";
6674             if (PM_GETRE(kPMOP))
6675                 pmstr = PM_GETRE(kPMOP)->precomp;
6676             Perl_warner(aTHX_ WARN_SYNTAX,
6677                         "/%s/ should probably be written as \"%s\"",
6678                         pmstr, pmstr);
6679         }
6680     }
6681     return ck_fun(o);
6682 }
6683
6684 OP *
6685 Perl_ck_subr(pTHX_ OP *o)
6686 {
6687     OP *prev = ((cUNOPo->op_first->op_sibling)
6688              ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
6689     OP *o2 = prev->op_sibling;
6690     OP *cvop;
6691     char *proto = 0;
6692     CV *cv = 0;
6693     GV *namegv = 0;
6694     int optional = 0;
6695     I32 arg = 0;
6696     I32 contextclass = 0;
6697     char *e = 0;
6698     STRLEN n_a;
6699
6700     o->op_private |= OPpENTERSUB_HASTARG;
6701     for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
6702     if (cvop->op_type == OP_RV2CV) {
6703         SVOP* tmpop;
6704         o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
6705         op_null(cvop);          /* disable rv2cv */
6706         tmpop = (SVOP*)((UNOP*)cvop)->op_first;
6707         if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
6708             GV *gv = cGVOPx_gv(tmpop);
6709             cv = GvCVu(gv);
6710             if (!cv)
6711                 tmpop->op_private |= OPpEARLY_CV;
6712             else if (SvPOK(cv)) {
6713                 namegv = CvANON(cv) ? gv : CvGV(cv);
6714                 proto = SvPV((SV*)cv, n_a);
6715             }
6716         }
6717     }
6718     else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
6719         if (o2->op_type == OP_CONST)
6720             o2->op_private &= ~OPpCONST_STRICT;
6721         else if (o2->op_type == OP_LIST) {
6722             OP *o = ((UNOP*)o2)->op_first->op_sibling;
6723             if (o && o->op_type == OP_CONST)
6724                 o->op_private &= ~OPpCONST_STRICT;
6725         }
6726     }
6727     o->op_private |= (PL_hints & HINT_STRICT_REFS);
6728     if (PERLDB_SUB && PL_curstash != PL_debstash)
6729         o->op_private |= OPpENTERSUB_DB;
6730     while (o2 != cvop) {
6731         if (proto) {
6732             switch (*proto) {
6733             case '\0':
6734                 return too_many_arguments(o, gv_ename(namegv));
6735             case ';':
6736                 optional = 1;
6737                 proto++;
6738                 continue;
6739             case '$':
6740                 proto++;
6741                 arg++;
6742                 scalar(o2);
6743                 break;
6744             case '%':
6745             case '@':
6746                 list(o2);
6747                 arg++;
6748                 break;
6749             case '&':
6750                 proto++;
6751                 arg++;
6752                 if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
6753                     bad_type(arg,
6754                         arg == 1 ? "block or sub {}" : "sub {}",
6755                         gv_ename(namegv), o2);
6756                 break;
6757             case '*':
6758                 /* '*' allows any scalar type, including bareword */
6759                 proto++;
6760                 arg++;
6761                 if (o2->op_type == OP_RV2GV)
6762                     goto wrapref;       /* autoconvert GLOB -> GLOBref */
6763                 else if (o2->op_type == OP_CONST)
6764                     o2->op_private &= ~OPpCONST_STRICT;
6765                 else if (o2->op_type == OP_ENTERSUB) {
6766                     /* accidental subroutine, revert to bareword */
6767                     OP *gvop = ((UNOP*)o2)->op_first;
6768                     if (gvop && gvop->op_type == OP_NULL) {
6769                         gvop = ((UNOP*)gvop)->op_first;
6770                         if (gvop) {
6771                             for (; gvop->op_sibling; gvop = gvop->op_sibling)
6772                                 ;
6773                             if (gvop &&
6774                                 (gvop->op_private & OPpENTERSUB_NOPAREN) &&
6775                                 (gvop = ((UNOP*)gvop)->op_first) &&
6776                                 gvop->op_type == OP_GV)
6777                             {
6778                                 GV *gv = cGVOPx_gv(gvop);
6779                                 OP *sibling = o2->op_sibling;
6780                                 SV *n = newSVpvn("",0);
6781                                 op_free(o2);
6782                                 gv_fullname3(n, gv, "");
6783                                 if (SvCUR(n)>6 && strnEQ(SvPVX(n),"main::",6))
6784                                     sv_chop(n, SvPVX(n)+6);
6785                                 o2 = newSVOP(OP_CONST, 0, n);
6786                                 prev->op_sibling = o2;
6787                                 o2->op_sibling = sibling;
6788                             }
6789                         }
6790                     }
6791                 }
6792                 scalar(o2);
6793                 break;
6794             case '[': case ']':
6795                  goto oops;
6796                  break;
6797             case '\\':
6798                 proto++;
6799                 arg++;
6800             again:
6801                 switch (*proto++) {
6802                 case '[':
6803                      if (contextclass++ == 0) {
6804                           e = strchr(proto, ']');
6805                           if (!e || e == proto)
6806                                goto oops;
6807                      }
6808                      else
6809                           goto oops;
6810                      goto again;
6811                      break;
6812                 case ']':
6813                      if (contextclass) {
6814                          char *p = proto;
6815                          char s = *p;
6816                          contextclass = 0;
6817                          *p = '\0';
6818                          while (*--p != '[');
6819                          bad_type(arg, Perl_form(aTHX_ "one of %s", p),
6820                                  gv_ename(namegv), o2);
6821                          *proto = s;
6822                      } else
6823                           goto oops;
6824                      break;
6825                 case '*':
6826                      if (o2->op_type == OP_RV2GV)
6827                           goto wrapref;
6828                      if (!contextclass)
6829                           bad_type(arg, "symbol", gv_ename(namegv), o2);
6830                      break;
6831                 case '&':
6832                      if (o2->op_type == OP_ENTERSUB)
6833                           goto wrapref;
6834                      if (!contextclass)
6835                           bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
6836                      break;
6837                 case '$':
6838                     if (o2->op_type == OP_RV2SV ||
6839                         o2->op_type == OP_PADSV ||
6840                         o2->op_type == OP_HELEM ||
6841                         o2->op_type == OP_AELEM ||
6842                         o2->op_type == OP_THREADSV)
6843                          goto wrapref;
6844                     if (!contextclass)
6845                         bad_type(arg, "scalar", gv_ename(namegv), o2);
6846                      break;
6847                 case '@':
6848                     if (o2->op_type == OP_RV2AV ||
6849                         o2->op_type == OP_PADAV)
6850                          goto wrapref;
6851                     if (!contextclass)
6852                         bad_type(arg, "array", gv_ename(namegv), o2);
6853                     break;
6854                 case '%':
6855                     if (o2->op_type == OP_RV2HV ||
6856                         o2->op_type == OP_PADHV)
6857                          goto wrapref;
6858                     if (!contextclass)
6859                          bad_type(arg, "hash", gv_ename(namegv), o2);
6860                     break;
6861                 wrapref:
6862                     {
6863                         OP* kid = o2;
6864                         OP* sib = kid->op_sibling;
6865                         kid->op_sibling = 0;
6866                         o2 = newUNOP(OP_REFGEN, 0, kid);
6867                         o2->op_sibling = sib;
6868                         prev->op_sibling = o2;
6869                     }
6870                     if (contextclass && e) {
6871                          proto = e + 1;
6872                          contextclass = 0;
6873                     }
6874                     break;
6875                 default: goto oops;
6876                 }
6877                 if (contextclass)
6878                      goto again;
6879                 break;
6880             case ' ':
6881                 proto++;
6882                 continue;
6883             default:
6884               oops:
6885                 Perl_croak(aTHX_ "Malformed prototype for %s: %s",
6886                            gv_ename(namegv), SvPV((SV*)cv, n_a));
6887             }
6888         }
6889         else
6890             list(o2);
6891         mod(o2, OP_ENTERSUB);
6892         prev = o2;
6893         o2 = o2->op_sibling;
6894     }
6895     if (proto && !optional &&
6896           (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
6897         return too_few_arguments(o, gv_ename(namegv));
6898     return o;
6899 }
6900
6901 OP *
6902 Perl_ck_svconst(pTHX_ OP *o)
6903 {
6904     SvREADONLY_on(cSVOPo->op_sv);
6905     return o;
6906 }
6907
6908 OP *
6909 Perl_ck_trunc(pTHX_ OP *o)
6910 {
6911     if (o->op_flags & OPf_KIDS) {
6912         SVOP *kid = (SVOP*)cUNOPo->op_first;
6913
6914         if (kid->op_type == OP_NULL)
6915             kid = (SVOP*)kid->op_sibling;
6916         if (kid && kid->op_type == OP_CONST &&
6917             (kid->op_private & OPpCONST_BARE))
6918         {
6919             o->op_flags |= OPf_SPECIAL;
6920             kid->op_private &= ~OPpCONST_STRICT;
6921         }
6922     }
6923     return ck_fun(o);
6924 }
6925
6926 OP *
6927 Perl_ck_substr(pTHX_ OP *o)
6928 {
6929     o = ck_fun(o);
6930     if ((o->op_flags & OPf_KIDS) && o->op_private == 4) {
6931         OP *kid = cLISTOPo->op_first;
6932
6933         if (kid->op_type == OP_NULL)
6934             kid = kid->op_sibling;
6935         if (kid)
6936             kid->op_flags |= OPf_MOD;
6937
6938     }
6939     return o;
6940 }
6941
6942 /* A peephole optimizer.  We visit the ops in the order they're to execute. */
6943
6944 void
6945 Perl_peep(pTHX_ register OP *o)
6946 {
6947     register OP* oldop = 0;
6948     STRLEN n_a;
6949
6950     if (!o || o->op_seq)
6951         return;
6952     ENTER;
6953     SAVEOP();
6954     SAVEVPTR(PL_curcop);
6955     for (; o; o = o->op_next) {
6956         if (o->op_seq)
6957             break;
6958         if (!PL_op_seqmax)
6959             PL_op_seqmax++;
6960         PL_op = o;
6961         switch (o->op_type) {
6962         case OP_SETSTATE:
6963         case OP_NEXTSTATE:
6964         case OP_DBSTATE:
6965             PL_curcop = ((COP*)o);              /* for warnings */
6966             o->op_seq = PL_op_seqmax++;
6967             break;
6968
6969         case OP_CONST:
6970             if (cSVOPo->op_private & OPpCONST_STRICT)
6971                 no_bareword_allowed(o);
6972 #ifdef USE_ITHREADS
6973             /* Relocate sv to the pad for thread safety.
6974              * Despite being a "constant", the SV is written to,
6975              * for reference counts, sv_upgrade() etc. */
6976             if (cSVOP->op_sv) {
6977                 PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
6978                 if (SvPADTMP(cSVOPo->op_sv)) {
6979                     /* If op_sv is already a PADTMP then it is being used by
6980                      * some pad, so make a copy. */
6981                     sv_setsv(PL_curpad[ix],cSVOPo->op_sv);
6982                     SvREADONLY_on(PL_curpad[ix]);
6983                     SvREFCNT_dec(cSVOPo->op_sv);
6984                 }
6985                 else {
6986                     SvREFCNT_dec(PL_curpad[ix]);
6987                     SvPADTMP_on(cSVOPo->op_sv);
6988                     PL_curpad[ix] = cSVOPo->op_sv;
6989                     /* XXX I don't know how this isn't readonly already. */
6990                     SvREADONLY_on(PL_curpad[ix]);
6991                 }
6992                 cSVOPo->op_sv = Nullsv;
6993                 o->op_targ = ix;
6994             }
6995 #endif
6996             o->op_seq = PL_op_seqmax++;
6997             break;
6998
6999         case OP_CONCAT:
7000             if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
7001                 if (o->op_next->op_private & OPpTARGET_MY) {
7002                     if (o->op_flags & OPf_STACKED) /* chained concats */
7003                         goto ignore_optimization;
7004                     else {
7005                         /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
7006                         o->op_targ = o->op_next->op_targ;
7007                         o->op_next->op_targ = 0;
7008                         o->op_private |= OPpTARGET_MY;
7009                     }
7010                 }
7011                 op_null(o->op_next);
7012             }
7013           ignore_optimization:
7014             o->op_seq = PL_op_seqmax++;
7015             break;
7016         case OP_STUB:
7017             if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
7018                 o->op_seq = PL_op_seqmax++;
7019                 break; /* Scalar stub must produce undef.  List stub is noop */
7020             }
7021             goto nothin;
7022         case OP_NULL:
7023             if (o->op_targ == OP_NEXTSTATE
7024                 || o->op_targ == OP_DBSTATE
7025                 || o->op_targ == OP_SETSTATE)
7026             {
7027                 PL_curcop = ((COP*)o);
7028             }
7029             /* XXX: We avoid setting op_seq here to prevent later calls
7030                to peep() from mistakenly concluding that optimisation
7031                has already occurred. This doesn't fix the real problem,
7032                though (See 20010220.007). AMS 20010719 */
7033             if (oldop && o->op_next) {
7034                 oldop->op_next = o->op_next;
7035                 continue;
7036             }
7037             break;
7038         case OP_SCALAR:
7039         case OP_LINESEQ:
7040         case OP_SCOPE:
7041           nothin:
7042             if (oldop && o->op_next) {
7043                 oldop->op_next = o->op_next;
7044                 continue;
7045             }
7046             o->op_seq = PL_op_seqmax++;
7047             break;
7048
7049         case OP_GV:
7050             if (o->op_next->op_type == OP_RV2SV) {
7051                 if (!(o->op_next->op_private & OPpDEREF)) {
7052                     op_null(o->op_next);
7053                     o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
7054                                                                | OPpOUR_INTRO);
7055                     o->op_next = o->op_next->op_next;
7056                     o->op_type = OP_GVSV;
7057                     o->op_ppaddr = PL_ppaddr[OP_GVSV];
7058                 }
7059             }
7060             else if (o->op_next->op_type == OP_RV2AV) {
7061                 OP* pop = o->op_next->op_next;
7062                 IV i;
7063                 if (pop && pop->op_type == OP_CONST &&
7064                     (PL_op = pop->op_next) &&
7065                     pop->op_next->op_type == OP_AELEM &&
7066                     !(pop->op_next->op_private &
7067                       (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
7068                     (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
7069                                 <= 255 &&
7070                     i >= 0)
7071                 {
7072                     GV *gv;
7073                     op_null(o->op_next);
7074                     op_null(pop->op_next);
7075                     op_null(pop);
7076                     o->op_flags |= pop->op_next->op_flags & OPf_MOD;
7077                     o->op_next = pop->op_next->op_next;
7078                     o->op_type = OP_AELEMFAST;
7079                     o->op_ppaddr = PL_ppaddr[OP_AELEMFAST];
7080                     o->op_private = (U8)i;
7081                     gv = cGVOPo_gv;
7082                     GvAVn(gv);
7083                 }
7084             }
7085             else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) {
7086                 GV *gv = cGVOPo_gv;
7087                 if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) {
7088                     /* XXX could check prototype here instead of just carping */
7089                     SV *sv = sv_newmortal();
7090                     gv_efullname3(sv, gv, Nullch);
7091                     Perl_warner(aTHX_ WARN_PROTOTYPE,
7092                                 "%s() called too early to check prototype",
7093                                 SvPV_nolen(sv));
7094                 }
7095             }
7096             else if (o->op_next->op_type == OP_READLINE
7097                     && o->op_next->op_next->op_type == OP_CONCAT
7098                     && (o->op_next->op_next->op_flags & OPf_STACKED))
7099             {
7100                 /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
7101                 o->op_type   = OP_RCATLINE;
7102                 o->op_flags |= OPf_STACKED;
7103                 o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
7104                 op_null(o->op_next->op_next);
7105                 op_null(o->op_next);
7106             }
7107
7108             o->op_seq = PL_op_seqmax++;
7109             break;
7110
7111         case OP_MAPWHILE:
7112         case OP_GREPWHILE:
7113         case OP_AND:
7114         case OP_OR:
7115         case OP_ANDASSIGN:
7116         case OP_ORASSIGN:
7117         case OP_COND_EXPR:
7118         case OP_RANGE:
7119             o->op_seq = PL_op_seqmax++;
7120             while (cLOGOP->op_other->op_type == OP_NULL)
7121                 cLOGOP->op_other = cLOGOP->op_other->op_next;
7122             peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
7123             break;
7124
7125         case OP_ENTERLOOP:
7126         case OP_ENTERITER:
7127             o->op_seq = PL_op_seqmax++;
7128             while (cLOOP->op_redoop->op_type == OP_NULL)
7129                 cLOOP->op_redoop = cLOOP->op_redoop->op_next;
7130             peep(cLOOP->op_redoop);
7131             while (cLOOP->op_nextop->op_type == OP_NULL)
7132                 cLOOP->op_nextop = cLOOP->op_nextop->op_next;
7133             peep(cLOOP->op_nextop);
7134             while (cLOOP->op_lastop->op_type == OP_NULL)
7135                 cLOOP->op_lastop = cLOOP->op_lastop->op_next;
7136             peep(cLOOP->op_lastop);
7137             break;
7138
7139         case OP_QR:
7140         case OP_MATCH:
7141         case OP_SUBST:
7142             o->op_seq = PL_op_seqmax++;
7143             while (cPMOP->op_pmreplstart &&
7144                    cPMOP->op_pmreplstart->op_type == OP_NULL)
7145                 cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
7146             peep(cPMOP->op_pmreplstart);
7147             break;
7148
7149         case OP_EXEC:
7150             o->op_seq = PL_op_seqmax++;
7151             if (ckWARN(WARN_SYNTAX) && o->op_next
7152                 && o->op_next->op_type == OP_NEXTSTATE) {
7153                 if (o->op_next->op_sibling &&
7154                         o->op_next->op_sibling->op_type != OP_EXIT &&
7155                         o->op_next->op_sibling->op_type != OP_WARN &&
7156                         o->op_next->op_sibling->op_type != OP_DIE) {
7157                     line_t oldline = CopLINE(PL_curcop);
7158
7159                     CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
7160                     Perl_warner(aTHX_ WARN_EXEC,
7161                                 "Statement unlikely to be reached");
7162                     Perl_warner(aTHX_ WARN_EXEC,
7163                                 "\t(Maybe you meant system() when you said exec()?)\n");
7164                     CopLINE_set(PL_curcop, oldline);
7165                 }
7166             }
7167             break;
7168
7169         case OP_HELEM: {
7170             UNOP *rop;
7171             SV *lexname;
7172             GV **fields;
7173             SV **svp, **indsvp, *sv;
7174             I32 ind;
7175             char *key = NULL;
7176             STRLEN keylen;
7177
7178             o->op_seq = PL_op_seqmax++;
7179
7180             if (((BINOP*)o)->op_last->op_type != OP_CONST)
7181                 break;
7182
7183             /* Make the CONST have a shared SV */
7184             svp = cSVOPx_svp(((BINOP*)o)->op_last);
7185             if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
7186                 key = SvPV(sv, keylen);
7187                 lexname = newSVpvn_share(key,
7188                                          SvUTF8(sv) ? -(I32)keylen : keylen,
7189                                          0);
7190                 SvREFCNT_dec(sv);
7191                 *svp = lexname;
7192             }
7193
7194             if ((o->op_private & (OPpLVAL_INTRO)))
7195                 break;
7196
7197             rop = (UNOP*)((BINOP*)o)->op_first;
7198             if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7199                 break;
7200             lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7201             if (!(SvFLAGS(lexname) & SVpad_TYPED))
7202                 break;
7203             fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
7204             if (!fields || !GvHV(*fields))
7205                 break;
7206             key = SvPV(*svp, keylen);
7207             indsvp = hv_fetch(GvHV(*fields), key,
7208                               SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
7209             if (!indsvp) {
7210                 Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s",
7211                       key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
7212             }
7213             ind = SvIV(*indsvp);
7214             if (ind < 1)
7215                 Perl_croak(aTHX_ "Bad index while coercing array into hash");
7216             rop->op_type = OP_RV2AV;
7217             rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
7218             o->op_type = OP_AELEM;
7219             o->op_ppaddr = PL_ppaddr[OP_AELEM];
7220             sv = newSViv(ind);
7221             if (SvREADONLY(*svp))
7222                 SvREADONLY_on(sv);
7223             SvFLAGS(sv) |= (SvFLAGS(*svp)
7224                             & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
7225             SvREFCNT_dec(*svp);
7226             *svp = sv;
7227             break;
7228         }
7229
7230         case OP_HSLICE: {
7231             UNOP *rop;
7232             SV *lexname;
7233             GV **fields;
7234             SV **svp, **indsvp, *sv;
7235             I32 ind;
7236             char *key;
7237             STRLEN keylen;
7238             SVOP *first_key_op, *key_op;
7239
7240             o->op_seq = PL_op_seqmax++;
7241             if ((o->op_private & (OPpLVAL_INTRO))
7242                 /* I bet there's always a pushmark... */
7243                 || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
7244                 /* hmmm, no optimization if list contains only one key. */
7245                 break;
7246             rop = (UNOP*)((LISTOP*)o)->op_last;
7247             if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
7248                 break;
7249             lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
7250             if (!(SvFLAGS(lexname) & SVpad_TYPED))
7251                 break;
7252             fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
7253             if (!fields || !GvHV(*fields))
7254                 break;
7255             /* Again guessing that the pushmark can be jumped over.... */
7256             first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
7257                 ->op_first->op_sibling;
7258             /* Check that the key list contains only constants. */
7259             for (key_op = first_key_op; key_op;
7260                  key_op = (SVOP*)key_op->op_sibling)
7261                 if (key_op->op_type != OP_CONST)
7262                     break;
7263             if (key_op)
7264                 break;
7265             rop->op_type = OP_RV2AV;
7266             rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
7267             o->op_type = OP_ASLICE;
7268             o->op_ppaddr = PL_ppaddr[OP_ASLICE];
7269             for (key_op = first_key_op; key_op;
7270                  key_op = (SVOP*)key_op->op_sibling) {
7271                 svp = cSVOPx_svp(key_op);
7272                 key = SvPV(*svp, keylen);
7273                 indsvp = hv_fetch(GvHV(*fields), key,
7274                                   SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
7275                 if (!indsvp) {
7276                     Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
7277                                "in variable %s of type %s",
7278                           key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
7279                 }
7280                 ind = SvIV(*indsvp);
7281                 if (ind < 1)
7282                     Perl_croak(aTHX_ "Bad index while coercing array into hash");
7283                 sv = newSViv(ind);
7284                 if (SvREADONLY(*svp))
7285                     SvREADONLY_on(sv);
7286                 SvFLAGS(sv) |= (SvFLAGS(*svp)
7287                                 & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
7288                 SvREFCNT_dec(*svp);
7289                 *svp = sv;
7290             }
7291             break;
7292         }
7293
7294         default:
7295             o->op_seq = PL_op_seqmax++;
7296             break;
7297         }
7298         oldop = o;
7299     }
7300     LEAVE;
7301 }
7302
7303
7304
7305 char* Perl_custom_op_name(pTHX_ OP* o)
7306 {
7307     IV  index = PTR2IV(o->op_ppaddr);
7308     SV* keysv;
7309     HE* he;
7310
7311     if (!PL_custom_op_names) /* This probably shouldn't happen */
7312         return PL_op_name[OP_CUSTOM];
7313
7314     keysv = sv_2mortal(newSViv(index));
7315
7316     he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
7317     if (!he)
7318         return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
7319
7320     return SvPV_nolen(HeVAL(he));
7321 }
7322
7323 char* Perl_custom_op_desc(pTHX_ OP* o)
7324 {
7325     IV  index = PTR2IV(o->op_ppaddr);
7326     SV* keysv;
7327     HE* he;
7328
7329     if (!PL_custom_op_descs)
7330         return PL_op_desc[OP_CUSTOM];
7331
7332     keysv = sv_2mortal(newSViv(index));
7333
7334     he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
7335     if (!he)
7336         return PL_op_desc[OP_CUSTOM];
7337
7338     return SvPV_nolen(HeVAL(he));
7339 }
7340
7341
7342 #include "XSUB.h"
7343
7344 /* Efficient sub that returns a constant scalar value. */
7345 static void
7346 const_sv_xsub(pTHX_ CV* cv)
7347 {
7348     dXSARGS;
7349     if (items != 0) {
7350 #if 0
7351         Perl_croak(aTHX_ "usage: %s::%s()",
7352                    HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
7353 #endif
7354     }
7355     EXTEND(sp, 1);
7356     ST(0) = (SV*)XSANY.any_ptr;
7357     XSRETURN(1);
7358 }