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