op.c

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