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