op.c

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