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