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