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