op.c

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