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