op.c

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